Allow creation of custom layers that have access to global plot data (#2875)

* allow creation of custom layers that have access to global plot data

* properly respect inherit.aes when looking for geometry column

* isFALSE() doesn't exist in R 3.4

* incorporate suggested changes by yutannihilation

* Move `setup_layer()` to plot build.

* update news item. fixes #2872

Author: clauswilke

NAMESPACE

@@ -180,6 +180,7 @@ export(GeomText)
 export(GeomTile)
 export(GeomViolin)
 export(GeomVline)
+export(LayerSf)
 export(Layout)
 export(Position)
 export(PositionDodge)

NEWS.md

@@ -1,13 +1,21 @@
 # ggplot2 3.1.0.9000
 
-*   `geom_rug()` now works with `coord_flip()` (@has2k1, #2987).
+* `geom_rug()` now works with `coord_flip()` (@has2k1, #2987).
+
+* Layers now have a new member function `setup_layer()` which is called at the
+  very beginning of the plot building process and which has access to the original
+  input data and the plot object being built. This function allows the creation of
+  custom layers that autogenerate aesthetic mappings based on the input data or that
+  filter the input data in some form. One example is the new `LayerSf` class which
+  locates the geometry column in sf objects and sets up an aesthetic mapping for it
+  (@clauswilke, #2872).
 
 * Default labels are now generated more consistently; e.g., symbols no longer
   get backticks, and long expressions are abbreviated with `...`
   (@yutannihilation, #2981).
 
 * Aesthetic mappings now accept functions that return `NULL` (@yutannihilation,
-  #2997)
+  #2997).
 
 * Closed arrows in `element_line()` are now filled (@yutannihilation, #2924).
 

R/layer.r

@@ -41,6 +41,8 @@
 #'   supplied parameters and aesthetics are understood by the `geom` or
 #'   `stat`. Use `FALSE` to suppress the checks.
 #' @param params Additional parameters to the `geom` and `stat`.
+#' @param layer_class The type of layer object to be constructued. This allows
+#'   the creation of custom layers. Can usually be left at its default.
 #' @keywords internal
 #' @examples
 #' # geom calls are just a short cut for layer
@@ -61,7 +63,7 @@ layer <- function(geom = NULL, stat = NULL,
                   data = NULL, mapping = NULL,
                   position = NULL, params = list(),
                   inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE,
-                  show.legend = NA) {
+                  show.legend = NA, layer_class = Layer) {
   if (is.null(geom))
     stop("Attempted to create layer with no geom.", call. = FALSE)
   if (is.null(stat))
@@ -130,7 +132,7 @@ layer <- function(geom = NULL, stat = NULL,
     )
   }
 
-  ggproto("LayerInstance", Layer,
+  ggproto("LayerInstance", layer_class,
     geom = geom,
     geom_params = geom_params,
     stat = stat,
@@ -197,6 +199,12 @@ Layer <- ggproto("Layer", NULL,
     }
   },
 
+  # hook to allow a layer access to the final layer data
+  # in input form and to global plot info
+  setup_layer = function(self, data, plot) {
+    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/plot-build.r

@@ -39,10 +39,15 @@ ggplot_build.ggplot <- function(plot) {
     out
   }
 
+  # Allow all layers to make any final adjustments based
+  # on raw input data and plot info
+  data <- layer_data
+  data <- by_layer(function(l, d) l$setup_layer(d, plot))
+
   # Initialise panels, add extra data for margins & missing faceting
   # variables, and add on a PANEL variable to data
   layout <- create_layout(plot$facet, plot$coordinates)
-  data <- layout$setup(layer_data, plot$data, plot$plot_env)
+  data <- layout$setup(data, plot$data, plot$plot_env)
 
   # Compute aesthetics to produce data with generalised variable names
   data <- by_layer(function(l, d) l$compute_aesthetics(d, plot))

R/sf.R

@@ -135,11 +135,37 @@ stat_sf <- function(mapping = NULL, data = NULL, geom = "rect",
       na.rm = na.rm,
       legend = if (is.character(show.legend)) show.legend else "polygon",
       ...
-    )
+    ),
+    layer_class = LayerSf
   )
 }
 
 
+# A special sf layer that auto-maps geometry data to the `geometry` aesthetic
+
+#' @export
+#' @rdname ggsf
+#' @usage NULL
+#' @format NULL
+LayerSf <- ggproto("LayerSf", Layer,
+  setup_layer = function(self, data, plot) {
+    # process generic layer setup first
+    data <- ggproto_parent(Layer, self)$setup_layer(data, plot)
+
+    # automatically determine the name of the geometry column
+    # and add the mapping if it doesn't exist
+    if ((isTRUE(self$inherit.aes) && is.null(self$mapping$geometry) && is.null(plot$mapping$geometry)) ||
+        (!isTRUE(self$inherit.aes) && is.null(self$mapping$geometry))) {
+      if (is_sf(data)) {
+        geometry_col <- attr(data, "sf_column")
+        self$mapping$geometry <- as.name(geometry_col)
+      }
+    }
+    data
+  }
+)
+
+
 # geom --------------------------------------------------------------------
 
 #' @export
@@ -234,17 +260,6 @@ sf_grob <- function(row, lineend = "butt", linejoin = "round", linemitre = 10) {
 geom_sf <- function(mapping = aes(), data = NULL, stat = "sf",
                     position = "identity", na.rm = FALSE, show.legend = NA,
                     inherit.aes = TRUE, ...) {
-
-  # Automatically determin name of geometry column
-  if (!is.null(data) && is_sf(data)) {
-    geometry_col <- attr(data, "sf_column")
-  } else {
-    geometry_col <- "geometry"
-  }
-  if (is.null(mapping$geometry)) {
-    mapping$geometry <- as.name(geometry_col)
-  }
-
   c(
     layer(
       geom = GeomSf,
@@ -258,7 +273,8 @@ geom_sf <- function(mapping = aes(), data = NULL, stat = "sf",
         na.rm = na.rm,
         legend = if (is.character(show.legend)) show.legend else "polygon",
         ...
-      )
+      ),
+      layer_class = LayerSf
     ),
     coord_sf(default = TRUE)
   )
@@ -282,16 +298,6 @@ geom_sf_label <- function(mapping = aes(), data = NULL,
                           inherit.aes = TRUE,
                           fun.geometry = NULL) {
 
-  # Automatically determin name of geometry column
-  if (!is.null(data) && is_sf(data)) {
-    geometry_col <- attr(data, "sf_column")
-  } else {
-    geometry_col <- "geometry"
-  }
-  if (is.null(mapping$geometry)) {
-    mapping$geometry <- as.name(geometry_col)
-  }
-
   if (!missing(nudge_x) || !missing(nudge_y)) {
     if (!missing(position)) {
       stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
@@ -316,7 +322,8 @@ geom_sf_label <- function(mapping = aes(), data = NULL,
       na.rm = na.rm,
       fun.geometry = fun.geometry,
       ...
-    )
+    ),
+    layer_class = LayerSf
   )
 }
 
@@ -335,15 +342,6 @@ geom_sf_text <- function(mapping = aes(), data = NULL,
                          show.legend = NA,
                          inherit.aes = TRUE,
                          fun.geometry = NULL) {
-  # Automatically determin name of geometry column
-  if (!is.null(data) && is_sf(data)) {
-    geometry_col <- attr(data, "sf_column")
-  } else {
-    geometry_col <- "geometry"
-  }
-  if (is.null(mapping$geometry)) {
-    mapping$geometry <- as.name(geometry_col)
-  }
 
   if (!missing(nudge_x) || !missing(nudge_y)) {
     if (!missing(position)) {
@@ -367,7 +365,8 @@ geom_sf_text <- function(mapping = aes(), data = NULL,
       na.rm = na.rm,
       fun.geometry = fun.geometry,
       ...
-    )
+    ),
+    layer_class = LayerSf
   )
 }
 

R/stat-sf-coordinates.R

@@ -23,7 +23,7 @@
 #' the line. `sf::st_zm()` is needed to drop Z and M dimension beforehand,
 #' otherwise `sf::st_point_on_surface()` may fail when the geometries have M
 #' dimension.
-#' 
+#'
 #' @section Computed variables:
 #' \describe{
 #'   \item{x}{X dimension of the simple feature}
@@ -33,10 +33,10 @@
 #' @examples
 #' if (requireNamespace("sf", quietly = TRUE)) {
 #' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"))
-#' 
+#'
 #' ggplot(nc) +
 #'   stat_sf_coordinates()
-#' 
+#'
 #' ggplot(nc) +
 #'   geom_errorbarh(
 #'     aes(geometry = geometry,
@@ -47,7 +47,7 @@
 #'     stat = "sf_coordinates"
 #'   )
 #' }
-#' 
+#'
 #' @export
 #' @inheritParams stat_identity
 #' @inheritParams geom_point
@@ -62,16 +62,6 @@ stat_sf_coordinates <- function(mapping = aes(), data = NULL, geom = "point",
                                 show.legend = NA, inherit.aes = TRUE,
                                 fun.geometry = NULL,
                                 ...) {
-  # Automatically determin name of geometry column
-  if (!is.null(data) && is_sf(data)) {
-    geometry_col <- attr(data, "sf_column")
-  } else {
-    geometry_col <- "geometry"
-  }
-  if (is.null(mapping$geometry)) {
-    mapping$geometry <- as.name(geometry_col)
-  }
-
   layer(
     stat = StatSfCoordinates,
     data = data,
@@ -84,7 +74,8 @@ stat_sf_coordinates <- function(mapping = aes(), data = NULL, geom = "point",
       na.rm = na.rm,
       fun.geometry = fun.geometry,
       ...
-    )
+    ),
+    layer_class = LayerSf
   )
 }
 
@@ -98,7 +89,7 @@ StatSfCoordinates <- ggproto(
     if (is.null(fun.geometry)) {
       fun.geometry <- function(x) sf::st_point_on_surface(sf::st_zm(x))
     }
-    
+
     points_sfc <- fun.geometry(data$geometry)
     coordinates <- sf::st_coordinates(points_sfc)
     data$x <- coordinates[, "X"]