Добавление уравнения линии регрессии и R2 на графике

Question

Интересно, как добавить уравнение линии регрессии и R ^ 2 на ggplot. Мой код

library(ggplot2)
df <- data.frame(x = c(1:100))
df$y <- 2 + 3 * df$x + rnorm(100, sd = 40)
p <- ggplot(data = df, aes(x = x, y = y)) +
            geom_smooth(method = "lm", se=FALSE, color="black", formula = y ~ x) +
            geom_point()
p

Любая помощь будет высоко оценена.

Answer 1

Вот одно из решений

# GET EQUATION AND R-SQUARED AS STRING
# SOURCE: https://groups.google.com/forum/#!topic/ggplot2/1TgH-kG5XMA

lm_eqn <- function(df){
    m <- lm(y ~ x, df);
    eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2, 
         list(a = format(unname(coef(m)[1]), digits = 2),
              b = format(unname(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)

EDIT. Я выяснил источник, откуда я выбрал этот код. Вот ссылка на исходное сообщение в ggplot2 google groups

Answer 2

Я включил статистику stat_poly_eq() в свой пакет ggpmisc, который позволяет этот ответ:

library(ggplot2)
library(ggpmisc)
df <- data.frame(x = c(1:100))
df$y <- 2 + 3 * df$x + rnorm(100, sd = 40)
my.formula <- y ~ x
p <- ggplot(data = df, aes(x = x, y = y)) +
   geom_smooth(method = "lm", se=FALSE, color="black", formula = my.formula) +
   stat_poly_eq(formula = my.formula, 
                aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")), 
                parse = TRUE) +         
   geom_point()
p

Эта статистика работает с любым полиномом без пропущенных терминов и, надеюсь, обладает достаточной гибкостью, чтобы быть в целом полезной. Метки R ^ 2 или скорректированные метки R ^ 2 можно использовать с любой формулой модели, снабженной функцией lm (). Будучи статистикой ggplot, она ведет себя как ожидалось как с группами, так и с аспектами.

Пакет 'ggpmisc' доступен через CRAN.

Версия 0.2.6 была только что принята в CRAN.

В нем рассматриваются комментарии @shabbychef и @ MYaseen208.

@ MYaseen208 показывает, как добавить шляпу .

library(ggplot2)
library(ggpmisc)
df <- data.frame(x = c(1:100))
df$y <- 2 + 3 * df$x + rnorm(100, sd = 40)
my.formula <- y ~ x
p <- ggplot(data = df, aes(x = x, y = y)) +
   geom_smooth(method = "lm", se=FALSE, color="black", formula = my.formula) +
   stat_poly_eq(formula = my.formula,
                eq.with.lhs = "italic(hat(y))~`=`~",
                aes(label = paste(..eq.label.., ..rr.label.., sep = "~~~")), 
                parse = TRUE) +         
   geom_point()
p

@ shabbychef Теперь можно сопоставить переменные в уравнении с теми, которые используются для меток оси. Чтобы заменить x , скажем, z и y на h , можно использовать:

p <- ggplot(data = df, aes(x = x, y = y)) +
   geom_smooth(method = "lm", se=FALSE, color="black", formula = my.formula) +
   stat_poly_eq(formula = my.formula,
                eq.with.lhs = "italic(h)~`=`~",
                eq.x.rhs = "~italic(z)",
                aes(label = ..eq.label..), 
                parse = TRUE) + 
   labs(x = expression(italic(z)), y = expression(italic(h))) +          
   geom_point()
p

Будучи этими нормальными R-разобранными выражениями, греческие буквы теперь могут также использоваться как в lhs, так и в rhs уравнения.

[2017-03-08] @elarry Отредактируйте, чтобы более точно ответить на исходный вопрос и показать, как добавить запятую между метками уравнения и R2.

p <- ggplot(data = df, aes(x = x, y = y)) +
  geom_smooth(method = "lm", se=FALSE, color="black", formula = my.formula) +
  stat_poly_eq(formula = my.formula,
               eq.with.lhs = "italic(hat(y))~`=`~",
               aes(label = paste(..eq.label.., ..rr.label.., sep = "*plain(\",\")~")), 
               parse = TRUE) +         
  geom_point()
p

Answer 3

Я изменил несколько строк источника stat_smooth и связанных функций, чтобы создать новую функцию, которая добавляет уравнение соответствия и значение R в квадрате. Это будет работать и на фасетных участках!

library(devtools)
source_gist("524eade46135f6348140")
df = data.frame(x = c(1:100))
df$y = 2 + 5 * df$x + rnorm(100, sd = 40)
df$class = rep(1:2,50)
ggplot(data = df, aes(x = x, y = y, label=y)) +
  stat_smooth_func(geom="text",method="lm",hjust=0,parse=TRUE) +
  geom_smooth(method="lm",se=FALSE) +
  geom_point() + facet_wrap(~class)

Я использовал код в ответе @ Ramnath для форматирования уравнения. Функция stat_smooth_func не очень надежна, но с ней не составит труда поиграть.

https://gist.github.com/kdauria/524eade46135f6348140. Попробуйте обновить ggplot2, если вы получили ошибку.

Answer 4

Я изменил сообщение Рамната на а) сделать более универсальным, чтобы он принимал линейную модель в качестве параметра, а не фрейм данных, и б) отображал негативы более подходящим образом.

lm_eqn = function(m) {

  l <- list(a = format(coef(m)[1], digits = 2),
      b = format(abs(coef(m)[2]), digits = 2),
      r2 = format(summary(m)$r.squared, digits = 3));

  if (coef(m)[2] >= 0)  {
    eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(r)^2~"="~r2,l)
  } else {
    eq <- substitute(italic(y) == a - b %.% italic(x)*","~~italic(r)^2~"="~r2,l)    
  }

  as.character(as.expression(eq));                 
}

