Skip to content

Commit 81070f8

Browse files
teunbrandteunbrand
committed
break up ggplot_gtable() method into smaller functions
1 parent b69b372 commit 81070f8

File tree

1 file changed

+179
-156
lines changed

1 file changed

+179
-156
lines changed

‎R/plot-render.R‎

Lines changed: 179 additions & 156 deletions
Original file line numberDiff line numberDiff line change
@@ -30,98 +30,24 @@ S7::method(ggplot_gtable, class_ggplot_built) <- function(data) {
3030
layout <- data@layout
3131
data <- data@data
3232
theme <- plot@theme
33+
labels <- plot@labels
3334

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

36-
plot_table <- layout$render(geom_grobs, data, theme, plot@labels)
37+
plot_table <- layout$render(geom_grobs, data, theme, labels)
3738

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

42-
# Title
43-
title <- element_render(
44-
theme, "plot.title", plot@labels$title,
45-
margin_y = TRUE, margin_x = TRUE
46-
)
47-
title_height <- grobHeight(title)
48-
49-
# Subtitle
50-
subtitle <- element_render(
51-
theme, "plot.subtitle", plot@labels$subtitle,
52-
margin_y = TRUE, margin_x = TRUE
53-
)
54-
subtitle_height <- grobHeight(subtitle)
55-
5643
# whole plot annotation
57-
caption <- element_render(
58-
theme, "plot.caption", plot@labels$caption,
59-
margin_y = TRUE, margin_x = TRUE
60-
)
61-
caption_height <- grobHeight(caption)
62-
63-
# positioning of title and subtitle is governed by plot.title.position
64-
# positioning of caption is governed by plot.caption.position
65-
# "panel" means align to the panel(s)
66-
# "plot" means align to the entire plot (except margins and tag)
67-
title_pos <- arg_match0(
68-
theme$plot.title.position %||% "panel",
69-
c("panel", "plot"),
70-
arg_nm = "plot.title.position",
71-
error_call = expr(theme())
72-
)
73-
74-
caption_pos <- arg_match0(
75-
theme$plot.caption.position %||% "panel",
76-
values = c("panel", "plot"),
77-
arg_nm = "plot.caption.position",
78-
error_call = expr(theme())
79-
)
80-
81-
pans <- plot_table$layout[grepl("^panel", plot_table$layout$name), , drop = FALSE]
82-
if (title_pos == "panel") {
83-
title_l <- min(pans$l)
84-
title_r <- max(pans$r)
85-
} else {
86-
title_l <- 1
87-
title_r <- ncol(plot_table)
88-
}
89-
if (caption_pos == "panel") {
90-
caption_l <- min(pans$l)
91-
caption_r <- max(pans$r)
92-
} else {
93-
caption_l <- 1
94-
caption_r <- ncol(plot_table)
95-
}
96-
97-
plot_table <- gtable_add_rows(plot_table, subtitle_height, pos = 0)
98-
plot_table <- gtable_add_grob(plot_table, subtitle, name = "subtitle",
99-
t = 1, b = 1, l = title_l, r = title_r, clip = "off")
100-
101-
plot_table <- gtable_add_rows(plot_table, title_height, pos = 0)
102-
plot_table <- gtable_add_grob(plot_table, title, name = "title",
103-
t = 1, b = 1, l = title_l, r = title_r, clip = "off")
104-
105-
plot_table <- gtable_add_rows(plot_table, caption_height, pos = -1)
106-
plot_table <- gtable_add_grob(plot_table, caption, name = "caption",
107-
t = -1, b = -1, l = caption_l, r = caption_r, clip = "off")
108-
109-
plot_table <- table_add_tag(plot_table, plot@labels$tag, theme)
110-
111-
# Margins
112-
plot_margin <- calc_element("plot.margin", theme) %||% margin()
113-
plot_table <- gtable_add_padding(plot_table, plot_margin)
114-
115-
if (is_theme_element(theme$plot.background)) {
116-
plot_table <- gtable_add_grob(plot_table,
117-
element_render(theme, "plot.background"),
118-
t = 1, l = 1, b = -1, r = -1, name = "background", z = -Inf)
119-
# plot_table$layout <- plot_table$layout[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1)),]
120-
# plot_table$grobs <- plot_table$grobs[c(nrow(plot_table$layout), 1:(nrow(plot_table$layout) - 1))]
121-
}
44+
plot_table <- table_add_titles(plot_table, labels, theme)
45+
plot_table <- table_add_caption(plot_table, labels$caption, theme)
46+
plot_table <- table_add_tag(plot_table, labels$tag, theme)
47+
plot_table <- table_add_background(plot_table, theme)
12248

12349
# add alt-text as attribute
124-
attr(plot_table, "alt-label") <- plot@labels$alt
50+
attr(plot_table, "alt-label") <- labels$alt
12551

12652
plot_table
12753
}
@@ -158,6 +84,166 @@ by_layer <- function(f, layers, data, step = NULL) {
15884
out
15985
}
16086

