对称的小提琴情节直方图？

Question

如何制作直方图,其中每个条的中心位于公共轴上？这看起来像一个阶梯形边缘的小提琴情节.

我想在莱迪思这样做,并不介意自定义面板功能等,但很乐意使用基本R图形甚至ggplot2.(我还没有把自己投入到ggplot2中,但是会在某些时候采取行动.)

(为什么我要这样做？我认为当数据是离散的并且以几个[5-50]均匀间隔的数值出现时,它可能是一个有用的替代小提琴图.每个bin然后代表一个点.当然我可以生成一个正常的直方图.但我认为有时显示盒须图和小提琴图是有用的.对于定期间隔的离散数据,具有与boxplot相同方向的对称直方图可以进行比较用箱形图绘制数据的详细结构,就像小提琴情节一样.在这种情况下,对称直方图可能比小提琴情节更具信息性.(豆图可能是我刚才描述的另一种选择,尽管事实上我的数据不是字面上离散的 - 它只是收敛到一系列常规值附近.这使得R的beanplot包对我来说没用,除非我通过将它们映射到最接近的常规值来规范化值.))

以下是一些数据的30个观察子集,它是由基于代理的模拟生成的:

df30 <- data.frame(crime.v=c(0.2069526, 0.2063516, 0.06919754,
0.2080366, -0.06975912, 0.206277, 0.3457634, 0.2058985, 0.3428499,
0.3428159, 0.06746109, -0.07068694, 0.4826098, -0.06910966, 0.06769761,
0.2098732, 0.3482267, 0.3483602, 0.4829777, 0.06844112, 0.2093492,
0.4845478, 0.2093505, 0.3482845, 0.3459249, 0.2106339, 0.2098397,
0.4844956, 0.2108985, 0.2107984), bias=c("beast", "beast", "beast",
"beast", "beast", "beast", "beast", "beast", "beast", "beast", "beast",
"beast", "beast", "beast", "beast", "virus", "virus", "virus", "virus",
"virus", "virus", "virus", "virus", "virus", "virus", "virus", "virus",
"virus", "virus", "virus"))

df可以从此链接下载以Rdata文件中的完整600个观察值命名的数据框:CVexample.rdata.

这些crime.v值都接近以下之一,我称之为焦点:

[1] -0.89115386 -0.75346155 -0.61576924 -0.47807693 -0.34038463 -0.20269232 -0.06500001
[8]  0.07269230  0.21038460  0.34807691  0.48576922  0.62346153  0.76115383  0.89884614

(这些crime.v值实际上是13个变量的平均值,其值的范围可以从-1到1,但最终会收敛到.9或-9附近的值.13个值的平均值为.9或 - .9有点靠近焦点.在实践中,我通过检查数据确定了焦点的适当值,因为还涉及一些额外的变化.)

可以制作小提琴情节:

require(lattice)
bwplot(crime.v ~ bias, data=df30, ylim=c(-1,1), panel=panel.violin)

如果你用较大的数据集运行它,你会发现其中一个小提琴图是多模式的,而另一个则不是.然而,这似乎并没有反映出两个小提琴情节的数据差异; 据我所知,这是一个神器,因为焦点的位置与情节有关.我可以通过调整density传递给panel.violin 的参数来消除差异,但只是表示每个集群中有多少点会更清楚.

谢谢!

Answer 1

这是使用基本图形的一种可能性:

tmp <- tapply( iris$Petal.Length, iris$Species, function(x) hist(x, plot=FALSE) )

plot.new()
tmp.r <- do.call( range, lapply(tmp, `[[`, 'breaks') )
plot.window(xlim=c(1/2,length(tmp)+1/2), ylim=tmp.r)
abline(v=seq_along(tmp))

for( i in seq_along(tmp) ) {
    h <- tmp[[i]]
    rf <- h$counts/sum(h$counts)
    rect( i-rf/2, head(h$breaks, -1), i+rf/2, tail(h$breaks, -1) )
}

