making progress

ddsjoberg · Dec 10, 2024 · d029a6a · d029a6a
1 parent b6ddbc1
commit d029a6a
Show file tree

Hide file tree

Showing 13 changed files with 227 additions and 78 deletions.
diff --git a/R/modify_abbreviation.R b/R/modify_abbreviation.R
@@ -34,7 +34,7 @@ modify_abbreviation <- function(x, abbreviation, text_interpret = c("md", "html"
 
   # add updates to `x$table_styling$abbreviation` ------------------------------
   x <- x |>
-    .modify_abbreviation(abbreviation = abbreviation, text_interpret = paste0("gt::", text_interpret))
+    .modify_abbreviation(abbreviation = abbreviation, text_interpret = text_interpret)
 
   # update call list and return table ------------------------------------------
   x$call_list <- updated_call_list
@@ -80,7 +80,7 @@ remove_abbreviation <- function(x, abbreviation) {
       dplyr::tibble(
         column = column,
         abbreviation = abbreviation,
-        text_interpret = text_interpret
+        text_interpret = paste0("gt::", text_interpret)
       )
     )
   x

diff --git a/R/modify_table_styling.R b/R/modify_table_styling.R
@@ -1,10 +1,19 @@
 #' Modify Table Styling
 #'
+#' @description
+#' This function is for developers.
+#' If you are not a developer, it's recommended that you use the following
+#' functions to make modifications to your table. [`modify_header()`],
+#' [`modify_spanning_header()`], `[modify_column_hide()]`, [`modify_column_unhide()`],
+#' [`modify_footnote_header()`], [`modify_footnote_body()`], [`modify_abbreviation()`],
+#' [`modify_column_alignment()`], [`modify_fmt_fun()`], `[modify_column_indent()]`,
+#' [`modify_column_merge()`].
+#'
+#'
 #' This is a function meant for advanced users to gain
 #' more control over the characteristics of the resulting
 #' gtsummary table by directly modifying `.$table_styling`.
-#' *This function is primarily used in the development of other gtsummary
-#' functions, and very little checking of the passed arguments is performed.*
+#' *This function has very little checking of the passed arguments.*
 #'
 #' Review the
 #' \href{https://www.danieldsjoberg.com/gtsummary/articles/gtsummary_definition.html}{gtsummary definition}
@@ -101,7 +110,7 @@ modify_table_styling <- function(x,
                                  text_format = NULL,
                                  undo_text_format = NULL,
                                  indent = NULL,
-                                 text_interpret = c("md", "html"),
+                                 text_interpret = "md",
                                  cols_merge_pattern = NULL) {
   set_cli_abort_call()
   updated_call_list <- c(x$call_list, list(modify_table_styling = match.call()))
@@ -175,8 +184,6 @@ modify_table_styling <- function(x,
     )
   }
 
-  text_interpret <- paste0("gt::", arg_match(text_interpret))
-
   if (!is_empty(text_format)) {
     text_format <- arg_match(text_format, values = c("bold", "italic"), multiple = TRUE)
   }
@@ -202,7 +209,7 @@ modify_table_styling <- function(x,
     x$table_styling$header <-
       x$table_styling$header %>%
       dplyr::rows_update(
-        dplyr::tibble(column = columns, interpret_label = text_interpret, label = label),
+        dplyr::tibble(column = columns, interpret_label = paste0("gt::", text_interpret), label = label),
         by = "column"
       )
   }
@@ -212,7 +219,7 @@ modify_table_styling <- function(x,
     x$table_styling$header <-
       x$table_styling$header %>%
       dplyr::rows_update(
-        dplyr::tibble(column = columns, interpret_spanning_header = text_interpret, spanning_header = spanning_header),
+        dplyr::tibble(column = columns, interpret_spanning_header = paste0("gt::", text_interpret), spanning_header = spanning_header),
         by = "column"
       )
   }
@@ -241,28 +248,25 @@ modify_table_styling <- function(x,
   if (!is_empty(footnote)) {
     # header footnotes
     if (tryCatch(is.null(eval_tidy(rows)), error = \(x) FALSE)) {
-      x$table_styling$footnote_header <- x$table_styling$footnote_header |>
-        dplyr::bind_rows(
-          dplyr::tibble(
-            column = columns,
-            footnote = footnote,
-            text_interpret = text_interpret,
-            replace = TRUE,
-            remove = is.na(footnote)
-          )
+      x <-
+        .modify_footnote_header(
+          x = x,
+          lst_footnotes =
+            rep_named(columns, as.list(footnote)),
+          text_interpret = text_interpret,
+          replace = TRUE,
+          remove = is.na(footnote)
         )
     }
     else {
-      x$table_styling$footnote_body <- x$table_styling$footnote_body |>
-        dplyr::bind_rows(
-          dplyr::tibble(
-            column = columns,
-            rows = list(rows),
-            footnote = footnote,
-            text_interpret = text_interpret,
-            replace = TRUE,
-            remove = is.na(footnote)
-          )
+      x <-
+        .modify_footnote_body(
+          x = x,
+          lst_footnotes = rep_named(columns, as.list(footnote)),
+          rows = !!rows,
+          text_interpret = text_interpret,
+          replace = TRUE,
+          remove = is.na(footnote)
         )
     }
   }

diff --git a/R/utils-as.R b/R/utils-as.R
@@ -135,14 +135,7 @@
       remove = ifelse(is.na(.data$footnote), TRUE, .data$remove),
     ) |>
     # within a column, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal
-    dplyr::filter(
-      .by = "column",
-      !ifelse(
-        dplyr::row_number() == dplyr::n(),
-        FALSE,
-        as.logical(rev(cummax(rev(max(.data$replace, .data$remove)))))
-      )
-    ) |>
+    .filter_row_with_subsequent_replace_or_removal() |>
     #finally, remove the row if it's marked for removal or if the column is not printed in final table
     dplyr::filter(!remove, .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide])
 
@@ -159,15 +152,8 @@
         )
     ) |>
     tidyr::unnest(cols = "row_numbers") |>
-    # within a column, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal
-    dplyr::filter(
-      .by = c("column", "row_numbers"),
-      !ifelse(
-        dplyr::row_number() == dplyr::n(),
-        FALSE,
-        as.logical(rev(cummax(rev(max(.data$replace, .data$remove)))))
-      )
-    ) |>
+    # within a column/row, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal
+    .filter_row_with_subsequent_replace_or_removal() |>
     #finally, remove the row if it's marked for removal or if the column is not printed in final table
     dplyr::filter(!remove, .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide]) |>
     dplyr::select(all_of(c("column", "row_numbers", "text_interpret", "footnote"))) |>
