tests/testthat/test-theme_gtsummary.R

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

skip_on_cran()

test_that("theme_gtsummary_compact() works", {
  expect_error(
    with_gtsummary_theme(
      theme_gtsummary_compact(),
      expr = trial |> tbl_summary(include = c(age, grade)) |> as_gt()
    ),
    NA
  )

  expect_error(
    with_gtsummary_theme(
      theme_gtsummary_compact(),
      expr = trial |> tbl_summary(include = c(age, grade)) |> as_hux_table()
    ),
    NA
  )

  expect_error(
    with_gtsummary_theme(
      theme_gtsummary_compact(),
      expr = trial |> tbl_summary(include = c(age, grade)) |> as_flex_table()
    ),
    NA
  )

  expect_error(
    with_gtsummary_theme(
      theme_gtsummary_compact(),
      expr = trial |> tbl_summary(include = c(age, grade)) |> as_kable_extra()
    ),
    NA
  )
})

test_that("theme_gtsummary_eda() works", {
  expect_snapshot(
    with_gtsummary_theme(
      theme_gtsummary_eda(),
      expr = trial |> tbl_summary(include = c(age, grade))
    ) |>
      as.data.frame()
  )
})

test_that("theme_gtsummary_mean_sd() works", {
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_mean_sd(),
      expr = trial |> tbl_summary(include = age)
    ) |>
      getElement("inputs") |>
      getElement("statistic") |>
      getElement("age"),
    "{mean} ({sd})",
    ignore_attr = TRUE
  )

  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_mean_sd(),
      expr = trial |> tbl_summary(by = trt, include = age) |> add_p()
    ) |>
      getElement("table_body") |>
      getElement("test_name") |>
      dplyr::last(),
    "t.test",
    ignore_attr = TRUE
  )
})

test_that("theme_gtsummary_continuous2() works", {
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_continuous2(),
      expr = trial |> tbl_summary(include = age)
    ) |>
      getElement("table_body") |>
      getElement("var_type") |>
      dplyr::last(),
    "continuous2"
  )
})

test_that("theme_gtsummary_language() works", {
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_language("es"),
      expr = trial |> tbl_summary(include = age)
    ) |>
      getElement("table_body") |>
      getElement("label") |>
      dplyr::last(),
    "Desconocido"
  )

  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_language("es", big.mark = " ", decimal.mark = ",", iqr.sep = " - "),
      expr = trial |> tbl_summary(include = marker)
    ) |>
      getElement("table_body") |>
      getElement("stat_0") |>
      head(n = 1L),
    "0,64 (0,22 - 1,41)"
  )
})

test_that("theme_gtsummary_journal('lancet') works", {
  # R 4.1 wasn't working with the UTF8 midpoint character, but is working on release (4.4 as of May 2024)
  skip_if(.Platform$OS.type == "windows" && startsWith(R.version$version.string, "R version 4.1"))

  # check that we get
  #  - IQR separated with emdash in table
  #  - pvalues are rounded to 2 places
  #  - CI seperator is " to "
  expect_snapshot(
    with_gtsummary_theme(
      theme_gtsummary_journal("lancet"),
      expr = trial |>
        tbl_summary(by = trt, include = marker, label = marker ~ "marker", missing = "no") |>
        add_difference() |>
        modify_column_hide(c("stat_2")) |>
        as.data.frame()
    )
  )
  # check the footnote updated to IQR from Q1 - Q3
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_journal("lancet"),
      expr = trial |>
        tbl_summary(by = trt, include = marker, label = marker ~ "marker", missing = "no") |>
        getElement("table_styling") |>
        getElement("footnote") |>
        dplyr::filter(.by = "column", dplyr::n() == dplyr::row_number(), column %in% c("stat_1", "stat_2")) |>
        dplyr::pull("footnote") |>
        unique()
    ),
    "Median (IQR)"
  )

  # check the prepend p-value function is used
  expect_true(
    with_gtsummary_theme(
      theme_gtsummary_journal("lancet"),
      lm(age ~ marker, trial) |>
        tbl_regression() |>
        inline_text(variable = marker)
    ) %>%
      {str_detect(., "p=") && endsWith(., "97)")}
  )
})