axis(1, at=seq_along(tmp), labels=names(tmp))
axis(2)
box()

您可以根据自己的喜好调整不同的部分,整个过程可以很容易地包含在一个函数中.

Answer 2

这是一个基于@ GregSnow使用基本图形的答案的Lattice面板功能.如果没有格雷格提供一个坚实的起点,我不可能做到这一点,所以所有的功劳归于格雷格.我的面板功能不是很复杂,可以很好地打破简单的东西,但可以处理水平和垂直方向,并允许你提供一个断点向量或将其遗漏.它还会移除空端的垃圾箱.面板函数使用hist的是默认行为breaks而不是histogram's,这更复杂.欢迎提供有关更好方法的评论.

由于对称或居中的直方图没有现有的名称,据我所知,它们让人想起河内塔玩具,也许它们应该被称为"河内塔直方图".因此调用该函数panel.hanoi.

使用上面df30定义的简单用法示例:

bwplot(crime.v ~ bias, data=df30, panel=panel.hanoi)

这是一个更复杂的例子,使用问题链接中提供的数据(答案末尾的图形).

bwplot(crime.v ~ bias, data=df, ylim=c(-1,1), pch="|", coef=0, panel=function(...){panel.hanoi(col="pink", breaks=cv.ints, ...); panel.bwplot(...)})

此示例添加ylim以指定绘图应从-1到1,并在河内图上方覆盖bwplot. pch并coef影响bwplot的外观.该示例还使用以下定义将Hanoi图的每个框围绕我的数据点所在的位置(请参阅原始问题):

cv.ints <- c(-1.000000000, -0.960000012, -0.822307704, -0.684615396, -0.546923088, -0.409230781, -0.271538473, -0.133846165, 0.003846142, 0.141538450, 0.279230758, 0.416923065, 0.554615373, 0.692307681, 0.829999988, 0.967692296, 1.000000000)

这是面板功能:

panel.hanoi <- function(x, y, horizontal, breaks="Sturges", ...) {  # "Sturges" is hist()'s default

  if (horizontal) {
    condvar <- y # conditioning ("independent") variable
    datavar <- x # data ("dependent") variable
  } else {
    condvar <- x
    datavar <- y
  }

  conds <- sort(unique(condvar))

  # loop through the possible values of the conditioning variable
  for (i in seq_along(conds)) {

      h <- hist(datavar[condvar == conds[i]], plot=F, breaks) # use base hist(ogram) function to extract some information

    # strip outer counts == 0, and corresponding bins
    brks.cnts <- stripOuterZeros(h$breaks, h$counts)
    brks <- brks.cnts[[1]]
    cnts <- brks.cnts[[2]]

    halfrelfs <- (cnts/sum(cnts))/2  # i.e. half of the relative frequency
    center <- i

    # All of the variables passed to panel.rec will usually be vectors, and panel.rect will therefore make multiple rectangles.
    if (horizontal) {
      panel.rect(head(brks, -1), center - halfrelfs, tail(brks, -1), center + halfrelfs, ...)
    } else {
      panel.rect(center - halfrelfs, head(brks, -1), center + halfrelfs, tail(brks, -1), ...)
    }
  }
}

# function to strip counts that are all zero on ends of data, along with the corresponding breaks
stripOuterZeros <- function(brks, cnts) { do.call("stripLeftZeros", stripRightZeros(brks, cnts)) }

stripLeftZeros <- function(brks, cnts) {
  if (cnts[1] == 0) {
    stripLeftZeros(brks[-1], cnts[-1])
  } else {
    list(brks, cnts)
  }
}

stripRightZeros <- function(brks, cnts) {
  len <- length(cnts)
  if (cnts[len] ==0) {
    stripRightZeros(brks[-(len+1)], cnts[-len])
  } else {
    list(brks, cnts)
  }
}