Make ScaleDiscrete$map() compatible with vctrs-palettes

NEWS.md

@@ -1,5 +1,6 @@
 # ggplot2 (development version)
 
+* More stability for vctrs-based palettes (@teunbrand, #6117).
 * Fixed regression in `guide_bins(reverse = TRUE)` (@teunbrand, #6183).
 * New function family for setting parts of a theme. For example, you can now use 
   `theme_sub_axis(line, text, ticks, ticks.length, line)` as a substitute for

R/scale-.R

@@ -963,10 +963,10 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale,
   transform = identity,
 
   map = function(self, x, limits = self$get_limits()) {
-    limits <- limits[!is.na(limits)]
-    n <- length(limits)
+    limits <- vec_slice(limits, !is.na(limits))
+    n <- vec_size(limits)
     if (n < 1) {
-      return(rep(self$na.value, length(x)))
+      return(vec_rep(self$na.value, vec_size(x)))
     }
     if (!is.null(self$n.breaks.cache) && self$n.breaks.cache == n) {
       pal <- self$palette.cache
@@ -982,21 +982,30 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale,
       self$n.breaks.cache <- n
     }
 
-    na_value <- if (self$na.translate) self$na.value else NA
-    pal_names <- names(pal)
+    na_value <- NA
+    if (self$na.translate) {
+      na_value <- self$na.value
+      if (obj_is_list(pal) && !obj_is_list(na_value)) {
+        # We prevent a casting error that occurs when mapping grid patterns
+        na_value <- list(na_value)
+      }
+    }
+
+    pal_names <- vec_names(pal)
 
     if (!is_null(pal_names)) {
       # if pal is named, limit the pal by the names first,
       # then limit the values by the pal
-      pal[is.na(match(pal_names, limits))] <- na_value
-      pal <- unname(pal)
+      vec_slice(pal, is.na(match(pal_names, limits))) <- na_value
+      pal <- vec_set_names(pal, NULL)
       limits <- pal_names
     }
-    pal <- c(pal, na_value)
-    pal_match <- pal[match(as.character(x), limits, nomatch = length(pal))]
+    pal <- vec_c(pal, na_value)
+    pal_match <-
+      vec_slice(pal, match(as.character(x), limits, nomatch = vec_size(pal)))
 
     if (!is.na(na_value)) {
-      pal_match[is.na(x)] <- na_value
+      vec_slice(pal_match, is.na(x)) <- na_value
     }
     pal_match
   },

tests/testthat/test-scales.R

@@ -747,3 +747,32 @@ test_that("discrete scales work with NAs in arbitrary positions", {
   expect_equal(test, output)
 
 })
+
+test_that("discrete scales can map to 2D structures", {
+
+  p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) +
+    geom_point()
+
+  # Test it can map to a vctrs rcrd class
+  rcrd <- new_rcrd(list(a = LETTERS[1:3], b = 3:1))
+
+  ld <- layer_data(p + scale_colour_manual(values = rcrd, na.value = NA))
+  expect_s3_class(ld$colour, "vctrs_rcrd")
+  expect_length(ld$colour, nrow(mtcars))
+
+  # Test it can map to data.frames
+  df <- data_frame0(a = LETTERS[1:3], b = 3:1)
+  my_pal <- function(n) vec_slice(df, seq_len(n))
+
+  ld <- layer_data(p + discrete_scale("colour", palette = my_pal))
+  expect_s3_class(ld$colour, "data.frame")
+  expect_equal(dim(ld$colour), c(nrow(mtcars), ncol(df)))
+
+  # Test it can map to matrices
+  mtx <- cbind(a = LETTERS[1:3], b = LETTERS[4:6])
+  my_pal <- function(n) vec_slice(mtx, seq_len(n))
+
+  ld <- layer_data(p + discrete_scale("colour", palette = my_pal))
+  expect_true(is.matrix(ld$colour))
+  expect_equal(dim(ld$colour), c(nrow(mtcars), ncol(df)))
+})