如何让ggplot2中geom_smooth平滑曲线起始于(0,0)点？

我在R语言中模拟了疾病流行率曲线数据，使用ggplot2的geom_smooth()绘制平滑曲线时发现，各曲线的起始点并非(x,y)=(0,0)，而是在0.1至0.15之间变动。注：我并非要设置坐标轴起始于0，而是希望曲线本身始于(0,0)或其附近。相关模拟及绘图代码如下：

library(ggplot2)
library(tidyverse)
library(colorspace)

# Set the random seed for reproducibility
set.seed(42)

n <- 80 # Number of data points to simulate
age <- seq(0, 80, length.out = n) # Create the "age" variable ranging from 0 to 80

# Calculate "seroprev" as a natural logarithmic sequence that plateaus at 0.7 after the 40th observation
max_seroprev <- 0.7
seroprev <- pmin(max_seroprev, log(age + 1) / log(40 + 1) * max_seroprev)

# Create a data frame to store the simulated data for year 1988
simulated_data.1988 <- data.frame(seroprev, age)
simulated_data.1988$year <- "1988"

#### 1990 ####
max_seroprev <- 0.65
seroprev <- pmin(max_seroprev, log(age + 1) / log(40 + 1) * max_seroprev)
simulated_data.1990 <- data.frame(seroprev, age)
simulated_data.1990$year <- "1990"

#### 2003 ####
max_seroprev <- 0.53
seroprev <- pmin(max_seroprev, log(age + 1) / log(40 + 1) * max_seroprev)
simulated_data.2003 <- data.frame(seroprev, age)
simulated_data.2003$year <- "2003"

#### 2008 ####
max_seroprev <- 0.45
seroprev <- pmin(max_seroprev, log(age + 1) / log(40 + 1) * max_seroprev)
simulated_data.2008 <- data.frame(seroprev, age)
simulated_data.2008$year <- "2008"

#### 2011 ####
# Initialize "seroprev" with zeros
seroprev <- rep(0, n)
# Calculate "seroprev" as a natural logarithmic sequence starting from age 5
start_age <- 5
seroprev[start_age:n] <- log(1:(n - start_age) + 1) / log((n - start_age) + 1) * 0.4

# Round the "seroprev" values to two decimal places
seroprev <- round(seroprev, 2)
simulated_data.2011 <- data.frame(seroprev, age)
simulated_data.2011$year <- "2011"
simulated_data.2011 <- simulated_data.2011[-c(80),] #fix error in 2011 data
simulated_data.2011 <- simulated_data.2011 %>% 
  add_row(age = 80, seroprev=0.4, year = "2011")

sim.full <- rbind(simulated_data.1988, simulated_data.1990,
                  simulated_data.2003, simulated_data.2008, 
                  simulated_data.2011) #bind each simulated year
sim.full$year <- as.factor(sim.full$year)

ggplot(sim.full, aes(x = age, y = seroprev, colour = year, group = year)) + 
  geom_smooth(se = F) + 
  xlab("Age (years)") + 
  ylab("Seroprevalence") + 
  scale_color_manual(values = c("1988" = "#990000",
                                "1990" = "red",
                                "2003" = "orange",
                                "2008" = "#FFCC00",
                                "2011" = "yellow")) +
  ylim(0, 1) +
  theme_classic() +
  theme(legend.title = element_blank(),
        legend.position=c(0.1,0.9), # Position legend top left
        legend.text = element_text( size = 15), 
        axis.title.x = element_text(face = "bold", size = 15), 
        axis.title.y = element_text(face = "bold", size = 15), 
        axis.text = element_text(face = "bold", size = 12)) 

要让平滑曲线强制贴近或经过(0,0)，可以用以下几种实用方法：

方法1：自定义带原点约束的GAM拟合函数 #

借助mgcv包的广义加性模型（GAM），去掉截距项强制模型过原点，直接在geom_smooth中调用：

library(mgcv)

