How to add the loess line, slope and intercept in Calibration plot using R?

Question

I would like to add the loess line, slope and intercept values to the calibration graph as in the following examples:

Would you please explain to me how to add these informations: slope, intercept, legend in th e bottom 'Ideal, nonparametric ...'?

My code is as follows:

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

I get the following graph:

with, the red circles representing the averages and I want to add the intercept and the slope (y = a + bx) of these points. As well as the curve that passes through the median of the boxplots. I also have a problem with the shape of the legend that does not match the red diamond, solid line and dotted line.

Respectfully,

Answer 1

Maybe this is what you are looking for.

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