Merge pull request #291 from kohske/feature/summary-2D

2D/hex summary

Author: hadley

DESCRIPTION

@@ -151,8 +151,8 @@ Collate:
     'scale-size.r'
     'scales-.r'
     'stat-.r'
-    'stat-aggr-2d.r'
-    'stat-aggr-hex.r'
+    'stat-summary-2d.r'
+    'stat-summary-hex.r'
     'stat-bin.r'
     'stat-bin2d.r'
     'stat-binhex.r'

NAMESPACE

@@ -166,8 +166,6 @@ export(scale_y_reverse)
 export(scale_y_sqrt)
 export(should_stop)
 export(stat_abline)
-export(stat_aggr2d)
-export(stat_aggrhex)
 export(stat_bin)
 export(stat_bin2d)
 export(stat_binhex)
@@ -183,7 +181,9 @@ export(stat_quantile)
 export(stat_smooth)
 export(stat_spoke)
 export(stat_sum)
+export(stat_summary_hex)
 export(stat_summary)
+export(stat_summary2d)
 export(stat_unique)
 export(stat_vline)
 export(stat_ydensity)

NEWS

@@ -19,6 +19,10 @@ NEW FEATURES
 * New fortify methods have been added for objects produced by the `multcomp`
   package.
 
+* `stat_summary2d` / `stat_summary_hex`. These are arbitrary function version
+  of stat_bin2d / stat_binhex. Any summarization (as stat-summary for 1D) can
+  be done for 2D.
+
 DEVELOPMENT
 
 * ggplot2 has moved away from the two (!!) homegrown documentation systems

R/stat-aggr-2d.r

@@ -0,0 +1,114 @@
+##' Apply function for 2D rectangular bins.
+##'
+##' \code{stat_summary2d} is 2D version of \code{\link{stat_summary}}. The data are devided by \code{x} and \code{y}.
+##' \code{z} in each cell is passed to arbitral summary function.
+##' 
+##' \code{stat_summary2d} requires the following aesthetics:
+##'
+##' \itemize{
+##'  \item \code{x}: horizontal position
+##'  \item \code{y}: vertical position
+##'  \item \code{z}: value passed to the summary function
+##' }
+##' 
+##' @seealso \code{\link{stat_summary_hex}} for hexagonal summarization. \code{\link{stat_bin2d}} for the binning options.
+##' @title Apply funciton for 2D rectangular bins.
+##' @param mapping 
+##' @param data 
+##' @param geom 
+##' @param position 
+##' @param bins see \code{\link{stat_bin2d}}
+##' @param drop drop if the output of \code{fun} is \code{NA}.
+##' @param fun function for summary.
+##' @param ... parameters passed to \code{fun}
+##' @export
+##' @examples
+##' d <- ggplot(diamonds, aes(carat, depth, z = price))
+##' d + stat_summary2d()
+##'
+##' # Specifying function
+##' d + stat_summary2d(fun = function(x) sum(x^2))
+##' d + stat_summary2d(fun = var)
+stat_summary2d <- function (mapping = NULL, data = NULL, geom = NULL, position = "identity", 
+bins = 30, drop = TRUE, fun = mean, ...) {
+
+  StatSummary2d$new(mapping = mapping, data = data, geom = geom, position = position, 
+  bins = bins, drop = drop, fun = fun, ...)
+}
+
+StatSummary2d <- proto(Stat, {
+  objname <- "Summary2d"
+
+  default_aes <- function(.) aes(fill = ..value..)
+  required_aes <- c("x", "y", "z")
+  default_geom <- function(.) GeomRect
+
+  calculate <- function(., data, scales, binwidth = NULL, bins = 30, breaks = NULL, origin = NULL, drop = TRUE, fun = mean, ...) {
+
+    data <- remove_missing(data, FALSE, c("x", "y", "z"), name="stat_summary2d")
+    
+    range <- list(
+      x = scale_dimension(scales$x, c(0, 0)),
+      y = scale_dimension(scales$y, c(0, 0))
+    )
+
+    # Determine origin, if omitted
+    if (is.null(origin)) {
+      origin <- c(NA, NA)
+    } else {
+      stopifnot(is.numeric(origin))
+      stopifnot(length(origin) == 2)
+    }    
+    originf <- function(x) if (is.integer(x)) -0.5 else min(x)
+    if (is.na(origin[1])) origin[1] <- originf(data$x)
+    if (is.na(origin[2])) origin[2] <- originf(data$y)
+    
+    # Determine binwidth, if omitted
+    if (is.null(binwidth)) {
+      binwidth <- c(NA, NA)
+      if (is.integer(data$x)) {
+        binwidth[1] <- 1
+      } else {
+        binwidth[1] <- diff(range$x) / bins
+      }
+      if (is.integer(data$y)) {
+        binwidth[2] <- 1
+      } else {
+        binwidth[2] <- diff(range$y) / bins
+      }      
+    }
+    stopifnot(is.numeric(binwidth))
+    stopifnot(length(binwidth) == 2)
+
+    # Determine breaks, if omitted
+    if (is.null(breaks)) {
+      breaks <- list(
+        seq(origin[1], max(range$x) + binwidth[1], binwidth[1]),
+        seq(origin[2], max(range$y) + binwidth[2], binwidth[2])
+      )
+    } else {
+      stopifnot(is.list(breaks))
+      stopifnot(length(breaks) == 2)      
+      stopifnot(all(sapply(breaks, is.numeric)))
+    }
+    names(breaks) <- c("x", "y")
+
+    xbin <- cut(data$x, sort(breaks$x), include.lowest=TRUE)
+    ybin <- cut(data$y, sort(breaks$y), include.lowest=TRUE)
+
+    if (is.null(data$weight)) data$weight <- 1
+
+    ans <- ddply(data.frame(data, xbin, ybin), .(xbin, ybin), function(d) data.frame(value = fun(d$z, ...)))
+    if (drop) ans <- na.omit(ans)
+    
+    within(ans,{
+      xint <- as.numeric(xbin)
+      xmin <- breaks$x[xint]
+      xmax <- breaks$x[xint + 1]
+
+      yint <- as.numeric(ybin)
+      ymin <- breaks$y[yint]
+      ymax <- breaks$y[yint + 1]
+    })
+  }
+})

