stat-summary-2d/hex: minor update (handling NA, change the origin for 2d).

Author: kohske

R/stat-summary-2d.r

@@ -9,8 +9,9 @@
 #' # Specifying function
 #' d + stat_summary2d(fun = function(x) sum(x^2))
 #' d + stat_summary2d(fun = var)
-stat_summary2d <- function (mapping = NULL, data = NULL, geom = "rect", position = "identity", 
+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, ...)
 }
@@ -24,11 +25,24 @@ StatSummary2d <- proto(Stat, {
 
   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)
@@ -48,29 +62,25 @@ StatSummary2d <- proto(Stat, {
 
     # 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])
-        )
-      }
+      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)))
     }
-    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, ...)))
 
+    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]

R/stat-summary-hex.r

@@ -10,9 +10,10 @@
 #' 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, na.rm = FALSE, fun = mean, ...) { 
+bins = 30, drop = TRUE, fun = mean, ...) {
+  
   StatSummaryhex$new(mapping = mapping, data = data, geom = geom, position = position, 
-  bins = bins, na.rm = na.rm, fun = fun, ...)
+  bins = bins, drop = drop, fun = fun, ...)
 }
 
 StatSummaryhex <- proto(Stat, {
@@ -22,9 +23,9 @@ StatSummaryhex <- proto(Stat, {
   required_aes <- c("x", "y", "z")
   default_geom <- function(.) GeomHex
 
-  calculate <- function(., data, scales, binwidth = NULL, bins = 30, na.rm = FALSE, fun = mean, ...) {
+  calculate <- function(., data, scales, binwidth = NULL, bins = 30, drop = TRUE, fun = mean, ...) {
     try_require("hexbin")
-    data <- remove_missing(data, na.rm, c("x", "y"), name="stat_summaryhex")
+    data <- remove_missing(data, FALSE, c("x", "y", "z"), name="stat_summary_hex")
 
     if (is.null(binwidth)) {
       binwidth <- c( 
@@ -59,8 +60,10 @@ StatSummaryhex <- proto(Stat, {
     )
 
     value <- tapply(data$z, hb@cID, fun, ...)
-    
+
     # Convert to data frame
-    data.frame(hcell2xy(hb), value)
+    ret <- data.frame(hcell2xy(hb), value)
+    if (drop) ret <- na.omit(ret)
+    ret
   }
 })