stat-aggr2d and stat-aggrhex: implementation of 2d aggregation.

DESCRIPTION

@@ -180,3 +180,5 @@ Collate:
     'utilities.r'
     'xxx-digest.r'
     'zxx.r'
+    'stat-aggr-2d.r'
+    'stat-aggr-hex.r'

NAMESPACE

@@ -151,6 +151,8 @@ 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)

man/stat_aggr2d.Rd

@@ -0,0 +1,24 @@
+\name{stat_aggr2d}
+\alias{stat_aggr2d}
+\title{Apply function for rectangular bins.}
+\usage{
+  stat_aggr2d(mapping = NULL, data = NULL, geom = "rect",
+  position = "identity", bins = 30, drop = TRUE, fun =
+  mean, ...)
+}
+\description{
+  Apply function for rectangular bins.
+}
+\examples{
+d <- ggplot(diamonds, aes(carat, depth, z = price))
+d + stat_aggr2d()
+
+# Specifying function
+d + stat_aggr2d(fun = function(x) sum(x^2))
+d + stat_aggr2d(fun = var)
+}
+\seealso{
+  \code{\link{stat_aggrhex}} for hexagonal aggregation.
+  \code{\link{stat_bin2d}} for the binning options.
+}
+

man/stat_aggrhex.Rd

@@ -0,0 +1,24 @@
+\name{stat_aggrhex}
+\alias{stat_aggrhex}
+\title{Aggregate 2d plane into hexagons.}
+\usage{
+  stat_aggrhex(mapping = NULL, data = NULL, geom = "hex",
+  position = "identity", bins = 30, na.rm = FALSE, fun =
+  mean, ...)
+}
+\description{
+  Aggregate 2d plane into hexagons.
+}
+\examples{
+d <- ggplot(diamonds, aes(carat, price))
+d + stat_aggrhex()
+
+# Specifying function
+d + stat_aggrhex(fun = function(x) sum(x^2))
+d + stat_aggrhex(fun = var)
+}
+\seealso{
+  \code{\link{stat_aggr2d}} for rectangular aggregation.
+  \code{\link{stat_bin2d}} for the hexagon-ing options.
+}
+

r/stat-aggr-2d.r

@@ -0,0 +1,84 @@
+#' Apply function for rectangular bins.
+#' 
+#' @seealso \code{\link{stat_aggrhex}} for hexagonal aggregation. \code{\link{stat_bin2d}} for the binning options.
+#' @export
+#' @examples
+#' d <- ggplot(diamonds, aes(carat, depth, z = price))
+#' d + stat_aggr2d()
+#'
+#' # Specifying function
+#' d + stat_aggr2d(fun = function(x) sum(x^2))
+#' d + stat_aggr2d(fun = var)
+stat_aggr2d <- function (mapping = NULL, data = NULL, geom = "rect", position = "identity", 
+bins = 30, drop = TRUE, fun = mean, ...) {
+  StatAggr2d$new(mapping = mapping, data = data, geom = geom, position = position, 
+  bins = bins, drop = drop, fun = fun, ...)
+}
+
+StatAggr2d <- proto(Stat, {
+  objname <- "aggr2d"
+
+  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, ...) {
+
+    range <- list(
+      x = scale_dimension(scales$x, c(0, 0)),
+      y = scale_dimension(scales$y, c(0, 0))
+    )
+
+    # 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)) {
+      if (is.null(origin)) {
+        breaks <- list(
+          fullseq(range$x, binwidth[1]),
+          fullseq(range$y, binwidth[2])
+        )
+      } else {
+        breaks <- list(
+          seq(origin[1], max(range$x) + binwidth[1], binwidth[1]),
+          seq(origin[2], max(range$y) + binwidth[2], binwidth[2])
+        )
+      }
+    }
+    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)
+browser()
+    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)))
+
+    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,66 @@
+#' Aggregate 2d plane into hexagons.
+#' 
+#' @seealso \code{\link{stat_aggr2d}} for rectangular aggregation. \code{\link{stat_bin2d}} for the hexagon-ing options.
+#' @export
+#' @examples
+#' d <- ggplot(diamonds, aes(carat, price))
+#' d + stat_aggrhex()
+#' 
+#' # Specifying function
+#' d + stat_aggrhex(fun = function(x) sum(x^2))
+#' d + stat_aggrhex(fun = var)
+stat_aggrhex <- function (mapping = NULL, data = NULL, geom = "hex", position = "identity", 
+bins = 30, na.rm = FALSE, fun = mean, ...) { 
+  StatAggrhex$new(mapping = mapping, data = data, geom = geom, position = position, 
+  bins = bins, na.rm = na.rm, fun = fun, ...)
+}
+
+StatAggrhex <- proto(Stat, {
+  objname <- "aggrhex"
+
+  default_aes <- function(.) aes(fill = ..value..)
+  required_aes <- c("x", "y", "z")
+  default_geom <- function(.) GeomHex
+
+  calculate <- function(., data, scales, binwidth = NULL, bins = 30, na.rm = FALSE, fun = mean, ...) {
+    try_require("hexbin")
+    data <- remove_missing(data, na.rm, c("x", "y"), name="stat_aggrbin")
+
+    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
+    data.frame(hcell2xy(hb), value)
+  }
+})