Add overall_row, ARD structure checks, and attribute labels to tbl_ard_hierarchical()

NEWS.md

@@ -1,5 +1,10 @@
 # gtsummary (development version)
 
+* Updates to `tbl_ard_hierarchical()`: (#2021)
+  - Added the `overall_row` argument to include an overall summary row at the top of the table, using results from `cards::ard_stack_hierarchical(over_variables = TRUE)` or `cards::ard_stack_hierarchical_count(over_variables = TRUE)`.
+  - The structure of the `cards` input is now checked against the `variables`, `by`, `include`, and `statistic` arguments, and an informative error is returned when they do not match. Previously, some mismatches silently returned an incomplete table.
+  - The default variable labels are now taken from the label attributes saved in the ARD (e.g. `cards::ard_stack_hierarchical(attributes = TRUE)`), and the `label` argument now accepts formula-list-selector syntax, as documented.
+
 * The `tbl_ard_summary(type)` argument may now assign a summary type that differs from the type implied by the ARD's `context` column, e.g. a continuous summary of re-shaped `cards::ard_tabulate()` results. The assigned type must be compatible with the structure of the ARD: continuous summaries require results without `variable_level` values, and categorical/dichotomous summaries require them. (#2482)
 
 * `tbl_split_by_rows()` now forwards the `row_numbers` and `variable_level` arguments when applied to an existing `tbl_split` object; previously only `variables` was passed and a misleading error was returned. The `variable_level` attribute is also now retained when a table is further split by rows. (#2479; @Melkiades)

R/tbl_ard_hierarchical.R

@@ -7,6 +7,18 @@
 #'
 #' @inheritParams tbl_hierarchical
 #' @inheritParams tbl_ard_summary
+#' @param label ([`formula-list-selector`][syntax])\cr
+#'   used to override default labels in hierarchical table, e.g. `list(AESOC = "System Organ Class")`.
+#'   The default for each variable is the label saved in the ARD (e.g. when created with
+#'   `cards::ard_stack_hierarchical(attributes = TRUE)`). If no label is present, the column name is used.
+#'
+#' @section Overall Row:
+#'
+#' An overall row can be added to the table as the first row by specifying `overall_row = TRUE`.
+#' The `cards` object must contain the overall results, which are calculated by
+#' `cards::ard_stack_hierarchical(over_variables = TRUE)` and `cards::ard_stack_hierarchical_count(over_variables = TRUE)`.
+#'
+#' A label for this overall row can be specified by passing an `'..ard_hierarchical_overall..'` element in `label`.
 #'
 #' @return a gtsummary table of class `"tbl_ard_hierarchical"`
 #' @export
@@ -26,14 +38,18 @@
 #'     variables = c(AESOC, AETERM),
 #'     by = TRTA,
 #'     denominator = cards::ADSL,
-#'     id = USUBJID
+#'     id = USUBJID,
+#'     over_variables = TRUE,
+#'     attributes = TRUE
 #'   )
 #'
 #' # Second, build table from the ARD
 #' tbl_ard_hierarchical(
 #'   cards = ard,
 #'   variables = c(AESOC, AETERM),
-#'   by = TRTA
+#'   by = TRTA,
+#'   overall_row = TRUE,
+#'   label = list(..ard_hierarchical_overall.. = "Any Adverse Event")
 #' )
 #'
 #' # Example 2: Event Counts  -------------------
@@ -56,6 +72,7 @@ tbl_ard_hierarchical <- function(cards,
                                  by = NULL,
                                  include = everything(),
                                  statistic = ~"{n} ({p}%)",
+                                 overall_row = FALSE,
                                  label = NULL) {
   set_cli_abort_call()
 
@@ -67,13 +84,29 @@ tbl_ard_hierarchical <- function(cards,
                 i = "Some operations cause a {.cls {'card'}} data frame to lose its class; use {.fun cards::as_card} to restore it as needed.")
   )
   check_not_missing(variables)
+  check_scalar_logical(overall_row)
 
   # define a data frame based on the context of `card` -------------------------
   data <- bootstrap_df_from_cards(cards)
 
   cards::process_selectors(data, variables = {{ variables }}, by = {{ by }})
   cards::process_selectors(data[variables], include = {{ include }})
-  cards::process_formula_selectors(data[intersect(variables, unique(cards$variable))], statistic = statistic)
+  check_length(by, length = 1L, allow_empty = TRUE)
+  if ("..ard_hierarchical_overall.." %in% variables) {
+    cli::cli_abort(
+      "The {.arg variables} argument cannot include a column named {.val ..ard_hierarchical_overall..}.",
+      call = get_cli_abort_call()
+    )
+  }
+  if (is_empty(include)) {
+    cli::cli_abort("Argument {.arg include} cannot be empty.", call = get_cli_abort_call())
+  }
+
+  # check structure of ARD input -----------------------------------------------
+  .check_ard_hierarchical_structure(cards, variables, by, include, overall_row)
+  summary_vars <- c(variables, if (overall_row) "..ard_hierarchical_overall..")
+
+  cards::process_formula_selectors(data[intersect(summary_vars, unique(cards$variable))], statistic = statistic)
 
   # check that all statistics passed are strings
   cards::check_list_elements(
@@ -84,25 +117,37 @@ tbl_ard_hierarchical <- function(cards,
 
   # fill in unspecified variables
   cards::fill_formula_selectors(
-    data[intersect(variables, unique(cards$variable))],
+    data[intersect(summary_vars, unique(cards$variable))],
     statistic = eval(formals(gtsummary::tbl_ard_hierarchical)[["statistic"]])
   )
+  .check_stats_available(cards, statistic)
 
   # add the gtsummary column names to ARD data frame ---------------------------
   cards <- .add_gts_column_to_cards_hierarchical(cards, variables, by)
 
   # save arguments
   tbl_ard_hierarchical_inputs <- as.list(environment())
   tbl_ard_hierarchical_inputs[["data"]] <- NULL
+  tbl_ard_hierarchical_inputs[["summary_vars"]] <- NULL
 
   # apply formatting fns -------------------------------------------------------
   cards <- cards |> cards::apply_fmt_fun()
 
   # fill in missing labels -----------------------------------------------------
-  default_label <- default_label <- names(data) |> as.list() |> stats::setNames(names(data))
-  label <- c(
-    label, default_label[setdiff(names(default_label), names(label))]
-  )[c(variables, if ("overall" %in% names(label)) "overall")]
+  # defaults are the label attributes saved in the ARD, otherwise the column name
+  df_attr_label <- cards |>
+    dplyr::filter(.data$context %in% "attributes", .data$stat_name %in% "label")
+  default_label <- names(data) |> as.list() |> stats::setNames(names(data))
+  default_label[intersect(df_attr_label$variable, names(data))] <-
+    df_attr_label$stat[match(intersect(df_attr_label$variable, names(data)), df_attr_label$variable)] |>
+    lapply(as.character)
+  if (overall_row) {
+    default_label[["..ard_hierarchical_overall.."]] <-
+      ifelse(inherits(cards, "ard_stack_hierarchical_count"), "Total number of events", "Number of patients with event")
+  }
+  cards::process_formula_selectors(data[summary_vars], label = label)
+  cards::fill_formula_selectors(data[summary_vars], label = default_label[summary_vars])
+  label <- label[summary_vars]
 
   # add hierarchical ARD args attribute and sort if not directly using a hierarchical ARD
   if (!inherits(cards, c("ard_stack_hierarchical", "ard_stack_hierarchical_count"))) {
@@ -123,7 +168,7 @@ tbl_ard_hierarchical <- function(cards,
     by = by,
     include = include,
     statistic = statistic,
-    overall_row = FALSE,
+    overall_row = overall_row,
     count = FALSE,
     is_ordered = is.ordered(data[[dplyr::last(variables)]]),
     label = label
@@ -136,3 +181,60 @@ tbl_ard_hierarchical <- function(cards,
     ) |>
     structure(class = c("tbl_ard_hierarchical", "gtsummary"))
 }
+
+.check_ard_hierarchical_structure <- function(cards, variables, by, include, overall_row) {
+  cards_no_attr <- cards |>
+    dplyr::filter(!.data$context %in% c("attributes", "total_n"))
+  group_name_cols <- cards_no_attr |>
+    select(cards::all_ard_groups("names")) |>
+    names()
+
+  # every summarized variable must be present in the ARD
+  missing_vars <- setdiff(union(include, dplyr::last(variables)), cards_no_attr$variable)
+  if (!is_empty(missing_vars)) {
+    cli::cli_abort(
+      c("Results for {.val {missing_vars}} were not found in the {.arg cards} object.",
+        i = "Use the {.arg include} argument to select the variables with summary statistics in the ARD."),
+      call = get_cli_abort_call()
+    )
+  }
+
+  # the overall row results must be present when requested
+  if (overall_row && !"..ard_hierarchical_overall.." %in% cards_no_attr$variable) {
+    cli::cli_abort(
+      c("Argument {.code overall_row = TRUE} requires overall results in the {.arg cards} object, but they were not found.",
+        i = "Use {.code over_variables = TRUE} in {.fun cards::ard_stack_hierarchical} or {.fun cards::ard_stack_hierarchical_count} to calculate them."),
+      call = get_cli_abort_call()
+    )
+  }
+
+  # each hierarchy variable must be nested within the `by` variable and the preceding hierarchy variables
+  expected_groups <-
+    lapply(seq_along(variables), \(i) c(by, variables[seq_len(i - 1L)])) |>
+    stats::setNames(variables)
+  if (overall_row) {
+    expected_groups[["..ard_hierarchical_overall.."]] <- by
+  }
+  walk(
+    names(expected_groups),
+    \(variable) {
+      df_groups <- cards_no_attr[cards_no_attr$variable %in% variable, group_name_cols, drop = FALSE] |>
+        unique()
+      for (i in seq_len(nrow(df_groups))) {
+        observed <- unlist(df_groups[i, ], use.names = FALSE)
+        observed <- observed[!is.na(observed)]
+        expected <- expected_groups[[variable]] %||% character(0L)
+        if (!identical(observed, expected)) {
+          cli::cli_abort(
+            c("The structure of the {.arg cards} object does not match the {.arg variables} and {.arg by} arguments.",
+              i = "Results for variable {.val {variable}} are expected to be grouped by {if (is_empty(expected)) 'no variables' else cli::format_inline('{.val {expected}}')},
+                   but are grouped by {if (is_empty(observed)) 'no variables' else cli::format_inline('{.val {observed}}')}."),
+            call = get_cli_abort_call()
+          )
+        }
+      }
+    }
+  )
+
+  invisible()
+}

tests/testthat/_snaps/tbl_ard_hierarchical.md

@@ -0,0 +1,60 @@
+# tbl_ard_hierarchical(overall_row) errors when overall results are missing
+
+    Code
+      tbl_ard_hierarchical(cards = ard, variables = c(AESOC, AETERM), by = TRTA,
+      overall_row = TRUE)
+    Condition
+      Error in `tbl_ard_hierarchical()`:
+      ! Argument `overall_row = TRUE` requires overall results in the `cards` object, but they were not found.
+      i Use `over_variables = TRUE` in `cards::ard_stack_hierarchical()` or `cards::ard_stack_hierarchical_count()` to calculate them.
+
+# tbl_ard_hierarchical() checks the structure of the ARD
+
+    Code
+      tbl_ard_hierarchical(cards = ard, variables = c(AESOC, AETERM))
+    Condition
+      Error in `tbl_ard_hierarchical()`:
+      ! The structure of the `cards` object does not match the `variables` and `by` arguments.
+      i Results for variable "AESOC" are expected to be grouped by no variables, but are grouped by "TRTA".
+
+---
+
+    Code
+      tbl_ard_hierarchical(cards = ard, variables = c(AETERM, AESOC), by = TRTA)
+    Condition
+      Error in `tbl_ard_hierarchical()`:
+      ! The structure of the `cards` object does not match the `variables` and `by` arguments.
+      i Results for variable "AETERM" are expected to be grouped by "TRTA", but are grouped by "TRTA" and "AESOC".
+
+---
+
+    Code
+      tbl_ard_hierarchical(cards = cards::ard_stack_hierarchical(data = ADAE_subset,
+        variables = c(AESOC, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID,
+        include = AETERM), variables = c(AESOC, AETERM), by = TRTA)
+    Condition
+      Error in `tbl_ard_hierarchical()`:
+      ! Results for "AESOC" were not found in the `cards` object.
+      i Use the `include` argument to select the variables with summary statistics in the ARD.
+
+---
+
+    Code
+      tbl_ard_hierarchical(cards = cards::ard_stack_hierarchical(data = ADAE_subset,
+        variables = c(AESOC, AETERM), by = TRTA, denominator = cards::ADSL, id = USUBJID,
+        over_variables = TRUE), variables = c(..ard_hierarchical_overall.., AETERM),
+      by = TRTA)
+    Condition
+      Error in `tbl_ard_hierarchical()`:
+      ! The `variables` argument cannot include a column named "..ard_hierarchical_overall..".
+
+---
+
+    Code
+      tbl_ard_hierarchical(cards = cards::ard_stack_hierarchical_count(data = ADAE_subset,
+        variables = c(AESOC, AETERM), by = TRTA), variables = c(AESOC, AETERM), by = TRTA)
+    Condition
+      Error in `tbl_ard_hierarchical()`:
+      ! Statistic "p" is not available for variable "AESOC".
+      i Select among "n".
+