ggplot2：geom_ribbon 的 alpha 取决于每个 x 沿 y 轴的数据密度

Question

在 ggplot2 中是否有办法根据点的密度生成具有不同 alpha 的 geom_ribbon（或其他基于区域的几何图形）？

以下代码生成 50 个嘈杂的正弦波，每个样本都有随机的 x 值。我不想画出每一个点，因为我可能需要一千个或更多的重新采样，所以我想总结所有这些点。

一个简单的方法是绘制一个覆盖 95% 分位数的 geom_ribbon。然而，首先这并不容易计算，因为每个重采样的 x 值都不相同；通常，您会计算 100 个 x 点中每个点的逐点分位数。

相反，我希望色带覆盖样本所在的整个区域，具有连续的 alpha 渐变，即色带在靠近实际线的中间最暗，在异常点处非常亮。这在 ggplot2 中可能吗？

library(ggplot2)

num_points = 100
num_samples = 50

x = seq(0, 4*pi, length.out=num_points)

sim <- lapply(1:num_samples, function(f) {
    x = runif(num_points, 0, 4*pi)
    y = sin(x) + rnorm(num_points, 0, 0.4)
    data.frame(x=x, y=y)
})

sim.df <- do.call(rbind, sim)
actual = data.frame(x=x, y=sin(x))

ggplot(sim.df, aes(x=x, y=y)) +
    geom_point(alpha=0.7) +
    geom_line(data=actual, colour='blue', size=1.5) 

Answer 1

一种选择是使用分位数回归在每个 x 值处获取每个分位数的 y 值，然后使用 geom_ribbon 绘制这些值。

library(splines)
library(quantreg)
library(reshape2)
library(dplyr)

1. 为密度带设置分位数：

   nq = 50 # Numbre of quantiles
   qq = seq(0,1, length.out=nq)
   

2. 对每个分位数运行分位数回归。我使用了一个灵活的样条函数来很好地拟合正弦函数：

   m1 = rq(y ~ ns(x,10), data=sim.df, tau=qq)
   

3. 创建数据框供 geom_ribbon 使用以绘制密度分位数。

   使用predict 创建回归分位数预测的数据框：

   xvals = seq(min(sim.df$x), max(sim.df$x), length.out=100)
   rqs = data.frame(x=xvals, predict(m1, newdata=data.frame(x=xvals)))
   names(rqs) = c("x", paste0("p",100*qq))
   

   重塑数据，使每个分位数的预测作为一个分位数的ymax 和下一个分位数的ymin 连续（除了第一个分位数仅作为第一个ymin最后一个分位数仅作为最后一个ymax)。将数据放在长格式中，以便我们可以在 ggplot 中按分位数进行分组：

   dat1 = rqs[, -length(rqs)]
   names(dat1)[-1] = paste0(names(dat1)[-1])
   dat2 = rqs[, -2]
   names(dat2)[-1] = paste0(names(dat1)[-1])
   
   dat1 = melt(dat1, id.var="x")
   names(dat1) = c("x","group","min")
   dat2 = melt(dat2, id.var="x")
   names(dat2) = c("x","group1","max")
   
   dat = bind_cols(dat1, dat2)
   

4. 现在创建情节。我们将分位数映射到alpha 美学，然后使用scale_alpha_manual 将alpha 值设置为对于接近0.5 的分位数较高，对于接近0 和1 的分位数较低：

   ggplot() +
     geom_point(data=sim.df, aes(x,y), alpha=0.1, size=0.5, colour="red") +
     geom_ribbon(data=dat, aes(x=x, ymin=min, ymax=max, group=group, alpha=group), 
             fill="blue", lwd=0, show.legend=FALSE) +
     theme_bw() +
     scale_alpha_manual(values=c(seq(0.05,0.9,length.out=floor(0.5*length(qq))),
                                 seq(0.9,0.05,length.out=floor(0.5*length(qq)))))
   

这是另一个示例，但数据具有不同的标准偏差：

sim <- lapply(1:num_samples, function(f) {
  x = runif(num_points, 0, 4*pi)
  y = sin(x) + rnorm(num_points, 0, abs(0.7*cos(x))+0.1)
  data.frame(x=x, y=y)
})

sim.df <- do.call(rbind, sim)

现在只需运行我们之前创建的所有代码即可获得此图：