87+
# Add the legends to the gtable
88+
table_add_legends <- function(table, legends, theme) {
89+
90+
if (is_zero(legends)) {
91+
legends <- rep(list(zeroGrob()), 5)
92+
names(legends) <- c(.trbl, "inside")
93+
}
94+
95+
# Extract sizes
96+
widths <- heights <- set_names(
97+
rep(list(unit(0, "cm")), length(legends)),
98+
names(legends)
99+
)
100+
101+
empty <- vapply(legends, is_zero, logical(1))
102+
widths[!empty] <- lapply(legends[!empty], gtable_width)
103+
heights[!empty] <- lapply(legends[!empty], gtable_height)
104+
spacing <- calc_element("legend.box.spacing", theme) %||% unit(0.2, "cm")
105+
106+
# If legend is missing, set spacing to zero for that legend
107+
zero <- unit(0, "pt")
108+
spacing <- lapply(empty, function(is_empty) if (is_empty) zero else spacing)
109+
110+
location <- switch(
111+
theme$legend.location %||% "panel",
112+
"plot" = plot_extent,
113+
find_panel
114+
)
115+
116+
place <- location(table)
117+
118+
# Add right legend
119+
table <- gtable_add_cols(table, spacing$right, pos = -1)
120+
table <- gtable_add_cols(table, widths$right, pos = -1)
121+
table <- gtable_add_grob(
122+
table, legends$right, clip = "off",
123+
t = place$t, b = place$b, l = -1, r = -1,
124+
name = "guide-box-right"
125+
)
126+
127+
# Add left legend
128+
table <- gtable_add_cols(table, spacing$left, pos = 0)
129+
table <- gtable_add_cols(table, widths$left, pos = 0)
130+
table <- gtable_add_grob(
131+
table, legends$left, clip = "off",
132+
t = place$t, b = place$b, l = 1, r = 1,
133+
name = "guide-box-left"
134+
)
135+
136+
place <- location(table)
137+
138+
# Add bottom legend
139+
table <- gtable_add_rows(table, spacing$bottom, pos = -1)
140+
table <- gtable_add_rows(table, heights$bottom, pos = -1)
141+
table <- gtable_add_grob(
142+
table, legends$bottom, clip = "off",
143+
t = -1, b = -1, l = place$l, r = place$r,
144+
name = "guide-box-bottom"
145+
)
146+
147+
# Add top legend
148+
table <- gtable_add_rows(table, spacing$top, pos = 0)
149+
table <- gtable_add_rows(table, heights$top, pos = 0)
150+
table <- gtable_add_grob(
151+
table, legends$top, clip = "off",
152+
t = 1, b = 1, l = place$l, r = place$r,
153+
name = "guide-box-top"
154+
)
155+
156+
# Add manual legend
157+
place <- find_panel(table)
158+
table <- gtable_add_grob(
159+
table, legends$inside, clip = "off",
160+
t = place$t, b = place$b, l = place$l, r = place$r,
161+
name = "guide-box-inside"
162+
)
163+
164+
table
165+
}
166+
167+
table_add_titles <- function(table, labels, theme) {
168+
169+
# Title
170+
title <- element_render(
171+
theme, "plot.title", labels$title,
172+
margin_y = TRUE, margin_x = TRUE
173+
)
174+
title_height <- grobHeight(title)
175+
176+
# Subtitle
177+
subtitle <- element_render(
178+
theme, "plot.subtitle", labels$subtitle,
179+
margin_y = TRUE, margin_x = TRUE
180+
)
181+
subtitle_height <- grobHeight(subtitle)
182+
183+
# positioning of title and subtitle is governed by plot.title.position
184+
# "panel" means align to the panel(s)
185+
# "plot" means align to the entire plot (except margins and tag)
186+
title_pos <- arg_match0(
187+
theme$plot.title.position %||% "panel",
188+
c("panel", "plot"),
189+
arg_nm = "plot.title.position",
190+
error_call = expr(theme())
191+
)
192+
193+
panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE]
194+
if (title_pos == "panel") {
195+
l <- min(panels$l)
196+
r <- max(panels$r)
197+
} else {
198+
l <- 1
199+
r <- ncol(table)
200+
}
201+
202+
table <- gtable_add_rows(table, subtitle_height, pos = 0)
203+
table <- gtable_add_grob(table, subtitle, name = "subtitle",
204+
t = 1, b = 1, l = l, r = r, clip = "off")
205+
206+
table <- gtable_add_rows(table, title_height, pos = 0)
207+
table <- gtable_add_grob(table, title, name = "title",
208+
t = 1, b = 1, l = l, r = r, clip = "off")
209+
210+
table
211+
}
212+
213+
table_add_caption <- function(table, label, theme) {
214+
215+
caption <- element_render(
216+
theme, "plot.caption", label,
217+
margin_y = TRUE, margin_x = TRUE
218+
)
219+
caption_height <- grobHeight(caption)
220+
221+
# positioning of title and subtitle is governed by plot.title.position
222+
# positioning of caption is governed by plot.caption.position
223+
# "panel" means align to the panel(s)
224+
# "plot" means align to the entire plot (except margins and tag)
225+
position <- arg_match0(
226+
theme$plot.caption.position %||% "panel",
227+
values = c("panel", "plot"),
228+
arg_nm = "plot.caption.position",
229+
error_call = expr(theme())
230+
)
231+
232+
pans <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE]
233+
if (position == "panel") {
234+
l <- min(pans$l)
235+
r <- max(pans$r)
236+
} else {
237+
l <- 1
238+
r <- ncol(table)
239+
}
240+
241+
table <- gtable_add_rows(table, caption_height, pos = -1)
242+
table <- gtable_add_grob(table, caption, name = "caption",
243+
t = -1, b = -1, l = l, r = r, clip = "off")
244+
table
245+
}
246+
161247
# Add the tag element to the gtable
162248
table_add_tag <- function(table, label, theme) {
163249
# Initialise the tag margins
@@ -273,83 +359,20 @@ table_add_tag <- function(table, label, theme) {
273359
)
274360
}
275361

