v2.0 add_overall.tbl summary()

NAMESPACE

@@ -2,6 +2,7 @@
 
 S3method(add_difference,tbl_summary)
 S3method(add_n,tbl_summary)
+S3method(add_overall,tbl_summary)
 S3method(add_p,tbl_summary)
 S3method(as.data.frame,gtsummary)
 S3method(as_tibble,gtsummary)
@@ -12,6 +13,7 @@ export("%>%")
 export(.table_styling_expr_to_row_number)
 export(add_difference)
 export(add_n)
+export(add_overall)
 export(add_p)
 export(add_q)
 export(all_categorical)

R/add_n.R

@@ -70,8 +70,7 @@ add_n.tbl_summary <- function(x, statistic = "{N_nonmiss}", col_label = "**N**",
   # calculate/grab the needed ARD results --------------------------------------
   if ("add_overall" %in% names(x[["call_list"]])) {
     # TODO: If `add_overall()` was previously run, we can get the stats from there instead of re-calculating
-  }
-  else if (is_empty(x$inputs$by)) {
+  } else if (is_empty(x$inputs$by)) {
     # TODO: If `tbl_summary(by)` is empty, then we can grab this from `x$card%tbl_summary`
     x$cards$add_n <-
       x[["cards"]][[1]] |>
@@ -80,8 +79,7 @@ add_n.tbl_summary <- function(x, statistic = "{N_nonmiss}", col_label = "**N**",
         .data$context %in% "missing"
       ) |>
       cards::apply_fmt_fn()
-  }
-  else {
+  } else {
     x$cards$add_n <-
       cards::ard_missing(
         data = x$inputs$data,

R/add_overall.R

@@ -0,0 +1,189 @@
+#' Add overall column
+#'
+#' - [`add_overall.tbl_summary()`]
+#'
+#' @param x (`gtsummary`)\cr
+#'   Object with class 'gtsummary'
+#' @param ... Passed to other methods.
+#' @keywords internal
+#' @author Daniel D. Sjoberg
+#' @export
+#'
+#' @seealso [`add_overall.tbl_summary()`]
+add_overall <- function(x, ...) {
+  check_not_missing(x)
+  check_class(x, "gtsummary")
+  UseMethod("add_overall")
+}
+
+#' Add overall column
+#'
+#' Adds a column with overall summary statistics to tables
+#' created by `tbl_summary`, `tbl_svysummary`, `tbl_continuous` or
+#' `tbl_custom_summary`.
+#'
+#' @param x (`tbl_summary`\`tbl_svysummary`\`tbl_continuous`\`tbl_custom_summary`)\cr
+#'   A stratified 'gtsummary' table
+#' @param last Logical indicator to display overall column last in table.
+#' Default is `FALSE`, which will display overall column first.
+#' @param col_label String indicating the column label. Default is `"**Overall**  \nN = {N}"`
+#' @param statistic Override the statistic argument in initial `tbl_*` function.
+#' call. Default is `NULL`.
+#' @param digits Override the digits argument in initial `tbl_*` function
+#' call. Default is `NULL`.
+#' @inheritParams rlang::args_dots_empty
+#'
+#' @author Daniel D. Sjoberg
+#' @export
+#' @return A `gtsummary` of same class as `x`
+#' @examples
+#' # Example 1 ----------------------------------
+#' trial |>
+#'   tbl_summary(include = c(age, grade), by = trt) |>
+#'   add_overall()
+#'
+#' # Example 2 ----------------------------------
+#' trial |>
+#'   tbl_summary(
+#'     include = grade,
+#'     by = trt,
+#'     percent = "row",
+#'     statistic = ~"{p}%",
+#'     digits = ~1
+#'   ) |>
+#'   add_overall(
+#'     last = TRUE,
+#'     statistic = ~"{p}% (n={n})",
+#'     digits = ~ c(1, 0)
+#'   )
+#'
+#' # TODO: Add this example after `tbl_continuous()`
+#' # # Example 3 ----------------------------------
+#' # tbl_overall_ex3 <-
+#' #   trial %>%
+#' #   tbl_continuous(
+#' #     variable = age,
+#' #     by = trt,
+#' #     include = grade
+#' #   ) %>%
+#' #   add_overall(last = TRUE)
+add_overall.tbl_summary <- function(x, last = FALSE, col_label = "**Overall**  \nN = {N}",
+                                    statistic = NULL, digits = NULL, ...) {
+  set_cli_abort_call()
+  check_dots_empty()
+
+  # translating the col_label, if nothing passed by user
+  if (missing(col_label)) {
+    paste0("**", translate_text("Overall"), "**  \nN = {N}")
+  }
+
+  add_overall_generic(
+    x = x,
+    last = last,
+    col_label = col_label,
+    statistic = statistic,
+    digits = digits,
+    call = c(x$call_list, list(add_overall = match.call())),
+    calling_fun = "tbl_summary"
+  )
+}
+
+add_overall_generic <- function(x, last, col_label, statistic, digits, call, calling_fun) {
+  check_scalar_logical(last)
+  check_string(col_label, allow_empty = TRUE)
+
+  # checking that input x has a by var
+  if (is_empty(x$inputs[["by"]])) {
+    cli::cli_abort(
+      "Cannot run {.fun add_overall} when original table function is not statified with {.code {calling_fun}(by)}.",
+      call = get_cli_abort_call()
+    )
+  }
+
+  # save arguments to pass to original function without `by` stratified --------
+  args_overall <- x$inputs |>
+    utils::modifyList(list(by = NULL), keep.null = TRUE)
+
+  # if overall row, already included in data -----------------------------------
+  if (isTRUE(args_overall$overall_row)) {
+    args_overall$overall_row <- FALSE
+  }
+
+  # update statistic/digit argument as needed ----------------------------------
+  if (!is_empty(statistic)) {
+    args_overall$statistic <- statistic
+  }
+  if (!is_empty(digits)) {
+    args_overall$digits <- digits
+  }
+
+  # create overall table -------------------------------------------------------
+  tbl_overall <- do.call(calling_fun, args_overall)
+
+  # merging overall results
+  x <- add_overall_merge(x, tbl_overall, last, col_label, calling_fun)
+
+  x$call_list <- call
+  x
+}
+
+add_overall_merge <- function(x, tbl_overall, last, col_label, calling_fun) {
+  # checking the original tbl_summary and the added overall,
+  # are the same before binding (excluding headers)
+  if (!identical(
+    select(x$table_body, c("row_type", "variable", "label")),
+    select(tbl_overall$table_body, c("row_type", "variable", "label")) |> as_tibble()
+  )) {
+    cli::cli_abort(
+      c(
+        "An error occured in {.fun add_overall}, and the overall statistic cannot be added.",
+        "Have variable labels changed since the original call to {.fun {calling_fun}}?"
+      ),
+      call = get_cli_abort_call()
+    )
+  }
+
+  # adding the overall cards object to the output
+  x[["cards"]][["add_overall"]] <- tbl_overall[["cards"]][[1]]
+
+  # adding overall stat to the table_body data frame
+  x$table_body <-
+    dplyr::bind_cols(
+      x$table_body,
+      tbl_overall$table_body |> dplyr::select("stat_0")
+    )
+
+  # add the overall header row to the primary table
+  x$table_styling$header <-
+    dplyr::bind_rows(
+      x$table_styling$header,
+      tbl_overall$table_styling$header |>
+        dplyr::filter(.data$column %in% "stat_0")
+    )
+
+  x$table_styling$header %>%
+    dplyr::rows_update(
+      tbl_overall$table_styling$header %>%
+        dplyr::filter(.data$column %in% "stat_0"),
+      by = "column"
+    )
+
+  if (last == FALSE) {
+    x <- modify_table_body(x, dplyr::relocate, "stat_0", .before = "stat_1")
+  }
+
+  # updating table_style with footnote and column header
+  x$table_styling$footnote <-
+    dplyr::bind_rows(
+      x$table_styling$footnote,
+      tbl_overall$table_styling$footnote %>%
+        dplyr::filter(.data$column %in% "stat_0")
+    )
+
+  # Add
+  x <- modify_header(x, stat_0 = col_label)
+
+
+
+  x
+}

R/add_q.R

@@ -65,16 +65,16 @@ add_q <- function(x, method = "fdr", pvalue_fun = NULL, quiet = NULL) {
     get_theme_element("add_q-arg:pvalue_fun") %||%
     get_theme_element("pkgwide-fn:pvalue_fun") %||%
     # default from p-value formatting function
-    (dplyr::filter(x$table_styling$fmt_fun, .data$column == "p.value") |> dplyr::pull("fmt_fun") |> rev() |>  getElement(1)) |>
+    (dplyr::filter(x$table_styling$fmt_fun, .data$column == "p.value") |> dplyr::pull("fmt_fun") |> rev() |> getElement(1)) |>
     as_function(arg = "pvalue_fun")
 
   # calculate the adjusted p-value ---------------------------------------------
   # TODO: add error handling here
-   q.value <- stats::p.adjust(x$table_body$p.value, method = method)
+  q.value <- stats::p.adjust(x$table_body$p.value, method = method)
 
   # update gtsummary table -----------------------------------------------------
   x <-
-    modify_table_body(x, ~dplyr::mutate(.x, q.value = q.value)) |>
+    modify_table_body(x, ~ dplyr::mutate(.x, q.value = q.value)) |>
     modify_table_styling(
       columns = "q.value",
       label = paste0("**", translate_text("q-value"), "**"),
@@ -97,16 +97,15 @@ add_q <- function(x, method = "fdr", pvalue_fun = NULL, quiet = NULL) {
 .add_q_method_label <- function(method) {
   lst_method_labels <-
     list(
-        "holm" = "Holm correction for multiple testing",
-        "hochberg" = "Hochberg correction for multiple testing",
-        "hommel" = "Hommel correction for multiple testing",
-        "bonferroni" = "Bonferroni correction for multiple testing",
-        "BH" = "Benjamini & Hochberg correction for multiple testing",
-        "BY" = "Benjamini & Yekutieli correction for multiple testing",
-        "fdr" = "False discovery rate correction for multiple testing",
-        "none" = "No correction for multiple testing"
+      "holm" = "Holm correction for multiple testing",
+      "hochberg" = "Hochberg correction for multiple testing",
+      "hommel" = "Hommel correction for multiple testing",
+      "bonferroni" = "Bonferroni correction for multiple testing",
+      "BH" = "Benjamini & Hochberg correction for multiple testing",
+      "BY" = "Benjamini & Yekutieli correction for multiple testing",
+      "fdr" = "False discovery rate correction for multiple testing",
+      "none" = "No correction for multiple testing"
     )
 
   lst_method_labels[[method]]
 }
-

R/tbl_regression.R

@@ -194,7 +194,7 @@ tbl_regression.default <- function(x,
   # TODO: Deprecate this... this was an odd choice?
   tidy_columns_to_report <-
     get_theme_element("tbl_regression-chr:tidy_columns",
-                      default = c("conf.low", "conf.high", "p.value")
+      default = c("conf.low", "conf.high", "p.value")
     ) |>
     union("estimate") |>
     intersect(names(table_body))
@@ -213,7 +213,7 @@ tbl_regression.default <- function(x,
   # adding the Ns to the `x$table_styling$header`
   if (!rlang::is_empty(res[c("N", "N_event")] |> compact())) {
     res$table_styling$header <-
-      res[c("N","N_event")] |>
+      res[c("N", "N_event")] |>
       compact() |>
       dplyr::as_tibble() |>
       dplyr::rename_with(.fn = ~ vec_paste0("modify_stat_", .), .cols = everything()) |>

R/utils-tbl_regression.R

@@ -37,7 +37,7 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label,
       attributes(.)[names(attributes(.)) %in% c("N_obs", "N_event", "coefficients_type", "coefficients_label")] %>%
         tibble::as_tibble()
     )}
-    # styler: on
+  # styler: on
 
   if (!"header_row" %in% names(df_tidy)) {
     df_tidy$header_row <- NA
@@ -138,8 +138,8 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label,
 
   x <-
     modify_table_styling(x,
-                         columns = any_of(c("conf.low", "conf.high")),
-                         fmt_fun = estimate_fun
+      columns = any_of(c("conf.low", "conf.high")),
+      fmt_fun = estimate_fun
     )
 
   # p.value --------------------------------------------------------------------
@@ -210,7 +210,7 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label,
   if (result$label %in% c("Beta", "exp(Beta)")) {
     exponentiate <- x$inputs$exponentiate
     result$label <- get_theme_element("tbl_regression-str:coef_header",
-                                      default = result$label
+      default = result$label
     )
   }
 
@@ -226,4 +226,3 @@ tidy_prep <- function(x, tidy_fun, exponentiate, conf.level, intercept, label,
   result$label <- translate_text(result$label, language)
   result
 }
-