Layers have names (#5967)

* use `%||%` for `na.rm`

* simplify special `key_glyph` case

* add `name` field to LayerInstance objects

* helper for layer names

* apply layer names

* add tests

* add bullet

* fallback for direct `layer()` calls

NEWS.md

@@ -1,5 +1,6 @@
 # ggplot2 (development version)
 
+* Layers can have names (@teunbrand, #4066).
 * (internal) improvements to `pal_qualitative()` (@teunbrand, #5013)
 * `coord_radial(clip = "on")` clips to the panel area when the graphics device
  supports clipping paths (@teunbrand, #5952).

R/layer.R

@@ -130,24 +130,16 @@ layer <- function(geom = NULL, stat = NULL,
  position <- check_subclass(position, "Position", env = parent.frame(), call = call_env)
 
  # Special case for na.rm parameter needed by all layers
- if (is.null(params$na.rm)) {
- params$na.rm <- FALSE
- }
-
- # Special case for key_glyph parameter which is handed in through
- # params since all geoms/stats forward ... to params
- if (!is.null(params$key_glyph)) {
- key_glyph <- params$key_glyph
- params$key_glyph <- NULL # remove to avoid warning about unknown parameter
- }
+ params$na.rm <- params$na.rm %||% FALSE
 
  # Split up params between aesthetics, geom, and stat
  params <- rename_aes(params)
  aes_params <- params[intersect(names(params), geom$aesthetics())]
  geom_params <- params[intersect(names(params), geom$parameters(TRUE))]
  stat_params <- params[intersect(names(params), stat$parameters(TRUE))]
 
- all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics())
+ ignore <- c("key_glyph", "name")
+ all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics(), ignore)
 
  # Take care of plain patterns provided as aesthetic
  pattern <- vapply(aes_params, is_pattern, logical(1))
@@ -181,9 +173,9 @@ layer <- function(geom = NULL, stat = NULL,
  }
 
  # adjust the legend draw key if requested
- geom <- set_draw_key(geom, key_glyph)
+ geom <- set_draw_key(geom, key_glyph %||% params$key_glyph)
 
- fr_call <- layer_class$constructor %||% frame_call(call_env)
+ fr_call <- layer_class$constructor %||% frame_call(call_env) %||% current_call()
 
  ggproto("LayerInstance", layer_class,
  constructor = fr_call,
@@ -196,7 +188,8 @@ layer <- function(geom = NULL, stat = NULL,
  aes_params = aes_params,
  position = position,
  inherit.aes = inherit.aes,
- show.legend = show.legend
+ show.legend = show.legend,
+ name = params$name
  )
 }
 

R/plot-construction.R

@@ -186,6 +186,25 @@ ggplot_add.by <- function(object, plot, object_name) {
 
 #' @export
 ggplot_add.Layer <- function(object, plot, object_name) {
+ layers_names <- new_layer_names(object, names(plot$layers))
  plot$layers <- append(plot$layers, object)
+ names(plot$layers) <- layers_names
  plot
 }
+
+new_layer_names <- function(layer, existing) {
+ new_name <- layer$name
+ if (is.null(new_name)) {
+ # Construct a name from the layer's call
+ new_name <- call_name(layer$constructor)
+
+ if (new_name %in% existing) {
+ names <- c(existing, new_name)
+ names <- vec_as_names(names, repair = "unique", quiet = TRUE)
+ new_name <- names[length(names)]
+ }
+ }
+
+ names <- c(existing, new_name)
+ vec_as_names(names, repair = "check_unique")
+}

tests/testthat/test-layer.R

@@ -138,6 +138,22 @@ test_that("layer warns for constant aesthetics", {
  expect_snapshot_warning(ggplot_build(p))
 })
 
+test_that("layer names can be resolved", {
+
+ p <- ggplot() + geom_point() + geom_point()
+ expect_equal(names(p$layers), c("geom_point", "geom_point...2"))
+
+ p <- ggplot() + geom_point(name = "foo") + geom_point(name = "bar")
+ expect_equal(names(p$layers), c("foo", "bar"))
+
+ l <- geom_point(name = "foobar")
+ expect_error(
+ p + l + l,
+ "names are duplicated"
+ )
+})
+
+
 # Data extraction ---------------------------------------------------------
 
 test_that("AsIs data passes unmodified", {