diff --git a/NEWS.md b/NEWS.md index 0a392e2b24..f4815f325d 100644 --- a/NEWS.md +++ b/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 diff --git a/R/scale-.R b/R/scale-.R index b2f9ef346a..5ae52f65ab 100644 --- a/R/scale-.R +++ b/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 }, diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 6fb4e4e667..0a750e4821 100644 --- a/tests/testthat/test-scales.R +++ b/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))) +})