Let Layer$compute_geom_2() handle legend defaults (#5903)

* use ellipses in `use_defaults()`/`compute_geom_2()`

* return empty keys as-is

* let `compute_geom_2()` handle populating defaults

* ensure legends can be rendered for unrelated geoms

* add visual tests for geom_sf legend types

* simplify sf legend type detection

* geom_sf can compute defaults for legend

* remove vestigial `default_aesthetics()`

Author: teunbrand

R/geom-.R

@@ -114,7 +114,7 @@ Geom <- ggproto("Geom",
   setup_data = function(data, params) data,
 
   # Combine data with defaults and set aesthetics from parameters
-  use_defaults = function(self, data, params = list(), modifiers = aes(), default_aes = NULL) {
+  use_defaults = function(self, data, params = list(), modifiers = aes(), default_aes = NULL, ...) {
     default_aes <- default_aes %||% self$default_aes
 
     # Inherit size as linewidth if no linewidth aesthetic and param exist

R/geom-sf.R

@@ -131,15 +131,21 @@ GeomSf <- ggproto("GeomSf", Geom,
     stroke = 0.5
   ),
 
-  use_defaults = function(self, data, params = list(), modifiers = aes(), default_aes = NULL) {
+  use_defaults = function(self, data, params = list(), modifiers = aes(),
+                          default_aes = NULL, ...) {
     data <- ggproto_parent(Geom, self)$use_defaults(data, params, modifiers, default_aes)
-    # Early exit for e.g. legend data that don't have geometry columns
     if (!"geometry" %in% names(data)) {
       return(data)
     }
 
+    # geometry column is a character if we're populating legend keys
+    type <- if (is.character(data$geometry)) {
+      data$geometry
+    } else {
+      sf_types[sf::st_geometry_type(data$geometry)]
+    }
+
     # Devise splitting index for geometry types
-    type <- sf_types[sf::st_geometry_type(data$geometry)]
     type <- factor(type, c("point", "line", "other", "collection"))
     index <- split(seq_len(nrow(data)), type)
 
@@ -202,27 +208,15 @@ GeomSf <- ggproto("GeomSf", Geom,
   },
 
   draw_key = function(data, params, size) {
-    data <- modify_list(default_aesthetics(params$legend), data)
-    if (params$legend == "point") {
-      draw_key_point(data, params, size)
-    } else if (params$legend == "line") {
-      draw_key_path(data, params, size)
-    } else {
+    switch(
+      params$legend %||% "other",
+      point = draw_key_point(data, params, size),
+      line  = draw_key_path(data, params, size),
       draw_key_polygon(data, params, size)
-    }
+    )
   }
 )
 
-default_aesthetics <- function(type) {
-  if (type == "point") {
-    GeomPoint$default_aes
-  } else if (type == "line") {
-    GeomLine$default_aes
-  } else  {
-    modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35"))
-  }
-}
-
 sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10,
                     arrow = NULL, arrow.fill = NULL, na.rm = TRUE) {
   type <- sf_types[sf::st_geometry_type(x$geometry)]

R/guide-legend.R

@@ -225,31 +225,36 @@ GuideLegend <- ggproto(
 
   get_layer_key = function(params, layers, data) {
 
+    # Return empty guides as-is
+    if (nrow(params$key) < 1) {
+      return(params)
+    }
+
     decor <- Map(layer = layers, df = data, f = function(layer, df) {
 
+      # Subset key to the column with aesthetic matching the layer
       matched_aes <- matched_aes(layer, params)
+      key <- params$key[matched_aes]
+      key$.id <- seq_len(nrow(key))
 
-      if (length(matched_aes) > 0) {
-        # Filter out aesthetics that can't be applied to the legend
-        n <- lengths(layer$aes_params, use.names = FALSE)
-        layer_params <- layer$aes_params[n == 1]
+      # Filter static aesthetics to those with single values
+      single_params <- lengths(layer$aes_params) == 1L
+      single_params <- layer$aes_params[single_params]
 
-        aesthetics  <- layer$computed_mapping
-        is_modified <- is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)
-        modifiers   <- aesthetics[is_modified]
+      # Use layer to populate defaults
+      key <- layer$compute_geom_2(key, single_params)
 
-        data <- layer$geom$use_defaults(params$key[matched_aes], layer_params, modifiers)
-        data$.draw <- keep_key_data(params$key, df, matched_aes, layer$show.legend)
-      } else {
-        reps <- rep(1, nrow(params$key))
-        data <- layer$geom$use_defaults(NULL, layer$aes_params)[reps, ]
+      # Filter non-existing levels
+      if (length(matched_aes) > 0) {
+        key$.draw <- keep_key_data(params$key, df, matched_aes, layer$show.legend)
       }
 
-      data <- modify_list(data, params$override.aes)
+      # Apply overrides
+      key <- modify_list(key, params$override.aes)
 
       list(
         draw_key = layer$geom$draw_key,
-        data     = data,
+        data     = key,
         params   = c(layer$computed_geom_params, layer$computed_stat_params)
       )
     })

R/layer-sf.R

@@ -38,10 +38,6 @@ layer_sf <- function(geom = NULL, stat = NULL,
 LayerSf <- ggproto("LayerSf", Layer,
   legend_key_type = NULL,
 
-  # This field carry state throughout rendering but will always be
-  # calculated before use
-  computed_legend_key_type = NULL,
-
   setup_layer = function(self, data, plot) {
     # process generic layer setup first
     data <- ggproto_parent(Layer, self)$setup_layer(data, plot)
@@ -56,35 +52,28 @@ LayerSf <- ggproto("LayerSf", Layer,
         self$computed_mapping$geometry <- sym(geometry_col)
       }
     }
-
-    # automatically determine the legend type
-    if (is.null(self$legend_key_type)) {
-      # first, set default value in case downstream tests fail
-      self$computed_legend_key_type <- "polygon"
-
-      # now check if the type should not be polygon
-      if (!is.null(self$computed_mapping$geometry) && quo_is_symbol(self$computed_mapping$geometry)) {
-        geometry_column <- as_name(self$computed_mapping$geometry)
-        if (inherits(data[[geometry_column]], "sfc")) {
-          sf_type <- detect_sf_type(data[[geometry_column]])
-          if (sf_type == "point") {
-            self$computed_legend_key_type <- "point"
-          } else if (sf_type == "line") {
-            self$computed_legend_key_type <- "line"
-          }
-        }
-      }
-    } else {
-      self$computed_legend_key_type <- self$legend_key_type
-    }
     data
   },
   compute_geom_1 = function(self, data) {
     data <- ggproto_parent(Layer, self)$compute_geom_1(data)
 
+    # Determine the legend type
+    legend_type <- self$legend_key_type
+    if (is.null(legend_type)) {
+      legend_type <- switch(
+        detect_sf_type(data$geometry),
+        point = "point", line = "line", "other"
+      )
+    }
+
     # Add legend type after computed_geom_params has been calculated
-    self$computed_geom_params$legend <- self$computed_legend_key_type
+    self$computed_geom_params$legend <- legend_type
     data
+  },
+
+  compute_geom_2 = function(self, data, params = self$aes_params, ...) {
+    data$geometry <- data$geometry %||% self$computed_geom_params$legend
+    ggproto_parent(Layer, self)$compute_geom_2(data, params, ...)
   }
 )
 
@@ -113,6 +102,9 @@ scale_type.sfc <- function(x) "identity"
 
 # helper function to determine the geometry type of sf object
 detect_sf_type <- function(sf) {
+  if (is.null(sf)) {
+    return("other")
+  }
   geometry_type <- unique0(as.character(sf::st_geometry_type(sf)))
   if (length(geometry_type) != 1)  geometry_type <- "GEOMETRY"
   sf_types[geometry_type]

R/layer.R

@@ -438,14 +438,14 @@ Layer <- ggproto("Layer", NULL,
     self$position$compute_layer(data, params, layout)
   },
 
-  compute_geom_2 = function(self, data) {
+  compute_geom_2 = function(self, data, params = self$aes_params, ...) {
     # Combine aesthetics, defaults, & params
     if (empty(data)) return(data)
 
     aesthetics <- self$computed_mapping
     modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)]
 
-    self$geom$use_defaults(data, self$aes_params, modifiers)
+    self$geom$use_defaults(data, params, modifiers, ...)
   },
 
   finish_statistics = function(self, data) {