@@ -228,6 +214,32 @@
   x
 }
 
+
+# this function processes the footnotes and removes footnotes that have
+# later been replaced or removed from the table
+.filter_row_with_subsequent_replace_or_removal <- function(x) {
+  if (nrow(x) == 0L) return(x)
+
+  # within a column/row, if a later entry contains `replace=TRUE` or `remove=TRUE`, then mark the row for removal
+  dplyr::filter(
+    .data = x,
+    .by = any_of(c("column", "row_numbers")),
+    !unlist(
+      pmap(
+        list(.data$replace, .data$remove, dplyr::row_number()),
+        function(row_replace, row_remove, row_number) {
+          # if this is the last row in the group, there will be now removal indications below
+          if (row_number == dplyr::n()) return(FALSE)
+          # if a subsequent call to replace or remove a footnote appear below,
+          # then the current row can be deleted.
+          any(.data$replace[seq(row_number + 1L, dplyr::n())]) ||
+            any(.data$remove[seq(row_number + 1L, dplyr::n())])
+        }
+      )
+    )
+  )
+}
+
 # this function orders the footnotes by where they first appear in the table,
 # and assigns them an sequential ID
 .number_footnotes <- function(x, type, start_with = 0L) {

diff --git a/man/modify_table_styling.Rd b/man/modify_table_styling.Rd
diff --git a/tests/testthat/_snaps/as_kable_extra.md b/tests/testthat/_snaps/as_kable_extra.md
@@ -97,7 +97,7 @@
       [13] "<tr>\n   <td style=\"text-align:left;\">  </td>\n   <td style=\"text-align:left;\"> Patient Died </td>\n   <td style=\"text-align:center;\"> 60 (59%) </td>\n "                        
       [14] "</tbody>\n<tfoot><tr><td style=\"padding: 0; \" colspan=\"100%\">\n<sup>1</sup> Median (Q1, Q3); n (%)</td></tr></tfoot>\n</table>"                                                    
 
-# as_kable_extra passes table footnotes & footnote abbreviations correctly
+# as_kable_extra passes table footnotes & abbreviations correctly
 
     "<\/tbody>\n<tfoot>\n<tr><td style=\"padding: 0; \" colspan=\"100%\">\n<sup>1<\/sup> n (%); Median (Q1, Q3)<\/td><\/tr>\n<tr><td style=\"padding: 0; \" colspan=\"100%\">\n<sup>2<\/sup> test footnote<\/td><\/tr>\n<\/tfoot>\n<\/table>"
 

diff --git a/tests/testthat/_snaps/modify_footnote_body.md b/tests/testthat/_snaps/modify_footnote_body.md
@@ -0,0 +1,9 @@
+# modify_footnote_body(rows) messaging
+
+    Code
+      modify_footnote_body(base_tbl_summary, footnote = "this will not appear",
+        columns = label, rows = not_a_predicate)
+    Condition
+      Error in `modify_footnote_body()`:
+      ! The `rows` argument must be an expression that evaluates to a logical vector in `x$table_body`.
+
diff --git a/tests/testthat/test-as_flex_table.R b/tests/testthat/test-as_flex_table.R
@@ -222,9 +222,9 @@ test_that("as_flex_table passes table column alignment correctly", {
   )
 })
 
