Skip to content

Commit b38caa3

Browse files
teunbrandteunbrand
authored
Stacked axes (tidyverse#5473)
* first draft * Sprinkle some comments * roxygenate * Add test * Add pkgdown item * pass along position/direction * measure size of theta axes * stacked axis is valid theta axis * stack theta axes * incorporate offset into theta guide * fix angle/justification for radial axes * enable theta.sec * add radial test * Add news bullet
1 parent 3765b97 commit b38caa3

11 files changed

+732
-22
lines changed

‎DESCRIPTION

+1
Original file line numberDiff line numberDiff line change
@@ -176,6 +176,7 @@ Collate:
176176
'guide-.R'
177177
'guide-axis.R'
178178
'guide-axis-logticks.R'
179+
'guide-axis-stack.R'
179180
'guide-axis-theta.R'
180181
'guide-legend.R'
181182
'guide-bins.R'

‎NAMESPACE

+2
Original file line numberDiff line numberDiff line change
@@ -214,6 +214,7 @@ export(GeomVline)
214214
export(Guide)
215215
export(GuideAxis)
216216
export(GuideAxisLogticks)
217+
export(GuideAxisStack)
217218
export(GuideBins)
218219
export(GuideColourbar)
219220
export(GuideColoursteps)
@@ -424,6 +425,7 @@ export(ggsave)
424425
export(ggtitle)
425426
export(guide_axis)
426427
export(guide_axis_logticks)
428+
export(guide_axis_stack)
427429
export(guide_axis_theta)
428430
export(guide_bins)
429431
export(guide_colorbar)

‎NEWS.md

+2
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
# ggplot2 (development version)
22

3+
* New `guide_axis_stack()` to combine other axis guides on top of one another.
4+
35
* New `guide_custom()` function for drawing custom graphical objects (grobs)
46
unrelated to scales in legend positions (#5416).
57

‎R/guide-axis-stack.R

+242
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,242 @@
1+
#' @include guide-axis.R
2+
NULL
3+
4+
#' Stacked axis guides
5+
#'
6+
#' This guide can stack other position guides that represent position scales,
7+
#' like those created with [scale_(x|y)_continuous()][scale_x_continuous()] and
8+
#' [scale_(x|y)_discrete()][scale_x_discrete()].
9+
#'
10+
#' @inheritParams guide_axis
11+
#' @param first A position guide given as one of the following:
12+
#' * A string, for example `"axis"`.
13+
#' * A call to a guide function, for example `guide_axis()`.
14+
#' @param ... Additional guides to stack given in the same manner as `first`.
15+
#' @param spacing A [unit()] objects that determines how far separate guides are
16+
#' spaced apart.
17+
#'
18+
#' @details
19+
#' The `first` guide will be placed closest to the panel and any subsequent
20+
#' guides provided through `...` will follow in the given order.
21+
#'
22+
#' @export
23+
#'
24+
#' @examples
25+
#' #' # A standard plot
26+
#' p <- ggplot(mpg, aes(displ, hwy)) +
27+
#' geom_point() +
28+
#' theme(axis.line = element_line())
29+
#'
30+
#' # A normal axis first, then a capped axis
31+
#' p + guides(x = guide_axis_stack("axis", guide_axis(cap = "both")))
32+
guide_axis_stack <- function(first = "axis", ..., title = waiver(),
33+
spacing = NULL, order = 0, position = waiver()) {
34+
35+
check_object(spacing, is.unit, "{.cls unit}", allow_null = TRUE)
36+
37+
# Validate guides
38+
axes <- list2(first, ...)
39+
axes <- lapply(axes, validate_guide)
40+
41+
# Check available aesthetics
42+
available <- lapply(axes, `[[`, name = "available_aes")
43+
available <- vapply(available, function(x) all(c("x", "y") %in% x), logical(1))
44+
if (all(!available)) {
45+
cli::cli_abort(paste0(
46+
"{.fn guide_axis_stack} can only use guides that handle {.field x} and ",
47+
"{.field y} aesthetics."
48+
))
49+
}
50+
51+
# Remove guides that don't support x/y aesthetics
52+
if (any(!available)) {
53+
remove <- which(!available)
54+
removed <- vapply(axes[remove], snake_class, character(1))
55+
axes[remove] <- NULL
56+
cli::cli_warn(c(paste0(
57+
"{.fn guide_axis_stack} cannot use the following guide{?s}: ",
58+
"{.and {.fn {removed}}}."
59+
), i = "Guides need to handle {.field x} and {.field y} aesthetics."))
60+
}
61+
62+
params <- lapply(axes, `[[`, name = "params")
63+
64+
new_guide(
65+
title = title,
66+
guides = axes,
67+
guide_params = params,
68+
available_aes = c("x", "y", "theta", "r"),
69+
order = order,
70+
position = position,
71+
name = "stacked_axis",
72+
super = GuideAxisStack
73+
)
74+
}
75+
76+
#' @rdname ggplot2-ggproto
77+
#' @format NULL
78+
#' @usage NULL
79+
#' @export
80+
GuideAxisStack <- ggproto(
81+
"GuideAxisStack", GuideAxis,
82+
83+
params = list(
84+
# List of guides to track the guide objects
85+
guides = list(),
86+
# List of parameters to each guide
87+
guide_params = list(),
88+
# Standard guide stuff
89+
name = "stacked_axis",
90+
title = waiver(),
91+
angle = waiver(),
92+
hash = character(),
93+
position = waiver(),
94+
direction = NULL,
95+
order = 0
96+
),
97+
98+
available_aes = c("x", "y", "theta", "r"),
99+
100+
# Doesn't depend on keys, but on member axis' class
101+
hashables = exprs(title, lapply(guides, snake_class), name),
102+
103+
# Sets position, loops through guides to train
104+
train = function(self, params = self$params, scale, aesthetic = NULL, ...) {
105+
position <- arg_match0(
106+
params$position, c(.trbl, "theta", "theta.sec"),
107+
arg_nm = "position"
108+
)
109+
for (i in seq_along(params$guides)) {
110+
params$guide_params[[i]]$position <- position
111+
params$guide_params[[i]]$angle <- params$guide_params[[i]]$angle %|W|% params$angle
112+
params$guide_params[[i]] <- params$guides[[i]]$train(
113+
params = params$guide_params[[i]],
114+
scale = scale, aesthetic = aesthetic,
115+
...
116+
)
117+
}
118+
params
119+
},
120+
121+
# Just loops through guides
122+
transform = function(self, params, coord, panel_params) {
123+
for (i in seq_along(params$guides)) {
124+
params$guide_params[[i]] <- params$guides[[i]]$transform(
125+
params = params$guide_params[[i]],
126+
coord = coord, panel_params = panel_params
127+
)
128+
}
129+
params
130+
},
131+
132+
# Just loops through guides
133+
get_layer_key = function(params, layers) {
134+
for (i in seq_along(params$guides)) {
135+
params$guide_params[[i]] <- params$guides[[i]]$get_layer_key(
136+
params = params$guide_params[[i]],
137+
layers = layers
138+
)
139+
}
140+
params
141+
},
142+
143+
draw = function(self, theme, position = NULL, direction = NULL,
144+
params = self$params) {
145+
146+
position <- params$position %||% position
147+
direction <- params$direction %||% direction
148+
149+
if (position %in% c("theta", "theta.sec")) {
150+
# If we are a theta guide, we need to keep track how much space in the
151+
# radial direction a guide occupies, and add that as an offset to the
152+
# next guide.
153+
offset <- unit(0, "cm")
154+
spacing <- params$spacing %||% unit(2.25, "pt")
155+
grobs <- list()
156+
for (i in seq_along(params$guides)) {
157+
# Add offset to params
158+
pars <- params$guide_params[[i]]
159+
pars$stack_offset <- offset
160+
# Draw guide
161+
grobs[[i]] <- params$guides[[i]]$draw(
162+
theme, position = position, direction = direction,
163+
params = pars
164+
)
165+
# Increment offset
166+
if (!is.null(grobs[[i]]$offset)) {
167+
offset <- offset + spacing + grobs[[i]]$offset
168+
offset <- convertUnit(offset, "cm")
169+
}
170+
}
171+
grob <- inject(grobTree(!!!grobs))
172+
return(grob)
173+
}
174+
175+
# Loop through every guide's draw method
176+
grobs <- list()
177+
for (i in seq_along(params$guides)) {
178+
grobs[[i]] <- params$guides[[i]]$draw(
179+
theme, position = position, direction = direction,
180+
params = params$guide_params[[i]]
181+
)
182+
}
183+
184+
# Remove empty grobs
185+
grobs <- grobs[!vapply(grobs, is.zero, logical(1))]
186+
if (length(grobs) == 0) {
187+
return(zeroGrob())
188+
}
189+
along <- seq_along(grobs)
190+
191+
# Get sizes
192+
widths <- inject(unit.c(!!!lapply(grobs, grobWidth)))
193+
heights <- inject(unit.c(!!!lapply(grobs, grobHeight)))
194+
195+
# Set spacing
196+
if (is.null(params$spacing)) {
197+
aes <- if (position %in% c("top", "bottom")) "x" else "y"
198+
spacing <- paste("axis.ticks.length", aes, position, sep = ".")
199+
spacing <- calc_element(spacing, theme)
200+
} else {
201+
spacing <- params$spacing
202+
}
203+
204+
# Reorder grobs/sizes if necessary
205+
if (position %in% c("top", "left")) {
206+
along <- rev(along)
207+
widths <- rev(widths)
208+
heights <- rev(heights)
209+
}
210+
211+
# Place guides in a gtable, apply spacing
212+
if (position %in% c("bottom", "top")) {
213+
gt <- gtable(widths = unit(1, "npc"), heights = heights)
214+
gt <- gtable_add_grob(gt, grobs, t = along, l = 1, name = "axis", clip = "off")
215+
gt <- gtable_add_row_space(gt, height = spacing)
216+
vp <- exec(
217+
viewport,
218+
y = unit(as.numeric(position == "bottom"), "npc"),
219+
height = grobHeight(gt),
220+
just = opposite_position(position)
221+
)
222+
} else {
223+
gt <- gtable(widths = widths, heights = unit(1, "npc"))
224+
gt <- gtable_add_grob(gt, grobs, t = 1, l = along, name = "axis", clip = "off")
225+
gt <- gtable_add_col_space(gt, width = spacing)
226+
vp <- exec(
227+
viewport,
228+
x = unit(as.numeric(position == "left"), "npc"),
229+
width = grobWidth(gt),
230+
just = opposite_position(position)
231+
)
232+
}
233+
234+
absoluteGrob(
235+
grob = gList(gt),
236+
width = gtable_width(gt),
237+
height = gtable_height(gt),
238+
vp = vp
239+
)
240+
}
241+
)
242+

0 commit comments

Comments
 (0)