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

Author: clauswilke

NAMESPACE

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

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,11 @@ Layer <- ggproto("Layer", NULL,
     }
   },
 
+  # hook to allow a layer access to global plot data
+  # as the plot is constructed.
+  setup_layer = function(self, plot) {
+  },
+
   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-construction.r

@@ -153,6 +153,10 @@ ggplot_add.list <- function(object, plot, object_name) {
 }
 #' @export
 ggplot_add.Layer <- function(object, plot, object_name) {
+  # allow the layer to modify itself based on plot object
+  # useful for layers that need to access the global data
+  object$setup_layer(plot)
+
   plot$layers <- append(plot$layers, object)
 
   # Add any new labels

R/sf.R

@@ -135,11 +135,39 @@ 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, plot) {
+    # Automatically determine the name of the geometry column
+    # and add the mapping if it doesn't exist
+    data <- self$layer_data(plot$data)
+
+    if (!is.null(data) && is_sf(data)) {
+      geometry_col <- attr(data, "sf_column")
+    } else {
+      geometry_col <- "geometry"
+    }
+
+    # isn't quite complete yet, should also check that the global mapping
+    # doesn't contain a setting for geometry
+    if (is.null(self$mapping$geometry)) {
+      self$mapping$geometry <- as.name(geometry_col)
+    }
+  }
+)
+
+
 # geom --------------------------------------------------------------------
 
 #' @export
@@ -234,17 +262,6 @@ sf_grob <- function(row, lineend, linejoin, linemitre) {
 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 +275,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 +300,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 +324,8 @@ geom_sf_label <- function(mapping = aes(), data = NULL,
       na.rm = na.rm,
       fun.geometry = fun.geometry,
       ...
-    )
+    ),
+    layer_class = LayerSf
   )
 }
 
@@ -335,15 +344,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 +367,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"]