R ggplot2 geom_smooth实现对数插值拟合解决曲线凸起问题

默认loess局部回归在Product B这类0-4小时间y值跳变极大的数据集上，即便把span拉到最大，局部多项式拟合仍会在快速增长拐点处产生不符合单调性的异常波动，以下是两类可直接运行的实现方案：

方案1：配置geom_smooth拟合指定对数函数 #

注意log(0)无数学定义，而数据集包含Time=0的观测点，拟合时给x值加一个可忽略的极小偏移即可解决报错，拟合得到的对数函数天然单调递增，不会出现异常凸起：

library(ggplot2)

# 构造数据集，无需attach，避免变量环境污染
RawData <- data.frame(
  Time = c(0, 4, 8, 24, 28, 32, 0, 4, 8, 24, 28, 32), 
  Curing = c(0, 28.57, 56.19, 86.67, 89.52, 91.42, 0, 85.71, 93.33, 94.28, 97.62, 98.09), 
  Grade = rep(c("Product A", "Product B"), each = 6)
)

Graph <- ggplot(data=RawData, aes(x=Time, y=Curing, col=Grade)) + 
  geom_point(shape = 1, size = 2.5) + 
  # 指定对数拟合公式，1e-6为极小偏移量，不影响x≥4区间的拟合精度
  geom_smooth(
    method = "glm",
    formula = y ~ log(x + 1e-6),
    level = 0.5,
    linewidth = 1
  ) + 
  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))

如果觉得x=0附近的拟合偏差不符合预期，可以微调偏移量大小，或单独固定x=0点的拟合值为0，不影响整体增长趋势的拟合效果。

方案2：其他无异常凸起的平滑实现方法 #

这类方法不需要手动指定对数函数形式，通过模型约束或适配反应动力学规律保证曲线单调贴合数据：

• 单调约束P样条平滑：用带单调递增约束的惩罚样条拟合，自动适配数据趋势同时全程不出现下降/异常凸起，需要用到scam包：

# 首次运行需安装包：install.packages("scam")
library(scam)

Graph <- ggplot(data=RawData, aes(x=Time, y=Curing, col=Grade)) + 
  geom_point(shape = 1, size = 2.5) + 
  geom_smooth(
    method = "scam",
    # bs="mp"指定单调递增P样条，k值越小曲线越平滑
    formula = y ~ s(x, bs = "mp", k = 4),
    level = 0.5
  ) + 
  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))

• 渐近回归模型拟合：固化度随时间的增长本身是趋近饱和值的渐近过程，用R内置的自启动渐近回归模型SSasymp拟合，比对数模型更贴合化工固化反应的实际规律，曲线天然单调递增趋近饱和上限：

Graph <- ggplot(data=RawData, aes(x=Time, y=Curing, col=Grade)) + 
  geom_point(shape = 1, size = 2.5) + 
  geom_smooth(
    method = "nls",
    formula = y ~ SSasymp(x, Asym, R0, lrc),
    se = FALSE,
    level = 0.5
  ) + 
  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))

注：原代码中attach(RawData)属于不推荐的写法，容易造成变量名冲突，ggplot2通过data参数指定数据集后无需额外绑定数据。

内容的提问来源于stack exchange，提问作者GiacomoDB