如何复用ggplot2 facet_wrap仅数据绘图的坐标轴范围？

当你用facet_wrap(scales = "free_y")绘制仅数据的图形，再添加GLM拟合曲线时，拟合曲线的预测值可能超出原数据的y范围，导致面板y轴被大幅拉伸。要复用原数据图的坐标轴范围，可以按以下步骤操作：

步骤1：提取原数据图的面板y轴范围 #

直接访问plot_data_only$scales无法获取每个面板的独立尺度信息，需要用ggplot_build()提取绘图的构建参数：

# 加载必要包（未安装则先安装）
if (!require("purrr")) install.packages("purrr")
library(purrr)

# 提取仅数据图的构建信息
pb <- ggplot_build(plot_data_only)

# 提取每个面板的y轴范围，并关联对应的ID
panel_y_limits <- pb$layout$panel_params %>%
  map_dfr(~data.frame(ymin = .$y$limits[1], ymax = .$y$limits[2]), .id = "panel") %>%
  mutate(ID = levels(data$ID)[as.integer(panel)])

步骤2：复用原坐标轴范围绘制带拟合曲线的图 #

这里推荐用ggh4x包的facetted_pos_scales函数，它支持给每个facet面板单独设置坐标轴尺度：

先安装并加载ggh4x #

if (!require("ggh4x")) install.packages("ggh4x")
library(ggh4x)

构建每个面板的y轴尺度并绘图 #

# 原代码中的glm_combined未定义，先拟合全局模型（若需要start参数）
glm_combined <- glm(y ~ 1 + x + I(x^2), data = data, family = quasipoisson(link = "log"))

# 为每个ID创建对应的y轴尺度
y_scales <- map2(panel_y_limits$ymin, panel_y_limits$ymax, 
                 ~scale_y_continuous(limits = c(.x, .y)))
names(y_scales) <- panel_y_limits$ID

# 绘制图形，复用原数据图的y轴范围
plot_data_only +
  stat_smooth(method = "glm",
              method.args = list(
                family = quasipoisson(link = "log"),
                start = coefficients(glm_combined),
                maxit = 100),
              se = FALSE,
              formula = y ~ 1 + x + I(x^2), size = 1) +
  labs(title = "Data and model fits (y轴范围与仅数据图一致)") +
  facetted_pos_scales(y = y_scales)

替代方法：限制拟合曲线的预测范围 #

如果不想额外安装包，可以手动拟合每个面板的模型，然后绘制曲线时限制y值在原数据范围内：

# 按ID分组拟合模型
model_list <- data %>%
  group_by(ID) %>%
  group_map(~glm(y ~ 1 + x + I(x^2), data = ., family = quasipoisson(link = "log")))
names(model_list) <- levels(data$ID)

# 生成每个ID的预测数据，并限制y在原数据范围内
pred_data <- data %>%
  group_by(ID) %>%
  group_map(function(.data, .id) {
    x_seq <- seq(min(.data$x), max(.data$x), length.out = 100)
    pred <- predict(model_list[[.id]], newdata = data.frame(x = x_seq), type = "response")
    # 限制预测值在原数据的y范围内
    pred_clamped <- pmax(min(.data$y), pmin(max(.data$y), pred))
    data.frame(ID = .id, x = x_seq, y_pred = pred_clamped)
  }) %>%
  bind_rows()

# 绘制图形
plot_data_only +
  geom_line(data = pred_data, aes(x = x, y = y_pred), size = 1) +
  labs(title = "Data and model fits (限制拟合曲线y范围)")

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