Enable 2D structures as aesthetics (#6076)

* replace `lengths()` with `list_sizes()`

* unname via `vec_set_names()`

* add test

* add news bullet

* use slicing as subsetting

* deduplicate label validation efforts

* comparise sizes

* use `is_finite()` helper in `check_transformation()`

Author: teunbrand

NEWS.md

@@ -219,6 +219,8 @@
   `labs()` and several guides (@teunbrand, #3196).
 * `stat_summary_bin()` no longer ignores `width` parameter (@teunbrand, #4647).
 * Added `keep.zeroes` argument to `stat_bin()` (@teunbrand, #3449)
+* (internal) removed barriers for using 2D structures as aesthetics 
+  (@teunbrand, #4189).
 * `coord_sf()` no longer errors when dealing with empty graticules (@teunbrand, #6052)
 * Added `theme_transparent()` with transparent backgrounds (@topepo).
 * New theme elements `palette.{aes}.discrete` and `palette.{aes}.continuous`. 

R/geom-.R

@@ -270,7 +270,7 @@ NULL
 .stroke <- 96 / 25.4
 
 check_aesthetics <- function(x, n) {
-  ns <- lengths(x)
+  ns <- list_sizes(x)
   good <- ns == 1L | ns == n
 
   if (all(good)) {

R/guide-.R

@@ -525,11 +525,12 @@ opposite_position <- function(position) {
 
 # Ensure that labels aren't a list of expressions, but proper expressions
 validate_labels <- function(labels) {
-  if (!is.list(labels)) {
+  if (!obj_is_list(labels)) {
     return(labels)
   }
+  labels[lengths(labels) == 0L] <- ""
   if (any(vapply(labels, is.language, logical(1)))) {
-    do.call(expression, labels)
+    inject(expression(!!!labels))
   } else {
     unlist(labels)
   }

R/layer.R

@@ -327,7 +327,7 @@ Layer <- ggproto("Layer", NULL,
     }
 
     n <- nrow(data)
-    aes_n <- lengths(evaled)
+    aes_n <- list_sizes(evaled)
     if (n == 0) {
       # No data, so look at longest evaluated aesthetic
       if (length(evaled) == 0) {
@@ -352,7 +352,7 @@ Layer <- ggproto("Layer", NULL,
     } else {
       evaled$PANEL <- data$PANEL
     }
-    evaled <- lapply(evaled, unname)
+    evaled <- lapply(evaled, vec_set_names, names = NULL)
     evaled <- as_gg_data_frame(evaled)
     evaled <- add_group(evaled)
     evaled

R/layout.R

@@ -318,7 +318,7 @@ scale_apply <- function(data, vars, method, scale_id, scales) {
 
   lapply(vars, function(var) {
     pieces <- lapply(seq_along(scales), function(i) {
-      scales[[i]][[method]](data[[var]][scale_index[[i]]])
+      scales[[i]][[method]](vec_slice(data[[var]], scale_index[[i]]))
     })
     # Remove empty vectors to avoid coercion issues with vctrs
     pieces[lengths(pieces) == 0] <- NULL

R/scale-.R

@@ -851,13 +851,14 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale,
       labels <- self$labels
     }
 
-    if (length(labels) != length(breaks)) {
+    if (!identical(size0(labels), size0(breaks))) {
       cli::cli_abort(
         "{.arg breaks} and {.arg labels} have different lengths.",
         call = self$call
       )
     }
-    if (is.list(labels)) {
+
+    if (obj_is_list(labels)) {
       # Guard against list with empty elements
       labels[lengths(labels) == 0] <- ""
       # Make sure each element is scalar
@@ -1386,7 +1387,7 @@ scale_flip_position <- function(scale) {
 }
 
 check_transformation <- function(x, transformed, name, arg = NULL, call = NULL) {
-  if (!any(is.finite(x) != is.finite(transformed))) {
+  if (!any(is_finite(x) != is_finite(transformed))) {
     return(invisible())
   }
   if (is.null(arg)) {

R/utilities.R

@@ -781,6 +781,16 @@ as_unordered_factor <- function(x) {
   x
 }
 
+size0 <- function(x) {
+  if (obj_is_vector(x)) {
+    vec_size(x)
+  } else if (is.vector(x)) {
+    length(x)
+  } else {
+    NULL
+  }
+}
+
 fallback_palette <- function(scale) {
   aes <- scale$aesthetics[1]
   discrete <- scale$is_discrete()

tests/testthat/test-layer.R

@@ -182,3 +182,20 @@ test_that("layer_data returns a data.frame", {
   l <- geom_point(data = nrow)
   expect_snapshot_error(l$layer_data(mtcars))
 })
+
+test_that("data.frames and matrix aesthetics survive the build stage", {
+  df <- data_frame0(
+    x = 1:2,
+    g = matrix(1:4, 2),
+    f = data_frame0(a = 1:2, b = c("c", "d"))
+  )
+
+  p <- layer_data(
+    ggplot(df, aes(x, x, colour = g, shape = f)) +
+      geom_point() +
+      scale_colour_identity() +
+      scale_shape_identity()
+  )
+  expect_vector(p$colour, matrix(NA_integer_, nrow = 0, ncol = 2), size = 2)
+  expect_vector(p$shape,  data_frame0(a = integer(), b = character()), size = 2)
+})