Add digits argument to tbl_hierarchical() (#2035)

* Take out type stuff

* Add digits argument to tbl_hierarchical

* Update documentation

* Update example

* Add check for variable type

* Remove type check

* Fix tbl_ard_hierarchical

* Update modify.R

* Fix tests

* Update statistic and digits accepted formats, defaults

* Update digits and statistic handling in tbl_ard_hierarchical

* Update documentation

---------

Co-authored-by: Daniel Sjoberg <[email protected]>

R/brdg_hierarchical.R

@@ -32,8 +32,6 @@
 #'   character list of hierarchy variables to include summary statistics for.
 #' @param statistic (named `list`)\cr
 #'   named list of summary statistic names.
-#' @param type (named `list`)\cr
-#'   named list of summary types.
 #' @param count (scalar `logical`)\cr
 #'   whether `tbl_hierarchical_count()` (`TRUE`) or `tbl_hierarchical()` (`FALSE`) is being applied.
 #' @param is_ordered (scalar `logical`)\cr
@@ -52,7 +50,6 @@ brdg_hierarchical <- function(cards,
                               by,
                               include,
                               statistic,
-                              type,
                               overall_row,
                               count,
                               is_ordered,
@@ -152,7 +149,7 @@ brdg_hierarchical <- function(cards,
     modify_table_styling(
       columns = all_stat_cols(),
       footnote =
-        .construct_hierarchical_footnote(cards, variables, statistic, type)
+        .construct_hierarchical_footnote(cards, variables, statistic)
     )
 
   x <- x |>
@@ -370,7 +367,7 @@ pier_summary_hierarchical <- function(cards,
   df_result_levels
 }
 
-.construct_hierarchical_footnote <- function(card, include, statistic, type) {
+.construct_hierarchical_footnote <- function(card, include, statistic) {
   include |>
     lapply(
       function(variable) {
@@ -380,7 +377,7 @@ pier_summary_hierarchical <- function(cards,
           dplyr::distinct() %>%
           {stats::setNames(as.list(.$stat_label), .$stat_name)} |> # styler: off
           glue::glue_data(
-            gsub("\\{(p|p_miss|p_nonmiss|p_unweighted)\\}%", "{\\1}", x = statistic[[variable]])
+            gsub("\\{(p)\\}%", "{\\1}", x = statistic[[variable]])
           )
       }
     ) |>

R/modify.R

@@ -299,7 +299,7 @@ show_header_names <- function(x, include_example, quiet) {
 
   cat("\n")
   cli::cli_inform(c("* These values may be dynamically placed into headers (and other locations).",
-    "i" = "Review the {.help [{.fun modify_header}](gtsummary::modify)} help for examples."
+    "i" = "Review the {.help [{.fun modify_header}](gtsummary::modify_header)} help for examples."
   ))
 }
 

R/tbl_ard_hierarchical.R

@@ -49,13 +49,13 @@
 #'   cards = ard,
 #'   variables = c(AESOC, AETERM),
 #'   by = TRTA,
-#'   statistic = "{n}"
+#'   statistic = ~"{n}"
 #' )
 tbl_ard_hierarchical <- function(cards,
                                  variables,
                                  by = NULL,
                                  include = everything(),
-                                 statistic = "{n} ({p})",
+                                 statistic = ~"{n} ({p}%)",
                                  label = NULL) {
   set_cli_abort_call()
 
@@ -67,13 +67,26 @@ 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_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 }})
+  cards::process_formula_selectors(data[intersect(variables, unique(cards$variable))], statistic = statistic)
+
+  # check that all statistics passed are strings
+  cards::check_list_elements(
+    x = statistic,
+    predicate = \(x) is_string(x),
+    error_msg = "Values passed in the {.arg statistic} argument must be strings."
+  )
+
+  # fill in unspecified variables
+  cards::fill_formula_selectors(
+    data[intersect(variables, unique(cards$variable))],
+    statistic = eval(formals(gtsummary::tbl_ard_hierarchical)[["statistic"]])
+  )
 
   # add the gtsummary column names to ARD data frame ---------------------------
   cards <- .add_gts_column_to_cards_hierarchical(cards, variables, by)
@@ -82,6 +95,24 @@ tbl_ard_hierarchical <- function(cards,
   tbl_ard_hierarchical_inputs <- as.list(environment())
   tbl_ard_hierarchical_inputs[["data"]] <- NULL
 
+  # define digits defaults
+  digits <- list(c(
+    c("n", "N") |> rep_named(list(label_style_number())),
+    c("p") |>
+      rep_named(list(get_theme_element("tbl_summary-fn:percent_fun", default = label_style_percent(digits = 1))))
+  )) |> rep(length(variables)) |>
+    stats::setNames(variables)
+
+  # apply digits ---------------------------------------------------------------
+  names(digits)[names(digits) == by] <- "..ard_hierarchical_overall.."
+  for (v in names(digits)) {
+    for (stat in lapply(statistic, function(x) .extract_glue_elements(x) |> unlist())[[v]]) {
+      cards <- cards |>
+        cards::update_ard_fmt_fn(variables = all_of(v), stat_names = stat, fmt_fn = digits[[v]][[stat]])
+    }
+  }
+  cards <- cards |> cards::apply_fmt_fn()
+
   # fill in missing labels -----------------------------------------------------
   default_label <- default_label <- names(data) |> as.list() |> stats::setNames(names(data))
   label <- c(
@@ -93,8 +124,7 @@ tbl_ard_hierarchical <- function(cards,
     variables = variables,
     by = by,
     include = include,
-    statistic = rep_named(include, list(statistic)),
-    type = rep_named(variables, list("categorical")),
+    statistic = statistic,
     overall_row = FALSE,
     count = FALSE,
     is_ordered = is.ordered(data[[dplyr::last(variables)]]),