在 ggpmisc 和 ggplot 中使用 stat_fit_tb() 时编辑表格显示的 *row* 名称答案

【问题标题】：Editing *row* names of tabular display when using stat_fit_tb() in ggpmisc & ggplot在 ggpmisc 和 ggplot 中使用 stat_fit_tb() 时编辑表格显示的 *row* 名称
【发布时间】：2021-02-16 06:41:07
【问题描述】：

虽然stat_poly_eq() 允许使用eq.with.lhs 和eq.x.rhs 更改变量名称，但根据我对ggpmisc 的阅读，stat_fit_tb() 中似乎没有类似的功能文档。

有没有办法修改以下示例中的plt 对象，以强制表格显示显示参数名称，使其更直观且与方程和轴标签更一致？

## dummy data
set.seed(1)
df <- data.frame(month = c(1:60))
df$observed <- 2.5 + 0.05*df$month + rnorm(60, sd = 1)

## min plot example
my.formula <- y ~ poly(x,2,raw=TRUE) ## formula with generic variable names

plt <- ggplot(df, aes(x=month, y=observed)) +
  geom_point() +
  ## show fit and CI
  geom_smooth(method = "lm", se=TRUE, level=0.95, formula = my.formula) +
  ## display equation with useful variable names (i.e. not x and y)
  stat_poly_eq(eq.with.lhs = "italic(Obs)~`=`~",
               eq.x.rhs = ".month",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")), 
               parse = TRUE,
               formula = my.formula, label.y = 0.9) +
  ## show table of each coefficient's p-value
  stat_fit_tb(method.args = list(formula = my.formula),
              tb.vars = c(parameter = "term", ## can change column headings
                          coeff = "estimate", 
                          "p-val" = "p.value"),
              label.y = 0.8, label.x = "left")

plt

【问题讨论】：

这是我应该添加到下一个版本的 'ggpmisc' 中的内容。同时，在下面的回答中，我展示了实现此目的的技巧。
现在可以在 Bitbucket 中使用，几周后将发布为 'ggpmisc' 0.3.7。
现在在 CRAN。在周末准备好更新。请参阅下面的新答案。

标签： r ggplot2 ggpmisc

【解决方案1】：

这可能会在将plt 转换为 grob 对象后被破解，但现在我喜欢一次性解决问题并完成它，所以我改为破解了底层的 ggproto 对象。

运行以下代码（对原始代码的更改以 cmets 表示）：

library(ggpmisc)

StatFitTb2 <- ggproto(
  "StatFitTb2",
  StatFitTb,
  compute_panel = function (data, scales, method, method.args, tb.type, tb.vars, 
                            tb.row.names, digits, npc.used = TRUE, label.x, label.y) {
    force(data)
    if (length(unique(data$x)) < 2) {
      return(data.frame())
    }
    panel.idx <- as.integer(as.character(data$PANEL[1]))
    if (length(label.x) >= panel.idx) {
      label.x <- label.x[panel.idx]
    }
    else if (length(label.x) > 0) {
      label.x <- label.x[1]
    }
    if (length(label.y) >= panel.idx) {
      label.y <- label.y[panel.idx]
    }
    else if (length(label.y) > 0) {
      label.y <- label.y[1]
    }
    method.args <- c(method.args, list(data = quote(data)))
    if (is.character(method)) 
      method <- match.fun(method)
    mf <- do.call(method, method.args)
    if (tolower(tb.type) %in% c("fit.anova", "anova")) {
      mf_tb <- broom::tidy(stats::anova(mf))
    }
    else if (tolower(tb.type) %in% c("fit.summary", "summary")) {
      mf_tb <- broom::tidy(mf)
    }
    else if (tolower(tb.type) %in% c("fit.coefs", "coefs")) {
      mf_tb <- broom::tidy(mf)[c("term", "estimate")]
    }
    num.cols <- sapply(mf_tb, is.numeric)
    mf_tb[num.cols] <- signif(mf_tb[num.cols], digits = digits)
    if (!is.null(tb.vars)) {
      mf_tb <- dplyr::select(mf_tb, !!tb.vars)
    }
    
    # new condition for modifying row names, if they are specified
    if(!is.null(tb.row.names)) {
      mf_tb[, 1] <- tb.row.names
    }
    
    z <- tibble::tibble(mf_tb = list(mf_tb))
    if (npc.used) {
      margin.npc <- 0.05
    }
    else {
      margin.npc <- 0
    }
    if (is.character(label.x)) {
      label.x <- switch(label.x, right = (1 - margin.npc), 
                        center = 0.5, centre = 0.5, 
                        middle = 0.5, left = (0 + margin.npc))
      if (!npc.used) {
        x.delta <- abs(diff(range(data$x)))
        x.min <- min(data$x)
        label.x <- label.x * x.delta + x.min
      }
    }
    if (is.character(label.y)) {
      label.y <- switch(label.y, top = (1 - margin.npc), center = 0.5, 
                        centre = 0.5, middle = 0.5, bottom = (0 + margin.npc))
      if (!npc.used) {
        y.delta <- abs(diff(range(data$y)))
        y.min <- min(data$y)
        label.y <- label.y * y.delta + y.min
      }
    }
    if (npc.used) {
      z$npcx <- label.x
      z$x <- NA_real_
      z$npcy <- label.y
      z$y <- NA_real_
    }
    else {
      z$x <- label.x
      z$npcx <- NA_real_
      z$y <- label.y
      z$npcy <- NA_real_
    }
    z
  })

