Skip to content

Commit

Permalink
Arbitrary positions for guides (#5488)
Browse files Browse the repository at this point in the history 
* Add legends in all positions

* Assemble separate guide boxes

* Add position argument to guides

* reoxygenate

* adapt tests

* deal with old R units

* rename manual position to "inside"

* resolve spacing once

* omit 'inside' option in justification

* Move more responsibility to `Guides$draw()`

* Propagate "manual" -> "inside" rename

* Fallback for inside position

* Rearrange methods into logical order

* remove vestigial stuff

* Separate numeric inside positioning from `legend.position` argument

* Implement plot-wise justification (#4020)

* Partially revert bd917cf

* Add extra justification theme settings

* Document `legend.justification.{position}`

* Apply justification

* Prevent FP warnings by partial matching

* Switch to new inside position

* Add test for justification per position

* Fix subsetting bug

* always add gtable rows/cols

* adjust table dimension expectations

* adapt test

* Don't calculate key sizes twice

* Use `calc_element()`

* Use conventional indexing

* prevent partial matching

* Move justification responsiblity to `Guides$package_box()`

* Fix bug

* incorporate guide_custom

* incorporate guide_custom
  • Loading branch information
@teunbrand
teunbrand authored Dec 8, 2023
1 parent 70a4c0e commit dad8a4b
Show file tree
Hide file tree
Showing 18 changed files with 554 additions and 166 deletions.
5 changes: 5 additions & 0 deletions R/guide-bins.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,7 @@ guide_bins <- function(
ticks.length = unit(0.2, "npc"),

# general
position = NULL,
direction = NULL,
default.unit = "line",
override.aes = list(),
Expand All @@ -121,6 +122,9 @@ guide_bins <- function(
if (!is.null(title.position)) {
title.position <- arg_match0(title.position, .trbl)
}
if (!is.null(position)) {
position <- arg_match0(position, c(.trbl, "inside"))
}
if (!is.null(direction)) {
direction <- arg_match0(direction, c("horizontal", "vertical"))
}
Expand Down Expand Up @@ -169,6 +173,7 @@ guide_bins <- function(
ticks_length = ticks.length,

# general
position = position,
direction = direction,
override.aes = rename_aes(override.aes),
reverse = reverse,
Expand Down
5 changes: 5 additions & 0 deletions R/guide-colorbar.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -151,6 +151,7 @@ guide_colourbar <- function(
draw.llim = TRUE,

# general
position = NULL,
direction = NULL,
default.unit = "line",
reverse = FALSE,
Expand All @@ -171,6 +172,9 @@ guide_colourbar <- function(
if (!is.null(title.position)) {
title.position <- arg_match0(title.position, .trbl)
}
if (!is.null(position)) {
position <- arg_match0(position, c(.trbl, "inside"))
}
if (!is.null(direction)) {
direction <- arg_match0(direction, c("horizontal", "vertical"))
}
Expand Down Expand Up @@ -240,6 +244,7 @@ guide_colourbar <- function(
draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)),

# general
position = position,
direction = direction,
reverse = reverse,
order = order,
Expand Down
2 changes: 1 addition & 1 deletion R/guide-custom.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,7 +43,7 @@
guide_custom <- function(
grob, width = grobWidth(grob), height = grobHeight(grob),
title = NULL, title.position = "top", margin = NULL,
position = waiver(), order = 0
position = NULL, order = 0
) {
check_object(grob, is.grob, "a {.cls grob} object")
check_object(width, is.unit, "a {.cls unit} object")
Expand Down
7 changes: 7 additions & 0 deletions R/guide-legend.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,8 @@
#' object specifying the distance between key-label pairs in the horizontal
#' direction (`key.spacing.x`), vertical direction (`key.spacing.y`) or both
#' (`key.spacing`).
#' @param position A character string indicating where the legend should be
#' placed relative to the plot panels.
#' @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()]
Expand Down Expand Up @@ -152,6 +154,7 @@ guide_legend <- function(
key.spacing.y = NULL,

# General
position = NULL,
direction = NULL,
default.unit = "line",
override.aes = list(),
Expand Down Expand Up @@ -187,6 +190,9 @@ guide_legend <- function(
if (!is.null(label.position)) {
label.position <- arg_match0(label.position, .trbl)
}
if (!is.null(position)) {
position <- arg_match0(position, c(.trbl, "inside"))
}

new_guide(
# Title
Expand Down Expand Up @@ -217,6 +223,7 @@ guide_legend <- function(
byrow = byrow,
reverse = reverse,
order = order,
position = position,

# Fixed parameters
available_aes = "any",
Expand Down
208 changes: 152 additions & 56 deletions R/guides-.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -262,8 +262,8 @@ Guides <- ggproto(

## Building ------------------------------------------------------------------

# The `Guides$build()` method is called in ggplotGrob (plot-build.R) and makes
# the guide box for *non-position* scales.
# The `Guides$build()` method is called in ggplot_build (plot-build.R) and
# collects all information needed from the plot.
# Note that position scales are handled in `Coord`s, which have their own
# procedures to do equivalent steps.
#
Expand All @@ -283,12 +283,7 @@ Guides <- ggproto(
# 3. Guides$process_layers()
# process layer information and generate geom info.
#
# 4. Guides$draw()
# generate guide grob from each guide object
# one guide grob for one guide object
#
# 5. Guides$assemble()
# arrange all guide grobs
# The resulting guide is then drawn in ggplot_gtable

build = function(self, scales, layers, labels, layer_data) {

Expand Down Expand Up @@ -476,104 +471,201 @@ Guides <- ggproto(
invisible()
},

# Loop over every guide, let them draw their grobs
draw = function(self, theme, position, direction) {
Map(
function(guide, params) guide$draw(theme, position, direction, params),
guide = self$guides,
params = self$params
)
},

# The `Guides$assemble()` method is called in ggplot_gtable (plot-build.R) and
# applies the styling from the theme to render each guide and package them
# into guide boxes.
#
# The procedure is as follows
#
# 1. Guides$draw()
# for every guide object, draw one grob,
# then group the grobs in a list per position
#
# 2. Guides$package_box()
# for every position, collect all individual guides and arrange them
# into a guide box which will be inserted into the main gtable
# Combining multiple guides in a guide box
assemble = function(self, theme, position) {
assemble = function(self, theme) {

if (length(self$guides) < 1) {
return(zeroGrob())
}

position <- legend_position(position)
if (position == "none") {
default_position <- theme$legend.position %||% "right"
if (length(default_position) == 2) {
default_position <- "inside"
}
if (default_position == "none") {
return(zeroGrob())
}
default_direction <- if (position == "inside") "vertical" else position

theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size
theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size
theme$legend.box <- theme$legend.box %||% default_direction
theme$legend.direction <- theme$legend.direction %||% default_direction
theme$legend.box.just <- theme$legend.box.just %||% switch(
position,
inside = c("center", "center"),
vertical = c("left", "top"),
horizontal = c("center", "top")
)
# Populate key sizes
theme$legend.key.width <- calc_element("legend.key.width", theme)
theme$legend.key.height <- calc_element("legend.key.height", theme)

grobs <- self$draw(theme, position, theme$legend.direction)
grobs <- self$draw(theme, default_position, theme$legend.direction)
if (length(grobs) < 1) {
return(zeroGrob())
}
grobs <- grobs[order(names(grobs))]

# Set spacing
theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines")
theme$legend.spacing.y <- theme$legend.spacing.y %||% theme$legend.spacing
theme$legend.spacing.x <- theme$legend.spacing.x %||% theme$legend.spacing
theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines")
theme$legend.spacing.y <- calc_element("legend.spacing.y", theme)
theme$legend.spacing.x <- calc_element("legend.spacing.x", theme)

Map(
grobs = grobs,
position = names(grobs),
self$package_box,
MoreArgs = list(theme = theme)
)
},

# Render the guides into grobs
draw = function(self, theme,
default_position = "right",
direction = NULL,
params = self$params,
guides = self$guides) {
positions <- vapply(
params,
function(p) p$position[1] %||% default_position,
character(1)
)
positions <- factor(positions, levels = c(.trbl, "inside"))

directions <- rep(direction %||% "vertical", length(positions))
if (is.null(direction)) {
directions[positions %in% c("top", "bottom")] <- "horizontal"
}

grobs <- vector("list", length(guides))
for (i in seq_along(grobs)) {
grobs[[i]] <- guides[[i]]$draw(
theme = theme, position = as.character(positions[i]),
direction = directions[i], params = params[[i]]
)
}
split(grobs, positions)
},

package_box = function(grobs, position, theme) {

if (is.zero(grobs) || length(grobs) == 0) {
return(zeroGrob())
}

# Determine default direction
direction <- switch(
position,
inside = , left = , right = "vertical",
top = , bottom = "horizontal"
)

# Populate missing theme arguments
theme$legend.box <- theme$legend.box %||% direction
theme$legend.box.just <- theme$legend.box.just %||% switch(
direction,
vertical = c("left", "top"),
horizontal = c("center", "top")
)

# Measure guides
widths <- lapply(grobs, function(g) sum(g$widths))
widths <- inject(unit.c(!!!widths))
heights <- lapply(grobs, function(g) sum(g$heights))
heights <- inject(unit.c(!!!heights))

# Global justification of the complete legend box
global_just <- paste0("legend.justification.", position)
global_just <- valid.just(calc_element(global_just, theme))

if (position == "inside") {
# The position of inside legends are set by their justification
inside_position <- theme$legend.position.inside %||% global_just
global_xjust <- inside_position[1]
global_yjust <- inside_position[2]
global_margin <- margin()
} else {
global_xjust <- global_just[1]
global_yjust <- global_just[2]
# Legends to the side of the plot need a margin for justification
# relative to the plot panel
global_margin <- margin(
t = 1 - global_yjust, b = global_yjust,
r = 1 - global_xjust, l = global_xjust,
unit = "null"
)
}

# Set the justification of each legend within the legend box
# First value is xjust, second value is yjust
just <- valid.just(theme$legend.box.just)
xjust <- just[1]
yjust <- just[2]
box_just <- valid.just(theme$legend.box.just)
box_xjust <- box_just[1]
box_yjust <- box_just[2]

# setting that is different for vertical and horizontal guide-boxes.
if (identical(theme$legend.box, "horizontal")) {
# Set justification for each legend
# Set justification for each legend within the box
for (i in seq_along(grobs)) {
grobs[[i]] <- editGrob(
grobs[[i]],
vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust),
vp = viewport(x = box_xjust, y = box_yjust, just = box_just,
height = heightDetails(grobs[[i]]))
)
}
spacing <- theme$legend.spacing.x

# Set global justification
vp <- viewport(
x = global_xjust, y = global_yjust, just = global_just,
height = max(heights),
width = sum(widths, spacing * (length(grobs) - 1L))
)

guides <- gtable_row(name = "guides",
grobs = grobs,
widths = widths, height = max(heights))
# Initialise gtable as legends in a row
guides <- gtable_row(
name = "guides", grobs = grobs,
widths = widths, height = max(heights),
vp = vp
)

# add space between the guide-boxes
guides <- gtable_add_col_space(guides, theme$legend.spacing.x)
# Add space between the guide-boxes
guides <- gtable_add_col_space(guides, spacing)

} else { # theme$legend.box == "vertical"
# Set justification for each legend
# Set justification for each legend within the box
for (i in seq_along(grobs)) {
grobs[[i]] <- editGrob(
grobs[[i]],
vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust),
vp = viewport(x = box_xjust, y = box_yjust, just = box_just,
width = widthDetails(grobs[[i]]))
)
}
spacing <- theme$legend.spacing.y

# Set global justification
vp <- viewport(
x = global_xjust, y = global_yjust, just = global_just,
height = sum(heights, spacing * (length(grobs) - 1L)),
width = max(widths)
)

guides <- gtable_col(name = "guides",
grobs = grobs,
width = max(widths), heights = heights)
# Initialise gtable as legends in a column
guides <- gtable_col(
name = "guides", grobs = grobs,
width = max(widths), heights = heights,
vp = vp
)

# add space between the guide-boxes
guides <- gtable_add_row_space(guides, theme$legend.spacing.y)
# Add space between the guide-boxes
guides <- gtable_add_row_space(guides, spacing)
}

# Add margins around the guide-boxes.
margin <- theme$legend.box.margin %||% margin()
guides <- gtable_add_cols(guides, margin[4], pos = 0)
guides <- gtable_add_cols(guides, margin[2], pos = ncol(guides))
guides <- gtable_add_rows(guides, margin[1], pos = 0)
guides <- gtable_add_rows(guides, margin[3], pos = nrow(guides))
guides <- gtable_add_padding(guides, margin)

# Add legend box background
background <- element_grob(theme$legend.box.background %||% element_blank())
Expand All @@ -584,6 +676,10 @@ Guides <- ggproto(
z = -Inf, clip = "off",
name = "legend.box.background"
)

# Set global margin
guides <- gtable_add_padding(guides, global_margin)

guides$name <- "guide-box"
guides
},
Expand Down
Loading

0 comments on commit dad8a4b

Please sign in to comment.