Merge branch 'main' into 2078-svy-assign-default-digits

NAMESPACE

@@ -163,6 +163,7 @@ export(modify_column_unhide)
 export(modify_fmt_fun)
 export(modify_footnote)
 export(modify_header)
+export(modify_source_note)
 export(modify_spanning_header)
 export(modify_table_body)
 export(modify_table_styling)
@@ -180,6 +181,7 @@ export(pool_and_tidy_mice)
 export(proportion_summary)
 export(ratio_summary)
 export(remove_row_type)
+export(remove_source_note)
 export(reset_gtsummary_theme)
 export(scope_header)
 export(scope_table_body)

R/add_glance.R

@@ -140,6 +140,7 @@ add_glance_source_note <- function(x,
   text_interpret <- arg_match(text_interpret)
   check_string(sep1)
   check_string(sep2)
+  text_interpret <- arg_match(text_interpret, error_call = get_cli_abort_call())
 
   # calculate and prepare the glance function results --------------------------
   lst_prep_glance <-
@@ -161,9 +162,13 @@ add_glance_source_note <- function(x,
   }
 
   # compile stats into source note ---------------------------------------------
-  x$table_styling$source_note <-
-    paste(lst_prep_glance$df_glance$label, lst_prep_glance$df_glance$estimate_fmt, sep = sep1, collapse = sep2)
-  attr(x$table_styling$source_note, "text_interpret") <- match.arg(text_interpret)
+  x <-
+    modify_source_note(
+      x,
+      source_note =
+        paste(lst_prep_glance$df_glance$label, lst_prep_glance$df_glance$estimate_fmt, sep = sep1, collapse = sep2),
+      text_interpret = text_interpret
+    )
 
   # returning gtsummary table --------------------------------------------------
   x$call_list <- updated_call_list

R/add_p.tbl_cross.R

@@ -109,11 +109,12 @@ add_p.tbl_cross <- function(x,
         columns = "p.value",
         footnote = NA_character_,
         hide = TRUE
+      ) |>
+      modify_source_note(
+        source_note =
+          paste(test_name, pvalue_fun(discard(x$table_body$p.value, is.na)), sep = ", "),
+        text_interpret = "md"
       )
-
-    x$table_styling$source_note <-
-      paste(test_name, pvalue_fun(discard(x$table_body$p.value, is.na)), sep = ", ")
-    attr(x$table_styling$source_note, "text_interpret") <- "md"
   }
 
   # strip markdown bold around column label ------------------------------------

R/as_flex_table.R

