[R] stacked histograms

[Deepayan Sarkar]

On 4/13/07, Deepayan Sarkar <deepayan.sarkar at gmail.com> wrote:

[...]

> Write your own panel function, it shouldn't be too hard.

And since this comes up every once in a while, here's a possible implementation:


library(lattice)

hist.constructor <-
    function(x, breaks,
             include.lowest = TRUE,
             right = TRUE, ...)
{
    if (is.numeric(breaks) && length(breaks) > 1)
        hist(as.numeric(x), breaks = breaks, plot = FALSE,
             include.lowest = include.lowest,
             right = right)
    else
        hist(as.numeric(x), breaks = breaks, plot = FALSE)
}



panel.grouped.histogram <-
    function(x,
             groups = stop("groups must be specified"), subscripts,
             breaks, equal.widths = TRUE, type = "density",
             nint = round(log2(length(x)) + 1),
             alpha = plot.polygon$alpha,
             col = plot.polygon$col,
             border = plot.polygon$border,
             lty = plot.polygon$lty,
             lwd = plot.polygon$lwd, ...)
{
    plot.polygon <- trellis.par.get("superpose.polygon")
    if (length(x) < 1) return()
    if (is.null(breaks)) {
        breaks <- if (is.factor(x))
            seq_len(1 + nlevels(x)) - 0.5
        else if (equal.widths)
            do.breaks(range(x, finite = TRUE), nint)
        else quantile(x, 0:nint/nint, na.rm = TRUE)
    }
    h <- hist.constructor(x, breaks = breaks, ...)
    y <-
        switch(type,
               count = h$counts,
               percent = 100 * h$counts/length(x),
               density = h$intensities)
    breaks <- h$breaks
    stopifnot((nb <- length(breaks)) > 1)

    ## support for groups
    vals <-
        if (is.factor(groups)) levels(groups)
        else sort(unique(groups))
    nvals <- length(vals)
    subg <- groups[subscripts]
    ok <- !is.na(subg)

    alpha <- rep(alpha, nvals)
    col <- rep(col, nvals)
    border <- rep(border, nvals)
    lty <- rep(lty, nvals)
    lwd <- rep(lwd, nvals)

    props.group <-
        sapply(vals,
               function(v) {
                   id <- subg == v
                   hv <- hist.constructor(x[id], breaks = breaks, ...)
                   if (type == "density") hv$intensities
                   else hv$counts
               })
    props.group <- prop.table(props.group, margin = 1)
    y.group <-
        sapply(seq_along(y),
               function(i) y[i] * c(0, cumsum(props.group[i, ])))
    for (i in seq_len(nvals))
    {
        panel.rect(x = breaks[-nb],
                   y = y.group[i, ],
                   height = y.group[i + 1, ] - y.group[i, ],
                   width = diff(breaks),
                   col = col[i], alpha = alpha[i],
                   border = border[i], lty = lty[i],
                   lwd = lwd[i],
                   just = c("left", "bottom"))
    }
}


histogram(~height, singer)

histogram(~height, singer, groups = voice.part,
          panel = panel.grouped.histogram,
          auto.key =
          list(space = "right", reverse.rows = TRUE,
               points = FALSE, rectangles = TRUE))


-Deepayan