Skip to content

Reorganise plot rendering #6665

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 5 commits into
base: main
Choose a base branch
from
Open

Reorganise plot rendering #6665

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
b69b372
revert d35f103
teunbrand Sep 30, 2025
81070f8
break up `ggplot_gtable()` method into smaller functions
teunbrand Sep 30, 2025
f5c40d0
move `by_layer`
teunbrand Sep 30, 2025
f6f921a
scales have already been extracted from plot object
teunbrand Sep 30, 2025
9817545
redocument
teunbrand Sep 30, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -213,6 +213,7 @@ Collate:
'plot-build.R'
'plot-construction.R'
'plot-last.R'
'plot-render.R'
'plot.R'
'position-.R'
'position-collide.R'
Expand Down
348 changes: 1 addition & 347 deletions R/plot-build.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -83,7 +83,7 @@ build_ggplot <- S7::method(ggplot_build, class_ggplot) <- function(plot, ...) {
data <- by_layer(function(l, d) l$map_statistic(d, plot), layers, data, "mapping stat to aesthetics")

# Make sure missing (but required) aesthetics are added
plot@scales$add_missing(c("x", "y"), plot@plot_env)
scales$add_missing(c("x", "y"), plot@plot_env)

# Reparameterise geoms from (e.g.) y and width to ymin and ymax
data <- by_layer(function(l, d) l$compute_geom_1(d), layers, data, "setting up geom")
Expand Down Expand Up @@ -178,146 +178,6 @@ get_layer_grob <- function(plot = get_last_plot(), i = 1L) {
#' @rdname ggplot_build
layer_grob <- get_layer_grob

#' Build a plot with all the usual bits and pieces.
#'
#' This function builds all grobs necessary for displaying the plot, and
#' stores them in a special data structure called a [`gtable`][gtable::gtable].
#' This object is amenable to programmatic manipulation, should you want
#' to (e.g.) make the legend box 2 cm wide, or combine multiple plots into
#' a single display, preserving aspect ratios across the plots.
#'
#' The `ggplot_gtable()` function is vestigial and the `gtable_ggplot()` function
#' should be used instead.
#'
#' @seealso
#' [print.ggplot()] and [benchplot()] for
#' for functions that contain the complete set of steps for generating
#' a ggplot2 plot.
#'
#' The `r link_book("gtable step section", "internals#sec-ggplotgtable")`
#' @return a `gtable` object
#' @keywords internal
#' @param data plot data generated by [ggplot_build()]
#' @export
ggplot_gtable <- function(data) {
# TODO: Swap to S7 generic once S7/#543 is resolved
attach_plot_env(data@plot@plot_env)
UseMethod("ggplot_gtable")
}

S7::method(ggplot_gtable, class_ggplot_built) <- function(data) {
plot <- data@plot
layout <- data@layout
data <- data@data
theme <- plot@theme

geom_grobs <- by_layer(function(l, d) l$draw_geom(d, layout), plot@layers, data, "converting geom to grob")

plot_table <- layout$render(geom_grobs, data, theme, plot@labels)

# Legends
legend_box <- plot@guides$assemble(theme)
plot_table <- table_add_legends(plot_table, legend_box, theme)

# Title
title <- element_render(
theme, "plot.title", plot@labels$title,
margin_y = TRUE, margin_x = TRUE
)
title_height <- grobHeight(title)

# Subtitle
subtitle <- element_render(
theme, "plot.subtitle", plot@labels$subtitle,
margin_y = TRUE, margin_x = TRUE
)
subtitle_height <- grobHeight(subtitle)

# whole plot annotation
caption <- element_render(
theme, "plot.caption", plot@labels$caption,
margin_y = TRUE, margin_x = TRUE
)
caption_height <- grobHeight(caption)

# positioning of title and subtitle is governed by plot.title.position
# positioning of caption is governed by plot.caption.position
# "panel" means align to the panel(s)
# "plot" means align to the entire plot (except margins and tag)
title_pos <- arg_match0(
theme$plot.title.position %||% "panel",
c("panel", "plot"),
arg_nm = "plot.title.position",
error_call = expr(theme())
)

caption_pos <- arg_match0(
theme$plot.caption.position %||% "panel",
values = c("panel", "plot"),
arg_nm = "plot.caption.position",
error_call = expr(theme())
)

pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), , drop = FALSE]
if (title_pos == "panel") {
title_l <- min(pans$l)
title_r <- max(pans$r)
} else {
title_l <- 1
title_r <- ncol(plot_table)
}
if (caption_pos == "panel") {
caption_l <- min(pans$l)
caption_r <- max(pans$r)
} else {
caption_l <- 1
caption_r <- ncol(plot_table)
}

plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0)
plot_table <- gtable_add_grob(plot_table, subtitle, name = "subtitle",
t = 1, b = 1, l = title_l, r = title_r, clip = "off")

