1#' Build ggplot for rendering. 2#' 3#' `ggplot_build()` takes the plot object, and performs all steps necessary 4#' to produce an object that can be rendered. This function outputs two pieces: 5#' a list of data frames (one for each layer), and a panel object, which 6#' contain all information about axis limits, breaks etc. 7#' 8#' `layer_data()`, `layer_grob()`, and `layer_scales()` are helper 9#' functions that return the data, grob, or scales associated with a given 10#' layer. These are useful for tests. 11#' 12#' @param plot ggplot object 13#' @param i An integer. In `layer_data()`, the data to return (in the order added to the 14#' plot). In `layer_grob()`, the grob to return (in the order added to the 15#' plot). In `layer_scales()`, the row of a facet to return scales for. 16#' @param j An integer. In `layer_scales()`, the column of a facet to return 17#' scales for. 18#' @seealso [print.ggplot()] and [benchplot()] for 19#' functions that contain the complete set of steps for generating 20#' a ggplot2 plot. 21#' @keywords internal 22#' @export 23ggplot_build <- function(plot) { 24 UseMethod('ggplot_build') 25} 26 27#' @export 28ggplot_build.ggplot <- function(plot) { 29 plot <- plot_clone(plot) 30 if (length(plot$layers) == 0) { 31 plot <- plot + geom_blank() 32 } 33 34 layers <- plot$layers 35 layer_data <- lapply(layers, function(y) y$layer_data(plot$data)) 36 37 scales <- plot$scales 38 # Apply function to layer and matching data 39 by_layer <- function(f) { 40 out <- vector("list", length(data)) 41 for (i in seq_along(data)) { 42 out[[i]] <- f(l = layers[[i]], d = data[[i]]) 43 } 44 out 45 } 46 47 # Allow all layers to make any final adjustments based 48 # on raw input data and plot info 49 data <- layer_data 50 data <- by_layer(function(l, d) l$setup_layer(d, plot)) 51 52 # Initialise panels, add extra data for margins & missing faceting 53 # variables, and add on a PANEL variable to data 54 layout <- create_layout(plot$facet, plot$coordinates) 55 data <- layout$setup(data, plot$data, plot$plot_env) 56 57 # Compute aesthetics to produce data with generalised variable names 58 data <- by_layer(function(l, d) l$compute_aesthetics(d, plot)) 59 60 # Transform all scales 61 data <- lapply(data, scales_transform_df, scales = scales) 62 63 # Map and train positions so that statistics have access to ranges 64 # and all positions are numeric 65 scale_x <- function() scales$get_scales("x") 66 scale_y <- function() scales$get_scales("y") 67 68 layout$train_position(data, scale_x(), scale_y()) 69 data <- layout$map_position(data) 70 71 # Apply and map statistics 72 data <- by_layer(function(l, d) l$compute_statistic(d, layout)) 73 data <- by_layer(function(l, d) l$map_statistic(d, plot)) 74 75 # Make sure missing (but required) aesthetics are added 76 scales_add_missing(plot, c("x", "y"), plot$plot_env) 77 78 # Reparameterise geoms from (e.g.) y and width to ymin and ymax 79 data <- by_layer(function(l, d) l$compute_geom_1(d)) 80 81 # Apply position adjustments 82 data <- by_layer(function(l, d) l$compute_position(d, layout)) 83 84 # Reset position scales, then re-train and map. This ensures that facets 85 # have control over the range of a plot: is it generated from what is 86 # displayed, or does it include the range of underlying data 87 layout$reset_scales() 88 layout$train_position(data, scale_x(), scale_y()) 89 layout$setup_panel_params() 90 data <- layout$map_position(data) 91 92 # Train and map non-position scales 93 npscales <- scales$non_position_scales() 94 if (npscales$n() > 0) { 95 lapply(data, scales_train_df, scales = npscales) 96 data <- lapply(data, scales_map_df, scales = npscales) 97 } 98 99 # Fill in defaults etc. 100 data <- by_layer(function(l, d) l$compute_geom_2(d)) 101 102 # Let layer stat have a final say before rendering 103 data <- by_layer(function(l, d) l$finish_statistics(d)) 104 105 # Let Layout modify data before rendering 106 data <- layout$finish_data(data) 107 108 # Consolidate alt-text 109 plot$labels$alt <- get_alt_text(plot) 110 111 structure( 112 list(data = data, layout = layout, plot = plot), 113 class = "ggplot_built" 114 ) 115} 116 117#' @export 118#' @rdname ggplot_build 119layer_data <- function(plot, i = 1L) { 120 ggplot_build(plot)$data[[i]] 121} 122 123#' @export 124#' @rdname ggplot_build 125layer_scales <- function(plot, i = 1L, j = 1L) { 126 b <- ggplot_build(plot) 127 128 layout <- b$layout$layout 129 selected <- layout[layout$ROW == i & layout$COL == j, , drop = FALSE] 130 131 list( 132 x = b$layout$panel_scales_x[[selected$SCALE_X]], 133 y = b$layout$panel_scales_y[[selected$SCALE_Y]] 134 ) 135} 136 137#' @export 138#' @rdname ggplot_build 139layer_grob <- function(plot, i = 1L) { 140 b <- ggplot_build(plot) 141 142 b$plot$layers[[i]]$draw_geom(b$data[[i]], b$layout) 143} 144 145#' Build a plot with all the usual bits and pieces. 146#' 147#' This function builds all grobs necessary for displaying the plot, and 148#' stores them in a special data structure called a [gtable()]. 149#' This object is amenable to programmatic manipulation, should you want 150#' to (e.g.) make the legend box 2 cm wide, or combine multiple plots into 151#' a single display, preserving aspect ratios across the plots. 152#' 153#' @seealso [print.ggplot()] and [benchplot()] for 154#' for functions that contain the complete set of steps for generating 155#' a ggplot2 plot. 156#' @return a [gtable()] object 157#' @keywords internal 158#' @param data plot data generated by [ggplot_build()] 159#' @export 160ggplot_gtable <- function(data) { 161 UseMethod('ggplot_gtable') 162} 163 164#' @export 165ggplot_gtable.ggplot_built <- function(data) { 166 plot <- data$plot 167 layout <- data$layout 168 data <- data$data 169 theme <- plot_theme(plot) 170 171 geom_grobs <- Map(function(l, d) l$draw_geom(d, layout), plot$layers, data) 172 layout$setup_panel_guides(plot$guides, plot$layers, plot$mapping) 173 plot_table <- layout$render(geom_grobs, data, theme, plot$labels) 174 175 # Legends 176 position <- theme$legend.position %||% "right" 177 if (length(position) == 2) { 178 position <- "manual" 179 } 180 181 legend_box <- if (position != "none") { 182 build_guides(plot$scales, plot$layers, plot$mapping, position, theme, plot$guides, plot$labels) 183 } else { 184 zeroGrob() 185 } 186 187 if (is.zero(legend_box)) { 188 position <- "none" 189 } else { 190 # these are a bad hack, since it modifies the contents of viewpoint directly... 191 legend_width <- gtable_width(legend_box) 192 legend_height <- gtable_height(legend_box) 193 194 # Set the justification of the legend box 195 # First value is xjust, second value is yjust 196 just <- valid.just(theme$legend.justification) 197 xjust <- just[1] 198 yjust <- just[2] 199 200 if (position == "manual") { 201 xpos <- theme$legend.position[1] 202 ypos <- theme$legend.position[2] 203 204 # x and y are specified via theme$legend.position (i.e., coords) 205 legend_box <- editGrob( 206 legend_box, 207 vp = viewport( 208 x = xpos, 209 y = ypos, 210 just = c(xjust, yjust), 211 height = legend_height, 212 width = legend_width 213 ) 214 ) 215 } else { 216 # x and y are adjusted using justification of legend box (i.e., theme$legend.justification) 217 legend_box <- editGrob( 218 legend_box, 219 vp = viewport( 220 x = xjust, 221 y = yjust, 222 just = c(xjust, yjust), 223 height = legend_height, 224 width = legend_width 225 ) 226 ) 227 legend_box <- gtable_add_rows(legend_box, unit(yjust, 'null')) 228 legend_box <- gtable_add_rows(legend_box, unit(1 - yjust, 'null'), 0) 229 legend_box <- gtable_add_cols(legend_box, unit(xjust, 'null'), 0) 230 legend_box <- gtable_add_cols(legend_box, unit(1 - xjust, 'null')) 231 } 232 } 233 234 panel_dim <- find_panel(plot_table) 235 # for align-to-device, use this: 236 # panel_dim <- summarise(plot_table$layout, t = min(t), r = max(r), b = max(b), l = min(l)) 237 238 theme$legend.box.spacing <- theme$legend.box.spacing %||% unit(0.2, 'cm') 239 if (position == "left") { 240 plot_table <- gtable_add_cols(plot_table, theme$legend.box.spacing, pos = 0) 241 plot_table <- gtable_add_cols(plot_table, legend_width, pos = 0) 242 plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", 243 t = panel_dim$t, b = panel_dim$b, l = 1, r = 1, name = "guide-box") 244 } else if (position == "right") { 245 plot_table <- gtable_add_cols(plot_table, theme$legend.box.spacing, pos = -1) 246 plot_table <- gtable_add_cols(plot_table, legend_width, pos = -1) 247 plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", 248 t = panel_dim$t, b = panel_dim$b, l = -1, r = -1, name = "guide-box") 249 } else if (position == "bottom") { 250 plot_table <- gtable_add_rows(plot_table, theme$legend.box.spacing, pos = -1) 251 plot_table <- gtable_add_rows(plot_table, legend_height, pos = -1) 252 plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", 253 t = -1, b = -1, l = panel_dim$l, r = panel_dim$r, name = "guide-box") 254 } else if (position == "top") { 255 plot_table <- gtable_add_rows(plot_table, theme$legend.box.spacing, pos = 0) 256 plot_table <- gtable_add_rows(plot_table, legend_height, pos = 0) 257 plot_table <- gtable_add_grob(plot_table, legend_box, clip = "off", 258 t = 1, b = 1, l = panel_dim$l, r = panel_dim$r, name = "guide-box") 259 } else if (position == "manual") { 260 # should guide box expand whole region or region without margin? 261 plot_table <- gtable_add_grob(plot_table, legend_box, 262 t = panel_dim$t, b = panel_dim$b, l = panel_dim$l, r = panel_dim$r, 263 clip = "off", name = "guide-box") 264 } 265 266 # Title 267 title <- element_render(theme, "plot.title", plot$labels$title, margin_y = TRUE) 268 title_height <- grobHeight(title) 269 270 # Subtitle 271 subtitle <- element_render(theme, "plot.subtitle", plot$labels$subtitle, margin_y = TRUE) 272 subtitle_height <- grobHeight(subtitle) 273 274 # Tag 275 tag <- element_render(theme, "plot.tag", plot$labels$tag, margin_y = TRUE, margin_x = TRUE) 276 tag_height <- grobHeight(tag) 277 tag_width <- grobWidth(tag) 278 279 # whole plot annotation 280 caption <- element_render(theme, "plot.caption", plot$labels$caption, margin_y = TRUE) 281 caption_height <- grobHeight(caption) 282 283 # positioning of title and subtitle is governed by plot.title.position 284 # positioning of caption is governed by plot.caption.position 285 # "panel" means align to the panel(s) 286 # "plot" means align to the entire plot (except margins and tag) 287 title_pos <- theme$plot.title.position %||% "panel" 288 if (!(title_pos %in% c("panel", "plot"))) { 289 abort('plot.title.position should be either "panel" or "plot".') 290 } 291 caption_pos <- theme$plot.caption.position %||% "panel" 292 if (!(caption_pos %in% c("panel", "plot"))) { 293 abort('plot.caption.position should be either "panel" or "plot".') 294 } 295 296 pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), , drop = FALSE] 297 if (title_pos == "panel") { 298 title_l = min(pans$l) 299 title_r = max(pans$r) 300 } else { 301 title_l = 1 302 title_r = ncol(plot_table) 303 } 304 if (caption_pos == "panel") { 305 caption_l = min(pans$l) 306 caption_r = max(pans$r) 307 } else { 308 caption_l = 1 309 caption_r = ncol(plot_table) 310 } 311 312 plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0) 313 plot_table <- gtable_add_grob(plot_table, subtitle, name = "subtitle", 314 t = 1, b = 1, l = title_l, r = title_r, clip = "off") 315 316 plot_table <- gtable_add_rows(plot_table, title_height, pos = 0) 317 plot_table <- gtable_add_grob(plot_table, title, name = "title", 318 t = 1, b = 1, l = title_l, r = title_r, clip = "off") 319 320 plot_table <- gtable_add_rows(plot_table, caption_height, pos = -1) 321 plot_table <- gtable_add_grob(plot_table, caption, name = "caption", 322 t = -1, b = -1, l = caption_l, r = caption_r, clip = "off") 323 324 plot_table <- gtable_add_rows(plot_table, unit(0, 'pt'), pos = 0) 325 plot_table <- gtable_add_cols(plot_table, unit(0, 'pt'), pos = 0) 326 plot_table <- gtable_add_rows(plot_table, unit(0, 'pt'), pos = -1) 327 plot_table <- gtable_add_cols(plot_table, unit(0, 'pt'), pos = -1) 328 329 tag_pos <- theme$plot.tag.position %||% "topleft" 330 if (length(tag_pos) == 2) tag_pos <- "manual" 331 valid_pos <- c("topleft", "top", "topright", "left", "right", "bottomleft", 332 "bottom", "bottomright") 333 334 if (!(tag_pos == "manual" || tag_pos %in% valid_pos)) { 335 abort(glue("plot.tag.position should be a coordinate or one of ", 336 glue_collapse(valid_pos, ', ', last = " or "))) 337 } 338 339 if (tag_pos == "manual") { 340 xpos <- theme$plot.tag.position[1] 341 ypos <- theme$plot.tag.position[2] 342 tag_parent <- justify_grobs(tag, x = xpos, y = ypos, 343 hjust = theme$plot.tag$hjust, 344 vjust = theme$plot.tag$vjust, 345 int_angle = theme$plot.tag$angle, 346 debug = theme$plot.tag$debug) 347 plot_table <- gtable_add_grob(plot_table, tag_parent, name = "tag", t = 1, 348 b = nrow(plot_table), l = 1, 349 r = ncol(plot_table), clip = "off") 350 } else { 351 # Widths and heights are reassembled below instead of assigning into them 352 # in order to avoid bug in grid 3.2 and below. 353 if (tag_pos == "topleft") { 354 plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) 355 plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) 356 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 357 t = 1, l = 1, clip = "off") 358 } else if (tag_pos == "top") { 359 plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) 360 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 361 t = 1, l = 1, r = ncol(plot_table), 362 clip = "off") 363 } else if (tag_pos == "topright") { 364 plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) 365 plot_table$heights <- unit.c(tag_height, plot_table$heights[-1]) 366 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 367 t = 1, l = ncol(plot_table), clip = "off") 368 } else if (tag_pos == "left") { 369 plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) 370 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 371 t = 1, b = nrow(plot_table), l = 1, 372 clip = "off") 373 } else if (tag_pos == "right") { 374 plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) 375 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 376 t = 1, b = nrow(plot_table), l = ncol(plot_table), 377 clip = "off") 378 } else if (tag_pos == "bottomleft") { 379 plot_table$widths <- unit.c(tag_width, plot_table$widths[-1]) 380 plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) 381 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 382 t = nrow(plot_table), l = 1, clip = "off") 383 } else if (tag_pos == "bottom") { 384 plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) 385 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 386 t = nrow(plot_table), l = 1, r = ncol(plot_table), clip = "off") 387 } else if (tag_pos == "bottomright") { 388 plot_table$widths <- unit.c(plot_table$widths[-ncol(plot_table)], tag_width) 389 plot_table$heights <- unit.c(plot_table$heights[-nrow(plot_table)], tag_height) 390 plot_table <- gtable_add_grob(plot_table, tag, name = "tag", 391 t = nrow(plot_table), l = ncol(plot_table), clip = "off") 392 } 393 } 394 395 # Margins 396 plot_table <- gtable_add_rows(plot_table, theme$plot.margin[1], pos = 0) 397 plot_table <- gtable_add_cols(plot_table, theme$plot.margin[2]) 398 plot_table <- gtable_add_rows(plot_table, theme$plot.margin[3]) 399 plot_table <- gtable_add_cols(plot_table, theme$plot.margin[4], pos = 0) 400 401 if (inherits(theme$plot.background, "element")) { 402 plot_table <- gtable_add_grob(plot_table, 403 element_render(theme, "plot.background"), 404 t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf) 405 plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),] 406 plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))] 407 } 408 409 # add alt-text as attribute 410 attr(plot_table, "alt-label") <- plot$labels$alt 411 412 plot_table 413} 414 415#' Generate a ggplot2 plot grob. 416#' 417#' @param x ggplot2 object 418#' @keywords internal 419#' @export 420ggplotGrob <- function(x) { 421 ggplot_gtable(ggplot_build(x)) 422} 423