diff --git a/DESCRIPTION b/DESCRIPTION index 6ac2e6f5c8..01f91fcb9a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -86,18 +86,15 @@ LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 Collate: - 'ggproto.R' + 'aes-delayed-eval.R' + 'aes-variants.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' + 'ggproto.R' 'all-classes.R' 'compat-plyr.R' 'utilities.R' 'aes.R' + 'annotate.R' 'annotation-borders.R' 'utilities-checks.R' 'legend-draw.R' @@ -112,7 +109,6 @@ Collate: 'annotation-map.R' 'geom-raster.R' 'annotation-raster.R' - 'annotation.R' 'autolayer.R' 'autoplot.R' 'axis-secondary.R' @@ -131,9 +127,11 @@ Collate: 'coord-sf.R' 'coord-transform.R' 'data.R' - 'docs_layer.R' + 'docs-aes.R' + 'docs-layer.R' 'facet-.R' 'facet-grid-.R' + 'facet-labeller.R' 'facet-null.R' 'facet-wrap.R' 'fortify-map.R' @@ -141,14 +139,13 @@ 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' 'geom-bin2d.R' 'geom-blank.R' 'geom-boxplot.R' - 'geom-col.R' 'geom-path.R' 'geom-contour.R' 'geom-point.R' @@ -156,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' @@ -166,7 +162,6 @@ Collate: 'geom-function.R' 'geom-hex.R' 'geom-histogram.R' - 'geom-hline.R' 'geom-jitter.R' 'geom-label.R' 'geom-linerange.R' @@ -177,8 +172,8 @@ Collate: 'geom-smooth.R' 'geom-spoke.R' 'geom-text.R' + 'geom-update-defaults.R' 'geom-violin.R' - 'geom-vline.R' 'ggplot2-package.R' 'grob-absolute.R' 'grob-dotstack.R' @@ -204,12 +199,10 @@ Collate: 'hexbin.R' 'import-standalone-obj-type.R' 'import-standalone-types-check.R' - 'labeller.R' 'labels.R' 'layer-sf.R' 'layout.R' 'limits.R' - 'performance.R' 'plot-build.R' 'plot-construction.R' 'plot-last.R' @@ -289,6 +282,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/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/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-evaluation.R b/R/aes-delayed-eval.R similarity index 100% rename from R/aes-evaluation.R rename to R/aes-delayed-eval.R 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/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) 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/annotation.R b/R/annotate.R similarity index 100% rename from R/annotation.R rename to R/annotate.R diff --git a/R/axis-secondary.R b/R/axis-secondary.R index d694cf3a47..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") } -#' @rdname ggplot2-ggproto +#' Secondary axis class +#' @keywords internal #' @format NULL #' @usage NULL #' @export 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 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 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/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 dea2808936..fec2af5dfd 100644 --- a/R/geom-abline.R +++ b/R/geom-abline-hline-vline.R @@ -68,7 +68,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, @@ -121,6 +121,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 @@ -162,3 +242,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-bar.R b/R/geom-bar.R index 219223cda4..38c99a25fa 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()`. @@ -133,3 +141,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/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-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/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/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/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/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/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)` # 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} diff --git a/man/Geom.Rd b/man/Geom.Rd index 8185c966e8..1542904a0b 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-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-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-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} @@ -21,13 +20,15 @@ \alias{GeomRaster} \alias{GeomRasterAnn} \alias{GeomAbline} +\alias{GeomHline} +\alias{GeomVline} \alias{GeomRect} \alias{GeomBar} +\alias{GeomCol} \alias{GeomTile} \alias{GeomBin2d} \alias{GeomBlank} \alias{GeomBoxplot} -\alias{GeomCol} \alias{GeomPath} \alias{GeomLine} \alias{GeomStep} @@ -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/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} diff --git a/man/annotate.Rd b/man/annotate.Rd index e74358741f..42dcafdf57 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} 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/geom_abline.Rd b/man/geom_abline.Rd index eb89d007b7..fa0550aeee 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/man/geom_bar.Rd b/man/geom_bar.Rd index 3c6ac4e0ab..9c9e5b74b9 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/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/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} 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/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{ 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} 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.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/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`. + 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/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/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 56% rename from tests/testthat/_snaps/facet-labels.md rename to tests/testthat/_snaps/facet-labeller.md index 6130705bea..668fe21190 100644 --- a/tests/testthat/_snaps/facet-labels.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/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 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/_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/_snaps/ggproto.md b/tests/testthat/_snaps/ggproto.md index 365bcce1df..2fbd19d83f 100644 --- a/tests/testthat/_snaps/ggproto.md +++ b/tests/testthat/_snaps/ggproto.md @@ -10,3 +10,15 @@ `_inherit` must be a 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 + 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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/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-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/guides/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/guides/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/guides/guide-bins-can-remove-axis.svg b/tests/testthat/_snaps/guide-bins/remove-axis.svg similarity index 98% rename from tests/testthat/_snaps/guides/guide-bins-can-remove-axis.svg rename to tests/testthat/_snaps/guide-bins/remove-axis.svg index c58ac5df8c..5b1b8a84ae 100644 --- a/tests/testthat/_snaps/guides/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/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/guides/guide-bins-can-show-arrows.svg b/tests/testthat/_snaps/guide-bins/show-arrows.svg similarity index 98% rename from tests/testthat/_snaps/guides/guide-bins-can-show-arrows.svg rename to tests/testthat/_snaps/guide-bins/show-arrows.svg index 442087e8c3..b14c89c784 100644 --- a/tests/testthat/_snaps/guides/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/guides/guide-bins-can-show-limits.svg b/tests/testthat/_snaps/guide-bins/show-limits.svg similarity index 98% rename from tests/testthat/_snaps/guides/guide-bins-can-show-limits.svg rename to tests/testthat/_snaps/guide-bins/show-limits.svg index d2271a703e..c0a905644d 100644 --- a/tests/testthat/_snaps/guides/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/guides/guide-bins-work-horizontally.svg b/tests/testthat/_snaps/guide-bins/work-horizontally.svg similarity index 98% rename from tests/testthat/_snaps/guides/guide-bins-work-horizontally.svg rename to tests/testthat/_snaps/guide-bins/work-horizontally.svg index 587e0b20c3..0eb053e926 100644 --- a/tests/testthat/_snaps/guides/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.md b/tests/testthat/_snaps/guide-colorsteps.md new file mode 100644 index 0000000000..b74ca82cc0 --- /dev/null +++ b/tests/testthat/_snaps/guide-colorsteps.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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/guides/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/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-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/guides/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/guides/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/guides/guide-coloursteps-can-show-limits.svg b/tests/testthat/_snaps/guide-colorsteps/show-limits.svg similarity index 98% rename from tests/testthat/_snaps/guides/guide-coloursteps-can-show-limits.svg rename to tests/testthat/_snaps/guide-colorsteps/show-limits.svg index 3601641e36..09643158ec 100644 --- a/tests/testthat/_snaps/guides/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/guides/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/guides/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/guides/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/_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/_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/_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 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/_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/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/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 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/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/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/_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/_snaps/stat-bin.md b/tests/testthat/_snaps/stat-bin.md index db0b8f44c0..a8a4f0ed28 100644 --- a/tests/testthat/_snaps/stat-bin.md +++ b/tests/testthat/_snaps/stat-bin.md @@ -21,41 +21,3 @@ 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. - 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/_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/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..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. @@ -24,54 +32,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 +45,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 +54,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/_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-help.md b/tests/testthat/_snaps/utilities-help.md new file mode 100644 index 0000000000..4396fffdc0 --- /dev/null +++ b/tests/testthat/_snaps/utilities-help.md @@ -0,0 +1,75 @@ +# rd_orientation formats a section + + Code + rd_orientation() + Output + [1] "@inheritSection ggplot2::shared_layer_parameters Orientation" + +# 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/_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 diff --git a/tests/testthat/_snaps/utilities.md b/tests/testthat/_snaps/utilities.md index 4ccf6d67d1..9287f5a671 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,13 @@ 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 +# should_stop stops when it should Code - summary(p) + should_stop(invisible()) 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 - + NULL + Condition + Error in `should_stop()`: + ! No error! 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-calculated.R b/tests/testthat/test-aes-delayed-eval.R similarity index 91% rename from tests/testthat/test-aes-calculated.R rename to tests/testthat/test-aes-delayed-eval.R index ee922ba005..0887eea548 100644 --- a/tests/testthat/test-aes-calculated.R +++ b/tests/testthat/test-aes-delayed-eval.R @@ -171,3 +171,20 @@ 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())) +}) + + +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-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-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)) +}) 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 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-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-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 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 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))) -}) 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-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-facet-.R b/tests/testthat/test-facet-.R index 71f78c1cf2..b93b8237ab 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,105 +150,52 @@ 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)) +# 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("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)) +test_that("strip clipping can be set from the theme", { + labels <- data_frame(var1 = "a") - # 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") + strip <- render_strips( + labels, + labeller = label_value, + theme = theme_test() + theme(strip.clip = "on") ) - 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) -}) + expect_equal(strip$x$top[[1]]$layout$clip, "on") -test_that("facet_wrap `axes` can draw inner axes.", { - df <- data_frame( - x = 1, y = 1, facet = LETTERS[1:4] + strip <- render_strips( + labels, + labeller = label_value, + theme = theme_test() + theme(strip.clip = "off") ) - - 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) + expect_equal(strip$x$top[[1]]$layout$clip, "off") }) -test_that("facet_wrap throws deprecation messages", { - withr::local_options(lifecycle_verbosity = "warning") +test_that("strip labels can be accessed", { + + expect_null(get_strip_labels(ggplot())) - facet <- facet_wrap(vars(year)) - facet$params$dir <- "h" + expect_equal( + get_strip_labels(ggplot() + facet_wrap(vars("X", "Y"))), + list(facets = data_frame0(`"X"` = "X", `"Y"` = "Y")) + ) - lifecycle::expect_deprecated( - ggplot_build(ggplot(mpg, aes(displ, hwy)) + geom_point() + facet), - "Internal use of" + expect_equal( + get_strip_labels(ggplot() + facet_grid(vars("X"), vars("Y"))), + list( + cols = data_frame0(`"Y"` = "Y"), + rows = data_frame0(`"X"` = "X") + ) ) }) @@ -478,6 +340,37 @@ test_that("check_layout() throws meaningful errors", { expect_snapshot_error(check_layout(mtcars)) }) +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) + layout$layout + } + + 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..eaa363e2ef --- /dev/null +++ b/tests/testthat/test-facet-grid-.R @@ -0,0 +1,528 @@ +# 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)) +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)) +}) + +# 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]) +}) + +# 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-labels.R b/tests/testthat/test-facet-labeller.R similarity index 80% rename from tests/testthat/test-facet-labels.R rename to tests/testthat/test-facet-labeller.R index f755e93aa8..74eb9e4214 100644 --- a/tests/testthat/test-facet-labels.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-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-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-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 new file mode 100644 index 0000000000..351814ec9c --- /dev/null +++ b/tests/testthat/test-facet-wrap.R @@ -0,0 +1,420 @@ +# 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)) +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)) +}) + +# 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]) +}) + +# 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) +}) 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))) }) 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-hline-vline-abline.R b/tests/testthat/test-geom-abline-hline-vline.R similarity index 70% rename from tests/testthat/test-geom-hline-vline-abline.R rename to tests/testthat/test-geom-abline-hline-vline.R index ec8a44bac1..926ef9afdb 100644 --- a/tests/testthat/test-geom-hline-vline-abline.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-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)) -}) 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)) -}) 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) + +}) diff --git a/tests/testthat/test-ggproto.R b/tests/testthat/test-ggproto.R index baad887619..7ffe265735 100644 --- a/tests/testthat/test-ggproto.R +++ b/tests/testthat/test-ggproto.R @@ -55,3 +55,16 @@ 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)) +}) diff --git a/tests/testthat/test-aes-grouping.R b/tests/testthat/test-grouping.R similarity index 83% rename from tests/testthat/test-aes-grouping.R rename to tests/testthat/test-grouping.R index d5536cc417..97652a53a5 100644 --- a/tests/testthat/test-aes-grouping.R +++ b/tests/testthat/test-grouping.R @@ -5,8 +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() @@ -18,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", { @@ -39,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")) }) diff --git a/tests/testthat/test-guide-bins.R b/tests/testthat/test-guide-bins.R new file mode 100644 index 0000000000..7e06d2f5cc --- /dev/null +++ b/tests/testthat/test-guide-bins.R @@ -0,0 +1,103 @@ +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( + "show limits", + p + guides(size = guide_bins(show.limits = TRUE)) + ) + expect_doppelganger( + "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( + "remove axis", + p + + guides(size = guide_bins()) + + theme_test() + + theme( + legend.axis.line = element_blank() + ) + ) + expect_doppelganger( + "work horizontally", + 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( + "coinciding limits and bins", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006), + guide = 'bins' + ) + ) + expect_doppelganger( + "coinciding limits and bins 2", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(2000, 2002, 2004, 2006, 2008), + guide = 'bins' + ) + ) + expect_doppelganger( + "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( + "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 new file mode 100644 index 0000000000..ea8e0cc717 --- /dev/null +++ b/tests/testthat/test-guide-colorsteps.R @@ -0,0 +1,155 @@ +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( + "show limits", + p + guides(colour = guide_coloursteps(show.limits = TRUE)) + ) + expect_doppelganger( + "bins relative to binsize", + p + guides(colour = guide_coloursteps(even.steps = FALSE)) + ) + expect_doppelganger( + "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( + "coinciding limits and bins", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(1999, 2000, 2002, 2004, 2006) + ) + ) + expect_doppelganger( + "coinciding limits and bins 2", + p + + scale_color_binned( + limits = c(1999, 2008), + breaks = c(2000, 2002, 2004, 2006, 2008) + ) + ) + expect_doppelganger( + "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( + "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-legend.R b/tests/testthat/test-guide-legend.R index 2dd68fe01b..c4b41995f7 100644 --- a/tests/testthat/test-guide-legend.R +++ b/tests/testthat/test-guide-legend.R @@ -146,6 +146,43 @@ 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))) +}) + +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, + 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", { 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() - ) -}) 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"))) -}) diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index b6d1683b73..8073ee51bc 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -266,3 +266,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) +}) + + 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'", { 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 + ) +}) 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-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 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-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 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) +}) 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 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) -}) 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 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-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-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-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 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") - ) -}) 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))) -}) 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 diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 27de4ef939..0b2d4879ef 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) @@ -225,35 +139,3 @@ 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", { - 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)) +}) 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))) +}) 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-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..fcb3345af6 100644 --- a/tests/testthat/test-theme.R +++ b/tests/testthat/test-theme.R @@ -49,17 +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) - ) -}) - -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()) + expect_snapshot(theme_grey() + "asdf", error = TRUE) }) test_that("adding theme object to ggplot object with + operator works", { @@ -108,24 +98,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 +267,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 +279,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 +330,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 +418,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 +428,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 +459,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 +474,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 +519,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 +543,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 +589,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 +623,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]) 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-grid-utils.R b/tests/testthat/test-utilities-grid.R similarity index 51% rename from tests/testthat/test-grid-utils.R rename to tests/testthat/test-utilities-grid.R index f9f018953e..c385c9a64f 100644 --- a/tests/testthat/test-grid-utils.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-help.R b/tests/testthat/test-utilities-help.R new file mode 100644 index 0000000000..6c629f1a94 --- /dev/null +++ b/tests/testthat/test-utilities-help.R @@ -0,0 +1,36 @@ + +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", { + skip_if(getRversion() < "4.2.0") + expect_snapshot(rd_aesthetics("geom", "point")) +}) + +test_that("roxygen parses the @aesthetics tag", { + skip_if(getRversion() < "4.2.0") + 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")) +}) 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 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 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..66e380c973 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 @@ -206,15 +183,17 @@ test_that("allow_lambda converts the correct cases", { 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() +test_that("should_stop stops when it should", { + expect_silent(should_stop(stop())) + expect_snapshot(should_stop(invisible()), error = TRUE) +}) - p <- ggplot(mpg, aes(displ, hwy, colour = drv)) + - geom_point() + - scale_x_continuous() + - scale_colour_brewer() + - facet_grid(year ~ cyl) +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)) - expect_snapshot(summary(p)) + sc <- discrete_scale("shape", palette = NULL, fallback.palette = pal_identity()) + pal <- fallback_palette(sc) + expect_true(is_discrete_pal(pal)) })