ggplot geom中调用自定义函数时如何直接引用传入的绘图数据

问题场景 #

在R中使用ggplot2的geom_vline结合自定义函数在直方图上绘制均值±指定倍数标准差的参考线时，自定义参考线函数如下：

# 计算均值及上下N倍标准差位置
sds_around_the_mean <- function(x, multiplier = 1) {
  mean_val <- mean(x, na.rm = TRUE)
  sd_val <- sd(x, na.rm = TRUE)
  
  tibble(low   = mean_val - multiplier * sd_val,
         mean  = mean_val,
         high  = mean_val + multiplier * sd_val) %>% 
    pivot_longer(cols = everything()) %>% 
    pull(value)
}

初始可复现代码如下：

set.seed(123)
normal <- tibble(data = rnorm(1000, mean = 100, sd = 5))
outliers <- tibble(data = runif(5, min = 150, max = 200))
df <- bind_rows(lst(normal, outliers), .id = "type")

df %>% 
  ggplot(aes(x = data)) + 
  geom_histogram(bins = 100) + 
  geom_vline(xintercept = sds_around_the_mean(df$data, multiplier = 3),
             linetype = "dashed", color = "red") + 
  geom_vline(xintercept = sds_around_the_mean(df$data, multiplier = 2),
             linetype = "dashed")

运行效果：

现存问题 #

上述写法中geom_vline的计算参数硬编码了df$data作为输入，如果在管道中对绘图数据做调整（比如过滤离群值），必须同步修改所有geom_vline里的数据源引用，否则参考线计算会基于未过滤的全量数据，很容易出错：

# 仅保留正常组数据绘图
df %>% filter(type == "normal")
# 此时必须手动把所有geom_vline里的df$data改为df$data[df$type == "normal"]才能得到正确结果

之前尝试用stat_summary(geom = "vline")实现自动适配，没有得到预期效果。 #

解决方案 #

方法1：管道块引用（零成本快速实现） #

不需要修改现有自定义函数，用{}包裹整个ggplot调用，用管道传入的.代指当前处理完的绘图数据集，所有xintercept计算都引用.的对应列即可。后续不管怎么调整前面的数据过滤、变换逻辑，后面的参考线计算都会自动基于最终传入ggplot的数据集，不需要手动同步修改：

df %>% 
  filter(type == "normal") %>% # 这里可以任意调整数据处理逻辑
  {
    ggplot(., aes(x = data)) + 
      geom_histogram(bins = 100) + 
      geom_vline(xintercept = sds_around_the_mean(.$data, multiplier = 3),
                 linetype = "dashed", color = "red") + 
      geom_vline(xintercept = sds_around_the_mean(.$data, multiplier = 2),
                 linetype = "dashed")
  }

方法2：自定义Stat图层（一劳永逸，支持分面自动适配） #

如果需要频繁画这类参考线，或者需要支持分面时每个面板单独计算参考线位置，可以自定义一个统计变换图层，让图层自动从当前绘图数据（包括分面后的分组数据）中提取x轴列计算参考线位置，调用时完全不需要手动传入数据源：

# 定义参考线计算逻辑
StatSdVline <- ggproto("StatSdVline", Stat,
  compute_group = function(data, scales, multiplier = 1) {
    x <- data$x
    m <- mean(x, na.rm = TRUE)
    s <- sd(x, na.rm = TRUE)
    data.frame(xintercept = c(m - multiplier*s, m, m + multiplier*s))
  },
  required_aes = "x"
)

# 封装成快捷调用函数
geom_sd_vline <- function(mapping = NULL, data = NULL, 
                          position = "identity", na.rm = FALSE, 
                          show.legend = NA, inherit.aes = TRUE,
                          multiplier = 1, ...) {
  layer(
    stat = StatSdVline, data = data, mapping = mapping, geom = GeomVline,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, multiplier = multiplier, ...)
  )
}

后续调用时直接加图层即可，自动适配所有数据变换、分面逻辑：

# 过滤数据场景
df %>% 
  filter(type == "normal") %>% 
  ggplot(aes(x = data)) +
  geom_histogram(bins = 100) +
  geom_sd_vline(multiplier = 3, linetype = "dashed", color = "red") +
  geom_sd_vline(multiplier = 2, linetype = "dashed")

# 分面场景，每个面板单独计算自己的均值和标准差参考线
df %>% 
  ggplot(aes(x = data)) +
  geom_histogram(bins = 50) +
  geom_sd_vline(multiplier = 3, linetype = "dashed", color = "red") +
  geom_sd_vline(multiplier = 2, linetype = "dashed") +
  facet_wrap(~type, scales = "free")

之前stat_summary调用失败的原因 #

stat_summary默认是针对y轴美学做汇总计算，输出的是y轴位置的映射，而geom_vline需要的是xintercept美学映射，默认逻辑不匹配所以无法得到预期结果。

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