stat_fit_tb2 <- function(mapping = NULL, data = NULL, geom = "table_npc",
                         method = "lm", method.args = list(formula = y ~ x), 
                         tb.type = "fit.summary", tb.vars = NULL, digits = 3, 
                         tb.row.names = NULL, # new parameter for row names (defaults to NULL)
                         label.x = "center", label.y = "top", label.x.npc = NULL, 
                         label.y.npc = NULL, position = "identity", table.theme = NULL, 
                         table.rownames = FALSE, table.colnames = TRUE, table.hjust = 1, 
                         parse = FALSE, na.rm = FALSE, show.legend = FALSE, inherit.aes = TRUE, 
                         ...) {
  if (!is.null(label.x.npc)) {
    stopifnot(grepl("_npc", geom))
    label.x <- label.x.npc
  }
  if (!is.null(label.y.npc)) {
    stopifnot(grepl("_npc", geom))
    label.y <- label.y.npc
  }
  ggplot2::layer(stat = StatFitTb2, # reference modified StatFitTb2 instead of the original
                 data = data, mapping = mapping, 
                 geom = geom, position = position, show.legend = show.legend, 
                 inherit.aes = inherit.aes, 
                 params = list(method = method, method.args = method.args, 
                               tb.type = tb.type, tb.vars = tb.vars, 
                               tb.row.names = tb.row.names, # new parameter here
                               digits = digits, label.x = label.x, label.y = label.y, 
                               npc.used = grepl("_npc", geom), table.theme = table.theme, 
                               table.rownames = table.rownames, table.colnames = table.colnames, 
                               table.hjust = table.hjust, parse = parse, na.rm = na.rm, 
                               ...))
}

用法：

ggplot(df, aes(x=month, y=observed)) +
  geom_point() +
  ## show fit and CI
  geom_smooth(method = "lm", se=TRUE, level=0.95, formula = my.formula) +
  ## display equation with useful variable names (i.e. not x and y)
  stat_poly_eq(eq.with.lhs = "italic(Obs)~`=`~",
               eq.x.rhs = ".month",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")), 
               parse = TRUE,
               formula = my.formula, label.y = 0.9) +
  ## show table of each coefficient's p-value
  stat_fit_tb2(method.args = list(formula = my.formula),
              tb.vars = c(parameter = "term", ## can change column headings
                          coeff = "estimate", 
                          "p-val" = "p.value"),
              tb.row.names = c("(Intercept)", "month", "month^2"),
              label.y = 0.8, label.x = "left", parse = TRUE)

注意：parse = TRUE 使 month^2 行名称看起来更好，但它也会影响表中的所有其他值（例如，p 值的破折号变成减号，数字四舍五入到不同的位数等.)

【讨论】：

谢谢！我将此代码添加到包中。如果您在 Bitbucket 中提出拉取请求或只是将您的批准（如果您愿意，请私下发送到维护者地址）发送给我（ORCID 和电子邮件地址），我会将您添加为贡献者。
@PedroAphalo 很高兴您发现这很有用 :) 请前往使用代码。我认为它在CC BY-SA 4.0 下涵盖，就像这些天在 SO 上的所有新答案一样。

【解决方案2】：

注意：如果您仍在使用 'ggpmisc' (= 0.3.7) 查看单独的答案。

在将它内置到包中之前，一个相当简单的技巧是在 aes() 中动态编辑 tibble。我先定义一个函数，以免代码混乱。

library(ggpmisc)

## dummy data
set.seed(1)
df <- data.frame(month = c(1:60))
df$observed <- 2.5 + 0.05*df$month + rnorm(60, sd = 1)

## min plot example
my.formula <- y ~ poly(x,2,raw=TRUE) ## formula with generic variable names

