r - 在 SEPARATE LINES 图上添加回归线方程和 R2

Question

几年前，一位发帖人在下面的链接中询问如何在 ggplot 图上添加回归线方程和 R2。

在图上添加回归线方程和 R2

最佳解决方案是：

lm_eqn <- function(df){
    m <- lm(y ~ x, df);
    eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2, 
         list(a = format(coef(m)[1], digits = 2), 
              b = format(coef(m)[2], digits = 2), 
             r2 = format(summary(m)$r.squared, digits = 3)))
    as.character(as.expression(eq));                 
}

p1 <- p + geom_text(x = 25, y = 300, label = lm_eqn(df), parse = TRUE)

我正在使用这段代码，效果很好。但是，我想知道是否有可能使此代码在单独的行上具有 R2 值和回归线方程，而不是用逗号分隔。

而不是这样

像这样的东西

在此先感谢您的帮助！

Answer 1

ggpmisc包具有stat_poly_eq专门为此任务构建的功能（但不限于线性回归）。使用与data@Sathish 发布的相同，我们可以分别添加方程和 R2，但给出label.y.npc不同的值。label.x.npc如果需要可以调节。

library(ggplot2)
library(ggpmisc)
#> For news about 'ggpmisc', please, see https://www.r4photobiology.info/

set.seed(21318)
df <- data.frame(x = c(1:100))
df$y <- 2 + 3*df$x + rnorm(100, sd = 40)

formula1 <- y ~ x

ggplot(data = df, aes(x = x, y = y)) +
  geom_point() +
  geom_smooth(method = "lm", se = FALSE, formula = formula1) +
  stat_poly_eq(aes(label = paste(..eq.label.., sep = "~~~")), 
               label.x.npc = "right", label.y.npc = 0.15,
               eq.with.lhs = "italic(hat(y))~`=`~",
               eq.x.rhs = "~italic(x)",
               formula = formula1, parse = TRUE, size = 5) +
  stat_poly_eq(aes(label = paste(..rr.label.., sep = "~~~")), 
               label.x.npc = "right", label.y.npc = "bottom",
               formula = formula1, parse = TRUE, size = 5) +
  theme_bw(base_size = 16)

# using `atop`
ggplot(data = df, aes(x = x, y = y)) +
  geom_point() +
  geom_smooth(method = "lm", se = FALSE, formula = formula1) +
  stat_poly_eq(aes(label = paste0("atop(", ..eq.label.., ",", ..rr.label.., ")")), 
               formula = formula1, 
               parse = TRUE) +
  theme_bw(base_size = 16)

### bonus: including result table
ggplot(data = df, aes(x = x, y = y)) +
  geom_point() +
  geom_smooth(method = "lm", se = FALSE, formula = formula1) +
  stat_fit_tb(method = "lm",
              method.args = list(formula = formula1),
              tb.vars = c(Parameter = "term", 
                          Estimate = "estimate", 
                          "s.e." = "std.error", 
                          "italic(t)" = "statistic", 
                          "italic(P)" = "p.value"),
              label.y = "bottom", label.x = "right",
              parse = TRUE) +
  stat_poly_eq(aes(label = paste0("atop(", ..eq.label.., ",", ..rr.label.., ")")), 
               formula = formula1, 
               parse = TRUE) +
  theme_bw(base_size = 16)

^{由reprex 包创建(v0.3.0)}

Answer 2

编辑：

除了插入方程之外，我还修复了截距值的符号。通过将 RNG 设置为set.seed(2L)将给出正截距。下面的示例产生负截距。

我还修复了重叠的文本geom_text

set.seed(3L)
library(ggplot2)
df <- data.frame(x = c(1:100))
df$y <- 2 + 3 * df$x + rnorm(100, sd = 40)

lm_eqn <- function(df){
  # browser()
  m <- lm(y ~ x, df)
  a <- coef(m)[1]
  a <- ifelse(sign(a) >= 0, 
              paste0(" + ", format(a, digits = 4)), 
              paste0(" - ", format(-a, digits = 4))  )
  eq1 <- substitute( paste( italic(y) == b, italic(x), a ), 
                     list(a = a, 
                          b = format(coef(m)[2], digits = 4)))
  eq2 <- substitute( paste( italic(R)^2 == r2 ), 
                     list(r2 = format(summary(m)$r.squared, digits = 3)))
  c( as.character(as.expression(eq1)), as.character(as.expression(eq2)))
}

labels <- lm_eqn(df)


p <- ggplot(data = df, aes(x = x, y = y)) +
  geom_smooth(method = "lm", se=FALSE, color="red", formula = y ~ x) +
  geom_point() +
  geom_text(x = 75, y = 90, label = labels[1], parse = TRUE,  check_overlap = TRUE ) +
  geom_text(x = 75, y = 70, label = labels[2], parse = TRUE, check_overlap = TRUE )

print(p)