Coloring each violin in a different color in panel.violin of bwplot

Question

Suppose I have this example data.frame:

df <- data.frame(y=c(rnorm(150, 2, 1), rnorm(100, 1, 1.5), rnorm(200, 3, 0.75)), x=c(rep("c1", 150),rep("c2", 100),rep("c3", 200)), color=c(rep("gray",150),rep("red",150),rep("blue",150)))

and I would like to use the panel.violin function of bwplot, such that the violins are filled with the colors that correspond to the y's in df. Obviously the following doesn't work:

bwplot(y ~ x, data = df, horizontal=FALSE, xlab=unique(df$x),
       panel = function(..., box.ratio) {
         panel.violin(..., col = df$color, varwidth = FALSE, box.ratio = box.ratio)
         panel.bwplot(..., col='black', cex=0.8, pch='|', fill="white", box.ratio = .1)},
       par.settings = list(box.rectangle=list(col='black'),
                           plot.symbol = list(pch='.', cex = 0.1)),
       scales=list(x=list(rot=45, cex=0.5)))

One more thing that would be nice is to be able to disable the default x axis of panel.violin

Answer 1

It's been a while, but it turned out that a search on the rhelp archives pulled up an effort of mine 4 years ago in that venue: My argument for needing to construct a substitute panel function was ... "it required a minor hack to panel.violin, since in its native state panel.violin only passes a single-element vector the the grid plotting functions."

panel.violin.hack <-
function (x, y, box.ratio = 1, box.width = box.ratio/(1 + box.ratio),
     horizontal = TRUE, alpha = plot.polygon$alpha, border =  
plot.polygon$border,
     lty = plot.polygon$lty, lwd = plot.polygon$lwd, col = plot.polygon 
$col,
     varwidth = FALSE, bw = NULL, adjust = NULL, kernel = NULL,
     window = NULL, width = NULL, n = 50, from = NULL, to = NULL,
     cut = NULL, na.rm = TRUE, ...)
{
     if (all(is.na(x) | is.na(y)))
         return()
     x <- as.numeric(x)
     y <- as.numeric(y)
     plot.polygon <- trellis.par.get("plot.polygon")
     darg <- list()
     darg$bw <- bw
     darg$adjust <- adjust
     darg$kernel <- kernel
     darg$window <- window
     darg$width <- width
     darg$n <- n
     darg$from <- from
     darg$to <- to
     darg$cut <- cut
     darg$na.rm <- na.rm
     my.density <- function(x) {
         ans <- try(do.call("density", c(list(x = x), darg)),
             silent = TRUE)
         if (inherits(ans, "try-error"))
             list(x = rep(x[1], 3), y = c(0, 1, 0))
         else ans
     }
     numeric.list <- if (horizontal)
         split(x, factor(y))
     else split(y, factor(x))
     levels.fos <- as.numeric(names(numeric.list))
     d.list <- lapply(numeric.list, my.density)
     dx.list <- lapply(d.list, "[[", "x")
     dy.list <- lapply(d.list, "[[", "y")
     max.d <- sapply(dy.list, max)
     if (varwidth)
         max.d[] <- max(max.d)
     xscale <- current.panel.limits()$xlim
     yscale <- current.panel.limits()$ylim
     height <- box.width
     if (horizontal) {
         for (i in seq_along(levels.fos)) {
             if (is.finite(max.d[i])) {
                 pushViewport(viewport(y = unit(levels.fos[i],
                   "native"), height = unit(height, "native"),
                   yscale = c(max.d[i] * c(-1, 1)), xscale = xscale))
                 grid.polygon(x = c(dx.list[[i]], rev(dx.list[[i]])),
                   y = c(dy.list[[i]], -rev(dy.list[[i]])),  
default.units = "native",
# this is the point at which the index is added
                   gp = gpar(fill = col[i], col = border, lty = lty,
                     lwd = lwd, alpha = alpha))
                 popViewport()
             }
         }
     }
     else {
         for (i in seq_along(levels.fos)) {
             if (is.finite(max.d[i])) {
                 pushViewport(viewport(x = unit(levels.fos[i],
                   "native"), width = unit(height, "native"),
                   xscale = c(max.d[i] * c(-1, 1)), yscale = yscale))
                 grid.polygon(y = c(dx.list[[i]], rev(dx.list[[i]])),
                   x = c(dy.list[[i]], -rev(dy.list[[i]])),  
default.units = "native",
# this is the point at which the index is added
                   gp = gpar(fill = col[i], col = border, lty = lty,
                     lwd = lwd, alpha = alpha))
                 popViewport()
             }
         }
     }
     invisible()
}

Do need to load grid as well:

load(grid)
bwplot(y ~ x, data = df, horizontal=FALSE, xlab=unique(df$x), col=c("yellow", "green"),
    panel = function(x,y, subscripts,  col=col, ..., box.ratio){
        panel.violin.hack(x,y,   col=col, ...,                               varwidth = FALSE, box.ratio = 0.1)
        panel.bwplot(x,y, ...,  box.ratio = .1)     },
                 )