Ignoring AsIs objects

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).

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) {

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, ]
 

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)

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, ...)

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"

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()
         }

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 <AsIs> objects cannot be discrete.
+

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))
+
+})