-test_that("as_flex_table passes table footnotes & footnote abbreviations correctly", {
+test_that("as_flex_table passes table footnotes & abbreviations correctly", {
   tbl_fn <- my_tbl_summary |>
-    modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age")
+    modify_footnote_body(columns = label, footnote = "test footnote", rows = variable == "age")
   ft_tbl_fn <- tbl_fn |> as_flex_table()
 
   # footnote
@@ -275,7 +275,7 @@ test_that("as_flex_table passes multiple table footnotes correctly", {
   # testing one footnote passed to multiple columns and rows, addresses issue #2062
   out <- my_tbl_summary |>
     remove_footnote_header(stat_0) |>
-    modify_table_styling(
+    modify_footnote_body(
       columns = c(label, stat_0),
       rows = (variable %in% "trt") & (row_type == "level"),
       footnote = "my footnote"
@@ -310,17 +310,17 @@ test_that("as_flex_table passes multiple table footnotes correctly", {
       by = trt,
       include = grade
     ) |>
-    modify_table_styling(
+    modify_footnote_body(
       columns = stat_1,
       rows = (variable %in% "grade") & (row_type == "level"),
       footnote = "my footnote"
     ) |>
-    modify_table_styling(
+    modify_footnote_body(
       columns = label,
       rows = label == "grade",
       footnote = "my footnote"
     ) |>
-    modify_table_styling(
+    modify_footnote_body(
       columns = label,
       rows = label == "I",
       footnote = "my footnote"

diff --git a/tests/testthat/test-as_gt.R b/tests/testthat/test-as_gt.R
@@ -213,9 +213,9 @@ test_that("as_gt passes table text interpreters correctly", {
   expect_true(attr(gt_tbl$`_spanners`$spanner_label[[1]], "html"))
 })
 
-test_that("as_gt passes table footnotes & footnote abbreviations correctly", {
+test_that("as_gt passes table footnotes & abbreviations correctly", {
   tbl_fn <- my_tbl_summary |>
-    modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age")
+    modify_footnote_body(footnote = "test footnote", columns = label,rows = variable == "age")
   gt_tbl_fn <- tbl_fn |> as_gt()
 
   # footnote
@@ -265,8 +265,8 @@ test_that("as_gt passes table footnotes & footnote abbreviations correctly", {
   # footnotes in the body of the table
   expect_equal(
     tbl_summary(trial, include = "age") |>
-      modify_table_styling(columns = label, rows = TRUE, footnote = "my footnote") |>
-      modify_table_styling(columns = stat_0, rows = row_type == "label", footnote = "my footnote") |>
+      modify_footnote_body(columns = label, rows = TRUE, footnote = "my footnote") |>
+      modify_footnote_body(columns = stat_0, rows = row_type == "label", footnote = "my footnote") |>
       as_gt() |>
       getElement("_footnotes") |>
       dplyr::filter(footnotes == "my footnote") |>

diff --git a/tests/testthat/test-as_hux_table.R b/tests/testthat/test-as_hux_table.R
@@ -110,9 +110,9 @@ test_that("as_hux_table passes table column alignment correctly", {
   )
 })
 
-test_that("as_hux_table passes table footnotes & footnote abbreviations correctly", {
+test_that("as_hux_table passes table footnotes & abbreviations correctly", {
   tbl_fn <- my_tbl_summary |>
-    modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age")
+    modify_footnote_body(columns = label, footnote = "test footnote", rows = variable == "age")
   ht_fn <- tbl_fn |> as_hux_table()
 
   # footnote

diff --git a/tests/testthat/test-as_kable_extra.R b/tests/testthat/test-as_kable_extra.R
@@ -167,9 +167,9 @@ test_that("as_kable_extra passes table column alignment correctly", {
   )
 })
 
-test_that("as_kable_extra passes table footnotes & footnote abbreviations correctly", {
+test_that("as_kable_extra passes table footnotes & abbreviations correctly", {
   tbl_fn <- my_tbl_summary |>
-    modify_table_styling(columns = label, footnote = "test footnote", rows = variable == "age")
+    modify_footnote_body(columns = label, footnote = "test footnote", rows = variable == "age")
   kbl_fn <- tbl_fn |> as_kable_extra()
 
   # footnote

diff --git a/tests/testthat/test-modify_footnote.R b/tests/testthat/test-modify_footnote.R
@@ -175,18 +175,20 @@ test_that("modify_footnote() works with tbl_svysummary()", {
 })
 
 test_that("modify_footnote() works with tbl_continuous()", {
-  expect_equal(tbl_continuous(data = trial, variable = age, by = trt, include = grade)|>
-                 add_overall() |>
-                 modify_footnote(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |>
-                 getElement("table_styling") |>
-                 getElement("footnote_header") |>
-                 dplyr::slice_tail(by = "column", n = 1) |>
-                 dplyr::filter(startsWith(column, "stat_")) |>
-                 dplyr::pull("footnote"),
-               c("Drug A | N = 200 | n = 98 | p = 49%",
-                 "Drug B | N = 200 | n = 102 | p = 51%",
-                 "Overall | N = 200 | n = 200 | p = 100%"),
-               ignore_attr = TRUE)
+  expect_equal(
+    tbl_continuous(data = trial, variable = age, by = trt, include = grade) |>
+      add_overall() |>
+      modify_footnote(all_stat_cols() ~ "{level} | N = {N} | n = {n} | p = {style_percent(p)}%") |>
+      getElement("table_styling") |>
+      getElement("footnote_header") |>
+      dplyr::slice_tail(by = "column", n = 1) |>
+      dplyr::filter(startsWith(column, "stat_")) |>
+      dplyr::pull("footnote"),
+    c("Drug A | N = 200 | n = 98 | p = 49%",
+      "Drug B | N = 200 | n = 102 | p = 51%",
+      "Overall | N = 200 | n = 200 | p = 100%"),
+    ignore_attr = TRUE
+  )
 })