如何在R语言校准图中添加loess线、斜率、截距并修正图例

完整可运行代码 #

# 加载依赖包
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))

# 计算分组汇总数据
group_summary <- DATA %>%
  group_by(x2, gr) %>%
  summarise(
    mean_Y = mean(Y, na.rm = T),
    median_Y = median(Y, na.rm = T),
    .groups = "drop"
  )

# 计算分组均值的线性回归系数
lm_fit <- lm(mean_Y ~ x2, data = group_summary)
intercept <- round(coef(lm_fit)[1], 3)
slope <- round(coef(lm_fit)[2], 3)
eq_text <- paste0("y = ", intercept, " + ", slope, "x")

# 统一美学映射
cols = c("Reference (Ideal)"="gray70","Lowess (nonparametric)" = "royalblue3" ,"Grouped mean"="darkorange2", "Median fit" = "firebrick")
ltys = c("Reference (Ideal)" = 2, "Lowess (nonparametric)" = 1, "Grouped mean" = 0, "Median fit" = 1)
shapes = c("Reference (Ideal)" = NA, "Lowess (nonparametric)" = NA, "Grouped mean" = 23, "Median fit" = NA)

# 绘图
ggplot(DATA, aes(x = x2, y = Y))+ 
  xlim(0,1)+
  ylim(0,1)+
  geom_boxplot(aes(group = gr))+
  geom_smooth(method = "loess", se=FALSE, aes(group=1, colour ="Lowess (nonparametric)", linetype = "Lowess (nonparametric)"),size=0.8)+
  geom_abline(aes(slope = 1, intercept = 0, colour= "Reference (Ideal)", linetype = "Reference (Ideal)"))+
  stat_summary(aes(group=X, colour = "Grouped mean", shape = "Grouped mean"), fun.y=function(x){mean(x, na.rm = T)}, 
               geom="point", size = 2, fill = "darkorange2")+
  # 中位数拟合曲线
  geom_line(data = group_summary, aes(x = x2, y = predict(loess(median_Y ~ x2)), color = "Median fit", linetype = "Median fit"), size = 0.8)+
  # 标注回归公式
  annotate("text", x = 0.2, y = 0.9, label = eq_text, hjust = 0)+
  theme_light()+  
  theme(legend.position = c(.97, .1),
        legend.justification = c("right", "bottom"),
        legend.box.just = "right",
        legend.margin = margin(6, 6, 6, 6),
        legend.background = element_rect(fill = "white", color = NA))+
  labs(title="Calibration plot",
       x ="Predicted values",
       y = "Observed values")+
  scale_colour_manual(name="", values=cols)+
  scale_linetype_manual(name="", values = ltys)+
  scale_shape_manual(name="", values = shapes)+
  # 修复图例匹配
  guides(
    color = guide_legend(override.aes = list(
      shape = shapes,
      linetype = ltys
    ))
  )

功能实现说明 #

• 需求1（斜率截距标注）：先对分组均值做线性回归，提取系数拼接为公式文本，用annotate函数标注在图面左上角，可自行调整x/y参数修改位置
• 需求2（中位数拟合曲线）：先计算每个箱线组的Y中位数，用loess拟合后绘制为红色实线，可根据需要修改颜色或拟合方法
• 需求3（图例匹配修复）：将颜色、线型、形状三个美学属性统一绑定到分类标签，通过guides函数覆写图例的显示样式，实现每个图例项和图中元素完全对应，同时图例标签已替换为需要的Ideal、nonparametric等描述

内容的提问来源于stack exchange，提问作者Ph.D.Student