如何使用 R 在校准图中添加黄土线、斜率和截距？

Posted 2023-02-14

【中文标题】如何使用 R 在校准图中添加黄土线、斜率和截距？

【英文标题】：How to add the loess line, slope and intercept in Calibration plot using R?

【发布时间】：2022-01-03 05:59:10

【问题描述】：

我想将黄土线、斜率和截距值添加到校准图中，如下例所示：

能否请您解释一下如何在底部“理想、非参数...”中添加这些信息：斜率、截距、图例？

我的代码如下：

Y <- c(0.4733333, 0.5133333, 0.5400000, 0.5066667, 0.4400000, 0.4733333, 0.4733333, 0.4600000, 0.3933333, 0.5000000, 0.5533333, 0.6266667, 0.5600000, 0.5800000, 0.6000000, 0.5133333, 0.5066667, 0.5933333, 0.5533333, 0.5266667, 0.6800000, 0.6400000, 0.6333333, 0.7266667, 0.6200000, 0.6400000, 0.6200000, 0.7266667, 0.5800000, 0.6066667, 0.6400000, 0.6600000, 0.6066667, 0.6400000, 0.6600000, 0.7266667, 0.6266667, 0.6933333, 0.7000000, 0.7266667, 0.6866667, 0.6933333, 0.6733333, 0.7666667, 0.7200000, 0.6733333, 0.7666667, 0.7266667, 0.6733333, 0.6733333, 0.7133333, 0.6800000, 0.6733333, 0.6866667, 0.7466667, 0.7533333, 0.7200000, 0.7066667, 0.7533333, 0.7933333, 0.8000000, 0.7466667, 0.7466667, 0.7133333, 0.8133333,
               0.7400000, 0.7666667, 0.6866667, 0.7933333, 0.6866667, 0.7533333, 0.7266667, 0.7533333, 0.7866667, 0.8000000, 0.8200000, 0.7600000, 0.7266667, 0.8200000, 0.8333333, 0.8066667, 0.8533333, 0.7600000, 0.8200000, 0.7600000, 0.8333333, 0.8066667, 0.8333333, 0.7733333, 0.8333333, 0.8600000, 0.8133333, 0.8466667, 0.8266667, 0.8533333, 0.8733333, 0.8666667, 0.8400000, 0.8200000, 0.7866667)

X <- c(0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150,
                0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 
                0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 
                0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 
                0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 
                0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 
                0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 
                0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 
                0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 
                0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516)
attr(X, "names") = rep(as.character(0:9),each = 10)
gr <- rep(1:10,each = 10)
DATA=data.frame(Y,X,gr)
DATA$x2 = as.numeric(as.character(DATA$X))
cols = c("Reference"="gray70","Lowess" = "royalblue3" ,"Grouped"="darkorange2")

ggplot(DATA, aes(x2,Y, group = gr))+ 
  xlim(0,1)+
  ylim(0,1)+
  geom_boxplot()+
  geom_smooth(method = "loess", se=FALSE, aes(group=1, colour ="Lowess"),size=0.8)+
  geom_abline(aes(slope = 1, intercept = 0,colour= "Reference"),linetype=2)+
  theme_light()+  
  theme(legend.position = c(.97, .1),
        legend.justification = c("right", "bottom"),
        legend.box.just = "right",
        legend.margin = margin(6, 6, 6, 6))+
  labs(title="Calibration plot",
       x ="Predicted values",
       y = "Observed values")+
  stat_summary(aes(group=X, colour = "Grouped"),fun.y=function(x)mean(x, na.rm = T), 
               geom="point", shape=23)+
  scale_colour_manual(name="",values=cols)+
  scale_shape_manual(values=c(23, 32, 1))

我得到以下图表：

红色圆圈代表平均值，我想添加这些点的截距和斜率 (y = a + bx)。以及通过箱线图中位数的曲线。我也有图例的形状与红色菱形、实线和虚线不匹配的问题。

尊敬的，

【参考方案1】：

也许这就是你要找的。​​p>

library(ggplot2)
library(dplyr)