# 定义强制过原点的GAM拟合函数
gam_origin <- function(formula, data, ...) {
  gam(update(formula, . ~ . + offset(0) - 1), data = data, ...)
}

# 修改绘图代码中的geom_smooth部分
ggplot(sim.full, aes(x = age, y = seroprev, colour = year, group = year)) + 
  geom_smooth(method = gam_origin, formula = y ~ s(x, bs = "cs"), se = F) + 
  xlab("Age (years)") + 
  ylab("Seroprevalence") + 
  scale_color_manual(values = c("1988" = "#990000",
                                "1990" = "red",
                                "2003" = "orange",
                                "2008" = "#FFCC00",
                                "2011" = "yellow")) +
  ylim(0, 1) +
  theme_classic() +
  theme(legend.title = element_blank(),
        legend.position=c(0.1,0.9),
        legend.text = element_text( size = 15), 
        axis.title.x = element_text(face = "bold", size = 15), 
        axis.title.y = element_text(face = "bold", size = 15), 
        axis.text = element_text(face = "bold", size = 12)) 

这里的offset(0) - 1移除了模型的截距项，确保曲线经过(0,0)，s(x, bs="cs")则保留了曲线的平滑特性。

方法2：手动分组拟合+绘制曲线 #

按年份单独拟合带约束的模型，生成预测值后用geom_line绘制，灵活性更高：

# 按年份分组拟合强制过原点的loess模型，并生成预测数据
fit_data <- sim.full %>%
  group_by(year) %>%
  nest() %>%
  mutate(
    # 拟合loess模型，指定表面为直接拟合（更贴近数据）
    fit = map(data, ~ loess(seroprev ~ age, data = ., control = loess.control(surface = "direct"))),
    # 生成0-80岁的预测值
    pred = map(fit, ~ predict(., newdata = data.frame(age = seq(0, 80, length.out = 100)))),
    age_pred = list(seq(0, 80, length.out = 100))
  ) %>%
  unnest(c(age_pred, pred))

# 绘制平滑曲线
ggplot() +
  geom_line(data = fit_data, aes(x = age_pred, y = pred, colour = year)) +
  xlab("Age (years)") + 
  ylab("Seroprevalence") + 
  scale_color_manual(values = c("1988" = "#990000",
                                "1990" = "red",
                                "2003" = "orange",
                                "2008" = "#FFCC00",
                                "2011" = "yellow")) +
  ylim(0, 1) +
  theme_classic() +
  theme(legend.title = element_blank(),
        legend.position=c(0.1,0.9),
        legend.text = element_text( size = 15), 
        axis.title.x = element_text(face = "bold", size = 15), 
        axis.title.y = element_text(face = "bold", size = 15), 
        axis.text = element_text(face = "bold", size = 12)) 

方法3：给原点数据点加权重 #

如果不想修改拟合模型，可给每个年份的(0,0)点赋予极高权重，让拟合曲线向原点靠拢：

# 为每个年份添加(0,0)数据点，并设置高权重
sim.full_weighted <- sim.full %>%
  group_by(year) %>%
  add_row(age = 0, seroprev = 0, year = cur_group()$year) %>%
  mutate(weight = ifelse(age == 0 & seroprev == 0, 1000, 1)) # 原点权重设为1000

# 绘图时传入weight参数
ggplot(sim.full_weighted, aes(x = age, y = seroprev, colour = year, group = year, weight = weight)) + 
  geom_smooth(se = F) + 
  xlab("Age (years)") + 
  ylab("Seroprevalence") + 
  scale_color_manual(values = c("1988" = "#990000",
                                "1990" = "red",
                                "2003" = "orange",
                                "2008" = "#FFCC00",
                                "2011" = "yellow")) +
  ylim(0, 1) +
  theme_classic() +
  theme(legend.title = element_blank(),
        legend.position=c(0.1,0.9),
        legend.text = element_text( size = 15), 
        axis.title.x = element_text(face = "bold", size = 15), 
        axis.title.y = element_text(face = "bold", size = 15), 
        axis.text = element_text(face = "bold", size = 12)) 

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