R/stat-aggr-hex.r

@@ -0,0 +1,85 @@
+##' Apply function for 2D hexagonal bins.
+##'
+##' \code{stat_summary2d} is hexagonal version of \code{\link{stat_summary}}. The data are devided by \code{x} and \code{y}.
+##' \code{z} in each cell is passed to arbitral summary function.
+##' 
+##' \code{stat_summary-hex} requires the following aesthetics:
+##'
+##' \itemize{
+##'  \item \code{x}: horizontal position
+##'  \item \code{y}: vertical position
+##'  \item \code{z}: value passed to the summary function
+##' }
+##' 
+##' @seealso \code{\link{stat_summary2d}} for rectangular summarization. \code{\link{stat_bin2d}} for the hexagon-ing options.
+##' @title Apply funciton for 2D hexagonal bins.
+##' @param bins see \code{\link{stat_binhex}}
+##' @param drop drop if the output of \code{fun} is \code{NA}.
+##' @param fun function for summary.
+##' @param ... parameters passed to \code{fun}
+##' @export
+##' @examples
+##' d <- ggplot(diamonds, aes(carat, depth, z = price))
+##' d + stat_summary_hex()
+##' 
+##' # Specifying function
+##' d + stat_summary_hex(fun = function(x) sum(x^2))
+##' d + stat_summary_hex(fun = var, na.rm = T)
+stat_summary_hex <- function (mapping = NULL, data = NULL, geom = "hex", position = "identity", 
+bins = 30, drop = TRUE, fun = mean, ...) {
+  
+  StatSummaryhex$new(mapping = mapping, data = data, geom = geom, position = position, 
+  bins = bins, drop = drop, fun = fun, ...)
+}
+
+StatSummaryhex <- proto(Stat, {
+  objname <- "summaryhex"
+
+  default_aes <- function(.) aes(fill = ..value..)
+  required_aes <- c("x", "y", "z")
+  default_geom <- function(.) GeomHex
+  
+  calculate <- function(., data, scales, binwidth = NULL, bins = 30, drop = TRUE, fun = mean, ...) {
+    try_require("hexbin")
+    data <- remove_missing(data, FALSE, c("x", "y", "z"), name="stat_summary_hex")
+
+    if (is.null(binwidth)) {
+      binwidth <- c( 
+        diff(scale_dimension(scales$x, c(0, 0))) / bins,
+        diff(scale_dimension(scales$y, c(0, 0))) / bins
+      )
+    }
+
+    try_require("hexbin")
+      
+    # Convert binwidths into bounds + nbins
+    x <- data$x
+    y <- data$y
+    
+    xbnds <- c(
+      round_any(min(x), binwidth[1], floor) - 1e-6, 
+      round_any(max(x), binwidth[1], ceiling) + 1e-6
+    )
+    xbins <- diff(xbnds) / binwidth[1]
+  
+    ybnds <- c(
+      round_any(min(y), binwidth[1], floor) - 1e-6, 
+      round_any(max(y), binwidth[2], ceiling) + 1e-6
+    )
+    ybins <- diff(ybnds) / binwidth[2]
+    
+    # Call hexbin
+    hb <- hexbin(
+      x, xbnds = xbnds, xbins = xbins,  
+      y, ybnds = ybnds, shape = ybins / xbins,
+      IDs = TRUE
+    )
+    
+    value <- tapply(data$z, hb@cID, fun, ...)
+
+    # Convert to data frame
+    ret <- data.frame(hcell2xy(hb), value)
+    if (drop) ret <- na.omit(ret)
+    ret
+  }
+})