Separate internal hierarchy processing from summary functions (#2034)

* Separate internal hierarchy processing from summary functions * Update .add_table_styling_stats * Fix syntax --------- Co-authored-by: Daniel Sjoberg <[email protected]>
ddsjoberg · Oct 9, 2024 · b183b75 · b183b75
1 parent b9c3ebb
commit b183b75
Show file tree

Hide file tree

Showing 5 changed files with 31 additions and 17 deletions.
diff --git a/R/brdg_hierarchical.R b/R/brdg_hierarchical.R
@@ -136,7 +136,8 @@ brdg_hierarchical <- function(cards,
   x <- .create_gtsummary_object(table_body)
 
   # add info to x$table_styling$header for dynamic headers ---------------------
-  x <- .add_table_styling_stats(x, cards = cards, by = by, hierarchical = TRUE)
+  noby_groups <- cards |> select(cards::all_ard_groups()) |> names() |> setdiff(by_groups)
+  x <- .add_table_styling_stats(x, cards = cards |> select(-all_of(noby_groups)), by = by)
 
   # adding styling -------------------------------------------------------------
   x <- x |>

diff --git a/R/brdg_summary.R b/R/brdg_summary.R
@@ -540,7 +540,7 @@ pier_summary_missing_row <- function(cards,
     )
 }
 
-.add_table_styling_stats <- function(x, cards, by, hierarchical = FALSE) {
+.add_table_styling_stats <- function(x, cards, by) {
   if (is_empty(by)) {
     x$table_styling$header$modify_stat_level <- translate_string("Overall")
 
@@ -574,7 +574,6 @@ pier_summary_missing_row <- function(cards,
         .data$variable %in% .env$by,
         .data$stat_name %in% c("N", "n", "p", "N_unweighted", "n_unweighted", "p_unweighted")
       )
-    by_gps <- paste0("group", seq_along(by), c("", "_level"))
 
     # if no tabulation of the 'by' variable provided, just return the 'by' levels
     if (nrow(df_by_stats) == 0L) {
@@ -593,7 +592,7 @@ pier_summary_missing_row <- function(cards,
         dplyr::select(cards::all_ard_variables(), "stat_name", "stat") |>
         dplyr::left_join(
           cards |>
-            dplyr::select(if (hierarchical) by_gps else cards::all_ard_groups(), "gts_column") |>
+            dplyr::select(cards::all_ard_groups(), "gts_column") |>
             dplyr::filter(!is.na(.data$gts_column)) |>
             dplyr::distinct() |>
             dplyr::rename(variable = "group1", variable_level = "group1_level"),

diff --git a/R/tbl_ard_hierarchical.R b/R/tbl_ard_hierarchical.R
@@ -76,7 +76,7 @@ tbl_ard_hierarchical <- function(cards,
   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)
+  cards <- .add_gts_column_to_cards_hierarchical(cards, variables, by)
 
   # save arguments
   tbl_ard_hierarchical_inputs <- as.list(environment())

diff --git a/R/tbl_hierarchical.R b/R/tbl_hierarchical.R
@@ -296,7 +296,7 @@ internal_tbl_hierarchical <- function(data,
   cards$stat_label <- translate_vector(cards$stat_label)
 
   # add the gtsummary column names to ARD data frame ---------------------------
-  cards <- .add_gts_column_to_cards_summary(cards, variables, by, hierarchical = TRUE)
+  cards <- .add_gts_column_to_cards_hierarchical(cards, variables, by)
 
   # fill in missing labels -----------------------------------------------------
   default_label <- sapply(
@@ -410,3 +410,27 @@ internal_tbl_hierarchical <- function(data,
     )
   }
 }
+
+.add_gts_column_to_cards_hierarchical <- function(cards, variables, by) {
+  # adding the name of the column the stats will populate
+  if (is_empty(by)) {
+    cards$gts_column <-
+      ifelse(
+        !cards$context %in% "attributes" & !cards$variable %in% "..ard_total_n..",
+        "stat_0",
+        NA_character_
+      )
+  } else {
+    cards <- cards |>
+      dplyr::group_by(.data$group1_level) |>
+      dplyr::mutate(gts_column = paste0("stat_", dplyr::cur_group_id()))
+
+    # process overall row
+    cards[cards$variable %in% by, ] <- cards[cards$variable %in% by, ] |>
+      dplyr::group_by(.data$variable_level) |>
+      dplyr::mutate(gts_column = paste0("stat_", dplyr::cur_group_id())) |>
+      dplyr::ungroup()
+  }
+
+  cards
+}
diff --git a/R/tbl_summary.R b/R/tbl_summary.R
@@ -426,7 +426,7 @@ tbl_summary <- function(data,
   x
 }
 
-.add_gts_column_to_cards_summary <- function(cards, variables, by, hierarchical = FALSE) {
+.add_gts_column_to_cards_summary <- function(cards, variables, by) {
   if ("gts_column" %in% names(cards)) {
     cli::cli_inform("The {.val gts_column} column is alread present. Defining the column has been skipped.")
     return(cards)
@@ -440,16 +440,6 @@ tbl_summary <- function(data,
         "stat_0",
         NA_character_
       )
-  } else if (hierarchical) { # disregard hierarchies, only check by variable
-    cards <- cards |>
-      dplyr::group_by(.data$group1_level) |>
-      dplyr::mutate(gts_column = paste0("stat_", dplyr::cur_group_id()))
-
-    # process overall row
-    cards[cards$variable %in% by, ] <- cards[cards$variable %in% by, ] |>
-      dplyr::group_by(.data$variable_level) |>
-      dplyr::mutate(gts_column = paste0("stat_", dplyr::cur_group_id())) |>
-      dplyr::ungroup()
   } else {
     # styler: off
     cards <-