Add hierarchy group levels to table_body in tbl_hierarchical()

R/brdg_hierarchical.R

@@ -125,7 +125,29 @@ brdg_hierarchical <- function(cards,
     table_body <- dplyr::bind_rows(over_row, table_body)
   }
 
-  table_body <- table_body |> select(-cards::all_ard_groups())
+  # add hierarchy levels to table_body for sorting & filtering -----------------
+  table_body <- table_body |>
+    dplyr::relocate(cards::all_ard_groups(), .after = "row_type") |>
+    mutate(across(cards::all_ard_groups(), .fns = ~str_replace(., "^ $", NA)))
+  if (n_by > 0 && length(variables) > 1) {
+    which_gps <- which(names(table_body) %in% (table_body |> select(cards::all_ard_groups()) |> names()))
+    if (n_by > 0) {
+      names(table_body)[which_gps] <- sapply(
+        names(table_body)[which_gps],
+        function(x) {
+          n <- as.numeric(gsub(".*([0-9]+).*", "\\1", x)) - n_by
+          gsub("[0-9]+", n, x)
+        }
+      )
+    }
+    for (i in which_gps[c(TRUE, FALSE)]) {
+      lbl_row <- which(is.na(table_body[i]) & !is.na(table_body[i + 1]))
+      table_body[lbl_row, i] <- table_body$variable[lbl_row]
+    }
+  }
+  if (overall_row && "group1" %in% names(table_body)) {
+    table_body$group1[table_body$variable == "..ard_hierarchical_overall.."] <- "..ard_hierarchical_overall.."
+  }
 
   # construct default table_styling --------------------------------------------
   x <- .create_gtsummary_object(table_body)

tests/testthat/_snaps/tbl_hierarchical.md

@@ -975,3 +975,23 @@
       188    <NA>
       189       1
 
+# tbl_hierarchical_count table_body enables sorting
+
+    Code
+      res$table_body
+    Output
+      # A tibble: 21 x 11
+         row_type group1                       group1_level group2 group2_level                                         var_label variable                     label                                                stat_1   stat_2   stat_3  
+         <chr>    <chr>                        <chr>        <chr>  <chr>                                                <chr>     <chr>                        <chr>                                                <chr>    <chr>    <chr>   
+       1 level    ..ard_hierarchical_overall.. <NA>         <NA>   <NA>                                                 <NA>      ..ard_hierarchical_overall.. Number of patients with event                        26 (30%) 42 (50%) 40 (48%)
+       2 level    SEX                          F            <NA>   <NA>                                                 <NA>      SEX                          F                                                    13 (25%) 18 (45%) 23 (46%)
+       3 level    SEX                          F            AESOC  CARDIAC DISORDERS                                    <NA>      AESOC                        CARDIAC DISORDERS                                    0 (0%)   1 (2.5%) 0 (0%)  
+       4 level    SEX                          F            AESOC  CARDIAC DISORDERS                                    <NA>      AETERM                       ATRIOVENTRICULAR BLOCK SECOND DEGREE                 0 (0%)   1 (2.5%) 0 (0%)  
+       5 level    SEX                          F            AESOC  GASTROINTESTINAL DISORDERS                           <NA>      AESOC                        GASTROINTESTINAL DISORDERS                           3 (5.7%) 0 (0%)   3 (6.0%)
+       6 level    SEX                          F            AESOC  GASTROINTESTINAL DISORDERS                           <NA>      AETERM                       DIARRHOEA                                            3 (5.7%) 0 (0%)   3 (6.0%)
+       7 level    SEX                          F            AESOC  GENERAL DISORDERS AND ADMINISTRATION SITE CONDITIONS <NA>      AESOC                        GENERAL DISORDERS AND ADMINISTRATION SITE CONDITIONS 5 (9.4%) 11 (28%) 13 (26%)
+       8 level    SEX                          F            AESOC  GENERAL DISORDERS AND ADMINISTRATION SITE CONDITIONS <NA>      AETERM                       APPLICATION SITE ERYTHEMA                            2 (3.8%) 5 (13%)  5 (10%) 
+       9 level    SEX                          F            AESOC  GENERAL DISORDERS AND ADMINISTRATION SITE CONDITIONS <NA>      AETERM                       APPLICATION SITE PRURITUS                            4 (7.5%) 10 (25%) 12 (24%)
+      10 level    SEX                          F            AESOC  SKIN AND SUBCUTANEOUS TISSUE DISORDERS               <NA>      AESOC                        SKIN AND SUBCUTANEOUS TISSUE DISORDERS               6 (11%)  7 (18%)  9 (18%) 
+      # i 11 more rows
+

tests/testthat/test-tbl_hierarchical.R

@@ -125,7 +125,7 @@ test_that("tbl_hierarchical(label) works properly", {
     label = list(stage = "My Stage", grade = "My Grade")
   )
   expect_snapshot(res |> as.data.frame())
-  expect_snapshot_value(res$table_styling$header$label[4])
+  expect_snapshot_value(res$table_styling$header$label[6])
 
   # errors thrown when bad label argument passed
   expect_snapshot(
@@ -273,7 +273,7 @@ test_that("tbl_hierarchical_count(label) works properly", {
     data = trial, variables = c(stage, grade), label = list(stage = "My Stage", grade = "My Grade")
   )
   expect_snapshot(res |> as.data.frame())
-  expect_snapshot_value(res$table_styling$header$label[4])
+  expect_snapshot_value(res$table_styling$header$label[6])
 
   # errors thrown when bad label argument passed
   expect_snapshot(
@@ -321,3 +321,27 @@ test_that("tbl_hierarchical_count with 10+ hierarchy variables", {
   )
   expect_snapshot(res |> as.data.frame())
 })
+
+# tbl_hierarchical_count table_body enables sorting ----------------------------------------
+test_that("tbl_hierarchical_count table_body enables sorting", {
+  withr::local_options(list(width = 250))
+
+  ADAE_subset <- cards::ADAE |>
+    dplyr::filter(
+      AESOC %in% unique(cards::ADAE$AESOC)[1:5],
+      AETERM %in% unique(cards::ADAE$AETERM)[1:5]
+    )
+
+  res <- expect_silent(
+    tbl_hierarchical(
+      data = ADAE_subset,
+      variables = c(SEX, AESOC, AETERM),
+      by = TRTA,
+      denominator = cards::ADSL |> mutate(TRTA = ARM),
+      id = USUBJID,
+      overall_row = TRUE
+    )
+  )
+
+  expect_snapshot(res$table_body)
+})