web-dev-qa-db-ja.com

グラフに回帰直線式とR2を追加

回帰直線式と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

任意の助けは非常に高く評価されます。

rggplot2ggpmisc
200
MYaseen208

これが一つの解決策です

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

編集します。私はこのコードを選んだところからソースを見つけました。これが、ggplot2 googleグループの元の投稿への link です。

Output

213
Ramnath

私は私のパッケージに統計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

enter image description here

この統計は、項が欠落していない任意の多項式で機能し、一般的に有用であるのに十分な柔軟性を持っていることを願っています。 R ^ 2または調整されたR ^ 2ラベルは、lm（）を適用した任意のモデル式で使用できます。 ggplot統計であるため、グループとファセットの両方で期待通りに動作します。

'ggpmisc'パッケージはCRANを通して利用可能です。

バージョン0.2.6がCRANに受け入れられました。

@shabbychefと@ MYaseen208によるコメントを扱います。

@ MYaseen208これはhatを追加する方法を示しています。

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

enter image description here

@shabbychefこれで、方程式内の変数を軸ラベルに使用されているものと一致させることができます。 xをsay 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

enter image description here

これらの通常の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

enter image description here

95
Pedro Aphalo

stat_smoothのソースと関連関数の数行を変更して、フィット方程式とRの2乗値を追加する新しい関数を作成しました。これはファセットプロットでも機能します。

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)

enter image description here

式をフォーマットするために@ Ramnathの答えのコードを使用しました。 stat_smooth_func関数はそれほど堅牢ではありませんが、それを使って遊ぶのは難しくありません。

https://Gist.github.com/kdauria/524eade46135f634814 。エラーが発生した場合はggplot2を更新してみてください。

94
kdauria

Ramnathの投稿をa）より一般的なものに変更したので、データフレームではなく線形モデルをパラメータとして受け入れ、b）負の値をより適切に表示します。

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

@Ramnathソリューションが大好きです。回帰式をカスタマイズして（リテラル変数名としてyおよびxに固定する代わりに）使用できるようにし、（@ Jerry Tがコメントしたように）同様にp値を出力に追加します。

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

enter image description here 残念ながら、これはfacet_wrapやfacet_gridでは動作しません。

5
X.X

この答え で提供されている方程式スタイルに触発されて、より一般的なアプローチ（オプションとして複数の予測子+ラテックス出力）は以下のようになります。

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)

これは次のようになります。 latex equation

1
rvezy