tests/testthat/test-modify_header.R

In ddsjoberg/gtsummary: Presentation-Ready Data Summary and Analytic Result Tables

skip_on_cran()
skip_if_not(is_pkg_installed(c("cardx", "broom.helpers")))

# first, testing deprecation
test_that("modify_header(update,quiet) are deprecated", {
  lifecycle::expect_deprecated(
    tbl_summary(trial, include = marker) |>
      modify_header(list(label = "Variable"))
  )

  # THIS ONE FAILS LOCALLY UNLESS I RUN ALL THE TESTS WITH THE 'Test' BUTTON
  lifecycle::expect_deprecated(
    tbl_summary(trial, include = marker) |>
      modify_header(update = list(label = "Variable"))
  )

  lifecycle::expect_deprecated(
    tbl_summary(trial, include = marker) |>
      modify_header(quiet = FALSE)
  )
})


test_that("modify_header(update) are deprecated and still work", {
  withr::local_options(lifecycle_verbosity = "quiet")
  expect_equal(
    tbl_summary(trial, include = marker) |>
      modify_header(list(label = "Variable")) |>
      getElement("table_styling") |>
      getElement("header"),
    tbl_summary(trial, include = marker) |>
      modify_header(label = "Variable") |>
      getElement("table_styling") |>
      getElement("header")
  )

  expect_equal(
    tbl_summary(trial, include = marker) |>
      modify_header(update = list(label = "Variable")) |>
      getElement("table_styling") |>
      getElement("header"),
    tbl_summary(trial, include = marker) |>
      modify_header(label = "Variable") |>
      getElement("table_styling") |>
      getElement("header")
  )
})

test_that("modify_header(update) deprecated argument still works", {
  withr::local_options(lifecycle_verbosity = "quiet")
  expect_equal(
    tbl_summary(trial, include = marker) |>
      modify_header(update = list(label = "Variable")) %>%
      {.[c("table_body", "table_styling")]},
    tbl_summary(trial, include = marker) |>
      modify_header(label = "Variable") %>%
      {.[c("table_body", "table_styling")]}
  )
})

test_that("modify_header(...) works", {
  tbl <- tbl_summary(trial, include = "marker")

  # typical use
  expect_equal(
    tbl |>
      modify_header(label = "Variable") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(column %in% "label") |>
      dplyr::pull("label"),
    "Variable"
  )

  expect_equal(
    tbl |>
      modify_header(label = "Variable", stat_0 = "Overall") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(column %in% c("label", "stat_0")) |>
      dplyr::pull("label"),
    c("Variable", "Overall")
  )
})