Y <- c(0.4733333, 0.5133333, 0.5400000, 0.5066667, 0.4400000, 0.4733333, 0.4733333, 0.4600000, 0.3933333, 0.5000000, 0.5533333, 0.6266667, 0.5600000, 0.5800000, 0.6000000, 0.5133333, 0.5066667, 0.5933333, 0.5533333, 0.5266667, 0.6800000, 0.6400000, 0.6333333, 0.7266667, 0.6200000, 0.6400000, 0.6200000, 0.7266667, 0.5800000, 0.6066667, 0.6400000, 0.6600000, 0.6066667, 0.6400000, 0.6600000, 0.7266667, 0.6266667, 0.6933333, 0.7000000, 0.7266667, 0.6866667, 0.6933333, 0.6733333, 0.7666667, 0.7200000, 0.6733333, 0.7666667, 0.7266667, 0.6733333, 0.6733333, 0.7133333, 0.6800000, 0.6733333, 0.6866667, 0.7466667, 0.7533333, 0.7200000, 0.7066667, 0.7533333, 0.7933333, 0.8000000, 0.7466667, 0.7466667, 0.7133333, 0.8133333,
               0.7400000, 0.7666667, 0.6866667, 0.7933333, 0.6866667, 0.7533333, 0.7266667, 0.7533333, 0.7866667, 0.8000000, 0.8200000, 0.7600000, 0.7266667, 0.8200000, 0.8333333, 0.8066667, 0.8533333, 0.7600000, 0.8200000, 0.7600000, 0.8333333, 0.8066667, 0.8333333, 0.7733333, 0.8333333, 0.8600000, 0.8133333, 0.8466667, 0.8266667, 0.8533333, 0.8733333, 0.8666667, 0.8400000, 0.8200000, 0.7866667)

X <- c(0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150, 0.4333150,
                0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 0.5448904, 
                0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 0.6054196, 
                0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 0.6522453, 
                0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 0.6934611, 
                0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 0.7327415, 
                0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 0.7666206, 
                0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 0.7984136, 
                0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 0.8300506, 
                0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516, 0.8732516)

attr(X, "names") = rep(as.character(0:9),each = 10)
gr <- rep(1:10,each = 10)
DATA=data.frame(Y,X,gr)
DATA$x2 = as.numeric(as.character(DATA$X))

DATA2 <- DATA %>%
         group_by(gr) %>%
         summarize(Y=mean(Y), x2=mean(x2))

ggplot(DATA, aes(x2,Y, group = gr))+ 
  xlim(0,1)+
  ylim(0,1)+
  geom_boxplot()+
  geom_smooth(data=DATA2, aes(x2, Y), formula=y~x, method="lm", color="blue", 
              size=1, linetype=1, inherit.aes=F, se=T) +
  geom_abline(slope = 1, intercept = 0)+
  theme_light()+ #scale_colour_gdocs()+
  theme(legend.position="bottom")+
  labs(title="Calibration plot",
       x ="Predicted values",
       y = "Observed values")+
  stat_summary(aes(group=X),fun.y=function(x)mean(x, na.rm = T), 
               geom="point", shape=23, col="red")

【讨论】：

感谢您的回答！是的，我希望它看起来像这个带有 method="loess" 的图形。我还想添加截距和斜率以及图例。

@Ph.D.Student 我更新了我的答案，在这条线上添加了置信区间。现在它看起来像黄土曲线。如果需要这条线的斜率和截距，可以输入summary(lm(Y~x2, data=DATA2))。关于图例，您应该更详细地说明您的需求。

感谢您的更新。回归方程为 y = a + bx，其中 b 是斜率，a 是截距。接近 0 的截距，接近 1 的斜率表示良好的校准。我认为这是校准点（红点）的线性回归

我想知道我们是否使用 mod

@Ph.D.Student mod$coefficients[1] 和 mod$coefficients[2] 可以。您也可以使用coef(mod)。是的，接近 0 的截距和接近 1 的斜率表明校准良好，是的，蓝线是红点的线性回归。有关校准的更多详细信息，您可以查看例如此链接：rdrr.io/cran/rms/man/calibrate.html