Add levels argument to add_difference() (tbl_summary + tbl_svysummary) to compare two groups (#2151)

NEWS.md

@@ -1,5 +1,7 @@
 # gtsummary (development version)
 
+* Added a `levels` argument to `add_difference.tbl_summary()` and `add_difference.tbl_svysummary()` to select which two `by` groups to compare. This makes `add_difference()` usable when `by=` has more than two levels, and lets users flip the direction of the difference for two-level `by` variables. (#2151)
+
 * `modify_abbreviation()` and `remove_abbreviation()` now accept a character vector of abbreviations, allowing multiple abbreviations to be added or removed in a single call. `modify_abbreviation()` also gains `prefix`, `sep1`, and `sep2` arguments to customize the abbreviation source note's leading text (e.g. `c("Abbr.", "Abbrs.")`), the separator between the prefix and the abbreviations (e.g. `": "`), and the separator between abbreviations (e.g. `"; "`). Defaults are also configurable via the `modify_abbreviation-arg:prefix`, `modify_abbreviation-arg:sep1`, and `modify_abbreviation-arg:sep2` theme elements. (#2172)
 
 * The `missing` argument of `tbl_summary()` and `tbl_svysummary()` now accepts the formula-list-selector syntax (e.g. `missing = list(age ~ "always", grade ~ "no")`), allowing the missing row to be shown for some variables and not others. A bare string (e.g. `missing = "no"`) remains supported. (#2283)

R/add_difference.R

@@ -36,6 +36,13 @@ add_difference <- function(x, ...) {
 #'   to round and format differences and confidence limits.
 #' @param conf.level (`numeric`)\cr
 #'   a scalar in the interval `(0, 1)` indicating the confidence level. Default is 0.95
+#' @param levels (`vector`)\cr
+#'   a length-two vector of the `tbl_summary(by=)` levels to compare. The
+#'   difference is calculated as `levels[1]` minus `levels[2]`.
+#'   This argument is required when the `by` variable has more than two levels, and
+#'   allows the user to select which two groups to compare. When `by` has exactly
+#'   two levels, this argument is optional and can be used to flip the direction of
+#'   the difference (e.g. `levels[2]` minus `levels[1]`). Default is `NULL`.
 #' @inheritParams  add_p.tbl_summary
 #'
 #' @export
@@ -69,12 +76,24 @@ add_difference <- function(x, ...) {
 #'   ) |>
 #'   add_n() |>
 #'   add_difference(adj.vars = c(grade, stage))
+#'
+#' # Example 3 ----------------------------------
+#' # Select two groups to compare when `by=` has 3+ levels
+#' trial |>
+#'   tbl_summary(
+#'     by = grade,
+#'     statistic = all_continuous() ~ "{mean} ({sd})",
+#'     include = c(age, marker),
+#'     missing = "no"
+#'   ) |>
+#'   add_difference(levels = c("I", "III"))
 add_difference.tbl_summary <- function(x,
                                        test = NULL,
                                        group = NULL,
                                        adj.vars = NULL,
                                        test.args = NULL,
                                        conf.level = 0.95,
+                                       levels = NULL,
                                        include = everything(),
                                        pvalue_fun = label_style_pvalue(digits = 1),
                                        estimate_fun = list(
@@ -95,12 +114,18 @@ add_difference.tbl_summary <- function(x,
     )
   }
 
-  # checking that input x has a by var and it has two levels
-  if (is_empty(x$inputs$by) || dplyr::n_distinct(x$inputs$data[[x$inputs$by]], na.rm = TRUE) != 2L) {
-    "Cannot run {.fun add_difference} when {.code tbl_summary(by)} column does not have exactly two levels." |>
+  # checking that input x has a by variable
+  if (is_empty(x$inputs$by)) {
+    "Cannot run {.fun add_difference} when {.code tbl_summary(by)} is not specified." |>
       cli::cli_abort(call = get_cli_abort_call())
   }
 
+  # process/validate the `levels` argument. When supplied, the data stored in
+  # `x` is subset to the two selected levels for the difference calculation; the
+  # original full data is restored on the returned object below.
+  original_inputs_data <- x$inputs$data
+  x <- .process_difference_levels(x, levels = levels)
+
   # if `pvalue_fun` not modified, check if we need to use a theme p-value
   if (missing(pvalue_fun)) {
     pvalue_fun <-
@@ -206,6 +231,26 @@ add_difference.tbl_summary <- function(x,
       pvalue_fun = pvalue_fun, estimate_fun = estimate_fun, calling_fun = "add_difference"
     )
 
+  # when `levels` is supplied, note the compared pair and direction ------------
+  # use `replace = FALSE` so this footnote is appended to (not overwriting) the
+  # footnote describing the difference method/test.
+  if (!is_empty(levels)) {
+    footnote_levels <-
+      glue("{translate_string('Difference')}: {levels[1]} - {levels[2]}")
+    footnote_columns <-
+      intersect(c("estimate", "conf.low", "conf.high", "p.value"), names(x$table_body))
+    x <-
+      .modify_footnote_header(
+        x,
+        lst_footnotes = rep_named(footnote_columns, list(footnote_levels)),
+        replace = FALSE
+      )
+  }
+
+  # restore the original full data on the returned object ----------------------
+  # (the subset was only needed for the difference calculation)
+  x$inputs$data <- original_inputs_data
+
   # update call list
   x$call_list <- updated_call_list
 
@@ -216,3 +261,114 @@ add_difference.tbl_summary <- function(x,
 
   x
 }
+
+#' Process the `levels` argument of `add_difference()`
+#'
+#' Validates the `levels` argument and, when supplied, subsets the data stored in
+#' `x$inputs$data` to the two selected `by` levels and re-levels the `by` factor so
+#' the difference is computed as `levels[1]` minus `levels[2]`. The full
+#' `x$table_body` (all summary statistic columns) is left untouched, so the
+#' resulting table keeps every group while the difference is calculated on the
+#' selected pair.
+#'
+#' Handles both `tbl_summary()` (where `x$inputs$data` is a data frame) and
+#' `tbl_svysummary()` (where `x$inputs$data` is a `survey.design` whose data
+#' frame lives in `$variables`).
+#'
+#' @param x (`tbl_summary`/`tbl_svysummary`)\cr a gtsummary table
+#' @param levels (`vector`)\cr the user-supplied `levels` argument (may be `NULL`)
+#'
+#' @return the (possibly modified) gtsummary table `x`
+#' @keywords internal
+#' @noRd
+.process_difference_levels <- function(x, levels) {
+  by_var <- x$inputs$by
+  is_survey <- inherits(x$inputs$data, "survey.design")
+  by_col <-
+    if (is_survey) x$inputs$data$variables[[by_var]] else x$inputs$data[[by_var]]
+
+  # the distinct, non-missing levels observed in the `by` column (in level order)
+  if (is.factor(by_col)) {
+    by_levels <- levels(droplevels(by_col))
+  } else {
+    by_levels <- by_col[!is.na(by_col)] |> unique() |> sort()
+  }
+  n_by_levels <- length(by_levels)
+
+  # `levels` not supplied -----------------------------------------------------
+  if (is_empty(levels)) {
+    if (n_by_levels != 2L) {
+      cli::cli_abort(
+        c(
+          "Cannot run {.fun add_difference} when {.code tbl_summary(by)} column
+           does not have exactly two levels.",
+          i = "The {.code by} variable has {n_by_levels} levels
+               ({.val {by_levels}}).",
+          i = "Use the {.arg levels} argument to select the two groups to compare,
+               e.g. {.code levels = c({.val {by_levels[1]}}, {.val {by_levels[2]}})}."
+        ),
+        call = get_cli_abort_call()
+      )
+    }
+    # two-level default path: leave the data untouched for backward compatibility
+    return(x)
+  }
+
+  # `levels` supplied: validate -----------------------------------------------
+  if (length(levels) != 2L) {
+    cli::cli_abort(
+      c(
+        "The {.arg levels} argument must be a length-two vector.",
+        i = "It has length {length(levels)}."
+      ),
+      call = get_cli_abort_call()
+    )
+  }
+  if (anyNA(levels) || levels[1] == levels[2]) {
+    cli::cli_abort(
+      "The {.arg levels} argument must contain two distinct, non-missing values.",
+      call = get_cli_abort_call()
+    )
+  }
+  not_present <- setdiff(as.character(levels), as.character(by_levels))
+  if (!is_empty(not_present)) {
+    cli::cli_abort(
+      c(
+        "Each value in the {.arg levels} argument must be one of the
+         {.code tbl_summary(by)} levels.",
+        i = "{cli::qty(length(not_present))} Value{?s} {.val {not_present}}
+             {cli::qty(length(not_present))} {?is/are} not present.",
+        i = "Valid levels are {.val {by_levels}}."
+      ),
+      call = get_cli_abort_call()
+    )
+  }
+
+  # subset the data to the two selected levels and re-level the `by` factor so
+  # the difference is computed as `levels[1]` minus `levels[2]`
+  if (is_survey) {
+    # save original column labels (subsetting a survey design strips them)
+    original_lbls <- lapply(x$inputs$data$variables, \(col) attr(col, "label"))
+
+    data <- x$inputs$data
+    data <-
+      call2("subset", x = expr(data),
+            subset = expr(as.character(!!sym(by_var)) %in% !!as.character(levels))) |>
+      eval()
+    data$variables[[by_var]] <-
+      factor(as.character(data$variables[[by_var]]), levels = as.character(levels))
+
+    # restore column labels
+    for (v in names(original_lbls)) {
+      attr(data$variables[[v]], "label") <- original_lbls[[v]]
+    }
+  } else {
+    data <- x$inputs$data
+    data <- data[as.character(data[[by_var]]) %in% as.character(levels), , drop = FALSE]
+    data[[by_var]] <- factor(as.character(data[[by_var]]), levels = as.character(levels))
+  }
+
+  x$inputs$data <- data
+
+  x
+}

R/add_difference.tbl_svysummary.R

@@ -19,6 +19,13 @@
 #'   `list(c(all_continuous(), all_categorical(FALSE)) ~ label_style_sigfig(), all_categorical() ~ \(x) paste0(style_sigfig(x, scale = 100), "%"))`
 #' @param conf.level (`numeric`)\cr
 #'   a scalar in the interval `(0, 1)` indicating the confidence level. Default is 0.95
+#' @param levels (`vector`)\cr
+#'   a length-two vector of the `tbl_svysummary(by=)` levels to compare. The
+#'   difference is calculated as `levels[1]` minus `levels[2]`.
+#'   This argument is required when the `by` variable has more than two levels, and
+#'   allows the user to select which two groups to compare. When `by` has exactly
+#'   two levels, this argument is optional and can be used to flip the direction of
+#'   the difference (e.g. `levels[2]` minus `levels[1]`). Default is `NULL`.
 #' @inheritParams  add_p.tbl_summary
 #'
 #' @export
@@ -33,12 +40,19 @@
 #'     include = c(Class, Age)
 #'   ) |>
 #'   add_difference()
+#'
+#' # Example 2 ----------------------------------
+#' # Select two groups to compare when `by=` has 3+ levels
+#' survey::svydesign(~1, data = trial, weights = ~1) |>
+#'   tbl_svysummary(by = grade, include = c(age, marker), missing = "no") |>
+#'   add_difference(levels = c("I", "III"))
 add_difference.tbl_svysummary <- function(x,
                                           test = NULL,
                                           group = NULL,
                                           adj.vars = NULL,
                                           test.args = NULL,
                                           conf.level = 0.95,
+                                          levels = NULL,
                                           include = everything(),
                                           pvalue_fun = label_style_pvalue(digits = 1),
                                           estimate_fun = list(
@@ -59,12 +73,18 @@ add_difference.tbl_svysummary <- function(x,
     )
   }
 
-  # checking that input x has a by var and it has two levels
-  if (is_empty(x$inputs$by) || dplyr::n_distinct(as.data.frame(x$inputs$data)[[x$inputs$by]], na.rm = TRUE) != 2L) {
-    "Cannot run {.fun add_difference} when {.code tbl_summary(by)} column does not have exactly two levels." |>
+  # checking that input x has a by variable
+  if (is_empty(x$inputs$by)) {
+    "Cannot run {.fun add_difference} when {.code tbl_summary(by)} is not specified." |>
       cli::cli_abort(call = get_cli_abort_call())
   }
 
+  # process/validate the `levels` argument. When supplied, the survey design
+  # stored in `x` is subset to the two selected levels for the difference
+  # calculation; the original full design is restored on the returned object below.
+  original_inputs_data <- x$inputs$data
+  x <- .process_difference_levels(x, levels = levels)
+
   # if `pvalue_fun` not modified, check if we need to use a theme p-value
   if (missing(pvalue_fun)) {
     pvalue_fun <-
@@ -171,6 +191,26 @@ add_difference.tbl_svysummary <- function(x,
       pvalue_fun = pvalue_fun, estimate_fun = estimate_fun, calling_fun = "add_difference"
     )
 
+  # when `levels` is supplied, note the compared pair and direction ------------
+  # use `replace = FALSE` so this footnote is appended to (not overwriting) the
+  # footnote describing the difference method/test.
+  if (!is_empty(levels)) {
+    footnote_levels <-
+      glue("{translate_string('Difference')}: {levels[1]} - {levels[2]}")
+    footnote_columns <-
+      intersect(c("estimate", "conf.low", "conf.high", "p.value"), names(x$table_body))
+    x <-
+      .modify_footnote_header(
+        x,
+        lst_footnotes = rep_named(footnote_columns, list(footnote_levels)),
+        replace = FALSE
+      )
+  }
+
+  # restore the original full design on the returned object --------------------
+  # (the subset was only needed for the difference calculation)
+  x$inputs$data <- original_inputs_data
+
   # update call list
   x$call_list <- updated_call_list
 

tests/testthat/_snaps/add_difference.tbl_svysummary.md

@@ -53,7 +53,7 @@
       add_difference(tbl_svysummary(svy_trial, include = age))
     Condition
       Error in `add_difference()`:
-      ! Cannot run `add_difference()` when `tbl_summary(by)` column does not have exactly two levels.
+      ! Cannot run `add_difference()` when `tbl_summary(by)` is not specified.
 
 ---