geom_rect() can derive corners from x/width or y/height (#5862)

* required aesthetics to non-missing aes

* <GeomBar> doesn't inherit `optional_aes`

* fill missing aes

* throw error when unresolveable

* protect against partial matching

* add tests

* add news bullet

* adjust docs

* fallback for corners wired through `params`

* Revert "<GeomBar> doesn't inherit `optional_aes`"

This reverts commit 65030f5.

* adapt `check_required_aesthetics()` to deal with multiple or-logic

* undo aesthetic field voodoo

* fill data from params more reliably

* throw error from `resolve_rect()`

* document

Author: teunbrand

NEWS.md

@@ -1,5 +1,7 @@
 # ggplot2 (development version)
 
+* `geom_rect()` can now derive the required corners positions from `x`/`width`
+  or `y`/`height` parameterisation (@teunbrand, #5861).
 * All position scales now use the same definition of `x` and `y` aesthetics.
   This lets uncommon aesthetics like `xintercept` expand scales as usual.
   (#3342, #4966, @teunbrand)

R/geom-rect.R

@@ -31,7 +31,39 @@ GeomRect <- ggproto("GeomRect", Geom,
   default_aes = aes(colour = NA, fill = "grey35", linewidth = 0.5, linetype = 1,
     alpha = NA),
 
-  required_aes = c("xmin", "xmax", "ymin", "ymax"),
+  required_aes = c("x|width|xmin|xmax", "y|height|ymin|ymax"),
+
+  setup_data = function(self, data, params) {
+    if (all(c("xmin", "xmax", "ymin", "ymax") %in% names(data))) {
+      return(data)
+    }
+
+    # Fill in missing aesthetics from parameters
+    required <- strsplit(self$required_aes, "|", fixed = TRUE)
+    missing  <- setdiff(unlist(required), names(data))
+    default <- params[intersect(missing, names(params))]
+    data[names(default)] <- default
+
+    if (is.null(data$xmin) || is.null(data$xmax)) {
+      x <- resolve_rect(
+        data[["xmin"]], data[["xmax"]],
+        data[["x"]], data[["width"]],
+        fun = snake_class(self), type = "x"
+      )
+      i <- lengths(x) > 1
+      data[c("xmin", "xmax")[i]] <- x[i]
+    }
+    if (is.null(data$ymin) || is.null(data$ymax)) {
+      y <- resolve_rect(
+        data[["ymin"]], data[["ymax"]],
+        data[["y"]], data[["height"]],
+        fun = snake_class(self), type = "y"
+      )
+      i <- lengths(y) > 1
+      data[c("ymin", "ymax")[i]] <- y[i]
+    }
+    data
+  },
 
   draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") {
     data <- check_linewidth(data, snake_class(self))
@@ -73,3 +105,41 @@ GeomRect <- ggproto("GeomRect", Geom,
 
   rename_size = TRUE
 )
+
+resolve_rect <- function(min = NULL, max = NULL, center = NULL, length = NULL,
+                         fun, type) {
+  absent <- c(is.null(min), is.null(max), is.null(center), is.null(length))
+  if (sum(absent) > 2) {
+    missing <- switch(
+      type,
+      x = c("xmin", "xmax", "x", "width"),
+      y = c("ymin", "ymax", "y", "height")
+    )
+    cli::cli_abort(c(
+      "{.fn {fun}} requires two of the following aesthetics: \\
+      {.or {.field {missing}}}.",
+      i = "Currently, {.field {missing[!absent]}} is present."
+    ))
+  }
+
+  if (absent[1] && absent[2]) {
+    min <- center - 0.5 * length
+    max <- center + 0.5 * length
+    return(list(min = min, max = max))
+  }
+  if (absent[1]) {
+    if (is.null(center)) {
+      min <- max - length
+    } else {
+      min <- max - 2 * (max - center)
+    }
+  }
+  if (absent[2]) {
+    if (is.null(center)) {
+      max <- min + length
+    } else {
+      max <- min + 2 * (center - min)
+    }
+  }
+  list(min = min, max = max)
+}

R/geom-tile.R

@@ -1,25 +1,26 @@
 #' Rectangles
 #'
 #' `geom_rect()` and `geom_tile()` do the same thing, but are
-#' parameterised differently: `geom_rect()` uses the locations of the four
-#' corners (`xmin`, `xmax`, `ymin` and `ymax`), while
-#' `geom_tile()` uses the center of the tile and its size (`x`,
-#' `y`, `width`, `height`). `geom_raster()` is a high
-#' performance special case for when all the tiles are the same size, and no
-#' pattern fills are applied.
+#' parameterised differently: `geom_tile()` uses the center of the tile and its
+#' size (`x`, `y`, `width`, `height`), while `geom_rect()` can use those or the
+#' locations of the corners (`xmin`, `xmax`, `ymin` and `ymax`).
+#' `geom_raster()` is a high performance special case for when all the tiles
+#' are the same size, and no pattern fills are applied.
 #'
-#' @eval rd_aesthetics("geom", "tile", "Note that `geom_raster()` ignores `colour`.")
+#' @eval rd_aesthetics(
+#'   "geom", "rect",
+#'   "`geom_tile()` understands only the `x`/`width` and `y`/`height` combinations.
+#'   Note that `geom_raster()` ignores `colour`."
+#' )
 #' @inheritParams layer
 #' @inheritParams geom_point
 #' @inheritParams geom_segment
 #' @export
 #'
 #' @details
-#' `geom_rect()` and `geom_tile()`'s respond differently to scale
-#' transformations due to their parameterisation. In `geom_rect()`, the scale
-#' transformation is applied to the corners of the rectangles. In `geom_tile()`,
-#' the transformation is applied only to the centres and its size is determined
-#' after transformation.
+#' Please note that the `width` and `height` aesthetics are not true position
+#' aesthetics and therefore are not subject to scale transformation. It is
+#' only after transformation that these aesthetics are applied.
 #'
 #' @examples
 #' # The most common use for rectangles is to draw a surface. You always want

R/utilities-help.R

@@ -23,7 +23,7 @@ rd_aesthetics <- function(type, name, extra_note = NULL) {
 
 rd_aesthetics_item <- function(x) {
   req <- x$required_aes
-  req <- sub("|", "} \\emph{or} \\code{", req, fixed = TRUE)
+  req <- gsub("|", "} \\emph{or} \\code{", req, fixed = TRUE)
   req_aes <- unlist(strsplit(x$required_aes, "|", fixed = TRUE))
   optional_aes <- setdiff(x$aesthetics(), req_aes)
   all <- union(req, sort(optional_aes))

R/utilities.R

@@ -24,25 +24,53 @@ scales::alpha
 # @param name of object for error message
 # @keyword internal
 check_required_aesthetics <- function(required, present, name, call = caller_env()) {
-  if (is.null(required)) return()
+  if (is.null(required)) {
+    return()
+  }
 
   required <- strsplit(required, "|", fixed = TRUE)
-  if (any(lengths(required) > 1)) {
-    required <- lapply(required, rep_len, 2)
-    required <- list(
-      vapply(required, `[`, character(1), 1),
-      vapply(required, `[`, character(1), 2)
+  n <- lengths(required)
+
+  is_present <- vapply(
+    required,
+    function(req) any(req %in% present),
+    logical(1)
+  )
+  if (all(is_present)) {
+    return()
+  }
+
+  # Deal with paired (bidirectional) aesthetics
+  pairs <- character()
+  missing_pairs <- n == 2
+  if (any(missing_pairs)) {
+    pairs <- lapply(required[missing_pairs], rep_len, 2)
+    pairs <- list(
+      vapply(pairs, `[`, character(1), 1),
+      vapply(pairs, `[`, character(1), 2)
     )
-  } else {
-    required <- list(unlist(required))
+    pairs <- lapply(pairs, setdiff, present)
+    pairs <- vapply(pairs, function(x) {
+      as_cli("{.and {.field {x}}}")
+    }, character(1))
+    pairs <- as_cli("{.or {pairs}}")
   }
-  missing_aes <- lapply(required, setdiff, present)
-  if (any(lengths(missing_aes) == 0)) return()
-  message <- "{.fn {name}} requires the following missing aesthetics: {.field {missing_aes[[1]]}}"
-  if (length(missing_aes) > 1) {
-    message <- paste0(message, " {.strong or} {.field {missing_aes[[2]]}}")
+
+  other <- character()
+  missing_other <- !is_present & n != 2
+  if (any(missing_other)) {
+    other <- lapply(required[missing_other], setdiff, present)
+    other <- vapply(other, function(x) {
+      as_cli("{.or {.field {x}}}")
+    }, character(1))
   }
-  cli::cli_abort(paste0(message, "."), call = call)
+
+  missing <- c(other, pairs)
+
+  cli::cli_abort(
+    "{.fn {name}} requires the following missing aesthetics: {.and {missing}}.",
+    call = call
+  )
 }
 
 # Concatenate a named list for output

man/geom_tile.Rd

@@ -12,7 +12,7 @@
 
 ---
 
-    `test()` requires the following missing aesthetics: x and fill or y and fill.
+    `test()` requires the following missing aesthetics: fill and x or y.
 
 # remove_missing checks input
 

tests/testthat/_snaps/utilities.md

@@ -0,0 +1,36 @@
+test_that("geom_rect can derive corners", {
+
+  corners <- c("xmin", "xmax", "ymin", "ymax")
+  full <- data.frame(
+    xmin = c(1, 2), xmax = c(3, 6),
+    ymin = c(1, 2), ymax = c(3, 6),
+    width = c(2, 4), height = c(2, 4),
+    x = c(2, 4), y = c(2, 4)
+  )
+
+  test <- full[, c("xmin", "ymin", "width", "height")]
+  test <- GeomRect$setup_data(test, NULL)
+  expect_equal(full[, corners], test[, corners])
+
+  test <- full[, c("xmin", "ymin", "x", "y")]
+  test <- GeomRect$setup_data(test, NULL)
+  expect_equal(full[, corners], test[, corners])
+
+  test <- full[, c("x", "y", "width", "height")]
+  test <- GeomRect$setup_data(test, NULL)
+  expect_equal(full[, corners], test[, corners])
+
+  test <- full[, c("xmax", "ymax", "width", "height")]
+  test <- GeomRect$setup_data(test, NULL)
+  expect_equal(full[, corners], test[, corners])
+
+  test <- full[, c("xmax", "ymax", "x", "y")]
+  test <- GeomRect$setup_data(test, NULL)
+  expect_equal(full[, corners], test[, corners])
+
+  test <- full[, c("x", "y")]
+  expect_error(
+    GeomRect$setup_data(test, NULL),
+    "requires two of the following aesthetics"
+  )
+})