ggplot2小提琴图：仅填充中心95%？

Question

ggplot2可以创建非常吸引人的填充小提琴图：

ggplot() + geom_violin(data=data.frame(x=1, y=rnorm(10 ^ 5)), 
    aes(x=x, y=y), fill='gray90', color='black') + 
    theme_classic()

如果可能的话，我希望将填充限制在分布的中心95％，同时保留轮廓线。有没有人对如何实现这一点有建议？

- dewarrn1

Answer 1

这个是否符合您的要求？它需要一些数据处理和绘制两个小提琴。

set.seed(1)
dat <- data.frame(x=1, y=rnorm(10 ^ 5))

#calculate for each point if it's central or not
dat_q <- quantile(dat$y, probs=c(0.025,0.975))
dat$central <- dat$y>dat_q[1] & dat$y < dat_q[2]

#plot; one'95' violin and one 'all'-violin with transparent fill.
p1 <- ggplot(data=dat, aes(x=x,y=y)) +
  geom_violin(data=dat[dat$central,], color="transparent",fill="gray90")+
  geom_violin(color="black",fill="transparent")+

  theme_classic()

编辑：圆角让我很不舒服，这是第二种方法。如果我要做这个，我会想要直线。所以我尝试了一些密度的调整（小提琴图就是基于这个）

d_y <- density(dat$y)

right_side <- data.frame(x=d_y$y, y=d_y$x) #note flip of x and y, prevents coord_flip later
right_side$central <- right_side$y > dat_q[1]&right_side$y < dat_q[2]

#add the 'left side', this entails reversing the order of the data for
#path and polygon
#and making x  negative
left_side <- right_side[nrow(right_side):1,]
left_side$x <- 0 - left_side$x

density_dat <- rbind(right_side,left_side)


p2 <- ggplot(density_dat, aes(x=x,y=y)) +
  geom_polygon(data=density_dat[density_dat$central,],fill="red")+
  geom_path()


p2

- Heroka

---

@Axeman 伟大的思想相似？我添加了第二种方法。 - Heroka

@Heroka，太棒了！正如你猜测的那样，我自己也尝试了你的第一种方法，但并不满意。你的第二种方法正是我想要的。非常感谢！ - dewarrn1

Answer 2

首先进行选择。概念证明：

df1 <- data.frame(x=1, y=rnorm(10 ^ 5))
df2 <- subset(df1, y > quantile(df1$y, 0.025) & y < quantile(df1$y, 0.975))

ggplot(mapping = aes(x = x, y = y)) + 
  geom_violin(data = df1, aes(fill = '100%'), color = NA) +
  geom_violin(data = df2, aes(fill = '95%'), color = 'black') +
  theme_classic() + 
  scale_fill_grey(name = 'level')

- Axeman

---

此答案更为简洁。 - trilisser

Answer 3

@Heroka给出了很好的答案。这里是一个基于他的答案的更通用的函数，允许根据任何范围（不仅仅是分位数）填充小提琴图。

violincol <- function(x,from=-Inf,to=Inf,col='grey'){ d <- density(x)

right <- data.frame(x=d$y, y=d$x) #note flip of x and y, prevents coord_flip later

whichrange <- function(r,x){x <= r[2] & x > r[1]}
ranges <- cbind(from,to)  

right$col <- sapply(right$y,function(y){
    id <- apply(ranges,1,whichrange,y)
    if(all(id==FALSE)) NA else col[which(id)]
})

left <- right[nrow(right):1,]
left$x <- 0 - left$x

dat <- rbind(right,left)

p <- ggplot(dat, aes(x=x,y=y)) +
    geom_polygon(data=dat,aes(fill=col),show.legend = F)+
    geom_path()+
    scale_fill_manual(values=col)
return(p)
}

x <- rnorm(10^5)
violincol(x=x)
violincol(x=x,from=c(-Inf,0),to=c(0,Inf),col=c('green','red'))
r <- seq(-5,5,0.5)
violincol(x=x,from=r,to=r+0.5,col=rainbow(length(r)))

- Wave