From bce33e21d2b10c7e6911979f5f7e87ca3ef12132 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Mon, 3 Jun 2024 20:46:59 -0700 Subject: [PATCH] progress --- NAMESPACE | 1 + R/add_significance_stars.R | 159 ++++++++++++++++++++++++++++++++++ man/add_significance_stars.Rd | 91 +++++++++++++++++++ pkgdown/_pkgdown.yml | 4 +- 4 files changed, 253 insertions(+), 2 deletions(-) create mode 100644 R/add_significance_stars.R create mode 100644 man/add_significance_stars.Rd diff --git a/NAMESPACE b/NAMESPACE index acbb58b90f..4e48e3b44c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -52,6 +52,7 @@ export(add_nevent) export(add_overall) export(add_p) export(add_q) +export(add_significance_stars) export(add_stat) export(add_stat_label) export(all_categorical) diff --git a/R/add_significance_stars.R b/R/add_significance_stars.R new file mode 100644 index 0000000000..05d33ccb85 --- /dev/null +++ b/R/add_significance_stars.R @@ -0,0 +1,159 @@ +#' Add significance stars +#' +#' Add significance stars to estimates with small p-values +#' +#' @param x (`gtsummary`)\cr +#' A `'gtsummary'` object with a `'p.value'` column +#' @param thresholds (`numeric`)\cr +#' Thresholds for significance stars. Default is `c(0.001, 0.01, 0.05)` +#' @param hide_ci (scalar `logical`)\cr +#' logical whether to hide confidence interval. Default is `TRUE` +#' @param hide_p (scalar `logical`)\cr +#' logical whether to hide p-value. Default is `TRUE` for regression summaries, and `FALSE` otherwise. +#' @param hide_se (scalar `logical`)\cr +#' logical whether to hide standard error. Default is `FALSE` +#' @param pattern (`string`)\cr +#' glue-syntax string indicating what to display in formatted column. +#' Default is `"{estimate}{stars}"` for regression summaries and `"{p.value}{stars}"` otherwise. +#' A footnote is placed on the first column listed in the pattern. +#' Other common patterns are +#' `"{estimate}{stars} ({conf.low}, {conf.high})"` and +#' `"{estimate} ({conf.low} to {conf.high}){stars}"` +#' +#' @export +#' @return a 'gtsummary' table +#' +#' @examplesIf gtsummary:::is_pkg_installed("car", reference_pkg = "gtsummary") +#' tbl <- +#' lm(time ~ ph.ecog + sex, survival::lung) |> +#' tbl_regression(label = list(ph.ecog = "ECOG Score", sex = "Sex")) +#' +#' # Example 1 ---------------------------------- +#' tbl |> +#' add_significance_stars(hide_ci = FALSE, hide_p = FALSE) +#' +#' # Example 2 ---------------------------------- +#' tbl |> +#' add_significance_stars( +#' pattern = "{estimate} ({conf.low}, {conf.high}){stars}", +#' hide_ci = TRUE, hide_se = TRUE +#' ) |> +#' modify_header(estimate = "**Beta (95% CI)**") |> +#' modify_footnote(estimate = "CI = Confidence Interval", abbreviation = TRUE) +#' +#' # Example 3 ---------------------------------- +#' # Use ' \n' to put a line break between beta and SE +#' tbl |> +#' add_significance_stars( +#' hide_se = TRUE, +#' pattern = "{estimate}{stars} \n({std.error})" +#' ) |> +#' modify_header(estimate = "**Beta \n(SE)**") |> +#' modify_footnote(estimate = "SE = Standard Error", abbreviation = TRUE) |> +#' as_gt() |> +#' gt::fmt_markdown(columns = everything()) |> +#' gt::tab_style( +#' style = "vertical-align:top", +#' locations = gt::cells_body(columns = label) +#' ) +#' +#' # Example 4 ---------------------------------- +#' lm(marker ~ stage + grade, data = trial) |> +#' tbl_regression() |> +#' add_global_p() |> +#' add_significance_stars( +#' hide_p = FALSE, +#' pattern = "{p.value}{stars}" +#' ) +add_significance_stars <- function(x, + pattern = + ifelse( + inherits(x, c("tbl_regression", "tbl_uvregression")), + "{estimate}{stars}", + "{p.value}{stars}" + ), + thresholds = c(0.001, 0.01, 0.05), + hide_ci = TRUE, + hide_p = inherits(x, c("tbl_regression", "tbl_uvregression")), + hide_se = FALSE) { + get_cli_abort_call() + updated_call_list <- c(x$call_list, list(add_significance_stars = match.call())) + + # checking inputs ------------------------------------------------------------ + check_not_missing(x) + check_class(x, "gtsummary") + check_class(thresholds, "numeric") + check_range(thresholds, range = c(0, 1)) + check_scalar_logical(hide_ci) + check_scalar_logical(hide_p) + check_scalar_logical(hide_se) + if (!"p.value" %in% names(x$table_body)) { + cli::cli_abort( + "There is no p-value column in the table and significance stars cannot be placed.", + call = get_cli_abort_call() + ) + } + + # assign default pattern and footnote placement ------------------------------ + thresholds <- sort(thresholds, decreasing = TRUE) |> unique() + + pattern_cols <- .extract_glue_elements(pattern) + if (is_empty(pattern_cols)) { + cli::cli_abort( + "The {.arg pattern} argumnet must be a string using glue syntax to select columns.", + call = get_cli_abort_call() + ) + } + if (!"stars" %in% pattern_cols) { + cli::cli_inform("The {.arg pattern} argument does not contain {.val {{stars}}} column, and no stars will be added.") + } + + # adding footnote ------------------------------------------------------------ + p_footnote <- + paste0( + imap(thresholds, ~ rep_len("*", .y) %>% paste(collapse = "")), + "p<", + thresholds + ) |> + unlist() |> + paste(collapse = "; ") + + x <- modify_footnote(x, any_of(pattern_cols[1]) ~ p_footnote) + + # adding stars column -------------------------------------------------------- + thresholds <- union(thresholds, 0L) + expr_stars_case_when <- + map2( + thresholds, seq_along(thresholds), + ~ expr(p.value >= !!.x ~ !!paste(rep_len("*", .y - 1), collapse = "")) |> + expr_deparse() + ) %>% + reduce(.f = \(.x, .y) paste(.x, .y, sep = ", ")) %>% + {paste0("dplyr::case_when(is.na(p.value) ~ '', ", ., ")")} |> # styler: off + parse_expr() + + x <- modify_table_body(x, ~ .x |> dplyr::mutate(stars = !!expr_stars_case_when)) + + # updating hidden column status ---------------------------------------------- + cols_to_hide <- c(conf.low = hide_ci, p.value = hide_p, std.error = hide_se) + cols_to_hide <- cols_to_hide[c("conf.low", "p.value", "std.error") %in% names(x$table_body)] + x <- x |> + modify_table_styling( + columns = all_of(names(cols_to_hide)), + hide = cols_to_hide + ) + + # adding `cols_merge` to table styling --------------------------------------- + x <- x |> + modify_column_merge( + rows = !is.na(.data$p.value), + pattern = pattern + ) + + # return x ------------------------------------------------------------------- + # fill in the Ns in the header table modify_stat_* columns + x <- .fill_table_header_modify_stats(x) + x$call_list <- updated_call_list + x + +} diff --git a/man/add_significance_stars.Rd b/man/add_significance_stars.Rd new file mode 100644 index 0000000000..dd416567bd --- /dev/null +++ b/man/add_significance_stars.Rd @@ -0,0 +1,91 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_significance_stars.R +\name{add_significance_stars} +\alias{add_significance_stars} +\title{Add significance stars} +\usage{ +add_significance_stars( + x, + pattern = ifelse(inherits(x, c("tbl_regression", "tbl_uvregression")), + "{estimate}{stars}", "{p.value}{stars}"), + thresholds = c(0.001, 0.01, 0.05), + hide_ci = TRUE, + hide_p = inherits(x, c("tbl_regression", "tbl_uvregression")), + hide_se = FALSE +) +} +\arguments{ +\item{x}{(\code{gtsummary})\cr +A \code{'gtsummary'} object with a \code{'p.value'} column} + +\item{pattern}{(\code{string})\cr +glue-syntax string indicating what to display in formatted column. +Default is \code{"{estimate}{stars}"} for regression summaries and \code{"{p.value}{stars}"} otherwise. +A footnote is placed on the first column listed in the pattern. +Other common patterns are +\code{"{estimate}{stars} ({conf.low}, {conf.high})"} and +\code{"{estimate} ({conf.low} to {conf.high}){stars}"}} + +\item{thresholds}{(\code{numeric})\cr +Thresholds for significance stars. Default is \code{c(0.001, 0.01, 0.05)}} + +\item{hide_ci}{(scalar \code{logical})\cr +logical whether to hide confidence interval. Default is \code{TRUE}} + +\item{hide_p}{(scalar \code{logical})\cr +logical whether to hide p-value. Default is \code{TRUE} for regression summaries, and \code{FALSE} otherwise.} + +\item{hide_se}{(scalar \code{logical})\cr +logical whether to hide standard error. Default is \code{FALSE}} +} +\value{ +a 'gtsummary' table +} +\description{ +Add significance stars to estimates with small p-values +} +\examples{ +\dontshow{if (gtsummary:::is_pkg_installed("car", reference_pkg = "gtsummary")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +tbl <- + lm(time ~ ph.ecog + sex, survival::lung) |> + tbl_regression(label = list(ph.ecog = "ECOG Score", sex = "Sex")) + +# Example 1 ---------------------------------- +tbl |> + add_significance_stars(hide_ci = FALSE, hide_p = FALSE) + +# Example 2 ---------------------------------- +tbl |> + add_significance_stars( + pattern = "{estimate} ({conf.low}, {conf.high}){stars}", + hide_ci = TRUE, hide_se = TRUE + ) |> + modify_header(estimate = "**Beta (95\% CI)**") |> + modify_footnote(estimate = "CI = Confidence Interval", abbreviation = TRUE) + +# Example 3 ---------------------------------- +# Use ' \n' to put a line break between beta and SE +tbl |> + add_significance_stars( + hide_se = TRUE, + pattern = "{estimate}{stars} \n({std.error})" + ) |> + modify_header(estimate = "**Beta \n(SE)**") |> + modify_footnote(estimate = "SE = Standard Error", abbreviation = TRUE) |> + as_gt() |> + gt::fmt_markdown(columns = everything()) |> + gt::tab_style( + style = "vertical-align:top", + locations = gt::cells_body(columns = label) + ) + +# Example 4 ---------------------------------- +lm(marker ~ stage + grade, data = trial) |> + tbl_regression() |> + add_global_p() |> + add_significance_stars( + hide_p = FALSE, + pattern = "{p.value}{stars}" + ) +\dontshow{\}) # examplesIf} +} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index a4a67db82a..abe170d4ab 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -111,8 +111,8 @@ reference: - add_nevent.tbl_regression - combine_terms # - add_glance - # - add_q - # - add_significance_stars + - add_q + - add_significance_stars # - add_vif # - plot