plot_table <- gtable_add_rows(plot_table, title_height, pos = 0)
plot_table <- gtable_add_grob(plot_table, title, name = "title",
t = 1, b = 1, l = title_l, r = title_r, clip = "off")

plot_table <- gtable_add_rows(plot_table, caption_height, pos = -1)
plot_table <- gtable_add_grob(plot_table, caption, name = "caption",
t = -1, b = -1, l = caption_l, r = caption_r, clip = "off")

plot_table <- table_add_tag(plot_table, plot@labels$tag, theme)

# Margins
plot_margin <- calc_element("plot.margin", theme) %||% margin()
plot_table <- gtable_add_padding(plot_table, plot_margin)

if (is_theme_element(theme$plot.background)) {
plot_table <- gtable_add_grob(plot_table,
element_render(theme, "plot.background"),
t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf)
plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),]
plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))]
}

# add alt-text as attribute
attr(plot_table, "alt-label") <- plot@labels$alt

plot_table
}

#' Generate a ggplot2 plot grob.
#'
#' @param x ggplot2 object
#' @keywords internal
#' @export
ggplotGrob <- function(x) {
ggplot_gtable(ggplot_build(x))
}

S7::method(as.gtable, class_ggplot) <- function(x, ...) ggplotGrob(x)
S7::method(as.gtable, class_ggplot_built) <- function(x, ...) ggplot_gtable(x)

# Apply function to layer and matching data
by_layer <- function(f, layers, data, step = NULL) {
ordinal <- label_ordinal()
Expand All @@ -337,209 +197,3 @@ by_layer <- function(f, layers, data, step = NULL) {
)
out
}

# Add the tag element to the gtable
table_add_tag <- function(table, label, theme) {
# Initialise the tag margins
table <- gtable_add_padding(table, unit(0, "pt"))

# Early exit when label is absent or element is blank
if (length(label) < 1) {
return(table)
}
element <- calc_element("plot.tag", theme)
if (is_theme_element(element, "blank")) {
return(table)
}

# Resolve position
position <- calc_element("plot.tag.position", theme) %||% "topleft"
location <- calc_element("plot.tag.location", theme) %||%
(if (is.numeric(position)) "plot" else "margin")

if (is.numeric(position)) {
if (location == "margin") {
cli::cli_abort(paste0(
"A {.cls numeric} {.arg plot.tag.position} cannot be used with ",
"`{.val margin}` as {.arg plot.tag.location}."
),
call = expr(theme()))
}
check_length(
position, 2L, call = expr(theme()),
arg = I("A {.cls numeric} {.arg plot.tag.position}")
)
top <- left <- right <- bottom <- FALSE
} else {
# Break position into top/left/right/bottom
position <- arg_match0(
position[1],
c("topleft", "top", "topright", "left",
"right", "bottomleft", "bottom", "bottomright"),
arg_nm = "plot.tag.position",
error_call = expr(theme())
)
top <- position %in% c("topleft", "top", "topright")
left <- position %in% c("topleft", "left", "bottomleft")
right <- position %in% c("topright", "right", "bottomright")
bottom <- position %in% c("bottomleft", "bottom", "bottomright")
}

# Resolve tag and sizes
tag <- element_grob(element, label = label, margin_y = TRUE, margin_x = TRUE)
height <- grobHeight(tag)
width <- grobWidth(tag)

if (location %in% c("plot", "panel")) {
if (!is.numeric(position)) {
hjust <- try_prop(element, "hjust", default = 0.5)
if (right || left) {
x <- (1 - hjust) * width
if (right) {
x <- unit(1, "npc") - x
}
} else {
x <- unit(hjust, "npc")
}
if (top || bottom) {
vjust <- try_prop(element, "vjust", default = 0.5)
y <- (1 - vjust) * height
if (top) {
y <- unit(1, "npc") - y
}
} else {
y <- unit(vjust, "npc")
}
} else {
x <- unit(position[1], "npc")
y <- unit(position[2], "npc")
}
# Re-render with manual positions
tag <- element_grob(
element, x = x, y = y, label = label,
margin_y = TRUE, margin_x = TRUE
)
if (location == "plot") {
table <- gtable_add_grob(
table, tag, name = "tag", clip = "off",
t = 1, b = nrow(table), l = 1, r = ncol(table)
)
return(table)
}
}

if (location == "panel") {
place <- find_panel(table)
} else {
n_col <- ncol(table)
n_row <- nrow(table)
# Actually fill margin with relevant units
if (top) table$heights <- unit.c(height, table$heights[-1])
if (left) table$widths <- unit.c(width, table$widths[-1])
if (right) table$widths <- unit.c(table$widths[-n_col], width)
if (bottom) table$heights <- unit.c(table$heights[-n_row], height)
place <- data_frame0(t = 1L, r = n_col, b = n_row, l = 1L)
}

# Shrink placement to position
if (top) place$b <- place$t
if (left) place$r <- place$l
if (right) place$l <- place$r
if (bottom) place$t <- place$b

gtable_add_grob(
table, tag, name = "tag", clip = "off",
t = place$t, l = place$l, b = place$b, r = place$r
)
}

# Add the legends to the gtable
table_add_legends <- function(table, legends, theme) {

if (is_zero(legends)) {
legends <- rep(list(zeroGrob()), 5)
names(legends) <- c(.trbl, "inside")
}

# Extract sizes
widths <- heights <- set_names(
rep(list(unit(0, "cm")), length(legends)),
names(legends)
)

empty <- vapply(legends, is_zero, logical(1))
widths[!empty] <- lapply(legends[!empty], gtable_width)
heights[!empty] <- lapply(legends[!empty], gtable_height)
spacing <- calc_element("legend.box.spacing", theme) %||% unit(0.2, "cm")

# If legend is missing, set spacing to zero for that legend
zero <- unit(0, "pt")
spacing <- lapply(empty, function(is_empty) if (is_empty) zero else spacing)

location <- switch(
theme$legend.location %||% "panel",
"plot" = plot_extent,
find_panel
)

place <- location(table)

# Add right legend
table <- gtable_add_cols(table, spacing$right, pos = -1)
table <- gtable_add_cols(table, widths$right, pos = -1)
table <- gtable_add_grob(
table, legends$right, clip = "off",
t = place$t, b = place$b, l = -1, r = -1,
name = "guide-box-right"
)

# Add left legend
table <- gtable_add_cols(table, spacing$left, pos = 0)
table <- gtable_add_cols(table, widths$left, pos = 0)
table <- gtable_add_grob(
table, legends$left, clip = "off",
t = place$t, b = place$b, l = 1, r = 1,
name = "guide-box-left"
)

place <- location(table)

# Add bottom legend
table <- gtable_add_rows(table, spacing$bottom, pos = -1)
table <- gtable_add_rows(table, heights$bottom, pos = -1)
table <- gtable_add_grob(
table, legends$bottom, clip = "off",
t = -1, b = -1, l = place$l, r = place$r,
name = "guide-box-bottom"
)

# Add top legend
table <- gtable_add_rows(table, spacing$top, pos = 0)
table <- gtable_add_rows(table, heights$top, pos = 0)
table <- gtable_add_grob(
table, legends$top, clip = "off",
t = 1, b = 1, l = place$l, r = place$r,
name = "guide-box-top"
)

# Add manual legend
place <- find_panel(table)
table <- gtable_add_grob(
table, legends$inside, clip = "off",
t = place$t, b = place$b, l = place$l, r = place$r,
name = "guide-box-inside"
)

table
}

plot_extent <- function(table) {
layout <- table$layout
data_frame0(
t = min(layout[["t"]]),
r = max(layout[["r"]]),
b = max(layout[["b"]]),
l = min(layout[["l"]]),
.size = 1L
)
}
Loading