add multiple footnotes in one cell feature

R/add_overall.R

@@ -205,6 +205,12 @@ add_overall_merge <- function(x, tbl_overall, last, col_label, calling_fun) {
       tbl_overall$table_styling$footnote_header %>%
         dplyr::filter(.data$column %in% "stat_0")
     )
+  x$table_styling$footnote_body <-
+    dplyr::bind_rows(
+      x$table_styling$footnote_body,
+      tbl_overall$table_styling$footnote_body %>%
+        dplyr::filter(.data$column %in% "stat_0")
+    )
 
   # Add header to overall column
   x <- modify_header(x, stat_0 = col_label)

R/modify_footnote.R

@@ -8,6 +8,11 @@
 #' @param rows (predicate `expression`)\cr
 #'   Predicate expression to select rows in `x$table_body`.
 #'   Review [rows argument details][rows_argument].
+#' @param replace (scalar `logical`)\cr
+#'   Logical indicating whether to replace any existing footnotes in the specified
+#'   location with the specified footnote, or whether the specified should
+#'   be added to the existing footnote(s) in the header/cell. Default
+#'   is to replace existing footnotes.
 #'
 #' @return Updated gtsummary object
 #' @name modify_footnote2
@@ -18,13 +23,14 @@ NULL
 
 #' @export
 #' @rdname modify_footnote2