test_that("theme_gtsummary_journal('nejm') works", {
  # check that we get
  #  - IQR separated with emdash in table, and no percent symbol
  #  - pvalues are rounded to 2 places
  #  - CI separator is " to "
  expect_snapshot(
    with_gtsummary_theme(
      theme_gtsummary_journal("nejm"),
      expr = trial |>
        tbl_summary(by = trt, include = age, label = age ~ "Age", missing = "no") |>
        add_difference() |>
        modify_column_hide(c("stat_2")) |>
        as.data.frame()
    )
  )
  # check the footnote has IQR in it
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_journal("nejm"),
      expr = trial |>
        tbl_summary(by = trt, include = age, label = age ~ "Age", missing = "no") |>
        getElement("table_styling") |>
        getElement("footnote") |>
        getElement("footnote") |>
        dplyr::last()
    ),
    "Median (IQR)"
  )

  # checking preprended pvalue
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_journal("nejm"),
      expr = lm(hp ~ am, mtcars) |>
        tbl_regression() |>
        inline_text(variable = "am")
    ),
    "-33 (95% CI -83, 16; p=0.18)"
  )
})

test_that("theme_gtsummary_journal('jama') works", {
  # check that we get
  #  - IQR separated with emdash in table
  #  - pvalues are rounded to 2 places
  #  - CI separator is " to "
  #  - estimate and CI are in the same cell with appropriate header
  expect_snapshot(
    with_gtsummary_theme(
      theme_gtsummary_journal("jama"),
      expr = trial |>
        tbl_summary(by = trt, include = age, label = age ~ "Age", missing = "no") |>
        add_difference() |>
        modify_column_hide(c("stat_2")) |>
        as.data.frame()
    )
  )

  # check that we get
  #  - pvalues are rounded to 2 places
  #  - CI separator is " to "
  #  - estimate and CI are in the same cell with approriate header
  expect_snapshot(
    with_gtsummary_theme(
      theme_gtsummary_journal("jama"),
      expr = lm(hp ~ am, mtcars) |>
        tbl_regression() |>
        as.data.frame()
    )
  )

  # checking preprended pvalue
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_journal("jama"),
      expr = lm(hp ~ am, mtcars) |>
        tbl_regression() |>
        inline_text(variable = "am")
    ),
    "-33 (95% CI -83, 16; p=0.18)"
  )
})

test_that("theme_gtsummary_journal('qjecon') works", {
  # check that we get
  #  - percentages rounded to one decimal place
  expect_equal(
    with_gtsummary_theme(
      theme_gtsummary_journal("qjecon"),
      expr = trial |>
        tbl_summary(include = response, missing = "no") |>
        as.data.frame(col_labels = FALSE) |>
        dplyr::select(stat_0) |>
        dplyr::pull()
    ),
    "61 (31.6%)"
  )

  # check that we get
  #  - pvalues are not shown
  #  - CI is not shown
  #  - estimate and std.error in same cell with line breaker between them
  #  - sign stars added to beta
  expect_snapshot(
    with_gtsummary_theme(
      theme_gtsummary_journal("qjecon"),
      expr = lm(mpg ~ factor(cyl) + hp, mtcars) |>
        tbl_regression() |>
        as.data.frame()
    )
  )
})

test_that("check_gtsummary_theme()", {
  expect_snapshot(
    check_gtsummary_theme(mean)
  )

  expect_snapshot(
    check_gtsummary_theme(list(not_a_theme_element = letters))
  )

  expect_snapshot(
    check_gtsummary_theme(list("add_global_p-str:type" = letters))
  )
})

test_that("with_gtsummary_theme()", {
  expect_snapshot({
    theme_gtsummary_compact()
    with_gtsummary_theme(
      x = list("pkgwide-str:theme_name" = "My new theme"),
      expr = identical(1L, 1L),
      msg_ignored_elements = "The following theme elements are temporarilty overwritten: {.val {elements}}."
    )
    reset_gtsummary_theme()
  })
})