Instantly share code, notes, and snippets.

# kohske/stat_aggr.R Created Nov 5, 2011

What would you like to do?
stat_aggr2d and stat_aggrhex in ggplot2
 # test with R 2.14.0 and ggplot2 0.8.9 library(ggplot2) # define stat_aggr2d 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 = scales\$x\$output_set(), y = scales\$y\$output_set() ) # 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) 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] }) } }) stat_aggr2d <- StatAggr2d\$build_accessor() # define stat_aggrhex 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_hexbin") if (is.null(binwidth)) { binwidth <- c( diff(scales\$x\$input_set()) / bins, diff(scales\$y\$input_set() ) / bins ) } try_require("hexbin") x <- data\$x y <- data\$y # Convert binwidths into bounds + nbins 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) } }) stat_aggrhex <- StatAggrhex\$build_accessor() # example xs <- runif(100,-1,1) ys <- runif(100,-1,1) rts <- rnorm(100) testDF <- data.frame("x"=xs,"y"=ys,"rt"=rts) ggplot(data = testDF,aes(x=x,y=y, z=rts)) + stat_aggr2d(bins=3) ggplot(data = testDF,aes(x=x,y=y, z=rts)) + stat_aggr2d(bins=3, fun = function(x) sum(x^2)) ggplot(data = testDF,aes(x=x,y=y, z=rts)) + stat_aggrhex(bins=3) ggplot(data = testDF,aes(x=x,y=y, z=rts)) + stat_aggrhex(bins=3, fun = function(x) sum(x^2))

### PauloEduardoCardoso commented Feb 5, 2014

 Error in proto(Stat, { : object 'Stat' not found Where Stat object came from?