Stacked axes

DESCRIPTION

@@ -175,6 +175,7 @@ Collate:
     'grouping.R'
     'guide-.R'
     'guide-axis.R'
+    'guide-axis-stack.R'
     'guide-legend.R'
     'guide-bins.R'
     'guide-colorbar.R'

NAMESPACE

@@ -211,6 +211,7 @@ export(GeomViolin)
 export(GeomVline)
 export(Guide)
 export(GuideAxis)
+export(GuideAxisStack)
 export(GuideBins)
 export(GuideColourbar)
 export(GuideColoursteps)
@@ -418,6 +419,7 @@ export(ggproto_parent)
 export(ggsave)
 export(ggtitle)
 export(guide_axis)
+export(guide_axis_stack)
 export(guide_bins)
 export(guide_colorbar)
 export(guide_colorsteps)

R/guide-axis-stack.R

@@ -0,0 +1,191 @@
+#' @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"),
+    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(),
+    hash      = character(),
+    position  = waiver(),
+    direction = NULL,
+    order     = 0
+  ),
+
+  available_aes = c("x", "y"),
+
+  # 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, .trbl, arg_nm = "position")
+    for (i in seq_along(params$guides)) {
+      params$guide_params[[i]]$position <- position
+      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, params = self$params) {
+    # Loop through every guide's draw method
+    grobs <- list()
+    for (i in seq_along(params$guides)) {
+      grobs[[i]] <- params$guides[[i]]$draw(theme, 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
+    position <- params$position
+    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)
+    } 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)
+    }
+
+    absoluteGrob(
+      grob   = gList(gt),
+      width  = gtable_width(gt),
+      height = gtable_height(gt)
+    )
+  }
+)
+