Использование изменилось бы на:

p1 = p + geom_text(aes(x = 25, y = 300, label = lm_eqn(lm(y ~ x, df))), parse = TRUE)

Answer 5

действительно люблю решение @Ramnath.Чтобы разрешить использование для настройки формулы регрессии (вместо того, чтобы фиксировать как y и x как литеральные имена переменных), а также добавить значение p в распечатку (как прокомментировал @Jerry T), вот мод:

lm_eqn <- function(df, y, x){
    formula = as.formula(sprintf('%s ~ %s', y, x))
    m <- lm(formula, data=df);
    # formating the values into a summary string to print out
    # ~ give some space, but equal size and comma need to be quoted
    eq <- substitute(italic(target) == a + b %.% italic(input)*","~~italic(r)^2~"="~r2*","~~p~"="~italic(pvalue), 
         list(target = y,
              input = x,
              a = format(as.vector(coef(m)[1]), digits = 2), 
              b = format(as.vector(coef(m)[2]), digits = 2), 
             r2 = format(summary(m)$r.squared, digits = 3),
             # getting the pvalue is painful
             pvalue = format(summary(m)$coefficients[2,'Pr(>|t|)'], digits=1)
            )
          )
    as.character(as.expression(eq));                 
}

geom_point() +
  ggrepel::geom_text_repel(label=rownames(mtcars)) +
  geom_text(x=3,y=300,label=lm_eqn(mtcars, 'hp','wt'),color='red',parse=T) +
  geom_smooth(method='lm')

К сожалению, это не работает с facet_wrap или facet_grid.

Answer 6

Вдохновленный стилем уравнения, представленным в этом ответе , более общий подход (более одного предиктора + вывод латекса в качестве опции) может быть:

print_equation= function(model, latex= FALSE, ...){
    dots <- list(...)
    cc= model$coefficients
    var_sign= as.character(sign(cc[-1]))%>%gsub("1","",.)%>%gsub("-"," - ",.)
    var_sign[var_sign==""]= ' + '

    f_args_abs= f_args= dots
    f_args$x= cc
    f_args_abs$x= abs(cc)
    cc_= do.call(format, args= f_args)
    cc_abs= do.call(format, args= f_args_abs)
    pred_vars=
        cc_abs%>%
        paste(., x_vars, sep= star)%>%
        paste(var_sign,.)%>%paste(., collapse= "")

    if(latex){
        star= " \\cdot "
        y_var= strsplit(as.character(model$call$formula), "~")[[2]]%>%
            paste0("\\hat{",.,"_{i}}")
        x_vars= names(cc_)[-1]%>%paste0(.,"_{i}")
    }else{
        star= " * "
        y_var= strsplit(as.character(model$call$formula), "~")[[2]]        
        x_vars= names(cc_)[-1]
    }

    equ= paste(y_var,"=",cc_[1],pred_vars)
    if(latex){
        equ= paste0(equ," + \\hat{\\varepsilon_{i}} \\quad where \\quad \\varepsilon \\sim \\mathcal{N}(0,",
                    summary(MetamodelKdifEryth)$sigma,")")%>%paste0("$",.,"$")
    }
    cat(equ)
}

modelАргумент ожидает объект lm, аргумент latex - логическое значение, запрашивающее простой символ или уравнение с латексным форматом, а аргумент ... передает свои значения в функцию format.

Я также добавил опцию для вывода его в виде латекса, чтобы вы могли использовать эту функцию в rmarkdown следующим образом:

```{r echo=FALSE, results='asis'}
print_equation(model = lm_mod, latex = TRUE)
```

---

Теперь используя его:

df <- data.frame(x = c(1:100))
df$y <- 2 + 3 * df$x + rnorm(100, sd = 40)
df$z <- 8 + 3 * df$x + rnorm(100, sd = 40)
lm_mod= lm(y~x+z, data = df)

print_equation(model = lm_mod, latex = FALSE)

Этот кодвыход: y = 11.3382963933174 + 2.5893419 * x + 0.1002227 * z

И если мы попросим уравнение латекса, округляем параметры до 3 цифр:

print_equation(model = lm_mod, latex = TRUE, digits= 3)

Это дает: