diff --git a/NAMESPACE b/NAMESPACE index efac71dcab..024c1c3cb1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -180,6 +180,7 @@ export(GeomText) export(GeomTile) export(GeomViolin) export(GeomVline) +export(LayerSf) export(Layout) export(Position) export(PositionDodge) diff --git a/NEWS.md b/NEWS.md index 62ae69c20b..ba64b6d462 100644 --- a/NEWS.md +++ b/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). diff --git a/R/layer.r b/R/layer.r index 3a6c5524aa..e097af4dc7 100644 --- a/R/layer.r +++ b/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) { diff --git a/R/plot-build.r b/R/plot-build.r index d7e94ad71e..67eae000ce 100644 --- a/R/plot-build.r +++ b/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)) diff --git a/R/sf.R b/R/sf.R index 025e26e759..98d2a3c52c 100644 --- a/R/sf.R +++ b/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 ) } diff --git a/R/stat-sf-coordinates.R b/R/stat-sf-coordinates.R index 4893829d6f..2268e1dc83 100644 --- a/R/stat-sf-coordinates.R +++ b/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"] diff --git a/man/ggsf.Rd b/man/ggsf.Rd index e7a0a8aaad..aeae6d0d27 100644 --- a/man/ggsf.Rd +++ b/man/ggsf.Rd @@ -5,6 +5,7 @@ \alias{ggsf} \alias{StatSf} \alias{stat_sf} +\alias{LayerSf} \alias{GeomSf} \alias{geom_sf} \alias{geom_sf_label} diff --git a/man/layer.Rd b/man/layer.Rd index f74846e5c0..76e5535b0b 100644 --- a/man/layer.Rd +++ b/man/layer.Rd @@ -6,7 +6,8 @@ \usage{ layer(geom = NULL, stat = NULL, data = NULL, mapping = NULL, position = NULL, params = list(), inherit.aes = TRUE, - check.aes = TRUE, check.param = TRUE, show.legend = NA) + check.aes = TRUE, check.param = TRUE, show.legend = NA, + layer_class = Layer) } \arguments{ \item{geom}{The geometric object to use display the data} @@ -52,6 +53,9 @@ supplied parameters and aesthetics are understood by the \code{geom} or \code{FALSE} never includes, and \code{TRUE} always includes. It can also be a named logical vector to finely select the aesthetics to display.} + +\item{layer_class}{The type of layer object to be constructued. This allows +the creation of custom layers. Can usually be left at its default.} } \description{ A layer is a combination of data, stat and geom with a potential position