tests/testthat/test-effects_snap.R

In DanChaltiel/crosstable: Crosstables for Descriptive Analyses

skip_on_cran()
skip_on_ci()

# skip("Too long")

# Automatic snapshot tests ------------------------------------------------
# They sometimes fail on other OS than Windows due to tiny RNG differences

can_be_by = function(x){
  length(unique(narm(x)))==2 && !all(is.na(x)) &&
    !is.numeric(x) && !is.Surv(x) && !is.date(x) && !inherits(x, "difftime")
}
# map_lgl(mtcars3, can_be_by)

for(.x in names(mtcars3)){
  set.seed(1234)
  if(can_be_by(mtcars3[[.x]])) {
    test_that(glue("Effect - .x='{.x}' - mean/OR (default)"), {
      skip_on_os(c("mac", "linux", "solaris"))
      local_reproducible_output(width = 1000)
      e_args = crosstable_effect_args()
      expect_snapshot({
        crosstable(mtcars3, -model, by=any_of(.x), effect=T, effect_args=e_args) %>%
          select(.id, any_of("effect")) %>% distinct() %>% as.data.frame()
      })
    })

    test_that(glue("Effect - .x='{.x}' - mean_boot/RR"), {
      skip_on_os(c("mac", "linux", "solaris"))
      local_reproducible_output(width = 1000)
      e_args = crosstable_effect_args()
      e_args$effect_summarize = diff_mean_boot
      e_args$effect_tabular = effect_relative_risk
      expect_snapshot({
        crosstable(mtcars3, -model, by=any_of(.x), effect=T, effect_args=e_args) %>%
          select(.id, any_of("effect")) %>% distinct() %>% as.data.frame()
      })
    })

    test_that(glue("Effect - .x='{.x}' - median/RD"), {
      skip_on_os(c("mac", "linux", "solaris"))
      local_reproducible_output(width = 1000)
      e_args = crosstable_effect_args()
      e_args$effect_summarize = diff_median_boot
      e_args$effect_tabular = effect_risk_difference
      expect_snapshot({
        crosstable(mtcars3, -model, by=any_of(.x), effect=T, effect_args=e_args) %>%
          select(.id, any_of("effect")) %>% distinct() %>% as.data.frame()
      })
    })
  }
}


# test_that("Effects never fail: mean/OR (default)", {
#   skip_on_os(c("mac", "linux", "solaris"))
#   rlang::local_options(width = 100)
#   e_args = crosstable_effect_args()
#
#   names(mtcars3) %>% set_names() %>% map(~{
#     set.seed(1234)
#     if(can_be_by(mtcars3[[.x]])) {
#       if(!is_testing()) print(glue("Effect part 1 - by={.x}"))
#       expect_snapshot({
#         print(glue("Effect part 1 - by={.x}"))
#         crosstable(mtcars3, -model, by=any_of(.x), effect=T, effect_args=e_args) %>%
#           select(.id, effect) %>% distinct() %>% as.data.frame()
#       })
#     }
#     return(0)
#   })
# })
# test_that("Effects never fail: mean_boot/RR", {
#   skip_on_os(c("mac", "linux", "solaris"))
#   rlang::local_options(width = 100)
#   e_args = crosstable_effect_args()
#   e_args$effect_summarize = diff_mean_boot
#   e_args$effect_tabular = effect_relative_risk
#
#   names(mtcars3) %>% set_names() %>% map(~{
#     set.seed(1234)
#     if(can_be_by(mtcars3[[.x]])) {
#       if(!is_testing()) print(glue("Effect part 2 - by={.x}"))
#       expect_snapshot({
#         print(glue("Effect part 2 - by={.x}"))
#         crosstable(mtcars3, -model, by=any_of(.x), effect=T, effect_args=e_args) %>%
#           select(.id, effect) %>% distinct() %>% as.data.frame()
#       })
#     }
#     return(0)
#   })
#
# })
#
# test_that("Effects never fail: median/RD", {
#   skip_on_os(c("mac", "linux", "solaris"))
#   rlang::local_options(width = 100)
#   e_args = crosstable_effect_args()
#   e_args$effect_summarize = diff_median_boot
#   e_args$effect_tabular = effect_risk_difference
#
#   map_lgl(mtcars3, can_be_by)
#
#   names(mtcars3) %>% set_names() %>% map(~{
#     if(!is_testing()) print(glue("Effect part 3 - by={.x}"))
#     if(can_be_by(mtcars3[[.x]])) {
#       expect_snapshot({
#         print(glue("Effect part 3 - by={.x}"))
#         set.seed(1234)
#         crosstable(mtcars3, -model, by=any_of(.x), effect=T, effect_args=e_args) %>%
#           select(.id, effect) %>% distinct() %>% as.data.frame()
#       })
#     }
#     return(0)
#   })
# })
#
#