From cce1e8f01f20028a9ee6cc80889f6d2990bd6cba Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 10:50:19 +0100 Subject: [PATCH 01/78] remove vestigial `aaa-.R` --- DESCRIPTION | 5 ++--- R/aaa-.R | 14 -------------- R/all-classes.R | 4 ++++ R/axis-secondary.R | 2 +- man/ggplot2-ggproto.Rd | 17 ----------------- 5 files changed, 7 insertions(+), 35 deletions(-) delete mode 100644 R/aaa-.R delete mode 100644 man/ggplot2-ggproto.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 254a6bcea2..d01559f86f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -86,14 +86,13 @@ LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 Collate: - 'ggproto.R' - 'ggplot-global.R' - 'aaa-.R' 'aes-colour-fill-alpha.R' 'aes-evaluation.R' 'aes-group-order.R' 'aes-linetype-size-shape.R' 'aes-position.R' + 'ggplot-global.R' + 'ggproto.R' 'all-classes.R' 'compat-plyr.R' 'utilities.R' diff --git a/R/aaa-.R b/R/aaa-.R deleted file mode 100644 index d8666f75d7..0000000000 --- a/R/aaa-.R +++ /dev/null @@ -1,14 +0,0 @@ -#' @include ggplot-global.R -#' @include ggproto.R -NULL - -#' Base ggproto classes for ggplot2 -#' -#' If you are creating a new geom, stat, position, or scale in another package, -#' you'll need to extend from `ggplot2::Geom`, `ggplot2::Stat`, -#' `ggplot2::Position`, or `ggplot2::Scale`. -#' -#' @seealso ggproto -#' @keywords internal -#' @name ggplot2-ggproto -NULL diff --git a/R/all-classes.R b/R/all-classes.R index 9f0f0ad44c..8a10585e6e 100644 --- a/R/all-classes.R +++ b/R/all-classes.R @@ -1,3 +1,7 @@ +#' @include ggproto.R +#' @include ggplot-global.R +NULL + # Docs ------------------------------------------------------------- #' Class definitions diff --git a/R/axis-secondary.R b/R/axis-secondary.R index d694cf3a47..1d70542150 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -153,7 +153,7 @@ derive <- function() { is_derived <- function(x) { inherits(x, "derived") } -#' @rdname ggplot2-ggproto +#' @noRd #' @format NULL #' @usage NULL #' @export diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd deleted file mode 100644 index d608a38c55..0000000000 --- a/man/ggplot2-ggproto.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aaa-.R, R/axis-secondary.R -\docType{data} -\name{ggplot2-ggproto} -\alias{ggplot2-ggproto} -\alias{AxisSecondary} -\title{Base ggproto classes for ggplot2} -\description{ -If you are creating a new geom, stat, position, or scale in another package, -you'll need to extend from \code{ggplot2::Geom}, \code{ggplot2::Stat}, -\code{ggplot2::Position}, or \code{ggplot2::Scale}. -} -\seealso{ -ggproto -} -\keyword{datasets} -\keyword{internal} From 52090f8f329ab1a2861035fee4245e0f6c17170e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 10:53:35 +0100 Subject: [PATCH 02/78] collect all `aes-X.R` docs in single file --- R/aes-colour-fill-alpha.R | 112 ---------- R/aes-group-order.R | 89 -------- R/aes-linetype-size-shape.R | 96 --------- R/aes-position.R | 99 --------- R/docs-aes.R | 399 ++++++++++++++++++++++++++++++++++++ 5 files changed, 399 insertions(+), 396 deletions(-) delete mode 100644 R/aes-colour-fill-alpha.R delete mode 100644 R/aes-group-order.R delete mode 100644 R/aes-linetype-size-shape.R delete mode 100644 R/aes-position.R create mode 100644 R/docs-aes.R diff --git a/R/aes-colour-fill-alpha.R b/R/aes-colour-fill-alpha.R deleted file mode 100644 index 90958d8e78..0000000000 --- a/R/aes-colour-fill-alpha.R +++ /dev/null @@ -1,112 +0,0 @@ -#' Colour related aesthetics: colour, fill, and alpha -#' -#' These aesthetics parameters change the colour (`colour` and `fill`) and the -#' opacity (`alpha`) of geom elements on a plot. Almost every geom has either -#' colour or fill (or both), as well as can have their alpha modified. -#' Modifying colour on a plot is a useful way to enhance the presentation of data, -#' often especially when a plot graphs more than two variables. -#' -#' @section Colour and fill: -#' -#' The `colour` aesthetic is used to draw lines and strokes, such as in -#' [`geom_point()`] and [`geom_line()`], but also the line contours of -#' [`geom_rect()`] and [`geom_polygon()`]. The `fill` aesthetic is used to -#' colour the inside areas of geoms, such as [`geom_rect()`] and -#' [`geom_polygon()`], but also the insides of shapes 21-25 of [`geom_point()`]. -#' -#' Colours and fills can be specified in the following ways: -#' * A name, e.g., `"red"`. R has 657 built-in named colours, which can be -#' listed with [grDevices::colors()]. -#' * An rgb specification, with a string of the form `"#RRGGBB"` where each of the -#' pairs `RR`, `GG`, `BB` consists of two hexadecimal digits giving a value in the -#' range `00` to `FF`. You can optionally make the colour transparent by using the -#' form `"#RRGGBBAA"`. -#' * An `NA`, for a completely transparent colour. -#' -#' @section Alpha: -#' -#' Alpha refers to the opacity of a geom. Values of `alpha` range from 0 to 1, -#' with lower values corresponding to more transparent colors. -#' -#' Alpha can additionally be modified through the `colour` or `fill` aesthetic -#' if either aesthetic provides color values using an rgb specification -#' (`"#RRGGBBAA"`), where `AA` refers to transparency values. -#' -#' -#' @seealso -#' * Other options for modifying colour: -#' [scale_colour_brewer()], -#' [scale_colour_gradient()], [scale_colour_grey()], -#' [scale_colour_hue()], [scale_colour_identity()], -#' [scale_colour_manual()], [scale_colour_viridis_d()] -#' * Other options for modifying fill: -#' [scale_fill_brewer()], -#' [scale_fill_gradient()], [scale_fill_grey()], -#' [scale_fill_hue()], [scale_fill_identity()], -#' [scale_fill_manual()], [scale_fill_viridis_d()] -#' * Other options for modifying alpha: -#' [scale_alpha()], [scale_alpha_manual()], [scale_alpha_identity()] -#' * Run `vignette("ggplot2-specs")` to see an overview of other aesthetics that -#' can be modified. -#' @family aesthetics documentation -#' -#' @name aes_colour_fill_alpha -#' @aliases colour color fill -#' @examples -#' \donttest{ -#' -#' # Bar chart example -#' p <- ggplot(mtcars, aes(factor(cyl))) -#' # Default plotting -#' p + geom_bar() -#' # To change the interior colouring use fill aesthetic -#' p + geom_bar(fill = "red") -#' # Compare with the colour aesthetic which changes just the bar outline -#' p + geom_bar(colour = "red") -#' # Combining both, you can see the changes more clearly -#' p + geom_bar(fill = "white", colour = "red") -#' # Both colour and fill can take an rgb specification. -#' p + geom_bar(fill = "#00abff") -#' # Use NA for a completely transparent colour. -#' p + geom_bar(fill = NA, colour = "#00abff") -#' -#' # Colouring scales differ depending on whether a discrete or -#' # continuous variable is being mapped. For example, when mapping -#' # fill to a factor variable, a discrete colour scale is used. -#' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + geom_bar() -#' -#' # When mapping fill to continuous variable a continuous colour -#' # scale is used. -#' ggplot(faithfuld, aes(waiting, eruptions)) + -#' geom_raster(aes(fill = density)) -#' -#' # Some geoms only use the colour aesthetic but not the fill -#' # aesthetic (e.g. geom_point() or geom_line()). -#' p <- ggplot(economics, aes(x = date, y = unemploy)) -#' p + geom_line() -#' p + geom_line(colour = "green") -#' p + geom_point() -#' p + geom_point(colour = "red") -#' -#' # For large datasets with overplotting the alpha -#' # aesthetic will make the points more transparent. -#' set.seed(1) -#' df <- data.frame(x = rnorm(5000), y = rnorm(5000)) -#' p <- ggplot(df, aes(x,y)) -#' p + geom_point() -#' p + geom_point(alpha = 0.5) -#' p + geom_point(alpha = 1/10) -#' -#' # Alpha can also be used to add shading. -#' p <- ggplot(economics, aes(x = date, y = unemploy)) + geom_line() -#' p -#' yrng <- range(economics$unemploy) -#' p <- p + -#' geom_rect( -#' aes(NULL, NULL, xmin = start, xmax = end, fill = party), -#' ymin = yrng[1], ymax = yrng[2], data = presidential -#' ) -#' p -#' p + scale_fill_manual(values = alpha(c("blue", "red"), .3)) -#' } -NULL diff --git a/R/aes-group-order.R b/R/aes-group-order.R deleted file mode 100644 index ade8198f72..0000000000 --- a/R/aes-group-order.R +++ /dev/null @@ -1,89 +0,0 @@ -#' Aesthetics: grouping -#' -#' @name aes_group_order -#' @aliases group -#' -#' @description -#' The `group` aesthetic is by default set to the interaction of all discrete variables -#' in the plot. This choice often partitions the data correctly, but when it does not, -#' or when no discrete variable is used in the plot, you will need to explicitly define the -#' grouping structure by mapping `group` to a variable that has a different value -#' for each group. -#' -#' @details -#' For most applications the grouping is set implicitly by mapping one or more -#' discrete variables to `x`, `y`, `colour`, `fill`, `alpha`, `shape`, `size`, -#' and/or `linetype`. This is demonstrated in the examples below. -#' -#' There are three common cases where the default does not display the data correctly. -#' 1. `geom_line()` where there are multiple individuals and the plot tries to -#' connect every observation, even across individuals, with a line. -#' 1. `geom_line()` where a discrete x-position implies groups, whereas observations -#' span the discrete x-positions. -#' 1. When the grouping needs to be different over different layers, for example -#' when computing a statistic on all observations when another layer shows -#' individuals. -#' -#' The examples below use a longitudinal dataset, `Oxboys`, from the nlme package to demonstrate -#' these cases. `Oxboys` records the heights (height) and centered ages (age) of 26 boys (Subject), -#' measured on nine occasions (Occasion). -#' -#' @seealso -#' * Geoms commonly used with groups: [geom_bar()], [geom_histogram()], [geom_line()] -#' * Run `vignette("ggplot2-specs")` to see an overview of other aesthetics that -#' can be modified. -#' @family aesthetics documentation -#' -#' @examples -#' \donttest{ -#' -#' p <- ggplot(mtcars, aes(wt, mpg)) -#' # A basic scatter plot -#' p + geom_point(size = 4) -#' # Using the colour aesthetic -#' p + geom_point(aes(colour = factor(cyl)), size = 4) -#' # Using the shape aesthetic -#' p + geom_point(aes(shape = factor(cyl)), size = 4) -#' -#' # Using fill -#' p <- ggplot(mtcars, aes(factor(cyl))) -#' p + geom_bar() -#' p + geom_bar(aes(fill = factor(cyl))) -#' p + geom_bar(aes(fill = factor(vs))) -#' -#' # Using linetypes -#' ggplot(economics_long, aes(date, value01)) + -#' geom_line(aes(linetype = variable)) -#' -#' # Multiple groups with one aesthetic -#' p <- ggplot(nlme::Oxboys, aes(age, height)) -#' # The default is not sufficient here. A single line tries to connect all -#' # the observations. -#' p + geom_line() -#' # To fix this, use the group aesthetic to map a different line for each -#' # subject. -#' p + geom_line(aes(group = Subject)) -#' -#' # Different groups on different layers -#' p <- p + geom_line(aes(group = Subject)) -#' # Using the group aesthetic with both geom_line() and geom_smooth() -#' # groups the data the same way for both layers -#' p + geom_smooth(aes(group = Subject), method = "lm", se = FALSE) -#' # Changing the group aesthetic for the smoother layer -#' # fits a single line of best fit across all boys -#' p + geom_smooth(aes(group = 1), size = 2, method = "lm", se = FALSE) -#' -#' # Overriding the default grouping -#' # Sometimes the plot has a discrete scale but you want to draw lines -#' # that connect across groups. This is the strategy used in interaction -#' # plots, profile plots, and parallel coordinate plots, among others. -#' # For example, we draw boxplots of height at each measurement occasion. -#' p <- ggplot(nlme::Oxboys, aes(Occasion, height)) + geom_boxplot() -#' p -#' # There is no need to specify the group aesthetic here; the default grouping -#' # works because occasion is a discrete variable. To overlay individual -#' # trajectories, we again need to override the default grouping for that layer -#' # with aes(group = Subject) -#' p + geom_line(aes(group = Subject), colour = "blue") -#' } -NULL diff --git a/R/aes-linetype-size-shape.R b/R/aes-linetype-size-shape.R deleted file mode 100644 index 77c8d78972..0000000000 --- a/R/aes-linetype-size-shape.R +++ /dev/null @@ -1,96 +0,0 @@ -#' Differentiation related aesthetics: linetype, size, shape -#' -#' @description -#' The `linetype`, `linewidth`, `size`, and `shape` aesthetics modify the -#' appearance of lines and/or points. They also apply to the outlines of -#' polygons (`linetype` and `linewidth`) or to text (`size`). -#' -#' @section Linetype: -#' The `linetype` aesthetic can be specified with either an integer (0-6), a -#' name (0 = blank, 1 = solid, 2 = dashed, 3 = dotted, 4 = dotdash, 5 = longdash, -#' 6 = twodash), a mapping to a discrete variable, or a string of an even number -#' (up to eight) of hexadecimal digits which give the lengths in consecutive -#' positions in the string. See examples for a hex string demonstration. -#' -#' @section Linewidth and stroke: -#' The `linewidth` aesthetic sets the widths of lines, and can be specified -#' with a numeric value (for historical reasons, these units are about 0.75 -#' millimetres). Alternatively, they can also be set via mapping to a continuous -#' variable. The `stroke` aesthetic serves the same role for points, but is -#' distinct for discriminating points from lines in geoms such as -#' [`geom_pointrange()`]. -#' -#' @section Size: -#' The `size` aesthetic control the size of points and text, and can be -#' specified with a numerical value (in millimetres) or via a mapping to a -#' continuous variable. -#' -#' @section Shape: -#' The `shape` aesthetic controls the symbols of points, and can be specified -#' with an integer (between 0 and 25), a single character (which uses that -#' character as the plotting symbol), a `.` to draw the smallest rectangle that -#' is visible (i.e., about one pixel), an `NA` to draw nothing, or a mapping to -#' a discrete variable. Symbols and filled shapes are described in the examples -#' below. -#' -#' @seealso -#' * [geom_line()] and [geom_point()] for geoms commonly used -#' with these aesthetics. -#' * [aes_group_order()] for using `linetype`, `size`, or -#' `shape` for grouping. -#' * Scales that can be used to modify these aesthetics: [`scale_linetype()`], -#' [`scale_linewidth()`], [`scale_size()`], and [`scale_shape()`]. -#' * Run `vignette("ggplot2-specs")` to see an overview of other aesthetics that -#' can be modified. -#' @family aesthetics documentation -#' @name aes_linetype_size_shape -#' @aliases linetype size shape -#' @examples -#' -#' df <- data.frame(x = 1:10 , y = 1:10) -#' p <- ggplot(df, aes(x, y)) -#' p + geom_line(linetype = 2) -#' p + geom_line(linetype = "dotdash") -#' -#' # An example with hex strings; the string "33" specifies three units on followed -#' # by three off and "3313" specifies three units on followed by three off followed -#' # by one on and finally three off. -#' p + geom_line(linetype = "3313") -#' -#' # Mapping line type from a grouping variable -#' ggplot(economics_long, aes(date, value01)) + -#' geom_line(aes(linetype = variable)) -#' -#' # Linewidth examples -#' ggplot(economics, aes(date, unemploy)) + -#' geom_line(linewidth = 2, lineend = "round") -#' ggplot(economics, aes(date, unemploy)) + -#' geom_line(aes(linewidth = uempmed), lineend = "round") -#' -#' # Size examples -#' p <- ggplot(mtcars, aes(wt, mpg)) -#' p + geom_point(size = 4) -#' p + geom_point(aes(size = qsec)) -#' p + geom_point(size = 2.5) + -#' geom_hline(yintercept = 25, size = 3.5) -#' -#' # Shape examples -#' p + geom_point() -#' p + geom_point(shape = 5) -#' p + geom_point(shape = "k", size = 3) -#' p + geom_point(shape = ".") -#' p + geom_point(shape = NA) -#' p + geom_point(aes(shape = factor(cyl))) -#' -#' # A look at all 25 symbols -#' df2 <- data.frame(x = 1:5 , y = 1:25, z = 1:25) -#' p <- ggplot(df2, aes(x, y)) -#' p + geom_point(aes(shape = z), size = 4) + -#' scale_shape_identity() -#' # While all symbols have a foreground colour, symbols 19-25 also take a -#' # background colour (fill) -#' p + geom_point(aes(shape = z), size = 4, colour = "Red") + -#' scale_shape_identity() -#' p + geom_point(aes(shape = z), size = 4, colour = "Red", fill = "Black") + -#' scale_shape_identity() -NULL diff --git a/R/aes-position.R b/R/aes-position.R deleted file mode 100644 index 40b0089200..0000000000 --- a/R/aes-position.R +++ /dev/null @@ -1,99 +0,0 @@ -#' Position related aesthetics: x, y, xmin, xmax, ymin, ymax, xend, yend -#' -#' The following aesthetics can be used to specify the position of elements: -#' `x`, `y`, `xmin`, `xmax`, `ymin`, `ymax`, `xend`, `yend`. -#' -#' `x` and `y` define the locations of points or of positions along a line -#' or path. -#' -#' `x`, `y` and `xend`, `yend` define the starting and ending points of -#' segment and curve geometries. -#' -#' `xmin`, `xmax`, `ymin` and `ymax` can be used to specify the position of -#' annotations and to represent rectangular areas. -#' -#' In addition, there are position aesthetics that are contextual to the -#' geometry that they're used in. These are `xintercept`, `yintercept`, -#' `xmin_final`, `ymin_final`, `xmax_final`, `ymax_final`, `xlower`, `lower`, -#' `xmiddle`, `middle`, `xupper`, `upper`, `x0` and `y0`. Many of these are used -#' and automatically computed in [`geom_boxplot()`]. -#' -#' ## Relation to `width` and `height` -#' -#' The position aesthetics mentioned above like `x` and `y` are all location -#' based. The `width` and `height` aesthetics are closely related length -#' based aesthetics, but are not position aesthetics. Consequently, `x` and `y` -#' aesthetics respond to scale transformations, whereas the length based -#' `width` and `height` aesthetics are not transformed by scales. For example, -#' if we have the pair `x = 10, width = 2`, that gets translated to the -#' locations `xmin = 9, xmax = 11` when using the default identity scales. -#' However, the same pair becomes `xmin = 1, xmax = 100` when using log10 scales, -#' as `width = 2` in log10-space spans a 100-fold change. -#' -#' @name aes_position -#' @aliases x y xmin xmax ymin ymax xend yend -#' -#' @seealso -#' * Geoms that commonly use these aesthetics: [geom_crossbar()], -#' [geom_curve()], [geom_errorbar()], [geom_line()], [geom_linerange()], -#' [geom_path()], [geom_point()], [geom_pointrange()], [geom_rect()], -#' [geom_segment()] -#' * Scales that can be used to modify positions: -#' [`scale_continuous()`][scale_x_continuous()], -#' [`scale_discrete()`][scale_x_discrete()], -#' [`scale_binned()`][scale_x_binned()], -#' [`scale_date()`][scale_x_date()]. -#' * See also [annotate()] for placing annotations. -#' @family aesthetics documentation -#' @examples -#' -#' # Generate data: means and standard errors of means for prices -#' # for each type of cut -#' dmod <- lm(price ~ cut, data = diamonds) -#' cut <- unique(diamonds$cut) -#' cuts_df <- data.frame( -#' cut, -#' predict(dmod, data.frame(cut), se = TRUE)[c("fit", "se.fit")] -#' ) -#' ggplot(cuts_df) + -#' aes( -#' x = cut, -#' y = fit, -#' ymin = fit - se.fit, -#' ymax = fit + se.fit, -#' colour = cut -#' ) + -#' geom_pointrange() -#' -#' # Using annotate -#' p <- ggplot(mtcars, aes(x = wt, y = mpg)) + geom_point() -#' p -#' p + annotate( -#' "rect", xmin = 2, xmax = 3.5, ymin = 2, ymax = 25, -#' fill = "dark grey", alpha = .5 -#' ) -#' -#' # Geom_segment examples -#' p + geom_segment( -#' aes(x = 2, y = 15, xend = 2, yend = 25), -#' arrow = arrow(length = unit(0.5, "cm")) -#' ) -#' p + geom_segment( -#' aes(x = 2, y = 15, xend = 3, yend = 15), -#' arrow = arrow(length = unit(0.5, "cm")) -#' ) -#' p + geom_segment( -#' aes(x = 5, y = 30, xend = 3.5, yend = 25), -#' arrow = arrow(length = unit(0.5, "cm")) -#' ) -#' -#' # You can also use geom_segment() to recreate plot(type = "h") -#' # from base R: -#' set.seed(1) -#' counts <- as.data.frame(table(x = rpois(100, 5))) -#' counts$x <- as.numeric(as.character(counts$x)) -#' with(counts, plot(x, Freq, type = "h", lwd = 10)) -#' -#' ggplot(counts, aes(x = x, y = Freq)) + -#' geom_segment(aes(yend = 0, xend = x), size = 10) -NULL diff --git a/R/docs-aes.R b/R/docs-aes.R new file mode 100644 index 0000000000..9ee4572c11 --- /dev/null +++ b/R/docs-aes.R @@ -0,0 +1,399 @@ +#' Position related aesthetics: x, y, xmin, xmax, ymin, ymax, xend, yend +#' +#' The following aesthetics can be used to specify the position of elements: +#' `x`, `y`, `xmin`, `xmax`, `ymin`, `ymax`, `xend`, `yend`. +#' +#' `x` and `y` define the locations of points or of positions along a line +#' or path. +#' +#' `x`, `y` and `xend`, `yend` define the starting and ending points of +#' segment and curve geometries. +#' +#' `xmin`, `xmax`, `ymin` and `ymax` can be used to specify the position of +#' annotations and to represent rectangular areas. +#' +#' In addition, there are position aesthetics that are contextual to the +#' geometry that they're used in. These are `xintercept`, `yintercept`, +#' `xmin_final`, `ymin_final`, `xmax_final`, `ymax_final`, `xlower`, `lower`, +#' `xmiddle`, `middle`, `xupper`, `upper`, `x0` and `y0`. Many of these are used +#' and automatically computed in [`geom_boxplot()`]. +#' +#' ## Relation to `width` and `height` +#' +#' The position aesthetics mentioned above like `x` and `y` are all location +#' based. The `width` and `height` aesthetics are closely related length +#' based aesthetics, but are not position aesthetics. Consequently, `x` and `y` +#' aesthetics respond to scale transformations, whereas the length based +#' `width` and `height` aesthetics are not transformed by scales. For example, +#' if we have the pair `x = 10, width = 2`, that gets translated to the +#' locations `xmin = 9, xmax = 11` when using the default identity scales. +#' However, the same pair becomes `xmin = 1, xmax = 100` when using log10 scales, +#' as `width = 2` in log10-space spans a 100-fold change. +#' +#' @name aes_position +#' @aliases x y xmin xmax ymin ymax xend yend +#' +#' @seealso +#' * Geoms that commonly use these aesthetics: [geom_crossbar()], +#' [geom_curve()], [geom_errorbar()], [geom_line()], [geom_linerange()], +#' [geom_path()], [geom_point()], [geom_pointrange()], [geom_rect()], +#' [geom_segment()] +#' * Scales that can be used to modify positions: +#' [`scale_continuous()`][scale_x_continuous()], +#' [`scale_discrete()`][scale_x_discrete()], +#' [`scale_binned()`][scale_x_binned()], +#' [`scale_date()`][scale_x_date()]. +#' * See also [annotate()] for placing annotations. +#' @family aesthetics documentation +#' @examples +#' +#' # Generate data: means and standard errors of means for prices +#' # for each type of cut +#' dmod <- lm(price ~ cut, data = diamonds) +#' cut <- unique(diamonds$cut) +#' cuts_df <- data.frame( +#' cut, +#' predict(dmod, data.frame(cut), se = TRUE)[c("fit", "se.fit")] +#' ) +#' ggplot(cuts_df) + +#' aes( +#' x = cut, +#' y = fit, +#' ymin = fit - se.fit, +#' ymax = fit + se.fit, +#' colour = cut +#' ) + +#' geom_pointrange() +#' +#' # Using annotate +#' p <- ggplot(mtcars, aes(x = wt, y = mpg)) + geom_point() +#' p +#' p + annotate( +#' "rect", xmin = 2, xmax = 3.5, ymin = 2, ymax = 25, +#' fill = "dark grey", alpha = .5 +#' ) +#' +#' # Geom_segment examples +#' p + geom_segment( +#' aes(x = 2, y = 15, xend = 2, yend = 25), +#' arrow = arrow(length = unit(0.5, "cm")) +#' ) +#' p + geom_segment( +#' aes(x = 2, y = 15, xend = 3, yend = 15), +#' arrow = arrow(length = unit(0.5, "cm")) +#' ) +#' p + geom_segment( +#' aes(x = 5, y = 30, xend = 3.5, yend = 25), +#' arrow = arrow(length = unit(0.5, "cm")) +#' ) +#' +#' # You can also use geom_segment() to recreate plot(type = "h") +#' # from base R: +#' set.seed(1) +#' counts <- as.data.frame(table(x = rpois(100, 5))) +#' counts$x <- as.numeric(as.character(counts$x)) +#' with(counts, plot(x, Freq, type = "h", lwd = 10)) +#' +#' ggplot(counts, aes(x = x, y = Freq)) + +#' geom_segment(aes(yend = 0, xend = x), size = 10) +NULL + +#' Aesthetics: grouping +#' +#' @name aes_group_order +#' @aliases group +#' +#' @description +#' The `group` aesthetic is by default set to the interaction of all discrete variables +#' in the plot. This choice often partitions the data correctly, but when it does not, +#' or when no discrete variable is used in the plot, you will need to explicitly define the +#' grouping structure by mapping `group` to a variable that has a different value +#' for each group. +#' +#' @details +#' For most applications the grouping is set implicitly by mapping one or more +#' discrete variables to `x`, `y`, `colour`, `fill`, `alpha`, `shape`, `size`, +#' and/or `linetype`. This is demonstrated in the examples below. +#' +#' There are three common cases where the default does not display the data correctly. +#' 1. `geom_line()` where there are multiple individuals and the plot tries to +#' connect every observation, even across individuals, with a line. +#' 1. `geom_line()` where a discrete x-position implies groups, whereas observations +#' span the discrete x-positions. +#' 1. When the grouping needs to be different over different layers, for example +#' when computing a statistic on all observations when another layer shows +#' individuals. +#' +#' The examples below use a longitudinal dataset, `Oxboys`, from the nlme package to demonstrate +#' these cases. `Oxboys` records the heights (height) and centered ages (age) of 26 boys (Subject), +#' measured on nine occasions (Occasion). +#' +#' @seealso +#' * Geoms commonly used with groups: [geom_bar()], [geom_histogram()], [geom_line()] +#' * Run `vignette("ggplot2-specs")` to see an overview of other aesthetics that +#' can be modified. +#' @family aesthetics documentation +#' +#' @examples +#' \donttest{ +#' +#' p <- ggplot(mtcars, aes(wt, mpg)) +#' # A basic scatter plot +#' p + geom_point(size = 4) +#' # Using the colour aesthetic +#' p + geom_point(aes(colour = factor(cyl)), size = 4) +#' # Using the shape aesthetic +#' p + geom_point(aes(shape = factor(cyl)), size = 4) +#' +#' # Using fill +#' p <- ggplot(mtcars, aes(factor(cyl))) +#' p + geom_bar() +#' p + geom_bar(aes(fill = factor(cyl))) +#' p + geom_bar(aes(fill = factor(vs))) +#' +#' # Using linetypes +#' ggplot(economics_long, aes(date, value01)) + +#' geom_line(aes(linetype = variable)) +#' +#' # Multiple groups with one aesthetic +#' p <- ggplot(nlme::Oxboys, aes(age, height)) +#' # The default is not sufficient here. A single line tries to connect all +#' # the observations. +#' p + geom_line() +#' # To fix this, use the group aesthetic to map a different line for each +#' # subject. +#' p + geom_line(aes(group = Subject)) +#' +#' # Different groups on different layers +#' p <- p + geom_line(aes(group = Subject)) +#' # Using the group aesthetic with both geom_line() and geom_smooth() +#' # groups the data the same way for both layers +#' p + geom_smooth(aes(group = Subject), method = "lm", se = FALSE) +#' # Changing the group aesthetic for the smoother layer +#' # fits a single line of best fit across all boys +#' p + geom_smooth(aes(group = 1), size = 2, method = "lm", se = FALSE) +#' +#' # Overriding the default grouping +#' # Sometimes the plot has a discrete scale but you want to draw lines +#' # that connect across groups. This is the strategy used in interaction +#' # plots, profile plots, and parallel coordinate plots, among others. +#' # For example, we draw boxplots of height at each measurement occasion. +#' p <- ggplot(nlme::Oxboys, aes(Occasion, height)) + geom_boxplot() +#' p +#' # There is no need to specify the group aesthetic here; the default grouping +#' # works because occasion is a discrete variable. To overlay individual +#' # trajectories, we again need to override the default grouping for that layer +#' # with aes(group = Subject) +#' p + geom_line(aes(group = Subject), colour = "blue") +#' } +NULL + +#' Colour related aesthetics: colour, fill, and alpha +#' +#' These aesthetics parameters change the colour (`colour` and `fill`) and the +#' opacity (`alpha`) of geom elements on a plot. Almost every geom has either +#' colour or fill (or both), as well as can have their alpha modified. +#' Modifying colour on a plot is a useful way to enhance the presentation of data, +#' often especially when a plot graphs more than two variables. +#' +#' @section Colour and fill: +#' +#' The `colour` aesthetic is used to draw lines and strokes, such as in +#' [`geom_point()`] and [`geom_line()`], but also the line contours of +#' [`geom_rect()`] and [`geom_polygon()`]. The `fill` aesthetic is used to +#' colour the inside areas of geoms, such as [`geom_rect()`] and +#' [`geom_polygon()`], but also the insides of shapes 21-25 of [`geom_point()`]. +#' +#' Colours and fills can be specified in the following ways: +#' * A name, e.g., `"red"`. R has 657 built-in named colours, which can be +#' listed with [grDevices::colors()]. +#' * An rgb specification, with a string of the form `"#RRGGBB"` where each of the +#' pairs `RR`, `GG`, `BB` consists of two hexadecimal digits giving a value in the +#' range `00` to `FF`. You can optionally make the colour transparent by using the +#' form `"#RRGGBBAA"`. +#' * An `NA`, for a completely transparent colour. +#' +#' @section Alpha: +#' +#' Alpha refers to the opacity of a geom. Values of `alpha` range from 0 to 1, +#' with lower values corresponding to more transparent colors. +#' +#' Alpha can additionally be modified through the `colour` or `fill` aesthetic +#' if either aesthetic provides color values using an rgb specification +#' (`"#RRGGBBAA"`), where `AA` refers to transparency values. +#' +#' +#' @seealso +#' * Other options for modifying colour: +#' [scale_colour_brewer()], +#' [scale_colour_gradient()], [scale_colour_grey()], +#' [scale_colour_hue()], [scale_colour_identity()], +#' [scale_colour_manual()], [scale_colour_viridis_d()] +#' * Other options for modifying fill: +#' [scale_fill_brewer()], +#' [scale_fill_gradient()], [scale_fill_grey()], +#' [scale_fill_hue()], [scale_fill_identity()], +#' [scale_fill_manual()], [scale_fill_viridis_d()] +#' * Other options for modifying alpha: +#' [scale_alpha()], [scale_alpha_manual()], [scale_alpha_identity()] +#' * Run `vignette("ggplot2-specs")` to see an overview of other aesthetics that +#' can be modified. +#' @family aesthetics documentation +#' +#' @name aes_colour_fill_alpha +#' @aliases colour color fill +#' @examples +#' \donttest{ +#' +#' # Bar chart example +#' p <- ggplot(mtcars, aes(factor(cyl))) +#' # Default plotting +#' p + geom_bar() +#' # To change the interior colouring use fill aesthetic +#' p + geom_bar(fill = "red") +#' # Compare with the colour aesthetic which changes just the bar outline +#' p + geom_bar(colour = "red") +#' # Combining both, you can see the changes more clearly +#' p + geom_bar(fill = "white", colour = "red") +#' # Both colour and fill can take an rgb specification. +#' p + geom_bar(fill = "#00abff") +#' # Use NA for a completely transparent colour. +#' p + geom_bar(fill = NA, colour = "#00abff") +#' +#' # Colouring scales differ depending on whether a discrete or +#' # continuous variable is being mapped. For example, when mapping +#' # fill to a factor variable, a discrete colour scale is used. +#' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) + geom_bar() +#' +#' # When mapping fill to continuous variable a continuous colour +#' # scale is used. +#' ggplot(faithfuld, aes(waiting, eruptions)) + +#' geom_raster(aes(fill = density)) +#' +#' # Some geoms only use the colour aesthetic but not the fill +#' # aesthetic (e.g. geom_point() or geom_line()). +#' p <- ggplot(economics, aes(x = date, y = unemploy)) +#' p + geom_line() +#' p + geom_line(colour = "green") +#' p + geom_point() +#' p + geom_point(colour = "red") +#' +#' # For large datasets with overplotting the alpha +#' # aesthetic will make the points more transparent. +#' set.seed(1) +#' df <- data.frame(x = rnorm(5000), y = rnorm(5000)) +#' p <- ggplot(df, aes(x,y)) +#' p + geom_point() +#' p + geom_point(alpha = 0.5) +#' p + geom_point(alpha = 1/10) +#' +#' # Alpha can also be used to add shading. +#' p <- ggplot(economics, aes(x = date, y = unemploy)) + geom_line() +#' p +#' yrng <- range(economics$unemploy) +#' p <- p + +#' geom_rect( +#' aes(NULL, NULL, xmin = start, xmax = end, fill = party), +#' ymin = yrng[1], ymax = yrng[2], data = presidential +#' ) +#' p +#' p + scale_fill_manual(values = alpha(c("blue", "red"), .3)) +#' } +NULL + +#' Differentiation related aesthetics: linetype, size, shape +#' +#' @description +#' The `linetype`, `linewidth`, `size`, and `shape` aesthetics modify the +#' appearance of lines and/or points. They also apply to the outlines of +#' polygons (`linetype` and `linewidth`) or to text (`size`). +#' +#' @section Linetype: +#' The `linetype` aesthetic can be specified with either an integer (0-6), a +#' name (0 = blank, 1 = solid, 2 = dashed, 3 = dotted, 4 = dotdash, 5 = longdash, +#' 6 = twodash), a mapping to a discrete variable, or a string of an even number +#' (up to eight) of hexadecimal digits which give the lengths in consecutive +#' positions in the string. See examples for a hex string demonstration. +#' +#' @section Linewidth and stroke: +#' The `linewidth` aesthetic sets the widths of lines, and can be specified +#' with a numeric value (for historical reasons, these units are about 0.75 +#' millimetres). Alternatively, they can also be set via mapping to a continuous +#' variable. The `stroke` aesthetic serves the same role for points, but is +#' distinct for discriminating points from lines in geoms such as +#' [`geom_pointrange()`]. +#' +#' @section Size: +#' The `size` aesthetic control the size of points and text, and can be +#' specified with a numerical value (in millimetres) or via a mapping to a +#' continuous variable. +#' +#' @section Shape: +#' The `shape` aesthetic controls the symbols of points, and can be specified +#' with an integer (between 0 and 25), a single character (which uses that +#' character as the plotting symbol), a `.` to draw the smallest rectangle that +#' is visible (i.e., about one pixel), an `NA` to draw nothing, or a mapping to +#' a discrete variable. Symbols and filled shapes are described in the examples +#' below. +#' +#' @seealso +#' * [geom_line()] and [geom_point()] for geoms commonly used +#' with these aesthetics. +#' * [aes_group_order()] for using `linetype`, `size`, or +#' `shape` for grouping. +#' * Scales that can be used to modify these aesthetics: [`scale_linetype()`], +#' [`scale_linewidth()`], [`scale_size()`], and [`scale_shape()`]. +#' * Run `vignette("ggplot2-specs")` to see an overview of other aesthetics that +#' can be modified. +#' @family aesthetics documentation +#' @name aes_linetype_size_shape +#' @aliases linetype size shape +#' @examples +#' +#' df <- data.frame(x = 1:10 , y = 1:10) +#' p <- ggplot(df, aes(x, y)) +#' p + geom_line(linetype = 2) +#' p + geom_line(linetype = "dotdash") +#' +#' # An example with hex strings; the string "33" specifies three units on followed +#' # by three off and "3313" specifies three units on followed by three off followed +#' # by one on and finally three off. +#' p + geom_line(linetype = "3313") +#' +#' # Mapping line type from a grouping variable +#' ggplot(economics_long, aes(date, value01)) + +#' geom_line(aes(linetype = variable)) +#' +#' # Linewidth examples +#' ggplot(economics, aes(date, unemploy)) + +#' geom_line(linewidth = 2, lineend = "round") +#' ggplot(economics, aes(date, unemploy)) + +#' geom_line(aes(linewidth = uempmed), lineend = "round") +#' +#' # Size examples +#' p <- ggplot(mtcars, aes(wt, mpg)) +#' p + geom_point(size = 4) +#' p + geom_point(aes(size = qsec)) +#' p + geom_point(size = 2.5) + +#' geom_hline(yintercept = 25, size = 3.5) +#' +#' # Shape examples +#' p + geom_point() +#' p + geom_point(shape = 5) +#' p + geom_point(shape = "k", size = 3) +#' p + geom_point(shape = ".") +#' p + geom_point(shape = NA) +#' p + geom_point(aes(shape = factor(cyl))) +#' +#' # A look at all 25 symbols +#' df2 <- data.frame(x = 1:5 , y = 1:25, z = 1:25) +#' p <- ggplot(df2, aes(x, y)) +#' p + geom_point(aes(shape = z), size = 4) + +#' scale_shape_identity() +#' # While all symbols have a foreground colour, symbols 19-25 also take a +#' # background colour (fill) +#' p + geom_point(aes(shape = z), size = 4, colour = "Red") + +#' scale_shape_identity() +#' p + geom_point(aes(shape = z), size = 4, colour = "Red", fill = "Black") + +#' scale_shape_identity() +NULL From 1576361a50eaa9003219676fac9d861f4dc0eb2f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 11:00:12 +0100 Subject: [PATCH 03/78] divorce various `aes_*()` variants --- R/aes-variants.R | 132 +++++++++++++++++++++++++++++++++++++++++++++++ R/aes.R | 132 ----------------------------------------------- 2 files changed, 132 insertions(+), 132 deletions(-) create mode 100644 R/aes-variants.R diff --git a/R/aes-variants.R b/R/aes-variants.R new file mode 100644 index 0000000000..459d6fe31b --- /dev/null +++ b/R/aes-variants.R @@ -0,0 +1,132 @@ +#' Define aesthetic mappings programmatically +#' +#' @description +#' `r lifecycle::badge("deprecated")` +#' +#' Aesthetic mappings describe how variables in the data are mapped to visual +#' properties (aesthetics) of geoms. [aes()] uses non-standard +#' evaluation to capture the variable names. `aes_()` and `aes_string()` +#' require you to explicitly quote the inputs either with `""` for +#' `aes_string()`, or with `quote` or `~` for `aes_()`. +#' (`aes_q()` is an alias to `aes_()`). This makes `aes_()` and +#' `aes_string()` easy to program with. +#' +#' `aes_string()` and `aes_()` are particularly useful when writing +#' functions that create plots because you can use strings or quoted +#' names/calls to define the aesthetic mappings, rather than having to use +#' [substitute()] to generate a call to `aes()`. +#' +#' I recommend using `aes_()`, because creating the equivalents of +#' `aes(colour = "my colour")` or \code{aes(x = `X$1`)} +#' with `aes_string()` is quite clunky. +#' +#' +#' @section Life cycle: +#' +#' All these functions are deprecated. Please use tidy evaluation idioms +#' instead. Regarding `aes_string()`, you can replace it with `.data` pronoun. +#' For example, the following code can achieve the same mapping as +#' `aes_string(x_var, y_var)`. +#' +#' ``` r +#' x_var <- "foo" +#' y_var <- "bar" +#' aes(.data[[x_var]], .data[[y_var]]) +#' ```` +#' +#' For more details, please see `vignette("ggplot2-in-packages")`. +#' +#' @param x,y,... List of name value pairs. Elements must be either +#' quoted calls, strings, one-sided formulas or constants. +#' @seealso [aes()] +#' +#' @keywords internal +#' +#' @export +aes_ <- function(x, y, ...) { + deprecate_warn0( + "3.0.0", + "aes_()", + details = "Please use tidy evaluation idioms with `aes()`" + ) + mapping <- list(...) + if (!missing(x)) mapping["x"] <- list(x) + if (!missing(y)) mapping["y"] <- list(y) + + caller_env <- parent.frame() + + as_quosure_aes <- function(x) { + if (is_formula(x) && length(x) == 2) { + as_quosure(x) + } else if (is.null(x) || is.call(x) || is.name(x) || is.atomic(x)) { + new_aesthetic(x, caller_env) + } else { + cli::cli_abort("Aesthetic must be a one-sided formula, call, name, or constant.") + } + } + mapping <- lapply(mapping, as_quosure_aes) + class_mapping(rename_aes(mapping)) +} + +#' @rdname aes_ +#' @export +aes_string <- function(x, y, ...) { + deprecate_warn0( + "3.0.0", + "aes_string()", + details = c( + "Please use tidy evaluation idioms with `aes()`. ", + 'See also `vignette("ggplot2-in-packages")` for more information.' + ) + ) + mapping <- list(...) + if (!missing(x)) mapping["x"] <- list(x) + if (!missing(y)) mapping["y"] <- list(y) + + caller_env <- parent.frame() + mapping <- lapply(mapping, function(x) { + if (is.character(x)) { + x <- parse_expr(x) + } + new_aesthetic(x, env = caller_env) + }) + + class_mapping(rename_aes(mapping)) +} + +#' @export +#' @rdname aes_ +aes_q <- aes_ + +#' Given a character vector, create a set of identity mappings +#' +#' @param vars vector of variable names +#' @keywords internal +#' @export +#' @examples +#' aes_all(names(mtcars)) +#' aes_all(c("x", "y", "col", "pch")) +aes_all <- function(vars) { + names(vars) <- vars + vars <- rename_aes(vars) + + # Quosure the symbols in the empty environment because they can only + # refer to the data mask + x <- class_mapping(lapply(vars, function(x) new_quosure(as.name(x), emptyenv()))) + class(x) <- union("unlabelled", class(x)) + x +} + +#' Automatic aesthetic mapping +#' +#' @description +#' `r lifecycle::badge("deprecated")` +#' +#' @param data data.frame or names of variables +#' @param ... aesthetics that need to be explicitly mapped. +#' @keywords internal +#' @export +aes_auto <- function(data = NULL, ...) { + lifecycle::deprecate_stop("2.0.0", "aes_auto()") +} + diff --git a/R/aes.R b/R/aes.R index 208053bf52..a2a6e1a989 100644 --- a/R/aes.R +++ b/R/aes.R @@ -237,138 +237,6 @@ is_position_aes <- function(vars) { aes_to_scale(vars) %in% c("x", "y") } -#' Define aesthetic mappings programmatically -#' -#' @description -#' `r lifecycle::badge("deprecated")` -#' -#' Aesthetic mappings describe how variables in the data are mapped to visual -#' properties (aesthetics) of geoms. [aes()] uses non-standard -#' evaluation to capture the variable names. `aes_()` and `aes_string()` -#' require you to explicitly quote the inputs either with `""` for -#' `aes_string()`, or with `quote` or `~` for `aes_()`. -#' (`aes_q()` is an alias to `aes_()`). This makes `aes_()` and -#' `aes_string()` easy to program with. -#' -#' `aes_string()` and `aes_()` are particularly useful when writing -#' functions that create plots because you can use strings or quoted -#' names/calls to define the aesthetic mappings, rather than having to use -#' [substitute()] to generate a call to `aes()`. -#' -#' I recommend using `aes_()`, because creating the equivalents of -#' `aes(colour = "my colour")` or \code{aes(x = `X$1`)} -#' with `aes_string()` is quite clunky. -#' -#' -#' @section Life cycle: -#' -#' All these functions are deprecated. Please use tidy evaluation idioms -#' instead. Regarding `aes_string()`, you can replace it with `.data` pronoun. -#' For example, the following code can achieve the same mapping as -#' `aes_string(x_var, y_var)`. -#' -#' ``` r -#' x_var <- "foo" -#' y_var <- "bar" -#' aes(.data[[x_var]], .data[[y_var]]) -#' ```` -#' -#' For more details, please see `vignette("ggplot2-in-packages")`. -#' -#' @param x,y,... List of name value pairs. Elements must be either -#' quoted calls, strings, one-sided formulas or constants. -#' @seealso [aes()] -#' -#' @keywords internal -#' -#' @export -aes_ <- function(x, y, ...) { - deprecate_warn0( - "3.0.0", - "aes_()", - details = "Please use tidy evaluation idioms with `aes()`" - ) - mapping <- list(...) - if (!missing(x)) mapping["x"] <- list(x) - if (!missing(y)) mapping["y"] <- list(y) - - caller_env <- parent.frame() - - as_quosure_aes <- function(x) { - if (is_formula(x) && length(x) == 2) { - as_quosure(x) - } else if (is.null(x) || is.call(x) || is.name(x) || is.atomic(x)) { - new_aesthetic(x, caller_env) - } else { - cli::cli_abort("Aesthetic must be a one-sided formula, call, name, or constant.") - } - } - mapping <- lapply(mapping, as_quosure_aes) - class_mapping(rename_aes(mapping)) -} - -#' @rdname aes_ -#' @export -aes_string <- function(x, y, ...) { - deprecate_warn0( - "3.0.0", - "aes_string()", - details = c( - "Please use tidy evaluation idioms with `aes()`. ", - 'See also `vignette("ggplot2-in-packages")` for more information.' - ) - ) - mapping <- list(...) - if (!missing(x)) mapping["x"] <- list(x) - if (!missing(y)) mapping["y"] <- list(y) - - caller_env <- parent.frame() - mapping <- lapply(mapping, function(x) { - if (is.character(x)) { - x <- parse_expr(x) - } - new_aesthetic(x, env = caller_env) - }) - - class_mapping(rename_aes(mapping)) -} - -#' @export -#' @rdname aes_ -aes_q <- aes_ - -#' Given a character vector, create a set of identity mappings -#' -#' @param vars vector of variable names -#' @keywords internal -#' @export -#' @examples -#' aes_all(names(mtcars)) -#' aes_all(c("x", "y", "col", "pch")) -aes_all <- function(vars) { - names(vars) <- vars - vars <- rename_aes(vars) - - # Quosure the symbols in the empty environment because they can only - # refer to the data mask - x <- class_mapping(lapply(vars, function(x) new_quosure(as.name(x), emptyenv()))) - class(x) <- union("unlabelled", class(x)) - x -} - -#' Automatic aesthetic mapping -#' -#' @description -#' `r lifecycle::badge("deprecated")` -#' -#' @param data data.frame or names of variables -#' @param ... aesthetics that need to be explicitly mapped. -#' @keywords internal -#' @export -aes_auto <- function(data = NULL, ...) { - lifecycle::deprecate_stop("2.0.0", "aes_auto()") -} - mapped_aesthetics <- function(x) { if (is.null(x)) { return(NULL) From f6f7f90cacd3f74cee0071ed67b6055bc2b9e79b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 11:08:22 +0100 Subject: [PATCH 04/78] for descriptiveness, rename `aes-evaluation.R` to `aes-delayed-eval.R` --- R/{aes-evaluation.R => aes-delayed-eval.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{aes-evaluation.R => aes-delayed-eval.R} (100%) diff --git a/R/aes-evaluation.R b/R/aes-delayed-eval.R similarity index 100% rename from R/aes-evaluation.R rename to R/aes-delayed-eval.R From f73588a26861b11d609648bf44a08373091cdd04 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 11:33:32 +0100 Subject: [PATCH 05/78] align `grouping.R` and `test-grouping.R` --- tests/testthat/{test-aes-grouping.R => test-grouping.R} | 1 - 1 file changed, 1 deletion(-) rename tests/testthat/{test-aes-grouping.R => test-grouping.R} (99%) diff --git a/tests/testthat/test-aes-grouping.R b/tests/testthat/test-grouping.R similarity index 99% rename from tests/testthat/test-aes-grouping.R rename to tests/testthat/test-grouping.R index d5536cc417..92ef700e59 100644 --- a/tests/testthat/test-aes-grouping.R +++ b/tests/testthat/test-grouping.R @@ -7,7 +7,6 @@ df <- data_frame( group <- function(x) as.vector(get_layer_data(x, 1)$group) groups <- function(x) vec_unique_count(group(x)) - test_that("one group per combination of discrete vars", { plot <- ggplot(df, aes(x, x)) + geom_point() expect_equal(group(plot), rep(NO_GROUP, 4)) From 7faf7275b1192db37b5f3636ad936ad2ad294db7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 11:34:24 +0100 Subject: [PATCH 06/78] tweaks to `test-grouping.R` --- tests/testthat/test-grouping.R | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/tests/testthat/test-grouping.R b/tests/testthat/test-grouping.R index 92ef700e59..97652a53a5 100644 --- a/tests/testthat/test-grouping.R +++ b/tests/testthat/test-grouping.R @@ -5,7 +5,7 @@ df <- data_frame( ) group <- function(x) as.vector(get_layer_data(x, 1)$group) -groups <- function(x) vec_unique_count(group(x)) +n_groups <- function(x) vec_unique_count(group(x)) test_that("one group per combination of discrete vars", { plot <- ggplot(df, aes(x, x)) + geom_point() @@ -17,15 +17,7 @@ test_that("one group per combination of discrete vars", { expect_equal(group(plot), c(1, 2, 1, 2)) plot <- ggplot(df, aes(a, b)) + geom_point() - expect_equal(groups(plot), 4) -}) - -test_that("no error for aes(groupS)", { - df2 <- data_frame(x = df$a, y = df$b, groupS = 1) - g <- add_group(df2) - - expect_equal(nrow(g), nrow(df2)) - expect_named(g, c("x", "y", "groupS", "group")) + expect_equal(n_groups(plot), 4) }) test_that("label is not used as a grouping var", { @@ -38,13 +30,21 @@ test_that("label is not used as a grouping var", { test_that("group aesthetic overrides defaults", { plot <- ggplot(df, aes(x, x, group = x)) + geom_point() - expect_equal(groups(plot), 4) + expect_equal(n_groups(plot), 4) plot <- ggplot(df, aes(a, b, group = 1)) + geom_point() - expect_equal(groups(plot), 1) + expect_equal(n_groups(plot), 1) }) test_that("group param overrides defaults", { plot <- ggplot(df, aes(a, b)) + geom_point(group = 1) - expect_equal(groups(plot), 1) + expect_equal(n_groups(plot), 1) +}) + +test_that("group does not partially match data", { + df2 <- data_frame(x = df$a, y = df$b, groupS = 1) + g <- add_group(df2) + + expect_equal(nrow(g), nrow(df2)) + expect_named(g, c("x", "y", "groupS", "group")) }) From 5539e6b711b2e732abaf0a03bd6bff051519892f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 11:49:57 +0100 Subject: [PATCH 07/78] align `aes-delayed-eval.R` and `test-aes-delayed-eval.R` --- .../{test-aes-calculated.R => test-aes-delayed-eval.R} | 6 ++++++ 1 file changed, 6 insertions(+) rename tests/testthat/{test-aes-calculated.R => test-aes-delayed-eval.R} (97%) diff --git a/tests/testthat/test-aes-calculated.R b/tests/testthat/test-aes-delayed-eval.R similarity index 97% rename from tests/testthat/test-aes-calculated.R rename to tests/testthat/test-aes-delayed-eval.R index ee922ba005..09321637ac 100644 --- a/tests/testthat/test-aes-calculated.R +++ b/tests/testthat/test-aes-delayed-eval.R @@ -171,3 +171,9 @@ test_that("A geom can have scaled defaults (#6135)", { defaults <- get_geom_defaults(test_geom) expect_equal(defaults$colour, c("#00000080")) }) + + +test_that("aes evaluation fails with unknown input", { + expect_snapshot_error(is_calculated(environment())) + expect_snapshot_error(strip_dots(environment())) +}) From 9c6f6bb7c5ecf1055c0e520779f2ccb4cf9227d8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 11:52:35 +0100 Subject: [PATCH 08/78] reorganise aes tests --- tests/testthat/test-add.R | 4 - tests/testthat/test-aes-setting.R | 55 ------------ tests/testthat/test-aes-variants.R | 39 +++++++++ tests/testthat/test-aes.R | 132 ++++++++++++++++------------- tests/testthat/test-guide-legend.R | 10 +++ 5 files changed, 123 insertions(+), 117 deletions(-) delete mode 100644 tests/testthat/test-add.R delete mode 100644 tests/testthat/test-aes-setting.R create mode 100644 tests/testthat/test-aes-variants.R diff --git a/tests/testthat/test-add.R b/tests/testthat/test-add.R deleted file mode 100644 index 0c318e6c9e..0000000000 --- a/tests/testthat/test-add.R +++ /dev/null @@ -1,4 +0,0 @@ -test_that("mapping class is preserved when adding mapping objects", { - p <- ggplot(mtcars) + aes(wt, mpg) - expect_s7_class(p@mapping, class_mapping) -}) diff --git a/tests/testthat/test-aes-setting.R b/tests/testthat/test-aes-setting.R deleted file mode 100644 index 2071921c03..0000000000 --- a/tests/testthat/test-aes-setting.R +++ /dev/null @@ -1,55 +0,0 @@ -test_that("aesthetic parameters match length of data", { - df <- data_frame(x = 1:5, y = 1:5) - p <- ggplot(df, aes(x, y)) - - set_colours <- function(colours) { - get_layer_data(p + geom_point(colour = colours)) - } - - set_colours("red") - expect_snapshot(set_colours(rep("red", 2)), error = TRUE) - expect_snapshot(set_colours(rep("red", 3)), error = TRUE) - expect_snapshot(set_colours(rep("red", 4)), error = TRUE) - set_colours(rep("red", 5)) -}) - -test_that("Length 1 aesthetics are recycled to 0", { - p <- ggplot(data.frame(x = numeric(), y = numeric())) + - geom_point(aes(x, y, colour = "red")) - - expect_silent(plot(p)) - - data <- get_layer_data(p) - - expect_equal(nrow(data), 0) -}) - -test_that("legend filters out aesthetics not of length 1", { - df <- data_frame(x = 1:5, y = 1:5) - p <- ggplot(df, aes(x, y, colour = factor(x))) + - geom_point(alpha = seq(0, 1, length.out = 5)) - - # Ideally would test something in the legend data structure, but - # that's not easily accessible currently. - expect_no_error(ggplot_gtable(ggplot_build(p))) -}) - -test_that("alpha affects only fill colour of solid geoms", { - df <- data_frame(x = 1:2, y = 1) - - poly <- ggplot(df, aes(x = x, y)) + - geom_polygon(fill = "red", colour = "red", alpha = 0.5) - rect <- ggplot(df, aes(xmin = x, xmax = x + 1, ymin = 1, ymax = y + 1)) + - geom_rect(fill = "red", colour = "red", alpha = 0.5) - # geom_ribbon() consists of polygonGrob and polylineGrob - ribb <- ggplot(df, aes(x = x, ymin = 1, ymax = y + 1)) + - geom_ribbon(fill = "red", colour = "red", alpha = 0.5) - - expect_equal(get_layer_grob(poly)[[1]]$gp$col[[1]], "red") - expect_equal(get_layer_grob(rect)[[1]]$gp$col[[1]], "red") - expect_equal(get_layer_grob(ribb)[[1]]$children[[1]]$children[[2]]$gp$col[[1]], "red") - - expect_equal(get_layer_grob(poly)[[1]]$gp$fill[[1]], "#FF000080") - expect_equal(get_layer_grob(rect)[[1]]$gp$fill[[1]], "#FF000080") - expect_equal(get_layer_grob(ribb)[[1]]$children[[1]]$children[[1]]$gp$fill[[1]], "#FF000080") -}) diff --git a/tests/testthat/test-aes-variants.R b/tests/testthat/test-aes-variants.R new file mode 100644 index 0000000000..e9915a6633 --- /dev/null +++ b/tests/testthat/test-aes-variants.R @@ -0,0 +1,39 @@ +test_that("aes_q() uses quoted calls and formulas", { + # Silence deprecation warning + out <- suppressWarnings(aes_q(quote(mpg), ~ wt + 1)) + expect_identical(out$x, quo(mpg)) + expect_identical(out$y, quo(wt + 1)) +}) + +test_that("aes_string() parses strings", { + # Silence deprecation warning + suppressWarnings(expect_equal(aes_string("a + b")$x, quo(a + b))) +}) + +test_that("aes_string() doesn't parse non-strings", { + old <- options(OutDec = ",") + on.exit(options(old)) + + # Silence deprecation warning + suppressWarnings(expect_identical(aes_string(0.4)$x, 0.4)) +}) + +test_that("aes_q() & aes_string() preserve explicit NULLs", { + # Silence deprecation warning + suppressWarnings(expect_equal(aes_q(NULL), aes(NULL))) + suppressWarnings(expect_equal(aes_q(x = NULL), aes(NULL))) + suppressWarnings(expect_equal(aes_q(colour = NULL), aes(colour = NULL))) + + suppressWarnings(expect_equal(aes_string(NULL), aes(NULL))) + suppressWarnings(expect_equal(aes_string(x = NULL), aes(NULL))) + suppressWarnings(expect_equal(aes_string(colour = NULL), aes(colour = NULL))) +}) + +test_that("aes_all() converts strings into mappings", { + expect_equal( + unclass(aes_all(c("x", "y", "col", "pch"))), + unclass(aes(x, y, colour = col, shape = pch)), + # ignore the environments of quosures + ignore_attr = TRUE + ) +}) diff --git a/tests/testthat/test-aes.R b/tests/testthat/test-aes.R index e2708eef6c..a798c073dd 100644 --- a/tests/testthat/test-aes.R +++ b/tests/testthat/test-aes.R @@ -1,49 +1,11 @@ +# Quosures ---------------------------------------------------------------- + test_that("aes() captures input expressions", { out <- aes(mpg, wt + 1) expect_identical(out$x, quo(mpg)) expect_identical(out$y, quo(wt + 1)) }) -test_that("aes_q() uses quoted calls and formulas", { - # Silence deprecation warning - out <- suppressWarnings(aes_q(quote(mpg), ~ wt + 1)) - expect_identical(out$x, quo(mpg)) - expect_identical(out$y, quo(wt + 1)) -}) - -test_that("aes_string() parses strings", { - # Silence deprecation warning - suppressWarnings(expect_equal(aes_string("a + b")$x, quo(a + b))) -}) - -test_that("aes_string() doesn't parse non-strings", { - old <- options(OutDec = ",") - on.exit(options(old)) - - # Silence deprecation warning - suppressWarnings(expect_identical(aes_string(0.4)$x, 0.4)) -}) - -test_that("aes_q() & aes_string() preserve explicit NULLs", { - # Silence deprecation warning - suppressWarnings(expect_equal(aes_q(NULL), aes(NULL))) - suppressWarnings(expect_equal(aes_q(x = NULL), aes(NULL))) - suppressWarnings(expect_equal(aes_q(colour = NULL), aes(colour = NULL))) - - suppressWarnings(expect_equal(aes_string(NULL), aes(NULL))) - suppressWarnings(expect_equal(aes_string(x = NULL), aes(NULL))) - suppressWarnings(expect_equal(aes_string(colour = NULL), aes(colour = NULL))) -}) - -test_that("aes_all() converts strings into mappings", { - expect_equal( - unclass(aes_all(c("x", "y", "col", "pch"))), - unclass(aes(x, y, colour = col, shape = pch)), - # ignore the environments of quosures - ignore_attr = TRUE - ) -}) - test_that("aes evaluated in environment where plot created", { df <- data_frame(x = 1, y = 1) p <- ggplot(df, aes(foo, y)) + geom_point() @@ -99,12 +61,7 @@ test_that("quosures are squashed when creating default label for a mapping", { expect_identical(labels$x, "identity(cyl)") }) -test_that("labelling doesn't cause error if aesthetic is NULL", { - p <- ggplot(mtcars) + aes(x = NULL) - labels <- ggplot_build(p)@plot@labels - # NULL labels should only be used as fallback labels - expect_identical(labels$x, structure("x", fallback = TRUE)) -}) +# Standardisation --------------------------------------------------------- test_that("aes standardises aesthetic names", { # test a few common cases @@ -119,6 +76,9 @@ test_that("aes standardises aesthetic names", { expect_snapshot_warning(aes(color = x, colour = y)) }) + +# Extraction -------------------------------------------------------------- + test_that("warn_for_aes_extract_usage() warns for discouraged uses of $ and [[ within aes()", { df <- data_frame(x = 1:5, nested_df = data_frame(x = 6:10)) @@ -165,9 +125,28 @@ test_that("Warnings are issued when plots use discouraged extract usage within a expect_snapshot_warning(ggplot_build(p)) }) -test_that("aes evaluation fails with unknown input", { - expect_snapshot_error(is_calculated(environment())) - expect_snapshot_error(strip_dots(environment())) +test_that("alternative_aes_extract_usage() can inspect the call", { + x <- quote(test[['var']]) + expect_identical(alternative_aes_extract_usage(x), ".data[[\"var\"]]") + x <- quote(test$var) + expect_identical(alternative_aes_extract_usage(x), "var") + x <- quote(foo()) + expect_snapshot_error(alternative_aes_extract_usage(x)) +}) + +# Other ------------------------------------------------------------------- + +test_that("mapping class is preserved when adding mapping objects", { + p <- ggplot(mtcars) + aes(wt, mpg) + expect_s7_class(p@mapping, class_mapping) +}) + + +test_that("labelling doesn't cause error if aesthetic is NULL", { + p <- ggplot(mtcars) + aes(x = NULL) + labels <- ggplot_build(p)@plot@labels + # NULL labels should only be used as fallback labels + expect_identical(labels$x, structure("x", fallback = TRUE)) }) test_that("aes() supports `!!!` in named arguments (#2675)", { @@ -186,19 +165,56 @@ test_that("aes() supports `!!!` in named arguments (#2675)", { expect_snapshot_error(aes(y = 1, !!!list(y = 2))) }) -test_that("alternative_aes_extract_usage() can inspect the call", { - x <- quote(test[['var']]) - expect_identical(alternative_aes_extract_usage(x), ".data[[\"var\"]]") - x <- quote(test$var) - expect_identical(alternative_aes_extract_usage(x), "var") - x <- quote(foo()) - expect_snapshot_error(alternative_aes_extract_usage(x)) -}) - test_that("class_mapping() checks its inputs", { expect_snapshot_error(class_mapping(1:5)) }) +test_that("aesthetic parameters match length of data", { + df <- data_frame(x = 1:5, y = 1:5) + p <- ggplot(df, aes(x, y)) + + set_colours <- function(colours) { + get_layer_data(p + geom_point(colour = colours)) + } + + set_colours("red") + expect_snapshot(set_colours(rep("red", 2)), error = TRUE) + expect_snapshot(set_colours(rep("red", 3)), error = TRUE) + expect_snapshot(set_colours(rep("red", 4)), error = TRUE) + set_colours(rep("red", 5)) +}) + +test_that("Length 1 aesthetics are recycled to 0", { + p <- ggplot(data.frame(x = numeric(), y = numeric())) + + geom_point(aes(x, y, colour = "red")) + + expect_silent(plot(p)) + + data <- get_layer_data(p) + + expect_equal(nrow(data), 0) +}) + +test_that("alpha affects only fill colour of solid geoms", { + df <- data_frame(x = 1:2, y = 1) + + poly <- ggplot(df, aes(x = x, y)) + + geom_polygon(fill = "red", colour = "red", alpha = 0.5) + rect <- ggplot(df, aes(xmin = x, xmax = x + 1, ymin = 1, ymax = y + 1)) + + geom_rect(fill = "red", colour = "red", alpha = 0.5) + # geom_ribbon() consists of polygonGrob and polylineGrob + ribb <- ggplot(df, aes(x = x, ymin = 1, ymax = y + 1)) + + geom_ribbon(fill = "red", colour = "red", alpha = 0.5) + + expect_equal(get_layer_grob(poly)[[1]]$gp$col[[1]], "red") + expect_equal(get_layer_grob(rect)[[1]]$gp$col[[1]], "red") + expect_equal(get_layer_grob(ribb)[[1]]$children[[1]]$children[[2]]$gp$col[[1]], "red") + + expect_equal(get_layer_grob(poly)[[1]]$gp$fill[[1]], "#FF000080") + expect_equal(get_layer_grob(rect)[[1]]$gp$fill[[1]], "#FF000080") + expect_equal(get_layer_grob(ribb)[[1]]$children[[1]]$children[[1]]$gp$fill[[1]], "#FF000080") +}) + # Visual tests ------------------------------------------------------------ test_that("aesthetics are drawn correctly", { diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R index 2dd68fe01b..063b99b836 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -146,6 +146,16 @@ test_that("unresolved, modified expressions throw a warning (#6264)", { expect_snapshot_warning(ggplot_build(p)) }) +test_that("legend filters out aesthetics not of length 1", { + df <- data_frame(x = 1:5, y = 1:5) + p <- ggplot(df, aes(x, y, colour = factor(x))) + + geom_point(alpha = seq(0, 1, length.out = 5)) + + # Ideally would test something in the legend data structure, but + # that's not easily accessible currently. + expect_no_error(ggplot_gtable(ggplot_build(p))) +}) + # Visual tests ------------------------------------------------------------ test_that("legend directions are set correctly", { From c2f57e6283ae13e0dcc0789cad8f772f3fe29a89 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 12:02:41 +0100 Subject: [PATCH 09/78] redocument --- DESCRIPTION | 8 +++----- man/aes_.Rd | 2 +- man/aes_all.Rd | 2 +- man/aes_auto.Rd | 2 +- man/aes_colour_fill_alpha.Rd | 2 +- man/aes_eval.Rd | 2 +- man/aes_group_order.Rd | 2 +- man/aes_linetype_size_shape.Rd | 2 +- man/aes_position.Rd | 2 +- 9 files changed, 11 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d01559f86f..13025c6b63 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -86,11 +86,8 @@ LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 Collate: - 'aes-colour-fill-alpha.R' - 'aes-evaluation.R' - 'aes-group-order.R' - 'aes-linetype-size-shape.R' - 'aes-position.R' + 'aes-delayed-eval.R' + 'aes-variants.R' 'ggplot-global.R' 'ggproto.R' 'all-classes.R' @@ -130,6 +127,7 @@ Collate: 'coord-sf.R' 'coord-transform.R' 'data.R' + 'docs-aes.R' 'docs_layer.R' 'facet-.R' 'facet-grid-.R' diff --git a/man/aes_.Rd b/man/aes_.Rd index dc1da98efd..65d74e0830 100644 --- a/man/aes_.Rd +++ b/man/aes_.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes.R +% Please edit documentation in R/aes-variants.R \name{aes_} \alias{aes_} \alias{aes_string} diff --git a/man/aes_all.Rd b/man/aes_all.Rd index b02501b21a..afe7164e76 100644 --- a/man/aes_all.Rd +++ b/man/aes_all.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes.R +% Please edit documentation in R/aes-variants.R \name{aes_all} \alias{aes_all} \title{Given a character vector, create a set of identity mappings} diff --git a/man/aes_auto.Rd b/man/aes_auto.Rd index fffa46b5ba..4791abfc93 100644 --- a/man/aes_auto.Rd +++ b/man/aes_auto.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes.R +% Please edit documentation in R/aes-variants.R \name{aes_auto} \alias{aes_auto} \title{Automatic aesthetic mapping} diff --git a/man/aes_colour_fill_alpha.Rd b/man/aes_colour_fill_alpha.Rd index 282337837a..8d84f6f568 100644 --- a/man/aes_colour_fill_alpha.Rd +++ b/man/aes_colour_fill_alpha.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes-colour-fill-alpha.R +% Please edit documentation in R/docs-aes.R \name{aes_colour_fill_alpha} \alias{aes_colour_fill_alpha} \alias{colour} diff --git a/man/aes_eval.Rd b/man/aes_eval.Rd index aaf4c55277..1fc72f1f8a 100644 --- a/man/aes_eval.Rd +++ b/man/aes_eval.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes-evaluation.R +% Please edit documentation in R/aes-delayed-eval.R \name{aes_eval} \alias{aes_eval} \alias{after_stat} diff --git a/man/aes_group_order.Rd b/man/aes_group_order.Rd index 09accf2017..438905b2f7 100644 --- a/man/aes_group_order.Rd +++ b/man/aes_group_order.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes-group-order.R +% Please edit documentation in R/docs-aes.R \name{aes_group_order} \alias{aes_group_order} \alias{group} diff --git a/man/aes_linetype_size_shape.Rd b/man/aes_linetype_size_shape.Rd index 952baadf5a..380dca48df 100644 --- a/man/aes_linetype_size_shape.Rd +++ b/man/aes_linetype_size_shape.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes-linetype-size-shape.R +% Please edit documentation in R/docs-aes.R \name{aes_linetype_size_shape} \alias{aes_linetype_size_shape} \alias{linetype} diff --git a/man/aes_position.Rd b/man/aes_position.Rd index 4f1cf4bbae..c6a67d973d 100644 --- a/man/aes_position.Rd +++ b/man/aes_position.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aes-position.R +% Please edit documentation in R/docs-aes.R \name{aes_position} \alias{aes_position} \alias{x} From e2265b0d33150524841bddea8be03d3bfaf7a6bf Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 15:48:58 +0100 Subject: [PATCH 10/78] accept snapshots moving around --- ...{aes-calculated.md => aes-delayed-eval.md} | 8 ++++ tests/testthat/_snaps/aes-setting.md | 36 -------------- tests/testthat/_snaps/aes.md | 48 +++++++++++++++---- 3 files changed, 46 insertions(+), 46 deletions(-) rename tests/testthat/_snaps/{aes-calculated.md => aes-delayed-eval.md} (85%) delete mode 100644 tests/testthat/_snaps/aes-setting.md diff --git a/tests/testthat/_snaps/aes-calculated.md b/tests/testthat/_snaps/aes-delayed-eval.md similarity index 85% rename from tests/testthat/_snaps/aes-calculated.md rename to tests/testthat/_snaps/aes-delayed-eval.md index cd3424516b..9cf41b8c20 100644 --- a/tests/testthat/_snaps/aes-calculated.md +++ b/tests/testthat/_snaps/aes-delayed-eval.md @@ -24,3 +24,11 @@ The dot-dot notation (`..bar..`) was deprecated in ggplot2 3.4.0. i Please use `after_stat(bar)` instead. +# aes evaluation fails with unknown input + + Unknown input: + +--- + + Unknown input: + diff --git a/tests/testthat/_snaps/aes-setting.md b/tests/testthat/_snaps/aes-setting.md deleted file mode 100644 index b0ba47a52a..0000000000 --- a/tests/testthat/_snaps/aes-setting.md +++ /dev/null @@ -1,36 +0,0 @@ -# aesthetic parameters match length of data - - Code - set_colours(rep("red", 2)) - Condition - Error in `geom_point()`: - ! Problem while setting up geom aesthetics. - i Error occurred in the 1st layer. - Caused by error in `check_aesthetics()`: - ! Aesthetics must be either length 1 or the same as the data (5). - x Fix the following mappings: `colour`. - ---- - - Code - set_colours(rep("red", 3)) - Condition - Error in `geom_point()`: - ! Problem while setting up geom aesthetics. - i Error occurred in the 1st layer. - Caused by error in `check_aesthetics()`: - ! Aesthetics must be either length 1 or the same as the data (5). - x Fix the following mappings: `colour`. - ---- - - Code - set_colours(rep("red", 4)) - Condition - Error in `geom_point()`: - ! Problem while setting up geom aesthetics. - i Error occurred in the 1st layer. - Caused by error in `check_aesthetics()`: - ! Aesthetics must be either length 1 or the same as the data (5). - x Fix the following mappings: `colour`. - diff --git a/tests/testthat/_snaps/aes.md b/tests/testthat/_snaps/aes.md index 1d3308ad53..e31be172d2 100644 --- a/tests/testthat/_snaps/aes.md +++ b/tests/testthat/_snaps/aes.md @@ -38,23 +38,51 @@ Use of `df$x` is discouraged. i Use `x` instead. -# aes evaluation fails with unknown input - - Unknown input: - ---- +# alternative_aes_extract_usage() can inspect the call - Unknown input: + Don't know how to get alternative usage for `foo`. # aes() supports `!!!` in named arguments (#2675) formal argument "y" matched by multiple actual arguments -# alternative_aes_extract_usage() can inspect the call - - Don't know how to get alternative usage for `foo`. - # class_mapping() checks its inputs `x` must be a , not an integer vector. +# aesthetic parameters match length of data + + Code + set_colours(rep("red", 2)) + Condition + Error in `geom_point()`: + ! Problem while setting up geom aesthetics. + i Error occurred in the 1st layer. + Caused by error in `check_aesthetics()`: + ! Aesthetics must be either length 1 or the same as the data (5). + x Fix the following mappings: `colour`. + +--- + + Code + set_colours(rep("red", 3)) + Condition + Error in `geom_point()`: + ! Problem while setting up geom aesthetics. + i Error occurred in the 1st layer. + Caused by error in `check_aesthetics()`: + ! Aesthetics must be either length 1 or the same as the data (5). + x Fix the following mappings: `colour`. + +--- + + Code + set_colours(rep("red", 4)) + Condition + Error in `geom_point()`: + ! Problem while setting up geom aesthetics. + i Error occurred in the 1st layer. + Caused by error in `check_aesthetics()`: + ! Aesthetics must be either length 1 or the same as the data (5). + x Fix the following mappings: `colour`. + From d9e75a33a293fd0e34e8180d964fe9eec7302db8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 12:12:35 +0100 Subject: [PATCH 11/78] rename `annotation.R` to `annotate.R` --- DESCRIPTION | 2 +- R/{annotation.R => annotate.R} | 0 man/annotate.Rd | 2 +- 3 files changed, 2 insertions(+), 2 deletions(-) rename R/{annotation.R => annotate.R} (100%) diff --git a/DESCRIPTION b/DESCRIPTION index 13025c6b63..5ca9986587 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -94,6 +94,7 @@ Collate: 'compat-plyr.R' 'utilities.R' 'aes.R' + 'annotate.R' 'annotation-borders.R' 'utilities-checks.R' 'legend-draw.R' @@ -108,7 +109,6 @@ Collate: 'annotation-map.R' 'geom-raster.R' 'annotation-raster.R' - 'annotation.R' 'autolayer.R' 'autoplot.R' 'axis-secondary.R' diff --git a/R/annotation.R b/R/annotate.R similarity index 100% rename from R/annotation.R rename to R/annotate.R diff --git a/man/annotate.Rd b/man/annotate.Rd index c5117fa236..f6194292af 100644 --- a/man/annotate.Rd +++ b/man/annotate.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/annotation.R +% Please edit documentation in R/annotate.R \name{annotate} \alias{annotate} \title{Create an annotation layer} From 53c0a9e599be9fcea4047bbde0ea56dc5bf8c052 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 12:47:54 +0100 Subject: [PATCH 12/78] reorganise annotation family of tests --- tests/testthat/test-annotate.R | 79 ----------------------- tests/testthat/test-annotation-borders.R | 5 ++ tests/testthat/test-annotation-custom.R | 32 +++++++++ tests/testthat/test-annotation-logticks.R | 10 +++ tests/testthat/test-annotation-map.R | 14 ++++ tests/testthat/test-annotation-raster.R | 30 +++++++++ 6 files changed, 91 insertions(+), 79 deletions(-) create mode 100644 tests/testthat/test-annotation-borders.R create mode 100644 tests/testthat/test-annotation-custom.R create mode 100644 tests/testthat/test-annotation-logticks.R create mode 100644 tests/testthat/test-annotation-map.R create mode 100644 tests/testthat/test-annotation-raster.R diff --git a/tests/testthat/test-annotate.R b/tests/testthat/test-annotate.R index 118927b96d..e692951d07 100644 --- a/tests/testthat/test-annotate.R +++ b/tests/testthat/test-annotate.R @@ -28,46 +28,6 @@ test_that("segment annotations transform with scales", { expect_doppelganger("line matches points", plot) }) -test_that("annotation_* has dummy data assigned and don't inherit aes", { - skip_if_not_installed("maps") - custom <- annotation_custom(zeroGrob()) - logtick <- annotation_logticks() - usamap <- map_data("state") - map <- annotation_map(usamap) - rainbow <- matrix(hcl(seq(0, 360, length.out = 50 * 50), 80, 70), nrow = 50) - raster <- annotation_raster(rainbow, 15, 20, 3, 4) - dummy <- dummy_data() - expect_equal(custom$data, dummy) - expect_equal(logtick$data, dummy) - expect_equal(map$data, dummy) - expect_equal(raster$data, dummy) - - expect_false(custom$inherit.aes) - expect_false(logtick$inherit.aes) - expect_false(map$inherit.aes) - expect_false(raster$inherit.aes) -}) - -test_that("annotation_raster() and annotation_custom() requires cartesian coordinates", { - rainbow <- matrix(hcl(seq(0, 360, length.out = 50 * 50), 80, 70), nrow = 50) - p <- ggplot() + - annotation_raster(rainbow, 15, 20, 3, 4) + - coord_polar() - expect_snapshot_error(ggplotGrob(p)) - p <- ggplot() + - annotation_custom( - grob = grid::roundrectGrob(), - xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf - ) + - coord_polar() - expect_snapshot_error(ggplotGrob(p)) -}) - -test_that("annotation_map() checks the input data", { - expect_snapshot_error(annotation_map(letters)) - expect_snapshot_error(annotation_map(mtcars)) -}) - test_that("unsupported geoms signal a warning (#4719)", { expect_snapshot_warning(annotate("hline", yintercept = 0)) }) @@ -76,47 +36,8 @@ test_that("annotate() checks aesthetic lengths match", { expect_snapshot_error(annotate("point", 1:3, 1:3, fill = c('red', 'black'))) }) -test_that("annotation_logticks warns about deprecated `size` argument", { - expect_snapshot_warning(annotation_logticks(size = 5)) -}) - test_that("annotate() warns about `stat` or `position` arguments", { expect_snapshot_warning( annotate("point", 1:3, 1:3, stat = "density", position = "dodge") ) }) - -test_that("annotation_custom() and annotation_raster() adhere to scale transforms", { - rast <- matrix(rainbow(10), nrow = 1) - - p <- ggplot() + - annotation_raster(rast, 1, 10, 1, 9) + - scale_x_continuous(transform = "log10", limits = c(0.1, 100), expand = FALSE) + - scale_y_continuous(limits = c(0, 10), expand = FALSE) - ann <- get_layer_grob(p)[[1]] - - expect_equal(as.numeric(ann$x), 1/3) - expect_equal(as.numeric(ann$y), 1/10) - expect_equal(as.numeric(ann$width), 1/3) - expect_equal(as.numeric(ann$height), 8/10) - - rast <- rasterGrob(rast, width = 1, height = 1) - - p <- ggplot() + - annotation_custom(rast, 1, 10, 1, 9) + - scale_x_continuous(transform = "log10", limits = c(0.1, 100), expand = FALSE) + - scale_y_continuous(limits = c(0, 10), expand = FALSE) - ann <- get_layer_grob(p)[[1]]$vp - - expect_equal(as.numeric(ann$x), 1/2) - expect_equal(as.numeric(ann$y), 1/2) - expect_equal(as.numeric(ann$width), 1/3) - expect_equal(as.numeric(ann$height), 8/10) - -}) - -test_that("annotation_borders() can create a map", { - skip_if_not_installed("maps") - lifecycle::expect_deprecated(utah <- borders("state", "utah")) - expect_doppelganger("annotation_borders utah", ggplot() + utah) -}) diff --git a/tests/testthat/test-annotation-borders.R b/tests/testthat/test-annotation-borders.R new file mode 100644 index 0000000000..3d89796c84 --- /dev/null +++ b/tests/testthat/test-annotation-borders.R @@ -0,0 +1,5 @@ +test_that("annotation_borders() can create a map", { + skip_if_not_installed("maps") + lifecycle::expect_deprecated(utah <- borders("state", "utah")) + expect_doppelganger("annotation_borders utah", ggplot() + utah) +}) diff --git a/tests/testthat/test-annotation-custom.R b/tests/testthat/test-annotation-custom.R new file mode 100644 index 0000000000..fe01558856 --- /dev/null +++ b/tests/testthat/test-annotation-custom.R @@ -0,0 +1,32 @@ +test_that("annotation_custom() has dummy data assigned and doesn't inherit aes", { + custom <- annotation_custom(zeroGrob()) + dummy <- dummy_data() + expect_equal(custom$data, dummy) + expect_false(custom$inherit.aes) +}) + +test_that("annotation_custom() adheres to scale transforms", { + + rast <- rasterGrob(matrix(rainbow(10), nrow = 1), width = 1, height = 1) + + p <- ggplot() + + annotation_custom(rast, 1, 10, 1, 9) + + scale_x_continuous(transform = "log10", limits = c(0.1, 100), expand = FALSE) + + scale_y_continuous(limits = c(0, 10), expand = FALSE) + ann <- get_layer_grob(p)[[1]]$vp + + expect_equal(as.numeric(ann$x), 1/2) + expect_equal(as.numeric(ann$y), 1/2) + expect_equal(as.numeric(ann$width), 1/3) + expect_equal(as.numeric(ann$height), 8/10) +}) + +test_that("annotation_custom() requires cartesian coordinates", { + p <- ggplot() + + annotation_custom( + grob = grid::roundrectGrob(), + xmin = -Inf, xmax = Inf, ymin = -Inf, ymax = Inf + ) + + coord_polar() + expect_snapshot_error(ggplotGrob(p)) +}) diff --git a/tests/testthat/test-annotation-logticks.R b/tests/testthat/test-annotation-logticks.R new file mode 100644 index 0000000000..3300881cfe --- /dev/null +++ b/tests/testthat/test-annotation-logticks.R @@ -0,0 +1,10 @@ +test_that("annotation_logticks has dummy data assigned and doesn't inherit aes", { + logtick <- annotation_logticks() + dummy <- dummy_data() + expect_equal(logtick$data, dummy) + expect_false(logtick$inherit.aes) +}) + +test_that("annotation_logticks warns about deprecated `size` argument", { + lifecycle::expect_deprecated(annotation_logticks(size = 5)) +}) diff --git a/tests/testthat/test-annotation-map.R b/tests/testthat/test-annotation-map.R new file mode 100644 index 0000000000..9da631eed8 --- /dev/null +++ b/tests/testthat/test-annotation-map.R @@ -0,0 +1,14 @@ +skip_if_not_installed("maps") + +test_that("annotation_map() checks the input data", { + expect_snapshot_error(annotation_map(letters)) + expect_snapshot_error(annotation_map(mtcars)) +}) + +test_that("annotation_* has dummy data assigned and don't inherit aes", { + usamap <- map_data("state") + map <- annotation_map(usamap) + dummy <- dummy_data() + expect_equal(map$data, dummy) + expect_false(map$inherit.aes) +}) diff --git a/tests/testthat/test-annotation-raster.R b/tests/testthat/test-annotation-raster.R new file mode 100644 index 0000000000..9c7d3d0204 --- /dev/null +++ b/tests/testthat/test-annotation-raster.R @@ -0,0 +1,30 @@ +test_that("annotation_raster has dummy data assigned and doesn't inherit aes", { + rainbow <- matrix(hcl(seq(0, 360, length.out = 50 * 50), 80, 70), nrow = 50) + raster <- annotation_raster(rainbow, 15, 20, 3, 4) + dummy <- dummy_data() + expect_equal(raster$data, dummy) + expect_false(raster$inherit.aes) +}) + +test_that("annotation_raster() adheres to scale transforms", { + rast <- matrix(rainbow(10), nrow = 1) + + p <- ggplot() + + annotation_raster(rast, 1, 10, 1, 9) + + scale_x_continuous(transform = "log10", limits = c(0.1, 100), expand = FALSE) + + scale_y_continuous(limits = c(0, 10), expand = FALSE) + ann <- get_layer_grob(p)[[1]] + + expect_equal(as.numeric(ann$x), 1/3) + expect_equal(as.numeric(ann$y), 1/10) + expect_equal(as.numeric(ann$width), 1/3) + expect_equal(as.numeric(ann$height), 8/10) +}) + +test_that("annotation_raster() requires cartesian coordinates", { + rainbow <- matrix(hcl(seq(0, 360, length.out = 50 * 50), 80, 70), nrow = 50) + p <- ggplot() + + annotation_raster(rainbow, 15, 20, 3, 4) + + coord_polar() + expect_snapshot_error(ggplotGrob(p)) +}) From 25ef778eadaa6192dd738bb89863522f0cc89fd1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:12:45 +0100 Subject: [PATCH 13/78] align `test-axis-secondary` --- tests/testthat/{test-sec-axis.R => test-axis-secondary.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-sec-axis.R => test-axis-secondary.R} (100%) diff --git a/tests/testthat/test-sec-axis.R b/tests/testthat/test-axis-secondary.R similarity index 100% rename from tests/testthat/test-sec-axis.R rename to tests/testthat/test-axis-secondary.R From eb5429e595c69436947ac54b164cf3ee830a0b8d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:27:18 +0100 Subject: [PATCH 14/78] isolate binning logic in separate test file --- tests/testthat/test-bin.R | 88 +++++++++++++++++++++++++++++++++ tests/testthat/test-stat-bin.R | 90 ---------------------------------- 2 files changed, 88 insertions(+), 90 deletions(-) create mode 100644 tests/testthat/test-bin.R diff --git a/tests/testthat/test-bin.R b/tests/testthat/test-bin.R new file mode 100644 index 0000000000..282da31c06 --- /dev/null +++ b/tests/testthat/test-bin.R @@ -0,0 +1,88 @@ +test_that("bins() computes fuzz with non-finite breaks", { + test <- bins(breaks = c(-Inf, 1, Inf)) + expect_equal(test$fuzzy, test$breaks, tolerance = 1e-10) + difference <- test$fuzzy - test$breaks + expect_equal(difference[2], 1000 * .Machine$double.eps, tolerance = 0) +}) + +test_that("bins is strictly adhered to", { + + nbins <- c(1, 2, 3, 4, 5, 10, 20, 30, 40, 50) + + # Default case + nbreaks <- vapply(nbins, function(bins) { + 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(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(compute_bins(c(0, 10), bins = bins, boundary = 0)$breaks) + }, numeric(1)) + expect_equal(nbreaks, nbins + 1) + +}) + +comp_bin <- function(df, ...) { + plot <- ggplot(df, aes(x = x)) + stat_bin(...) + get_layer_data(plot) +} + +test_that("inputs to binning are checked", { + dat <- data_frame(x = c(0, 10)) + 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", { + dat <- data_frame(x = c(0, 10)) + + res <- comp_bin(dat, binwidth = 10, pad = FALSE) + expect_identical(res$count, c(1, 1)) + res <- comp_bin(dat, binwidth = 10, boundary = 5, pad = FALSE) + expect_identical(res$count, c(1, 1)) + res <- comp_bin(dat, binwidth = 10, boundary = 0, pad = FALSE) + expect_identical(res$count, 2) + res <- comp_bin(dat, binwidth = 5, boundary = 0, pad = FALSE) + expect_identical(res$count, c(1, 1)) + + res <- comp_bin(dat, binwidth = 10, pad = FALSE, closed = "left") + expect_identical(res$count, c(1, 1)) + res <- comp_bin(dat, binwidth = 10, boundary = 5, pad = FALSE, closed = "left") + expect_identical(res$count, c(1, 1)) + res <- comp_bin(dat, binwidth = 10, boundary = 0, pad = FALSE, closed = "left") + expect_identical(res$count, c(2)) + res <- comp_bin(dat, binwidth = 5, boundary = 0, pad = FALSE, closed = "left") + expect_identical(res$count, c(1, 1)) +}) + +test_that("setting boundary and center", { + # numeric + df <- data_frame(x = c(0, 30)) + + # Error if both boundary and center are specified + 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, 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) +}) + + +test_that("bin errors at high bin counts", { + expect_snapshot(compute_bins(c(1, 2e6), binwidth = 1), error = TRUE) +}) diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 27de4ef939..4d3c61036e 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -132,92 +132,6 @@ test_that("stat_bin(drop) options work as intended", { expect_equal(ld$x, c(1:3, 5:7)) }) -# Underlying binning algorithm -------------------------------------------- - -test_that("bins() computes fuzz with non-finite breaks", { - test <- bins(breaks = c(-Inf, 1, Inf)) - expect_equal(test$fuzzy, test$breaks, tolerance = 1e-10) - difference <- test$fuzzy - test$breaks - expect_equal(difference[2], 1000 * .Machine$double.eps, tolerance = 0) -}) - -test_that("bins is strictly adhered to", { - - nbins <- c(1, 2, 3, 4, 5, 10, 20, 30, 40, 50) - - # Default case - nbreaks <- vapply(nbins, function(bins) { - 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(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(compute_bins(c(0, 10), bins = bins, boundary = 0)$breaks) - }, numeric(1)) - expect_equal(nbreaks, nbins + 1) - -}) - -comp_bin <- function(df, ...) { - plot <- ggplot(df, aes(x = x)) + stat_bin(...) - get_layer_data(plot) -} - -test_that("inputs to binning are checked", { - dat <- data_frame(x = c(0, 10)) - 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", { - dat <- data_frame(x = c(0, 10)) - - res <- comp_bin(dat, binwidth = 10, pad = FALSE) - expect_identical(res$count, c(1, 1)) - res <- comp_bin(dat, binwidth = 10, boundary = 5, pad = FALSE) - expect_identical(res$count, c(1, 1)) - res <- comp_bin(dat, binwidth = 10, boundary = 0, pad = FALSE) - expect_identical(res$count, 2) - res <- comp_bin(dat, binwidth = 5, boundary = 0, pad = FALSE) - expect_identical(res$count, c(1, 1)) - - res <- comp_bin(dat, binwidth = 10, pad = FALSE, closed = "left") - expect_identical(res$count, c(1, 1)) - res <- comp_bin(dat, binwidth = 10, boundary = 5, pad = FALSE, closed = "left") - expect_identical(res$count, c(1, 1)) - res <- comp_bin(dat, binwidth = 10, boundary = 0, pad = FALSE, closed = "left") - expect_identical(res$count, c(2)) - res <- comp_bin(dat, binwidth = 5, boundary = 0, pad = FALSE, closed = "left") - expect_identical(res$count, c(1, 1)) -}) - -test_that("setting boundary and center", { - # numeric - df <- data_frame(x = c(0, 30)) - - # Error if both boundary and center are specified - 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, 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) -}) - test_that("weights are added", { df <- data_frame(x = 1:10, y = 1:10) p <- ggplot(df, aes(x = x, weight = y)) + geom_histogram(binwidth = 1) @@ -226,10 +140,6 @@ test_that("weights are added", { expect_equal(out$count, df$y) }) -test_that("bin errors at high bin counts", { - expect_snapshot(compute_bins(c(1, 2e6), binwidth = 1), error = TRUE) -}) - # stat_count -------------------------------------------------------------- test_that("stat_count throws error when both x and y aesthetic present", { From 2c56252a6b0a044b2b2f6421d419cc752a486ffd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:34:21 +0100 Subject: [PATCH 15/78] rename `test-build.R` to `test-plot-build.R` --- tests/testthat/{test-build.R => test-plot-build.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-build.R => test-plot-build.R} (100%) diff --git a/tests/testthat/test-build.R b/tests/testthat/test-plot-build.R similarity index 100% rename from tests/testthat/test-build.R rename to tests/testthat/test-plot-build.R From 5e6bd055b8d39bbca09383cfbdb31ec602200d94 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 16:17:49 +0100 Subject: [PATCH 16/78] accept snapshots moving around --- tests/testthat/_snaps/annotate.md | 27 ---------------- .../annotation-borders-utah.svg | 0 tests/testthat/_snaps/annotation-custom.md | 7 +++++ tests/testthat/_snaps/annotation-map.md | 8 +++++ tests/testthat/_snaps/annotation-raster.md | 7 +++++ .../_snaps/{sec-axis.md => axis-secondary.md} | 0 .../sec-axis-custom-transform.svg | 0 .../sec-axis-datetime-scale.svg | 0 .../sec-axis-independent-transformations.svg | 0 .../sec-axis-monotonicity-test.svg | 0 .../sec-axis-sec-power-transform.svg | 0 .../sec-axis-skewed-transform.svg | 0 .../sec-axis-with-division.svg | 0 tests/testthat/_snaps/bin.md | 31 +++++++++++++++++++ tests/testthat/_snaps/stat-bin.md | 31 ------------------- 15 files changed, 53 insertions(+), 58 deletions(-) rename tests/testthat/_snaps/{annotate => annotation-borders}/annotation-borders-utah.svg (100%) create mode 100644 tests/testthat/_snaps/annotation-custom.md create mode 100644 tests/testthat/_snaps/annotation-map.md create mode 100644 tests/testthat/_snaps/annotation-raster.md rename tests/testthat/_snaps/{sec-axis.md => axis-secondary.md} (100%) rename tests/testthat/_snaps/{sec-axis => axis-secondary}/sec-axis-custom-transform.svg (100%) rename tests/testthat/_snaps/{sec-axis => axis-secondary}/sec-axis-datetime-scale.svg (100%) rename tests/testthat/_snaps/{sec-axis => axis-secondary}/sec-axis-independent-transformations.svg (100%) rename tests/testthat/_snaps/{sec-axis => axis-secondary}/sec-axis-monotonicity-test.svg (100%) rename tests/testthat/_snaps/{sec-axis => axis-secondary}/sec-axis-sec-power-transform.svg (100%) rename tests/testthat/_snaps/{sec-axis => axis-secondary}/sec-axis-skewed-transform.svg (100%) rename tests/testthat/_snaps/{sec-axis => axis-secondary}/sec-axis-with-division.svg (100%) create mode 100644 tests/testthat/_snaps/bin.md diff --git a/tests/testthat/_snaps/annotate.md b/tests/testthat/_snaps/annotate.md index abf4bb83e7..0b0552029a 100644 --- a/tests/testthat/_snaps/annotate.md +++ b/tests/testthat/_snaps/annotate.md @@ -1,25 +1,3 @@ -# annotation_raster() and annotation_custom() requires cartesian coordinates - - Problem while converting geom to grob. - i Error occurred in the 1st layer. - Caused by error in `ranges_annotation()`: - ! `annotation_raster()` only works with `coord_cartesian()`. - ---- - - Problem while converting geom to grob. - i Error occurred in the 1st layer. - Caused by error in `ranges_annotation()`: - ! `annotation_custom()` only works with `coord_cartesian()`. - -# annotation_map() checks the input data - - `map` must be a data frame, not a character vector. - ---- - - `map` must have the columns `x`, `y`, and `id`. - # unsupported geoms signal a warning (#4719) `geom` must not be "hline". @@ -29,11 +7,6 @@ Unequal parameter lengths: x (3), y (3), and fill (2) -# annotation_logticks warns about deprecated `size` argument - - Using the `size` aesthetic in this geom was deprecated in ggplot2 3.5.0. - i Please use `linewidth` instead. - # annotate() warns about `stat` or `position` arguments `annotate()` can't accept `stat` or `position` arguments. diff --git a/tests/testthat/_snaps/annotate/annotation-borders-utah.svg b/tests/testthat/_snaps/annotation-borders/annotation-borders-utah.svg similarity index 100% rename from tests/testthat/_snaps/annotate/annotation-borders-utah.svg rename to tests/testthat/_snaps/annotation-borders/annotation-borders-utah.svg diff --git a/tests/testthat/_snaps/annotation-custom.md b/tests/testthat/_snaps/annotation-custom.md new file mode 100644 index 0000000000..baf5986eec --- /dev/null +++ b/tests/testthat/_snaps/annotation-custom.md @@ -0,0 +1,7 @@ +# annotation_custom() requires cartesian coordinates + + Problem while converting geom to grob. + i Error occurred in the 1st layer. + Caused by error in `ranges_annotation()`: + ! `annotation_custom()` only works with `coord_cartesian()`. + diff --git a/tests/testthat/_snaps/annotation-map.md b/tests/testthat/_snaps/annotation-map.md new file mode 100644 index 0000000000..e5035c1ce2 --- /dev/null +++ b/tests/testthat/_snaps/annotation-map.md @@ -0,0 +1,8 @@ +# annotation_map() checks the input data + + `map` must be a data frame, not a character vector. + +--- + + `map` must have the columns `x`, `y`, and `id`. + diff --git a/tests/testthat/_snaps/annotation-raster.md b/tests/testthat/_snaps/annotation-raster.md new file mode 100644 index 0000000000..2f81d53282 --- /dev/null +++ b/tests/testthat/_snaps/annotation-raster.md @@ -0,0 +1,7 @@ +# annotation_raster() requires cartesian coordinates + + Problem while converting geom to grob. + i Error occurred in the 1st layer. + Caused by error in `ranges_annotation()`: + ! `annotation_raster()` only works with `coord_cartesian()`. + diff --git a/tests/testthat/_snaps/sec-axis.md b/tests/testthat/_snaps/axis-secondary.md similarity index 100% rename from tests/testthat/_snaps/sec-axis.md rename to tests/testthat/_snaps/axis-secondary.md diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-custom-transform.svg b/tests/testthat/_snaps/axis-secondary/sec-axis-custom-transform.svg similarity index 100% rename from tests/testthat/_snaps/sec-axis/sec-axis-custom-transform.svg rename to tests/testthat/_snaps/axis-secondary/sec-axis-custom-transform.svg diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-datetime-scale.svg b/tests/testthat/_snaps/axis-secondary/sec-axis-datetime-scale.svg similarity index 100% rename from tests/testthat/_snaps/sec-axis/sec-axis-datetime-scale.svg rename to tests/testthat/_snaps/axis-secondary/sec-axis-datetime-scale.svg diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-independent-transformations.svg b/tests/testthat/_snaps/axis-secondary/sec-axis-independent-transformations.svg similarity index 100% rename from tests/testthat/_snaps/sec-axis/sec-axis-independent-transformations.svg rename to tests/testthat/_snaps/axis-secondary/sec-axis-independent-transformations.svg diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-monotonicity-test.svg b/tests/testthat/_snaps/axis-secondary/sec-axis-monotonicity-test.svg similarity index 100% rename from tests/testthat/_snaps/sec-axis/sec-axis-monotonicity-test.svg rename to tests/testthat/_snaps/axis-secondary/sec-axis-monotonicity-test.svg diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-sec-power-transform.svg b/tests/testthat/_snaps/axis-secondary/sec-axis-sec-power-transform.svg similarity index 100% rename from tests/testthat/_snaps/sec-axis/sec-axis-sec-power-transform.svg rename to tests/testthat/_snaps/axis-secondary/sec-axis-sec-power-transform.svg diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-skewed-transform.svg b/tests/testthat/_snaps/axis-secondary/sec-axis-skewed-transform.svg similarity index 100% rename from tests/testthat/_snaps/sec-axis/sec-axis-skewed-transform.svg rename to tests/testthat/_snaps/axis-secondary/sec-axis-skewed-transform.svg diff --git a/tests/testthat/_snaps/sec-axis/sec-axis-with-division.svg b/tests/testthat/_snaps/axis-secondary/sec-axis-with-division.svg similarity index 100% rename from tests/testthat/_snaps/sec-axis/sec-axis-with-division.svg rename to tests/testthat/_snaps/axis-secondary/sec-axis-with-division.svg diff --git a/tests/testthat/_snaps/bin.md b/tests/testthat/_snaps/bin.md new file mode 100644 index 0000000000..1f5e110a93 --- /dev/null +++ b/tests/testthat/_snaps/bin.md @@ -0,0 +1,31 @@ +# inputs to binning are checked + + `breaks` must be a vector, not a character vector. + +--- + + `binwidth` must be a number, not a character vector. + +--- + + `binwidth` must be a number larger than or equal to 0, not the number -4. + +--- + + `bins` must be a whole number larger than or equal to 1, not the number -4. + +# setting boundary and center + + 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 + 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. + i Did you make `binwidth` too small? + diff --git a/tests/testthat/_snaps/stat-bin.md b/tests/testthat/_snaps/stat-bin.md index db0b8f44c0..fb035d2996 100644 --- a/tests/testthat/_snaps/stat-bin.md +++ b/tests/testthat/_snaps/stat-bin.md @@ -21,37 +21,6 @@ x the x aesthetic is discrete. i Perhaps you want `stat="count"`? -# inputs to binning are checked - - `breaks` must be a vector, not a character vector. - ---- - - `binwidth` must be a number, not a character vector. - ---- - - `binwidth` must be a number larger than or equal to 0, not the number -4. - ---- - - `bins` must be a whole number larger than or equal to 1, not the number -4. - -# setting boundary and center - - 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 - 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. - i Did you make `binwidth` too small? - # stat_count throws error when both x and y aesthetic present Problem while computing stat. From 0052c8b07889a15b5964d9f8328263d9cc756ebb Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:50:40 +0100 Subject: [PATCH 17/78] fix typo in `test-coord_sf.R` name --- tests/testthat/{test-coord_sf.R => test-coord-sf.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-coord_sf.R => test-coord-sf.R} (100%) diff --git a/tests/testthat/test-coord_sf.R b/tests/testthat/test-coord-sf.R similarity index 100% rename from tests/testthat/test-coord_sf.R rename to tests/testthat/test-coord-sf.R From bd58d37302d129517a6779f88698569455afe0dc Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:50:54 +0100 Subject: [PATCH 18/78] move test in `test-coord-train.R` --- tests/testthat/test-coord-.R | 35 +++++++++++++++++++++++++++++++ tests/testthat/test-coord-train.R | 33 ----------------------------- 2 files changed, 35 insertions(+), 33 deletions(-) delete mode 100644 tests/testthat/test-coord-train.R diff --git a/tests/testthat/test-coord-.R b/tests/testthat/test-coord-.R index ea80cb5ce1..389a39b464 100644 --- a/tests/testthat/test-coord-.R +++ b/tests/testthat/test-coord-.R @@ -108,3 +108,38 @@ test_that("coord expand takes a vector", { }) +test_that("NA's don't appear in breaks", { + + # Returns true if any major/minor breaks have an NA + any_NA_major_minor <- function(trained) { + ns <- names(trained)[grepl("(\\.major)|(\\.minor)$", names(trained))] + + for (n in ns) { + if (!is.null(trained[n]) && anyNA(trained[n])) + return(TRUE) + } + + return(FALSE) + } + + scale_x <- scale_x_continuous(limits = c(1, 12)) + scale_y <- scale_y_continuous(limits = c(1, 12)) + + # First have to test that scale_breaks_positions will return a vector with NA + # This is a test to make sure the later tests will be useful! + # It's possible that changes to the way that breaks are calculated will + # make it so that scale_break_positions will no longer give NA for range 1, 12 + expect_true(anyNA(scale_x$break_positions())) + expect_true(anyNA(scale_y$break_positions())) + + # Check the various types of coords to make sure they don't have NA breaks + expect_false(any_NA_major_minor(coord_polar()$setup_panel_params(scale_x, scale_y))) + expect_false(any_NA_major_minor(coord_cartesian()$setup_panel_params(scale_x, scale_y))) + expect_false(any_NA_major_minor(coord_transform()$setup_panel_params(scale_x, scale_y))) + expect_false(any_NA_major_minor(coord_fixed()$setup_panel_params(scale_x, scale_y))) + + skip_if_not_installed("mapproj") + expect_false(any_NA_major_minor(coord_map()$setup_panel_params(scale_x, scale_y))) +}) + + diff --git a/tests/testthat/test-coord-train.R b/tests/testthat/test-coord-train.R deleted file mode 100644 index 39344d8e2d..0000000000 --- a/tests/testthat/test-coord-train.R +++ /dev/null @@ -1,33 +0,0 @@ -test_that("NA's don't appear in breaks", { - - # Returns true if any major/minor breaks have an NA - any_NA_major_minor <- function(trained) { - ns <- names(trained)[grepl("(\\.major)|(\\.minor)$", names(trained))] - - for (n in ns) { - if (!is.null(trained[n]) && anyNA(trained[n])) - return(TRUE) - } - - return(FALSE) - } - - scale_x <- scale_x_continuous(limits = c(1, 12)) - scale_y <- scale_y_continuous(limits = c(1, 12)) - - # First have to test that scale_breaks_positions will return a vector with NA - # This is a test to make sure the later tests will be useful! - # It's possible that changes to the way that breaks are calculated will - # make it so that scale_break_positions will no longer give NA for range 1, 12 - expect_true(anyNA(scale_x$break_positions())) - expect_true(anyNA(scale_y$break_positions())) - - # Check the various types of coords to make sure they don't have NA breaks - expect_false(any_NA_major_minor(coord_polar()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_cartesian()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_transform()$setup_panel_params(scale_x, scale_y))) - expect_false(any_NA_major_minor(coord_fixed()$setup_panel_params(scale_x, scale_y))) - - skip_if_not_installed("mapproj") - expect_false(any_NA_major_minor(coord_map()$setup_panel_params(scale_x, scale_y))) -}) From 582d5a0d6fae306a7755c490549eec74a6414615 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:52:19 +0100 Subject: [PATCH 19/78] kebab-case `docs-layer.R` --- R/{docs_layer.R => docs-layer.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{docs_layer.R => docs-layer.R} (100%) diff --git a/R/docs_layer.R b/R/docs-layer.R similarity index 100% rename from R/docs_layer.R rename to R/docs-layer.R From 3b63e686d3385e1077589a80026f341ae36c3ee0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:55:29 +0100 Subject: [PATCH 20/78] migrate layer tests for empty data --- tests/testthat/test-empty-data.R | 100 ----------------------------- tests/testthat/test-layer.R | 105 +++++++++++++++++++++++++++++++ 2 files changed, 105 insertions(+), 100 deletions(-) delete mode 100644 tests/testthat/test-empty-data.R diff --git a/tests/testthat/test-empty-data.R b/tests/testthat/test-empty-data.R deleted file mode 100644 index 58b2180adc..0000000000 --- a/tests/testthat/test-empty-data.R +++ /dev/null @@ -1,100 +0,0 @@ -df0 <- data_frame(mpg = numeric(0), wt = numeric(0), am = numeric(0), cyl = numeric(0)) - -test_that("layers with empty data are silently omitted", { - # Empty data (no visible points) - d <- ggplot(df0, aes(mpg,wt)) + geom_point() - expect_equal(nrow(get_layer_data(d)), 0) - - d <- ggplot() + geom_point(data = df0, aes(mpg,wt)) - expect_equal(nrow(get_layer_data(d)), 0) - - # Regular mtcars data, x=mpg, y=wt, normal points and points from empty data frame - d <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_point(data = df0) - expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) - expect_equal(nrow(get_layer_data(d, 2)), 0) - - # Regular mtcars data, but points only from empty data frame - d <- ggplot(mtcars, aes(mpg, wt)) + geom_point(data = df0) - expect_equal(nrow(get_layer_data(d, 1)), 0) -}) - -test_that("plots with empty data and vectors for aesthetics work", { - d <- ggplot(NULL, aes(1:5, 1:5)) + geom_point() - expect_equal(nrow(get_layer_data(d)), 5) - - d <- ggplot(data_frame(), aes(1:5, 1:5)) + geom_point() - expect_equal(nrow(get_layer_data(d)), 5) - - d <- ggplot() + geom_point(aes(1:5, 1:5)) - expect_equal(nrow(get_layer_data(d)), 5) -}) - -test_that("layers with empty data are silently omitted with facet_wrap", { - # Empty data, facet_wrap, throws error - d <- ggplot(df0, aes(mpg, wt)) + - geom_point() + - facet_wrap(~cyl) - expect_snapshot(get_layer_data(d), error = TRUE) - - d <- d + geom_point(data = mtcars) - expect_equal(nrow(get_layer_data(d, 1)), 0) - expect_equal(nrow(get_layer_data(d, 2)), nrow(mtcars)) -}) - -test_that("layers with empty data are silently omitted with facet_grid", { - d <- ggplot(df0, aes(mpg, wt)) + - geom_point() + - facet_grid(am ~ cyl) - expect_snapshot(get_layer_data(d), error = TRUE) - - d <- d + geom_point(data = mtcars) - expect_equal(nrow(get_layer_data(d, 1)), 0) - expect_equal(nrow(get_layer_data(d, 2)), nrow(mtcars)) -}) - -test_that("empty data overrides plot defaults", { - # No extra points when x and y vars don't exist but are set - d <- ggplot(mtcars, aes(mpg, wt)) + - geom_point() + - geom_point(data = data_frame(), x = 20, y = 3) - expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) - expect_equal(nrow(get_layer_data(d, 2)), 0) - - # No extra points when x and y vars are empty, even when aesthetics are set - d <- ggplot(mtcars, aes(mpg, wt)) + - geom_point() + - geom_point(data = df0, x = 20, y = 3) - expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) - expect_equal(nrow(get_layer_data(d, 2)), 0) - - skip_if(getRversion() <= "4.4.0") - d <- ggplot(mtcars, aes(mpg, wt)) + - geom_point() + - geom_point(data = data_frame()) - expect_snapshot(get_layer_data(d), error = TRUE) -}) - -test_that("layer inherits data from plot when data = NULL", { - d <- ggplot(mtcars, aes(mpg, wt)) + - geom_point(data = NULL) - expect_equal(nrow(get_layer_data(d)), nrow(mtcars)) -}) - -test_that("empty layers still generate one grob per panel", { - df <- data_frame(x = 1:3, y = c("a", "b", "c")) - - d <- ggplot(df, aes(x, y)) + - geom_point(data = df[0, ]) + - geom_point() + - facet_wrap(~y) - - expect_length(get_layer_grob(d), 3) -}) - -test_that("missing layers generate one grob per panel", { - df <- data_frame(x = 1:4, y = rep(1:2, 2), g = rep(1:2, 2)) - base <- ggplot(df, aes(x, y)) + geom_point(shape = NA, na.rm = TRUE) - - expect_length(get_layer_grob(base), 1) - expect_length(get_layer_grob(base + facet_wrap(~ g)), 2) -}) diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 9528c2927f..0e65b2a74e 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -242,3 +242,108 @@ test_that("data.frames and matrix aesthetics survive the build stage", { expect_vector(p$colour, matrix(NA_integer_, nrow = 0, ncol = 2), size = 2) expect_vector(p$shape, data_frame0(a = integer(), b = character()), size = 2) }) + +# Empty data -------------------------------------------------------------- + +df0 <- data_frame(mpg = numeric(0), wt = numeric(0), am = numeric(0), cyl = numeric(0)) + +test_that("layers with empty data are silently omitted", { + # Empty data (no visible points) + d <- ggplot(df0, aes(mpg,wt)) + geom_point() + expect_equal(nrow(get_layer_data(d)), 0) + + d <- ggplot() + geom_point(data = df0, aes(mpg,wt)) + expect_equal(nrow(get_layer_data(d)), 0) + + # Regular mtcars data, x=mpg, y=wt, normal points and points from empty data frame + d <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_point(data = df0) + expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 2)), 0) + + # Regular mtcars data, but points only from empty data frame + d <- ggplot(mtcars, aes(mpg, wt)) + geom_point(data = df0) + expect_equal(nrow(get_layer_data(d, 1)), 0) +}) + +test_that("plots with empty data and vectors for aesthetics work", { + d <- ggplot(NULL, aes(1:5, 1:5)) + geom_point() + expect_equal(nrow(get_layer_data(d)), 5) + + d <- ggplot(data_frame(), aes(1:5, 1:5)) + geom_point() + expect_equal(nrow(get_layer_data(d)), 5) + + d <- ggplot() + geom_point(aes(1:5, 1:5)) + expect_equal(nrow(get_layer_data(d)), 5) +}) + +test_that("layers with empty data are silently omitted with facet_wrap", { + # Empty data, facet_wrap, throws error + d <- ggplot(df0, aes(mpg, wt)) + + geom_point() + + facet_wrap(~cyl) + expect_snapshot(get_layer_data(d), error = TRUE) + + d <- d + geom_point(data = mtcars) + expect_equal(nrow(get_layer_data(d, 1)), 0) + expect_equal(nrow(get_layer_data(d, 2)), nrow(mtcars)) +}) + +test_that("layers with empty data are silently omitted with facet_grid", { + d <- ggplot(df0, aes(mpg, wt)) + + geom_point() + + facet_grid(am ~ cyl) + expect_snapshot(get_layer_data(d), error = TRUE) + + d <- d + geom_point(data = mtcars) + expect_equal(nrow(get_layer_data(d, 1)), 0) + expect_equal(nrow(get_layer_data(d, 2)), nrow(mtcars)) +}) + +test_that("empty data overrides plot defaults", { + # No extra points when x and y vars don't exist but are set + d <- ggplot(mtcars, aes(mpg, wt)) + + geom_point() + + geom_point(data = data_frame(), x = 20, y = 3) + expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 2)), 0) + + # No extra points when x and y vars are empty, even when aesthetics are set + d <- ggplot(mtcars, aes(mpg, wt)) + + geom_point() + + geom_point(data = df0, x = 20, y = 3) + expect_equal(nrow(get_layer_data(d, 1)), nrow(mtcars)) + expect_equal(nrow(get_layer_data(d, 2)), 0) + + skip_if(getRversion() <= "4.4.0") + d <- ggplot(mtcars, aes(mpg, wt)) + + geom_point() + + geom_point(data = data_frame()) + expect_snapshot(get_layer_data(d), error = TRUE) +}) + +test_that("layer inherits data from plot when data = NULL", { + d <- ggplot(mtcars, aes(mpg, wt)) + + geom_point(data = NULL) + expect_equal(nrow(get_layer_data(d)), nrow(mtcars)) +}) + +test_that("empty layers still generate one grob per panel", { + df <- data_frame(x = 1:3, y = c("a", "b", "c")) + + d <- ggplot(df, aes(x, y)) + + geom_point(data = df[0, ]) + + geom_point() + + facet_wrap(~y) + + expect_length(get_layer_grob(d), 3) +}) + +test_that("missing layers generate one grob per panel", { + df <- data_frame(x = 1:4, y = rep(1:2, 2), g = rep(1:2, 2)) + base <- ggplot(df, aes(x, y)) + geom_point(shape = NA, na.rm = TRUE) + + expect_length(get_layer_grob(base), 1) + expect_length(get_layer_grob(base + facet_wrap(~ g)), 2) +}) + + From 34170fcc7211a527033722eb87d10ad89e2e53eb Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 13:59:02 +0100 Subject: [PATCH 21/78] migrate `test-draw-key.R` --- tests/testthat/test-draw-key.R | 121 ------------------------------ tests/testthat/test-legend-draw.R | 121 ++++++++++++++++++++++++++++++ 2 files changed, 121 insertions(+), 121 deletions(-) delete mode 100644 tests/testthat/test-draw-key.R diff --git a/tests/testthat/test-draw-key.R b/tests/testthat/test-draw-key.R deleted file mode 100644 index 511077d0a1..0000000000 --- a/tests/testthat/test-draw-key.R +++ /dev/null @@ -1,121 +0,0 @@ -# Setting of legend key glyphs has to be tested visually - -test_that("alternative key glyphs work", { - df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) - - # specify key glyph by name - expect_doppelganger("time series and polygon key glyphs", - ggplot(df, aes(x, y)) + - geom_line(aes(color = "line"), key_glyph = "timeseries") + - geom_point(aes(fill = z), pch = 21, size = 3, key_glyph = "polygon") + - guides(fill = guide_legend(order = 1)) - ) - - # specify key glyph by function - expect_doppelganger("rectangle and dotplot key glyphs", - ggplot(df, aes(x, y)) + - geom_line(aes(color = "line"), key_glyph = draw_key_rect) + - geom_point(aes(fill = z), pch = 21, size = 3, stroke = 2, key_glyph = draw_key_dotplot) + - guides(fill = guide_legend(order = 1)) - ) -}) - -test_that("keys can communicate their size", { - - draw_key_dummy <- function(data, params, size) { - grob <- circleGrob(r = unit(1, "cm")) - attr(grob, "width") <- 2 - attr(grob, "height") <- 2 - grob - } - - expect_doppelganger( - "circle glyphs of 2cm size", - ggplot(mtcars, aes(mpg, wt, colour = factor(cyl))) + - geom_point(key_glyph = draw_key_dummy) - ) -}) - -# Orientation-aware key glyphs -------------------------------------------- - -test_that("horizontal key glyphs work", { - df <- data.frame( - middle = 1:2, - lower = 0:1, - upper = 2:3, - min = -1:0, - max = 3:4, - group1 = c("a","b"), - group2 = c("c","d") - ) - - p <- ggplot(df, aes( - x = middle, - xmiddle = middle, - xlower = lower, - xupper = upper, - xmin = min, - xmax = max - )) - - expect_doppelganger("horizontal boxplot and crossbar", - p + - geom_boxplot(aes(y = group1, color = group1), stat = "identity") + - geom_crossbar(aes(y = group2, fill = group2)) + - guides(color = guide_legend(order = 1)) - ) - expect_doppelganger("horizontal linerange and pointrange", - p + - geom_linerange(aes(y = group1, color = group1)) + - geom_pointrange(aes(y = group2, shape = group2)) + - guides(color = guide_legend(order = 1)) - ) -}) - -test_that("keep_draw_key", { - - key <- data_frame0(.value = c("A", "C")) - data <- data_frame0(foo = c("A", "B"), bar = c("B", "C")) - - expect_true( keep_key_data(key, data, "foo", show = TRUE)) - expect_false(keep_key_data(key, data, "foo", show = FALSE)) - expect_equal(keep_key_data(key, data, "foo", show = NA), c(TRUE, FALSE)) - expect_equal(keep_key_data(key, data, "bar", show = NA), c(FALSE, TRUE)) - expect_equal(keep_key_data(key, data, c("foo", "bar"), show = NA), c(TRUE, TRUE)) - - # Named show - expect_true( - keep_key_data(key, data, c("foo", "bar"), show = c(foo = TRUE, bar = FALSE)) - ) - expect_equal( - keep_key_data(key, data, c("foo", "bar"), show = c(foo = NA, bar = FALSE)), - c(TRUE, FALSE) - ) - expect_equal( - keep_key_data(key, data, c("foo", "bar"), show = c(foo = FALSE, bar = NA)), - c(FALSE, TRUE) - ) - - # Missing values - key <- data_frame0(.value = c("A", "B", NA)) - data <- data_frame0(foo = c("A", "B", "C")) # 'C' should count as NA - expect_equal(keep_key_data(key, data, "foo", show = NA), c(TRUE, TRUE, TRUE)) - - p <- ggplot(data.frame(x = 1:2), aes(x, x)) + - geom_point( - aes(colour = "point", alpha = "point"), - show.legend = c("colour" = NA, alpha = FALSE) - ) + - geom_line( - aes(colour = "line", alpha = "line"), - show.legend = c("colour" = NA, alpha = TRUE) - ) + - suppressWarnings(scale_alpha_discrete()) + - guides( - alpha = guide_legend(order = 1), - colour = guide_legend(order = 2) - ) - - expect_doppelganger("appropriate colour key with alpha key as lines", p) - -}) diff --git a/tests/testthat/test-legend-draw.R b/tests/testthat/test-legend-draw.R index b0c0505b2a..1943dbfc49 100644 --- a/tests/testthat/test-legend-draw.R +++ b/tests/testthat/test-legend-draw.R @@ -1,3 +1,124 @@ +# Setting of legend key glyphs has to be tested visually + +test_that("alternative key glyphs work", { + df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) + + # specify key glyph by name + expect_doppelganger("time series and polygon key glyphs", + ggplot(df, aes(x, y)) + + geom_line(aes(color = "line"), key_glyph = "timeseries") + + geom_point(aes(fill = z), pch = 21, size = 3, key_glyph = "polygon") + + guides(fill = guide_legend(order = 1)) + ) + + # specify key glyph by function + expect_doppelganger("rectangle and dotplot key glyphs", + ggplot(df, aes(x, y)) + + geom_line(aes(color = "line"), key_glyph = draw_key_rect) + + geom_point(aes(fill = z), pch = 21, size = 3, stroke = 2, key_glyph = draw_key_dotplot) + + guides(fill = guide_legend(order = 1)) + ) +}) + +test_that("keys can communicate their size", { + + draw_key_dummy <- function(data, params, size) { + grob <- circleGrob(r = unit(1, "cm")) + attr(grob, "width") <- 2 + attr(grob, "height") <- 2 + grob + } + + expect_doppelganger( + "circle glyphs of 2cm size", + ggplot(mtcars, aes(mpg, wt, colour = factor(cyl))) + + geom_point(key_glyph = draw_key_dummy) + ) +}) + +# Orientation-aware key glyphs -------------------------------------------- + +test_that("horizontal key glyphs work", { + df <- data.frame( + middle = 1:2, + lower = 0:1, + upper = 2:3, + min = -1:0, + max = 3:4, + group1 = c("a","b"), + group2 = c("c","d") + ) + + p <- ggplot(df, aes( + x = middle, + xmiddle = middle, + xlower = lower, + xupper = upper, + xmin = min, + xmax = max + )) + + expect_doppelganger("horizontal boxplot and crossbar", + p + + geom_boxplot(aes(y = group1, color = group1), stat = "identity") + + geom_crossbar(aes(y = group2, fill = group2)) + + guides(color = guide_legend(order = 1)) + ) + expect_doppelganger("horizontal linerange and pointrange", + p + + geom_linerange(aes(y = group1, color = group1)) + + geom_pointrange(aes(y = group2, shape = group2)) + + guides(color = guide_legend(order = 1)) + ) +}) + +test_that("keep_draw_key", { + + key <- data_frame0(.value = c("A", "C")) + data <- data_frame0(foo = c("A", "B"), bar = c("B", "C")) + + expect_true( keep_key_data(key, data, "foo", show = TRUE)) + expect_false(keep_key_data(key, data, "foo", show = FALSE)) + expect_equal(keep_key_data(key, data, "foo", show = NA), c(TRUE, FALSE)) + expect_equal(keep_key_data(key, data, "bar", show = NA), c(FALSE, TRUE)) + expect_equal(keep_key_data(key, data, c("foo", "bar"), show = NA), c(TRUE, TRUE)) + + # Named show + expect_true( + keep_key_data(key, data, c("foo", "bar"), show = c(foo = TRUE, bar = FALSE)) + ) + expect_equal( + keep_key_data(key, data, c("foo", "bar"), show = c(foo = NA, bar = FALSE)), + c(TRUE, FALSE) + ) + expect_equal( + keep_key_data(key, data, c("foo", "bar"), show = c(foo = FALSE, bar = NA)), + c(FALSE, TRUE) + ) + + # Missing values + key <- data_frame0(.value = c("A", "B", NA)) + data <- data_frame0(foo = c("A", "B", "C")) # 'C' should count as NA + expect_equal(keep_key_data(key, data, "foo", show = NA), c(TRUE, TRUE, TRUE)) + + p <- ggplot(data.frame(x = 1:2), aes(x, x)) + + geom_point( + aes(colour = "point", alpha = "point"), + show.legend = c("colour" = NA, alpha = FALSE) + ) + + geom_line( + aes(colour = "line", alpha = "line"), + show.legend = c("colour" = NA, alpha = TRUE) + ) + + suppressWarnings(scale_alpha_discrete()) + + guides( + alpha = guide_legend(order = 1), + colour = guide_legend(order = 2) + ) + + expect_doppelganger("appropriate colour key with alpha key as lines", p) + +}) test_that("all keys can be drawn without 'params'", { From eb7922a23db4c8ca52c96d6370bb5839909a2b1f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 16:32:50 +0100 Subject: [PATCH 22/78] accept snapshots moving around --- .../_snaps/{coord_sf.md => coord-sf.md} | 0 .../coord-sf-with-custom-guides.svg | 0 .../limits-specified-in-long-lat.svg | 0 .../limits-specified-in-projected-coords.svg | 0 .../{coord_sf => coord-sf}/no-breaks.svg | 0 .../{coord_sf => coord-sf}/no-panel-grid.svg | 0 .../non-sf-geoms-using-long-lat.svg | 0 .../non-sf-geoms-using-projected-coords.svg | 0 .../reversed-sf-coords.svg | 0 .../{coord_sf => coord-sf}/sf-polygons.svg | 0 tests/testthat/_snaps/empty-data.md | 27 ------------------- tests/testthat/_snaps/layer.md | 27 +++++++++++++++++++ ...ate-colour-key-with-alpha-key-as-lines.svg | 0 .../circle-glyphs-of-2cm-size.svg | 0 .../horizontal-boxplot-and-crossbar.svg | 0 .../horizontal-linerange-and-pointrange.svg | 0 .../rectangle-and-dotplot-key-glyphs.svg | 0 .../time-series-and-polygon-key-glyphs.svg | 0 18 files changed, 27 insertions(+), 27 deletions(-) rename tests/testthat/_snaps/{coord_sf.md => coord-sf.md} (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/coord-sf-with-custom-guides.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/limits-specified-in-long-lat.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/limits-specified-in-projected-coords.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/no-breaks.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/no-panel-grid.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/non-sf-geoms-using-long-lat.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/non-sf-geoms-using-projected-coords.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/reversed-sf-coords.svg (100%) rename tests/testthat/_snaps/{coord_sf => coord-sf}/sf-polygons.svg (100%) delete mode 100644 tests/testthat/_snaps/empty-data.md rename tests/testthat/_snaps/{draw-key => legend-draw}/appropriate-colour-key-with-alpha-key-as-lines.svg (100%) rename tests/testthat/_snaps/{draw-key => legend-draw}/circle-glyphs-of-2cm-size.svg (100%) rename tests/testthat/_snaps/{draw-key => legend-draw}/horizontal-boxplot-and-crossbar.svg (100%) rename tests/testthat/_snaps/{draw-key => legend-draw}/horizontal-linerange-and-pointrange.svg (100%) rename tests/testthat/_snaps/{draw-key => legend-draw}/rectangle-and-dotplot-key-glyphs.svg (100%) rename tests/testthat/_snaps/{draw-key => legend-draw}/time-series-and-polygon-key-glyphs.svg (100%) diff --git a/tests/testthat/_snaps/coord_sf.md b/tests/testthat/_snaps/coord-sf.md similarity index 100% rename from tests/testthat/_snaps/coord_sf.md rename to tests/testthat/_snaps/coord-sf.md diff --git a/tests/testthat/_snaps/coord_sf/coord-sf-with-custom-guides.svg b/tests/testthat/_snaps/coord-sf/coord-sf-with-custom-guides.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/coord-sf-with-custom-guides.svg rename to tests/testthat/_snaps/coord-sf/coord-sf-with-custom-guides.svg diff --git a/tests/testthat/_snaps/coord_sf/limits-specified-in-long-lat.svg b/tests/testthat/_snaps/coord-sf/limits-specified-in-long-lat.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/limits-specified-in-long-lat.svg rename to tests/testthat/_snaps/coord-sf/limits-specified-in-long-lat.svg diff --git a/tests/testthat/_snaps/coord_sf/limits-specified-in-projected-coords.svg b/tests/testthat/_snaps/coord-sf/limits-specified-in-projected-coords.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/limits-specified-in-projected-coords.svg rename to tests/testthat/_snaps/coord-sf/limits-specified-in-projected-coords.svg diff --git a/tests/testthat/_snaps/coord_sf/no-breaks.svg b/tests/testthat/_snaps/coord-sf/no-breaks.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/no-breaks.svg rename to tests/testthat/_snaps/coord-sf/no-breaks.svg diff --git a/tests/testthat/_snaps/coord_sf/no-panel-grid.svg b/tests/testthat/_snaps/coord-sf/no-panel-grid.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/no-panel-grid.svg rename to tests/testthat/_snaps/coord-sf/no-panel-grid.svg diff --git a/tests/testthat/_snaps/coord_sf/non-sf-geoms-using-long-lat.svg b/tests/testthat/_snaps/coord-sf/non-sf-geoms-using-long-lat.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/non-sf-geoms-using-long-lat.svg rename to tests/testthat/_snaps/coord-sf/non-sf-geoms-using-long-lat.svg diff --git a/tests/testthat/_snaps/coord_sf/non-sf-geoms-using-projected-coords.svg b/tests/testthat/_snaps/coord-sf/non-sf-geoms-using-projected-coords.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/non-sf-geoms-using-projected-coords.svg rename to tests/testthat/_snaps/coord-sf/non-sf-geoms-using-projected-coords.svg diff --git a/tests/testthat/_snaps/coord_sf/reversed-sf-coords.svg b/tests/testthat/_snaps/coord-sf/reversed-sf-coords.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/reversed-sf-coords.svg rename to tests/testthat/_snaps/coord-sf/reversed-sf-coords.svg diff --git a/tests/testthat/_snaps/coord_sf/sf-polygons.svg b/tests/testthat/_snaps/coord-sf/sf-polygons.svg similarity index 100% rename from tests/testthat/_snaps/coord_sf/sf-polygons.svg rename to tests/testthat/_snaps/coord-sf/sf-polygons.svg diff --git a/tests/testthat/_snaps/empty-data.md b/tests/testthat/_snaps/empty-data.md deleted file mode 100644 index 38966a1dab..0000000000 --- a/tests/testthat/_snaps/empty-data.md +++ /dev/null @@ -1,27 +0,0 @@ -# layers with empty data are silently omitted with facet_wrap - - Code - get_layer_data(d) - Condition - Error in `combine_vars()`: - ! Faceting variables must have at least one value. - -# layers with empty data are silently omitted with facet_grid - - Code - get_layer_data(d) - Condition - Error in `combine_vars()`: - ! Faceting variables must have at least one value. - -# empty data overrides plot defaults - - Code - get_layer_data(d) - Condition - Error in `geom_point()`: - ! Problem while computing aesthetics. - i Error occurred in the 2nd layer. - Caused by error: - ! object 'wt' not found - diff --git a/tests/testthat/_snaps/layer.md b/tests/testthat/_snaps/layer.md index a7ae1d1a85..943ac00b46 100644 --- a/tests/testthat/_snaps/layer.md +++ b/tests/testthat/_snaps/layer.md @@ -145,3 +145,30 @@ `layer_data()` must return a . +# layers with empty data are silently omitted with facet_wrap + + Code + get_layer_data(d) + Condition + Error in `combine_vars()`: + ! Faceting variables must have at least one value. + +# layers with empty data are silently omitted with facet_grid + + Code + get_layer_data(d) + Condition + Error in `combine_vars()`: + ! Faceting variables must have at least one value. + +# empty data overrides plot defaults + + Code + get_layer_data(d) + Condition + Error in `geom_point()`: + ! Problem while computing aesthetics. + i Error occurred in the 2nd layer. + Caused by error: + ! object 'wt' not found + diff --git a/tests/testthat/_snaps/draw-key/appropriate-colour-key-with-alpha-key-as-lines.svg b/tests/testthat/_snaps/legend-draw/appropriate-colour-key-with-alpha-key-as-lines.svg similarity index 100% rename from tests/testthat/_snaps/draw-key/appropriate-colour-key-with-alpha-key-as-lines.svg rename to tests/testthat/_snaps/legend-draw/appropriate-colour-key-with-alpha-key-as-lines.svg diff --git a/tests/testthat/_snaps/draw-key/circle-glyphs-of-2cm-size.svg b/tests/testthat/_snaps/legend-draw/circle-glyphs-of-2cm-size.svg similarity index 100% rename from tests/testthat/_snaps/draw-key/circle-glyphs-of-2cm-size.svg rename to tests/testthat/_snaps/legend-draw/circle-glyphs-of-2cm-size.svg diff --git a/tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg b/tests/testthat/_snaps/legend-draw/horizontal-boxplot-and-crossbar.svg similarity index 100% rename from tests/testthat/_snaps/draw-key/horizontal-boxplot-and-crossbar.svg rename to tests/testthat/_snaps/legend-draw/horizontal-boxplot-and-crossbar.svg diff --git a/tests/testthat/_snaps/draw-key/horizontal-linerange-and-pointrange.svg b/tests/testthat/_snaps/legend-draw/horizontal-linerange-and-pointrange.svg similarity index 100% rename from tests/testthat/_snaps/draw-key/horizontal-linerange-and-pointrange.svg rename to tests/testthat/_snaps/legend-draw/horizontal-linerange-and-pointrange.svg diff --git a/tests/testthat/_snaps/draw-key/rectangle-and-dotplot-key-glyphs.svg b/tests/testthat/_snaps/legend-draw/rectangle-and-dotplot-key-glyphs.svg similarity index 100% rename from tests/testthat/_snaps/draw-key/rectangle-and-dotplot-key-glyphs.svg rename to tests/testthat/_snaps/legend-draw/rectangle-and-dotplot-key-glyphs.svg diff --git a/tests/testthat/_snaps/draw-key/time-series-and-polygon-key-glyphs.svg b/tests/testthat/_snaps/legend-draw/time-series-and-polygon-key-glyphs.svg similarity index 100% rename from tests/testthat/_snaps/draw-key/time-series-and-polygon-key-glyphs.svg rename to tests/testthat/_snaps/legend-draw/time-series-and-polygon-key-glyphs.svg From 89613209b26b860223d2b3d48a226ddf815d9517 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 14:04:25 +0100 Subject: [PATCH 23/78] align `facet-labeller` --- R/{labeller.R => facet-labeller.R} | 0 tests/testthat/{test-facet-labels.R => test-facet-labeller.R} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename R/{labeller.R => facet-labeller.R} (100%) rename tests/testthat/{test-facet-labels.R => test-facet-labeller.R} (100%) diff --git a/R/labeller.R b/R/facet-labeller.R similarity index 100% rename from R/labeller.R rename to R/facet-labeller.R diff --git a/tests/testthat/test-facet-labels.R b/tests/testthat/test-facet-labeller.R similarity index 100% rename from tests/testthat/test-facet-labels.R rename to tests/testthat/test-facet-labeller.R From 60a8c5ee26a0c24f7cf09d34c9408e9a09a6f997 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 14:26:33 +0100 Subject: [PATCH 24/78] cannibalise `test-facet-layout.R` --- tests/testthat/test-facet-.R | 23 +++ tests/testthat/test-facet-grid-.R | 140 ++++++++++++++ tests/testthat/test-facet-layout.R | 283 ----------------------------- tests/testthat/test-facet-wrap.R | 144 +++++++++++++++ 4 files changed, 307 insertions(+), 283 deletions(-) create mode 100644 tests/testthat/test-facet-grid-.R delete mode 100644 tests/testthat/test-facet-layout.R create mode 100644 tests/testthat/test-facet-wrap.R diff --git a/tests/testthat/test-facet-.R b/tests/testthat/test-facet-.R index 71f78c1cf2..bdbbd8d6c0 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -478,6 +478,29 @@ test_that("check_layout() throws meaningful errors", { expect_snapshot_error(check_layout(mtcars)) }) +test_that("wrap and grid are equivalent for 1d data", { + rowg <- panel_layout(facet_grid(a~.), list(a)) + roww <- panel_layout(facet_wrap(~a, ncol = 1), list(a)) + expect_equal(roww, rowg) + + colg <- panel_layout(facet_grid(.~a), list(a)) + colw <- panel_layout(facet_wrap(~a, nrow = 1), list(a)) + expect_equal(colw, colg) +}) + +test_that("facet_wrap and facet_grid throws errors when using reserved words", { + mtcars2 <- mtcars + mtcars2$PANEL <- mtcars2$cyl + mtcars2$ROW <- mtcars2$gear + + p <- ggplot(mtcars2) + + geom_point(aes(mpg, disp)) + expect_snapshot_error(ggplotGrob(p + facet_grid(ROW ~ gear))) + expect_snapshot_error(ggplotGrob(p + facet_grid(ROW ~ PANEL))) + expect_snapshot_error(ggplotGrob(p + facet_wrap(~ROW))) +}) + + # Visual tests ------------------------------------------------------------ test_that("facet labels respect both justification and margin arguments", { diff --git a/tests/testthat/test-facet-grid-.R b/tests/testthat/test-facet-grid-.R new file mode 100644 index 0000000000..83b1bae655 --- /dev/null +++ b/tests/testthat/test-facet-grid-.R @@ -0,0 +1,140 @@ +# Layout ------------------------------------------------------------------ + +a <- data_frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) +b <- data_frame(a = 3) +c <- data_frame(b = 3) +empty <- data_frame() +a2 <- data_frame( + a = factor(1:3, levels = 1:4), + b = factor(1:3, levels = 4:1), + c = as.character(c(1:2, NA)) +) + +panel_layout <- function(facet, data) { + layout <- create_layout(facet = facet, coord = CoordCartesian) + layout$setup(data) + layout$layout +} + +test_that("facet_grid() single row and single col are equivalent", { + row <- panel_layout(facet_grid(a~.), list(a)) + col <- panel_layout(facet_grid(.~a), list(a)) + + expect_equal(row$ROW, 1:2) + expect_equal(row$ROW, col$COL) + expect_equal(row[c("PANEL", "a")], col[c("PANEL", "a")]) + + row <- panel_layout(facet_grid(a~.), list(a, b)) + col <- panel_layout(facet_grid(.~a), list(a, b)) + + expect_equal(row$ROW, 1:3) + expect_equal(row$ROW, col$COL) + expect_equal(row[c("PANEL", "a")], col[c("PANEL", "a")]) +}) + +test_that("facet_grid() includes all combinations", { + d <- data_frame(a = c(1, 2), b = c(2, 1)) + all <- panel_layout(facet_grid(a~b), list(d)) + + expect_equal(nrow(all), 4) +}) + +test_that("facet_grid() crossed rows/cols create no more combinations than necessary", { + facet <- facet_grid(a~b) + + one <- panel_layout(facet, list(a)) + expect_equal(nrow(one), 4) + + one_a <- panel_layout(facet, list(a, empty)) + expect_equal(nrow(one_a), 4) + + two <- panel_layout(facet, list(a, b)) + expect_equal(nrow(two), 4 + 2) + + three <- panel_layout(facet, list(a, b, c)) + expect_equal(nrow(three), 9) + + four <- panel_layout(facet, list(b, c)) + expect_equal(nrow(four), 1) +}) + + +test_that("facet_grid() nested rows/cols create no more combinations than necessary", { + one <- panel_layout(facet_grid(drv+cyl~.), list(mpg)) + expect_equal(one$PANEL, factor(1:9)) + expect_equal(one$ROW, 1:9) +}) + +test_that("facet_grid(margins) add correct combinations", { + one <- panel_layout(facet_grid(a~b, margins = TRUE), list(a)) + expect_equal(nrow(one), 4 + 2 + 2 + 1) +}) + +test_that("facet_grid(as.table) reverses rows", { + one <- panel_layout(facet_grid(a~., as.table = FALSE), list(a)) + expect_equal(as.character(one$a), c("2", "1")) + + two <- panel_layout(facet_grid(a~., as.table = TRUE), list(a)) + expect_equal(as.character(two$a), c("1", "2")) +}) + +test_that("facet_grid(drop = FALSE) preserves unused levels", { + grid_a <- panel_layout(facet_grid(a~., drop = FALSE), list(a2)) + expect_equal(nrow(grid_a), 4) + expect_equal(as.character(grid_a$a), as.character(1:4)) + + grid_b <- panel_layout(facet_grid(b~., drop = FALSE), list(a2)) + expect_equal(nrow(grid_b), 4) + expect_equal(as.character(grid_b$b), as.character(4:1)) + + grid_ab <- panel_layout(facet_grid(a~b, drop = FALSE), list(a2)) + expect_equal(nrow(grid_ab), 16) + expect_equal(as.character(grid_ab$a), as.character(rep(1:4, each = 4))) + expect_equal(as.character(grid_ab$b), as.character(rep(4:1, 4))) +}) + +test_that("missing values get a panel", { + a3 <- data_frame( + a = c(1:3, NA), + b = factor(c(1:3, NA)), + c = factor(c(1:3, NA), exclude = NULL) + ) + + grid_a <- panel_layout(facet_grid(a~.), list(a3)) + grid_b <- panel_layout(facet_grid(b~.), list(a3)) + grid_c <- panel_layout(facet_grid(c~.), list(a3)) + + expect_equal(nrow(grid_a), 4) + expect_equal(nrow(grid_b), 4) + expect_equal(nrow(grid_c), 4) +}) + +test_that("facet_grid() throws errors at bad layout specs", { + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp)) + + facet_grid(.~gear, scales = "free") + + coord_fixed() + expect_snapshot_error(ggplotGrob(p)) + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp)) + + facet_grid(.~gear, space = "free") + + theme(aspect.ratio = 1) + expect_snapshot_error(ggplotGrob(p)) +}) + +test_that("facet_grid() can respect coord aspect with free scales/space", { + df <- expand.grid(x = letters[1:6], y = LETTERS[1:3]) + p <- ggplot(df, aes(x, y)) + + geom_tile() + + facet_grid( + rows = vars(y == "C"), + cols = vars(x %in% c("e", "f")), + scales = "free", space = "free" + ) + + coord_fixed(3, expand = FALSE) + gt <- ggplotGrob(p) + width <- gt$widths[panel_cols(gt)$l] + height <- gt$heights[panel_rows(gt)$t] + expect_equal(as.numeric(width), c(4, 2)) + expect_equal(as.numeric(height), c(6, 3)) +}) diff --git a/tests/testthat/test-facet-layout.R b/tests/testthat/test-facet-layout.R deleted file mode 100644 index a008a0c80d..0000000000 --- a/tests/testthat/test-facet-layout.R +++ /dev/null @@ -1,283 +0,0 @@ -a <- data_frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) -b <- data_frame(a = 3) -c <- data_frame(b = 3) -empty <- data_frame() - -panel_layout <- function(facet, data) { - layout <- create_layout(facet = facet, coord = CoordCartesian) - layout$setup(data) - layout$layout -} - -test_that("grid: single row and single col are equivalent", { - row <- panel_layout(facet_grid(a~.), list(a)) - col <- panel_layout(facet_grid(.~a), list(a)) - - expect_equal(row$ROW, 1:2) - expect_equal(row$ROW, col$COL) - expect_equal(row[c("PANEL", "a")], col[c("PANEL", "a")]) - - row <- panel_layout(facet_grid(a~.), list(a, b)) - col <- panel_layout(facet_grid(.~a), list(a, b)) - - expect_equal(row$ROW, 1:3) - expect_equal(row$ROW, col$COL) - expect_equal(row[c("PANEL", "a")], col[c("PANEL", "a")]) -}) - -test_that("grid: includes all combinations", { - d <- data_frame(a = c(1, 2), b = c(2, 1)) - all <- panel_layout(facet_grid(a~b), list(d)) - - expect_equal(nrow(all), 4) -}) - -test_that("wrap: layout sorting is correct", { - - dummy <- list(data_frame0(x = 1:5)) - - test <- panel_layout(facet_wrap(~x, dir = "lt"), dummy) - expect_equal(test$ROW, rep(c(1,2), c(3, 2))) - expect_equal(test$COL, c(1:3, 1:2)) - - test <- panel_layout(facet_wrap(~x, dir = "tl"), dummy) - expect_equal(test$ROW, c(1, 2, 1, 2, 1)) - expect_equal(test$COL, c(1, 1, 2, 2, 3)) - - test <- panel_layout(facet_wrap(~x, dir = "lb"), dummy) - expect_equal(test$ROW, c(2, 2, 2, 1, 1)) - expect_equal(test$COL, c(1, 2, 3, 1, 2)) - - test <- panel_layout(facet_wrap(~x, dir = "bl"), dummy) - expect_equal(test$ROW, c(2, 1, 2, 1, 2)) - expect_equal(test$COL, c(1, 1, 2, 2, 3)) - - test <- panel_layout(facet_wrap(~x, dir = "rt"), dummy) - expect_equal(test$ROW, c(1, 1, 1, 2, 2)) - expect_equal(test$COL, c(3, 2, 1, 3, 2)) - - test <- panel_layout(facet_wrap(~x, dir = "tr"), dummy) - expect_equal(test$ROW, c(1, 2, 1, 2, 1)) - expect_equal(test$COL, c(3, 3, 2, 2, 1)) - - test <- panel_layout(facet_wrap(~x, dir = "rb"), dummy) - expect_equal(test$ROW, c(2, 2, 2, 1, 1)) - expect_equal(test$COL, c(3, 2, 1, 3, 2)) - - test <- panel_layout(facet_wrap(~x, dir = "br"), dummy) - expect_equal(test$ROW, c(2, 1, 2, 1, 2)) - expect_equal(test$COL, c(3, 3, 2, 2, 1)) - -}) - -test_that("wrap and grid are equivalent for 1d data", { - rowg <- panel_layout(facet_grid(a~.), list(a)) - roww <- panel_layout(facet_wrap(~a, ncol = 1), list(a)) - expect_equal(roww, rowg) - - colg <- panel_layout(facet_grid(.~a), list(a)) - colw <- panel_layout(facet_wrap(~a, nrow = 1), list(a)) - expect_equal(colw, colg) -}) - -test_that("grid: crossed rows/cols create no more combinations than necessary", { - facet <- facet_grid(a~b) - - one <- panel_layout(facet, list(a)) - expect_equal(nrow(one), 4) - - one_a <- panel_layout(facet, list(a, empty)) - expect_equal(nrow(one_a), 4) - - two <- panel_layout(facet, list(a, b)) - expect_equal(nrow(two), 4 + 2) - - three <- panel_layout(facet, list(a, b, c)) - expect_equal(nrow(three), 9) - - four <- panel_layout(facet, list(b, c)) - expect_equal(nrow(four), 1) -}) - -test_that("grid: nested rows/cols create no more combinations than necessary", { - one <- panel_layout(facet_grid(drv+cyl~.), list(mpg)) - expect_equal(one$PANEL, factor(1:9)) - expect_equal(one$ROW, 1:9) -}) - -test_that("grid: margins add correct combinations", { - one <- panel_layout(facet_grid(a~b, margins = TRUE), list(a)) - expect_equal(nrow(one), 4 + 2 + 2 + 1) -}) - -test_that("wrap: as.table reverses rows", { - one <- panel_layout(facet_wrap(~a, ncol = 1, as.table = FALSE), list(a)) - expect_equal(one$ROW, c(2, 1)) - - two <- panel_layout(facet_wrap(~a, nrow = 1, as.table = FALSE), list(a)) - expect_equal(two$ROW, c(1, 1)) -}) - -test_that("wrap: as.table = FALSE gets axes", { - p <- ggplot(mpg, aes(displ, hwy)) + - geom_point() + - scale_y_continuous(position = "left") + - facet_wrap(vars(class), dir = "v", as.table = FALSE) - expect_doppelganger("Axes are positioned correctly in non-table layout", p) -}) - -test_that("grid: as.table reverses rows", { - one <- panel_layout(facet_grid(a~., as.table = FALSE), list(a)) - expect_equal(as.character(one$a), c("2", "1")) - - two <- panel_layout(facet_grid(a~., as.table = TRUE), list(a)) - expect_equal(as.character(two$a), c("1", "2")) -}) - -# Drop behaviour ------------------------------------------------------------- - -a2 <- data_frame( - a = factor(1:3, levels = 1:4), - b = factor(1:3, levels = 4:1), - c = as.character(c(1:2, NA)) -) - -test_that("wrap: drop = FALSE preserves unused levels", { - wrap_a <- panel_layout(facet_wrap(~a, drop = FALSE), list(a2)) - expect_equal(nrow(wrap_a), 4) - expect_equal(as.character(wrap_a$a), as.character(1:4)) - - wrap_b <- panel_layout(facet_wrap(~b, drop = FALSE), list(a2)) - expect_equal(nrow(wrap_b), 4) - expect_equal(as.character(wrap_b$b), as.character(4:1)) - - # NA character should not be dropped or throw errors #5485 - wrap_c <- panel_layout(facet_wrap(~c, drop = FALSE), list(a2)) - expect_equal(nrow(wrap_c), 3) - expect_equal(wrap_c$c, a2$c) -}) - -test_that("grid: drop = FALSE preserves unused levels", { - grid_a <- panel_layout(facet_grid(a~., drop = FALSE), list(a2)) - expect_equal(nrow(grid_a), 4) - expect_equal(as.character(grid_a$a), as.character(1:4)) - - grid_b <- panel_layout(facet_grid(b~., drop = FALSE), list(a2)) - expect_equal(nrow(grid_b), 4) - expect_equal(as.character(grid_b$b), as.character(4:1)) - - grid_ab <- panel_layout(facet_grid(a~b, drop = FALSE), list(a2)) - expect_equal(nrow(grid_ab), 16) - expect_equal(as.character(grid_ab$a), as.character(rep(1:4, each = 4))) - expect_equal(as.character(grid_ab$b), as.character(rep(4:1, 4))) -}) - -test_that("wrap: space = 'free_x/y' sets panel sizes", { - - df <- data.frame(x = 1:3) - p <- ggplot(df, aes(x, x)) + - geom_point() + - scale_x_continuous(limits = c(0, NA), expand = c(0, 0)) + - scale_y_continuous(limits = c(0, NA), expand = c(0, 0)) - - # Test free_x - gt <- ggplotGrob(p + facet_wrap(~x, scales = "free_x", space = "free_x")) - test <- gt$widths[panel_cols(gt)$l] - expect_equal(as.numeric(test), 1:3) - - # Test free_y - gt <- ggplotGrob(p + facet_wrap(~x, scales = "free_y", space = "free_y")) - test <- gt$heights[panel_rows(gt)$t] - expect_equal(as.numeric(test), 1:3) -}) - -# Missing behaviour ---------------------------------------------------------- - -a3 <- data_frame( - a = c(1:3, NA), - b = factor(c(1:3, NA)), - c = factor(c(1:3, NA), exclude = NULL) -) - -test_that("missing values get a panel", { - wrap_a <- panel_layout(facet_wrap(~a), list(a3)) - wrap_b <- panel_layout(facet_wrap(~b), list(a3)) - wrap_c <- panel_layout(facet_wrap(~c), list(a3)) - grid_a <- panel_layout(facet_grid(a~.), list(a3)) - grid_b <- panel_layout(facet_grid(b~.), list(a3)) - grid_c <- panel_layout(facet_grid(c~.), list(a3)) - - expect_equal(nrow(wrap_a), 4) - expect_equal(nrow(wrap_b), 4) - expect_equal(nrow(wrap_c), 4) - expect_equal(nrow(grid_a), 4) - expect_equal(nrow(grid_b), 4) - expect_equal(nrow(grid_c), 4) -}) - -# Input checking ---------------------------------------------------------- - -test_that("facet_wrap throws errors at bad layout specs", { - expect_snapshot_error(facet_wrap(~test, ncol = 1:4)) - expect_snapshot_error(facet_wrap(~test, ncol = -1)) - expect_snapshot_error(facet_wrap(~test, ncol = 1.5)) - - expect_snapshot_error(facet_wrap(~test, nrow = 1:4)) - expect_snapshot_error(facet_wrap(~test, nrow = -1)) - expect_snapshot_error(facet_wrap(~test, nrow = 1.5)) - - expect_snapshot_warning(facet_wrap(~test, nrow = 2, space = "free_x")) - - p <- ggplot(mtcars) + - geom_point(aes(mpg, disp)) + - facet_wrap(~gear, ncol = 1, nrow = 1) - expect_snapshot_error(ggplot_build(p)) - - p <- ggplot(mtcars) + - geom_point(aes(mpg, disp)) + - facet_wrap(~gear, scales = "free") + - coord_fixed() - expect_snapshot_error(ggplotGrob(p)) -}) - -test_that("facet_grid throws errors at bad layout specs", { - p <- ggplot(mtcars) + - geom_point(aes(mpg, disp)) + - facet_grid(.~gear, scales = "free") + - coord_fixed() - expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + - geom_point(aes(mpg, disp)) + - facet_grid(.~gear, space = "free") + - theme(aspect.ratio = 1) - expect_snapshot_error(ggplotGrob(p)) -}) - -test_that("facet_grid can respect coord aspect with free scales/space", { - df <- expand.grid(x = letters[1:6], y = LETTERS[1:3]) - p <- ggplot(df, aes(x, y)) + - geom_tile() + - facet_grid( - rows = vars(y == "C"), - cols = vars(x %in% c("e", "f")), - scales = "free", space = "free" - ) + - coord_fixed(3, expand = FALSE) - gt <- ggplotGrob(p) - width <- gt$widths[panel_cols(gt)$l] - height <- gt$heights[panel_rows(gt)$t] - expect_equal(as.numeric(width), c(4, 2)) - expect_equal(as.numeric(height), c(6, 3)) -}) - -test_that("facet_wrap and facet_grid throws errors when using reserved words", { - mtcars2 <- mtcars - mtcars2$PANEL <- mtcars2$cyl - mtcars2$ROW <- mtcars2$gear - - p <- ggplot(mtcars2) + - geom_point(aes(mpg, disp)) - expect_snapshot_error(ggplotGrob(p + facet_grid(ROW ~ gear))) - expect_snapshot_error(ggplotGrob(p + facet_grid(ROW ~ PANEL))) - expect_snapshot_error(ggplotGrob(p + facet_wrap(~ROW))) -}) diff --git a/tests/testthat/test-facet-wrap.R b/tests/testthat/test-facet-wrap.R new file mode 100644 index 0000000000..2005acdd75 --- /dev/null +++ b/tests/testthat/test-facet-wrap.R @@ -0,0 +1,144 @@ +# Layout ------------------------------------------------------------------ + +a <- data_frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) +b <- data_frame(a = 3) +c <- data_frame(b = 3) +empty <- data_frame() +a2 <- data_frame( + a = factor(1:3, levels = 1:4), + b = factor(1:3, levels = 4:1), + c = as.character(c(1:2, NA)) +) + +panel_layout <- function(facet, data) { + layout <- create_layout(facet = facet, coord = CoordCartesian) + layout$setup(data) + layout$layout +} + +test_that("facet_wrap() layout sorting is correct", { + + dummy <- list(data_frame0(x = 1:5)) + + test <- panel_layout(facet_wrap(~x, dir = "lt"), dummy) + expect_equal(test$ROW, rep(c(1,2), c(3, 2))) + expect_equal(test$COL, c(1:3, 1:2)) + + test <- panel_layout(facet_wrap(~x, dir = "tl"), dummy) + expect_equal(test$ROW, c(1, 2, 1, 2, 1)) + expect_equal(test$COL, c(1, 1, 2, 2, 3)) + + test <- panel_layout(facet_wrap(~x, dir = "lb"), dummy) + expect_equal(test$ROW, c(2, 2, 2, 1, 1)) + expect_equal(test$COL, c(1, 2, 3, 1, 2)) + + test <- panel_layout(facet_wrap(~x, dir = "bl"), dummy) + expect_equal(test$ROW, c(2, 1, 2, 1, 2)) + expect_equal(test$COL, c(1, 1, 2, 2, 3)) + + test <- panel_layout(facet_wrap(~x, dir = "rt"), dummy) + expect_equal(test$ROW, c(1, 1, 1, 2, 2)) + expect_equal(test$COL, c(3, 2, 1, 3, 2)) + + test <- panel_layout(facet_wrap(~x, dir = "tr"), dummy) + expect_equal(test$ROW, c(1, 2, 1, 2, 1)) + expect_equal(test$COL, c(3, 3, 2, 2, 1)) + + test <- panel_layout(facet_wrap(~x, dir = "rb"), dummy) + expect_equal(test$ROW, c(2, 2, 2, 1, 1)) + expect_equal(test$COL, c(3, 2, 1, 3, 2)) + + test <- panel_layout(facet_wrap(~x, dir = "br"), dummy) + expect_equal(test$ROW, c(2, 1, 2, 1, 2)) + expect_equal(test$COL, c(3, 3, 2, 2, 1)) + +}) + +test_that("facet_wrap(as.table) reverses rows", { + one <- panel_layout(facet_wrap(~a, ncol = 1, as.table = FALSE), list(a)) + expect_equal(one$ROW, c(2, 1)) + + two <- panel_layout(facet_wrap(~a, nrow = 1, as.table = FALSE), list(a)) + expect_equal(two$ROW, c(1, 1)) +}) + +test_that("facet_wrap(as.table = FALSE) gets axes", { + p <- ggplot(mpg, aes(displ, hwy)) + + geom_point() + + scale_y_continuous(position = "left") + + facet_wrap(vars(class), dir = "v", as.table = FALSE) + expect_doppelganger("Axes are positioned correctly in non-table layout", p) +}) + +test_that("facet_wrap(drop = FALSE) preserves unused levels", { + wrap_a <- panel_layout(facet_wrap(~a, drop = FALSE), list(a2)) + expect_equal(nrow(wrap_a), 4) + expect_equal(as.character(wrap_a$a), as.character(1:4)) + + wrap_b <- panel_layout(facet_wrap(~b, drop = FALSE), list(a2)) + expect_equal(nrow(wrap_b), 4) + expect_equal(as.character(wrap_b$b), as.character(4:1)) + + # NA character should not be dropped or throw errors #5485 + wrap_c <- panel_layout(facet_wrap(~c, drop = FALSE), list(a2)) + expect_equal(nrow(wrap_c), 3) + expect_equal(wrap_c$c, a2$c) +}) + +test_that("facet_wrap(space = 'free_x/y') sets panel sizes", { + + df <- data.frame(x = 1:3) + p <- ggplot(df, aes(x, x)) + + geom_point() + + scale_x_continuous(limits = c(0, NA), expand = c(0, 0)) + + scale_y_continuous(limits = c(0, NA), expand = c(0, 0)) + + # Test free_x + gt <- ggplotGrob(p + facet_wrap(~x, scales = "free_x", space = "free_x")) + test <- gt$widths[panel_cols(gt)$l] + expect_equal(as.numeric(test), 1:3) + + # Test free_y + gt <- ggplotGrob(p + facet_wrap(~x, scales = "free_y", space = "free_y")) + test <- gt$heights[panel_rows(gt)$t] + expect_equal(as.numeric(test), 1:3) +}) + +test_that("missing values get a panel", { + a3 <- data_frame( + a = c(1:3, NA), + b = factor(c(1:3, NA)), + c = factor(c(1:3, NA), exclude = NULL) + ) + + wrap_a <- panel_layout(facet_wrap(~a), list(a3)) + wrap_b <- panel_layout(facet_wrap(~b), list(a3)) + wrap_c <- panel_layout(facet_wrap(~c), list(a3)) + + expect_equal(nrow(wrap_a), 4) + expect_equal(nrow(wrap_b), 4) + expect_equal(nrow(wrap_c), 4) +}) + +test_that("facet_wrap() throws errors at bad layout specs", { + expect_snapshot_error(facet_wrap(~test, ncol = 1:4)) + expect_snapshot_error(facet_wrap(~test, ncol = -1)) + expect_snapshot_error(facet_wrap(~test, ncol = 1.5)) + + expect_snapshot_error(facet_wrap(~test, nrow = 1:4)) + expect_snapshot_error(facet_wrap(~test, nrow = -1)) + expect_snapshot_error(facet_wrap(~test, nrow = 1.5)) + + expect_snapshot_warning(facet_wrap(~test, nrow = 2, space = "free_x")) + + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp)) + + facet_wrap(~gear, ncol = 1, nrow = 1) + expect_snapshot_error(ggplot_build(p)) + + p <- ggplot(mtcars) + + geom_point(aes(mpg, disp)) + + facet_wrap(~gear, scales = "free") + + coord_fixed() + expect_snapshot_error(ggplotGrob(p)) +}) From f7d4fb50e936690f4b8c1e3e00c921d44c6575ae Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 14:50:26 +0100 Subject: [PATCH 25/78] cannibalise `test-facet-map.R` --- tests/testthat/test-facet-grid-.R | 165 +++++++++++++++++++ tests/testthat/test-facet-map.R | 254 ------------------------------ tests/testthat/test-facet-wrap.R | 119 ++++++++++++++ 3 files changed, 284 insertions(+), 254 deletions(-) delete mode 100644 tests/testthat/test-facet-map.R diff --git a/tests/testthat/test-facet-grid-.R b/tests/testthat/test-facet-grid-.R index 83b1bae655..fd0df003b9 100644 --- a/tests/testthat/test-facet-grid-.R +++ b/tests/testthat/test-facet-grid-.R @@ -138,3 +138,168 @@ test_that("facet_grid() can respect coord aspect with free scales/space", { expect_equal(as.numeric(width), c(4, 2)) expect_equal(as.numeric(height), c(6, 3)) }) + +# Data mapping ------------------------------------------------------------ + +df <- expand.grid(a = 1:2, b = 1:2) +df_a <- unique(df["a"]) +df_b <- unique(df["b"]) +df_c <- unique(data_frame(c = 1)) + +panel_map_one <- function(facet, data, plot_data = data) { + layout <- create_layout(facet = facet, coord = CoordCartesian) + layout$setup(list(data), plot_data)[[1]] +} + +test_that("two col cases with no missings adds a single extra column", { + loc <- panel_map_one(facet_grid(cyl~vs), mtcars) + + expect_equal(nrow(loc), nrow(mtcars)) + expect_equal(ncol(loc), ncol(mtcars) + 1) + + match <- unique(loc[c("cyl", "vs", "PANEL")]) + expect_equal(nrow(match), 5) +}) + +test_that("margins add extra data", { + loc <- panel_map_one(facet_grid(a~b, margins = "b"), df) + + expect_equal(nrow(loc), nrow(df) * 2) + + # For variables including computation (#1864) + loc <- panel_map_one(facet_grid(a ~ I(b + 1), margins = TRUE), df) + expect_equal(nrow(loc), nrow(df) * 4) +}) + +test_that("facet_grid(): missing facet columns are duplicated", { + facet <- facet_grid(a~b) + + loc_a <- panel_map_one(facet, df_a, plot_data = df) + expect_equal(nrow(loc_a), 4) + expect_equal(loc_a$PANEL, factor(c(1, 3, 2, 4))) + + loc_b <- panel_map_one(facet, df_b, plot_data = df) + expect_equal(nrow(loc_b), 4) + expect_equal(loc_b$PANEL, factor(1:4)) + + loc_c <- panel_map_one(facet, df_c, plot_data = df) + expect_equal(nrow(loc_c), 4) + expect_equal(loc_c$PANEL, factor(1:4)) +}) + +test_that("facet_grid can facet by a date/POSIXct variable", { + date_df <- data_frame(date_var = as.Date(c("1971-12-11", "1987-01-13", "2000-01-01"))) + + grid_col <- facet_grid(~date_var) + loc_grid_col <- panel_map_one(grid_col, date_df) + expect_equal(loc_grid_col$PANEL, factor(1:3)) + + grid_row <- facet_grid(date_var ~ .) + loc_grid_row <- panel_map_one(grid_row, date_df) + expect_equal(loc_grid_row$PANEL, factor(1:3)) + + date_df <- data_frame(date_var = as.POSIXct(c("1971-12-11", "1987-01-13", "2000-01-01"))) + + grid_col <- facet_grid(~date_var) + loc_grid_col <- panel_map_one(grid_col, date_df) + expect_equal(loc_grid_col$PANEL, factor(1:3)) + + grid_row <- facet_grid(date_var ~ .) + loc_grid_row <- panel_map_one(grid_row, date_df) + expect_equal(loc_grid_row$PANEL, factor(1:3)) +}) + +test_that("facet_grid() respects layer layout", { + + df <- expand.grid(x = LETTERS[1:2], y = 1:3) + + p <- ggplot(df, aes(x, y)) + + geom_point(colour = "red", layout = "fixed") + + geom_point(colour = "green", layout = "fixed_rows") + + geom_point(colour = "purple", layout = "fixed_cols") + + geom_point() + + geom_point(colour = "blue", layout = 5) + + facet_grid(x ~ y) + b <- ggplot_build(p) + + expect_equal( + table(get_layer_data(b, i = 1L)$PANEL), + table(rep(1:6, 6)) + ) + expect_equal( + table(get_layer_data(b, i = 2L)$PANEL), + table(rep(1:6, 3)) + ) + expect_equal( + table(get_layer_data(b, i = 3L)$PANEL), + table(rep(1:6, 2)) + ) + expect_equal( + table(get_layer_data(b, i = 4L)$PANEL), + table(1:6) + ) + expect_equal( + table(get_layer_data(b, i = 5L)$PANEL), + table(factor(5, levels = 1:6)) + ) +}) + +test_that("facet_grid() locates missing values correctly", { + a3 <- data_frame( + # a = c(1:3, NA), Not currently supported + b = factor(c(1:3, NA)), + c = factor(c(1:3, NA), exclude = NULL) + ) + + facet <- facet_grid(b~.) + loc_b <- panel_map_one(facet, data_frame(b = NA), plot_data = a3) + expect_equal(as.character(loc_b$PANEL), "4") + + facet <- facet_grid(c~.) + loc_c <- panel_map_one(facet, data_frame(c = NA), plot_data = a3) + expect_equal(as.character(loc_c$PANEL), "4") +}) + +test_that("facet_grid() order follows default data frame order", { + get_layout <- function(p) ggplot_build(p)@layout$layout + + # Data with factor f with levels CBA + d <- data_frame(x = 1:9, y = 1:9, + fx = factor(rep(letters[1:3], each = 3), levels = letters[3:1]), + fy = factor(rep(LETTERS[1:3], each = 3), levels = LETTERS[3:1])) + + # Data with factor f with only level B + d2 <- data_frame(x = 1:9, y = 2:10, fx = factor("a"), fy = factor("B")) + + + # Facets should be in order: + # CBA for rows 1:3 + # cba for cols 1:3 + lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) + geom_point()) + expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) + + # When adding d2, facets should still be in order: + # CBA for rows 1:3 + # cba for cols 1:3 + lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) + + geom_blank(data = d2) + geom_point()) + expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) + + # With no default data: should search each layer in order + # BCA for rows 1:3 + # acb for cols 1:3 + lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) + + geom_blank(data = d2) + geom_point(data = d)) + expect_equal(as.character(lay$fy), c("B","C","A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("a","c","b")[lay$COL]) + + # Same as previous, but different layer order. + # CBA for rows 1:3 + # cba for cols 1:3 + lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) + + geom_point(data = d) + geom_blank(data = d2)) + expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) + expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) +}) diff --git a/tests/testthat/test-facet-map.R b/tests/testthat/test-facet-map.R deleted file mode 100644 index 4ce6e24329..0000000000 --- a/tests/testthat/test-facet-map.R +++ /dev/null @@ -1,254 +0,0 @@ -df <- expand.grid(a = 1:2, b = 1:2) -df_a <- unique(df["a"]) -df_b <- unique(df["b"]) -df_c <- unique(data_frame(c = 1)) - -panel_map_one <- function(facet, data, plot_data = data) { - layout <- create_layout(facet = facet, coord = CoordCartesian) - layout$setup(list(data), plot_data)[[1]] -} - -test_that("two col cases with no missings adds a single extra column", { - loc <- panel_map_one(facet_grid(cyl~vs), mtcars) - - expect_equal(nrow(loc), nrow(mtcars)) - expect_equal(ncol(loc), ncol(mtcars) + 1) - - match <- unique(loc[c("cyl", "vs", "PANEL")]) - expect_equal(nrow(match), 5) -}) - -test_that("margins add extra data", { - loc <- panel_map_one(facet_grid(a~b, margins = "b"), df) - - expect_equal(nrow(loc), nrow(df) * 2) - - # For variables including computation (#1864) - loc <- panel_map_one(facet_grid(a ~ I(b + 1), margins = TRUE), df) - expect_equal(nrow(loc), nrow(df) * 4) -}) - -test_that("grid: missing facet columns are duplicated", { - facet <- facet_grid(a~b) - - loc_a <- panel_map_one(facet, df_a, plot_data = df) - expect_equal(nrow(loc_a), 4) - expect_equal(loc_a$PANEL, factor(c(1, 3, 2, 4))) - - loc_b <- panel_map_one(facet, df_b, plot_data = df) - expect_equal(nrow(loc_b), 4) - expect_equal(loc_b$PANEL, factor(1:4)) - - loc_c <- panel_map_one(facet, df_c, plot_data = df) - expect_equal(nrow(loc_c), 4) - expect_equal(loc_c$PANEL, factor(1:4)) -}) - -test_that("wrap: missing facet columns are duplicated", { - facet <- facet_wrap(~a+b, ncol = 1) - - loc_a <- panel_map_one(facet, df_a, plot_data = df) - expect_equal(nrow(loc_a), 4) - expect_equal(loc_a$PANEL, factor(c(1, 3, 2, 4))) - expect_equal(loc_a$a, c(1, 2, 1, 2)) - - loc_b <- panel_map_one(facet, df_b, plot_data = df) - expect_equal(nrow(loc_b), 4) - expect_equal(loc_b$PANEL, factor(1:4)) - - loc_c <- panel_map_one(facet, df_c, plot_data = df) - expect_equal(nrow(loc_c), 4) - expect_equal(loc_c$PANEL, factor(1:4)) -}) - -test_that("wrap and grid can facet by a date variable", { - date_df <- data_frame(date_var = as.Date(c("1971-12-11", "1987-01-13", "2000-01-01"))) - - wrap <- facet_wrap(~date_var) - loc_wrap <- panel_map_one(wrap, date_df) - expect_equal(loc_wrap$PANEL, factor(1:3)) - - grid_col <- facet_grid(~date_var) - loc_grid_col <- panel_map_one(grid_col, date_df) - expect_equal(loc_grid_col$PANEL, factor(1:3)) - - grid_row <- facet_grid(date_var ~ .) - loc_grid_row <- panel_map_one(grid_row, date_df) - expect_equal(loc_grid_row$PANEL, factor(1:3)) -}) - -test_that("wrap and grid can facet by a POSIXct variable", { - date_df <- data_frame(date_var = as.POSIXct(c("1971-12-11", "1987-01-13", "2000-01-01"))) - - wrap <- facet_wrap(~date_var) - loc_wrap <- panel_map_one(wrap, date_df) - expect_equal(loc_wrap$PANEL, factor(1:3)) - - grid_col <- facet_grid(~date_var) - loc_grid_col <- panel_map_one(grid_col, date_df) - expect_equal(loc_grid_col$PANEL, factor(1:3)) - - grid_row <- facet_grid(date_var ~ .) - loc_grid_row <- panel_map_one(grid_row, date_df) - expect_equal(loc_grid_row$PANEL, factor(1:3)) -}) - -test_that("wrap: layer layout is respected", { - - df <- expand.grid(x = LETTERS[1:2], y = 1:3) - - p <- ggplot(df, aes(x, y)) + - geom_point(colour = "red", layout = "fixed") + - geom_point() + - geom_point(colour = "blue", layout = 5) + - facet_wrap(~ x + y) - b <- ggplot_build(p) - - expect_equal( - table(get_layer_data(b, i = 1L)$PANEL), - table(rep(1:6, 6)) - ) - expect_equal( - table(get_layer_data(b, i = 2L)$PANEL), - table(1:6) - ) - expect_equal( - table(get_layer_data(b, i = 3L)$PANEL), - table(factor(5, levels = 1:6)) - ) -}) - -test_that("grid: layer layout is respected", { - - df <- expand.grid(x = LETTERS[1:2], y = 1:3) - - p <- ggplot(df, aes(x, y)) + - geom_point(colour = "red", layout = "fixed") + - geom_point(colour = "green", layout = "fixed_rows") + - geom_point(colour = "purple", layout = "fixed_cols") + - geom_point() + - geom_point(colour = "blue", layout = 5) + - facet_grid(x ~ y) - b <- ggplot_build(p) - - expect_equal( - table(get_layer_data(b, i = 1L)$PANEL), - table(rep(1:6, 6)) - ) - expect_equal( - table(get_layer_data(b, i = 2L)$PANEL), - table(rep(1:6, 3)) - ) - expect_equal( - table(get_layer_data(b, i = 3L)$PANEL), - table(rep(1:6, 2)) - ) - expect_equal( - table(get_layer_data(b, i = 4L)$PANEL), - table(1:6) - ) - expect_equal( - table(get_layer_data(b, i = 5L)$PANEL), - table(factor(5, levels = 1:6)) - ) -}) - - -# Missing behaviour ---------------------------------------------------------- - -a3 <- data_frame( -# a = c(1:3, NA), Not currently supported - b = factor(c(1:3, NA)), - c = factor(c(1:3, NA), exclude = NULL) -) - -test_that("wrap: missing values are located correctly", { - facet <- facet_wrap(~b, ncol = 1) - loc_b <- panel_map_one(facet, data_frame(b = NA), plot_data = a3) - expect_equal(as.character(loc_b$PANEL), "4") - - facet <- facet_wrap(~c, ncol = 1) - loc_c <- panel_map_one(facet, data_frame(c = NA), plot_data = a3) - expect_equal(as.character(loc_c$PANEL), "4") -}) - -test_that("grid: missing values are located correctly", { - facet <- facet_grid(b~.) - loc_b <- panel_map_one(facet, data_frame(b = NA), plot_data = a3) - expect_equal(as.character(loc_b$PANEL), "4") - - facet <- facet_grid(c~.) - loc_c <- panel_map_one(facet, data_frame(c = NA), plot_data = a3) - expect_equal(as.character(loc_c$PANEL), "4") -}) - -# Facet order ---------------------------------------------------------------- - -get_layout <- function(p) ggplot_build(p)@layout$layout - -# Data with factor f with levels CBA -d <- data_frame(x = 1:9, y = 1:9, - fx = factor(rep(letters[1:3], each = 3), levels = letters[3:1]), - fy = factor(rep(LETTERS[1:3], each = 3), levels = LETTERS[3:1])) - -# Data with factor f with only level B -d2 <- data_frame(x = 1:9, y = 2:10, fx = factor("a"), fy = factor("B")) - - -test_that("grid: facet order follows default data frame order", { - # Facets should be in order: - # CBA for rows 1:3 - # cba for cols 1:3 - lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) + geom_point()) - expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) - - # When adding d2, facets should still be in order: - # CBA for rows 1:3 - # cba for cols 1:3 - lay <- get_layout(ggplot(d, aes(x, y)) + facet_grid(fy ~ fx) + - geom_blank(data = d2) + geom_point()) - expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) - - # With no default data: should search each layer in order - # BCA for rows 1:3 - # acb for cols 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) + - geom_blank(data = d2) + geom_point(data = d)) - expect_equal(as.character(lay$fy), c("B","C","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("a","c","b")[lay$COL]) - - # Same as previous, but different layer order. - # CBA for rows 1:3 - # cba for cols 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_grid(fy ~ fx) + - geom_point(data = d) + geom_blank(data = d2)) - expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) -}) - -test_that("wrap: facet order follows default data frame order", { - # Facets should be in order: - # cba for panels 1:3 - lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~fx) + geom_point()) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) - - # When adding d2, facets should still be in order: - # cba for panels 1:3 - lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~fx) + - geom_blank(data = d2) + geom_point()) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) - - # With no default data: should search each layer in order - # acb for panels 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~fx) + - geom_blank(data = d2) + geom_point(data = d)) - expect_equal(as.character(lay$fx), c("a","c","b")[lay$PANEL]) - - # Same as previous, but different layer order. - # cba for panels 1:3 - lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~fx) + - geom_point(data = d) + geom_blank(data = d2)) - expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) -}) diff --git a/tests/testthat/test-facet-wrap.R b/tests/testthat/test-facet-wrap.R index 2005acdd75..99e80781d5 100644 --- a/tests/testthat/test-facet-wrap.R +++ b/tests/testthat/test-facet-wrap.R @@ -142,3 +142,122 @@ test_that("facet_wrap() throws errors at bad layout specs", { coord_fixed() expect_snapshot_error(ggplotGrob(p)) }) + +# Data mapping ------------------------------------------------------------ + +df <- expand.grid(a = 1:2, b = 1:2) +df_a <- unique(df["a"]) +df_b <- unique(df["b"]) +df_c <- unique(data_frame(c = 1)) + +panel_map_one <- function(facet, data, plot_data = data) { + layout <- create_layout(facet = facet, coord = CoordCartesian) + layout$setup(list(data), plot_data)[[1]] +} + +test_that("facet_wrap() missing facet columns are duplicated", { + facet <- facet_wrap(~a+b, ncol = 1) + + loc_a <- panel_map_one(facet, df_a, plot_data = df) + expect_equal(nrow(loc_a), 4) + expect_equal(loc_a$PANEL, factor(c(1, 3, 2, 4))) + expect_equal(loc_a$a, c(1, 2, 1, 2)) + + loc_b <- panel_map_one(facet, df_b, plot_data = df) + expect_equal(nrow(loc_b), 4) + expect_equal(loc_b$PANEL, factor(1:4)) + + loc_c <- panel_map_one(facet, df_c, plot_data = df) + expect_equal(nrow(loc_c), 4) + expect_equal(loc_c$PANEL, factor(1:4)) +}) + +test_that("facet_wrap can facet by a date/POSIXct variable", { + date_df <- data_frame(date_var = as.Date(c("1971-12-11", "1987-01-13", "2000-01-01"))) + + wrap <- facet_wrap(~date_var) + loc_wrap <- panel_map_one(wrap, date_df) + expect_equal(loc_wrap$PANEL, factor(1:3)) + + date_df <- data_frame(date_var = as.POSIXct(c("1971-12-11", "1987-01-13", "2000-01-01"))) + + wrap <- facet_wrap(~date_var) + loc_wrap <- panel_map_one(wrap, date_df) + expect_equal(loc_wrap$PANEL, factor(1:3)) +}) + +test_that("facet_wrap() respects layer layout", { + + df <- expand.grid(x = LETTERS[1:2], y = 1:3) + + p <- ggplot(df, aes(x, y)) + + geom_point(colour = "red", layout = "fixed") + + geom_point() + + geom_point(colour = "blue", layout = 5) + + facet_wrap(~ x + y) + b <- ggplot_build(p) + + expect_equal( + table(get_layer_data(b, i = 1L)$PANEL), + table(rep(1:6, 6)) + ) + expect_equal( + table(get_layer_data(b, i = 2L)$PANEL), + table(1:6) + ) + expect_equal( + table(get_layer_data(b, i = 3L)$PANEL), + table(factor(5, levels = 1:6)) + ) +}) + +test_that("facet_wrap() locates missing values correctly", { + a3 <- data_frame( + # a = c(1:3, NA), Not currently supported + b = factor(c(1:3, NA)), + c = factor(c(1:3, NA), exclude = NULL) + ) + + facet <- facet_wrap(~b, ncol = 1) + loc_b <- panel_map_one(facet, data_frame(b = NA), plot_data = a3) + expect_equal(as.character(loc_b$PANEL), "4") + + facet <- facet_wrap(~c, ncol = 1) + loc_c <- panel_map_one(facet, data_frame(c = NA), plot_data = a3) + expect_equal(as.character(loc_c$PANEL), "4") +}) + +test_that("facet_wrap() order follows default data frame order", { + get_layout <- function(p) ggplot_build(p)@layout$layout + + # Data with factor f with levels CBA + d <- data_frame(x = 1:9, y = 1:9, + fx = factor(rep(letters[1:3], each = 3), levels = letters[3:1]), + fy = factor(rep(LETTERS[1:3], each = 3), levels = LETTERS[3:1])) + + # Data with factor f with only level B + d2 <- data_frame(x = 1:9, y = 2:10, fx = factor("a"), fy = factor("B")) + + # Facets should be in order: + # cba for panels 1:3 + lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~fx) + geom_point()) + expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) + + # When adding d2, facets should still be in order: + # cba for panels 1:3 + lay <- get_layout(ggplot(d, aes(x, y)) + facet_wrap(~fx) + + geom_blank(data = d2) + geom_point()) + expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) + + # With no default data: should search each layer in order + # acb for panels 1:3 + lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~fx) + + geom_blank(data = d2) + geom_point(data = d)) + expect_equal(as.character(lay$fx), c("a","c","b")[lay$PANEL]) + + # Same as previous, but different layer order. + # cba for panels 1:3 + lay <- get_layout(ggplot(mapping = aes(x, y)) + facet_wrap(~fx) + + geom_point(data = d) + geom_blank(data = d2)) + expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) +}) From 24fff436595e1a38fbf4c13ae49c5fdbf2b37679 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 15:05:14 +0100 Subject: [PATCH 26/78] cannibalise `test-facet-strips.R` --- tests/testthat/test-facet-.R | 49 ++++++ tests/testthat/test-facet-grid-.R | 125 ++++++++++++++++ tests/testthat/test-facet-strips.R | 229 ----------------------------- tests/testthat/test-facet-wrap.R | 62 ++++++++ 4 files changed, 236 insertions(+), 229 deletions(-) delete mode 100644 tests/testthat/test-facet-strips.R diff --git a/tests/testthat/test-facet-.R b/tests/testthat/test-facet-.R index bdbbd8d6c0..053c83fdec 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -337,6 +337,55 @@ test_that("facet_wrap throws deprecation messages", { ) }) +# Strips ------------------------------------------------------------------ + +test_that("strips can be removed", { + dat <- data_frame(a = rep(LETTERS[1:10], 10), x = rnorm(100), y = rnorm(100)) + g <- ggplot(dat, aes(x = x, y = y)) + + geom_point() + + facet_wrap(~a) + + theme(strip.background = element_blank(), strip.text = element_blank()) + g_grobs <- ggplotGrob(g) + strip_grobs <- g_grobs$grobs[grepl('strip-', g_grobs$layout$name)] + expect_true(all(sapply(strip_grobs, inherits, 'zeroGrob'))) +}) + +test_that("strip clipping can be set from the theme", { + labels <- data_frame(var1 = "a") + + strip <- render_strips( + labels, + labeller = label_value, + theme = theme_test() + theme(strip.clip = "on") + ) + expect_equal(strip$x$top[[1]]$layout$clip, "on") + + strip <- render_strips( + labels, + labeller = label_value, + theme = theme_test() + theme(strip.clip = "off") + ) + expect_equal(strip$x$top[[1]]$layout$clip, "off") +}) + +test_that("strip labels can be accessed", { + + expect_null(get_strip_labels(ggplot())) + + expect_equal( + get_strip_labels(ggplot() + facet_wrap(vars("X", "Y"))), + list(facets = data_frame0(`"X"` = "X", `"Y"` = "Y")) + ) + + expect_equal( + get_strip_labels(ggplot() + facet_grid(vars("X"), vars("Y"))), + list( + cols = data_frame0(`"Y"` = "Y"), + rows = data_frame0(`"X"` = "X") + ) + ) +}) + # Variable combinations --------------------------------------------------- test_that("zero-length vars in combine_vars() generates zero combinations", { diff --git a/tests/testthat/test-facet-grid-.R b/tests/testthat/test-facet-grid-.R index fd0df003b9..42e69576af 100644 --- a/tests/testthat/test-facet-grid-.R +++ b/tests/testthat/test-facet-grid-.R @@ -303,3 +303,128 @@ test_that("facet_grid() order follows default data frame order", { expect_equal(as.character(lay$fy), c("C","B","A")[lay$ROW]) expect_equal(as.character(lay$fx), c("c","b","a")[lay$COL]) }) + +# Strips ------------------------------------------------------------------ + +test_that("facet_grid() lays out strips correctly", { + + strip_layout <- function(p) { + data <- ggplot_build(p) + plot <- data@plot + layout <- data@layout + data <- data@data + theme <- plot_theme(plot) + + geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot@layers, data) + + facet <- layout$render(geom_grobs, data, theme, plot@labels) + layout <- facet$layout + strip_layout <- layout[grepl("^strip", layout$name), 1:4] + as.list(strip_layout) + } + + p <- ggplot(mtcars, aes(disp, drat)) + geom_point() + + # Default (top + right) + grid <- p + facet_grid(~cyl) + grid_expected <- list( + t = c(3, 3, 3), + l = c(3, 5, 7), + b = c(3, 3, 3), + r = c(3, 5, 7) + ) + expect_equal(strip_layout(grid), grid_expected) + + # Switch x (bottom + right) + grid_x <- p + facet_grid(am ~ cyl, switch = "x") + grid_x_expected <- list( + t = c(6, 6, 6, 3, 5), + l = c(3, 5, 7, 8, 8), + b = c(6, 6, 6, 3, 5), + r = c(3, 5, 7, 8, 8) + ) + expect_equal(strip_layout(grid_x), grid_x_expected) + + # Switch y (top + left) + grid_y <- p + facet_grid(am ~ cyl, switch = "y") + grid_y_expected <- list( + t = c(3, 3, 3, 4, 6), + l = c(4, 6, 8, 3, 3), + b = c(3, 3, 3, 4, 6), + r = c(4, 6, 8, 3, 3) + ) + expect_equal(strip_layout(grid_y), grid_y_expected) + + # Switch both (bottom + left) + grid_xy <- p + facet_grid(am ~ cyl, switch = "both") + grid_xy_expected <- list( + t = c(6, 6, 6, 3, 5), + l = c(4, 6, 8, 3, 3), + b = c(6, 6, 6, 3, 5), + r = c(4, 6, 8, 3, 3) + ) + expect_equal(strip_layout(grid_xy), grid_xy_expected) +}) + +test_that("facet_grid() warns about bad switch input", { + expect_snapshot_error(facet_grid(am ~ cyl, switch = "z")) +}) + +test_that("padding is only added if axis is present", { + p <- ggplot(data = mpg, aes(x = displ, y = hwy)) + + facet_grid(year ~ drv) + + theme( + strip.placement = "outside", + strip.switch.pad.grid = unit(10, "mm") + ) + pg <- ggplotGrob(p) + expect_length(pg$heights, 19) + expect_length(pg$widths, 18) + + pg <- ggplotGrob( + p + scale_x_continuous(position = "top") + + scale_y_continuous(position = "right") + ) + expect_length(pg$heights, 20) + expect_equal(as.character(pg$heights[9]), "1cm") + expect_length(pg$widths, 19) + expect_equal(as.character(pg$widths[13]), "1cm") + + # Also add padding with negative ticks and no text (#5251) + pg <- ggplotGrob( + p + scale_x_continuous(labels = NULL, position = "top") + + theme(axis.ticks.length.x.top = unit(-2, "mm")) + ) + expect_length(pg$heights, 20) + expect_equal(as.character(pg$heights[9]), "1cm") + + # Inverse should be true when strips are switched + p <- ggplot(data = mpg, aes(x = displ, y = hwy)) + + facet_grid(year ~ drv, switch = "both") + + theme( + strip.placement = "outside", + strip.switch.pad.grid = unit(10, "mm") + ) + + pg <- ggplotGrob(p) + expect_length(pg$heights, 20) + expect_equal(as.character(pg$heights[13]), "1cm") + expect_length(pg$widths, 19) + expect_equal(as.character(pg$widths[7]), "1cm") + + pg <- ggplotGrob( + p + scale_x_continuous(position = "top") + + scale_y_continuous(position = "right") + ) + expect_length(pg$heights, 19) + expect_length(pg$widths, 18) +}) + +test_that("y strip labels are rotated when strips are switched", { + switched <- ggplot(mtcars, aes(disp, drat)) + + geom_point() + + facet_grid(am ~ cyl, switch = "both") + + expect_doppelganger("switched facet strips", switched) +}) + diff --git a/tests/testthat/test-facet-strips.R b/tests/testthat/test-facet-strips.R deleted file mode 100644 index 2f1080877f..0000000000 --- a/tests/testthat/test-facet-strips.R +++ /dev/null @@ -1,229 +0,0 @@ -strip_layout <- function(p) { - data <- ggplot_build(p) - plot <- data@plot - layout <- data@layout - data <- data@data - theme <- plot_theme(plot) - - geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot@layers, data) - - facet <- layout$render(geom_grobs, data, theme, plot@labels) - layout <- facet$layout - strip_layout <- layout[grepl("^strip", layout$name), 1:4] - as.list(strip_layout) -} - -p <- ggplot(mtcars, aes(disp, drat)) + geom_point() - - -test_that("facet_wrap() builds correct output", { - wrap <- p + facet_wrap(~cyl) - - wrap_expected <- list( - t = c(3, 3, 3), - l = c(3, 7, 11), - b = c(3, 3, 3), - r = c(3, 7, 11) - ) - - expect_equal(strip_layout(wrap), wrap_expected) -}) - -test_that("facet_wrap() switches to 'bottom'", { - wrap_b <- p + facet_wrap(~cyl, strip.position = "bottom") - - wrap_b_expected <- list( - t = c(4, 4, 4), - l = c(3, 7, 11), - b = c(4, 4, 4), - r = c(3, 7, 11) - ) - - expect_equal(strip_layout(wrap_b), wrap_b_expected) -}) - -test_that("facet_wrap() switches to 'left'", { - wrap_l <- p + facet_wrap(~cyl, strip.position = "left") - - wrap_l_expected <- list( - t = c(3, 3, 3), - l = c(13, 8, 3), - b = c(3, 3, 3), - r = c(13, 8, 3) - ) - - expect_equal(strip_layout(wrap_l), wrap_l_expected) -}) - -test_that("facet_wrap() switches to 'right'", { - wrap_r <- p + facet_wrap(~cyl, strip.position = "right") - - wrap_r_expected <- list( - t = c(3, 3, 3), - l = c(14, 9, 4), - b = c(3, 3, 3), - r = c(14, 9, 4) - ) - - expect_equal(strip_layout(wrap_r), wrap_r_expected) -}) - -test_that("facet_grid() builds correct output", { - grid <- p + facet_grid(~cyl) - - grid_expected <- list( - t = c(3, 3, 3), - l = c(3, 5, 7), - b = c(3, 3, 3), - r = c(3, 5, 7) - ) - - expect_equal(strip_layout(grid), grid_expected) -}) - -test_that("facet_grid() switches to 'x'", { - grid_x <- p + facet_grid(am ~ cyl, switch = "x") - - grid_x_expected <- list( - t = c(6, 6, 6, 3, 5), - l = c(3, 5, 7, 8, 8), - b = c(6, 6, 6, 3, 5), - r = c(3, 5, 7, 8, 8) - ) - - expect_equal(strip_layout(grid_x), grid_x_expected) -}) - -test_that("facet_grid() switches to 'y'", { - grid_y <- p + facet_grid(am ~ cyl, switch = "y") - - grid_y_expected <- list( - t = c(3, 3, 3, 4, 6), - l = c(4, 6, 8, 3, 3), - b = c(3, 3, 3, 4, 6), - r = c(4, 6, 8, 3, 3) - ) - - expect_equal(strip_layout(grid_y), grid_y_expected) -}) - -test_that("facet_grid() switches to both 'x' and 'y'", { - grid_xy <- p + facet_grid(am ~ cyl, switch = "both") - - grid_xy_expected <- list( - t = c(6, 6, 6, 3, 5), - l = c(4, 6, 8, 3, 3), - b = c(6, 6, 6, 3, 5), - r = c(4, 6, 8, 3, 3) - ) - - expect_equal(strip_layout(grid_xy), grid_xy_expected) -}) - -test_that("facet_grid() warns about bad switch input", { - expect_snapshot_error(facet_grid(am ~ cyl, switch = "z")) -}) - -test_that("strips can be removed", { - dat <- data_frame(a = rep(LETTERS[1:10], 10), x = rnorm(100), y = rnorm(100)) - g <- ggplot(dat, aes(x = x, y = y)) + - geom_point() + - facet_wrap(~a) + - theme(strip.background = element_blank(), strip.text = element_blank()) - g_grobs <- ggplotGrob(g) - strip_grobs <- g_grobs$grobs[grepl('strip-', g_grobs$layout$name)] - expect_true(all(sapply(strip_grobs, inherits, 'zeroGrob'))) -}) - -test_that("padding is only added if axis is present", { - p <- ggplot(data = mpg, aes(x = displ, y = hwy)) + - facet_grid(year ~ drv) + - theme( - strip.placement = "outside", - strip.switch.pad.grid = unit(10, "mm") - ) - pg <- ggplotGrob(p) - expect_length(pg$heights, 19) - expect_length(pg$widths, 18) - - pg <- ggplotGrob( - p + scale_x_continuous(position = "top") + - scale_y_continuous(position = "right") - ) - expect_length(pg$heights, 20) - expect_equal(as.character(pg$heights[9]), "1cm") - expect_length(pg$widths, 19) - expect_equal(as.character(pg$widths[13]), "1cm") - - # Also add padding with negative ticks and no text (#5251) - pg <- ggplotGrob( - p + scale_x_continuous(labels = NULL, position = "top") + - theme(axis.ticks.length.x.top = unit(-2, "mm")) - ) - expect_length(pg$heights, 20) - expect_equal(as.character(pg$heights[9]), "1cm") - - # Inverse should be true when strips are switched - p <- ggplot(data = mpg, aes(x = displ, y = hwy)) + - facet_grid(year ~ drv, switch = "both") + - theme( - strip.placement = "outside", - strip.switch.pad.grid = unit(10, "mm") - ) - - pg <- ggplotGrob(p) - expect_length(pg$heights, 20) - expect_equal(as.character(pg$heights[13]), "1cm") - expect_length(pg$widths, 19) - expect_equal(as.character(pg$widths[7]), "1cm") - - pg <- ggplotGrob( - p + scale_x_continuous(position = "top") + - scale_y_continuous(position = "right") - ) - expect_length(pg$heights, 19) - expect_length(pg$widths, 18) -}) - -test_that("y strip labels are rotated when strips are switched", { - switched <- p + facet_grid(am ~ cyl, switch = "both") - - expect_doppelganger("switched facet strips", switched) -}) - -test_that("strip clipping can be set from the theme", { - labels <- data_frame(var1 = "a") - - strip <- render_strips( - labels, - labeller = label_value, - theme = theme_test() + theme(strip.clip = "on") - ) - expect_equal(strip$x$top[[1]]$layout$clip, "on") - - strip <- render_strips( - labels, - labeller = label_value, - theme = theme_test() + theme(strip.clip = "off") - ) - expect_equal(strip$x$top[[1]]$layout$clip, "off") -}) - -test_that("strip labels can be accessed", { - - expect_null(get_strip_labels(ggplot())) - - expect_equal( - get_strip_labels(ggplot() + facet_wrap(vars("X", "Y"))), - list(facets = data_frame0(`"X"` = "X", `"Y"` = "Y")) - ) - - expect_equal( - get_strip_labels(ggplot() + facet_grid(vars("X"), vars("Y"))), - list( - cols = data_frame0(`"Y"` = "Y"), - rows = data_frame0(`"X"` = "X") - ) - ) -}) - diff --git a/tests/testthat/test-facet-wrap.R b/tests/testthat/test-facet-wrap.R index 99e80781d5..1ece5f06a5 100644 --- a/tests/testthat/test-facet-wrap.R +++ b/tests/testthat/test-facet-wrap.R @@ -261,3 +261,65 @@ test_that("facet_wrap() order follows default data frame order", { geom_point(data = d) + geom_blank(data = d2)) expect_equal(as.character(lay$fx), c("c","b","a")[lay$PANEL]) }) + +# Strips ------------------------------------------------------------------ + +test_that("facet_wrap() lays out strips correctly", { + + strip_layout <- function(p) { + data <- ggplot_build(p) + plot <- data@plot + layout <- data@layout + data <- data@data + theme <- plot_theme(plot) + + geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot@layers, data) + + facet <- layout$render(geom_grobs, data, theme, plot@labels) + layout <- facet$layout + strip_layout <- layout[grepl("^strip", layout$name), 1:4] + as.list(strip_layout) + } + + p <- ggplot(mtcars, aes(disp, drat)) + geom_point() + + # Building correct output (top position) + wrap <- p + facet_wrap(~cyl) + wrap_expected <- list( + t = c(3, 3, 3), + l = c(3, 7, 11), + b = c(3, 3, 3), + r = c(3, 7, 11) + ) + expect_equal(strip_layout(wrap), wrap_expected) + + # Switching to bottom + wrap_b <- p + facet_wrap(~cyl, strip.position = "bottom") + wrap_b_expected <- list( + t = c(4, 4, 4), + l = c(3, 7, 11), + b = c(4, 4, 4), + r = c(3, 7, 11) + ) + expect_equal(strip_layout(wrap_b), wrap_b_expected) + + # Switching to left + wrap_l <- p + facet_wrap(~cyl, strip.position = "left") + wrap_l_expected <- list( + t = c(3, 3, 3), + l = c(13, 8, 3), + b = c(3, 3, 3), + r = c(13, 8, 3) + ) + expect_equal(strip_layout(wrap_l), wrap_l_expected) + + # Switching to right + wrap_r <- p + facet_wrap(~cyl, strip.position = "right") + wrap_r_expected <- list( + t = c(3, 3, 3), + l = c(14, 9, 4), + b = c(3, 3, 3), + r = c(14, 9, 4) + ) + expect_equal(strip_layout(wrap_r), wrap_r_expected) +}) From 170bee26a0e7424a3bfb37ba8d17f2f17e17a608 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 15:26:52 +0100 Subject: [PATCH 27/78] migrate wrap/grid specific tests out from `test-facet.R` --- tests/testthat/test-facet-.R | 193 +----------------------------- tests/testthat/test-facet-grid-.R | 98 +++++++++++++++ tests/testthat/test-facet-wrap.R | 95 +++++++++++++++ 3 files changed, 199 insertions(+), 187 deletions(-) diff --git a/tests/testthat/test-facet-.R b/tests/testthat/test-facet-.R index 053c83fdec..6dc050530f 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -112,96 +112,11 @@ test_that("facets split up the data", { expect_equal(d1, d5) }) - -test_that("facet_wrap() accepts vars()", { - df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) - p <- ggplot(df, aes(x, y)) + geom_point() - - p1 <- p + facet_wrap(~z) - p2 <- p + facet_wrap(vars(Z = z), labeller = label_both) - - expect_identical(get_layer_data(p1), get_layer_data(p2)) -}) - -test_that("facet_grid() accepts vars()", { - grid <- facet_grid(vars(a = foo)) - expect_identical(grid$params$rows, quos(a = foo)) - - grid <- facet_grid(vars(a = foo), vars(b = bar)) - expect_identical(grid$params$rows, quos(a = foo)) - expect_identical(grid$params$cols, quos(b = bar)) - - grid <- facet_grid(vars(foo), vars(bar)) - expect_identical(grid$params$rows, quos(foo = foo)) - expect_identical(grid$params$cols, quos(bar = bar)) - - expect_equal(facet_grid(vars(am, vs))$params, facet_grid(am + vs ~ .)$params) - expect_equal(facet_grid(vars(am, vs), vars(cyl))$params, facet_grid(am + vs ~ cyl)$params) - expect_equal(facet_grid(NULL, vars(cyl))$params, facet_grid(. ~ cyl)$params) - expect_equal(facet_grid(vars(am, vs), TRUE)$params, facet_grid(am + vs ~ ., margins = TRUE)$params) -}) - -test_that("facet_grid() fails if passed both a formula and a vars()", { - expect_snapshot_error(facet_grid(~foo, vars())) -}) - -test_that("can't pass formulas to `cols`", { - expect_snapshot_error(facet_grid(NULL, ~foo)) -}) - -test_that("can still pass `margins` as second argument", { - grid <- facet_grid(~foo, TRUE) - expect_true(grid$params$margins) -}) - test_that("vars() accepts optional names", { wrap <- facet_wrap(vars(A = a, b)) expect_named(wrap$params$facets, c("A", "b")) }) -test_that("facet_wrap()/facet_grid() compact the facet spec, and accept empty spec", { - df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) - p <- ggplot(df, aes(x, y)) + geom_point() - - # facet_wrap() - p_wrap <- p + facet_wrap(vars(NULL)) - d_wrap <- get_layer_data(p_wrap) - - expect_equal(d_wrap$PANEL, factor(c(1L, 1L, 1L))) - expect_equal(d_wrap$group, structure(c(-1L, -1L, -1L), n = 1L)) - - # facet_grid() - p_grid <- p + facet_grid(vars(NULL)) - d_grid <- get_layer_data(p_grid) - - expect_equal(d_grid$PANEL, factor(c(1L, 1L, 1L))) - expect_equal(d_grid$group, structure(c(-1L, -1L, -1L), n = 1L)) -}) - - -test_that("facets with free scales scale independently", { - df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) - p <- ggplot(df, aes(x, y)) + geom_point() - - # facet_wrap() - l1 <- p + facet_wrap(~z, scales = "free") - d1 <- cdata(l1)[[1]] - expect_true(sd(d1$x) < 1e-10) - expect_true(sd(d1$y) < 1e-10) - - # RHS of facet_grid() - l2 <- p + facet_grid(. ~ z, scales = "free") - d2 <- cdata(l2)[[1]] - expect_true(sd(d2$x) < 1e-10) - expect_length(unique(d2$y), 3) - - # LHS of facet_grid() - l3 <- p + facet_grid(z ~ ., scales = "free") - d3 <- cdata(l3)[[1]] - expect_length(unique(d3$x), 3) - expect_true(sd(d3$y) < 1e-10) -}) - test_that("shrink parameter affects scaling", { df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) @@ -235,108 +150,6 @@ test_that("facet gives clear error if ", { expect_snapshot_error(print(ggplot(df, aes(x)) + facet_grid(vars(x), "free"))) }) -test_that("facet_grid `axis_labels` argument can be overruled", { - - f <- facet_grid(vars(cyl), axes = "all", axis.labels = "all") - expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - - f <- facet_grid(vars(cyl), axes = "all", axis.labels = "margins") - expect_equal(f$params$axis_labels, list(x = FALSE, y = FALSE)) - - # Overrule when only drawing at margins - f <- facet_grid(vars(cyl), axes = "margins", axis.labels = "margins") - expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - -}) - -test_that("facet_wrap `axis_labels` argument can be overruled", { - - # The folllowing three should all draw axis labels - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "all") - expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - - f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "all") - expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "all") - expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - - # The only case when labels shouldn't be drawn is when scales are fixed but - # the axes are to be drawn - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "margins") - expect_equal(f$params$axis_labels, list(x = FALSE, y = FALSE)) - - # Should draw labels because scales are free - f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "margins") - expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - - # Should draw labels because only drawing at margins - f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "margins") - expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) - -}) - -test_that("facet_grid `axes` can draw inner axes.", { - df <- data_frame( - x = 1:4, y = 1:4, - fx = c("A", "A", "B", "B"), - fy = c("c", "d", "c", "d") - ) - p <- ggplot(df, aes(x, y)) + geom_point() - - case <- ggplotGrob(p + facet_grid(vars(fy), vars(fx), axes = "all")) - ctrl <- ggplotGrob(p + facet_grid(vars(fy), vars(fx), axes = "margins")) - - # 4 x-axes if all axes should be drawn - bottom <- case$grobs[grepl("axis-b", case$layout$name)] - expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 4) - # 2 x-axes if drawing at the margins - bottom <- ctrl$grobs[grepl("axis-b", ctrl$layout$name)] - expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 2) - - # Ditto for y-axes - left <- case$grobs[grepl("axis-l", case$layout$name)] - expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 4) - left <- ctrl$grobs[grepl("axis-l", ctrl$layout$name)] - expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 2) -}) - -test_that("facet_wrap `axes` can draw inner axes.", { - df <- data_frame( - x = 1, y = 1, facet = LETTERS[1:4] - ) - - p <- ggplot(df, aes(x, y)) + geom_point() - - case <- ggplotGrob(p + facet_wrap(vars(facet), axes = "all")) - ctrl <- ggplotGrob(p + facet_wrap(vars(facet), axes = "margins")) - - # 4 x-axes if all axes should be drawn - bottom <- case$grobs[grepl("axis-b", case$layout$name)] - expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 4) - # 2 x-axes if drawing at the margins - bottom <- ctrl$grobs[grepl("axis-b", ctrl$layout$name)] - expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 2) - - # Ditto for y-axes - left <- case$grobs[grepl("axis-l", case$layout$name)] - expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 4) - left <- ctrl$grobs[grepl("axis-l", ctrl$layout$name)] - expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 2) -}) - -test_that("facet_wrap throws deprecation messages", { - withr::local_options(lifecycle_verbosity = "warning") - - facet <- facet_wrap(vars(year)) - facet$params$dir <- "h" - - lifecycle::expect_deprecated( - ggplot_build(ggplot(mpg, aes(displ, hwy)) + geom_point() + facet), - "Internal use of" - ) -}) - # Strips ------------------------------------------------------------------ test_that("strips can be removed", { @@ -528,6 +341,12 @@ test_that("check_layout() throws meaningful errors", { }) test_that("wrap and grid are equivalent for 1d data", { + panel_layout <- function(facet, data) { + layout <- create_layout(facet = facet, coord = CoordCartesian) + layout$setup(data) + layout$layout + } + rowg <- panel_layout(facet_grid(a~.), list(a)) roww <- panel_layout(facet_wrap(~a, ncol = 1), list(a)) expect_equal(roww, rowg) diff --git a/tests/testthat/test-facet-grid-.R b/tests/testthat/test-facet-grid-.R index 42e69576af..eaa363e2ef 100644 --- a/tests/testthat/test-facet-grid-.R +++ b/tests/testthat/test-facet-grid-.R @@ -1,3 +1,101 @@ +# General ----------------------------------------------------------------- + +test_that("facet_grid() accepts vars()", { + grid <- facet_grid(vars(a = foo)) + expect_identical(grid$params$rows, quos(a = foo)) + + grid <- facet_grid(vars(a = foo), vars(b = bar)) + expect_identical(grid$params$rows, quos(a = foo)) + expect_identical(grid$params$cols, quos(b = bar)) + + grid <- facet_grid(vars(foo), vars(bar)) + expect_identical(grid$params$rows, quos(foo = foo)) + expect_identical(grid$params$cols, quos(bar = bar)) + + expect_equal(facet_grid(vars(am, vs))$params, facet_grid(am + vs ~ .)$params) + expect_equal(facet_grid(vars(am, vs), vars(cyl))$params, facet_grid(am + vs ~ cyl)$params) + expect_equal(facet_grid(NULL, vars(cyl))$params, facet_grid(. ~ cyl)$params) + expect_equal(facet_grid(vars(am, vs), TRUE)$params, facet_grid(am + vs ~ ., margins = TRUE)$params) +}) + +test_that("facet_grid() handles rows/cols correctly", { + # fails if passed both a formula and a vars() + expect_snapshot_error(facet_grid(~foo, vars())) + + # can't pass formulas to `cols` + expect_snapshot_error(facet_grid(NULL, ~foo)) + + # can still pass `margins` as second argument + grid <- facet_grid(~foo, TRUE) + expect_true(grid$params$margins) +}) + +test_that("facet_grid() compact the facet spec, and accept empty spec", { + df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) + p <- ggplot(df, aes(x, y)) + geom_point() + + facet_grid(vars(NULL)) + d_grid <- get_layer_data(p) + + expect_equal(d_grid$PANEL, factor(c(1L, 1L, 1L))) + expect_equal(d_grid$group, structure(c(-1L, -1L, -1L), n = 1L)) +}) + +test_that("facets with free scales scale independently", { + df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) + p <- ggplot(df, aes(x, y)) + geom_point() + + # RHS of facet_grid() + l1 <- p + facet_grid(. ~ z, scales = "free") + d1 <- cdata(l1)[[1]] + expect_true(sd(d1$x) < 1e-10) + expect_length(unique(d1$y), 3) + + # LHS of facet_grid() + l2 <- p + facet_grid(z ~ ., scales = "free") + d2 <- cdata(l2)[[1]] + expect_length(unique(d2$x), 3) + expect_true(sd(d2$y) < 1e-10) +}) + +test_that("facet_grid `axis_labels` argument can be overruled", { + + f <- facet_grid(vars(cyl), axes = "all", axis.labels = "all") + expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) + + f <- facet_grid(vars(cyl), axes = "all", axis.labels = "margins") + expect_equal(f$params$axis_labels, list(x = FALSE, y = FALSE)) + + # Overrule when only drawing at margins + f <- facet_grid(vars(cyl), axes = "margins", axis.labels = "margins") + expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) + +}) + +test_that("facet_grid `axes` can draw inner axes.", { + df <- data_frame( + x = 1:4, y = 1:4, + fx = c("A", "A", "B", "B"), + fy = c("c", "d", "c", "d") + ) + p <- ggplot(df, aes(x, y)) + geom_point() + + case <- ggplotGrob(p + facet_grid(vars(fy), vars(fx), axes = "all")) + ctrl <- ggplotGrob(p + facet_grid(vars(fy), vars(fx), axes = "margins")) + + # 4 x-axes if all axes should be drawn + bottom <- case$grobs[grepl("axis-b", case$layout$name)] + expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 4) + # 2 x-axes if drawing at the margins + bottom <- ctrl$grobs[grepl("axis-b", ctrl$layout$name)] + expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 2) + + # Ditto for y-axes + left <- case$grobs[grepl("axis-l", case$layout$name)] + expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 4) + left <- ctrl$grobs[grepl("axis-l", ctrl$layout$name)] + expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 2) +}) + # Layout ------------------------------------------------------------------ a <- data_frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) diff --git a/tests/testthat/test-facet-wrap.R b/tests/testthat/test-facet-wrap.R index 1ece5f06a5..351814ec9c 100644 --- a/tests/testthat/test-facet-wrap.R +++ b/tests/testthat/test-facet-wrap.R @@ -1,3 +1,98 @@ +# General ----------------------------------------------------------------- + +test_that("facet_wrap() accepts vars()", { + df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) + p <- ggplot(df, aes(x, y)) + geom_point() + + p1 <- p + facet_wrap(~z) + p2 <- p + facet_wrap(vars(Z = z), labeller = label_both) + + expect_identical(get_layer_data(p1), get_layer_data(p2)) +}) + +test_that("facet_wrap() compact the facet spec, and accept empty spec", { + df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) + p <- ggplot(df, aes(x, y)) + geom_point() + + facet_wrap(vars(NULL)) + d_wrap <- get_layer_data(p) + + expect_equal(d_wrap$PANEL, factor(c(1L, 1L, 1L))) + expect_equal(d_wrap$group, structure(c(-1L, -1L, -1L), n = 1L)) +}) + +test_that("facets with free scales scale independently", { + df <- data_frame(x = 1:3, y = 3:1, z = letters[1:3]) + p <- ggplot(df, aes(x, y)) + geom_point() + + l1 <- p + facet_wrap(~z, scales = "free") + d1 <- cdata(l1)[[1]] + expect_true(sd(d1$x) < 1e-10) + expect_true(sd(d1$y) < 1e-10) +}) + +test_that("facet_wrap `axis_labels` argument can be overruled", { + + # The folllowing three should all draw axis labels + f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "all") + expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) + + f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "all") + expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) + + f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "all") + expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) + + # The only case when labels shouldn't be drawn is when scales are fixed but + # the axes are to be drawn + f <- facet_wrap(vars(cyl), scales = "fixed", axes = "all", axis.labels = "margins") + expect_equal(f$params$axis_labels, list(x = FALSE, y = FALSE)) + + # Should draw labels because scales are free + f <- facet_wrap(vars(cyl), scales = "free", axes = "all", axis.labels = "margins") + expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) + + # Should draw labels because only drawing at margins + f <- facet_wrap(vars(cyl), scales = "fixed", axes = "margins", axis.labels = "margins") + expect_equal(f$params$axis_labels, list(x = TRUE, y = TRUE)) + +}) + +test_that("facet_wrap `axes` can draw inner axes.", { + df <- data_frame( + x = 1, y = 1, facet = LETTERS[1:4] + ) + + p <- ggplot(df, aes(x, y)) + geom_point() + + case <- ggplotGrob(p + facet_wrap(vars(facet), axes = "all")) + ctrl <- ggplotGrob(p + facet_wrap(vars(facet), axes = "margins")) + + # 4 x-axes if all axes should be drawn + bottom <- case$grobs[grepl("axis-b", case$layout$name)] + expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 4) + # 2 x-axes if drawing at the margins + bottom <- ctrl$grobs[grepl("axis-b", ctrl$layout$name)] + expect_equal(sum(vapply(bottom, inherits, logical(1), "absoluteGrob")), 2) + + # Ditto for y-axes + left <- case$grobs[grepl("axis-l", case$layout$name)] + expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 4) + left <- ctrl$grobs[grepl("axis-l", ctrl$layout$name)] + expect_equal(sum(vapply(left, inherits, logical(1), "absoluteGrob")), 2) +}) + +test_that("facet_wrap throws deprecation messages", { + withr::local_options(lifecycle_verbosity = "warning") + + facet <- facet_wrap(vars(year)) + facet$params$dir <- "h" + + lifecycle::expect_deprecated( + ggplot_build(ggplot(mpg, aes(displ, hwy)) + geom_point() + facet), + "Internal use of" + ) +}) + # Layout ------------------------------------------------------------------ a <- data_frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) From d5f59210787fa041656580ffc5f59be9b48c673f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 16:39:21 +0100 Subject: [PATCH 28/78] accept snapshots moving around --- tests/testthat/_snaps/facet-.md | 23 ++++--- tests/testthat/_snaps/facet-grid-.md | 20 +++++++ .../switched-facet-strips.svg | 0 .../{facet-labels.md => facet-labeller.md} | 0 .../outside-justified-labels.svg | 0 .../parsed-facet-labels.svg | 0 tests/testthat/_snaps/facet-layout.md | 60 ------------------- tests/testthat/_snaps/facet-strips.md | 4 -- tests/testthat/_snaps/facet-wrap.md | 37 ++++++++++++ ...sitioned-correctly-in-non-table-layout.svg | 0 10 files changed, 72 insertions(+), 72 deletions(-) create mode 100644 tests/testthat/_snaps/facet-grid-.md rename tests/testthat/_snaps/{facet-strips => facet-grid-}/switched-facet-strips.svg (100%) rename tests/testthat/_snaps/{facet-labels.md => facet-labeller.md} (100%) rename tests/testthat/_snaps/{facet-labels => facet-labeller}/outside-justified-labels.svg (100%) rename tests/testthat/_snaps/{facet-labels => facet-labeller}/parsed-facet-labels.svg (100%) delete mode 100644 tests/testthat/_snaps/facet-layout.md delete mode 100644 tests/testthat/_snaps/facet-strips.md create mode 100644 tests/testthat/_snaps/facet-wrap.md rename tests/testthat/_snaps/{facet-layout => facet-wrap}/axes-are-positioned-correctly-in-non-table-layout.svg (100%) diff --git a/tests/testthat/_snaps/facet-.md b/tests/testthat/_snaps/facet-.md index 154499e38a..77050e88c0 100644 --- a/tests/testthat/_snaps/facet-.md +++ b/tests/testthat/_snaps/facet-.md @@ -14,14 +14,6 @@ Error in `check_vars()`: ! Please use `vars()` to supply facet variables. -# facet_grid() fails if passed both a formula and a vars() - - `rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list. - -# can't pass formulas to `cols` - - `cols` must be a `vars()` specification or `NULL`, not a object. - # facet gives clear error if Faceting variables can only appear in `rows` or `cols`, not both. @@ -86,3 +78,18 @@ Facet layout has a bad format. It must contain columns `PANEL`, `SCALE_X`, and `SCALE_Y`. +# facet_wrap and facet_grid throws errors when using reserved words + + "ROW" is not an allowed name for faceting variables. + i Change the name of your data columns to not be "PANEL", "ROW", "COL", "SCALE_X", or "SCALE_Y". + +--- + + "ROW" and "PANEL" are not allowed names for faceting variables. + i Change the name of your data columns to not be "PANEL", "ROW", "COL", "SCALE_X", or "SCALE_Y". + +--- + + "ROW" is not an allowed name for faceting variables. + i Change the name of your data columns to not be "PANEL", "ROW", "COL", "SCALE_X", or "SCALE_Y". + diff --git a/tests/testthat/_snaps/facet-grid-.md b/tests/testthat/_snaps/facet-grid-.md new file mode 100644 index 0000000000..f709fef1ac --- /dev/null +++ b/tests/testthat/_snaps/facet-grid-.md @@ -0,0 +1,20 @@ +# facet_grid() handles rows/cols correctly + + `rows` must be `NULL` or a `vars()` list if `cols` is a `vars()` list. + +--- + + `cols` must be a `vars()` specification or `NULL`, not a object. + +# facet_grid() throws errors at bad layout specs + + `facet_grid()` can't use free scales with `coord_cartesian()` with a fixed `ratio` argument. + +--- + + Free scales cannot be mixed with a fixed aspect ratio. + +# facet_grid() warns about bad switch input + + `switch` must be one of "both", "x", or "y", not "z". + diff --git a/tests/testthat/_snaps/facet-strips/switched-facet-strips.svg b/tests/testthat/_snaps/facet-grid-/switched-facet-strips.svg similarity index 100% rename from tests/testthat/_snaps/facet-strips/switched-facet-strips.svg rename to tests/testthat/_snaps/facet-grid-/switched-facet-strips.svg diff --git a/tests/testthat/_snaps/facet-labels.md b/tests/testthat/_snaps/facet-labeller.md similarity index 100% rename from tests/testthat/_snaps/facet-labels.md rename to tests/testthat/_snaps/facet-labeller.md diff --git a/tests/testthat/_snaps/facet-labels/outside-justified-labels.svg b/tests/testthat/_snaps/facet-labeller/outside-justified-labels.svg similarity index 100% rename from tests/testthat/_snaps/facet-labels/outside-justified-labels.svg rename to tests/testthat/_snaps/facet-labeller/outside-justified-labels.svg diff --git a/tests/testthat/_snaps/facet-labels/parsed-facet-labels.svg b/tests/testthat/_snaps/facet-labeller/parsed-facet-labels.svg similarity index 100% rename from tests/testthat/_snaps/facet-labels/parsed-facet-labels.svg rename to tests/testthat/_snaps/facet-labeller/parsed-facet-labels.svg diff --git a/tests/testthat/_snaps/facet-layout.md b/tests/testthat/_snaps/facet-layout.md deleted file mode 100644 index 2df447c705..0000000000 --- a/tests/testthat/_snaps/facet-layout.md +++ /dev/null @@ -1,60 +0,0 @@ -# facet_wrap throws errors at bad layout specs - - `ncol` must be a whole number or `NULL`, not an integer vector. - ---- - - `ncol` must be a whole number larger than or equal to 1 or `NULL`, not the number -1. - ---- - - `ncol` must be a whole number or `NULL`, not the number 1.5. - ---- - - `nrow` must be a whole number or `NULL`, not an integer vector. - ---- - - `nrow` must be a whole number larger than or equal to 1 or `NULL`, not the number -1. - ---- - - `nrow` must be a whole number or `NULL`, not the number 1.5. - ---- - - Cannot use `space = "free_x"` with custom `nrow` or `ncol`. - ---- - - Need 3 panels, but together `nrow` and `ncol` only provide 1. - i Please increase `ncol` and/or `nrow`. - ---- - - `facet_wrap()` can't use free scales with `coord_cartesian()` with a fixed `ratio` argument. - -# facet_grid throws errors at bad layout specs - - `facet_grid()` can't use free scales with `coord_cartesian()` with a fixed `ratio` argument. - ---- - - Free scales cannot be mixed with a fixed aspect ratio. - -# facet_wrap and facet_grid throws errors when using reserved words - - "ROW" is not an allowed name for faceting variables. - i Change the name of your data columns to not be "PANEL", "ROW", "COL", "SCALE_X", or "SCALE_Y". - ---- - - "ROW" and "PANEL" are not allowed names for faceting variables. - i Change the name of your data columns to not be "PANEL", "ROW", "COL", "SCALE_X", or "SCALE_Y". - ---- - - "ROW" is not an allowed name for faceting variables. - i Change the name of your data columns to not be "PANEL", "ROW", "COL", "SCALE_X", or "SCALE_Y". - diff --git a/tests/testthat/_snaps/facet-strips.md b/tests/testthat/_snaps/facet-strips.md deleted file mode 100644 index e6a72d047c..0000000000 --- a/tests/testthat/_snaps/facet-strips.md +++ /dev/null @@ -1,4 +0,0 @@ -# facet_grid() warns about bad switch input - - `switch` must be one of "both", "x", or "y", not "z". - diff --git a/tests/testthat/_snaps/facet-wrap.md b/tests/testthat/_snaps/facet-wrap.md new file mode 100644 index 0000000000..f3b84914b9 --- /dev/null +++ b/tests/testthat/_snaps/facet-wrap.md @@ -0,0 +1,37 @@ +# facet_wrap() throws errors at bad layout specs + + `ncol` must be a whole number or `NULL`, not an integer vector. + +--- + + `ncol` must be a whole number larger than or equal to 1 or `NULL`, not the number -1. + +--- + + `ncol` must be a whole number or `NULL`, not the number 1.5. + +--- + + `nrow` must be a whole number or `NULL`, not an integer vector. + +--- + + `nrow` must be a whole number larger than or equal to 1 or `NULL`, not the number -1. + +--- + + `nrow` must be a whole number or `NULL`, not the number 1.5. + +--- + + Cannot use `space = "free_x"` with custom `nrow` or `ncol`. + +--- + + Need 3 panels, but together `nrow` and `ncol` only provide 1. + i Please increase `ncol` and/or `nrow`. + +--- + + `facet_wrap()` can't use free scales with `coord_cartesian()` with a fixed `ratio` argument. + diff --git a/tests/testthat/_snaps/facet-layout/axes-are-positioned-correctly-in-non-table-layout.svg b/tests/testthat/_snaps/facet-wrap/axes-are-positioned-correctly-in-non-table-layout.svg similarity index 100% rename from tests/testthat/_snaps/facet-layout/axes-are-positioned-correctly-in-non-table-layout.svg rename to tests/testthat/_snaps/facet-wrap/axes-are-positioned-correctly-in-non-table-layout.svg From 46b3d5bcdae7b0d89272254c25bb60cd20e1cc59 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 16:43:21 +0100 Subject: [PATCH 29/78] isolate spatial `fortify()` test --- tests/testthat/test-fortify-spatial.R | 57 ++++++++++++++++++++++++++ tests/testthat/test-fortify.R | 58 --------------------------- 2 files changed, 57 insertions(+), 58 deletions(-) create mode 100644 tests/testthat/test-fortify-spatial.R diff --git a/tests/testthat/test-fortify-spatial.R b/tests/testthat/test-fortify-spatial.R new file mode 100644 index 0000000000..73e5a7aabc --- /dev/null +++ b/tests/testthat/test-fortify-spatial.R @@ -0,0 +1,57 @@ +test_that("spatial polygons have correct ordering", { + suppressPackageStartupMessages({ + skip_if_not_installed("sp") + }) + + + make_square <- function(x = 0, y = 0, height = 1, width = 1){ + delx <- width/2 + dely <- height/2 + sp::Polygon(matrix(c(x + delx, x - delx,x - delx,x + delx,x + delx , + y - dely,y - dely,y + dely,y + dely,y - dely), ncol = 2)) + } + + make_hole <- function(x = 0, y = 0, height = 0.5, width = 0.5){ + p <- make_square(x = x, y = y, height = height, width = width) + p@hole <- TRUE + p + } + + fake_data <- data_frame(ids = 1:5, region = c(1,1,2,3,4)) + rownames(fake_data) <- 1:5 + polys <- list(sp::Polygons(list(make_square(), make_hole()), 1), + sp::Polygons(list(make_square(1,0), make_square(2, 0)), 2), + sp::Polygons(list(make_square(1,1)), 3), + sp::Polygons(list(make_square(0,1)), 4), + sp::Polygons(list(make_square(0,3)), 5)) + + polys_sp <- sp::SpatialPolygons(polys) + fake_sp <- sp::SpatialPolygonsDataFrame(polys_sp, fake_data) + + # now reorder regions + polys2 <- rev(polys) + polys2_sp <- sp::SpatialPolygons(polys2) + fake_sp2 <- sp::SpatialPolygonsDataFrame(polys2_sp, fake_data) + lifecycle::expect_deprecated( + # supressing: Regions defined for each Polygons + expected <- suppressMessages(fortify(fake_sp2)) + ) + expected <- expected[order(expected$id, expected$order), ] + + lifecycle::expect_deprecated( + # supressing: Regions defined for each Polygons + actual <- suppressMessages(fortify(fake_sp)) + ) + + # the levels are different, so these columns need to be converted to character to compare + expected$group <- as.character(expected$group) + actual$group <- as.character(actual$group) + + # Use expect_equal(ignore_attr = TRUE) to ignore rownames + expect_equal(actual, expected, ignore_attr = TRUE) + + lifecycle::expect_deprecated( + # fortify() with region is defunct due to maptools' retirement + lifecycle::expect_defunct(fortify(fake_sp, region = "foo")) + ) +}) diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 2650884942..8e01603eea 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -1,61 +1,3 @@ -test_that("spatial polygons have correct ordering", { - suppressPackageStartupMessages({ - skip_if_not_installed("sp") - }) - - - make_square <- function(x = 0, y = 0, height = 1, width = 1){ - delx <- width/2 - dely <- height/2 - sp::Polygon(matrix(c(x + delx, x - delx,x - delx,x + delx,x + delx , - y - dely,y - dely,y + dely,y + dely,y - dely), ncol = 2)) - } - - make_hole <- function(x = 0, y = 0, height = 0.5, width = 0.5){ - p <- make_square(x = x, y = y, height = height, width = width) - p@hole <- TRUE - p - } - - fake_data <- data_frame(ids = 1:5, region = c(1,1,2,3,4)) - rownames(fake_data) <- 1:5 - polys <- list(sp::Polygons(list(make_square(), make_hole()), 1), - sp::Polygons(list(make_square(1,0), make_square(2, 0)), 2), - sp::Polygons(list(make_square(1,1)), 3), - sp::Polygons(list(make_square(0,1)), 4), - sp::Polygons(list(make_square(0,3)), 5)) - - polys_sp <- sp::SpatialPolygons(polys) - fake_sp <- sp::SpatialPolygonsDataFrame(polys_sp, fake_data) - - # now reorder regions - polys2 <- rev(polys) - polys2_sp <- sp::SpatialPolygons(polys2) - fake_sp2 <- sp::SpatialPolygonsDataFrame(polys2_sp, fake_data) - lifecycle::expect_deprecated( - # supressing: Regions defined for each Polygons - expected <- suppressMessages(fortify(fake_sp2)) - ) - expected <- expected[order(expected$id, expected$order), ] - - lifecycle::expect_deprecated( - # supressing: Regions defined for each Polygons - actual <- suppressMessages(fortify(fake_sp)) - ) - - # the levels are different, so these columns need to be converted to character to compare - expected$group <- as.character(expected$group) - actual$group <- as.character(actual$group) - - # Use expect_equal(ignore_attr = TRUE) to ignore rownames - expect_equal(actual, expected, ignore_attr = TRUE) - - lifecycle::expect_deprecated( - # fortify() with region is defunct due to maptools' retirement - lifecycle::expect_defunct(fortify(fake_sp, region = "foo")) - ) -}) - test_that("fortify.default proves a helpful error with mapping class", { expect_snapshot_error(ggplot(aes(x = x))) }) From bb69642add3c38601ee64b2ffa142397fca190e7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 16:58:56 +0100 Subject: [PATCH 30/78] quick little documentation --- DESCRIPTION | 4 ++-- man/as_labeller.Rd | 2 +- man/label_bquote.Rd | 2 +- man/labeller.Rd | 2 +- man/labellers.Rd | 2 +- man/layer_geoms.Rd | 2 +- man/layer_positions.Rd | 2 +- man/layer_stats.Rd | 2 +- tests/testthat/test-facet-.R | 2 ++ 9 files changed, 11 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5ca9986587..075a5072ca 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -128,9 +128,10 @@ Collate: 'coord-transform.R' 'data.R' 'docs-aes.R' - 'docs_layer.R' + 'docs-layer.R' 'facet-.R' 'facet-grid-.R' + 'facet-labeller.R' 'facet-null.R' 'facet-wrap.R' 'fortify-map.R' @@ -201,7 +202,6 @@ Collate: 'hexbin.R' 'import-standalone-obj-type.R' 'import-standalone-types-check.R' - 'labeller.R' 'labels.R' 'layer-sf.R' 'layout.R' diff --git a/man/as_labeller.Rd b/man/as_labeller.Rd index 3d6400a6d5..e1f50dafad 100644 --- a/man/as_labeller.Rd +++ b/man/as_labeller.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/labeller.R +% Please edit documentation in R/facet-labeller.R \name{as_labeller} \alias{as_labeller} \title{Coerce to labeller function} diff --git a/man/label_bquote.Rd b/man/label_bquote.Rd index 375f73d0b0..04d655f69d 100644 --- a/man/label_bquote.Rd +++ b/man/label_bquote.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/labeller.R +% Please edit documentation in R/facet-labeller.R \name{label_bquote} \alias{label_bquote} \title{Label with mathematical expressions} diff --git a/man/labeller.Rd b/man/labeller.Rd index 2c863d2aee..4ecfe0ba1f 100644 --- a/man/labeller.Rd +++ b/man/labeller.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/labeller.R +% Please edit documentation in R/facet-labeller.R \name{labeller} \alias{labeller} \title{Construct labelling specification} diff --git a/man/labellers.Rd b/man/labellers.Rd index 70ac8bf712..4231fdd29a 100644 --- a/man/labellers.Rd +++ b/man/labellers.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/labeller.R +% Please edit documentation in R/facet-labeller.R \name{labellers} \alias{labellers} \alias{label_value} diff --git a/man/layer_geoms.Rd b/man/layer_geoms.Rd index 26b75b2d9d..5ec1874601 100644 --- a/man/layer_geoms.Rd +++ b/man/layer_geoms.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/docs_layer.R +% Please edit documentation in R/docs-layer.R \name{layer_geoms} \alias{layer_geoms} \title{Layer geometry display} diff --git a/man/layer_positions.Rd b/man/layer_positions.Rd index bc04bd8cab..2427bb8f03 100644 --- a/man/layer_positions.Rd +++ b/man/layer_positions.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/docs_layer.R +% Please edit documentation in R/docs-layer.R \name{layer_positions} \alias{layer_positions} \title{Layer position adjustments} diff --git a/man/layer_stats.Rd b/man/layer_stats.Rd index 2115a0537e..a6aba25cb2 100644 --- a/man/layer_stats.Rd +++ b/man/layer_stats.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/docs_layer.R +% Please edit documentation in R/docs-layer.R \name{layer_stats} \alias{layer_stats} \title{Layer statistical transformations} diff --git a/tests/testthat/test-facet-.R b/tests/testthat/test-facet-.R index 6dc050530f..b93b8237ab 100644 --- a/tests/testthat/test-facet-.R +++ b/tests/testthat/test-facet-.R @@ -341,6 +341,8 @@ test_that("check_layout() throws meaningful errors", { }) test_that("wrap and grid are equivalent for 1d data", { + a <- data_frame(a = c(1, 1, 2, 2), b = c(1, 2, 1, 1)) + panel_layout <- function(facet, data) { layout <- create_layout(facet = facet, coord = CoordCartesian) layout$setup(data) From ca6037bde1d4e32a2d2acd1729cb1333a7389180 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 6 Nov 2025 17:11:40 +0100 Subject: [PATCH 31/78] merge hline/vline into abline geom file --- DESCRIPTION | 4 +- ...eom-abline.R => geom-abline-hline-vline.R} | 146 +++++++++++++++++- R/geom-hline.R | 73 --------- R/geom-vline.R | 69 --------- man/Geom.Rd | 15 +- man/geom_abline.Rd | 2 +- ...e-abline.md => geom-abline-hline-vline.md} | 0 .../cartesian-lines-intersect-mid-bars.svg | 0 .../flipped-lines-intersect-mid-bars.svg | 0 .../lines-curved-in-azequalarea.svg | 0 .../polar-lines-intersect-mid-bars.svg | 0 .../straight-lines-in-mercator.svg | 0 ...bline.R => test-geom-abline-hline-vline.R} | 0 13 files changed, 154 insertions(+), 155 deletions(-) rename R/{geom-abline.R => geom-abline-hline-vline.R} (59%) delete mode 100644 R/geom-hline.R delete mode 100644 R/geom-vline.R rename tests/testthat/_snaps/{geom-hline-vline-abline.md => geom-abline-hline-vline.md} (100%) rename tests/testthat/_snaps/{geom-hline-vline-abline => geom-abline-hline-vline}/cartesian-lines-intersect-mid-bars.svg (100%) rename tests/testthat/_snaps/{geom-hline-vline-abline => geom-abline-hline-vline}/flipped-lines-intersect-mid-bars.svg (100%) rename tests/testthat/_snaps/{geom-hline-vline-abline => geom-abline-hline-vline}/lines-curved-in-azequalarea.svg (100%) rename tests/testthat/_snaps/{geom-hline-vline-abline => geom-abline-hline-vline}/polar-lines-intersect-mid-bars.svg (100%) rename tests/testthat/_snaps/{geom-hline-vline-abline => geom-abline-hline-vline}/straight-lines-in-mercator.svg (100%) rename tests/testthat/{test-geom-hline-vline-abline.R => test-geom-abline-hline-vline.R} (100%) diff --git a/DESCRIPTION b/DESCRIPTION index 075a5072ca..7e4c8c5a2f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -139,7 +139,7 @@ Collate: 'fortify-spatial.R' 'fortify.R' 'stat-.R' - 'geom-abline.R' + 'geom-abline-hline-vline.R' 'geom-rect.R' 'geom-bar.R' 'geom-tile.R' @@ -164,7 +164,6 @@ Collate: 'geom-function.R' 'geom-hex.R' 'geom-histogram.R' - 'geom-hline.R' 'geom-jitter.R' 'geom-label.R' 'geom-linerange.R' @@ -176,7 +175,6 @@ Collate: 'geom-spoke.R' 'geom-text.R' 'geom-violin.R' - 'geom-vline.R' 'ggplot2-package.R' 'grob-absolute.R' 'grob-dotstack.R' diff --git a/R/geom-abline.R b/R/geom-abline-hline-vline.R similarity index 59% rename from R/geom-abline.R rename to R/geom-abline-hline-vline.R index a47a9dd86a..d5cdcdb102 100644 --- a/R/geom-abline.R +++ b/R/geom-abline-hline-vline.R @@ -69,7 +69,7 @@ NULL #' geom_hline(aes(yintercept = wt, colour = wt), mean_wt) + #' facet_wrap(~ cyl) geom_abline <- function(mapping = NULL, data = NULL, - stat = "identity", + stat = "identity", ..., slope, intercept, @@ -122,6 +122,86 @@ geom_abline <- function(mapping = NULL, data = NULL, ) } +#' @export +#' @rdname geom_abline +geom_hline <- function(mapping = NULL, data = NULL, + stat = "identity", position = "identity", + ..., + yintercept, + na.rm = FALSE, + show.legend = NA, + inherit.aes = FALSE) { + + # Act like an annotation + if (!missing(yintercept)) { + # Warn if supplied mapping and/or data is going to be overwritten + if (!is.null(mapping)) { + cli::cli_warn("{.fn geom_hline}: Ignoring {.arg mapping} because {.arg yintercept} was provided.") + } + if (!is.null(data)) { + cli::cli_warn("{.fn geom_hline}: Ignoring {.arg data} because {.arg yintercept} was provided.") + } + + data <- data_frame0(yintercept = yintercept) + mapping <- aes(yintercept = yintercept) + show.legend <- FALSE + } + + layer( + data = data, + mapping = mapping, + stat = stat, + geom = GeomHline, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + na.rm = na.rm, + ... + ) + ) +} + +#' @export +#' @rdname geom_abline +geom_vline <- function(mapping = NULL, data = NULL, + stat = "identity", position = "identity", + ..., + xintercept, + na.rm = FALSE, + show.legend = NA, + inherit.aes = FALSE) { + + # Act like an annotation + if (!missing(xintercept)) { + # Warn if supplied mapping and/or data is going to be overwritten + if (!is.null(mapping)) { + cli::cli_warn("{.fn geom_vline}: Ignoring {.arg mapping} because {.arg xintercept} was provided.") + } + if (!is.null(data)) { + cli::cli_warn("{.fn geom_vline}: Ignoring {.arg data} because {.arg xintercept} was provided.") + } + + data <- data_frame0(xintercept = xintercept) + mapping <- aes(xintercept = xintercept) + show.legend <- FALSE + } + + layer( + data = data, + mapping = mapping, + stat = stat, + geom = GeomVline, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list2( + na.rm = na.rm, + ... + ) + ) +} + #' @rdname Geom #' @format NULL #' @usage NULL @@ -163,3 +243,67 @@ GeomAbline <- ggproto("GeomAbline", Geom, check_constant_aes = FALSE ) + +#' @rdname Geom +#' @format NULL +#' @usage NULL +#' @export +GeomHline <- ggproto("GeomHline", Geom, + draw_panel = function(data, panel_params, coord, lineend = "butt") { + ranges <- coord$backtransform_range(panel_params) + + data$x <- ranges$x[1] + data$xend <- ranges$x[2] + data$y <- data$yintercept + data$yend <- data$yintercept + + GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) + }, + + default_aes = aes( + colour = from_theme(colour %||% ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), + required_aes = "yintercept", + + draw_key = draw_key_path, + + rename_size = TRUE, + + check_constant_aes = FALSE +) + +#' @rdname Geom +#' @format NULL +#' @usage NULL +#' @export +GeomVline <- ggproto("GeomVline", Geom, + draw_panel = function(data, panel_params, coord, lineend = "butt") { + ranges <- coord$backtransform_range(panel_params) + + data$x <- data$xintercept + data$xend <- data$xintercept + data$y <- ranges$y[1] + data$yend <- ranges$y[2] + + GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) + }, + + default_aes = aes( + colour = from_theme(colour %||% ink), + linewidth = from_theme(linewidth), + linetype = from_theme(linetype), + alpha = NA + ), + + required_aes = "xintercept", + + draw_key = draw_key_vline, + + rename_size = TRUE, + + check_constant_aes = FALSE +) + diff --git a/R/geom-hline.R b/R/geom-hline.R deleted file mode 100644 index 1498077d30..0000000000 --- a/R/geom-hline.R +++ /dev/null @@ -1,73 +0,0 @@ -#' @include stat-.R -NULL - -#' @export -#' @rdname geom_abline -geom_hline <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - yintercept, - na.rm = FALSE, - show.legend = NA, - inherit.aes = FALSE) { - - # Act like an annotation - if (!missing(yintercept)) { - # Warn if supplied mapping and/or data is going to be overwritten - if (!is.null(mapping)) { - cli::cli_warn("{.fn geom_hline}: Ignoring {.arg mapping} because {.arg yintercept} was provided.") - } - if (!is.null(data)) { - cli::cli_warn("{.fn geom_hline}: Ignoring {.arg data} because {.arg yintercept} was provided.") - } - - data <- data_frame0(yintercept = yintercept) - mapping <- aes(yintercept = yintercept) - show.legend <- FALSE - } - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomHline, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname Geom -#' @format NULL -#' @usage NULL -#' @export -GeomHline <- ggproto("GeomHline", Geom, - draw_panel = function(data, panel_params, coord, lineend = "butt") { - ranges <- coord$backtransform_range(panel_params) - - data$x <- ranges$x[1] - data$xend <- ranges$x[2] - data$y <- data$yintercept - data$yend <- data$yintercept - - GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) - }, - - default_aes = aes( - colour = from_theme(colour %||% ink), - linewidth = from_theme(linewidth), - linetype = from_theme(linetype), - alpha = NA - ), - required_aes = "yintercept", - - draw_key = draw_key_path, - - rename_size = TRUE, - - check_constant_aes = FALSE -) diff --git a/R/geom-vline.R b/R/geom-vline.R deleted file mode 100644 index 12302dcf72..0000000000 --- a/R/geom-vline.R +++ /dev/null @@ -1,69 +0,0 @@ -#' @include stat-.R -NULL - -#' @export -#' @rdname geom_abline -geom_vline <- function(mapping = NULL, data = NULL, - stat = "identity", position = "identity", - ..., - xintercept, - na.rm = FALSE, - show.legend = NA, - inherit.aes = FALSE) { - - # Act like an annotation - if (!missing(xintercept)) { - # Warn if supplied mapping and/or data is going to be overwritten - if (!is.null(mapping)) { - cli::cli_warn("{.fn geom_vline}: Ignoring {.arg mapping} because {.arg xintercept} was provided.") - } - if (!is.null(data)) { - cli::cli_warn("{.fn geom_vline}: Ignoring {.arg data} because {.arg xintercept} was provided.") - } - - data <- data_frame0(xintercept = xintercept) - mapping <- aes(xintercept = xintercept) - show.legend <- FALSE - } - - layer( - data = data, - mapping = mapping, - stat = stat, - geom = GeomVline, - position = position, - show.legend = show.legend, - inherit.aes = inherit.aes, - params = list2( - na.rm = na.rm, - ... - ) - ) -} - -#' @rdname Geom -#' @format NULL -#' @usage NULL -#' @export -GeomVline <- ggproto("GeomVline", Geom, - draw_panel = function(data, panel_params, coord, lineend = "butt") { - ranges <- coord$backtransform_range(panel_params) - - data$x <- data$xintercept - data$xend <- data$xintercept - data$y <- ranges$y[1] - data$yend <- ranges$y[2] - - GeomSegment$draw_panel(unique0(data), panel_params, coord, lineend = lineend) - }, - - default_aes = GeomPath$default_aes, - - required_aes = "xintercept", - - draw_key = draw_key_vline, - - rename_size = TRUE, - - check_constant_aes = FALSE -) diff --git a/man/Geom.Rd b/man/Geom.Rd index 8185c966e8..19c911de10 100644 --- a/man/Geom.Rd +++ b/man/Geom.Rd @@ -1,15 +1,14 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/geom-.R, R/annotation-custom.R, % R/annotation-logticks.R, R/geom-polygon.R, R/geom-map.R, R/annotation-map.R, -% R/geom-raster.R, R/annotation-raster.R, R/geom-abline.R, R/geom-rect.R, -% R/geom-bar.R, R/geom-tile.R, R/geom-bin2d.R, R/geom-blank.R, +% R/geom-raster.R, R/annotation-raster.R, R/geom-abline-hline-vline.R, +% R/geom-rect.R, R/geom-bar.R, R/geom-tile.R, R/geom-bin2d.R, R/geom-blank.R, % R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, R/geom-contour.R, % R/geom-point.R, R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, % R/geom-ribbon.R, R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, -% R/geom-errorbar.R, R/geom-function.R, R/geom-hex.R, R/geom-hline.R, -% R/geom-label.R, R/geom-linerange.R, R/geom-pointrange.R, R/geom-quantile.R, -% R/geom-rug.R, R/geom-smooth.R, R/geom-spoke.R, R/geom-text.R, -% R/geom-violin.R, R/geom-vline.R +% R/geom-errorbar.R, R/geom-function.R, R/geom-hex.R, R/geom-label.R, +% R/geom-linerange.R, R/geom-pointrange.R, R/geom-quantile.R, R/geom-rug.R, +% R/geom-smooth.R, R/geom-spoke.R, R/geom-text.R, R/geom-violin.R \docType{data} \name{Geom} \alias{Geom} @@ -21,6 +20,8 @@ \alias{GeomRaster} \alias{GeomRasterAnn} \alias{GeomAbline} +\alias{GeomHline} +\alias{GeomVline} \alias{GeomRect} \alias{GeomBar} \alias{GeomTile} @@ -47,7 +48,6 @@ \alias{GeomErrorbarh} \alias{GeomFunction} \alias{GeomHex} -\alias{GeomHline} \alias{GeomLabel} \alias{GeomLinerange} \alias{GeomPointrange} @@ -57,7 +57,6 @@ \alias{GeomSpoke} \alias{GeomText} \alias{GeomViolin} -\alias{GeomVline} \title{Geoms} \description{ All \verb{geom_*()} functions (like \code{geom_point()}) return a layer that diff --git a/man/geom_abline.Rd b/man/geom_abline.Rd index 06392312b7..efec74d793 100644 --- a/man/geom_abline.Rd +++ b/man/geom_abline.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/geom-abline.R, R/geom-hline.R, R/geom-vline.R +% Please edit documentation in R/geom-abline-hline-vline.R \name{geom_abline} \alias{geom_abline} \alias{geom_hline} diff --git a/tests/testthat/_snaps/geom-hline-vline-abline.md b/tests/testthat/_snaps/geom-abline-hline-vline.md similarity index 100% rename from tests/testthat/_snaps/geom-hline-vline-abline.md rename to tests/testthat/_snaps/geom-abline-hline-vline.md diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/cartesian-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-abline-hline-vline/cartesian-lines-intersect-mid-bars.svg similarity index 100% rename from tests/testthat/_snaps/geom-hline-vline-abline/cartesian-lines-intersect-mid-bars.svg rename to tests/testthat/_snaps/geom-abline-hline-vline/cartesian-lines-intersect-mid-bars.svg diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/flipped-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-abline-hline-vline/flipped-lines-intersect-mid-bars.svg similarity index 100% rename from tests/testthat/_snaps/geom-hline-vline-abline/flipped-lines-intersect-mid-bars.svg rename to tests/testthat/_snaps/geom-abline-hline-vline/flipped-lines-intersect-mid-bars.svg diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/lines-curved-in-azequalarea.svg b/tests/testthat/_snaps/geom-abline-hline-vline/lines-curved-in-azequalarea.svg similarity index 100% rename from tests/testthat/_snaps/geom-hline-vline-abline/lines-curved-in-azequalarea.svg rename to tests/testthat/_snaps/geom-abline-hline-vline/lines-curved-in-azequalarea.svg diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg b/tests/testthat/_snaps/geom-abline-hline-vline/polar-lines-intersect-mid-bars.svg similarity index 100% rename from tests/testthat/_snaps/geom-hline-vline-abline/polar-lines-intersect-mid-bars.svg rename to tests/testthat/_snaps/geom-abline-hline-vline/polar-lines-intersect-mid-bars.svg diff --git a/tests/testthat/_snaps/geom-hline-vline-abline/straight-lines-in-mercator.svg b/tests/testthat/_snaps/geom-abline-hline-vline/straight-lines-in-mercator.svg similarity index 100% rename from tests/testthat/_snaps/geom-hline-vline-abline/straight-lines-in-mercator.svg rename to tests/testthat/_snaps/geom-abline-hline-vline/straight-lines-in-mercator.svg diff --git a/tests/testthat/test-geom-hline-vline-abline.R b/tests/testthat/test-geom-abline-hline-vline.R similarity index 100% rename from tests/testthat/test-geom-hline-vline-abline.R rename to tests/testthat/test-geom-abline-hline-vline.R From 4667ed9d4d849346631b84424187cdba9949f5c5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:17:13 +0100 Subject: [PATCH 32/78] merge `geom-bar.R` and `geom-col.R` --- DESCRIPTION | 1 - R/geom-bar.R | 12 +++++++++ R/geom-col.R | 11 -------- man/Geom.Rd | 14 +++++----- man/geom_bar.Rd | 2 +- tests/testthat/_snaps/geom-bar.md | 8 ++++++ tests/testthat/_snaps/geom-col.md | 8 ------ tests/testthat/test-geom-bar.R | 45 +++++++++++++++++++++++++++++++ tests/testthat/test-geom-col.R | 44 ------------------------------ 9 files changed, 73 insertions(+), 72 deletions(-) delete mode 100644 R/geom-col.R delete mode 100644 tests/testthat/_snaps/geom-col.md delete mode 100644 tests/testthat/test-geom-col.R diff --git a/DESCRIPTION b/DESCRIPTION index 7e4c8c5a2f..1698adb9c4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -146,7 +146,6 @@ Collate: 'geom-bin2d.R' 'geom-blank.R' 'geom-boxplot.R' - 'geom-col.R' 'geom-path.R' 'geom-contour.R' 'geom-point.R' diff --git a/R/geom-bar.R b/R/geom-bar.R index 42d4d1db2b..605713677f 100644 --- a/R/geom-bar.R +++ b/R/geom-bar.R @@ -40,6 +40,14 @@ GeomBar <- ggproto( rename_size = FALSE ) +#' @rdname Geom +#' @format NULL +#' @usage NULL +#' @export +#' @include geom-rect.R +# TODO: deprecate this +GeomCol <- ggproto("GeomCol", GeomBar) + #' Bar charts #' #' There are two types of bar charts: `geom_bar()` and `geom_col()`. @@ -140,3 +148,7 @@ geom_bar <- make_constructor( GeomBar, stat = "count", position = "stack", just = 0.5 ) + +#' @export +#' @rdname geom_bar +geom_col <- make_constructor(GeomCol, position = "stack", just = 0.5) diff --git a/R/geom-col.R b/R/geom-col.R deleted file mode 100644 index d5aa92cfb7..0000000000 --- a/R/geom-col.R +++ /dev/null @@ -1,11 +0,0 @@ -#' @rdname Geom -#' @format NULL -#' @usage NULL -#' @export -#' @include geom-rect.R -# TODO: deprecate this -GeomCol <- ggproto("GeomCol", GeomBar) - -#' @export -#' @rdname geom_bar -geom_col <- make_constructor(GeomCol, position = "stack", just = 0.5) diff --git a/man/Geom.Rd b/man/Geom.Rd index 19c911de10..1542904a0b 100644 --- a/man/Geom.Rd +++ b/man/Geom.Rd @@ -3,12 +3,12 @@ % R/annotation-logticks.R, R/geom-polygon.R, R/geom-map.R, R/annotation-map.R, % R/geom-raster.R, R/annotation-raster.R, R/geom-abline-hline-vline.R, % R/geom-rect.R, R/geom-bar.R, R/geom-tile.R, R/geom-bin2d.R, R/geom-blank.R, -% R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, R/geom-contour.R, -% R/geom-point.R, R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, -% R/geom-ribbon.R, R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, -% R/geom-errorbar.R, R/geom-function.R, R/geom-hex.R, R/geom-label.R, -% R/geom-linerange.R, R/geom-pointrange.R, R/geom-quantile.R, R/geom-rug.R, -% R/geom-smooth.R, R/geom-spoke.R, R/geom-text.R, R/geom-violin.R +% R/geom-boxplot.R, R/geom-path.R, R/geom-contour.R, R/geom-point.R, +% R/geom-crossbar.R, R/geom-segment.R, R/geom-curve.R, R/geom-ribbon.R, +% R/geom-density.R, R/geom-density2d.R, R/geom-dotplot.R, R/geom-errorbar.R, +% R/geom-function.R, R/geom-hex.R, R/geom-label.R, R/geom-linerange.R, +% R/geom-pointrange.R, R/geom-quantile.R, R/geom-rug.R, R/geom-smooth.R, +% R/geom-spoke.R, R/geom-text.R, R/geom-violin.R \docType{data} \name{Geom} \alias{Geom} @@ -24,11 +24,11 @@ \alias{GeomVline} \alias{GeomRect} \alias{GeomBar} +\alias{GeomCol} \alias{GeomTile} \alias{GeomBin2d} \alias{GeomBlank} \alias{GeomBoxplot} -\alias{GeomCol} \alias{GeomPath} \alias{GeomLine} \alias{GeomStep} diff --git a/man/geom_bar.Rd b/man/geom_bar.Rd index c6573959ae..64f56d4fd5 100644 --- a/man/geom_bar.Rd +++ b/man/geom_bar.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/geom-bar.R, R/geom-col.R, R/stat-count.R +% Please edit documentation in R/geom-bar.R, R/stat-count.R \name{geom_bar} \alias{geom_bar} \alias{geom_col} diff --git a/tests/testthat/_snaps/geom-bar.md b/tests/testthat/_snaps/geom-bar.md index 0afff44c16..c72bcc3b1a 100644 --- a/tests/testthat/_snaps/geom-bar.md +++ b/tests/testthat/_snaps/geom-bar.md @@ -2,3 +2,11 @@ Removed 1 row containing missing values or values outside the scale range (`geom_bar()`). +# geom_col removes columns with parts outside the plot limits + + Removed 3 rows containing missing values or values outside the scale range (`geom_col()`). + +--- + + Removed 1 row containing missing values or values outside the scale range (`geom_col()`). + diff --git a/tests/testthat/_snaps/geom-col.md b/tests/testthat/_snaps/geom-col.md deleted file mode 100644 index 1dfce430b0..0000000000 --- a/tests/testthat/_snaps/geom-col.md +++ /dev/null @@ -1,8 +0,0 @@ -# geom_col removes columns with parts outside the plot limits - - Removed 3 rows containing missing values or values outside the scale range (`geom_col()`). - ---- - - Removed 1 row containing missing values or values outside the scale range (`geom_col()`). - diff --git a/tests/testthat/test-geom-bar.R b/tests/testthat/test-geom-bar.R index 4fb34ef4e6..237b32f8b5 100644 --- a/tests/testthat/test-geom-bar.R +++ b/tests/testthat/test-geom-bar.R @@ -46,3 +46,48 @@ test_that("geom_bar default widths considers panels", { rep(0.5, 4) ) }) + +test_that("geom_col removes columns with parts outside the plot limits", { + dat <- data_frame(x = c(1, 2, 3)) + + p <- ggplot(dat, aes(x, x)) + geom_col() + + # warnings created at render stage + expect_snapshot_warning(ggplotGrob(p + ylim(0.5, 4))) + expect_snapshot_warning(ggplotGrob(p + ylim(0, 2.5))) +}) + +test_that("geom_col works in both directions", { + dat <- data_frame(x = c("a", "b", "c"), y = c(1.2, 2.5, 3.1)) + + p <- ggplot(dat, aes(x, y)) + geom_col() + x <- get_layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(dat, aes(y, x)) + geom_col() + y <- get_layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, TRUE)[,names(x)]) +}) + +test_that("geom_col supports alignment of columns", { + dat <- data_frame(x = c("a", "b"), y = c(1.2, 2.5)) + + p <- ggplot(dat, aes(x, y)) + geom_col(just = 0.5) + y <- get_layer_data(p) + expect_equal(as.numeric(y$xmin), c(0.55, 1.55)) + expect_equal(as.numeric(y$xmax), c(1.45, 2.45)) + + p <- ggplot(dat, aes(x, y)) + geom_col(just = 1.0) + y <- get_layer_data(p) + expect_equal(as.numeric(y$xmin), c(0.1, 1.1)) + expect_equal(as.numeric(y$xmax), c(1.0, 2.0)) + + p <- ggplot(dat, aes(x, y)) + geom_col(just = 0.0) + y <- get_layer_data(p) + expect_equal(as.numeric(y$xmin), c(1.0, 2.0)) + expect_equal(as.numeric(y$xmax), c(1.9, 2.9)) +}) diff --git a/tests/testthat/test-geom-col.R b/tests/testthat/test-geom-col.R deleted file mode 100644 index 32840fbd9e..0000000000 --- a/tests/testthat/test-geom-col.R +++ /dev/null @@ -1,44 +0,0 @@ -test_that("geom_col removes columns with parts outside the plot limits", { - dat <- data_frame(x = c(1, 2, 3)) - - p <- ggplot(dat, aes(x, x)) + geom_col() - - # warnings created at render stage - expect_snapshot_warning(ggplotGrob(p + ylim(0.5, 4))) - expect_snapshot_warning(ggplotGrob(p + ylim(0, 2.5))) -}) - -test_that("geom_col works in both directions", { - dat <- data_frame(x = c("a", "b", "c"), y = c(1.2, 2.5, 3.1)) - - p <- ggplot(dat, aes(x, y)) + geom_col() - x <- get_layer_data(p) - expect_false(x$flipped_aes[1]) - - p <- ggplot(dat, aes(y, x)) + geom_col() - y <- get_layer_data(p) - expect_true(y$flipped_aes[1]) - - x$flipped_aes <- NULL - y$flipped_aes <- NULL - expect_identical(x, flip_data(y, TRUE)[,names(x)]) -}) - -test_that("geom_col supports alignment of columns", { - dat <- data_frame(x = c("a", "b"), y = c(1.2, 2.5)) - - p <- ggplot(dat, aes(x, y)) + geom_col(just = 0.5) - y <- get_layer_data(p) - expect_equal(as.numeric(y$xmin), c(0.55, 1.55)) - expect_equal(as.numeric(y$xmax), c(1.45, 2.45)) - - p <- ggplot(dat, aes(x, y)) + geom_col(just = 1.0) - y <- get_layer_data(p) - expect_equal(as.numeric(y$xmin), c(0.1, 1.1)) - expect_equal(as.numeric(y$xmax), c(1.0, 2.0)) - - p <- ggplot(dat, aes(x, y)) + geom_col(just = 0.0) - y <- get_layer_data(p) - expect_equal(as.numeric(y$xmin), c(1.0, 2.0)) - expect_equal(as.numeric(y$xmax), c(1.9, 2.9)) -}) From 5aa4e9764c115e6d0e90290e25f52d7f541112a5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:23:23 +0100 Subject: [PATCH 33/78] clarify that `geom-defaults.R` was just about updating defaults --- DESCRIPTION | 2 +- R/{geom-defaults.R => geom-update-defaults.R} | 0 man/get_geom_defaults.Rd | 2 +- man/update_defaults.Rd | 2 +- 4 files changed, 3 insertions(+), 3 deletions(-) rename R/{geom-defaults.R => geom-update-defaults.R} (100%) diff --git a/DESCRIPTION b/DESCRIPTION index 1698adb9c4..f8baa1abc4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -153,7 +153,6 @@ Collate: 'geom-crossbar.R' 'geom-segment.R' 'geom-curve.R' - 'geom-defaults.R' 'geom-ribbon.R' 'geom-density.R' 'geom-density2d.R' @@ -173,6 +172,7 @@ Collate: 'geom-smooth.R' 'geom-spoke.R' 'geom-text.R' + 'geom-update-defaults.R' 'geom-violin.R' 'ggplot2-package.R' 'grob-absolute.R' diff --git a/R/geom-defaults.R b/R/geom-update-defaults.R similarity index 100% rename from R/geom-defaults.R rename to R/geom-update-defaults.R diff --git a/man/get_geom_defaults.Rd b/man/get_geom_defaults.Rd index a39f80d720..77c7571076 100644 --- a/man/get_geom_defaults.Rd +++ b/man/get_geom_defaults.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/geom-defaults.R +% Please edit documentation in R/geom-update-defaults.R \name{get_geom_defaults} \alias{get_geom_defaults} \title{Resolve and get geom defaults} diff --git a/man/update_defaults.Rd b/man/update_defaults.Rd index 9620dde4e1..b838a99aa6 100644 --- a/man/update_defaults.Rd +++ b/man/update_defaults.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/geom-defaults.R +% Please edit documentation in R/geom-update-defaults.R \name{update_geom_defaults} \alias{update_geom_defaults} \alias{update_stat_defaults} From c9d247e8f0e1482597daddf80b64f62ec615403e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:23:57 +0100 Subject: [PATCH 34/78] move default update tests to own file --- tests/testthat/test-geom-.R | 81 ---------------------- tests/testthat/test-geom-update-defaults.R | 77 ++++++++++++++++++++ 2 files changed, 77 insertions(+), 81 deletions(-) create mode 100644 tests/testthat/test-geom-update-defaults.R diff --git a/tests/testthat/test-geom-.R b/tests/testthat/test-geom-.R index 02e0ed9710..9436770838 100644 --- a/tests/testthat/test-geom-.R +++ b/tests/testthat/test-geom-.R @@ -5,84 +5,3 @@ test_that("aesthetic checking in geom throws correct errors", { aes <- list(a = 1:4, b = letters[1:4], c = TRUE, d = 1:2, e = 1:5) expect_snapshot_error(check_aesthetics(aes, 4)) }) - -test_that("get_geom_defaults can use various sources", { - - test <- get_geom_defaults(geom_point) - expect_equal(test$colour, "black") - - test <- get_geom_defaults(geom_point(colour = "red")) - expect_equal(test$colour, "red") - - test <- get_geom_defaults("point") - expect_equal(test$colour, "black") - - test <- get_geom_defaults(GeomPoint, theme(geom = element_geom("red"))) - expect_equal(test$colour, "red") -}) - -test_that("geom defaults can be set and reset", { - l <- geom_point() - orig <- l$geom$default_aes$colour - test <- get_geom_defaults(l) - expect_equal(test$colour, "black") - - inv <- update_geom_defaults("point", list(colour = "red")) - test <- get_geom_defaults(l) - expect_equal(test$colour, "red") - expect_equal(inv$colour, orig) - - inv <- update_geom_defaults("point", NULL) - test <- get_geom_defaults(l) - expect_equal(test$colour, "black") - expect_equal(inv$colour, "red") - - inv <- update_geom_defaults("line", list(colour = "blue")) - reset <- reset_geom_defaults() - - expect_equal(reset$geom_line$colour, "blue") - expect_equal(reset$geom_point$colour, GeomPoint$default_aes$colour) - expect_equal(GeomLine$default_aes$colour, inv$colour) -}) - -test_that("updating geom aesthetic defaults preserves class and order", { - - original_defaults <- GeomPoint$default_aes - - update_geom_defaults("point", aes(color = "red")) - - updated_defaults <- GeomPoint$default_aes - - expect_s7_class(updated_defaults, class_mapping) - - intended_defaults <- original_defaults - intended_defaults[["colour"]] <- "red" - - expect_equal(updated_defaults, intended_defaults) - - update_geom_defaults("point", NULL) - -}) - - - - -test_that("updating stat aesthetic defaults preserves class and order", { - - original_defaults <- StatBin$default_aes - - update_stat_defaults("bin", aes(y = after_stat(density))) - - updated_defaults <- StatBin$default_aes - - expect_s7_class(updated_defaults, class_mapping) - - intended_defaults <- original_defaults - intended_defaults[["y"]] <- expr(after_stat(density)) - attr(intended_defaults[["y"]], ".Environment") <- attr(updated_defaults[["y"]], ".Environment") - - expect_equal(updated_defaults, intended_defaults) - - update_stat_defaults("bin", NULL) - -}) diff --git a/tests/testthat/test-geom-update-defaults.R b/tests/testthat/test-geom-update-defaults.R new file mode 100644 index 0000000000..565c46c6ec --- /dev/null +++ b/tests/testthat/test-geom-update-defaults.R @@ -0,0 +1,77 @@ +test_that("get_geom_defaults can use various sources", { + + test <- get_geom_defaults(geom_point) + expect_equal(test$colour, "black") + + test <- get_geom_defaults(geom_point(colour = "red")) + expect_equal(test$colour, "red") + + test <- get_geom_defaults("point") + expect_equal(test$colour, "black") + + test <- get_geom_defaults(GeomPoint, theme(geom = element_geom("red"))) + expect_equal(test$colour, "red") +}) + +test_that("geom defaults can be set and reset", { + l <- geom_point() + orig <- l$geom$default_aes$colour + test <- get_geom_defaults(l) + expect_equal(test$colour, "black") + + inv <- update_geom_defaults("point", list(colour = "red")) + test <- get_geom_defaults(l) + expect_equal(test$colour, "red") + expect_equal(inv$colour, orig) + + inv <- update_geom_defaults("point", NULL) + test <- get_geom_defaults(l) + expect_equal(test$colour, "black") + expect_equal(inv$colour, "red") + + inv <- update_geom_defaults("line", list(colour = "blue")) + reset <- reset_geom_defaults() + + expect_equal(reset$geom_line$colour, "blue") + expect_equal(reset$geom_point$colour, GeomPoint$default_aes$colour) + expect_equal(GeomLine$default_aes$colour, inv$colour) +}) + +test_that("updating geom aesthetic defaults preserves class and order", { + + original_defaults <- GeomPoint$default_aes + + update_geom_defaults("point", aes(color = "red")) + + updated_defaults <- GeomPoint$default_aes + + expect_s7_class(updated_defaults, class_mapping) + + intended_defaults <- original_defaults + intended_defaults[["colour"]] <- "red" + + expect_equal(updated_defaults, intended_defaults) + + update_geom_defaults("point", NULL) + +}) + +test_that("updating stat aesthetic defaults preserves class and order", { + + original_defaults <- StatBin$default_aes + + update_stat_defaults("bin", aes(y = after_stat(density))) + + updated_defaults <- StatBin$default_aes + + expect_s7_class(updated_defaults, class_mapping) + + intended_defaults <- original_defaults + intended_defaults[["y"]] <- expr(after_stat(density)) + attr(intended_defaults[["y"]], ".Environment") <- attr(updated_defaults[["y"]], ".Environment") + + expect_equal(updated_defaults, intended_defaults) + + update_stat_defaults("bin", NULL) + +}) From ea24e290ef4b6b526d6799f00b24ab9ee5656dd8 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:26:34 +0100 Subject: [PATCH 35/78] cannibalise `test-geom-rule.R` --- tests/testthat/test-geom-abline-hline-vline.R | 31 +++++++++++++++++ tests/testthat/test-geom-rule.R | 33 ------------------- 2 files changed, 31 insertions(+), 33 deletions(-) delete mode 100644 tests/testthat/test-geom-rule.R diff --git a/tests/testthat/test-geom-abline-hline-vline.R b/tests/testthat/test-geom-abline-hline-vline.R index ec8a44bac1..926ef9afdb 100644 --- a/tests/testthat/test-geom-abline-hline-vline.R +++ b/tests/testthat/test-geom-abline-hline-vline.R @@ -1,3 +1,34 @@ +df <- data_frame(x = 1:3, y = 3:1) +p <- ggplot(df, aes(x, y)) + geom_point() +p_col <- ggplot(df, aes(x, y, colour = factor(x))) + geom_point() + +test_that("setting parameters makes one row df", { + b <- p + geom_hline(yintercept = 1.5) + expect_equal(get_layer_data(b, 2)$yintercept, 1.5) + + b <- p + geom_vline(xintercept = 1.5) + expect_equal(get_layer_data(b, 2)$xintercept, 1.5) + + b <- p + geom_abline() + expect_equal(get_layer_data(b, 2)$intercept, 0) + expect_equal(get_layer_data(b, 2)$slope, 1) + + b <- p + geom_abline(slope = 0, intercept = 1) + expect_equal(get_layer_data(b, 2)$intercept, 1) + expect_equal(get_layer_data(b, 2)$slope, 0) +}) + +test_that("setting aesthetics generates one row for each input row", { + b <- p + geom_hline(aes(yintercept = 1.5)) + expect_equal(get_layer_data(b, 2)$yintercept, rep(1.5, 3)) + + b <- p + geom_vline(aes(xintercept = 1.5)) + expect_equal(get_layer_data(b, 2)$xintercept, rep(1.5, 3)) + + b <- p + geom_abline(aes(slope = 0, intercept = 1)) + expect_equal(get_layer_data(b, 2)$intercept, rep(1, 3)) + expect_equal(get_layer_data(b, 2)$slope, rep(0, 3)) +}) # Visual tests ------------------------------------------------------------ diff --git a/tests/testthat/test-geom-rule.R b/tests/testthat/test-geom-rule.R deleted file mode 100644 index 35bac24974..0000000000 --- a/tests/testthat/test-geom-rule.R +++ /dev/null @@ -1,33 +0,0 @@ -# tests for geom_vline, geom_hline & geom_abline - -df <- data_frame(x = 1:3, y = 3:1) -p <- ggplot(df, aes(x, y)) + geom_point() -p_col <- ggplot(df, aes(x, y, colour = factor(x))) + geom_point() - -test_that("setting parameters makes one row df", { - b <- p + geom_hline(yintercept = 1.5) - expect_equal(get_layer_data(b, 2)$yintercept, 1.5) - - b <- p + geom_vline(xintercept = 1.5) - expect_equal(get_layer_data(b, 2)$xintercept, 1.5) - - b <- p + geom_abline() - expect_equal(get_layer_data(b, 2)$intercept, 0) - expect_equal(get_layer_data(b, 2)$slope, 1) - - b <- p + geom_abline(slope = 0, intercept = 1) - expect_equal(get_layer_data(b, 2)$intercept, 1) - expect_equal(get_layer_data(b, 2)$slope, 0) -}) - -test_that("setting aesthetics generates one row for each input row", { - b <- p + geom_hline(aes(yintercept = 1.5)) - expect_equal(get_layer_data(b, 2)$yintercept, rep(1.5, 3)) - - b <- p + geom_vline(aes(xintercept = 1.5)) - expect_equal(get_layer_data(b, 2)$xintercept, rep(1.5, 3)) - - b <- p + geom_abline(aes(slope = 0, intercept = 1)) - expect_equal(get_layer_data(b, 2)$intercept, rep(1, 3)) - expect_equal(get_layer_data(b, 2)$slope, rep(0, 3)) -}) From b9675fb3894d6f7008b5f2618fe6681de5db4eae Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:29:53 +0100 Subject: [PATCH 36/78] align `test-save.R` --- tests/testthat/{test-ggsave.R => test-save.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-ggsave.R => test-save.R} (100%) diff --git a/tests/testthat/test-ggsave.R b/tests/testthat/test-save.R similarity index 100% rename from tests/testthat/test-ggsave.R rename to tests/testthat/test-save.R From a483fb46a7b1f629869b757adbca11e1a8006ae1 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:30:52 +0100 Subject: [PATCH 37/78] align `test-grid-utils.R` --- tests/testthat/{test-grid-utils.R => test-utilities-grid.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-grid-utils.R => test-utilities-grid.R} (100%) diff --git a/tests/testthat/test-grid-utils.R b/tests/testthat/test-utilities-grid.R similarity index 100% rename from tests/testthat/test-grid-utils.R rename to tests/testthat/test-utilities-grid.R From a59e057eeddbb286fa8050b2d86a7f2388978bad Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:52:16 +0100 Subject: [PATCH 38/78] accept snapshots moving around --- tests/testthat/_snaps/{ggsave.md => save.md} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/_snaps/{ggsave.md => save.md} (100%) diff --git a/tests/testthat/_snaps/ggsave.md b/tests/testthat/_snaps/save.md similarity index 100% rename from tests/testthat/_snaps/ggsave.md rename to tests/testthat/_snaps/save.md From 4938fd2992574161ab3787c9f4a28926da17f3e5 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 09:54:52 +0100 Subject: [PATCH 39/78] redistribute `test-guides.R` to separate files per guide --- .../guide-bins-can-remove-axis.svg | 0 .../guide-bins-can-show-arrows.svg | 0 .../guide-bins-can-show-limits.svg | 0 .../guide-bins-looks-as-it-should.svg | 0 .../guide-bins-work-horizontally.svg | 0 .../reversed-guide-bins.svg | 0 tests/testthat/_snaps/guide-colorsteps.md | 10 + ...e-bins-can-show-ticks-and-transparancy.svg | 0 ...s-sets-labels-when-limits-is-in-breaks.svg | 0 ...derstands-coinciding-limits-and-bins-2.svg | 0 ...derstands-coinciding-limits-and-bins-3.svg | 0 ...understands-coinciding-limits-and-bins.svg | 0 ...s-sets-labels-when-limits-is-in-breaks.svg | 0 ...derstands-coinciding-limits-and-bins-2.svg | 0 ...derstands-coinciding-limits-and-bins-3.svg | 0 ...understands-coinciding-limits-and-bins.svg | 0 ...teps-can-have-bins-relative-to-binsize.svg | 0 .../guide-coloursteps-can-show-limits.svg | 0 .../guide-coloursteps-looks-as-it-should.svg | 0 .../guide-custom-with-void-theme.svg | 0 .../stylised-guide-custom.svg | 0 tests/testthat/_snaps/guide-old.md | 5 + .../old-s3-guide-drawing-a-circle.svg | 0 tests/testthat/_snaps/guides.md | 15 - tests/testthat/test-guide-bins.R | 56 +++ tests/testthat/test-guide-colorsteps.R | 197 +++++++++++ tests/testthat/test-guide-custom.R | 26 ++ tests/testthat/test-guide-none.R | 18 + tests/testthat/test-guide-old.R | 63 ++++ tests/testthat/test-guides.R | 320 +----------------- 30 files changed, 388 insertions(+), 322 deletions(-) rename tests/testthat/_snaps/{guides => guide-bins}/guide-bins-can-remove-axis.svg (100%) rename tests/testthat/_snaps/{guides => guide-bins}/guide-bins-can-show-arrows.svg (100%) rename tests/testthat/_snaps/{guides => guide-bins}/guide-bins-can-show-limits.svg (100%) rename tests/testthat/_snaps/{guides => guide-bins}/guide-bins-looks-as-it-should.svg (100%) rename tests/testthat/_snaps/{guides => guide-bins}/guide-bins-work-horizontally.svg (100%) rename tests/testthat/_snaps/{guides => guide-bins}/reversed-guide-bins.svg (100%) create mode 100644 tests/testthat/_snaps/guide-colorsteps.md rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-bins-can-show-ticks-and-transparancy.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-bins-sets-labels-when-limits-is-in-breaks.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-bins-understands-coinciding-limits-and-bins-2.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-bins-understands-coinciding-limits-and-bins-3.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-bins-understands-coinciding-limits-and-bins.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-colorsteps-understands-coinciding-limits-and-bins.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-coloursteps-can-have-bins-relative-to-binsize.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-coloursteps-can-show-limits.svg (100%) rename tests/testthat/_snaps/{guides => guide-colorsteps}/guide-coloursteps-looks-as-it-should.svg (100%) rename tests/testthat/_snaps/{guides => guide-custom}/guide-custom-with-void-theme.svg (100%) rename tests/testthat/_snaps/{guides => guide-custom}/stylised-guide-custom.svg (100%) create mode 100644 tests/testthat/_snaps/guide-old.md rename tests/testthat/_snaps/{guides => guide-old}/old-s3-guide-drawing-a-circle.svg (100%) create mode 100644 tests/testthat/test-guide-bins.R create mode 100644 tests/testthat/test-guide-colorsteps.R create mode 100644 tests/testthat/test-guide-custom.R create mode 100644 tests/testthat/test-guide-none.R create mode 100644 tests/testthat/test-guide-old.R diff --git a/tests/testthat/_snaps/guides/guide-bins-can-remove-axis.svg b/tests/testthat/_snaps/guide-bins/guide-bins-can-remove-axis.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-can-remove-axis.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-can-remove-axis.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-can-show-arrows.svg b/tests/testthat/_snaps/guide-bins/guide-bins-can-show-arrows.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-can-show-arrows.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-can-show-arrows.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-can-show-limits.svg b/tests/testthat/_snaps/guide-bins/guide-bins-can-show-limits.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-can-show-limits.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-can-show-limits.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-looks-as-it-should.svg b/tests/testthat/_snaps/guide-bins/guide-bins-looks-as-it-should.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-looks-as-it-should.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-looks-as-it-should.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-work-horizontally.svg b/tests/testthat/_snaps/guide-bins/guide-bins-work-horizontally.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-work-horizontally.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-work-horizontally.svg diff --git a/tests/testthat/_snaps/guides/reversed-guide-bins.svg b/tests/testthat/_snaps/guide-bins/reversed-guide-bins.svg similarity index 100% rename from tests/testthat/_snaps/guides/reversed-guide-bins.svg rename to tests/testthat/_snaps/guide-bins/reversed-guide-bins.svg diff --git a/tests/testthat/_snaps/guide-colorsteps.md b/tests/testthat/_snaps/guide-colorsteps.md new file mode 100644 index 0000000000..f7aadf6b09 --- /dev/null +++ b/tests/testthat/_snaps/guide-colorsteps.md @@ -0,0 +1,10 @@ +# binning scales understand the different combinations of limits, breaks, labels, and show.limits + + `show.limits` is ignored when `labels` are given as a character vector. + i Either add the limits to `breaks` or provide a function for `labels`. + +--- + + `show.limits` is ignored when `labels` are given as a character vector. + i Either add the limits to `breaks` or provide a function for `labels`. + diff --git a/tests/testthat/_snaps/guides/guide-bins-can-show-ticks-and-transparancy.svg b/tests/testthat/_snaps/guide-colorsteps/guide-bins-can-show-ticks-and-transparancy.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-can-show-ticks-and-transparancy.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-bins-can-show-ticks-and-transparancy.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-sets-labels-when-limits-is-in-breaks.svg b/tests/testthat/_snaps/guide-colorsteps/guide-bins-sets-labels-when-limits-is-in-breaks.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-sets-labels-when-limits-is-in-breaks.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-bins-sets-labels-when-limits-is-in-breaks.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-2.svg b/tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-2.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-2.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-2.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-3.svg b/tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-3.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins-3.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-3.svg diff --git a/tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins.svg b/tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-bins-understands-coinciding-limits-and-bins.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins.svg diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg b/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg b/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg b/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg diff --git a/tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins.svg b/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-colorsteps-understands-coinciding-limits-and-bins.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins.svg diff --git a/tests/testthat/_snaps/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg b/tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-have-bins-relative-to-binsize.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-coloursteps-can-have-bins-relative-to-binsize.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-have-bins-relative-to-binsize.svg diff --git a/tests/testthat/_snaps/guides/guide-coloursteps-can-show-limits.svg b/tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-show-limits.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-coloursteps-can-show-limits.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-show-limits.svg diff --git a/tests/testthat/_snaps/guides/guide-coloursteps-looks-as-it-should.svg b/tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-looks-as-it-should.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-coloursteps-looks-as-it-should.svg rename to tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-looks-as-it-should.svg diff --git a/tests/testthat/_snaps/guides/guide-custom-with-void-theme.svg b/tests/testthat/_snaps/guide-custom/guide-custom-with-void-theme.svg similarity index 100% rename from tests/testthat/_snaps/guides/guide-custom-with-void-theme.svg rename to tests/testthat/_snaps/guide-custom/guide-custom-with-void-theme.svg diff --git a/tests/testthat/_snaps/guides/stylised-guide-custom.svg b/tests/testthat/_snaps/guide-custom/stylised-guide-custom.svg similarity index 100% rename from tests/testthat/_snaps/guides/stylised-guide-custom.svg rename to tests/testthat/_snaps/guide-custom/stylised-guide-custom.svg diff --git a/tests/testthat/_snaps/guide-old.md b/tests/testthat/_snaps/guide-old.md new file mode 100644 index 0000000000..c5bdbfd541 --- /dev/null +++ b/tests/testthat/_snaps/guide-old.md @@ -0,0 +1,5 @@ +# old S3 guides can be implemented + + The S3 guide system was deprecated in ggplot2 3.5.0. + i It has been replaced by a ggproto system that can be extended. + diff --git a/tests/testthat/_snaps/guides/old-s3-guide-drawing-a-circle.svg b/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg similarity index 100% rename from tests/testthat/_snaps/guides/old-s3-guide-drawing-a-circle.svg rename to tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg diff --git a/tests/testthat/_snaps/guides.md b/tests/testthat/_snaps/guides.md index a47fba746b..c4fd49859c 100644 --- a/tests/testthat/_snaps/guides.md +++ b/tests/testthat/_snaps/guides.md @@ -53,16 +53,6 @@ Error in `get_guide_data()`: ! `panel` must be a whole number, not the string "a". -# binning scales understand the different combinations of limits, breaks, labels, and show.limits - - `show.limits` is ignored when `labels` are given as a character vector. - i Either add the limits to `breaks` or provide a function for `labels`. - ---- - - `show.limits` is ignored when `labels` are given as a character vector. - i Either add the limits to `breaks` or provide a function for `labels`. - # guides() warns if unnamed guides are provided Guides provided to `guides()` must be named. @@ -73,8 +63,3 @@ Guides provided to `guides()` must be named. i The 2nd guide is unnamed. -# old S3 guides can be implemented - - The S3 guide system was deprecated in ggplot2 3.5.0. - i It has been replaced by a ggproto system that can be extended. - diff --git a/tests/testthat/test-guide-bins.R b/tests/testthat/test-guide-bins.R new file mode 100644 index 0000000000..1bccc804a8 --- /dev/null +++ b/tests/testthat/test-guide-bins.R @@ -0,0 +1,56 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +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)) + + p <- ggplot(df, aes(x, y, size = x)) + + geom_point() + + scale_size_binned() + + expect_doppelganger("guide_bins looks as it should", p) + expect_doppelganger( + "guide_bins can show limits", + p + guides(size = guide_bins(show.limits = TRUE)) + ) + expect_doppelganger( + "guide_bins can show arrows", + p + + guides(size = guide_bins()) + + theme_test() + + theme( + legend.axis.line = element_line( + linewidth = 0.5 / .pt, + arrow = arrow(length = unit(1.5, "mm"), ends = "both") + ) + ) + ) + expect_doppelganger( + "guide_bins can remove axis", + p + + guides(size = guide_bins()) + + theme_test() + + theme( + legend.axis.line = element_blank() + ) + ) + expect_doppelganger( + "guide_bins work horizontally", + p + guides(size = guide_bins(direction = "horizontal")) + ) +}) diff --git a/tests/testthat/test-guide-colorsteps.R b/tests/testthat/test-guide-colorsteps.R new file mode 100644 index 0000000000..6e0bf8beee --- /dev/null +++ b/tests/testthat/test-guide-colorsteps.R @@ -0,0 +1,197 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("guide_coloursteps and guide_bins return ordered breaks", { + scale <- scale_colour_viridis_c(breaks = c(2, 3, 1)) + scale$train(c(0, 4)) + + # Coloursteps guide is increasing order + g <- guide_colorsteps() + key <- g$train(scale = scale, aesthetic = "colour")$key + expect_true(all(diff(key$.value) > 0)) + + # Bins guide is increasing order + g <- guide_bins() + key <- g$train(scale = scale, aesthetics = "colour")$key + expect_true(all(diff(key$.value) > 0)) + + # Out of bound breaks are removed + scale <- scale_colour_viridis_c(breaks = c(10, 20, 30, 40, 50), na.value = "grey50") + scale$train(c(15, 45)) + + g <- guide_colorsteps() + key <- g$train(scale = scale, aesthetic = "colour")$key + expect_equal(sum(key$colour == "grey50"), 0) +}) + +test_that("guide_coloursteps can parse (un)even steps from discrete scales", { + + val <- cut(1:10, breaks = c(0, 3, 5, 10), include.lowest = TRUE) + scale <- scale_colour_viridis_d() + scale$train(val) + + g <- guide_coloursteps(even.steps = TRUE) + decor <- g$train(scale = scale, aesthetics = "colour")$decor + expect_equal(decor$max - decor$min, rep(1/3, 3)) + + g <- guide_coloursteps(even.steps = FALSE) + decor <- g$train(scale = scale, aesthetics = "colour")$decor + expect_equal(decor$max - decor$min, c(0.3, 0.2, 0.5)) +}) + +test_that("bins can be parsed by guides for all scale types", { + + breaks <- c(90, 100, 200, 300) + limits <- c(0, 1000) + + sc <- scale_colour_continuous(breaks = breaks) + sc$train(limits) + + expect_equal(parse_binned_breaks(sc)$breaks, breaks) + + sc <- scale_colour_binned(breaks = breaks) + sc$train(limits) + + expect_equal(parse_binned_breaks(sc)$breaks, breaks) + + # Note: discrete binned breaks treats outer breaks as limits + cut <- cut(c(0, 95, 150, 250, 1000), breaks = breaks) + + sc <- scale_colour_discrete() + sc$train(cut) + + parsed <- parse_binned_breaks(sc) + expect_equal( + sort(c(parsed$limits, parsed$breaks)), + breaks + ) +}) + +test_that("binned breaks can have hardcoded labels when oob", { + + sc <- scale_colour_steps(breaks = 1:3, labels = as.character(1:3)) + sc$train(c(1, 2)) + + g <- guide_bins() + key <- g$train(scale = sc, aesthetic = "colour")$key + expect_equal(key$.label, c("1", "2")) + + g <- guide_coloursteps() + key <- g$train(scale = sc, aesthetic = "colour")$key + expect_equal(key$.label, c("1", "2")) +}) + + +test_that("coloursteps guide can be styled correctly", { + df <- data_frame(x = c(1, 2, 4), y = c(6, 5, 7)) + + p <- ggplot(df, aes(x, y, colour = x)) + + geom_point() + + scale_colour_binned(breaks = c(1.5, 2, 3)) + + expect_doppelganger("guide_coloursteps looks as it should", p) + expect_doppelganger( + "guide_coloursteps can show limits", + p + guides(colour = guide_coloursteps(show.limits = TRUE)) + ) + expect_doppelganger( + "guide_coloursteps can have bins relative to binsize", + p + guides(colour = guide_coloursteps(even.steps = FALSE)) + ) + expect_doppelganger( + "guide_bins can show ticks and transparancy", + p + + guides( + colour = guide_coloursteps( + alpha = 0.75, + theme = theme( + legend.ticks = element_line(linewidth = 0.5 / .pt, colour = "white") + ) + ) + ) + ) +}) + +test_that("binning scales understand the different combinations of limits, breaks, labels, and show.limits", { + p <- ggplot(mpg, aes(cty, hwy, color = year)) + + geom_point() + + expect_doppelganger( + "guide_bins understands coinciding limits and bins", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + guide = 'bins' + ) + ) + expect_doppelganger( + "guide_bins understands coinciding limits and bins 2", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(2000, 2002, 2004, 2006, 2008), + guide = 'bins' + ) + ) + expect_doppelganger( + "guide_bins understands coinciding limits and bins 3", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + guide = 'bins', + show.limits = TRUE + ) + ) + expect_doppelganger( + "guide_bins sets labels when limits is in breaks", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + labels = 1:5, + guide = 'bins' + ) + ) + expect_snapshot_warning(ggplotGrob( + p + scale_color_binned(labels = 1:4, show.limits = TRUE, guide = "bins") + )) + + expect_doppelganger( + "guide_colorsteps understands coinciding limits and bins", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006) + ) + ) + expect_doppelganger( + "guide_colorsteps understands coinciding limits and bins 2", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(2000, 2002, 2004, 2006, 2008) + ) + ) + expect_doppelganger( + "guide_colorsteps understands coinciding limits and bins 3", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + show.limits = TRUE + ) + ) + expect_doppelganger( + "guide_colorsteps sets labels when limits is in breaks", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + labels = 1:5 + ) + ) + expect_snapshot_warning(ggplotGrob( + p + scale_color_binned(labels = 1:4, show.limits = TRUE) + )) +}) diff --git a/tests/testthat/test-guide-custom.R b/tests/testthat/test-guide-custom.R new file mode 100644 index 0000000000..791f16d415 --- /dev/null +++ b/tests/testthat/test-guide-custom.R @@ -0,0 +1,26 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("guide_custom can be drawn and styled", { + p <- ggplot() + + guides( + custom = guide_custom( + circleGrob(r = unit(1, "cm")), + title = "custom guide" + ) + ) + + expect_doppelganger( + "stylised guide_custom", + p + + theme( + legend.background = element_rect(fill = "grey50"), + legend.title.position = "left", + legend.title = element_text(angle = 90, hjust = 0.5) + ) + ) + + expect_doppelganger( + "guide_custom with void theme", + p + theme_void() + ) +}) diff --git a/tests/testthat/test-guide-none.R b/tests/testthat/test-guide-none.R new file mode 100644 index 0000000000..bbc110f916 --- /dev/null +++ b/tests/testthat/test-guide-none.R @@ -0,0 +1,18 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("guide_none() can be used in non-position scales", { + p <- ggplot(mpg, aes(cty, hwy, colour = class)) + + geom_point() + + scale_color_discrete(guide = guide_none()) + + built <- ggplot_build(p) + plot <- built@plot + guides <- guides_list(plot@guides) + guides <- guides$build( + plot@scales, + plot@layers, + plot@labels + ) + + expect_length(guides$guides, 0) +}) diff --git a/tests/testthat/test-guide-old.R b/tests/testthat/test-guide-old.R new file mode 100644 index 0000000000..7fb5386793 --- /dev/null +++ b/tests/testthat/test-guide-old.R @@ -0,0 +1,63 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("old S3 guides can be implemented", { + my_env <- env() + my_env$guide_circle <- function() { + structure( + list(available_aes = c("x", "y"), position = "bottom"), + class = c("guide", "circle") + ) + } + + registerS3method( + "guide_train", + "circle", + function(guide, ...) guide, + envir = my_env + ) + registerS3method( + "guide_transform", + "circle", + function(guide, ...) guide, + envir = my_env + ) + registerS3method( + "guide_merge", + "circle", + function(guide, ...) guide, + envir = my_env + ) + registerS3method( + "guide_geom", + "circle", + function(guide, ...) guide, + envir = my_env + ) + registerS3method( + "guide_gengrob", + "circle", + function(guide, ...) { + absoluteGrob( + gList(circleGrob()), + height = unit(1, "cm"), + width = unit(1, "cm") + ) + }, + envir = my_env + ) + + 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() + + my_guides + ) + ) +}) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index ae1bfe85bd..516e6a79e1 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -1,22 +1,5 @@ skip_on_cran() # This test suite is long-running (on cran) and is skipped -test_that("guide_none() can be used in non-position scales", { - p <- ggplot(mpg, aes(cty, hwy, colour = class)) + - geom_point() + - scale_color_discrete(guide = guide_none()) - - built <- ggplot_build(p) - plot <- built@plot - guides <- guides_list(plot@guides) - guides <- guides$build( - plot@scales, - plot@layers, - plot@labels - ) - - expect_length(guides$guides, 0) -}) - test_that("guide specifications are properly checked", { expect_snapshot_error(validate_guide("test")) expect_snapshot_error(validate_guide(1)) @@ -51,44 +34,6 @@ test_that("guide specifications are properly checked", { expect_snapshot_error(ggplotGrob(p)) }) -test_that("guide_coloursteps and guide_bins return ordered breaks", { - scale <- scale_colour_viridis_c(breaks = c(2, 3, 1)) - scale$train(c(0, 4)) - - # Coloursteps guide is increasing order - g <- guide_colorsteps() - key <- g$train(scale = scale, aesthetic = "colour")$key - expect_true(all(diff(key$.value) > 0)) - - # Bins guide is increasing order - g <- guide_bins() - key <- g$train(scale = scale, aesthetics = "colour")$key - expect_true(all(diff(key$.value) > 0)) - - # Out of bound breaks are removed - scale <- scale_colour_viridis_c(breaks = c(10, 20, 30, 40, 50), na.value = "grey50") - scale$train(c(15, 45)) - - g <- guide_colorsteps() - key <- g$train(scale = scale, aesthetic = "colour")$key - expect_equal(sum(key$colour == "grey50"), 0) -}) - -test_that("guide_coloursteps can parse (un)even steps from discrete scales", { - - val <- cut(1:10, breaks = c(0, 3, 5, 10), include.lowest = TRUE) - scale <- scale_colour_viridis_d() - scale$train(val) - - g <- guide_coloursteps(even.steps = TRUE) - decor <- g$train(scale = scale, aesthetics = "colour")$decor - expect_equal(decor$max - decor$min, rep(1/3, 3)) - - g <- guide_coloursteps(even.steps = FALSE) - decor <- g$train(scale = scale, aesthetics = "colour")$decor - expect_equal(decor$max - decor$min, c(0.3, 0.2, 0.5)) -}) - test_that("get_guide_data retrieves keys appropriately", { p <- ggplot(mtcars, aes(mpg, disp, colour = drat, size = drat, fill = wt)) + @@ -162,46 +107,23 @@ test_that("empty guides are dropped", { expect_true(is_zero(guides)) }) -test_that("bins can be parsed by guides for all scale types", { - - breaks <- c(90, 100, 200, 300) - limits <- c(0, 1000) - - sc <- scale_colour_continuous(breaks = breaks) - sc$train(limits) - - expect_equal(parse_binned_breaks(sc)$breaks, breaks) - - sc <- scale_colour_binned(breaks = breaks) - sc$train(limits) - - expect_equal(parse_binned_breaks(sc)$breaks, breaks) - - # Note: discrete binned breaks treats outer breaks as limits - cut <- cut(c(0, 95, 150, 250, 1000), breaks = breaks) - - sc <- scale_colour_discrete() - sc$train(cut) - - parsed <- parse_binned_breaks(sc) - expect_equal( - sort(c(parsed$limits, parsed$breaks)), - breaks - ) +test_that("guides() warns if unnamed guides are provided", { + expect_snapshot_warning(guides("axis")) + expect_snapshot_warning(guides(x = "axis", "axis")) + expect_null(guides()) }) -test_that("binned breaks can have hardcoded labels when oob", { - - sc <- scale_colour_steps(breaks = 1:3, labels = as.character(1:3)) - sc$train(c(1, 2)) +test_that("a warning is generated when guides( = FALSE) is specified", { + df <- data_frame(x = c(1, 2, 4), + y = c(6, 5, 7)) - g <- guide_bins() - key <- g$train(scale = sc, aesthetic = "colour")$key - expect_equal(key$.label, c("1", "2")) + # warn on guide( = FALSE) + lifecycle::expect_deprecated(g <- guides(colour = FALSE)) + expect_equal(g$guides[["colour"]], "none") - g <- guide_coloursteps() - key <- g$train(scale = sc, aesthetic = "colour")$key - expect_equal(key$.label, c("1", "2")) + # warn on scale_*(guide = FALSE) + p <- ggplot(df, aes(x, y, colour = x)) + scale_colour_continuous(guide = FALSE) + lifecycle::expect_deprecated(ggplot_build(p)) }) # Visual tests ------------------------------------------------------------ @@ -410,219 +332,3 @@ 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)) - - p <- ggplot(df, aes(x, y, size = x)) + - geom_point() + - scale_size_binned() - - expect_doppelganger("guide_bins looks as it should", p) - expect_doppelganger("guide_bins can show limits", - p + guides(size = guide_bins(show.limits = TRUE)) - ) - expect_doppelganger("guide_bins can show arrows", - p + guides(size = guide_bins()) + - theme_test() + - theme( - legend.axis.line = element_line( - linewidth = 0.5 / .pt, - arrow = arrow(length = unit(1.5, "mm"), ends = "both") - ) - ) - ) - expect_doppelganger("guide_bins can remove axis", - p + guides(size = guide_bins()) + - theme_test() + - theme( - legend.axis.line = element_blank() - ) - ) - expect_doppelganger("guide_bins work horizontally", - p + guides(size = guide_bins(direction = "horizontal")) - ) -}) - -test_that("coloursteps guide can be styled correctly", { - df <- data_frame(x = c(1, 2, 4), - y = c(6, 5, 7)) - - p <- ggplot(df, aes(x, y, colour = x)) + - geom_point() + - scale_colour_binned(breaks = c(1.5, 2, 3)) - - expect_doppelganger("guide_coloursteps looks as it should", p) - expect_doppelganger("guide_coloursteps can show limits", - p + guides(colour = guide_coloursteps(show.limits = TRUE)) - ) - expect_doppelganger("guide_coloursteps can have bins relative to binsize", - p + guides(colour = guide_coloursteps(even.steps = FALSE)) - ) - expect_doppelganger("guide_bins can show ticks and transparancy", - p + guides(colour = guide_coloursteps( - alpha = 0.75, - theme = theme(legend.ticks = element_line(linewidth = 0.5 / .pt, colour = "white")) - )) - ) -}) - -test_that("binning scales understand the different combinations of limits, breaks, labels, and show.limits", { - p <- ggplot(mpg, aes(cty, hwy, color = year)) + - geom_point() - - expect_doppelganger("guide_bins understands coinciding limits and bins", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - guide = 'bins') - ) - expect_doppelganger("guide_bins understands coinciding limits and bins 2", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(2000, 2002, 2004, 2006, 2008), - guide = 'bins') - ) - expect_doppelganger("guide_bins understands coinciding limits and bins 3", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - guide = 'bins', show.limits = TRUE) - ) - expect_doppelganger("guide_bins sets labels when limits is in breaks", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - labels = 1:5, guide = 'bins') - ) - expect_snapshot_warning(ggplotGrob(p + scale_color_binned(labels = 1:4, show.limits = TRUE, guide = "bins"))) - - expect_doppelganger("guide_colorsteps understands coinciding limits and bins", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006)) - ) - expect_doppelganger("guide_colorsteps understands coinciding limits and bins 2", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(2000, 2002, 2004, 2006, 2008)) - ) - expect_doppelganger("guide_colorsteps understands coinciding limits and bins 3", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - show.limits = TRUE) - ) - expect_doppelganger("guide_colorsteps sets labels when limits is in breaks", - p + scale_color_binned(limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - labels = 1:5) - ) - expect_snapshot_warning(ggplotGrob(p + scale_color_binned(labels = 1:4, show.limits = TRUE))) -}) - -test_that("a warning is generated when guides( = FALSE) is specified", { - df <- data_frame(x = c(1, 2, 4), - y = c(6, 5, 7)) - - # warn on guide( = FALSE) - lifecycle::expect_deprecated(g <- guides(colour = FALSE)) - expect_equal(g$guides[["colour"]], "none") - - # warn on scale_*(guide = FALSE) - p <- ggplot(df, aes(x, y, colour = x)) + scale_colour_continuous(guide = FALSE) - lifecycle::expect_deprecated(ggplot_build(p)) -}) - -test_that("guides() warns if unnamed guides are provided", { - expect_snapshot_warning(guides("axis")) - expect_snapshot_warning(guides(x = "axis", "axis")) - expect_null(guides()) -}) - -test_that("old S3 guides can be implemented", { - - my_env <- env() - my_env$guide_circle <- function() { - structure( - list(available_aes = c("x", "y"), position = "bottom"), - class = c("guide", "circle") - ) - } - - registerS3method( - "guide_train", "circle", - function(guide, ...) guide, - envir = my_env - ) - registerS3method( - "guide_transform", "circle", - function(guide, ...) guide, - envir = my_env - ) - registerS3method( - "guide_merge", "circle", - function(guide, ...) guide, - envir = my_env - ) - registerS3method( - "guide_geom", "circle", - function(guide, ...) guide, - envir = my_env - ) - registerS3method( - "guide_gengrob", "circle", - function(guide, ...) { - absoluteGrob( - gList(circleGrob()), - height = unit(1, "cm"), width = unit(1, "cm") - ) - }, - envir = my_env - ) - - 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() + - my_guides - ) - ) -}) - -test_that("guide_custom can be drawn and styled", { - - p <- ggplot() + guides(custom = guide_custom( - circleGrob(r = unit(1, "cm")), - title = "custom guide" - )) - - expect_doppelganger( - "stylised guide_custom", - p + theme(legend.background = element_rect(fill = "grey50"), - legend.title.position = "left", - legend.title = element_text(angle = 90, hjust = 0.5)) - ) - - expect_doppelganger( - "guide_custom with void theme", - p + theme_void() - ) -}) From e27beac9a4a6efa022bfb69a871a3d5419cb6897 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:01:12 +0100 Subject: [PATCH 40/78] cannibalise `test-labellers.R` --- tests/testthat/_snaps/facet-labeller.md | 12 +++++++ tests/testthat/_snaps/labellers.md | 12 ------- tests/testthat/test-facet-labeller.R | 42 +++++++++++++++++++++++++ tests/testthat/test-labellers.R | 42 ------------------------- 4 files changed, 54 insertions(+), 54 deletions(-) delete mode 100644 tests/testthat/_snaps/labellers.md delete mode 100644 tests/testthat/test-labellers.R diff --git a/tests/testthat/_snaps/facet-labeller.md b/tests/testthat/_snaps/facet-labeller.md index 6130705bea..668fe21190 100644 --- a/tests/testthat/_snaps/facet-labeller.md +++ b/tests/testthat/_snaps/facet-labeller.md @@ -14,3 +14,15 @@ Error in `labeller()`: ! Conflict between `.cols` and `cyl`. +# resolve_labeller() provide meaningful errors + + Supply one of `rows` or `cols`. + +--- + + Cannot supply both `rows` and `cols` to `facet_wrap()`. + +# labeller function catches overlap in names + + Conflict between `.rows` and `vs`. + diff --git a/tests/testthat/_snaps/labellers.md b/tests/testthat/_snaps/labellers.md deleted file mode 100644 index 8887717d9d..0000000000 --- a/tests/testthat/_snaps/labellers.md +++ /dev/null @@ -1,12 +0,0 @@ -# resolve_labeller() provide meaningful errors - - Supply one of `rows` or `cols`. - ---- - - Cannot supply both `rows` and `cols` to `facet_wrap()`. - -# labeller function catches overlap in names - - Conflict between `.rows` and `vs`. - diff --git a/tests/testthat/test-facet-labeller.R b/tests/testthat/test-facet-labeller.R index f755e93aa8..74eb9e4214 100644 --- a/tests/testthat/test-facet-labeller.R +++ b/tests/testthat/test-facet-labeller.R @@ -138,6 +138,48 @@ test_that("old school labellers are deprecated", { lifecycle::expect_defunct(facet_grid(~cyl, labeller = my_labeller)) }) +test_that("facets convert labeller to function", { + f <- facet_grid(foo ~ bar, labeller = "label_both") + expect_type(f$params$labeller, "closure") + + f <- facet_wrap(foo ~ bar, labeller = "label_value") + expect_type(f$params$labeller, "closure") +}) + +test_that("label_bquote has access to functions in the calling environment", { + labels <- data.frame(lab = letters[1:2]) + attr(labels, "facet") <- "wrap" + labeller <- label_bquote(rows = .(paste0(lab, ":"))) + labels_calc <- labeller(labels) + expect_equal(labels_calc[[1]][[1]], "a:") +}) + +test_that("resolve_labeller() provide meaningful errors", { + expect_snapshot_error(resolve_labeller(NULL, NULL)) + expect_snapshot_error(resolve_labeller(prod, sum, structure(1:4, facet = "wrap"))) +}) + +test_that("labeller function catches overlap in names", { + p <- ggplot(mtcars, aes(x = mpg, y = wt)) + + geom_point() + + facet_grid( + vs + am ~ gear, + labeller = labeller(.rows = label_both, vs = label_value) + ) + expect_snapshot_error(ggplotGrob(p)) +}) + +test_that("labeller handles badly specified labels from lookup tables", { + df <- data_frame0(am = c(0, 1)) + labs <- labeller(am = c("0" = "Automatic", "11" = "Manual")) + expect_equal(labs(df), list(am = c("Automatic", "1"))) +}) + +test_that("labeller allows cherry-pick some labels", { + df <- data_frame0(am = c(0, 1)) + labs <- labeller(am = c("0" = "Automatic")) + expect_equal(labs(df), list(am = c("Automatic", "1"))) +}) # Visual test ------------------------------------------------------------- diff --git a/tests/testthat/test-labellers.R b/tests/testthat/test-labellers.R deleted file mode 100644 index 7cc6ad0df3..0000000000 --- a/tests/testthat/test-labellers.R +++ /dev/null @@ -1,42 +0,0 @@ -test_that("facets convert labeller to function", { - f <- facet_grid(foo ~ bar, labeller = "label_both") - expect_type(f$params$labeller, "closure") - - f <- facet_wrap(foo ~ bar, labeller = "label_value") - expect_type(f$params$labeller, "closure") -}) - -test_that("label_bquote has access to functions in the calling environment", { - labels <- data.frame(lab = letters[1:2]) - attr(labels, "facet") <- "wrap" - labeller <- label_bquote(rows = .(paste0(lab, ":"))) - labels_calc <- labeller(labels) - expect_equal(labels_calc[[1]][[1]], "a:") -}) - -test_that("resolve_labeller() provide meaningful errors", { - expect_snapshot_error(resolve_labeller(NULL, NULL)) - expect_snapshot_error(resolve_labeller(prod, sum, structure(1:4, facet = "wrap"))) -}) - -test_that("labeller function catches overlap in names", { - p <- ggplot(mtcars, aes(x = mpg, y = wt)) + - geom_point() + - facet_grid( - vs + am ~ gear, - labeller = labeller(.rows = label_both, vs = label_value) - ) - expect_snapshot_error(ggplotGrob(p)) -}) - -test_that("labeller handles badly specified labels from lookup tables", { - df <- data_frame0(am = c(0, 1)) - labs <- labeller(am = c("0" = "Automatic", "11" = "Manual")) - expect_equal(labs(df), list(am = c("Automatic", "1"))) -}) - -test_that("labeller allows cherry-pick some labels", { - df <- data_frame0(am = c(0, 1)) - labs <- labeller(am = c("0" = "Automatic")) - expect_equal(labs(df), list(am = c("Automatic", "1"))) -}) From a3cdee234d12274043b7b33ce3bab044e26e0e2b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:05:06 +0100 Subject: [PATCH 41/78] align `test-munch.R` --- tests/testthat/{test-munch.R => test-coord-munch.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-munch.R => test-coord-munch.R} (100%) diff --git a/tests/testthat/test-munch.R b/tests/testthat/test-coord-munch.R similarity index 100% rename from tests/testthat/test-munch.R rename to tests/testthat/test-coord-munch.R From a16fba38cde84c5ae78b4af469c1c4a04b8b4aee Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:06:40 +0100 Subject: [PATCH 42/78] align `test-patterns.R` --- tests/testthat/{test-patterns.R => test-utilities-patterns.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-patterns.R => test-utilities-patterns.R} (100%) diff --git a/tests/testthat/test-patterns.R b/tests/testthat/test-utilities-patterns.R similarity index 100% rename from tests/testthat/test-patterns.R rename to tests/testthat/test-utilities-patterns.R From 4d18e8badeb4ed684e15c5d51b7f5d1a0cb503fd Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:10:04 +0100 Subject: [PATCH 43/78] cannibalise `test-plot-summary-api.R` --- tests/testthat/test-plot-summary-api.R | 124 ------------------------ tests/testthat/test-summarise-plot.R | 125 +++++++++++++++++++++++++ 2 files changed, 125 insertions(+), 124 deletions(-) delete mode 100644 tests/testthat/test-plot-summary-api.R diff --git a/tests/testthat/test-plot-summary-api.R b/tests/testthat/test-plot-summary-api.R deleted file mode 100644 index 6d90f9f3ae..0000000000 --- a/tests/testthat/test-plot-summary-api.R +++ /dev/null @@ -1,124 +0,0 @@ -# Note: the functions tested here are used by Shiny; please do not change -# their behavior without checking with the Shiny team first. - -# Some basic plots that we build on for the tests -p <- ggplot(mpg, aes(displ, hwy)) + geom_point() -pw <- p + facet_wrap(~ drv) -pg <- p + facet_grid(drv ~ cyl) - -test_that("layout summary - basic plot", { - l <- summarise_layout(ggplot_build(p)) - - empty_named_list <- list(a=1)[0] - - expect_equal(l$panel, factor(1)) - expect_equal(l$row, 1) - expect_equal(l$col, 1) - expect_equal(l$vars, list(empty_named_list)) - expect_equal(l$xmin, 1.33) - expect_equal(l$xmax, 7.27) - expect_equal(l$ymin, 10.4) - expect_equal(l$ymax, 45.6) - expect_equal(l$xscale[[1]]$range$range, c(1.6, 7)) - expect_equal(l$yscale[[1]]$range$range, c(12, 44)) -}) - -test_that("layout summary - facet_wrap", { - lw <- summarise_layout(ggplot_build(pw)) - - expect_equal(lw$panel, factor(1:3)) - expect_equal(lw$row, rep(1, 3)) - expect_equal(lw$col, 1:3) - expect_equal(lw$vars, list(list(drv = "4"), list(drv = "f"), list(drv = "r"))) - expect_equal(lw$xmin, rep(1.33, 3)) - expect_equal(lw$xmax, rep(7.27, 3)) - expect_equal(lw$ymin, rep(10.4, 3)) - expect_equal(lw$ymax, rep(45.6, 3)) - expect_equal(lw$xscale[[1]]$range$range, c(1.6, 7)) - expect_identical(lw$xscale[[1]], lw$xscale[[2]]) - expect_identical(lw$xscale[[1]], lw$xscale[[3]]) - expect_equal(lw$yscale[[1]]$range$range, c(12, 44)) - expect_identical(lw$yscale[[1]], lw$yscale[[2]]) - expect_identical(lw$yscale[[1]], lw$yscale[[3]]) -}) - -test_that("layout summary - facet_grid", { - lg <- summarise_layout(ggplot_build(pg)) - - expect_equal(lg$panel, factor(1:12)) - expect_equal(lg$row, rep(1:3, each = 4)) - expect_equal(lg$col, rep(1:4, 3)) - # Test just a subset of the rows, for simplicity - expect_equal(lg$vars[[1]], list(drv = "4", cyl = 4)) - expect_equal(lg$vars[[2]], list(drv = "4", cyl = 5)) - expect_equal(lg$vars[[12]], list(drv = "r", cyl = 8)) - expect_equal(lg$xmin, rep(1.33, 12)) - expect_equal(lg$xmax, rep(7.27, 12)) - expect_equal(lg$ymin, rep(10.4, 12)) - expect_equal(lg$ymax, rep(45.6, 12)) - expect_equal(lg$xscale[[1]]$range$range, c(1.6, 7)) - expect_identical(lg$xscale[[1]], lg$xscale[[12]]) - expect_equal(lg$yscale[[1]]$range$range, c(12, 44)) - expect_identical(lg$yscale[[1]], lg$yscale[[12]]) -}) - -test_that("layout summary - free scales", { - pwf <- p + facet_wrap(~ drv, scales = "free") - lwf <- summarise_layout(ggplot_build(pwf)) - expect_equal(lwf$xmin, c(1.565, 1.415, 3.640)) - expect_equal(lwf$xmax, c(6.735, 5.485, 7.160)) - expect_equal(lwf$ymin, c(11.20, 15.65, 14.45)) - expect_equal(lwf$ymax, c(28.80, 45.35, 26.55)) - expect_equal(lwf$xscale[[1]]$range$range, c(1.8, 6.5)) - expect_equal(lwf$xscale[[2]]$range$range, c(1.6, 5.3)) - expect_equal(lwf$yscale[[1]]$range$range, c(12, 28)) - expect_equal(lwf$yscale[[2]]$range$range, c(17, 44)) -}) - -test_that("layout summary - reversed scales", { - pr <- p + scale_x_reverse() - lr <- summarise_layout(ggplot_build(pr)) - expect_equal(lr$xmin, -7.27) - expect_equal(lr$xmax, -1.33) - expect_equal(lr$xscale[[1]]$get_transformation()$name, "reverse") - expect_equal(lr$xscale[[1]]$get_transformation()$transform(5), -5) -}) - -test_that("layout summary - log scales", { - pl <- p + scale_x_log10() + scale_y_continuous(transform = "log2") - ll <- summarise_layout(ggplot_build(pl)) - expect_equal(ll$xscale[[1]]$get_transformation()$name, "log-10") - expect_equal(ll$xscale[[1]]$get_transformation()$transform(100), 2) - expect_equal(ll$yscale[[1]]$get_transformation()$name, "log-2") - expect_equal(ll$yscale[[1]]$get_transformation()$transform(16), 4) -}) - -test_that("coord summary - basic", { - l <- summarise_coord(ggplot_build(p)) - expect_identical(l, list(xlog = NA_real_, ylog = NA_real_, flip = FALSE)) -}) - -test_that("coord summary - log transformations", { - # Check for coord log transformations (should ignore log scale) - pl <- p + scale_x_log10() + coord_transform(x = "log2") - ll <- summarise_coord(ggplot_build(pl)) - expect_identical(ll, list(xlog = 2, ylog = NA_real_, flip = FALSE)) -}) - -test_that("coord summary - coord_flip", { - pf <- p + coord_flip() - lf <- summarise_coord(ggplot_build(pf)) - expect_identical(lf, list(xlog = NA_real_, ylog = NA_real_, flip = TRUE)) -}) - -test_that("summarise_layers", { - l <- summarise_layers(ggplot_build(p)) - expect_equal(l$mapping[[1]], list(x = quo(displ), y = quo(hwy)), ignore_attr = TRUE) - - p2 <- p + geom_point(aes(x = displ/2, y = hwy/2)) - l2 <- summarise_layers(ggplot_build(p2)) - expect_equal(l2$mapping[[1]], list(x = quo(displ), y = quo(hwy)), ignore_attr = TRUE) - - # Here use _identical because the quosures are supposed to be local - expect_identical(l2$mapping[[2]], list(x = quo(displ/2), y = quo(hwy/2))) -}) diff --git a/tests/testthat/test-summarise-plot.R b/tests/testthat/test-summarise-plot.R index 601147f4e0..838240f612 100644 --- a/tests/testthat/test-summarise-plot.R +++ b/tests/testthat/test-summarise-plot.R @@ -5,3 +5,128 @@ test_that("summarise_*() throws appropriate errors", { expect_snapshot_error(summarise_layers(TRUE)) }) + +# Note: the functions tested here are used by Shiny; please do not change +# their behavior without checking with the Shiny team first. + +# Some basic plots that we build on for the tests +p <- ggplot(mpg, aes(displ, hwy)) + geom_point() +pw <- p + facet_wrap(~ drv) +pg <- p + facet_grid(drv ~ cyl) + +test_that("layout summary - basic plot", { + l <- summarise_layout(ggplot_build(p)) + + empty_named_list <- list(a=1)[0] + + expect_equal(l$panel, factor(1)) + expect_equal(l$row, 1) + expect_equal(l$col, 1) + expect_equal(l$vars, list(empty_named_list)) + expect_equal(l$xmin, 1.33) + expect_equal(l$xmax, 7.27) + expect_equal(l$ymin, 10.4) + expect_equal(l$ymax, 45.6) + expect_equal(l$xscale[[1]]$range$range, c(1.6, 7)) + expect_equal(l$yscale[[1]]$range$range, c(12, 44)) +}) + +test_that("layout summary - facet_wrap", { + lw <- summarise_layout(ggplot_build(pw)) + + expect_equal(lw$panel, factor(1:3)) + expect_equal(lw$row, rep(1, 3)) + expect_equal(lw$col, 1:3) + expect_equal(lw$vars, list(list(drv = "4"), list(drv = "f"), list(drv = "r"))) + expect_equal(lw$xmin, rep(1.33, 3)) + expect_equal(lw$xmax, rep(7.27, 3)) + expect_equal(lw$ymin, rep(10.4, 3)) + expect_equal(lw$ymax, rep(45.6, 3)) + expect_equal(lw$xscale[[1]]$range$range, c(1.6, 7)) + expect_identical(lw$xscale[[1]], lw$xscale[[2]]) + expect_identical(lw$xscale[[1]], lw$xscale[[3]]) + expect_equal(lw$yscale[[1]]$range$range, c(12, 44)) + expect_identical(lw$yscale[[1]], lw$yscale[[2]]) + expect_identical(lw$yscale[[1]], lw$yscale[[3]]) +}) + +test_that("layout summary - facet_grid", { + lg <- summarise_layout(ggplot_build(pg)) + + expect_equal(lg$panel, factor(1:12)) + expect_equal(lg$row, rep(1:3, each = 4)) + expect_equal(lg$col, rep(1:4, 3)) + # Test just a subset of the rows, for simplicity + expect_equal(lg$vars[[1]], list(drv = "4", cyl = 4)) + expect_equal(lg$vars[[2]], list(drv = "4", cyl = 5)) + expect_equal(lg$vars[[12]], list(drv = "r", cyl = 8)) + expect_equal(lg$xmin, rep(1.33, 12)) + expect_equal(lg$xmax, rep(7.27, 12)) + expect_equal(lg$ymin, rep(10.4, 12)) + expect_equal(lg$ymax, rep(45.6, 12)) + expect_equal(lg$xscale[[1]]$range$range, c(1.6, 7)) + expect_identical(lg$xscale[[1]], lg$xscale[[12]]) + expect_equal(lg$yscale[[1]]$range$range, c(12, 44)) + expect_identical(lg$yscale[[1]], lg$yscale[[12]]) +}) + +test_that("layout summary - free scales", { + pwf <- p + facet_wrap(~ drv, scales = "free") + lwf <- summarise_layout(ggplot_build(pwf)) + expect_equal(lwf$xmin, c(1.565, 1.415, 3.640)) + expect_equal(lwf$xmax, c(6.735, 5.485, 7.160)) + expect_equal(lwf$ymin, c(11.20, 15.65, 14.45)) + expect_equal(lwf$ymax, c(28.80, 45.35, 26.55)) + expect_equal(lwf$xscale[[1]]$range$range, c(1.8, 6.5)) + expect_equal(lwf$xscale[[2]]$range$range, c(1.6, 5.3)) + expect_equal(lwf$yscale[[1]]$range$range, c(12, 28)) + expect_equal(lwf$yscale[[2]]$range$range, c(17, 44)) +}) + +test_that("layout summary - reversed scales", { + pr <- p + scale_x_reverse() + lr <- summarise_layout(ggplot_build(pr)) + expect_equal(lr$xmin, -7.27) + expect_equal(lr$xmax, -1.33) + expect_equal(lr$xscale[[1]]$get_transformation()$name, "reverse") + expect_equal(lr$xscale[[1]]$get_transformation()$transform(5), -5) +}) + +test_that("layout summary - log scales", { + pl <- p + scale_x_log10() + scale_y_continuous(transform = "log2") + ll <- summarise_layout(ggplot_build(pl)) + expect_equal(ll$xscale[[1]]$get_transformation()$name, "log-10") + expect_equal(ll$xscale[[1]]$get_transformation()$transform(100), 2) + expect_equal(ll$yscale[[1]]$get_transformation()$name, "log-2") + expect_equal(ll$yscale[[1]]$get_transformation()$transform(16), 4) +}) + +test_that("coord summary - basic", { + l <- summarise_coord(ggplot_build(p)) + expect_identical(l, list(xlog = NA_real_, ylog = NA_real_, flip = FALSE)) +}) + +test_that("coord summary - log transformations", { + # Check for coord log transformations (should ignore log scale) + pl <- p + scale_x_log10() + coord_transform(x = "log2") + ll <- summarise_coord(ggplot_build(pl)) + expect_identical(ll, list(xlog = 2, ylog = NA_real_, flip = FALSE)) +}) + +test_that("coord summary - coord_flip", { + pf <- p + coord_flip() + lf <- summarise_coord(ggplot_build(pf)) + expect_identical(lf, list(xlog = NA_real_, ylog = NA_real_, flip = TRUE)) +}) + +test_that("summarise_layers", { + l <- summarise_layers(ggplot_build(p)) + expect_equal(l$mapping[[1]], list(x = quo(displ), y = quo(hwy)), ignore_attr = TRUE) + + p2 <- p + geom_point(aes(x = displ/2, y = hwy/2)) + l2 <- summarise_layers(ggplot_build(p2)) + expect_equal(l2$mapping[[1]], list(x = quo(displ), y = quo(hwy)), ignore_attr = TRUE) + + # Here use _identical because the quosures are supposed to be local + expect_identical(l2$mapping[[2]], list(x = quo(displ/2), y = quo(hwy/2))) +}) From 534a0e5f91c5ba30c506003ec79a5180bb83d864 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:24:12 +0100 Subject: [PATCH 44/78] clarify `performance.R` has performance utilities --- R/{performance.R => utilities-performance.R} | 0 .../testthat/{test-performance.R => test-utilities-performance.R} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename R/{performance.R => utilities-performance.R} (100%) rename tests/testthat/{test-performance.R => test-utilities-performance.R} (100%) diff --git a/R/performance.R b/R/utilities-performance.R similarity index 100% rename from R/performance.R rename to R/utilities-performance.R diff --git a/tests/testthat/test-performance.R b/tests/testthat/test-utilities-performance.R similarity index 100% rename from tests/testthat/test-performance.R rename to tests/testthat/test-utilities-performance.R From acf6515ec34be9cf3e8a112815a9d6bd77911fa3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:27:29 +0100 Subject: [PATCH 45/78] underscore to kebab --- tests/testthat/{test-position_dodge.R => test-position-dodge.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-position_dodge.R => test-position-dodge.R} (100%) diff --git a/tests/testthat/test-position_dodge.R b/tests/testthat/test-position-dodge.R similarity index 100% rename from tests/testthat/test-position_dodge.R rename to tests/testthat/test-position-dodge.R From 621118c9d340d9a6633834159c9ca825b934cde4 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:30:23 +0100 Subject: [PATCH 46/78] align `test-qplot.R` --- tests/testthat/{test-qplot.R => test-quick-plot.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-qplot.R => test-quick-plot.R} (100%) diff --git a/tests/testthat/test-qplot.R b/tests/testthat/test-quick-plot.R similarity index 100% rename from tests/testthat/test-qplot.R rename to tests/testthat/test-quick-plot.R From 5861dc0b9973719c547575454804ec5e38a1a32c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:34:15 +0100 Subject: [PATCH 47/78] delete `test-range.R`: {scales} is responsible and tests this already --- tests/testthat/test-range.R | 22 ---------------------- 1 file changed, 22 deletions(-) delete mode 100644 tests/testthat/test-range.R diff --git a/tests/testthat/test-range.R b/tests/testthat/test-range.R deleted file mode 100644 index e75b6352f3..0000000000 --- a/tests/testthat/test-range.R +++ /dev/null @@ -1,22 +0,0 @@ -test_that("continuous ranges expand as expected", { - r <- ContinuousRange$new() - - r$train(1) - expect_equal(r$range, c(1, 1)) - - r$train(10) - expect_equal(r$range, c(1, 10)) -}) - -test_that("discrete ranges expand as expected", { - r <- DiscreteRange$new() - - r$train("a") - expect_equal(r$range, "a") - - r$train("b") - expect_equal(r$range, c("a", "b")) - - r$train(letters) - expect_equal(r$range, letters) -}) From c7c1ebb61a6b8c13172398e637bb1798280a0c4b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:36:20 +0100 Subject: [PATCH 48/78] cannibalise `test-scale_date.R` --- tests/testthat/test-scale-date.R | 62 ++++++++++++++++++++++++++++++++ tests/testthat/test-scale_date.R | 55 ---------------------------- 2 files changed, 62 insertions(+), 55 deletions(-) delete mode 100644 tests/testthat/test-scale_date.R diff --git a/tests/testthat/test-scale-date.R b/tests/testthat/test-scale-date.R index 48259e3261..3fbcd07b46 100644 --- a/tests/testthat/test-scale-date.R +++ b/tests/testthat/test-scale-date.R @@ -1,3 +1,18 @@ +test_that("date(time) scales coerce data types", { + + date <- as.Date("2024-11-11") + datetime <- as.POSIXct(date) + + sc <- scale_x_datetime() + df <- sc$transform_df(data_frame0(x = date)) + expect_equal(df$x, as.numeric(datetime)) + + sc <- scale_x_date() + df <- sc$transform_df(data_frame0(x = datetime)) + expect_equal(df$x, as.numeric(date)) + +}) + base_time <- function(tz = "") { as.POSIXct(strptime("2015-06-01", "%Y-%m-%d", tz = tz)) } @@ -83,6 +98,53 @@ test_that("datetime colour scales work", { expect_equal(range(get_layer_data(p)$colour), c("#132B43", "#56B1F7")) }) +# Visual tests ------------------------------------------------------------ + +test_that("date scale draws correctly", { + # datetime labels are locale dependent + withr::local_locale(c(LC_TIME = "C")) + + set.seed(321) + df <- data_frame( + dx = seq(as.Date("2012-02-29"), length.out = 100, by = "1 day")[sample( + 100, + 50 + )], + price = runif(50) + ) + df <- df[order(df$dx), ] + + dt <- ggplot(df, aes(dx, price)) + geom_line() + expect_doppelganger("dates along x, default breaks", dt) + expect_doppelganger( + "scale_x_date(breaks = breaks_width(\"2 weeks\"))", + dt + scale_x_date(breaks = breaks_width("2 weeks")) + ) + expect_doppelganger( + "scale_x_date(breaks = \"3 weeks\")", + dt + scale_x_date(date_breaks = "3 weeks") + ) + expect_doppelganger( + "scale_x_date(labels = label_date(\"%m/%d\"))", + dt + scale_x_date(labels = label_date("%m/%d")) + ) + expect_doppelganger( + "scale_x_date(labels = label_date(\"%W\"), \"week\")", + dt + scale_x_date(labels = label_date("%W"), "week") + ) + + dt <- ggplot(df, aes(price, dx)) + geom_line() + expect_doppelganger("dates along y, default breaks", dt) + expect_doppelganger( + "scale_y_date(breaks = breaks_width(\"2 weeks\"))", + dt + scale_y_date(breaks = breaks_width("2 weeks")) + ) + expect_doppelganger( + "scale_y_date(breaks = \"3 weeks\")", + dt + scale_y_date(date_breaks = "3 weeks") + ) +}) + test_that("date(time) scales throw warnings when input is incorrect", { p <- ggplot(data.frame(x = 1, y = 1), aes(x, y)) + geom_point() diff --git a/tests/testthat/test-scale_date.R b/tests/testthat/test-scale_date.R deleted file mode 100644 index b9a788bb70..0000000000 --- a/tests/testthat/test-scale_date.R +++ /dev/null @@ -1,55 +0,0 @@ - -test_that("date(time) scales coerce data types", { - - date <- as.Date("2024-11-11") - datetime <- as.POSIXct(date) - - sc <- scale_x_datetime() - df <- sc$transform_df(data_frame0(x = date)) - expect_equal(df$x, as.numeric(datetime)) - - sc <- scale_x_date() - df <- sc$transform_df(data_frame0(x = datetime)) - expect_equal(df$x, as.numeric(date)) - -}) - -# Visual tests ------------------------------------------------------------ - -test_that("date scale draws correctly", { - # datetime labels are locale dependent - withr::local_locale(c(LC_TIME = "C")) - - set.seed(321) - df <- data_frame( - dx = seq(as.Date("2012-02-29"), length.out = 100, by = "1 day")[sample(100, 50)], - price = runif(50) - ) - df <- df[order(df$dx), ] - - dt <- ggplot(df, aes(dx, price)) + geom_line() - expect_doppelganger("dates along x, default breaks", - dt - ) - expect_doppelganger("scale_x_date(breaks = breaks_width(\"2 weeks\"))", - dt + scale_x_date(breaks = breaks_width("2 weeks")) - ) - expect_doppelganger("scale_x_date(breaks = \"3 weeks\")", - dt + scale_x_date(date_breaks = "3 weeks") - ) - expect_doppelganger("scale_x_date(labels = label_date(\"%m/%d\"))", - dt + scale_x_date(labels = label_date("%m/%d")) - ) - expect_doppelganger("scale_x_date(labels = label_date(\"%W\"), \"week\")", - dt + scale_x_date(labels = label_date("%W"), "week") - ) - - dt <- ggplot(df, aes(price, dx)) + geom_line() - expect_doppelganger("dates along y, default breaks", dt) - expect_doppelganger("scale_y_date(breaks = breaks_width(\"2 weeks\"))", - dt + scale_y_date(breaks = breaks_width("2 weeks")) - ) - expect_doppelganger("scale_y_date(breaks = \"3 weeks\")", - dt + scale_y_date(date_breaks = "3 weeks") - ) -}) From 444d655075fe363596c53d099b4485c71b27991e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 10:43:06 +0100 Subject: [PATCH 49/78] accept snapshots moving around --- tests/testthat/_snaps/{position_dodge.md => position-dodge.md} | 0 tests/testthat/_snaps/{qplot.md => quick-plot.md} | 0 .../{scale_date => scale-date}/dates-along-x-default-breaks.svg | 0 .../{scale_date => scale-date}/dates-along-y-default-breaks.svg | 0 .../{scale_date => scale-date}/scale-x-date-breaks-3-weeks.svg | 0 .../scale-x-date-breaks-breaks-width-2-weeks.svg | 0 .../scale-x-date-labels-label-date-m-d.svg | 0 .../scale-x-date-labels-label-date-w-week.svg | 0 .../{scale_date => scale-date}/scale-y-date-breaks-3-weeks.svg | 0 .../scale-y-date-breaks-breaks-width-2-weeks.svg | 0 tests/testthat/_snaps/{patterns.md => utilities-patterns.md} | 0 .../{patterns => utilities-patterns}/pattern-fills-no-alpha.svg | 0 .../pattern-fills-through-scale.svg | 0 .../{patterns => utilities-patterns}/pattern-fills-with-alpha.svg | 0 .../{patterns => utilities-patterns}/single-pattern-fill.svg | 0 .../testthat/_snaps/{performance.md => utilities-performance.md} | 0 16 files changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/_snaps/{position_dodge.md => position-dodge.md} (100%) rename tests/testthat/_snaps/{qplot.md => quick-plot.md} (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/dates-along-x-default-breaks.svg (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/dates-along-y-default-breaks.svg (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/scale-x-date-breaks-3-weeks.svg (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/scale-x-date-breaks-breaks-width-2-weeks.svg (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/scale-x-date-labels-label-date-m-d.svg (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/scale-x-date-labels-label-date-w-week.svg (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/scale-y-date-breaks-3-weeks.svg (100%) rename tests/testthat/_snaps/{scale_date => scale-date}/scale-y-date-breaks-breaks-width-2-weeks.svg (100%) rename tests/testthat/_snaps/{patterns.md => utilities-patterns.md} (100%) rename tests/testthat/_snaps/{patterns => utilities-patterns}/pattern-fills-no-alpha.svg (100%) rename tests/testthat/_snaps/{patterns => utilities-patterns}/pattern-fills-through-scale.svg (100%) rename tests/testthat/_snaps/{patterns => utilities-patterns}/pattern-fills-with-alpha.svg (100%) rename tests/testthat/_snaps/{patterns => utilities-patterns}/single-pattern-fill.svg (100%) rename tests/testthat/_snaps/{performance.md => utilities-performance.md} (100%) diff --git a/tests/testthat/_snaps/position_dodge.md b/tests/testthat/_snaps/position-dodge.md similarity index 100% rename from tests/testthat/_snaps/position_dodge.md rename to tests/testthat/_snaps/position-dodge.md diff --git a/tests/testthat/_snaps/qplot.md b/tests/testthat/_snaps/quick-plot.md similarity index 100% rename from tests/testthat/_snaps/qplot.md rename to tests/testthat/_snaps/quick-plot.md diff --git a/tests/testthat/_snaps/scale_date/dates-along-x-default-breaks.svg b/tests/testthat/_snaps/scale-date/dates-along-x-default-breaks.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/dates-along-x-default-breaks.svg rename to tests/testthat/_snaps/scale-date/dates-along-x-default-breaks.svg diff --git a/tests/testthat/_snaps/scale_date/dates-along-y-default-breaks.svg b/tests/testthat/_snaps/scale-date/dates-along-y-default-breaks.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/dates-along-y-default-breaks.svg rename to tests/testthat/_snaps/scale-date/dates-along-y-default-breaks.svg diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-breaks-3-weeks.svg b/tests/testthat/_snaps/scale-date/scale-x-date-breaks-3-weeks.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/scale-x-date-breaks-3-weeks.svg rename to tests/testthat/_snaps/scale-date/scale-x-date-breaks-3-weeks.svg diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-breaks-breaks-width-2-weeks.svg b/tests/testthat/_snaps/scale-date/scale-x-date-breaks-breaks-width-2-weeks.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/scale-x-date-breaks-breaks-width-2-weeks.svg rename to tests/testthat/_snaps/scale-date/scale-x-date-breaks-breaks-width-2-weeks.svg diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg b/tests/testthat/_snaps/scale-date/scale-x-date-labels-label-date-m-d.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg rename to tests/testthat/_snaps/scale-date/scale-x-date-labels-label-date-m-d.svg diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg b/tests/testthat/_snaps/scale-date/scale-x-date-labels-label-date-w-week.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg rename to tests/testthat/_snaps/scale-date/scale-x-date-labels-label-date-w-week.svg diff --git a/tests/testthat/_snaps/scale_date/scale-y-date-breaks-3-weeks.svg b/tests/testthat/_snaps/scale-date/scale-y-date-breaks-3-weeks.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/scale-y-date-breaks-3-weeks.svg rename to tests/testthat/_snaps/scale-date/scale-y-date-breaks-3-weeks.svg diff --git a/tests/testthat/_snaps/scale_date/scale-y-date-breaks-breaks-width-2-weeks.svg b/tests/testthat/_snaps/scale-date/scale-y-date-breaks-breaks-width-2-weeks.svg similarity index 100% rename from tests/testthat/_snaps/scale_date/scale-y-date-breaks-breaks-width-2-weeks.svg rename to tests/testthat/_snaps/scale-date/scale-y-date-breaks-breaks-width-2-weeks.svg diff --git a/tests/testthat/_snaps/patterns.md b/tests/testthat/_snaps/utilities-patterns.md similarity index 100% rename from tests/testthat/_snaps/patterns.md rename to tests/testthat/_snaps/utilities-patterns.md diff --git a/tests/testthat/_snaps/patterns/pattern-fills-no-alpha.svg b/tests/testthat/_snaps/utilities-patterns/pattern-fills-no-alpha.svg similarity index 100% rename from tests/testthat/_snaps/patterns/pattern-fills-no-alpha.svg rename to tests/testthat/_snaps/utilities-patterns/pattern-fills-no-alpha.svg diff --git a/tests/testthat/_snaps/patterns/pattern-fills-through-scale.svg b/tests/testthat/_snaps/utilities-patterns/pattern-fills-through-scale.svg similarity index 100% rename from tests/testthat/_snaps/patterns/pattern-fills-through-scale.svg rename to tests/testthat/_snaps/utilities-patterns/pattern-fills-through-scale.svg diff --git a/tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg b/tests/testthat/_snaps/utilities-patterns/pattern-fills-with-alpha.svg similarity index 100% rename from tests/testthat/_snaps/patterns/pattern-fills-with-alpha.svg rename to tests/testthat/_snaps/utilities-patterns/pattern-fills-with-alpha.svg diff --git a/tests/testthat/_snaps/patterns/single-pattern-fill.svg b/tests/testthat/_snaps/utilities-patterns/single-pattern-fill.svg similarity index 100% rename from tests/testthat/_snaps/patterns/single-pattern-fill.svg rename to tests/testthat/_snaps/utilities-patterns/single-pattern-fill.svg diff --git a/tests/testthat/_snaps/performance.md b/tests/testthat/_snaps/utilities-performance.md similarity index 100% rename from tests/testthat/_snaps/performance.md rename to tests/testthat/_snaps/utilities-performance.md From ffc60735f43c8b3476f3e247d7f9742302813f0b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 12:18:19 +0100 Subject: [PATCH 50/78] reorganise scale tests --- tests/testthat/_snaps/scale-.md | 273 ++++++ .../character.svg | 0 .../{scales-breaks-labels => scale-}/date.svg | 0 .../functional-limits.svg | 0 .../no-alpha-breaks-no-legend.svg | 0 .../no-colour-breaks-no-legend.svg | 0 .../no-fill-breaks-no-legend.svg | 0 .../no-size-breaks-no-legend.svg | 0 .../no-x-breaks.svg | 0 .../no-y-breaks.svg | 0 .../numeric-exp.svg | 0 .../numeric-log.svg | 0 .../numeric-polar.svg | 0 .../numeric.svg | 0 tests/testthat/_snaps/scale-continuous.md | 12 + tests/testthat/_snaps/scales-breaks-labels.md | 69 -- tests/testthat/_snaps/scales.md | 216 ----- tests/testthat/test-aes-delayed-eval.R | 11 + tests/testthat/test-scale-.R | 850 ++++++++++++++++++ tests/testthat/test-scale-colour.R | 12 + tests/testthat/test-scale-continuous.R | 67 ++ tests/testthat/test-scale-identity.R | 30 + tests/testthat/test-scale-view.R | 25 + tests/testthat/test-scales-breaks-labels.R | 396 -------- tests/testthat/test-scales.R | 589 ------------ 25 files changed, 1280 insertions(+), 1270 deletions(-) create mode 100644 tests/testthat/_snaps/scale-.md rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/character.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/date.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/functional-limits.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/no-alpha-breaks-no-legend.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/no-colour-breaks-no-legend.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/no-fill-breaks-no-legend.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/no-size-breaks-no-legend.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/no-x-breaks.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/no-y-breaks.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/numeric-exp.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/numeric-log.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/numeric-polar.svg (100%) rename tests/testthat/_snaps/{scales-breaks-labels => scale-}/numeric.svg (100%) create mode 100644 tests/testthat/_snaps/scale-continuous.md delete mode 100644 tests/testthat/_snaps/scales-breaks-labels.md create mode 100644 tests/testthat/test-scale-.R create mode 100644 tests/testthat/test-scale-continuous.R create mode 100644 tests/testthat/test-scale-identity.R create mode 100644 tests/testthat/test-scale-view.R delete mode 100644 tests/testthat/test-scales-breaks-labels.R diff --git a/tests/testthat/_snaps/scale-.md b/tests/testthat/_snaps/scale-.md new file mode 100644 index 0000000000..8c26a8fc9f --- /dev/null +++ b/tests/testthat/_snaps/scale-.md @@ -0,0 +1,273 @@ +# training incorrectly appropriately communicates the offenders + + Continuous value supplied to a discrete scale. + i Example values: 1, 2, 3, 4, and 5. + +--- + + Discrete value supplied to a continuous scale. + i Example values: "A" and "E". + +# Using `scale_name` prompts deprecation message + + The `scale_name` argument of `continuous_scale()` is deprecated as of ggplot2 3.5.0. + +--- + + The `scale_name` argument of `discrete_scale()` is deprecated as of ggplot2 3.5.0. + +--- + + The `scale_name` argument of `binned_scale()` is deprecated as of ggplot2 3.5.0. + +# continuous scales warn about faulty `limits` + + Code + scale_x_continuous(limits = c("A", "B")) + Condition + Error in `scale_x_continuous()`: + ! `limits` must be a vector, not a character vector. + +--- + + Code + scale_x_continuous(limits = 1:3) + Condition + Error in `scale_x_continuous()`: + ! `limits` must be a vector of length 2, not length 3. + +# breaks and labels are correctly checked + + `breaks` and `labels` must have the same length. + +--- + + Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Invalid `minor_breaks` specification. Use `NULL`, not `NA`. + +--- + + Invalid `labels` specification. Use `NULL`, not `NA`. + +--- + + `breaks` and `labels` have different lengths. + +--- + + Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Invalid `labels` specification. Use `NULL`, not `NA`. + +--- + + Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Invalid `labels` specification. Use `NULL`, not `NA`. + +--- + + `breaks` and `labels` have different lengths. + +# labels match breaks + + Code + scale_x_discrete(breaks = 1:3, labels = 1:2) + Condition + Error in `scale_x_discrete()`: + ! `breaks` and `labels` must have the same length. + +--- + + Code + scale_x_continuous(breaks = 1:3, labels = 1:2) + Condition + Error in `scale_x_continuous()`: + ! `breaks` and `labels` must have the same length. + +# passing continuous limits to a discrete scale generates a warning + + Continuous limits supplied to discrete scale. + i Did you mean `limits = factor(...)` or `scale_*_continuous()`? + +# suppressing breaks, minor_breask, and labels works + + Code + scale_x_date(breaks = NA, limits = lims)$get_breaks() + Condition + Error in `scale_x_date()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_date(labels = NA, limits = lims)$get_labels() + Condition + Error in `scale_x_date()`: + ! Invalid `labels` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor() + Condition + Error in `scale_x_date()`: + ! Invalid `minor_breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_datetime(breaks = NA, limits = lims)$get_breaks() + Condition + Error in `scale_x_datetime()`: + ! Invalid `breaks` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_datetime(labels = NA, limits = lims)$get_labels() + Condition + Error in `scale_x_datetime()`: + ! Invalid `labels` specification. Use `NULL`, not `NA`. + +--- + + Code + scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor() + Condition + Error in `scale_x_datetime()`: + ! Invalid `minor_breaks` specification. Use `NULL`, not `NA`. + +# 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 + diff --git a/tests/testthat/_snaps/scales-breaks-labels/character.svg b/tests/testthat/_snaps/scale-/character.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/character.svg rename to tests/testthat/_snaps/scale-/character.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/date.svg b/tests/testthat/_snaps/scale-/date.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/date.svg rename to tests/testthat/_snaps/scale-/date.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/functional-limits.svg b/tests/testthat/_snaps/scale-/functional-limits.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/functional-limits.svg rename to tests/testthat/_snaps/scale-/functional-limits.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/no-alpha-breaks-no-legend.svg b/tests/testthat/_snaps/scale-/no-alpha-breaks-no-legend.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/no-alpha-breaks-no-legend.svg rename to tests/testthat/_snaps/scale-/no-alpha-breaks-no-legend.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/no-colour-breaks-no-legend.svg b/tests/testthat/_snaps/scale-/no-colour-breaks-no-legend.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/no-colour-breaks-no-legend.svg rename to tests/testthat/_snaps/scale-/no-colour-breaks-no-legend.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/no-fill-breaks-no-legend.svg b/tests/testthat/_snaps/scale-/no-fill-breaks-no-legend.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/no-fill-breaks-no-legend.svg rename to tests/testthat/_snaps/scale-/no-fill-breaks-no-legend.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/no-size-breaks-no-legend.svg b/tests/testthat/_snaps/scale-/no-size-breaks-no-legend.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/no-size-breaks-no-legend.svg rename to tests/testthat/_snaps/scale-/no-size-breaks-no-legend.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/no-x-breaks.svg b/tests/testthat/_snaps/scale-/no-x-breaks.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/no-x-breaks.svg rename to tests/testthat/_snaps/scale-/no-x-breaks.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/no-y-breaks.svg b/tests/testthat/_snaps/scale-/no-y-breaks.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/no-y-breaks.svg rename to tests/testthat/_snaps/scale-/no-y-breaks.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/numeric-exp.svg b/tests/testthat/_snaps/scale-/numeric-exp.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/numeric-exp.svg rename to tests/testthat/_snaps/scale-/numeric-exp.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/numeric-log.svg b/tests/testthat/_snaps/scale-/numeric-log.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/numeric-log.svg rename to tests/testthat/_snaps/scale-/numeric-log.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/numeric-polar.svg b/tests/testthat/_snaps/scale-/numeric-polar.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/numeric-polar.svg rename to tests/testthat/_snaps/scale-/numeric-polar.svg diff --git a/tests/testthat/_snaps/scales-breaks-labels/numeric.svg b/tests/testthat/_snaps/scale-/numeric.svg similarity index 100% rename from tests/testthat/_snaps/scales-breaks-labels/numeric.svg rename to tests/testthat/_snaps/scale-/numeric.svg diff --git a/tests/testthat/_snaps/scale-continuous.md b/tests/testthat/_snaps/scale-continuous.md new file mode 100644 index 0000000000..298232a4e4 --- /dev/null +++ b/tests/testthat/_snaps/scale-continuous.md @@ -0,0 +1,12 @@ +# oob affects position values + + Removed 1 row containing missing values or values outside the scale range (`geom_bar()`). + +--- + + Removed 3 rows containing missing values or values outside the scale range (`geom_bar()`). + +# scales warn when transforms introduces non-finite values + + log-10 transformation introduced infinite values. + diff --git a/tests/testthat/_snaps/scales-breaks-labels.md b/tests/testthat/_snaps/scales-breaks-labels.md deleted file mode 100644 index 55ef686c68..0000000000 --- a/tests/testthat/_snaps/scales-breaks-labels.md +++ /dev/null @@ -1,69 +0,0 @@ -# labels match breaks - - Code - scale_x_discrete(breaks = 1:3, labels = 1:2) - Condition - Error in `scale_x_discrete()`: - ! `breaks` and `labels` must have the same length. - ---- - - Code - scale_x_continuous(breaks = 1:3, labels = 1:2) - Condition - Error in `scale_x_continuous()`: - ! `breaks` and `labels` must have the same length. - -# passing continuous limits to a discrete scale generates a warning - - Continuous limits supplied to discrete scale. - i Did you mean `limits = factor(...)` or `scale_*_continuous()`? - -# suppressing breaks, minor_breask, and labels works - - Code - scale_x_date(breaks = NA, limits = lims)$get_breaks() - Condition - Error in `scale_x_date()`: - ! Invalid `breaks` specification. Use `NULL`, not `NA`. - ---- - - Code - scale_x_date(labels = NA, limits = lims)$get_labels() - Condition - Error in `scale_x_date()`: - ! Invalid `labels` specification. Use `NULL`, not `NA`. - ---- - - Code - scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor() - Condition - Error in `scale_x_date()`: - ! Invalid `minor_breaks` specification. Use `NULL`, not `NA`. - ---- - - Code - scale_x_datetime(breaks = NA, limits = lims)$get_breaks() - Condition - Error in `scale_x_datetime()`: - ! Invalid `breaks` specification. Use `NULL`, not `NA`. - ---- - - Code - scale_x_datetime(labels = NA, limits = lims)$get_labels() - Condition - Error in `scale_x_datetime()`: - ! Invalid `labels` specification. Use `NULL`, not `NA`. - ---- - - Code - scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor() - Condition - Error in `scale_x_datetime()`: - ! Invalid `minor_breaks` specification. Use `NULL`, not `NA`. - diff --git a/tests/testthat/_snaps/scales.md b/tests/testthat/_snaps/scales.md index 3d7cf53e7c..4318930a3c 100644 --- a/tests/testthat/_snaps/scales.md +++ b/tests/testthat/_snaps/scales.md @@ -1,15 +1,3 @@ -# oob affects position values - - Removed 1 row containing missing values or values outside the scale range (`geom_bar()`). - ---- - - Removed 3 rows containing missing values or values outside the scale range (`geom_bar()`). - -# scales warn when transforms introduces non-finite values - - log-10 transformation introduced infinite values. - # size and alpha scales throw appropriate warnings for factors Using size for a discrete variable is not advised. @@ -30,207 +18,3 @@ `scale_id` must not contain any "NA". -# breaks and labels are correctly checked - - `breaks` and `labels` must have the same length. - ---- - - Invalid `breaks` specification. Use `NULL`, not `NA`. - ---- - - Invalid `minor_breaks` specification. Use `NULL`, not `NA`. - ---- - - Invalid `labels` specification. Use `NULL`, not `NA`. - ---- - - `breaks` and `labels` have different lengths. - ---- - - Invalid `breaks` specification. Use `NULL`, not `NA`. - ---- - - Invalid `labels` specification. Use `NULL`, not `NA`. - ---- - - Invalid `breaks` specification. Use `NULL`, not `NA`. - ---- - - Invalid `labels` specification. Use `NULL`, not `NA`. - ---- - - `breaks` and `labels` have different lengths. - -# 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 value supplied to a discrete scale. - i Example values: 1, 2, 3, 4, and 5. - ---- - - Discrete value supplied to a continuous scale. - i Example values: "A" and "E". - -# Using `scale_name` prompts deprecation message - - The `scale_name` argument of `continuous_scale()` is deprecated as of ggplot2 3.5.0. - ---- - - The `scale_name` argument of `discrete_scale()` is deprecated as of ggplot2 3.5.0. - ---- - - The `scale_name` argument of `binned_scale()` is deprecated as of ggplot2 3.5.0. - -# continuous scales warn about faulty `limits` - - Code - scale_x_continuous(limits = c("A", "B")) - Condition - Error in `scale_x_continuous()`: - ! `limits` must be a vector, not a character vector. - ---- - - Code - scale_x_continuous(limits = 1:3) - Condition - Error in `scale_x_continuous()`: - ! `limits` must be a vector of length 2, not length 3. - diff --git a/tests/testthat/test-aes-delayed-eval.R b/tests/testthat/test-aes-delayed-eval.R index 09321637ac..0887eea548 100644 --- a/tests/testthat/test-aes-delayed-eval.R +++ b/tests/testthat/test-aes-delayed-eval.R @@ -177,3 +177,14 @@ test_that("aes evaluation fails with unknown input", { expect_snapshot_error(is_calculated(environment())) expect_snapshot_error(strip_dots(environment())) }) + + +test_that("staged aesthetics are backtransformed properly (#4155)", { + p <- ggplot(data.frame(value = 16)) + + geom_point(aes(stage(value, after_stat = x / 2), 0)) + + scale_x_sqrt(limits = c(0, 16), breaks = c(2, 4, 8)) + + # x / 2 should be 16 / 2 = 8, thus the result should be sqrt(8) on scale_x_sqrt() + expect_equal(get_layer_data(p)$x, sqrt(8)) +}) + diff --git a/tests/testthat/test-scale-.R b/tests/testthat/test-scale-.R new file mode 100644 index 0000000000..49ec77652f --- /dev/null +++ b/tests/testthat/test-scale-.R @@ -0,0 +1,850 @@ +test_that("ranges update only for variables listed in aesthetics", { + sc <- scale_alpha() + + sc$train_df(data_frame(alpha = 1:10)) + expect_equal(sc$range$range, c(1, 10)) + + sc$train_df(data_frame(alpha = 50)) + expect_equal(sc$range$range, c(1, 50)) + + sc$train_df(data_frame(beta = 100)) + expect_equal(sc$range$range, c(1, 50)) + + sc$train_df(data_frame()) + expect_equal(sc$range$range, c(1, 50)) +}) + +test_that("mapping works", { + sc <- scale_alpha(range = c(0, 1), na.value = 0) + sc$train_df(data_frame(alpha = 1:10)) + + expect_equal( + sc$map_df(data_frame(alpha = 1:10))[[1]], + seq(0, 1, length.out = 10) + ) + + expect_equal(sc$map_df(data_frame(alpha = NA))[[1]], 0) + + expect_equal( + sc$map_df(data_frame(alpha = c(-10, 11)))[[1]], + c(0, 0)) +}) + +test_that("aesthetics can be set independently of scale name", { + df <- data_frame( + x = LETTERS[1:3], + y = LETTERS[4:6] + ) + p <- ggplot(df, aes(x, y, fill = y)) + + scale_colour_manual(values = c("red", "green", "blue"), aesthetics = "fill") + + expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) +}) + +test_that("multiple aesthetics can be set with one function call", { + df <- data_frame( + x = LETTERS[1:3], + y = LETTERS[4:6] + ) + p <- ggplot(df, aes(x, y, colour = x, fill = y)) + + scale_colour_manual( + values = c("grey20", "grey40", "grey60", "red", "green", "blue"), + aesthetics = c("colour", "fill") + ) + + expect_equal(get_layer_data(p)$colour, c("grey20", "grey40", "grey60")) + expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) + + # color order is determined by data order, and breaks are combined where possible + df <- data_frame( + x = LETTERS[1:3], + y = LETTERS[2:4] + ) + p <- ggplot(df, aes(x, y, colour = x, fill = y)) + + scale_colour_manual( + values = c("cyan", "red", "green", "blue"), + aesthetics = c("fill", "colour") + ) + + expect_equal(get_layer_data(p)$colour, c("cyan", "red", "green")) + expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) +}) + +test_that("scales accept lambda notation for function input", { + check_lambda <- function(items, ggproto) { + vapply(items, function(x) { + f <- environment(ggproto[[x]])$f + is_lambda(f) + }, logical(1)) + } + + # Test continuous scale + scale <- scale_fill_gradient( + limits = ~ .x + c(-1, 1), + breaks = ~ seq(.x[1], .x[2], by = 2), + minor_breaks = ~ seq(.x[1], .x[2], by = 1), + labels = ~ toupper(.x), + rescaler = ~ rescale_mid(.x, mid = 0), + oob = ~ oob_squish(.x, .y, only.finite = FALSE) + ) + check <- check_lambda( + c("limits", "breaks", "minor_breaks", "labels", "rescaler"), + scale + ) + expect_true(all(check)) + + # Test discrete scale + scale <- scale_x_discrete( + limits = ~ rev(.x), + breaks = ~ .x[-1], + labels = ~ toupper(.x) + ) + check <- check_lambda(c("limits", "breaks", "labels"), scale) + expect_true(all(check)) + + # Test binned scale + scale <- scale_fill_steps( + limits = ~ .x + c(-1, 1), + breaks = ~ seq(.x[1], .x[2], by = 2), + labels = ~ toupper(.x), + rescaler = ~ rescale_mid(.x, mid = 0), + oob = ~ oob_squish(.x, .y, only.finite = FALSE) + ) + check <- check_lambda( + c("limits", "breaks", "labels", "rescaler"), + scale + ) + expect_true(all(check)) +}) + +test_that("training incorrectly appropriately communicates the offenders", { + + sc <- scale_colour_viridis_d() + expect_snapshot_error( + sc$train(1:5) + ) + + sc <- scale_colour_viridis_c() + expect_snapshot_error( + sc$train(LETTERS[1:5]) + ) +}) + +test_that("Using `scale_name` prompts deprecation message", { + + expect_snapshot_warning(continuous_scale("x", "foobar", pal_identity())) + expect_snapshot_warning(discrete_scale("x", "foobar", pal_identity())) + expect_snapshot_warning(binned_scale("x", "foobar", pal_identity())) + +}) + +# Continuous scales ------------------------------------------------------- + +test_that("limits with NA are replaced with the min/max of the data for continuous scales", { + make_scale <- function(limits = NULL, data = NULL) { + scale <- continuous_scale("aesthetic", palette = identity, limits = limits) + if (!is.null(data)) { + scale$train(data) + } + scale + } + + # emptiness + expect_true(make_scale()$is_empty()) + expect_false(make_scale(limits = c(0, 1))$is_empty()) + expect_true(make_scale(limits = c(0, NA))$is_empty()) + expect_true(make_scale(limits = c(NA, NA))$is_empty()) + expect_true(make_scale(limits = c(NA, 0))$is_empty()) + + # limits + expect_equal(make_scale(data = 1:5)$get_limits(), c(1, 5)) + expect_equal(make_scale(limits = c(1, 5))$get_limits(), c(1, 5)) + expect_equal(make_scale(limits = c(NA, NA))$get_limits(), c(0, 1)) + expect_equal(make_scale(limits = c(NA, NA), data = 1:5)$get_limits(), c(1, 5)) + expect_equal(make_scale(limits = c(1, NA), data = 1:5)$get_limits(), c(1, 5)) + expect_equal(make_scale(limits = c(NA, 5), data = 1:5)$get_limits(), c(1, 5)) +}) + + +test_that("continuous scales warn about faulty `limits`", { + expect_snapshot(scale_x_continuous(limits = c("A", "B")), error = TRUE) + expect_snapshot(scale_x_continuous(limits = 1:3), error = TRUE) +}) + +# Discrete scales --------------------------------------------------------- + +# From #5623 +test_that("Discrete scales with only NAs return `na.value`", { + + x <- c(NA, NA) + + sc <- scale_colour_discrete(na.value = "red") + sc$train(x) + expect_equal(sc$map(x), c("red", "red")) + + sc <- scale_shape(na.value = NA_real_) + sc$train(x) + expect_equal(sc$map(x), c(NA_real_, NA_real_)) +}) + +test_that("discrete scales work with NAs in arbitrary positions", { + # Prevents intermediate caching of palettes + map <- function(x, limits) { + sc <- scale_colour_manual( + values = c("red", "green", "blue"), + na.value = "gray" + ) + sc$map(x, limits) + } + + # All inputs should yield output regardless of where NA is + input <- c("A", "B", "C", NA) + output <- c("red", "green", "blue", "gray") + + test <- map(input, limits = c("A", "B", "C", NA)) + expect_equal(test, output) + + test <- map(input, limits = c("A", NA, "B", "C")) + expect_equal(test, output) + + test <- map(input, limits = c(NA, "A", "B", "C")) + 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))) +}) + +# Calls ------------------------------------------------------------------- + +test_that("scale functions accurately report their calls", { + + construct <- exprs( + scale_alpha(), + scale_alpha_binned(), + scale_alpha_continuous(), + scale_alpha_date(), + scale_alpha_datetime(), + scale_alpha_discrete(), + scale_alpha_identity(), + scale_alpha_manual(), + scale_alpha_ordinal(), + # Skipping American spelling of 'color' scales here + scale_colour_binned(), + scale_colour_brewer(), + scale_colour_continuous(), + scale_colour_date(), + scale_colour_datetime(), + scale_colour_discrete(), + scale_colour_distiller(), + scale_colour_fermenter(), + scale_colour_gradient(), + scale_colour_gradient2(), + # Some scales have required arguments + scale_colour_gradientn(colours = c("firebrick", "limegreen")), + scale_colour_grey(), + scale_colour_hue(), + scale_colour_identity(), + scale_colour_manual(), + scale_colour_ordinal(), + scale_colour_steps(), + scale_colour_steps2(), + scale_colour_stepsn(colours = c("orchid", "tomato")), + scale_colour_viridis_b(), + scale_colour_viridis_c(), + scale_colour_viridis_d(), + scale_continuous_identity(aesthetics = "foo"), + scale_discrete_identity(aesthetics = "bar"), + scale_discrete_manual(aesthetics = "baz"), + scale_fill_binned(), + scale_fill_brewer(), + scale_fill_continuous(), + scale_fill_date(), + scale_fill_datetime(), + scale_fill_discrete(), + scale_fill_distiller(), + scale_fill_fermenter(), + scale_fill_gradient(), + scale_fill_gradient2(), + scale_fill_gradientn(colours = c("yellow", "green")), + scale_fill_grey(), + scale_fill_hue(), + scale_fill_identity(), + scale_fill_manual(), + scale_fill_ordinal(), + scale_fill_steps(), + scale_fill_steps2(), + scale_fill_stepsn(colours = c("steelblue", "pink")), + scale_fill_viridis_b(), + scale_fill_viridis_c(), + scale_fill_viridis_d(), + scale_linetype(), + scale_linetype_binned(), + # scale_linetype_continuous(), # designed to throw error + scale_linetype_discrete(), + scale_linetype_identity(), + scale_linetype_manual(), + scale_linewidth(), + scale_linewidth_binned(), + scale_linewidth_continuous(), + scale_linewidth_date(), + scale_linewidth_datetime(), + scale_linewidth_discrete(), + scale_linewidth_identity(), + scale_linewidth_manual(), + scale_linewidth_ordinal(), + scale_radius(), + scale_shape(), + scale_shape_binned(), + # scale_shape_continuous(), # designed to throw error + scale_shape_discrete(), + scale_shape_identity(), + scale_shape_manual(), + scale_shape_ordinal(), + scale_size(), + scale_size_area(), + scale_size_binned(), + scale_size_binned_area(), + scale_size_continuous(), + scale_size_date(), + scale_size_datetime(), + scale_size_discrete(), + scale_size_identity(), + scale_size_manual(), + scale_size_ordinal(), + scale_x_binned(), + scale_x_continuous(), + scale_x_date(), + scale_x_datetime(), + scale_x_discrete(), + scale_x_log10(), + scale_x_reverse(), + scale_x_sqrt(), + # scale_x_time(), + scale_y_binned(), + scale_y_continuous(), + scale_y_date(), + scale_y_datetime(), + scale_y_discrete(), + scale_y_log10(), + scale_y_reverse(), + scale_y_sqrt(), + # scale_y_time(), + xlim(10, 20), + ylim("A", "B") + ) + if (is_installed("hms")) { + construct <- c(construct, exprs(scale_x_time(), scale_y_time())) + } + + suppressWarnings( + calls <- lapply(construct, function(x) eval(x)$call) + ) + expect_equal(calls, construct) +}) + +test_that("scale call is found accurately", { + + call_template <- quote(scale_x_continuous(transform = "log10")) + + sc <- do.call("scale_x_continuous", list(transform = "log10")) + expect_equal(sc$call, call_template) + + sc <- inject(scale_x_continuous(!!!list(transform = "log10"))) + expect_equal(sc$call, call_template) + + sc <- exec("scale_x_continuous", transform = "log10") + expect_equal(sc$call, call_template) + + foo <- function() scale_x_continuous(transform = "log10") + expect_equal(foo()$call, call_template) + + env <- new_environment() + env$bar <- function() scale_x_continuous(transform = "log10") + expect_equal(env$bar()$call, call_template) + + # Now should recognise the outer function + scale_x_new <- function() { + scale_x_continuous(transform = "log10") + } + expect_equal( + scale_x_new()$call, + quote(scale_x_new()) + ) +}) + + +# Labels and breaks ------------------------------------------------------- + +test_that("breaks and labels are correctly checked", { + expect_snapshot_error(check_breaks_labels(1:10, letters)) + expect_snapshot_error(scale_x_continuous(breaks = NA)) + p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(minor_breaks = NA) + expect_snapshot_error(ggplot_build(p)) + p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(labels = NA) + expect_snapshot_error(ggplotGrob(p)) + p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(labels = function(x) 1:2) + expect_snapshot_error(ggplotGrob(p)) + expect_snapshot_error(scale_x_discrete(breaks = NA)) + p <- ggplot(mtcars) + geom_bar(aes(factor(gear))) + scale_x_discrete(labels = NA) + expect_snapshot_error(ggplotGrob(p)) + + expect_snapshot_error(scale_x_binned(breaks = NA)) + p <- ggplot(mtcars) + geom_bar(aes(mpg)) + scale_x_binned(labels = NA) + expect_snapshot_error(ggplotGrob(p)) + p <- ggplot(mtcars) + geom_bar(aes(mpg)) + scale_x_binned(labels = function(x) 1:2) + expect_snapshot_error(ggplotGrob(p)) +}) + +test_that("labels match breaks, even when outside limits", { + sc <- scale_y_continuous(breaks = 1:4, labels = 1:4, limits = c(1, 3)) + + expect_equal(sc$get_breaks(), 1:4) + expect_equal(sc$get_labels(), 1:4) + expect_equal(sc$get_breaks_minor(), c(1, 1.5, 2, 2.5, 3)) +}) + +test_that("labels match breaks", { + expect_snapshot(scale_x_discrete(breaks = 1:3, labels = 1:2), error = TRUE) + expect_snapshot(scale_x_continuous(breaks = 1:3, labels = 1:2), error = TRUE) +}) + +test_that("labels don't have to match null breaks", { + expect_silent(check_breaks_labels(breaks = 1:3, labels = NULL)) + expect_silent(check_breaks_labels(breaks = NULL, labels = 1:2)) +}) + +test_that("labels accept expressions", { + labels <- parse(text = paste0(1:4, "^degree")) + sc <- scale_y_continuous(breaks = 1:4, labels = labels, limits = c(1, 3)) + + expect_equal(sc$get_breaks(), 1:4) + expect_equal(sc$get_labels(), as.list(labels)) +}) + +test_that("labels don't have extra spaces", { + labels <- c("a", "abc", "abcdef") + + sc1 <- scale_x_discrete(limits = labels) + sc2 <- scale_fill_discrete(limits = labels) + + expect_equal(sc1$get_labels(), labels) + expect_equal(sc2$get_labels(), labels) +}) + +test_that("out-of-range breaks are dropped", { + + # Limits are explicitly specified, automatic labels + sc <- scale_x_continuous(breaks = 1:5, limits = c(2, 4)) + bi <- sc$break_info() + expect_equal(bi$labels, as.character(2:4)) + expect_equal(bi$major, c(0, 0.5, 1)) + expect_equal(bi$major_source, 2:4) + + # Limits and labels are explicitly specified + sc <- scale_x_continuous(breaks = 1:5, labels = letters[1:5], limits = c(2, 4)) + bi <- sc$break_info() + expect_equal(bi$labels, letters[2:4]) + expect_equal(bi$major, c(0, 0.5, 1)) + expect_equal(bi$major_source, 2:4) + + # Limits are specified, and all breaks are out of range + sc <- scale_x_continuous(breaks = c(1,5), labels = letters[c(1,5)], limits = c(2, 4)) + bi <- sc$break_info() + expect_length(bi$labels, 0) + expect_length(bi$major, 0) + expect_length(bi$major_source, 0) + + # limits aren't specified, automatic labels + # limits are set by the data + sc <- scale_x_continuous(breaks = 1:5) + sc$train_df(data_frame(x = 2:4)) + bi <- sc$break_info() + expect_equal(bi$labels, as.character(2:4)) + expect_equal(bi$major_source, 2:4) + expect_equal(bi$major, c(0, 0.5, 1)) + + # Limits and labels are specified + sc <- scale_x_continuous(breaks = 1:5, labels = letters[1:5]) + sc$train_df(data_frame(x = 2:4)) + bi <- sc$break_info() + expect_equal(bi$labels, letters[2:4]) + expect_equal(bi$major_source, 2:4) + expect_equal(bi$major, c(0, 0.5, 1)) + + # Limits aren't specified, and all breaks are out of range of data + sc <- scale_x_continuous(breaks = c(1,5), labels = letters[c(1,5)]) + sc$train_df(data_frame(x = 2:4)) + bi <- sc$break_info() + expect_length(bi$labels, 0) + expect_length(bi$major, 0) + expect_length(bi$major_source, 0) +}) + +test_that("no minor breaks when only one break", { + sc1 <- scale_x_discrete(limits = "a") + sc2 <- scale_x_continuous(limits = c(1, 1)) + + expect_length(sc1$get_breaks_minor(), 0) + expect_length(sc2$get_breaks_minor(), 0) +}) + +init_scale <- function(...) { + sc <- scale_x_discrete(...) + sc$train(factor(1:100)) + expect_length(sc$get_limits(), 100) + sc +} + +test_that("discrete labels match breaks", { + + sc <- init_scale(breaks = 0:5 * 10) + expect_length(sc$get_breaks(), 5) + expect_length(sc$get_labels(), 5) + expect_equal(sc$get_labels(), sc$get_breaks(), ignore_attr = TRUE) + + sc <- init_scale(breaks = 0:5 * 10, labels = letters[1:6]) + expect_length(sc$get_breaks(), 5) + expect_length(sc$get_labels(), 5) + expect_equal(sc$get_labels(), letters[2:6]) + + sc <- init_scale(breaks = 0:5 * 10, labels = + function(x) paste(x, "-", sep = "")) + expect_equal(sc$get_labels(), c("10-", "20-", "30-", "40-", "50-")) + + pick_5 <- function(x) sample(x, 5) + sc <- init_scale(breaks = pick_5) + expect_length(sc$get_breaks(), 5) + expect_length(sc$get_labels(), 5) +}) + +test_that("scale breaks work with numeric log transformation", { + sc <- scale_x_continuous(limits = c(1, 1e5), transform = transform_log10()) + expect_equal(sc$get_breaks(), c(0, 2, 4)) # 1, 100, 10000 + expect_equal(sc$get_breaks_minor(), c(0, 1, 2, 3, 4, 5)) +}) + +test_that("continuous scales with no data have no breaks or labels", { + sc <- scale_x_continuous() + + expect_equal(sc$get_breaks(), numeric()) + expect_equal(sc$get_labels(), character()) + expect_equal(sc$get_limits(), c(0, 1)) +}) + +test_that("discrete scales with no data have no breaks or labels", { + sc <- scale_x_discrete() + + expect_equal(sc$get_breaks(), numeric()) + expect_equal(sc$get_labels(), character()) + expect_equal(sc$get_limits(), c(0, 1)) +}) + +test_that("passing continuous limits to a discrete scale generates a warning", { + expect_snapshot_warning(scale_x_discrete(limits = 1:3)) +}) + +test_that("suppressing breaks, minor_breask, and labels works", { + expect_null(scale_x_continuous(breaks = NULL, limits = c(1, 3))$get_breaks()) + expect_null(scale_x_discrete(breaks = NULL, limits = c("one", "three"))$get_breaks()) + expect_null(scale_x_continuous(minor_breaks = NULL, limits = c(1, 3))$get_breaks_minor()) + + expect_null(scale_x_continuous(labels = NULL, limits = c(1, 3))$get_labels()) + expect_null(scale_x_discrete(labels = NULL, limits = c("one", "three"))$get_labels()) + + # date, datetime + lims <- as.Date(c("2000/1/1", "2000/2/1")) + expect_null(scale_x_date(breaks = NULL, limits = lims)$get_breaks()) + # NA is defunct, should throw error + expect_snapshot( + scale_x_date(breaks = NA, limits = lims)$get_breaks(), + error = TRUE + ) + expect_null(scale_x_date(labels = NULL, limits = lims)$get_labels()) + expect_snapshot( + scale_x_date(labels = NA, limits = lims)$get_labels(), + error = TRUE + ) + expect_null(scale_x_date(minor_breaks = NULL, limits = lims)$get_breaks_minor()) + expect_snapshot( + scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor(), + error = TRUE + ) + + # date, datetime + lims <- as.POSIXct(c("2000/1/1 0:0:0", "2010/1/1 0:0:0")) + expect_null(scale_x_datetime(breaks = NULL, limits = lims)$get_breaks()) + expect_snapshot( + scale_x_datetime(breaks = NA, limits = lims)$get_breaks(), + error = TRUE + ) + expect_null(scale_x_datetime(labels = NULL, limits = lims)$get_labels()) + expect_snapshot( + scale_x_datetime(labels = NA, limits = lims)$get_labels(), + error = TRUE + ) + expect_null(scale_x_datetime(minor_breaks = NULL, limits = lims)$get_breaks_minor()) + expect_snapshot( + scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor(), + error = TRUE + ) +}) + +test_that("scale_breaks with explicit NA options (deprecated)", { + # NA is defunct, should throw error + expect_error(scale_x_continuous(breaks = NA)) + expect_error(scale_y_continuous(breaks = NA)) + expect_error(scale_alpha_continuous(breaks = NA)) + expect_error(scale_size_continuous(breaks = NA)) + expect_error(scale_fill_continuous(breaks = NA)) + expect_error(scale_colour_continuous(breaks = NA)) +}) + +test_that("breaks can be specified by names of labels", { + labels <- setNames(LETTERS[1:4], letters[1:4]) + + s <- scale_x_discrete(limits = letters[1:4], labels = labels) + expect_equal(as.vector(s$get_breaks()), letters[1:4]) + expect_equal(as.vector(s$get_labels()), LETTERS[1:4]) + + s <- scale_x_discrete(limits = letters[1:4], labels = rev(labels)) + expect_equal(as.vector(s$get_breaks()), letters[1:4]) + expect_equal(as.vector(s$get_labels()), LETTERS[1:4]) + + s <- scale_x_discrete(limits = letters[1:4], labels = labels[1:2]) + expect_equal(as.vector(s$get_breaks()), letters[1:4]) + expect_equal(as.vector(s$get_labels()), c("A", "B", "c", "d")) + + s <- scale_x_discrete(limits = letters[1:4], labels = labels[3:4]) + expect_equal(as.vector(s$get_breaks()), letters[1:4]) + expect_equal(as.vector(s$get_labels()), c("a", "b", "C", "D")) + + s <- scale_x_discrete(limits = letters[1:3], labels = labels) + expect_equal(as.vector(s$get_breaks()), letters[1:3]) + expect_equal(as.vector(s$get_labels()), LETTERS[1:3]) +}) + +test_that("only finite or NA values for breaks for transformed scales (#871)", { + sc <- scale_y_continuous(limits = c(0.01, 0.99), transform = "probit", + breaks = seq(0, 1, 0.2)) + breaks <- sc$break_info()$major_source + expect_true(all(is.finite(breaks) | is.na(breaks))) +}) + +test_that("minor breaks are transformed by scales", { + sc <- scale_y_continuous(limits = c(1, 100), transform = "log10", + minor_breaks = c(1, 10, 100)) + + expect_equal(sc$get_breaks_minor(), c(0, 1, 2)) +}) + +test_that("continuous limits accepts functions", { + p <- ggplot(mpg, aes(class, hwy)) + + scale_y_continuous(limits = function(lims) (c(lims[1] - 10, lims[2] + 100))) + + expect_equal( + get_panel_scales(p)$y$get_limits(), + c(range(mpg$hwy)[1] - 10, range(mpg$hwy)[2] + 100) + ) +}) + +test_that("equal length breaks and labels can be passed to ViewScales with limits", { + + test_scale <- scale_x_continuous( + breaks = c(0, 20, 40), + labels = c("0", "20", "40"), + limits = c(10, 30) + ) + + expect_identical(test_scale$get_breaks(), c(0, 20, 40)) + expect_identical(test_scale$get_labels(), c(c("0", "20", "40"))) + + test_view_scale <- view_scale_primary(test_scale) + expect_identical(test_view_scale$get_breaks(), c(NA, 20, NA)) + expect_identical(test_view_scale$get_labels(), c(c("0", "20", "40"))) + + # ViewScale accepts the limits in the opposite order (#3952) + test_view_scale_rev <- view_scale_primary(test_scale, limits = rev(test_scale$get_limits())) + expect_identical(test_view_scale_rev$get_breaks(), c(NA, 20, NA)) + expect_identical(test_view_scale_rev$get_labels(), c(c("0", "20", "40"))) +}) + +test_that("break names are returned as labels", { + + sc <- scale_x_continuous(breaks = c(A = 10, B = 20, C = 30)) + sc$train(c(10, 30)) + expect_equal(sc$get_labels(), c("A", "B", "C")) + + sc <- scale_x_discrete(breaks = c(foo = "A", bar = "B", qux = "C")) + sc$train(c(LETTERS[1:3])) + expect_equal(sc$get_labels(), c("foo", "bar", "qux")) +}) + +test_that("numeric scale transforms can produce breaks", { + + test_breaks <- function(transform, limits) { + scale <- scale_x_continuous(transform = transform) + scale$train(scale$transform(limits)) + view <- view_scale_primary(scale) + scale$get_transformation()$inverse(view$get_breaks()) + } + + 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_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))) +}) + + +# Visual tests ------------------------------------------------------------ + +test_that("minor breaks draw correctly", { + df <- data_frame( + x_num = c(1, 3), + x_chr = c("a", "b"), + x_date = as.Date("2012-2-29") + c(0, 100), + x_log = c(1, 1e4), + y = c(1, 3) + ) + theme <- theme_test() + + theme( + panel.grid.major = element_line(colour = "grey30", linewidth = 0.5), + panel.grid.minor = element_line(colour = "grey70") + ) + + p <- ggplot(df, aes(x_num, y)) + + geom_blank() + + scale_x_continuous(breaks = 1:3, minor_breaks = c(1.25, 2.75)) + + scale_y_continuous(breaks = 1:3, minor_breaks = c(1.25, 2.75)) + + labs(x = NULL, y = NULL) + + theme + expect_doppelganger("numeric", p) + expect_doppelganger("numeric-polar", p + coord_polar()) + + expect_doppelganger("numeric-log", + ggplot(df, aes(x_log, x_log)) + + scale_x_continuous(transform = transform_log2()) + + scale_y_log10() + + labs(x = NULL, y = NULL) + + theme + ) + expect_doppelganger("numeric-exp", + ggplot(df, aes(x_num, x_num)) + + scale_x_continuous(transform = transform_exp(2)) + + scale_y_continuous(transform = transform_exp(2)) + + labs(x = NULL, y = NULL) + + theme + ) + + expect_doppelganger("character", + ggplot(df, aes(x_chr, y)) + + geom_blank() + + labs(x = NULL, y = NULL) + + theme + ) + + expect_doppelganger("date", + ggplot(df, aes(x_date, y)) + + geom_blank() + + scale_x_date( + labels = scales::label_date("%m/%d"), + breaks = scales::date_breaks("month"), + minor_breaks = scales::date_breaks("week") + ) + + labs(x = NULL, y = NULL) + + theme + ) +}) + +test_that("scale breaks can be removed", { + dat <- data_frame(x = 1:3, y = 1:3) + + expect_doppelganger("no x breaks", + ggplot(dat, aes(x = x, y = y)) + geom_point() + scale_x_continuous(breaks = NULL) + ) + expect_doppelganger("no y breaks", + ggplot(dat, aes(x = x, y = y)) + geom_point() + scale_y_continuous(breaks = NULL) + ) + expect_doppelganger("no alpha breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, alpha = x)) + geom_point() + scale_alpha_continuous(breaks = NULL) + ) + expect_doppelganger("no size breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, size = x)) + geom_point() + scale_size_continuous(breaks = NULL) + ) + expect_doppelganger("no fill breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, fill = x)) + geom_point(shape = 21) + scale_fill_continuous(breaks = NULL) + ) + expect_doppelganger("no colour breaks (no legend)", + ggplot(dat, aes(x = 1, y = y, colour = x)) + geom_point() + scale_colour_continuous(breaks = NULL) + ) +}) + +test_that("functional limits work for continuous scales", { + limiter <- function(by) { + function(limits) { + low <- floor(limits[1] / by) * by + high <- ceiling(limits[2] / by) * by + c(low, high) + } + } + + expect_doppelganger( + "functional limits", + ggplot(mpg, aes(class)) + geom_bar(aes(fill = drv)) + scale_y_continuous(limits = limiter(50)) + ) +}) + +test_that("limits are squished to transformation domain", { + # Breaks should not be calculated on ranges outside domain #980 + sc1 <- scale_x_sqrt() + sc2 <- scale_x_sqrt() + sc3 <- scale_x_reverse(breaks = 1:9) # Test for #4858 + + sc1$train(c(0, 10)) + sc2$train(c(-10, 10)) + sc3$train(c(0, -10)) # training expects transformed input + + expect_equal(sc1$get_breaks(), sc2$get_breaks()) + expect_equal(sc2$get_breaks()[1], 0) + expect_equal(sc3$get_breaks(), -1:-9) +}) diff --git a/tests/testthat/test-scale-colour.R b/tests/testthat/test-scale-colour.R index 0828e358ee..606ddd566b 100644 --- a/tests/testthat/test-scale-colour.R +++ b/tests/testthat/test-scale-colour.R @@ -72,3 +72,15 @@ test_that("`name` is directed correctly (#6623)", { test_that("backwards compatibility allows trailing args (#6710)", { expect_no_error(scale_fill_discrete(breaks = 1:2, direction = -1L, )) }) + +test_that("All scale_colour_*() have their American versions", { + # In testthat, the package env contains non-exported functions as well so we + # need to parse NAMESPACE file by ourselves + exports <- readLines(system.file("NAMESPACE", package = "ggplot2")) + colour_scale_exports <- grep("export\\(scale_colour_.*\\)", exports, value = TRUE) + color_scale_exports <- grep("export\\(scale_color_.*\\)", exports, value = TRUE) + expect_equal( + colour_scale_exports, + sub("color", "colour", color_scale_exports) + ) +}) diff --git a/tests/testthat/test-scale-continuous.R b/tests/testthat/test-scale-continuous.R new file mode 100644 index 0000000000..4e98f68760 --- /dev/null +++ b/tests/testthat/test-scale-continuous.R @@ -0,0 +1,67 @@ +test_that("position scales are updated by all position aesthetics", { + df <- data_frame(x = 1:3, y = 1:3) + + aesthetics <- list( + aes(xend = x, yend = x), + aes(xmin = x, ymin = x), + aes(xmax = x, ymax = x), + aes(xintercept = x, yintercept = y) + ) + + base <- ggplot(df, aes(x = 1, y = 1)) + geom_point() + plots <- lapply(aesthetics, ggplot_add, plot = base) + ranges <- lapply(plots, pranges) + + lapply(ranges, function(range) { + expect_equal(range$x[[1]], c(1, 3)) + expect_equal(range$y[[1]], c(1, 3)) + }) +}) + +test_that("oob affects position values", { + dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) + base <- ggplot(dat, aes(x, y)) + + geom_col() + + annotate("point", x = "a", y = c(-Inf, Inf)) + + y_scale <- function(limits, oob = censor) { + scale_y_continuous(limits = limits, oob = oob, expand = c(0, 0)) + } + base + scale_y_continuous(limits = c(-0,5)) + + low_censor <- cdata(base + y_scale(c(0, 5), censor)) + mid_censor <- cdata(base + y_scale(c(3, 7), censor)) + handle <- GeomBar$handle_na + + expect_snapshot_warning( + low_censor[[1]] <- handle(low_censor[[1]], list(na.rm = FALSE)), + ) + expect_snapshot_warning( + mid_censor[[1]] <- handle(mid_censor[[1]], list(na.rm = FALSE)), + ) + + low_squish <- cdata(base + y_scale(c(0, 5), squish)) + mid_squish <- cdata(base + y_scale(c(3, 7), squish)) + + # Points are always at the top and bottom + expect_equal(low_censor[[2]]$y, c(0, 1)) + expect_equal(mid_censor[[2]]$y, c(0, 1)) + expect_equal(low_squish[[2]]$y, c(0, 1)) + expect_equal(mid_squish[[2]]$y, c(0, 1)) + + # Bars depend on limits and oob + expect_equal(low_censor[[1]]$y, c(0.2, 1)) + expect_equal(mid_censor[[1]]$y, numeric(0)) + expect_equal(low_squish[[1]]$y, c(0.2, 1, 1)) + expect_equal(mid_squish[[1]]$y, c(0, 0.5, 1)) +}) + +test_that("scales warn when transforms introduces non-finite values", { + df <- data_frame(x = c(1e1, 1e5), y = c(0, 100)) + + p <- ggplot(df, aes(x, y)) + + geom_point(size = 5) + + scale_y_log10() + + expect_snapshot_warning(ggplot_build(p)) +}) diff --git a/tests/testthat/test-scale-identity.R b/tests/testthat/test-scale-identity.R new file mode 100644 index 0000000000..ade8e3528b --- /dev/null +++ b/tests/testthat/test-scale-identity.R @@ -0,0 +1,30 @@ +test_that("identity scale preserves input values", { + df <- data_frame(x = 1:3, z = factor(letters[1:3])) + + # aesthetic-specific scales + p1 <- ggplot(df, + aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x)) + + geom_point() + + scale_colour_identity() + + scale_fill_identity() + + scale_shape_identity() + + scale_size_identity() + + scale_alpha_identity() + d1 <- get_layer_data(p1) + + expect_equal(d1$colour, as.character(df$z)) + expect_equal(d1$fill, as.character(df$z)) + expect_equal(d1$shape, as.character(df$z)) + expect_equal(d1$size, as.numeric(df$z)) + expect_equal(d1$alpha, as.numeric(df$z)) + + # generic scales + p2 <- ggplot(df, + aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x)) + + geom_point() + + scale_discrete_identity(aesthetics = c("colour", "fill", "shape")) + + scale_continuous_identity(aesthetics = c("size", "alpha")) + d2 <- get_layer_data(p2) + + expect_equal(d1, d2) +}) diff --git a/tests/testthat/test-scale-view.R b/tests/testthat/test-scale-view.R new file mode 100644 index 0000000000..731d424865 --- /dev/null +++ b/tests/testthat/test-scale-view.R @@ -0,0 +1,25 @@ +test_that("ViewScales can make fixed copies", { + + p1 <- ggplot(mpg, aes(drv, displ)) + + geom_boxplot() + + annotate("point", x = 5, y = 10) + + scale_x_discrete(labels = c("four-wheel", "forward", "reverse")) + + b1 <- ggplot_build(p1)@layout$panel_params[[1]] + + # We build a second plot with the first plot's scales + p2 <- ggplot(mpg, aes(drv, cyl)) + + geom_violin() + + annotate("point", x = 15, y = 100) + + b1$x$make_fixed_copy() + + b1$y$make_fixed_copy() + b2 <- ggplot_build(p2) + + # Breaks and labels should respect p1's limits + x <- get_guide_data(b2, "x") + expect_equal(x$x, 0.6:2.6 / diff(b1$x.range)) + expect_equal(x$.label, c("four-wheel", "forward", "reverse")) + + y <- get_guide_data(b2, "y") + expect_equal(y$y, rescale(seq(2.5, 10, by = 2.5), from = b1$y.range)) +}) diff --git a/tests/testthat/test-scales-breaks-labels.R b/tests/testthat/test-scales-breaks-labels.R deleted file mode 100644 index 70a7e0ddcb..0000000000 --- a/tests/testthat/test-scales-breaks-labels.R +++ /dev/null @@ -1,396 +0,0 @@ -test_that("labels match breaks, even when outside limits", { - sc <- scale_y_continuous(breaks = 1:4, labels = 1:4, limits = c(1, 3)) - - expect_equal(sc$get_breaks(), 1:4) - expect_equal(sc$get_labels(), 1:4) - expect_equal(sc$get_breaks_minor(), c(1, 1.5, 2, 2.5, 3)) -}) - -test_that("labels match breaks", { - expect_snapshot(scale_x_discrete(breaks = 1:3, labels = 1:2), error = TRUE) - expect_snapshot(scale_x_continuous(breaks = 1:3, labels = 1:2), error = TRUE) -}) - -test_that("labels don't have to match null breaks", { - expect_silent(check_breaks_labels(breaks = 1:3, labels = NULL)) - expect_silent(check_breaks_labels(breaks = NULL, labels = 1:2)) -}) - -test_that("labels accept expressions", { - labels <- parse(text = paste0(1:4, "^degree")) - sc <- scale_y_continuous(breaks = 1:4, labels = labels, limits = c(1, 3)) - - expect_equal(sc$get_breaks(), 1:4) - expect_equal(sc$get_labels(), as.list(labels)) -}) - -test_that("labels don't have extra spaces", { - labels <- c("a", "abc", "abcdef") - - sc1 <- scale_x_discrete(limits = labels) - sc2 <- scale_fill_discrete(limits = labels) - - expect_equal(sc1$get_labels(), labels) - expect_equal(sc2$get_labels(), labels) -}) - -test_that("out-of-range breaks are dropped", { - - # Limits are explicitly specified, automatic labels - sc <- scale_x_continuous(breaks = 1:5, limits = c(2, 4)) - bi <- sc$break_info() - expect_equal(bi$labels, as.character(2:4)) - expect_equal(bi$major, c(0, 0.5, 1)) - expect_equal(bi$major_source, 2:4) - - # Limits and labels are explicitly specified - sc <- scale_x_continuous(breaks = 1:5, labels = letters[1:5], limits = c(2, 4)) - bi <- sc$break_info() - expect_equal(bi$labels, letters[2:4]) - expect_equal(bi$major, c(0, 0.5, 1)) - expect_equal(bi$major_source, 2:4) - - # Limits are specified, and all breaks are out of range - sc <- scale_x_continuous(breaks = c(1,5), labels = letters[c(1,5)], limits = c(2, 4)) - bi <- sc$break_info() - expect_length(bi$labels, 0) - expect_length(bi$major, 0) - expect_length(bi$major_source, 0) - - # limits aren't specified, automatic labels - # limits are set by the data - sc <- scale_x_continuous(breaks = 1:5) - sc$train_df(data_frame(x = 2:4)) - bi <- sc$break_info() - expect_equal(bi$labels, as.character(2:4)) - expect_equal(bi$major_source, 2:4) - expect_equal(bi$major, c(0, 0.5, 1)) - - # Limits and labels are specified - sc <- scale_x_continuous(breaks = 1:5, labels = letters[1:5]) - sc$train_df(data_frame(x = 2:4)) - bi <- sc$break_info() - expect_equal(bi$labels, letters[2:4]) - expect_equal(bi$major_source, 2:4) - expect_equal(bi$major, c(0, 0.5, 1)) - - # Limits aren't specified, and all breaks are out of range of data - sc <- scale_x_continuous(breaks = c(1,5), labels = letters[c(1,5)]) - sc$train_df(data_frame(x = 2:4)) - bi <- sc$break_info() - expect_length(bi$labels, 0) - expect_length(bi$major, 0) - expect_length(bi$major_source, 0) -}) - -test_that("no minor breaks when only one break", { - sc1 <- scale_x_discrete(limits = "a") - sc2 <- scale_x_continuous(limits = c(1, 1)) - - expect_length(sc1$get_breaks_minor(), 0) - expect_length(sc2$get_breaks_minor(), 0) -}) - -init_scale <- function(...) { - sc <- scale_x_discrete(...) - sc$train(factor(1:100)) - expect_length(sc$get_limits(), 100) - sc -} - -test_that("discrete labels match breaks", { - - sc <- init_scale(breaks = 0:5 * 10) - expect_length(sc$get_breaks(), 5) - expect_length(sc$get_labels(), 5) - expect_equal(sc$get_labels(), sc$get_breaks(), ignore_attr = TRUE) - - sc <- init_scale(breaks = 0:5 * 10, labels = letters[1:6]) - expect_length(sc$get_breaks(), 5) - expect_length(sc$get_labels(), 5) - expect_equal(sc$get_labels(), letters[2:6]) - - sc <- init_scale(breaks = 0:5 * 10, labels = - function(x) paste(x, "-", sep = "")) - expect_equal(sc$get_labels(), c("10-", "20-", "30-", "40-", "50-")) - - pick_5 <- function(x) sample(x, 5) - sc <- init_scale(breaks = pick_5) - expect_length(sc$get_breaks(), 5) - expect_length(sc$get_labels(), 5) -}) - -test_that("scale breaks work with numeric log transformation", { - sc <- scale_x_continuous(limits = c(1, 1e5), transform = transform_log10()) - expect_equal(sc$get_breaks(), c(0, 2, 4)) # 1, 100, 10000 - expect_equal(sc$get_breaks_minor(), c(0, 1, 2, 3, 4, 5)) -}) - -test_that("continuous scales with no data have no breaks or labels", { - sc <- scale_x_continuous() - - expect_equal(sc$get_breaks(), numeric()) - expect_equal(sc$get_labels(), character()) - expect_equal(sc$get_limits(), c(0, 1)) -}) - -test_that("discrete scales with no data have no breaks or labels", { - sc <- scale_x_discrete() - - expect_equal(sc$get_breaks(), numeric()) - expect_equal(sc$get_labels(), character()) - expect_equal(sc$get_limits(), c(0, 1)) -}) - -test_that("passing continuous limits to a discrete scale generates a warning", { - expect_snapshot_warning(scale_x_discrete(limits = 1:3)) -}) - -test_that("suppressing breaks, minor_breask, and labels works", { - expect_null(scale_x_continuous(breaks = NULL, limits = c(1, 3))$get_breaks()) - expect_null(scale_x_discrete(breaks = NULL, limits = c("one", "three"))$get_breaks()) - expect_null(scale_x_continuous(minor_breaks = NULL, limits = c(1, 3))$get_breaks_minor()) - - expect_null(scale_x_continuous(labels = NULL, limits = c(1, 3))$get_labels()) - expect_null(scale_x_discrete(labels = NULL, limits = c("one", "three"))$get_labels()) - - # date, datetime - lims <- as.Date(c("2000/1/1", "2000/2/1")) - expect_null(scale_x_date(breaks = NULL, limits = lims)$get_breaks()) - # NA is defunct, should throw error - expect_snapshot( - scale_x_date(breaks = NA, limits = lims)$get_breaks(), - error = TRUE - ) - expect_null(scale_x_date(labels = NULL, limits = lims)$get_labels()) - expect_snapshot( - scale_x_date(labels = NA, limits = lims)$get_labels(), - error = TRUE - ) - expect_null(scale_x_date(minor_breaks = NULL, limits = lims)$get_breaks_minor()) - expect_snapshot( - scale_x_date(minor_breaks = NA, limits = lims)$get_breaks_minor(), - error = TRUE - ) - - # date, datetime - lims <- as.POSIXct(c("2000/1/1 0:0:0", "2010/1/1 0:0:0")) - expect_null(scale_x_datetime(breaks = NULL, limits = lims)$get_breaks()) - expect_snapshot( - scale_x_datetime(breaks = NA, limits = lims)$get_breaks(), - error = TRUE - ) - expect_null(scale_x_datetime(labels = NULL, limits = lims)$get_labels()) - expect_snapshot( - scale_x_datetime(labels = NA, limits = lims)$get_labels(), - error = TRUE - ) - expect_null(scale_x_datetime(minor_breaks = NULL, limits = lims)$get_breaks_minor()) - expect_snapshot( - scale_x_datetime(minor_breaks = NA, limits = lims)$get_breaks_minor(), - error = TRUE - ) -}) - -test_that("scale_breaks with explicit NA options (deprecated)", { - # NA is defunct, should throw error - expect_error(scale_x_continuous(breaks = NA)) - expect_error(scale_y_continuous(breaks = NA)) - expect_error(scale_alpha_continuous(breaks = NA)) - expect_error(scale_size_continuous(breaks = NA)) - expect_error(scale_fill_continuous(breaks = NA)) - expect_error(scale_colour_continuous(breaks = NA)) -}) - -test_that("breaks can be specified by names of labels", { - labels <- setNames(LETTERS[1:4], letters[1:4]) - - s <- scale_x_discrete(limits = letters[1:4], labels = labels) - expect_equal(as.vector(s$get_breaks()), letters[1:4]) - expect_equal(as.vector(s$get_labels()), LETTERS[1:4]) - - s <- scale_x_discrete(limits = letters[1:4], labels = rev(labels)) - expect_equal(as.vector(s$get_breaks()), letters[1:4]) - expect_equal(as.vector(s$get_labels()), LETTERS[1:4]) - - s <- scale_x_discrete(limits = letters[1:4], labels = labels[1:2]) - expect_equal(as.vector(s$get_breaks()), letters[1:4]) - expect_equal(as.vector(s$get_labels()), c("A", "B", "c", "d")) - - s <- scale_x_discrete(limits = letters[1:4], labels = labels[3:4]) - expect_equal(as.vector(s$get_breaks()), letters[1:4]) - expect_equal(as.vector(s$get_labels()), c("a", "b", "C", "D")) - - s <- scale_x_discrete(limits = letters[1:3], labels = labels) - expect_equal(as.vector(s$get_breaks()), letters[1:3]) - expect_equal(as.vector(s$get_labels()), LETTERS[1:3]) -}) - -test_that("only finite or NA values for breaks for transformed scales (#871)", { - sc <- scale_y_continuous(limits = c(0.01, 0.99), transform = "probit", - breaks = seq(0, 1, 0.2)) - breaks <- sc$break_info()$major_source - expect_true(all(is.finite(breaks) | is.na(breaks))) -}) - -test_that("minor breaks are transformed by scales", { - sc <- scale_y_continuous(limits = c(1, 100), transform = "log10", - minor_breaks = c(1, 10, 100)) - - expect_equal(sc$get_breaks_minor(), c(0, 1, 2)) -}) - -test_that("continuous limits accepts functions", { - p <- ggplot(mpg, aes(class, hwy)) + - scale_y_continuous(limits = function(lims) (c(lims[1] - 10, lims[2] + 100))) - - expect_equal( - get_panel_scales(p)$y$get_limits(), - c(range(mpg$hwy)[1] - 10, range(mpg$hwy)[2] + 100) - ) -}) - -test_that("equal length breaks and labels can be passed to ViewScales with limits", { - - test_scale <- scale_x_continuous( - breaks = c(0, 20, 40), - labels = c("0", "20", "40"), - limits = c(10, 30) - ) - - expect_identical(test_scale$get_breaks(), c(0, 20, 40)) - expect_identical(test_scale$get_labels(), c(c("0", "20", "40"))) - - test_view_scale <- view_scale_primary(test_scale) - expect_identical(test_view_scale$get_breaks(), c(NA, 20, NA)) - expect_identical(test_view_scale$get_labels(), c(c("0", "20", "40"))) - - # ViewScale accepts the limits in the opposite order (#3952) - test_view_scale_rev <- view_scale_primary(test_scale, limits = rev(test_scale$get_limits())) - expect_identical(test_view_scale_rev$get_breaks(), c(NA, 20, NA)) - expect_identical(test_view_scale_rev$get_labels(), c(c("0", "20", "40"))) -}) - -test_that("break names are returned as labels", { - - sc <- scale_x_continuous(breaks = c(A = 10, B = 20, C = 30)) - sc$train(c(10, 30)) - expect_equal(sc$get_labels(), c("A", "B", "C")) - - sc <- scale_x_discrete(breaks = c(foo = "A", bar = "B", qux = "C")) - sc$train(c(LETTERS[1:3])) - expect_equal(sc$get_labels(), c("foo", "bar", "qux")) -}) - -# Visual tests ------------------------------------------------------------ - -test_that("minor breaks draw correctly", { - df <- data_frame( - x_num = c(1, 3), - x_chr = c("a", "b"), - x_date = as.Date("2012-2-29") + c(0, 100), - x_log = c(1, 1e4), - y = c(1, 3) - ) - theme <- theme_test() + - theme( - panel.grid.major = element_line(colour = "grey30", linewidth = 0.5), - panel.grid.minor = element_line(colour = "grey70") - ) - - p <- ggplot(df, aes(x_num, y)) + - geom_blank() + - scale_x_continuous(breaks = 1:3, minor_breaks = c(1.25, 2.75)) + - scale_y_continuous(breaks = 1:3, minor_breaks = c(1.25, 2.75)) + - labs(x = NULL, y = NULL) + - theme - expect_doppelganger("numeric", p) - expect_doppelganger("numeric-polar", p + coord_polar()) - - expect_doppelganger("numeric-log", - ggplot(df, aes(x_log, x_log)) + - scale_x_continuous(transform = transform_log2()) + - scale_y_log10() + - labs(x = NULL, y = NULL) + - theme - ) - expect_doppelganger("numeric-exp", - ggplot(df, aes(x_num, x_num)) + - scale_x_continuous(transform = transform_exp(2)) + - scale_y_continuous(transform = transform_exp(2)) + - labs(x = NULL, y = NULL) + - theme - ) - - expect_doppelganger("character", - ggplot(df, aes(x_chr, y)) + - geom_blank() + - labs(x = NULL, y = NULL) + - theme - ) - - expect_doppelganger("date", - ggplot(df, aes(x_date, y)) + - geom_blank() + - scale_x_date( - labels = scales::label_date("%m/%d"), - breaks = scales::date_breaks("month"), - minor_breaks = scales::date_breaks("week") - ) + - labs(x = NULL, y = NULL) + - theme - ) -}) - -test_that("scale breaks can be removed", { - dat <- data_frame(x = 1:3, y = 1:3) - - expect_doppelganger("no x breaks", - ggplot(dat, aes(x = x, y = y)) + geom_point() + scale_x_continuous(breaks = NULL) - ) - expect_doppelganger("no y breaks", - ggplot(dat, aes(x = x, y = y)) + geom_point() + scale_y_continuous(breaks = NULL) - ) - expect_doppelganger("no alpha breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, alpha = x)) + geom_point() + scale_alpha_continuous(breaks = NULL) - ) - expect_doppelganger("no size breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, size = x)) + geom_point() + scale_size_continuous(breaks = NULL) - ) - expect_doppelganger("no fill breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, fill = x)) + geom_point(shape = 21) + scale_fill_continuous(breaks = NULL) - ) - expect_doppelganger("no colour breaks (no legend)", - ggplot(dat, aes(x = 1, y = y, colour = x)) + geom_point() + scale_colour_continuous(breaks = NULL) - ) -}) - -test_that("functional limits work for continuous scales", { - limiter <- function(by) { - function(limits) { - low <- floor(limits[1] / by) * by - high <- ceiling(limits[2] / by) * by - c(low, high) - } - } - - expect_doppelganger( - "functional limits", - ggplot(mpg, aes(class)) + geom_bar(aes(fill = drv)) + scale_y_continuous(limits = limiter(50)) - ) -}) - -test_that("limits are squished to transformation domain", { - # Breaks should not be calculated on ranges outside domain #980 - sc1 <- scale_x_sqrt() - sc2 <- scale_x_sqrt() - sc3 <- scale_x_reverse(breaks = 1:9) # Test for #4858 - - sc1$train(c(0, 10)) - sc2$train(c(-10, 10)) - sc3$train(c(0, -10)) # training expects transformed input - - expect_equal(sc1$get_breaks(), sc2$get_breaks()) - expect_equal(sc2$get_breaks()[1], 0) - expect_equal(sc3$get_breaks(), -1:-9) -}) diff --git a/tests/testthat/test-scales.R b/tests/testthat/test-scales.R index 4be77ae371..faed08e180 100644 --- a/tests/testthat/test-scales.R +++ b/tests/testthat/test-scales.R @@ -8,89 +8,6 @@ test_that("building a plot does not affect its scales", { expect_length(p@scales$scales, 0) }) -test_that("ranges update only for variables listed in aesthetics", { - sc <- scale_alpha() - - sc$train_df(data_frame(alpha = 1:10)) - expect_equal(sc$range$range, c(1, 10)) - - sc$train_df(data_frame(alpha = 50)) - expect_equal(sc$range$range, c(1, 50)) - - sc$train_df(data_frame(beta = 100)) - expect_equal(sc$range$range, c(1, 50)) - - sc$train_df(data_frame()) - expect_equal(sc$range$range, c(1, 50)) -}) - -test_that("mapping works", { - sc <- scale_alpha(range = c(0, 1), na.value = 0) - sc$train_df(data_frame(alpha = 1:10)) - - expect_equal( - sc$map_df(data_frame(alpha = 1:10))[[1]], - seq(0, 1, length.out = 10) - ) - - expect_equal(sc$map_df(data_frame(alpha = NA))[[1]], 0) - - expect_equal( - sc$map_df(data_frame(alpha = c(-10, 11)))[[1]], - c(0, 0)) -}) - -test_that("identity scale preserves input values", { - df <- data_frame(x = 1:3, z = factor(letters[1:3])) - - # aesthetic-specific scales - p1 <- ggplot(df, - aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x)) + - geom_point() + - scale_colour_identity() + - scale_fill_identity() + - scale_shape_identity() + - scale_size_identity() + - scale_alpha_identity() - d1 <- get_layer_data(p1) - - expect_equal(d1$colour, as.character(df$z)) - expect_equal(d1$fill, as.character(df$z)) - expect_equal(d1$shape, as.character(df$z)) - expect_equal(d1$size, as.numeric(df$z)) - expect_equal(d1$alpha, as.numeric(df$z)) - - # generic scales - p2 <- ggplot(df, - aes(x, z, colour = z, fill = z, shape = z, size = x, alpha = x)) + - geom_point() + - scale_discrete_identity(aesthetics = c("colour", "fill", "shape")) + - scale_continuous_identity(aesthetics = c("size", "alpha")) - d2 <- get_layer_data(p2) - - expect_equal(d1, d2) -}) - -test_that("position scales are updated by all position aesthetics", { - df <- data_frame(x = 1:3, y = 1:3) - - aesthetics <- list( - aes(xend = x, yend = x), - aes(xmin = x, ymin = x), - aes(xmax = x, ymax = x), - aes(xintercept = x, yintercept = y) - ) - - base <- ggplot(df, aes(x = 1, y = 1)) + geom_point() - plots <- lapply(aesthetics, ggplot_add, plot = base) - ranges <- lapply(plots, pranges) - - lapply(ranges, function(range) { - expect_equal(range$x[[1]], c(1, 3)) - expect_equal(range$y[[1]], c(1, 3)) - }) -}) - test_that("position scales generate after stats", { df <- data_frame(x = factor(c(1, 1, 1))) plot <- ggplot(df, aes(x)) + geom_bar() @@ -100,44 +17,6 @@ test_that("position scales generate after stats", { expect_equal(ranges$y[[1]], c(0, 3)) }) -test_that("oob affects position values", { - dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) - base <- ggplot(dat, aes(x, y)) + - geom_col() + - annotate("point", x = "a", y = c(-Inf, Inf)) - - y_scale <- function(limits, oob = censor) { - scale_y_continuous(limits = limits, oob = oob, expand = c(0, 0)) - } - base + scale_y_continuous(limits = c(-0,5)) - - low_censor <- cdata(base + y_scale(c(0, 5), censor)) - mid_censor <- cdata(base + y_scale(c(3, 7), censor)) - handle <- GeomBar$handle_na - - expect_snapshot_warning( - low_censor[[1]] <- handle(low_censor[[1]], list(na.rm = FALSE)), - ) - expect_snapshot_warning( - mid_censor[[1]] <- handle(mid_censor[[1]], list(na.rm = FALSE)), - ) - - low_squish <- cdata(base + y_scale(c(0, 5), squish)) - mid_squish <- cdata(base + y_scale(c(3, 7), squish)) - - # Points are always at the top and bottom - expect_equal(low_censor[[2]]$y, c(0, 1)) - expect_equal(mid_censor[[2]]$y, c(0, 1)) - expect_equal(low_squish[[2]]$y, c(0, 1)) - expect_equal(mid_squish[[2]]$y, c(0, 1)) - - # Bars depend on limits and oob - expect_equal(low_censor[[1]]$y, c(0.2, 1)) - expect_equal(mid_censor[[1]]$y, numeric(0)) - expect_equal(low_squish[[1]]$y, c(0.2, 1, 1)) - expect_equal(mid_squish[[1]]$y, c(0, 0.5, 1)) -}) - test_that("all-Inf layers are not used for determining the type of scale", { d1 <- data_frame(x = c("a", "b")) p1 <- ggplot(d1, aes(x, x)) + @@ -196,16 +75,6 @@ test_that("find_global searches in the right places", { ggplot2::scale_colour_hue) }) -test_that("scales warn when transforms introduces non-finite values", { - df <- data_frame(x = c(1e1, 1e5), y = c(0, 100)) - - p <- ggplot(df, aes(x, y)) + - geom_point(size = 5) + - scale_y_log10() - - expect_snapshot_warning(ggplot_build(p)) -}) - test_that("size and alpha scales throw appropriate warnings for factors", { df <- data_frame( x = 1:3, @@ -248,71 +117,6 @@ test_that("shape scale throws appropriate warnings for factors", { ) }) -test_that("aesthetics can be set independently of scale name", { - df <- data_frame( - x = LETTERS[1:3], - y = LETTERS[4:6] - ) - p <- ggplot(df, aes(x, y, fill = y)) + - scale_colour_manual(values = c("red", "green", "blue"), aesthetics = "fill") - - expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) -}) - -test_that("multiple aesthetics can be set with one function call", { - df <- data_frame( - x = LETTERS[1:3], - y = LETTERS[4:6] - ) - p <- ggplot(df, aes(x, y, colour = x, fill = y)) + - scale_colour_manual( - values = c("grey20", "grey40", "grey60", "red", "green", "blue"), - aesthetics = c("colour", "fill") - ) - - expect_equal(get_layer_data(p)$colour, c("grey20", "grey40", "grey60")) - expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) - - # color order is determined by data order, and breaks are combined where possible - df <- data_frame( - x = LETTERS[1:3], - y = LETTERS[2:4] - ) - p <- ggplot(df, aes(x, y, colour = x, fill = y)) + - scale_colour_manual( - values = c("cyan", "red", "green", "blue"), - aesthetics = c("fill", "colour") - ) - - expect_equal(get_layer_data(p)$colour, c("cyan", "red", "green")) - expect_equal(get_layer_data(p)$fill, c("red", "green", "blue")) -}) - -test_that("limits with NA are replaced with the min/max of the data for continuous scales", { - make_scale <- function(limits = NULL, data = NULL) { - scale <- continuous_scale("aesthetic", palette = identity, limits = limits) - if (!is.null(data)) { - scale$train(data) - } - scale - } - - # emptiness - expect_true(make_scale()$is_empty()) - expect_false(make_scale(limits = c(0, 1))$is_empty()) - expect_true(make_scale(limits = c(0, NA))$is_empty()) - expect_true(make_scale(limits = c(NA, NA))$is_empty()) - expect_true(make_scale(limits = c(NA, 0))$is_empty()) - - # limits - expect_equal(make_scale(data = 1:5)$get_limits(), c(1, 5)) - expect_equal(make_scale(limits = c(1, 5))$get_limits(), c(1, 5)) - expect_equal(make_scale(limits = c(NA, NA))$get_limits(), c(0, 1)) - expect_equal(make_scale(limits = c(NA, NA), data = 1:5)$get_limits(), c(1, 5)) - expect_equal(make_scale(limits = c(1, NA), data = 1:5)$get_limits(), c(1, 5)) - expect_equal(make_scale(limits = c(NA, 5), data = 1:5)$get_limits(), c(1, 5)) -}) - test_that("scale_apply preserves class and attributes", { df <- data_frame( x = structure(c(1, 2), foo = "bar", class = c("baz", "numeric")), @@ -369,292 +173,6 @@ test_that("scale_apply preserves class and attributes", { expect_null(attributes(out)) }) -test_that("All scale_colour_*() have their American versions", { - # In testthat, the package env contains non-exported functions as well so we - # need to parse NAMESPACE file by ourselves - exports <- readLines(system.file("NAMESPACE", package = "ggplot2")) - colour_scale_exports <- grep("export\\(scale_colour_.*\\)", exports, value = TRUE) - color_scale_exports <- grep("export\\(scale_color_.*\\)", exports, value = TRUE) - expect_equal( - colour_scale_exports, - sub("color", "colour", color_scale_exports) - ) -}) - -test_that("scales accept lambda notation for function input", { - check_lambda <- function(items, ggproto) { - vapply(items, function(x) { - f <- environment(ggproto[[x]])$f - is_lambda(f) - }, logical(1)) - } - - # Test continuous scale - scale <- scale_fill_gradient( - limits = ~ .x + c(-1, 1), - breaks = ~ seq(.x[1], .x[2], by = 2), - minor_breaks = ~ seq(.x[1], .x[2], by = 1), - labels = ~ toupper(.x), - rescaler = ~ rescale_mid(.x, mid = 0), - oob = ~ oob_squish(.x, .y, only.finite = FALSE) - ) - check <- check_lambda( - c("limits", "breaks", "minor_breaks", "labels", "rescaler"), - scale - ) - expect_true(all(check)) - - # Test discrete scale - scale <- scale_x_discrete( - limits = ~ rev(.x), - breaks = ~ .x[-1], - labels = ~ toupper(.x) - ) - check <- check_lambda(c("limits", "breaks", "labels"), scale) - expect_true(all(check)) - - # Test binned scale - scale <- scale_fill_steps( - limits = ~ .x + c(-1, 1), - breaks = ~ seq(.x[1], .x[2], by = 2), - labels = ~ toupper(.x), - rescaler = ~ rescale_mid(.x, mid = 0), - oob = ~ oob_squish(.x, .y, only.finite = FALSE) - ) - check <- check_lambda( - c("limits", "breaks", "labels", "rescaler"), - scale - ) - expect_true(all(check)) -}) - -test_that("breaks and labels are correctly checked", { - expect_snapshot_error(check_breaks_labels(1:10, letters)) - expect_snapshot_error(scale_x_continuous(breaks = NA)) - p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(minor_breaks = NA) - expect_snapshot_error(ggplot_build(p)) - p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(labels = NA) - expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + scale_x_continuous(labels = function(x) 1:2) - expect_snapshot_error(ggplotGrob(p)) - expect_snapshot_error(scale_x_discrete(breaks = NA)) - p <- ggplot(mtcars) + geom_bar(aes(factor(gear))) + scale_x_discrete(labels = NA) - expect_snapshot_error(ggplotGrob(p)) - - expect_snapshot_error(scale_x_binned(breaks = NA)) - p <- ggplot(mtcars) + geom_bar(aes(mpg)) + scale_x_binned(labels = NA) - expect_snapshot_error(ggplotGrob(p)) - p <- ggplot(mtcars) + geom_bar(aes(mpg)) + scale_x_binned(labels = function(x) 1:2) - expect_snapshot_error(ggplotGrob(p)) -}) - -test_that("staged aesthetics are backtransformed properly (#4155)", { - p <- ggplot(data.frame(value = 16)) + - geom_point(aes(stage(value, after_stat = x / 2), 0)) + - scale_x_sqrt(limits = c(0, 16), breaks = c(2, 4, 8)) - - # x / 2 should be 16 / 2 = 8, thus the result should be sqrt(8) on scale_x_sqrt() - expect_equal(get_layer_data(p)$x, sqrt(8)) -}) - -test_that("numeric scale transforms can produce breaks", { - - test_breaks <- function(transform, limits) { - scale <- scale_x_continuous(transform = transform) - scale$train(scale$transform(limits)) - view <- view_scale_primary(scale) - scale$get_transformation()$inverse(view$get_breaks()) - } - - 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_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", { - - construct <- exprs( - scale_alpha(), - scale_alpha_binned(), - scale_alpha_continuous(), - scale_alpha_date(), - scale_alpha_datetime(), - scale_alpha_discrete(), - scale_alpha_identity(), - scale_alpha_manual(), - scale_alpha_ordinal(), - # Skipping American spelling of 'color' scales here - scale_colour_binned(), - scale_colour_brewer(), - scale_colour_continuous(), - scale_colour_date(), - scale_colour_datetime(), - scale_colour_discrete(), - scale_colour_distiller(), - scale_colour_fermenter(), - scale_colour_gradient(), - scale_colour_gradient2(), - # Some scales have required arguments - scale_colour_gradientn(colours = c("firebrick", "limegreen")), - scale_colour_grey(), - scale_colour_hue(), - scale_colour_identity(), - scale_colour_manual(), - scale_colour_ordinal(), - scale_colour_steps(), - scale_colour_steps2(), - scale_colour_stepsn(colours = c("orchid", "tomato")), - scale_colour_viridis_b(), - scale_colour_viridis_c(), - scale_colour_viridis_d(), - scale_continuous_identity(aesthetics = "foo"), - scale_discrete_identity(aesthetics = "bar"), - scale_discrete_manual(aesthetics = "baz"), - scale_fill_binned(), - scale_fill_brewer(), - scale_fill_continuous(), - scale_fill_date(), - scale_fill_datetime(), - scale_fill_discrete(), - scale_fill_distiller(), - scale_fill_fermenter(), - scale_fill_gradient(), - scale_fill_gradient2(), - scale_fill_gradientn(colours = c("yellow", "green")), - scale_fill_grey(), - scale_fill_hue(), - scale_fill_identity(), - scale_fill_manual(), - scale_fill_ordinal(), - scale_fill_steps(), - scale_fill_steps2(), - scale_fill_stepsn(colours = c("steelblue", "pink")), - scale_fill_viridis_b(), - scale_fill_viridis_c(), - scale_fill_viridis_d(), - scale_linetype(), - scale_linetype_binned(), - # scale_linetype_continuous(), # designed to throw error - scale_linetype_discrete(), - scale_linetype_identity(), - scale_linetype_manual(), - scale_linewidth(), - scale_linewidth_binned(), - scale_linewidth_continuous(), - scale_linewidth_date(), - scale_linewidth_datetime(), - scale_linewidth_discrete(), - scale_linewidth_identity(), - scale_linewidth_manual(), - scale_linewidth_ordinal(), - scale_radius(), - scale_shape(), - scale_shape_binned(), - # scale_shape_continuous(), # designed to throw error - scale_shape_discrete(), - scale_shape_identity(), - scale_shape_manual(), - scale_shape_ordinal(), - scale_size(), - scale_size_area(), - scale_size_binned(), - scale_size_binned_area(), - scale_size_continuous(), - scale_size_date(), - scale_size_datetime(), - scale_size_discrete(), - scale_size_identity(), - scale_size_manual(), - scale_size_ordinal(), - scale_x_binned(), - scale_x_continuous(), - scale_x_date(), - scale_x_datetime(), - scale_x_discrete(), - scale_x_log10(), - scale_x_reverse(), - scale_x_sqrt(), - # scale_x_time(), - scale_y_binned(), - scale_y_continuous(), - scale_y_date(), - scale_y_datetime(), - scale_y_discrete(), - scale_y_log10(), - scale_y_reverse(), - scale_y_sqrt(), - # scale_y_time(), - xlim(10, 20), - ylim("A", "B") - ) - if (is_installed("hms")) { - construct <- c(construct, exprs(scale_x_time(), scale_y_time())) - } - - suppressWarnings( - calls <- lapply(construct, function(x) eval(x)$call) - ) - expect_equal(calls, construct) -}) - -test_that("scale call is found accurately", { - - call_template <- quote(scale_x_continuous(transform = "log10")) - - sc <- do.call("scale_x_continuous", list(transform = "log10")) - expect_equal(sc$call, call_template) - - sc <- inject(scale_x_continuous(!!!list(transform = "log10"))) - expect_equal(sc$call, call_template) - - sc <- exec("scale_x_continuous", transform = "log10") - expect_equal(sc$call, call_template) - - foo <- function() scale_x_continuous(transform = "log10") - expect_equal(foo()$call, call_template) - - env <- new_environment() - env$bar <- function() scale_x_continuous(transform = "log10") - expect_equal(env$bar()$call, call_template) - - # Now should recognise the outer function - scale_x_new <- function() { - scale_x_continuous(transform = "log10") - } - expect_equal( - scale_x_new()$call, - quote(scale_x_new()) - ) -}) - -test_that("training incorrectly appropriately communicates the offenders", { - - sc <- scale_colour_viridis_d() - expect_snapshot_error( - sc$train(1:5) - ) - - sc <- scale_colour_viridis_c() - expect_snapshot_error( - sc$train(LETTERS[1:5]) - ) -}) - test_that("find_scale appends appropriate calls", { expect_equal( @@ -669,33 +187,6 @@ test_that("find_scale appends appropriate calls", { }) -test_that("Using `scale_name` prompts deprecation message", { - - expect_snapshot_warning(continuous_scale("x", "foobar", pal_identity())) - expect_snapshot_warning(discrete_scale("x", "foobar", pal_identity())) - expect_snapshot_warning(binned_scale("x", "foobar", pal_identity())) - -}) - -# From #5623 -test_that("Discrete scales with only NAs return `na.value`", { - - x <- c(NA, NA) - - sc <- scale_colour_discrete(na.value = "red") - sc$train(x) - expect_equal(sc$map(x), c("red", "red")) - - sc <- scale_shape(na.value = NA_real_) - sc$train(x) - expect_equal(sc$map(x), c(NA_real_, NA_real_)) -}) - -test_that("continuous scales warn about faulty `limits`", { - expect_snapshot(scale_x_continuous(limits = c("A", "B")), error = TRUE) - expect_snapshot(scale_x_continuous(limits = 1:3), error = TRUE) -}) - test_that("populating palettes works", { scl <- scales_list() @@ -719,83 +210,3 @@ test_that("populating palettes works", { expect_equal(scl$scales[[1]]$palette(2), c("red", "blue")) }) - -test_that("discrete scales work with NAs in arbitrary positions", { - # Prevents intermediate caching of palettes - map <- function(x, limits) { - sc <- scale_colour_manual( - values = c("red", "green", "blue"), - na.value = "gray" - ) - sc$map(x, limits) - } - - # All inputs should yield output regardless of where NA is - input <- c("A", "B", "C", NA) - output <- c("red", "green", "blue", "gray") - - test <- map(input, limits = c("A", "B", "C", NA)) - expect_equal(test, output) - - test <- map(input, limits = c("A", NA, "B", "C")) - expect_equal(test, output) - - test <- map(input, limits = c(NA, "A", "B", "C")) - expect_equal(test, output) - -}) - -test_that("ViewScales can make fixed copies", { - - p1 <- ggplot(mpg, aes(drv, displ)) + - geom_boxplot() + - annotate("point", x = 5, y = 10) + - scale_x_discrete(labels = c("four-wheel", "forward", "reverse")) - - b1 <- ggplot_build(p1)@layout$panel_params[[1]] - - # We build a second plot with the first plot's scales - p2 <- ggplot(mpg, aes(drv, cyl)) + - geom_violin() + - annotate("point", x = 15, y = 100) + - b1$x$make_fixed_copy() + - b1$y$make_fixed_copy() - b2 <- ggplot_build(p2) - - # Breaks and labels should respect p1's limits - x <- get_guide_data(b2, "x") - expect_equal(x$x, 0.6:2.6 / diff(b1$x.range)) - expect_equal(x$.label, c("four-wheel", "forward", "reverse")) - - y <- get_guide_data(b2, "y") - expect_equal(y$y, rescale(seq(2.5, 10, by = 2.5), from = b1$y.range)) -}) - -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 f17b3a2e55273a323297fb34e93433e2ef145931 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 13:24:27 +0100 Subject: [PATCH 51/78] repatriate `stat_count()` tests --- tests/testthat/_snaps/stat-bin.md | 7 ------- tests/testthat/_snaps/stat-count.md | 7 +++++++ tests/testthat/test-stat-bin.R | 28 ---------------------------- tests/testthat/test-stat-count.R | 26 ++++++++++++++++++++++++++ 4 files changed, 33 insertions(+), 35 deletions(-) diff --git a/tests/testthat/_snaps/stat-bin.md b/tests/testthat/_snaps/stat-bin.md index fb035d2996..a8a4f0ed28 100644 --- a/tests/testthat/_snaps/stat-bin.md +++ b/tests/testthat/_snaps/stat-bin.md @@ -21,10 +21,3 @@ x the x aesthetic is discrete. i Perhaps you want `stat="count"`? -# stat_count throws error when both x and y aesthetic present - - Problem while computing stat. - i Error occurred in the 1st layer. - Caused by error in `setup_params()`: - ! `stat_count()` must only have an x or y aesthetic. - diff --git a/tests/testthat/_snaps/stat-count.md b/tests/testthat/_snaps/stat-count.md index 51d990c52e..4ef9142abc 100644 --- a/tests/testthat/_snaps/stat-count.md +++ b/tests/testthat/_snaps/stat-count.md @@ -12,3 +12,10 @@ Caused by error in `setup_params()`: ! `stat_count()` must only have an x or y aesthetic. +# stat_count throws error when both x and y aesthetic present + + Problem while computing stat. + i Error occurred in the 1st layer. + Caused by error in `setup_params()`: + ! `stat_count()` must only have an x or y aesthetic. + diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 4d3c61036e..0b2d4879ef 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -139,31 +139,3 @@ test_that("weights are added", { expect_equal(out$count, df$y) }) - -# stat_count -------------------------------------------------------------- - -test_that("stat_count throws error when both x and y aesthetic present", { - dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) - - expect_snapshot_error(ggplot_build(ggplot(dat, aes(x, y)) + stat_count())) -}) - -test_that("stat_count preserves x order for continuous and discrete", { - # x is numeric - b <- ggplot_build(ggplot(mtcars, aes(carb)) + geom_bar()) - expect_identical(b@data[[1]]$x, c(1,2,3,4,6,8)) - expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) - - # x is factor where levels match numeric order - mtcars$carb2 <- factor(mtcars$carb) - b <- ggplot_build(ggplot(mtcars, aes(carb2)) + geom_bar()) - expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) - expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) - - # x is factor levels differ from numeric order - mtcars$carb3 <- factor(mtcars$carb, levels = c(4,1,2,3,6,8)) - b <- ggplot_build(ggplot(mtcars, aes(carb3)) + geom_bar()) - expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) - expect_identical(b@layout$panel_params[[1]]$x$get_labels(), c("4","1","2","3","6","8")) - expect_identical(b@data[[1]]$y, c(10,7,10,3,1,1)) -}) diff --git a/tests/testthat/test-stat-count.R b/tests/testthat/test-stat-count.R index b014fc672e..e96cc49947 100644 --- a/tests/testthat/test-stat-count.R +++ b/tests/testthat/test-stat-count.R @@ -15,3 +15,29 @@ test_that("stat_count() respects uniqueness of `x`", { expect_length(vec_unique(df$x), 4) expect_equal(data$y, rep(1, 4)) }) + +test_that("stat_count throws error when both x and y aesthetic present", { + dat <- data_frame(x = c("a", "b", "c"), y = c(1, 5, 10)) + + expect_snapshot_error(ggplot_build(ggplot(dat, aes(x, y)) + stat_count())) +}) + +test_that("stat_count preserves x order for continuous and discrete", { + # x is numeric + b <- ggplot_build(ggplot(mtcars, aes(carb)) + geom_bar()) + expect_identical(b@data[[1]]$x, c(1,2,3,4,6,8)) + expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) + + # x is factor where levels match numeric order + mtcars$carb2 <- factor(mtcars$carb) + b <- ggplot_build(ggplot(mtcars, aes(carb2)) + geom_bar()) + expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) + expect_identical(b@data[[1]]$y, c(7,10,3,10,1,1)) + + # x is factor levels differ from numeric order + mtcars$carb3 <- factor(mtcars$carb, levels = c(4,1,2,3,6,8)) + b <- ggplot_build(ggplot(mtcars, aes(carb3)) + geom_bar()) + expect_identical(b@data[[1]]$x, mapped_discrete(1:6)) + expect_identical(b@layout$panel_params[[1]]$x$get_labels(), c("4","1","2","3","6","8")) + expect_identical(b@data[[1]]$y, c(10,7,10,3,1,1)) +}) From eff28541c31f969d7373b30807491fba34c3375b Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 13:36:57 +0100 Subject: [PATCH 52/78] align `test-stats.R` --- tests/testthat/_snaps/{stats.md => stat-.md} | 0 tests/testthat/{test-stats.R => test-stat-.R} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/_snaps/{stats.md => stat-.md} (100%) rename tests/testthat/{test-stats.R => test-stat-.R} (100%) diff --git a/tests/testthat/_snaps/stats.md b/tests/testthat/_snaps/stat-.md similarity index 100% rename from tests/testthat/_snaps/stats.md rename to tests/testthat/_snaps/stat-.md diff --git a/tests/testthat/test-stats.R b/tests/testthat/test-stat-.R similarity index 100% rename from tests/testthat/test-stats.R rename to tests/testthat/test-stat-.R From 801cf6685dfb51f6609377668abca915622ac281 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 14:06:55 +0100 Subject: [PATCH 53/78] reorganise theme tests --- tests/testthat/_snaps/margins.md | 11 + .../theme-bw-large.svg | 0 .../{theme => theme-defaults}/theme-bw.svg | 0 .../theme-classic-large.svg | 0 .../theme-classic.svg | 0 .../theme-dark-large.svg | 0 .../{theme => theme-defaults}/theme-dark.svg | 0 .../theme-gray-large.svg | 0 .../{theme => theme-defaults}/theme-gray.svg | 0 .../theme-light-large.svg | 0 .../{theme => theme-defaults}/theme-light.svg | 0 .../theme-linedraw-large.svg | 0 .../theme-linedraw.svg | 0 .../theme-minimal-large.svg | 0 .../theme-minimal.svg | 0 .../theme-void-large.svg | 0 .../{theme => theme-defaults}/theme-void.svg | 0 .../theme-with-inverted-colours.svg | 0 tests/testthat/_snaps/theme-elements.md | 73 +++ .../point-elements.svg | 0 .../polygon-elements.svg | 0 tests/testthat/_snaps/theme-sub.md | 23 + tests/testthat/_snaps/theme.md | 107 ---- tests/testthat/test-margins.R | 57 ++ tests/testthat/test-theme-current.R | 63 +++ tests/testthat/test-theme-defaults.R | 128 +++++ tests/testthat/test-theme-elements.R | 186 ++++++ tests/testthat/test-theme-sub.R | 49 ++ tests/testthat/test-theme.R | 528 +----------------- 29 files changed, 621 insertions(+), 604 deletions(-) create mode 100644 tests/testthat/_snaps/margins.md rename tests/testthat/_snaps/{theme => theme-defaults}/theme-bw-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-bw.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-classic-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-classic.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-dark-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-dark.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-gray-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-gray.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-light-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-light.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-linedraw-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-linedraw.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-minimal-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-minimal.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-void-large.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-void.svg (100%) rename tests/testthat/_snaps/{theme => theme-defaults}/theme-with-inverted-colours.svg (100%) create mode 100644 tests/testthat/_snaps/theme-elements.md rename tests/testthat/_snaps/{theme => theme-elements}/point-elements.svg (100%) rename tests/testthat/_snaps/{theme => theme-elements}/polygon-elements.svg (100%) create mode 100644 tests/testthat/_snaps/theme-sub.md create mode 100644 tests/testthat/test-margins.R create mode 100644 tests/testthat/test-theme-current.R create mode 100644 tests/testthat/test-theme-defaults.R create mode 100644 tests/testthat/test-theme-elements.R create mode 100644 tests/testthat/test-theme-sub.R diff --git a/tests/testthat/_snaps/margins.md b/tests/testthat/_snaps/margins.md new file mode 100644 index 0000000000..82b0e7d995 --- /dev/null +++ b/tests/testthat/_snaps/margins.md @@ -0,0 +1,11 @@ +# margins() warn against wrong input lengths + + Code + margin(c(1, 2), 3, 4, c(5, 6, 7)) + Condition + Warning: + In `margin()`, the arguments `t` and `l` should have length 1, not length 2 and 3. + i Arguments get(s) truncated to length 1. + Output + [1] 1points 3points 4points 5points + diff --git a/tests/testthat/_snaps/theme/theme-bw-large.svg b/tests/testthat/_snaps/theme-defaults/theme-bw-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-bw-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-bw-large.svg diff --git a/tests/testthat/_snaps/theme/theme-bw.svg b/tests/testthat/_snaps/theme-defaults/theme-bw.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-bw.svg rename to tests/testthat/_snaps/theme-defaults/theme-bw.svg diff --git a/tests/testthat/_snaps/theme/theme-classic-large.svg b/tests/testthat/_snaps/theme-defaults/theme-classic-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-classic-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-classic-large.svg diff --git a/tests/testthat/_snaps/theme/theme-classic.svg b/tests/testthat/_snaps/theme-defaults/theme-classic.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-classic.svg rename to tests/testthat/_snaps/theme-defaults/theme-classic.svg diff --git a/tests/testthat/_snaps/theme/theme-dark-large.svg b/tests/testthat/_snaps/theme-defaults/theme-dark-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-dark-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-dark-large.svg diff --git a/tests/testthat/_snaps/theme/theme-dark.svg b/tests/testthat/_snaps/theme-defaults/theme-dark.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-dark.svg rename to tests/testthat/_snaps/theme-defaults/theme-dark.svg diff --git a/tests/testthat/_snaps/theme/theme-gray-large.svg b/tests/testthat/_snaps/theme-defaults/theme-gray-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-gray-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-gray-large.svg diff --git a/tests/testthat/_snaps/theme/theme-gray.svg b/tests/testthat/_snaps/theme-defaults/theme-gray.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-gray.svg rename to tests/testthat/_snaps/theme-defaults/theme-gray.svg diff --git a/tests/testthat/_snaps/theme/theme-light-large.svg b/tests/testthat/_snaps/theme-defaults/theme-light-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-light-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-light-large.svg diff --git a/tests/testthat/_snaps/theme/theme-light.svg b/tests/testthat/_snaps/theme-defaults/theme-light.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-light.svg rename to tests/testthat/_snaps/theme-defaults/theme-light.svg diff --git a/tests/testthat/_snaps/theme/theme-linedraw-large.svg b/tests/testthat/_snaps/theme-defaults/theme-linedraw-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-linedraw-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-linedraw-large.svg diff --git a/tests/testthat/_snaps/theme/theme-linedraw.svg b/tests/testthat/_snaps/theme-defaults/theme-linedraw.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-linedraw.svg rename to tests/testthat/_snaps/theme-defaults/theme-linedraw.svg diff --git a/tests/testthat/_snaps/theme/theme-minimal-large.svg b/tests/testthat/_snaps/theme-defaults/theme-minimal-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-minimal-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-minimal-large.svg diff --git a/tests/testthat/_snaps/theme/theme-minimal.svg b/tests/testthat/_snaps/theme-defaults/theme-minimal.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-minimal.svg rename to tests/testthat/_snaps/theme-defaults/theme-minimal.svg diff --git a/tests/testthat/_snaps/theme/theme-void-large.svg b/tests/testthat/_snaps/theme-defaults/theme-void-large.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-void-large.svg rename to tests/testthat/_snaps/theme-defaults/theme-void-large.svg diff --git a/tests/testthat/_snaps/theme/theme-void.svg b/tests/testthat/_snaps/theme-defaults/theme-void.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-void.svg rename to tests/testthat/_snaps/theme-defaults/theme-void.svg diff --git a/tests/testthat/_snaps/theme/theme-with-inverted-colours.svg b/tests/testthat/_snaps/theme-defaults/theme-with-inverted-colours.svg similarity index 100% rename from tests/testthat/_snaps/theme/theme-with-inverted-colours.svg rename to tests/testthat/_snaps/theme-defaults/theme-with-inverted-colours.svg diff --git a/tests/testthat/_snaps/theme-elements.md b/tests/testthat/_snaps/theme-elements.md new file mode 100644 index 0000000000..f3931ef6b0 --- /dev/null +++ b/tests/testthat/_snaps/theme-elements.md @@ -0,0 +1,73 @@ +# elements can be merged + + Code + merge_element(text_base, rect_base) + Condition + Error in `method(merge_element, list(ggplot2::element, class_any))`: + ! Only elements of the same class can be merged. + +# element tree can be modified + + The `blablabla` theme element is not defined in the element hierarchy. + +--- + + The `blablabla` theme element must be a object. + +--- + + The `blablabla` theme element must be a object. + +--- + + 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". + +# element_text throws appropriate conditions + + Vectorized input to `element_text()` is not officially supported. + i Results may be unexpected or may change in future versions of ggplot2. + +--- + + The `margin` argument should be constructed using the `margin()` function. + +--- + + Code + element_text(margin = 5) + Condition + Error in `as_margin()`: + ! `margin` must be a class, not a number. + +--- + + Code + element_text(colour = sqrt(2)) + Condition + Error: + ! object properties are invalid: + - @colour cannot be a decimal number, but could be an integer. + +--- + + Code + element_grob(el, label = element_blank()) + Condition + Warning: + `label` cannot be a object. + Output + zeroGrob[NULL] + diff --git a/tests/testthat/_snaps/theme/point-elements.svg b/tests/testthat/_snaps/theme-elements/point-elements.svg similarity index 100% rename from tests/testthat/_snaps/theme/point-elements.svg rename to tests/testthat/_snaps/theme-elements/point-elements.svg diff --git a/tests/testthat/_snaps/theme/polygon-elements.svg b/tests/testthat/_snaps/theme-elements/polygon-elements.svg similarity index 100% rename from tests/testthat/_snaps/theme/polygon-elements.svg rename to tests/testthat/_snaps/theme-elements/polygon-elements.svg diff --git a/tests/testthat/_snaps/theme-sub.md b/tests/testthat/_snaps/theme-sub.md new file mode 100644 index 0000000000..68de436802 --- /dev/null +++ b/tests/testthat/_snaps/theme-sub.md @@ -0,0 +1,23 @@ +# subtheme functions rename arguments as intended + + Ignoring unknown `theme()` elements: foo and bar. + +# theme elements are covered in `theme_sub_*()` functions + + Code + extra_elements + Output + [1] "..." "line" + [3] "rect" "text" + [5] "title" "point" + [7] "polygon" "geom" + [9] "spacing" "margins" + [11] "aspect.ratio" "axis.text.theta" + [13] "axis.text.r" "axis.ticks.theta" + [15] "axis.ticks.r" "axis.minor.ticks.theta" + [17] "axis.minor.ticks.r" "axis.ticks.length.theta" + [19] "axis.ticks.length.r" "axis.minor.ticks.length.theta" + [21] "axis.minor.ticks.length.r" "axis.line.theta" + [23] "axis.line.r" "complete" + [25] "validate" + diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 180e0563a1..4b2f8fa1b2 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -24,54 +24,6 @@ `new` must be a object, not the string "foo". -# element tree can be modified - - The `blablabla` theme element is not defined in the element hierarchy. - ---- - - The `blablabla` theme element must be a object. - ---- - - The `blablabla` theme element must be a object. - ---- - - 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 - merge_element(text_base, rect_base) - Condition - Error in `method(merge_element, list(ggplot2::element, class_any))`: - ! Only elements of the same class can be merged. - -# margins() warn against wrong input lengths - - Code - margin(c(1, 2), 3, 4, c(5, 6, 7)) - Condition - Warning: - In `margin()`, the arguments `t` and `l` should have length 1, not length 2 and 3. - i Arguments get(s) truncated to length 1. - Output - [1] 1points 3points 4points 5points - # Theme elements are checked during build `plot.title.position` must be one of "panel" or "plot", not "test". @@ -85,46 +37,6 @@ `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. - -# element_text throws appropriate conditions - - Vectorized input to `element_text()` is not officially supported. - i Results may be unexpected or may change in future versions of ggplot2. - ---- - - The `margin` argument should be constructed using the `margin()` function. - ---- - - Code - element_text(margin = 5) - Condition - Error in `as_margin()`: - ! `margin` must be a class, not a number. - ---- - - Code - element_text(colour = sqrt(2)) - Condition - Error: - ! object properties are invalid: - - @colour cannot be a decimal number, but could be an integer. - ---- - - Code - element_grob(el, label = element_blank()) - Condition - Warning: - `label` cannot be a object. - Output - zeroGrob[NULL] - # Theme validation behaves as expected The `aspect.ratio` theme element must be a object. @@ -134,22 +46,3 @@ The `options('ggplot2.discrete.colour')` setting is incompatible with the `palette.colour.discrete` theme setting. i You can set `options(ggplot2.discrete.colour = NULL)`. -# theme elements are covered in `theme_sub_*()` functions - - Code - extra_elements - Output - [1] "..." "line" - [3] "rect" "text" - [5] "title" "point" - [7] "polygon" "geom" - [9] "spacing" "margins" - [11] "aspect.ratio" "axis.text.theta" - [13] "axis.text.r" "axis.ticks.theta" - [15] "axis.ticks.r" "axis.minor.ticks.theta" - [17] "axis.minor.ticks.r" "axis.ticks.length.theta" - [19] "axis.ticks.length.r" "axis.minor.ticks.length.theta" - [21] "axis.minor.ticks.length.r" "axis.line.theta" - [23] "axis.line.r" "complete" - [25] "validate" - diff --git a/tests/testthat/test-margins.R b/tests/testthat/test-margins.R new file mode 100644 index 0000000000..690519b725 --- /dev/null +++ b/tests/testthat/test-margins.R @@ -0,0 +1,57 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("titleGrob() and margins() work correctly", { + # ascenders and descenders + g1 <- titleGrob("aaaa", 0, 0, 0.5, 0.5) # lower-case letters, no ascenders or descenders + g2 <- titleGrob("bbbb", 0, 0, 0.5, 0.5) # lower-case letters, no descenders + g3 <- titleGrob("gggg", 0, 0, 0.5, 0.5) # lower-case letters, no ascenders + g4 <- titleGrob("AAAA", 0, 0, 0.5, 0.5) # upper-case letters, no descenders + + expect_equal(height_cm(g1), height_cm(g2)) + expect_equal(height_cm(g1), height_cm(g3)) + expect_equal(height_cm(g1), height_cm(g4)) + + # margins + g5 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 0, b = 0, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) + g6 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 1, b = 0, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) + g7 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 0, b = 1, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) + g8 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 0, b = 0, l = 1, unit = "cm"), margin_x = TRUE, margin_y = TRUE) + + expect_equal(height_cm(g5), height_cm(g1) + 1) + expect_equal(width_cm(g5), width_cm(g1)) + expect_equal(height_cm(g6), height_cm(g1)) + expect_equal(width_cm(g6), width_cm(g1) + 1) + expect_equal(height_cm(g7), height_cm(g1) + 1) + expect_equal(width_cm(g7), width_cm(g1)) + expect_equal(height_cm(g8), height_cm(g1)) + expect_equal(width_cm(g8), width_cm(g1) + 1) + + # no margins when set to false + g9 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), margin_x = FALSE, margin_y = TRUE) + g10 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), margin_x = TRUE, margin_y = FALSE) + expect_equal(height_cm(g9), height_cm(g1) + 2) + # when one of margin_x or margin_y is set to FALSE and the other to TRUE, then the dimension for FALSE turns into + # length 1null. + expect_equal(g9$widths, grid::unit(1, "null")) + expect_equal(g10$heights, grid::unit(1, "null")) + expect_equal(width_cm(g10), width_cm(g1) + 2) +}) + +test_that("margins() warn against wrong input lengths", { + expect_snapshot(margin(c(1, 2), 3, 4, c(5, 6, 7))) +}) + +test_that("margin_part() mechanics work as expected", { + + t <- theme_gray() + + theme(plot.margin = margin_part(b = 11)) + + test <- calc_element("plot.margin", t) + expect_equal(as.numeric(test), c(5.5, 5.5, 11, 5.5)) + + t <- theme_gray() + + theme(margins = margin_part(b = 11)) + + test <- calc_element("plot.margin", t) + expect_equal(as.numeric(test), c(5.5, 5.5, 11, 5.5)) +}) diff --git a/tests/testthat/test-theme-current.R b/tests/testthat/test-theme-current.R new file mode 100644 index 0000000000..c082d833bb --- /dev/null +++ b/tests/testthat/test-theme-current.R @@ -0,0 +1,63 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("current theme can be updated with new elements", { + old <- set_theme(theme_grey()) + + b1 <- ggplot() + theme_grey() + b2 <- ggplot() + + # works for root element + expect_identical( + calc_element("text", plot_theme(b1)), + calc_element("text", plot_theme(b2)) + ) + + # works for derived element + expect_identical( + calc_element("axis.text.x", plot_theme(b1)), + calc_element("axis.text.x", plot_theme(b2)) + ) + + # theme calculation for nonexisting element returns NULL + expect_null(calc_element("abcde", plot_theme(b1))) + + # element tree gets merged properly + register_theme_elements( + abcde = element_text(color = "blue", hjust = 0, vjust = 1), + element_tree = list(abcde = el_def(element_text, "text")) + ) + + e1 <- calc_element("abcde", plot_theme(b2)) + e2 <- calc_element("text", plot_theme(b2)) + e2@colour <- "blue" + e2@hjust <- 0 + e2@vjust <- 1 + expect_identical(e1, e2) + + reset_theme_settings() + set_theme(old) +}) + +test_that("replacing theme elements with %+replace% operator works", { + # Changing a "leaf node" works + t <- theme_grey() %+replace% theme(axis.title.x = element_text(colour = 'red')) + expect_identical(t$axis.title.x, element_text(colour = 'red')) + # Make sure the class didn't change or get dropped + expect_s7_class(t, class_theme) + + # Changing an intermediate node works + t <- theme_grey() %+replace% theme(axis.title = element_text(colour = 'red')) + expect_identical(t$axis.title, element_text(colour = 'red')) + # Descendent is unchanged + expect_identical(t$axis.title.x, theme_grey()$axis.title.x) + + # Adding empty theme() has no effect + t <- theme_grey() %+replace% theme() + expect_identical(t, theme_grey()) +}) + +test_that("set_theme() resets theme to default when called with no arguments", { + theme_set(theme_void()) + set_theme() + expect_identical(theme_get(), theme_grey()) +}) diff --git a/tests/testthat/test-theme-defaults.R b/tests/testthat/test-theme-defaults.R new file mode 100644 index 0000000000..3a66b5c247 --- /dev/null +++ b/tests/testthat/test-theme-defaults.R @@ -0,0 +1,128 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("all elements in complete themes have inherit.blank=TRUE", { + inherit_blanks <- function(theme) { + all(vapply( + theme, try_prop, + name = "inherit.blank", default = TRUE, + logical(1) + )) + } + expect_true(inherit_blanks(theme_grey())) + expect_true(inherit_blanks(theme_bw())) + expect_true(inherit_blanks(theme_classic())) + expect_true(inherit_blanks(theme_dark())) + expect_true(inherit_blanks(theme_light())) + expect_true(inherit_blanks(theme_linedraw())) + expect_true(inherit_blanks(theme_minimal())) + expect_true(inherit_blanks(theme_void())) +}) + +test_that("complete plot themes shouldn't inherit from default", { + default_theme <- theme_gray() + theme(axis.text.x = element_text(colour = "red")) + base <- ggplot(data.frame(x = 1), aes(x, x)) + geom_point() + + ptheme <- plot_theme(base + theme(axis.text.x = element_text(colour = "blue")), default_theme) + expect_equal(ptheme$axis.text.x@colour, "blue") + + ptheme <- plot_theme(base + theme_void(), default_theme) + expect_null(ptheme$axis.text.x) +}) + +test_that("provided themes explicitly define all elements", { + elements <- names(.element_tree) + + t <- theme_all_null() + expect_true(all(names(t) %in% elements)) + expect_true(all(vapply(t, is.null, logical(1)))) + + t <- theme_grey() + expect_true(all(names(t) %in% elements)) + + t <- theme_bw() + expect_true(all(names(t) %in% elements)) + + t <- theme_linedraw() + expect_true(all(names(t) %in% elements)) + + t <- theme_light() + expect_true(all(names(t) %in% elements)) + + t <- theme_dark() + expect_true(all(names(t) %in% elements)) + + t <- theme_minimal() + expect_true(all(names(t) %in% elements)) + + t <- theme_classic() + expect_true(all(names(t) %in% elements)) + + t <- theme_void() + expect_true(all(names(t) %in% elements)) + + t <- theme_test() + expect_true(all(names(t) %in% elements)) +}) + +test_that("header_family is passed on correctly", { + + td <- theme_dark(base_family = "x", header_family = "y") + + test <- calc_element("plot.title", td) + expect_equal(test@family, "y") + + test <- calc_element("plot.subtitle", td) + expect_equal(test@family, "x") +}) + +# Visual tests ------------------------------------------------------------ + +test_that("themes don't change without acknowledgement", { + df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) + plot <- ggplot(df, aes(x, y, colour = z)) + + geom_point() + + facet_wrap(~ a) + + expect_doppelganger("theme_bw", plot + theme_bw()) + expect_doppelganger("theme_classic", plot + theme_classic()) + expect_doppelganger("theme_dark", plot + theme_dark()) + expect_doppelganger("theme_minimal", plot + theme_minimal()) + expect_doppelganger("theme_gray", plot + theme_gray()) + expect_doppelganger("theme_light", plot + theme_light()) + expect_doppelganger("theme_void", plot + theme_void()) + expect_doppelganger("theme_linedraw", plot + theme_linedraw()) +}) + +test_that("themes look decent at larger base sizes", { + df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) + plot <- ggplot(df, aes(x, y, colour = z)) + + geom_point() + + facet_wrap(~ a) + + expect_doppelganger("theme_bw_large", plot + theme_bw(base_size = 33)) + expect_doppelganger("theme_classic_large", plot + theme_classic(base_size = 33)) + expect_doppelganger("theme_dark_large", plot + theme_dark(base_size = 33)) + expect_doppelganger("theme_minimal_large", plot + theme_minimal(base_size = 33)) + expect_doppelganger("theme_gray_large", plot + theme_gray(base_size = 33)) + expect_doppelganger("theme_light_large", plot + theme_light(base_size = 33)) + expect_doppelganger("theme_void_large", plot + theme_void(base_size = 33)) + expect_doppelganger("theme_linedraw_large", plot + theme_linedraw(base_size = 33)) +}) + +test_that("theme ink and paper settings work", { + + p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + + geom_point() + + facet_wrap(~"Strip title") + + labs( + title = "Main title", + subtitle = "Subtitle", + tag = "A", + caption = "Caption" + ) + + expect_doppelganger( + "Theme with inverted colours", + p + theme_gray(ink = "white", paper = "black") + ) +}) diff --git a/tests/testthat/test-theme-elements.R b/tests/testthat/test-theme-elements.R new file mode 100644 index 0000000000..d74b35b5c3 --- /dev/null +++ b/tests/testthat/test-theme-elements.R @@ -0,0 +1,186 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +test_that("elements can be merged", { + text_base <- element_text(colour = "red", size = 10) + expect_equal( + merge_element(element_text(colour = "blue"), text_base), + element_text(colour = "blue", size = 10) + ) + rect_base <- element_rect(colour = "red", linewidth = 10) + expect_equal( + merge_element(element_rect(colour = "blue"), rect_base), + element_rect(colour = "blue", linewidth = 10) + ) + line_base <- element_line(colour = "red", linewidth = 10) + expect_equal( + merge_element(element_line(colour = "blue"), line_base), + element_line(colour = "blue", linewidth = 10) + ) + expect_snapshot(merge_element(text_base, rect_base), error = TRUE) +}) + +test_that("theme elements that don't inherit from element can be combined", { + expect_identical(combine_elements(1, NULL), 1) + expect_identical(combine_elements(NULL, 1), 1) + expect_identical(combine_elements(1, 0), 1) +}) + +test_that("element tree can be modified", { + # we cannot add a new theme element without modifying the element tree + p <- ggplot() + theme(blablabla = element_text(colour = "red")) + expect_snapshot_warning(print(p)) + + register_theme_elements( + element_tree = list(blablabla = el_def("character", "text")) + ) + expect_snapshot_error(ggplotGrob(p)) + + register_theme_elements( + element_tree = list(blablabla = el_def("unit", "text")) + ) + expect_snapshot_error(ggplotGrob(p)) + + # things work once we add a new element to the element tree + register_theme_elements( + element_tree = list(blablabla = el_def(element_text, "text")) + ) + expect_silent(ggplotGrob(p)) + + 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) + e2 <- calc_element("text", final_theme) + expect_identical(e1@family, e2@family) + expect_identical(e1@face, e2@face) + expect_identical(e1@size, e2@size) + expect_identical(e1@lineheight, e2@lineheight) + expect_identical(e1@colour, "red") # not inherited from element_text + + # existing elements can be overwritten + ed <- el_def(element_rect, "rect") + register_theme_elements( + element_tree = list(axis.title = ed) + ) + expect_identical(get_element_tree()$axis.title, ed) + + reset_theme_settings() # revert back to defaults +}) + +test_that("element_text throws appropriate conditions", { + expect_snapshot_warning( + element_text(colour = c("red", "blue")) + ) + expect_snapshot_warning( + element_text(margin = unit(1, "cm")) + ) + expect_snapshot( + element_text(margin = 5), + error = TRUE + ) + expect_snapshot( + element_text(colour = sqrt(2)), + error = TRUE + ) + + # Some absurd case found in reverse dependency check where + # labs(y = element_blank()) for some reason + el <- theme_get()$text + expect_snapshot( + element_grob(el, label = element_blank()) + ) +}) + +test_that("Minor tick length supports biparental inheritance", { + my_theme <- theme_gray() + theme( + axis.ticks.length = unit(1, "cm"), + axis.ticks.length.y.left = unit(1, "pt"), + axis.minor.ticks.length.y = unit(1, "inch"), + axis.minor.ticks.length = rel(0.5) + ) + expect_equal( # Inherits rel(0.5) from minor, 1cm from major + calc_element("axis.minor.ticks.length.x.bottom", my_theme), + unit(1, "cm") * 0.5 + ) + expect_equal( # Inherits 1inch directly from minor + calc_element("axis.minor.ticks.length.y.left", my_theme), + unit(1, "inch") + ) +}) + +test_that("geom elements are inherited correctly", { + + GeomFoo <- ggproto("GeomFoo", GeomPoint) + GeomBar <- ggproto("GeomBar", GeomFoo) + + p <- ggplot(data.frame(x = 1), aes(x, x)) + + stat_identity(geom = GeomBar) + + theme( + geom = element_geom(pointshape = 15), + geom.point = element_geom(borderwidth = 2, ink = "blue"), + geom.foo = element_geom(pointsize = 2), + geom.bar = element_geom(ink = "red") + ) + p <- layer_data(p) + expect_equal(p$shape, 15) + expect_equal(p$stroke, 2) + expect_equal(p$size, 2) + expect_equal(p$colour, "red") +}) + +# Visual tests ------------------------------------------------------------ + +test_that("element_polygon() can render a grob", { + + t <- theme_gray() + theme(polygon = element_polygon(fill = "orchid")) + e <- calc_element("polygon", t) + g <- element_grob( + e, + x = c(0, 0.5, 1, 0.5, 0.15, 0.85, 0.85, 0.15), + y = c(0.5, 0, 0.5, 1, 0.15, 0.15, 0.85, 0.85), + id = c(1, 1, 1, 1, 2, 2, 2, 2), + colour = c("orange", "limegreen") + ) + + expect_s3_class(g, "pathgrob") + expect_equal(g$gp$fill, "orchid") + + expect_doppelganger( + "polygon elements", + function() {grid.newpage(); grid.draw(g)} + ) +}) + +test_that("element_point() can render a grob", { + + t <- theme_gray() + theme(point = element_point(shape = 21, size = 5)) + e <- calc_element("point", t) + g <- element_grob( + e, + x = seq(0.1, 0.9, length.out = 5), + y = seq(0.9, 0.1, length.out = 5), + fill = c("orange", "limegreen", "orchid", "turquoise", "grey") + ) + + expect_s3_class(g, "points") + expect_equal(g$pch, 21) + + expect_doppelganger( + "point elements", + function() {grid.newpage(); grid.draw(g)} + ) +}) + diff --git a/tests/testthat/test-theme-sub.R b/tests/testthat/test-theme-sub.R new file mode 100644 index 0000000000..32d4f98d92 --- /dev/null +++ b/tests/testthat/test-theme-sub.R @@ -0,0 +1,49 @@ +skip_on_cran() # This test suite is long-running (on cran) and is skipped + +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 elements are covered in `theme_sub_*()` functions", { + # We use a snapshot test here to trigger when a new theme element is added + # or removed. + # A failure of this test should be taken as a prompt to see if the new + # theme element should be included in one of the `theme_sub_*` functions. + + fmls <- paste0("axis.", fn_fmls_names(theme_sub_axis)) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_x), ".x")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_y), ".y")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_top), ".x.top")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_bottom), ".x.bottom")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_left), ".y.left")) + fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_right), ".y.right")) + fmls <- c(fmls, paste0("legend.", fn_fmls_names(theme_sub_legend))) + fmls <- c(fmls, paste0("plot.", fn_fmls_names(theme_sub_plot))) + fmls <- c(fmls, paste0("panel.", fn_fmls_names(theme_sub_panel))) + fmls <- c(fmls, paste0("strip.", fn_fmls_names(theme_sub_strip))) + + extra_elements <- setdiff(fn_fmls_names(theme), fmls) + expect_snapshot(extra_elements) +}) diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index d8508f9070..849bacdf12 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -56,12 +56,6 @@ test_that("modifying theme element properties with + operator works", { ) }) -test_that("set_theme() resets theme to default when called with no arguments", { - theme_set(theme_void()) - set_theme() - expect_identical(theme_get(), theme_grey()) -}) - test_that("adding theme object to ggplot object with + operator works", { ## test with complete theme p <- ggplot(data.frame(x = 1:3), aes(x, x)) + geom_point() + theme_grey() @@ -108,24 +102,6 @@ test_that("adding theme object to ggplot object with + operator works", { expect_identical(p1@theme, p2@theme) }) -test_that("replacing theme elements with %+replace% operator works", { - # Changing a "leaf node" works - t <- theme_grey() %+replace% theme(axis.title.x = element_text(colour = 'red')) - expect_identical(t$axis.title.x, element_text(colour = 'red')) - # Make sure the class didn't change or get dropped - expect_s7_class(t, class_theme) - - # Changing an intermediate node works - t <- theme_grey() %+replace% theme(axis.title = element_text(colour = 'red')) - expect_identical(t$axis.title, element_text(colour = 'red')) - # Descendent is unchanged - expect_identical(t$axis.title.x, theme_grey()$axis.title.x) - - # Adding empty theme() has no effect - t <- theme_grey() %+replace% theme() - expect_identical(t, theme_grey()) -}) - test_that("calculating theme element inheritance works", { t <- theme_grey() + theme(axis.title = element_text(colour = 'red')) @@ -295,229 +271,6 @@ test_that("incorrect theme specifications throw meaningful errors", { reset_theme_settings() }) -test_that("element tree can be modified", { - # we cannot add a new theme element without modifying the element tree - p <- ggplot() + theme(blablabla = element_text(colour = "red")) - expect_snapshot_warning(print(p)) - - register_theme_elements( - element_tree = list(blablabla = el_def("character", "text")) - ) - expect_snapshot_error(ggplotGrob(p)) - - register_theme_elements( - element_tree = list(blablabla = el_def("unit", "text")) - ) - expect_snapshot_error(ggplotGrob(p)) - - # things work once we add a new element to the element tree - register_theme_elements( - element_tree = list(blablabla = el_def(element_text, "text")) - ) - expect_silent(ggplotGrob(p)) - - 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) - e2 <- calc_element("text", final_theme) - expect_identical(e1@family, e2@family) - expect_identical(e1@face, e2@face) - expect_identical(e1@size, e2@size) - expect_identical(e1@lineheight, e2@lineheight) - expect_identical(e1@colour, "red") # not inherited from element_text - - # existing elements can be overwritten - ed <- el_def(element_rect, "rect") - register_theme_elements( - element_tree = list(axis.title = ed) - ) - expect_identical(get_element_tree()$axis.title, ed) - - reset_theme_settings() # revert back to defaults -}) - -test_that("all elements in complete themes have inherit.blank=TRUE", { - inherit_blanks <- function(theme) { - all(vapply( - theme, try_prop, - name = "inherit.blank", default = TRUE, - logical(1) - )) - } - expect_true(inherit_blanks(theme_grey())) - expect_true(inherit_blanks(theme_bw())) - expect_true(inherit_blanks(theme_classic())) - expect_true(inherit_blanks(theme_dark())) - expect_true(inherit_blanks(theme_light())) - expect_true(inherit_blanks(theme_linedraw())) - expect_true(inherit_blanks(theme_minimal())) - expect_true(inherit_blanks(theme_void())) -}) - -test_that("elements can be merged", { - text_base <- element_text(colour = "red", size = 10) - expect_equal( - merge_element(element_text(colour = "blue"), text_base), - element_text(colour = "blue", size = 10) - ) - rect_base <- element_rect(colour = "red", linewidth = 10) - expect_equal( - merge_element(element_rect(colour = "blue"), rect_base), - element_rect(colour = "blue", linewidth = 10) - ) - line_base <- element_line(colour = "red", linewidth = 10) - expect_equal( - merge_element(element_line(colour = "blue"), line_base), - element_line(colour = "blue", linewidth = 10) - ) - expect_snapshot(merge_element(text_base, rect_base), error = TRUE) -}) - -test_that("theme elements that don't inherit from element can be combined", { - expect_identical(combine_elements(1, NULL), 1) - expect_identical(combine_elements(NULL, 1), 1) - expect_identical(combine_elements(1, 0), 1) -}) - -test_that("complete plot themes shouldn't inherit from default", { - default_theme <- theme_gray() + theme(axis.text.x = element_text(colour = "red")) - base <- ggplot(data.frame(x = 1), aes(x, x)) + geom_point() - - ptheme <- plot_theme(base + theme(axis.text.x = element_text(colour = "blue")), default_theme) - expect_equal(ptheme$axis.text.x@colour, "blue") - - ptheme <- plot_theme(base + theme_void(), default_theme) - expect_null(ptheme$axis.text.x) -}) - -test_that("current theme can be updated with new elements", { - old <- set_theme(theme_grey()) - - b1 <- ggplot() + theme_grey() - b2 <- ggplot() - - # works for root element - expect_identical( - calc_element("text", plot_theme(b1)), - calc_element("text", plot_theme(b2)) - ) - - # works for derived element - expect_identical( - calc_element("axis.text.x", plot_theme(b1)), - calc_element("axis.text.x", plot_theme(b2)) - ) - - # theme calculation for nonexisting element returns NULL - expect_null(calc_element("abcde", plot_theme(b1))) - - # element tree gets merged properly - register_theme_elements( - abcde = element_text(color = "blue", hjust = 0, vjust = 1), - element_tree = list(abcde = el_def(element_text, "text")) - ) - - e1 <- calc_element("abcde", plot_theme(b2)) - e2 <- calc_element("text", plot_theme(b2)) - e2@colour <- "blue" - e2@hjust <- 0 - e2@vjust <- 1 - expect_identical(e1, e2) - - reset_theme_settings() - set_theme(old) -}) - -test_that("titleGrob() and margins() work correctly", { - # ascenders and descenders - g1 <- titleGrob("aaaa", 0, 0, 0.5, 0.5) # lower-case letters, no ascenders or descenders - g2 <- titleGrob("bbbb", 0, 0, 0.5, 0.5) # lower-case letters, no descenders - g3 <- titleGrob("gggg", 0, 0, 0.5, 0.5) # lower-case letters, no ascenders - g4 <- titleGrob("AAAA", 0, 0, 0.5, 0.5) # upper-case letters, no descenders - - expect_equal(height_cm(g1), height_cm(g2)) - expect_equal(height_cm(g1), height_cm(g3)) - expect_equal(height_cm(g1), height_cm(g4)) - - # margins - g5 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 0, b = 0, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) - g6 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 1, b = 0, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) - g7 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 0, b = 1, l = 0, unit = "cm"), margin_x = TRUE, margin_y = TRUE) - g8 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 0, r = 0, b = 0, l = 1, unit = "cm"), margin_x = TRUE, margin_y = TRUE) - - expect_equal(height_cm(g5), height_cm(g1) + 1) - expect_equal(width_cm(g5), width_cm(g1)) - expect_equal(height_cm(g6), height_cm(g1)) - expect_equal(width_cm(g6), width_cm(g1) + 1) - expect_equal(height_cm(g7), height_cm(g1) + 1) - expect_equal(width_cm(g7), width_cm(g1)) - expect_equal(height_cm(g8), height_cm(g1)) - expect_equal(width_cm(g8), width_cm(g1) + 1) - - # no margins when set to false - g9 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), margin_x = FALSE, margin_y = TRUE) - g10 <- titleGrob("aaaa", 0, 0, 0.5, 0.5, margin = margin(t = 1, r = 1, b = 1, l = 1, unit = "cm"), margin_x = TRUE, margin_y = FALSE) - expect_equal(height_cm(g9), height_cm(g1) + 2) - # when one of margin_x or margin_y is set to FALSE and the other to TRUE, then the dimension for FALSE turns into - # length 1null. - expect_equal(g9$widths, grid::unit(1, "null")) - expect_equal(g10$heights, grid::unit(1, "null")) - expect_equal(width_cm(g10), width_cm(g1) + 2) -}) - -test_that("margins() warn against wrong input lengths", { - expect_snapshot(margin(c(1, 2), 3, 4, c(5, 6, 7))) -}) - -test_that("provided themes explicitly define all elements", { - elements <- names(.element_tree) - - t <- theme_all_null() - expect_true(all(names(t) %in% elements)) - expect_true(all(vapply(t, is.null, logical(1)))) - - t <- theme_grey() - expect_true(all(names(t) %in% elements)) - - t <- theme_bw() - expect_true(all(names(t) %in% elements)) - - t <- theme_linedraw() - expect_true(all(names(t) %in% elements)) - - t <- theme_light() - expect_true(all(names(t) %in% elements)) - - t <- theme_dark() - expect_true(all(names(t) %in% elements)) - - t <- theme_minimal() - expect_true(all(names(t) %in% elements)) - - t <- theme_classic() - expect_true(all(names(t) %in% elements)) - - t <- theme_void() - expect_true(all(names(t) %in% elements)) - - t <- theme_test() - expect_true(all(names(t) %in% elements)) -}) - test_that("Theme elements are checked during build", { p <- ggplot(mtcars) + geom_point(aes(disp, mpg)) + theme(plot.title.position = "test") expect_snapshot_error(ggplotGrob(p)) @@ -530,56 +283,6 @@ 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("element_text throws appropriate conditions", { - expect_snapshot_warning( - element_text(colour = c("red", "blue")) - ) - expect_snapshot_warning( - element_text(margin = unit(1, "cm")) - ) - expect_snapshot( - element_text(margin = 5), - error = TRUE - ) - expect_snapshot( - element_text(colour = sqrt(2)), - error = TRUE - ) - - # Some absurd case found in reverse dependency check where - # labs(y = element_blank()) for some reason - el <- theme_get()$text - expect_snapshot( - element_grob(el, label = element_blank()) - ) -}) - test_that("Theme validation behaves as expected", { tree <- get_element_tree() expect_silent(check_element(1, "aspect.ratio", tree)) @@ -631,34 +334,6 @@ test_that("Element subclasses are inherited", { ) }) -test_that("Minor tick length supports biparental inheritance", { - my_theme <- theme_gray() + theme( - axis.ticks.length = unit(1, "cm"), - axis.ticks.length.y.left = unit(1, "pt"), - axis.minor.ticks.length.y = unit(1, "inch"), - axis.minor.ticks.length = rel(0.5) - ) - expect_equal( # Inherits rel(0.5) from minor, 1cm from major - calc_element("axis.minor.ticks.length.x.bottom", my_theme), - unit(1, "cm") * 0.5 - ) - expect_equal( # Inherits 1inch directly from minor - calc_element("axis.minor.ticks.length.y.left", my_theme), - unit(1, "inch") - ) -}) - -test_that("header_family is passed on correctly", { - - td <- theme_dark(base_family = "x", header_family = "y") - - test <- calc_element("plot.title", td) - expect_equal(test@family, "y") - - test <- calc_element("plot.subtitle", td) - expect_equal(test@family, "x") -}) - test_that("complete_theme completes a theme", { # `NULL` should match default gray <- theme_gray() @@ -747,21 +422,6 @@ test_that("panel.withs and panel.heights preserve aspect ratios with single pane expect_equal(as.character(width), c("1null", "1null")) }) -test_that("margin_part() mechanics work as expected", { - - t <- theme_gray() + - theme(plot.margin = margin_part(b = 11)) - - test <- calc_element("plot.margin", t) - expect_equal(as.numeric(test), c(5.5, 5.5, 11, 5.5)) - - t <- theme_gray() + - theme(margins = margin_part(b = 11)) - - test <- calc_element("plot.margin", t) - expect_equal(as.numeric(test), c(5.5, 5.5, 11, 5.5)) -}) - test_that("theme() warns about conflicting palette options", { expect_silent( theme(palette.colour.discrete = c("dodgerblue", "orange")) @@ -772,91 +432,8 @@ test_that("theme() warns about conflicting palette options", { ) }) -test_that("geom elements are inherited correctly", { - - GeomFoo <- ggproto("GeomFoo", GeomPoint) - GeomBar <- ggproto("GeomBar", GeomFoo) - - p <- ggplot(data.frame(x = 1), aes(x, x)) + - stat_identity(geom = GeomBar) + - theme( - geom = element_geom(pointshape = 15), - geom.point = element_geom(borderwidth = 2, ink = "blue"), - geom.foo = element_geom(pointsize = 2), - geom.bar = element_geom(ink = "red") - ) - p <- layer_data(p) - expect_equal(p$shape, 15) - expect_equal(p$stroke, 2) - expect_equal(p$size, 2) - expect_equal(p$colour, "red") -}) - -test_that("theme elements are covered in `theme_sub_*()` functions", { - # We use a snapshot test here to trigger when a new theme element is added - # or removed. - # A failure of this test should be taken as a prompt to see if the new - # theme element should be included in one of the `theme_sub_*` functions. - - fmls <- paste0("axis.", fn_fmls_names(theme_sub_axis)) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_x), ".x")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_y), ".y")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_top), ".x.top")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_bottom), ".x.bottom")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_left), ".y.left")) - fmls <- c(fmls, paste0("axis.", fn_fmls_names(theme_sub_axis_right), ".y.right")) - fmls <- c(fmls, paste0("legend.", fn_fmls_names(theme_sub_legend))) - fmls <- c(fmls, paste0("plot.", fn_fmls_names(theme_sub_plot))) - fmls <- c(fmls, paste0("panel.", fn_fmls_names(theme_sub_panel))) - fmls <- c(fmls, paste0("strip.", fn_fmls_names(theme_sub_strip))) - - extra_elements <- setdiff(fn_fmls_names(theme), fmls) - expect_snapshot(extra_elements) -}) - # Visual tests ------------------------------------------------------------ -test_that("element_polygon() can render a grob", { - - t <- theme_gray() + theme(polygon = element_polygon(fill = "orchid")) - e <- calc_element("polygon", t) - g <- element_grob( - e, - x = c(0, 0.5, 1, 0.5, 0.15, 0.85, 0.85, 0.15), - y = c(0.5, 0, 0.5, 1, 0.15, 0.15, 0.85, 0.85), - id = c(1, 1, 1, 1, 2, 2, 2, 2), - colour = c("orange", "limegreen") - ) - - expect_s3_class(g, "pathgrob") - expect_equal(g$gp$fill, "orchid") - - expect_doppelganger( - "polygon elements", - function() {grid.newpage(); grid.draw(g)} - ) -}) - -test_that("element_point() can render a grob", { - - t <- theme_gray() + theme(point = element_point(shape = 21, size = 5)) - e <- calc_element("point", t) - g <- element_grob( - e, - x = seq(0.1, 0.9, length.out = 5), - y = seq(0.9, 0.1, length.out = 5), - fill = c("orange", "limegreen", "orchid", "turquoise", "grey") - ) - - expect_s3_class(g, "points") - expect_equal(g$pch, 21) - - expect_doppelganger( - "point elements", - function() {grid.newpage(); grid.draw(g)} - ) -}) - test_that("aspect ratio is honored", { df <- cbind(data_frame(x = 1:8, y = 1:8, f = gl(2,4)), expand.grid(f1 = 1:2, f2 = 1:2, rep = 1:2)) p <- ggplot(df, aes(x, y)) + @@ -886,39 +463,6 @@ test_that("aspect ratio is honored", { expect_doppelganger("height is 3 times width, 2x2 facets", p_a + facet_grid(f1~f2) ) - -}) - -test_that("themes don't change without acknowledgement", { - df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) - plot <- ggplot(df, aes(x, y, colour = z)) + - geom_point() + - facet_wrap(~ a) - - expect_doppelganger("theme_bw", plot + theme_bw()) - expect_doppelganger("theme_classic", plot + theme_classic()) - expect_doppelganger("theme_dark", plot + theme_dark()) - expect_doppelganger("theme_minimal", plot + theme_minimal()) - expect_doppelganger("theme_gray", plot + theme_gray()) - expect_doppelganger("theme_light", plot + theme_light()) - expect_doppelganger("theme_void", plot + theme_void()) - expect_doppelganger("theme_linedraw", plot + theme_linedraw()) -}) - -test_that("themes look decent at larger base sizes", { - df <- data_frame(x = 1:3, y = 1:3, z = c("a", "b", "a"), a = 1) - plot <- ggplot(df, aes(x, y, colour = z)) + - geom_point() + - facet_wrap(~ a) - - expect_doppelganger("theme_bw_large", plot + theme_bw(base_size = 33)) - expect_doppelganger("theme_classic_large", plot + theme_classic(base_size = 33)) - expect_doppelganger("theme_dark_large", plot + theme_dark(base_size = 33)) - expect_doppelganger("theme_minimal_large", plot + theme_minimal(base_size = 33)) - expect_doppelganger("theme_gray_large", plot + theme_gray(base_size = 33)) - expect_doppelganger("theme_light_large", plot + theme_light(base_size = 33)) - expect_doppelganger("theme_void_large", plot + theme_void(base_size = 33)) - expect_doppelganger("theme_linedraw_large", plot + theme_linedraw(base_size = 33)) }) test_that("setting 'spacing' and 'margins' affect the whole plot", { @@ -934,6 +478,8 @@ test_that("setting 'spacing' and 'margins' affect the whole plot", { }) +## Axes -------------------------------------------------------------------- + test_that("axes can be styled independently", { plot <- ggplot() + geom_point(aes(1:10, 1:10)) + @@ -977,6 +523,19 @@ test_that("axes ticks can have independent lengths", { expect_doppelganger("ticks_length", plot) }) +test_that("rotated axis tick labels work", { + df <- data_frame( + y = c(1, 2, 3), + label = c("short", "medium size", "very long label") + ) + + plot <- ggplot(df, aes(label, y)) + geom_point() + + theme(axis.text.x = element_text(angle = 50, hjust = 1)) + expect_doppelganger("rotated x axis tick labels", plot) +}) + +## Strips ------------------------------------------------------------------ + test_that("strips can be styled independently", { df <- data_frame(x = 1:2, y = 1:2) plot <- ggplot(df, aes(x, y)) + @@ -988,17 +547,23 @@ test_that("strips can be styled independently", { expect_doppelganger("strip_styling", plot) }) -test_that("rotated axis tick labels work", { - df <- data_frame( - y = c(1, 2, 3), - label = c("short", "medium size", "very long label") - ) +test_that("Strips can render custom elements", { + element_test <- S7::new_class("element_test", element_text) + S7::method(element_grob, element_test) <- + function(element, label = "", x = NULL, y = NULL, ...) { + rectGrob(width = unit(1, "cm"), height = unit(1, "cm")) + } - plot <- ggplot(df, aes(label, y)) + geom_point() + - theme(axis.text.x = element_text(angle = 50, hjust = 1)) - expect_doppelganger("rotated x axis tick labels", plot) + df <- data_frame(x = 1:3, y = 1:3, a = letters[1:3]) + plot <- ggplot(df, aes(x, y)) + + geom_point() + + facet_wrap(~a) + + theme(strip.text = element_test()) + expect_doppelganger("custom strip elements can render", plot) }) +# Titles ------------------------------------------------------------------ + test_that("plot titles and caption can be aligned to entire plot", { df <- data_frame( x = 1:3, @@ -1028,6 +593,8 @@ test_that("plot titles and caption can be aligned to entire plot", { }) +# Legends ----------------------------------------------------------------- + test_that("Legends can on all sides of the plot with custom justification", { plot <- ggplot(mtcars) + @@ -1060,39 +627,6 @@ test_that("Legends can on all sides of the plot with custom justification", { expect_doppelganger("legends at all sides with justification", plot) }) -test_that("Strips can render custom elements", { - element_test <- S7::new_class("element_test", element_text) - S7::method(element_grob, element_test) <- - function(element, label = "", x = NULL, y = NULL, ...) { - rectGrob(width = unit(1, "cm"), height = unit(1, "cm")) - } - - df <- data_frame(x = 1:3, y = 1:3, a = letters[1:3]) - plot <- ggplot(df, aes(x, y)) + - geom_point() + - facet_wrap(~a) + - theme(strip.text = element_test()) - expect_doppelganger("custom strip elements can render", plot) -}) - -test_that("theme ink and paper settings work", { - - p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + - geom_point() + - facet_wrap(~"Strip title") + - labs( - title = "Main title", - subtitle = "Subtitle", - tag = "A", - caption = "Caption" - ) - - expect_doppelganger( - "Theme with inverted colours", - p + theme_gray(ink = "white", paper = "black") - ) -}) - test_that("legend margins are correct when using relative key sizes", { df <- data_frame(x = 1:3, y = 1:3, a = letters[1:3]) From ca9e94901d1986d8196d14811e1718bac16048a7 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 14:13:36 +0100 Subject: [PATCH 54/78] align `test-viridis.R` --- tests/testthat/{test-viridis.R => test-scale-viridis.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/testthat/{test-viridis.R => test-scale-viridis.R} (100%) diff --git a/tests/testthat/test-viridis.R b/tests/testthat/test-scale-viridis.R similarity index 100% rename from tests/testthat/test-viridis.R rename to tests/testthat/test-scale-viridis.R From 3475c893dd25185f47726b07c82a49a42029ed31 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 14:25:47 +0100 Subject: [PATCH 55/78] move `allow_lambda` to general `utilities.R` --- R/scale-.R | 5 ----- R/utilities.R | 5 +++++ 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/scale-.R b/R/scale-.R index d9837c8e15..960c59caa6 100644 --- a/R/scale-.R +++ b/R/scale-.R @@ -1795,11 +1795,6 @@ check_continuous_limits <- function(limits, ..., check_length(limits, 2L, arg = arg, call = call) } -allow_lambda <- function(x) { - # we check the 'call' class to prevent interpreting `bquote()` calls as a function - if (is_formula(x, lhs = FALSE) && !inherits(x, "call")) as_function(x) else x -} - validate_fallback_palette <- function(pal, fallback, aesthetic = "x", discrete = FALSE, call = caller_env()) { if (!is.null(pal) || is.function(fallback)) { diff --git a/R/utilities.R b/R/utilities.R index 4f3d96c084..357d82f707 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -73,6 +73,11 @@ check_required_aesthetics <- function(required, present, name, call = caller_env ) } +allow_lambda <- function(x) { + # we check the 'call' class to prevent interpreting `bquote()` calls as a function + if (is_formula(x, lhs = FALSE) && !inherits(x, "call")) as_function(x) else x +} + # Concatenate a named list for output # Print a `list(a=1, b=2)` as `(a=1, b=2)` # From 29c798a1452c05b6825befc045765a111f055f19 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 14:26:46 +0100 Subject: [PATCH 56/78] reorganise utilities tests --- tests/testthat/_snaps/summary.md | 16 ++++++++ tests/testthat/_snaps/utilities-break.md | 12 ++++++ tests/testthat/_snaps/utilities-grid.md | 8 ++++ tests/testthat/_snaps/utilities.md | 44 ++-------------------- tests/testthat/test-summary.R | 12 ++++++ tests/testthat/test-utilities-break.R | 6 +++ tests/testthat/test-utilities-grid.R | 5 +++ tests/testthat/test-utilities-resolution.R | 11 ++++++ tests/testthat/test-utilities.R | 44 ++-------------------- 9 files changed, 78 insertions(+), 80 deletions(-) create mode 100644 tests/testthat/_snaps/summary.md create mode 100644 tests/testthat/_snaps/utilities-grid.md create mode 100644 tests/testthat/test-summary.R create mode 100644 tests/testthat/test-utilities-resolution.R diff --git a/tests/testthat/_snaps/summary.md b/tests/testthat/_snaps/summary.md new file mode 100644 index 0000000000..50e6c07711 --- /dev/null +++ b/tests/testthat/_snaps/summary.md @@ -0,0 +1,16 @@ +# summary method gives a nice summary + + Code + summary(p) + Output + data: manufacturer, model, displ, year, cyl, trans, drv, cty, hwy, fl, + class [234x11] + mapping: x = ~displ, y = ~hwy, colour = ~drv + scales: x, xmin, xmax, xend, xintercept, xmin_final, xmax_final, xlower, xmiddle, xupper, x0, colour + faceting: ~year, ~cyl + ----------------------------------- + geom_point: na.rm = FALSE + stat_identity: na.rm = FALSE + position_identity + + diff --git a/tests/testthat/_snaps/utilities-break.md b/tests/testthat/_snaps/utilities-break.md index 31563a6cd7..0784afaae6 100644 --- a/tests/testthat/_snaps/utilities-break.md +++ b/tests/testthat/_snaps/utilities-break.md @@ -2,3 +2,15 @@ Specify exactly one of `n` and `length`. +# cut_*() checks its input and output + + Insufficient data values to produce 10 bins. + +--- + + Specify exactly one of `n` and `width`. + +--- + + Only one of `boundary` and `center` may be specified. + diff --git a/tests/testthat/_snaps/utilities-grid.md b/tests/testthat/_snaps/utilities-grid.md new file mode 100644 index 0000000000..a4755a6bde --- /dev/null +++ b/tests/testthat/_snaps/utilities-grid.md @@ -0,0 +1,8 @@ +# width_cm() and height_cm() checks input + + Don't know how to get width of object + +--- + + Don't know how to get height of object + diff --git a/tests/testthat/_snaps/utilities.md b/tests/testthat/_snaps/utilities.md index 4ccf6d67d1..d2d92eb96f 100644 --- a/tests/testthat/_snaps/utilities.md +++ b/tests/testthat/_snaps/utilities.md @@ -1,3 +1,7 @@ +# parse_safe() checks input + + `text` must be a character vector, not an integer vector. + # check_required_aesthetics() errors on missing `test()` requires the following missing aesthetics: y. @@ -30,43 +34,3 @@ Please use `to_upper_ascii()`, which works fine in all locales. -# parse_safe() checks input - - `text` must be a character vector, not an integer vector. - -# width_cm() and height_cm() checks input - - Don't know how to get width of object - ---- - - Don't know how to get height of object - -# cut_*() checks its input and output - - Insufficient data values to produce 10 bins. - ---- - - Specify exactly one of `n` and `width`. - ---- - - Only one of `boundary` and `center` may be specified. - -# summary method gives a nice summary - - Code - summary(p) - Output - data: manufacturer, model, displ, year, cyl, trans, drv, cty, hwy, fl, - class [234x11] - mapping: x = ~displ, y = ~hwy, colour = ~drv - scales: x, xmin, xmax, xend, xintercept, xmin_final, xmax_final, xlower, xmiddle, xupper, x0, colour - faceting: ~year, ~cyl - ----------------------------------- - geom_point: na.rm = FALSE - stat_identity: na.rm = FALSE - position_identity - - diff --git a/tests/testthat/test-summary.R b/tests/testthat/test-summary.R new file mode 100644 index 0000000000..7b9a420164 --- /dev/null +++ b/tests/testthat/test-summary.R @@ -0,0 +1,12 @@ +test_that("summary method gives a nice summary", { + # This test isn't important enough to break anything on CRAN + skip_on_cran() + + p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + + geom_point() + + scale_x_continuous() + + scale_colour_brewer() + + facet_grid(year ~ cyl) + + expect_snapshot(summary(p)) +}) diff --git a/tests/testthat/test-utilities-break.R b/tests/testthat/test-utilities-break.R index 23bc143a45..0e14986a8c 100644 --- a/tests/testthat/test-utilities-break.R +++ b/tests/testthat/test-utilities-break.R @@ -1,3 +1,9 @@ test_that("cut_interval throws the correct error message", { expect_snapshot_error(cut_interval(x = 1:10, width = 10)) }) + +test_that("cut_*() checks its input and output", { + expect_snapshot_error(cut_number(1, 10)) + expect_snapshot_error(breaks(1:10, "numbers", nbins = 2, binwidth = 05)) + expect_snapshot_error(cut_width(1:10, 1, center = 0, boundary = 0.5)) +}) diff --git a/tests/testthat/test-utilities-grid.R b/tests/testthat/test-utilities-grid.R index f9f018953e..c385c9a64f 100644 --- a/tests/testthat/test-utilities-grid.R +++ b/tests/testthat/test-utilities-grid.R @@ -4,3 +4,8 @@ test_that("width_cm and height_cm work with unit arithmetic", { expect_equal(width_cm(x), 2) expect_equal(height_cm(x), 2) }) + +test_that("width_cm() and height_cm() checks input", { + expect_snapshot_error(width_cm(letters)) + expect_snapshot_error(height_cm(letters)) +}) diff --git a/tests/testthat/test-utilities-resolution.R b/tests/testthat/test-utilities-resolution.R new file mode 100644 index 0000000000..effb3502d2 --- /dev/null +++ b/tests/testthat/test-utilities-resolution.R @@ -0,0 +1,11 @@ +test_that("resolution() gives correct answers", { + expect_equal(resolution(c(4, 6)), 2) + expect_equal(resolution(c(4L, 6L)), 1L) + expect_equal(resolution(mapped_discrete(c(4, 6)), discrete = TRUE), 1L) + expect_equal(resolution(mapped_discrete(c(4, 6))), 2) + expect_equal(resolution(c(0, 0)), 1L) + expect_equal(resolution(c(0.5, 1.5), zero = TRUE), 0.5) + + # resolution has a tolerance + expect_equal(resolution(c(1, 1 + 1000 * .Machine$double.eps, 2)), 1) +}) diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index 4768bbf3da..f1ead8175b 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -86,6 +86,10 @@ test_that("parse_safe works with multi expressions", { ) }) +test_that("parse_safe() checks input", { + expect_snapshot_error(parse_safe(1:5)) +}) + test_that("x and y aesthetics have the same length", { expect_length(ggplot_global$x_aes, length(ggplot_global$y_aes)) }) @@ -115,21 +119,6 @@ test_that("tolower() and toupper() has been masked", { expect_snapshot_error(toupper()) }) -test_that("parse_safe() checks input", { - expect_snapshot_error(parse_safe(1:5)) -}) - -test_that("width_cm() and height_cm() checks input", { - expect_snapshot_error(width_cm(letters)) - expect_snapshot_error(height_cm(letters)) -}) - -test_that("cut_*() checks its input and output", { - expect_snapshot_error(cut_number(1, 10)) - expect_snapshot_error(breaks(1:10, "numbers", nbins = 2, binwidth = 05)) - expect_snapshot_error(cut_width(1:10, 1, center = 0, boundary = 0.5)) -}) - test_that("vec_rbind0 can combined ordered factors", { withr::local_options(lifecycle_verbosity = "warning") @@ -158,18 +147,6 @@ test_that("vec_rbind0 can combined ordered factors", { }) -test_that("resolution() gives correct answers", { - expect_equal(resolution(c(4, 6)), 2) - expect_equal(resolution(c(4L, 6L)), 1L) - expect_equal(resolution(mapped_discrete(c(4, 6)), discrete = TRUE), 1L) - expect_equal(resolution(mapped_discrete(c(4, 6))), 2) - expect_equal(resolution(c(0, 0)), 1L) - expect_equal(resolution(c(0.5, 1.5), zero = TRUE), 0.5) - - # resolution has a tolerance - expect_equal(resolution(c(1, 1 + 1000 * .Machine$double.eps, 2)), 1) -}) - test_that("expose/ignore_data() can round-trip a data.frame", { # Plain data.frame @@ -205,16 +182,3 @@ test_that("allow_lambda converts the correct cases", { f <- allow_lambda(bquote("foo"~"bar")) expect_equal(f, call("~", "foo", "bar")) }) - -test_that("summary method gives a nice summary", { - # This test isn't important enough to break anything on CRAN - skip_on_cran() - - p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + - geom_point() + - scale_x_continuous() + - scale_colour_brewer() + - facet_grid(year ~ cyl) - - expect_snapshot(summary(p)) -}) From d815c7891d0c1579f3f04586261ce1262d323118 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 15:34:50 +0100 Subject: [PATCH 57/78] add snapshot tests for rd helper functions --- tests/testthat/_snaps/utilities-help.md | 76 +++++++++++++++++++++++++ tests/testthat/test-utilities-help.R | 34 +++++++++++ 2 files changed, 110 insertions(+) create mode 100644 tests/testthat/_snaps/utilities-help.md create mode 100644 tests/testthat/test-utilities-help.R diff --git a/tests/testthat/_snaps/utilities-help.md b/tests/testthat/_snaps/utilities-help.md new file mode 100644 index 0000000000..2dda94daaa --- /dev/null +++ b/tests/testthat/_snaps/utilities-help.md @@ -0,0 +1,76 @@ +# rd_orientation formats a section + + Code + rd_orientation() + Output + [1] "@section Orientation: " + [2] "This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \\code{orientation} parameter, which can be either \\code{\"x\"} or \\code{\"y\"}. The value gives the axis that the geom should run along, \\code{\"x\"} being the default orientation you would expect for the geom." + +# rd_computed_vars formats a list + + Code + rd_computed_vars(x = "foo", y = "bar") + Output + [1] "@section Computed variables: " + [2] "These are calculated by the 'stat' part of layers and can be accessed with [delayed evaluation][aes_eval]. " + [3] "* `after_stat(x)`\\cr foo" + [4] "* `after_stat(y)`\\cr bar" + +# rd_aesthetics formats a section + + Code + rd_aesthetics("geom", "point") + Output + [1] "@section Aesthetics:" + [2] "\\code{geom_point()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics:" + [3] "\\tabular{rll}{" + [4] " • \\tab \\strong{\\code{\\link[ggplot2:aes_position]{x}}} \\tab \\cr" + [5] " • \\tab \\strong{\\code{\\link[ggplot2:aes_position]{y}}} \\tab \\cr" + [6] " • \\tab \\code{\\link[ggplot2:aes_colour_fill_alpha]{alpha}} \\tab → \\code{NA} \\cr" + [7] " • \\tab \\code{\\link[ggplot2:aes_colour_fill_alpha]{colour}} \\tab → via \\code{theme()} \\cr" + [8] " • \\tab \\code{\\link[ggplot2:aes_colour_fill_alpha]{fill}} \\tab → via \\code{theme()} \\cr" + [9] " • \\tab \\code{\\link[ggplot2:aes_group_order]{group}} \\tab → inferred \\cr" + [10] " • \\tab \\code{\\link[ggplot2:aes_linetype_size_shape]{shape}} \\tab → via \\code{theme()} \\cr" + [11] " • \\tab \\code{\\link[ggplot2:aes_linetype_size_shape]{size}} \\tab → via \\code{theme()} \\cr" + [12] " • \\tab \\code{stroke} \\tab → via \\code{theme()} \\cr" + [13] "}" + [14] "Learn more about setting these aesthetics in \\code{vignette(\"ggplot2-specs\")}." + +# roxygen parses the @aesthetics tag + + Code + rd_text + Output + % Generated by roxygen2: do not edit by hand + % Please edit documentation in ./ + \name{geom_point} + \alias{geom_point} + \title{geom_point} + \description{ + geom_point + } + \section{Aesthetics}{ + + \code{geom_point()} understands the following aesthetics. Required aesthetics are displayed in bold and defaults are displayed for optional aesthetics: + \tabular{rll}{ + • \tab \strong{\code{\link[ggplot2:aes_position]{x}}} \tab \cr + • \tab \strong{\code{\link[ggplot2:aes_position]{y}}} \tab \cr + • \tab \code{\link[ggplot2:aes_colour_fill_alpha]{alpha}} \tab → \code{NA} \cr + • \tab \code{\link[ggplot2:aes_colour_fill_alpha]{colour}} \tab → via \code{theme()} \cr + • \tab \code{\link[ggplot2:aes_colour_fill_alpha]{fill}} \tab → via \code{theme()} \cr + • \tab \code{\link[ggplot2:aes_group_order]{group}} \tab → inferred \cr + • \tab \code{\link[ggplot2:aes_linetype_size_shape]{shape}} \tab → via \code{theme()} \cr + • \tab \code{\link[ggplot2:aes_linetype_size_shape]{size}} \tab → via \code{theme()} \cr + • \tab \code{stroke} \tab → via \code{theme()} \cr + } + + Learn more about setting these aesthetics in \code{vignette("ggplot2-specs")}. + } + +# link_book() works + + Code + link_book("facet chapter", "facet") + Output + [1] "[facet chapter](https://ggplot2-book.org/facet) of the online ggplot2 book." + diff --git a/tests/testthat/test-utilities-help.R b/tests/testthat/test-utilities-help.R new file mode 100644 index 0000000000..2cb633de9f --- /dev/null +++ b/tests/testthat/test-utilities-help.R @@ -0,0 +1,34 @@ + +test_that("rd_orientation formats a section", { + expect_snapshot(rd_orientation()) +}) + +test_that("rd_computed_vars formats a list", { + expect_snapshot(rd_computed_vars(x = "foo", y = "bar")) +}) + +test_that("rd_aesthetics formats a section", { + expect_snapshot(rd_aesthetics("geom", "point")) +}) + +test_that("roxygen parses the @aesthetics tag", { + skip_if_not_installed("roxygen2") + + text <- " + #' @title geom_point + #' @name geom_point + #' @aesthetics GeomPoint + NULL + " + + rd_text <- roxygen2::roc_proc_text( + roxygen2::rd_roclet(), + text + )[[1]] + + expect_snapshot(rd_text) +}) + +test_that("link_book() works", { + expect_snapshot(link_book("facet chapter", "facet")) +}) From 73ea06259b96047f9c93050a9de60cf2ca74fbde Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 16:05:13 +0100 Subject: [PATCH 58/78] add snapshot tests for `make_constructor()` --- tests/testthat/_snaps/make-constructor.md | 70 +++++++++++++++++++++ tests/testthat/test-make-constructor.R | 74 +++++++++++++++++++++++ 2 files changed, 144 insertions(+) create mode 100644 tests/testthat/_snaps/make-constructor.md create mode 100644 tests/testthat/test-make-constructor.R diff --git a/tests/testthat/_snaps/make-constructor.md b/tests/testthat/_snaps/make-constructor.md new file mode 100644 index 0000000000..5a39d06c2b --- /dev/null +++ b/tests/testthat/_snaps/make-constructor.md @@ -0,0 +1,70 @@ +# make_constructor builds a geom constructor + + Code + print(geom_foo) + Output + function (mapping = NULL, data = NULL, stat = "identity", position = "identity", + ..., my_param = "foo", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) + { + match.arg(my_param, c("foo", "bar")) + layer(mapping = mapping, data = data, geom = "foo", stat = stat, + position = position, show.legend = show.legend, inherit.aes = inherit.aes, + params = list2(na.rm = na.rm, my_param = my_param, ...)) + } + + +# make_constructor builds a stat constructor + + Code + print(stat_foo) + Output + function (mapping = NULL, data = NULL, geom = "point", position = "identity", + ..., my_param = "foo", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) + { + match.arg(my_param, c("foo", "bar")) + layer(mapping = mapping, data = data, geom = geom, stat = "foo", + position = position, show.legend = show.legend, inherit.aes = inherit.aes, + params = list2(na.rm = na.rm, my_param = my_param, ...)) + } + + +# make_constructor refuses overdefined cases + + Code + make_constructor(GeomPoint, geom = "line") + Condition + Error in `make_constructor()`: + ! `geom` is a reserved argument. + +--- + + Code + make_constructor(StatDensity, geom = "point", stat = "smooth") + Condition + Error in `make_constructor()`: + ! `stat` is a reversed argument. + +# make_constructor complains about default values + + In `geom_foo()`: please consider providing default values for: my_param. + +--- + + In `stat_foo()`: please consider providing default values for: my_param. + +# make_constructor rejects bad input for `checks` + + Code + make_constructor(GeomPoint, checks = 10) + Condition + Error in `make_constructor()`: + ! `checks` must be a list of calls, such as one constructed with `rlang::exprs()`. + +--- + + Code + make_constructor(StatDensity, geom = "line", checks = "A") + Condition + Error in `make_constructor()`: + ! `checks` must be a list of calls, such as one constructed with `rlang::exprs()`. + diff --git a/tests/testthat/test-make-constructor.R b/tests/testthat/test-make-constructor.R new file mode 100644 index 0000000000..2ee18d7b81 --- /dev/null +++ b/tests/testthat/test-make-constructor.R @@ -0,0 +1,74 @@ +# Printing closure environments is stochastic +censor_fun_env <- function(x) { + x[startsWith(x, "" + x +} + +test_that("make_constructor builds a geom constructor", { + GeomFoo <- ggproto( + "GeomFoo", Geom, + draw_panel = function(data, panel_params, coord, my_param = "foo") { + zeroGrob() + } + ) + check <- rlang::exprs(match.arg(my_param, c("foo", "bar"))) + geom_foo <- make_constructor(GeomFoo, checks = check) + expect_snapshot(print(geom_foo), transform = censor_fun_env) +}) + +test_that("make_constructor builds a stat constructor", { + StatFoo <- ggproto( + "StatFoo", Stat, + compute_panel = function(data, scales, my_param = "foo") { + data + } + ) + check <- rlang::exprs(match.arg(my_param, c("foo", "bar"))) + stat_foo <- make_constructor(StatFoo, geom = "point", checks = check) + expect_snapshot(print(stat_foo), transform = censor_fun_env) +}) + +test_that("make_constructor refuses overdefined cases", { + # Can't define Geom/Stat twice + expect_snapshot( + make_constructor(GeomPoint, geom = "line"), + error = TRUE + ) + expect_snapshot( + make_constructor(StatDensity, geom = "point", stat = "smooth"), + error = TRUE + ) +}) + +test_that("make_constructor complains about default values", { + # No default value for my_param + GeomFoo <- ggproto( + "GeomFoo", Geom, + draw_panel = function(data, panel_params, coord, my_param) { + zeroGrob() + } + ) + expect_snapshot_warning( + make_constructor(GeomFoo) + ) + StatFoo <- ggproto( + "StatFoo", Stat, + compute_panel = function(data, scales, my_param) { + data + } + ) + expect_snapshot_warning( + make_constructor(StatFoo, geom = "point") + ) +}) + +test_that("make_constructor rejects bad input for `checks`", { + expect_snapshot( + make_constructor(GeomPoint, checks = 10), + error = TRUE + ) + expect_snapshot( + make_constructor(StatDensity, geom = "line", checks = "A"), + error = TRUE + ) +}) From 136bbd04db82065f4a12113dfc000efad2c19cc0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 16:23:35 +0100 Subject: [PATCH 59/78] add tests for properties --- tests/testthat/test-properties.R | 68 ++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 tests/testthat/test-properties.R diff --git a/tests/testthat/test-properties.R b/tests/testthat/test-properties.R new file mode 100644 index 0000000000..adfdf69941 --- /dev/null +++ b/tests/testthat/test-properties.R @@ -0,0 +1,68 @@ +test_that("property_boolean works as intended", { + bool <- property_boolean(allow_null = TRUE) + expect_equal( + bool$class, + S7::new_union(S7::class_logical, NULL) + ) + # Good input + expect_length(bool$validator(TRUE), 0) + expect_length(bool$validator(NULL), 0) + # Bad input + expect_length(bool$validator(NA), 1) +}) + +test_that("property_choice works as intended", { + choice <- property_choice(options = c("A", "B"), allow_null = TRUE) + expect_equal( + choice$class, + S7::new_union(S7::class_character, NULL) + ) + # Good input + expect_length(choice$validator(NULL), 0) + expect_length(choice$validator("B"), 0) + # Bad input + expect_length(choice$validator("X"), 1) + expect_length(choice$validator(12), 1) +}) + +test_that("property_fontface works as intended", { + fontface <- property_fontface() + expect_equal( + fontface$class, + S7::new_union(S7::class_character, S7::class_numeric, NULL) + ) + + # Good input + expect_length(fontface$validator(NULL), 0) + expect_length(fontface$validator(2), 0) + expect_length(fontface$validator("italic"), 0) + # Bad input + expect_length(fontface$validator(10), 1) + expect_length(fontface$validator("foobar"), 1) +}) + +test_that("property_nullable works as intended", { + nullable <- property_nullable(S7::class_integer) + expect_equal( + nullable$class, + S7::new_union(NULL, S7::class_integer) + ) +}) + +test_that("property_colour works as intended", { + colour <- property_colour(pattern = TRUE) + expect_equal( + colour$class, + S7::new_union( + S7::class_character, + S7::class_logical, + S7::class_numeric, + S7::new_S3_class("GridPattern"), + NULL + ) + ) + # Good input + expect_length(colour$validator("blue"), 0) + # Bad input + expect_length(colour$validator(sqrt(2)), 1) +}) From 26c5b86646f1e97b0479888ee56a2c8f2bb288e0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 16:27:52 +0100 Subject: [PATCH 60/78] add test for `print( object, not a object. +# ggproto objects print well + + Code + print(Foo) + Output + + empty: NULL + env: environment + method: function + num: 12 + theme: theme, ggplot2::theme, gg, S7_object + +--- + + Code + print(Foo$method) + Output + + + function(...) !!call2(name, !!!args) + + + function(x) print(x) + diff --git a/tests/testthat/test-ggproto.R b/tests/testthat/test-ggproto.R index baad887619..8ecd69e5a0 100644 --- a/tests/testthat/test-ggproto.R +++ b/tests/testthat/test-ggproto.R @@ -55,3 +55,17 @@ test_that("all ggproto methods start with `{` (#6459)", { failures <- failures[lengths(failures) > 0] expect_equal(names(failures), character()) }) + +test_that("ggproto objects print well", { + Foo <- ggproto( + "Foo", + env = empty_env(), + num = 12, + method = function(x) print(x), + empty = NULL, + theme = theme() + ) + + expect_snapshot(print(Foo)) + expect_snapshot(print(Foo$method)) +}) From d5334f23fcf0e987339778f6ffc3f64d413d8865 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 16:38:41 +0100 Subject: [PATCH 61/78] extra utilities tests --- tests/testthat/_snaps/utilities.md | 10 ++++++++++ tests/testthat/test-utilities.R | 15 +++++++++++++++ 2 files changed, 25 insertions(+) diff --git a/tests/testthat/_snaps/utilities.md b/tests/testthat/_snaps/utilities.md index d2d92eb96f..9287f5a671 100644 --- a/tests/testthat/_snaps/utilities.md +++ b/tests/testthat/_snaps/utilities.md @@ -34,3 +34,13 @@ Please use `to_upper_ascii()`, which works fine in all locales. +# should_stop stops when it should + + Code + should_stop(invisible()) + Output + NULL + Condition + Error in `should_stop()`: + ! No error! + diff --git a/tests/testthat/test-utilities.R b/tests/testthat/test-utilities.R index f1ead8175b..66e380c973 100644 --- a/tests/testthat/test-utilities.R +++ b/tests/testthat/test-utilities.R @@ -182,3 +182,18 @@ test_that("allow_lambda converts the correct cases", { f <- allow_lambda(bquote("foo"~"bar")) expect_equal(f, call("~", "foo", "bar")) }) + +test_that("should_stop stops when it should", { + expect_silent(should_stop(stop())) + expect_snapshot(should_stop(invisible()), error = TRUE) +}) + +test_that("fallback_palette finds palettes", { + sc <- continuous_scale("colour", palette = NULL, fallback.palette = pal_identity()) + pal <- fallback_palette(sc) + expect_true(is_continuous_pal(pal)) + + sc <- discrete_scale("shape", palette = NULL, fallback.palette = pal_identity()) + pal <- fallback_palette(sc) + expect_true(is_discrete_pal(pal)) +}) From 3f052015bcfdaab3fe0016bb4be81a32665a860e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Fri, 7 Nov 2025 16:50:15 +0100 Subject: [PATCH 62/78] add test for `deprecated_guide_args()` --- tests/testthat/test-guide-legend.R | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R index 063b99b836..910dd2bdc9 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -156,6 +156,29 @@ test_that("legend filters out aesthetics not of length 1", { expect_no_error(ggplot_gtable(ggplot_build(p))) }) +test_that("deprecated_guide_args works as expected", { + thm <- guide_legend( + label.hjust = 0.5, + title.hjust = 0.5, + frame.colour = "black", + ticks.colour = "black", + axis.colour = "black", + theme = list() + )$params$theme + expect_true(is_theme_element(thm$legend.frame, "rect")) + expect_true(is_theme_element(thm$legend.ticks, "line")) + expect_true(is_theme_element(thm$legend.axis.line, "line")) + expect_true(is_theme_element(thm$legend.text, "text")) + expect_true(is_theme_element(thm$legend.title, "text")) + + thm <- guide_legend( + label = FALSE, + ticks = FALSE, + axis = FALSE + )$params$theme + expect_true(is_theme_element(thm$legend.text, "blank")) +}) + # Visual tests ------------------------------------------------------------ test_that("legend directions are set correctly", { From 06ba50379e3ee03ca04302022ff98a91d9f9583d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Nov 2025 09:22:44 +0100 Subject: [PATCH 63/78] fix a few loose ends --- DESCRIPTION | 2 +- tests/testthat/test-guide-legend.R | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index f8baa1abc4..0e01d03cc7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -203,7 +203,6 @@ Collate: 'layer-sf.R' 'layout.R' 'limits.R' - 'performance.R' 'plot-build.R' 'plot-construction.R' 'plot-last.R' @@ -282,6 +281,7 @@ Collate: 'utilities-grid.R' 'utilities-help.R' 'utilities-patterns.R' + 'utilities-performance.R' 'utilities-resolution.R' 'utilities-tidy-eval.R' 'zxx.R' diff --git a/tests/testthat/test-guide-legend.R b/tests/testthat/test-guide-legend.R index 910dd2bdc9..c4b41995f7 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -157,6 +157,9 @@ test_that("legend filters out aesthetics not of length 1", { }) test_that("deprecated_guide_args works as expected", { + + withr::local_options(lifecycle_verbosity = "quiet") + thm <- guide_legend( label.hjust = 0.5, title.hjust = 0.5, @@ -165,6 +168,7 @@ test_that("deprecated_guide_args works as expected", { axis.colour = "black", theme = list() )$params$theme + expect_true(is_theme_element(thm$legend.frame, "rect")) expect_true(is_theme_element(thm$legend.ticks, "line")) expect_true(is_theme_element(thm$legend.axis.line, "line")) From b98c26e6b89742b5c13662e9ef1c46302cf11156 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Nov 2025 10:13:19 +0100 Subject: [PATCH 64/78] redocument `AxisSecondary` --- R/axis-secondary.R | 3 ++- man/AxisSecondary.Rd | 10 ++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) create mode 100644 man/AxisSecondary.Rd diff --git a/R/axis-secondary.R b/R/axis-secondary.R index 1d70542150..2be809b382 100644 --- a/R/axis-secondary.R +++ b/R/axis-secondary.R @@ -153,7 +153,8 @@ derive <- function() { is_derived <- function(x) { inherits(x, "derived") } -#' @noRd +#' Secondary axis class +#' @keywords internal #' @format NULL #' @usage NULL #' @export diff --git a/man/AxisSecondary.Rd b/man/AxisSecondary.Rd new file mode 100644 index 0000000000..d8a77ae54e --- /dev/null +++ b/man/AxisSecondary.Rd @@ -0,0 +1,10 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/axis-secondary.R +\docType{data} +\name{AxisSecondary} +\alias{AxisSecondary} +\title{Secondary axis class} +\description{ +Secondary axis class +} +\keyword{internal} From a483fd03887a3e457ddb0a95102619b5c2e8fb4f Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Nov 2025 10:30:14 +0100 Subject: [PATCH 65/78] separate `guide_bins()` and `guide_coloursteps()` snapshots --- tests/testthat/_snaps/guide-bins.md | 5 ++ ...s-sets-labels-when-limits-is-in-breaks.svg | 0 ...derstands-coinciding-limits-and-bins-2.svg | 0 ...derstands-coinciding-limits-and-bins-3.svg | 0 ...understands-coinciding-limits-and-bins.svg | 0 tests/testthat/_snaps/guide-colorsteps.md | 5 -- tests/testthat/test-guide-bins.R | 47 +++++++++++++++++++ tests/testthat/test-guide-colorsteps.R | 42 ----------------- 8 files changed, 52 insertions(+), 47 deletions(-) create mode 100644 tests/testthat/_snaps/guide-bins.md rename tests/testthat/_snaps/{guide-colorsteps => guide-bins}/guide-bins-sets-labels-when-limits-is-in-breaks.svg (100%) rename tests/testthat/_snaps/{guide-colorsteps => guide-bins}/guide-bins-understands-coinciding-limits-and-bins-2.svg (100%) rename tests/testthat/_snaps/{guide-colorsteps => guide-bins}/guide-bins-understands-coinciding-limits-and-bins-3.svg (100%) rename tests/testthat/_snaps/{guide-colorsteps => guide-bins}/guide-bins-understands-coinciding-limits-and-bins.svg (100%) diff --git a/tests/testthat/_snaps/guide-bins.md b/tests/testthat/_snaps/guide-bins.md new file mode 100644 index 0000000000..b74ca82cc0 --- /dev/null +++ b/tests/testthat/_snaps/guide-bins.md @@ -0,0 +1,5 @@ +# binning scales understand the different combinations of limits, breaks, labels, and show.limits + + `show.limits` is ignored when `labels` are given as a character vector. + i Either add the limits to `breaks` or provide a function for `labels`. + diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-bins-sets-labels-when-limits-is-in-breaks.svg b/tests/testthat/_snaps/guide-bins/guide-bins-sets-labels-when-limits-is-in-breaks.svg similarity index 100% rename from tests/testthat/_snaps/guide-colorsteps/guide-bins-sets-labels-when-limits-is-in-breaks.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-sets-labels-when-limits-is-in-breaks.svg diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-2.svg b/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-2.svg similarity index 100% rename from tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-2.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-2.svg diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-3.svg b/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-3.svg similarity index 100% rename from tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins-3.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-3.svg diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins.svg b/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins.svg similarity index 100% rename from tests/testthat/_snaps/guide-colorsteps/guide-bins-understands-coinciding-limits-and-bins.svg rename to tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins.svg diff --git a/tests/testthat/_snaps/guide-colorsteps.md b/tests/testthat/_snaps/guide-colorsteps.md index f7aadf6b09..b74ca82cc0 100644 --- a/tests/testthat/_snaps/guide-colorsteps.md +++ b/tests/testthat/_snaps/guide-colorsteps.md @@ -3,8 +3,3 @@ `show.limits` is ignored when `labels` are given as a character vector. i Either add the limits to `breaks` or provide a function for `labels`. ---- - - `show.limits` is ignored when `labels` are given as a character vector. - i Either add the limits to `breaks` or provide a function for `labels`. - diff --git a/tests/testthat/test-guide-bins.R b/tests/testthat/test-guide-bins.R index 1bccc804a8..28331c9690 100644 --- a/tests/testthat/test-guide-bins.R +++ b/tests/testthat/test-guide-bins.R @@ -54,3 +54,50 @@ test_that("bin guide can be styled correctly", { p + guides(size = guide_bins(direction = "horizontal")) ) }) + +test_that("binning scales understand the different combinations of limits, breaks, labels, and show.limits", { + p <- ggplot(mpg, aes(cty, hwy, color = year)) + + geom_point() + + expect_doppelganger( + "guide_bins understands coinciding limits and bins", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + guide = 'bins' + ) + ) + expect_doppelganger( + "guide_bins understands coinciding limits and bins 2", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(2000, 2002, 2004, 2006, 2008), + guide = 'bins' + ) + ) + expect_doppelganger( + "guide_bins understands coinciding limits and bins 3", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + guide = 'bins', + show.limits = TRUE + ) + ) + expect_doppelganger( + "guide_bins sets labels when limits is in breaks", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + labels = 1:5, + guide = 'bins' + ) + ) + expect_snapshot_warning(ggplotGrob( + p + scale_color_binned(labels = 1:4, show.limits = TRUE, guide = "bins") + )) +}) diff --git a/tests/testthat/test-guide-colorsteps.R b/tests/testthat/test-guide-colorsteps.R index 6e0bf8beee..5ee3828d94 100644 --- a/tests/testthat/test-guide-colorsteps.R +++ b/tests/testthat/test-guide-colorsteps.R @@ -115,48 +115,6 @@ test_that("binning scales understand the different combinations of limits, break p <- ggplot(mpg, aes(cty, hwy, color = year)) + geom_point() - expect_doppelganger( - "guide_bins understands coinciding limits and bins", - p + - scale_color_binned( - limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - guide = 'bins' - ) - ) - expect_doppelganger( - "guide_bins understands coinciding limits and bins 2", - p + - scale_color_binned( - limits = c(1999, 2008), - breaks = c(2000, 2002, 2004, 2006, 2008), - guide = 'bins' - ) - ) - expect_doppelganger( - "guide_bins understands coinciding limits and bins 3", - p + - scale_color_binned( - limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - guide = 'bins', - show.limits = TRUE - ) - ) - expect_doppelganger( - "guide_bins sets labels when limits is in breaks", - p + - scale_color_binned( - limits = c(1999, 2008), - breaks = c(1999, 2000, 2002, 2004, 2006), - labels = 1:5, - guide = 'bins' - ) - ) - expect_snapshot_warning(ggplotGrob( - p + scale_color_binned(labels = 1:4, show.limits = TRUE, guide = "bins") - )) - expect_doppelganger( "guide_colorsteps understands coinciding limits and bins", p + From a536c66eac27c7adc3cd0047f230674c480a0136 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Nov 2025 10:35:05 +0100 Subject: [PATCH 66/78] attempt to adhere to file name limits --- ...ns-2.svg => coinciding-limits-and-bins-2.svg} | 2 +- ...ns-3.svg => coinciding-limits-and-bins-3.svg} | 2 +- ...d-bins.svg => coinciding-limits-and-bins.svg} | 2 +- ...s.svg => labels-when-limits-is-in-breaks.svg} | 2 +- ...-bins-can-remove-axis.svg => remove-axis.svg} | 2 +- ...-bins-can-show-arrows.svg => show-arrows.svg} | 2 +- ...-bins-can-show-limits.svg => show-limits.svg} | 2 +- ...rk-horizontally.svg => work-horizontally.svg} | 2 +- ...-binsize.svg => bins-relative-to-binsize.svg} | 2 +- ...ns-2.svg => coinciding-limits-and-bins-2.svg} | 2 +- ...ns-3.svg => coinciding-limits-and-bins-3.svg} | 2 +- ...d-bins.svg => coinciding-limits-and-bins.svg} | 2 +- ...s.svg => labels-when-limits-is-in-breaks.svg} | 2 +- ...steps-can-show-limits.svg => show-limits.svg} | 2 +- ...rancy.svg => show-ticks-and-transparancy.svg} | 2 +- tests/testthat/test-guide-bins.R | 16 ++++++++-------- tests/testthat/test-guide-colorsteps.R | 14 +++++++------- 17 files changed, 30 insertions(+), 30 deletions(-) rename tests/testthat/_snaps/guide-bins/{guide-bins-understands-coinciding-limits-and-bins-2.svg => coinciding-limits-and-bins-2.svg} (99%) rename tests/testthat/_snaps/guide-bins/{guide-bins-understands-coinciding-limits-and-bins-3.svg => coinciding-limits-and-bins-3.svg} (99%) rename tests/testthat/_snaps/guide-bins/{guide-bins-understands-coinciding-limits-and-bins.svg => coinciding-limits-and-bins.svg} (99%) rename tests/testthat/_snaps/guide-bins/{guide-bins-sets-labels-when-limits-is-in-breaks.svg => labels-when-limits-is-in-breaks.svg} (99%) rename tests/testthat/_snaps/guide-bins/{guide-bins-can-remove-axis.svg => remove-axis.svg} (98%) rename tests/testthat/_snaps/guide-bins/{guide-bins-can-show-arrows.svg => show-arrows.svg} (98%) rename tests/testthat/_snaps/guide-bins/{guide-bins-can-show-limits.svg => show-limits.svg} (98%) rename tests/testthat/_snaps/guide-bins/{guide-bins-work-horizontally.svg => work-horizontally.svg} (98%) rename tests/testthat/_snaps/guide-colorsteps/{guide-coloursteps-can-have-bins-relative-to-binsize.svg => bins-relative-to-binsize.svg} (97%) rename tests/testthat/_snaps/guide-colorsteps/{guide-colorsteps-understands-coinciding-limits-and-bins-2.svg => coinciding-limits-and-bins-2.svg} (99%) rename tests/testthat/_snaps/guide-colorsteps/{guide-colorsteps-understands-coinciding-limits-and-bins-3.svg => coinciding-limits-and-bins-3.svg} (99%) rename tests/testthat/_snaps/guide-colorsteps/{guide-colorsteps-understands-coinciding-limits-and-bins.svg => coinciding-limits-and-bins.svg} (99%) rename tests/testthat/_snaps/guide-colorsteps/{guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg => labels-when-limits-is-in-breaks.svg} (99%) rename tests/testthat/_snaps/guide-colorsteps/{guide-coloursteps-can-show-limits.svg => show-limits.svg} (98%) rename tests/testthat/_snaps/guide-colorsteps/{guide-bins-can-show-ticks-and-transparancy.svg => show-ticks-and-transparancy.svg} (98%) diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-2.svg b/tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins-2.svg similarity index 99% rename from tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-2.svg rename to tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins-2.svg index 4139ddca47..1355049ed5 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-2.svg +++ b/tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins-2.svg @@ -307,6 +307,6 @@ 2004 2006 2008 -guide_bins understands coinciding limits and bins 2 +coinciding limits and bins 2 diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-3.svg b/tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins-3.svg similarity index 99% rename from tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-3.svg rename to tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins-3.svg index 5a89f75984..5a60c52d71 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins-3.svg +++ b/tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins-3.svg @@ -309,6 +309,6 @@ 2004 2006 2008 -guide_bins understands coinciding limits and bins 3 +coinciding limits and bins 3 diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins.svg b/tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins.svg similarity index 99% rename from tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins.svg rename to tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins.svg index db8bce73dd..21c96a2ce4 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-understands-coinciding-limits-and-bins.svg +++ b/tests/testthat/_snaps/guide-bins/coinciding-limits-and-bins.svg @@ -307,6 +307,6 @@ 2002 2004 2006 -guide_bins understands coinciding limits and bins +coinciding limits and bins diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-sets-labels-when-limits-is-in-breaks.svg b/tests/testthat/_snaps/guide-bins/labels-when-limits-is-in-breaks.svg similarity index 99% rename from tests/testthat/_snaps/guide-bins/guide-bins-sets-labels-when-limits-is-in-breaks.svg rename to tests/testthat/_snaps/guide-bins/labels-when-limits-is-in-breaks.svg index aadb4a0b81..5e9cf7337d 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-sets-labels-when-limits-is-in-breaks.svg +++ b/tests/testthat/_snaps/guide-bins/labels-when-limits-is-in-breaks.svg @@ -307,6 +307,6 @@ 3 4 5 -guide_bins sets labels when limits is in breaks +labels when limits is in breaks diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-can-remove-axis.svg b/tests/testthat/_snaps/guide-bins/remove-axis.svg similarity index 98% rename from tests/testthat/_snaps/guide-bins/guide-bins-can-remove-axis.svg rename to tests/testthat/_snaps/guide-bins/remove-axis.svg index c58ac5df8c..5b1b8a84ae 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-can-remove-axis.svg +++ b/tests/testthat/_snaps/guide-bins/remove-axis.svg @@ -68,6 +68,6 @@ 1.5 2.0 2.5 -guide_bins can remove axis +remove axis diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-can-show-arrows.svg b/tests/testthat/_snaps/guide-bins/show-arrows.svg similarity index 98% rename from tests/testthat/_snaps/guide-bins/guide-bins-can-show-arrows.svg rename to tests/testthat/_snaps/guide-bins/show-arrows.svg index 442087e8c3..b14c89c784 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-can-show-arrows.svg +++ b/tests/testthat/_snaps/guide-bins/show-arrows.svg @@ -74,6 +74,6 @@ 1.5 2.0 2.5 -guide_bins can show arrows +show arrows diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-can-show-limits.svg b/tests/testthat/_snaps/guide-bins/show-limits.svg similarity index 98% rename from tests/testthat/_snaps/guide-bins/guide-bins-can-show-limits.svg rename to tests/testthat/_snaps/guide-bins/show-limits.svg index d2271a703e..c0a905644d 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-can-show-limits.svg +++ b/tests/testthat/_snaps/guide-bins/show-limits.svg @@ -76,6 +76,6 @@ 2.0 2.5 3 -guide_bins can show limits +show limits diff --git a/tests/testthat/_snaps/guide-bins/guide-bins-work-horizontally.svg b/tests/testthat/_snaps/guide-bins/work-horizontally.svg similarity index 98% rename from tests/testthat/_snaps/guide-bins/guide-bins-work-horizontally.svg rename to tests/testthat/_snaps/guide-bins/work-horizontally.svg index 587e0b20c3..0eb053e926 100644 --- a/tests/testthat/_snaps/guide-bins/guide-bins-work-horizontally.svg +++ b/tests/testthat/_snaps/guide-bins/work-horizontally.svg @@ -72,6 +72,6 @@ 1.5 2.0 2.5 -guide_bins work horizontally +work horizontally diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-have-bins-relative-to-binsize.svg b/tests/testthat/_snaps/guide-colorsteps/bins-relative-to-binsize.svg similarity index 97% rename from tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-have-bins-relative-to-binsize.svg rename to tests/testthat/_snaps/guide-colorsteps/bins-relative-to-binsize.svg index 274ad91fbe..8368b5ac2f 100644 --- a/tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-have-bins-relative-to-binsize.svg +++ b/tests/testthat/_snaps/guide-colorsteps/bins-relative-to-binsize.svg @@ -62,6 +62,6 @@ 1.5 2.0 3.0 -guide_coloursteps can have bins relative to binsize +bins relative to binsize diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg b/tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins-2.svg similarity index 99% rename from tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg rename to tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins-2.svg index f1855cedf9..88308dbd12 100644 --- a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-2.svg +++ b/tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins-2.svg @@ -296,6 +296,6 @@ 2004 2006 2008 -guide_colorsteps understands coinciding limits and bins 2 +coinciding limits and bins 2 diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg b/tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins-3.svg similarity index 99% rename from tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg rename to tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins-3.svg index 3682f1b2e0..eedaa37a38 100644 --- a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins-3.svg +++ b/tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins-3.svg @@ -297,6 +297,6 @@ 2004 2006 2008 -guide_colorsteps understands coinciding limits and bins 3 +coinciding limits and bins 3 diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins.svg b/tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins.svg similarity index 99% rename from tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins.svg rename to tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins.svg index 61350097bc..f722d7004e 100644 --- a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-understands-coinciding-limits-and-bins.svg +++ b/tests/testthat/_snaps/guide-colorsteps/coinciding-limits-and-bins.svg @@ -296,6 +296,6 @@ 2002 2004 2006 -guide_colorsteps understands coinciding limits and bins +coinciding limits and bins diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg b/tests/testthat/_snaps/guide-colorsteps/labels-when-limits-is-in-breaks.svg similarity index 99% rename from tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg rename to tests/testthat/_snaps/guide-colorsteps/labels-when-limits-is-in-breaks.svg index 9575c4f9f9..ad63b25fc7 100644 --- a/tests/testthat/_snaps/guide-colorsteps/guide-colorsteps-sets-labels-when-limits-is-in-breaks.svg +++ b/tests/testthat/_snaps/guide-colorsteps/labels-when-limits-is-in-breaks.svg @@ -296,6 +296,6 @@ 3 4 5 -guide_colorsteps sets labels when limits is in breaks +labels when limits is in breaks diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-show-limits.svg b/tests/testthat/_snaps/guide-colorsteps/show-limits.svg similarity index 98% rename from tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-show-limits.svg rename to tests/testthat/_snaps/guide-colorsteps/show-limits.svg index 3601641e36..09643158ec 100644 --- a/tests/testthat/_snaps/guide-colorsteps/guide-coloursteps-can-show-limits.svg +++ b/tests/testthat/_snaps/guide-colorsteps/show-limits.svg @@ -64,6 +64,6 @@ 2.0 3.0 4 -guide_coloursteps can show limits +show limits diff --git a/tests/testthat/_snaps/guide-colorsteps/guide-bins-can-show-ticks-and-transparancy.svg b/tests/testthat/_snaps/guide-colorsteps/show-ticks-and-transparancy.svg similarity index 98% rename from tests/testthat/_snaps/guide-colorsteps/guide-bins-can-show-ticks-and-transparancy.svg rename to tests/testthat/_snaps/guide-colorsteps/show-ticks-and-transparancy.svg index 824123d482..992983411b 100644 --- a/tests/testthat/_snaps/guide-colorsteps/guide-bins-can-show-ticks-and-transparancy.svg +++ b/tests/testthat/_snaps/guide-colorsteps/show-ticks-and-transparancy.svg @@ -68,6 +68,6 @@ 1.5 2.0 3.0 -guide_bins can show ticks and transparancy +show ticks and transparancy diff --git a/tests/testthat/test-guide-bins.R b/tests/testthat/test-guide-bins.R index 28331c9690..7e06d2f5cc 100644 --- a/tests/testthat/test-guide-bins.R +++ b/tests/testthat/test-guide-bins.R @@ -25,11 +25,11 @@ test_that("bin guide can be styled correctly", { expect_doppelganger("guide_bins looks as it should", p) expect_doppelganger( - "guide_bins can show limits", + "show limits", p + guides(size = guide_bins(show.limits = TRUE)) ) expect_doppelganger( - "guide_bins can show arrows", + "show arrows", p + guides(size = guide_bins()) + theme_test() + @@ -41,7 +41,7 @@ test_that("bin guide can be styled correctly", { ) ) expect_doppelganger( - "guide_bins can remove axis", + "remove axis", p + guides(size = guide_bins()) + theme_test() + @@ -50,7 +50,7 @@ test_that("bin guide can be styled correctly", { ) ) expect_doppelganger( - "guide_bins work horizontally", + "work horizontally", p + guides(size = guide_bins(direction = "horizontal")) ) }) @@ -60,7 +60,7 @@ test_that("binning scales understand the different combinations of limits, break geom_point() expect_doppelganger( - "guide_bins understands coinciding limits and bins", + "coinciding limits and bins", p + scale_color_binned( limits = c(1999, 2008), @@ -69,7 +69,7 @@ test_that("binning scales understand the different combinations of limits, break ) ) expect_doppelganger( - "guide_bins understands coinciding limits and bins 2", + "coinciding limits and bins 2", p + scale_color_binned( limits = c(1999, 2008), @@ -78,7 +78,7 @@ test_that("binning scales understand the different combinations of limits, break ) ) expect_doppelganger( - "guide_bins understands coinciding limits and bins 3", + "coinciding limits and bins 3", p + scale_color_binned( limits = c(1999, 2008), @@ -88,7 +88,7 @@ test_that("binning scales understand the different combinations of limits, break ) ) expect_doppelganger( - "guide_bins sets labels when limits is in breaks", + "labels when limits is in breaks", p + scale_color_binned( limits = c(1999, 2008), diff --git a/tests/testthat/test-guide-colorsteps.R b/tests/testthat/test-guide-colorsteps.R index 5ee3828d94..ea8e0cc717 100644 --- a/tests/testthat/test-guide-colorsteps.R +++ b/tests/testthat/test-guide-colorsteps.R @@ -90,15 +90,15 @@ test_that("coloursteps guide can be styled correctly", { expect_doppelganger("guide_coloursteps looks as it should", p) expect_doppelganger( - "guide_coloursteps can show limits", + "show limits", p + guides(colour = guide_coloursteps(show.limits = TRUE)) ) expect_doppelganger( - "guide_coloursteps can have bins relative to binsize", + "bins relative to binsize", p + guides(colour = guide_coloursteps(even.steps = FALSE)) ) expect_doppelganger( - "guide_bins can show ticks and transparancy", + "show ticks and transparancy", p + guides( colour = guide_coloursteps( @@ -116,7 +116,7 @@ test_that("binning scales understand the different combinations of limits, break geom_point() expect_doppelganger( - "guide_colorsteps understands coinciding limits and bins", + "coinciding limits and bins", p + scale_color_binned( limits = c(1999, 2008), @@ -124,7 +124,7 @@ test_that("binning scales understand the different combinations of limits, break ) ) expect_doppelganger( - "guide_colorsteps understands coinciding limits and bins 2", + "coinciding limits and bins 2", p + scale_color_binned( limits = c(1999, 2008), @@ -132,7 +132,7 @@ test_that("binning scales understand the different combinations of limits, break ) ) expect_doppelganger( - "guide_colorsteps understands coinciding limits and bins 3", + "coinciding limits and bins 3", p + scale_color_binned( limits = c(1999, 2008), @@ -141,7 +141,7 @@ test_that("binning scales understand the different combinations of limits, break ) ) expect_doppelganger( - "guide_colorsteps sets labels when limits is in breaks", + "labels when limits is in breaks", p + scale_color_binned( limits = c(1999, 2008), From 543085988a2577b8df683c2c5dd43a5a4ac821b3 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Nov 2025 11:04:40 +0100 Subject: [PATCH 67/78] remove fickle snapshot test --- tests/testthat/_snaps/ggproto.md | 12 ------------ tests/testthat/test-ggproto.R | 1 - 2 files changed, 13 deletions(-) diff --git a/tests/testthat/_snaps/ggproto.md b/tests/testthat/_snaps/ggproto.md index bb611a4f5f..2fbd19d83f 100644 --- a/tests/testthat/_snaps/ggproto.md +++ b/tests/testthat/_snaps/ggproto.md @@ -22,15 +22,3 @@ num: 12 theme: theme, ggplot2::theme, gg, S7_object ---- - - Code - print(Foo$method) - Output - - - function(...) !!call2(name, !!!args) - - - function(x) print(x) - diff --git a/tests/testthat/test-ggproto.R b/tests/testthat/test-ggproto.R index 8ecd69e5a0..7ffe265735 100644 --- a/tests/testthat/test-ggproto.R +++ b/tests/testthat/test-ggproto.R @@ -67,5 +67,4 @@ test_that("ggproto objects print well", { ) expect_snapshot(print(Foo)) - expect_snapshot(print(Foo$method)) }) From ea2c74024a473927997a7271727aa8ccebf34825 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Nov 2025 12:38:10 +0100 Subject: [PATCH 68/78] turn off aesthetics section check on older R --- tests/testthat/test-utilities-help.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-utilities-help.R b/tests/testthat/test-utilities-help.R index 2cb633de9f..ffc86ec320 100644 --- a/tests/testthat/test-utilities-help.R +++ b/tests/testthat/test-utilities-help.R @@ -4,10 +4,12 @@ test_that("rd_orientation formats a section", { }) test_that("rd_computed_vars formats a list", { + skip_if(getRversion() < "4.2.0") expect_snapshot(rd_computed_vars(x = "foo", y = "bar")) }) test_that("rd_aesthetics formats a section", { + skip_if(getRversion() < "4.2.0") expect_snapshot(rd_aesthetics("geom", "point")) }) From 75be62089f65e516cdab0280e15aaa75e3703cd0 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 10 Nov 2025 13:18:50 +0100 Subject: [PATCH 69/78] lol at my incompetence --- tests/testthat/test-utilities-help.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-utilities-help.R b/tests/testthat/test-utilities-help.R index ffc86ec320..6c629f1a94 100644 --- a/tests/testthat/test-utilities-help.R +++ b/tests/testthat/test-utilities-help.R @@ -4,7 +4,6 @@ test_that("rd_orientation formats a section", { }) test_that("rd_computed_vars formats a list", { - skip_if(getRversion() < "4.2.0") expect_snapshot(rd_computed_vars(x = "foo", y = "bar")) }) @@ -14,6 +13,7 @@ test_that("rd_aesthetics formats a section", { }) test_that("roxygen parses the @aesthetics tag", { + skip_if(getRversion() < "4.2.0") skip_if_not_installed("roxygen2") text <- " From b4bb908485f9f7c848a6460d5ba3c307c72c1884 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Tue, 18 Nov 2025 15:19:50 +0100 Subject: [PATCH 70/78] update snapshots --- tests/testthat/_snaps/4.2/theme.md | 8 ++++++++ tests/testthat/_snaps/utilities-help.md | 3 +-- 2 files changed, 9 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/_snaps/4.2/theme.md diff --git a/tests/testthat/_snaps/4.2/theme.md b/tests/testthat/_snaps/4.2/theme.md new file mode 100644 index 0000000000..e4df8865e7 --- /dev/null +++ b/tests/testthat/_snaps/4.2/theme.md @@ -0,0 +1,8 @@ +# modifying theme element properties with + operator works + + Code + theme_grey() + "asdf" + Condition + Error in `method(+, list(ggplot2::theme, class_any))`: + ! Can't add `"asdf"` to a theme object. + diff --git a/tests/testthat/_snaps/utilities-help.md b/tests/testthat/_snaps/utilities-help.md index 2dda94daaa..4396fffdc0 100644 --- a/tests/testthat/_snaps/utilities-help.md +++ b/tests/testthat/_snaps/utilities-help.md @@ -3,8 +3,7 @@ Code rd_orientation() Output - [1] "@section Orientation: " - [2] "This geom treats each axis differently and, thus, can thus have two orientations. Often the orientation is easy to deduce from a combination of the given mappings and the types of positional scales in use. Thus, ggplot2 will by default try to guess which orientation the layer should have. Under rare circumstances, the orientation is ambiguous and guessing may fail. In that case the orientation can be specified directly using the \\code{orientation} parameter, which can be either \\code{\"x\"} or \\code{\"y\"}. The value gives the axis that the geom should run along, \\code{\"x\"} being the default orientation you would expect for the geom." + [1] "@inheritSection ggplot2::shared_layer_parameters Orientation" # rd_computed_vars formats a list From 274a59aaf1789f44ee7e3da408ccc37acbef3f81 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 20 Nov 2025 09:54:48 +0100 Subject: [PATCH 71/78] redocument --- man/shared_layer_parameters.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/shared_layer_parameters.Rd b/man/shared_layer_parameters.Rd index de0676efe3..88c9e59b97 100644 --- a/man/shared_layer_parameters.Rd +++ b/man/shared_layer_parameters.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/docs_layer.R +% Please edit documentation in R/docs-layer.R \name{shared_layer_parameters} \title{Shared layer parameters} \arguments{ From bf1d3787246a4af430731eb66bdc6f53a44b068d Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Thu, 20 Nov 2025 10:25:31 +0100 Subject: [PATCH 72/78] get rid of variant snapshots --- R/theme.R | 2 +- tests/testthat/_snaps/4.0/theme.md | 8 -------- tests/testthat/_snaps/4.2/theme.md | 8 -------- tests/testthat/_snaps/4.4/theme.md | 8 -------- tests/testthat/_snaps/4.5/theme.md | 8 -------- tests/testthat/_snaps/theme.md | 8 ++++++++ tests/testthat/test-theme.R | 6 +----- 7 files changed, 10 insertions(+), 38 deletions(-) delete mode 100644 tests/testthat/_snaps/4.0/theme.md delete mode 100644 tests/testthat/_snaps/4.2/theme.md delete mode 100644 tests/testthat/_snaps/4.4/theme.md delete mode 100644 tests/testthat/_snaps/4.5/theme.md diff --git a/R/theme.R b/R/theme.R index bab9e23b5a..ae3e3922d6 100644 --- a/R/theme.R +++ b/R/theme.R @@ -702,7 +702,7 @@ add_theme <- function(t1, t2, t2name, call = caller_env()) { return(t1) } if (!is.list(t2)) { # in various places in the code base, simple lists are used as themes - cli::cli_abort("Can't add {.arg {t2name}} to a theme object.", call = call) + cli::cli_abort("Can't add {.arg {t2name}} to a theme object.", call = NULL) } # If t2 is a complete theme or t1 is NULL, just return t2 diff --git a/tests/testthat/_snaps/4.0/theme.md b/tests/testthat/_snaps/4.0/theme.md deleted file mode 100644 index e4df8865e7..0000000000 --- a/tests/testthat/_snaps/4.0/theme.md +++ /dev/null @@ -1,8 +0,0 @@ -# modifying theme element properties with + operator works - - Code - theme_grey() + "asdf" - Condition - Error in `method(+, list(ggplot2::theme, class_any))`: - ! Can't add `"asdf"` to a theme object. - diff --git a/tests/testthat/_snaps/4.2/theme.md b/tests/testthat/_snaps/4.2/theme.md deleted file mode 100644 index e4df8865e7..0000000000 --- a/tests/testthat/_snaps/4.2/theme.md +++ /dev/null @@ -1,8 +0,0 @@ -# modifying theme element properties with + operator works - - Code - theme_grey() + "asdf" - Condition - Error in `method(+, list(ggplot2::theme, class_any))`: - ! Can't add `"asdf"` to a theme object. - diff --git a/tests/testthat/_snaps/4.4/theme.md b/tests/testthat/_snaps/4.4/theme.md deleted file mode 100644 index ee5f23ab56..0000000000 --- a/tests/testthat/_snaps/4.4/theme.md +++ /dev/null @@ -1,8 +0,0 @@ -# modifying theme element properties with + operator works - - Code - theme_grey() + "asdf" - Condition - Error: - ! Can't add `"asdf"` to a theme object. - diff --git a/tests/testthat/_snaps/4.5/theme.md b/tests/testthat/_snaps/4.5/theme.md deleted file mode 100644 index ee5f23ab56..0000000000 --- a/tests/testthat/_snaps/4.5/theme.md +++ /dev/null @@ -1,8 +0,0 @@ -# modifying theme element properties with + operator works - - Code - theme_grey() + "asdf" - Condition - Error: - ! Can't add `"asdf"` to a theme object. - diff --git a/tests/testthat/_snaps/theme.md b/tests/testthat/_snaps/theme.md index 4b2f8fa1b2..3895a36391 100644 --- a/tests/testthat/_snaps/theme.md +++ b/tests/testthat/_snaps/theme.md @@ -1,3 +1,11 @@ +# modifying theme element properties with + operator works + + Code + theme_grey() + "asdf" + Condition + Error: + ! Can't add `"asdf"` to a theme object. + # theme validation happens at build stage The `text` theme element must be a object. diff --git a/tests/testthat/test-theme.R b/tests/testthat/test-theme.R index 849bacdf12..fcb3345af6 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -49,11 +49,7 @@ test_that("modifying theme element properties with + operator works", { t <- theme_grey() + theme() expect_identical(t, theme_grey()) - expect_snapshot( - theme_grey() + "asdf", - error = TRUE, - variant = substr(as.character(getRversion()), start = 1, stop = 3) - ) + expect_snapshot(theme_grey() + "asdf", error = TRUE) }) test_that("adding theme object to ggplot object with + operator works", { From 98202cb39123d4a52b3c59f368707d9e1070bc5e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 24 Nov 2025 12:08:02 +0100 Subject: [PATCH 73/78] separate old guide expectations --- tests/testthat/_snaps/guide-old.md | 5 - .../old-s3-guide-drawing-a-circle.svg | 106 +++++++++--------- tests/testthat/test-guide-old.R | 18 +-- 3 files changed, 63 insertions(+), 66 deletions(-) delete mode 100644 tests/testthat/_snaps/guide-old.md diff --git a/tests/testthat/_snaps/guide-old.md b/tests/testthat/_snaps/guide-old.md deleted file mode 100644 index c5bdbfd541..0000000000 --- a/tests/testthat/_snaps/guide-old.md +++ /dev/null @@ -1,5 +0,0 @@ -# old S3 guides can be implemented - - The S3 guide system was deprecated in ggplot2 3.5.0. - i It has been replaced by a ggproto system that can be extended. - diff --git a/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg b/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg index 35af42a85f..c0b64b7cd7 100644 --- a/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg +++ b/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg @@ -18,64 +18,64 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -10 -15 -20 -25 -30 -35 - - - - - - - -mpg -old S3 guide drawing a circle +10 +15 +20 +25 +30 +35 + + + + + + + +mpg +old S3 guide drawing a circle diff --git a/tests/testthat/test-guide-old.R b/tests/testthat/test-guide-old.R index 7fb5386793..420b5acea3 100644 --- a/tests/testthat/test-guide-old.R +++ b/tests/testthat/test-guide-old.R @@ -51,13 +51,15 @@ test_that("old S3 guides can be implemented", { my_guides <- guides(x = guide_circle()) expect_length(my_guides$guides, 1) expect_s3_class(my_guides$guides[[1]], "guide") + title <- "old S3 guide drawing a circle" - expect_snapshot_warning( - expect_doppelganger( - "old S3 guide drawing a circle", - ggplot(mtcars, aes(disp, mpg)) + - geom_point() + - my_guides - ) - ) + p <- ggplot(mtcars, aes(disp, mpg)) + + geom_point() + + my_guides + + theme_test() + + labs(title = title) + + lifecycle::expect_deprecated(gt <- ggplotGrob(p)) + + expect_doppelganger(title, fig = function() grid.draw(gt)) }) From 3147acea33bb35e90acef1d27108177383287319 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 24 Nov 2025 12:31:02 +0100 Subject: [PATCH 74/78] is this the only failing test? --- tests/testthat/test-guide-old.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-guide-old.R b/tests/testthat/test-guide-old.R index 420b5acea3..9d7f6cc55c 100644 --- a/tests/testthat/test-guide-old.R +++ b/tests/testthat/test-guide-old.R @@ -1,4 +1,5 @@ skip_on_cran() # This test suite is long-running (on cran) and is skipped +skip("Temporarily disabled for testing CI") test_that("old S3 guides can be implemented", { my_env <- env() From 2bec39de107195acfd74598679c958a1f61c4363 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 24 Nov 2025 13:55:07 +0100 Subject: [PATCH 75/78] another attempt at placating the CI gods --- .../old-s3-guide-drawing-a-circle.svg | 106 +++++++++--------- tests/testthat/test-guide-old.R | 18 ++- 2 files changed, 60 insertions(+), 64 deletions(-) diff --git a/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg b/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg index c0b64b7cd7..35af42a85f 100644 --- a/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg +++ b/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg @@ -18,64 +18,64 @@ - + - - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -10 -15 -20 -25 -30 -35 - - - - - - - -mpg -old S3 guide drawing a circle +10 +15 +20 +25 +30 +35 + + + + + + + +mpg +old S3 guide drawing a circle diff --git a/tests/testthat/test-guide-old.R b/tests/testthat/test-guide-old.R index 9d7f6cc55c..fc745a3d61 100644 --- a/tests/testthat/test-guide-old.R +++ b/tests/testthat/test-guide-old.R @@ -1,5 +1,4 @@ skip_on_cran() # This test suite is long-running (on cran) and is skipped -skip("Temporarily disabled for testing CI") test_that("old S3 guides can be implemented", { my_env <- env() @@ -48,19 +47,16 @@ test_that("old S3 guides can be implemented", { ) withr::local_environment(my_env) + withr::local_options(lifecycle_verbosity = "quiet") my_guides <- guides(x = guide_circle()) expect_length(my_guides$guides, 1) expect_s3_class(my_guides$guides[[1]], "guide") - title <- "old S3 guide drawing a circle" - p <- ggplot(mtcars, aes(disp, mpg)) + - geom_point() + - my_guides + - theme_test() + - labs(title = title) - - lifecycle::expect_deprecated(gt <- ggplotGrob(p)) - - expect_doppelganger(title, fig = function() grid.draw(gt)) + expect_doppelganger( + "old S3 guide drawing a circle", + ggplot(mtcars, aes(disp, mpg)) + + geom_point() + + my_guides + ) }) From 109fca1d8b7ee16b84dd1af1e1f5c90132e75361 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 24 Nov 2025 15:05:30 +0100 Subject: [PATCH 76/78] is it some weird filename thingy? --- ...old-s3-guide-drawing-a-circle.svg => dummy-old-s3-guide.svg} | 2 +- tests/testthat/test-guide-old.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) rename tests/testthat/_snaps/guide-old/{old-s3-guide-drawing-a-circle.svg => dummy-old-s3-guide.svg} (98%) diff --git a/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg b/tests/testthat/_snaps/guide-old/dummy-old-s3-guide.svg similarity index 98% rename from tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg rename to tests/testthat/_snaps/guide-old/dummy-old-s3-guide.svg index 35af42a85f..e3834f42e8 100644 --- a/tests/testthat/_snaps/guide-old/old-s3-guide-drawing-a-circle.svg +++ b/tests/testthat/_snaps/guide-old/dummy-old-s3-guide.svg @@ -76,6 +76,6 @@ mpg -old S3 guide drawing a circle +dummy old s3 guide diff --git a/tests/testthat/test-guide-old.R b/tests/testthat/test-guide-old.R index fc745a3d61..7189e7d65b 100644 --- a/tests/testthat/test-guide-old.R +++ b/tests/testthat/test-guide-old.R @@ -54,7 +54,7 @@ test_that("old S3 guides can be implemented", { expect_s3_class(my_guides$guides[[1]], "guide") expect_doppelganger( - "old S3 guide drawing a circle", + "dummy old s3 guide", ggplot(mtcars, aes(disp, mpg)) + geom_point() + my_guides From 1cf5af1368024149b19a6e33fdf690e663226137 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 24 Nov 2025 15:27:59 +0100 Subject: [PATCH 77/78] try without messing with environment --- tests/testthat/test-guide-old.R | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/tests/testthat/test-guide-old.R b/tests/testthat/test-guide-old.R index 7189e7d65b..b1f021624e 100644 --- a/tests/testthat/test-guide-old.R +++ b/tests/testthat/test-guide-old.R @@ -1,8 +1,8 @@ skip_on_cran() # This test suite is long-running (on cran) and is skipped test_that("old S3 guides can be implemented", { - my_env <- env() - my_env$guide_circle <- function() { + + guide_circle <- function() { structure( list(available_aes = c("x", "y"), position = "bottom"), class = c("guide", "circle") @@ -12,26 +12,22 @@ test_that("old S3 guides can be implemented", { registerS3method( "guide_train", "circle", - function(guide, ...) guide, - envir = my_env + function(guide, ...) guide ) registerS3method( "guide_transform", "circle", - function(guide, ...) guide, - envir = my_env + function(guide, ...) guide ) registerS3method( "guide_merge", "circle", - function(guide, ...) guide, - envir = my_env + function(guide, ...) guide ) registerS3method( "guide_geom", "circle", - function(guide, ...) guide, - envir = my_env + function(guide, ...) guide ) registerS3method( "guide_gengrob", @@ -42,11 +38,9 @@ test_that("old S3 guides can be implemented", { height = unit(1, "cm"), width = unit(1, "cm") ) - }, - envir = my_env + } ) - withr::local_environment(my_env) withr::local_options(lifecycle_verbosity = "quiet") my_guides <- guides(x = guide_circle()) From 6efe4de18f3640627811f6cbe819edbb13569d9a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 24 Nov 2025 16:55:32 +0100 Subject: [PATCH 78/78] avoid recalcitrant visual test --- .../_snaps/guide-old/dummy-old-s3-guide.svg | 81 ------------------- tests/testthat/test-guide-old.R | 21 +++-- 2 files changed, 13 insertions(+), 89 deletions(-) delete mode 100644 tests/testthat/_snaps/guide-old/dummy-old-s3-guide.svg diff --git a/tests/testthat/_snaps/guide-old/dummy-old-s3-guide.svg b/tests/testthat/_snaps/guide-old/dummy-old-s3-guide.svg deleted file mode 100644 index e3834f42e8..0000000000 --- a/tests/testthat/_snaps/guide-old/dummy-old-s3-guide.svg +++ /dev/null @@ -1,81 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -10 -15 -20 -25 -30 -35 - - - - - - - -mpg -dummy old s3 guide - - diff --git a/tests/testthat/test-guide-old.R b/tests/testthat/test-guide-old.R index b1f021624e..2d3f6584d0 100644 --- a/tests/testthat/test-guide-old.R +++ b/tests/testthat/test-guide-old.R @@ -5,33 +5,33 @@ test_that("old S3 guides can be implemented", { guide_circle <- function() { structure( list(available_aes = c("x", "y"), position = "bottom"), - class = c("guide", "circle") + class = c("guide", "circle_guide") ) } registerS3method( "guide_train", - "circle", + "circle_guide", function(guide, ...) guide ) registerS3method( "guide_transform", - "circle", + "circle_guide", function(guide, ...) guide ) registerS3method( "guide_merge", - "circle", + "circle_guide", function(guide, ...) guide ) registerS3method( "guide_geom", - "circle", + "circle_guide", function(guide, ...) guide ) registerS3method( "guide_gengrob", - "circle", + "circle_guide", function(guide, ...) { absoluteGrob( gList(circleGrob()), @@ -47,10 +47,15 @@ test_that("old S3 guides can be implemented", { expect_length(my_guides$guides, 1) expect_s3_class(my_guides$guides[[1]], "guide") - expect_doppelganger( - "dummy old s3 guide", + gt <- ggplotGrob( ggplot(mtcars, aes(disp, mpg)) + geom_point() + my_guides ) + + axis <- gtable_filter(gt, "axis-b")$grobs[[1]] + expect_s3_class( + axis$children[[1]], + "circle" + ) })