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