r - 使用 geom_smooth 强制拦截

Question

我正在寻找两个变量之间的比较图，重叠两个产品的 geom_smooth()。测量力理论的起点是 (x=0; y=0) 但是当我制作图表时，蓝色回归线是用 geom_smooth() 不传递坐标 (0;0)。是否可以将此 geom_smooth() 固定在第一个点 (0;0) 的特定定义坐标处？

代码下方:

library(ggplot2)

RawData <- data.frame(
  "Time" = c(0, 3, 6, 9, 24, 30, 34, 48, 57, 0, 3, 6, 9, 24, 30, 34, 48, 57), 
  "Curing" = c(0, 11.36, 31.81, 34.09, 75, 86.36, 97.7, 100, 100, 0, 77.5, 92, 95, 98, 100, 100, 100, 100), 
  "Grade" = c("Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B"))

attach(RawData)

Graph <- ggplot(data=RawData, aes(x=`Time`, y=`Curing`, col=Grade)) + 
  geom_point(aes(color = Grade), shape = 1, size = 2.5) + 
  geom_smooth(level=0.50, span = 0.9999999999) +
  scale_color_manual(values=c('#f92410','#644196')) + 
  xlab("Tempo espresso in ore") + 
  ylab("% Di reticolazione") + 
  labs(color='') + 
  theme(legend.justification = "top")

Graph + geom_rug(aes(color = Grade))

预先感谢您最终的帮助!!

Answer 1

geom_smooth 有多种平滑方法可用。对于 GLM/LM/GAM，您可以明确指定截距为零的公式，例如 geom_smooth(method="lm", formula=y~x+0)。这不适用于 loess，它是 geom_smooth 中用于小型数据集 (N<1,000) 的默认方法，大概是因为它适合局部。

在这种情况下，该示例使用黄土平滑方法，因此要强制拟合通过零，您可以为每个组的数据集中的点 (0,0) 赋予非常高的权重通过使用以下代码:

library(ggplot2)

RawData <- data.frame("Time" = c(0, 3, 6, 9, 24, 30, 34, 48, 57, 0, 3, 6, 9, 24, 30, 34, 48, 57), "Curing" = c(0, 11.36, 31.81, 34.09, 75, 86.36, 97.7, 100, 100, 0, 77.5, 92, 95, 98, 100, 100, 100, 100), "Grade" = c("Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product A", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B", "Product B"))

RawData$weight  = ifelse(RawData$Time==0, 1000, 1)

Graph <- ggplot(data=RawData, aes(x=`Time`, y=`Curing`, col=Grade)) + geom_point(aes(color = Grade), shape = 1, size = 2.5) + 
  geom_smooth(aes(weight=weight), level=0.50, span = 0.9999999999) + 
  scale_color_manual(values=c('#f92410','#644196')) + xlab("Tempo espresso in ore") + ylab("% Di reticolazione") + labs(color='') + theme(legend.justification = "top")
Graph + geom_rug(aes(color = Grade))

这迫使建模拟合非常接近原点，给出所需的图: