Skip to content

Aesthetics for position adjustments #6100

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 18 commits into from
Jan 27, 2025
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -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
Expand Down
14 changes: 1 addition & 13 deletions R/geom-label.R
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
30 changes: 2 additions & 28 deletions R/geom-sf.R
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand All @@ -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,
Expand All @@ -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,
Expand Down
28 changes: 1 addition & 27 deletions R/geom-text.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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,
Expand Down
7 changes: 4 additions & 3 deletions R/layer.R
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down Expand Up @@ -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)) {
Expand Down Expand Up @@ -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)

Expand Down
32 changes: 32 additions & 0 deletions R/position-.R
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,8 @@
Position <- ggproto("Position",
required_aes = character(),

default_aes = aes(),

setup_params = function(self, data) {
list()
},
Expand All @@ -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

Comment on lines +81 to +100
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

There are some restrictions here that don't apply to the classic aesthetics, right? You can't use after_scale() for instance. Is that somehow taken care of?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Any surviving modifiers would be ignored. after_stat() is already evaluated, so that isn't really a concern. after_scale() doesn't really apply as position adjustments are computed before scales are applied. It will be interpreted as there is no such aesthetic, therefore the default value is substituted.

I'm not sure whether this was clear, but this does not replace Geom$use_defaults(), it just evaluates the Position$default_aes really.

}
)

Expand Down
24 changes: 23 additions & 1 deletion R/position-dodge.R
Original file line number Diff line number Diff line change
Expand Up @@ -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))) +
Expand Down Expand Up @@ -104,7 +106,10 @@ PositionDodge <- ggproto("PositionDodge", Position,
preserve = "total",
orientation = "x",
reverse = NULL,
default_aes = aes(order = NULL),
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I can be a bit worried that order is so general that it conflicts with aesthetics from extension packages. Have you looked into that?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It is hard to search for, but I can confidently tell you that no package on CRAN has a scale_order_*() function. I've personally never seen an extension package use an order aesthetic.


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",
Expand Down Expand Up @@ -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)
},

Expand Down Expand Up @@ -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)
Expand All @@ -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), ...))
}
29 changes: 13 additions & 16 deletions R/position-nudge.R
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand All @@ -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
Expand All @@ -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)
}
)
3 changes: 2 additions & 1 deletion R/utilities-help.R
Original file line number Diff line number Diff line change
Expand Up @@ -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())

Check warning on line 7 in R/utilities-help.R

View check run for this annotation

Codecov / codecov/patch

R/utilities-help.R#L6-L7

Added lines #L6 - L7 were not covered by tests
)
aes <- rd_aesthetics_item(obj)

Expand Down
2 changes: 1 addition & 1 deletion R/utilities.R
Original file line number Diff line number Diff line change
Expand Up @@ -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]], ...)
}
Expand Down
1 change: 1 addition & 0 deletions man/geom_boxplot.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

1 change: 1 addition & 0 deletions man/geom_dotplot.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading
Loading