如何在R中绘制小提琴散点箱线图？

Question

我刚看到了下面这个图：

我想知道怎样在R（或其他软件）中实现它？

更新 10.03.11： 感谢所有参与回答这个问题的人 - 你们提供了很棒的解决方案！我在我的博客文章中总结了这里提出的所有解决方案（以及我在网上找到的一些其他方案）。

- Tal Galili

---

这可能是一个愚蠢的评论，但点的位置意味着什么？ - mbq

这不是一个愚蠢的评论，因为绘制图形的答案是plot(x,y)。我相信mbq试图表达的是，你所尝试做的可能不仅仅是一个简单的散点图。 - John

@Tal，@John--我知道标准的vioplot是如何工作的，但我无法弄清楚这些点是如何获得的（而且我看到不仅仅是我，因为这对于产生好的答案至关重要）--某种茎？或者可能有人认为用扭曲的波点填充vioplot是一个好主意？ - mbq

我以前见过那种类型的图表，但不记得使用了哪个软件，但x位置只是“随机”抖动（与该点处的密度成比例）。就个人而言，我觉得这些有点难读，我更喜欢箱线图 :) - nico

好的，我找到了这个软件。它是在GraphPad Prism中制作的“列散点图”。例如，请参见http://graphpad.com/help/prism5/prism5help.html?what_is_a_frequency_distribution.htm。我还在这里找到了一些相关的参考资料：http://www.originlab.com/www/products/GraphGallery.aspx?GID=104&s=8&lm=215 - nico

Answer 1

Make.Funny.Plot基本上实现了我所期望的功能。可以根据您自己的需要进行调整，并且可能需要进行一些优化，但这应该是一个不错的开始。

Make.Funny.Plot <- function(x){
    unique.vals <- length(unique(x))
    N <- length(x)
    N.val <- min(N/20,unique.vals)

    if(unique.vals>N.val){
      x <- ave(x,cut(x,N.val),FUN=min)
      x <- signif(x,4)
    }
    # construct the outline of the plot
    outline <- as.vector(table(x))
    outline <- outline/max(outline)

    # determine some correction to make the V shape,
    # based on the range
    y.corr <- diff(range(x))*0.05

    # Get the unique values
    yval <- sort(unique(x))

    plot(c(-1,1),c(min(yval),max(yval)),
        type="n",xaxt="n",xlab="")

    for(i in 1:length(yval)){
        n <- sum(x==yval[i])
        x.plot <- seq(-outline[i],outline[i],length=n)
        y.plot <- yval[i]+abs(x.plot)*y.corr
        points(x.plot,y.plot,pch=19,cex=0.5)
    }
}

N <- 500
x <- rpois(N,4)+abs(rnorm(N))
Make.Funny.Plot(x)

编辑：已更正为始终有效。

- Joris Meys

---

发现一个问题：如果cut返回一个空的级别，你会得到一个错误。 - Joris Meys

+1 干得好！但我认为还缺少一些东西——原始图是不对称的。 - mbq

@Joris 或许可以尝试使用 Hmisc 中的 cut2 而不是 cut？ - chl

如果我不必加载其他库，我宁愿避免。我只是在for循环中使用了错误的数字，现在已经更正了。 - Joris Meys

这将增加一点随机性： x.plot <- sample(seq(-outline[i],outline[i],outline[i]/25), n, replace=T) - nico

Answer 2

我最近发现了蜂群图包，它与之相似。

蜂群图是一种一维散点图，类似于“stripchart”，但具有紧密排列、不重叠的点。

以下是一个示例：

  library(beeswarm)
  beeswarm(time_survival ~ event_survival, data = breast,
    method = 'smile',
    pch = 16, pwcol = as.numeric(ER),
    xlab = '', ylab = 'Follow-up time (months)',
    labels = c('Censored', 'Metastasis'))
  legend('topright', legend = levels(breast$ER),
    title = 'ER', pch = 16, col = 1:2)

_{(source: eklund at www.cbs.dtu.dk)}

- Shane

Answer 3

我想到了与Joris相似的代码，但我认为这不仅仅是一个茎叶图；在这里，我指的是每个系列中的y值是到内部均值的绝对距离，而x值更多的是关于该值是否低于或高于均值。
示例代码（有时会引发警告，但可以正常工作）：

px<-function(x,N=40,...){
x<-sort(x);

#Cutting in bins
cut(x,N)->p;

#Calculate the means over bins
sapply(levels(p),function(i) mean(x[p==i]))->meansl;
means<-meansl[p];

#Calculate the mins over bins
sapply(levels(p),function(i) min(x[p==i]))->minl;
mins<-minl[p];

#Each dot is one value.
#X is an order of a value inside bin, moved so that the values lower than bin mean go below 0
X<-rep(0,length(x));
for(e in levels(p)) X[p==e]<-(1:sum(p==e))-1-sum((x-means)[p==e]<0);
#Y is a bin minum + absolute value of a difference between value and its bin mean
plot(X,mins+abs(x-means),pch=19,cex=0.5,...);
}

- mbq

---

谢谢mbq，我一直在想该选谁的答案。我选择了Joris，因为他总结得很好。无论如何，两个答案都很棒，我投了+1票。干杯-Tal - Tal Galili

Answer 4

尝试使用vioplot软件包：

library(vioplot)
vioplot(rnorm(100))

(使用默认的糟糕颜色;-)

还有wvioplot()函数在wvioplot包中，用于加权小提琴图，以及beanplot，它将小提琴图和地毯图结合在一起。它们也可以通过lattice包获得，详见?panel.violin。

- chl

---

这不会生成散点图，对吧？ - Shane

@Shane 不是的，这只是一个带有核密度估计的箱线图的变体。 - chl

@Shane @Tal 顺便说一下，箱线百分位图更好（Hmisc包中的bpplot）。 - chl

嗨，chl。谢谢回答。我记得看到过那个函数，但正如Shane所说 - 它不会产生散点图元素。我会+1支持你的好意 - 但仍然会保持这个问题开放：）。干杯，Tal - Tal Galili

@Tal 好的，我会尝试自己在R中找出如何制作它；我认为使用 stripchart() 或抖动程序不会太难。 - chl

嗨，chl，感谢你尝试这个。这里使用的代码：http://www.cl.cam.ac.uk/~sjm217/projects/graphics/可能是一个不错的开始（因为它成功地叠加了点，而不仅仅是抖动它们）。 - Tal Galili

Answer 5

自从这个还没有提到，还有一个相对较新的基于ggplot2的R包ggbeeswarm。

它添加了另一个几何图形到ggplot中，可以用来替代geom_jitter或类似的东西。

特别是geom_quasirandom（见下面的第二个例子），产生了非常好的效果，事实上我已经将其作为默认图表进行了调整。

值得注意的是，还有一个名为vipor（VIolin POints in R）的包，它使用标准的R图形绘制图表，并且实际上也被ggbeeswarm在幕后使用。

set.seed(12345)
install.packages('ggbeeswarm')
library(ggplot2)
library(ggbeeswarm)

ggplot(iris,aes(Species, Sepal.Length)) + geom_beeswarm()

ggplot(iris,aes(Species, Sepal.Length)) + geom_quasirandom()

#compare to jitter
ggplot(iris,aes(Species, Sepal.Length)) + geom_jitter()

- Sebastian Müller