diff --git a/DESCRIPTION b/DESCRIPTION
index 3fc6116632..c5c8af640e 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 b423ca0bbc..1e43aa78ad 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -214,6 +214,7 @@ export(GeomVline)
export(Guide)
export(GuideAxis)
export(GuideAxisLogticks)
+export(GuideAxisStack)
export(GuideBins)
export(GuideColourbar)
export(GuideColoursteps)
@@ -424,6 +425,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 96ca2cdf69..992d5cc395 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,7 @@
# ggplot2 (development version)
+* 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/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/_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 @@
+
+
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 @@
+
+
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", {