Permalink
704 lines (650 sloc) 21 KB
#' Legend guide
#'
#' Legend type guide shows key (i.e., geoms) mapped onto values.
#' Legend guides for various scales are integrated if possible.
#'
#' Guides can be specified in each `scale_*` or in [guides()].
#' `guide="legend"` in `scale_*` is syntactic sugar for
#' `guide=guide_legend()` (e.g. `scale_color_manual(guide = "legend")`).
#' As for how to specify the guide for each scale in more detail,
#' see [guides()].
#'
#' @param title A character string or expression indicating a title of guide.
#' If `NULL`, the title is not shown. By default
#' ([waiver()]), the name of the scale object or the name
#' specified in [labs()] is used for the title.
#' @param title.position A character string indicating the position of a
#' title. One of "top" (default for a vertical guide), "bottom", "left"
#' (default for a horizontal guide), or "right."
#' @param title.theme A theme object for rendering the title text. Usually the
#' object of [element_text()] is expected. By default, the theme is
#' specified by `legend.title` in [theme()] or theme.
#' @param title.hjust A number specifying horizontal justification of the
#' title text.
#' @param title.vjust A number specifying vertical justification of the title
#' text.
#' @param label logical. If `TRUE` then the labels are drawn. If
#' `FALSE` then the labels are invisible.
#' @param label.position A character string indicating the position of a
#' label. One of "top", "bottom" (default for horizontal guide), "left", or
#' "right" (default for vertical guide).
#' @param label.theme A theme object for rendering the label text. Usually the
#' object of [element_text()] is expected. By default, the theme is
#' specified by `legend.text` in [theme()] or theme.
#' @param label.hjust A numeric specifying horizontal justification of the
#' label text.
#' @param label.vjust A numeric specifying vertical justification of the label
#' text.
#' @param keywidth A numeric or a [grid::unit()] object specifying
#' the width of the legend key. Default value is `legend.key.width` or
#' `legend.key.size` in [theme()] or theme.
#' @param keyheight A numeric or a [grid::unit()] object specifying
#' the height of the legend key. Default value is `legend.key.height` or
#' `legend.key.size` in [theme()] or theme.
#' @param direction A character string indicating the direction of the guide.
#' One of "horizontal" or "vertical."
#' @param default.unit A character string indicating [grid::unit()]
#' for `keywidth` and `keyheight`.
#' @param override.aes A list specifying aesthetic parameters of legend key.
#' See details and examples.
#' @param nrow The desired number of rows of legends.
#' @param ncol The desired number of column of legends.
#' @param byrow logical. If `FALSE` (the default) the legend-matrix is
#' filled by columns, otherwise the legend-matrix is filled by rows.
#' @param reverse logical. If `TRUE` the order of legends is reversed.
#' @param order positive integer less that 99 that specifies the order of
#' this guide among multiple guides. This controls the order in which
#' multiple guides are displayed, not the contents of the guide itself.
#' If 0 (default), the order is determined by a secret algorithm.
#' @param ... ignored.
#' @return A guide object
#' @export
#' @family guides
#' @examples
#' \donttest{
#' df <- reshape2::melt(outer(1:4, 1:4), varnames = c("X1", "X2"))
#'
#' p1 <- ggplot(df, aes(X1, X2)) + geom_tile(aes(fill = value))
#' p2 <- p1 + geom_point(aes(size = value))
#'
#' # Basic form
#' p1 + scale_fill_continuous(guide = "legend")
#' p1 + scale_fill_continuous(guide = guide_legend())
#'
#' # Guide title
#' p1 + scale_fill_continuous(guide = guide_legend(title = "V")) # title text
#' p1 + scale_fill_continuous(guide = guide_legend(title = NULL)) # no title
#'
#' # Control styles
#'
#' # key size
#' p1 + guides(fill = guide_legend(keywidth = 3, keyheight = 1))
#'
#' # title position
#' p1 + guides(fill = guide_legend(title = "LEFT", title.position = "left"))
#'
#' # title text styles via element_text
#' p1 + guides(fill =
#' guide_legend(
#' title.theme = element_text(
#' size = 15,
#' face = "italic",
#' colour = "red",
#' angle = 0
#' )
#' )
#' )
#'
#' # label position
#' p1 + guides(fill = guide_legend(label.position = "left", label.hjust = 1))
#'
#' # label styles
#' p1 + scale_fill_continuous(breaks = c(5, 10, 15),
#' labels = paste("long", c(5, 10, 15)),
#' guide = guide_legend(
#' direction = "horizontal",
#' title.position = "top",
#' label.position = "bottom",
#' label.hjust = 0.5,
#' label.vjust = 1,
#' label.theme = element_text(angle = 90)
#' )
#' )
#'
#' # Set aesthetic of legend key
#'
#' # very low alpha value make it difficult to see legend key
#' p3 <- ggplot(diamonds, aes(carat, price)) +
#' geom_point(aes(colour = color), alpha = 1/100)
#' p3
#'
#' # override.aes overwrites the alpha
#' p3 + guides(colour = guide_legend(override.aes = list(alpha = 1)))
#'
#' # multiple row/col legends
#' df <- data.frame(x = 1:20, y = 1:20, color = letters[1:20])
#' p <- ggplot(df, aes(x, y)) +
#' geom_point(aes(colour = color))
#' p + guides(col = guide_legend(nrow = 8))
#' p + guides(col = guide_legend(ncol = 8))
#' p + guides(col = guide_legend(nrow = 8, byrow = TRUE))
#' p + guides(col = guide_legend(ncol = 8, byrow = TRUE))
#'
#' # reversed order legend
#' p + guides(col = guide_legend(reverse = TRUE))
#'
#' # hide some aesthetics from the legend
#' p4 <- ggplot(mtcars, aes(mpg, qsec, colour = factor(vs), shape = factor(am))) +
#' geom_point()
#' p4 + geom_line()
#' p4 + geom_line(show.legend = c(color = FALSE))
#'
#' }
guide_legend <- function(# title
title = waiver(),
title.position = NULL,
title.theme = NULL,
title.hjust = NULL,
title.vjust = NULL,
# label
label = TRUE,
label.position = NULL,
label.theme = NULL,
label.hjust = NULL,
label.vjust = NULL,
# key
keywidth = NULL,
keyheight = NULL,
# general
direction = NULL,
default.unit = "line",
override.aes = list(),
nrow = NULL,
ncol = NULL,
byrow = FALSE,
reverse = FALSE,
order = 0,
...) {
if (!is.null(keywidth) && !is.unit(keywidth)) {
keywidth <- unit(keywidth, default.unit)
}
if (!is.null(keyheight) && !is.unit(keyheight)) {
keyheight <- unit(keyheight, default.unit)
}
structure(
list(
# title
title = title,
title.position = title.position,
title.theme = title.theme,
title.hjust = title.hjust,
title.vjust = title.vjust,
# label
label = label,
label.position = label.position,
label.theme = label.theme,
label.hjust = label.hjust,
label.vjust = label.vjust,
# size of key
keywidth = keywidth,
keyheight = keyheight,
# general
direction = direction,
override.aes = rename_aes(override.aes),
nrow = nrow,
ncol = ncol,
byrow = byrow,
reverse = reverse,
order = order,
# parameter
available_aes = c("any"),
...,
name = "legend"
),
class = c("guide", "legend")
)
}
#' @export
guide_train.legend <- function(guide, scale) {
breaks <- scale$get_breaks()
if (length(breaks) == 0 || all(is.na(breaks))) {
return()
}
key <- as.data.frame(
setNames(list(scale$map(breaks)), scale$aesthetics[1]),
stringsAsFactors = FALSE
)
key$.label <- scale$get_labels(breaks)
# Drop out-of-range values for continuous scale
# (should use scale$oob?)
if (!scale$is_discrete()) {
limits <- scale$get_limits()
noob <- !is.na(breaks) & limits[1] <= breaks & breaks <= limits[2]
key <- key[noob, , drop = FALSE]
}
if (guide$reverse) key <- key[nrow(key):1, ]
guide$key <- key
guide$hash <- with(
guide,
digest::digest(list(title, key$.label, direction, name))
)
guide
}
#' @export
guide_merge.legend <- function(guide, new_guide) {
guide$key <- merge(guide$key, new_guide$key, sort = FALSE)
guide$override.aes <- c(guide$override.aes, new_guide$override.aes)
if (any(duplicated(names(guide$override.aes)))) {
warning("Duplicated override.aes is ignored.")
}
guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))]
guide
}
#' @export
guide_geom.legend <- function(guide, layers, default_mapping) {
# arrange common data for vertical and horizontal guide
guide$geoms <- plyr::llply(layers, function(layer) {
matched <- matched_aes(layer, guide, default_mapping)
if (length(matched) > 0) {
# This layer contributes to the legend
# check if this layer should be included, different behaviour depending on
# if show.legend is a logical or a named logical vector
if (!is.null(names(layer$show.legend))) {
layer$show.legend <- rename_aes(layer$show.legend)
include <- is.na(layer$show.legend[matched]) ||
layer$show.legend[matched]
} else {
include <- is.na(layer$show.legend) || layer$show.legend
}
if (include) {
# Default is to include it
# Filter out set aesthetics that can't be applied to the legend
n <- vapply(layer$aes_params, length, integer(1))
params <- layer$aes_params[n == 1]
data <- layer$geom$use_defaults(guide$key[matched], params)
} else {
return(NULL)
}
} else {
# This layer does not contribute to the legend
if (is.na(layer$show.legend) || !layer$show.legend) {
# Default is to exclude it
return(NULL)
} else {
data <- layer$geom$use_defaults(NULL, layer$aes_params)[rep(1, nrow(guide$key)), ]
}
}
# override.aes in guide_legend manually changes the geom
data <- utils::modifyList(data, guide$override.aes)
list(
draw_key = layer$geom$draw_key,
data = data,
params = c(layer$geom_params, layer$stat_params)
)
})
# remove null geom
guide$geoms <- compact(guide$geoms)
# Finally, remove this guide if no layer is drawn
if (length(guide$geoms) == 0) guide <- NULL
guide
}
#' @export
guide_gengrob.legend <- function(guide, theme) {
# default setting
label.position <- guide$label.position %||% "right"
if (!label.position %in% c("top", "bottom", "left", "right"))
stop("label position \"", label.position, "\" is invalid")
nbreak <- nrow(guide$key)
grob.title <- ggname("guide.title",
element_grob(
guide$title.theme %||% calc_element("legend.title", theme),
label = guide$title,
hjust = guide$title.hjust %||% theme$legend.title.align %||% 0,
vjust = guide$title.vjust %||% 0.5,
margin_x = FALSE,
margin_y = FALSE
)
)
title_width <- width_cm(grob.title)
title_height <- height_cm(grob.title)
# gap between keys etc
hgap <- width_cm(theme$legend.spacing.x %||% unit(0.3, "line"))
vgap <- height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_height, "cm")))
# Labels
if (!guide$label || is.null(guide$key$.label)) {
grob.labels <- rep(list(zeroGrob()), nrow(guide$key))
} else {
label.theme <- guide$label.theme %||% calc_element("legend.text", theme)
# label.theme in param of guide_legend() > theme$legend.text.align > default
# hjust/vjust in theme$legend.text and label.theme are ignored.
hjust <- x <- guide$label.hjust %||% theme$legend.text.align %||%
if (any(is.expression(guide$key$.label))) 1 else 0
vjust <- y <- guide$label.vjust %||% 0.5
grob.labels <- lapply(guide$key$.label, function(label, ...) {
g <- element_grob(
element = label.theme,
label = label,
x = x,
y = y,
hjust = hjust,
vjust = vjust,
margin_x = FALSE,
margin_y = FALSE
)
ggname("guide.label", g)
})
}
label_widths <- width_cm(grob.labels)
label_heights <- height_cm(grob.labels)
# Keys
key_width <- width_cm(
guide$keywidth %||% theme$legend.key.width %||% theme$legend.key.size
)
key_height <- height_cm(
guide$keyheight %||% theme$legend.key.height %||% theme$legend.key.size
)
key_size_mat <- do.call("cbind", lapply(guide$geoms, function(g) g$data$size / 10))
if (nrow(key_size_mat) == 0 || ncol(key_size_mat) == 0) {
key_size_mat <- matrix(0, ncol = 1, nrow = nbreak)
}
key_sizes <- apply(key_size_mat, 1, max)
if (!is.null(guide$nrow) && !is.null(guide$ncol) &&
guide$nrow * guide$ncol < nbreak) {
stop(
"`nrow` * `ncol` needs to be larger than the number of breaks",
call. = FALSE
)
}
# If neither nrow/ncol specified, guess with "reasonable" values
if (is.null(guide$nrow) && is.null(guide$ncol)) {
if (guide$direction == "horizontal") {
guide$nrow <- ceiling(nbreak / 5)
} else {
guide$ncol <- ceiling(nbreak / 20)
}
}
legend.nrow <- guide$nrow %||% ceiling(nbreak / guide$ncol)
legend.ncol <- guide$ncol %||% ceiling(nbreak / guide$nrow)
key_sizes <- matrix(
c(key_sizes, rep(0, legend.nrow * legend.ncol - nbreak)),
legend.nrow,
legend.ncol,
byrow = guide$byrow
)
key_widths <- pmax(key_width, apply(key_sizes, 2, max))
key_heights <- pmax(key_height, apply(key_sizes, 1, max))
label_widths <- apply(
matrix(
c(label_widths, rep(0, legend.nrow * legend.ncol - nbreak)),
legend.nrow,
legend.ncol,
byrow = guide$byrow
),
2,
max
)
label_heights <- apply(
matrix(
c(label_heights, rep(0, legend.nrow * legend.ncol - nbreak)),
legend.nrow,
legend.ncol,
byrow = guide$byrow
),
1,
max
)
if (guide$byrow) {
vps <- data.frame(
R = ceiling(seq(nbreak) / legend.ncol),
C = (seq(nbreak) - 1) %% legend.ncol + 1
)
} else {
vps <- as.data.frame(arrayInd(seq(nbreak), dim(key_sizes)))
names(vps) <- c("R", "C")
}
# layout of key-label depends on the direction of the guide
if (guide$byrow == TRUE) {
switch(
label.position,
"top" = {
kl_widths <- pmax(label_widths, key_widths)
kl_heights <- utils::head(
interleave(label_heights, vgap / 2, key_heights, vgap / 2),
-1
)
vps <- transform(
vps,
key.row = R * 4 - 1,
key.col = C,
label.row = R * 4 - 3,
label.col = C
)
},
"bottom" = {
kl_widths <- pmax(label_widths, key_widths)
kl_heights <- utils::head(
interleave(key_heights, vgap / 2, label_heights, vgap / 2),
-1
)
vps <- transform(
vps,
key.row = R * 4 - 3,
key.col = C,
label.row = R * 4 - 1,
label.col = C
)
},
"left" = {
kl_widths <- utils::head(
interleave(label_widths, hgap / 2, key_widths, hgap / 2),
-1
)
kl_heights <- utils::head(
interleave(pmax(label_heights, key_heights), vgap / 2),
-1
)
vps <- transform(
vps,
key.row = R * 2 - 1,
key.col = C * 4 - 1,
label.row = R * 2 - 1,
label.col = C * 4 - 3
)
},
"right" = {
kl_widths <- utils::head(
interleave(key_widths, hgap / 2, label_widths, hgap / 2),
-1
)
kl_heights <- utils::head(
interleave(pmax(label_heights, key_heights), vgap / 2),
-1
)
vps <- transform(
vps,
key.row = R * 2 - 1,
key.col = C * 4 - 3,
label.row = R * 2 - 1,
label.col = C * 4 - 1
)
})
} else {
switch(
label.position,
"top" = {
kl_widths <- utils::head(
interleave(pmax(label_widths, key_widths), hgap/2),
-1
)
kl_heights <- utils::head(
interleave(label_heights, vgap / 2, key_heights, vgap / 2),
-1
)
vps <- transform(
vps,
key.row = R * 4 - 1,
key.col = C * 2 - 1,
label.row = R * 4 - 3,
label.col = C * 2 - 1
)
},
"bottom" = {
kl_widths <- utils::head(
interleave(pmax(label_widths, key_widths), hgap / 2),
-1
)
kl_heights <- utils::head(
interleave(key_heights, vgap / 2, label_heights, vgap / 2),
-1
)
vps <- transform(
vps,
key.row = R * 4 - 3,
key.col = C * 2 - 1,
label.row = R * 4 - 1,
label.col = C * 2 - 1
)
},
"left" = {
kl_widths <- utils::head(
interleave(label_widths, hgap / 2, key_widths, hgap / 2),
-1
)
kl_heights <- pmax(key_heights, label_heights)
vps <- transform(
vps,
key.row = R,
key.col = C * 4 - 1,
label.row = R,
label.col = C * 4 - 3
)
},
"right" = {
kl_widths <- utils::head(
interleave(key_widths, hgap / 2, label_widths, hgap / 2),
-1
)
kl_heights <- pmax(key_heights, label_heights)
vps <- transform(
vps,
key.row = R,
key.col = C * 4 - 3,
label.row = R,
label.col = C * 4 - 1
)
})
}
# layout the title over key-label
switch(guide$title.position,
"top" = {
widths <- c(kl_widths, max(0, title_width - sum(kl_widths)))
heights <- c(title_height, vgap, kl_heights)
vps <- transform(
vps,
key.row = key.row + 2,
key.col = key.col,
label.row = label.row + 2,
label.col = label.col
)
vps.title.row = 1; vps.title.col = 1:length(widths)
},
"bottom" = {
widths <- c(kl_widths, max(0, title_width - sum(kl_widths)))
heights <- c(kl_heights, vgap, title_height)
vps <- transform(
vps,
key.row = key.row,
key.col = key.col,
label.row = label.row,
label.col = label.col
)
vps.title.row = length(heights); vps.title.col = 1:length(widths)
},
"left" = {
widths <- c(title_width, hgap, kl_widths)
heights <- c(kl_heights, max(0, title_height - sum(kl_heights)))
vps <- transform(
vps,
key.row = key.row,
key.col = key.col + 2,
label.row = label.row,
label.col = label.col + 2
)
vps.title.row = 1:length(heights); vps.title.col = 1
},
"right" = {
widths <- c(kl_widths, hgap, title_width)
heights <- c(kl_heights, max(0, title_height - sum(kl_heights)))
vps <- transform(
vps,
key.row = key.row,
key.col = key.col,
label.row = label.row,
label.col = label.col
)
vps.title.row = 1:length(heights); vps.title.col = length(widths)
})
# grob for key
key_size <- c(key_width, key_height) * 10
draw_key <- function(i) {
bg <- element_render(theme, "legend.key")
keys <- lapply(guide$geoms, function(g) {
g$draw_key(g$data[i, ], g$params, key_size)
})
c(list(bg), keys)
}
grob.keys <- unlist(lapply(seq_len(nbreak), draw_key), recursive = FALSE)
# background
grob.background <- element_render(theme, "legend.background")
ngeom <- length(guide$geoms) + 1
kcols <- rep(vps$key.col, each = ngeom)
krows <- rep(vps$key.row, each = ngeom)
# padding
padding <- convertUnit(theme$legend.margin %||% margin(), "cm")
widths <- c(padding[4], widths, padding[2])
heights <- c(padding[1], heights, padding[3])
# Create the gtable for the legend
gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm"))
gt <- gtable_add_grob(
gt,
grob.background,
name = "background",
clip = "off",
t = 1,
r = -1,
b = -1,
l = 1
)
gt <- gtable_add_grob(
gt,
grob.title,
name = "title",
clip = "off",
t = 1 + min(vps.title.row),
r = 1 + max(vps.title.col),
b = 1 + max(vps.title.row),
l = 1 + min(vps.title.col)
)
gt <- gtable_add_grob(
gt,
grob.keys,
name = paste("key", krows, kcols, c("bg", seq(ngeom - 1)), sep = "-"),
clip = "off",
t = 1 + krows,
r = 1 + kcols,
b = 1 + krows,
l = 1 + kcols
)
gt <- gtable_add_grob(
gt,
grob.labels,
name = paste("label", vps$label.row, vps$label.col, sep = "-"),
clip = "off",
t = 1 + vps$label.row,
r = 1 + vps$label.col,
b = 1 + vps$label.row,
l = 1 + vps$label.col
)
gt
}
globalVariables(c("C", "R", "key.row", "key.col", "label.row", "label.col"))