-modify_footnote_header <- function(x, footnote, columns, text_interpret = c("md", "html")) {
+modify_footnote_header <- function(x, footnote, columns, replace = TRUE, text_interpret = c("md", "html")) {
   set_cli_abort_call()
   updated_call_list <- c(x$call_list, list(modify_footnote_header = match.call()))
 
   # check inputs ---------------------------------------------------------------
   check_class(x, "gtsummary")
   check_string(footnote)
+  check_scalar_logical(replace)
   text_interpret <- arg_match(text_interpret, error_call = get_cli_abort_call())
 
   # process columns ------------------------------------------------------------
@@ -42,6 +48,7 @@ modify_footnote_header <- function(x, footnote, columns, text_interpret = c("md"
       x,
       lst_footnotes = lst_footnotes,
       text_interpret = text_interpret,
+      replace = replace,
       remove = FALSE
     )
 
@@ -52,13 +59,14 @@ modify_footnote_header <- function(x, footnote, columns, text_interpret = c("md"
 
 #' @export
 #' @rdname modify_footnote2
-modify_footnote_body <- function(x, footnote, columns, rows, text_interpret = c("md", "html")) {
+modify_footnote_body <- function(x, footnote, columns, rows, replace = TRUE, text_interpret = c("md", "html")) {
   set_cli_abort_call()
   updated_call_list <- c(x$call_list, list(modify_footnote_body = match.call()))
 
   # check inputs ---------------------------------------------------------------
   check_class(x, "gtsummary")
   check_string(footnote)
+  check_scalar_logical(replace)
   text_interpret <- arg_match(text_interpret, error_call = get_cli_abort_call())
   .check_rows_input(x, {{ rows }})
 
@@ -78,6 +86,7 @@ modify_footnote_body <- function(x, footnote, columns, rows, text_interpret = c(
       lst_footnotes = lst_footnotes,
       rows = {{ rows }},
       text_interpret = text_interpret,
+      replace = replace,
       remove = FALSE
     )
 
@@ -166,14 +175,16 @@ remove_footnote_body <- function(x, columns, rows) {
 }
 
 # modify_footnote_*() for internal use (no checking of inputs) -----------------
-.modify_footnote_header <- function(x, lst_footnotes, text_interpret = "md", remove = FALSE) {
+.modify_footnote_header <- function(x, lst_footnotes, text_interpret = "md",
+                                    replace = TRUE, remove = FALSE) {
   # add updates to `x$table_styling$footnote_header` ---------------------------
   x$table_styling$footnote_header <- x$table_styling$footnote_header |>
     dplyr::bind_rows(
       dplyr::tibble(
         column = names(lst_footnotes),
         footnote = unlist(lst_footnotes) |> unname(),
         text_interpret = paste0("gt::", text_interpret),
+        replace = replace,
         remove = remove
       )
     )
@@ -182,7 +193,8 @@ remove_footnote_body <- function(x, columns, rows) {
   x
 }
 
-.modify_footnote_body <- function(x, lst_footnotes, rows, text_interpret = "md", remove = FALSE) {
+.modify_footnote_body <- function(x, lst_footnotes, rows, text_interpret = "md",
+                                  replace = TRUE, remove = FALSE) {
   # add updates to `x$table_styling$footnote_body` -----------------------------
   x$table_styling$footnote_body <- x$table_styling$footnote_body |>
     dplyr::bind_rows(
@@ -191,6 +203,7 @@ remove_footnote_body <- function(x, columns, rows) {
         rows = list(enquo(rows)),
         footnote = unlist(lst_footnotes) |> unname(),
         text_interpret = paste0("gt::", text_interpret),
+        replace = replace,
         remove = remove
       )
     )

R/modify_table_styling.R

@@ -247,6 +247,7 @@ modify_table_styling <- function(x,
             column = columns,
             footnote = footnote,
             text_interpret = text_interpret,
+            replace = TRUE,
             remove = is.na(footnote)
           )
         )
@@ -259,6 +260,7 @@ modify_table_styling <- function(x,
             rows = list(rows),
             footnote = footnote,
             text_interpret = text_interpret,
+            replace = TRUE,
             remove = is.na(footnote)
           )
         )

R/utils-as.R

@@ -130,16 +130,48 @@
   # footnote_header ------------------------------------------------------------
   x$table_styling$footnote_header <-
     x$table_styling$footnote_header |>
-    dplyr::slice_tail(n = 1L, by = "column") |>
+    dplyr::mutate(
+      # this is a hold-over from old syntax where NA removed footnotes.
+      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(
-      !.data$remove,
-      !is.na(.data$footnote),
-      .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide]
-    )
+      .by = "column",
+      !ifelse(
+        dplyr::row_number() == dplyr::n(),
+        FALSE,
+        as.logical(rev(cummax(rev(max(.data$replace, .data$remove)))))
+      )
+    ) |>
+    #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])
 
   # footnote_body --------------------------------------------------------------
   x$table_styling$footnote_body <-
-    .table_styling_expr_to_row_number_footnote(x, "footnote_body")
+    x$table_styling$footnote_body |>
+    dplyr::mutate(
+      remove = ifelse(is.na(.data$footnote), TRUE, .data$remove), # this is a hold-over from pre-v2.0.0 syntax where NA removed footnotes.
+      # convert rows predicate expression to row numbers
+      row_numbers =
+        map(
+          .data$rows,
+          \(rows) .rows_expr_to_row_numbers(x$table_body, rows)
+        )
+    ) |>
+    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)))))
+      )
+    ) |>
+    #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"))) |>
+    dplyr::mutate(row_numbers = as.integer(.data$row_numbers)) # when there are no body footnotes, this ensures expected type/class
 
   # abbreviation ---------------------------------------------------------------
   abbreviation_cols <-
@@ -196,43 +228,6 @@
   x
 }
 
-.table_styling_expr_to_row_number_footnote <- function(x, footnote_type) {
-  df_clean <-
-    x$table_styling[[footnote_type]] %>%
-    dplyr::filter(.data$column %in% .cols_to_show(x))
-  if (nrow(df_clean) == 0) {
-    return(dplyr::tibble(
-      column = character(0), tab_location = character(0), row_numbers = logical(0),
-      text_interpret = character(0), footnote = character(0)
-    ))
-  }
-
-  df_clean <-
-    df_clean %>%
-    dplyr::rowwise() %>%
-    dplyr::mutate(
-      row_numbers =
-        switch(nrow(.) == 0,
-          integer(0)
-        ) %||%
-          .rows_expr_to_row_numbers(x$table_body, .data$rows) %>% list(),
-      tab_location = ifelse(identical(.data$row_numbers, NA), "header", "body")
-    ) %>%
-    dplyr::select(-"rows") %>%
-    tidyr::unnest(cols = "row_numbers") %>%
-    dplyr::group_by(.data$column, .data$tab_location, .data$row_numbers) %>%
-    dplyr::filter(dplyr::row_number() == dplyr::n()) %>%
-    # keeping the most recent addition
-    dplyr::filter(
-      !.data$remove,
-      !is.na(.data$footnote),
-      .data$column %in% x$table_styling$header$column[!x$table_styling$header$hide]
-    )
-
-  df_clean %>%
-    dplyr::select(all_of(c("column", "tab_location", "row_numbers", "text_interpret", "footnote")))
-}
-
 # 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) {
@@ -259,45 +254,6 @@
     dplyr::mutate(footnote_id = dplyr::row_number() + .env$start_with) |>
     tidyr::unnest(cols = "data") |>
     dplyr::select(any_of(c("footnote_id", "footnote", "column", "column_id", "row_numbers")))
-
-
-
-
-
-  # # stacking the header and body footnotes into the structure from the older structure
-  # # will need to update this after we implement footnotes for spanning headers
-  # x$table_styling$footnote <-
-  #   dplyr::bind_rows(
-  #     x$table_styling$footnote_header |> dplyr::mutate(tab_location = "header"),
-  #     x$table_styling$footnote_body |> dplyr::mutate(tab_location = "body")
-  #   )
-  #
-  # if (nrow(x$table_styling$footnote) == 0) {
-  #   return(dplyr::tibble(
-  #     footnote_id = integer(), footnote = character(), column = character(),
-  #     tab_location = character(), row_numbers = integer()
-  #   ))
-  # }
-  # dplyr::bind_rows(
-  #   x$table_styling$footnote,
-  #   x$table_styling$footnote_abbrev
-  # ) %>%
-  #   dplyr::inner_join(
-  #     x$table_styling$header %>%
-  #       select("column") %>%
-  #       mutate(column_id = dplyr::row_number()),
-  #     by = "column"
-  #   ) %>%
-  #   dplyr::arrange(dplyr::desc(.data$tab_location), .data$column_id, .data$row_numbers) %>%
-  #   dplyr::group_by(.data$footnote) %>%
-  #   tidyr::nest() %>%
-  #   dplyr::ungroup() %>%
-  #   dplyr::mutate(footnote_id = dplyr::row_number()) %>%
-  #   tidyr::unnest(cols = "data") %>%
-  #   dplyr::select(
-  #     "footnote_id", "footnote", "column",
-  #     "tab_location", "row_numbers"
-  #   )
 }
 
 

