Merge pull request #293 from wch/feature/violin-clean

Feature/violin-clean

Author: hadley

DESCRIPTION

@@ -102,6 +102,7 @@ Collate:
     'geom-smooth.r'
     'geom-text.r'
     'geom-tile.r'
+    'geom-violin.r'
     'geom-vline.r'
     'ggplot2.r'
     'grob-absolute.r'
@@ -170,6 +171,7 @@ Collate:
     'stat-summary.r'
     'stat-unique.r'
     'stat-vline.r'
+    'stat-ydensity.r'
     'summary.r'
     'templates.r'
     'theme-defaults.r'

NAMESPACE

@@ -60,6 +60,7 @@ export(geom_smooth)
 export(geom_step)
 export(geom_text)
 export(geom_tile)
+export(geom_violin)
 export(geom_vline)
 export(ggfluctuation)
 export(ggmissing)
@@ -185,6 +186,7 @@ export(stat_sum)
 export(stat_summary)
 export(stat_unique)
 export(stat_vline)
+export(stat_ydensity)
 export(theme_blank)
 export(theme_bw)
 export(theme_get)

NEWS

@@ -13,6 +13,9 @@ NEW FEATURES
   `annotation_raster`, an even faster special case, for when you want to draw
   the same raster in each panel.
 
+* `geom_violin`: an implementation violin plots, which are a way of visualizing
+  kernel density estimates. (Thanks to Winston Chang)
+
 * New fortify methods have been added for objects produced by the `multcomp`
   package.
 

R/geom-violin.r

@@ -0,0 +1,119 @@
+#' Violin plot.
+#'
+#' @param trim If \code{TRUE} (default), trim the tails of the violins
+#'   to the range of the data. If \code{FALSE}, don't trim the tails.
+#' @param scale if "equal" (default), all violins have the same area (to be
+#'   precise, they would have the same area if tails are not trimmed). If
+#'   "count", the areas are scaled proportionally to the number of observations.
+#' @export
+#' @examples
+#' p <- ggplot(mtcars, aes(factor(cyl), mpg))
+#' 
+#' p + geom_violin()
+#' qplot(factor(cyl), mpg, data = mtcars, geom = "violin")
+#' 
+#' p + geom_violin() + geom_jitter(height = 0)
+#' p + geom_violin() + coord_flip()
+#' qplot(factor(cyl), mpg, data = mtcars, geom = "violin") +
+#'   coord_flip()
+#' 
+#' # Scale maximum width proportional to sample size:
+#' p + geom_violin(scale = "count")
+#' 
+#' # Default is to trim violins to the range of the data. To disable:
+#' p + geom_violin(trim = FALSE)
+#' 
+#' # Use a smaller bandwidth for closer density fit (default is 1).
+#' p + geom_violin(adjust = .5)
+#' 
+#' # Add aesthetic mappings
+#' # Note that violins are automatically dodged when any aesthetic is 
+#' # a factor
+#' p + geom_violin(aes(fill = cyl))
+#' p + geom_violin(aes(fill = factor(cyl)))
+#' p + geom_violin(aes(fill = factor(vs)))
+#' p + geom_violin(aes(fill = factor(am)))
+#' 
+#' # Set aesthetics to fixed value
+#' p + geom_violin(fill = "grey80", colour = "#3366FF")
+#' qplot(factor(cyl), mpg, data = mtcars, geom = "violin", 
+#'   colour = I("#3366FF"))
+#' 
+#' # Scales vs. coordinate transforms -------
+#' # Scale transformations occur before the density statistics are computed.
+#' # Coordinate transformations occur afterwards.  Observe the effect on the
+#' # number of outliers.
+#' m <- ggplot(movies, aes(y = votes, x = rating,
+#'    group = round_any(rating, 0.5)))
+#' m + geom_violin()
+#' m + geom_violin() + scale_y_log10()
+#' m + geom_violin() + coord_trans(y = "log10")
+#' m + geom_violin() + scale_y_log10() + coord_trans(y = "log10")
+#' 
+#' # Violin plots with continuous x:
+#' # Use the group aesthetic to group observations in violins
+#' qplot(year, budget, data = movies, geom = "violin")
+#' qplot(year, budget, data = movies, geom = "violin", 
+#'   group = round_any(year, 10, floor))
+#'
+geom_violin <- function (mapping = NULL, data = NULL, stat = "ydensity", position = "dodge",
+trim = TRUE, scale = "equal", ...) {
+  GeomViolin$new(mapping = mapping, data = data, stat = stat, 
+  position = position, trim = trim, scale = scale, ...)
+}
+
+GeomViolin <- proto(Geom, {
+  objname <- "violin"
+
+  reparameterise <- function(., df, params) {
+    df$width <- df$width %||% 
+      params$width %||% (resolution(df$x, FALSE) * 0.9)
+
+    # ymin, ymax, xmin, and xmax define the bounding rectangle for each group
+    ddply(df, .(group), transform,
+          ymin = min(y),
+          ymax = max(y),
+          xmin = x - width / 2,
+          xmax = x + width / 2)
+
+  }
+  
+  draw <- function(., data, ...) { 
+
+    # Find the points for the line to go all the way around
+    data <- transform(data, xminv = x - scaled * (x-xmin),
+                            xmaxv = x + scaled * (xmax-x))
+
+    # Make sure it's sorted properly to draw the outline
+    newdata <- rbind(arrange(transform(data, x = xminv), y),
+                     arrange(transform(data, x = xmaxv), -y))
+
+    # Close the polygon: set first and last point the same
+    # Needed for coord_polar and such
+    newdata <- rbind(newdata, newdata[1,])
+
+    ggname(.$my_name(), GeomPolygon$draw(newdata, ...))
+  }
+
+  guide_geom <- function(.) "polygon"
+
+  icon <- function(.) {
+    y <- seq(-.3, .3, length=40)
+    x1 <- dnorm(y, mean = -.15, sd = 0.05) + 1.5*dnorm(y, mean = 0.1, sd = 0.1)
+    x2 <- dnorm(y, mean = -.1, sd = 0.1) + dnorm(y, mean = 0.1, sd = 0.1)
+
+    y <- c(y, rev(y))
+    x1 <- c(x1, -rev(x1)) / max(8 * x1)
+    x2 <- c(x2, -rev(x2)) / max(8 * x2)
+    gTree(children = gList(
+      polygonGrob(x1 + .30, y + .35, default = "npc", gp = gpar(fill = "black")),
+      polygonGrob(x2 + .70, y + .55, default = "npc", gp = gpar(fill = "black"))
+    ))
+  }
+  
+  default_stat <- function(.) StatYdensity
+  default_pos <- function(.) PositionDodge
+  default_aes <- function(.) aes(weight=1, colour="grey20", fill="white", size=0.5, alpha = 1, linetype = "solid")
+  required_aes <- c("x", "y")
+
+})