test_that("modify_header(...) dynamic headers work with `tbl_summary()`", {
  tbl <- tbl_summary(trial, include = "marker")

  # test dynamic dots
  expect_equal(
    tbl |>
      modify_header(!!!list(label = "Variable", stat_0 = "Overall")) |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(column %in% c("label", "stat_0")) |>
      dplyr::pull("label"),
    c("Variable", "Overall")
  )

  # testing dynamic entries in header
  expect_equal(
    tbl |>
      modify_header(stat_0 = "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(column %in% "stat_0") |>
      dplyr::pull("label"),
    "Overall | N = 200 | n = 200 | p = 100%"
  )

  expect_equal(
    tbl_summary(trial, by = trt, include = marker) |>
      modify_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(startsWith(column, "stat_")) |>
      dplyr::pull("label"),
    c("Drug A | N = 200 | n = 98 | p = 49%",
      "Drug B | N = 200 | n = 102 | p = 51%")
  )

  expect_equal(
    tbl_summary(trial, by = trt, include = marker) |>
      add_overall() |>
      modify_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(startsWith(column, "stat_")) |>
      dplyr::pull("label"),
    c("Overall | N = 200 | n = 200 | p = 100%",
      "Drug A | N = 200 | n = 98 | p = 49%",
      "Drug B | N = 200 | n = 102 | p = 51%")
  )

  expect_snapshot(
    error = TRUE,
    tbl_summary(trial, include = marker) |>
      modify_header(label = "This is not a valid {element}.")
  )
})

test_that("modify_header(text_interpret) works", {
  expect_equal(
    tbl_summary(trial, include = marker) |>
      modify_header(label = "Variable", text_interpret = "html") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(column %in% "label") |>
      dplyr::pull(interpret_label),
    "gt::html"
  )
})

test_that("modify_header() works with tbl_svysummary()", {
  skip_if_not(is_pkg_installed(c("survey", "cardx")))

  expect_equal(
    survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq) |>
      tbl_svysummary(by = Survived, percent = "row", include = c(Class, Age))|>
      add_overall() |>
      modify_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(startsWith(column, "stat_")) |>
      dplyr::pull("label"),
    c("Overall | N = 2201 | n = 2201 | p = 100%",
      "No | N = 2201 | n = 1490 | p = 68%",
      "Yes | N = 2201 | n = 711 | p = 32%")
  )

  expect_equal(
    survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq) |>
      tbl_svysummary(by = Survived, percent = "row", include = c(Class, Age))|>
      add_overall() |>
      modify_header(all_stat_cols() ~ "{level} | N = {N_unweighted} | n = {n_unweighted} | p = {style_percent(p_unweighted)}%") |>
      getElement("table_styling") |>
      getElement("header") |>
      dplyr::filter(startsWith(column, "stat_")) |>
      dplyr::pull("label"),
    c("Overall | N = 32 | n = 32 | p = 100%",
      "No | N = 32 | n = 16 | p = 50%",
      "Yes | N = 32 | n = 16 | p = 50%")
  )
})

test_that("modify_header() works with tbl_continuous()", {
  expect_equal(tbl_continuous(data = trial, variable = age, by = trt, include = grade)|>
                 add_overall() |>
                 modify_header(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |>
                 getElement("table_styling") |>
                 getElement("header") |>
                 dplyr::filter(startsWith(column, "stat_")) |>
                 dplyr::pull("label"),
               c("Overall | N = 200 | n = 200 | p = 100%",
                 "Drug A | N = 200 | n = 98 | p = 49%",
                 "Drug B | N = 200 | n = 102 | p = 51%")
  )
})

test_that("modify_header() works with tbl_cross()", {
  expect_equal(tbl_cross(data = trial, row = trt, col = response) |>
                 modify_header(all_stat_cols() ~ "N = {N} | n = {n} | p = {style_percent(p)}%") |>
                 getElement("table_styling") |>
                 getElement("header") |>
                 dplyr::filter(startsWith(column, "stat_")) |>
                 dplyr::pull("label"),
               c("N = 200 | n = 132 | p = 66%",
                 "N = 200 | n = 61 | p = 31%",
                 "N = 200 | n = 7 | p = 3.5%",
                 "N = 200 | n = 200 | p = 100%")
  )
})

test_that("modify_header() works with tbl_regression()", {
  skip_if_not(is_pkg_installed("broom.helpers"))

  expect_equal(glm(response ~ age + grade, trial, family = binomial()) |>
                 tbl_regression(exponentiate = TRUE) |>
                 modify_header(p.value = "P-Value", conf.low = "Confidence Interval") |>
                 getElement("table_styling") |>
                 getElement("header") |>
                 dplyr::filter(hide == "FALSE") |>
                 dplyr::pull("label"),
               c("**Characteristic**",
                 "**OR**",
                 "Confidence Interval",
                 "P-Value")
  )
})

test_that("modify_header() works with tbl_uvregression()", {
  expect_equal(tbl_uvregression(trial, method = glm, y = response, method.args = list(family = binomial),
                                exponentiate = TRUE, include = c("age", "grade")) |>
                 modify_header(p.value = "P-Value", conf.low = "Confidence Interval") |>
                 getElement("table_styling") |>
                 getElement("header") |>
                 dplyr::filter(hide == "FALSE") |>
                 dplyr::pull("label"),
               c("**Characteristic**",
                 "**N**",
                 "**OR**",
                 "Confidence Interval",
                 "P-Value")
  )
})