Merge pull request #1527 from thomasp85/function_as_data

Function as data

Author: hadley

NAMESPACE

@@ -36,6 +36,7 @@ S3method(format,facet)
 S3method(format,ggproto)
 S3method(format,ggproto_method)
 S3method(fortify,"NULL")
+S3method(fortify,"function")
 S3method(fortify,Line)
 S3method(fortify,Lines)
 S3method(fortify,Polygon)

NEWS.md

@@ -1,5 +1,9 @@
 # ggplot2 2.0.0.9000
 
+* `layer()` now accepts a function as the data argument. The function will be
+  applied to the data passed to the `ggplot()` function and must return a
+  data.frame (#1527).
+  
 * The theme can now modify the margins of legend title and text (#1502).
 
 * `scale_size()` warns when used with categorical data.

R/fortify.r

@@ -16,6 +16,8 @@ fortify.data.frame <- function(model, data, ...) model
 #' @export
 fortify.NULL <- function(model, data, ...) waiver()
 #' @export
+fortify.function <- function(model, data, ...) model
+#' @export
 fortify.default <- function(model, data, ...) {
   stop(
     "ggplot2 doesn't know how to deal with data of class ",

R/layer.r

@@ -1,5 +1,25 @@
 #' Create a new layer
 #'
+#' A layer is a combination of data, stat and geom with a potential position
+#' adjustment. Usually layers are created using \code{geom_*} or \code{stat_*}
+#' calls but it can also be created directly using the \code{layer} function.
+#'
+#' @details
+#' The data in a layer can be specified in one of three ways:
+#'
+#' \itemize{
+#'  \item{If the data argument is \code{NULL} (the default) the data is
+#'  inherited from the global plot data as specified in the call to
+#'  \code{\link{ggplot}}.}
+#'  \item{If the data argument is a function, that function is called with the
+#'  global data as the only argument and the return value is used as the layer
+#'  data. The function must return a data.frame.}
+#'  \item{Any other type of value passed to \code{data} will be passed through
+#'  \code{\link{fortify}}, and there must thus be a \code{fortify} method
+#'  defined for the class of the value. Passing a data.frame is a special case
+#'  of this as \code{fortify.data.frame} returns the data.frame untouched.}
+#' }
+#'
 #' @export
 #' @inheritParams geom_point
 #' @param geom,stat,position Geom, stat and position adjustment to use in
@@ -16,6 +36,13 @@
 #'   layer(geom = "point", stat = "identity", position = "identity",
 #'     params = list(na.rm = FALSE)
 #'   )
+#'
+#' # use a function as data to plot a subset of global data
+#' ggplot(mpg, aes(displ, hwy)) +
+#'   layer(geom = "point", stat = "identity", position = "identity",
+#'     data = head, params = list(na.rm = FALSE)
+#'   )
+#'
 layer <- function(geom = NULL, stat = NULL,
                   data = NULL, mapping = NULL,
                   position = NULL, params = list(),
@@ -101,6 +128,20 @@ Layer <- ggproto("Layer", NULL,
     cat(snakeize(class(self$position)[[1]]), "\n")
   },
 
+  layer_data = function(self, plot_data) {
+    if (is.waive(self$data)) {
+      data <- plot_data
+    } else if (is.function(self$data)) {
+      data <- self$data(plot_data)
+      if (!is.data.frame(data)) {
+        stop("Data function must return a data.frame", call. = FALSE)
+      }
+    } else {
+      data <- self$data
+    }
+    data
+  },
+
   compute_aesthetics = function(self, data, plot) {
     # For annotation geoms, it is useful to be able to ignore the default aes
     if (self$inherit.aes) {

R/panel.r

@@ -45,10 +45,8 @@ train_layout <- function(panel, facet, data, plot_data) {
 # @param panel a trained panel object
 # @param the facetting specification
 # @param data list of data frames (one for each layer)
-# @param plot_data default plot data frame
-map_layout <- function(panel, facet, data, plot_data) {
+map_layout <- function(panel, facet, data) {
   lapply(data, function(data) {
-    if (is.waive(data)) data <- plot_data
     facet_map_layout(facet, data, panel$layout)
   })
 }

R/plot-build.r

@@ -22,7 +22,7 @@ ggplot_build <- function(plot) {
   }
 
   layers <- plot$layers
-  layer_data <- lapply(layers, function(y) y$data)
+  layer_data <- lapply(layers, function(y) y$layer_data(plot$data))
 
   scales <- plot$scales
   # Apply function to layer and matching data
@@ -39,7 +39,7 @@ ggplot_build <- function(plot) {
 
   panel <- new_panel()
   panel <- train_layout(panel, plot$facet, layer_data, plot$data)
-  data <- map_layout(panel, plot$facet, layer_data, plot$data)
+  data <- map_layout(panel, plot$facet, layer_data)
 
   # Compute aesthetics to produce data with generalised variable names
   data <- by_layer(function(l, d) l$compute_aesthetics(d, plot))

man/layer.Rd

@@ -32,3 +32,16 @@ test_that("strip_dots remove dots around calculated aesthetics", {
   expect_equal(strip_dots(aes(sapply(..density.., function(x) mean(x)))$x),
                quote(sapply(density, function(x) mean(x))))
 })
+
+# Data extraction ---------------------------------------------------------
+
+test_that("layer_data returns a data.frame", {
+  l <- geom_point()
+  expect_equal(l$layer_data(mtcars), mtcars)
+  l <- geom_point(data = head(mtcars))
+  expect_equal(l$layer_data(mtcars), head(mtcars))
+  l <- geom_point(data = head)
+  expect_equal(l$layer_data(mtcars), head(mtcars))
+  l <- geom_point(data = nrow)
+  expect_error(l$layer_data(mtcars), "Data function must return a data.frame")
+})