R/utils-gtsummary_core.R

@@ -30,13 +30,15 @@
     )
   x$table_styling$footnote_header <-
     dplyr::tibble(
-      column = character(), footnote = character(),
-      text_interpret = character(), remove = logical()
+      column = character(),
+      footnote = character(), text_interpret = character(),
+      replace = logical(), remove = logical()
     )
   x$table_styling$footnote_body <-
     dplyr::tibble(
       column = character(), rows = list(),
-      footnote = character(), text_interpret = character(), remove = logical()
+      footnote = character(), text_interpret = character(),
+      replace = logical(), remove = logical()
     )
   x$table_styling$abbreviation <-
     dplyr::tibble(

tests/testthat/_snaps/separate_p_footnotes.md

@@ -5,22 +5,22 @@
         variable, by, ...) broom::tidy(t.test(data[[variable]] ~ data[[by]]))))), "table_styling"), "footnote_body"), dplyr::row_number() %in%
         c(dplyr::n(), dplyr::n() - 1L)), rows = map_chr(rows, ~ expr_deparse(quo_squash(.x)))))
     Output
-         column                                                      rows                   footnote text_interpret remove
-      1 p.value   .data$variable %in% "age" & .data$row_type %in% "label"    Welch Two Sample t-test         gt::md  FALSE
-      2 p.value .data$variable %in% "grade" & .data$row_type %in% "label" Pearson's Chi-squared test         gt::md  FALSE
+         column                                                      rows                   footnote text_interpret replace remove
+      1 p.value   .data$variable %in% "age" & .data$row_type %in% "label"    Welch Two Sample t-test         gt::md    TRUE  FALSE
+      2 p.value .data$variable %in% "grade" & .data$row_type %in% "label" Pearson's Chi-squared test         gt::md    TRUE  FALSE
 
 ---
 
     Code
       as.data.frame(dplyr::mutate(dplyr::filter(getElement(getElement(separate_p_footnotes(add_difference(tbl)), "table_styling"),
       "footnote_body"), dplyr::row_number() %in% seq(dplyr::n(), dplyr::n() - 4L)), rows = map_chr(rows, ~ expr_deparse(quo_squash(.x)))))
     Output
-          column                                                      rows                     footnote text_interpret remove
-      1 estimate   .data$variable %in% "age" & .data$row_type %in% "label"      Welch Two Sample t-test         gt::md  FALSE
-      2 conf.low   .data$variable %in% "age" & .data$row_type %in% "label"      Welch Two Sample t-test         gt::md  FALSE
-      3  p.value   .data$variable %in% "age" & .data$row_type %in% "label"      Welch Two Sample t-test         gt::md  FALSE
-      4 estimate .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference         gt::md  FALSE
-      5 conf.low .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference         gt::md  FALSE
+          column                                                      rows                     footnote text_interpret replace remove
+      1 estimate   .data$variable %in% "age" & .data$row_type %in% "label"      Welch Two Sample t-test         gt::md    TRUE  FALSE
+      2 conf.low   .data$variable %in% "age" & .data$row_type %in% "label"      Welch Two Sample t-test         gt::md    TRUE  FALSE
+      3  p.value   .data$variable %in% "age" & .data$row_type %in% "label"      Welch Two Sample t-test         gt::md    TRUE  FALSE
+      4 estimate .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference         gt::md    TRUE  FALSE
+      5 conf.low .data$variable %in% "grade" & .data$row_type %in% "label" Standardized Mean Difference         gt::md    TRUE  FALSE
 
 # separate_p_footnotes() messaging
 

tests/testthat/test-modify_footnote_header.R

@@ -0,0 +1,14 @@
+skip_on_cran()
+
+base_tbl_summary <- tbl_summary(trial, include = marker)
+test_that("modify_footnote_header(footnote)", {
+  expect_silent(
+    tbl <- base_tbl_summary |>
+      modify_footnote_header(
+        footnote = "testing",
+        columns = all_stat_cols()
+      )
+  )
+
+
+})