## define function for renaming parameters in tibble(s) returned by the stat
## walk through the list an operate on all the tibbles found so that
## grouping and facets are also supported.
set_param_names <- function(x, names) {
  for (i in seq_along(x)) {
   x[[i]][[1]] <- names
  }
  x
}

plt <- ggplot(df, aes(x=month, y=observed)) +
  geom_point() +
  ## show fit and CI
  geom_smooth(method = "lm", se=TRUE, level=0.95, formula = my.formula) +
  ## display equation with useful variable names (i.e. not x and y)
  stat_poly_eq(eq.with.lhs = "italic(Obs)~`=`~",
               eq.x.rhs = ".month",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")), 
               parse = TRUE,
               formula = my.formula, label.y = 0.9) +
  ## show table of each coefficient's p-value
  stat_fit_tb(method.args = list(formula = my.formula),
              tb.vars = c(parameter = "term", ## can change column headings
                          coeff = "estimate", 
                          "p-val" = "p.value"),
              label.y = 0.8, label.x = "left",
              aes(label = set_param_names(stat(mf_tb), 
                                          c("intercept", "month", "month^2"))),
              parse = TRUE)

plt

这给出了：

【讨论】：

小标题嵌套在列表中。尽管我是作者，但我还是使用了“gginnards”包中的geom_debug() 来快速检查stat_fit_tb() 统计数据返回的数据的名称和结构。此调试几何可用于任何 ggplot 统计数据。
Pedro - 对于构面，初始函数需要命名列表中的每个小标题。就目前而言，表格最终会在每个图表上重复。
@BigOldDave 感谢您指出这一点！我在答案中编辑了set_param_names() 的定义，以便它可以与构面一起正常工作。

【解决方案3】：

更新后的 'ggpmisc' (>= 0.3.7) 使这个答案成为可能，在我看来应该是首选。

## ggpmisc (>= 0.3.7)
library(ggpmisc)

## dummy data
set.seed(1)
df <- data.frame(month = c(1:60))
df$observed <- 2.5 + 0.05*df$month + rnorm(60, sd = 1)

## min plot example
my.formula <- y ~ poly(x,2,raw=TRUE) ## formula with generic variable names

plt <- ggplot(df, aes(x=month, y=observed)) +
  geom_point() +
  ## show fit and CI
  geom_smooth(method = "lm", se=TRUE, level=0.95, formula = my.formula) +
  ## display equation with useful variable names (i.e. not x and y)
  stat_poly_eq(eq.with.lhs = "italic(Obs)~`=`~",
               eq.x.rhs = '" month"',
               aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")),
               parse = TRUE,
               formula = my.formula, label.y = 0.9) +
  ## show table of each coefficient's p-value
  stat_fit_tb(method.args = list(formula = my.formula),
              tb.vars = c(parameter = "term", ## can change column headings
                          coeff = "estimate",
                          "p-val" = "p.value"),
              tb.params = c(1, month = 2, "month^2" = 3), ##
              label.y = 0.8, label.x = "left",
              parse = TRUE)

plt

给出以下情节。（我也确实将参数更改为eq.x.rhs，尽管不是问题的直接部分。P-values 的更好格式是在新版本的 'ggpmisc' 包中实现的。） p>

【讨论】：

谢谢！我确实喜欢汇总表的 p 值四舍五入（....我知道其他人会不同意）。在您的下一个版本中，您可能希望抑制多面的“删除列...”消息。当我尝试 tb.vars = c(coeff = "estimate", "p-val" = "p.value") 时，我遇到了一个制表错误，即只有这些列的较小的表，尽管当有一个不同的错误时tb.params = c(intercept = 1, ...).
@BigOldDave “删除列...”是 R 消息，因此可以通过将代码包含在 suppressMessages() 中来使它们静音。在 Rmarkdown 块中，您可以使用 message=FALSE 来抑制它们。在下一个版本中，我将为此实现自己的选项。我认为由于界面有点不寻常，最好警告用户列正在被删除，但我以后可能会改变主意。
@BigOldDave 删除 tb.params 预期修改的列时会发生制表错误，因为在重命名参数之前已删除列。可能最简单的解决方案是在下一个版本的代码中更改这两个操作的顺序......一个永远不会做足够的测试......！感谢您报告此事！
@BigOldDave 再次感谢！我决定修复代码而不是提出问题来提醒自己。您报告的错误现在通过消息处理。现在仅当删除的列是具有参数名称的列时才会发出删除列消息，我不希望许多用户想要删除它。如果删除行，也会触发消息，因为这似乎又不是明智的做法。用户现在可以禁用 p 值的四舍五入，并且还可以设置位数。这些更改现已推送到 Bitbucket。