diff --git a/DESCRIPTION b/DESCRIPTION index e5e05ed5d9..1481517272 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -176,6 +176,7 @@ Collate: 'guide-.R' 'guide-axis.R' 'guide-axis-logticks.R' + 'guide-axis-stack.R' 'guide-axis-theta.R' 'guide-legend.R' 'guide-bins.R' diff --git a/NAMESPACE b/NAMESPACE index 000bc1a6a2..b15bde6e2f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -218,6 +218,7 @@ export(GeomVline) export(Guide) export(GuideAxis) export(GuideAxisLogticks) +export(GuideAxisStack) export(GuideBins) export(GuideColourbar) export(GuideColoursteps) @@ -429,6 +430,7 @@ export(ggsave) export(ggtitle) export(guide_axis) export(guide_axis_logticks) +export(guide_axis_stack) export(guide_axis_theta) export(guide_bins) export(guide_colorbar) diff --git a/NEWS.md b/NEWS.md index 1f293ffe26..7f984112bc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,11 @@ from `fill = alpha(fill, alpha)` to `fill = fill_alpha(fill, alpha)` when providing fills to `grid::gpar()` (@teunbrand, #3997). +* The plot's title, subtitle and caption now obey horizontal text margins + (#5533). + +* New `guide_axis_stack()` to combine other axis guides on top of one another. + * New `guide_custom()` function for drawing custom graphical objects (grobs) unrelated to scales in legend positions (#5416). diff --git a/R/geom-segment.R b/R/geom-segment.R index 611ba85e2c..f32b61f876 100644 --- a/R/geom-segment.R +++ b/R/geom-segment.R @@ -103,7 +103,7 @@ geom_segment <- function(mapping = NULL, data = NULL, #' @export GeomSegment <- ggproto("GeomSegment", Geom, required_aes = c("x", "y", "xend|yend"), - non_missing_aes = c("linetype", "linewidth", "shape"), + non_missing_aes = c("linetype", "linewidth"), default_aes = aes(colour = "black", linewidth = 0.5, linetype = 1, alpha = NA), draw_panel = function(self, data, panel_params, coord, arrow = NULL, arrow.fill = NULL, lineend = "butt", linejoin = "round", na.rm = FALSE) { @@ -111,7 +111,7 @@ GeomSegment <- ggproto("GeomSegment", Geom, data$yend <- data$yend %||% data$y data <- check_linewidth(data, snake_class(self)) data <- remove_missing(data, na.rm = na.rm, - c("x", "y", "xend", "yend", "linetype", "linewidth", "shape"), + c("x", "y", "xend", "yend", "linetype", "linewidth"), name = "geom_segment" ) diff --git a/R/guide-axis-stack.R b/R/guide-axis-stack.R new file mode 100644 index 0000000000..2fdd73b34e --- /dev/null +++ b/R/guide-axis-stack.R @@ -0,0 +1,242 @@ +#' @include guide-axis.R +NULL + +#' Stacked axis guides +#' +#' This guide can stack other position guides that represent position scales, +#' like those created with [scale_(x|y)_continuous()][scale_x_continuous()] and +#' [scale_(x|y)_discrete()][scale_x_discrete()]. +#' +#' @inheritParams guide_axis +#' @param first A position guide given as one of the following: +#' * A string, for example `"axis"`. +#' * A call to a guide function, for example `guide_axis()`. +#' @param ... Additional guides to stack given in the same manner as `first`. +#' @param spacing A [unit()] objects that determines how far separate guides are +#' spaced apart. +#' +#' @details +#' The `first` guide will be placed closest to the panel and any subsequent +#' guides provided through `...` will follow in the given order. +#' +#' @export +#' +#' @examples +#' #' # A standard plot +#' p <- ggplot(mpg, aes(displ, hwy)) + +#' geom_point() + +#' theme(axis.line = element_line()) +#' +#' # A normal axis first, then a capped axis +#' p + guides(x = guide_axis_stack("axis", guide_axis(cap = "both"))) +guide_axis_stack <- function(first = "axis", ..., title = waiver(), + spacing = NULL, order = 0, position = waiver()) { + + check_object(spacing, is.unit, "{.cls unit}", allow_null = TRUE) + + # Validate guides + axes <- list2(first, ...) + axes <- lapply(axes, validate_guide) + + # Check available aesthetics + available <- lapply(axes, `[[`, name = "available_aes") + available <- vapply(available, function(x) all(c("x", "y") %in% x), logical(1)) + if (all(!available)) { + cli::cli_abort(paste0( + "{.fn guide_axis_stack} can only use guides that handle {.field x} and ", + "{.field y} aesthetics." + )) + } + + # Remove guides that don't support x/y aesthetics + if (any(!available)) { + remove <- which(!available) + removed <- vapply(axes[remove], snake_class, character(1)) + axes[remove] <- NULL + cli::cli_warn(c(paste0( + "{.fn guide_axis_stack} cannot use the following guide{?s}: ", + "{.and {.fn {removed}}}." + ), i = "Guides need to handle {.field x} and {.field y} aesthetics.")) + } + + params <- lapply(axes, `[[`, name = "params") + + new_guide( + title = title, + guides = axes, + guide_params = params, + available_aes = c("x", "y", "theta", "r"), + order = order, + position = position, + name = "stacked_axis", + super = GuideAxisStack + ) +} + +#' @rdname ggplot2-ggproto +#' @format NULL +#' @usage NULL +#' @export +GuideAxisStack <- ggproto( + "GuideAxisStack", GuideAxis, + + params = list( + # List of guides to track the guide objects + guides = list(), + # List of parameters to each guide + guide_params = list(), + # Standard guide stuff + name = "stacked_axis", + title = waiver(), + angle = waiver(), + hash = character(), + position = waiver(), + direction = NULL, + order = 0 + ), + + available_aes = c("x", "y", "theta", "r"), + + # Doesn't depend on keys, but on member axis' class + hashables = exprs(title, lapply(guides, snake_class), name), + + # Sets position, loops through guides to train + train = function(self, params = self$params, scale, aesthetic = NULL, ...) { + position <- arg_match0( + params$position, c(.trbl, "theta", "theta.sec"), + arg_nm = "position" + ) + for (i in seq_along(params$guides)) { + params$guide_params[[i]]$position <- position + params$guide_params[[i]]$angle <- params$guide_params[[i]]$angle %|W|% params$angle + params$guide_params[[i]] <- params$guides[[i]]$train( + params = params$guide_params[[i]], + scale = scale, aesthetic = aesthetic, + ... + ) + } + params + }, + + # Just loops through guides + transform = function(self, params, coord, panel_params) { + for (i in seq_along(params$guides)) { + params$guide_params[[i]] <- params$guides[[i]]$transform( + params = params$guide_params[[i]], + coord = coord, panel_params = panel_params + ) + } + params + }, + + # Just loops through guides + get_layer_key = function(params, layers) { + for (i in seq_along(params$guides)) { + params$guide_params[[i]] <- params$guides[[i]]$get_layer_key( + params = params$guide_params[[i]], + layers = layers + ) + } + params + }, + + draw = function(self, theme, position = NULL, direction = NULL, + params = self$params) { + + position <- params$position %||% position + direction <- params$direction %||% direction + + if (position %in% c("theta", "theta.sec")) { + # If we are a theta guide, we need to keep track how much space in the + # radial direction a guide occupies, and add that as an offset to the + # next guide. + offset <- unit(0, "cm") + spacing <- params$spacing %||% unit(2.25, "pt") + grobs <- list() + for (i in seq_along(params$guides)) { + # Add offset to params + pars <- params$guide_params[[i]] + pars$stack_offset <- offset + # Draw guide + grobs[[i]] <- params$guides[[i]]$draw( + theme, position = position, direction = direction, + params = pars + ) + # Increment offset + if (!is.null(grobs[[i]]$offset)) { + offset <- offset + spacing + grobs[[i]]$offset + offset <- convertUnit(offset, "cm") + } + } + grob <- inject(grobTree(!!!grobs)) + return(grob) + } + + # Loop through every guide's draw method + grobs <- list() + for (i in seq_along(params$guides)) { + grobs[[i]] <- params$guides[[i]]$draw( + theme, position = position, direction = direction, + params = params$guide_params[[i]] + ) + } + + # Remove empty grobs + grobs <- grobs[!vapply(grobs, is.zero, logical(1))] + if (length(grobs) == 0) { + return(zeroGrob()) + } + along <- seq_along(grobs) + + # Get sizes + widths <- inject(unit.c(!!!lapply(grobs, grobWidth))) + heights <- inject(unit.c(!!!lapply(grobs, grobHeight))) + + # Set spacing + if (is.null(params$spacing)) { + aes <- if (position %in% c("top", "bottom")) "x" else "y" + spacing <- paste("axis.ticks.length", aes, position, sep = ".") + spacing <- calc_element(spacing, theme) + } else { + spacing <- params$spacing + } + + # Reorder grobs/sizes if necessary + if (position %in% c("top", "left")) { + along <- rev(along) + widths <- rev(widths) + heights <- rev(heights) + } + + # Place guides in a gtable, apply spacing + if (position %in% c("bottom", "top")) { + gt <- gtable(widths = unit(1, "npc"), heights = heights) + gt <- gtable_add_grob(gt, grobs, t = along, l = 1, name = "axis", clip = "off") + gt <- gtable_add_row_space(gt, height = spacing) + vp <- exec( + viewport, + y = unit(as.numeric(position == "bottom"), "npc"), + height = grobHeight(gt), + just = opposite_position(position) + ) + } else { + gt <- gtable(widths = widths, heights = unit(1, "npc")) + gt <- gtable_add_grob(gt, grobs, t = 1, l = along, name = "axis", clip = "off") + gt <- gtable_add_col_space(gt, width = spacing) + vp <- exec( + viewport, + x = unit(as.numeric(position == "left"), "npc"), + width = grobWidth(gt), + just = opposite_position(position) + ) + } + + absoluteGrob( + grob = gList(gt), + width = gtable_width(gt), + height = gtable_height(gt), + vp = vp + ) + } +) + diff --git a/R/guide-axis-theta.R b/R/guide-axis-theta.R index abdc9277c1..c8c8fa3619 100644 --- a/R/guide-axis-theta.R +++ b/R/guide-axis-theta.R @@ -158,6 +158,24 @@ GuideAxisTheta <- ggproto( elements }, + build_decor = function(decor, grobs, elements, params) { + if (is.null(params$stack_offset) || !("theta" %in% names(decor))) { + # Just use regular method if we do not need to offset the guide + decor <- GuideAxis$build_decor(decor, grobs, elements, params) + return(decor) + } + if (empty(decor)) { + return(zeroGrob()) + } + if (params$position == "theta.sec") { + decor$theta <- decor$theta + pi + } + # Add the stacking offset to positions + x <- unit(decor$x, "npc") + sin(decor$theta) * params$stack_offset + y <- unit(decor$y, "npc") + cos(decor$theta) * params$stack_offset + element_grob(elements$line, x = x, y = y) + }, + build_labels = function(key, elements, params) { if (inherits(elements$text, "element_blank")) { @@ -183,9 +201,15 @@ GuideAxisTheta <- ggproto( # Position angle in radians theta <- key$theta + # Add the stacking offset if necessary + offset <- elements$offset + if (!is.null(params$stack_offset)) { + offset <- offset + params$stack_offset + } + # Offset distance to displace text away from outer circle line - xoffset <- elements$offset * sin(theta) - yoffset <- elements$offset * cos(theta) + xoffset <- offset * sin(theta) + yoffset <- offset * cos(theta) # Note that element_grob expects 1 angle for *all* labels, so we're # rendering one grob per label to propagate angle properly @@ -201,14 +225,14 @@ GuideAxisTheta <- ggproto( }, build_ticks = function(key, elements, params, position = params$position) { - + offset <- params$stack_offset major <- theta_tickmarks( vec_slice(key, (key$.type %||% "major") == "major"), - elements$ticks, elements$major_length + elements$ticks, elements$major_length, offset = offset ) minor <- theta_tickmarks( vec_slice(key, (key$.type %||% "major") == "minor"), - elements$minor, elements$minor_length + elements$minor, elements$minor_length, offset = offset ) grobTree(major, minor, name = "ticks") @@ -219,7 +243,63 @@ GuideAxisTheta <- ggproto( # we don't need to measure grob sizes nor arrange the layout. # There is a fallback in `$assemble_drawing()` that takes care of this # for non-polar coordinates. - NULL + if (is.null(params$stack_offset)) { + return(NULL) + } + + # However, when this guide is part of a stacked axis guide, we need to + # know the width of the 'ring' that this guide occupies to correctly + # position the next guide + + offset <- convertUnit(elements$offset, "cm", valueOnly = TRUE) + + key <- params$key + key <- vec_slice(key, !is.na(key$.label) & nzchar(key$.label)) + labels <- key$.label + if (length(labels) == 0 || inherits(elements$text, "element_blank")) { + return(list(offset = offset)) + } + + # Resolve text angle + if (is.waive(params$angle %||% waiver())) { + angle <- elements$text$angle + } else { + angle <- flip_text_angle(params$angle - rad2deg(key$theta)) + } + angle <- key$theta + deg2rad(angle) + + # Set margin + margin <- rep(max(elements$text$margin), length.out = 4) + + # Measure size of each individual label + single_labels <- lapply(labels, function(lab) { + element_grob( + elements$text, label = lab, + margin = margin, margin_x = TRUE, margin_y = TRUE + ) + }) + widths <- width_cm(single_labels) + heights <- height_cm(single_labels) + + # Set text justification + hjust <- 0.5 - sin(angle) / 2 + vjust <- 0.5 - cos(angle) / 2 + + # Calculate text bounding box + xmin <- widths * -hjust + xmax <- widths * (1 - hjust) + + ymin <- heights * -vjust + ymax <- heights * (1 - vjust) + + # Convert to corner coordinates + x <- vec_interleave(xmin, xmin, xmax, xmax) + y <- vec_interleave(ymin, ymax, ymax, ymin) + + # Rotate y coordinate to get maximum height + rotate <- rep(angle, each = 4) + height <- x * sin(rotate) + y * cos(rotate) + list(offset = max(height)) }, arrange_layout = function(key, sizes, params) { @@ -227,8 +307,13 @@ GuideAxisTheta <- ggproto( }, assemble_drawing = function(grobs, layout, sizes, params, elements) { + if (params$position %in% c("theta", "theta.sec")) { - return(inject(grobTree(!!!grobs))) + # We append an 'offset' slot in case this guide is part + # of a stacked guide + grobs <- inject(gList(!!!grobs)) + offset <- unit(sizes$offset %||% 0, "cm") + return(gTree(offset = offset, children = grobs)) } # As a fallback, we adjust the viewport to act like regular axes. @@ -263,7 +348,7 @@ GuideAxisTheta <- ggproto( } ) -theta_tickmarks <- function(key, element, length) { +theta_tickmarks <- function(key, element, length, offset = NULL) { n_breaks <- nrow(key) if (n_breaks < 1 || inherits(element, "element_blank")) { return(zeroGrob()) @@ -274,6 +359,9 @@ theta_tickmarks <- function(key, element, length) { x <- rep(key$x, each = 2) y <- rep(key$y, each = 2) length <- rep(c(0, 1), times = n_breaks) * length + if (!is.null(offset)) { + length <- length + offset + } minor <- element_grob( element, diff --git a/R/plot-build.R b/R/plot-build.R index 7fa0a89be3..51208d20dd 100644 --- a/R/plot-build.R +++ b/R/plot-build.R @@ -265,15 +265,24 @@ ggplot_gtable.ggplot_built <- function(data) { } # Title - title <- element_render(theme, "plot.title", plot$labels$title, margin_y = TRUE) + title <- element_render( + theme, "plot.title", plot$labels$title, + margin_y = TRUE, margin_x = TRUE + ) title_height <- grobHeight(title) # Subtitle - subtitle <- element_render(theme, "plot.subtitle", plot$labels$subtitle, margin_y = TRUE) + subtitle <- element_render( + theme, "plot.subtitle", plot$labels$subtitle, + margin_y = TRUE, margin_x = TRUE + ) subtitle_height <- grobHeight(subtitle) # whole plot annotation - caption <- element_render(theme, "plot.caption", plot$labels$caption, margin_y = TRUE) + caption <- element_render( + theme, "plot.caption", plot$labels$caption, + margin_y = TRUE, margin_x = TRUE + ) caption_height <- grobHeight(caption) # positioning of title and subtitle is governed by plot.title.position diff --git a/_pkgdown.yml b/_pkgdown.yml index 43fc512789..1bf6161b79 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -127,6 +127,7 @@ reference: - guide_legend - guide_axis - guide_axis_logticks + - guide_axis_stack - guide_axis_theta - guide_bins - guide_coloursteps diff --git a/man/ggplot2-ggproto.Rd b/man/ggplot2-ggproto.Rd index ebc8961b45..789a28db3c 100644 --- a/man/ggplot2-ggproto.Rd +++ b/man/ggplot2-ggproto.Rd @@ -1,19 +1,19 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/aaa-.R, 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/axis-secondary.R, -% R/coord-.R, R/coord-cartesian-.R, R/coord-fixed.R, R/coord-flip.R, -% R/coord-map.R, R/coord-polar.R, R/coord-quickmap.R, R/coord-radial.R, -% R/coord-transform.R, R/facet-.R, R/facet-grid-.R, R/facet-null.R, -% R/facet-wrap.R, R/stat-.R, R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, -% R/geom-blank.R, R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, -% R/geom-contour.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-errorbarh.R, R/geom-function.R, R/geom-hex.R, -% R/geom-hline.R, R/geom-label.R, R/geom-linerange.R, R/geom-point.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-tile.R, R/geom-violin.R, -% R/geom-vline.R, R/guide-.R, R/guide-axis.R, R/guide-axis-logticks.R, +% R/geom-raster.R, R/annotation-raster.R, R/axis-secondary.R, R/coord-.R, +% R/coord-cartesian-.R, R/coord-fixed.R, R/coord-flip.R, R/coord-map.R, +% R/coord-polar.R, R/coord-quickmap.R, R/coord-radial.R, R/coord-transform.R, +% R/facet-.R, R/facet-grid-.R, R/facet-null.R, R/facet-wrap.R, R/stat-.R, +% R/geom-abline.R, R/geom-rect.R, R/geom-bar.R, R/geom-blank.R, +% R/geom-boxplot.R, R/geom-col.R, R/geom-path.R, R/geom-contour.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-errorbarh.R, R/geom-function.R, R/geom-hex.R, R/geom-hline.R, +% R/geom-label.R, R/geom-linerange.R, R/geom-point.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-tile.R, R/geom-violin.R, R/geom-vline.R, +% R/guide-.R, R/guide-axis.R, R/guide-axis-logticks.R, R/guide-axis-stack.R, % R/guide-legend.R, R/guide-bins.R, R/guide-colorbar.R, R/guide-colorsteps.R, % R/guide-custom.R, R/guide-none.R, R/guide-old.R, R/layout.R, R/position-.R, % R/position-dodge.R, R/position-dodge2.R, R/position-identity.R, @@ -92,6 +92,7 @@ \alias{Guide} \alias{GuideAxis} \alias{GuideAxisLogticks} +\alias{GuideAxisStack} \alias{GuideLegend} \alias{GuideBins} \alias{GuideColourbar} diff --git a/man/guide_axis_stack.Rd b/man/guide_axis_stack.Rd new file mode 100644 index 0000000000..63ae75b003 --- /dev/null +++ b/man/guide_axis_stack.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/guide-axis-stack.R +\name{guide_axis_stack} +\alias{guide_axis_stack} +\title{Stacked axis guides} +\usage{ +guide_axis_stack( + first = "axis", + ..., + title = waiver(), + spacing = NULL, + order = 0, + position = waiver() +) +} +\arguments{ +\item{first}{A position guide given as one of the following: +\itemize{ +\item A string, for example \code{"axis"}. +\item A call to a guide function, for example \code{guide_axis()}. +}} + +\item{...}{Additional guides to stack given in the same manner as \code{first}.} + +\item{title}{A character string or expression indicating a title of guide. +If \code{NULL}, the title is not shown. By default +(\code{\link[=waiver]{waiver()}}), the name of the scale object or the name +specified in \code{\link[=labs]{labs()}} is used for the title.} + +\item{spacing}{A \code{\link[=unit]{unit()}} objects that determines how far separate guides are +spaced apart.} + +\item{order}{A positive \code{integer} of length 1 that specifies the order of +this guide among multiple guides. This controls in which order guides are +merged if there are multiple guides for the same position. If 0 (default), +the order is determined by a secret algorithm.} + +\item{position}{Where this guide should be drawn: one of top, bottom, +left, or right.} +} +\description{ +This guide can stack other position guides that represent position scales, +like those created with \link[=scale_x_continuous]{scale_(x|y)_continuous()} and +\link[=scale_x_discrete]{scale_(x|y)_discrete()}. +} +\details{ +The \code{first} guide will be placed closest to the panel and any subsequent +guides provided through \code{...} will follow in the given order. +} +\examples{ +#' # A standard plot +p <- ggplot(mpg, aes(displ, hwy)) + + geom_point() + + theme(axis.line = element_line()) + +# A normal axis first, then a capped axis +p + guides(x = guide_axis_stack("axis", guide_axis(cap = "both"))) +} diff --git a/tests/testthat/_snaps/guides/stacked-axes.svg b/tests/testthat/_snaps/guides/stacked-axes.svg new file mode 100644 index 0000000000..6d66656927 --- /dev/null +++ b/tests/testthat/_snaps/guides/stacked-axes.svg @@ -0,0 +1,148 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 + + + + +100 +200 +300 + +100 +200 +300 +400 + + + + + +100 +200 +300 +400 + + + + + + + + + +100 +200 +300 +400 + + + + + +100 +200 +300 +400 + + + + +100 +200 +300 + + + + +100 +200 +300 +top +bottom +left +right +stacked axes + + diff --git a/tests/testthat/_snaps/guides/stacked-radial-axes.svg b/tests/testthat/_snaps/guides/stacked-radial-axes.svg new file mode 100644 index 0000000000..240e16d958 --- /dev/null +++ b/tests/testthat/_snaps/guides/stacked-radial-axes.svg @@ -0,0 +1,143 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +100 +200 +300 + + + + +100 +200 +300 + + + + +100 +200 +300 + + + + +100 +200 +300 + + + + + +100 +200 +300 +400 + + + + + +100 +200 +300 +400 + + + + + + + + + +100 +200 +300 +400 + + + + + +100 +200 +300 +400 +hp +left +right +stacked radial axes + + diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-m-d.svg b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg similarity index 97% rename from tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-m-d.svg rename to tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg index 49346a1c5e..1fef513fa1 100644 --- a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-m-d.svg +++ b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-m-d.svg @@ -51,6 +51,6 @@ 06/01 dx price -scale_x_date(labels = date_format("%m/%d")) +scale_x_date(labels = label_date("%m/%d")) diff --git a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-w-week.svg b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg similarity index 97% rename from tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-w-week.svg rename to tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg index fa832b94e5..1748ed74f5 100644 --- a/tests/testthat/_snaps/scale_date/scale-x-date-labels-date-format-w-week.svg +++ b/tests/testthat/_snaps/scale_date/scale-x-date-labels-label-date-w-week.svg @@ -51,6 +51,6 @@ 22 week price -scale_x_date(labels = date_format("%W"), "week") +scale_x_date(labels = label_date("%W"), "week") diff --git a/tests/testthat/test-fortify.R b/tests/testthat/test-fortify.R index 43b7adb74c..03980c19c1 100644 --- a/tests/testthat/test-fortify.R +++ b/tests/testthat/test-fortify.R @@ -1,5 +1,8 @@ test_that("spatial polygons have correct ordering", { - skip_if_not_installed("sp") + suppressPackageStartupMessages({ + skip_if_not_installed("sp") + }) + make_square <- function(x = 0, y = 0, height = 1, width = 1){ delx <- width/2 @@ -30,12 +33,14 @@ test_that("spatial polygons have correct ordering", { polys2_sp <- sp::SpatialPolygons(polys2) fake_sp2 <- sp::SpatialPolygonsDataFrame(polys2_sp, fake_data) lifecycle::expect_deprecated( - expected <- fortify(fake_sp2) + # supressing: Regions defined for each Polygons + expected <- suppressMessages(fortify(fake_sp2)) ) expected <- expected[order(expected$id, expected$order), ] lifecycle::expect_deprecated( - actual <- fortify(fake_sp) + # 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 diff --git a/tests/testthat/test-function-args.R b/tests/testthat/test-function-args.R index 6be2567689..2a78bf9f50 100644 --- a/tests/testthat/test-function-args.R +++ b/tests/testthat/test-function-args.R @@ -50,8 +50,8 @@ test_that("stat_xxx and StatXxx$compute_panel arg defaults match", { stat_fun_names, c("stat_function", "stat_sf") ) - # Remove stat_spoke as it has been deprecated - stat_fun_names <- setdiff(stat_fun_names, "stat_spoke") + # Remove deprecated stats + stat_fun_names <- setdiff(stat_fun_names, c("stat_spoke", "stat_summary2d")) # For each stat_xxx function and the corresponding StatXxx$compute_panel and # StatXxx$compute_group functions, make sure that if they have same args, that diff --git a/tests/testthat/test-geom-dotplot.R b/tests/testthat/test-geom-dotplot.R index a095158937..69b7d65a75 100644 --- a/tests/testthat/test-geom-dotplot.R +++ b/tests/testthat/test-geom-dotplot.R @@ -63,7 +63,7 @@ test_that("NA's result in warning from stat_bindot", { test_that("when binning on y-axis, limits depend on the panel", { p <- ggplot(mtcars, aes(factor(cyl), mpg)) + - geom_dotplot(binaxis='y') + geom_dotplot(binaxis='y', binwidth = 1/30 * diff(range(mtcars$mpg))) b1 <- ggplot_build(p + facet_wrap(~am)) b2 <- ggplot_build(p + facet_wrap(~am, scales = "free_y")) @@ -77,10 +77,10 @@ test_that("when binning on y-axis, limits depend on the panel", { test_that("weight aesthetic is checked", { p <- ggplot(mtcars, aes(x = mpg, weight = gear/3)) + - geom_dotplot() + geom_dotplot(binwidth = 1/30 * diff(range(mtcars$mpg))) expect_snapshot_warning(ggplot_build(p)) p <- ggplot(mtcars, aes(x = mpg, weight = -gear)) + - geom_dotplot() + geom_dotplot(binwidth = 1/30 * diff(range(mtcars$mpg))) expect_snapshot_warning(ggplot_build(p)) }) diff --git a/tests/testthat/test-geom-hline-vline-abline.R b/tests/testthat/test-geom-hline-vline-abline.R index 61510a3c7c..b637cd0a2f 100644 --- a/tests/testthat/test-geom-hline-vline-abline.R +++ b/tests/testthat/test-geom-hline-vline-abline.R @@ -9,12 +9,11 @@ test_that("check h/v/abline transformed on basic projections", { geom_vline(xintercept = 3, colour = "red") + geom_hline(yintercept = 3, colour = "blue") + geom_abline(intercept = 0, slope = 1, colour = "purple") + - labs(x = NULL, y = NULL) + - coord_cartesian(expand = FALSE) + labs(x = NULL, y = NULL) expect_doppelganger( "cartesian lines intersect mid-bars", - plot + plot + coord_cartesian(expand = FALSE) ) expect_doppelganger( "flipped lines intersect mid-bars", @@ -34,11 +33,10 @@ test_that("curved lines in map projections", { nzmap <- ggplot(nz, aes(long, lat, group = group)) + geom_path() + geom_hline(yintercept = -38.6) + # roughly Taupo - geom_vline(xintercept = 176) + - coord_map() + geom_vline(xintercept = 176) expect_doppelganger("straight lines in mercator", - nzmap + nzmap + coord_map() ) expect_doppelganger("lines curved in azequalarea", nzmap + coord_map(projection = 'azequalarea', orientation = c(-36.92, 174.6, 0)) diff --git a/tests/testthat/test-geom-quantile.R b/tests/testthat/test-geom-quantile.R index 710f88436d..d9eaf84184 100644 --- a/tests/testthat/test-geom-quantile.R +++ b/tests/testthat/test-geom-quantile.R @@ -13,7 +13,7 @@ test_that("geom_quantile matches quantile regression", { y = x^2 + 0.5 * rnorm(10) ) - ps <- ggplot(df, aes(x, y)) + geom_quantile() + ps <- ggplot(df, aes(x, y)) + geom_quantile(formula = y ~ x) quants <- c(0.25, 0.5, 0.75) diff --git a/tests/testthat/test-geom-smooth.R b/tests/testthat/test-geom-smooth.R index ca57bd2e38..e71df88485 100644 --- a/tests/testthat/test-geom-smooth.R +++ b/tests/testthat/test-geom-smooth.R @@ -8,11 +8,13 @@ test_that("data is ordered by x", { }) test_that("geom_smooth works in both directions", { - p <- ggplot(mpg, aes(displ, hwy)) + geom_smooth() + p <- ggplot(mpg, aes(displ, hwy)) + + geom_smooth(method = 'loess', formula = y ~ x) x <- layer_data(p) expect_false(x$flipped_aes[1]) - p <- ggplot(mpg, aes(hwy, displ)) + geom_smooth(orientation = "y") + p <- ggplot(mpg, aes(hwy, displ)) + + geom_smooth(orientation = "y", method = 'loess', formula = y ~ x) y <- layer_data(p) expect_true(y$flipped_aes[1]) @@ -103,11 +105,11 @@ test_that("geom_smooth() works with alternative stats", { expect_doppelganger("ribbon turned on in geom_smooth", { ggplot(df, aes(x, y, color = fill, fill = fill)) + - geom_smooth(stat = "summary") # ribbon on by default + geom_smooth(stat = "summary", fun.data = mean_se) # ribbon on by default }) expect_doppelganger("ribbon turned off in geom_smooth", { ggplot(df, aes(x, y, color = fill, fill = fill)) + - geom_smooth(stat = "summary", se = FALSE) # ribbon is turned off via `se = FALSE` + geom_smooth(stat = "summary", se = FALSE, fun.data = mean_se) # ribbon is turned off via `se = FALSE` }) }) diff --git a/tests/testthat/test-guides.R b/tests/testthat/test-guides.R index 96c90efe96..58d5d04124 100644 --- a/tests/testthat/test-guides.R +++ b/tests/testthat/test-guides.R @@ -627,6 +627,31 @@ test_that("axis guides can be capped", { expect_doppelganger("axis guides with capped ends", p) }) +test_that("guide_axis_stack stacks axes", { + + left <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "left") + right <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "right") + bottom <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "bottom") + top <- guide_axis_stack("axis", guide_axis(cap = "both"), title = "top") + + p <- ggplot(mtcars, aes(hp, disp)) + + geom_point() + + theme(axis.line = element_line()) + + guides(x = bottom, x.sec = top, y = left, y.sec = right) + expect_doppelganger("stacked axes", p) + + bottom <- guide_axis_stack("axis_theta", guide_axis_theta(cap = "both")) + top <- guide_axis_stack("axis_theta", guide_axis_theta(cap = "both")) + + p <- ggplot(mtcars, aes(hp, disp)) + + geom_point() + + theme(axis.line = element_line()) + + coord_radial(start = 0.25 * pi, end = 1.75 * pi, donut = 0.5) + + guides(theta = top, theta.sec = bottom, r = left, r.sec = right) + expect_doppelganger("stacked radial axes", p) + +}) + test_that("logticks look as they should", { p <- ggplot(data.frame(x = c(-100, 100), y = c(10, 1000)), aes(x, y)) + @@ -660,7 +685,6 @@ test_that("logticks look as they should", { ) ) expect_doppelganger("logtick axes with customisation", p) - }) test_that("guides are positioned correctly", { diff --git a/tests/testthat/test-layer.R b/tests/testthat/test-layer.R index 58ae5051bd..b0507cf7ae 100644 --- a/tests/testthat/test-layer.R +++ b/tests/testthat/test-layer.R @@ -26,10 +26,13 @@ test_that("unknown aesthetics create warning", { }) test_that("invalid aesthetics throws errors", { - p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = data)) - expect_snapshot_error(ggplot_build(p)) - p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = after_stat(data))) - expect_snapshot_error(ggplot_build(p)) + # We want to test error and ignore the scale search message + suppressMessages({ + p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = data)) + expect_snapshot_error(ggplot_build(p)) + p <- ggplot(mtcars) + geom_point(aes(disp, mpg, fill = after_stat(data))) + expect_snapshot_error(ggplot_build(p)) + }) }) test_that("unknown NULL aesthetic doesn't create warning (#1909)", { @@ -57,8 +60,12 @@ test_that("missing aesthetics trigger informative error", { test_that("function aesthetics are wrapped with after_stat()", { df <- data_frame(x = 1:10) - expect_snapshot_error( - ggplot_build(ggplot(df, aes(colour = density, fill = density)) + geom_point()) + suppressMessages( + expect_snapshot_error( + ggplot_build( + ggplot(df, aes(colour = density, fill = density)) + geom_point() + ) + ) ) }) diff --git a/tests/testthat/test-stat-bin.R b/tests/testthat/test-stat-bin.R index 24aa21ec6a..d15a19fcff 100644 --- a/tests/testthat/test-stat-bin.R +++ b/tests/testthat/test-stat-bin.R @@ -9,11 +9,11 @@ test_that("stat_bin throws error when wrong combination of aesthetic is present" }) test_that("stat_bin works in both directions", { - p <- ggplot(mpg, aes(hwy)) + stat_bin() + p <- ggplot(mpg, aes(hwy)) + stat_bin(bins = 30) x <- layer_data(p) expect_false(x$flipped_aes[1]) - p <- ggplot(mpg, aes(y = hwy)) + stat_bin() + p <- ggplot(mpg, aes(y = hwy)) + stat_bin(bins = 30) y <- layer_data(p) expect_true(y$flipped_aes[1]) @@ -81,7 +81,7 @@ test_that("breaks are transformed by the scale", { test_that("geom_histogram() can be drawn over a 0-width range (#3043)", { df <- data_frame(x = rep(1, 100)) - out <- layer_data(ggplot(df, aes(x)) + geom_histogram()) + out <- layer_data(ggplot(df, aes(x)) + geom_histogram(bins = 30)) expect_equal(nrow(out), 1) expect_equal(out$xmin, 0.95) diff --git a/tests/testthat/test-utilities-checks.R b/tests/testthat/test-utilities-checks.R index 04dbd79f52..0619ccc707 100644 --- a/tests/testthat/test-utilities-checks.R +++ b/tests/testthat/test-utilities-checks.R @@ -2,7 +2,8 @@ test_that("check_device checks R versions correctly", { # Most widely supported device - withr::local_pdf() + file <- withr::local_tempfile(fileext = ".pdf") + withr::local_pdf(file) # R 4.0.0 doesn't support any new features with_mocked_bindings( @@ -45,7 +46,8 @@ test_that("check_device finds device capabilities", { getRversion() < "4.2.0", "R version < 4.2.0 does doesn't have proper `dev.capabilities()`." ) - withr::local_pdf() + file <- withr::local_tempfile(fileext = ".pdf") + withr::local_pdf(file) with_mocked_bindings( dev.capabilities = function() list(clippingPaths = TRUE), expect_true(check_device("clippingPaths")),