diff --git a/NEWS.md b/NEWS.md index 360fd75990..34c510acfa 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # ggplot2 3.1.0.9000 +* Scales are now accessible to the `Geom` at draw time through a new + `layer_params` argument to `Geom$draw_layer()` (#3116). + * `coord_sf()` graticule lines are now drawn in the same thickness as panel grid lines in `coord_cartesian()`, and seting panel grid lines to `element_blank()` now also works in `coord_sf()` diff --git a/R/geom-.r b/R/geom-.r index 4f19896ee2..1c60b76056 100644 --- a/R/geom-.r +++ b/R/geom-.r @@ -71,7 +71,7 @@ Geom <- ggproto("Geom", ) }, - draw_layer = function(self, data, params, layout, coord) { + draw_layer = function(self, data, params, layout, coord, layer_params, ...) { if (empty(data)) { n <- if (is.factor(data$PANEL)) nlevels(data$PANEL) else 1L return(rep(list(zeroGrob()), n)) diff --git a/R/layer.r b/R/layer.r index df3b5d1fa4..aaf81172fa 100644 --- a/R/layer.r +++ b/R/layer.r @@ -173,6 +173,7 @@ Layer <- ggproto("Layer", NULL, mapping = NULL, position = NULL, inherit.aes = FALSE, + layer_params = NULL, print = function(self) { if (!is.null(self$mapping)) { @@ -202,6 +203,23 @@ 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) { + + # generate the layer_params object that gets passed to + # Geom$draw_layer() + scales <- plot$scales + self$layer_params <- ggproto("LayerParams", NULL, + get_scale = function(self, scale, panel, layout) { + if(scale %in% c("x", "y")) { + # depends on panel + if(identical(panel, NA)) stop("Position scale depends on panel") + layout$get_scales(panel)[[scale]] + } else { + scales$get_scales(scale) + } + } + ) + + # return the data data }, @@ -332,7 +350,7 @@ Layer <- ggproto("Layer", NULL, } data <- self$geom$handle_na(data, self$geom_params) - self$geom$draw_layer(data, self$geom_params, layout, layout$coord) + self$geom$draw_layer(data, self$geom_params, layout, layout$coord, self$layer_params) } ) diff --git a/tests/testthat/test-layer.r b/tests/testthat/test-layer.r index f07228adec..25753ae1a3 100644 --- a/tests/testthat/test-layer.r +++ b/tests/testthat/test-layer.r @@ -45,6 +45,85 @@ test_that("if an aes is mapped to a function that returns NULL, it is removed", expect_identical(names(p[[1]]), c("PANEL", "x", "group")) }) +# The layer_params object ------------------------------------------------- + +test_that("layers in a built plot have a layer_params object", { + df <- data_frame(x = 1:10, y = 1:10) + built <- ggplot_build(ggplot(df, aes(x, y)) + geom_point()) + expect_is(built$plot$layers[[1]]$layer_params, "LayerParams") +}) + +test_that("the correct scales are returned from layer_params$get_scale()", { + + # test Geom that displays select scale information + GeomScaleInfo <- ggproto( + "GeomScaleInfo", Geom, + required_aes = "x", + + draw_layer = function(self, data, params, layout, coord, layer_params, ...) { + + # list the same length as number of panels in data$PANEL + lapply(unique(data$PANEL), function(panel) { + x_limits <- layer_params$get_scale("x", panel, layout)$get_limits() + y_limits <- layer_params$get_scale("y", panel, layout)$get_limits() + col_limits <- layer_params$get_scale("colour", panel, layout)$get_limits() + text <- sprintf( + "x: %s; y: %s; col: %s", + paste(x_limits, collapse = ", "), + paste(y_limits, collapse = ", "), + paste(col_limits, collapse = ", ") + ) + grid::textGrob(text) + }) + } + ) + + geom_scale_info <- function() { + layer( + geom = GeomScaleInfo, stat = "identity", data = data_frame(x = 1), mapping = aes(x = x), + position = "identity", + params = list(), inherit.aes = FALSE, show.legend = NA + ) + } + + # a test plot that has some position and non-position scales, function to extract text + # from the plot + df <- data_frame(x = 1:10, y = 21:30, col = factor(c(1, 1, 1, 1, 1, 2, 2, 2, 3, 3))) + p <- ggplot(df, aes(x, y, col = col)) + geom_blank() + geom_scale_info() + limits_from_plot <- function(p) { + built <- ggplot_build(p) + panels <- seq_along(built$layout$panel_params) + vapply(panels, function(panel) layer_grob(p, 2)[[panel]]$label, character(1)) + } + + # expect the correct limits for single, multi-panel plots with (possibly) free scales + expect_identical(limits_from_plot(p), "x: 1, 10; y: 21, 30; col: 1, 2, 3") + expect_identical( + unique(limits_from_plot(p + facet_wrap(vars(col)))), + "x: 1, 10; y: 21, 30; col: 1, 2, 3" + ) + expect_identical( + unique(limits_from_plot(p + facet_grid(vars(col)))), + "x: 1, 10; y: 21, 30; col: 1, 2, 3" + ) + expect_identical( + unique(limits_from_plot(p + facet_wrap(vars(col), scales = "free"))), + c( + "x: 1, 5; y: 21, 25; col: 1, 2, 3", + "x: 1, 8; y: 26, 28; col: 1, 2, 3", + "x: 1, 10; y: 29, 30; col: 1, 2, 3" + ) + ) + expect_identical( + unique(limits_from_plot(p + facet_grid(vars(col), scales = "free"))), + c( + "x: 1, 10; y: 21, 25; col: 1, 2, 3", + "x: 1, 10; y: 26, 28; col: 1, 2, 3", + "x: 1, 10; y: 29, 30; col: 1, 2, 3" + ) + ) +}) + # Data extraction --------------------------------------------------------- test_that("layer_data returns a data.frame", {