1#' A binned version of guide_legend
2#'
3#' This guide is a version of the [guide_legend()] guide for binned scales. It
4#' differs in that it places ticks correctly between the keys, and sports a
5#' small axis to better show the binning. Like [guide_legend()] it can be used
6#' for all non-position aesthetics though colour and fill defaults to
7#' [guide_coloursteps()], and it will merge aesthetics together into the same
8#' guide if they are mapped in the same way.
9#'
10#' @inheritParams guide_legend
11#' @param axis Logical. Should a small axis be drawn along the guide
12#' @param axis.colour,axis.linewidth Graphic specifications for the look of the
13#'   axis.
14#' @param axis.arrow A call to `arrow()` to specify arrows at the end of the
15#'   axis line, thus showing an open interval.
16#' @param show.limits Logical. Should the limits of the scale be shown with
17#'   labels and ticks.
18#'
19#' @section Use with discrete scale:
20#' This guide is intended to show binned data and work together with ggplot2's
21#' binning scales. However, it is sometimes desirable to perform the binning in
22#' a separate step, either as part of a stat (e.g. [stat_contour_filled()]) or
23#' prior to the visualisation. If you want to use this guide for discrete data
24#' the levels must follow the naming scheme implemented by [base::cut()]. This
25#' means that a bin must be encoded as `"(<lower>, <upper>]"` with `<lower>`
26#' giving the lower bound of the bin and `<upper>` giving the upper bound
27#' (`"[<lower>, <upper>)"` is also accepted). If you use [base::cut()] to
28#' perform the binning everything should work as expected, if not, some recoding
29#' may be needed.
30#'
31#' @return A guide object
32#' @family guides
33#' @export
34#'
35#' @examples
36#' p <- ggplot(mtcars) +
37#'   geom_point(aes(disp, mpg, size = hp)) +
38#'   scale_size_binned()
39#'
40#' # Standard look
41#' p
42#'
43#' # Remove the axis or style it
44#' p + guides(size = guide_bins(axis = FALSE))
45#'
46#' p + guides(size = guide_bins(show.limits = TRUE))
47#'
48#' p + guides(size = guide_bins(
49#'   axis.arrow = arrow(length = unit(1.5, 'mm'), ends = 'both')
50#' ))
51#'
52#' # Guides are merged together if possible
53#' ggplot(mtcars) +
54#'   geom_point(aes(disp, mpg, size = hp, colour = hp)) +
55#'   scale_size_binned() +
56#'   scale_colour_binned(guide = "bins")
57#'
58guide_bins <- function(
59  # title
60  title = waiver(),
61  title.position = NULL,
62  title.theme = NULL,
63  title.hjust = NULL,
64  title.vjust = NULL,
65
66  # label
67  label = TRUE,
68  label.position = NULL,
69  label.theme = NULL,
70  label.hjust = NULL,
71  label.vjust = NULL,
72
73  # key
74  keywidth = NULL,
75  keyheight = NULL,
76
77  # ticks
78  axis = TRUE,
79  axis.colour = "black",
80  axis.linewidth = 0.5,
81  axis.arrow = NULL,
82
83  # general
84  direction = NULL,
85  default.unit = "line",
86  override.aes = list(),
87  reverse = FALSE,
88  order = 0,
89  show.limits = NULL,
90  ...) {
91
92  structure(list(
93    # title
94    title = title,
95    title.position = title.position,
96    title.theme = title.theme,
97    title.hjust = title.hjust,
98    title.vjust = title.vjust,
99
100    # label
101    label = label,
102    label.position = label.position,
103    label.theme = label.theme,
104    label.hjust = label.hjust,
105    label.vjust = label.vjust,
106
107    # key
108    keywidth = keywidth,
109    keyheight = keyheight,
110
111    # ticks
112    axis = axis,
113    axis.colour = axis.colour,
114    axis.linewidth = axis.linewidth,
115    axis.arrow = axis.arrow,
116
117    # general
118    direction = direction,
119    override.aes = rename_aes(override.aes),
120    default.unit = default.unit,
121    reverse = reverse,
122    order = order,
123    show.limits = show.limits,
124
125    # parameter
126    available_aes = c("any"),
127    ...,
128    name = "bins"),
129    class = c("guide", "bins")
130  )
131}
132
133#' @export
134guide_train.bins <- function(guide, scale, aesthetic = NULL) {
135  breaks <- scale$get_breaks()
136  breaks <- breaks[!is.na(breaks)]
137  if (length(breaks) == 0 || all(is.na(breaks))) {
138    return()
139  }
140  # in the key data frame, use either the aesthetic provided as
141  # argument to this function or, as a fall back, the first in the vector
142  # of possible aesthetics handled by the scale
143  aes_column_name <- aesthetic %||% scale$aesthetics[1]
144
145  if (is.numeric(breaks)) {
146    limits <- scale$get_limits()
147    breaks <- breaks[!breaks %in% limits]
148    all_breaks <- c(limits[1], breaks, limits[2])
149    bin_at <- all_breaks[-1] - diff(all_breaks) / 2
150  } else {
151    # If the breaks are not numeric it is used with a discrete scale. We check
152    # if the breaks follow the allowed format "(<lower>, <upper>]", and if it
153    # does we convert it into bin specs
154    bin_at <- breaks
155    breaks <- as.character(breaks)
156    breaks <- strsplit(gsub("\\(|\\)|\\[|\\]", "", breaks), ",\\s?")
157    breaks <- as.numeric(unlist(breaks))
158    if (anyNA(breaks)) {
159      abort('Breaks not formatted correctly for a bin legend. Use `(<lower>, <upper>]` format to indicate bins')
160    }
161    all_breaks <- breaks[c(1, seq_along(bin_at) * 2)]
162  }
163  key <- new_data_frame(setNames(list(c(scale$map(bin_at), NA)), aes_column_name))
164  key$.label <- scale$get_labels(all_breaks)
165  guide$show.limits <- guide$show.limits %||% scale$show_limits %||% FALSE
166
167  if (guide$reverse) {
168    key <- key[rev(seq_len(nrow(key))), ]
169    # Move last row back to last
170    aesthetics <- setdiff(names(key), ".label")
171    key[, aesthetics] <- key[c(seq_len(nrow(key))[-1], 1), aesthetics]
172  }
173
174  guide$key <- key
175  guide$hash <- with(
176    guide,
177    digest::digest(list(title, key$.label, direction, name))
178  )
179  guide
180}
181
182#' @export
183guide_merge.bins <- function(guide, new_guide) {
184  guide$key <- merge(guide$key, new_guide$key, sort = FALSE)
185  guide$override.aes <- c(guide$override.aes, new_guide$override.aes)
186  if (any(duplicated(names(guide$override.aes)))) {
187    warn("Duplicated override.aes is ignored.")
188  }
189  guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))]
190  guide
191}
192
193#' @export
194guide_geom.bins <- function(guide, layers, default_mapping) {
195  # arrange common data for vertical and horizontal guide
196  guide$geoms <- lapply(layers, function(layer) {
197    matched <- matched_aes(layer, guide)
198
199    # check if this layer should be included
200    include <- include_layer_in_guide(layer, matched)
201
202    if (!include) {
203      return(NULL)
204    }
205
206    if (length(matched) > 0) {
207      # Filter out set aesthetics that can't be applied to the legend
208      n <- vapply(layer$aes_params, length, integer(1))
209      params <- layer$aes_params[n == 1]
210
211      aesthetics <- layer$computed_mapping
212      modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)]
213
214      data <- tryCatch(
215        layer$geom$use_defaults(guide$key[matched], params, modifiers),
216        error = function(...) {
217          warn("Failed to apply `after_scale()` modifications to legend")
218          layer$geom$use_defaults(guide$key[matched], params, list())
219        }
220      )
221    } else {
222      data <- layer$geom$use_defaults(NULL, layer$aes_params)[rep(1, nrow(guide$key)), ]
223    }
224
225    # override.aes in guide_legend manually changes the geom
226    data <- modify_list(data, guide$override.aes)
227
228    list(
229      draw_key = layer$geom$draw_key,
230      data = data,
231      params = c(layer$computed_geom_params, layer$computed_stat_params)
232    )
233  })
234
235  # remove null geom
236  guide$geoms <- compact(guide$geoms)
237
238  # Finally, remove this guide if no layer is drawn
239  if (length(guide$geoms) == 0) guide <- NULL
240  guide
241}
242
243#' @export
244guide_gengrob.bins <- function(guide, theme) {
245  if (!guide$show.limits) {
246    guide$key$.label[c(1, nrow(guide$key))] <- NA
247  }
248
249  # default setting
250  if (guide$direction == "horizontal") {
251    label.position <- guide$label.position %||% "bottom"
252    if (!label.position %in% c("top", "bottom")) {
253      warn("Ignoring invalid label.position")
254      label.position <- "bottom"
255    }
256  } else {
257    label.position <- guide$label.position %||% "right"
258    if (!label.position %in% c("left", "right")) {
259      warn("Ignoring invalid label.position")
260      label.position <- "right"
261    }
262  }
263
264  n_keys <- nrow(guide$key) - 1
265
266  # obtain the theme for the legend title. We need this both for the title grob
267  # and to obtain the title fontsize.
268  title.theme <- guide$title.theme %||% calc_element("legend.title", theme)
269
270  title.hjust <- guide$title.hjust %||% theme$legend.title.align %||% title.theme$hjust %||% 0
271  title.vjust <- guide$title.vjust %||% title.theme$vjust %||% 0.5
272
273  grob.title <- ggname("guide.title",
274                       element_grob(
275                         title.theme,
276                         label = guide$title,
277                         hjust = title.hjust,
278                         vjust = title.vjust,
279                         margin_x = TRUE,
280                         margin_y = TRUE
281                       )
282  )
283
284  title_width <- width_cm(grob.title)
285  title_height <- height_cm(grob.title)
286  title_fontsize <- title.theme$size %||% calc_element("legend.title", theme)$size %||%
287    calc_element("text", theme)$size %||% 11
288
289  # gap between keys etc
290  # the default horizontal and vertical gap need to be the same to avoid strange
291  # effects for certain guide layouts
292  hgap <- width_cm(theme$legend.spacing.x  %||% (0.5 * unit(title_fontsize, "pt")))
293  vgap <- height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_fontsize, "pt")))
294
295  # Labels
296
297  # first get the label theme, we need it below even when there are no labels
298  label.theme <- guide$label.theme %||% calc_element("legend.text", theme)
299
300  if (!guide$label || is.null(guide$key$.label)) {
301    grob.labels <- rep(list(zeroGrob()), nrow(guide$key))
302  } else {
303    # get the defaults for label justification. The defaults are complicated and depend
304    # on the direction of the legend and on label placement
305    just_defaults <- label_just_defaults.bins(guide$direction, label.position)
306    # don't set expressions left-justified
307    if (just_defaults$hjust == 0 && any(is.expression(guide$key$.label))) just_defaults$hjust <- 1
308
309    # We break inheritance for hjust and vjust, because that's more intuitive here; it still allows manual
310    # setting of hjust and vjust if desired. The alternative is to ignore hjust and vjust altogether, which
311    # seems worse
312    if (is.null(guide$label.theme$hjust) && is.null(theme$legend.text$hjust)) label.theme$hjust <- NULL
313    if (is.null(guide$label.theme$vjust) && is.null(theme$legend.text$vjust)) label.theme$vjust <- NULL
314
315    # label.theme in param of guide_legend() > theme$legend.text.align > default
316    hjust <- guide$label.hjust %||% theme$legend.text.align %||% label.theme$hjust %||%
317      just_defaults$hjust
318    vjust <- guide$label.vjust %||% label.theme$vjust %||%
319      just_defaults$vjust
320
321    grob.labels <- lapply(guide$key$.label, function(label, ...) {
322      g <- element_grob(
323        element = label.theme,
324        label = label,
325        hjust = hjust,
326        vjust = vjust,
327        margin_x = TRUE,
328        margin_y = TRUE
329      )
330      ggname("guide.label", g)
331    })
332    if (!guide$show.limits) {
333      grob.labels[c(1, length(grob.labels))] <- list(zeroGrob())
334    }
335  }
336
337  label_widths <- width_cm(grob.labels)
338  label_heights <- height_cm(grob.labels)
339
340  # Keys
341  key_width <- width_cm(
342    guide$keywidth %||% theme$legend.key.width %||% theme$legend.key.size
343  )
344  key_height <- height_cm(
345    guide$keyheight %||% theme$legend.key.height %||% theme$legend.key.size
346  )
347
348  key_size_mat <- do.call("cbind",
349    lapply(guide$geoms, function(g) g$data$size / 10)
350  )
351
352  # key_size_mat can be an empty matrix (e.g. the data doesn't contain size
353  # column), so subset it only when it has any rows and columns.
354  if (nrow(key_size_mat) == 0 || ncol(key_size_mat) == 0) {
355    key_size_mat <- matrix(0, ncol = 1, nrow = n_keys)
356  } else {
357    key_size_mat <- key_size_mat[seq_len(n_keys), , drop = FALSE]
358  }
359  key_sizes <- apply(key_size_mat, 1, max)
360
361  if (guide$direction == "horizontal") {
362    key.nrow <- 1
363    key.ncol <- n_keys
364    label.nrow <- 1
365    label.ncol <- n_keys + 1
366  } else {
367    key.nrow <- n_keys
368    key.ncol <- 1
369    label.nrow <- n_keys + 1
370    label.ncol <- 1
371  }
372
373  key_sizes <- matrix(key_sizes, key.nrow, key.ncol)
374  label_sizes <- matrix(label_widths, label.nrow, label.ncol)
375
376  key_widths <- max(key_width, apply(key_sizes, 2, max))
377  key_heights <- max(key_height, apply(key_sizes, 1, max))
378
379  label_widths <- max(apply(label_sizes, 2, max))
380  label_heights <- max(apply(label_sizes, 1, max))
381
382  key_loc <- data_frame(
383    R = seq(2, by = 2, length.out = n_keys),
384    C = if (label.position %in% c("right", "bottom")) 1 else 3
385  )
386  label_loc <- data_frame(
387    R = seq(1, by = 2, length.out = n_keys + 1),
388    C = if (label.position %in% c("right", "bottom")) 3 else 1
389  )
390  tick_loc <- label_loc
391  tick_loc$C <- if (label.position %in% c("right", "bottom")) 1 else 3
392
393  widths <- c(key_widths, hgap, label_widths)
394  if (label.position != "right") widths <- rev(widths)
395  heights <- c(interleave(rep(0, n_keys), key_heights), 0)
396  if (guide$direction == "horizontal") {
397    names(key_loc) <- c("C", "R")
398    names(label_loc) <- c("C", "R")
399    names(tick_loc) <- c("C", "R")
400    heights <- c(key_heights, vgap, label_heights)
401    if (label.position != "bottom") heights <- rev(heights)
402    widths <- c(interleave(rep(0, n_keys), key_widths), 0)
403  }
404
405  # layout the title over key-label
406  switch(guide$title.position,
407    "top" = {
408      widths <- c(widths, max(0, title_width - sum(widths)))
409      heights <- c(title_height, vgap, heights)
410      key_loc$R <- key_loc$R + 2
411      label_loc$R <- label_loc$R + 2
412      tick_loc$R <- tick_loc$R + 2
413      title_row = 1
414      title_col = seq_along(widths)
415    },
416    "bottom" = {
417      widths <- c(widths, max(0, title_width - sum(widths)))
418      heights <- c(heights, vgap, title_height)
419      title_row = length(heights)
420      title_col = seq_along(widths)
421    },
422    "left" = {
423      widths <- c(title_width, hgap, widths)
424      heights <- c(heights, max(0, title_height - sum(heights)))
425      key_loc$C <- key_loc$C + 2
426      label_loc$C <- label_loc$C + 2
427      tick_loc$C <- tick_loc$C + 2
428      title_row = seq_along(heights)
429      title_col = 1
430    },
431    "right" = {
432      widths <- c(widths, hgap, title_width)
433      heights <- c(heights, max(0, title_height - sum(heights)))
434      title_row = seq_along(heights)
435      title_col = length(widths)
436    }
437  )
438
439  # grob for key
440  key_size <- c(key_width, key_height) * 10
441
442  draw_key <- function(i) {
443    bg <- element_render(theme, "legend.key")
444    keys <- lapply(guide$geoms, function(g) {
445      g$draw_key(g$data[i, ], g$params, key_size)
446    })
447    c(list(bg), keys)
448  }
449  grob.keys <- unlist(lapply(seq_len(n_keys), draw_key), recursive = FALSE)
450
451  # background
452  grob.background <- element_render(theme, "legend.background")
453
454  ngeom <- length(guide$geoms) + 1
455  kcols <- rep(key_loc$C, each = ngeom)
456  krows <- rep(key_loc$R, each = ngeom)
457
458  # padding
459  padding <- convertUnit(theme$legend.margin %||% margin(), "cm", valueOnly = TRUE)
460  widths <- c(padding[4], widths, padding[2])
461  heights <- c(padding[1], heights, padding[3])
462
463  # make the ticks grob (`grob.ticks`)
464  if (!guide$axis) {
465    grob.ticks <- zeroGrob()
466    grob.axis <- zeroGrob()
467  } else {
468    if (guide$direction == "horizontal") {
469      x0 <- 0.5
470      y0 <- 0
471      x1 <- 0.5
472      y1 <- 1/5
473      axis_x <- c(0, 1)
474      axis_y <- c(0, 0)
475      if (label.position == "top") {
476        y0 <- 4/5
477        y1 <- 1
478        axis_y <- c(1, 1)
479      }
480    } else { # guide$direction == "vertical"
481      y0 <- 0.5
482      x0 <- 4/5
483      y1 <- 0.5
484      x1 <- 1
485      axis_x <- c(1, 1)
486      axis_y <- c(0, 1)
487      if (label.position == "left") {
488        x0 <- 0
489        x1 <- 1/5
490        axis_x <- c(0, 0)
491      }
492    }
493    grob.ticks <- segmentsGrob(
494      x0 = x0, y0 = y0, x1 = x1, y1 = y1,
495      default.units = "npc",
496      gp = gpar(
497        col = guide$axis.colour,
498        lwd = guide$axis.linewidth,
499        lineend = "butt"
500      )
501    )
502    grob.axis <- segmentsGrob(
503      x0 = axis_x[1], y0 = axis_y[1], x1 = axis_x[2], y1 = axis_y[2],
504      default.units = "npc",
505      arrow = guide$axis.arrow,
506      gp = gpar(
507        col = guide$axis.colour,
508        lwd = guide$axis.linewidth,
509        lineend = if (is.null(guide$axis.arrow)) "square" else "round"
510      )
511    )
512  }
513  grob.ticks <- rep_len(list(grob.ticks), length(grob.labels))
514  if (!guide$show.limits) {
515    grob.ticks[c(1, length(grob.ticks))] <- list(zeroGrob())
516  }
517  # Create the gtable for the legend
518  gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm"))
519  gt <- gtable_add_grob(
520    gt,
521    grob.background,
522    name = "background",
523    clip = "off",
524    t = 1,
525    r = -1,
526    b = -1,
527    l = 1
528  )
529  gt <- gtable_add_grob(
530    gt,
531    justify_grobs(
532      grob.title,
533      hjust = title.hjust,
534      vjust = title.vjust,
535      int_angle = title.theme$angle,
536      debug = title.theme$debug
537    ),
538    name = "title",
539    clip = "off",
540    t = 1 + min(title_row),
541    r = 1 + max(title_col),
542    b = 1 + max(title_row),
543    l = 1 + min(title_col)
544  )
545  gt <- gtable_add_grob(
546    gt,
547    grob.keys,
548    name = paste("key", krows, kcols, c("bg", seq(ngeom - 1)), sep = "-"),
549    clip = "off",
550    t = 1 + krows,
551    r = 1 + kcols,
552    b = 1 + krows,
553    l = 1 + kcols
554  )
555  gt <- gtable_add_grob(
556    gt,
557    grob.ticks,
558    name = paste("tick", tick_loc$R, tick_loc$C, sep = "-"),
559    clip = "off",
560    t = 1 + tick_loc$R,
561    r = 1 + tick_loc$C,
562    b = 1 + tick_loc$R,
563    l = 1 + tick_loc$C
564  )
565  gt <- gtable_add_grob(
566    gt,
567    grob.axis,
568    name = "axis",
569    clip = "off",
570    t = min(1 + tick_loc$R),
571    r = min(1 + tick_loc$C),
572    b = max(1 + tick_loc$R),
573    l = max(1 + tick_loc$C)
574  )
575  gt <- gtable_add_grob(
576    gt,
577    justify_grobs(
578      grob.labels,
579      hjust = hjust,
580      vjust = vjust,
581      int_angle = label.theme$angle,
582      debug = label.theme$debug
583    ),
584    name = paste("label", label_loc$R, label_loc$C, sep = "-"),
585    clip = "off",
586    t = 1 + label_loc$R,
587    r = 1 + label_loc$C,
588    b = 1 + label_loc$R,
589    l = 1 + label_loc$C
590  )
591  gt
592}
593
594#' Calculate the default hjust and vjust settings depending on legend
595#' direction and position.
596#'
597#' @noRd
598label_just_defaults.bins <- function(direction, position) {
599  if (direction == "horizontal") {
600    switch(
601      position,
602      "top" = list(hjust = 0.5, vjust = 0),
603      "bottom" = list(hjust = 0.5, vjust = 1),
604      "left" = list(hjust = 1, vjust = 0.5),
605      list(hjust = 0.5, vjust = 0.5)
606    )
607  }
608  else {
609    switch(
610      position,
611      "top" = list(hjust = 0.5, vjust = 0),
612      "bottom" = list(hjust = 0.5, vjust = 1),
613      "left" = list(hjust = 1, vjust = 0.5),
614      list(hjust = 0, vjust = 0.5)
615    )
616
617  }
618}
619