R/position-collide.r

@@ -85,7 +85,7 @@ pos_fill <- function(df, width) {
 # Dodge overlapping interval.
 # Assumes that each set has the same horizontal position.
 pos_dodge <- function(df, width) {
-  n <- nrow(df)
+  n <- length(unique(df$group))
   if (n == 1) return(df)
 
   if (!all(c("xmin", "xmax") %in% names(df))) {
@@ -99,8 +99,12 @@ pos_dodge <- function(df, width) {
   # df <- data.frame(n = c(2:5, 10, 26), div = c(4, 3, 2.666666,  2.5, 2.2, 2.1))
   # qplot(n, div, data = df)
 
+  # Have a new group index from 1 to number of groups.
+  # This might be needed if the group numbers in this set don't include all of 1:n
+  groupidx <- match(df$group, sort(unique(df$group)))
+
   within(df, {
-    xmin <- xmin + width / n * (seq_len(n) - 1) - diff * (n - 1) / (2 * n)
+    xmin <- xmin + width / n * (groupidx - 1) - diff * (n - 1) / (2 * n)
     xmax <- xmin + d_width / n
     x <- (xmin + xmax) / 2
   })

R/stat-ydensity.r

@@ -0,0 +1,81 @@
+#' 1d kernel density estimate along y axis, for violin plot.
+#'
+#' @inheritParams stat_density
+#' @param trim If \code{TRUE} (default), trim the tails of the violins
+#'   to the range of the data. If \code{FALSE}, don't trim the tails.
+#' @param scale if "equal" (default), all violins have the same area (to be
+#'   precise, they would have the same area if tails are not trimmed). If
+#'   "count", the areas are scaled proportionally to the number of observations.
+#'
+#' @return A data frame with additional columns:
+#'   \item{width}{width of violin bounding box}
+#'   \item{ydensity}{density estimate}
+#'   \item{scaled}{density estimate, scaled depending on scalearea and scalecount}
+#'   \item{count}{ydensity * number of points}
+#'   \item{counttotal}{number of points} 
+#' @examples
+#' # See geom_violin for examples
+#' # Also see stat_density for similar examples with data along x axis
+stat_ydensity <- function (mapping = NULL, data = NULL, geom = "violin", position = "dodge", 
+adjust = 1, kernel = "gaussian", trim = TRUE, scale = "equal", na.rm = FALSE, ...) {
+  StatYdensity$new(mapping = mapping, data = data, geom = geom, position = position,
+  adjust = adjust, kernel = kernel, trim = trim, scale = scale,
+  na.rm = na.rm, ...)
+}
+  
+StatYdensity <- proto(Stat, {
+  objname <- "ydensity"
+
+  calculate_groups <- function(., data, na.rm = FALSE, width = NULL,
+                               scale = "equal", ...) {
+    data <- remove_missing(data, na.rm, "y", name = "stat_ydensity", finite = TRUE)
+    data <- .super$calculate_groups(., data, na.rm = na.rm, width = width, ...)
+
+    # Scale to have equal areas
+    data$scaled <- data$ydensity / max(data$ydensity)
+
+    if (scale == "count") {
+      data$scaled <- data$scaled * data$counttotal/max(data$counttotal)
+    } else if (scale != "equal") {
+      stop('scale must be "equal" or "count".')
+    }
+
+    data
+  }
+
+  calculate <- function(., data, scales, width=NULL, adjust=1, kernel="gaussian",
+                        trim=TRUE, na.rm = FALSE, ...) {
+    
+    n <- nrow(data)
+
+    # If just 1 point, return a flat violin
+    if (n < 2) { return(data.frame(data, scaled = 1, ydensity = 1, count = 1)) }
+    if (is.null(data$weight)) { data$weight <- rep(1, n) / n }
+
+    if(trim) {
+      dens <- density(data$y, adjust = adjust, kernel = kernel, weight = data$weight,
+                      n = 200, from = min(data$y), to = max(data$y))
+    } else  {
+      dens <- density(data$y, adjust = adjust, kernel = kernel, weight = data$weight,
+                      n = 200)
+    }
+
+    # We predict ydensity from y ('density' calls them y and x, respectively)
+    densdf <- data.frame(ydensity = dens$y, y = dens$x)
+    densdf$scaled <- densdf$ydensity / max(densdf$ydensity, na.rm = TRUE)
+
+    if (length(unique(data$x)) > 1) { width <- diff(range(data$x)) * 0.9 }
+
+    densdf$x <- mean(range(data$x))
+    densdf$count <- densdf$ydensity * n
+    densdf$counttotal <- n
+    densdf$width <- width
+
+    densdf
+  }
+
+  icon <- function(.) GeomViolin$icon()
+  default_geom <- function(.) GeomViolin
+  required_aes <- c("x", "y")
+
+})

inst/tests/visual-violin.r

@@ -0,0 +1,46 @@
+set.seed(111)
+dat <- data.frame(x=LETTERS[1:3], y=rnorm(90))
+dat <- dat[ dat$x!="C" | c(T,F), ]  # Keep half the C's
+
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin() +
+  opts(title="Basic violin")
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin() + geom_point(shape=21) +
+  opts(title="Basic violin with overlaid points")
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin(scale="count") +
+  opts(title="Scale area to sample size (C is smaller)")
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin(width=.5) +
+  opts(title="Narrower (width=.5)")
+
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin(trim=FALSE) + geom_point(shape=21) +
+  opts(title="With tails and points")
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin(adjust=.3) + geom_point(shape=21) +
+  opts(title="With smaller bandwidth and points")
+
+
+ggplot(dat, aes(x="foo", y=y, fill=x)) + geom_violin() +
+  opts(title="Dodging")
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin() + coord_polar() +
+  opts(title="coord_polar")
+
+ggplot(dat, aes(x=x, y=y)) + geom_violin() + coord_flip() +
+  opts(title="coord_flip")
+
+ggplot(dat, aes(x="foo", y=y, fill=x)) + geom_violin() + coord_flip() +
+  opts(title="Dodging and coord_flip")
+
+ggplot(dat, aes(x=as.numeric(x), y=y)) + geom_violin() +
+  opts(title="Continuous x axis, multiple groups\n(center should be 2)")
+
+ggplot(dat, aes(x=as.numeric(1), y=y)) + geom_violin() +
+  opts(title="Continuous x axis, single group")
+
+ggplot(d2, aes(x=x, y=y, fill=g)) + geom_violin() +
+  opts(title="Grouping on x and fill")
+