Merge branch 'main' into 2099-spanning-headers

ddsjoberg · Jan 6, 2025 · f618ab6 · f618ab6
2 parents adce4ea + 5495a79
commit f618ab6
Show file tree

Hide file tree

Showing 4 changed files with 141 additions and 27 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: gtsummary
 Title: Presentation-Ready Data Summary and Analytic Result Tables
-Version: 2.0.4.9005
+Version: 2.0.4.9006
 Authors@R: c(
     person("Daniel D.", "Sjoberg", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0003-0862-2018")),
@@ -60,7 +60,7 @@ Suggests:
     broom.helpers (>= 1.17.0),
     broom.mixed (>= 0.2.9),
     car (>= 3.0-11),
-    cardx (>= 0.2.2),
+    cardx (>= 0.2.2.9006),
     cmprsk,
     effectsize (>= 0.6.0),
     emmeans (>= 1.7.3),
@@ -86,6 +86,7 @@ Suggests:
     testthat (>= 3.2.0),
     withr (>= 2.5.0),
     workflows (>= 0.2.4)
+Remotes: insightsengineering/cardx
 VignetteBuilder: 
     knitr
 Config/Needs/check: hms

diff --git a/NEWS.md b/NEWS.md
@@ -14,6 +14,8 @@
 
 * Swapped out `dplyr::rows_update()` with a base R implementation in `tbl_merge()` that allows for tables with mixed types in `x$table_styling$header$modify_*` columns. For example, `tbl_summary()` has integer Ns and `tbl_svysummary()` has double Ns that can now be combined. (#1626)
 
+* The `add_ci.tbl_summary()` function now works with categorical variables that were summarized using `tbl_summary(percent = c('row', 'cell'))`. (#1929)
+
 # gtsummary 2.0.4
 
 ### New Features and Functions

diff --git a/R/add_ci.R b/R/add_ci.R
@@ -91,10 +91,6 @@ add_ci.tbl_summary <- function(x,
   # check inputs ---------------------------------------------------------------
   check_scalar_range(conf.level, range = c(0, 1))
   check_string(pattern, allow_empty = TRUE)
-  if (!"column" %in% x$inputs$percent) {
-    cli::cli_inform("The {.fun add_ci} function is meant to work with {.code tbl_summary(percent={cli::cli_format('column')})},
-                     but {.code tbl_summary(percent={cli::cli_format(x$inputs$percent)})} was used.")
-  }
 
   # process inputs -------------------------------------------------------------
   cards::process_selectors(
@@ -177,7 +173,8 @@ add_ci.tbl_summary <- function(x,
     .calculate_add_ci_cards_summary(data = x$inputs$data, include = include, by = x$inputs$by,
                                     method = method, style_fun = style_fun, conf.level = conf.level,
                                     overall= "add_overall" %in% names(x$call_list),
-                                    value = x$inputs$value)
+                                    value = x$inputs$value,
+                                    denominator = x$inputs$percent)
 
 
 
@@ -351,11 +348,13 @@ brdg_add_ci <- function(x, pattern, statistic, include, conf.level, updated_call
   x
 }
 
-.calculate_add_ci_cards_summary <- function(data, include, by, method, style_fun, conf.level, overall= FALSE, value) {
+.calculate_add_ci_cards_summary <- function(data, include, by, method, style_fun,
+                                            conf.level, overall= FALSE, value, denominator) {
   lst_cards <-
     lapply(
       include,
-      FUN = \(v) .calculate_one_ci_ard_summary(data = data, variable = v, by = by, method = method, conf.level = conf.level, value = value)
+      FUN = \(v) .calculate_one_ci_ard_summary(data = data, variable = v, by = by, method = method,
+                                               conf.level = conf.level, value = value, denominator = denominator)
     ) |>
     set_names(include)
 
@@ -364,7 +363,8 @@ brdg_add_ci <- function(x, pattern, statistic, include, conf.level, updated_call
     lst_cards <-
       lapply(
         include,
-        FUN = \(v) .calculate_one_ci_ard_summary(data = data, variable = v, by = NULL, method = method, conf.level = conf.level, value = value)
+        FUN = \(v) .calculate_one_ci_ard_summary(data = data, variable = v, by = NULL, method = method,
+                                                 conf.level = conf.level, value = value, denominator = denominator)
       ) |>
       set_names(include) |>
       append(lst_cards)
@@ -386,23 +386,23 @@ brdg_add_ci <- function(x, pattern, statistic, include, conf.level, updated_call
     cards::tidy_ard_column_order()
 }
 
-.calculate_one_ci_ard_summary <- function(data, variable, by, method, conf.level, value) {
+.calculate_one_ci_ard_summary <- function(data, variable, by, method, conf.level, value, denominator) {
   switch(
     method[[variable]],
     # continuous variables
     "t.test" = cardx::ard_stats_t_test_onesample(data, variables = all_of(variable), by = any_of(by), conf.level = conf.level),
     "wilcox.test" = cardx::ard_stats_wilcox_test_onesample(data, variables = all_of(variable), by = any_of(by), conf.level = conf.level, conf.int = TRUE),
 
     # categorical variables
-    "wald" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "waldcc", conf.level = conf.level, value = value),
-    "wald.no.correct" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wald", conf.level = conf.level, value = value),
-    "exact" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "clopper-pearson", conf.level = conf.level, value = value),
-    "wilson" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wilsoncc", conf.level = conf.level, value = value),
-    "wilson.no.correct" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wilson", conf.level = conf.level, value = value),
-    "agresti.coull" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "agresti-coull", conf.level = conf.level, value = value),
-    "jeffreys" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "jeffreys", conf.level = conf.level, value = value),
+    "wald" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "waldcc", conf.level = conf.level, value = value, denominator = denominator),
+    "wald.no.correct" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wald", conf.level = conf.level, value = value, denominator = denominator),
+    "exact" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "clopper-pearson", conf.level = conf.level, value = value, denominator = denominator),
+    "wilson" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wilsoncc", conf.level = conf.level, value = value, denominator = denominator),
+    "wilson.no.correct" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wilson", conf.level = conf.level, value = value, denominator = denominator),
+    "agresti.coull" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "agresti-coull", conf.level = conf.level, value = value, denominator = denominator),
+    "jeffreys" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "jeffreys", conf.level = conf.level, value = value, denominator = denominator),
 
     # Documentation for 'asymptotic' was removed in v2.0.0
-    "asymptotic" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wald", conf.level = conf.level, value = value)
+    "asymptotic" = cardx::ard_categorical_ci(data, variables = all_of(variable), by = any_of(by), method = "wald", conf.level = conf.level, value = value, denominator = denominator)
   )
 }
diff --git a/tests/testthat/test-add_ci.tbl_summary.R b/tests/testthat/test-add_ci.tbl_summary.R
@@ -801,15 +801,126 @@ test_that("add_ci() correctly handles dichotomous variables", {
   )
 })
 
-test_that("add_ci() messaging for tbl_summary(percent)", {
-  expect_message(
+test_that("add_ci() correctly handles tbl_summary(percent='row')", {
+  expect_silent(
+    df <-
+      trial |>
+      tbl_summary(include = c(response, grade), percent='row', statistic = ~"{n} / {N} ({p}%)") |>
+      add_ci(
+        statistic = ~"{conf.low} {conf.high}",
+        style_fun = ~label_style_number(scale = 100, digits = 1)
+      ) |>
+      as_tibble(col_labels = FALSE)
+  )
+
+  # check the CIs are correct for response
+  expect_equal(
+    df[1, "ci_stat_0"] |>
+      dplyr::pull("ci_stat_0"),
+    cardx::proportion_ci_wilson(
+      x = rep_len(TRUE, table(trial$response) |> as.data.frame() |> dplyr::filter(Var1 == 1) |> dplyr::pull(Freq)),
+      correct = TRUE
+    )[c("conf.low", "conf.high")] |>
+      map_chr(label_style_number(scale = 100, digits = 1)) |>
+      unlist() |>
+      paste(collapse = " ")
+  )
+
+  # check the CIs are correct for grade II
+  expect_equal(
+    df |>
+      dplyr::filter(label == "II") |>
+      dplyr::pull("ci_stat_0"),
+    cardx::proportion_ci_wilson(
+      x = rep_len(TRUE, table(trial$grade) |> as.data.frame() |> dplyr::filter(Var1 == "II") |> dplyr::pull(Freq)),
+      correct = TRUE
+    )[c("conf.low", "conf.high")] |>
+      map_chr(label_style_number(scale = 100, digits = 1)) |>
+      unlist() |>
+      paste(collapse = " ")
+  )
+
+  # now with a by variable
+  expect_equal(
     trial |>
-      tbl_summary(
-        missing = "no",
-        statistic = all_continuous() ~ "{mean} ({sd})",
-        include = c(marker, response, trt), percent = "row"
+      tbl_summary(by = trt, include = response, percent='row', statistic = ~"{n} / {N} ({p}%)", missing = "no") |>
+      add_ci(
+        statistic = ~"{conf.low} {conf.high}",
+        style_fun = ~label_style_number(scale = 100, digits = 1)
+      ) |>
+      as_tibble(col_labels = FALSE) |>
+      dplyr::pull("ci_stat_1"),
+    cardx::proportion_ci_wilson(
+      x = (trial$trt == "Drug A")[trial$response == 1],
+      correct = TRUE
+    )[c("conf.low", "conf.high")] |>
+      map_chr(label_style_number(scale = 100, digits = 1)) |>
+      unlist() |>
+      paste(collapse = " ")
+  )
+})
+
+
+test_that("add_ci() correctly handles tbl_summary(percent='cell')", {
+  expect_silent(
+    df <-
+      trial |>
+      tbl_summary(include = c(response, grade), percent='cell', statistic = ~"{n} / {N} ({p}%)") |>
+      add_ci(
+        statistic = ~"{conf.low} {conf.high}",
+        style_fun = ~label_style_number(scale = 100, digits = 1)
       ) |>
-      add_ci(),
-    "function is meant to work with"
+      as_tibble(col_labels = FALSE)
+  )
+
+  # check the CIs are correct for response
+  expect_equal(
+    df[1, "ci_stat_0"] |>
+      dplyr::pull("ci_stat_0"),
+    cardx::proportion_ci_wilson(
+      x = trial$response == 1,
+      correct = TRUE
+    )[c("conf.low", "conf.high")] |>
+      map_chr(label_style_number(scale = 100, digits = 1)) |>
+      unlist() |>
+      paste(collapse = " ")
+  )
+
+  # check the CIs are correct for grade II
+  expect_equal(
+    df |>
+      dplyr::filter(label == "II") |>
+      dplyr::pull("ci_stat_0"),
+    cardx::proportion_ci_wilson(
+      x = trial$grade == "II",
+      correct = TRUE
+    )[c("conf.low", "conf.high")] |>
+      map_chr(label_style_number(scale = 100, digits = 1)) |>
+      unlist() |>
+      paste(collapse = " ")
+  )
+
+  # now with a by variable
+  expect_equal(
+    trial |>
+      tbl_summary(by = trt, include = response, percent='cell', statistic = ~"{n} / {N} ({p}%)", missing = "no") |>
+      add_ci(
+        statistic = ~"{conf.low} {conf.high}",
+        style_fun = ~label_style_number(scale = 100, digits = 1)
+      ) |>
+      as_tibble(col_labels = FALSE) |>
+      dplyr::pull("ci_stat_1"),
+    cardx::proportion_ci_wilson(
+      x =
+        with(
+          tidyr::drop_na(trial, c(trt, response)),
+          trt == "Drug A" & response == 1
+        ),
+      correct = TRUE
+    )[c("conf.low", "conf.high")] |>
+      map_chr(label_style_number(scale = 100, digits = 1)) |>
+      unlist() |>
+      paste(collapse = " ")
   )
 })
+