1
2#' Axis guide
3#'
4#' Axis guides are the visual representation of position scales like those
5#' created with [scale_(x|y)_continuous()][scale_x_continuous()] and
6#' [scale_(x|y)_discrete()][scale_x_discrete()].
7#'
8#' @inheritParams guide_legend
9#' @param check.overlap silently remove overlapping labels,
10#'   (recursively) prioritizing the first, last, and middle labels.
11#' @param angle Compared to setting the angle in [theme()] / [element_text()],
12#'   this also uses some heuristics to automatically pick the `hjust` and `vjust` that
13#'   you probably want.
14#' @param n.dodge The number of rows (for vertical axes) or columns (for
15#'   horizontal axes) that should be used to render the labels. This is
16#'   useful for displaying labels that would otherwise overlap.
17#' @param order Used to determine the order of the guides (left-to-right,
18#'   top-to-bottom), if more than one  guide must be drawn at the same location.
19#' @param position Where this guide should be drawn: one of top, bottom,
20#'   left, or right.
21#'
22#' @export
23#'
24#' @examples
25#' # plot with overlapping text
26#' p <- ggplot(mpg, aes(cty * 100, hwy * 100)) +
27#'   geom_point() +
28#'   facet_wrap(vars(class))
29#'
30#' # axis guides can be customized in the scale_* functions or
31#' # using guides()
32#' p + scale_x_continuous(guide = guide_axis(n.dodge = 2))
33#' p + guides(x = guide_axis(angle = 90))
34#'
35#' # can also be used to add a duplicate guide
36#' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis())
37#'
38#'
39guide_axis <- function(title = waiver(), check.overlap = FALSE, angle = NULL, n.dodge = 1,
40                       order = 0, position = waiver()) {
41  structure(
42    list(
43      title = title,
44
45      # customizations
46      check.overlap = check.overlap,
47      angle = angle,
48      n.dodge = n.dodge,
49
50      # general
51      order = order,
52      position = position,
53
54      # parameter
55      available_aes = c("x", "y"),
56
57      name = "axis"
58    ),
59    class = c("guide", "axis")
60  )
61}
62
63#' @export
64guide_train.axis <- function(guide, scale, aesthetic = NULL) {
65
66  aesthetic <- aesthetic %||% scale$aesthetics[1]
67  breaks <- scale$get_breaks()
68
69  empty_ticks <- new_data_frame(
70    list(aesthetic = numeric(0), .value = numeric(0), .label = character(0))
71  )
72  names(empty_ticks) <- c(aesthetic, ".value", ".label")
73
74  if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) {
75    warn(glue(
76      "axis guide needs appropriate scales: ",
77      glue_collapse(guide$available_aes, ", ", last = " or ")
78    ))
79    guide$key <- empty_ticks
80  } else if (length(breaks) == 0) {
81    guide$key <- empty_ticks
82  } else {
83    mapped_breaks <- if (scale$is_discrete()) scale$map(breaks) else breaks
84    ticks <- new_data_frame(setNames(list(mapped_breaks), aesthetic))
85    ticks$.value <- breaks
86    ticks$.label <- scale$get_labels(breaks)
87
88    guide$key <- ticks[is.finite(ticks[[aesthetic]]), ]
89  }
90
91  guide$name <- paste0(guide$name, "_", aesthetic)
92  guide$hash <- digest::digest(list(guide$title, guide$key$.value, guide$key$.label, guide$name))
93  guide
94}
95
96#' @export
97guide_transform.axis <- function(guide, coord, panel_params) {
98  if (is.null(guide$position) || nrow(guide$key) == 0) {
99    return(guide)
100  }
101
102  aesthetics <- names(guide$key)[!grepl("^\\.", names(guide$key))]
103
104  if (all(c("x", "y") %in% aesthetics)) {
105    guide$key <- coord$transform(guide$key, panel_params)
106  } else {
107    other_aesthetic <- setdiff(c("x", "y"), aesthetics)
108    override_value <- if (guide$position %in% c("bottom", "left")) -Inf else Inf
109    guide$key[[other_aesthetic]] <- override_value
110
111    guide$key <- coord$transform(guide$key, panel_params)
112
113    warn_for_guide_position(guide)
114  }
115
116  guide
117}
118
119# discards the new guide with a warning
120#' @export
121guide_merge.axis <- function(guide, new_guide) {
122  if (!inherits(new_guide, "guide_none")) {
123    warn("guide_axis(): Discarding guide on merge. Do you have more than one guide with the same position?")
124  }
125
126  guide
127}
128
129# axis guides don't care which geometry uses these aesthetics
130#' @export
131guide_geom.axis <- function(guide, layers, default_mapping) {
132  guide
133}
134
135#' @export
136guide_gengrob.axis <- function(guide, theme) {
137  aesthetic <- names(guide$key)[!grepl("^\\.", names(guide$key))][1]
138
139  draw_axis(
140    break_positions = guide$key[[aesthetic]],
141    break_labels = guide$key$.label,
142    axis_position = guide$position,
143    theme = theme,
144    check.overlap = guide$check.overlap,
145    angle = guide$angle,
146    n.dodge = guide$n.dodge
147  )
148}
149
150
151#' Grob for axes
152#'
153#' @param break_position position of ticks
154#' @param break_labels labels at ticks
155#' @param axis_position position of axis (top, bottom, left or right)
156#' @param theme A complete [theme()] object
157#' @param check.overlap silently remove overlapping labels,
158#'   (recursively) prioritizing the first, last, and middle labels.
159#' @param angle Compared to setting the angle in [theme()] / [element_text()],
160#'   this also uses some heuristics to automatically pick the `hjust` and `vjust` that
161#'   you probably want.
162#' @param n.dodge The number of rows (for vertical axes) or columns (for
163#'   horizontal axes) that should be used to render the labels. This is
164#'   useful for displaying labels that would otherwise overlap.
165#'
166#' @noRd
167#'
168draw_axis <- function(break_positions, break_labels, axis_position, theme,
169                      check.overlap = FALSE, angle = NULL, n.dodge = 1) {
170
171  axis_position <- match.arg(axis_position, c("top", "bottom", "right", "left"))
172  aesthetic <- if (axis_position %in% c("top", "bottom")) "x" else "y"
173
174  # resolve elements
175  line_element_name <- paste0("axis.line.", aesthetic, ".", axis_position)
176  tick_element_name <- paste0("axis.ticks.", aesthetic, ".", axis_position)
177  tick_length_element_name <- paste0("axis.ticks.length.", aesthetic, ".", axis_position)
178  label_element_name <- paste0("axis.text.", aesthetic, ".", axis_position)
179
180  line_element <- calc_element(line_element_name, theme)
181  tick_element <- calc_element(tick_element_name, theme)
182  tick_length <- calc_element(tick_length_element_name, theme)
183  label_element <- calc_element(label_element_name, theme)
184
185  # override label element parameters for rotation
186  if (inherits(label_element, "element_text")) {
187    label_overrides <- axis_label_element_overrides(axis_position, angle)
188    # label_overrides is an element_text, but label_element may not be;
189    # to merge the two elements, we just copy angle, hjust, and vjust
190    # unless their values are NULL
191    if (!is.null(label_overrides$angle)) {
192      label_element$angle <- label_overrides$angle
193    }
194    if (!is.null(label_overrides$hjust)) {
195      label_element$hjust <- label_overrides$hjust
196    }
197    if (!is.null(label_overrides$vjust)) {
198      label_element$vjust <- label_overrides$vjust
199    }
200  }
201
202  # conditionally set parameters that depend on axis orientation
203  is_vertical <- axis_position %in% c("left",  "right")
204
205  position_dim <- if (is_vertical) "y" else "x"
206  non_position_dim <- if (is_vertical) "x" else "y"
207  position_size <- if (is_vertical) "height" else "width"
208  non_position_size <- if (is_vertical) "width" else "height"
209  gtable_element <- if (is_vertical) gtable_row else gtable_col
210  measure_gtable <- if (is_vertical) gtable_width else gtable_height
211  measure_labels_non_pos <- if (is_vertical) grobWidth else grobHeight
212
213  # conditionally set parameters that depend on which side of the panel
214  # the axis is on
215  is_second <- axis_position %in% c("right", "top")
216
217  tick_direction <- if (is_second) 1 else -1
218  non_position_panel <- if (is_second) unit(0, "npc") else unit(1, "npc")
219  tick_coordinate_order <- if (is_second) c(2, 1) else c(1, 2)
220
221  # conditionally set the gtable ordering
222  labels_first_gtable <- axis_position %in% c("left", "top") # refers to position in gtable
223
224  # set common parameters
225  n_breaks <- length(break_positions)
226  opposite_positions <- c("top" = "bottom", "bottom" = "top", "right" = "left", "left" = "right")
227  axis_position_opposite <- unname(opposite_positions[axis_position])
228
229  # draw elements
230  line_grob <- exec(
231    element_grob, line_element,
232    !!position_dim := unit(c(0, 1), "npc"),
233    !!non_position_dim := unit.c(non_position_panel, non_position_panel)
234  )
235
236  if (n_breaks == 0) {
237    return(
238      absoluteGrob(
239        gList(line_grob),
240        width = grobWidth(line_grob),
241        height = grobHeight(line_grob)
242      )
243    )
244  }
245
246  # break_labels can be a list() of language objects
247  if (is.list(break_labels)) {
248    if (any(vapply(break_labels, is.language, logical(1)))) {
249      break_labels <- do.call(expression, break_labels)
250    } else {
251      break_labels <- unlist(break_labels)
252    }
253  }
254
255  # calculate multiple rows/columns of labels (which is usually 1)
256  dodge_pos <- rep(seq_len(n.dodge), length.out = n_breaks)
257  dodge_indices <- split(seq_len(n_breaks), dodge_pos)
258
259  label_grobs <- lapply(dodge_indices, function(indices) {
260    draw_axis_labels(
261      break_positions = break_positions[indices],
262      break_labels = break_labels[indices],
263      label_element = label_element,
264      is_vertical = is_vertical,
265      check.overlap = check.overlap
266    )
267  })
268
269  ticks_grob <- exec(
270    element_grob, tick_element,
271    !!position_dim := rep(unit(break_positions, "native"), each = 2),
272    !!non_position_dim := rep(
273      unit.c(non_position_panel + (tick_direction * tick_length), non_position_panel)[tick_coordinate_order],
274      times = n_breaks
275    ),
276    id.lengths = rep(2, times = n_breaks)
277  )
278
279  # create gtable
280  non_position_sizes <- paste0(non_position_size, "s")
281  label_dims <- do.call(unit.c, lapply(label_grobs, measure_labels_non_pos))
282  grobs <- c(list(ticks_grob), label_grobs)
283  grob_dims <- unit.c(max(tick_length, unit(0, "pt")), label_dims)
284
285  if (labels_first_gtable) {
286    grobs <- rev(grobs)
287    grob_dims <- rev(grob_dims)
288  }
289
290  gt <- exec(
291    gtable_element,
292    name = "axis",
293    grobs = grobs,
294    !!non_position_sizes := grob_dims,
295    !!position_size := unit(1, "npc")
296  )
297
298  # create viewport
299  justvp <- exec(
300    viewport,
301    !!non_position_dim := non_position_panel,
302    !!non_position_size := measure_gtable(gt),
303    just = axis_position_opposite
304  )
305
306  absoluteGrob(
307    gList(line_grob, gt),
308    width = gtable_width(gt),
309    height = gtable_height(gt),
310    vp = justvp
311  )
312}
313
314draw_axis_labels <- function(break_positions, break_labels, label_element, is_vertical,
315                             check.overlap = FALSE) {
316
317  position_dim <- if (is_vertical) "y" else "x"
318  label_margin_name <- if (is_vertical) "margin_x" else "margin_y"
319
320  n_breaks <- length(break_positions)
321  break_positions <- unit(break_positions, "native")
322
323  if (check.overlap) {
324    priority <- axis_label_priority(n_breaks)
325    break_labels <- break_labels[priority]
326    break_positions <- break_positions[priority]
327  }
328
329  labels_grob <- exec(
330    element_grob, label_element,
331    !!position_dim := break_positions,
332    !!label_margin_name := TRUE,
333    label = break_labels,
334    check.overlap = check.overlap
335  )
336}
337
338#' Determine the label priority for a given number of labels
339#'
340#' @param n The number of labels
341#'
342#' @return The vector `seq_len(n)` arranged such that the
343#'   first, last, and middle elements are recursively
344#'   placed at the beginning of the vector.
345#' @noRd
346#'
347axis_label_priority <- function(n) {
348  if (n <= 0) {
349    return(numeric(0))
350  }
351
352  c(1, n, axis_label_priority_between(1, n))
353}
354
355axis_label_priority_between <- function(x, y) {
356  n <- y - x + 1
357  if (n <= 2) {
358    return(numeric(0))
359  }
360
361  mid <- x - 1 + (n + 1) %/% 2
362  c(
363    mid,
364    axis_label_priority_between(x, mid),
365    axis_label_priority_between(mid, y)
366  )
367}
368
369#' Override axis text angle and alignment
370#'
371#' @param axis_position One of bottom, left, top, or right
372#' @param angle The text angle, or NULL to override nothing
373#'
374#' @return An [element_text()] that contains parameters that should be
375#'   overridden from the user- or theme-supplied element.
376#' @noRd
377#'
378axis_label_element_overrides <- function(axis_position, angle = NULL) {
379  if (is.null(angle)) {
380    return(element_text(angle = NULL, hjust = NULL, vjust = NULL))
381  }
382
383  # it is not worth the effort to align upside-down labels properly
384  if (angle > 90 || angle < -90) {
385    abort("`angle` must be between 90 and -90")
386  }
387
388  if (axis_position == "bottom") {
389    element_text(
390      angle = angle,
391      hjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5,
392      vjust = if (abs(angle) == 90) 0.5 else 1
393    )
394  } else if (axis_position == "left") {
395    element_text(
396      angle = angle,
397      hjust = if (abs(angle) == 90) 0.5 else 1,
398      vjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5,
399    )
400  } else if (axis_position == "top") {
401    element_text(
402      angle = angle,
403      hjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5,
404      vjust = if (abs(angle) == 90) 0.5 else 0
405    )
406  } else if (axis_position == "right") {
407    element_text(
408      angle = angle,
409      hjust = if (abs(angle) == 90) 0.5 else 0,
410      vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5,
411    )
412  } else {
413    abort(glue("Unrecognized position: '{axis_position}'"))
414  }
415}
416
417warn_for_guide_position <- function(guide) {
418  # This is trying to catch when a user specifies a position perpendicular
419  # to the direction of the axis (e.g., a "y" axis on "top").
420  # The strategy is to check that two or more unique breaks are mapped
421  # to the same value along the axis.
422  breaks_are_unique <- !duplicated(guide$key$.value)
423  if (empty(guide$key) || sum(breaks_are_unique) == 1) {
424    return()
425  }
426
427  if (guide$position %in% c("top", "bottom")) {
428    position_aes <- "x"
429  } else if(guide$position %in% c("left", "right")) {
430    position_aes <- "y"
431  } else {
432    return()
433  }
434
435  if (length(unique(guide$key[[position_aes]][breaks_are_unique])) == 1) {
436    warn("Position guide is perpendicular to the intended axis. Did you mean to specify a different guide `position`?")
437  }
438}
439