ggplot2：geom_ribbon，其中alpha依赖于每个x沿y轴的数据密度

Question

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

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

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

相反，我希望有一个色带覆盖样品所在的整个区域，具有连续的α梯度，即色带在实际线附近的中间最暗，在离群点处非常浅。 这可能在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绘制那些y值。

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)

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