Adding tbl_ard_hierarchical() function.

NAMESPACE

@@ -194,6 +194,7 @@ export(style_pvalue)
 export(style_ratio)
 export(style_sigfig)
 export(tbl_ard_continuous)
+export(tbl_ard_hierarchical)
 export(tbl_ard_summary)
 export(tbl_ard_wide_summary)
 export(tbl_butcher)

NEWS.md

@@ -1,6 +1,6 @@
 # gtsummary (development version)
 
-* Added function `tbl_hierarchical()`, `tbl_hierarchical_count()`, `brdg_hierarchical()`, and `pier_summary_hierarchical()`. Consider these functions as a preview. We will be making changes without the full deprecation cycle in the coming releases. (#1872) 
+* Added function `tbl_hierarchical()`, `tbl_hierarchical_count()`, `tbl_ard_hierarchical()`, `brdg_hierarchical()`, and `pier_summary_hierarchical()`. Consider these functions as a preview. We will be making changes without the full deprecation cycle in the coming releases. (#1872) 
 
 * Adding the `style_*(prefix, suffix)` and  `label_style_*(prefix, suffix)` for adding a string before or after the formatted results. These arguments have not been added to the p-value formatting functions. (#1690)
 

R/tbl_ard_hierarchical.R

@@ -0,0 +1,115 @@
+#' ARD Hierarchical Table
+#'
+#' @description `r lifecycle::badge('experimental')`\cr
+#' *This is an preview of this function. There will be changes in the coming releases, and changes will not undergo a formal deprecation cycle.*
+#'
+#' Calculates *rates* of events (e.g. adverse events).
+#'
+#' @inheritParams tbl_hierarchical
+#' @inheritParams tbl_ard_summary
+#'
+#' @return a gtsummary table of class `"tbl_ard_hierarchical"`
+#' @export
+#'
+#' @examples
+#' ADAE_subset <- cards::ADAE |>
+#'   dplyr::filter(
+#'     AESOC %in% unique(cards::ADAE$AESOC)[1:5],
+#'     AETERM %in% unique(cards::ADAE$AETERM)[1:5]
+#'   )
+#'
+#' # Example 1: Event Rates  --------------------
+#' # First, build the ARD
+#' ard <-
+#'   cards::ard_stack_hierarchical(
+#'     data = ADAE_subset,
+#'     variables = c(AESOC, AETERM),
+#'     by = TRTA,
+#'     denominator = cards::ADSL |> mutate(TRTA = ARM),
+#'     id = USUBJID
+#'   )
+#'
+#' # Second, build table from the ARD
+#' tbl_ard_hierarchical(
+#'   cards = ard,
+#'   variables = c(AESOC, AETERM),
+#'   by = TRTA
+#' )
+#'
+#' # Example 2: Event Counts  -------------------
+#' ard <-
+#'   cards::ard_stack_hierarchical_count(
+#'     data = ADAE_subset,
+#'     variables = c(AESOC, AETERM),
+#'     by = TRTA,
+#'     denominator = cards::ADSL |> mutate(TRTA = ARM)
+#'   )
+#'
+#' tbl_ard_hierarchical(
+#'   cards = ard,
+#'   variables = c(AESOC, AETERM),
+#'   by = TRTA,
+#'   statistic = "{n}"
+#' )
+tbl_ard_hierarchical <- function(cards,
+                                 variables,
+                                 by = NULL,
+                                 include = everything(),
+                                 statistic = "{n} ({p})",
+                                 label = NULL) {
+  set_cli_abort_call()
+
+  # data argument checks -------------------------------------------------------
+  check_not_missing(cards)
+  check_class(
+    cards, "card",
+    message = c("The {.arg {arg_name}} argument must be class {.cls {'card'}}, not {.obj_type_friendly {x}}.",
+                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_string(statistic)
+
+  # 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 }})
+
+  # add the gtsummary column names to ARD data frame ---------------------------
+  cards <- .add_gts_column_to_cards_summary(cards, variables, by, hierarchical = TRUE)
+
+  # save arguments
+  tbl_ard_hierarchical_inputs <- as.list(environment())
+  tbl_ard_hierarchical_inputs[["data"]] <- NULL
+
+  # fill in missing labels -----------------------------------------------------
+  label = NULL
+  default_label <- sapply(
+    variables,
+    \(x) if (!is_empty(attr(data[[x]], "label"))) attr(data[[x]], "label") else x
+  ) |>
+    as.list()
+  label <- c(
+    label, default_label[setdiff(names(default_label), names(label))]
+  )[c(variables, if ("overall" %in% names(label)) "overall")]
+
+  brdg_hierarchical(
+    cards = cards,
+    variables = variables,
+    by = by,
+    include = include,
+    statistic = rep_named(include, list(statistic)),
+    type = rep_named(variables, list("categorical")),
+    overall_row = FALSE,
+    count = FALSE,
+    is_ordered = is.ordered(data[[dplyr::last(variables)]]),
+    label = label
+  ) |>
+    append(
+      list(
+        cards = list(cards) |> stats::setNames("tbl_ard_hierarchical"),
+        inputs = tbl_ard_hierarchical_inputs
+      )
+    ) |>
+    structure(class = c("tbl_ard_hierarchical", "gtsummary"))
+}

R/tbl_hierarchical.R

@@ -1,4 +1,4 @@
-#' Hierarchical table
+#' Hierarchical Table
 #'
 #' @description `r lifecycle::badge('experimental')`\cr
 #' *This is an preview of this function. There will be changes in the coming releases, and changes will not undergo a formal deprecation cycle.*

tests/testthat/test-tbl_ard_hierarchical.R

@@ -0,0 +1,70 @@
+skip_on_cran()
+
+ADAE_subset <- cards::ADAE |>
+  dplyr::filter(
+    AESOC %in% unique(cards::ADAE$AESOC)[1:5],
+    AETERM %in% unique(cards::ADAE$AETERM)[1:5]
+  )
+
+test_that("tbl_ard_hierarchical() event rates", {
+  ard <-
+    cards::ard_stack_hierarchical(
+      data = ADAE_subset,
+      variables = c(AESOC, AETERM, AESEV),
+      by = TRTA,
+      denominator = cards::ADSL |> mutate(TRTA = ARM),
+      id = USUBJID
+    )
+
+  expect_error(
+    tbl <- tbl_ard_hierarchical(
+      cards = ard,
+      variables = c(AESOC, AETERM, AESEV),
+      by = TRTA
+    ),
+    NA
+  )
+
+  expect_equal(
+    as.data.frame(tbl, col_labels = FALSE),
+    tbl_hierarchical(
+      data = ADAE_subset,
+      variables = c(AESOC, AETERM, AESEV),
+      by = TRTA,
+      denominator = cards::ADSL |> mutate(TRTA = ARM),
+      id = USUBJID
+    ) |>
+      as.data.frame(col_labels = FALSE)
+  )
+})
+
+test_that("tbl_ard_hierarchical() counts", {
+  ard <-
+    cards::ard_stack_hierarchical_count(
+      data = ADAE_subset,
+      variables = c(AESOC, AETERM),
+      by = TRTA,
+      denominator = cards::ADSL |> mutate(TRTA = ARM)
+    )
+
+  expect_error(
+    tbl <- tbl_ard_hierarchical(
+      cards = ard,
+      variables = c(AESOC, AETERM),
+      by = TRTA,
+      statistic = "{n}"
+    ),
+    NA
+  )
+
+  expect_equal(
+    as.data.frame(tbl, col_labels = FALSE),
+    tbl_hierarchical_count(
+      data = ADAE_subset,
+      variables = c(AESOC, AETERM),
+      by = TRTA,
+      denominator = cards::ADSL |> mutate(TRTA = ARM)
+    ) |>
+      as.data.frame(col_labels = FALSE)
+  )
+})