r - 重叠晶格直方图的常见断点和自由轴

Question

实现重叠、多面的 lattice::histogram 所需的咒语是什么？具有共同的断点(跨组，但可能因面板而异)？
例如，假设我希望将每个面板的数据总范围(组合的组)分成 30 个箱。
示例数据:

library(lattice)
set.seed(1)
d <- data.frame(v1=rep(c('A', 'B'), each=1000), 
                v2=rep(c(0.5, 1), each=2000),
                mean=rep(c(0, 10, 2, 12), each=1000))
d$x <- rnorm(nrow(d), d$mean, d$v2)

使用 nint=30 ?

p1 <- histogram(~x|v1, d, groups=v2, nint=30,
                scales=list(relation='free'), type='percent',
                panel = function(...) {
                  panel.superpose(..., panel.groups=panel.histogram, 
                                  col=c('red', 'blue'), alpha=0.3)
                })
p1

上面，箱在各组之间是一致的，但是 (1) x 轴限制在面板之间共享(当 x 轴范围在面板之间有很大差异时会出现问题 - 我真的希望为每个面板单独计算 30 个箱)， (2) 使用 type='percent' 时 y 轴狭窄。 (它应该进一步扩展)。
使用 breaks=30 ?

p2 <- histogram(~x|v1, d, groups=v2, breaks=30,
                scales=list(relation='free'), type='percent',
                panel = function(...) {
                  panel.superpose(..., panel.groups=panel.histogram, 
                                  col=c('red', 'blue'), alpha=0.3)
                })
p2

现在轴限制看起来不错，但箱宽度因组而异。
所以...
使用 lattice ，如何实现重叠的多面直方图，这些直方图在面板内的各组之间具有恒定的 bin 宽度，但具有适合每个面板数据的轴限制？
(我意识到 ggplot 是一个选项，但我希望图形样式与我的其他格子图一致。)

Answer 1

这行得通，但我担心它相当行人。至少它只需要格子对象本身；它将假定您在每个面板中所需的箱数等于 nint 参数。

它的工作原理是这样的:检查面板范围是否重叠。如果他们不这样做，请将每个(稍微扩展的)范围拆分为 nint垃圾箱，然后将它们与中间的几个空垃圾箱连接起来。我们还需要计算出 y 范围，这是通过根据最大计数进行缩放来完成的。

fix_facets <- function(p1)
{
  n_bins <- p1$panel.args.common$nint
  xvals1 <- p1$panel.args[[1]]$x
  xvals2 <- p1$panel.args[[2]]$x

  if(min(xvals2) > max(xvals1) | min(xvals1) > max(xvals2)){
    left_range  <- range(xvals1)
    left_range  <- left_range + (diff(left_range) * c(-0.1, 0.1))
    left_bins   <- seq(left_range[1], left_range[2], diff(left_range)/n_bins)
    right_range <- range(xvals2)
    right_range  <- right_range + (diff(right_range) * c(-0.1, 0.1))
    right_bins   <- seq(right_range[1], right_range[2], diff(right_range)/n_bins)

    if(max(left_range) < min(right_range)){
      mid_bins <- seq(max(left_bins), min(right_bins), diff(left_bins[1:2]))
      all_bins <- c(left_bins, mid_bins, right_bins)
    } else {
      mid_bins <- seq(max(right_bins), min(left_bins), diff(right_bins[1:2]))
      all_bins <- c(right_bins, mid_bins, left_bins)
    }
    p1$panel.args.common$breaks <- all_bins
    p1$x.limits[[1]] <- left_range
    p1$x.limits[[2]] <- right_range
    histleft  <- hist(xvals1, breaks = left_bins)
    histright <- hist(xvals2, breaks = right_bins)
    group_factor <- 100 * length(p1$condlevels[[1]])

    p1$y.limits[[1]][2] <- group_factor * max(histleft$counts) / length(xvals1)
    p1$y.limits[[2]][2] <- group_factor * max(histright$counts) / length(xvals2)
  }
  return(p1)
}

因此，以您的示例为例，我们可以这样做:

p1 <- histogram(~x|v1, d, groups=v2, nint=30,
                scales=list(relation='free'), type='percent',
                panel = function(...) {
                  panel.superpose(..., panel.groups=panel.histogram, 
                                  col=c('red', 'blue'), alpha=0.3)
                })
fix_facets(p1)

并显示它适用于其他数量的垃圾箱......

p1 <- histogram(~x|v1, d, groups=v2, nint=10,
                scales=list(relation='free'), type='percent',
                panel = function(...) {
                  panel.superpose(..., panel.groups=panel.histogram, 
                                  col=c('red', 'blue'), alpha=0.3)
                })
fix_facets(p1)