1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
#' Wrap arbitrary graphics in a patchwork-compliant patch
#'
#' In order to add non-ggplot2 element to a patchwork they can be
#' converted to a compliant representation using the `wrap_elements()` function.
#' This allows you to position either grobs, ggplot objects, patchwork
#' objects, or even base graphics (if passed as a formula) in either the full
#' area, the full plotting area (anything between and
#' including the axis label), or the panel area (only the actual area where data
#' is drawn). Further you can still add title, subtitle, tag, and caption using
#' the same approach as with normal ggplots (using
#' [ggtitle()][ggplot2::ggtitle] and [labs()][ggplot2::labs]) as well as styling
#' using [theme()][ggplot2::theme]. For the latter, only the theme elements
#' targeting plot margins and background as well as title, subtitle, etc styling
#' will have an effect. If a patchwork or ggplot object is wrapped, it will be
#' fixated in its state and will no longer respond to addition of styling,
#' geoms, etc.. When grobs and formulas are added directly, they will implicitly
#' be converted to `wrap_elements(full = x)`.
#'
#' @param panel,plot,full A grob, ggplot, patchwork, formula, raster,
#' nativeRaster, or gt object to add to the respective area.
#'
#' @param clip Should the grobs be clipped if expanding outside its area
#'
#' @param ignore_tag Should tags be ignored for this patch. This is relevant
#' when using automatic tagging of plots and the content of the patch does not
#' qualify for a tag.
#'
#' @return A wrapped_patch object
#'
#' @export
#'
#' @examples
#' library(ggplot2)
#' library(grid)
#'
#' # Combine grobs with each other
#' wrap_elements(panel = textGrob('Here are some text')) +
#' wrap_elements(
#' panel = rectGrob(gp = gpar(fill = 'steelblue')),
#' full = rectGrob(gp = gpar(fill = 'goldenrod'))
#' )
#'
#' # wrapped elements can still get titles etc like ggplots
#' wrap_elements(panel = textGrob('Here are some text')) +
#' wrap_elements(
#' panel = rectGrob(gp = gpar(fill = 'steelblue')),
#' full = rectGrob(gp = gpar(fill = 'goldenrod'))
#' ) +
#' ggtitle('Title for the amazing rectangles')
#'
#' # You can also pass in ggplots or patchworks to e.g. have it fill out the
#' # panel area
#' p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp))
#' p1 + wrap_elements(panel = p1 + ggtitle('Look at me shrink'))
#'
#' # You can even add base graphics if you pass it as a formula (requires gridGraphics package)
#' if (requireNamespace("gridGraphics", quietly = TRUE)) {
#' p1 + wrap_elements(full = ~ plot(mtcars$mpg, mtcars$disp))
#'
#' # Adding a grob or formula directly is equivalent to placing it in `full`
#' p1 + ~ plot(mtcars$mpg, mtcars$disp)
#' }
#'
wrap_elements <- function(panel = NULL, plot = NULL, full = NULL, clip = TRUE, ignore_tag = FALSE) {
clip <- if (clip) 'on' else 'off'
table <- make_patch()
attr(table, 'grobs') <- list(panel = panel, plot = plot, full = full)
attr(table, 'patch_settings') <- list(clip = clip, ignore_tag = ignore_tag)
class(table) <- c('wrapped_patch', class(table))
table
}
is_wrapped_patch <- function(x) inherits(x, 'wrapped_patch')
#' @importFrom ggplot2 ggplotGrob theme_get
#' @importFrom gtable gtable_add_grob
#' @importFrom grid grobHeight convertHeight
#' @export
patchGrob.wrapped_patch <- function(x, guides = 'auto') {
gt <- ggplotGrob(x)
table <- patch_table(x, gt)
settings <- attr(x, 'patch_settings')
grobs <- attr(x, 'grobs')
if (!is.null(grobs$full)) {
table <- gtable_add_grob(table, list(as_patch(grobs$full)), 1, 1, nrow(table),
ncol(table), clip = settings$clip, name = 'full')
}
if (!is.null(grobs$plot)) {
table <- gtable_add_grob(table, list(as_patch(grobs$plot)), PLOT_TOP,
PLOT_LEFT, PLOT_BOTTOM, PLOT_RIGHT,
clip = settings$clip, name = 'plot')
}
if (!is.null(grobs$panel)) {
table <- gtable_add_grob(table, list(as_patch(grobs$panel)), PANEL_ROW,
PANEL_COL, clip = settings$clip, name = 'panel')
}
title <- get_grob(gt, 'title')
table <- gtable_add_grob(table, list(title), TITLE_ROW, PANEL_COL,
clip = settings$clip, name = 'title')
table$heights[TITLE_ROW] <- convertHeight(grobHeight(title), 'mm')
subtitle <- get_grob(gt, 'subtitle')
table <- gtable_add_grob(table, list(subtitle), SUBTITLE_ROW, PANEL_COL,
clip = settings$clip, name = 'subtitle')
table$heights[SUBTITLE_ROW] <- convertHeight(grobHeight(subtitle), 'mm')
caption <- get_grob(gt, 'caption')
table <- gtable_add_grob(table, list(caption), CAPTION_ROW, PANEL_COL,
clip = settings$clip, name = 'caption')
table$heights[CAPTION_ROW] <- convertHeight(grobHeight(caption), 'mm')
if (!settings$ignore_tag) {
table$widths[c(2, ncol(table)-1)] <- gt$widths[c(2, ncol(gt)-1)]
table$heights[c(2, nrow(table)-1)] <- gt$heights[c(2, nrow(gt)-1)]
tag <- get_grob(gt, 'tag')
tag_pos <- calc_element("plot.tag.position", x$theme %||% theme_get())
if (is.null(tag_pos)) tag_pos <- theme_get()$plot.tag.position
if (!is.character(tag_pos)) tag_pos <- 'manual'
table <- switch(
tag_pos,
topleft = gtable_add_grob(table, tag, name = "tag", t = 2, l = 2, clip = "off"),
top = gtable_add_grob(table, tag, name = "tag", t = 2, l = 2, r = ncol(table)-1, clip = "off"),
topright = gtable_add_grob(table, tag, name = "tag", t = 2, l = ncol(table)-1, clip = "off"),
left = gtable_add_grob(table, tag, name = "tag", t = 2, b = nrow(table)-1, l = 2, clip = "off"),
right = gtable_add_grob(table, tag, name = "tag", t = 2, b = nrow(table)-1, l = ncol(table)-1, clip = "off"),
bottomleft = gtable_add_grob(table, tag, name = "tag", t = nrow(table)-1, l = 2, clip = "off"),
bottom = gtable_add_grob(table, tag, name = "tag", t = nrow(table)-1, l = 2, r = ncol(table)-1, clip = "off"),
bottomright = gtable_add_grob(table, tag, name = "tag", t = nrow(table)-1, l = ncol(table)-1, clip = "off"),
manual = gtable_add_grob(table, tag, name = 'tag', t = 2, l = 2, b = nrow(table)-1, r = ncol(table)-1, clip = "off")
)
}
table
}
as_patch <- function(x, ...) {
UseMethod('as_patch')
}
#' @export
as_patch.grob <- function(x, ...) {
x
}
#' @importFrom grid gTree
#' @export
as_patch.gList <- function(x, ...) {
gTree(children = x)
}
#' @importFrom ggplot2 ggplotGrob
#' @export
as_patch.ggplot <- function(x, ...) {
ggplotGrob(x)
}
#' @export
as_patch.patchwork <- function(x, ...) {
patchworkGrob(x)
}
#' @export
as_patch.formula <- function(x, ...) {
rlang::check_installed('gridGraphics', 'to add base plots to patchworks')
gp <- graphics::par(no.readonly = TRUE)
plot_call <- function() {
old_gp <- graphics::par(no.readonly = TRUE)
graphics::par(gp)
on.exit(try(graphics::par(old_gp)))
res <- suppressMessages(eval(x[[2]], attr(x, '.Environment')))
invisible(NULL)
}
gridGraphics::echoGrob(plot_call, name = 'patchwork_base', device = offscreen_dev())
}
#' @export
#' @importFrom grid rasterGrob
as_patch.raster <- function(x, ...) {
as_patch(rasterGrob(x), ...)
}
#' @export
as_patch.nativeRaster <- as_patch.raster
#' @importFrom ggplot2 ggplotGrob
get_grob <- function(x, name) {
ind <- grep(paste0('^', name, '$'), x$layout$name)
if (length(ind) == 0) return(ggplot2::zeroGrob())
x$grobs[[grep(paste0('^', name, '$'), x$layout$name)]]
}
offscreen_dev <- function() {
if (requireNamespace('ragg', quietly = TRUE)) {
function(width, height) {
ragg::agg_capture(width = width, height = height, units = 'in')
grDevices::dev.control("enable")
}
} else {
function(width, height) {
grDevices::pdf(NULL, width = width, height = height)
grDevices::dev.control("enable")
}
}
}
#' @export
has_tag.wrapped_patch <- function(x) !attr(x, 'patch_settings')$ignore_tag
|
