From 50b7d30447dd69f032b61df75c77a0848864ba6e Mon Sep 17 00:00:00 2001 From: Luke Hannan Date: Thu, 9 Jan 2025 14:55:08 +0200 Subject: [PATCH 01/31] Fix typo in coord_radial documentation (#6277) --- R/coord-radial.R | 2 +- man/coord_polar.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/coord-radial.R b/R/coord-radial.R index 1b4da20a23..d02f88fd11 100644 --- a/R/coord-radial.R +++ b/R/coord-radial.R @@ -4,7 +4,7 @@ #' @param end Position from 12 o'clock in radians where plot ends, to allow #' for partial polar coordinates. The default, `NULL`, is set to #' `start + 2 * pi`. -#' @param expand If `TRUE`, the default, adds a small expansion factor the +#' @param expand If `TRUE`, the default, adds a small expansion factor to #' the limits to prevent overlap between data and axes. If `FALSE`, limits #' are taken directly from the scale. #' @param r.axis.inside One of the following: diff --git a/man/coord_polar.Rd b/man/coord_polar.Rd index 57be882bea..35d9083bfd 100644 --- a/man/coord_polar.Rd +++ b/man/coord_polar.Rd @@ -38,7 +38,7 @@ means no. For details, please see \code{\link[=coord_cartesian]{coord_cartesian( for partial polar coordinates. The default, \code{NULL}, is set to \code{start + 2 * pi}.} -\item{expand}{If \code{TRUE}, the default, adds a small expansion factor the +\item{expand}{If \code{TRUE}, the default, adds a small expansion factor to the limits to prevent overlap between data and axes. If \code{FALSE}, limits are taken directly from the scale.} From 3d1102cc1c2a2d6ab06382476849fb15205ef0a5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Jan 2025 11:31:42 +0100 Subject: [PATCH 02/31] Restore old guides in `guides()` (#6167) * Early exit earlier * fix `is.guide()` -> `inherits()` * explicitly test `guides()` adds old S3 guides properly --- R/guides-.R | 14 ++++++-------- tests/testthat/test-guides.R | 6 +++++- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/R/guides-.R b/R/guides-.R index debb99237e..0e7ca26882 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -68,11 +68,14 @@ NULL #' } guides <- function(...) { args <- list2(...) - if (length(args) > 0) { - if (is.list(args[[1]]) && !is.guide(args[[1]])) args <- args[[1]] - args <- rename_aes(args) + # If there are no guides do nothing + if (length(args) == 0) { + return(NULL) } + if (is.list(args[[1]]) && !inherits(args[[1]], "guide")) args <- args[[1]] + args <- rename_aes(args) + idx_false <- vapply(args, isFALSE, FUN.VALUE = logical(1L)) if (isTRUE(any(idx_false))) { deprecate_warn0("3.3.4", "guides(`` = 'cannot be `FALSE`. Use \"none\" instead')") @@ -84,11 +87,6 @@ guides <- function(...) { return(guides_list(guides = args)) } - # If there are no guides, do nothing - if (length(args) == 0) { - return(NULL) - } - # Raise warning about unnamed guides nms <- names(args) if (is.null(nms)) { diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 31ce6c8b98..5718e4f2ad 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -577,12 +577,16 @@ test_that("old S3 guides can be implemented", { withr::local_environment(my_env) + my_guides <- guides(x = guide_circle()) + expect_length(my_guides$guides, 1) + expect_s3_class(my_guides$guides[[1]], "guide") + expect_snapshot_warning( expect_doppelganger( "old S3 guide drawing a circle", ggplot(mtcars, aes(disp, mpg)) + geom_point() + - guides(x = "circle") + my_guides ) ) }) From 97edd6260a44c71a8ce7954ae4ad6be29224bda3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 21 Jan 2025 13:48:23 +0100 Subject: [PATCH 03/31] Continuous limits for discrete scales (#6273) * simplify expansion * add `continuous.limits` as scale argument * allow `scale$continuous_limits` to overrule expansion limits * document * confine and improve * add news bullet * add tests * fix wrong description * Better parity with continuous limits --- NEWS.md | 2 ++ R/scale-discrete-.R | 16 ++++++++++++++-- R/scale-expansion.R | 22 +++++++++++++++++----- man/scale_discrete.Rd | 15 +++++++++++++-- tests/testthat/test-scale-expansion.R | 21 +++++++++++++++++++++ 5 files changed, 67 insertions(+), 9 deletions(-) diff --git a/NEWS.md b/NEWS.md index e19471d2e2..539dee258c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* `scale_{x/y}_discrete(continuous.limits)` is a new argument to control the + display range of discrete scales (@teunbrand, #4174, #6259). * `geom_ribbon()` now appropriately warns about, and removes, missing values (@teunbrand, #6243). * `guide_*()` can now accept two inside legend theme elements: diff --git a/R/scale-discrete-.R b/R/scale-discrete-.R index f6fc512f9c..a5ff3289a4 100644 --- a/R/scale-discrete-.R +++ b/R/scale-discrete-.R @@ -16,6 +16,12 @@ #' argument (the number of levels in the scale) returns the numerical values #' that they should take. #' @param sec.axis [dup_axis()] is used to specify a secondary axis. +#' @param continuous.limits One of: +#' * `NULL` to use the default scale range +#' * A numeric vector of length two providing a display range for the scale. +#' Use `NA` to refer to the existing minimum or maximum. +#' * A function that accepts the limits and returns a numeric vector of +#' length two. #' @rdname scale_discrete #' @family position scales #' @seealso @@ -69,7 +75,8 @@ #' } scale_x_discrete <- function(name = waiver(), ..., palette = seq_len, expand = waiver(), guide = waiver(), - position = "bottom", sec.axis = waiver()) { + position = "bottom", sec.axis = waiver(), + continuous.limits = NULL) { sc <- discrete_scale( aesthetics = ggplot_global$x_aes, name = name, palette = palette, ..., @@ -78,13 +85,15 @@ scale_x_discrete <- function(name = waiver(), ..., palette = seq_len, ) sc$range_c <- ContinuousRange$new() + sc$continuous_limits <- continuous.limits set_sec_axis(sec.axis, sc) } #' @rdname scale_discrete #' @export scale_y_discrete <- function(name = waiver(), ..., palette = seq_len, expand = waiver(), guide = waiver(), - position = "left", sec.axis = waiver()) { + position = "left", sec.axis = waiver(), + continuous.limits = NULL) { sc <- discrete_scale( aesthetics = ggplot_global$y_aes, name = name, palette = palette, ..., @@ -93,6 +102,7 @@ scale_y_discrete <- function(name = waiver(), ..., palette = seq_len, ) sc$range_c <- ContinuousRange$new() + sc$continuous_limits <- continuous.limits set_sec_axis(sec.axis, sc) } @@ -106,6 +116,8 @@ scale_y_discrete <- function(name = waiver(), ..., palette = seq_len, #' @usage NULL #' @export ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete, + continuous_limits = NULL, + train = function(self, x) { if (is.discrete(x)) { self$range$train(x, drop = self$drop, na.rm = !self$na.translate) diff --git a/R/scale-expansion.R b/R/scale-expansion.R index a132f5cd22..9c682eeaa6 100644 --- a/R/scale-expansion.R +++ b/R/scale-expansion.R @@ -81,9 +81,7 @@ expand_range4 <- function(limits, expand) { # Calculate separate range expansion for the lower and # upper range limits, and then combine them into one vector - lower <- expand_range(limits, expand[1], expand[2])[1] - upper <- expand_range(limits, expand[3], expand[4])[2] - c(lower, upper) + expand_range(limits, expand[c(1, 3)], expand[c(2, 4)]) } #' Calculate the default expansion for a scale @@ -153,7 +151,8 @@ expand_limits_scale <- function(scale, expand = expansion(0, 0), limits = waiver scale$map(limits), expand, coord_limits, - range_continuous = scale$range_c$range + range_continuous = scale$range_c$range, + continuous_limits = scale$continuous_limits ) } else { # using the inverse transform to resolve the NA value is needed for date/datetime/time @@ -170,7 +169,20 @@ expand_limits_continuous <- function(limits, expand = expansion(0, 0), coord_lim } expand_limits_discrete <- function(limits, expand = expansion(0, 0), coord_limits = c(NA, NA), - range_continuous = NULL) { + range_continuous = NULL, continuous_limits = NULL) { + if (is.function(continuous_limits)) { + continuous_limits <- continuous_limits(limits) + } + if (!is.null(continuous_limits)) { + if (!anyNA(continuous_limits)) { + continuous_limits <- range(continuous_limits) + } + check_numeric(continuous_limits, arg = "continuous.limits") + check_length(continuous_limits, 2L, arg = "continuous.limits") + missing <- is.na(continuous_limits) + limits <- ifelse(missing, range(limits), continuous_limits) + } + limit_info <- expand_limits_discrete_trans( limits, expand, diff --git a/man/scale_discrete.Rd b/man/scale_discrete.Rd index 0bab3ad985..19e1df99fb 100644 --- a/man/scale_discrete.Rd +++ b/man/scale_discrete.Rd @@ -12,7 +12,8 @@ scale_x_discrete( expand = waiver(), guide = waiver(), position = "bottom", - sec.axis = waiver() + sec.axis = waiver(), + continuous.limits = NULL ) scale_y_discrete( @@ -22,7 +23,8 @@ scale_y_discrete( expand = waiver(), guide = waiver(), position = "left", - sec.axis = waiver() + sec.axis = waiver(), + continuous.limits = NULL ) } \arguments{ @@ -107,6 +109,15 @@ expand the scale by 5\% on each side for continuous variables, and by \code{left} or \code{right} for y axes, \code{top} or \code{bottom} for x axes.} \item{sec.axis}{\code{\link[=dup_axis]{dup_axis()}} is used to specify a secondary axis.} + +\item{continuous.limits}{One of: +\itemize{ +\item \code{NULL} to use the default scale range +\item A numeric vector of length two providing a display range for the scale. +Use \code{NA} to refer to the existing minimum or maximum. +\item A function that accepts the limits and returns a numeric vector of +length two. +}} } \description{ \code{scale_x_discrete()} and \code{scale_y_discrete()} are used to set the values for diff --git a/tests/testthat/test-scale-expansion.R b/tests/testthat/test-scale-expansion.R index 41bd9430e7..331c6a651d 100644 --- a/tests/testthat/test-scale-expansion.R +++ b/tests/testthat/test-scale-expansion.R @@ -96,6 +96,27 @@ test_that("expand_limits_discrete() can override limits with a both discrete and expand_limits_discrete(c("one", "two"), coord_limits = c(0, NA), range_continuous = c(1, 2)), c(0, 2) ) + expect_identical( + expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(0, 3)), + c(0, 3) + ) + expect_identical( + expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(NA, 4)), + c(1, 4) + ) + expect_identical( + expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(0, NA)), + c(0, 2) + ) + expect_identical( + expand_limits_discrete(1:2, range_continuous = c(1, 2), continuous_limits = c(NA_real_, NA_real_)), + c(1, 2) + ) + expect_identical( + expand_limits_discrete(1:2, range_continuous = 1:2, + continuous_limits = function(x) x + c(-1, 1)), + c(0, 3) + ) }) test_that("expand_limits_continuous_trans() works with inverted transformations", { From 180355242b82dd38f60853599f5ad862e3051e25 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 11:55:23 +0100 Subject: [PATCH 04/31] Subtheme functions (#5430) * Draft subtheme * warn when elements are unknown * Document * add tests * Add news bullet * Tweak test * Add topic to pkgdown index * rename prefix to `theme_sub_*()` * cleanup merge debris --- DESCRIPTION | 1 + NAMESPACE | 11 +++ NEWS.md | 5 ++ R/theme-sub.R | 144 +++++++++++++++++++++++++++++ _pkgdown.yml | 1 + man/subtheme.Rd | 159 +++++++++++++++++++++++++++++++++ tests/testthat/_snaps/theme.md | 4 + tests/testthat/test-theme.R | 26 ++++++ 8 files changed, 351 insertions(+) create mode 100644 R/theme-sub.R create mode 100644 man/subtheme.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 978cbf725c..777d755861 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -274,6 +274,7 @@ Collate: 'theme.R' 'theme-defaults.R' 'theme-current.R' + 'theme-sub.R' 'utilities-break.R' 'utilities-grid.R' 'utilities-help.R' diff --git a/NAMESPACE b/NAMESPACE index 391f435b30..690b9fb0ed 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -725,6 +725,17 @@ export(theme_linedraw) export(theme_minimal) export(theme_replace) export(theme_set) +export(theme_sub_axis) +export(theme_sub_axis_bottom) +export(theme_sub_axis_left) +export(theme_sub_axis_right) +export(theme_sub_axis_top) +export(theme_sub_axis_x) +export(theme_sub_axis_y) +export(theme_sub_legend) +export(theme_sub_panel) +export(theme_sub_plot) +export(theme_sub_strip) export(theme_test) export(theme_transparent) export(theme_update) diff --git a/NEWS.md b/NEWS.md index 539dee258c..62a18cfd4d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,10 @@ # ggplot2 (development version) +* New function family for setting parts of a theme. For example, you can now use + `theme_sub_axis(line, text, ticks, ticks.length, line)` as a substitute for + `theme(axis.line, axis.text, axis.ticks, axis.ticks.length, axis.line)`. This + should allow slightly terser and more organised theme declarations + (@teunbrand, #5301). * `scale_{x/y}_discrete(continuous.limits)` is a new argument to control the display range of discrete scales (@teunbrand, #4174, #6259). * `geom_ribbon()` now appropriately warns about, and removes, missing values diff --git a/R/theme-sub.R b/R/theme-sub.R new file mode 100644 index 0000000000..abfb178c44 --- /dev/null +++ b/R/theme-sub.R @@ -0,0 +1,144 @@ +#' Shortcuts for theme settings +#' +#' This collection of functions serves as a shortcut for [`theme()`][theme] with +#' shorter argument names. Besides the shorter arguments, it also helps in +#' keeping theme declarations more organised. +#' +#' @eval subtheme_param_doc() +#' +#' @return A `theme`-class object that can be added to a plot. +#' @name subtheme +#' +#' @examples +#' # A standard plot +#' p <- ggplot(mtcars, aes(disp, mpg, colour = drat)) + +#' geom_point() +#' +#' red_text <- element_text(colour = "red") +#' red_line <- element_line(colour = "red") +#' +#' # The theme settings below: +#' p + theme( +#' axis.title.x.bottom = red_text, +#' axis.text.x.bottom = red_text, +#' axis.line.x.bottom = red_line, +#' axis.ticks.x.bottom = red_line +#' ) +#' +#' # Are equivalent to these less verbose theme settings +#' p + theme_sub_axis_bottom( +#' title = red_text, +#' text = red_text, +#' line = red_line, +#' ticks = red_line +#' ) +NULL + +subtheme <- function(elements, prefix = "", suffix = "", call = caller_env()) { + if (length(elements) < 1) { + return(theme()) + } + names(elements) <- paste0(prefix, names(elements), suffix) + + extra <- setdiff(names(elements), names(get_element_tree())) + if (length(extra) > 0) { + cli::cli_warn( + "Ignoring unknown {.fn theme} element{?s}: {.and {.field {extra}}}.", + call = call + ) + elements <- elements[setdiff(names(elements), extra)] + } + + exec(theme, !!!elements) +} + +#' @export +#' @describeIn subtheme Theme specification for all axes. +theme_sub_axis <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.") +} + +#' @export +#' @describeIn subtheme Theme specification for both x axes. +theme_sub_axis_x <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.", ".x") +} + +#' @export +#' @describeIn subtheme Theme specification for both y axes. +theme_sub_axis_y <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.", ".y") +} + +#' @export +#' @describeIn subtheme Theme specification for the bottom x axis. +theme_sub_axis_bottom <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.", ".x.bottom") +} + +#' @export +#' @describeIn subtheme Theme specification for the top x axis. +theme_sub_axis_top <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.", ".x.top") +} + +#' @export +#' @describeIn subtheme Theme specification for the left y axis. +theme_sub_axis_left <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.", ".y.left") +} + +#' @export +#' @describeIn subtheme Theme specification for the right y axis. +theme_sub_axis_right <- function(title, text, ticks, ticks.length, line) { + subtheme(find_args(), "axis.", ".y.right") +} + +#' @export +#' @describeIn subtheme Theme specification for the legend. +theme_sub_legend <- function(background, margin, spacing, spacing.x, spacing.y, + key, key.size, key.height, key.width, text, title, + position, direction, justification, box, box.just, + box.margin, box.background, box.spacing) { + subtheme(find_args(), "legend.") +} + +#' @export +#' @describeIn subtheme Theme specification for the panels. +theme_sub_panel <- function(background, border, spacing, spacing.x, spacing.y, + grid, grid.major, grid.minor, grid.major.x, + grid.major.y, grid.minor.x, grid.minor.y, ontop) { + subtheme(find_args(), "panel.") +} + +#' @export +#' @describeIn subtheme Theme specification for the whole plot. +theme_sub_plot <- function(background, title, title.position, subtitle, caption, + caption.position, tag, tag.position, tag.location, + margin) { + subtheme(find_args(), "plot.") +} + +#' @export +#' @describeIn subtheme Theme specification for facet strips. +theme_sub_strip <- function(background, background.x, background.y, clip, + placement, text, text.x, text.x.bottom, text.x.top, + text.y, text.y.left, text.y.right, + switch.pad.grid, switch.pad.wrap) { + subtheme(find_args(), "strip.") +} + +subtheme_param_doc <- function() { + funs <- list( + theme_sub_axis, theme_sub_axis_x, theme_sub_axis_y, theme_sub_axis_bottom, + theme_sub_axis_top, theme_sub_axis_left, theme_sub_axis_right, theme_sub_legend, + theme_sub_panel, theme_sub_plot, theme_sub_strip + ) + args <- sort(unique(unlist(lapply(funs, fn_fmls_names), use.names = FALSE))) + paste0( + "@param ", + paste0(args, collapse = ","), + " Arguments that are renamed and passed on to ", + "\\code{\\link[=theme]{theme()}}." + ) +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 593f015590..0259312234 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -186,6 +186,7 @@ reference: - theme - theme_bw - theme_update + - subtheme - element_line - margin diff --git a/man/subtheme.Rd b/man/subtheme.Rd new file mode 100644 index 0000000000..a05a98a54c --- /dev/null +++ b/man/subtheme.Rd @@ -0,0 +1,159 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/theme-sub.R +\name{subtheme} +\alias{subtheme} +\alias{theme_sub_axis} +\alias{theme_sub_axis_x} +\alias{theme_sub_axis_y} +\alias{theme_sub_axis_bottom} +\alias{theme_sub_axis_top} +\alias{theme_sub_axis_left} +\alias{theme_sub_axis_right} +\alias{theme_sub_legend} +\alias{theme_sub_panel} +\alias{theme_sub_plot} +\alias{theme_sub_strip} +\title{Shortcuts for theme settings} +\usage{ +theme_sub_axis(title, text, ticks, ticks.length, line) + +theme_sub_axis_x(title, text, ticks, ticks.length, line) + +theme_sub_axis_y(title, text, ticks, ticks.length, line) + +theme_sub_axis_bottom(title, text, ticks, ticks.length, line) + +theme_sub_axis_top(title, text, ticks, ticks.length, line) + +theme_sub_axis_left(title, text, ticks, ticks.length, line) + +theme_sub_axis_right(title, text, ticks, ticks.length, line) + +theme_sub_legend( + background, + margin, + spacing, + spacing.x, + spacing.y, + key, + key.size, + key.height, + key.width, + text, + title, + position, + direction, + justification, + box, + box.just, + box.margin, + box.background, + box.spacing +) + +theme_sub_panel( + background, + border, + spacing, + spacing.x, + spacing.y, + grid, + grid.major, + grid.minor, + grid.major.x, + grid.major.y, + grid.minor.x, + grid.minor.y, + ontop +) + +theme_sub_plot( + background, + title, + title.position, + subtitle, + caption, + caption.position, + tag, + tag.position, + tag.location, + margin +) + +theme_sub_strip( + background, + background.x, + background.y, + clip, + placement, + text, + text.x, + text.x.bottom, + text.x.top, + text.y, + text.y.left, + text.y.right, + switch.pad.grid, + switch.pad.wrap +) +} +\arguments{ +\item{background, background.x, background.y, border, box, box.background, box.just, box.margin, box.spacing, caption, caption.position, clip, direction, grid, grid.major, grid.major.x, grid.major.y, grid.minor, grid.minor.x, grid.minor.y, justification, key, key.height, key.size, key.width, line, margin, ontop, placement, position, spacing, spacing.x, spacing.y, subtitle, switch.pad.grid, switch.pad.wrap, tag, tag.location, tag.position, text, text.x, text.x.bottom, text.x.top, text.y, text.y.left, text.y.right, ticks, ticks.length, title, title.position}{Arguments that are renamed and passed on to \code{\link[=theme]{theme()}}.} +} +\value{ +A \code{theme}-class object that can be added to a plot. +} +\description{ +This collection of functions serves as a shortcut for \code{\link[=theme]{theme()}} with +shorter argument names. Besides the shorter arguments, it also helps in +keeping theme declarations more organised. +} +\section{Functions}{ +\itemize{ +\item \code{theme_sub_axis()}: Theme specification for all axes. + +\item \code{theme_sub_axis_x()}: Theme specification for both x axes. + +\item \code{theme_sub_axis_y()}: Theme specification for both y axes. + +\item \code{theme_sub_axis_bottom()}: Theme specification for the bottom x axis. + +\item \code{theme_sub_axis_top()}: Theme specification for the top x axis. + +\item \code{theme_sub_axis_left()}: Theme specification for the left y axis. + +\item \code{theme_sub_axis_right()}: Theme specification for the right y axis. + +\item \code{theme_sub_legend()}: Theme specification for the legend. + +\item \code{theme_sub_panel()}: Theme specification for the panels. + +\item \code{theme_sub_plot()}: Theme specification for the whole plot. + +\item \code{theme_sub_strip()}: Theme specification for facet strips. + +}} +\examples{ +# A standard plot +p <- ggplot(mtcars, aes(disp, mpg, colour = drat)) + + geom_point() + +red_text <- element_text(colour = "red") +red_line <- element_line(colour = "red") + +# The theme settings below: +p + theme( + axis.title.x.bottom = red_text, + axis.text.x.bottom = red_text, + axis.line.x.bottom = red_line, + axis.ticks.x.bottom = red_line +) + +# Are equivalent to these less verbose theme settings +p + theme_sub_axis_bottom( + title = red_text, + text = red_text, + line = red_line, + ticks = red_line +) +} diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index fa7237d37d..322cce92b7 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -77,6 +77,10 @@ `plot.tag.position` must be one of "topleft", "top", "topright", "left", "right", "bottomleft", "bottom", or "bottomright", not "test". i Did you mean "left"? +# subtheme functions rename arguments as intended + + Ignoring unknown `theme()` elements: foo and bar. + # Theme validation behaves as expected The `aspect.ratio` theme element must be a object. diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index ef358b10b6..b6248acaa3 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -514,6 +514,32 @@ test_that("Theme elements are checked during build", { expect_snapshot_error(ggplotGrob(p)) }) +test_that("subtheme functions rename arguments as intended", { + + line <- element_line(colour = "red") + rect <- element_rect(colour = "red") + + expect_equal(theme_sub_axis(ticks = line), theme(axis.ticks = line)) + expect_equal(theme_sub_axis_x(ticks = line), theme(axis.ticks.x = line)) + expect_equal(theme_sub_axis_y(ticks = line), theme(axis.ticks.y = line)) + expect_equal(theme_sub_axis_top(ticks = line), theme(axis.ticks.x.top = line)) + expect_equal(theme_sub_axis_bottom(ticks = line), theme(axis.ticks.x.bottom = line)) + expect_equal(theme_sub_axis_left(ticks = line), theme(axis.ticks.y.left = line)) + expect_equal(theme_sub_axis_right(ticks = line), theme(axis.ticks.y.right = line)) + expect_equal(theme_sub_legend(key = rect), theme(legend.key = rect)) + expect_equal(theme_sub_panel(border = rect), theme(panel.border = rect)) + expect_equal(theme_sub_plot(background = rect), theme(plot.background = rect)) + expect_equal(theme_sub_strip(background = rect), theme(strip.background = rect)) + + # Test rejection of unknown theme elements + expect_snapshot_warning( + expect_equal( + subtheme(list(foo = 1, bar = 2, axis.line = line)), + theme(axis.line = line) + ) + ) +}) + test_that("Theme validation behaves as expected", { tree <- get_element_tree() expect_silent(validate_element(1, "aspect.ratio", tree)) From 628d7ab5ee286ae86e816b14879406289c23a7b0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 12:02:30 +0100 Subject: [PATCH 05/31] Standardise `width` calculation (#6065) * helper for computing size * use helper * add news bullet --- NEWS.md | 2 ++ R/geom-bar.R | 13 ++++++------- R/geom-boxplot.R | 17 +++++++++-------- R/geom-dotplot.R | 12 ++++++++---- R/geom-errorbar.R | 12 ++++++++---- R/geom-tile.R | 21 ++++++++++++++------- R/geom-violin.R | 11 +++++++---- R/utilities.R | 29 +++++++++++++++++++++++++++++ 8 files changed, 83 insertions(+), 34 deletions(-) diff --git a/NEWS.md b/NEWS.md index 62a18cfd4d..140d7dd25b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -252,6 +252,8 @@ * `geom_abline()` clips to the panel range in the vertical direction too (@teunbrand, #6086). * Added `panel.widths` and `panel.heights` to `theme()` (#5338, @teunbrand). +* Standardised the calculation of `width`, which are now implemented as + aesthetics (@teunbrand, #2800). # ggplot2 3.5.1 diff --git a/R/geom-bar.R b/R/geom-bar.R index de7490bfc4..19c86dfbb1 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -130,7 +130,7 @@ GeomBar <- ggproto("GeomBar", GeomRect, # limits, not just those for which x and y are outside the limits non_missing_aes = c("xmin", "xmax", "ymin", "ymax"), - default_aes = aes(!!!GeomRect$default_aes, width = NULL), + default_aes = aes(!!!GeomRect$default_aes, width = 0.9), setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params) @@ -139,14 +139,13 @@ GeomBar <- ggproto("GeomBar", GeomRect, extra_params = c("just", "na.rm", "orientation"), - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (min(vapply( - split(data$x, data$PANEL, drop = TRUE), - resolution, numeric(1), zero = FALSE - )) * 0.9) + data <- compute_data_size( + data, size = params$width, + default = self$default_aes$width, zero = FALSE + ) data$just <- params$just %||% 0.5 data <- transform(data, ymin = pmin(y, 0), ymax = pmax(y, 0), diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index efb6dd14bd..eaa950dced 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -236,21 +236,21 @@ geom_boxplot <- function(mapping = NULL, data = NULL, #' @export GeomBoxplot <- ggproto("GeomBoxplot", Geom, - # need to declare `width` here in case this geom is used with a stat that - # doesn't have a `width` parameter (e.g., `stat_identity`). - extra_params = c("na.rm", "width", "orientation", "outliers"), + extra_params = c("na.rm", "orientation", "outliers"), setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params) params }, - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) - + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + zero = FALSE, discrete = TRUE + ) if (isFALSE(params$outliers)) { data$outliers <- NULL } @@ -389,7 +389,8 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, weight = 1, colour = from_theme(col_mix(ink, paper, 0.2)), fill = from_theme(paper), size = from_theme(pointsize), alpha = NA, shape = from_theme(pointshape), linetype = from_theme(bordertype), - linewidth = from_theme(borderwidth) + linewidth = from_theme(borderwidth), + width = 0.9 ), required_aes = c("x|y", "lower|xlower", "upper|xupper", "middle|xmiddle", "ymin|xmin", "ymax|xmax"), diff --git a/R/geom-dotplot.R b/R/geom-dotplot.R index 54b7ce1f57..09ebeb793e 100644 --- a/R/geom-dotplot.R +++ b/R/geom-dotplot.R @@ -194,12 +194,16 @@ GeomDotplot <- ggproto("GeomDotplot", Geom, alpha = NA, stroke = from_theme(borderwidth * 2), linetype = from_theme(linetype), - weight = 1 + weight = 1, + width = 0.9 ), - setup_data = function(data, params) { - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) + setup_data = function(self, data, params) { + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + zero = FALSE, discrete = TRUE + ) # Set up the stacking function and range if (is.null(params$stackdir) || params$stackdir == "up") { diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R index 7551f0be59..b75d81cd9d 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -62,7 +62,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, colour = from_theme(ink), linewidth = from_theme(linewidth), linetype = from_theme(linetype), - width = 0.5, + width = 0.9, alpha = NA ), @@ -76,17 +76,21 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, extra_params = c("na.rm", "orientation"), - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + zero = FALSE, discrete = TRUE + ) data <- transform(data, xmin = x - width / 2, xmax = x + width / 2, width = NULL ) flip_data(data, params$flipped_aes) }, + # Note: `width` is vestigial draw_panel = function(self, data, panel_params, coord, lineend = "butt", width = NULL, flipped_aes = FALSE) { data <- check_linewidth(data, snake_class(self)) diff --git a/R/geom-tile.R b/R/geom-tile.R index e7bb6bc9e3..04ff0b71c2 100644 --- a/R/geom-tile.R +++ b/R/geom-tile.R @@ -109,13 +109,20 @@ geom_tile <- function(mapping = NULL, data = NULL, GeomTile <- ggproto("GeomTile", GeomRect, extra_params = c("na.rm"), - setup_data = function(data, params) { - - data$width <- data$width %||% params$width %||% - stats::ave(data$x, data$PANEL, FUN = function(x) resolution(x, FALSE, TRUE)) - data$height <- data$height %||% params$height %||% - stats::ave(data$y, data$PANEL, FUN = function(y) resolution(y, FALSE, TRUE)) + setup_data = function(self, data, params) { + data <- compute_data_size( + data, params$width, + default = self$default_aes$width, + panels = "by", target = "width", + zero = FALSE, discrete = TRUE + ) + data <- compute_data_size( + data, params$height, + default = self$default_aes$height, + panels = "by", target = "height", + zero = FALSE, discrete = TRUE + ) transform(data, xmin = x - width / 2, xmax = x + width / 2, width = NULL, ymin = y - height / 2, ymax = y + height / 2, height = NULL @@ -127,7 +134,7 @@ GeomTile <- ggproto("GeomTile", GeomRect, colour = NA, linewidth = from_theme(0.4 * borderwidth), linetype = from_theme(bordertype), - alpha = NA, width = NA, height = NA + alpha = NA, width = 1, height = 1 ), required_aes = c("x", "y"), diff --git a/R/geom-violin.R b/R/geom-violin.R index 9976e5b8a4..e53c29396f 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -131,11 +131,13 @@ GeomViolin <- ggproto("GeomViolin", Geom, extra_params = c("na.rm", "orientation", "lineend", "linejoin", "linemitre"), - setup_data = function(data, params) { + setup_data = function(self, data, params) { data$flipped_aes <- params$flipped_aes data <- flip_data(data, params$flipped_aes) - data$width <- data$width %||% - params$width %||% (resolution(data$x, FALSE, TRUE) * 0.9) + data <- compute_data_size( + data, params$width, + default = self$default_aes$width + ) # ymin, ymax, xmin, and xmax define the bounding rectangle for each group data <- dapply(data, "group", transform, xmin = x - width / 2, @@ -203,7 +205,8 @@ GeomViolin <- ggproto("GeomViolin", Geom, fill = from_theme(paper), linewidth = from_theme(borderwidth), linetype = from_theme(bordertype), - alpha = NA + alpha = NA, + width = 0.9 ), required_aes = c("x", "y"), diff --git a/R/utilities.R b/R/utilities.R index 54087eba68..adb2475047 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -909,3 +909,32 @@ prompt_install <- function(pkg, reason = NULL) { utils::install.packages(pkg) is_installed(pkg) } + +compute_data_size <- function(data, size, default = 0.9, + target = "width", + panels = c("across", "by", "ignore"), + ...) { + + data[[target]] <- data[[target]] %||% size + if (!is.null(data[[target]])) { + return(data) + } + + var <- if (target == "height") "y" else "x" + panels <- arg_match0(panels, c("across", "by", "ignore")) + + if (panels == "across") { + res <- split(data[[var]], data$PANEL, drop = FALSE) + 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, ...)) + } else { + res <- resolution(data[[var]], ...) + } + if (is_quosure(default)) { + default <- eval_tidy(default, data = data) + } + data[[target]] <- res * (default %||% 0.9) + data +} From 9eeeafed53bf57b23212efc7ce2689faa6f61230 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 12:24:00 +0100 Subject: [PATCH 06/31] Improve consistency of naming internal functions (#6072) * rename `validate_facets()` to `check_facets()` * write prevalidation/postvalidation as checks * more responsibility for `check_nondata_cols()` * `check_subclass()` is actually validator * path checker is validator * plot_dev is a validator * `check_breaks_labels()` has no return value * make `check_scale_type()` consistent * `validate_theme/element()` is a check * update labeller deprecation message * `check_labeller()` performs an update * `check_linewidth()` performs an update * `check_polar_guide()` is validator * `update_labeller()` -> `fix_labeller()` * `update_linewidth()` -> `fix_linewidth()` * `check_facet_class()` --> `check_vars()` --- R/coord-radial.R | 4 +- R/facet-.R | 6 +- R/facet-grid-.R | 2 +- R/facet-wrap.R | 2 +- R/fortify.R | 46 ++++++++++------ R/geom-.R | 18 ++---- R/geom-boxplot.R | 2 +- R/geom-crossbar.R | 3 +- R/geom-defaults.R | 4 +- R/geom-errorbar.R | 2 +- R/geom-hex.R | 2 +- R/geom-path.R | 2 +- R/geom-polygon.R | 2 +- R/geom-rect.R | 2 +- R/geom-ribbon.R | 2 +- R/geom-rug.R | 2 +- R/geom-segment.R | 2 +- R/guide-.R | 4 +- R/labeller.R | 14 ++--- R/layer.R | 64 ++++++++-------------- R/save.R | 10 ++-- R/scale-.R | 9 +-- R/scale-colour.R | 9 ++- R/scales-.R | 1 + R/theme-elements.R | 2 +- R/theme.R | 8 +-- R/utilities-help.R | 4 +- R/utilities.R | 34 ++++++++---- tests/testthat/_snaps/facet-.md | 6 +- tests/testthat/_snaps/facet-labels.md | 4 +- tests/testthat/_snaps/fortify.md | 24 ++++---- tests/testthat/_snaps/geom-.md | 8 +-- tests/testthat/_snaps/ggsave.md | 4 +- tests/testthat/_snaps/layer.md | 26 ++++----- tests/testthat/test-facet-.R | 6 +- tests/testthat/test-ggsave.R | 12 ++-- tests/testthat/test-layer.R | 4 +- tests/testthat/test-scales-breaks-labels.R | 4 +- tests/testthat/test-theme.R | 8 +-- 39 files changed, 183 insertions(+), 185 deletions(-) diff --git a/R/coord-radial.R b/R/coord-radial.R index d02f88fd11..1fea09dcde 100644 --- a/R/coord-radial.R +++ b/R/coord-radial.R @@ -191,7 +191,7 @@ CoordRadial <- ggproto("CoordRadial", Coord, # Validate appropriateness of guides drop_guides <- character(0) for (type in aesthetics) { - drop_guides <- check_polar_guide(drop_guides, guides, type) + drop_guides <- validate_polar_guide(drop_guides, guides, type) } guide_params <- guides$get_params(aesthetics) @@ -603,7 +603,7 @@ theta_grid <- function(theta, element, inner_radius = c(0, 0.4), ) } -check_polar_guide <- function(drop_list, guides, type = "theta") { +validate_polar_guide <- function(drop_list, guides, type = "theta") { guide <- guides$get_guide(type) primary <- gsub("\\.sec$", "", type) if (inherits(guide, "GuideNone") || primary %in% guide$available_aes) { diff --git a/R/facet-.R b/R/facet-.R index b124b54872..0c120beba3 100644 --- a/R/facet-.R +++ b/R/facet-.R @@ -443,7 +443,7 @@ df.grid <- function(a, b) { # facetting variables. as_facets_list <- function(x) { - x <- validate_facets(x) + check_vars(x) if (is_quosures(x)) { x <- quos_auto_name(x) return(list(x)) @@ -487,7 +487,7 @@ as_facets_list <- function(x) { x } -validate_facets <- function(x) { +check_vars <- function(x) { if (is.mapping(x)) { cli::cli_abort("Please use {.fn vars} to supply facet variables.") } @@ -499,7 +499,7 @@ validate_facets <- function(x) { "i" = "Did you use {.code %>%} or {.code |>} instead of {.code +}?" )) } - x + invisible() } # Flatten a list of quosures objects to a quosures object, and compact it diff --git a/R/facet-grid-.R b/R/facet-grid-.R index 784e394885..be11524541 100644 --- a/R/facet-grid-.R +++ b/R/facet-grid-.R @@ -177,7 +177,7 @@ facet_grid <- function(rows = NULL, cols = NULL, scales = "fixed", facets_list <- grid_as_facets_list(rows, cols) # Check for deprecated labellers - labeller <- check_labeller(labeller) + labeller <- fix_labeller(labeller) ggproto(NULL, FacetGrid, shrink = shrink, diff --git a/R/facet-wrap.R b/R/facet-wrap.R index 114b3332d9..6bc72f8af4 100644 --- a/R/facet-wrap.R +++ b/R/facet-wrap.R @@ -174,7 +174,7 @@ facet_wrap <- function(facets, nrow = NULL, ncol = NULL, scales = "fixed", ) # Check for deprecated labellers - labeller <- check_labeller(labeller) + labeller <- fix_labeller(labeller) # Flatten all facets dimensions into a single one facets <- compact_facets(facets) diff --git a/R/fortify.R b/R/fortify.R index da4bcf7892..17d6e37b12 100644 --- a/R/fortify.R +++ b/R/fortify.R @@ -44,34 +44,46 @@ fortify.grouped_df <- function(model, data, ...) { # There are a lot of ways that dim(), colnames(), or as.data.frame() could # do non-sensical things (they are not even guaranteed to work!) hence the # paranoid mode. -.prevalidate_data_frame_like_object <- function(data) { +check_data_frame_like <- function(data) { orig_dims <- dim(data) - if (!vec_is(orig_dims, integer(), size=2)) - cli::cli_abort(paste0("{.code dim(data)} must return ", - "an {.cls integer} of length 2.")) - if (anyNA(orig_dims) || any(orig_dims < 0)) # extra-paranoid mode - cli::cli_abort(paste0("{.code dim(data)} can't have {.code NA}s ", - "or negative values.")) + if (!vec_is(orig_dims, integer(), size = 2)) { + cli::cli_abort( + "{.code dim(data)} must return an {.cls integer} of length 2." + ) + } + if (anyNA(orig_dims) || any(orig_dims < 0)) { # extra-paranoid mode + cli::cli_abort( + "{.code dim(data)} can't have {.code NA}s or negative values." + ) + } orig_colnames <- colnames(data) - if (!vec_is(orig_colnames, character(), size = ncol(data))) - cli::cli_abort(paste0("{.code colnames(data)} must return a ", - "{.cls character} of length {.code ncol(data)}.")) + if (!vec_is(orig_colnames, character(), size = ncol(data))) { + cli::cli_abort( + "{.code colnames(data)} must return a {.cls character} of length {.code ncol(data)}." + ) + } + invisible() } -.postvalidate_data_frame_like_object <- function(df, data) { +check_data_frame_conversion <- function(new, old) { msg0 <- "{.code as.data.frame(data)} must " - if (!is.data.frame(df)) + if (!is.data.frame(new)) { cli::cli_abort(paste0(msg0, "return a {.cls data.frame}.")) - if (!identical(dim(df), dim(data))) + } + if (!identical(dim(new), dim(old))) { cli::cli_abort(paste0(msg0, "preserve dimensions.")) - if (!identical(colnames(df), colnames(data))) + } + if (!identical(colnames(new), colnames(old))) { cli::cli_abort(paste0(msg0, "preserve column names.")) + } + invisible() } validate_as_data_frame <- function(data) { - if (is.data.frame(data)) + if (is.data.frame(data)) { return(data) - .prevalidate_data_frame_like_object(data) + } + check_data_frame_like(data) df <- as.data.frame(data) - .postvalidate_data_frame_like_object(df, data) + check_data_frame_conversion(df, data) df } diff --git a/R/geom-.R b/R/geom-.R index 50bdeb66a6..f8b5027438 100644 --- a/R/geom-.R +++ b/R/geom-.R @@ -170,17 +170,11 @@ Geom <- ggproto("Geom", ) # Check that all output are valid data - nondata_modified <- check_nondata_cols(modified_aes) - if (length(nondata_modified) > 0) { - issues <- paste0("{.code ", nondata_modified, " = ", as_label(modifiers[[nondata_modified]]), "}") - names(issues) <- rep("x", length(issues)) - cli::cli_abort(c( - "Aesthetic modifiers returned invalid values", - "x" = "The following mappings are invalid", - issues, - "i" = "Did you map the modifier in the wrong layer?" - )) - } + check_nondata_cols( + modified_aes, modifiers, + problem = "Aesthetic modifiers returned invalid values.", + hint = "Did you map the modifier in the wrong layer?" + ) modified_aes <- cleanup_mismatched_data(modified_aes, nrow(data), "after_scale") @@ -283,7 +277,7 @@ check_aesthetics <- function(x, n) { )) } -check_linewidth <- function(data, name) { +fix_linewidth <- function(data, name) { if (is.null(data$linewidth) && !is.null(data$size)) { deprecate_soft0("3.4.0", I(paste0("Using the `size` aesthetic with ", name)), I("the `linewidth` aesthetic")) data$linewidth <- data$size diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index eaa950dced..edd6117538 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -286,7 +286,7 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, whisker_gp = NULL, staple_gp = NULL, median_gp = NULL, box_gp = NULL, notch = FALSE, notchwidth = 0.5, staplewidth = 0, varwidth = FALSE, flipped_aes = FALSE) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) # this may occur when using geom_boxplot(stat = "identity") if (nrow(data) != 1) { diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index be7ce1f658..7316033de6 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -84,8 +84,7 @@ GeomCrossbar <- ggproto("GeomCrossbar", Geom, draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre", fatten = 2.5, width = NULL, flipped_aes = FALSE, middle_gp = NULL, box_gp = NULL) { - - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) middle <- transform(data, x = xmin, xend = xmax, yend = y, linewidth = linewidth * fatten, alpha = NA) diff --git a/R/geom-defaults.R b/R/geom-defaults.R index 732f5ddb32..c1bc8a782f 100644 --- a/R/geom-defaults.R +++ b/R/geom-defaults.R @@ -106,7 +106,7 @@ get_geom_defaults <- function(geom, theme = theme_get()) { return(data) } if (is.character(geom)) { - geom <- check_subclass(geom, "Geom") + geom <- validate_subclass(geom, "Geom") } if (is.geom(geom)) { out <- geom$use_defaults(data = NULL, theme = theme) @@ -126,7 +126,7 @@ reset_stat_defaults <- function() reset_defaults("stat") cache_defaults <- new_environment() update_defaults <- function(name, subclass, new, env = parent.frame()) { - obj <- check_subclass(name, subclass, env = env) + obj <- validate_subclass(name, subclass, env = env) index <- snake_class(obj) if (is.null(new)) { # Reset from cache diff --git a/R/geom-errorbar.R b/R/geom-errorbar.R index b75d81cd9d..3e50c59877 100644 --- a/R/geom-errorbar.R +++ b/R/geom-errorbar.R @@ -93,7 +93,7 @@ GeomErrorbar <- ggproto("GeomErrorbar", Geom, # Note: `width` is vestigial draw_panel = function(self, data, panel_params, coord, lineend = "butt", width = NULL, flipped_aes = FALSE) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) x <- vec_interleave(data$xmin, data$xmax, NA, data$x, data$x, NA, data$xmin, data$xmax) y <- vec_interleave(data$ymax, data$ymax, NA, data$ymax, data$ymin, NA, data$ymin, data$ymin) diff --git a/R/geom-hex.R b/R/geom-hex.R index 152227a40b..5add9250c8 100644 --- a/R/geom-hex.R +++ b/R/geom-hex.R @@ -58,7 +58,7 @@ geom_hex <- function(mapping = NULL, data = NULL, GeomHex <- ggproto("GeomHex", Geom, draw_group = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre", linemitre = 10) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) if (empty(data)) { return(zeroGrob()) } diff --git a/R/geom-path.R b/R/geom-path.R index 72c4f7154e..fe930363a6 100644 --- a/R/geom-path.R +++ b/R/geom-path.R @@ -165,7 +165,7 @@ GeomPath <- ggproto("GeomPath", Geom, draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, lineend = "butt", linejoin = "round", linemitre = 10, na.rm = FALSE) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) if (!anyDuplicated(data$group)) { cli::cli_inform(c( "{.fn {snake_class(self)}}: Each group consists of only one observation.", diff --git a/R/geom-polygon.R b/R/geom-polygon.R index a271ef5011..a97d3c2194 100644 --- a/R/geom-polygon.R +++ b/R/geom-polygon.R @@ -109,7 +109,7 @@ geom_polygon <- function(mapping = NULL, data = NULL, GeomPolygon <- ggproto("GeomPolygon", Geom, draw_panel = function(self, data, panel_params, coord, rule = "evenodd", lineend = "butt", linejoin = "round", linemitre = 10) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) n <- nrow(data) if (n == 1) return(zeroGrob()) diff --git a/R/geom-rect.R b/R/geom-rect.R index 8473474525..1765a2506a 100644 --- a/R/geom-rect.R +++ b/R/geom-rect.R @@ -69,7 +69,7 @@ GeomRect <- ggproto("GeomRect", Geom, }, draw_panel = function(self, data, panel_params, coord, lineend = "butt", linejoin = "mitre") { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) if (!coord$is_linear()) { aesthetics <- setdiff( names(data), c("x", "y", "xmin", "xmax", "ymin", "ymax") diff --git a/R/geom-ribbon.R b/R/geom-ribbon.R index f1d339a2eb..4365c122d5 100644 --- a/R/geom-ribbon.R +++ b/R/geom-ribbon.R @@ -157,7 +157,7 @@ GeomRibbon <- ggproto("GeomRibbon", Geom, draw_group = function(self, data, panel_params, coord, lineend = "butt", linejoin = "round", linemitre = 10, na.rm = FALSE, flipped_aes = FALSE, outline.type = "both") { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) data <- flip_data(data, flipped_aes) data <- data[order(data$group), ] diff --git a/R/geom-rug.R b/R/geom-rug.R index ffc761b91c..8992f1069d 100644 --- a/R/geom-rug.R +++ b/R/geom-rug.R @@ -90,7 +90,7 @@ GeomRug <- ggproto("GeomRug", Geom, draw_panel = function(self, data, panel_params, coord, lineend = "butt", sides = "bl", outside = FALSE, length = unit(0.03, "npc")) { - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) check_inherits(length, "unit") rugs <- list() data <- coord$transform(data, panel_params) diff --git a/R/geom-segment.R b/R/geom-segment.R index 00d9eff87a..51de135b53 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -116,7 +116,7 @@ GeomSegment <- ggproto("GeomSegment", Geom, lineend = "butt", linejoin = "round", na.rm = FALSE) { data$xend <- data$xend %||% data$x data$yend <- data$yend %||% data$y - data <- check_linewidth(data, snake_class(self)) + data <- fix_linewidth(data, snake_class(self)) data <- remove_missing(data, na.rm = na.rm, c("x", "y", "xend", "yend", "linetype", "linewidth"), name = "geom_segment" diff --git a/R/guide-.R b/R/guide-.R index c700329cb3..54cae7c873 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -19,7 +19,7 @@ NULL new_guide <- function(..., available_aes = "any", super) { pf <- parent.frame() - super <- check_subclass(super, "Guide", env = pf) + super <- validate_subclass(super, "Guide", env = pf) args <- list2(...) @@ -51,7 +51,7 @@ new_guide <- function(..., available_aes = "any", super) { # Validate theme settings if (!is.null(params$theme)) { check_object(params$theme, is.theme, what = "a {.cls theme} object") - validate_theme(params$theme, call = caller_env()) + check_theme(params$theme, call = caller_env()) params$direction <- params$direction %||% params$theme$legend.direction } diff --git a/R/labeller.R b/R/labeller.R index 4ca220c2b4..a9ba883a79 100644 --- a/R/labeller.R +++ b/R/labeller.R @@ -577,21 +577,21 @@ assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) { }) } -# Check for old school labeller -check_labeller <- function(labeller) { +# Repair old school labeller +fix_labeller <- function(labeller) { labeller <- match.fun(labeller) is_deprecated <- all(c("variable", "value") %in% names(formals(labeller))) if (is_deprecated) { + deprecate_warn0( + "2.0.0", what = "facet_(labeller)", + details = + "Modern labellers do not take `variable` and `value` arguments anymore." + ) old_labeller <- labeller labeller <- function(labels) { Map(old_labeller, names(labels), labels) } - # TODO Update to lifecycle after next lifecycle release - cli::cli_warn(c( - "The {.arg labeller} API has been updated. Labellers taking {.arg variable} and {.arg value} arguments are now deprecated.", - "i" = "See labellers documentation." - )) } labeller diff --git a/R/layer.R b/R/layer.R index d2355a46ba..a915763e3c 100644 --- a/R/layer.R +++ b/R/layer.R @@ -101,12 +101,6 @@ layer <- function(geom = NULL, stat = NULL, show.legend = NA, key_glyph = NULL, layer_class = Layer) { call_env <- caller_env() user_env <- caller_env(2) - if (is.null(geom)) - cli::cli_abort("Can't create layer without a geom.", call = call_env) - if (is.null(stat)) - cli::cli_abort("Can't create layer without a stat.", call = call_env) - if (is.null(position)) - cli::cli_abort("Can't create layer without a position.", call = call_env) # Handle show_guide/show.legend if (!is.null(params$show_guide)) { @@ -125,9 +119,9 @@ layer <- function(geom = NULL, stat = NULL, data <- fortify(data) - geom <- check_subclass(geom, "Geom", env = parent.frame(), call = call_env) - stat <- check_subclass(stat, "Stat", env = parent.frame(), call = call_env) - position <- check_subclass(position, "Position", env = parent.frame(), call = call_env) + geom <- validate_subclass(geom, "Geom", env = parent.frame(), call = call_env) + stat <- validate_subclass(stat, "Stat", env = parent.frame(), call = call_env) + position <- validate_subclass(position, "Position", env = parent.frame(), call = call_env) # Special case for na.rm parameter needed by all layers params$na.rm <- params$na.rm %||% FALSE @@ -314,17 +308,11 @@ Layer <- ggproto("Layer", NULL, warn_for_aes_extract_usage(aesthetics, data[setdiff(names(data), "PANEL")]) # Check aesthetic values - nondata_cols <- check_nondata_cols(evaled) - if (length(nondata_cols) > 0) { - issues <- paste0("{.code ", nondata_cols, " = ", as_label(aesthetics[[nondata_cols]]), "}") - names(issues) <- rep("x", length(issues)) - cli::cli_abort(c( - "Aesthetics are not valid data columns.", - "x" = "The following aesthetics are invalid:", - issues, - "i" = "Did you mistype the name of a data column or forget to add {.fn after_stat}?" - )) - } + check_nondata_cols( + evaled, aesthetics, + problem = "Aesthetics are not valid data columns.", + hint = "Did you mistype the name of a data column or forget to add {.fn after_stat}?" + ) n <- nrow(data) aes_n <- list_sizes(evaled) @@ -392,17 +380,11 @@ Layer <- ggproto("Layer", NULL, mask = list(stage = stage_calculated) ) # Check that all columns in aesthetic stats are valid data - nondata_stat_cols <- check_nondata_cols(stat_data) - if (length(nondata_stat_cols) > 0) { - issues <- paste0("{.code ", nondata_stat_cols, " = ", as_label(aesthetics[[nondata_stat_cols]]), "}") - names(issues) <- rep("x", length(issues)) - cli::cli_abort(c( - "Aesthetics must be valid computed stats.", - "x" = "The following aesthetics are invalid:", - issues, - "i" = "Did you map your stat in the wrong layer?" - )) - } + check_nondata_cols( + stat_data, aesthetics, + problem = "Aesthetics must be valid computed stats.", + hint = "Did you map your stat in the wrong layer?" + ) stat_data <- data_frame0(!!!stat_data) @@ -464,24 +446,26 @@ Layer <- ggproto("Layer", NULL, } ) -check_subclass <- function(x, subclass, - argname = to_lower_ascii(subclass), - env = parent.frame(), - call = caller_env()) { +validate_subclass <- function(x, subclass, + argname = to_lower_ascii(subclass), + x_arg = caller_arg(x), + env = parent.frame(), + call = caller_env()) { + if (inherits(x, subclass)) { - x + return(x) } else if (is_scalar_character(x)) { name <- paste0(subclass, camelize(x, first = TRUE)) obj <- find_global(name, env = env) if (is.null(obj) || !inherits(obj, subclass)) { cli::cli_abort("Can't find {argname} called {.val {x}}.", call = call) - } else { - obj } - } else { - stop_input_type(x, as_cli("either a string or a {.cls {subclass}} object")) + return(obj) + } else if (is.null(x)) { + cli::cli_abort("The {.arg {x_arg}} argument cannot be empty.", call = call) } + stop_input_type(x, as_cli("either a string or a {.cls {subclass}} object")) } # helper function to adjust the draw_key slot of a geom diff --git a/R/save.R b/R/save.R index b06c567b2e..5e1ef5983a 100644 --- a/R/save.R +++ b/R/save.R @@ -95,10 +95,10 @@ ggsave <- function(filename, plot = get_last_plot(), dpi = 300, limitsize = TRUE, bg = NULL, create.dir = FALSE, ...) { - filename <- check_path(path, filename, create.dir) + filename <- validate_path(path, filename, create.dir) dpi <- parse_dpi(dpi) - dev <- plot_dev(device, filename, dpi = dpi) + dev <- validate_device(device, filename, dpi = dpi) dim <- plot_dim(c(width, height), scale = scale, units = units, limitsize = limitsize, dpi = dpi) @@ -116,8 +116,8 @@ ggsave <- function(filename, plot = get_last_plot(), invisible(filename) } -check_path <- function(path, filename, create.dir, - call = caller_env()) { +validate_path <- function(path, filename, create.dir, + call = caller_env()) { if (length(filename) > 1 && is.character(filename)) { cli::cli_warn(c( @@ -235,7 +235,7 @@ plot_dim <- function(dim = c(NA, NA), scale = 1, units = "in", dim } -plot_dev <- function(device, filename = NULL, dpi = 300, call = caller_env()) { +validate_device <- function(device, filename = NULL, dpi = 300, call = caller_env()) { force(filename) force(dpi) diff --git a/R/scale-.R b/R/scale-.R index 4bf54328b3..b2f9ef346a 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -622,11 +622,8 @@ Scale <- ggproto("Scale", NULL, ) check_breaks_labels <- function(breaks, labels, call = NULL) { - if (is.null(breaks)) { - return(TRUE) - } - if (is.null(labels)) { - return(TRUE) + if (is.null(breaks) || is.null(labels)) { + return(invisible()) } bad_labels <- is.atomic(breaks) && is.atomic(labels) && @@ -638,7 +635,7 @@ check_breaks_labels <- function(breaks, labels, call = NULL) { ) } - TRUE + invisible() } default_transform <- function(self, x) { diff --git a/R/scale-colour.R b/R/scale-colour.R index a17d872dbe..592aa288e1 100644 --- a/R/scale-colour.R +++ b/R/scale-colour.R @@ -81,7 +81,6 @@ scale_colour_continuous <- function(..., aesthetics = "colour", guide = "colourbar", na.value = "grey50", type = getOption("ggplot2.continuous.colour")) { - if (!is.null(type)) { scale <- scale_backward_compatibility( ..., guide = guide, na.value = na.value, scale = type, @@ -179,8 +178,7 @@ check_scale_type <- function(scale, name, aesthetic, scale_is_discrete = FALSE, "x" = "The provided scale is {scale_types[2]}." ), call = call) } - - scale + invisible() } # helper function for backwards compatibility through setting defaults @@ -241,8 +239,9 @@ scale_backward_compatibility <- function(..., scale, aesthetic, type) { if (!"..." %in% fn_fmls_names(scale)) { args <- args[intersect(names(args), fn_fmls_names(scale))] } - scale <- check_scale_type( - exec(scale, !!!args), + scale <- exec(scale, !!!args) + check_scale_type( + scale, paste("scale", aesthetic, type, sep = "_"), aesthetic, scale_is_discrete = type == "discrete" diff --git a/R/scales-.R b/R/scales-.R index 769613a2d8..87c5f6f586 100644 --- a/R/scales-.R +++ b/R/scales-.R @@ -154,6 +154,7 @@ ScalesList <- ggproto("ScalesList", NULL, return() } + for (aes in new_aesthetics) { self$add(find_scale(aes, data[[aes]], env)) } diff --git a/R/theme-elements.R b/R/theme-elements.R index 947e4e0af3..5a6b1a43cf 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -698,7 +698,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { # @param el an element # @param elname the name of the element # @param element_tree the element tree to validate against -validate_element <- function(el, elname, element_tree, call = caller_env()) { +check_element <- function(el, elname, element_tree, call = caller_env()) { eldef <- element_tree[[elname]] if (is.null(eldef)) { diff --git a/R/theme.R b/R/theme.R index 2ebd892f62..cb7859dfe2 100644 --- a/R/theme.R +++ b/R/theme.R @@ -208,7 +208,7 @@ #' differently when added to a ggplot object. Also, when setting #' `complete = TRUE` all elements will be set to inherit from blank #' elements. -#' @param validate `TRUE` to run `validate_element()`, `FALSE` to bypass checks. +#' @param validate `TRUE` to run `check_element()`, `FALSE` to bypass checks. #' @export #' @seealso #' [+.gg()] and [%+replace%], @@ -561,12 +561,12 @@ is_theme_validate <- function(x) { isTRUE(validate %||% TRUE) } -validate_theme <- function(theme, tree = get_element_tree(), call = caller_env()) { +check_theme <- function(theme, tree = get_element_tree(), call = caller_env()) { if (!is_theme_validate(theme)) { return() } mapply( - validate_element, theme, names(theme), + check_element, theme, names(theme), MoreArgs = list(element_tree = tree, call = call) ) } @@ -627,7 +627,7 @@ plot_theme <- function(x, default = get_theme()) { theme[missing] <- ggplot_global$theme_default[missing] # Check that all elements have the correct class (element_text, unit, etc) - validate_theme(theme) + check_theme(theme) # Remove elements that are not registered theme[setdiff(names(theme), names(get_element_tree()))] <- NULL diff --git a/R/utilities-help.R b/R/utilities-help.R index 87f5419612..22bddc7dcd 100644 --- a/R/utilities-help.R +++ b/R/utilities-help.R @@ -2,8 +2,8 @@ # Geoms and there's some difference among their aesthetics). rd_aesthetics <- function(type, name, extra_note = NULL) { obj <- switch(type, - geom = check_subclass(name, "Geom", env = globalenv()), - stat = check_subclass(name, "Stat", env = globalenv()) + geom = validate_subclass(name, "Geom", env = globalenv()), + stat = validate_subclass(name, "Stat", env = globalenv()) ) aes <- rd_aesthetics_item(obj) diff --git a/R/utilities.R b/R/utilities.R index adb2475047..3b0e9ec806 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -277,17 +277,29 @@ is.discrete <- function(x) { is.factor(x) || is.character(x) || is.logical(x) } -# This function checks that all columns of a dataframe `x` are data and returns -# the names of any columns that are not. -# We define "data" as atomic types or lists, not functions or otherwise. -# The `inherits(x, "Vector")` check is for checking S4 classes from Bioconductor -# and whether they can be expected to follow behavior typical of vectors. See -# also #3835 -check_nondata_cols <- function(x) { - idx <- (vapply(x, function(x) { - is.null(x) || rlang::is_vector(x) || inherits(x, "Vector") - }, logical(1))) - names(x)[which(!idx)] +check_nondata_cols <- function(data, mapping, problem = NULL, hint = NULL) { + # We define "data" as atomic types or lists, not functions or otherwise. + # The `inherits(x, "Vector")` check is for checking S4 classes from Bioconductor + # and whether they can be expected to follow behaviour typical of vectors. See + # also #3835 + invalid <- which(!vapply( + data, FUN.VALUE = logical(1), + function(x) is.null(x) || rlang::is_vector(x) || inherits(x, "Vector") + )) + invalid <- names(data)[invalid] + + if (length(invalid) < 1) { + return(invisible()) + } + + mapping <- vapply(mapping[invalid], as_label, character(1)) + issues <- paste0("{.code ", invalid, " = ", mapping, "}") + names(issues) <- rep("*", length(issues)) + issues <- c(x = "The following aesthetics are invalid:", issues) + + # Using 'call = NULL' here because `by_layer()` does a good job of indicating + # the origin of the error + cli::cli_abort(c(problem, issues, i = hint), call = NULL) } compact <- function(x) { diff --git a/tests/testthat/_snaps/facet-.md b/tests/testthat/_snaps/facet-.md index 17d76b1f86..154499e38a 100644 --- a/tests/testthat/_snaps/facet-.md +++ b/tests/testthat/_snaps/facet-.md @@ -3,7 +3,7 @@ Code facet_wrap(aes(foo)) Condition - Error in `validate_facets()`: + Error in `check_vars()`: ! Please use `vars()` to supply facet variables. --- @@ -11,7 +11,7 @@ Code facet_grid(aes(foo)) Condition - Error in `validate_facets()`: + Error in `check_vars()`: ! Please use `vars()` to supply facet variables. # facet_grid() fails if passed both a formula and a vars() @@ -73,7 +73,7 @@ Error: ! object 'no_such_variable' not found -# validate_facets() provide meaningful errors +# check_vars() provide meaningful errors Please use `vars()` to supply facet variables. diff --git a/tests/testthat/_snaps/facet-labels.md b/tests/testthat/_snaps/facet-labels.md index 6cdd9c1ad0..525e0dd0b7 100644 --- a/tests/testthat/_snaps/facet-labels.md +++ b/tests/testthat/_snaps/facet-labels.md @@ -16,6 +16,6 @@ # old school labellers still work - The `labeller` API has been updated. Labellers taking `variable` and `value` arguments are now deprecated. - i See labellers documentation. + The `labeller` argument of `facet_()` is deprecated as of ggplot2 2.0.0. + i Modern labellers do not take `variable` and `value` arguments anymore. diff --git a/tests/testthat/_snaps/fortify.md b/tests/testthat/_snaps/fortify.md index 2034f092fb..605829d9d8 100644 --- a/tests/testthat/_snaps/fortify.md +++ b/tests/testthat/_snaps/fortify.md @@ -10,7 +10,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `dim(data)` must return an of length 2. --- @@ -20,7 +20,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `dim(data)` must return an of length 2. --- @@ -30,7 +30,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `colnames(data)` must return a of length `ncol(data)`. --- @@ -50,7 +50,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `dim(data)` must return an of length 2. --- @@ -60,7 +60,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `dim(data)` must return an of length 2. --- @@ -70,7 +70,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `dim(data)` can't have `NA`s or negative values. --- @@ -80,7 +80,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `dim(data)` can't have `NA`s or negative values. --- @@ -100,7 +100,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `colnames(data)` must return a of length `ncol(data)`. --- @@ -110,7 +110,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.prevalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_like()`: ! `colnames(data)` must return a of length `ncol(data)`. --- @@ -130,7 +130,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.postvalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_conversion()`: ! `as.data.frame(data)` must return a . --- @@ -140,7 +140,7 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.postvalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_conversion()`: ! `as.data.frame(data)` must preserve dimensions. --- @@ -150,6 +150,6 @@ Condition Error in `fortify()`: ! `data` must be a , or an object coercible by `fortify()`, or a valid -like object coercible by `as.data.frame()`. - Caused by error in `.postvalidate_data_frame_like_object()`: + Caused by error in `check_data_frame_conversion()`: ! `as.data.frame(data)` must preserve column names. diff --git a/tests/testthat/_snaps/geom-.md b/tests/testthat/_snaps/geom-.md index 0eae2d74ba..b0ca0c7e85 100644 --- a/tests/testthat/_snaps/geom-.md +++ b/tests/testthat/_snaps/geom-.md @@ -2,10 +2,10 @@ Problem while setting up geom aesthetics. i Error occurred in the 1st layer. - Caused by error in `use_defaults()`: - ! Aesthetic modifiers returned invalid values - x The following mappings are invalid - x `colour = after_scale(data)` + Caused by error: + ! Aesthetic modifiers returned invalid values. + x The following aesthetics are invalid: + * `colour = after_scale(data)` i Did you map the modifier in the wrong layer? --- diff --git a/tests/testthat/_snaps/ggsave.md b/tests/testthat/_snaps/ggsave.md index 372d324b95..03440c5eba 100644 --- a/tests/testthat/_snaps/ggsave.md +++ b/tests/testthat/_snaps/ggsave.md @@ -58,7 +58,7 @@ --- Code - plot_dev("xyz") + validate_device("xyz") Condition Error: ! Unknown graphics device "xyz" @@ -66,7 +66,7 @@ --- Code - plot_dev(NULL, "test.xyz") + validate_device(NULL, "test.xyz") Condition Error: ! Unknown graphics device "xyz" diff --git a/tests/testthat/_snaps/layer.md b/tests/testthat/_snaps/layer.md index 70573a3d7c..79b561b17d 100644 --- a/tests/testthat/_snaps/layer.md +++ b/tests/testthat/_snaps/layer.md @@ -1,14 +1,14 @@ # layer() checks its input - Can't create layer without a geom. + The `geom` argument cannot be empty. --- - Can't create layer without a stat. + The `stat` argument cannot be empty. --- - Can't create layer without a position. + The `position` argument cannot be empty. --- @@ -43,20 +43,20 @@ Problem while computing aesthetics. i Error occurred in the 1st layer. - Caused by error in `compute_aesthetics()`: + Caused by error: ! Aesthetics are not valid data columns. x The following aesthetics are invalid: - x `fill = data` + * `fill = data` i Did you mistype the name of a data column or forget to add `after_stat()`? --- Problem while mapping stat to aesthetics. i Error occurred in the 1st layer. - Caused by error in `map_statistic()`: + Caused by error: ! Aesthetics must be valid computed stats. x The following aesthetics are invalid: - x `fill = after_stat(data)` + * `fill = after_stat(data)` i Did you map your stat in the wrong layer? # missing aesthetics trigger informative error @@ -85,22 +85,22 @@ Problem while computing aesthetics. i Error occurred in the 1st layer. - Caused by error in `compute_aesthetics()`: + Caused by error: ! Aesthetics are not valid data columns. x The following aesthetics are invalid: - x `colour = NULL` - x `fill = NULL` + * `colour = density` + * `fill = density` i Did you mistype the name of a data column or forget to add `after_stat()`? # computed stats are in appropriate layer Problem while mapping stat to aesthetics. i Error occurred in the 1st layer. - Caused by error in `map_statistic()`: + Caused by error: ! Aesthetics must be valid computed stats. x The following aesthetics are invalid: - x `colour = NULL` - x `fill = NULL` + * `colour = after_stat(density)` + * `fill = after_stat(density)` i Did you map your stat in the wrong layer? # layer reports the error with correct index etc diff --git a/tests/testthat/test-facet-.R b/tests/testthat/test-facet-.R index 11e86247ca..a24a5e4ca5 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -469,9 +469,9 @@ test_that("eval_facet() is tolerant for missing columns (#2963)", { ) }) -test_that("validate_facets() provide meaningful errors", { - expect_snapshot_error(validate_facets(aes(var))) - expect_snapshot_error(validate_facets(ggplot())) +test_that("check_vars() provide meaningful errors", { + expect_snapshot_error(check_vars(aes(var))) + expect_snapshot_error(check_vars(ggplot())) }) test_that("check_layout() throws meaningful errors", { diff --git a/tests/testthat/test-ggsave.R b/tests/testthat/test-ggsave.R index 4180eadc98..158dae2594 100644 --- a/tests/testthat/test-ggsave.R +++ b/tests/testthat/test-ggsave.R @@ -125,19 +125,19 @@ test_that("scale multiplies height & width", { # plot_dev --------------------------------------------------------------------- test_that("unknown device triggers error", { - expect_snapshot_error(plot_dev(1)) - expect_snapshot(plot_dev("xyz"), error = TRUE) - expect_snapshot(plot_dev(NULL, "test.xyz"), error = TRUE) + expect_snapshot_error(validate_device(1)) + expect_snapshot(validate_device("xyz"), error = TRUE) + expect_snapshot(validate_device(NULL, "test.xyz"), error = TRUE) }) test_that("text converted to function", { - expect_identical(body(plot_dev("png"))[[1]], quote(png_dev)) - expect_identical(body(plot_dev("pdf"))[[1]], quote(grDevices::pdf)) + expect_identical(body(validate_device("png"))[[1]], quote(png_dev)) + expect_identical(body(validate_device("pdf"))[[1]], quote(grDevices::pdf)) }) test_that("if device is NULL, guess from extension", { - expect_identical(body(plot_dev(NULL, "test.png"))[[1]], quote(png_dev)) + expect_identical(body(validate_device(NULL, "test.png"))[[1]], quote(png_dev)) }) # parse_dpi --------------------------------------------------------------- diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 225cedd947..59970c7db5 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -8,8 +8,8 @@ test_that("layer() checks its input", { expect_snapshot_error(layer("point", "identity", mapping = 1:4, position = "identity")) expect_snapshot_error(layer("point", "identity", mapping = ggplot(), position = "identity")) - expect_snapshot_error(check_subclass("test", "geom")) - expect_snapshot_error(check_subclass(environment(), "geom")) + expect_snapshot_error(validate_subclass("test", "geom")) + expect_snapshot_error(validate_subclass(environment(), "geom")) }) test_that("aesthetics go in aes_params", { diff --git a/tests/testthat/test-scales-breaks-labels.R b/tests/testthat/test-scales-breaks-labels.R index 42e3d67bb3..e0b8474a40 100644 --- a/tests/testthat/test-scales-breaks-labels.R +++ b/tests/testthat/test-scales-breaks-labels.R @@ -12,8 +12,8 @@ test_that("labels match breaks", { }) test_that("labels don't have to match null breaks", { - expect_true(check_breaks_labels(breaks = 1:3, labels = NULL)) - expect_true(check_breaks_labels(breaks = NULL, labels = 1:2)) + expect_silent(check_breaks_labels(breaks = 1:3, labels = NULL)) + expect_silent(check_breaks_labels(breaks = NULL, labels = 1:2)) }) test_that("labels don't have extra spaces", { diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index b6248acaa3..7477e41317 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -250,7 +250,7 @@ test_that("complete and non-complete themes interact correctly with ggplot objec expect_equal(p$plot$theme$text$face, "italic") }) -test_that("theme(validate=FALSE) means do not validate_element", { +test_that("theme(validate=FALSE) means do not check_element", { p <- ggplot(data.frame(x = 1:3), aes(x, x)) + geom_point() bw <- p + theme_bw() red.text <- theme(text = element_text(colour = "red")) @@ -542,9 +542,9 @@ test_that("subtheme functions rename arguments as intended", { test_that("Theme validation behaves as expected", { tree <- get_element_tree() - expect_silent(validate_element(1, "aspect.ratio", tree)) - expect_silent(validate_element(1L, "aspect.ratio", tree)) - expect_snapshot_error(validate_element("A", "aspect.ratio", tree)) + expect_silent(check_element(1, "aspect.ratio", tree)) + expect_silent(check_element(1L, "aspect.ratio", tree)) + expect_snapshot_error(check_element("A", "aspect.ratio", tree)) }) test_that("Element subclasses are inherited", { From 123b26e581032dd91442aaa17a4a4809cce713a6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 13:19:32 +0100 Subject: [PATCH 07/31] Violin quantiles are based on observations (#5912) * plumbing for `draw_quantiles` in `stat_ydensity()` * stat computes quantiles * geom draws quantiles, not compute them * migrate docs * add test * accept snapshot changes * add news bullet * stat param is named `quantiles` * quantile drawing is controlled by graphical params * adapt tests * document * add news bullets * dedup news bullets * Deprecation of the `draw_quantiles` parameter coming from `geom_violin()` parity --- NEWS.md | 7 ++ R/geom-violin.R | 93 ++++++++++++------- R/stat-ydensity.R | 51 +++++++++- man/geom_violin.Rd | 21 ++++- tests/testthat/_snaps/geom-violin.md | 14 ++- tests/testthat/_snaps/geom-violin/basic.svg | 6 +- ...is-many-groups-center-should-be-at-2-0.svg | 2 +- ...s-single-group-center-should-be-at-1-0.svg | 2 +- .../_snaps/geom-violin/coord-flip.svg | 6 +- .../_snaps/geom-violin/coord-polar.svg | 6 +- .../geom-violin/dodging-and-coord-flip.svg | 6 +- tests/testthat/_snaps/geom-violin/dodging.svg | 6 +- ...grouping-on-x-and-fill-dodge-width-0-5.svg | 12 +-- .../geom-violin/grouping-on-x-and-fill.svg | 12 +-- .../_snaps/geom-violin/narrower-width-5.svg | 6 +- .../testthat/_snaps/geom-violin/quantiles.svg | 69 -------------- ...scale-area-to-sample-size-c-is-smaller.svg | 6 +- .../_snaps/geom-violin/styled-quantiles.svg | 69 ++++++++++++++ .../with-smaller-bandwidth-and-points.svg | 6 +- .../geom-violin/with-tails-and-points.svg | 6 +- tests/testthat/test-geom-violin.R | 18 ++-- tests/testthat/test-stat-ydensity.R | 12 +++ 22 files changed, 272 insertions(+), 164 deletions(-) delete mode 100644 tests/testthat/_snaps/geom-violin/quantiles.svg create mode 100644 tests/testthat/_snaps/geom-violin/styled-quantiles.svg diff --git a/NEWS.md b/NEWS.md index 140d7dd25b..3d9a9f7f99 100644 --- a/NEWS.md +++ b/NEWS.md @@ -51,6 +51,13 @@ (@teunbrand, #4320) * `geom_boxplot()` gains additional arguments to style the colour, linetype and linewidths of the box, whiskers, median line and staples (@teunbrand, #5126) +* `geom_violin()` gains additional arguments to style the colour, linetype and + linewidths of the quantiles, which replace the now-deprecated `draw_quantiles` + argument (#5912). +* (breaking) `geom_violin(quantiles)` now has actual quantiles based on + the data, rather than inferred quantiles based on the computed density. The + `quantiles` parameter that replaces `draw_quantiles` now belongs to + `stat_ydensity()` instead of `geom_violin()` (@teunbrand, #4120). * (internal) Using `after_scale()` in the `Geom*$default_aes()` field is now evaluated in the context of data (@teunbrand, #6135) * Fixed bug where binned scales wouldn't simultaneously accept transformations diff --git a/R/geom-violin.R b/R/geom-violin.R index e53c29396f..8c3d23ad71 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -10,8 +10,6 @@ #' @eval rd_aesthetics("geom", "violin") #' @inheritParams layer #' @inheritParams geom_bar -#' @param draw_quantiles If `not(NULL)` (default), draw horizontal lines -#' at the given quantiles of the density estimate. #' @param trim If `TRUE` (default), trim the tails of the violins #' to the range of the data. If `FALSE`, don't trim the tails. #' @param geom,stat Use to override the default connection between @@ -23,6 +21,12 @@ #' finite, boundary effect of default density estimation will be corrected by #' reflecting tails outside `bounds` around their closest edge. Data points #' outside of bounds are removed with a warning. +#' @param quantile.colour,quantile.color,quantile.linewidth,quantile.linetype +#' Default aesthetics for the quantile lines. Set to `NULL` to inherit from +#' the data's aesthetics. By default, quantile lines are hidden and can be +#' turned on by changing `quantile.linetype`. +#' @param draw_quantiles `r lifecycle::badge("deprecated")` Previous +#' specification of drawing quantiles. #' @export #' @references Hintze, J. L., Nelson, R. D. (1998) Violin Plots: A Box #' Plot-Density Trace Synergism. The American Statistician 52, 181-184. @@ -91,14 +95,46 @@ geom_violin <- function(mapping = NULL, data = NULL, stat = "ydensity", position = "dodge", ..., - draw_quantiles = NULL, trim = TRUE, bounds = c(-Inf, Inf), + quantile.colour = NULL, + quantile.color = NULL, + quantile.linetype = 0L, + quantile.linewidth = NULL, + draw_quantiles = deprecated(), scale = "area", na.rm = FALSE, orientation = NA, show.legend = NA, inherit.aes = TRUE) { + + extra <- list() + if (lifecycle::is_present(draw_quantiles)) { + deprecate_soft0( + "3.6.0", + what = "geom_violin(draw_quantiles)", + with = "geom_violin(quantiles.linetype)" + ) + check_numeric(draw_quantiles) + + # Pass on to stat when stat accepts 'quantiles' + stat <- check_subclass(stat, "Stat", current_call(), caller_env()) + if ("quantiles" %in% stat$parameters()) { + extra$quantiles <- draw_quantiles + } + + # Turn on quantile lines + if (!is.null(quantile.linetype)) { + quantile.linetype <- max(quantile.linetype, 1) + } + } + + quantile_gp <- list( + colour = quantile.color %||% quantile.colour, + linetype = quantile.linetype, + linewidth = quantile.linewidth + ) + layer( data = data, mapping = mapping, @@ -110,10 +146,11 @@ geom_violin <- function(mapping = NULL, data = NULL, params = list2( trim = trim, scale = scale, - draw_quantiles = draw_quantiles, na.rm = na.rm, orientation = orientation, bounds = bounds, + quantile_gp = quantile_gp, + !!!extra, ... ) ) @@ -146,7 +183,7 @@ GeomViolin <- ggproto("GeomViolin", Geom, flip_data(data, params$flipped_aes) }, - draw_group = function(self, data, ..., draw_quantiles = NULL, flipped_aes = FALSE) { + draw_group = function(self, data, ..., quantile_gp = list(linetype = 0), flipped_aes = FALSE) { data <- flip_data(data, flipped_aes) # Find the points for the line to go all the way around data <- transform(data, @@ -165,36 +202,28 @@ GeomViolin <- ggproto("GeomViolin", Geom, newdata <- vec_rbind0(newdata, newdata[1,]) newdata <- flip_data(newdata, flipped_aes) + violin_grob <- GeomPolygon$draw_panel(newdata, ...) + + if (!"quantile" %in% names(newdata) || + all(quantile_gp$linetype == 0) || + all(quantile_gp$linetype == "blank")) { + return(ggname("geom_violin", violin_grob)) + } + # Draw quantiles if requested, so long as there is non-zero y range - if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) { - if (!(all(draw_quantiles >= 0) && all(draw_quantiles <= 1))) { - cli::cli_abort("{.arg draw_quantiles} must be between 0 and 1.") - } - - # Compute the quantile segments and combine with existing aesthetics - quantiles <- create_quantile_segment_frame(data, draw_quantiles) - aesthetics <- data[ - rep(1, nrow(quantiles)), - setdiff(names(data), c("x", "y", "group")), - drop = FALSE - ] - aesthetics$alpha <- rep(1, nrow(quantiles)) - both <- vec_cbind(quantiles, aesthetics) - both <- both[!is.na(both$group), , drop = FALSE] - both <- flip_data(both, flipped_aes) - quantile_grob <- if (nrow(both) == 0) { - zeroGrob() - } else { - GeomPath$draw_panel(both, ...) - } - - ggname("geom_violin", grobTree( - GeomPolygon$draw_panel(newdata, ...), - quantile_grob) - ) + quantiles <- newdata[!is.na(newdata$quantile),] + quantiles$group <- match(quantiles$quantile, unique(quantiles$quantile)) + quantiles$linetype <- quantile_gp$linetype %||% quantiles$linetype + quantiles$linewidth <- quantile_gp$linewidth %||% quantiles$linewidth + quantiles$colour <- quantile_gp$colour %||% quantiles$colour + + quantile_grob <- if (nrow(quantiles) == 0) { + zeroGrob() } else { - ggname("geom_violin", GeomPolygon$draw_panel(newdata, ...)) + GeomPath$draw_panel(quantiles, ...) } + + ggname("geom_violin", grobTree(violin_grob, quantile_grob)) }, draw_key = draw_key_polygon, diff --git a/R/stat-ydensity.R b/R/stat-ydensity.R index 4eadd8ca58..6b0e4f0ff8 100644 --- a/R/stat-ydensity.R +++ b/R/stat-ydensity.R @@ -7,6 +7,8 @@ #' @param drop Whether to discard groups with less than 2 observations #' (`TRUE`, default) or keep such groups for position adjustment purposes #' (`FALSE`). +#' @param quantiles If not `NULL` (default), compute the `quantile` variable +#' and draw horizontal lines at the given quantiles in `geom_violin()`. #' #' @eval rd_computed_vars( #' density = "Density estimate.", @@ -16,7 +18,8 @@ #' violinwidth = "Density scaled for the violin plot, according to area, #' counts or to a constant maximum width.", #' n = "Number of points.", -#' width = "Width of violin bounding box." +#' width = "Width of violin bounding box.", +#' quantile = "Whether the row is part of the `quantiles` computation." #' ) #' #' @seealso [geom_violin()] for examples, and [stat_density()] @@ -26,6 +29,7 @@ stat_ydensity <- function(mapping = NULL, data = NULL, geom = "violin", position = "dodge", ..., + quantiles = c(0.25, 0.50, 0.75), bw = "nrd0", adjust = 1, kernel = "gaussian", @@ -56,6 +60,7 @@ stat_ydensity <- function(mapping = NULL, data = NULL, drop = drop, na.rm = na.rm, bounds = bounds, + quantiles = quantiles, ... ) ) @@ -73,14 +78,26 @@ StatYdensity <- ggproto("StatYdensity", Stat, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = TRUE, group_has_equal = TRUE) + if (!is.null(params$draw_quantiles)) { + deprecate_soft0( + "3.6.0", + what = "stat_ydensity(draw_quantiles)", + with = "stat_ydensity(quantiles)" + ) + params$quantiles <- params$draw_quantiles + check_numeric(params$quantiles, arg = "quantiles") + } + params }, - extra_params = c("na.rm", "orientation"), + # `draw_quantiles` is here for deprecation repair reasons + extra_params = c("na.rm", "orientation", "draw_quantiles"), compute_group = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1, kernel = "gaussian", trim = TRUE, na.rm = FALSE, - drop = TRUE, flipped_aes = FALSE, bounds = c(-Inf, Inf)) { + drop = TRUE, flipped_aes = FALSE, bounds = c(-Inf, Inf), + quantiles = c(0.25, 0.50, 0.75)) { if (nrow(data) < 2) { if (isTRUE(drop)) { cli::cli_warn(c( @@ -115,17 +132,43 @@ StatYdensity <- ggproto("StatYdensity", Stat, } dens$width <- width + if (!is.null(quantiles)) { + if (!(all(quantiles >= 0) && all(quantiles <= 1))) { + cli::cli_abort("{.arg quantiles} must be between 0 and 1.") + } + if (!is.null(data[["weight"]]) || !all(data[["weight"]] == 1)) { + cli::cli_warn( + "{.arg quantiles} for weighted data is not implemented." + ) + } + quants <- quantile(data$y, probs = quantiles) + quants <- data_frame0( + y = unname(quants), + quantile = quantiles + ) + + # Interpolate other metrics + for (var in setdiff(names(dens), names(quants))) { + quants[[var]] <- + approx(dens$y, dens[[var]], xout = quants$y, ties = "ordered")$y + } + + dens <- vec_slice(dens, !dens$y %in% quants$y) + dens <- vec_c(dens, quants) + } + dens }, compute_panel = function(self, data, scales, width = NULL, bw = "nrd0", adjust = 1, kernel = "gaussian", trim = TRUE, na.rm = FALSE, scale = "area", flipped_aes = FALSE, drop = TRUE, - bounds = c(-Inf, Inf)) { + bounds = c(-Inf, Inf), quantiles = c(0.25, 0.50, 0.75)) { data <- flip_data(data, flipped_aes) data <- ggproto_parent(Stat, self)$compute_panel( data, scales, width = width, bw = bw, adjust = adjust, kernel = kernel, trim = trim, na.rm = na.rm, drop = drop, bounds = bounds, + quantiles = quantiles ) if (!drop && any(data$n < 2)) { cli::cli_warn( diff --git a/man/geom_violin.Rd b/man/geom_violin.Rd index 974d1c5bdc..244a7ac7ea 100644 --- a/man/geom_violin.Rd +++ b/man/geom_violin.Rd @@ -11,9 +11,13 @@ geom_violin( stat = "ydensity", position = "dodge", ..., - draw_quantiles = NULL, trim = TRUE, bounds = c(-Inf, Inf), + quantile.colour = NULL, + quantile.color = NULL, + quantile.linetype = 0L, + quantile.linewidth = NULL, + draw_quantiles = deprecated(), scale = "area", na.rm = FALSE, orientation = NA, @@ -27,6 +31,7 @@ stat_ydensity( geom = "violin", position = "dodge", ..., + quantiles = c(0.25, 0.5, 0.75), bw = "nrd0", adjust = 1, kernel = "gaussian", @@ -102,9 +107,6 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{draw_quantiles}{If \code{not(NULL)} (default), draw horizontal lines -at the given quantiles of the density estimate.} - \item{trim}{If \code{TRUE} (default), trim the tails of the violins to the range of the data. If \code{FALSE}, don't trim the tails.} @@ -114,6 +116,13 @@ finite, boundary effect of default density estimation will be corrected by reflecting tails outside \code{bounds} around their closest edge. Data points outside of bounds are removed with a warning.} +\item{quantile.colour, quantile.color, quantile.linewidth, quantile.linetype}{Default aesthetics for the quantile lines. Set to \code{NULL} to inherit from +the data's aesthetics. By default, quantile lines are hidden and can be +turned on by changing \code{quantile.linetype}.} + +\item{draw_quantiles}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Previous +specification of drawing quantiles.} + \item{scale}{if "area" (default), all violins have the same area (before trimming the tails). If "count", areas are scaled proportionally to the number of observations. If "width", all violins have the same maximum width.} @@ -144,6 +153,9 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} +\item{quantiles}{If not \code{NULL} (default), compute the \code{quantile} variable +and draw horizontal lines at the given quantiles in \code{geom_violin()}.} + \item{bw}{The smoothing bandwidth to be used. If numeric, the standard deviation of the smoothing kernel. If character, a rule to choose the bandwidth, as listed in @@ -198,6 +210,7 @@ These are calculated by the 'stat' part of layers and can be accessed with \link \item \code{after_stat(violinwidth)}\cr Density scaled for the violin plot, according to area, counts or to a constant maximum width. \item \code{after_stat(n)}\cr Number of points. \item \code{after_stat(width)}\cr Width of violin bounding box. +\item \code{after_stat(quantile)}\cr Whether the row is part of the \code{quantiles} computation. } } diff --git a/tests/testthat/_snaps/geom-violin.md b/tests/testthat/_snaps/geom-violin.md index 80da5aad02..68cc4c1c5a 100644 --- a/tests/testthat/_snaps/geom-violin.md +++ b/tests/testthat/_snaps/geom-violin.md @@ -1,14 +1,12 @@ # quantiles fails outside 0-1 bound - Problem while converting geom to grob. - i Error occurred in the 1st layer. - Caused by error in `draw_group()`: - ! `draw_quantiles` must be between 0 and 1. + Computation failed in `stat_ydensity()`. + Caused by error in `compute_group()`: + ! `quantiles` must be between 0 and 1. --- - Problem while converting geom to grob. - i Error occurred in the 1st layer. - Caused by error in `draw_group()`: - ! `draw_quantiles` must be between 0 and 1. + Computation failed in `stat_ydensity()`. + Caused by error in `compute_group()`: + ! `quantiles` must be between 0 and 1. diff --git a/tests/testthat/_snaps/geom-violin/basic.svg b/tests/testthat/_snaps/geom-violin/basic.svg index 206a6b4626..16e7518c21 100644 --- a/tests/testthat/_snaps/geom-violin/basic.svg +++ b/tests/testthat/_snaps/geom-violin/basic.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg b/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg index f737690144..611f73f969 100644 --- a/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg +++ b/tests/testthat/_snaps/geom-violin/continuous-x-axis-many-groups-center-should-be-at-2-0.svg @@ -27,7 +27,7 @@ - + diff --git a/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg b/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg index f11a934abb..74fc5ed64e 100644 --- a/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg +++ b/tests/testthat/_snaps/geom-violin/continuous-x-axis-single-group-center-should-be-at-1-0.svg @@ -27,7 +27,7 @@ - + diff --git a/tests/testthat/_snaps/geom-violin/coord-flip.svg b/tests/testthat/_snaps/geom-violin/coord-flip.svg index 434afe96c8..59f095248a 100644 --- a/tests/testthat/_snaps/geom-violin/coord-flip.svg +++ b/tests/testthat/_snaps/geom-violin/coord-flip.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/coord-polar.svg b/tests/testthat/_snaps/geom-violin/coord-polar.svg index e70e3b11f3..02ae1107df 100644 --- a/tests/testthat/_snaps/geom-violin/coord-polar.svg +++ b/tests/testthat/_snaps/geom-violin/coord-polar.svg @@ -36,9 +36,9 @@ - - - + + + A B C diff --git a/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg b/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg index 86a328e5b5..6af10a6faa 100644 --- a/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg +++ b/tests/testthat/_snaps/geom-violin/dodging-and-coord-flip.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/dodging.svg b/tests/testthat/_snaps/geom-violin/dodging.svg index c1ccf480ce..d1d537e3b2 100644 --- a/tests/testthat/_snaps/geom-violin/dodging.svg +++ b/tests/testthat/_snaps/geom-violin/dodging.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg index 17142781de..fcf5700ada 100644 --- a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg +++ b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill-dodge-width-0-5.svg @@ -27,12 +27,12 @@ - - - - - - + + + + + + diff --git a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg index 56049d8ef6..477f9a02c5 100644 --- a/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg +++ b/tests/testthat/_snaps/geom-violin/grouping-on-x-and-fill.svg @@ -27,12 +27,12 @@ - - - - - - + + + + + + diff --git a/tests/testthat/_snaps/geom-violin/narrower-width-5.svg b/tests/testthat/_snaps/geom-violin/narrower-width-5.svg index d7a23e057b..d233183697 100644 --- a/tests/testthat/_snaps/geom-violin/narrower-width-5.svg +++ b/tests/testthat/_snaps/geom-violin/narrower-width-5.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/quantiles.svg b/tests/testthat/_snaps/geom-violin/quantiles.svg deleted file mode 100644 index 8bec1ac1a6..0000000000 --- a/tests/testthat/_snaps/geom-violin/quantiles.svg +++ /dev/null @@ -1,69 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --3 --2 --1 -0 -1 -2 -3 - - - - - - - - - - -A -B -C -x -y -quantiles - - diff --git a/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg b/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg index 1c0bf845b4..ca9f1bf889 100644 --- a/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg +++ b/tests/testthat/_snaps/geom-violin/scale-area-to-sample-size-c-is-smaller.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/styled-quantiles.svg b/tests/testthat/_snaps/geom-violin/styled-quantiles.svg new file mode 100644 index 0000000000..0b8d55329f --- /dev/null +++ b/tests/testthat/_snaps/geom-violin/styled-quantiles.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-3 +-2 +-1 +0 +1 +2 +3 + + + + + + + + + + +A +B +C +x +y +styled quantiles + + diff --git a/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg b/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg index 1494c6bd08..3dc573d465 100644 --- a/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg +++ b/tests/testthat/_snaps/geom-violin/with-smaller-bandwidth-and-points.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg b/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg index 1db22dd441..d109c20fbc 100644 --- a/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg +++ b/tests/testthat/_snaps/geom-violin/with-tails-and-points.svg @@ -27,9 +27,9 @@ - - - + + + diff --git a/tests/testthat/test-geom-violin.R b/tests/testthat/test-geom-violin.R index a93a534b40..ff3cae8de8 100644 --- a/tests/testthat/test-geom-violin.R +++ b/tests/testthat/test-geom-violin.R @@ -40,7 +40,8 @@ test_that("create_quantile_segment_frame functions for 3 quantiles", { test_that("quantiles do not fail on zero-range data", { zero.range.data <- data_frame(y = rep(1,3)) - p <- ggplot(zero.range.data) + geom_violin(aes(1, y), draw_quantiles = 0.5) + p <- ggplot(zero.range.data) + + geom_violin(aes(1, y), quantiles = 0.5, quantile.linetype = NULL) # This should return without error and have length one expect_length(get_layer_grob(p), 1) @@ -48,10 +49,10 @@ test_that("quantiles do not fail on zero-range data", { test_that("quantiles fails outside 0-1 bound", { p <- ggplot(mtcars) + - geom_violin(aes(as.factor(gear), mpg), draw_quantiles = c(-1, 0.5)) + geom_violin(aes(as.factor(gear), mpg), quantiles = c(-1, 0.5)) expect_snapshot_error(ggplotGrob(p)) p <- ggplot(mtcars) + - geom_violin(aes(as.factor(gear), mpg), draw_quantiles = c(0.5, 2)) + geom_violin(aes(as.factor(gear), mpg), quantiles = c(0.5, 2)) expect_snapshot_error(ggplotGrob(p)) }) @@ -70,7 +71,7 @@ test_that("quantiles do not issue warning", { data <- data_frame(x = 1, y = c(0, 0.25, 0.5, 0.75, 5)) p <- ggplot(data, aes(x = x, y = y)) + - geom_violin(draw_quantiles = 0.5) + geom_violin(quantiles = 0.5, quantile.linetype = NULL) expect_silent(plot(p)) }) @@ -116,8 +117,13 @@ test_that("geom_violin draws correctly", { expect_doppelganger("continuous x axis, single group (center should be at 1.0)", ggplot(dat, aes(x = as.numeric(1), y = y)) + geom_violin() ) - expect_doppelganger("quantiles", - ggplot(dat, aes(x=x, y=y)) + geom_violin(draw_quantiles=c(0.25,0.5,0.75)) + expect_doppelganger("styled quantiles", + ggplot(dat, aes(x=x, y=y)) + + geom_violin( + quantile.colour = "red", + quantile.linetype = "dotted", + quantile.linewidth = 2 + ) ) dat2 <- data_frame(x = rep(factor(LETTERS[1:3]), 30), y = rnorm(90), g = rep(factor(letters[5:6]), 45)) diff --git a/tests/testthat/test-stat-ydensity.R b/tests/testthat/test-stat-ydensity.R index d43fbcc0e3..fb5d39c036 100644 --- a/tests/testthat/test-stat-ydensity.R +++ b/tests/testthat/test-stat-ydensity.R @@ -39,3 +39,15 @@ test_that("mapped_discrete class is preserved", { expect_s3_class(ld$x, "mapped_discrete") expect_equal(unique(ld$x), c(1, 3)) }) + +test_that("quantiles are based on actual data (#4120)", { + + df <- data.frame(y = 0:10) + q <- seq(0.1, 0.9, by = 0.1) + + p <- ggplot(df, aes("X", y)) + + stat_ydensity(quantiles = q) + ld <- get_layer_data(p) + + expect_equal(ld$y[!is.na(ld$quantile)], 1:9) +}) From ccda105a4c8fc1051746550dcb21ad8691504083 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 13:21:52 +0100 Subject: [PATCH 08/31] add note (#6170) --- R/aes.R | 7 +++++++ man/aes.Rd | 7 +++++++ 2 files changed, 14 insertions(+) diff --git a/R/aes.R b/R/aes.R index 0829f64daf..045d388d8a 100644 --- a/R/aes.R +++ b/R/aes.R @@ -38,6 +38,13 @@ NULL #' #' [Delayed evaluation][aes_eval] for working with computed variables. #' +#' @note +#' Using `I()` to create objects of class 'AsIs' causes scales to ignore the +#' variable and assumes the wrapped variable is direct input for the grid +#' package. Please be aware that variables are sometimes combined, like in +#' some stats or position adjustments, that may yield unexpected results with +#' 'AsIs' variables. +#' #' @family aesthetics documentation #' @return A list with class `uneval`. Components of the list are either #' quosures or constants. diff --git a/man/aes.Rd b/man/aes.Rd index c49fbefada..ed77c5d39e 100644 --- a/man/aes.Rd +++ b/man/aes.Rd @@ -30,6 +30,13 @@ This function also standardises aesthetic names by converting \code{color} to \c (also in substrings, e.g., \code{point_color} to \code{point_colour}) and translating old style R names to ggplot names (e.g., \code{pch} to \code{shape} and \code{cex} to \code{size}). } +\note{ +Using \code{I()} to create objects of class 'AsIs' causes scales to ignore the +variable and assumes the wrapped variable is direct input for the grid +package. Please be aware that variables are sometimes combined, like in +some stats or position adjustments, that may yield unexpected results with +'AsIs' variables. +} \section{Quasiquotation}{ From 8efc700377c6bfb0583909846f7dc235b0122c34 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 13:22:25 +0100 Subject: [PATCH 09/31] Use snapshot expectations for breaks (#6171) --- tests/testthat/_snaps/scales.md | 119 ++++++++++++++++++++++++++++++++ tests/testthat/test-scales.R | 69 +++++------------- 2 files changed, 136 insertions(+), 52 deletions(-) diff --git a/tests/testthat/_snaps/scales.md b/tests/testthat/_snaps/scales.md index 549769419c..33b36a3cd8 100644 --- a/tests/testthat/_snaps/scales.md +++ b/tests/testthat/_snaps/scales.md @@ -72,11 +72,130 @@ # numeric scale transforms can produce breaks + Code + test_breaks("asn", limits = c(0, 1)) + Output + [1] 0.00 0.25 0.50 0.75 1.00 + +--- + + Code + test_breaks("sqrt", limits = c(0, 10)) + Output + [1] 0.0 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks("atanh", limits = c(-0.9, 0.9)) + Output + [1] NA -0.5 0.0 0.5 NA + +--- + + Code + test_breaks(transform_boxcox(0), limits = c(1, 10)) + Output + [1] NA 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks(transform_modulus(0), c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks(transform_yj(0), c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("exp", c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("identity", limits = c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + Code test_breaks("log", limits = c(0.1, 1000)) Output [1] NA 1.00000 20.08554 403.42879 +--- + + Code + test_breaks("log10", limits = c(0.1, 1000)) + Output + [1] 1e-01 1e+00 1e+01 1e+02 1e+03 + +--- + + Code + test_breaks("log2", limits = c(0.5, 32)) + Output + [1] 0.5 2.0 8.0 32.0 + +--- + + Code + test_breaks("log1p", limits = c(0, 10)) + Output + [1] 0.0 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks("pseudo_log", limits = c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("logit", limits = c(0.001, 0.999)) + Output + [1] NA 0.25 0.50 0.75 NA + +--- + + Code + test_breaks("probit", limits = c(0.001, 0.999)) + Output + [1] NA 0.25 0.50 0.75 NA + +--- + + Code + test_breaks("reciprocal", limits = c(1, 10)) + Output + [1] NA 2.5 5.0 7.5 10.0 + +--- + + Code + test_breaks("reverse", limits = c(-10, 10)) + Output + [1] -10 -5 0 5 10 + +--- + + Code + test_breaks("sqrt", limits = c(0, 10)) + Output + [1] 0.0 2.5 5.0 7.5 10.0 + # training incorrectly appropriately communicates the offenders Continuous values supplied to discrete scale. diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 514cb392a3..6fb4e4e667 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -469,59 +469,24 @@ test_that("numeric scale transforms can produce breaks", { scale$get_transformation()$inverse(view$get_breaks()) } - expect_equal(test_breaks("asn", limits = c(0, 1)), - seq(0, 1, by = 0.25)) - - expect_equal(test_breaks("sqrt", limits = c(0, 10)), - seq(0, 10, by = 2.5)) - - expect_equal(test_breaks("atanh", limits = c(-0.9, 0.9)), - c(NA, -0.5, 0, 0.5, NA)) - - expect_equal(test_breaks(transform_boxcox(0), limits = c(1, 10)), - c(NA, 2.5, 5.0, 7.5, 10)) - - expect_equal(test_breaks(transform_modulus(0), c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks(transform_yj(0), c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("exp", c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("identity", limits = c(-10, 10)), - seq(-10, 10, by = 5)) - - # irrational numbers, so snapshot values + expect_snapshot(test_breaks("asn", limits = c(0, 1))) + expect_snapshot(test_breaks("sqrt", limits = c(0, 10))) + expect_snapshot(test_breaks("atanh", limits = c(-0.9, 0.9))) + expect_snapshot(test_breaks(transform_boxcox(0), limits = c(1, 10))) + expect_snapshot(test_breaks(transform_modulus(0), c(-10, 10))) + expect_snapshot(test_breaks(transform_yj(0), c(-10, 10))) + expect_snapshot(test_breaks("exp", c(-10, 10))) + expect_snapshot(test_breaks("identity", limits = c(-10, 10))) expect_snapshot(test_breaks("log", limits = c(0.1, 1000))) - - expect_equal(test_breaks("log10", limits = c(0.1, 1000)), - 10 ^ seq(-1, 3)) - - expect_equal(test_breaks("log2", limits = c(0.5, 32)), - c(0.5, 2, 8, 32)) - - expect_equal(test_breaks("log1p", limits = c(0, 10)), - seq(0, 10, by = 2.5)) - - expect_equal(test_breaks("pseudo_log", limits = c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("logit", limits = c(0.001, 0.999)), - c(NA, 0.25, 0.5, 0.75, NA)) - - expect_equal(test_breaks("probit", limits = c(0.001, 0.999)), - c(NA, 0.25, 0.5, 0.75, NA)) - - expect_equal(test_breaks("reciprocal", limits = c(1, 10)), - c(NA, 2.5, 5, 7.5, 10)) - - expect_equal(test_breaks("reverse", limits = c(-10, 10)), - seq(-10, 10, by = 5)) - - expect_equal(test_breaks("sqrt", limits = c(0, 10)), - seq(0, 10, by = 2.5)) + expect_snapshot(test_breaks("log10", limits = c(0.1, 1000))) + expect_snapshot(test_breaks("log2", limits = c(0.5, 32))) + expect_snapshot(test_breaks("log1p", limits = c(0, 10))) + expect_snapshot(test_breaks("pseudo_log", limits = c(-10, 10))) + expect_snapshot(test_breaks("logit", limits = c(0.001, 0.999))) + expect_snapshot(test_breaks("probit", limits = c(0.001, 0.999))) + expect_snapshot(test_breaks("reciprocal", limits = c(1, 10))) + expect_snapshot(test_breaks("reverse", limits = c(-10, 10))) + expect_snapshot(test_breaks("sqrt", limits = c(0, 10))) }) test_that("scale functions accurately report their calls", { From a62895aef8909ddb4c86a65554ecff4cd89d5983 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 14:02:10 +0100 Subject: [PATCH 10/31] Fix regression in `guide_bins(reverse)` (#6185) * bump NA to back of key * add test * add news bullet * Fix interaction between #5912 and #6072 --- NEWS.md | 1 + R/geom-violin.R | 2 +- R/guide-bins.R | 5 +- .../_snaps/guides/reversed-guide-bins.svg | 97 +++++++++++++++++++ tests/testthat/test-guides.R | 16 +++ 5 files changed, 119 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/_snaps/guides/reversed-guide-bins.svg diff --git a/NEWS.md b/NEWS.md index 3d9a9f7f99..4d67350673 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # ggplot2 (development version) +* Fixed regression in `guide_bins(reverse = TRUE)` (@teunbrand, #6183). * New function family for setting parts of a theme. For example, you can now use `theme_sub_axis(line, text, ticks, ticks.length, line)` as a substitute for `theme(axis.line, axis.text, axis.ticks, axis.ticks.length, axis.line)`. This diff --git a/R/geom-violin.R b/R/geom-violin.R index 8c3d23ad71..1ad8c2172a 100644 --- a/R/geom-violin.R +++ b/R/geom-violin.R @@ -118,7 +118,7 @@ geom_violin <- function(mapping = NULL, data = NULL, check_numeric(draw_quantiles) # Pass on to stat when stat accepts 'quantiles' - stat <- check_subclass(stat, "Stat", current_call(), caller_env()) + stat <- validate_subclass(stat, "Stat", current_call(), caller_env()) if ("quantiles" %in% stat$parameters()) { extra$quantiles <- draw_quantiles } diff --git a/R/guide-bins.R b/R/guide-bins.R index c0344bbbe0..c03d5179d6 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -211,7 +211,10 @@ GuideBins <- ggproto( params$show.limits <- show.limits if (params$reverse) { - key <- key[rev(seq_len(nrow(key))), , drop = FALSE] + ord <- seq_len(nrow(key)) + key <- vec_slice(key, rev(ord)) + # Put NA back in the trailing position + key[params$aesthetic] <- vec_slice(key[params$aesthetic], c(ord[-1], ord[1])) key$.value <- 1 - key$.value } diff --git a/tests/testthat/_snaps/guides/reversed-guide-bins.svg b/tests/testthat/_snaps/guides/reversed-guide-bins.svg new file mode 100644 index 0000000000..16e8f7efca --- /dev/null +++ b/tests/testthat/_snaps/guides/reversed-guide-bins.svg @@ -0,0 +1,97 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +25 +50 +75 +100 + + + + + + + + + + +0 +25 +50 +75 +100 +x +x + +x + + + + + + + + + + + + + + +100 +75 +50 +25 +0 + +x + + + + + + + + + + + + +75 +50 +25 +reversed guide_bins + + diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 5718e4f2ad..1a3a31143a 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -411,6 +411,22 @@ test_that("guides title and text are positioned correctly", { expect_doppelganger("legends with all title justifications", p) }) +test_that("bin guide can be reversed", { + + p <- ggplot(data.frame(x = c(0, 100)), aes(x, x, colour = x, fill = x)) + + geom_point() + + guides( + colour = guide_bins(reverse = TRUE, show.limits = TRUE, order = 1), + fill = guide_bins( + reverse = TRUE, show.limits = FALSE, order = 2, + override.aes = list(shape = 21) + ) + ) + + expect_doppelganger("reversed guide_bins", p) + +}) + test_that("bin guide can be styled correctly", { df <- data_frame(x = c(1, 2, 3), y = c(6, 5, 7)) From a4264bc48fb990fc7408fae4a04dc4a442b6ca8a Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 14:02:47 +0100 Subject: [PATCH 11/31] Checks for `register_theme_element(element_tree)` (#6169) * error on circular parents * more elaborate checks on element tree * add test * add news bullet --- NEWS.md | 1 + R/theme-elements.R | 39 ++++++++++++++++++++++++++++++++++ tests/testthat/_snaps/theme.md | 13 ++++++++++++ tests/testthat/test-theme.R | 11 ++++++++++ 4 files changed, 64 insertions(+) diff --git a/NEWS.md b/NEWS.md index 4d67350673..0a392e2b24 100644 --- a/NEWS.md +++ b/NEWS.md @@ -262,6 +262,7 @@ * Added `panel.widths` and `panel.heights` to `theme()` (#5338, @teunbrand). * Standardised the calculation of `width`, which are now implemented as aesthetics (@teunbrand, #2800). +* Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162) # ggplot2 3.5.1 diff --git a/R/theme-elements.R b/R/theme-elements.R index 5a6b1a43cf..b83822ed3a 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -415,6 +415,8 @@ register_theme_elements <- function(..., element_tree = NULL, complete = TRUE) { t <- theme(..., complete = complete) ggplot_global$theme_default <- ggplot_global$theme_default %+replace% t + check_element_tree(element_tree) + # Merge element trees ggplot_global$element_tree <- defaults(element_tree, ggplot_global$element_tree) @@ -460,6 +462,43 @@ get_element_tree <- function() { ggplot_global$element_tree } +check_element_tree <- function(x, arg = caller_arg(x), call = caller_env()) { + check_object(x, is_bare_list, "a bare {.cls list}", arg = arg, call = call) + if (length(x) < 1) { + return(invisible(NULL)) + } + + if (!is_named(x)) { + cli::cli_abort("{.arg {arg}} must have names.", call = call) + } + + # All elements should be constructed with `el_def()` + fields <- names(el_def()) + bad_fields <- !vapply(x, function(el) all(fields %in% names(el)), logical(1)) + if (any(bad_fields)) { + bad_fields <- names(x)[bad_fields] + cli::cli_abort( + c("{.arg {arg}} must have elements constructed with {.fn el_def}.", + i = "Invalid structure: {.and {.val {bad_fields}}}"), + call = call + ) + } + + # Check element tree, prevent elements from being their own parent (#6162) + bad_parent <- unlist(Map( + function(name, el) any(name %in% el$inherit), + name = names(x), el = x + )) + if (any(bad_parent)) { + bad_parent <- names(x)[bad_parent] + cli::cli_abort( + "Invalid parent in {.arg {arg}}: {.and {.val {bad_parent}}}.", + call = call + ) + } + invisible(NULL) +} + #' @rdname register_theme_elements #' @details #' The function `el_def()` is used to define new or modified element types and diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 322cce92b7..005e1b2abd 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -56,6 +56,19 @@ The `blablabla` theme element must be a object. +--- + + `element_tree` must have names. + +--- + + `element_tree` must have elements constructed with `el_def()`. + i Invalid structure: "foo" + +--- + + Invalid parent in `element_tree`: "foo". + # elements can be merged Code diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 7477e41317..eba47a0c75 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -312,6 +312,17 @@ test_that("element tree can be modified", { p1 <- ggplot() + theme(blablabla = element_line()) expect_snapshot_error(ggplotGrob(p1)) + # Expect errors for invalid element trees + expect_snapshot_error( + register_theme_elements(element_tree = list(el_def("rect"), el_def("line"))) + ) + expect_snapshot_error( + register_theme_elements(element_tree = list(foo = "bar")) + ) + expect_snapshot_error( + register_theme_elements(element_tree = list(foo = el_def(inherit = "foo"))) + ) + # inheritance and final calculation of novel element works final_theme <- ggplot2:::plot_theme(p, theme_gray()) e1 <- calc_element("blablabla", final_theme) From c9fbb28d89402aeb54f936279881d374464246ba Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 14:28:32 +0100 Subject: [PATCH 12/31] Make `ScaleDiscrete$map()` compatible with vctrs-palettes (#6118) * sprinkle vctrs over `ScaleDiscrete$map()` * add test * prevent guide from clogging up * add news bullet --- NEWS.md | 1 + R/scale-.R | 29 +++++++++++++++++++---------- tests/testthat/test-scales.R | 29 +++++++++++++++++++++++++++++ 3 files changed, 49 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index 0a392e2b24..f4815f325d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # ggplot2 (development version) +* 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 `theme_sub_axis(line, text, ticks, ticks.length, line)` as a substitute for diff --git a/R/scale-.R b/R/scale-.R index b2f9ef346a..5ae52f65ab 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -963,10 +963,10 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, transform = identity, map = function(self, x, limits = self$get_limits()) { - limits <- limits[!is.na(limits)] - n <- length(limits) + limits <- vec_slice(limits, !is.na(limits)) + n <- vec_size(limits) if (n < 1) { - return(rep(self$na.value, length(x))) + return(vec_rep(self$na.value, vec_size(x))) } if (!is.null(self$n.breaks.cache) && self$n.breaks.cache == n) { pal <- self$palette.cache @@ -982,21 +982,30 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale, self$n.breaks.cache <- n } - na_value <- if (self$na.translate) self$na.value else NA - pal_names <- names(pal) + na_value <- NA + if (self$na.translate) { + na_value <- self$na.value + if (obj_is_list(pal) && !obj_is_list(na_value)) { + # We prevent a casting error that occurs when mapping grid patterns + na_value <- list(na_value) + } + } + + pal_names <- vec_names(pal) if (!is_null(pal_names)) { # if pal is named, limit the pal by the names first, # then limit the values by the pal - pal[is.na(match(pal_names, limits))] <- na_value - pal <- unname(pal) + vec_slice(pal, is.na(match(pal_names, limits))) <- na_value + pal <- vec_set_names(pal, NULL) limits <- pal_names } - pal <- c(pal, na_value) - pal_match <- pal[match(as.character(x), limits, nomatch = length(pal))] + pal <- vec_c(pal, na_value) + pal_match <- + vec_slice(pal, match(as.character(x), limits, nomatch = vec_size(pal))) if (!is.na(na_value)) { - pal_match[is.na(x)] <- na_value + vec_slice(pal_match, is.na(x)) <- na_value } pal_match }, diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 6fb4e4e667..0a750e4821 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -747,3 +747,32 @@ test_that("discrete scales work with NAs in arbitrary positions", { expect_equal(test, output) }) + +test_that("discrete scales can map to 2D structures", { + + p <- ggplot(mtcars, aes(disp, mpg, colour = factor(cyl))) + + geom_point() + + # Test it can map to a vctrs rcrd class + rcrd <- new_rcrd(list(a = LETTERS[1:3], b = 3:1)) + + ld <- layer_data(p + scale_colour_manual(values = rcrd, na.value = NA)) + expect_s3_class(ld$colour, "vctrs_rcrd") + expect_length(ld$colour, nrow(mtcars)) + + # Test it can map to data.frames + df <- data_frame0(a = LETTERS[1:3], b = 3:1) + my_pal <- function(n) vec_slice(df, seq_len(n)) + + ld <- layer_data(p + discrete_scale("colour", palette = my_pal)) + expect_s3_class(ld$colour, "data.frame") + expect_equal(dim(ld$colour), c(nrow(mtcars), ncol(df))) + + # Test it can map to matrices + mtx <- cbind(a = LETTERS[1:3], b = LETTERS[4:6]) + my_pal <- function(n) vec_slice(mtx, seq_len(n)) + + ld <- layer_data(p + discrete_scale("colour", palette = my_pal)) + expect_true(is.matrix(ld$colour)) + expect_equal(dim(ld$colour), c(nrow(mtcars), ncol(df))) +}) From 5964f7a30c24077d9263cceb543e532e1c106a2e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 14:33:23 +0100 Subject: [PATCH 13/31] Ensure boxplot key can be drawn without `params` (#6192) * fallback for `staplewidth` in boxplot key * add test * add comment * test for completeness too --- R/legend-draw.R | 2 +- .../_snaps/legend-draw/all-legend-keys.svg | 63 ++++++++++++++++++ tests/testthat/test-legend-draw.R | 66 +++++++++++++++++++ 3 files changed, 130 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/_snaps/legend-draw/all-legend-keys.svg create mode 100644 tests/testthat/test-legend-draw.R diff --git a/R/legend-draw.R b/R/legend-draw.R index d08c6c6c93..eb33cc24d7 100644 --- a/R/legend-draw.R +++ b/R/legend-draw.R @@ -128,7 +128,7 @@ draw_key_boxplot <- function(data, params, size) { lwd = params$box_gp$linewidth ) - staple_size <- 0.5 + c(0.375, -0.375) * params$staplewidth + staple_size <- 0.5 + c(0.375, -0.375) * (params$staplewidth %||% 0) staple <- gg_par( col = params$staple_gp$colour, lty = params$staple_gp$linetype, diff --git a/tests/testthat/_snaps/legend-draw/all-legend-keys.svg b/tests/testthat/_snaps/legend-draw/all-legend-keys.svg new file mode 100644 index 0000000000..c1ea77a335 --- /dev/null +++ b/tests/testthat/_snaps/legend-draw/all-legend-keys.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + +point + +abline + +rect + +polygon + +blank +boxplot + + + + + + +crossbar + + +path + +vpath + +dotplot + +linerange + +pointrange + + +smooth + +text +a +label + +a +vline + +timeseries + + + diff --git a/tests/testthat/test-legend-draw.R b/tests/testthat/test-legend-draw.R new file mode 100644 index 0000000000..5f4cc01032 --- /dev/null +++ b/tests/testthat/test-legend-draw.R @@ -0,0 +1,66 @@ + +test_that("all keys can be drawn without 'params'", { + + params <- list() + size <- convertUnit(calc_element("legend.key.size", theme_gray()), "cm", valueOnly = TRUE) + size <- size * 10 # cm to mm + + # Render every key + # If we're to develop new legend keys, we can keep appending this pattern + # for new keys and layout should adjust automatically. + # This is also an implicit test whether the key can be constructed without errors + keys <- list( + point = draw_key_point(GeomPoint$use_defaults(NULL), params, size), + abline = draw_key_abline(GeomAbline$use_defaults(NULL), params, size), + rect = draw_key_rect(GeomRect$use_defaults(NULL), params, size), + polygon = draw_key_polygon(GeomPolygon$use_defaults(NULL), params, size), + blank = draw_key_blank(GeomBlank$use_defaults(NULL), params, size), + boxplot = draw_key_boxplot(GeomBoxplot$use_defaults(NULL), params, size), + crossbar = draw_key_crossbar(GeomCrossbar$use_defaults(NULL), params, size), + path = draw_key_path(GeomPath$use_defaults(NULL), params, size), + vpath = draw_key_vpath(GeomPath$use_defaults(NULL), params, size), + dotplot = draw_key_dotplot(GeomDotplot$use_defaults(NULL), params, size), + linerange = draw_key_linerange(GeomLinerange$use_defaults(NULL), params, size), + pointrange = draw_key_pointrange(GeomPointrange$use_defaults(NULL), params, size), + smooth = draw_key_smooth(GeomSmooth$use_defaults(NULL), params, size), + text = draw_key_text(GeomText$use_defaults(NULL), params, size), + label = draw_key_label(GeomLabel$use_defaults(NULL), params, size), + vline = draw_key_vline(GeomVline$use_defaults(NULL), params, size), + timeseries = draw_key_timeseries(GeomPath$use_defaults(NULL), params, size) + ) + + # Test that we've covered all exported keys above + nse <- getNamespaceExports(asNamespace("ggplot2")) + nse <- grep("^draw_key", nse, value = TRUE) + nse <- gsub("^draw_key_", "", nse) + expect_in(nse, names(keys)) + + # Add title to every key + template <- gtable(width = unit(size, "mm"), heights = unit(c(1, size), c("lines", "mm"))) + keys <- Map( + function(key, name) { + text <- textGrob(name, gp = gpar(fontsize = 8)) + gtable_add_grob(template, list(text, key), t = 1:2, l = 1, clip = "off") + }, + key = keys, name = names(keys) + ) + + # Set layout + n <- length(keys) + nrow <- ceiling(n / 5) + ncol <- ceiling(n / nrow) + mtx <- matrix(list(zeroGrob()), nrow = nrow, ncol = ncol) + mtx[seq_along(keys)] <- keys + + # Render as gtable + gt <- gtable_matrix( + name = "layout", grobs = mtx, + widths = unit(rep(size, ncol(mtx)), "mm"), + heights = unit(rep(size, nrow(mtx)), "mm") + unit(1, "lines"), + clip = "off" + ) + gt <- gtable_add_col_space(gt, unit(1, "cm")) + gt <- gtable_add_row_space(gt, unit(1, "cm")) + + expect_doppelganger("all legend keys", gt) +}) From ed1b80dd37b5a05350421d95a8c0ff654efe4072 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 14:51:19 +0100 Subject: [PATCH 14/31] 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 --- NEWS.md | 3 ++ R/geom-label.R | 14 +------- R/geom-sf.R | 30 ++--------------- R/geom-text.R | 28 +--------------- R/layer.R | 7 ++-- R/position-.R | 32 +++++++++++++++++++ R/position-dodge.R | 24 +++++++++++++- R/position-nudge.R | 29 ++++++++--------- R/utilities-help.R | 3 +- R/utilities.R | 2 +- man/geom_boxplot.Rd | 1 + man/geom_dotplot.Rd | 1 + man/geom_text.Rd | 16 +++------- man/geom_violin.Rd | 1 + man/ggsf.Rd | 12 ++----- man/position_dodge.Rd | 9 ++++++ man/position_nudge.Rd | 12 ++++++- man/theme.Rd | 2 +- tests/testthat/_snaps/geom-label.md | 3 +- tests/testthat/_snaps/geom-sf.md | 6 ++-- tests/testthat/_snaps/geom-text.md | 3 +- tests/testthat/_snaps/prohibited-functions.md | 10 ++---- tests/testthat/test-geom-label.R | 2 +- tests/testthat/test-geom-sf.R | 4 +-- tests/testthat/test-geom-text.R | 2 +- tests/testthat/test-position_dodge.R | 15 +++++++++ 26 files changed, 137 insertions(+), 134 deletions(-) diff --git a/NEWS.md b/NEWS.md index f4815f325d..643e11bc65 100644 --- a/NEWS.md +++ b/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 diff --git a/R/geom-label.R b/R/geom-label.R index 6f21478da0..68f4549b6e 100644 --- a/R/geom-label.R +++ b/R/geom-label.R @@ -4,11 +4,9 @@ #' @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, @@ -16,16 +14,6 @@ geom_label <- function(mapping = NULL, data = NULL, 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, diff --git a/R/geom-sf.R b/R/geom-sf.R index 1d53d67499..4b61300108 100644 --- a/R/geom-sf.R +++ b/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, diff --git a/R/geom-text.R b/R/geom-text.R index 78e601f8f9..7e7a1b8f81 100644 --- a/R/geom-text.R +++ b/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, diff --git a/R/layer.R b/R/layer.R index a915763e3c..6be74b5d72 100644 --- a/R/layer.R +++ b/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) diff --git a/R/position-.R b/R/position-.R index 88d6f914a9..c78ca0fc4c 100644 --- a/R/position-.R +++ b/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 + } ) diff --git a/R/position-dodge.R b/R/position-dodge.R index 78d4a9a45f..bd816eecc9 100644 --- a/R/position-dodge.R +++ b/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), ...)) +} diff --git a/R/position-nudge.R b/R/position-nudge.R index 56e4e8fe4d..6bf8a81f01 100644 --- a/R/position-nudge.R +++ b/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) } ) diff --git a/R/utilities-help.R b/R/utilities-help.R index 22bddc7dcd..e97e7ad50e 100644 --- a/R/utilities-help.R +++ b/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) diff --git a/R/utilities.R b/R/utilities.R index 3b0e9ec806..3bcdaacedc 100644 --- a/R/utilities.R +++ b/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]], ...) } diff --git a/man/geom_boxplot.Rd b/man/geom_boxplot.Rd index d5026c013f..5760caa71a 100644 --- a/man/geom_boxplot.Rd +++ b/man/geom_boxplot.Rd @@ -240,6 +240,7 @@ See McGill et al. (1978) for more details. \item \code{\link[=aes_linetype_size_shape]{shape}} \item \code{\link[=aes_linetype_size_shape]{size}} \item \code{weight} +\item \code{width} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_dotplot.Rd b/man/geom_dotplot.Rd index ff7f30a4fc..5dbf0614db 100644 --- a/man/geom_dotplot.Rd +++ b/man/geom_dotplot.Rd @@ -171,6 +171,7 @@ to match the number of dots. \item \code{\link[=aes_linetype_size_shape]{linetype}} \item \code{stroke} \item \code{weight} +\item \code{width} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/geom_text.Rd b/man/geom_text.Rd index e88e45a0e1..e92e3fe3d8 100644 --- a/man/geom_text.Rd +++ b/man/geom_text.Rd @@ -9,11 +9,9 @@ geom_label( mapping = NULL, data = NULL, stat = "identity", - position = "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, @@ -27,11 +25,9 @@ geom_text( mapping = NULL, data = NULL, stat = "identity", - position = "identity", + position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, check_overlap = FALSE, size.unit = "mm", na.rm = FALSE, @@ -73,12 +69,12 @@ give the stat as \code{"count"}. \link[=layer_stats]{layer stat} documentation. }} -\item{position}{A position adjustment to use on the data for this layer. -Cannot be jointy specified with \code{nudge_x} or \code{nudge_y}. This +\item{position}{A position adjustment to use on the data for this layer. This can be used in various ways, including to prevent overplotting and improving the display. The \code{position} argument accepts the following: \itemize{ \item The result of calling a position function, such as \code{position_jitter()}. +This method allows for passing extra arguments to the position. \item A string naming the position adjustment. To give the position as a string, strip the function name of the \code{position_} prefix. For example, to use \code{position_jitter()}, give the position as \code{"jitter"}. @@ -117,10 +113,6 @@ lists which parameters it can accept. \item{parse}{If \code{TRUE}, the labels will be parsed into expressions and displayed as described in \code{?plotmath}.} -\item{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 \code{position}.} - \item{label.padding}{Amount of padding around label. Defaults to 0.25 lines.} \item{label.r}{Radius of rounded corners. Defaults to 0.15 lines.} diff --git a/man/geom_violin.Rd b/man/geom_violin.Rd index 244a7ac7ea..7b923b68ab 100644 --- a/man/geom_violin.Rd +++ b/man/geom_violin.Rd @@ -196,6 +196,7 @@ This geom treats each axis differently and, thus, can thus have two orientations \item \code{\link[=aes_linetype_size_shape]{linetype}} \item \code{\link[=aes_linetype_size_shape]{linewidth}} \item \code{weight} +\item \code{width} } Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. } diff --git a/man/ggsf.Rd b/man/ggsf.Rd index 1fee9f59bb..1ab15f232a 100644 --- a/man/ggsf.Rd +++ b/man/ggsf.Rd @@ -44,11 +44,9 @@ geom_sf_label( mapping = aes(), data = NULL, stat = "sf_coordinates", - position = "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, @@ -62,11 +60,9 @@ geom_sf_text( mapping = aes(), data = NULL, stat = "sf_coordinates", - position = "identity", + position = "nudge", ..., parse = FALSE, - nudge_x = 0, - nudge_y = 0, check_overlap = FALSE, na.rm = FALSE, show.legend = NA, @@ -277,10 +273,6 @@ lists which parameters it can accept. \item{parse}{If \code{TRUE}, the labels will be parsed into expressions and displayed as described in \code{?plotmath}.} -\item{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 \code{position}.} - \item{label.padding}{Amount of padding around label. Defaults to 0.25 lines.} \item{label.r}{Radius of rounded corners. Defaults to 0.15 lines.} diff --git a/man/position_dodge.Rd b/man/position_dodge.Rd index e4f9211110..5706e93e02 100644 --- a/man/position_dodge.Rd +++ b/man/position_dodge.Rd @@ -46,6 +46,15 @@ be specified in the global or \verb{geom_*} layer. Unlike \code{position_dodge() particularly useful for arranging box plots, which can have variable widths. } +\section{Aesthetics}{ + +\code{position_dodge()} understands the following aesthetics (required aesthetics are in bold): +\itemize{ +\item \code{order} +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. +} + \examples{ ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + geom_bar(position = "dodge2") diff --git a/man/position_nudge.Rd b/man/position_nudge.Rd index 3b2b2573cb..0db66c8035 100644 --- a/man/position_nudge.Rd +++ b/man/position_nudge.Rd @@ -4,7 +4,7 @@ \alias{position_nudge} \title{Nudge points a fixed distance} \usage{ -position_nudge(x = 0, y = 0) +position_nudge(x = NULL, y = NULL) } \arguments{ \item{x, y}{Amount of vertical and horizontal distance to move.} @@ -15,6 +15,16 @@ items on discrete scales by a small amount. Nudging is built in to \code{\link[=geom_text]{geom_text()}} because it's so useful for moving labels a small distance from what they're labelling. } +\section{Aesthetics}{ + +\code{position_nudge()} understands the following aesthetics (required aesthetics are in bold): +\itemize{ +\item \code{nudge_x} +\item \code{nudge_y} +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. +} + \examples{ df <- data.frame( x = c(1,3,2,5), diff --git a/man/theme.Rd b/man/theme.Rd index d28c10b149..51f92e1f96 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -384,7 +384,7 @@ differently when added to a ggplot object. Also, when setting \code{complete = TRUE} all elements will be set to inherit from blank elements.} -\item{validate}{\code{TRUE} to run \code{validate_element()}, \code{FALSE} to bypass checks.} +\item{validate}{\code{TRUE} to run \code{check_element()}, \code{FALSE} to bypass checks.} } \description{ Themes are a powerful way to customize the non-data components of your plots: diff --git a/tests/testthat/_snaps/geom-label.md b/tests/testthat/_snaps/geom-label.md index 2ea8c33c06..68ab4ebba4 100644 --- a/tests/testthat/_snaps/geom-label.md +++ b/tests/testthat/_snaps/geom-label.md @@ -1,7 +1,6 @@ # geom_label() throws meaningful errors - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Choose one approach to alter the position. + Ignoring unknown parameters: `nudge_x` --- diff --git a/tests/testthat/_snaps/geom-sf.md b/tests/testthat/_snaps/geom-sf.md index 2d5217dd4f..74edd268e1 100644 --- a/tests/testthat/_snaps/geom-sf.md +++ b/tests/testthat/_snaps/geom-sf.md @@ -19,13 +19,11 @@ --- - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Only use one approach to alter the position. + Ignoring unknown parameters: `nudge_x` --- - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Only use one approach to alter the position. + Ignoring unknown parameters: `nudge_x` --- diff --git a/tests/testthat/_snaps/geom-text.md b/tests/testthat/_snaps/geom-text.md index e86cc9c905..917a4ca707 100644 --- a/tests/testthat/_snaps/geom-text.md +++ b/tests/testthat/_snaps/geom-text.md @@ -1,7 +1,6 @@ # geom_text() checks input - Both `position` and `nudge_x`/`nudge_y` are supplied. - i Only use one approach to alter the position. + Ignoring unknown parameters: `nudge_x` # geom_text() drops missing angles diff --git a/tests/testthat/_snaps/prohibited-functions.md b/tests/testthat/_snaps/prohibited-functions.md index 007e6521c4..4612a484bf 100644 --- a/tests/testthat/_snaps/prohibited-functions.md +++ b/tests/testthat/_snaps/prohibited-functions.md @@ -43,17 +43,11 @@ $geom_density_2d_filled [1] "contour_var" - $geom_label - [1] "nudge_x" "nudge_y" - - $geom_sf_label - [1] "nudge_x" "nudge_y" - $geom_sf_text - [1] "nudge_x" "nudge_y" "check_overlap" + [1] "check_overlap" $geom_text - [1] "nudge_x" "nudge_y" "check_overlap" + [1] "check_overlap" $geom_violin [1] "draw_quantiles" diff --git a/tests/testthat/test-geom-label.R b/tests/testthat/test-geom-label.R index 028c3c4980..c80be5e38b 100644 --- a/tests/testthat/test-geom-label.R +++ b/tests/testthat/test-geom-label.R @@ -1,5 +1,5 @@ test_that("geom_label() throws meaningful errors", { - expect_snapshot_error(geom_label(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_label(position = "jitter", nudge_x = 0.5)) expect_snapshot_error(labelGrob(label = 1:3)) }) diff --git a/tests/testthat/test-geom-sf.R b/tests/testthat/test-geom-sf.R index ed6914ba61..29f5da8323 100644 --- a/tests/testthat/test-geom-sf.R +++ b/tests/testthat/test-geom-sf.R @@ -137,8 +137,8 @@ test_that("errors are correctly triggered", { ) p <- ggplot(pts) + geom_sf() + coord_cartesian() expect_snapshot_error(ggplotGrob(p)) - expect_snapshot_error(geom_sf_label(position = "jitter", nudge_x = 0.5)) - expect_snapshot_error(geom_sf_text(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_sf_label(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_sf_text(position = "jitter", nudge_x = 0.5)) # #5204: missing linewidth should be dropped pts <- sf::st_sf( diff --git a/tests/testthat/test-geom-text.R b/tests/testthat/test-geom-text.R index a6fe3359d9..8fe509e724 100644 --- a/tests/testthat/test-geom-text.R +++ b/tests/testthat/test-geom-text.R @@ -1,5 +1,5 @@ test_that("geom_text() checks input", { - expect_snapshot_error(geom_text(position = "jitter", nudge_x = 0.5)) + expect_snapshot_warning(geom_text(position = "jitter", nudge_x = 0.5)) }) test_that("geom_text() drops missing angles", { diff --git a/tests/testthat/test-position_dodge.R b/tests/testthat/test-position_dodge.R index 14b79d3cad..878ee6d155 100644 --- a/tests/testthat/test-position_dodge.R +++ b/tests/testthat/test-position_dodge.R @@ -38,6 +38,21 @@ test_that("position_dodge() can reverse the dodge order", { expect_equal(ld$label[order(ld$x)], c("A", "A", "B", "B", "C")) }) +test_that("position_dodge() can use the order aesthetic", { + + major <- c(1,1,1,2,2,3,3,4,4,5,6,7) + minor <- c(1:3, 1:2, 1, 3, 2:3, 1:3) + df <- data_frame0( + x = LETTERS[major], + g = c("X", "Y", "Z")[minor] + ) + ld <- layer_data( + ggplot(df, aes(x, 1, colour = g, order = g)) + + geom_point(position = position_dodge(preserve = "single", width = 0.6)) + ) + expect_equal(ld$x, major + c(-0.2, 0, 0.2)[minor], ignore_attr = TRUE) +}) + test_that("position_dodge warns about missing required aesthetics", { # Bit of a contrived geom to not have a required 'x' aesthetic From aa6ee959602c415e5e5d1247c54857514704556e Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 15:21:50 +0100 Subject: [PATCH 15/31] Weighted ellipses (#6186) * add `weight` aesthetic * add news bullet * document aesthetics --- NEWS.md | 1 + R/stat-ellipse.R | 13 ++++++++++--- man/stat_ellipse.Rd | 12 ++++++++++++ 3 files changed, 23 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 643e11bc65..f325bec637 100644 --- a/NEWS.md +++ b/NEWS.md @@ -267,6 +267,7 @@ * Standardised the calculation of `width`, which are now implemented as aesthetics (@teunbrand, #2800). * Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162) +* Added `weight` aesthetic for `stat_ellipse()` (@teunbrand, #5272) # ggplot2 3.5.1 diff --git a/R/stat-ellipse.R b/R/stat-ellipse.R index 5d1f41dd55..d462bf3575 100644 --- a/R/stat-ellipse.R +++ b/R/stat-ellipse.R @@ -20,6 +20,7 @@ #' @param segments The number of segments to be used in drawing the ellipse. #' @inheritParams layer #' @inheritParams geom_point +#' @eval rd_aesthetics("stat", "ellipse") #' @export #' @examples #' ggplot(faithful, aes(waiting, eruptions)) + @@ -76,6 +77,8 @@ stat_ellipse <- function(mapping = NULL, data = NULL, #' @export StatEllipse <- ggproto("StatEllipse", Stat, required_aes = c("x", "y"), + optional_aes = "weight", + dropped_aes = "weight", setup_params = function(data, params) { params$type <- params$type %||% "t" @@ -96,6 +99,9 @@ calculate_ellipse <- function(data, vars, type, level, segments){ dfn <- 2 dfd <- nrow(data) - 1 + weight <- data$weight %||% rep(1, nrow(data)) + weight <- weight / sum(weight) + if (!type %in% c("t", "norm", "euclid")) { cli::cli_inform("Unrecognized ellipse type") ellipse <- matrix(NA_real_, ncol = 2) @@ -104,11 +110,12 @@ calculate_ellipse <- function(data, vars, type, level, segments){ ellipse <- matrix(NA_real_, ncol = 2) } else { if (type == "t") { - v <- MASS::cov.trob(data[,vars]) + # Prone to convergence problems when `sum(weight) != nrow(data)` + v <- MASS::cov.trob(data[,vars], wt = weight * nrow(data)) } else if (type == "norm") { - v <- stats::cov.wt(data[,vars]) + v <- stats::cov.wt(data[,vars], wt = weight) } else if (type == "euclid") { - v <- stats::cov.wt(data[,vars]) + v <- stats::cov.wt(data[,vars], wt = weight) v$cov <- diag(rep(min(diag(v$cov)), 2)) } shape <- v$cov diff --git a/man/stat_ellipse.Rd b/man/stat_ellipse.Rd index 4bc30ef863..8ef16d92cc 100644 --- a/man/stat_ellipse.Rd +++ b/man/stat_ellipse.Rd @@ -125,6 +125,18 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} The method for calculating the ellipses has been modified from \code{car::dataEllipse} (Fox and Weisberg 2011, Friendly and Monette 2013) } +\section{Aesthetics}{ + +\code{stat_ellipse()} understands the following aesthetics (required aesthetics are in bold): +\itemize{ +\item \strong{\code{\link[=aes_position]{x}}} +\item \strong{\code{\link[=aes_position]{y}}} +\item \code{\link[=aes_group_order]{group}} +\item \code{weight} +} +Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. +} + \examples{ ggplot(faithful, aes(waiting, eruptions)) + geom_point() + From e327a5e08f4dd6da14c769ad5020118095f70eff Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 16:07:29 +0100 Subject: [PATCH 16/31] Guide custom order (#6199) * apply order * add news bullet --- NEWS.md | 1 + R/guides-.R | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index f325bec637..5b65a25614 100644 --- a/NEWS.md +++ b/NEWS.md @@ -268,6 +268,7 @@ aesthetics (@teunbrand, #2800). * Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162) * Added `weight` aesthetic for `stat_ellipse()` (@teunbrand, #5272) +* Fixed a bug where the `guide_custom(order)` wasn't working (@teunbrand, #6195) # ggplot2 3.5.1 diff --git a/R/guides-.R b/R/guides-.R index 0e7ca26882..63a17cc430 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -306,8 +306,9 @@ Guides <- ggproto( return(no_guides) } - guides$guides <- c(guides$guides, custom$guides) - guides$params <- c(guides$params, custom$params) + ord <- order(c(names(guides$guides), names(custom$guides))) + guides$guides <- c(guides$guides, custom$guides)[ord] + guides$params <- c(guides$params, custom$params)[ord] guides }, From 0b6751674b14d5572a17267b95386547095e98b6 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 16:07:43 +0100 Subject: [PATCH 17/31] Clip qq line (#6220) * `geom/stat_qq_line()` use `stat = "abline"` * document new computed variables * add news bullet --- NEWS.md | 3 +++ R/stat-qq-line.R | 7 +++++-- R/stat-qq.R | 4 +++- man/geom_qq.Rd | 6 ++++-- 4 files changed, 15 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index 5b65a25614..70050e2ee2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # ggplot2 (development version) +* New default `geom_qq_line(geom = "abline")` for better clipping in the + vertical direction. In addition, `slope` and `intercept` are new computed + variables in `stat_qq_line()` (@teunbrand, #6087). * 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) diff --git a/R/stat-qq-line.R b/R/stat-qq-line.R index 8133216779..ab6c194cfe 100644 --- a/R/stat-qq-line.R +++ b/R/stat-qq-line.R @@ -6,7 +6,7 @@ #' the data geom_qq_line <- function(mapping = NULL, data = NULL, - geom = "path", + geom = "abline", position = "identity", ..., distribution = stats::qnorm, @@ -86,6 +86,9 @@ StatQqLine <- ggproto("StatQqLine", Stat, x <- range(theoretical) } - data_frame0(x = x, y = slope * x + intercept) + data_frame0( + x = x, y = slope * x + intercept, + slope = slope, intercept = intercept + ) } ) diff --git a/R/stat-qq.R b/R/stat-qq.R index 4ffab00320..71068bbd04 100644 --- a/R/stat-qq.R +++ b/R/stat-qq.R @@ -22,7 +22,9 @@ #' x = "x-coordinates of the endpoints of the line segment connecting the #' points at the chosen quantiles of the theoretical and the sample #' distributions.", -#' y = "y-coordinates of the endpoints." +#' y = "y-coordinates of the endpoints.", +#' slope = "Amount of change in `y` across 1 unit of `x`.", +#' intercept = "Value of `y` at `x == 0`." #' ) #' #' @export diff --git a/man/geom_qq.Rd b/man/geom_qq.Rd index d6bedf3427..88656bc53a 100644 --- a/man/geom_qq.Rd +++ b/man/geom_qq.Rd @@ -10,7 +10,7 @@ geom_qq_line( mapping = NULL, data = NULL, - geom = "path", + geom = "abline", position = "identity", ..., distribution = stats::qnorm, @@ -25,7 +25,7 @@ geom_qq_line( stat_qq_line( mapping = NULL, data = NULL, - geom = "path", + geom = "abline", position = "identity", ..., distribution = stats::qnorm, @@ -205,6 +205,8 @@ Variables computed by \code{stat_qq_line()}: \itemize{ \item \code{after_stat(x)}\cr x-coordinates of the endpoints of the line segment connecting the points at the chosen quantiles of the theoretical and the sample distributions. \item \code{after_stat(y)}\cr y-coordinates of the endpoints. +\item \code{after_stat(slope)}\cr Amount of change in \code{y} across 1 unit of \code{x}. +\item \code{after_stat(intercept)}\cr Value of \code{y} at \code{x == 0}. } } From 321b300bd9ef1b902ca84def2e0e69c88d16f54f Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 16:10:54 +0100 Subject: [PATCH 18/31] missing contour parameter defaults to `TRUE` (#6222) --- R/stat-density-2d.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/stat-density-2d.R b/R/stat-density-2d.R index d8bbfed57b..af2b10b14d 100644 --- a/R/stat-density-2d.R +++ b/R/stat-density-2d.R @@ -143,7 +143,7 @@ StatDensity2d <- ggproto("StatDensity2d", Stat, data <- ggproto_parent(Stat, self)$compute_layer(data, params, layout) # if we're not contouring we're done - if (!isTRUE(params$contour)) return(data) + if (!isTRUE(params$contour %||% TRUE)) return(data) # set up data and parameters for contouring contour_var <- params$contour_var %||% "density" From 7eeb6365be8cfa559aabeda9b59828414515d785 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 16:52:01 +0100 Subject: [PATCH 19/31] Sanitise bin calculations (#6212) * capture bin argument fixup in function * capture binning logic in function * helper for cutting bins * consistency of `stat_bin2d()` * necromancy: resurrect `stat_bin(drop)` by sacrificing `stat_bin(keep.zeroes)` * fix `boundary = 0` * same treatment for `stat_summary2d()` * Implement `StatBin2d` as subclass of `StatSummary2d` * consistency for `stat_summary_bin()` * document * collect bin utilities in one place * remove vestigial `bin2d_breaks()` * discard superfluous `self` * bring `stat_bindot()` into the fold * centralise argument checking in `compute_bins()` * `stat_bin_2d(boundary)` internally defaults to 0 * add news bullets * allow lambda notation for breaks/binwidth/bins * improve docs --- DESCRIPTION | 2 +- NEWS.md | 6 +- R/bin.R | 109 ++++++++++++++++++++++++---- R/geom-bin2d.R | 2 +- R/stat-bin.R | 72 ++++++------------ R/stat-bin2d.R | 109 ++++++++-------------------- R/stat-bindot.R | 12 ++- R/stat-binhex.R | 7 ++ R/stat-summary-2d.R | 44 ++++++++--- R/stat-summary-bin.R | 17 +++-- man/geom_bin_2d.Rd | 47 ++++++++++-- man/geom_hex.Rd | 28 +++++-- man/geom_histogram.Rd | 7 +- man/ggplot2-ggproto.Rd | 10 +-- man/stat_summary_2d.Rd | 26 ++++++- tests/testthat/_snaps/stat-bin.md | 37 ++-------- tests/testthat/_snaps/stat-bin2d.md | 6 +- tests/testthat/test-stat-bin.R | 31 ++++---- tests/testthat/test-stat-bin2d.R | 2 +- 19 files changed, 327 insertions(+), 247 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 777d755861..753e7dd49a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -242,6 +242,7 @@ Collate: 'scales-.R' 'stat-align.R' 'stat-bin.R' + 'stat-summary-2d.R' 'stat-bin2d.R' 'stat-bindot.R' 'stat-binhex.R' @@ -263,7 +264,6 @@ Collate: 'stat-smooth-methods.R' 'stat-smooth.R' 'stat-sum.R' - 'stat-summary-2d.R' 'stat-summary-bin.R' 'stat-summary-hex.R' 'stat-summary.R' diff --git a/NEWS.md b/NEWS.md index 70050e2ee2..2eec9e3b33 100644 --- a/NEWS.md +++ b/NEWS.md @@ -254,7 +254,7 @@ * The ellipsis argument is now checked in `fortify()`, `get_alt_text()`, `labs()` and several guides (@teunbrand, #3196). * `stat_summary_bin()` no longer ignores `width` parameter (@teunbrand, #4647). -* Added `keep.zeroes` argument to `stat_bin()` (@teunbrand, #3449) +* Reintroduced `drop` argument to `stat_bin()` (@teunbrand, #3449) * (internal) removed barriers for using 2D structures as aesthetics (@teunbrand, #4189). * `coord_sf()` no longer errors when dealing with empty graticules (@teunbrand, #6052) @@ -272,6 +272,10 @@ * Stricter check on `register_theme_elements(element_tree)` (@teunbrand, #6162) * Added `weight` aesthetic for `stat_ellipse()` (@teunbrand, #5272) * Fixed a bug where the `guide_custom(order)` wasn't working (@teunbrand, #6195) +* All binning stats now use the `boundary`/`center` parametrisation rather + than `origin`, following in `stat_bin()`'s footsteps (@teunbrand). +* `stat_summary_2d()` and `stat_bin_2d()` now deal with zero-range data + more elegantly (@teunbrand, #6207). # ggplot2 3.5.1 diff --git a/R/bin.R b/R/bin.R index 055721f0e4..f45fe90090 100644 --- a/R/bin.R +++ b/R/bin.R @@ -54,19 +54,12 @@ bin_breaks <- function(breaks, closed = c("right", "left")) { bin_breaks_width <- function(x_range, width = NULL, center = NULL, boundary = NULL, closed = c("right", "left")) { - check_length(x_range, 2L) - # binwidth seems to be the argument name supplied to width. (stat-bin and stat-bindot) - check_number_decimal(width, min = 0, allow_infinite = FALSE, arg = "binwidth") - - if (!is.null(boundary) && !is.null(center)) { - cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.") - } else if (is.null(boundary)) { + if (is.null(boundary)) { if (is.null(center)) { # If neither edge nor center given, compute both using tile layer's # algorithm. This puts min and max of data in outer half of their bins. boundary <- width / 2 - } else { # If center given but not boundary, compute boundary. boundary <- center - width / 2 @@ -75,9 +68,6 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL, # Find the left side of left-most bin: inputs could be Dates or POSIXct, so # coerce to numeric first. - x_range <- as.numeric(x_range) - width <- as.numeric(width) - boundary <- as.numeric(boundary) shift <- floor((x_range[1] - boundary) / width) origin <- boundary + shift * width @@ -104,9 +94,7 @@ bin_breaks_width <- function(x_range, width = NULL, center = NULL, bin_breaks_bins <- function(x_range, bins = 30, center = NULL, boundary = NULL, closed = c("right", "left")) { - check_length(x_range, 2L) - check_number_whole(bins, min = 1) if (zero_range(x_range)) { # 0.1 is the same width as the expansion `default_expansion()` gives for 0-width data width <- 0.1 @@ -128,6 +116,56 @@ bin_breaks_bins <- function(x_range, bins = 30, center = NULL, # Compute bins ------------------------------------------------------------ +compute_bins <- function(x, scale = NULL, breaks = NULL, binwidth = NULL, bins = NULL, + center = NULL, boundary = NULL, + closed = c("right", "left")) { + + range <- if (is.scale(scale)) scale$dimension() else range(x) + check_length(range, 2L) + + if (!is.null(breaks)) { + breaks <- allow_lambda(breaks) + if (is.function(breaks)) { + breaks <- breaks(x) + } + if (is.scale(scale) && !scale$is_discrete()) { + breaks <- scale$transform(breaks) + } + check_numeric(breaks) + bins <- bin_breaks(breaks, closed) + return(bins) + } + + check_number_decimal(boundary, allow_infinite = FALSE, allow_null = TRUE) + check_number_decimal(center, allow_infinite = FALSE, allow_null = TRUE) + if (!is.null(boundary) && !is.null(center)) { + cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified.") + } + + if (!is.null(binwidth)) { + binwidth <- allow_lambda(binwidth) + if (is.function(binwidth)) { + binwidth <- binwidth(x) + } + check_number_decimal(binwidth, min = 0, allow_infinite = FALSE) + bins <- bin_breaks_width( + range, binwidth, + center = center, boundary = boundary, closed = closed + ) + return(bins) + } + + bins <- allow_lambda(bins) + if (is.function(bins)) { + bins <- bins(x) + } + check_number_whole(bins, min = 1, allow_infinite = FALSE) + bin_breaks_bins( + range, bins, + center = center, boundary = boundary, closed = closed + ) +} + bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { check_object(bins, is_bins, "a {.cls ggplot2_bins} object") @@ -141,8 +179,7 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { weight[is.na(weight)] <- 0 } - bin_idx <- cut(x, bins$fuzzy, right = bins$right_closed, - include.lowest = TRUE) + bin_idx <- bin_cut(x, bins) bin_count <- as.numeric(tapply(weight, bin_idx, sum, na.rm = TRUE)) bin_count[is.na(bin_count)] <- 0 @@ -170,6 +207,10 @@ bin_vector <- function(x, bins, weight = NULL, pad = FALSE) { bin_out(bin_count, bin_x, bin_widths) } +bin_cut <- function(x, bins) { + cut(x, bins$fuzzy, right = bins$right_closed, include.lowest = TRUE) +} + bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), xmin = x - width / 2, xmax = x + width / 2) { density <- count / width / sum(abs(count)) @@ -186,3 +227,41 @@ bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0), .size = length(count) ) } + +bin_loc <- function(x, id) { + left <- x[-length(x)] + right <- x[-1] + + list( + left = left[id], + right = right[id], + mid = ((left + right) / 2)[id], + length = diff(x)[id] + ) +} + +fix_bin_params = function(params, fun, version) { + + if (!is.null(params$origin)) { + args <- paste0(fun, c("(origin)", "(boundary)")) + deprecate_warn0(version, args[1], args[2]) + params$boudnary <- params$origin + params$origin <- NULL + } + + if (!is.null(params$right)) { + args <- paste0(fun, c("(right)", "(closed)")) + deprecate_warn0(version, args[1], args[2]) + params$closed <- if (isTRUE(params$right)) "right" else "left" + params$right <- NULL + } + + if (is.null(params$breaks %||% params$binwidth %||% params$bins)) { + cli::cli_inform( + "{.fn {fun}} using {.code bins = 30}. Pick better value {.arg binwidth}." + ) + params$bins <- 30 + } + + params +} diff --git a/R/geom-bin2d.R b/R/geom-bin2d.R index 5a143df51d..e0c78ab5e4 100644 --- a/R/geom-bin2d.R +++ b/R/geom-bin2d.R @@ -25,7 +25,7 @@ NULL #' # You can control the size of the bins by specifying the number of #' # bins in each direction: #' d + geom_bin_2d(bins = 10) -#' d + geom_bin_2d(bins = 30) +#' d + geom_bin_2d(bins = list(x = 30, y = 10)) #' #' # Or by specifying the width of the bins #' d + geom_bin_2d(binwidth = c(0.1, 0.1)) diff --git a/R/stat-bin.R b/R/stat-bin.R index 9c571ae519..711b0c5ad7 100644 --- a/R/stat-bin.R +++ b/R/stat-bin.R @@ -26,10 +26,11 @@ #' or left edges of bins are included in the bin. #' @param pad If `TRUE`, adds empty bins at either end of x. This ensures #' frequency polygons touch 0. Defaults to `FALSE`. -#' @param keep.zeroes Treatment of zero count bins. If `"all"` (default), such +#' @param drop Treatment of zero count bins. If `"all"` (default), such #' bins are kept as-is. If `"none"`, all zero count bins are filtered out. #' If `"inner"` only zero count bins at the flanks are filtered out, but not -#' in the middle. +#' in the middle. `TRUE` is shorthand for `"all"` and `FALSE` is shorthand +#' for `"none"`. #' @eval rd_computed_vars( #' count = "number of points in bin.", #' density = "density of points in bin, scaled to integrate to 1.", @@ -59,7 +60,7 @@ stat_bin <- function(mapping = NULL, data = NULL, closed = c("right", "left"), pad = FALSE, na.rm = FALSE, - keep.zeroes = "all", + drop = "all", orientation = NA, show.legend = NA, inherit.aes = TRUE) { @@ -82,7 +83,7 @@ stat_bin <- function(mapping = NULL, data = NULL, pad = pad, na.rm = na.rm, orientation = orientation, - keep.zeroes = keep.zeroes, + drop = drop, ... ) ) @@ -95,9 +96,13 @@ stat_bin <- function(mapping = NULL, data = NULL, StatBin <- ggproto("StatBin", Stat, setup_params = function(self, data, params) { params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE) - params$keep.zeroes <- arg_match0( - params$keep.zeroes %||% "all", - c("all", "none", "inner"), arg_nm = "keep.zeroes" + + if (is.logical(params$drop)) { + params$drop <- if (isTRUE(params$drop)) "all" else "none" + } + params$drop <- arg_match0( + params$drop %||% "all", + c("all", "none", "inner"), arg_nm = "drop" ) has_x <- !(is.null(data$x) && is.null(params$x)) @@ -118,29 +123,7 @@ StatBin <- ggproto("StatBin", Stat, )) } - if (!is.null(params$drop)) { - deprecate_warn0("2.1.0", "stat_bin(drop)", "stat_bin(pad)") - params$drop <- NULL - } - if (!is.null(params$origin)) { - deprecate_warn0("2.1.0", "stat_bin(origin)", "stat_bin(boundary)") - params$boundary <- params$origin - params$origin <- NULL - } - if (!is.null(params$right)) { - deprecate_warn0("2.1.0", "stat_bin(right)", "stat_bin(closed)") - params$closed <- if (params$right) "right" else "left" - params$right <- NULL - } - if (!is.null(params$boundary) && !is.null(params$center)) { - cli::cli_abort("Only one of {.arg boundary} and {.arg center} may be specified in {.fn {snake_class(self)}}.") - } - - if (is.null(params$breaks) && is.null(params$binwidth) && is.null(params$bins)) { - cli::cli_inform("{.fn {snake_class(self)}} using {.code bins = 30}. Pick better value with {.arg binwidth}.") - params$bins <- 30 - } - + params <- fix_bin_params(params, fun = snake_class(self), version = "2.1.0") params }, @@ -149,33 +132,20 @@ StatBin <- ggproto("StatBin", Stat, compute_group = function(data, scales, binwidth = NULL, bins = NULL, center = NULL, boundary = NULL, closed = c("right", "left"), pad = FALSE, - breaks = NULL, flipped_aes = FALSE, keep.zeroes = "all", + breaks = NULL, flipped_aes = FALSE, drop = "all", # The following arguments are not used, but must # be listed so parameters are computed correctly - origin = NULL, right = NULL, drop = NULL) { + origin = NULL, right = NULL) { x <- flipped_names(flipped_aes)$x - if (!is.null(breaks)) { - if (is.function(breaks)) { - breaks <- breaks(data[[x]]) - } - if (!scales[[x]]$is_discrete()) { - breaks <- scales[[x]]$transform(breaks) - } - bins <- bin_breaks(breaks, closed) - } else if (!is.null(binwidth)) { - if (is.function(binwidth)) { - binwidth <- binwidth(data[[x]]) - } - bins <- bin_breaks_width(scales[[x]]$dimension(), binwidth, - center = center, boundary = boundary, closed = closed) - } else { - bins <- bin_breaks_bins(scales[[x]]$dimension(), bins, center = center, - boundary = boundary, closed = closed) - } + bins <- compute_bins( + data[[x]], scales[[x]], + breaks = breaks, binwidth = binwidth, bins = bins, + center = center, boundary = boundary, closed = closed + ) bins <- bin_vector(data[[x]], bins, weight = data$weight, pad = pad) keep <- switch( - keep.zeroes, + drop, none = bins$count != 0, inner = inner_runs(bins$count != 0), TRUE diff --git a/R/stat-bin2d.R b/R/stat-bin2d.R index bdb69db23a..fe27a41162 100644 --- a/R/stat-bin2d.R +++ b/R/stat-bin2d.R @@ -1,7 +1,4 @@ -#' @param bins numeric vector giving number of bins in both vertical and -#' horizontal directions. Set to 30 by default. -#' @param binwidth Numeric vector giving bin width in both vertical and -#' horizontal directions. Overrides `bins` if both set. +#' @inheritParams stat_bin #' @param drop if `TRUE` removes all cells with 0 counts. #' @export #' @rdname geom_bin_2d @@ -11,11 +8,21 @@ #' ncount = "count, scaled to maximum of 1.", #' ndensity = "density, scaled to a maximum of 1." #' ) +#' @section Controlling binning parameters for the x and y directions: +#' The arguments `bins`, `binwidth`, `breaks`, `center`, and `boundary` can +#' be set separately for the x and y directions. When given as a scalar, one +#' value applies to both directions. When given as a vector of length two, +#' the first is applied to the x direction and the second to the y direction. +#' Alternatively, these can be a named list containing `x` and `y` elements, +#' for example `list(x = 10, y = 20)`. stat_bin_2d <- function(mapping = NULL, data = NULL, geom = "tile", position = "identity", ..., bins = 30, binwidth = NULL, + center = NULL, + boundary = NULL, + breaks = NULL, drop = TRUE, na.rm = FALSE, show.legend = NA, @@ -31,6 +38,9 @@ stat_bin_2d <- function(mapping = NULL, data = NULL, params = list2( bins = bins, binwidth = binwidth, + center = center, + boundary = boundary, + breaks = breaks, drop = drop, na.rm = na.rm, ... @@ -45,48 +55,37 @@ stat_bin_2d <- function(mapping = NULL, data = NULL, stat_bin2d <- stat_bin_2d #' @rdname ggplot2-ggproto +#' @include stat-summary-2d.R #' @format NULL #' @usage NULL #' @export -StatBin2d <- ggproto("StatBin2d", Stat, +StatBin2d <- ggproto( + "StatBin2d", StatSummary2d, default_aes = aes(weight = 1, fill = after_stat(count)), required_aes = c("x", "y"), compute_group = function(data, scales, binwidth = NULL, bins = 30, - breaks = NULL, origin = NULL, drop = TRUE) { + breaks = NULL, origin = NULL, drop = TRUE, + boundary = NULL, closed = NULL, center = NULL) { - origin <- dual_param(origin, list(NULL, NULL)) - binwidth <- dual_param(binwidth, list(NULL, NULL)) - breaks <- dual_param(breaks, list(NULL, NULL)) - bins <- dual_param(bins, list(x = 30, y = 30)) + data$z <- data$weight %||% 1 + data$weight <- NULL - xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x) - ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y) + # For backward compatibility, boundary defaults to 0 + boundary <- boundary %||% if (is.null(center)) list(x = 0, y = 0) - xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) - ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) - - if (is.null(data$weight)) - data$weight <- 1 - - out <- tapply_df(data$weight, list(xbin = xbin, ybin = ybin), sum, drop = drop) - - xdim <- bin_loc(xbreaks, out$xbin) - out$x <- xdim$mid - out$width <- xdim$length - - ydim <- bin_loc(ybreaks, out$ybin) - out$y <- ydim$mid - out$height <- ydim$length + out <- StatSummary2d$compute_group( + data, scales, binwidth = binwidth, bins = bins, breaks = breaks, + drop = drop, fun = "sum", boundary = boundary, closed = closed, + center = center + ) out$count <- out$value out$ncount <- out$count / max(out$count, na.rm = TRUE) out$density <- out$count / sum(out$count, na.rm = TRUE) out$ndensity <- out$density / max(out$density, na.rm = TRUE) out - }, - - dropped_aes = "weight" # No longer available after transformation + } ) dual_param <- function(x, default = list(x = NULL, y = NULL)) { @@ -102,53 +101,3 @@ dual_param <- function(x, default = list(x = NULL, y = NULL)) { list(x = x, y = x) } } - -bin2d_breaks <- function(scale, breaks = NULL, origin = NULL, binwidth = NULL, - bins = 30, closed = "right") { - # Bins for categorical data should take the width of one level, - # and should show up centered over their tick marks. All other parameters - # are ignored. - if (scale$is_discrete()) { - breaks <- scale$get_breaks() - return(-0.5 + seq_len(length(breaks) + 1)) - } else { - if (!is.null(breaks)) { - breaks <- scale$transform(breaks) - } - } - - if (!is.null(breaks)) - return(breaks) - - range <- scale$get_limits() - - if (is.null(binwidth) || identical(binwidth, NA)) { - binwidth <- diff(range) / bins - } - check_number_decimal(binwidth) - - if (is.null(origin) || identical(origin, NA)) { - origin <- round_any(range[1], binwidth, floor) - } - check_number_decimal(origin) - - breaks <- seq(origin, range[2] + binwidth, binwidth) - - # Check if the last bin lies fully outside the range - if (length(breaks) > 1 && breaks[length(breaks) - 1] >= range[2]) { - breaks <- breaks[-length(breaks)] - } - bins(breaks, closed)$fuzzy -} - -bin_loc <- function(x, id) { - left <- x[-length(x)] - right <- x[-1] - - list( - left = left[id], - right = right[id], - mid = ((left + right) / 2)[id], - length = diff(x)[id] - ) -} diff --git a/R/stat-bindot.R b/R/stat-bindot.R index 85eecc4d54..66184a527c 100644 --- a/R/stat-bindot.R +++ b/R/stat-bindot.R @@ -77,13 +77,11 @@ StatBindot <- ggproto("StatBindot", Stat, } if (method == "histodot") { - closed <- if (right) "right" else "left" - if (!is.null(binwidth)) { - bins <- bin_breaks_width(range, binwidth, boundary = origin, closed = closed) - } else { - bins <- bin_breaks_bins(range, 30, boundary = origin, closed = closed) - } - + bins <- compute_bins( + values, scales[[binaxis]], + breaks = NULL, binwidth = binwidth, bins = 30, center = NULL, + boundary = origin, closed = if (right) "right" else "left" + ) data <- bin_vector(values, bins, weight = data$weight, pad = FALSE) # Change "width" column to "binwidth" for consistency diff --git a/R/stat-binhex.R b/R/stat-binhex.R index 0b5d3991c6..be5b61daf7 100644 --- a/R/stat-binhex.R +++ b/R/stat-binhex.R @@ -7,6 +7,13 @@ #' ncount = "count, scaled to maximum of 1.", #' ndensity = "density, scaled to maximum of 1." #' ) +#' @section Controlling binning parameters for the x and y directions: +#' The arguments `bins` and `binwidth` can +#' be set separately for the x and y directions. When given as a scalar, one +#' value applies to both directions. When given as a vector of length two, +#' the first is applied to the x direction and the second to the y direction. +#' Alternatively, these can be a named list containing `x` and `y` elements, +#' for example `list(x = 10, y = 20)`. stat_bin_hex <- function(mapping = NULL, data = NULL, geom = "hex", position = "identity", ..., diff --git a/R/stat-summary-2d.R b/R/stat-summary-2d.R index 60e5e49813..41d0c5b588 100644 --- a/R/stat-summary-2d.R +++ b/R/stat-summary-2d.R @@ -28,6 +28,7 @@ #' @param drop drop if the output of `fun` is `NA`. #' @param fun function for summary. #' @param fun.args A list of extra arguments to pass to `fun` +#' @inheritSection stat_bin_2d Controlling binning parameters for the x and y directions #' @export #' @examples #' d <- ggplot(diamonds, aes(carat, depth, z = price)) @@ -92,31 +93,50 @@ StatSummary2d <- ggproto("StatSummary2d", Stat, required_aes = c("x", "y", "z"), dropped_aes = "z", # z gets dropped during statistical transformation + setup_params = function(self, data, params) { + + if (is.character(params$drop)) { + params$drop <- !identical(params$drop, "none") + } + + params <- fix_bin_params(params, fun = snake_class(self), version = "3.5.2") + vars <- c("origin", "binwidth", "breaks", "center", "boundary") + params[vars] <- lapply(params[vars], dual_param, default = NULL) + params$closed <- dual_param(params$closed, list(x = "right", y = "right")) + + params + }, + compute_group = function(data, scales, binwidth = NULL, bins = 30, breaks = NULL, origin = NULL, drop = TRUE, - fun = "mean", fun.args = list()) { - origin <- dual_param(origin, list(NULL, NULL)) - binwidth <- dual_param(binwidth, list(NULL, NULL)) - breaks <- dual_param(breaks, list(NULL, NULL)) + fun = "mean", fun.args = list(), + boundary = 0, closed = NULL, center = NULL) { bins <- dual_param(bins, list(x = 30, y = 30)) - xbreaks <- bin2d_breaks(scales$x, breaks$x, origin$x, binwidth$x, bins$x) - ybreaks <- bin2d_breaks(scales$y, breaks$y, origin$y, binwidth$y, bins$y) - - xbin <- cut(data$x, xbreaks, include.lowest = TRUE, labels = FALSE) - ybin <- cut(data$y, ybreaks, include.lowest = TRUE, labels = FALSE) + xbin <- compute_bins( + data$x, scales$x, breaks$x, binwidth$x, bins$x, + center$x, boundary$x, closed$x + ) + ybin <- compute_bins( + data$y, scales$y, breaks$y, binwidth$y, bins$y, + center$y, boundary$y, closed$y + ) + cut_id <- list( + xbin = as.integer(bin_cut(data$x, xbin)), + ybin = as.integer(bin_cut(data$y, ybin)) + ) fun <- as_function(fun) f <- function(x) { inject(fun(x, !!!fun.args)) } - out <- tapply_df(data$z, list(xbin = xbin, ybin = ybin), f, drop = drop) + out <- tapply_df(data$z, cut_id, f, drop = drop) - xdim <- bin_loc(xbreaks, out$xbin) + xdim <- bin_loc(xbin$breaks, out$xbin) out$x <- xdim$mid out$width <- xdim$length - ydim <- bin_loc(ybreaks, out$ybin) + ydim <- bin_loc(ybin$breaks, out$ybin) out$y <- ydim$mid out$height <- ydim$length diff --git a/R/stat-summary-bin.R b/R/stat-summary-bin.R index a56bea189e..e3db18b102 100644 --- a/R/stat-summary-bin.R +++ b/R/stat-summary-bin.R @@ -79,16 +79,21 @@ StatSummaryBin <- ggproto("StatSummaryBin", Stat, compute_group = function(data, scales, fun = NULL, bins = 30, binwidth = NULL, breaks = NULL, origin = NULL, right = FALSE, na.rm = FALSE, - flipped_aes = FALSE, width = NULL) { - data <- flip_data(data, flipped_aes) + flipped_aes = FALSE, width = NULL, center = NULL, + boundary = NULL, closed = c("right", "left")) { + x <- flipped_names(flipped_aes)$x - breaks <- bin2d_breaks(scales[[x]], breaks, origin, binwidth, bins, - closed = if (right) "right" else "left") + bins <- compute_bins( + data[[x]], scales[[x]], + breaks = breaks, binwidth = binwidth, bins = bins, + center = center, boundary = boundary, closed = closed + ) + data$bin <- bin_cut(data[[x]], bins) - data$bin <- cut(data$x, breaks, include.lowest = TRUE, labels = FALSE) + data <- flip_data(data, flipped_aes) out <- dapply(data, "bin", fun %||% function(df) mean_se(df$y)) - locs <- bin_loc(breaks, out$bin) + locs <- bin_loc(bins$breaks, out$bin) out$x <- locs$mid out$width <- width %||% if (scales[[x]]$is_discrete()) 0.9 else locs$length out$flipped_aes <- flipped_aes diff --git a/man/geom_bin_2d.Rd b/man/geom_bin_2d.Rd index fa3b32b4ce..dc0b9ce082 100644 --- a/man/geom_bin_2d.Rd +++ b/man/geom_bin_2d.Rd @@ -26,6 +26,9 @@ stat_bin_2d( ..., bins = 30, binwidth = NULL, + center = NULL, + boundary = NULL, + breaks = NULL, drop = TRUE, na.rm = FALSE, show.legend = NA, @@ -115,11 +118,33 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} - -\item{binwidth}{Numeric vector giving bin width in both vertical and -horizontal directions. Overrides \code{bins} if both set.} +\item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} + +\item{binwidth}{The width of the bins. Can be specified as a numeric value +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. +The default is to use the number of bins in \code{bins}, +covering the range of the data. You should always override +this value, exploring multiple widths to find the best to illustrate the +stories in your data. + +The bin width of a date variable is the number of days in each time; the +bin width of a time variable is the number of seconds.} + +\item{center, boundary}{bin position specifiers. Only one, \code{center} or +\code{boundary}, may be specified for a single plot. \code{center} specifies the +center of one of the bins. \code{boundary} specifies the boundary between two +bins. Note that if either is above or below the range of the data, things +will be shifted by the appropriate integer multiple of \code{binwidth}. +For example, to center on integers use \code{binwidth = 1} and \code{center = 0}, even +if \code{0} is outside the range of the data. Alternatively, this same alignment +can be specified with \code{binwidth = 1} and \code{boundary = 0.5}, even if \code{0.5} is +outside the range of the data.} + +\item{breaks}{Alternatively, you can supply a numeric vector giving +the bin boundaries. Overrides \code{binwidth}, \code{bins}, \code{center}, +and \code{boundary}. Can also be a function that takes group-wise values as input and returns bin boundaries.} \item{drop}{if \code{TRUE} removes all cells with 0 counts.} } @@ -153,6 +178,16 @@ These are calculated by the 'stat' part of layers and can be accessed with \link } } +\section{Controlling binning parameters for the x and y directions}{ + +The arguments \code{bins}, \code{binwidth}, \code{breaks}, \code{center}, and \code{boundary} can +be set separately for the x and y directions. When given as a scalar, one +value applies to both directions. When given as a vector of length two, +the first is applied to the x direction and the second to the y direction. +Alternatively, these can be a named list containing \code{x} and \code{y} elements, +for example \code{list(x = 10, y = 20)}. +} + \examples{ d <- ggplot(diamonds, aes(x, y)) + xlim(4, 10) + ylim(4, 10) d + geom_bin_2d() @@ -160,7 +195,7 @@ d + geom_bin_2d() # You can control the size of the bins by specifying the number of # bins in each direction: d + geom_bin_2d(bins = 10) -d + geom_bin_2d(bins = 30) +d + geom_bin_2d(bins = list(x = 30, y = 10)) # Or by specifying the width of the bins d + geom_bin_2d(binwidth = c(0.1, 0.1)) diff --git a/man/geom_hex.Rd b/man/geom_hex.Rd index 553787761b..da103b0e3c 100644 --- a/man/geom_hex.Rd +++ b/man/geom_hex.Rd @@ -112,11 +112,19 @@ the default plot specification, e.g. \code{\link[=borders]{borders()}}.} \code{stat_bin_hex()}. For more information about overriding these connections, see how the \link[=layer_stats]{stat} and \link[=layer_geoms]{geom} arguments work.} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} - -\item{binwidth}{Numeric vector giving bin width in both vertical and -horizontal directions. Overrides \code{bins} if both set.} +\item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} + +\item{binwidth}{The width of the bins. Can be specified as a numeric value +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. +The default is to use the number of bins in \code{bins}, +covering the range of the data. You should always override +this value, exploring multiple widths to find the best to illustrate the +stories in your data. + +The bin width of a date variable is the number of days in each time; the +bin width of a time variable is the number of seconds.} } \description{ Divides the plane into regular hexagons, counts the number of cases in @@ -162,6 +170,16 @@ These are calculated by the 'stat' part of layers and can be accessed with \link } } +\section{Controlling binning parameters for the x and y directions}{ + +The arguments \code{bins} and \code{binwidth} can +be set separately for the x and y directions. When given as a scalar, one +value applies to both directions. When given as a vector of length two, +the first is applied to the x direction and the second to the y direction. +Alternatively, these can be a named list containing \code{x} and \code{y} elements, +for example \code{list(x = 10, y = 20)}. +} + \examples{ d <- ggplot(diamonds, aes(carat, price)) d + geom_hex() diff --git a/man/geom_histogram.Rd b/man/geom_histogram.Rd index 32f9c39610..0a27e87c10 100644 --- a/man/geom_histogram.Rd +++ b/man/geom_histogram.Rd @@ -46,7 +46,7 @@ stat_bin( closed = c("right", "left"), pad = FALSE, na.rm = FALSE, - keep.zeroes = "all", + drop = "all", orientation = NA, show.legend = NA, inherit.aes = TRUE @@ -174,10 +174,11 @@ or left edges of bins are included in the bin.} \item{pad}{If \code{TRUE}, adds empty bins at either end of x. This ensures frequency polygons touch 0. Defaults to \code{FALSE}.} -\item{keep.zeroes}{Treatment of zero count bins. If \code{"all"} (default), such +\item{drop}{Treatment of zero count bins. If \code{"all"} (default), such bins are kept as-is. If \code{"none"}, all zero count bins are filtered out. If \code{"inner"} only zero count bins at the flanks are filtered out, but not -in the middle.} +in the middle. \code{TRUE} is shorthand for \code{"all"} and \code{FALSE} is shorthand +for \code{"none"}.} } \description{ Visualise the distribution of a single continuous variable by dividing diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index ea01c29996..6658fdafb9 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -19,14 +19,14 @@ % R/position-dodge.R, R/position-dodge2.R, R/position-identity.R, % R/position-jitter.R, R/position-jitterdodge.R, R/position-nudge.R, % R/position-stack.R, R/scale-.R, R/scale-binned.R, R/scale-continuous.R, -% R/scale-date.R, R/scale-discrete-.R, R/scale-identity.R, -% R/stat-align.R, R/stat-bin.R, R/stat-bin2d.R, R/stat-bindot.R, +% R/scale-date.R, R/scale-discrete-.R, R/scale-identity.R, R/stat-align.R, +% R/stat-bin.R, R/stat-summary-2d.R, R/stat-bin2d.R, R/stat-bindot.R, % R/stat-binhex.R, R/stat-boxplot.R, R/stat-contour.R, R/stat-count.R, % R/stat-density-2d.R, R/stat-density.R, R/stat-ecdf.R, R/stat-ellipse.R, % R/stat-function.R, R/stat-identity.R, R/stat-manual.R, R/stat-qq-line.R, % R/stat-qq.R, R/stat-quantilemethods.R, R/stat-smooth.R, R/stat-sum.R, -% R/stat-summary-2d.R, R/stat-summary-bin.R, R/stat-summary-hex.R, -% R/stat-summary.R, R/stat-unique.R, R/stat-ydensity.R +% R/stat-summary-bin.R, R/stat-summary-hex.R, R/stat-summary.R, +% R/stat-unique.R, R/stat-ydensity.R \docType{data} \name{ggplot2-ggproto} \alias{ggplot2-ggproto} @@ -126,6 +126,7 @@ \alias{ScaleContinuousIdentity} \alias{StatAlign} \alias{StatBin} +\alias{StatSummary2d} \alias{StatBin2d} \alias{StatBindot} \alias{StatBinhex} @@ -146,7 +147,6 @@ \alias{StatQuantile} \alias{StatSmooth} \alias{StatSum} -\alias{StatSummary2d} \alias{StatSummaryBin} \alias{StatSummaryHex} \alias{StatSummary} diff --git a/man/stat_summary_2d.Rd b/man/stat_summary_2d.Rd index 9ee4604b65..da62dd0a15 100644 --- a/man/stat_summary_2d.Rd +++ b/man/stat_summary_2d.Rd @@ -113,11 +113,19 @@ lists which parameters it can accept. \link[=draw_key]{key glyphs}, to change the display of the layer in the legend. }} -\item{bins}{numeric vector giving number of bins in both vertical and -horizontal directions. Set to 30 by default.} +\item{bins}{Number of bins. Overridden by \code{binwidth}. Defaults to 30.} -\item{binwidth}{Numeric vector giving bin width in both vertical and -horizontal directions. Overrides \code{bins} if both set.} +\item{binwidth}{The width of the bins. Can be specified as a numeric value +or as a function that takes x after scale transformation as input and +returns a single numeric value. When specifying a function along with a +grouping structure, the function will be called once per group. +The default is to use the number of bins in \code{bins}, +covering the range of the data. You should always override +this value, exploring multiple widths to find the best to illustrate the +stories in your data. + +The bin width of a date variable is the number of days in each time; the +bin width of a time variable is the number of seconds.} \item{drop}{drop if the output of \code{fun} is \code{NA}.} @@ -173,6 +181,16 @@ These are calculated by the 'stat' part of layers and can be accessed with \link } } +\section{Controlling binning parameters for the x and y directions}{ + +The arguments \code{bins}, \code{binwidth}, \code{breaks}, \code{center}, and \code{boundary} can +be set separately for the x and y directions. When given as a scalar, one +value applies to both directions. When given as a vector of length two, +the first is applied to the x direction and the second to the y direction. +Alternatively, these can be a named list containing \code{x} and \code{y} elements, +for example \code{list(x = 10, y = 20)}. +} + \examples{ d <- ggplot(diamonds, aes(carat, depth, z = price)) d + stat_summary_2d() diff --git a/tests/testthat/_snaps/stat-bin.md b/tests/testthat/_snaps/stat-bin.md index 2b5ee05525..db0b8f44c0 100644 --- a/tests/testthat/_snaps/stat-bin.md +++ b/tests/testthat/_snaps/stat-bin.md @@ -23,51 +23,30 @@ # inputs to binning are checked - Computation failed in `stat_bin()`. - Caused by error in `bins()`: - ! `breaks` must be a vector, not a character vector. + `breaks` must be a vector, not a character vector. --- - `x_range` must be a vector of length 2, not length 1. + `binwidth` must be a number, not a character vector. --- - Computation failed in `stat_bin()`. - Caused by error in `bin_breaks_width()`: - ! `binwidth` must be a number, not a character vector. + `binwidth` must be a number larger than or equal to 0, not the number -4. --- - Computation failed in `stat_bin()`. - Caused by error in `bin_breaks_width()`: - ! `binwidth` must be a number larger than or equal to 0, not the number -4. - ---- - - `x_range` must be a vector of length 2, not length 1. - ---- - - Computation failed in `stat_bin()`. - Caused by error in `bin_breaks_bins()`: - ! `bins` must be a whole number larger than or equal to 1, not the number -4. + `bins` must be a whole number larger than or equal to 1, not the number -4. # setting boundary and center - Code - comp_bin(df, boundary = 5, center = 0) - Condition - Error in `stat_bin()`: - ! Problem while computing stat. - i Error occurred in the 1st layer. - Caused by error in `setup_params()`: - ! Only one of `boundary` and `center` may be specified in `stat_bin()`. + Computation failed in `stat_bin()`. + Caused by error in `compute_bins()`: + ! Only one of `boundary` and `center` may be specified. # bin errors at high bin counts Code - bin_breaks_width(c(1, 2e+06), 1) + compute_bins(c(1, 2e+06), binwidth = 1) Condition Error in `bin_breaks_width()`: ! The number of histogram bins must be less than 1,000,000. diff --git a/tests/testthat/_snaps/stat-bin2d.md b/tests/testthat/_snaps/stat-bin2d.md index ffc60d7f92..a0bb2eebc7 100644 --- a/tests/testthat/_snaps/stat-bin2d.md +++ b/tests/testthat/_snaps/stat-bin2d.md @@ -1,12 +1,12 @@ # binwidth is respected Computation failed in `stat_bin2d()`. - Caused by error in `bin2d_breaks()`: + Caused by error in `compute_bins()`: ! `binwidth` must be a number, not a double vector. --- Computation failed in `stat_bin2d()`. - Caused by error in `bin2d_breaks()`: - ! `origin` must be a number, not a double vector. + Caused by error in `compute_bins()`: + ! `boundary` must be a number or `NULL`, not a double vector. diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index a114748daf..3df87821b8 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -118,17 +118,17 @@ test_that("stat_bin() provides width (#3522)", { expect_equal(out$xmax - out$xmin, rep(binwidth, 10)) }) -test_that("stat_bin(keep.zeroes) options work as intended", { +test_that("stat_bin(drop) options work as intended", { p <- ggplot(data.frame(x = c(1, 2, 2, 3, 5, 6, 6, 7)), aes(x)) + scale_x_continuous(limits = c(-1, 9)) - ld <- layer_data(p + geom_histogram(binwidth = 1, keep.zeroes = "all")) + ld <- layer_data(p + geom_histogram(binwidth = 1, drop = "all")) expect_equal(ld$x, -1:9) - ld <- layer_data(p + geom_histogram(binwidth = 1, keep.zeroes = "inner")) + ld <- layer_data(p + geom_histogram(binwidth = 1, drop = "inner")) expect_equal(ld$x, c(1:7)) - ld <- layer_data(p + geom_histogram(binwidth = 1, keep.zeroes = "none")) + ld <- layer_data(p + geom_histogram(binwidth = 1, drop = "none")) expect_equal(ld$x, c(1:3, 5:7)) }) @@ -147,19 +147,19 @@ test_that("bins is strictly adhered to", { # Default case nbreaks <- vapply(nbins, function(bins) { - length(bin_breaks_bins(c(0, 10), bins)$breaks) + length(compute_bins(c(0, 10), bins = bins)$breaks) }, numeric(1)) expect_equal(nbreaks, nbins + 1) # Center is provided nbreaks <- vapply(nbins, function(bins) { - length(bin_breaks_bins(c(0, 10), bins, center = 0)$breaks) + length(compute_bins(c(0, 10), bins = bins, center = 0)$breaks) }, numeric(1)) expect_equal(nbreaks, nbins + 1) # Boundary is provided nbreaks <- vapply(nbins, function(bins) { - length(bin_breaks_bins(c(0, 10), bins, boundary = 0)$breaks) + length(compute_bins(c(0, 10), bins = bins, boundary = 0)$breaks) }, numeric(1)) expect_equal(nbreaks, nbins + 1) @@ -172,13 +172,10 @@ comp_bin <- function(df, ...) { test_that("inputs to binning are checked", { dat <- data_frame(x = c(0, 10)) - expect_snapshot_error(comp_bin(dat, breaks = letters)) - expect_snapshot_error(bin_breaks_width(3)) - expect_snapshot_error(comp_bin(dat, binwidth = letters)) - expect_snapshot_error(comp_bin(dat, binwidth = -4)) - - expect_snapshot_error(bin_breaks_bins(3)) - expect_snapshot_error(comp_bin(dat, bins = -4)) + expect_snapshot_error(compute_bins(dat, breaks = letters)) + expect_snapshot_error(compute_bins(dat, binwidth = letters)) + expect_snapshot_error(compute_bins(dat, binwidth = -4)) + expect_snapshot_error(compute_bins(dat, bins = -4)) }) test_that("closed left or right", { @@ -208,14 +205,14 @@ test_that("setting boundary and center", { df <- data_frame(x = c(0, 30)) # Error if both boundary and center are specified - expect_snapshot(comp_bin(df, boundary = 5, center = 0), error = TRUE) + expect_snapshot_warning(comp_bin(df, boundary = 5, center = 0, bins = 30)) res <- comp_bin(df, binwidth = 10, boundary = 0, pad = FALSE) expect_identical(res$count, c(1, 0, 1)) expect_identical(res$xmin[1], 0) expect_identical(res$xmax[3], 30) - res <- comp_bin(df, binwidth = 10, center = 0, pad = FALSE) + res <- comp_bin(df, binwidth = 10, center = 0, boundary = NULL, pad = FALSE) expect_identical(res$count, c(1, 0, 0, 1)) expect_identical(res$xmin[1], df$x[1] - 5) expect_identical(res$xmax[4], df$x[2] + 5) @@ -230,7 +227,7 @@ test_that("weights are added", { }) test_that("bin errors at high bin counts", { - expect_snapshot(bin_breaks_width(c(1, 2e6), 1), error = TRUE) + expect_snapshot(compute_bins(c(1, 2e6), binwidth = 1), error = TRUE) }) # stat_count -------------------------------------------------------------- diff --git a/tests/testthat/test-stat-bin2d.R b/tests/testthat/test-stat-bin2d.R index 54d95679c9..6d83448956 100644 --- a/tests/testthat/test-stat-bin2d.R +++ b/tests/testthat/test-stat-bin2d.R @@ -14,7 +14,7 @@ test_that("binwidth is respected", { expect_snapshot_warning(ggplot_build(p)) p <- ggplot(df, aes(x, y)) + - stat_bin_2d(geom = "tile", origin = c(0.25, 0.5, 0.75)) + stat_bin_2d(geom = "tile", boundary = c(0.25, 0.5, 0.75)) expect_snapshot_warning(ggplot_build(p)) }) From e30642b0b65e5288e8dea0a3ed59f84e63be502a Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 16:52:49 +0100 Subject: [PATCH 20/31] Limits of binned scales when data has zero width (#6225) * fallback for zero-range limits * add test * add news bullet --- NEWS.md | 2 ++ R/scale-.R | 10 +++++++++- tests/testthat/test-scale-binned.R | 6 ++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 2eec9e3b33..c587911c83 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Binned scales with zero-width data expand the default limits by 0.1 + (@teunbrand, #5066) * New default `geom_qq_line(geom = "abline")` for better clipping in the vertical direction. In addition, `slope` and `intercept` are new computed variables in `stat_qq_line()` (@teunbrand, #6087). diff --git a/R/scale-.R b/R/scale-.R index 5ae52f65ab..1ab3381099 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -1292,9 +1292,17 @@ ScaleBinned <- ggproto("ScaleBinned", Scale, new_limits[1] <- breaks[1] breaks <- breaks[-1] } - } else { + } else if (nbreaks == 1) { bin_size <- max(breaks[1] - limits[1], limits[2] - breaks[1]) new_limits <- c(breaks[1] - bin_size, breaks[1] + bin_size) + } else { + new_limits <- limits + if (zero_range(new_limits)) { + # 0.1 is the same width as the expansion `default_expansion()` + # gives for 0-width data + new_limits <- new_limits + c(-0.05, 0.05) + } + breaks <- new_limits } new_limits_trans <- suppressWarnings(transformation$transform(new_limits)) limits[is.finite(new_limits_trans)] <- new_limits[is.finite(new_limits_trans)] diff --git a/tests/testthat/test-scale-binned.R b/tests/testthat/test-scale-binned.R index 527d862339..22ce6ef12a 100644 --- a/tests/testthat/test-scale-binned.R +++ b/tests/testthat/test-scale-binned.R @@ -104,3 +104,9 @@ test_that('binned scales can calculate breaks on date-times', { ))) ) }) + +test_that("binned scales can calculate breaks for zero-width data", { + scale <- scale_x_binned() + scale$train(c(1, 1)) + expect_equal(scale$get_breaks(), c(0.95, 1.05)) +}) From 4b887b713392a3a5fdfdbcf4e7d2c4143098b967 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Mon, 27 Jan 2025 19:45:31 +0100 Subject: [PATCH 21/31] Tweak polar distance (#6226) * add boosts to radius * tweak test * accept snapshots * add news bullet --- NEWS.md | 3 + R/coord-polar.R | 6 +- R/coord-radial.R | 6 +- .../bottom-half-circle-with-rotated-text.svg | 4 +- ...with-axes-placed-at-90-and-225-degrees.svg | 10 +- .../inner-radius-with-all-axes.svg | 44 +-- .../coord-polar/partial-with-all-axes.svg | 46 +-- ...etrack-plot-closed-and-has-center-hole.svg | 6 +- ...cetrack-plot-closed-and-no-center-hole.svg | 6 +- .../rays-circular-arcs-and-spiral-arcs.svg | 285 +++++++++--------- .../rose-plot-with-has-equal-spacing.svg | 4 +- .../coord-polar/three-concentric-circles.svg | 4 +- .../polar-lines-intersect-mid-bars.svg | 12 +- .../open-and-closed-munched-polygons.svg | 8 +- .../_snaps/geom-raster/rectangle-fallback.svg | 8 +- .../_snaps/geom-violin/coord-polar.svg | 2 +- ...xis-theta-with-angle-adapting-to-theta.svg | 96 +++--- .../_snaps/guide-axis/stacked-radial-axes.svg | 42 +-- tests/testthat/test-coord-polar.R | 2 +- 19 files changed, 306 insertions(+), 288 deletions(-) diff --git a/NEWS.md b/NEWS.md index c587911c83..1d4344dc5e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -278,6 +278,9 @@ than `origin`, following in `stat_bin()`'s footsteps (@teunbrand). * `stat_summary_2d()` and `stat_bin_2d()` now deal with zero-range data more elegantly (@teunbrand, #6207). +* Munching in `coord_polar()` and `coord_radial()` now adds more detail, + particularly for data-points with a low radius near the center + (@teunbrand, #5023). # ggplot2 3.5.1 diff --git a/R/coord-polar.R b/R/coord-polar.R index de9453ddb9..b8855f52b9 100644 --- a/R/coord-polar.R +++ b/R/coord-polar.R @@ -84,7 +84,7 @@ CoordPolar <- ggproto("CoordPolar", Coord, is_free = function() TRUE, - distance = function(self, x, y, details) { + distance = function(self, x, y, details, boost = 0.75) { arc <- self$start + c(0, 2 * pi) dir <- self$direction if (self$theta == "x") { @@ -94,8 +94,8 @@ CoordPolar <- ggproto("CoordPolar", Coord, r <- rescale(x, from = details$r.range) theta <- theta_rescale_no_clip(y, details$theta.range, arc, dir) } - - dist_polar(r, theta) + # The ^boost boosts detailed munching when r is small + dist_polar(r^boost, theta) }, backtransform_range = function(self, panel_params) { diff --git a/R/coord-radial.R b/R/coord-radial.R index 1fea09dcde..ef6130fb34 100644 --- a/R/coord-radial.R +++ b/R/coord-radial.R @@ -120,7 +120,7 @@ CoordRadial <- ggproto("CoordRadial", Coord, is_free = function() TRUE, - distance = function(self, x, y, details) { + distance = function(self, x, y, details, boost = 0.75) { arc <- details$arc %||% c(0, 2 * pi) if (self$theta == "x") { r <- rescale(y, from = details$r.range, to = self$inner_radius / 0.4) @@ -129,8 +129,8 @@ CoordRadial <- ggproto("CoordRadial", Coord, r <- rescale(x, from = details$r.range, to = self$inner_radius / 0.4) theta <- theta_rescale_no_clip(y, details$theta.range, arc) } - - dist_polar(r, theta) + # The ^boost boosts detailed munching when r is small + dist_polar(r^boost, theta) }, backtransform_range = function(self, panel_params) { diff --git a/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg b/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg index c01f91abbc..6349bcb350 100644 --- a/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg +++ b/tests/testthat/_snaps/coord-polar/bottom-half-circle-with-rotated-text.svg @@ -33,8 +33,8 @@ - - + + diff --git a/tests/testthat/_snaps/coord-polar/full-circle-with-axes-placed-at-90-and-225-degrees.svg b/tests/testthat/_snaps/coord-polar/full-circle-with-axes-placed-at-90-and-225-degrees.svg index 497db8dcf4..46607ddecd 100644 --- a/tests/testthat/_snaps/coord-polar/full-circle-with-axes-placed-at-90-and-225-degrees.svg +++ b/tests/testthat/_snaps/coord-polar/full-circle-with-axes-placed-at-90-and-225-degrees.svg @@ -29,15 +29,15 @@ - - - + + + - - + + diff --git a/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg b/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg index b75d829d47..7fddfe8e83 100644 --- a/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg +++ b/tests/testthat/_snaps/coord-polar/inner-radius-with-all-axes.svg @@ -28,26 +28,26 @@ - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + - - - - + + + + @@ -97,8 +97,8 @@ - - + + 10 15 20 @@ -111,7 +111,7 @@ - + diff --git a/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg b/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg index 03d06791cf..2f1de17be0 100644 --- a/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg +++ b/tests/testthat/_snaps/coord-polar/partial-with-all-axes.svg @@ -28,26 +28,26 @@ - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + @@ -105,8 +105,8 @@ - - + + 100 200 300 @@ -115,7 +115,7 @@ - + diff --git a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg index 8bf3cc6ec2..60045c846f 100644 --- a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg +++ b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-has-center-hole.svg @@ -44,9 +44,9 @@ - - - + + + 1 2 0/3 diff --git a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg index d145a1e446..32bb41821f 100644 --- a/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg +++ b/tests/testthat/_snaps/coord-polar/racetrack-plot-closed-and-no-center-hole.svg @@ -44,9 +44,9 @@ - - - + + + 1 2 0/3 diff --git a/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg b/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg index dfc63cb3d9..0c255f0bb8 100644 --- a/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg +++ b/tests/testthat/_snaps/coord-polar/rays-circular-arcs-and-spiral-arcs.svg @@ -47,115 +47,130 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -303,32 +318,32 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg b/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg index b9d09b1835..c82603f417 100644 --- a/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg +++ b/tests/testthat/_snaps/coord-polar/rose-plot-with-has-equal-spacing.svg @@ -44,8 +44,8 @@ - - + + A B diff --git a/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg b/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg index e00a3d6a7c..b54b3afc35 100644 --- a/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg +++ b/tests/testthat/_snaps/coord-polar/three-concentric-circles.svg @@ -47,8 +47,8 @@ - - + + 0.25 0.50 diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg index 2f67080988..4bd4970011 100644 --- a/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg +++ b/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg @@ -36,10 +36,10 @@ - - - - + + + + @@ -47,8 +47,8 @@ - - + + A B C diff --git a/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg index b970c9f317..5080746f6c 100644 --- a/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg +++ b/tests/testthat/_snaps/geom-polygon/open-and-closed-munched-polygons.svg @@ -25,10 +25,10 @@ - - - - + + + + colour diff --git a/tests/testthat/_snaps/geom-raster/rectangle-fallback.svg b/tests/testthat/_snaps/geom-raster/rectangle-fallback.svg index efb96b5c87..9a3ee13ab3 100644 --- a/tests/testthat/_snaps/geom-raster/rectangle-fallback.svg +++ b/tests/testthat/_snaps/geom-raster/rectangle-fallback.svg @@ -36,10 +36,10 @@ - - - - + + + + 1.0 1.5 2.0 diff --git a/tests/testthat/_snaps/geom-violin/coord-polar.svg b/tests/testthat/_snaps/geom-violin/coord-polar.svg index 02ae1107df..5da2c31990 100644 --- a/tests/testthat/_snaps/geom-violin/coord-polar.svg +++ b/tests/testthat/_snaps/geom-violin/coord-polar.svg @@ -38,7 +38,7 @@ - + A B C diff --git a/tests/testthat/_snaps/guide-axis/guide-axis-theta-with-angle-adapting-to-theta.svg b/tests/testthat/_snaps/guide-axis/guide-axis-theta-with-angle-adapting-to-theta.svg index 48b903c6f3..79f3e27b8c 100644 --- a/tests/testthat/_snaps/guide-axis/guide-axis-theta-with-angle-adapting-to-theta.svg +++ b/tests/testthat/_snaps/guide-axis/guide-axis-theta-with-angle-adapting-to-theta.svg @@ -28,53 +28,53 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + @@ -176,8 +176,8 @@ - - + + 10 15 20 diff --git a/tests/testthat/_snaps/guide-axis/stacked-radial-axes.svg b/tests/testthat/_snaps/guide-axis/stacked-radial-axes.svg index 9b4cf580e7..d8399aeb76 100644 --- a/tests/testthat/_snaps/guide-axis/stacked-radial-axes.svg +++ b/tests/testthat/_snaps/guide-axis/stacked-radial-axes.svg @@ -28,21 +28,21 @@ - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + @@ -95,15 +95,15 @@ - + 100 200 300 - - + + 100 200 300 @@ -112,7 +112,7 @@ - + 100 200 300 @@ -121,7 +121,7 @@ - + @@ -130,7 +130,7 @@ 200 300 400 - + diff --git a/tests/testthat/test-coord-polar.R b/tests/testthat/test-coord-polar.R index 2b07d96b21..1f662d2322 100644 --- a/tests/testthat/test-coord-polar.R +++ b/tests/testthat/test-coord-polar.R @@ -9,7 +9,7 @@ test_that("polar distance is calculated correctly", { ) coord <- coord_polar() panel_params <- coord$setup_panel_params(scales$x, scales$y) - dists <- coord$distance(dat$theta, dat$r, panel_params) + dists <- coord$distance(dat$theta, dat$r, panel_params, boost = 1) # dists is normalized by dividing by this value, so we'll add it back # The maximum length of a spiral arc, from (t,r) = (0,0) to (2*pi,1) From 212224dfcf934181ce88f846609be04b1e5e031d Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 09:16:38 +0100 Subject: [PATCH 22/31] Scale name function (#6200) * `Scale$make_title()` can uses functions * Disentangle `Layout$resolve_label()` * pre-resolve functions in `labs()` * rework how guides make titles * add test * add news bullet --- NEWS.md | 2 ++ R/axis-secondary.R | 4 +-- R/guide-bins.R | 2 +- R/guide-colorbar.R | 2 +- R/guide-colorsteps.R | 4 +-- R/guide-legend.R | 2 +- R/guide-old.R | 2 +- R/labels.R | 9 +++++++ R/layout.R | 48 +++++++++++++++++++----------------- R/scale-.R | 19 +++++++++++--- R/scale-continuous.R | 6 ++--- R/scale-date.R | 12 ++++----- R/scale-view.R | 6 ++--- tests/testthat/test-labels.R | 23 +++++++++++++++++ 14 files changed, 95 insertions(+), 46 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1d4344dc5e..9340b73a2f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* Scale names, guide titles and aesthetic labels can now accept functions + (@teunbrand, #4313) * Binned scales with zero-width data expand the default limits by 0.1 (@teunbrand, #5066) * New default `geom_qq_line(geom = "abline")` for better clipping in the diff --git a/R/axis-secondary.R b/R/axis-secondary.R index 23d36092b6..c1d024e288 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -329,7 +329,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL, scale$train(range) scale }, - make_title = function(title) { - title + make_title = function(...) { + ScaleContinuous$make_title(...) } ) diff --git a/R/guide-bins.R b/R/guide-bins.R index c03d5179d6..b83494fb77 100644 --- a/R/guide-bins.R +++ b/R/guide-bins.R @@ -218,7 +218,7 @@ GuideBins <- ggproto( key$.value <- 1 - key$.value } - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) params$key <- key params }, diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index c7c424c2ac..287b0087b8 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -259,7 +259,7 @@ GuideColourbar <- ggproto( extract_params = function(scale, params, title = waiver(), ...) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) limits <- params$decor$value[c(1L, nrow(params$decor))] to <- switch( params$display, diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R index 240a1e607c..14cca8563d 100644 --- a/R/guide-colorsteps.R +++ b/R/guide-colorsteps.R @@ -191,9 +191,7 @@ GuideColoursteps <- ggproto( params$key <- key } - params$title <- scale$make_title( - params$title %|W|% scale$name %|W|% title - ) + params$title <- scale$make_title(params$title, scale$name, title) limits <- c(params$decor$min[1], params$decor$max[nrow(params$decor)]) if (params$reverse) { diff --git a/R/guide-legend.R b/R/guide-legend.R index 37aad2e3f0..9355ae5a70 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -185,7 +185,7 @@ GuideLegend <- ggproto( extract_params = function(scale, params, title = waiver(), ...) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) if (isTRUE(params$reverse %||% FALSE)) { params$key <- params$key[nrow(params$key):1, , drop = FALSE] } diff --git a/R/guide-old.R b/R/guide-old.R index de870965fd..d20fec0e3e 100644 --- a/R/guide-old.R +++ b/R/guide-old.R @@ -89,7 +89,7 @@ GuideOld <- ggproto( train = function(self, params, scale, aesthetic = NULL, title = waiver(), direction = NULL) { - params$title <- scale$make_title(params$title %|W|% scale$name %|W|% title) + params$title <- scale$make_title(params$title, scale$name, title) params$direction <- params$direction %||% direction %||% "vertical" params <- guide_train(params, scale, aesthetic) params diff --git a/R/labels.R b/R/labels.R index 14d7f32a41..a736e2bf54 100644 --- a/R/labels.R +++ b/R/labels.R @@ -84,6 +84,15 @@ setup_plot_labels <- function(plot, layers, data) { )) } + # User labels can be functions, so apply these to the default labels + plot_labels <- lapply(setNames(nm = names(plot_labels)), function(nm) { + label <- plot_labels[[nm]] + if (!is.function(label)) { + return(label) + } + label(labels[[nm]] %||% "") + }) + dict <- plot_labels$dictionary if (length(dict) > 0) { labels <- lapply(labels, function(x) { diff --git a/R/layout.R b/R/layout.R index d3cad0ffeb..92a28216d7 100644 --- a/R/layout.R +++ b/R/layout.R @@ -244,35 +244,39 @@ Layout <- ggproto("Layout", NULL, }, resolve_label = function(self, scale, labels) { - # General order is: guide title > scale name > labels - aes <- scale$aesthetics[[1]] - primary <- scale$name %|W|% labels[[aes]] - secondary <- if (is.null(scale$secondary.axis)) { - waiver() - } else { - scale$sec_name() - } %|W|% labels[[paste0("sec.", aes)]] - if (is.derived(secondary)) secondary <- primary + aes <- scale$aesthetics[[1]] + + prim_scale <- scale$name + seco_scale <- (scale$sec_name %||% waiver)() + + prim_label <- labels[[aes]] + seco_label <- labels[[paste0("sec. aes")]] + + prim_guide <- seco_guide <- waiver() + order <- scale$axis_order() - if (!is.null(self$panel_params[[1]]$guides)) { - if ((scale$position) %in% c("left", "right")) { - guides <- c("y", "y.sec") - } else { - guides <- c("x", "x.sec") - } - params <- self$panel_params[[1]]$guides$get_params(guides) + panel <- self$panel_params[[1]]$guides + if (!is.null(panel)) { + position <- scale$position + aes <- switch(position, left = , right = "y", "x") + params <- panel$get_params(paste0(aes, c("", ".sec"))) if (!is.null(params)) { - primary <- params[[1]]$title %|W|% primary - secondary <- params[[2]]$title %|W|% secondary - position <- params[[1]]$position %||% scale$position - if (position != scale$position) { + prim_guide <- params[[1]]$title + seco_guide <- params[[2]]$title + position <- scale$position + if ((params[[1]]$position %||% position) != position) { order <- rev(order) } } } - primary <- scale$make_title(primary) - secondary <- scale$make_sec_title(secondary) + + primary <- scale$make_title(prim_guide, prim_scale, prim_label) + secondary <- scale$make_sec_title(seco_guide, seco_scale, seco_label) + if (is.derived(secondary)) { + secondary <- primary + } + list(primary = primary, secondary = secondary)[order] }, diff --git a/R/scale-.R b/R/scale-.R index 1ab3381099..f6e42a7e1e 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -612,12 +612,25 @@ Scale <- ggproto("Scale", NULL, ord }, - make_title = function(title) { + make_title = function(self, guide_title = waiver(), scale_title = waiver(), label_title = waiver()) { + title <- label_title + scale_title <- allow_lambda(scale_title) + if (is.function(scale_title)) { + title <- scale_title(title) + } else { + title <- scale_title %|W|% title + } + guide_title <- allow_lambda(guide_title) + if (is.function(guide_title)) { + title <- guide_title(title) + } else { + title <- guide_title %|W|% title + } title }, - make_sec_title = function(title) { - title + make_sec_title = function(self, ...) { + self$make_title(...) } ) diff --git a/R/scale-continuous.R b/R/scale-continuous.R index 39b5203565..8a681c2f20 100644 --- a/R/scale-continuous.R +++ b/R/scale-continuous.R @@ -159,11 +159,11 @@ ScaleContinuousPosition <- ggproto("ScaleContinuousPosition", ScaleContinuous, self$secondary.axis$name } }, - make_sec_title = function(self, title) { + make_sec_title = function(self, ...) { if (!is.waiver(self$secondary.axis)) { - self$secondary.axis$make_title(title) + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } ) diff --git a/R/scale-date.R b/R/scale-date.R index 436b9b129d..dff564e71e 100644 --- a/R/scale-date.R +++ b/R/scale-date.R @@ -392,11 +392,11 @@ ScaleContinuousDatetime <- ggproto("ScaleContinuousDatetime", ScaleContinuous, self$secondary.axis$name } }, - make_sec_title = function(self, title) { + make_sec_title = function(self, ...) { if (!is.waiver(self$secondary.axis)) { - self$secondary.axis$make_title(title) + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } @@ -443,11 +443,11 @@ ScaleContinuousDate <- ggproto("ScaleContinuousDate", ScaleContinuous, self$secondary.axis$name } }, - make_sec_title = function(self, title) { + make_sec_title = function(self, ...) { if (!is.waiver(self$secondary.axis)) { - self$secondary.axis$make_title(title) + self$secondary.axis$make_title(...) } else { - ggproto_parent(ScaleContinuous, self)$make_sec_title(title) + ggproto_parent(ScaleContinuous, self)$make_sec_title(...) } } ) diff --git a/R/scale-view.R b/R/scale-view.R index 350d27e9c0..cf9d4195d5 100644 --- a/R/scale-view.R +++ b/R/scale-view.R @@ -76,7 +76,7 @@ view_scale_secondary <- function(scale, limits = scale$get_limits(), # different breaks and labels in a different data space aesthetics = scale$aesthetics, name = scale$sec_name(), - make_title = function(self, title) self$scale$make_sec_title(title), + make_title = function(self, ...) self$scale$make_sec_title(...), continuous_range = sort(continuous_range), dimension = function(self) self$break_info$range, get_limits = function(self) self$break_info$range, @@ -127,8 +127,8 @@ ViewScale <- ggproto("ViewScale", NULL, x } }, - make_title = function(self, title) { - self$scale$make_title(title) + make_title = function(self, ...) { + self$scale$make_title(...) }, mapped_breaks = function(self) { self$map(self$get_breaks()) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 0b1fc5df50..172eca6364 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -199,6 +199,29 @@ test_that("position axis label hierarchy works as intended", { ) }) +test_that("labels can be derived using functions", { + + p <- ggplot(mtcars, aes(disp, mpg, colour = drat, shape = factor(cyl))) + + geom_point() + + labs( + y = to_upper_ascii, + shape = function(x) gsub("factor", "foo", x) + ) + + scale_shape_discrete( + name = to_upper_ascii, + guide = guide_legend(title = function(x) paste0(x, "!!!")) + ) + + scale_x_continuous(name = to_upper_ascii) + + guides(colour = guide_colourbar(title = to_upper_ascii)) + + labs <- get_labs(p) + expect_equal(labs$shape, "FOO(CYL)!!!") + expect_equal(labs$colour, "DRAT") + expect_equal(labs$x, "DISP") + expect_equal(labs$y, "MPG") + +}) + test_that("moving guide positions lets titles follow", { df <- data_frame(foo = c(1e1, 1e5), bar = c(0, 100)) From fdaa19510f58165878c44f1d7b021e03e0ec17fe Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 09:32:55 +0100 Subject: [PATCH 23/31] link blog (#6246) --- README.Rmd | 10 ++++++++-- README.md | 17 ++++++++++------- 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/README.Rmd b/README.Rmd index f546e5dc22..8c601f59ea 100644 --- a/README.Rmd +++ b/README.Rmd @@ -70,7 +70,7 @@ If you are looking for innovation, look to ggplot2's rich ecosystem of extension ## Learning ggplot2 -If you are new to ggplot2 you are better off starting with a systematic introduction, rather than trying to learn from reading individual documentation pages. Currently, there are three good places to start: +If you are new to ggplot2 you are better off starting with a systematic introduction, rather than trying to learn from reading individual documentation pages. Currently, there are several good places to start: 1. The [Data Visualization][r4ds-vis] and [Communication][r4ds-comm] chapters in @@ -92,7 +92,12 @@ If you are new to ggplot2 you are better off starting with a systematic introduc by Winston Chang. It provides a set of recipes to solve common graphics problems. -If you've mastered the basics and want to learn more, read [ggplot2: Elegant Graphics for Data Analysis][ggplot2-book]. It describes the theoretical underpinnings of ggplot2 and shows you how all the pieces fit together. This book helps you understand the theory that underpins ggplot2, and will help you create new types of graphics specifically tailored to your needs. +1. If you've mastered the basics and want to learn more, read [ggplot2: Elegant Graphics for Data Analysis][ggplot2-book]. + It describes the theoretical underpinnings of ggplot2 and shows you how all the pieces fit together. + This book helps you understand the theory that underpins ggplot2, + and will help you create new types of graphics specifically tailored to your needs. + +1. For articles about announcements and deep-dives you can visit the [tidyverse blog][blog]. ## Getting help @@ -114,3 +119,4 @@ There are two main places to get help with ggplot2: [r4ds-vis]: https://r4ds.hadley.nz/data-visualize [r4ds-comm]: https://r4ds.hadley.nz/communication [oreilly]: https://learning.oreilly.com/videos/data-visualization-in/9781491963661/ +[blog]: https://www.tidyverse.org/tags/ggplot2/ diff --git a/README.md b/README.md index 7fa139829b..3683108c63 100644 --- a/README.md +++ b/README.md @@ -74,7 +74,7 @@ extensions. See a community maintained list at If you are new to ggplot2 you are better off starting with a systematic introduction, rather than trying to learn from reading individual -documentation pages. Currently, there are three good places to start: +documentation pages. Currently, there are several good places to start: 1. The [Data Visualization](https://r4ds.hadley.nz/data-visualize) and [Communication](https://r4ds.hadley.nz/communication) chapters in [R @@ -97,12 +97,15 @@ documentation pages. Currently, there are three good places to start: Cookbook](https://r-graphics.org) by Winston Chang. It provides a set of recipes to solve common graphics problems. -If you’ve mastered the basics and want to learn more, read [ggplot2: -Elegant Graphics for Data Analysis](https://ggplot2-book.org). It -describes the theoretical underpinnings of ggplot2 and shows you how all -the pieces fit together. This book helps you understand the theory that -underpins ggplot2, and will help you create new types of graphics -specifically tailored to your needs. +5. If you’ve mastered the basics and want to learn more, read [ggplot2: + Elegant Graphics for Data Analysis](https://ggplot2-book.org). It + describes the theoretical underpinnings of ggplot2 and shows you how + all the pieces fit together. This book helps you understand the + theory that underpins ggplot2, and will help you create new types of + graphics specifically tailored to your needs. + +6. For articles about announcements and deep-dives you can visit the + [tidyverse blog](https://www.tidyverse.org/tags/ggplot2/). ## Getting help From fa7e2c1b5c6a8f24c7c9e1520600b6f11cb6b112 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 09:34:30 +0100 Subject: [PATCH 24/31] Include image of shape table (#6236) * add news bullet * add images * include in docs * Revert "add news bullet" This reverts commit e16ae8b600180c1b3d95a0da39bdaa3e43296373. --- R/scale-shape.R | 7 +++ man/figures/shape_table.pdf | Bin 0 -> 5370 bytes man/figures/shape_table.svg | 120 ++++++++++++++++++++++++++++++++++++ man/scale_shape.Rd | 7 +++ 4 files changed, 134 insertions(+) create mode 100644 man/figures/shape_table.pdf create mode 100644 man/figures/shape_table.svg diff --git a/R/scale-shape.R b/R/scale-shape.R index effa0a0b2f..39687022fc 100644 --- a/R/scale-shape.R +++ b/R/scale-shape.R @@ -12,6 +12,13 @@ #' @inheritParams scale_x_discrete #' @inheritDotParams discrete_scale -expand -position -scale_name -palette #' @rdname scale_shape +#' @details +#' Shapes can be referred to by number or name. Shapes in \[0, 20\] do not +#' support a fill aesthetic, whereas shapes in \[21, 25\] do. +#' +#' \if{html}{\figure{shape_table.svg}{All shapes by number and name}} +#' \if{latex}{\figure{shape_table.pdf}} +#' #' @seealso #' The documentation for [differentiation related aesthetics][aes_linetype_size_shape]. #' diff --git a/man/figures/shape_table.pdf b/man/figures/shape_table.pdf new file mode 100644 index 0000000000000000000000000000000000000000..8e7f539dc2c72736cc80d3062e92ec3ef343ccfb GIT binary patch literal 5370 zcmZ`-XH=6}yQK(7q(}#)ydY?(Apt_DN|oLrbiojcLJ}eL-jOyG>CzDtWDx1yLPv^# z2r5WXs&oXT=uMn)zHhGgzWH_bdCED@%36D$EnuLkE(#Ts1PO%Bhc1K;hmKjhgP?#o zfW3JOBrgwwsJNr;@h(`5sy!YJfK_E-;xI`ljPQfPB%soQAc!v3;s4z;alyM1vW$T1 z?)Erm7nBE}?}^8G;t6R6?pOy;6xyA*D=8)^1|wiUdtr%?AV^UWgvK}!PXYVqGyufJ z7l#HQD)xALSF95NF|c<+djJxI03+Z(3DUnM5aWo^?r04D?{J6;7K0}&Jpjbdbchk! z1MBIIBGi-oU-gIqzs8}1#yH`f0jQLWBmhx&am5pE08w`(3`Z4>!aAUd=k~x8X66R+ zxj${8ZOkuC(|%C3#Xz@xw7$VPrDddMYLs@(ly026mxL5X-a<3}{Zu2}p@nLHj?*J^ zCS9~I|G{udPTi`Bg=dwb?&f~*iF*5IX*o_OODmSsIvwHY z17k|3{)M!i{MAr4-(Yywd}DB4+Yj1wI=#R=F~w&$k*TI-TP^vn+XrjRZMLoMyepaG zMHw1@l&xvz>S|e-i@)kut0+dc1o1m(D1l_j zmL`j@O_^A|xZJKO^scr36_Z%K&D@NRQ)p14}Et_NUiMnFPR0rLm zgJDnwhaNxH`i*#7K=yp^s{)J2=yFg_Qh%#mNj96$UCer>NLUM|rzU+`vPO6jbO zNkT?fR6mVr7)iPPu_kF{^lEc*K|&g)(@a?{rCATWJHFCsRx;nR7QtG6hvrTCRxFkP zn=etbz5f%3EzRk7YMFgk$7D&4(Oru$?LO7kLmwz#x|{qdbFsnGmQM$IkGY!ujoBJeoA>!lWN!^^2V1b(9}Z<>eDEjD%>I55)2xXinHL7GegQF) z?Y?3{aqra~NXpe29R+$Z0^HPGWxna)0WXp9_1=)KydEzci|`pyTg~N3k(!98FMf|3 z1s}ImcT$Z?p!`MYMX0a5P&%6_>^8~1r_`NR*fef%eokxMEw_!re^JA$k@vA7?i74m zK*%tu{&EqiH&jK6yV>By#caLF@#-Z>>N@?Q4uguBQyMDG+>hY*V&6Y2!L0M?>^RtWNdM5A8sGb9k-cpLQA1`KGBUAvABjppEHN)X@eMt^ytri`x`Sef$}{LF*M}7hR1_SN%3~6{ znkhan?4z$HnS%}E){yjd*x(!DTP?>wgw zaET?H>Wo!0tuVWa+IYrhGUbAD(H#R#N;;4+b0aGw?*+lfI6X%2v(uRpF}Z~=UnY1S zJ(`ehZS*2RK#!+Cd&v!r(sdh;GKIXr8h?R+~8}3 zEzgWbzw>kiVEwYfID9VYj+yX6J$-Y6hlbByHeY;7WE zCvUQIBtT+?=e|Sh3upbH@nMLmLU!SN?v5W9K`W)j;+dIT@r64aWa-0+9MNpz-4d1x za|0f{MJ>tmE)qKfgNJN~*l8;IB(4*xp&!T6r{~hzgHH&=_cw?9O@Ty)`-_2oQQ%+9 z2hnzM@Bpj;BI6kWHUwtGdJ-583P5zx4lee}SRcSjoUkV;0RvzNgw21EB$4EPks5)E zQO0OIUyZ0~_~0N}(Zn_o0fT>ZME5|LLi#3m3`w3iDC zO)Lu0BTzTwZvuu%$-w_l0w$j69|F!z_ck$}VvQbdlWsFeIUjp(40y?LSt9spOgH^zt?2J2PHAcj9=P0oU-O%>q96Y?+Y~O_hr^g z>JEu(4e?oo!OT)Uc0{ZK_OsCRGP|${d5!^(p?UPyrw>;a5@Zxx?qNo%wEKGF4mt@5a_B#QfDT(*S+f&?`$Z zM*gxGj?31@Q3$e=7*k|(9;x~ZdRHy0KXn>A8{mec4#I|xba z({@j~z&qT{0k%e+^CC{d6(2rWYm?^R7KAKs9_7;otK0|}Hfo>V{A};Dn~F%mLse|0 zF^+zvs-3+<^SEy`i}}%qJXGI3xmg)b_}gP3_taDeN_7C8^g63vrWlGW<)~|i`Pql` zFTa;eHKpHucgQf3Zcg@q_rkRxZW6E%13>NXAUv`ec&__8`M1Hi*IAjl$HQUY1Cfn7 z-+Nj4gA-BLRbh>chC^SnPb|qK0TQ)q%E|W7oJ5&FRp^=1smYhrp9CPN59dtH~ zIf+yiU}FxcD`3ADR%v(TA*E*lgJd`y$Bqw0%}OGu#6kz`&U_#>5~s@x5!?d3x^_My zviCfTQ8XS<>E(PHX`XcP6FG$ng8}EgvjQs08e}Zj)(VUsa+XJ}7CJ6lEranFnn`F? z8VU@Z8IM@}s4j_9mp-?A!r)3#W2cWen;60Nyl)GJ;1LUJc$S7E4>-ROq5m>tmcbl! zHMEQ&kD<|WFLNN2HuJ!#u74@Ywwb{OL&@MHImDEt(Ym*)Sw1B_s;e6 zutd%mr5BnN!i&odsSI)-Dvq0ugKvSpGU%$`E*gA2v`m5*k>$vZ6H`YPB7 ziS^^mD)T}g)jJy7j~H$HH11Y*8d^RuDaMuSMlw!olwM79t zwK=?5!mr!U&@a+&-S1$J`bgxI|CH;f?Z}u?mXeo}g0hmbfp$Ae3cnH$?-lk=BM*Krh0g2f1ER zEVc|ri;l4Bu`0(=#$D85981l5>55LY92E^0Jtx{Cl5fFb-eu)hv)XXv?1s(7Ogjhm zMBQX^Hg+CE?N(G~iN3Ax-hXGkWBswIV##Yb5aWdDX?TzF9?QGMbF<@l``ho~;l<&- zg@g8^ub)9*S5ItH#&v^GZjQO$%5uIkm0q%odlOU7ExrUyeq&=R)y~$A8z}be-aXvC zu$0iW+T?D%X7d0;)1cbWhB5NC@lNy)KPIOSq|dva+7nUs$f;-{tv_r)Ljpp?D!@zKrciz!lG+l)x_464BXFHw}uOV z7^ToEQ*lpQx+JHD$3r?*pW4E*7t)PWcP~rJ9%$sb=ZRzOnx=Mi2d?Y{?snLQT0XaV zZB=0Pq}~qyV5$Gebfo-2g&%UQO3YHBy&F3iS{G60ayuAYD<%R7XcBX@(N8veon2J@ zHE7K$jwM#DOB&wj`tW_sJMbi;(Pg8wT$e}NM}SScQd?N-BX$wfewa3hOuG^IE~OUz zoE&wK8tZ5~vp>wSqCav5J*4eXJI4RKGjpK4ojSWnrY z4eIJv13k6AY9t_a{VN^UOW(b1@olO4vOPIwR%VK{Jit`hZ4UZ%91T$xN5uwa2Fe_B z!_}qtg9neAn>33b)vmk@nhRP9jUf*lOdK2(%@##h;wnl!ckEs~ANc4KJT~3!T7fNV z$lxZ6=8xtM&N*EF`cf&{|Bok$wSi8DHf~gP#U)Iu)-y71(nbZ=6W6#EFZk3p^gJkA z@E_Pb;2Bde^RWKxGe!O4ZV^+y-eUfJ#Wc^=m6cCps5WiC&HHy1JSrir*e%zQsokZ3 z;oOyjFIRnMzMfQ{8)8eeb+Gx;{0aBS<5^I_0@X2(EG6M}63rRi43V?h;K-8>n2$Y9 z8$-5L<+ZTl)<=6!lIPY8-(qJp8hP9LTD~ot9aSzhcwmMdeW<>275!r`sCAk5n|)Wrkm~NG_t$$a2VQ|(wLSDX(VR%l zD(ku`{KNYA)u$=%4xba4IE$Rrck8{Av8tRK4?8A*jBcPe@soR}NRBE;+l*GjV2@eR zHMbuvnchqiO`Fx5!dEkcmcOy@ZEuvt>*oiNA4KdP|0cC%{*j@ezuhJ^48hoO!4T{w zqHO)o3h9DT!g#p+0zeQ|7e_}l!D1qMNLGNP6vWL1$= z*z+d-r?*7}3Hn{n-i;uB3DWy#)4yUg(5_x+ybH=61o_nzARhO>y)Pekv?E9yfI>my z|9k*kN=iZsa0LFrU<8Mc_yL%IFesex$oMw~m60M?U;oBn;*!7R!k|*W<-(u{f}sC* zt~kLq{2i0|4U + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0: +square open +1: +circle open +2: +triangle open +3: +plus +4: +cross +5: +diamond open +6: +triangle down open +7: +square cross +8: +asterisk +9: +diamond plus +10: +circle plus +11: +star +12: +square plus +13: +circle cross +14: +square triangle +15: +square +16: +circle small +17: +triangle +18: +diamond +19: +circle +20: +bullet +21: +circle filled +22: +square filled +23: +diamond filled +24: +triangle filled +25: +triangle down filled + + diff --git a/man/scale_shape.Rd b/man/scale_shape.Rd index 85b991fd9a..4f90b5c0d6 100644 --- a/man/scale_shape.Rd +++ b/man/scale_shape.Rd @@ -89,6 +89,13 @@ seventh and subsequent levels will not appear on the plot. Use a continuous variable to shape unless \code{scale_shape_binned()} is used. Still, as shape has no inherent order, this use is not advised. } +\details{ +Shapes can be referred to by number or name. Shapes in [0, 20] do not +support a fill aesthetic, whereas shapes in [21, 25] do. + +\if{html}{\figure{shape_table.svg}{All shapes by number and name}} +\if{latex}{\figure{shape_table.pdf}} +} \examples{ set.seed(596) dsmall <- diamonds[sample(nrow(diamonds), 100), ] From 7356fe3029ade295dd53589d96869b8a64f17bf5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 11:35:02 +0100 Subject: [PATCH 25/31] Coord sf breaks fallback (#6232) * add news bullet * fallback * avoid duplicated labels * add test * add news bullet --- NEWS.md | 4 ++++ R/coord-sf.R | 8 ++++++++ tests/testthat/test-coord_sf.R | 12 ++++++++++++ 3 files changed, 24 insertions(+) diff --git a/NEWS.md b/NEWS.md index 9340b73a2f..e2e2d0c607 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # ggplot2 (development version) +* Axis labels are now preserved better when using `coord_sf(expand = TRUE)` and + graticule lines are straight but do not meet the edge (@teunbrand, #2985). +* Attempt to boost detail in `coord_polar()` and `coord_radial()` near the + center (@teunbrand, #5023) * Scale names, guide titles and aesthetic labels can now accept functions (@teunbrand, #4313) * Binned scales with zero-width data expand the default limits by 0.1 diff --git a/R/coord-sf.R b/R/coord-sf.R index 3f96ff6aaf..d603d57de7 100644 --- a/R/coord-sf.R +++ b/R/coord-sf.R @@ -721,6 +721,14 @@ view_scales_from_graticule <- function(graticule, scale, aesthetic, accept_start <- graticule[[orth_start]] < thres accept_end <- graticule[[orth_end]] < thres } + if (!any(accept_start | accept_end)) { + eps <- sqrt(.Machine$double.xmin) + subtract <- switch(position, top = , bottom = 90, 0) + straight <- + abs(graticule$angle_start - subtract) < eps & + abs(graticule$angle_end - subtract) < eps + accept_start <- straight + } # Parsing the information of the `label_axes` argument: # should we label the meridians ("E") or parallels ("N")? diff --git a/tests/testthat/test-coord_sf.R b/tests/testthat/test-coord_sf.R index 516d2fa9ec..a684bea20b 100644 --- a/tests/testthat/test-coord_sf.R +++ b/tests/testthat/test-coord_sf.R @@ -425,3 +425,15 @@ test_that("coord_sf() can render with empty graticules", { p <- suppressWarnings(layer_grob(ggplot(df) + geom_sf())[[1]]) expect_length(p$x, 1) }) + +test_that("coord_sf() can calculate breaks when expansion is on", { + skip_if_not_installed("sf") + df <- sf::st_multipoint(cbind(c(-180, 180), c(-90, 90))) + df <- sf::st_sfc(df, crs = 4326) + b <- ggplot_build(ggplot(df) + geom_sf()) + + x <- get_guide_data(b, "x") + y <- get_guide_data(b, "y") + expect_equal(nrow(x), 5L) + expect_equal(nrow(y), 3L) +}) From c052d8123440a18d6d132d2143757c74e61b6305 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 11:35:34 +0100 Subject: [PATCH 26/31] Scales expose `aesthetics` argument (#6227) * add news bullet * add `aesthetics` as parameter * redocument * add news bullet --- NEWS.md | 1 + R/scale-alpha.R | 20 ++++++++++---------- R/scale-identity.R | 25 +++++++++++++++---------- R/scale-linetype.R | 10 +++++----- R/scale-linewidth.R | 21 +++++++++++---------- R/scale-manual.R | 22 +++++++++++----------- R/scale-shape.R | 10 +++++----- R/scale-size.R | 34 ++++++++++++++++++---------------- R/zxx.R | 20 ++++++++++++-------- man/scale_alpha.Rd | 15 +++++++++++---- man/scale_identity.Rd | 30 +++++++++++++++++++++++++----- man/scale_linetype.Rd | 19 +++++++++++++++---- man/scale_linewidth.Rd | 8 ++++++-- man/scale_manual.Rd | 40 +++++++++++++++++++++++++++++++++++----- man/scale_shape.Rd | 7 ++++--- man/scale_size.Rd | 15 ++++++++++----- 16 files changed, 194 insertions(+), 103 deletions(-) diff --git a/NEWS.md b/NEWS.md index e2e2d0c607..c0f7809db6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -287,6 +287,7 @@ * Munching in `coord_polar()` and `coord_radial()` now adds more detail, particularly for data-points with a low radius near the center (@teunbrand, #5023). +* All scales now expose the `aesthetics` parameter (@teunbrand, #5841) # ggplot2 3.5.1 diff --git a/R/scale-alpha.R b/R/scale-alpha.R index 5e22937e88..c9155db9aa 100644 --- a/R/scale-alpha.R +++ b/R/scale-alpha.R @@ -31,9 +31,9 @@ #' #' # Changing the title #' p + scale_alpha("cylinders") -scale_alpha <- function(name = waiver(), ..., range = NULL) { +scale_alpha <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { palette <- if (!is.null(range)) pal_rescale(range) else NULL - continuous_scale("alpha", name = name, palette = palette, ...) + continuous_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_alpha @@ -42,9 +42,9 @@ scale_alpha_continuous <- scale_alpha #' @rdname scale_alpha #' @export -scale_alpha_binned <- function(name = waiver(), ..., range = NULL) { +scale_alpha_binned <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { palette <- if (!is.null(range)) pal_rescale(range) else NULL - binned_scale("alpha", name = name, palette = palette, ...) + binned_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_alpha @@ -58,22 +58,22 @@ scale_alpha_discrete <- function(...) { #' @rdname scale_alpha #' @export -scale_alpha_ordinal <- function(name = waiver(), ..., range = NULL) { +scale_alpha_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { palette <- if (!is.null(range)) { function(n) seq(range[1], range[2], length.out = n) } else { NULL } - discrete_scale("alpha", name = name, palette = palette, ...) + discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_alpha #' @export #' @usage NULL -scale_alpha_datetime <- function(name = waiver(), ..., range = NULL) { +scale_alpha_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha") { palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics = "alpha", transform = "time", name = name, + aesthetics = aesthetics, transform = "time", name = name, palette = palette, ... ) } @@ -81,10 +81,10 @@ scale_alpha_datetime <- function(name = waiver(), ..., range = NULL) { #' @rdname scale_alpha #' @export #' @usage NULL -scale_alpha_date <- function(name = waiver(), ..., range = NULL){ +scale_alpha_date <- function(name = waiver(), ..., range = NULL, aesthetics = "alpha"){ palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - aesthetics = "alpha", transform = "date", name = name, + aesthetics = aesthetics, transform = "date", name = name, palette = palette, ... ) } diff --git a/R/scale-identity.R b/R/scale-identity.R index d86f6ae360..3ab2de5c43 100644 --- a/R/scale-identity.R +++ b/R/scale-identity.R @@ -89,9 +89,10 @@ scale_fill_identity <- function(name = waiver(), ..., guide = "none", #' @seealso #' Other shape scales: [scale_shape()], [scale_shape_manual()]. #' @export -scale_shape_identity <- function(name = waiver(), ..., guide = "none") { +scale_shape_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "shape") { continuous_scale( - "shape", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) @@ -101,9 +102,10 @@ scale_shape_identity <- function(name = waiver(), ..., guide = "none") { #' @seealso #' Other linetype scales: [scale_linetype()], [scale_linetype_manual()]. #' @export -scale_linetype_identity <- function(name = waiver(), ..., guide = "none") { +scale_linetype_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "linetype") { discrete_scale( - "linetype", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleDiscreteIdentity ) @@ -113,9 +115,10 @@ scale_linetype_identity <- function(name = waiver(), ..., guide = "none") { #' @seealso #' Other alpha scales: [scale_alpha()], [scale_alpha_manual()]. #' @export -scale_linewidth_identity <- function(name = waiver(), ..., guide = "none") { +scale_linewidth_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "linewidth") { continuous_scale( - "linewidth", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) @@ -123,9 +126,10 @@ scale_linewidth_identity <- function(name = waiver(), ..., guide = "none") { #' @rdname scale_identity #' @export -scale_alpha_identity <- function(name = waiver(), ..., guide = "none") { +scale_alpha_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "alpha") { continuous_scale( - "alpha", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) @@ -135,9 +139,10 @@ scale_alpha_identity <- function(name = waiver(), ..., guide = "none") { #' @seealso #' Other size scales: [scale_size()], [scale_size_manual()]. #' @export -scale_size_identity <- function(name = waiver(), ..., guide = "none") { +scale_size_identity <- function(name = waiver(), ..., guide = "none", + aesthetics = "size") { continuous_scale( - "size", name = name, + aesthetics, name = name, palette = pal_identity(), ..., guide = guide, super = ScaleContinuousIdentity ) diff --git a/R/scale-linetype.R b/R/scale-linetype.R index 8f8c62e30e..a53f660c72 100644 --- a/R/scale-linetype.R +++ b/R/scale-linetype.R @@ -5,7 +5,7 @@ #' line types unless `scale_linetype_binned()` is used. Still, as linetypes has #' no inherent order, this use is not advised. #' -#' @inheritParams scale_x_discrete +#' @inheritParams discrete_scale #' @inheritDotParams discrete_scale -expand -position -na.value -scale_name -palette #' @param na.value The linetype to use for `NA` values. #' @rdname scale_linetype @@ -35,9 +35,9 @@ #' scale_linetype_identity() + #' facet_grid(linetype ~ .) + #' theme_void(20) -scale_linetype <- function(name = waiver(), ..., na.value = NA) { +scale_linetype <- function(name = waiver(), ..., na.value = NA, aesthetics = "linetype") { discrete_scale( - "linetype", name = name, + aesthetics, name = name, palette = NULL, na.value = na.value, ... @@ -46,9 +46,9 @@ scale_linetype <- function(name = waiver(), ..., na.value = NA) { #' @rdname scale_linetype #' @export -scale_linetype_binned <- function(name = waiver(), ..., na.value = NA) { +scale_linetype_binned <- function(name = waiver(), ..., na.value = NA, aesthetics = "linetype") { binned_scale( - "linetype", name = name, + aesthetics, name = name, palette = NULL, na.value = na.value, ... diff --git a/R/scale-linewidth.R b/R/scale-linewidth.R index 9bf05b3913..f9cec8856f 100644 --- a/R/scale-linewidth.R +++ b/R/scale-linewidth.R @@ -33,9 +33,10 @@ scale_linewidth_continuous <- function(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, range = NULL, transform = "identity", trans = deprecated(), - guide = "legend") { + guide = "legend", + aesthetics = "linewidth") { palette <- if (!is.null(range)) pal_rescale(range) else NULL - continuous_scale("linewidth", palette = palette, name = name, + continuous_scale(aesthetics, palette = palette, name = name, breaks = breaks, labels = labels, limits = limits, transform = transform, trans = trans, guide = guide) } @@ -49,9 +50,9 @@ scale_linewidth <- scale_linewidth_continuous scale_linewidth_binned <- function(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, range = NULL, n.breaks = NULL, nice.breaks = TRUE, transform = "identity", - trans = deprecated(), guide = "bins") { + trans = deprecated(), guide = "bins", aesthetics = "linewidth") { palette <- if (!is.null(range)) pal_rescale(range) else NULL - binned_scale("linewidth", palette = palette, name = name, + binned_scale(aesthetics, palette = palette, name = name, breaks = breaks, labels = labels, limits = limits, transform = transform, trans = trans, n.breaks = n.breaks, nice.breaks = nice.breaks, guide = guide) @@ -70,22 +71,22 @@ scale_linewidth_discrete <- function(...) { #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_ordinal <- function(name = waiver(), ..., range = NULL) { +scale_linewidth_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { palette <- if (!is.null(range)) { function(n) seq(range[1], range[2], length.out = n) } else { NULL } - discrete_scale("linewidth", name = name, palette = palette, ...) + discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_datetime <- function(name = waiver(), ..., range = NULL) { +scale_linewidth_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - "linewidth", transform = "time", name = name, + aesthetics, transform = "time", name = name, palette = palette, ... ) } @@ -93,10 +94,10 @@ scale_linewidth_datetime <- function(name = waiver(), ..., range = NULL) { #' @rdname scale_linewidth #' @export #' @usage NULL -scale_linewidth_date <- function(name = waiver(), ..., range = NULL) { +scale_linewidth_date <- function(name = waiver(), ..., range = NULL, aesthetics = "linewidth") { palette <- if (!is.null(range)) pal_rescale(range) else NULL datetime_scale( - "linewidth", transform = "date", name = name, + aesthetics, transform = "date", name = name, palette = palette, ... ) } diff --git a/R/scale-manual.R b/R/scale-manual.R index 47c647fc02..9f6284361b 100644 --- a/R/scale-manual.R +++ b/R/scale-manual.R @@ -11,7 +11,7 @@ #' `scale_discrete_manual()` is a generic scale that can work with any aesthetic or set #' of aesthetics provided via the `aesthetics` argument. #' -#' @inheritParams scale_x_discrete +#' @inheritParams discrete_scale #' @inheritDotParams discrete_scale -expand -position -aesthetics -palette -scale_name #' @param aesthetics Character string or vector of character strings listing the #' name(s) of the aesthetic(s) that this scale works with. This can be useful, for @@ -103,38 +103,38 @@ scale_fill_manual <- function(..., values, aesthetics = "fill", breaks = waiver( #' @seealso #' Other size scales: [scale_size()], [scale_size_identity()]. #' @export -scale_size_manual <- function(..., values, breaks = waiver(), na.value = NA) { - manual_scale("size", values, breaks, ..., na.value = na.value) +scale_size_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "size") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @seealso #' Other shape scales: [scale_shape()], [scale_shape_identity()]. #' @export -scale_shape_manual <- function(..., values, breaks = waiver(), na.value = NA) { - manual_scale("shape", values, breaks, ..., na.value = na.value) +scale_shape_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "shape") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @seealso #' Other linetype scales: [scale_linetype()], [scale_linetype_identity()]. #' @export -scale_linetype_manual <- function(..., values, breaks = waiver(), na.value = NA) { - manual_scale("linetype", values, breaks, ..., na.value = na.value) +scale_linetype_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "linetype") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @seealso #' Other alpha scales: [scale_alpha()], [scale_alpha_identity()]. #' @export -scale_linewidth_manual <- function(..., values, breaks = waiver(), na.value = NA) { - manual_scale("linewidth", values, breaks, ..., na.value = na.value) +scale_linewidth_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "linewidth") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual #' @export -scale_alpha_manual <- function(..., values, breaks = waiver(), na.value = NA) { - manual_scale("alpha", values, breaks, ..., na.value = na.value) +scale_alpha_manual <- function(..., values, breaks = waiver(), na.value = NA, aesthetics = "alpha") { + manual_scale(aesthetics, values, breaks, ..., na.value = na.value) } #' @rdname scale_manual diff --git a/R/scale-shape.R b/R/scale-shape.R index 39687022fc..bde6756840 100644 --- a/R/scale-shape.R +++ b/R/scale-shape.R @@ -9,7 +9,7 @@ #' #' @param solid Should the shapes be solid, `TRUE`, or hollow, #' `FALSE`? -#' @inheritParams scale_x_discrete +#' @inheritParams discrete_scale #' @inheritDotParams discrete_scale -expand -position -scale_name -palette #' @rdname scale_shape #' @details @@ -49,16 +49,16 @@ #' scale_shape_identity() + #' facet_wrap(~shape) + #' theme_void() -scale_shape <- function(name = waiver(), ..., solid = NULL) { +scale_shape <- function(name = waiver(), ..., solid = NULL, aesthetics = "shape") { palette <- if (!is.null(solid)) pal_shape(solid) else NULL - discrete_scale("shape", name = name, palette = palette, ...) + discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_shape #' @export -scale_shape_binned <- function(name = waiver(), ..., solid = TRUE) { +scale_shape_binned <- function(name = waiver(), ..., solid = TRUE, aesthetics = "shape") { palette <- if (!is.null(solid)) pal_binned(pal_shape(solid)) else NULL - binned_scale("shape", name = name, palette = palette, ...) + binned_scale(aesthetics, name = name, palette = palette, ...) } #' @rdname scale_shape diff --git a/R/scale-size.R b/R/scale-size.R index 525f378e15..964abf16a6 100644 --- a/R/scale-size.R +++ b/R/scale-size.R @@ -55,9 +55,10 @@ scale_size_continuous <- function(name = waiver(), breaks = waiver(), labels = w limits = NULL, range = NULL, transform = "identity", trans = deprecated(), - guide = "legend") { + guide = "legend", + aesthetics = "size") { palette <- if (!is.null(range)) pal_area(range) else NULL - continuous_scale("size", palette = palette, name = name, + continuous_scale(aesthetics, palette = palette, name = name, breaks = breaks, labels = labels, limits = limits, transform = transform, trans = trans, guide = guide) } @@ -71,8 +72,8 @@ scale_size <- scale_size_continuous scale_radius <- function(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, range = c(1, 6), transform = "identity", trans = deprecated(), - guide = "legend") { - continuous_scale("size", palette = pal_rescale(range), name = name, + guide = "legend", aesthetics = "size") { + continuous_scale(aesthetics, palette = pal_rescale(range), name = name, breaks = breaks, labels = labels, limits = limits, transform = transform, trans = trans, guide = guide) } @@ -82,9 +83,10 @@ scale_radius <- function(name = waiver(), breaks = waiver(), labels = waiver(), scale_size_binned <- function(name = waiver(), breaks = waiver(), labels = waiver(), limits = NULL, range = NULL, n.breaks = NULL, nice.breaks = TRUE, transform = "identity", - trans = deprecated(), guide = "bins") { + trans = deprecated(), guide = "bins", + aesthetics = "size") { palette <- if (!is.null(range)) pal_area(range) else NULL - binned_scale("size", palette = palette, name = name, + binned_scale(aesthetics, palette = palette, name = name, breaks = breaks, labels = labels, limits = limits, transform = transform, trans = trans, n.breaks = n.breaks, nice.breaks = nice.breaks, guide = guide) @@ -103,22 +105,22 @@ scale_size_discrete <- function(...) { #' @rdname scale_size #' @export #' @usage NULL -scale_size_ordinal <- function(name = waiver(), ..., range = NULL) { +scale_size_ordinal <- function(name = waiver(), ..., range = NULL, aesthetics = "size") { palette <- if (!is.null(range)) { function(n) sqrt(seq(range[1]^2, range[2]^2, length.out = n)) } else { NULL } - discrete_scale("size", name = name, palette = palette, ...) + discrete_scale(aesthetics, name = name, palette = palette, ...) } #' @inheritDotParams continuous_scale -aesthetics -scale_name -palette -rescaler -expand -position #' @param max_size Size of largest points. #' @export #' @rdname scale_size -scale_size_area <- function(name = waiver(), ..., max_size = 6) { +scale_size_area <- function(name = waiver(), ..., max_size = 6, aesthetics = "size") { continuous_scale( - "size", name = name, + aesthetics, name = name, palette = abs_area(max_size), rescaler = rescale_max, ... ) @@ -126,9 +128,9 @@ scale_size_area <- function(name = waiver(), ..., max_size = 6) { #' @export #' @rdname scale_size -scale_size_binned_area <- function(name = waiver(), ..., max_size = 6) { +scale_size_binned_area <- function(name = waiver(), ..., max_size = 6, aesthetics = "size") { binned_scale( - "size", name = name, + aesthetics, name = name, palette = abs_area(max_size), rescaler = rescale_max, ... ) @@ -137,15 +139,15 @@ scale_size_binned_area <- function(name = waiver(), ..., max_size = 6) { #' @rdname scale_size #' @export #' @usage NULL -scale_size_datetime <- function(name = waiver(), ..., range = NULL) { +scale_size_datetime <- function(name = waiver(), ..., range = NULL, aesthetics = "size") { palette <- if (!is.null(range)) pal_area(range) else NULL - datetime_scale("size", "time", name = name, palette = palette, ...) + datetime_scale(aesthetics, "time", name = name, palette = palette, ...) } #' @rdname scale_size #' @export #' @usage NULL -scale_size_date <- function(name = waiver(), ..., range = NULL) { +scale_size_date <- function(name = waiver(), ..., range = NULL, aesthetics = "size") { palette <- if (!is.null(range)) pal_area(range) else NULL - datetime_scale("size", "date", name = name, palette = palette, ...) + datetime_scale(aesthetics, "date", name = name, palette = palette, ...) } diff --git a/R/zxx.R b/R/zxx.R index 59b3812e56..7c10940491 100644 --- a/R/zxx.R +++ b/R/zxx.R @@ -36,9 +36,10 @@ scale_colour_datetime <- function(name = waiver(), ..., high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "colour") { datetime_scale( - aesthetics = "colour", transform = "time", name = name, + aesthetics = aesthetics, transform = "time", name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -60,9 +61,10 @@ scale_colour_date <- function(name = waiver(), high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "colour") { datetime_scale( - aesthetics = "colour", transform = "date", name = name, + aesthetics = aesthetics, transform = "date", name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -114,9 +116,10 @@ scale_fill_datetime <- function(name = waiver(), ..., high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "fill") { datetime_scale( - aesthetics = "fill", transform = "time", name = name, + aesthetics = aesthetics, transform = "time", name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, @@ -132,9 +135,10 @@ scale_fill_date <- function(name = waiver(), ..., high = "#56B1F7", space = "Lab", na.value = "grey50", - guide = "colourbar") { + guide = "colourbar", + aesthetics = "fill") { datetime_scale( - aesthetics = "fill", transform = "date", name = name, + aesthetics = aesthetics, transform = "date", name = name, palette = pal_seq_gradient(low, high, space), na.value = na.value, guide = guide, diff --git a/man/scale_alpha.Rd b/man/scale_alpha.Rd index 6833a08002..7c4a5784df 100644 --- a/man/scale_alpha.Rd +++ b/man/scale_alpha.Rd @@ -10,15 +10,20 @@ \alias{scale_alpha_date} \title{Alpha transparency scales} \usage{ -scale_alpha(name = waiver(), ..., range = NULL) +scale_alpha(name = waiver(), ..., range = NULL, aesthetics = "alpha") -scale_alpha_continuous(name = waiver(), ..., range = NULL) +scale_alpha_continuous( + name = waiver(), + ..., + range = NULL, + aesthetics = "alpha" +) -scale_alpha_binned(name = waiver(), ..., range = NULL) +scale_alpha_binned(name = waiver(), ..., range = NULL, aesthetics = "alpha") scale_alpha_discrete(...) -scale_alpha_ordinal(name = waiver(), ..., range = NULL) +scale_alpha_ordinal(name = waiver(), ..., range = NULL, aesthetics = "alpha") } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -31,6 +36,8 @@ or \code{\link[=discrete_scale]{discrete_scale()}} as appropriate, to control na breaks, labels and so forth.} \item{range}{Output range of alpha values. Must lie between 0 and 1.} + +\item{aesthetics}{The names of the aesthetics that this scale works with.} } \description{ Alpha-transparency scales are not tremendously useful, but can be a diff --git a/man/scale_identity.Rd b/man/scale_identity.Rd index 2f3a877cfd..68100940e0 100644 --- a/man/scale_identity.Rd +++ b/man/scale_identity.Rd @@ -22,15 +22,35 @@ scale_colour_identity( scale_fill_identity(name = waiver(), ..., guide = "none", aesthetics = "fill") -scale_shape_identity(name = waiver(), ..., guide = "none") +scale_shape_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "shape" +) -scale_linetype_identity(name = waiver(), ..., guide = "none") +scale_linetype_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "linetype" +) -scale_linewidth_identity(name = waiver(), ..., guide = "none") +scale_linewidth_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "linewidth" +) -scale_alpha_identity(name = waiver(), ..., guide = "none") +scale_alpha_identity( + name = waiver(), + ..., + guide = "none", + aesthetics = "alpha" +) -scale_size_identity(name = waiver(), ..., guide = "none") +scale_size_identity(name = waiver(), ..., guide = "none", aesthetics = "size") scale_discrete_identity(aesthetics, name = waiver(), ..., guide = "none") diff --git a/man/scale_linetype.Rd b/man/scale_linetype.Rd index cc5fa67cb4..5707bd9f90 100644 --- a/man/scale_linetype.Rd +++ b/man/scale_linetype.Rd @@ -7,13 +7,23 @@ \alias{scale_linetype_discrete} \title{Scale for line patterns} \usage{ -scale_linetype(name = waiver(), ..., na.value = NA) +scale_linetype(name = waiver(), ..., na.value = NA, aesthetics = "linetype") -scale_linetype_binned(name = waiver(), ..., na.value = NA) +scale_linetype_binned( + name = waiver(), + ..., + na.value = NA, + aesthetics = "linetype" +) scale_linetype_continuous(...) -scale_linetype_discrete(name = waiver(), ..., na.value = NA) +scale_linetype_discrete( + name = waiver(), + ..., + na.value = NA, + aesthetics = "linetype" +) } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -49,7 +59,6 @@ every level in a legend, the layer should use \code{show.legend = TRUE}.} \item{\code{na.translate}}{Unlike continuous scales, discrete scales can easily show missing values, and do so by default. If you want to remove missing values from a discrete scale, specify \code{na.translate = FALSE}.} - \item{\code{aesthetics}}{The names of the aesthetics that this scale works with.} \item{\code{minor_breaks}}{One of: \itemize{ \item \code{NULL} for no minor breaks @@ -79,6 +88,8 @@ notation. }} \item{na.value}{The linetype to use for \code{NA} values.} + +\item{aesthetics}{The names of the aesthetics that this scale works with.} } \description{ Default line types based on a set supplied by Richard Pearson, diff --git a/man/scale_linewidth.Rd b/man/scale_linewidth.Rd index 5c9a842da9..86e414a8a6 100644 --- a/man/scale_linewidth.Rd +++ b/man/scale_linewidth.Rd @@ -18,7 +18,8 @@ scale_linewidth( range = NULL, transform = "identity", trans = deprecated(), - guide = "legend" + guide = "legend", + aesthetics = "linewidth" ) scale_linewidth_binned( @@ -31,7 +32,8 @@ scale_linewidth_binned( nice.breaks = TRUE, transform = "identity", trans = deprecated(), - guide = "bins" + guide = "bins", + aesthetics = "linewidth" ) } \arguments{ @@ -99,6 +101,8 @@ You can create your own transformation with \code{\link[scales:new_transform]{sc \item{guide}{A function used to create a guide or its name. See \code{\link[=guides]{guides()}} for more information.} +\item{aesthetics}{The names of the aesthetics that this scale works with.} + \item{n.breaks}{An integer guiding the number of major breaks. The algorithm may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default diff --git a/man/scale_manual.Rd b/man/scale_manual.Rd index d49cd0f526..b2723888d4 100644 --- a/man/scale_manual.Rd +++ b/man/scale_manual.Rd @@ -28,15 +28,45 @@ scale_fill_manual( na.value = "grey50" ) -scale_size_manual(..., values, breaks = waiver(), na.value = NA) +scale_size_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "size" +) -scale_shape_manual(..., values, breaks = waiver(), na.value = NA) +scale_shape_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "shape" +) -scale_linetype_manual(..., values, breaks = waiver(), na.value = NA) +scale_linetype_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "linetype" +) -scale_linewidth_manual(..., values, breaks = waiver(), na.value = NA) +scale_linewidth_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "linewidth" +) -scale_alpha_manual(..., values, breaks = waiver(), na.value = NA) +scale_alpha_manual( + ..., + values, + breaks = waiver(), + na.value = NA, + aesthetics = "alpha" +) scale_discrete_manual(aesthetics, ..., values, breaks = waiver()) } diff --git a/man/scale_shape.Rd b/man/scale_shape.Rd index 4f90b5c0d6..64f831c75d 100644 --- a/man/scale_shape.Rd +++ b/man/scale_shape.Rd @@ -8,9 +8,9 @@ \alias{scale_shape_continuous} \title{Scales for shapes, aka glyphs} \usage{ -scale_shape(name = waiver(), ..., solid = NULL) +scale_shape(name = waiver(), ..., solid = NULL, aesthetics = "shape") -scale_shape_binned(name = waiver(), ..., solid = TRUE) +scale_shape_binned(name = waiver(), ..., solid = TRUE, aesthetics = "shape") } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -49,7 +49,6 @@ from a discrete scale, specify \code{na.translate = FALSE}.} \item{\code{na.value}}{If \code{na.translate = TRUE}, what aesthetic value should the missing values be displayed as? Does not apply to position scales where \code{NA} is always placed at the far right.} - \item{\code{aesthetics}}{The names of the aesthetics that this scale works with.} \item{\code{minor_breaks}}{One of: \itemize{ \item \code{NULL} for no minor breaks @@ -80,6 +79,8 @@ notation. \item{solid}{Should the shapes be solid, \code{TRUE}, or hollow, \code{FALSE}?} + +\item{aesthetics}{The names of the aesthetics that this scale works with.} } \description{ \code{scale_shape()} maps discrete variables to six easily discernible shapes. diff --git a/man/scale_size.Rd b/man/scale_size.Rd index 2ba6a1e295..028d5b8490 100644 --- a/man/scale_size.Rd +++ b/man/scale_size.Rd @@ -21,7 +21,8 @@ scale_size( range = NULL, transform = "identity", trans = deprecated(), - guide = "legend" + guide = "legend", + aesthetics = "size" ) scale_radius( @@ -32,7 +33,8 @@ scale_radius( range = c(1, 6), transform = "identity", trans = deprecated(), - guide = "legend" + guide = "legend", + aesthetics = "size" ) scale_size_binned( @@ -45,12 +47,13 @@ scale_size_binned( nice.breaks = TRUE, transform = "identity", trans = deprecated(), - guide = "bins" + guide = "bins", + aesthetics = "size" ) -scale_size_area(name = waiver(), ..., max_size = 6) +scale_size_area(name = waiver(), ..., max_size = 6, aesthetics = "size") -scale_size_binned_area(name = waiver(), ..., max_size = 6) +scale_size_binned_area(name = waiver(), ..., max_size = 6, aesthetics = "size") } \arguments{ \item{name}{The name of the scale. Used as the axis or legend title. If @@ -117,6 +120,8 @@ You can create your own transformation with \code{\link[scales:new_transform]{sc \item{guide}{A function used to create a guide or its name. See \code{\link[=guides]{guides()}} for more information.} +\item{aesthetics}{The names of the aesthetics that this scale works with.} + \item{n.breaks}{An integer guiding the number of major breaks. The algorithm may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default From 1b9ee73e55261f38060b441091d8280a87f81b1c Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 11:38:41 +0100 Subject: [PATCH 27/31] Encourage specifying `breaks` when giving labels as a vector (#6237) --- R/scale-.R | 4 +++- man/binned_scale.Rd | 4 +++- man/continuous_scale.Rd | 4 +++- man/datetime_scale.Rd | 4 +++- man/discrete_scale.Rd | 4 +++- man/scale_binned.Rd | 4 +++- man/scale_continuous.Rd | 4 +++- man/scale_date.Rd | 4 +++- man/scale_discrete.Rd | 4 +++- man/scale_gradient.Rd | 4 +++- man/scale_grey.Rd | 4 +++- man/scale_hue.Rd | 4 +++- man/scale_linetype.Rd | 4 +++- man/scale_linewidth.Rd | 4 +++- man/scale_manual.Rd | 4 +++- man/scale_shape.Rd | 4 +++- man/scale_size.Rd | 4 +++- man/scale_steps.Rd | 4 +++- 18 files changed, 54 insertions(+), 18 deletions(-) diff --git a/R/scale-.R b/R/scale-.R index f6e42a7e1e..7cae5da74b 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -34,7 +34,9 @@ #' may choose a slightly different number to ensure nice break labels. Will #' only have an effect if `breaks = waiver()`. Use `NULL` to use the default #' number of breaks given by the transformation. -#' @param labels One of: +#' @param labels One of the options below. Please note that when `labels` is a +#' vector, it is highly recommended to also set the `breaks` argument as a +#' vector to protect against unintended mismatches. #' - `NULL` for no labels #' - `waiver()` for the default labels computed by the #' transformation object diff --git a/man/binned_scale.Rd b/man/binned_scale.Rd index c1bbd50404..203cd66bb4 100644 --- a/man/binned_scale.Rd +++ b/man/binned_scale.Rd @@ -55,7 +55,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/continuous_scale.Rd b/man/continuous_scale.Rd index a572ec2bf7..76d7492ba6 100644 --- a/man/continuous_scale.Rd +++ b/man/continuous_scale.Rd @@ -70,7 +70,9 @@ may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default number of breaks given by the transformation.} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/datetime_scale.Rd b/man/datetime_scale.Rd index d0a1afeec2..c843dc0706 100644 --- a/man/datetime_scale.Rd +++ b/man/datetime_scale.Rd @@ -61,7 +61,9 @@ values between 0 and 1 returns the corresponding output values output }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/discrete_scale.Rd b/man/discrete_scale.Rd index ae349cdf1f..cf76226a67 100644 --- a/man/discrete_scale.Rd +++ b/man/discrete_scale.Rd @@ -60,7 +60,9 @@ the function has two arguments, it will be given the limits and major break positions. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_binned.Rd b/man/scale_binned.Rd index ad98d61969..f75f8a16f9 100644 --- a/man/scale_binned.Rd +++ b/man/scale_binned.Rd @@ -68,7 +68,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_continuous.Rd b/man/scale_continuous.Rd index 153bb325f5..5fa4a0fb44 100644 --- a/man/scale_continuous.Rd +++ b/man/scale_continuous.Rd @@ -92,7 +92,9 @@ may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default number of breaks given by the transformation.} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_date.Rd b/man/scale_date.Rd index 86c82e0271..bce3946d9a 100644 --- a/man/scale_date.Rd +++ b/man/scale_date.Rd @@ -122,7 +122,9 @@ weeks", or "10 years". If both \code{breaks} and \code{date_breaks} are specified, \code{date_breaks} wins. Valid specifications are 'sec', 'min', 'hour', 'day', 'week', 'month' or 'year', optionally followed by 's'.} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_discrete.Rd b/man/scale_discrete.Rd index 19e1df99fb..d6a3b99378 100644 --- a/man/scale_discrete.Rd +++ b/man/scale_discrete.Rd @@ -76,7 +76,9 @@ accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major break positions. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_gradient.Rd b/man/scale_gradient.Rd index 619e71f3ef..6d0b5c8c15 100644 --- a/man/scale_gradient.Rd +++ b/man/scale_gradient.Rd @@ -129,7 +129,9 @@ break positions. may choose a slightly different number to ensure nice break labels. Will only have an effect if \code{breaks = waiver()}. Use \code{NULL} to use the default number of breaks given by the transformation.} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_grey.Rd b/man/scale_grey.Rd index 0ee97a15de..9d838508dc 100644 --- a/man/scale_grey.Rd +++ b/man/scale_grey.Rd @@ -69,7 +69,9 @@ accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major break positions. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_hue.Rd b/man/scale_hue.Rd index 1280e741bb..0a0aba8fcd 100644 --- a/man/scale_hue.Rd +++ b/man/scale_hue.Rd @@ -75,7 +75,9 @@ accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major break positions. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_linetype.Rd b/man/scale_linetype.Rd index 5707bd9f90..d0b2fb9349 100644 --- a/man/scale_linetype.Rd +++ b/man/scale_linetype.Rd @@ -70,7 +70,9 @@ accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major break positions. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_linewidth.Rd b/man/scale_linewidth.Rd index 86e414a8a6..2efb7378d3 100644 --- a/man/scale_linewidth.Rd +++ b/man/scale_linewidth.Rd @@ -54,7 +54,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_manual.Rd b/man/scale_manual.Rd index b2723888d4..75677d54d0 100644 --- a/man/scale_manual.Rd +++ b/man/scale_manual.Rd @@ -105,7 +105,9 @@ accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major break positions. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_shape.Rd b/man/scale_shape.Rd index 64f831c75d..4ec9ba9894 100644 --- a/man/scale_shape.Rd +++ b/man/scale_shape.Rd @@ -60,7 +60,9 @@ accepts rlang \link[rlang:as_function]{lambda} function notation. When the function has two arguments, it will be given the limits and major break positions. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_size.Rd b/man/scale_size.Rd index 028d5b8490..0756ed4483 100644 --- a/man/scale_size.Rd +++ b/man/scale_size.Rd @@ -73,7 +73,9 @@ Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} -\item{labels}{One of: +\item{labels}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the diff --git a/man/scale_steps.Rd b/man/scale_steps.Rd index 1206c159f9..9f6740a561 100644 --- a/man/scale_steps.Rd +++ b/man/scale_steps.Rd @@ -129,7 +129,9 @@ as output (e.g., a function returned by \code{\link[scales:breaks_extended]{scal Note that for position scales, limits are provided after scale expansion. Also accepts rlang \link[rlang:as_function]{lambda} function notation. }} - \item{\code{labels}}{One of: + \item{\code{labels}}{One of the options below. Please note that when \code{labels} is a +vector, it is highly recommended to also set the \code{breaks} argument as a +vector to protect against unintended mismatches. \itemize{ \item \code{NULL} for no labels \item \code{waiver()} for the default labels computed by the From f8d98257fff4e71cb93494db5ca11573779e5c2f Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 12:05:38 +0100 Subject: [PATCH 28/31] Deprecate `fatten` (#6238) * deprecate fatten * `fatten` isn't a formal argument to `geom_boxplot()` * document * add news bullet --- NEWS.md | 2 ++ R/geom-boxplot.R | 9 +++++++++ R/geom-crossbar.R | 11 ++++++++++- R/geom-linerange.R | 6 +++--- R/geom-pointrange.R | 8 +++++++- man/geom_linerange.Rd | 10 +++++----- 6 files changed, 36 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index c0f7809db6..d8167c66c9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* The `fatten` argument has been deprecated in `geom_boxplot()`, + `geom_crossbar()` and `geom_pointrange()` (@teunbrand, #4881). * Axis labels are now preserved better when using `coord_sf(expand = TRUE)` and graticule lines are straight but do not meet the edge (@teunbrand, #2985). * Attempt to boost detail in `coord_polar()` and `coord_radial()` near the diff --git a/R/geom-boxplot.R b/R/geom-boxplot.R index edd6117538..96c6ed9d35 100644 --- a/R/geom-boxplot.R +++ b/R/geom-boxplot.R @@ -239,6 +239,15 @@ GeomBoxplot <- ggproto("GeomBoxplot", Geom, extra_params = c("na.rm", "orientation", "outliers"), setup_params = function(data, params) { + if ("fatten" %in% names(params)) { + deprecate_soft0( + "3.6.0", "geom_boxplot(fatten)", + "geom_boxplot(median.linewidth)" + ) + } else { + # For backward compatibility reasons + params$fatten <- 2 + } params$flipped_aes <- has_flipped_aes(data, params) params }, diff --git a/R/geom-crossbar.R b/R/geom-crossbar.R index 7316033de6..8f9d8ccd74 100644 --- a/R/geom-crossbar.R +++ b/R/geom-crossbar.R @@ -17,7 +17,7 @@ geom_crossbar <- function(mapping = NULL, data = NULL, box.color = NULL, box.linetype = NULL, box.linewidth = NULL, - fatten = 2.5, + fatten = deprecated(), na.rm = FALSE, orientation = NA, show.legend = NA, @@ -60,6 +60,15 @@ geom_crossbar <- function(mapping = NULL, data = NULL, #' @export GeomCrossbar <- ggproto("GeomCrossbar", Geom, setup_params = function(data, params) { + if (lifecycle::is_present(params$fatten)) { + deprecate_soft0( + "3.6.0", "geom_crossbar(fatten)", + "geom_crossbar(middle.linewidth)" + ) + } else { + # For backward compatibility reasons + params$fatten <- 2.5 + } GeomErrorbar$setup_params(data, params) }, diff --git a/R/geom-linerange.R b/R/geom-linerange.R index 085d8f98a9..71c0799971 100644 --- a/R/geom-linerange.R +++ b/R/geom-linerange.R @@ -6,9 +6,9 @@ #' @eval rd_orientation() #' #' @eval rd_aesthetics("geom", "linerange", "Note that `geom_pointrange()` also understands `size` for the size of the points.") -#' @param fatten A multiplicative factor used to increase the size of the -#' middle bar in `geom_crossbar()` and the middle point in -#' `geom_pointrange()`. +#' @param fatten `r lifecycle::badge("deprecated")` A multiplicative factor +#' used to increase the size of the middle bar in `geom_crossbar()` and the +#' middle point in `geom_pointrange()`. #' @seealso #' [stat_summary()] for examples of these guys in use, #' [geom_smooth()] for continuous analogue diff --git a/R/geom-pointrange.R b/R/geom-pointrange.R index d0e5194311..1943bb4f4c 100644 --- a/R/geom-pointrange.R +++ b/R/geom-pointrange.R @@ -3,7 +3,7 @@ geom_pointrange <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., - fatten = 4, + fatten = deprecated(), na.rm = FALSE, orientation = NA, show.legend = NA, @@ -42,6 +42,12 @@ GeomPointrange <- ggproto("GeomPointrange", Geom, required_aes = c("x", "y", "ymin|xmin", "ymax|xmax"), setup_params = function(data, params) { + if (lifecycle::is_present(params$fatten)) { + deprecate_soft0("3.6.0", "geom_pointrange(fatten)", I("the `size` aesthetic")) + } else { + # For backward compatibility reasons + params$fatten <- 4 + } GeomLinerange$setup_params(data, params) }, diff --git a/man/geom_linerange.Rd b/man/geom_linerange.Rd index 93f340656e..0c77084236 100644 --- a/man/geom_linerange.Rd +++ b/man/geom_linerange.Rd @@ -23,7 +23,7 @@ geom_crossbar( box.color = NULL, box.linetype = NULL, box.linewidth = NULL, - fatten = 2.5, + fatten = deprecated(), na.rm = FALSE, orientation = NA, show.legend = NA, @@ -72,7 +72,7 @@ geom_pointrange( stat = "identity", position = "identity", ..., - fatten = 4, + fatten = deprecated(), na.rm = FALSE, orientation = NA, show.legend = NA, @@ -160,9 +160,9 @@ data's aesthetics.} \item{box.colour, box.color, box.linetype, box.linewidth}{Default aesthetics for the boxes. Set to \code{NULL} to inherit from the data's aesthetics.} -\item{fatten}{A multiplicative factor used to increase the size of the -middle bar in \code{geom_crossbar()} and the middle point in -\code{geom_pointrange()}.} +\item{fatten}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} A multiplicative factor +used to increase the size of the middle bar in \code{geom_crossbar()} and the +middle point in \code{geom_pointrange()}.} \item{na.rm}{If \code{FALSE}, the default, missing values are removed with a warning. If \code{TRUE}, missing values are silently removed.} From 12d1c98fd4efd60f05d0e50409c2244c701255b9 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 12:06:11 +0100 Subject: [PATCH 29/31] Document guide theme argument (#6268) * mention ignored arguments * No need to fuss over these specifics with axes * document --- R/guide-axis.R | 3 +++ R/guide-legend.R | 6 +++++- man/guide_axis.Rd | 2 +- man/guide_axis_logticks.Rd | 2 +- man/guide_axis_stack.Rd | 2 +- man/guide_axis_theta.Rd | 2 +- man/guide_bins.Rd | 6 +++++- man/guide_colourbar.Rd | 6 +++++- man/guide_coloursteps.Rd | 6 +++++- man/guide_custom.Rd | 6 +++++- man/guide_legend.Rd | 6 +++++- 11 files changed, 37 insertions(+), 10 deletions(-) diff --git a/R/guide-axis.R b/R/guide-axis.R index 70ac3da43f..d445900071 100644 --- a/R/guide-axis.R +++ b/R/guide-axis.R @@ -6,6 +6,9 @@ #' [scale_(x|y)_discrete()][scale_x_discrete()]. #' #' @inheritParams guide_legend +#' @param theme A [`theme`][theme()] object to style the guide individually or +#' differently from the plot's theme settings. The `theme` argument in the +#' guide partially overrides, and is combined with, the plot's theme. #' @param check.overlap silently remove overlapping labels, #' (recursively) prioritizing the first, last, and middle labels. #' @param angle Compared to setting the angle in [theme()] / [element_text()], diff --git a/R/guide-legend.R b/R/guide-legend.R index 9355ae5a70..b875fa1950 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -15,7 +15,11 @@ #' specified in [labs()] is used for the title. #' @param theme A [`theme`][theme()] object to style the guide individually or #' differently from the plot's theme settings. The `theme` argument in the -#' guide overrides, and is combined with, the plot's theme. +#' guide partially overrides, and is combined with, the plot's theme. +#' Arguments that apply to a single legend are respected, most of which have +#' the `legend`-prefix. Arguments that apply to combined legends +#' (the legend box) are ignored, including `legend.position`, +#' `legend.justification.*`, `legend.location` and `legend.box.*`. #' @param position A character string indicating where the legend should be #' placed relative to the plot panels. #' @param direction A character string indicating the direction of the guide. diff --git a/man/guide_axis.Rd b/man/guide_axis.Rd index 4d4ba4f166..baf05cebe6 100644 --- a/man/guide_axis.Rd +++ b/man/guide_axis.Rd @@ -24,7 +24,7 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{check.overlap}{silently remove overlapping labels, (recursively) prioritizing the first, last, and middle labels.} diff --git a/man/guide_axis_logticks.Rd b/man/guide_axis_logticks.Rd index b6f7d55737..7398f24890 100644 --- a/man/guide_axis_logticks.Rd +++ b/man/guide_axis_logticks.Rd @@ -51,7 +51,7 @@ and \code{FALSE} are shorthand for \code{"both"} and \code{"none"} respectively. \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{prescale_base, negative_small, short_theme}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} diff --git a/man/guide_axis_stack.Rd b/man/guide_axis_stack.Rd index 4a18fc3fdb..542f4eb44b 100644 --- a/man/guide_axis_stack.Rd +++ b/man/guide_axis_stack.Rd @@ -30,7 +30,7 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{spacing}{A \code{\link[=unit]{unit()}} objects that determines how far separate guides are spaced apart.} diff --git a/man/guide_axis_theta.Rd b/man/guide_axis_theta.Rd index 6e18e57a60..79f4b61cad 100644 --- a/man/guide_axis_theta.Rd +++ b/man/guide_axis_theta.Rd @@ -22,7 +22,7 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme.} \item{angle}{Compared to setting the angle in \code{\link[=theme]{theme()}} / \code{\link[=element_text]{element_text()}}, this also uses some heuristics to automatically pick the \code{hjust} and \code{vjust} that diff --git a/man/guide_bins.Rd b/man/guide_bins.Rd index 8ee5311445..d9fd873cdb 100644 --- a/man/guide_bins.Rd +++ b/man/guide_bins.Rd @@ -25,7 +25,11 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{angle}{Overrules the theme settings to automatically apply appropriate \code{hjust} and \code{vjust} for angled legend text. Can be a single number diff --git a/man/guide_colourbar.Rd b/man/guide_colourbar.Rd index 9a441f39cc..95546aa21c 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -49,7 +49,11 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{nbin}{A numeric specifying the number of bins for drawing the colourbar. A smoother colourbar results from a larger value.} diff --git a/man/guide_coloursteps.Rd b/man/guide_coloursteps.Rd index 5bec4a8d73..dc5806929a 100644 --- a/man/guide_coloursteps.Rd +++ b/man/guide_coloursteps.Rd @@ -43,7 +43,11 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{alpha}{A numeric between 0 and 1 setting the colour transparency of the bar. Use \code{NA} to preserve the alpha encoded in the colour itself diff --git a/man/guide_custom.Rd b/man/guide_custom.Rd index 74c8a9f00a..f13559cae2 100644 --- a/man/guide_custom.Rd +++ b/man/guide_custom.Rd @@ -25,7 +25,11 @@ If \code{NULL} (default), no title is shown.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{position}{A character string indicating where the legend should be placed relative to the plot panels.} diff --git a/man/guide_legend.Rd b/man/guide_legend.Rd index 67465c9877..366005c99f 100644 --- a/man/guide_legend.Rd +++ b/man/guide_legend.Rd @@ -25,7 +25,11 @@ specified in \code{\link[=labs]{labs()}} is used for the title.} \item{theme}{A \code{\link[=theme]{theme}} object to style the guide individually or differently from the plot's theme settings. The \code{theme} argument in the -guide overrides, and is combined with, the plot's theme.} +guide partially overrides, and is combined with, the plot's theme. +Arguments that apply to a single legend are respected, most of which have +the \code{legend}-prefix. Arguments that apply to combined legends +(the legend box) are ignored, including \code{legend.position}, +\verb{legend.justification.*}, \code{legend.location} and \verb{legend.box.*}.} \item{position}{A character string indicating where the legend should be placed relative to the plot panels.} From 09776db1488a85f370b0203b20e64fea660ef11d Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 12:44:13 +0100 Subject: [PATCH 30/31] =?UTF-8?q?=F0=9F=90=9B=20Deal=20with=20empty=20radi?= =?UTF-8?q?al=20axes=20=20(#6272)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Avoid assigning NULL to list, thereby deleting the element * protect theta guide better against empty keys * add test * add news bullet * Fix partial match * fix another partial match --- NEWS.md | 2 ++ R/coord-radial.R | 40 ++++++++++++++++++------------- R/guide-axis-theta.R | 26 +++++++++++--------- R/guides-.R | 6 ++--- tests/testthat/test-coord-polar.R | 12 ++++++++++ 5 files changed, 56 insertions(+), 30 deletions(-) diff --git a/NEWS.md b/NEWS.md index d8167c66c9..3090a3fa3b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # ggplot2 (development version) +* `coord_radial()` now displays no axis instead of throwing an error when + a scale has no breaks (@teunbrand, #6271). * The `fatten` argument has been deprecated in `geom_boxplot()`, `geom_crossbar()` and `geom_pointrange()` (@teunbrand, #4881). * Axis labels are now preserved better when using `coord_sf(expand = TRUE)` and diff --git a/R/coord-radial.R b/R/coord-radial.R index ef6130fb34..bc933ea1d7 100644 --- a/R/coord-radial.R +++ b/R/coord-radial.R @@ -250,11 +250,18 @@ CoordRadial <- ggproto("CoordRadial", Coord, names(gdefs) <- aesthetics # Train theta guide - for (t in intersect(c("theta", "theta.sec"), aesthetics[!empty])) { - gdefs[[t]] <- guides[[t]]$train(gdefs[[t]], panel_params[[t]]) - gdefs[[t]] <- guides[[t]]$transform(gdefs[[t]], self, panel_params) - gdefs[[t]] <- guides[[t]]$get_layer_key(gdefs[[t]], layers) - } + t <- intersect(c("theta", "theta.sec"), aesthetics[!empty]) + gdefs[t] <- Map( + function(guide, guide_param, scale) { + guide_param$theme_suffix <- "theta" + guide_param <- guide$train(guide_param, scale) + guide_param <- guide$transform(guide_param, self, panel_params) + guide_param <- guide$get_layer_key(guide_param, layers) + }, + guide = guides[t], + guide_param = gdefs[t], + scale = panel_params[t] + ) if (!isFALSE(self$r_axis_inside)) { # For radial axis, we need to pretend that rotation starts at 0 and @@ -269,17 +276,18 @@ CoordRadial <- ggproto("CoordRadial", Coord, temp <- modify_list(panel_params, mod) # Train radial guide - for (r in intersect(c("r", "r.sec"), aesthetics[!empty])) { - gdefs[[r]] <- guides[[r]]$train(gdefs[[r]], panel_params[[r]]) - gdefs[[r]] <- guides[[r]]$transform(gdefs[[r]], self, temp) # Use temp - gdefs[[r]] <- guides[[r]]$get_layer_key(gdefs[[r]], layers) - } - - # Set theme suffixes - gdefs$theta$theme_suffix <- "theta" - gdefs$theta.sec$theme_suffix <- "theta" - gdefs$r$theme_suffix <- "r" - gdefs$r.sec$theme_suffix <- "r" + r <- intersect(c("r", "r.sec"), aesthetics[!empty]) + gdefs[r] <- Map( + function(guide, guide_param, scale) { + guide_param$theme_suffix <- "r" + guide_param <- guide$train(guide_param, scale) + guide_param <- guide$transform(guide_param, self, temp) + guide_param <- guide$get_layer_key(guide_param, layers) + }, + guide = guides[r], + guide_param = gdefs[r], + scale = panel_params[r] + ) panel_params$guides$update_params(gdefs) panel_params diff --git a/R/guide-axis-theta.R b/R/guide-axis-theta.R index 7f4c3c9246..af96a337b6 100644 --- a/R/guide-axis-theta.R +++ b/R/guide-axis-theta.R @@ -63,22 +63,26 @@ GuideAxisTheta <- ggproto( transform = function(params, coord, panel_params) { - opposite_var <- setdiff(c("x", "y"), params$aesthetic) - opposite_value <- switch(params$position, top = , right = , theta.sec = -Inf, Inf) - if (is.unsorted(panel_params$inner_radius %||% NA)) { - opposite_value <- -opposite_value - } - if (nrow(params$key) > 0) { - params$key[[opposite_var]] <- opposite_value - } - if (nrow(params$decor) > 0) { - params$decor[[opposite_var]] <- opposite_value + position <- params$position + + if (!is.null(position)) { + opposite_var <- setdiff(c("x", "y"), params$aesthetic) + opposite_value <- switch(position, top = , right = , theta.sec = -Inf, Inf) + if (is.unsorted(panel_params$inner_radius %||% NA)) { + opposite_value <- -opposite_value + } + if (nrow(params$key) > 0) { + params$key[[opposite_var]] <- opposite_value + } + if (nrow(params$decor) > 0) { + params$decor[[opposite_var]] <- opposite_value + } } params <- GuideAxis$transform(params, coord, panel_params) key <- params$key - n <- nrow(key) + n <- vec_size(key) if (n < 1) { return(params) } diff --git a/R/guides-.R b/R/guides-.R index 63a17cc430..3ea09c7104 100644 --- a/R/guides-.R +++ b/R/guides-.R @@ -525,7 +525,7 @@ Guides <- ggproto( coord <- coord %||% default_inside_position %||% just groups$justs[[i]] <- just - groups$coord[[i]] <- coord + groups$coords[[i]] <- coord } groups <- vec_group_loc(vec_slice(groups, keep)) @@ -540,10 +540,10 @@ Guides <- ggproto( # prepare output for (i in vec_seq_along(groups)) { adjust <- NULL - position <- groups$key$position[i] + position <- groups$key$positions[i] if (position == "inside") { adjust <- theme( - legend.position.inside = groups$key$coord[[i]], + legend.position.inside = groups$key$coords[[i]], legend.justification.inside = groups$key$justs[[i]] ) } diff --git a/tests/testthat/test-coord-polar.R b/tests/testthat/test-coord-polar.R index 1f662d2322..466162b0f5 100644 --- a/tests/testthat/test-coord-polar.R +++ b/tests/testthat/test-coord-polar.R @@ -197,6 +197,18 @@ test_that("radial coords can be reversed", { expect_equal(as.numeric(fwd$y), rev(as.numeric(rev$y))) }) +test_that("coord_radial can deal with empty breaks (#6271)", { + p <- ggplot_build( + ggplot(mtcars, aes(mpg, disp)) + + geom_point() + + coord_radial() + + scale_x_continuous(breaks = numeric()) + + scale_y_continuous(breaks = numeric()) + ) + guides <- p$layout$panel_params[[1]]$guides$guides + is_none <- vapply(guides, inherits, logical(1), what = "GuideNone") + expect_true(all(is_none)) +}) # Visual tests ------------------------------------------------------------ From b9d1c79da0f59405ffef2279ebe44b18a8dad697 Mon Sep 17 00:00:00 2001 From: Teun van den Brand <49372158+teunbrand@users.noreply.github.com> Date: Tue, 28 Jan 2025 12:44:59 +0100 Subject: [PATCH 31/31] =?UTF-8?q?=E2=9C=A8=20Justification=20for=20legend?= =?UTF-8?q?=20keys=20(#6279)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * combine glyph layers into a single key earlier * new `key.justification` theme element * apply key justification * add test * add news bullet --- NEWS.md | 2 + R/guide-legend.R | 54 +++++-- R/theme-elements.R | 1 + R/theme.R | 5 + man/theme.Rd | 6 + .../guide-legend/legend-key-justification.svg | 136 ++++++++++++++++++ tests/testthat/test-guide-legend.R | 16 +++ 7 files changed, 205 insertions(+), 15 deletions(-) create mode 100644 tests/testthat/_snaps/guide-legend/legend-key-justification.svg diff --git a/NEWS.md b/NEWS.md index 3090a3fa3b..d38fbc670d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -292,6 +292,8 @@ particularly for data-points with a low radius near the center (@teunbrand, #5023). * All scales now expose the `aesthetics` parameter (@teunbrand, #5841) +* New `theme(legend.key.justification)` to control the alignment of legend keys + (@teunbrand, #3669). # ggplot2 3.5.1 diff --git a/R/guide-legend.R b/R/guide-legend.R index b875fa1950..c8bf395f0a 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -178,6 +178,7 @@ GuideLegend <- ggproto( key = "legend.key", key_height = "legend.key.height", key_width = "legend.key.width", + key_just = "legend.key.justification", text = "legend.text", theme.title = "legend.title", spacing_x = "legend.key.spacing.x", @@ -275,7 +276,6 @@ GuideLegend <- ggproto( c("horizontal", "vertical"), arg_nm = "direction" ) params$n_breaks <- n_breaks <- nrow(params$key) - params$n_key_layers <- length(params$decor) + 1 # +1 is key background # Resolve shape if (!is.null(params$nrow) && !is.null(params$ncol) && @@ -378,6 +378,9 @@ GuideLegend <- ggproto( elements$key <- ggname("legend.key", element_grob(elements$key)) } + if (!is.null(elements$key_just)) { + elements$key_just <- valid.just(elements$key_just) + } elements$text <- label_angle_heuristic(elements$text, elements$text_position, params$angle) @@ -391,22 +394,39 @@ GuideLegend <- ggproto( build_decor = function(decor, grobs, elements, params) { - key_size <- c(elements$width_cm, elements$height_cm) * 10 - - draw <- function(i) { - bg <- elements$key - keys <- lapply(decor, function(g) { - data <- vec_slice(g$data, i) - if (data$.draw %||% TRUE) { - key <- g$draw_key(data, g$params, key_size) - set_key_size(key, data$linewidth, data$size, key_size / 10) - } else { - zeroGrob() + key_size <- c(elements$width_cm, elements$height_cm) + just <- elements$key_just + idx <- seq_len(params$n_breaks) + + key_glyphs <- lapply(idx, function(i) { + glyph <- lapply(decor, function(dec) { + data <- vec_slice(dec$data, i) + if (!(data$.draw %||% TRUE)) { + return(zeroGrob()) } + key <- dec$draw_key(data, dec$params, key_size * 10) + set_key_size(key, data$linewidth, data$size, key_size) }) - c(list(bg), keys) - } - unlist(lapply(seq_len(params$n_breaks), draw), FALSE) + + width <- vapply(glyph, get_attr, which = "width", default = 0, numeric(1)) + width <- max(width, 0, key_size[1], na.rm = TRUE) + height <- vapply(glyph, get_attr, which = "height", default = 0, numeric(1)) + height <- max(height, 0, key_size[2], na.rm = TRUE) + + vp <- NULL + if (!is.null(just)) { + vp <- viewport( + x = just[1], y = just[2], just = just, + width = unit(width, "cm"), height = unit(height, "cm") + ) + } + + grob <- gTree(children = inject(gList(elements$key, !!!glyph)), vp = vp) + attr(grob, "width") <- width + attr(grob, "height") <- height + grob + }) + key_glyphs }, build_labels = function(key, elements, params) { @@ -795,3 +815,7 @@ deprecated_guide_args <- function( } theme } + +get_attr <- function(x, which, exact = TRUE, default = NULL) { + attr(x, which = which, exact = exact) %||% default +} diff --git a/R/theme-elements.R b/R/theme-elements.R index b83822ed3a..833da1b192 100644 --- a/R/theme-elements.R +++ b/R/theme-elements.R @@ -625,6 +625,7 @@ el_def <- function(class = NULL, inherit = NULL, description = NULL) { legend.key.spacing = el_def(c("unit", "rel"), "spacing"), legend.key.spacing.x = el_def(c("unit", "rel"), "legend.key.spacing"), legend.key.spacing.y = el_def(c("unit", "rel"), "legend.key.spacing"), + legend.key.justification = el_def(c("character", "numeric", "integer")), legend.frame = el_def("element_rect", "rect"), legend.axis.line = el_def("element_line", "line"), legend.ticks = el_def("element_line", "legend.axis.line"), diff --git a/R/theme.R b/R/theme.R index cb7859dfe2..bf65c565a9 100644 --- a/R/theme.R +++ b/R/theme.R @@ -84,6 +84,10 @@ #' between legend keys given as a `unit`. Spacing in the horizontal (x) and #' vertical (y) direction inherit from `legend.key.spacing` or can be #' specified separately. `legend.key.spacing` inherits from `spacing`. +#' @param legend.key.justification Justification for positioning legend keys +#' when more space is available than needed for display. The default, `NULL`, +#' stretches keys into the available space. Can be a location like `"center"` +#' or `"top"`, or a two-element numeric vector. #' @param legend.frame frame drawn around the bar ([element_rect()]). #' @param legend.ticks tick marks shown along bars or axes ([element_line()]) #' @param legend.ticks.length length of tick marks in legend @@ -393,6 +397,7 @@ theme <- function(..., legend.key.spacing, legend.key.spacing.x, legend.key.spacing.y, + legend.key.justification, legend.frame, legend.ticks, legend.ticks.length, diff --git a/man/theme.Rd b/man/theme.Rd index 51f92e1f96..0a4941266e 100644 --- a/man/theme.Rd +++ b/man/theme.Rd @@ -84,6 +84,7 @@ theme( legend.key.spacing, legend.key.spacing.x, legend.key.spacing.y, + legend.key.justification, legend.frame, legend.ticks, legend.ticks.length, @@ -229,6 +230,11 @@ between legend keys given as a \code{unit}. Spacing in the horizontal (x) and vertical (y) direction inherit from \code{legend.key.spacing} or can be specified separately. \code{legend.key.spacing} inherits from \code{spacing}.} +\item{legend.key.justification}{Justification for positioning legend keys +when more space is available than needed for display. The default, \code{NULL}, +stretches keys into the available space. Can be a location like \code{"center"} +or \code{"top"}, or a two-element numeric vector.} + \item{legend.frame}{frame drawn around the bar (\code{\link[=element_rect]{element_rect()}}).} \item{legend.ticks}{tick marks shown along bars or axes (\code{\link[=element_line]{element_line()}})} diff --git a/tests/testthat/_snaps/guide-legend/legend-key-justification.svg b/tests/testthat/_snaps/guide-legend/legend-key-justification.svg new file mode 100644 index 0000000000..25880c7d29 --- /dev/null +++ b/tests/testthat/_snaps/guide-legend/legend-key-justification.svg @@ -0,0 +1,136 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 +400 + + + + + + + + + + +10 +15 +20 +25 +30 +35 +mpg +disp + +drat + + + + + + +3 +4 +5 + +factor(cyl) + + + + + + +one line +up +to +four +lines +up +to +five +whole +lines +legend key justification + + diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R index d4a47c145e..c68ab03297 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -212,3 +212,19 @@ test_that("legend.byrow works in `guide_legend()`", { expect_doppelganger("legend.byrow = TRUE", p) }) +test_that("legend.key.justification works as intended", { + + p <- ggplot(mtcars, aes(mpg, disp, colour = factor(cyl), size = drat)) + + geom_point() + + scale_size_continuous( + range = c(0, 20), breaks = c(3, 4, 5), limits = c(2.5, 5) + ) + + scale_colour_discrete( + labels = c("one line", "up\nto\nfour\nlines", "up\nto\nfive\nwhole\nlines") + ) + + theme(legend.key.justification = c(1, 0)) + + expect_doppelganger("legend key justification", p) + +}) +