Aesthetics for position adjustments (#6100)

* positions have `default_aes` field

* positions communicate their aesthetics

* positions populate defaults

* simplify `PositionNudge$compute_layer()`

* `position_nudge()` accepts nudge aesthetics

* remove nudge specific stuff from `geom_text()`/`geom_label()`

* document

* `order` aesthetic for `position_dodge()`

* document aesthetic

* add news bullet

* add test

* fix small note

* document

Author: teunbrand

NEWS.md

@@ -1,5 +1,8 @@
 # ggplot2 (development version)
 
+* Position adjustments can now have auxiliary aesthetics (@teunbrand).
+    * `position_nudge()` gains `nudge_x` and `nudge_y` aesthetics (#3026, #5445).
+    * `position_dodge()` gains `order` aesthetic (#3022, #3345)
 * 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 

R/geom-label.R

@@ -4,28 +4,16 @@
 #' @param label.r Radius of rounded corners. Defaults to 0.15 lines.
 #' @param label.size Size of label border, in mm.
 geom_label <- function(mapping = NULL, data = NULL,
-                       stat = "identity", position = "identity",
+                       stat = "identity", position = "nudge",
                        ...,
                        parse = FALSE,
-                       nudge_x = 0,
-                       nudge_y = 0,
                        label.padding = unit(0.25, "lines"),
                        label.r = unit(0.15, "lines"),
                        label.size = 0.25,
                        size.unit = "mm",
                        na.rm = FALSE,
                        show.legend = NA,
                        inherit.aes = TRUE) {
-  if (!missing(nudge_x) || !missing(nudge_y)) {
-    if (!missing(position)) {
-      cli::cli_abort(c(
-        "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.",
-        "i" = "Choose one approach to alter the position."
-      ))
-    }
-
-    position <- position_nudge(nudge_x, nudge_y)
-  }
 
   layer(
     data = data,

R/geom-sf.R

@@ -314,11 +314,9 @@ geom_sf <- function(mapping = aes(), data = NULL, stat = "sf",
 #' @inheritParams geom_label
 #' @inheritParams stat_sf_coordinates
 geom_sf_label <- function(mapping = aes(), data = NULL,
-                          stat = "sf_coordinates", position = "identity",
+                          stat = "sf_coordinates", position = "nudge",
                           ...,
                           parse = FALSE,
-                          nudge_x = 0,
-                          nudge_y = 0,
                           label.padding = unit(0.25, "lines"),
                           label.r = unit(0.15, "lines"),
                           label.size = 0.25,
@@ -327,17 +325,6 @@ geom_sf_label <- function(mapping = aes(), data = NULL,
                           inherit.aes = TRUE,
                           fun.geometry = NULL) {
 
-  if (!missing(nudge_x) || !missing(nudge_y)) {
-    if (!missing(position)) {
-      cli::cli_abort(c(
-        "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.",
-        "i" = "Only use one approach to alter the position."
-      ))
-    }
-
-    position <- position_nudge(nudge_x, nudge_y)
-  }
-
   layer_sf(
     data = data,
     mapping = mapping,
@@ -363,28 +350,15 @@ geom_sf_label <- function(mapping = aes(), data = NULL,
 #' @inheritParams geom_text
 #' @inheritParams stat_sf_coordinates
 geom_sf_text <- function(mapping = aes(), data = NULL,
-                         stat = "sf_coordinates", position = "identity",
+                         stat = "sf_coordinates", position = "nudge",
                          ...,
                          parse = FALSE,
-                         nudge_x = 0,
-                         nudge_y = 0,
                          check_overlap = FALSE,
                          na.rm = FALSE,
                          show.legend = NA,
                          inherit.aes = TRUE,
                          fun.geometry = NULL) {
 
-  if (!missing(nudge_x) || !missing(nudge_y)) {
-    if (!missing(position)) {
-      cli::cli_abort(c(
-        "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.",
-        "i" = "Only use one approach to alter the position."
-      ))
-    }
-
-    position <- position_nudge(nudge_x, nudge_y)
-  }
-
   layer_sf(
     data = data,
     mapping = mapping,

R/geom-text.R

@@ -41,19 +41,6 @@
 #' @inheritParams geom_point
 #' @param parse If `TRUE`, the labels will be parsed into expressions and
 #'   displayed as described in `?plotmath`.
-#' @param nudge_x,nudge_y Horizontal and vertical adjustment to nudge labels by.
-#'   Useful for offsetting text from points, particularly on discrete scales.
-#'   Cannot be jointly specified with `position`.
-#' @param position A position adjustment to use on the data for this layer.
-#'   Cannot be jointy specified with `nudge_x` or `nudge_y`. This
-#'   can be used in various ways, including to prevent overplotting and
-#'   improving the display. The `position` argument accepts the following:
-#'   * The result of calling a position function, such as `position_jitter()`.
-#'   * A string naming the position adjustment. To give the position as a
-#'     string, strip the function name of the `position_` prefix. For example,
-#'     to use `position_jitter()`, give the position as `"jitter"`.
-#'   * For more information and other ways to specify the position, see the
-#'     [layer position][layer_positions] documentation.
 #' @param check_overlap If `TRUE`, text that overlaps previous text in the
 #'   same layer will not be plotted. `check_overlap` happens at draw time and in
 #'   the order of the data. Therefore data should be arranged by the label
@@ -166,28 +153,15 @@
 #'   geom_text(aes(label = text), vjust = "inward", hjust = "inward")
 #' }
 geom_text <- function(mapping = NULL, data = NULL,
-                      stat = "identity", position = "identity",
+                      stat = "identity", position = "nudge",
                       ...,
                       parse = FALSE,
-                      nudge_x = 0,
-                      nudge_y = 0,
                       check_overlap = FALSE,
                       size.unit = "mm",
                       na.rm = FALSE,
                       show.legend = NA,
                       inherit.aes = TRUE)
 {
-  if (!missing(nudge_x) || !missing(nudge_y)) {
-    if (!missing(position)) {
-      cli::cli_abort(c(
-        "Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.",
-        "i" = "Only use one approach to alter the position."
-      ))
-    }
-
-    position <- position_nudge(nudge_x, nudge_y)
-  }
-
   layer(
     data = data,
     mapping = mapping,

R/layer.R

@@ -128,12 +128,12 @@ layer <- function(geom = NULL, stat = NULL,
 
   # Split up params between aesthetics, geom, and stat
   params <- rename_aes(params)
-  aes_params  <- params[intersect(names(params), geom$aesthetics())]
+  aes_params  <- params[intersect(names(params), union(geom$aesthetics(), position$aesthetics()))]
   geom_params <- params[intersect(names(params), geom$parameters(TRUE))]
   stat_params <- params[intersect(names(params), stat$parameters(TRUE))]
 
   ignore <- c("key_glyph", "name")
-  all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics(), ignore)
+  all <- c(geom$parameters(TRUE), stat$parameters(TRUE), geom$aesthetics(), position$aesthetics(), ignore)
 
   # Take care of plain patterns provided as aesthetic
   pattern <- vapply(aes_params, is_pattern, logical(1))
@@ -164,7 +164,7 @@ layer <- function(geom = NULL, stat = NULL,
 
   extra_aes <- setdiff(
     mapped_aesthetics(mapping),
-    c(geom$aesthetics(), stat$aesthetics())
+    c(geom$aesthetics(), stat$aesthetics(), position$aesthetics())
   )
   # Take care of size->linewidth aes renaming
   if (geom$rename_size && "size" %in% extra_aes && !"linewidth" %in% mapped_aesthetics(mapping)) {
@@ -415,6 +415,7 @@ Layer <- ggproto("Layer", NULL,
   compute_position = function(self, data, layout) {
     if (empty(data)) return(data_frame0())
 
+    data <- self$position$use_defaults(data, self$aes_params)
     params <- self$position$setup_params(data)
     data <- self$position$setup_data(data, params)
 

R/position-.R

@@ -46,6 +46,8 @@
 Position <- ggproto("Position",
   required_aes = character(),
 
+  default_aes = aes(),
+
   setup_params = function(self, data) {
     list()
   },
@@ -66,6 +68,36 @@ Position <- ggproto("Position",
 
   compute_panel = function(self, data, params, scales) {
     cli::cli_abort("Not implemented.")
+  },
+
+  aesthetics = function(self) {
+    required_aes <- self$required_aes
+    if (!is.null(required_aes)) {
+      required_aes <- unlist(strsplit(self$required_aes, "|", fixed = TRUE))
+    }
+    c(union(required_aes, names(self$default_aes)))
+  },
+
+  use_defaults = function(self, data, params = list()) {
+
+    aes <- self$aesthetics()
+    defaults <- self$default_aes
+
+    params <- params[intersect(names(params), aes)]
+    params <- params[setdiff(names(params), names(data))]
+    defaults <- defaults[setdiff(names(defaults), c(names(params), names(data)))]
+
+    if ((length(params) + length(defaults)) < 1) {
+      return(data)
+    }
+
+    new <- compact(lapply(defaults, eval_tidy, data = data))
+    new[names(params)] <- params
+    check_aesthetics(new, nrow(data))
+
+    data[names(new)] <- new
+    data
+
   }
 )
 

R/position-dodge.R

@@ -19,6 +19,8 @@
 #' @param reverse If `TRUE`, will reverse the default stacking order.
 #'   This is useful if you're rotating both the plot and legend.
 #' @family position adjustments
+#' @eval rd_aesthetics("position", "dodge")
+#'
 #' @export
 #' @examples
 #' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) +
@@ -104,7 +106,10 @@ PositionDodge <- ggproto("PositionDodge", Position,
   preserve = "total",
   orientation = "x",
   reverse = NULL,
+  default_aes = aes(order = NULL),
+
   setup_params = function(self, data) {
+
     flipped_aes <- has_flipped_aes(data, default = self$orientation == "y")
     check_required_aesthetics(
       if (flipped_aes) "y|ymin" else "x|xmin",
@@ -139,9 +144,22 @@ PositionDodge <- ggproto("PositionDodge", Position,
 
   setup_data = function(self, data, params) {
     data <- flip_data(data, params$flipped_aes)
+
     if (!"x" %in% names(data) && all(c("xmin", "xmax") %in% names(data))) {
       data$x <- (data$xmin + data$xmax) / 2
     }
+
+    data$order <- xtfrm( # xtfrm makes anything 'sortable'
+      data$order %||% ave(data$group, data$x, data$PANEL, FUN = match_sorted)
+    )
+    if (params$reverse) {
+      data$order <- -data$order
+    }
+    if (is.null(params$n)) { # preserve = "total"
+      data$order <- ave(data$order, data$x, data$PANEL, FUN = match_sorted)
+    } else { # preserve = "single"
+      data$order <- match_sorted(data$order)
+    }
     flip_data(data, params$flipped_aes)
   },
 
@@ -179,7 +197,7 @@ pos_dodge <- function(df, width, n = NULL) {
 
   # Have a new group index from 1 to number of groups.
   # This might be needed if the group numbers in this set don't include all of 1:n
-  groupidx <- match(df$group, unique0(df$group))
+  groupidx <- df$order %||% match_sorted(df$group)
 
   # Find the center for each group, then use that to calculate xmin and xmax
   df$x <- df$x + width * ((groupidx - 0.5) / n - 0.5)
@@ -188,3 +206,7 @@ pos_dodge <- function(df, width, n = NULL) {
 
   df
 }
+
+match_sorted <- function(x, y = x, ...) {
+  vec_match(x, vec_sort(unique0(y), ...))
+}

R/position-nudge.R

@@ -8,6 +8,7 @@
 #' @family position adjustments
 #' @param x,y Amount of vertical and horizontal distance to move.
 #' @export
+#' @eval rd_aesthetics("position", "nudge")
 #' @examples
 #' df <- data.frame(
 #'   x = c(1,3,2,5),
@@ -26,7 +27,7 @@
 #' ggplot(df, aes(x, y)) +
 #'   geom_point() +
 #'   geom_text(aes(label = y), nudge_y = -0.1)
-position_nudge <- function(x = 0, y = 0) {
+position_nudge <- function(x = NULL, y = NULL) {
   ggproto(NULL, PositionNudge,
     x = x,
     y = y
@@ -38,25 +39,21 @@ position_nudge <- function(x = 0, y = 0) {
 #' @usage NULL
 #' @export
 PositionNudge <- ggproto("PositionNudge", Position,
-  x = 0,
-  y = 0,
+  x = NULL,
+  y = NULL,
+
+  default_aes = aes(nudge_x = 0, nudge_y = 0),
 
   setup_params = function(self, data) {
-    list(x = self$x, y = self$y)
+    list(
+      x = self$x %||% data$nudge_x,
+      y = self$y %||% data$nudge_y
+    )
   },
 
   compute_layer = function(self, data, params, layout) {
-    # transform only the dimensions for which non-zero nudging is requested
-    if (any(params$x != 0)) {
-      if (any(params$y != 0)) {
-        transform_position(data, function(x) x + params$x, function(y) y + params$y)
-      } else {
-        transform_position(data, function(x) x + params$x, NULL)
-      }
-    } else if (any(params$y != 0)) {
-      transform_position(data, NULL, function(y) y + params$y)
-    } else {
-      data # if both x and y are 0 we don't need to transform
-    }
+    trans_x <- if (any(params$x != 0)) function(x) x + params$x
+    trans_y <- if (any(params$y != 0)) function(y) y + params$y
+    transform_position(data, trans_x, trans_y)
   }
 )

R/utilities-help.R

@@ -3,7 +3,8 @@
 rd_aesthetics <- function(type, name, extra_note = NULL) {
   obj <- switch(type,
     geom = validate_subclass(name, "Geom", env = globalenv()),
-    stat = validate_subclass(name, "Stat", env = globalenv())
+    stat = validate_subclass(name, "Stat", env = globalenv()),
+    position = validate_subclass(name, "Position", env = globalenv())
   )
   aes <- rd_aesthetics_item(obj)
 

R/utilities.R

@@ -940,7 +940,7 @@ compute_data_size <- function(data, size, default = 0.9,
     res <- vapply(res, resolution, FUN.VALUE = numeric(1), ...)
     res <- min(res, na.rm = TRUE)
   } else if (panels == "by") {
-    res <- ave(data[[var]], data$PANEL, FUN = function(x) resolution(x, ...))
+    res <- stats::ave(data[[var]], data$PANEL, FUN = function(x) resolution(x, ...))
   } else {
     res <- resolution(data[[var]], ...)
   }