Merge branch 'main' into 2070_var_levels_tbl_hierarchical

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.R

@@ -269,7 +269,7 @@ calculate_and_add_test_results <- function(x, include, group = NULL, test.args,
         if (!is.null(lst_captured_results[["result"]])) return(lst_captured_results[["result"]]) # styler: off
         # otherwise, construct a {cards}-like object with error
         dplyr::tibble(
-          group1 = x$inputs$by,
+          group1 = switch(!is_empty(x$inputs$by), x$inputs$by),
           variable = variable,
           stat_name = switch(calling_fun,
                              "add_p" = "p.value",

R/add_p.tbl_continuous.R

@@ -11,10 +11,16 @@
 #' @export
 #' @return 'tbl_continuous' object
 #'
-#' @examplesIf gtsummary:::is_pkg_installed("cardx")
+#' @examplesIf (identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")) && gtsummary:::is_pkg_installed("cardx")
+#' # Example 1 ----------------------------------
 #' trial |>
 #'   tbl_continuous(variable = age, by = trt, include = grade) |>
-#'   add_p()
+#'   add_p(pvalue_fun = label_style_pvalue(digits = 2))
+#'
+#' # Example 2 ----------------------------------
+#' trial |>
+#'   tbl_continuous(variable = age, include = grade) |>
+#'   add_p(test = everything() ~ "kruskal.test")
 add_p.tbl_continuous <- function(x,
                                  test = NULL,
                                  pvalue_fun = label_style_pvalue(digits = 1),

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/tbl_ard_summary.R

@@ -36,6 +36,22 @@
 #'   Default is `FALSE`.
 #' @inheritParams tbl_summary
 #'
+#' @details
+#' There are three types of additional data that can be included in the ARD to
+#' improve the default appearance of the table.
+#'
+#' 1. **Attributes**: When attributes are included, the default labels will be
+#'   the variable labels, when available. Attributes can be included in an ARD
+#'   with `cards::ard_attributes()` or `ard_stack(.attributes = TRUE)`.
+#'
+#' 2. **Missing**: When missing results are included, users can include
+#'   missing counts or rates for variables with `tbl_ard_summary(missing = c("ifany", "always"))`.
+#'   The missing statistics can be included in an ARD with
+#'   `cards::ard_missing()` or `ard_stack(.missing = TRUE)`.
+#'
+#' 3. **Total N**: The total N is saved internally when available, and it can
+#'   be calculated with `cards::ard_total_n()` or `ard_stack(.total_n = TRUE)`.
+#'
 #' @return a gtsummary table of class `"tbl_ard_summary"`
 #' @export
 #'

R/tbl_strata.R

@@ -85,8 +85,7 @@
 #'         modify_header(stat_0 = "**Rate (95% CI)**") |>
 #'         modify_footnote(stat_0 = NA),
 #'     .combine_with = "tbl_stack",
-#'     .combine_args = list(group_header = NULL),
-#'     .quiet = TRUE
+#'     .combine_args = list(group_header = NULL)
 #'   ) |>
 #'   modify_caption("**Response Rate by Grade**")
 NULL

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(),