Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'feature/stat-aggregate' into cutting-edge

Conflicts:
	DESCRIPTION
  • Loading branch information...
commit 43793cf5f1f60f34ba5d07215ba7399f012938c6 2 parents 50700ca + 89fff49
@kohske kohske authored
View
2  DESCRIPTION
@@ -182,3 +182,5 @@ Collate:
'guides-.r'
'guide-legend.r'
'guide-colorbar.r'
+ 'stat-aggr-2d.r'
+ 'stat-aggr-hex.r'
View
2  NAMESPACE
@@ -154,6 +154,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)
View
24 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.
+}
+
View
24 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.
+}
+
View
84 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]
+ })
+ }
+})
View
66 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)
+ }
+})
Please sign in to comment.
Something went wrong with that request. Please try again.