修改gtsummary的显著性星号表示方式
请看下面的例子:
library(gtsummary)
lm(marker ~ stage + grade, data = trial) |>
tbl_regression() |>
add_global_p() |>
add_significance_stars(
hide_p = FALSE,
pattern = "{p.value}{stars}"
)
得到的结果是:

我该如何把gtsummary使用的约定改成,例如:
* p<0.1, + p<0.05; ++ p<0.01; +++ p<0.001
关于 add_significance_stars 的文档包含一个参数thresholds,用来改变阈值,但始终使用星号 *。
如果再增加一个阈值,最多会得到4 个星号。
解决方案
这基本上与这里描述的问题相同,只是针对 gtsummary 而不是 sjPlot。星号标签在 add_significance_stars 的多处地方都是[硬编码]的,因此你要么需要对输出进行后处理,要么重写该函数。
幸运的是,在 gtsummary 的情况下,这样的重写比 sjPlot 时要容易得多,只需要修改原始代码的几行。我下面将粘贴函数代码,关键的变化是 thresholds= 现在是一个带名称的向量,其名称指定标签:
data("trial", package="gtsummary")
lm(marker ~ stage + grade, data = trial) |>
gtsummary::tbl_regression() |>
gtsummary::add_global_p() |>
my_add_significance_stars(
hide_p = FALSE,
pattern = "{p.value}{stars}",
thresholds = c("+++"=0.001, "++"=0.01, "+"=0.05, "*"=0.1)
)
和我在另一条回答中一样,对于重复、缺失或其他无效的阈值/标签,并没有真正的健全性检查,当然这是可以很容易添加的。
函数代码
my_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
) {
`%>%` <- magrittr::`%>%`
gtsummary:::get_cli_abort_call()
updated_call_list <- c(x$call_list, list(my_add_significance_stars = match.call()))
# checking inputs ------------------------------------------------------------
gtsummary:::check_not_missing(x)
gtsummary:::check_class(x, "gtsummary")
gtsummary:::check_class(thresholds, c("numeric", "integer"))
gtsummary:::check_range(thresholds, range = c(0, 1), include_bounds = c(TRUE, TRUE))
gtsummary:::check_scalar_logical(hide_ci)
gtsummary:::check_scalar_logical(hide_p)
gtsummary:::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 = gtsummary:::get_cli_abort_call()
)
}
# assign default pattern and footnote placement ------------------------------
ord <- order(thresholds, decreasing=TRUE)[!duplicated(thresholds)]
sym <- names(thresholds)[ord]
thr <- thresholds[ord]
pattern_cols <- gtsummary:::.extract_glue_elements(pattern)
if (rlang::is_empty(pattern_cols)) {
cli::cli_abort(
"The {.arg pattern} argumnet must be a string using glue syntax to select columns.",
call = gtsummary:::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(sym, "p<", thr) |>
unlist() |>
paste(collapse = "; ")
x <- gtsummary:::modify_footnote_header(x, footnote = p_footnote, columns = any_of(pattern_cols[1]), replace = FALSE)
# adding stars column --------------------------------------------------------
thr <- union(thr, 0L)
sym <- union("", sym)
expr_stars_case_when <-
gtsummary:::map2(
thr, seq_along(thr),
~ rlang::expr(p.value >= !!.x ~ !!sym[.y]) |>
rlang::expr_deparse()
) %>%
gtsummary:::reduce(.f = \(.x, .y) paste(.x, .y, sep = ", ")) %>%
{paste0("dplyr::case_when(is.na(p.value) ~ '', ", ., ")")} |> # styler: off
rlang::parse_expr()
x <- gtsummary:::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 |>
gtsummary:::modify_table_styling(
columns = tidyselect::all_of(names(cols_to_hide)),
hide = cols_to_hide
)
# adding `cols_merge` to table styling ---------------------------------------
x <- x |>
gtsummary:::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 <- gtsummary:::.fill_table_header_modify_stats(x)
x$call_list <- updated_call_list
x
}
站内所有文章版权归属LeftHeroAI导航站,无授权禁止任何主体转载、抄袭、复制内容,亦不得私自架设镜像站点。一经侵权,本站将通过法律途径追责。