@@ -317,12 +317,15 @@ table_styling_to_flextable_calls <- function(x, ...) {
 
   # source note ----------------------------------------------------------------
   # in flextable, this is just a footnote associated without column or symbol
-  if (!is.null(x$table_styling$source_note)) {
-    flextable_calls[["source_note"]] <-
-      expr(
-        flextable::add_footer_lines(value = flextable::as_paragraph(!!x$table_styling$source_note))
-      )
-  }
+  flextable_calls[["source_note"]] <-
+    map(
+      seq_len(nrow(x$table_styling$source_note)),
+      \(i) {
+        expr(
+          flextable::add_footer_lines(value = flextable::as_paragraph(!!x$table_styling$source_note$source_note[i]))
+        )
+      }
+    )
 
   # border ---------------------------------------------------------------------
   flextable_calls[["border"]] <-

R/as_gt.R

@@ -325,14 +325,18 @@ table_styling_to_gt_calls <- function(x, ...) {
 
   # tab_source_note  -----------------------------------------------------------
   # adding other calls from x$table_styling$source_note
-  if (!is.null(x$table_styling$source_note)) {
-    source_note <-
-      rlang::call2(
-        get(attr(x$table_styling$source_note, "text_interpret"), envir = asNamespace("gt")),
-        x$table_styling$source_note
-      )
-    gt_calls[["tab_source_note"]] <- expr(gt::tab_source_note(source_note = !!source_note))
-  }
+  gt_calls[["tab_source_note"]] <-
+    map(
+      seq_len(nrow(x$table_styling$source_note)),
+      \(i) {
+        expr(
+          gt::tab_source_note(source_note =
+                                !!do.call(eval(rlang::parse_expr(x$table_styling$source_note$text_interpret[i])),
+                                          args = list(x$table_styling$source_note$source_note[i])))
+        )
+      }
+    )
+
 
   # cols_hide ------------------------------------------------------------------
   gt_calls[["cols_hide"]] <-

R/as_hux_table.R

@@ -206,14 +206,15 @@ table_styling_to_huxtable_calls <- function(x, ...) {
   }
 
   # source note ----------------------------------------------------------------
-  if (!is.null(x$table_styling$source_note)) {
-    huxtable_calls[["add_footnote"]] <- append(
-      huxtable_calls[["add_footnote"]],
-      expr(
-        huxtable::add_footnote(text = !!x$table_styling$source_note)
-      )
+  huxtable_calls[["source_note"]] <-
+    map(
+      seq_len(nrow(x$table_styling$source_note)),
+      \(i) {
+        expr(
+          huxtable::add_footnote(text = !!x$table_styling$source_note$source_note[i])
+        )
+      }
     )
-  }
 
   # bold -----------------------------------------------------------------------
   df_bold <-

R/modify_source_note.R

@@ -0,0 +1,89 @@
+#' Modify source note
+#'
+#' @description
+#' Add and remove source notes from a table.
+#' Source notes are similar to footnotes, expect they are not linked to a cell in
+#' the table.
+#'
+#' @param x (`gtsummary`)\cr
+#'   A gtsummary object.
+#' @param source_note (`string`)\cr
+#'   A string to add as a source note.
+#' @param source_note_id (`integers`)\cr
+#'   Integers specifying the ID of the source note to remove.
+#'   Source notes are indexed sequentially at the time of creation.
+#' @inheritParams modify
+#'
+#' @details
+#' Source notes are not supported by `as_kable_extra()`.
+#'
+#'
+#' @return gtsummary object
+#' @name modify_source_note
+#'
+#' @examplesIf identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")
+#'
+NULL
+
+#' @export
+#' @rdname modify_source_note
+modify_source_note <- function(x, source_note, text_interpret = c("md", "html")) {
+  set_cli_abort_call()
+  updated_call_list <- c(x$call_list, list(modify_source_note = match.call()))
+
+  # check inputs ---------------------------------------------------------------
+  check_not_missing(x)
+  check_not_missing(source_note)
+  check_class(x, "gtsummary")
+  check_string(source_note)
+  text_interpret <- arg_match(text_interpret, error_call = get_cli_abort_call())
+
+  # add source note to table_styling -------------------------------------------
+  x$table_styling$source_note <-
+    dplyr::bind_rows(
+      x$table_styling$source_note,
+      dplyr::tibble(
+        id = nrow(x$table_styling$source_note) + 1L,
+        source_note = source_note,
+        text_interpret = paste0("gt::", text_interpret),
+        remove = FALSE
+      )
+    )
+
+  # return table ---------------------------------------------------------------
+  x$call_list <- updated_call_list
+  x
+}
+
+#' @export
+#' @rdname modify_source_note
+remove_source_note <- function(x, source_note_id) {
+  set_cli_abort_call()
+  updated_call_list <- c(x$call_list, list(remove_source_note = match.call()))
+
+  # check inputs ---------------------------------------------------------------
+  check_not_missing(x)
+  check_not_missing(source_note_id)
+  check_class(x, "gtsummary")
+  check_integerish(source_note_id, allow_empty = TRUE)
+
+  # mark source note for removal -----------------------------------------------
+  if (!is_empty(source_note_id)) {
+    if (any(!source_note_id %in% x$table_styling$source_note$id)) {
+      cli::cli_abort(
+        c("Argument {.arg source_note_id} is out of bounds.",
+          i = "Must be one or more of {.val {x$table_styling$source_note$id}} or {.code NULL}."),
+        call = get_cli_abort_call()
+      )
+    }
+
+    x$table_styling$source_note$remove[x$table_styling$source_note$id %in% source_note_id] <- TRUE
+  }
+  else {
+    x$table_styling$source_note$remove <- TRUE
+  }
+
+  # return table ---------------------------------------------------------------
+  x$call_list <- updated_call_list
+  x
+}

R/utils-as.R

@@ -71,6 +71,11 @@
     dplyr::select("column", "row_numbers", everything()) %>%
     dplyr::ungroup()
 
+  # source_note ----------------------------------------------------------------
+  x$table_styling$source_note <-
+    x$table_styling$source_note |>
+    dplyr::filter(.data$remove == FALSE)
+
   # indentation ----------------------------------------------------------------
   x$table_styling$indent <-
     x$table_styling$indent %>%

R/utils-gtsummary_core.R

@@ -39,6 +39,13 @@
       column = character(), rows = list(),
       text_interpret = character(), footnote = character()
     )
+  x$table_styling$source_note <-
+    dplyr::tibble(
+      id = integer(),
+      source_note = character(),
+      text_interpret = character(),
+      remove = logical()
+    )
   x$table_styling$text_format <-
     dplyr::tibble(
       column = character(), rows = list(),

pkgdown/_pkgdown.yml

@@ -161,6 +161,7 @@ reference:
   - subtitle: Style Summary Tables
   - contents:
       - modify
+      - modify_source_note
       - modify_caption
       - bold_italicize_labels_levels
       - bold_p

tests/testthat/_snaps/modify_source_note.md

@@ -0,0 +1,27 @@
+# modify_source_note() messaging
+
+    Code
+      modify_source_note(tbl_summary(trial, include = trt), source_note = letters)
+    Condition
+      Error in `modify_source_note()`:
+      ! The `source_note` argument must be a string, not a character vector.
+
+---
+
+    Code
+      modify_source_note(tbl_summary(trial, include = trt), source_note = "ttt",
+      text_interpret = letters)
+    Condition
+      Error in `modify_source_note()`:
+      ! `text_interpret` must be one of "md" or "html", not "a".
+
+# remove_source_note(source_note_id) messaging
+
+    Code
+      remove_source_note(modify_source_note(tbl_summary(trial, include = trt),
+      "Created June 26, 2015"), source_note_id = 100)
+    Condition
+      Error in `remove_source_note()`:
+      ! Argument `source_note_id` is out of bounds.
+      i Must be one or more of 1 or `NULL`.
+

tests/testthat/test-add_glance.R

@@ -8,6 +8,7 @@ test_that("add_glance_source_note(x)", {
       tbl_regression() |>
       add_glance_source_note() |>
       getElement("table_styling") |>
+      getElement("source_note") |>
       getElement("source_note"),
     "R² = 0.000; Adjusted R² = -0.005; Sigma = 14.3; Statistic = 0.044; p-value = 0.8; df = 1; Log-likelihood = -771; AIC = 1,547; BIC = 1,557; Deviance = 38,499; Residual df = 187; No. Obs. = 189",
     ignore_attr = TRUE
@@ -20,6 +21,7 @@ test_that("add_glance_source_note(include,label)", {
       tbl_regression() |>
       add_glance_source_note(include = r.squared, label = r.squared ~ "R * R") |>
       getElement("table_styling") |>
+      getElement("source_note") |>
       getElement("source_note"),
     "R * R = 0.000",
     ignore_attr = TRUE
@@ -32,6 +34,7 @@ test_that("add_glance_source_note(fmt_fn)", {
       tbl_regression() |>
       add_glance_source_note(fmt_fun = ~label_style_sigfig(digits = 5), include = 1:3) |>
       getElement("table_styling") |>
+      getElement("source_note") |>
       getElement("source_note"),
     "R² = 0.00024; Adjusted R² = -0.00511; Sigma = 14.348",
     ignore_attr = TRUE
@@ -44,11 +47,13 @@ test_that("add_glance_source_note(glance_fun)", {
       tbl_regression() |>
       add_glance_source_note(glance_fun = \(x, ...) broom::glance(x, ...) |> dplyr::select(1:3)) |>
       getElement("table_styling") |>
+      getElement("source_note") |>
       getElement("source_note"),
     lm(age ~ trt, trial) |>
       tbl_regression() |>
       add_glance_source_note(include = 1:3) |>
       getElement("table_styling") |>
+      getElement("source_note") |>
       getElement("source_note")
   )
 })
@@ -60,8 +65,8 @@ test_that("add_glance_source_note(text_interpret)", {
       add_glance_source_note(text_interpret = "html") |>
       getElement("table_styling") |>
       getElement("source_note") |>
-      attr("text_interpret"),
-    "html"
+      getElement("text_interpret"),
+    "gt::html"
   )
 })
 
@@ -71,7 +76,8 @@ test_that("add_glance_source_note(sep1,sep2)", {
       tbl_regression() |>
       add_glance_source_note(include = 1:3, sep1 = "==", sep2 = " | ") |>
       getElement("table_styling") |>
-      getElement("source_note") ,
+      getElement("source_note") |>
+      getElement("source_note"),
     "R²==0.000 | Adjusted R²==-0.005 | Sigma==14.3",
     ignore_attr = TRUE
   )
@@ -132,9 +138,8 @@ test_that("add_glance_table(glance_fun) for mice models", {
   tbl <- mice::mice(mice::nhanes2, print = FALSE, maxit = 1) |>
     with(lm(bmi ~ age)) |>
     tbl_regression()
-  glance <- tbl$inputs$x |>
-    mice::pool() |>
-    broom::glance() |>
+  glance <- tbl$inputs$x %>%
+    {suppressWarnings(broom::glance(mice::pool(.)))} |>
     dplyr::mutate(
       across(c(nimp, nobs), label_style_number()),
       across(c(r.squared, adj.r.squared), label_style_number(digits = 3))
@@ -156,6 +161,7 @@ test_that("add_glance_table(glance_fun) for mice models", {
         label = names(glance) |> as.list() |> setNames(names(glance))
       ) |>
       getElement("table_styling") |>
+      getElement("source_note") |>
       getElement("source_note"),
     imap(glance, ~paste0(.y, " = ", .x)) |> unlist() |> paste(collapse = "; "),
     ignore_attr = TRUE