修改gtsummary的显著性星号表示方式

编程语言 2026-07-09

请看下面的例子:

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

带自定义P值注释的模型摘要表

和我在另一条回答中一样,对于重复、缺失或其他无效的阈值/标签,并没有真正的健全性检查,当然这是可以很容易添加的。

函数代码
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导航站,无授权禁止任何主体转载、抄袭、复制内容,亦不得私自架设镜像站点。一经侵权,本站将通过法律途径追责。

相关文章