diff --git a/NEWS.md b/NEWS.md index 401083cb6d..a6784dc5b3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,10 @@ # ggplot2 (development version) +* Plot scales now ignore `AsIs` objects constructed with `I(x)`, instead of + invoking the identity scale. This allows these columns to co-exist with other + layers that need a non-identity scale for the same aesthetic. Also, it makes + it easy to specify relative positions (@teunbrand, #5142). + * `geom_text()` and `geom_label()` gained a `size.unit` parameter that set the text size to millimetres, points, centimetres, inches or picas (@teunbrand, #3799). diff --git a/R/facet-.R b/R/facet-.R index 2f92697d25..e56bfbc14b 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -102,20 +102,36 @@ Facet <- ggproto("Facet", NULL, # loop over each layer, training x and y scales in turn for (layer_data in data) { match_id <- match(layer_data$PANEL, layout$PANEL) + names <- names(layer_data) + ignore <- vapply(layer_data, inherits, what = "AsIs", logical(1)) + names <- names[!ignore] if (!is.null(x_scales)) { - x_vars <- intersect(x_scales[[1]]$aesthetics, names(layer_data)) + x_vars <- intersect(x_scales[[1]]$aesthetics, names) SCALE_X <- layout$SCALE_X[match_id] scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales) } if (!is.null(y_scales)) { - y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data)) + y_vars <- intersect(y_scales[[1]]$aesthetics, names) SCALE_Y <- layout$SCALE_Y[match_id] scale_apply(layer_data, y_vars, "train", SCALE_Y, y_scales) } + + # Check if AsIs variables + if (any(ignore)) { + position_aes <- union(ggplot_global$x_aes, ggplot_global$y_aes) + ignored <- intersect(names(ignore)[ignore], position_aes) + is_discrete <- vapply(layer_data[ignored], is.discrete, logical(1)) + if (any(is_discrete)) { + cli::cli_abort(paste0( + "Position aesthetic{?s} {.field {ignored[is_discrete]}} provided ", + "as {.cls AsIs} object{?s} cannot be discrete." + )) + } + } } }, draw_back = function(data, layout, x_scales, y_scales, theme, params) { diff --git a/R/geom-path.R b/R/geom-path.R index 6194d647e1..fd473b0b43 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -135,7 +135,7 @@ GeomPath <- ggproto("GeomPath", Geom, handle_na = function(self, data, params) { # Drop missing values at the start or end of a line - can't drop in the # middle since you expect those to be shown by a break in the line - complete <- stats::complete.cases(data[names(data) %in% c("x", "y", "linewidth", "colour", "linetype")]) + complete <- vec_detect_complete(data[names(data) %in% c("x", "y", "linewidth", "colour", "linetype")]) kept <- stats::ave(complete, data$group, FUN = keep_mid_true) data <- data[kept, ] diff --git a/R/layout.R b/R/layout.R index 56841b647b..431ea12489 100644 --- a/R/layout.R +++ b/R/layout.R @@ -152,16 +152,18 @@ Layout <- ggproto("Layout", NULL, lapply(data, function(layer_data) { match_id <- match(layer_data$PANEL, layout$PANEL) + names <- names(layer_data) + names <- names[!vapply(layer_data, inherits, what = "AsIs", logical(1))] # Loop through each variable, mapping across each scale, then joining # back together - x_vars <- intersect(self$panel_scales_x[[1]]$aesthetics, names(layer_data)) + x_vars <- intersect(self$panel_scales_x[[1]]$aesthetics, names) names(x_vars) <- x_vars SCALE_X <- layout$SCALE_X[match_id] new_x <- scale_apply(layer_data, x_vars, "map", SCALE_X, self$panel_scales_x) layer_data[, x_vars] <- new_x - y_vars <- intersect(self$panel_scales_y[[1]]$aesthetics, names(layer_data)) + y_vars <- intersect(self$panel_scales_y[[1]]$aesthetics, names) names(y_vars) <- y_vars SCALE_Y <- layout$SCALE_Y[match_id] new_y <- scale_apply(layer_data, y_vars, "map", SCALE_Y, self$panel_scales_y) diff --git a/R/position-.R b/R/position-.R index e9ea2ddf6f..a08cce633d 100644 --- a/R/position-.R +++ b/R/position-.R @@ -79,6 +79,7 @@ transform_position <- function(df, trans_x = NULL, trans_y = NULL, ...) { oldclass <- class(df) df <- unclass(df) scales <- aes_to_scale(names(df)) + scales[vapply(df, inherits, what = "AsIs", logical(1))] <- "ignored" if (!is.null(trans_x)) { df[scales == "x"] <- lapply(df[scales == "x"], trans_x, ...) diff --git a/R/scale-type.R b/R/scale-type.R index d8d4a70b6f..c05c172477 100644 --- a/R/scale-type.R +++ b/R/scale-type.R @@ -68,7 +68,7 @@ scale_type.default <- function(x) { scale_type.list <- function(x) "identity" #' @export -scale_type.AsIs <- function(x) "identity" +scale_type.AsIs <- function(x) NULL #' @export scale_type.logical <- function(x) "discrete" diff --git a/R/scales-.R b/R/scales-.R index 73c490c8a2..4320554954 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -65,17 +65,18 @@ ScalesList <- ggproto("ScalesList", NULL, if (empty(df) || length(self$scales) == 0) { return() } - lapply(self$scales, function(scale) scale$train_df(df = df)) + ignore <- vapply(df, inherits, what = "AsIs", logical(1)) + lapply(self$scales, function(scale) scale$train_df(df = df[!ignore])) }, map_df = function(self, df) { if (empty(df) || length(self$scales) == 0) { return(df) } - + ignore <- vapply(df, inherits, what = "AsIs", logical(1)) mapped <- unlist(lapply( self$scales, - function(scale) scale$map_df(df = df) + function(scale) scale$map_df(df = df[!ignore]) ), recursive = FALSE) data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))]) @@ -98,9 +99,10 @@ ScalesList <- ggproto("ScalesList", NULL, return(df) } + ignore <- vapply(df, inherits, what = "AsIs", logical(1)) transformed <- unlist(lapply( scales, - function(scale) scale$transform_df(df = df) + function(scale) scale$transform_df(df = df[!ignore]) ), recursive = FALSE) data_frame0(!!!transformed, df[setdiff(names(df), names(transformed))]) @@ -122,10 +124,11 @@ ScalesList <- ggproto("ScalesList", NULL, return(df) } + ignore <- vapply(df, inherits, what = "AsIs", logical(1)) backtransformed <- unlist(lapply( scales, function(scale) { - aesthetics <- intersect(scale$aesthetics, names(df)) + aesthetics <- intersect(scale$aesthetics, names(df[!ignore])) if (length(aesthetics) == 0) { return() } diff --git a/tests/testthat/_snaps/scales.md b/tests/testthat/_snaps/scales.md index b9adefae05..50df95093f 100644 --- a/tests/testthat/_snaps/scales.md +++ b/tests/testthat/_snaps/scales.md @@ -49,3 +49,7 @@ Output [1] NA 1.00000 20.08554 403.42879 +# discrete I() objects are rejected as position aesthetics + + Position aesthetics x and y provided as objects cannot be discrete. + diff --git a/tests/testthat/_snaps/scales/scales-ignore-i.svg b/tests/testthat/_snaps/scales/scales-ignore-i.svg new file mode 100644 index 0000000000..f00e7eeb80 --- /dev/null +++ b/tests/testthat/_snaps/scales/scales-ignore-i.svg @@ -0,0 +1,74 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +I(x) +I(y) +scales ignore I() + + diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 639f65674b..c36e38509c 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -521,3 +521,31 @@ test_that("numeric scale transforms can produce breaks", { expect_equal(test_breaks("sqrt", limits = c(0, 10)), seq(0, 10, by = 2.5)) }) + +test_that("scales ignore I()/AsIs vectors", { + set.seed(42) + df <- data_frame0( + x = runif(20), + y = runif(20), + colour = sample(rainbow(20)), + shape = 1:20 + ) + + p <- ggplot(df, aes(I(x), I(y), colour = I(colour), shape = I(shape))) + + geom_point() + data <- layer_data(p) + expect_identical(df$x, unclass(data$x)) + expect_identical(df$y, unclass(data$y)) + expect_identical(df$colour, unclass(data$colour)) + expect_identical(df$shape, unclass(data$shape)) + + expect_doppelganger("scales ignore I()", p) +}) + +test_that("discrete I() objects are rejected as position aesthetics", { + + p <- ggplot(mapping = aes(x = I("foo"), y = I("bar"))) + + geom_point() + expect_snapshot_error(ggplotGrob(p)) + +})