276-
# Add the legends to the gtable
277-
table_add_legends <- function(table, legends, theme) {
278-
279-
if (is_zero(legends)) {
280-
legends <- rep(list(zeroGrob()), 5)
281-
names(legends) <- c(.trbl, "inside")
362+
table_add_background <- function(table, theme) {
363+
# Margins
364+
margin <- calc_element("plot.margin", theme) %||% margin()
365+
table <- gtable_add_padding(table, margin)
366+
367+
background <- calc_element("plot.background", theme)
368+
if (is_theme_element(background)) {
369+
table <- gtable_add_grob(
370+
table, element_grob(background),
371+
t = 1, l = 1, b = -1, r = -1,
372+
name = "background", z = -Inf
373+
)
282374
}
283375

284-
# Extract sizes
285-
widths <- heights <- set_names(
286-
rep(list(unit(0, "cm")), length(legends)),
287-
names(legends)
288-
)
289-
290-
empty <- vapply(legends, is_zero, logical(1))
291-
widths[!empty] <- lapply(legends[!empty], gtable_width)
292-
heights[!empty] <- lapply(legends[!empty], gtable_height)
293-
spacing <- calc_element("legend.box.spacing", theme) %||% unit(0.2, "cm")
294-
295-
# If legend is missing, set spacing to zero for that legend
296-
zero <- unit(0, "pt")
297-
spacing <- lapply(empty, function(is_empty) if (is_empty) zero else spacing)
298-
299-
location <- switch(
300-
theme$legend.location %||% "panel",
301-
"plot" = plot_extent,
302-
find_panel
303-
)
304-
305-
place <- location(table)
306-
307-
# Add right legend
308-
table <- gtable_add_cols(table, spacing$right, pos = -1)
309-
table <- gtable_add_cols(table, widths$right, pos = -1)
310-
table <- gtable_add_grob(
311-
table, legends$right, clip = "off",
312-
t = place$t, b = place$b, l = -1, r = -1,
313-
name = "guide-box-right"
314-
)
315-
316-
# Add left legend
317-
table <- gtable_add_cols(table, spacing$left, pos = 0)
318-
table <- gtable_add_cols(table, widths$left, pos = 0)
319-
table <- gtable_add_grob(
320-
table, legends$left, clip = "off",
321-
t = place$t, b = place$b, l = 1, r = 1,
322-
name = "guide-box-left"
323-
)
324-
325-
place <- location(table)
326-
327-
# Add bottom legend
328-
table <- gtable_add_rows(table, spacing$bottom, pos = -1)
329-
table <- gtable_add_rows(table, heights$bottom, pos = -1)
330-
table <- gtable_add_grob(
331-
table, legends$bottom, clip = "off",
332-
t = -1, b = -1, l = place$l, r = place$r,
333-
name = "guide-box-bottom"
334-
)
335-
336-
# Add top legend
337-
table <- gtable_add_rows(table, spacing$top, pos = 0)
338-
table <- gtable_add_rows(table, heights$top, pos = 0)
339-
table <- gtable_add_grob(
340-
table, legends$top, clip = "off",
341-
t = 1, b = 1, l = place$l, r = place$r,
342-
name = "guide-box-top"
343-
)
344-
345-
# Add manual legend
346-
place <- find_panel(table)
347-
table <- gtable_add_grob(
348-
table, legends$inside, clip = "off",
349-
t = place$t, b = place$b, l = place$l, r = place$r,
350-
name = "guide-box-inside"
351-
)
352-
353376
table
354377
}
355378

0 commit comments

Comments
 (0)