# ----------------------------------------------------------------------
#
# ---
# repo: r-lib/rlang
# file: standalone-obj-type.R
# last-updated: 2023-05-01
# license: https://unlicense.org
# imports: rlang (>= 1.1.0)
# ---
#
# ## Changelog
#
# 2023-05-01:
# - `obj_type_friendly()` now only displays the first class of S3 objects.
#
# 2023-03-30:
# - `stop_input_type()` now handles `I()` input literally in `arg`.
#
# 2022-10-04:
# - `obj_type_friendly(value = TRUE)` now shows numeric scalars
# literally.
# - `stop_friendly_type()` now takes `show_value`, passed to
# `obj_type_friendly()` as the `value` argument.
#
# 2022-10-03:
# - Added `allow_na` and `allow_null` arguments.
# - `NULL` is now backticked.
# - Better friendly type for infinities and `NaN`.
#
# 2022-09-16:
# - Unprefixed usage of rlang functions with `rlang::` to
# avoid onLoad issues when called from rlang (#1482).
#
# 2022-08-11:
# - Prefixed usage of rlang functions with `rlang::`.
#
# 2022-06-22:
# - `friendly_type_of()` is now `obj_type_friendly()`.
# - Added `obj_type_oo()`.
#
# 2021-12-20:
# - Added support for scalar values and empty vectors.
# - Added `stop_input_type()`
#
# 2021-06-30:
# - Added support for missing arguments.
#
# 2021-04-19:
# - Added support for matrices and arrays (#141).
# - Added documentation.
# - Added changelog.
#
# nocov start
#' Return English-friendly type
#' @param x Any R object.
#' @param value Whether to describe the value of `x`. Special values
#' like `NA` or `""` are always described.
#' @param length Whether to mention the length of vectors and lists.
#' @return A string describing the type. Starts with an indefinite
#' article, e.g. "an integer vector".
#' @noRd
obj_type_friendly <- function(x, value = TRUE) {
if (is_missing(x)) {
return("absent")
}
if (is.object(x)) {
if (inherits(x, "quosure")) {
type <- "quosure"
} else {
type <- class(x)[[1L]]
}
return(sprintf("a <%s> object", type))
}
if (!is_vector(x)) {
return(.rlang_as_friendly_type(typeof(x)))
}
n_dim <- length(dim(x))
if (!n_dim) {
if (!is_list(x) && length(x) == 1) {
if (is_na(x)) {
return(switch(
typeof(x),
logical = "`NA`",
integer = "an integer `NA`",
double =
if (is.nan(x)) {
"`NaN`"
} else {
"a numeric `NA`"
},
complex = "a complex `NA`",
character = "a character `NA`",
.rlang_stop_unexpected_typeof(x)
))
}
show_infinites <- function(x) {
if (x > 0) {
"`Inf`"
} else {
"`-Inf`"
}
}
str_encode <- function(x, width = 30, ...) {
if (nchar(x) > width) {
x <- substr(x, 1, width - 3)
x <- paste0(x, "...")
}
encodeString(x, ...)
}
if (value) {
if (is.numeric(x) && is.infinite(x)) {
return(show_infinites(x))
}
if (is.numeric(x) || is.complex(x)) {
number <- as.character(round(x, 2))
what <- if (is.complex(x)) "the complex number" else "the number"
return(paste(what, number))
}
return(switch(
typeof(x),
logical = if (x) "`TRUE`" else "`FALSE`",
character = {
what <- if (nzchar(x)) "the string" else "the empty string"
paste(what, str_encode(x, quote = "\""))
},
raw = paste("the raw value", as.character(x)),
.rlang_stop_unexpected_typeof(x)
))
}
return(switch(
typeof(x),
logical = "a logical value",
integer = "an integer",
double = if (is.infinite(x)) show_infinites(x) else "a number",
complex = "a complex number",
character = if (nzchar(x)) "a string" else "\"\"",
raw = "a raw value",
.rlang_stop_unexpected_typeof(x)
))
}
if (length(x) == 0) {
return(switch(
typeof(x),
logical = "an empty logical vector",
integer = "an empty integer vector",
double = "an empty numeric vector",
complex = "an empty complex vector",
character = "an empty character vector",
raw = "an empty raw vector",
list = "an empty list",
.rlang_stop_unexpected_typeof(x)
))
}
}
vec_type_friendly(x)
}
vec_type_friendly <- function(x, length = FALSE) {
if (!is_vector(x)) {
abort("`x` must be a vector.")
}
type <- typeof(x)
n_dim <- length(dim(x))
add_length <- function(type) {
if (length && !n_dim) {
paste0(type, sprintf(" of length %s", length(x)))
} else {
type
}
}
if (type == "list") {
if (n_dim < 2) {
return(add_length("a list"))
} else if (is.data.frame(x)) {
return("a data frame")
} else if (n_dim == 2) {
return("a list matrix")
} else {
return("a list array")
}
}
type <- switch(
type,
logical = "a logical %s",
integer = "an integer %s",
numeric = ,
double = "a double %s",
complex = "a complex %s",
character = "a character %s",
raw = "a raw %s",
type = paste0("a ", type, " %s")
)
if (n_dim < 2) {
kind <- "vector"
} else if (n_dim == 2) {
kind <- "matrix"
} else {
kind <- "array"
}
out <- sprintf(type, kind)
if (n_dim >= 2) {
out
} else {
add_length(out)
}
}
.rlang_as_friendly_type <- function(type) {
switch(
type,
list = "a list",
NULL = "`NULL`",
environment = "an environment",
externalptr = "a pointer",
weakref = "a weak reference",
S4 = "an S4 object",
name = ,
symbol = "a symbol",
language = "a call",
pairlist = "a pairlist node",
expression = "an expression vector",
char = "an internal string",
promise = "an internal promise",
... = "an internal dots object",
any = "an internal `any` object",
bytecode = "an internal bytecode object",
primitive = ,
builtin = ,
special = "a primitive function",
closure = "a function",
type
)
}
.rlang_stop_unexpected_typeof <- function(x, call = caller_env()) {
abort(
sprintf("Unexpected type <%s>.", typeof(x)),
call = call
)
}
#' Return OO type
#' @param x Any R object.
#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`,
#' `"R6"`, or `"R7"`.
#' @noRd
obj_type_oo <- function(x) {
if (!is.object(x)) {
return("bare")
}
class <- inherits(x, c("R6", "R7_object"), which = TRUE)
if (class[[1]]) {
"R6"
} else if (class[[2]]) {
"R7"
} else if (isS4(x)) {
"S4"
} else {
"S3"
}
}
#' @param x The object type which does not conform to `what`. Its
#' `obj_type_friendly()` is taken and mentioned in the error message.
#' @param what The friendly expected type as a string. Can be a
#' character vector of expected types, in which case the error
#' message mentions all of them in an "or" enumeration.
#' @param show_value Passed to `value` argument of `obj_type_friendly()`.
#' @param ... Arguments passed to [abort()].
#' @inheritParams args_error_context
#' @noRd
stop_input_type <- function(x,
what,
...,
allow_na = FALSE,
allow_null = FALSE,
show_value = TRUE,
arg = caller_arg(x),
call = caller_env()) {
# From standalone-cli.R
cli <- env_get_list(
nms = c("format_arg", "format_code"),
last = topenv(),
default = function(x) sprintf("`%s`", x),
inherit = TRUE
)
if (allow_na) {
what <- c(what, cli$format_code("NA"))
}
if (allow_null) {
what <- c(what, cli$format_code("NULL"))
}
if (length(what)) {
what <- oxford_comma(what)
}
if (inherits(arg, "AsIs")) {
format_arg <- identity
} else {
format_arg <- cli$format_arg
}
message <- sprintf(
"%s must be %s, not %s.",
format_arg(arg),
what,
obj_type_friendly(x, value = show_value)
)
abort(message, ..., call = call, arg = arg)
}
oxford_comma <- function(chr, sep = ", ", final = "or") {
n <- length(chr)
if (n < 2) {
return(chr)
}
head <- chr[seq_len(n - 1)]
last <- chr[n]
head <- paste(head, collapse = sep)
# Write a or b. But a, b, or c.
if (n > 2) {
paste0(head, sep, final, " ", last)
} else {
paste0(head, " ", final, " ", last)
}
}
# nocov end
patchwork/R/patch.R 0000644 0001762 0000144 00000004707 14545547771 013732 0 ustar ligges users #' @importFrom gtable gtable gtable_add_grob
#' @importFrom grid unit
#' @importFrom ggplot2 zeroGrob ggplot
make_patch <- function() {
widths <- unit(rep(0, TABLE_COLS), 'mm')
widths[PANEL_COL] <- unit(1, 'null')
heights <- unit(rep(0, TABLE_ROWS), 'mm')
heights[PANEL_ROW] <- unit(1, 'null')
table <- gtable(widths, heights)
# Mark the panel patch
table <- gtable_add_grob(table, list(zeroGrob()), PANEL_ROW, PANEL_COL,
z = -Inf, name = 'panel_patch')
class(table) <- c('patchgrob', class(table))
patch <- ggplot()
class(patch) <- c('patch', class(patch))
attr(patch, 'table') <- table
patch
}
is_patch <- function(x) inherits(x, 'patch')
is_patchgrob <- function(x) inherits(x, 'patchgrob')
#' @importFrom ggplot2 ggplotGrob
#' @importFrom gtable gtable_add_grob
patch_table <- function(x, grob = NULL) {
table <- attr(x, 'table')
if (is.null(grob)) grob <- ggplotGrob(x)
table$widths[c(1, ncol(table))] <- grob$widths[c(1, ncol(grob))]
table$heights[c(1, nrow(table))] <- grob$heights[c(1, nrow(grob))]
gtable_add_grob(table, grob$grobs[grep('background', grob$layout$name)], 1, 1,
nrow(table), ncol(table), z = -100, clip = 'on',
name = 'background')
}
#' Get a grob describing the content of a patch object
#'
#' Methods for this generic should be defined for all `patch` subclasses
#' and should return a compliant `gtable` object ready to be combined with
#' regular plot objects. In general it is best to call `patch_table()` on the
#' object and add grobs to this as `patch_table()` will return a compliant
#' `gtable`
#'
#' @param x An `patch` object
#'
#' @return A `gtable` object
#'
#' @export
#' @keywords internal
#'
patchGrob <- function(x, guides = 'auto') {
UseMethod('patchGrob')
}
#' @export
patchGrob.patch <- function(x, guides = 'auto') patch_table(x)
#' @importFrom grid grid.newpage grid.draw seekViewport pushViewport upViewport
#' @export
print.patch <- function(x, newpage = is.null(vp), vp = NULL, ...) {
if (newpage) grid.newpage()
grDevices::recordGraphics(
requireNamespace("patchwork", quietly = TRUE),
list(),
getNamespace("patchwork")
)
gt <- patchGrob(x)
if (is.null(vp)) {
grid.draw(gt)
} else {
if (is.character(vp)) {
seekViewport(vp)
} else {
pushViewport(vp)
}
grid.draw(gt)
upViewport()
}
invisible(x)
}
#' @export
plot.patch <- print.patch
#' @export
has_tag.ggplot <- function(x) !is_empty(x)
patchwork/R/plot_patchwork.R 0000644 0001762 0000144 00000132607 14670774554 015674 0 ustar ligges users #' @importFrom grid grid.newpage grid.draw seekViewport pushViewport upViewport
#' @importFrom utils modifyList
#' @importFrom ggplot2 set_last_plot
#' @export
print.patchwork <- function(x, newpage = is.null(vp), vp = NULL, ...) {
if (newpage) grid.newpage()
grDevices::recordGraphics(
requireNamespace("patchwork", quietly = TRUE),
list(),
getNamespace("patchwork")
)
annotation <- modifyList(
default_annotation,
x$patches$annotation[!vapply(x$patches$annotation, is.null, logical(1))]
)
x <- recurse_tags(x, annotation$tag_levels, annotation$tag_prefix,
annotation$tag_suffix, annotation$tag_sep)$patches
plot <- get_patches(x)
gtable <- build_patchwork(plot, plot$layout$guides %||% 'auto')
gtable <- annotate_table(gtable, annotation)
set_last_plot(x)
if (!is.null(vp)) {
if (is.character(vp)) {
seekViewport(vp)
} else {
pushViewport(vp)
}
}
tryCatch(
grid.draw(gtable),
error = function(e) {
if (inherits(e, 'simpleError') && deparse(conditionCall(e)[[1]]) == 'grid.Call') {
if (Sys.getenv("RSTUDIO") == "1") {
cli_abort(c("The RStudio {.field Plots} window may be too small to show this patchwork.",
i = "Please make the window larger.")
)
} else {
cli_abort(c("The viewport may be too small to show this patchwork.",
i = "Please make the window larger.")
)
}
}
}
)
if (!is.null(vp)) {
upViewport()
}
invisible(x)
}
#' @export
plot.patchwork <- print.patchwork
#' @export
length.patchwork <- function(x) {
length(x$patches$plots) + !is_empty(x)
}
#' @export
names.patchwork <- function(x) NULL
#' @export
`[[.patchwork` <- function(x, ..., exact = TRUE) {
ind <- ..1
if (!is.numeric(ind)) {
cli_abort('Patchworks can only be indexed with numeric indices')
}
n_patches <- length(x$patches$plots)
if (!is_empty(x) && ind[1] == n_patches + 1) {
plot <- x
plot$patches <- NULL
class(plot) <- setdiff(class(plot), 'patchwork')
} else {
if (ind > n_patches) {
cli_abort('Index out of bounds')
}
plot <- x$patches$plots[[ind[1]]]
}
if (length(ind) > 1) {
if (!is_patchwork(plot)) {
cli_abort('Can only do nested indexing into patchworks')
}
plot <- plot[[ind[-1]]]
}
plot
}
#' @export
`[[<-.patchwork` <- function(x, ..., value) {
ind <- ..1
if (!is.numeric(ind)) {
cli_abort('Patchworks can only be indexed with numeric indices')
}
if (!is.ggplot(value)) {
value <- wrap_elements(value)
}
n_patches <- length(x$patches$plots)
if (!is_empty(x) && ind == n_patches + 1) {
if (length(ind) != 1) {
cli_abort('Can only do nested indexing into patchworks')
}
return(add_patches(value, x$patches))
}
if (length(ind) > 1) {
if (!is_patchwork(x$patches$plots[[ind[1]]])) {
cli_abort('Can only do nested indexing into patchworks')
}
x$patches$plots[[ind[1]]][[ind[-1]]] <- value
} else {
x$patches$plots[[ind]] <- value
}
x
}
#' @export
as.list.patchwork <- function(x, ...) {
get_patches(x)$plots
}
#' @importFrom utils str
#' @export
str.patchwork <- function(object, ...) {
n_patches <- length(object$patches$plots)
if (!is_empty(object)) n_patches <- n_patches + 1
cat('A patchwork composed of ', n_patches, ' patches\n', sep = '')
cat('- Autotagging is turned ', if (is.null(object$patches$annotation$tag_levels)) 'off' else 'on', '\n', sep = '')
cat('- Guides are ', if (isTRUE(object$patches$layout$guides == 'collect')) 'collected' else 'kept', '\n', sep = '')
cat('\n')
cat('Layout:\n')
if (is.null(object$layout$design)) {
l <- object$layout
if (is.null(l$ncol) && !is.null(l$widths) && length(l$widths) > 1) {
l$ncol <- length(l$widths)
}
if (is.null(l$nrow) && !is.null(l$heights) && length(l$heights) > 1) {
l$nrow <- length(l$heights)
}
dims <- wrap_dims(n_patches, nrow = l$nrow, ncol = l$ncol)
print(create_design(dims[2], dims[1], isTRUE(l$byrow)))
} else {
print(object$layout$design)
}
}
#' @importFrom ggplot2 ggplot_build ggplot_gtable panel_rows panel_cols wrap_dims
#' @importFrom gtable gtable
#' @importFrom grid unit unit.pmax is.unit
#' @importFrom utils modifyList
#' @importFrom stats na.omit
build_patchwork <- function(x, guides = 'auto') {
x$layout <- modifyList(default_layout, x$layout[!vapply(x$layout, is.null, logical(1))])
guides <- if (guides == 'collect' && x$layout$guides != 'keep') {
'collect'
} else {
x$layout$guides
}
gt <- lapply(x$plots, plot_table, guides = guides)
guide_grobs <- unlist(lapply(gt, `[[`, 'collected_guides'), recursive = FALSE)
gt <- lapply(gt, simplify_gt)
gt <- add_insets(gt)
fixed_asp <- vapply(gt, function(x) isTRUE(x$respect), logical(1))
if (is.null(x$layout$design)) {
if (is.null(x$layout$ncol) && !is.null(x$layout$widths) && length(x$layout$widths) > 1) {
x$layout$ncol <- length(x$layout$widths)
}
if (is.null(x$layout$nrow) && !is.null(x$layout$heights) && length(x$layout$heights) > 1) {
x$layout$nrow <- length(x$layout$heights)
}
dims <- wrap_dims(length(gt), nrow = x$layout$nrow, ncol = x$layout$ncol)
x$layout$design <- create_design(dims[2], dims[1], isTRUE(x$layout$byrow))
} else {
dims <- c(
max(x$layout$design$b),
max(x$layout$design$r)
)
}
gt_new <- gtable(unit(rep(0, TABLE_COLS * dims[2]), 'null'),
unit(rep(0, TABLE_ROWS * dims[1]), 'null'))
design <- as.data.frame(unclass(x$layout$design))
if (nrow(design) < length(gt)) {
warning('Too few patch areas to hold all plots. Dropping plots', call. = FALSE)
gt <- gt[seq_len(nrow(design))]
fixed_asp <- fixed_asp[seq_len(nrow(design))]
} else {
design <- design[seq_along(gt), ]
}
if (any(design$t < 1)) design$t[design$t < 1] <- 1
if (any(design$l < 1)) design$l[design$l < 1] <- 1
if (any(design$b > dims[1])) design$b[design$b > dims[1]] <- dims[1]
if (any(design$r > dims[2])) design$r[design$r > dims[2]] <- dims[2]
max_z <- lapply(gt, function(x) max(x$layout$z))
max_z <- c(0, cumsum(max_z))
gt_new$layout <- exec(rbind, !!!lapply(seq_along(gt), function(i) {
loc <- design[i, ]
lay <- gt[[i]]$layout
lay$z <- lay$z + ifelse(lay$name == "background", 0, max_z[i])
lay$t <- lay$t + ifelse(lay$t <= PANEL_ROW, (loc$t - 1) * TABLE_ROWS, (loc$b - 1) * TABLE_ROWS)
lay$l <- lay$l + ifelse(lay$l <= PANEL_COL, (loc$l - 1) * TABLE_COLS, (loc$r - 1) * TABLE_COLS)
lay$b <- lay$b + ifelse(lay$b < PANEL_ROW, (loc$t - 1) * TABLE_ROWS, (loc$b - 1) * TABLE_ROWS)
lay$r <- lay$r + ifelse(lay$r < PANEL_COL, (loc$l - 1) * TABLE_COLS, (loc$r - 1) * TABLE_COLS)
lay$name <- paste0(lay$name, '-', i)
lay
}))
table_dimensions <- table_dims(
lapply(gt, `[[`, 'widths'),
lapply(gt, `[[`, 'heights'),
design,
dims[2],
dims[1]
)
gt_new$grobs <- set_grob_sizes(gt, table_dimensions$widths, table_dimensions$heights, design)
gt_new$widths <- table_dimensions$widths
gt_new$heights <- table_dimensions$heights
widths <- rep(x$layout$widths, length.out = dims[2])
heights <- rep(x$layout$heights, length.out = dims[1])
gt_new <- set_panel_dimensions(gt_new, gt, widths, heights, fixed_asp, design)
if (x$layout$guides == 'collect') {
guide_grobs <- collapse_guides(guide_grobs)
if (length(guide_grobs) != 0) {
theme <- x$annotation$theme
if (!attr(theme, 'complete')) {
theme <- theme_get() + theme
}
position <- theme$legend.position %||% "right"
if (length(position) == 2) {
warning("Manual legend position not possible for collected guides. Defaulting to 'right'", call. = FALSE)
position <- "right"
}
guide_grobs <- assemble_guides(guide_grobs, position, theme)
gt_new <- attach_guides(gt_new, guide_grobs, position, theme)
}
} else {
gt_new$collected_guides <- guide_grobs
}
axes <- x$layout$axes %||% default_layout$axes
if (axes %in% c('collect', 'collect_x')) {
gt_new <- collect_axes(gt_new, "x")
}
if (axes %in% c('collect', 'collect_y')) {
gt_new <- collect_axes(gt_new, "y")
}
titles <- x$layout$axis_titles %||% default_layout$axis_titles
if (titles %in% c('collect', 'collect_x')) {
gt_new <- collect_axis_titles(gt_new, "x", merge = TRUE)
}
if (titles %in% c('collect', 'collect_y')) {
gt_new <- collect_axis_titles(gt_new, "y", merge = TRUE)
}
gt_new <- gtable_add_grob(
gt_new, zeroGrob(),
t = PANEL_ROW,
l = PANEL_COL,
b = PANEL_ROW + TABLE_ROWS * (dims[1] - 1),
r = PANEL_COL + TABLE_COLS * (dims[2] - 1),
z = -1,
name = "panel-area"
)
class(gt_new) <- c('gtable_patchwork', class(gt_new))
gt_new
}
#' Convert a patchwork to a gtable
#'
#' This function is the patchwork analogue of [ggplot2::ggplotGrob()] in that it
#' takes an unevaluated patchwork object and fixate it into a gtable object to
#' further manipulate directly.
#'
#' @param x A `patchwork` object
#'
#' @return A `gtable` object
#'
#' @keywords internal
#' @importFrom utils modifyList
#' @export
#'
patchworkGrob <- function(x) {
annotation <- modifyList(
default_annotation,
x$patches$annotation[!vapply(x$patches$annotation, is.null, logical(1))]
)
x <- recurse_tags(x, annotation$tag_levels, annotation$tag_prefix,
annotation$tag_suffix, annotation$tag_sep)$patches
plot <- get_patches(x)
gtable <- build_patchwork(plot)
gtable <- annotate_table(gtable, annotation)
class(gtable) <- setdiff(class(gtable), 'gtable_patchwork')
gtable
}
plot_table <- function(x, guides) {
UseMethod('plot_table')
}
#' @importFrom ggplot2 ggplotGrob
#' @export
plot_table.ggplot <- function(x, guides) {
gt <- ggplotGrob(x)
gt <- add_strips(gt)
add_guides(gt, guides == 'collect')
}
#' @export
plot_table.patchwork <- function(x, guides) {
if (is_free_plot(x)) {
plot_table.free_plot(x, guides)
} else {
build_patchwork(get_patches(x), guides)
}
}
#' @export
plot_table.patch <- function(x, guides) {
patchGrob(x, guides)
}
#' @export
plot_table.inset_patch <- function(x, guides) {
settings <- attr(x, 'inset_settings')
class(x) <- setdiff(class(x), 'inset_patch')
table <- plot_table(x, guides)
table$vp <- viewport(x = settings$left, y = settings$bottom,
width = settings$right - settings$left,
height = settings$top - settings$bottom,
just = c(0, 0))
attr(table, 'inset_settings') <- settings
class(table) <- c('inset_table', class(table))
table
}
#' @export
plot_table.free_plot <- function(x, guides) {
if (is_patchwork(x)) {
settings <- attr(x, 'patchwork_free_settings')
# We do this directly because the last plot in the patchwork might be free
# so we don't want to remove the free class and dispatch
table <- build_patchwork(get_patches(x), guides)
} else {
settings <- attr(x, 'free_settings')
class(x) <- setdiff(class(x), 'free_plot')
table <- plot_table(x, guides)
}
attr(table, 'free_settings') <- settings
class(table) <- c('free_table', class(table))
table
}
simplify_gt <- function(gt) {
UseMethod('simplify_gt')
}
#' @importFrom gtable gtable_add_grob gtable_add_rows gtable_add_cols
#' @importFrom ggplot2 find_panel
#' @importFrom grid unit convertWidth convertHeight
#' @export
simplify_gt.gtable <- function(gt) {
guides <- gt$collected_guides
gt$collected_guides <- NULL
panel_pos <- find_panel(gt)
rows <- c(panel_pos$t, panel_pos$b)
cols <- c(panel_pos$l, panel_pos$r)
if (!gt$respect && rows[1] == rows[2] && cols[1] == cols[2] && !any(grepl('^strip-', gt$layout$name))) {
gt$widths <- convertWidth(gt$widths, 'mm')
gt$heights <- convertHeight(gt$heights, 'mm')
return(gt)
}
p_rows <- seq(rows[1], rows[2])
p_cols <- seq(cols[1], cols[2])
panels <- gt[p_rows, p_cols]
gt_new <- gt[-p_rows, -p_cols]
gt_new$widths <- convertWidth(gt$widths[-p_cols], 'mm')
if (all(is_abs_unit(gt$widths[p_cols]))) {
new_width <- sum(convertWidth(gt$widths[p_cols], 'mm'))
} else {
new_width <- unit(1, 'null')
}
gt_new$heights <- convertHeight(gt$heights[-p_rows], 'mm')
if (all(is_abs_unit(gt$heights[p_rows]))) {
new_height <- sum(convertHeight(gt$heights[p_rows], 'mm'))
} else {
new_height <- unit(1, 'null')
}
gt_new <- gtable_add_rows(gt_new, new_height, rows[1] - 1)
gt_new <- gtable_add_cols(gt_new, new_width, cols[1] - 1)
if (gt$respect) {
gt_new <- simplify_fixed(gt, gt_new, panels, rows, cols)
} else {
gt_new <- simplify_free(gt, gt_new, panels, rows, cols)
}
gt_new$collected_guides <- guides
gt_new
}
#' @importFrom grid unit.c unit
#' @importFrom ggplot2 find_panel
#' @importFrom gtable gtable gtable_add_grob
#' @export
simplify_gt.gtable_patchwork <- function(gt) {
guides <- gt$collected_guides
gt$collected_guides <- NULL
panel_pos <- find_panel(gt)
if (all(is_abs_unit(gt$widths[panel_pos$l:panel_pos$r]))) {
new_width <- sum(convertWidth(gt$widths[panel_pos$l:panel_pos$r], 'mm'))
} else {
new_width <- unit(1, 'null')
}
if (all(is_abs_unit(gt$heights[panel_pos$t:panel_pos$b]))) {
new_height <- sum(convertHeight(gt$widths[panel_pos$t:panel_pos$b], 'mm'))
} else {
new_height <- unit(1, 'null')
}
widths <- unit.c(gt$widths[seq_len(panel_pos$l - 1)], new_width, gt$widths[seq(panel_pos$r + 1, ncol(gt))])
heights <- unit.c(gt$heights[seq_len(panel_pos$t - 1)], new_height, gt$heights[seq(panel_pos$b + 1, nrow(gt))])
gt_new <- gtable(widths = widths, heights = heights)
gt_new <- gtable_add_grob(gt_new, zeroGrob(), PANEL_ROW, PANEL_COL, name = 'panel-nested-patchwork')
gt_new <- gtable_add_grob(gt_new, gt, 1, 1, nrow(gt_new), ncol(gt_new), clip = 'off', name = 'patchwork-table')
class(gt_new) <- c('gtable_patchwork_simple', class(gt_new))
gt_new$collected_guides <- guides
gt_new
}
#' @export
simplify_gt.patchgrob <- function(gt) gt
#' @export
simplify_gt.inset_table <- function(gt) gt
#' @export
simplify_gt.free_table <- function(gt) {
settings <- attr(gt, "free_settings")
settings <- split(names(settings), settings)
gt_new <- NextMethod()
if (!is.null(settings$label)) {
gt_new <- free_label(gt_new, c("t", "r", "b", "l") %in% settings$label)
}
if (!is.null(settings$space)) {
gt_new <- free_space(gt_new, c("t", "r", "b", "l") %in% settings$space)
}
if (!is.null(settings$panel)) {
gt_new <- free_panel(gt_new, c("t", "r", "b", "l") %in% settings$panel)
}
gt_new
}
#' @importFrom gtable gtable_add_grob is.gtable
#' @importFrom grid viewport
simplify_free <- function(gt, gt_new, panels, rows, cols) {
p_cols <- seq(cols[1], cols[2])
if (length(p_cols) == 1) {
top <- which(gt$layout$l == p_cols & gt$layout$r == p_cols & gt$layout$b < rows[1])
gt_new <- gtable_add_grob(gt_new, gt$grobs[top], gt$layout$t[top], p_cols,
gt$layout$b[top], z = gt$layout$z[top],
clip = gt$layout$clip[top], name = gt$layout$name[top])
bottom <- which(gt$layout$l == p_cols & gt$layout$r == p_cols & gt$layout$t > rows[2])
b_mod <- rows[2] - rows[1]
gt_new <- gtable_add_grob(gt_new, gt$grobs[bottom], gt$layout$t[bottom] - b_mod,
p_cols, gt$layout$b[bottom] - b_mod, z = gt$layout$z[bottom],
clip = gt$layout$clip[bottom], name = gt$layout$name[bottom])
t_strips <- grepl('^strip-t-', gt_new$layout$name)
if (any(t_strips)) {
gt_new$grobs[t_strips] <- lapply(gt_new$grobs[t_strips], function(g) {
if (is.gtable(g)) {
g$vp <- viewport(y = 0, just = 'bottom', height = sum(g$heights))
}
g
})
}
b_strips <- grepl('^strip-b-', gt_new$layout$name)
if (any(b_strips)) {
gt_new$grobs[b_strips] <- lapply(gt_new$grobs[b_strips], function(g) {
if (is.gtable(g)) {
g$vp <- viewport(y = 1, just = 'top', height = sum(g$heights))
}
g
})
}
} else {
for (i in seq_len(nrow(gt))) {
if (i >= rows[1]) {
if (i <= rows[2]) next
ii <- i - diff(rows)
pos <- 'bottom'
} else {
ii <- i
pos <- 'top'
}
table <- gt[i, p_cols]
if (length(table$grobs) != 0) {
grobname <- paste(table$layout$name, collapse = ', ')
if (pos == 'top') {
table$vp <- viewport(y = 0, just = 'bottom', height = table$heights)
} else {
table$vp <- viewport(y = 1, just = 'top', height = table$heights)
}
gt_new <- gtable_add_grob(gt_new, table, ii, cols[1], clip = 'off',
name = grobname, z = max(table$layout$z))
}
}
}
p_rows <- seq(rows[1], rows[2])
if (length(p_rows) == 1) {
left <- which(gt$layout$t == p_rows & gt$layout$b == p_rows & gt$layout$r < cols[1])
gt_new <- gtable_add_grob(gt_new, gt$grobs[left], p_rows, gt$layout$l[left], p_rows,
gt$layout$r[left], z = gt$layout$z[left],
clip = gt$layout$clip[left], name = gt$layout$name[left])
right <- which(gt$layout$t == p_rows & gt$layout$b == p_rows & gt$layout$l > cols[2])
r_mod <- cols[2] - cols[1]
gt_new <- gtable_add_grob(gt_new, gt$grobs[right], p_rows, gt$layout$l[right] - r_mod,
p_rows, gt$layout$r[right] - r_mod, z = gt$layout$z[right],
clip = gt$layout$clip[right], name = gt$layout$name[right])
l_strips <- grepl('^strip-l-', gt_new$layout$name)
if (any(l_strips)) {
gt_new$grobs[l_strips] <- lapply(gt_new$grobs[l_strips], function(g) {
if (is.gtable(g)) {
g$vp <- viewport(x = 1, just = 'right', width = sum(g$widths))
}
g
})
}
r_strips <- grepl('^strip-r-', gt_new$layout$name)
if (any(r_strips)) {
gt_new$grobs[r_strips] <- lapply(gt_new$grobs[r_strips], function(g) {
if (is.gtable(g)) {
g$vp <- viewport(x = 0, just = 'left', width = sum(g$widths))
}
g
})
}
} else {
for (i in seq_len(ncol(gt))) {
if (i >= cols[1]) {
if (i <= cols[2]) next
ii <- i - diff(cols)
pos <- 'right'
} else {
ii <- i
pos <- 'left'
}
table <- gt[p_rows, i]
if (length(table$grobs) != 0) {
grobname <- paste(table$layout$name, collapse = ', ')
if (pos == 'left') {
table$vp <- viewport(x = 1, just = 'right', width = table$widths)
} else {
table$vp <- viewport(x = 0, just = 'left', width = table$widths)
}
gt_new <- gtable_add_grob(gt_new, table, rows[1], ii, clip = 'off',
name = grobname, z = max(table$layout$z))
}
}
}
panel_name <- paste0('panel; ', paste(panels$layout$name, collapse = ', '))
gtable_add_grob(gt_new, panels, rows[1], cols[1], clip = 'off', name = panel_name, z = 1)
}
#' @importFrom grid viewport unit convertWidth convertHeight
#' @importFrom gtable gtable_add_grob
simplify_fixed <- function(gt, gt_new, panels, rows, cols) {
p_rows <- seq(rows[1], rows[2])
p_cols <- seq(cols[1], cols[2])
left <- gt$layout$l[grep('-l(-|$)', gt$layout$name)]
right <- gt$layout$r[grep('-r(-|$)', gt$layout$name)]
top <- gt$layout$t[grep('-t(-|$)', gt$layout$name)]
bottom <- gt$layout$b[grep('-b(-|$)', gt$layout$name)]
# Add strips, axes and labels to panel grob
if (length(left) != 0 && min(left) < cols[1]) {
left_grob <- gt[p_rows, seq(min(left), cols[1] - 1)]
h_width <- unit(sum(convertWidth(left_grob$widths, 'mm', TRUE))/2, 'mm')
left_grob$vp <- viewport(x = unit(0, 'npc') - h_width)
panels <- gtable_add_grob(panels, grobs = list(left_grob),
t = 1, l = 1, b = nrow(panels), r = ncol(panels),
z = Inf, clip = 'off', name = 'left-l')
}
if (length(right) != 0 && max(right) > cols[2]) {
right_grob <- gt[p_rows, seq(cols[2] + 1, max(right))]
h_width <- unit(sum(convertWidth(right_grob$widths, 'mm', TRUE))/2, 'mm')
right_grob$vp <- viewport(x = unit(1, 'npc') + h_width)
panels <- gtable_add_grob(panels, grobs = list(right_grob),
t = 1, l = 1, b = nrow(panels), r = ncol(panels),
z = Inf, clip = 'off', name = 'right-r')
}
if (length(top) != 0 && min(top) < rows[1]) {
top_grob <- gt[seq(min(top), rows[1] - 1), p_cols]
h_height <- unit(sum(convertHeight(top_grob$heights, 'mm', TRUE))/2, 'mm')
top_grob$vp <- viewport(y = unit(1, 'npc') + h_height)
panels <- gtable_add_grob(panels, grobs = list(top_grob),
t = 1, l = 1, b = nrow(panels), r = ncol(panels),
z = Inf, clip = 'off', name = 'top-t')
}
if (length(bottom) != 0 && max(bottom) > rows[2]) {
bottom_grob <- gt[seq(rows[2] + 1, max(bottom)), p_cols]
h_height <- unit(sum(convertHeight(bottom_grob$heights, 'mm', TRUE))/2, 'mm')
bottom_grob$vp <- viewport(y = unit(0, 'npc') - h_height)
panels <- gtable_add_grob(panels, grobs = list(bottom_grob),
t = 1, l = 1, b = nrow(panels), r = ncol(panels),
z = Inf, clip = 'off', name = 'bottom-b')
}
# Add remaining grobs to gt_new
left <- if (length(left) != 0) min(left) else cols[1]
for (i in seq_len(left - 1)) {
table <- gt[p_rows, i]
if (length(table$grobs) != 0) {
if (length(table$grobs) == 1) {
grobname <- table$layout$name
grob <- table$grobs[[1]]
} else {
grobname <- paste(table$layout$name, collapse = ', ')
grob <- table
}
gt_new <- gtable_add_grob(gt_new, grob, rows[1], i, clip = 'off', name = grobname, z = max(table$layout$z))
}
}
right <- if (length(right) != 0) max(right) else cols[2]
for (i in seq_len(ncol(gt) - right)) {
table <- gt[p_rows, i + right]
if (length(table$grobs) != 0) {
if (length(table$grobs) == 1) {
grobname <- table$layout$name
grob <- table$grobs[[1]]
} else {
grobname <- paste(table$layout$name, collapse = ', ')
grob <- table
}
gt_new <- gtable_add_grob(gt_new, grob, rows[1], i + cols[1] + right - cols[2], clip = 'off', name = grobname, z = max(table$layout$z))
}
}
top <- if (length(top) != 0) min(top) else rows[1]
for (i in seq_len(top - 1)) {
table <- gt[i, p_cols]
if (length(table$grobs) != 0) {
if (length(table$grobs) == 1) {
grobname <- table$layout$name
grob <- table$grobs[[1]]
} else {
grobname <- paste(table$layout$name, collapse = ', ')
grob <- table
}
gt_new <- gtable_add_grob(gt_new, grob, i, cols[1], clip = 'off', name = grobname, z = max(table$layout$z))
}
}
bottom <- if (length(bottom) != 0) max(bottom) else rows[2]
for (i in seq_len(nrow(gt) - bottom)) {
table <- gt[i + bottom, p_cols]
if (length(table$grobs) != 0) {
if (length(table$grobs) == 1) {
grobname <- table$layout$name
grob <- table$grobs[[1]]
} else {
grobname <- paste(table$layout$name, collapse = ', ')
grob <- table
}
gt_new <- gtable_add_grob(gt_new, grob, i + rows[1] + bottom - rows[2], cols[1], clip = 'off', name = grobname, z = max(table$layout$z))
}
}
panel_name <- paste0('panel; ', paste(panels$layout$name, collapse = ', '))
gtable_add_grob(gt_new, panels, rows[1], cols[1], clip = 'off', name = panel_name, z = 1)
}
free_panel <- function(gt, has_side) {
nested <- grep("patchwork-table", gt$layout$name)
for (i in nested) {
loc <- gt$layout[i, ]
loc <- c(loc$t, loc$r, loc$b, loc$l) == c(1, ncol(gt), nrow(gt), 1) & has_side
if (!any(loc)) next
gt$grobs[[i]] <- free_panel(gt$grobs[[i]], loc)
}
top <- if (has_side[1]) 3 else PANEL_ROW
right <- ncol(gt) - if (has_side[2]) 2 else TABLE_COLS - PANEL_COL
bottom <- nrow(gt) - if (has_side[3]) 2 else TABLE_ROWS - PANEL_ROW
left <- if (has_side[4]) 3 else PANEL_COL
panel_col_pos <- seq(0, by = TABLE_COLS, length.out = floor(ncol(gt) / TABLE_COLS)) + PANEL_COL
panel_row_pos <- seq(0, by = TABLE_ROWS, length.out = floor(nrow(gt) / TABLE_ROWS)) + PANEL_ROW
panel_width <- gt$widths[panel_col_pos]
panel_height <- gt$heights[panel_row_pos]
gt$widths[panel_col_pos][as.numeric(panel_width) == 0] <- unit(1, "null")
gt$heights[panel_row_pos][as.numeric(panel_height) == 0] <- unit(1, "null")
# Fixed aspect plots needs special treatment
if (isTRUE(gt$respect)) {
p_i <- grep("panel;", gt$layout$name)
if (has_side[1]) {
h <- gt$grobs[[p_i]]$grobs[[grep("top", gt$grobs[[p_i]]$layout$name)]]
gt$grobs[[p_i]] <- gtable_add_rows(gt$grobs[[p_i]], sum(h$heights), pos = 0)
gt$layout$t[p_i] <- top
}
if (has_side[2]) {
w <- gt$grobs[[p_i]]$grobs[[grep("right", gt$grobs[[p_i]]$layout$name)]]
gt$grobs[[p_i]] <- gtable_add_cols(gt$grobs[[p_i]], sum(w$widths), pos = -1)
gt$layout$r[p_i] <- right
}
if (has_side[3]) {
h <- gt$grobs[[p_i]]$grobs[[grep("bottom", gt$grobs[[p_i]]$layout$name)]]
gt$grobs[[p_i]] <- gtable_add_rows(gt$grobs[[p_i]], sum(h$heights), pos = -1)
gt$layout$b[p_i] <- bottom
}
if (has_side[4]) {
w <- gt$grobs[[p_i]]$grobs[[grep("left", gt$grobs[[p_i]]$layout$name)]]
gt$grobs[[p_i]] <- gtable_add_cols(gt$grobs[[p_i]], sum(w$widths), pos = 0)
gt$layout$l[p_i] <- left
}
} else {
gt <- liberate_area(gt, top, right, bottom, left, "free_panel")
}
if (!has_side[1] && (has_side[2] || has_side[4])) {
gt <- liberate_rows(gt, 3, right, top - 1, left, align = 0, "free_row")
}
if (!has_side[2] && (has_side[1] || has_side[3])) {
gt <- liberate_cols(gt, top, ncol(gt) - 2, bottom, right + 1, align = 0, "free_col")
}
if (!has_side[3] && (has_side[2] || has_side[4])) {
gt <- liberate_rows(gt, bottom + 1, right, nrow(gt) - 2, left, align = 1, "free_row")
}
if (!has_side[4] && (has_side[1] || has_side[3])) {
gt <- liberate_cols(gt, top, left - 1, bottom, 3, align = 1, "free_col")
}
old_free <- grepl("free_panel-", gt$layout$name) | grepl("free_row-", gt$layout$name) | grepl("free_col-", gt$layout$name)
if (any(old_free)) {
for (i in which(old_free)) {
loc <- unlist(gt$layout[i, c("t", "r", "b", "l")])
loc[has_side] <- c(top, right, bottom, left)[has_side]
gt_old <- gt
gt_old$grobs <- gt_old$grobs[i]
gt_old$layout <- gt_old$layout[i, ]
gt$grobs[[i]] <- gt_old[loc[1]:loc[3], loc[4]:loc[2]]
gt$layout[i, c("t", "r", "b", "l")] <- loc
}
}
gt$widths[setdiff(left:right, min(panel_col_pos):max(panel_col_pos))] <- unit(0, "mm")
gt$widths[panel_col_pos] <- panel_width
gt$heights[setdiff(top:bottom, min(panel_row_pos):max(panel_row_pos))] <- unit(0, "mm")
gt$heights[panel_row_pos] <- panel_height
gt
}
grob_in_rect <- function(gt, top, right, bottom, left) {
gt$layout$l >= left & gt$layout$t >= top & gt$layout$r <= right & gt$layout$b <= bottom
}
liberate_area <- function(gt, top, right, bottom, left, name = NULL, vp = NULL) {
liberated <- gt[top:bottom, left:right]
remove <- grob_in_rect(gt, top, right, bottom, left)
if (any(remove)) {
if (!is.null(vp)) liberated$vp <- vp
name <- name %||% paste(liberated$layout$name, collapse ="; ")
gt$grobs <- gt$grobs[!remove]
gt$layout <- gt$layout[!remove,]
gt <- gtable_add_grob(gt, liberated, top, left, bottom, right, max(liberated$layout$z), "inherit", name)
}
gt
}
liberate_rows <- function(gt, top, right, bottom, left, align = 0.5, name = NULL) {
liberate <- which(grob_in_rect(gt, top, right, bottom, left))
unique_rows <- unique(gt$layout[liberate, c("t", "b")])
for (i in seq_len(nrow(unique_rows))) {
gt <- liberate_area(gt, unique_rows$t[i], right, unique_rows$b[i], left, name, vp = viewport(y = align, height = sum(gt$heights[unique_rows$t[i]:unique_rows$b[i]]), just = c(0.5, align)))
}
gt
}
liberate_cols <- function(gt, top, right, bottom ,left, align = 0.5, name = NULL) {
liberate <- which(grob_in_rect(gt, top, right, bottom, left))
unique_cols <- unique(gt$layout[liberate, c("l", "r")])
for (i in seq_len(nrow(unique_cols))) {
gt <- liberate_area(gt, top, unique_cols$r[i], bottom, unique_cols$l[i], name, vp = viewport(x = align, width = sum(gt$widths[unique_cols$l[i]:unique_cols$r[i]]), just = c(align, 0.5)))
}
gt
}
free_label <- function(gt, has_side) {
# Fixed aspect plots already have this behaviour
if (isTRUE(gt$respect)) return(gt)
nested <- grep("patchwork-table", gt$layout$name)
for (i in nested) {
loc <- gt$layout[i, ]
loc <- c(loc$t, loc$r, loc$b, loc$l) == c(1, ncol(gt), nrow(gt), 1) & has_side
if (!any(loc)) next
gt$grobs[[i]] <- free_label(gt$grobs[[i]], loc)
}
panel_col_pos <- seq(0, by = TABLE_COLS, length.out = floor(ncol(gt) / TABLE_COLS)) + PANEL_COL
panel_row_pos <- seq(0, by = TABLE_ROWS, length.out = floor(nrow(gt) / TABLE_ROWS)) + PANEL_ROW
panel_width <- gt$widths[panel_col_pos]
panel_height <- gt$heights[panel_row_pos]
gt$widths[panel_col_pos][as.numeric(panel_width) == 0] <- unit(1, "null")
gt$heights[panel_row_pos][as.numeric(panel_height) == 0] <- unit(1, "null")
top <- PANEL_ROW
right <- ncol(gt) - (TABLE_COLS - PANEL_COL)
bottom <- nrow(gt) - (TABLE_ROWS - PANEL_ROW)
left <- PANEL_COL
if (has_side[1]) {
gt <- liberate_area(gt, top - 3, right, top - 1, left, vp = viewport(y = 0, height = sum(gt$heights[(top - 3):(top - 1)]), just = c(0.5, 0)))
}
if (has_side[2]) {
gt <- liberate_area(gt, top, right + 3, bottom, right + 1, vp = viewport(x = 0, width = sum(gt$widths[(right + 1):(right + 3)]), just = c(0, 0.5)))
}
if (has_side[3]) {
gt <- liberate_area(gt, bottom + 1, right, bottom + 3, left, vp = viewport(y = 1, height = sum(gt$heights[(bottom + 1):(bottom + 3)]), just = c(0.5, 1)))
}
if (has_side[4]) {
gt <- liberate_area(gt, top, left - 1, bottom, left - 3, vp = viewport(x = 1, width = sum(gt$widths[(left - 3):(left - 1)]), just = c(1, 0.5)))
}
gt$widths[panel_col_pos] <- panel_width
gt$heights[panel_row_pos] <- panel_height
gt
}
free_space <- function(gt, has_side) {
nested <- grep("patchwork-table", gt$layout$name)
for (i in nested) {
loc <- gt$layout[i, ]
loc <- c(loc$t, loc$r, loc$b, loc$l) == c(1, ncol(gt), nrow(gt), 1) & has_side
if (!any(loc)) next
gt$grobs[[i]] <- free_space(gt$grobs[[i]], loc)
}
panel_col_pos <- seq(0, by = TABLE_COLS, length.out = floor(ncol(gt) / TABLE_COLS)) + PANEL_COL
panel_row_pos <- seq(0, by = TABLE_ROWS, length.out = floor(nrow(gt) / TABLE_ROWS)) + PANEL_ROW
panel_width <- gt$widths[panel_col_pos]
panel_height <- gt$heights[panel_row_pos]
gt$widths[panel_col_pos][as.numeric(panel_width) == 0] <- unit(1, "null")
gt$heights[panel_row_pos][as.numeric(panel_height) == 0] <- unit(1, "null")
top <- PANEL_ROW
right <- ncol(gt) - (TABLE_COLS - PANEL_COL)
bottom <- nrow(gt) - (TABLE_ROWS - PANEL_ROW)
left <- PANEL_COL
if (has_side[1]) {
gt <- liberate_area(gt, 3, right, top - 1, left, vp = viewport(y = 0, height = sum(gt$heights[3:(top - 1)]), just = c(0.5, 0)))
gt$heights[3:(top - 1)] <- unit(0, "mm")
}
if (has_side[2]) {
gt <- liberate_area(gt, top, ncol(gt) - 2, bottom, right + 1, vp = viewport(x = 0, width = sum(gt$widths[(right + 1):(ncol(gt) - 2)]), just = c(0, 0.5)))
gt$widths[(right + 1):(ncol(gt) - 2)] <- unit(0, "mm")
}
if (has_side[3]) {
gt <- liberate_area(gt, bottom + 1, right, nrow(gt) - 2, left, vp = viewport(y = 1, height = sum(gt$heights[(bottom + 1):(nrow(gt) - 2)]), just = c(0.5, 1)))
gt$heights[(bottom + 1):(nrow(gt) - 2)] <- unit(0, "mm")
}
if (has_side[4]) {
gt <- liberate_area(gt, top, left - 1, bottom, 3, vp = viewport(x = 1, width = sum(gt$widths[3:(left - 1)]), just = c(1, 0.5)))
gt$widths[3:(left - 1)] <- unit(0, "mm")
}
gt$widths[panel_col_pos] <- panel_width
gt$heights[panel_row_pos] <- panel_height
gt
}
create_design <- function(width, height, byrow) {
mat <- matrix(seq_len(width * height), nrow = height, ncol = width, byrow = byrow)
ind <- as.vector(mat)
ind <- match(seq_along(ind), ind)
area(
t = row(mat)[ind],
l = col(mat)[ind]
)
}
#' @importFrom grid convertHeight convertWidth unit
table_dims <- function(widths, heights, areas, ncol, nrow) {
widths <- lapply(widths, convertWidth, 'mm', valueOnly = TRUE)
widths <- vapply(seq_len(ncol * TABLE_COLS), function(i) {
area <- (i - 1) %/% TABLE_COLS + 1
col_loc <- i %% TABLE_COLS
if (col_loc == 0) col_loc <- TABLE_COLS
area_side <- if (col_loc <= PANEL_COL) 'l' else 'r'
tables <- which(areas[[area_side]] == area)
if (length(tables) == 0) {
0
} else {
max(vapply(widths[tables], `[[`, numeric(1), col_loc), 0)
}
}, numeric(1))
heights <- lapply(heights, convertHeight, 'mm', valueOnly = TRUE)
heights <- vapply(seq_len(nrow * TABLE_ROWS), function(i) {
area <- (i - 1) %/% TABLE_ROWS + 1
row_loc <- i %% TABLE_ROWS
if (row_loc == 0) row_loc <- TABLE_ROWS
area_side <- if (row_loc <= PANEL_ROW) 't' else 'b'
tables <- which(areas[[area_side]] == area)
if (length(tables) == 0) {
0
} else {
max(vapply(heights[tables], `[[`, numeric(1), row_loc), 0)
}
}, numeric(1))
list(widths = unit(widths, 'mm'), heights = unit(heights, 'mm'))
}
set_grob_sizes <- function(tables, widths, heights, design) {
unlist(lapply(seq_along(tables), function(i) {
gt <- tables[[i]]
if (!inherits(gt, 'gtable_patchwork_simple')) {
return(gt$grobs)
}
table_loc <- design[i, , drop = FALSE]
l <- (table_loc$l - 1) * TABLE_COLS
l_widths <- widths[seq(l + 1, l + PANEL_COL - 1)]
r <- (table_loc$r - 1) * TABLE_COLS
r_widths <- widths[seq(r + PANEL_COL + 1, r + TABLE_COLS)]
t <- (table_loc$t - 1) * TABLE_ROWS
t_heights <- heights[seq(t + 1, t + PANEL_ROW - 1)]
b <- (table_loc$b - 1) * TABLE_ROWS
b_heights <- heights[seq(b + PANEL_ROW + 1, b + TABLE_ROWS)]
nested <- grep("patchwork-table", gt$layout$name)
gt$grobs[[nested]] <- set_border_sizes(gt$grobs[[nested]], l_widths, r_widths, t_heights, b_heights)
gt$grobs
}), recursive = FALSE)
}
set_border_sizes <- function(gt, l = NULL, r = NULL, t = NULL, b = NULL) {
if (is.null(l) && is.null(r) && is.null(t) && is.null(b)) return(gt)
if (!is.null(l)) gt$widths[seq_along(l)] <- l
if (!is.null(r)) gt$widths[seq(ncol(gt) - length(r) + 1, ncol(gt))] <- r
if (!is.null(t)) gt$heights[seq_along(t)] <- t
if (!is.null(b)) gt$heights[seq(nrow(gt) - length(b) + 1, nrow(gt))] <- b
gt$grobs <- lapply(seq_along(gt$grobs), function(i) {
grob <- gt$grobs[[i]]
if (!inherits(grob, 'gtable_patchwork')) {
return(grob)
}
set_border_sizes(
grob,
if (gt$layout$l[i] == 1) l else NULL,
if (gt$layout$r[i] == ncol(gt)) r else NULL,
if (gt$layout$t[i] == 1) t else NULL,
if (gt$layout$b[i] == nrow(gt)) b else NULL
)
})
gt
}
#' @importFrom gtable gtable_add_rows gtable_add_cols
#' @importFrom grid unit
#' @importFrom ggplot2 find_panel
add_strips <- function(gt) {
panel_loc <- find_panel(gt)
strip_pos <- switch(
find_strip_pos(gt),
inside = 0,
outside = 2
)
if (!any(grepl('strip-b', gt$layout$name))) {
gt <- gtable_add_rows(gt, unit(0, 'mm'), panel_loc$b + strip_pos)
} else if (strip_pos == 2 && !any(gt$layout$b == panel_loc$b + 2)) {
# Merge the strip-gap height into the axis and remove it. Only performed if
# an axis exist
gt$heights[panel_loc$b + 1] <- sum(gt$heights[panel_loc$b + c(1, 2)])
gt <- gt[-(panel_loc$b + 2), ]
}
if (!any(grepl('strip-t', gt$layout$name))) {
gt <- gtable_add_rows(gt, unit(0, 'mm'), panel_loc$t - 1 - strip_pos)
} else if (strip_pos == 2 && !any(gt$layout$t == panel_loc$t - 2)) {
gt$heights[panel_loc$t - 1] <- sum(gt$heights[panel_loc$t - c(1, 2)])
gt <- gt[-(panel_loc$t - 2), ]
}
if (!any(grepl('strip-r', gt$layout$name))) {
gt <- gtable_add_cols(gt, unit(0, 'mm'), panel_loc$r + strip_pos)
} else if (strip_pos == 2 && !any(gt$layout$r == panel_loc$r + 2)) {
gt$widths[panel_loc$r + 1] <- sum(gt$widths[panel_loc$r + c(1, 2)])
gt <- gt[, -(panel_loc$r + 2)]
}
if (!any(grepl('strip-l', gt$layout$name))) {
gt <- gtable_add_cols(gt, unit(0, 'mm'), panel_loc$l - 1 - strip_pos)
} else if (strip_pos == 2 && !any(gt$layout$l == panel_loc$l - 2)) {
gt$widths[panel_loc$l - 1] <- sum(gt$widths[panel_loc$l - c(1, 2)])
gt <- gt[, -(panel_loc$l - 2)]
}
gt
}
#' @importFrom gtable gtable_add_rows gtable_add_cols
#' @importFrom grid unit
add_guides <- function(gt, collect = FALSE) {
panel_loc <- find_panel(gt)[, c('t', 'l', 'b', 'r')]
guide_ind <- which(grepl('guide-box', gt$layout$name))
if (length(guide_ind) == 5) {
# For ggplot2 >3.5.0, we don't need to add extra space for missing legends,
# as every position already has relevant cells in the gtable.
if (!collect) {
return(gt)
}
# We need to collect guides from multiple cells in the gtable instead.
guide_loc <- gt$layout[guide_ind, ]
guide_pos <- gsub("guide-box-", "", guide_loc$name)
# Set space for guides to zero
space_pos <- ifelse(guide_pos %in% c('left', 'top'), 1L, -1L)
lr <- guide_pos %in% c('left', 'right')
col <- guide_loc$l[lr]
gt$widths[c(col, col + space_pos[lr])] <- unit(0, "mm")
tb <- guide_pos %in% c('top', 'bottom')
row <- guide_loc$t[tb]
gt$heights[c(row, row + space_pos[tb])] <- unit(0, "mm")
# Collect guides
collection <- lapply(gt$grobs[guide_ind], function(box) {
box$grobs[grepl('guides', box$layout$name)] # NULL if legend is empty
})
collection <- unlist(collection, recursive = FALSE) # drops NULL
gt$collected_guides <- collection
# Remove guides from gtable
gt$grobs[guide_ind] <- NULL
gt$layout <- gt$layout[-guide_ind, ]
return(gt)
}
guide_loc <- gt$layout[guide_ind, c('t', 'l', 'b', 'r')]
guide_pos <- if (nrow(guide_loc) == 0) {
'none'
} else if (all(unlist(guide_loc == panel_loc))) {
'inside'
} else {
if (panel_loc$t == guide_loc$t) {
if (panel_loc$l > guide_loc$l) {
'left'
} else {
'right'
}
} else {
if (panel_loc$t > guide_loc$t) {
'top'
} else {
'bottom'
}
}
}
if (guide_pos != 'right') {
gt <- gtable_add_cols(gt, unit(c(0, 0), 'mm'), panel_loc$r + 3)
}
if (guide_pos != 'left') {
gt <- gtable_add_cols(gt, unit(c(0, 0), 'mm'), panel_loc$l - 4)
}
if (guide_pos != 'bottom') {
gt <- gtable_add_rows(gt, unit(c(0, 0), 'mm'), panel_loc$b + 5)
}
if (guide_pos != 'top') {
gt <- gtable_add_rows(gt, unit(c(0, 0), 'mm'), panel_loc$t - 4)
}
if (collect && guide_pos != 'none') {
guide_grob <- gt$grobs[[guide_ind]]
guide_loc <- gt$layout[guide_ind, ] # May have changed above
space_pos <- if (guide_pos %in% c('left', 'top')) 1 else -1
if (guide_pos %in% c('right', 'left')) {
gt$widths[c(guide_loc$l, guide_loc$l + space_pos)] <- unit(c(0, 0), 'mm')
} else if (guide_pos %in% c('bottom', 'top')) {
gt$heights[c(guide_loc$t, guide_loc$t + space_pos)] <- unit(c(0, 0), 'mm')
}
gt$grobs[guide_ind] <- NULL
gt$layout <- gt$layout[-guide_ind, ]
gt$collected_guides <- guide_grob$grobs[grepl('guides', guide_grob$layout$name)]
}
gt
}
find_strip_pos <- function(gt) {
panel_loc <- find_panel(gt)
ind <- grep('strip-t', gt$layout$name)
if (length(ind) != 0 && panel_loc$t - min(gt$layout$t[ind]) != 1) {
return('outside')
}
ind <- grep('strip-r', gt$layout$name)
if (length(ind) != 0 && max(gt$layout$r[ind]) - panel_loc$r != 1) {
return('outside')
}
ind <- grep('strip-b', gt$layout$name)
if (length(ind) != 0 && max(gt$layout$b[ind]) - panel_loc$b != 1) {
return('outside')
}
ind <- grep('strip-l', gt$layout$name)
if (length(ind) != 0 && panel_loc$l - min(gt$layout$l[ind]) != 1) {
return('outside')
}
'inside'
}
set_panel_dimensions <- function(gt, panels, widths, heights, fixed_asp, design) {
width_ind <- seq(PANEL_COL, by = TABLE_COLS, length.out = length(widths))
height_ind <- seq(PANEL_ROW, by = TABLE_ROWS, length.out = length(heights))
if (!is.unit(widths)) {
widths[is.na(widths)] <- -1
widths <- unit(widths, 'null')
}
width_strings <- as.character(widths)
if (!is.unit(heights)) {
heights[is.na(heights)] <- -1
heights <- unit(heights, 'null')
}
height_strings <- as.character(heights)
panel_widths <- do.call(unit.c, lapply(panels, function(x) x$widths[PANEL_COL]))
absolute_col <- is_abs_unit(panel_widths) & as.numeric(panel_widths) != 0
if (any(absolute_col)) {
pos <- ifelse(absolute_col & design$l == design$r & width_strings[design$l] == "-1null", design$l, NA)
fixed_widths <- lapply(split(panel_widths, pos), "max")
widths[as.numeric(names(fixed_widths))] <- do.call(unit.c, fixed_widths)
width_strings <- as.character(widths)
}
panel_heights <- do.call(unit.c, lapply(panels, function(x) x$heights[PANEL_ROW]))
absolute_row <- is_abs_unit(panel_heights) & as.numeric(panel_heights) != 0
if (any(absolute_row)) {
pos <- ifelse(absolute_row & design$t == design$b & height_strings[design$t] == "-1null", design$t, NA)
fixed_heights <- lapply(split(panel_heights, pos), "max")
heights[as.numeric(names(fixed_heights))] <- do.call(unit.c, fixed_heights)
height_strings <- as.character(heights)
}
if (any(width_strings == '-1null') && any(height_strings == '-1null')) {
respect <- matrix(0, nrow = length(gt$heights), ncol = length(gt$widths))
fixed_areas <- lapply(which(fixed_asp), function(i) {
list(
rows = seq(design$t[i], design$b[i]),
cols = seq(design$l[i], design$r[i])
)
})
can_fix <- vapply(fixed_areas, function(x) length(x$rows) == 1 && length(x$cols), logical(1))
can_fix_row <- vapply(fixed_areas, function(x) all(grepl('null$', height_strings[x$rows])), logical(1))
can_fix_col <- vapply(fixed_areas, function(x) all(grepl('null$', width_strings[x$cols])), logical(1))
fixed_areas <- fixed_areas[can_fix & (can_fix_row & can_fix_col)]
fixed_gt <- which(fixed_asp)[can_fix & (can_fix_row & can_fix_col)]
all_fixed_rows <- table(unlist(lapply(fixed_areas, `[[`, 'rows')))
all_fixed_cols <- table(unlist(lapply(fixed_areas, `[[`, 'cols')))
controls_dim <- vapply(fixed_areas, function(a) {
all(all_fixed_rows[as.character(a$rows)] == 1) || all(all_fixed_cols[as.character(a$cols)] == 1)
}, logical(1))
for (i in order(controls_dim)) {
panel_ind <- grep('panel', panels[[fixed_gt[i]]]$layout$name)[1]
# Guard against rows and cols added by free_panel()
content_cols <- range(panels[[fixed_gt[i]]]$grobs[[panel_ind]]$layout$l, panels[[fixed_gt[i]]]$grobs[[panel_ind]]$layout$r)
content_rows <- range(panels[[fixed_gt[i]]]$grobs[[panel_ind]]$layout$t, panels[[fixed_gt[i]]]$grobs[[panel_ind]]$layout$b)
w <- panels[[fixed_gt[i]]]$grobs[[panel_ind]]$widths[content_cols[1]:content_cols[2]]
h <- panels[[fixed_gt[i]]]$grobs[[panel_ind]]$heights[content_rows[1]:content_rows[2]]
can_set_width <- all(width_strings[fixed_areas[[i]]$cols] == '-1null') && length(w) == 1 && length(h) == 1
can_set_height <- all(height_strings[fixed_areas[[i]]$rows] == '-1null') && length(w) == 1 && length(h) == 1
will_be_fixed <- TRUE
if (can_set_width && can_set_height) {
widths[fixed_areas[[i]]$cols] <- w
width_strings[fixed_areas[[i]]$cols] <- ''
heights[fixed_areas[[i]]$rows] <- h
height_strings[fixed_areas[[i]]$rows] <- ''
} else if (can_set_width) {
widths[fixed_areas[[i]]$cols] <- heights[fixed_areas[[i]]$rows] * (as.numeric(w) / as.numeric(h))
width_strings[fixed_areas[[i]]$cols] <- ''
} else if (can_set_height) {
heights[fixed_areas[[i]]$rows] <- widths[fixed_areas[[i]]$cols] * (as.numeric(h) / as.numeric(w))
height_strings[fixed_areas[[i]]$rows] <- ''
} else {
will_be_fixed <- FALSE
}
if (will_be_fixed) {
respect[height_ind[fixed_areas[[i]]$rows], width_ind[fixed_areas[[i]]$cols]] <- 1
}
}
if (all(respect == 0)) respect <- FALSE
gt$respect <- respect
}
widths[width_strings == '-1null'] <- unit(1, 'null')
heights[height_strings == '-1null'] <- unit(1, 'null')
gt$widths[width_ind] <- widths
gt$heights[height_ind] <- heights
gt
}
add_insets <- function(gt) {
is_inset <- vapply(gt, inherits, logical(1), 'inset_table')
if (!any(is_inset)) {
return(gt)
}
canvas <- rank(cumsum(!is_inset), ties.method = "min")[is_inset]
if (canvas[1] == 0) {
cli_abort("insets cannot be the first plot in a patchwork")
}
insets <- which(is_inset)
name <- paste0('inset_', insets)
for (i in seq_along(insets)) {
ins <- gt[[insets[i]]]
can <- gt[[canvas[i]]]
setting <- attr(ins, 'inset_settings')
if (setting$on_top) {
z <- max(can$layout$z) + 1
} else {
bg <- which(grepl('background', can$layout$name))
if (length(bg) != 0) {
z <- can$layout$z[bg[1]]
} else {
z <- min(can$layout$z) - 1
}
}
gt[[canvas[i]]] <- switch(setting$align_to,
panel = gtable_add_grob(can, list(ins), PANEL_ROW, PANEL_COL, z = z,
clip = setting$clip, name = name[i]),
plot = gtable_add_grob(can, list(ins), PLOT_TOP, PLOT_LEFT, PLOT_BOTTOM,
PLOT_RIGHT, z = z, clip = setting$clip, name = name[i]),
full = gtable_add_grob(can, list(ins), 1, 1, nrow(can), ncol(can), z = z,
clip = setting$clip, name = name[i]),
cli_abort('Unknown alignment setting: {.arg {setting$align_to}}')
)
}
gt[!is_inset]
}
patchwork/R/zzz.R 0000644 0001762 0000144 00000002614 14670021173 013441 0 ustar ligges users .onLoad <- function(...) {
run_on_load()
}
print_plot.patchwork <- function(p, title = '') {
if (is.null(p$patches$annotation$title)) {
p <- p + plot_annotation(title = title)
}
print(p)
}
register_s3_method <- function(pkg, generic, class, fun = NULL) {
check_string(pkg)
check_string(generic)
check_string(class)
if (is.null(fun)) {
fun <- get(paste0(generic, ".", class), envir = parent.frame())
} else {
check_function(fun)
}
if (pkg %in% loadedNamespaces()) {
registerS3method(generic, class, fun, envir = asNamespace(pkg))
}
# Always register hook in case package is later unloaded & reloaded
setHook(
packageEvent(pkg, "onLoad"),
function(...) {
registerS3method(generic, class, fun, envir = asNamespace(pkg))
}
)
}
unitType <- function(x) {
unit <- attr(x, "unit")
if (!is.null(unit)) {
return(unit)
}
if (is.list(x) && is.unit(x[[1]])) {
unit <- vapply(x, unitType, character(1))
return(unit)
} else if ("fname" %in% names(x)) {
return(x$fname)
}
rep("", length(x)) # we're only interested in simple units for now
}
is_abs_unit <- function(x) {
unitType(x) %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")
}
on_load({
register_s3_method("vdiffr", "print_plot", "patchwork")
if ("unitType" %in% getNamespaceExports("grid")) {
unitType <- grid::unitType
}
})
patchwork/R/wrap_plots.R 0000644 0001762 0000144 00000006007 14571545322 015005 0 ustar ligges users #' Wrap plots into a patchwork
#'
#' While the use of `+` is a natural way to add plots together, it can be
#' difficult to string together multiple plots programmatically if the number
#' of plots is not known beforehand. `wrap_plots` makes it easy to take a list
#' of plots and add them into one composition, along with layout specifications.
#'
#' If `design` is specified as a text string *and* the plots are named (e.g.
#' `wrap_plots(A = p1, ...)`) *and* all plot names are single characters
#' represented in the design layout string, the plots will be matched to their
#' respective area by name. Otherwise the areas will be filled out
#' sequentially in the same manner as using the `+` operator. See the examples
#' for more.
#'
#' @param ... multiple `ggplot`s or a list containing `ggplot` objects
#' @inheritParams plot_layout
#'
#' @return A `patchwork` object
#'
#' @importFrom ggplot2 is.ggplot
#' @export
#'
#' @examples
#' library(ggplot2)
#'
#' p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))
#' p3 <- ggplot(mtcars) + geom_bar(aes(gear)) + facet_wrap(~cyl)
#' p4 <- ggplot(mtcars) + geom_bar(aes(carb))
#' p5 <- ggplot(mtcars) + geom_violin(aes(cyl, mpg, group = cyl))
#'
#' # Either add the plots as single arguments
#' wrap_plots(p1, p2, p3, p4, p5)
#'
#' # Or add them as a list...
#' plots <- list(p1, p2, p3, p4, p5)
#' wrap_plots(plots)
#'
#' # Match plots to areas by name
#' design <- "#BB
#' AA#"
#' wrap_plots(B = p1, A = p2, design = design)
#'
#' # Compare to not using named plot arguments
#' wrap_plots(p1, p2, design = design)
#'
wrap_plots <- function(..., ncol = NULL, nrow = NULL, byrow = NULL,
widths = NULL, heights = NULL, guides = NULL,
tag_level = NULL, design = NULL, axes = NULL,
axis_titles = axes) {
if (is_valid_plot(..1)) {
plots <- list(...)
} else if (is.list(..1)) {
plots <- ..1
} else {
cli_abort('Can only wrap {.cls ggplot} and/or {.cls grob} objects or a list of them')
}
if (!all(vapply(plots, is_valid_plot, logical(1)))) cli_abort('Only know how to add {.cls ggplot} and/or {.cls grob} objects')
if (!is.null(names(plots)) && !is.null(design) && is.character(design)) {
area_names <- unique(trimws(strsplit(design, '')[[1]]))
area_names <- sort(setdiff(area_names, c('', '#')))
if (all(names(plots) %in% area_names)) {
plot_list <- vector('list', length(area_names))
names(plot_list) <- area_names
plot_list[names(plots)] <- plots
plot_list[vapply(plot_list, is.null, logical(1))] <- list(plot_spacer())
plots <- plot_list
}
}
Reduce(`+`, plots, init = plot_filler()) + plot_layout(
ncol = ncol, nrow = nrow, byrow = byrow, widths = widths, heights = heights,
guides = guides, tag_level = tag_level, design = design, axes = axes,
axis_titles = axis_titles
)
}
#' @importFrom ggplot2 is.ggplot
#' @importFrom grid is.grob
is_valid_plot <- function(x) is.ggplot(x) || is.grob(x)
patchwork/R/plot_multipage.R 0000644 0001762 0000144 00000012177 14466377413 015654 0 ustar ligges users #' Align plots across multiple pages
#'
#' Sometimes it is necessary to make sure that separate plots are aligned, with
#' each other, but still exists as separate plots. That could e.g. be if they
#' need to be part of a slideshow and you don't want titles and panels jumping
#' around as you switch between slides. patchwork provides a range of utilities
#' to achieve that. Currently it is only possible to align ggplots, but aligning
#' patchworks will be supported in the future.
#'
#' @param plot A ggplot object
#' @param dim A plot_dimension object as created by `get_dim()`
#' @param ... ggplot objects or a single list of them
#'
#' @return `get_dim()` and `get_max_dim()` return a plot_dimension object.
#' `set_dim()` returns a modified ggplot object with fixed outer dimensions and
#' `align_patches()` return a list of such. The modified ggplots still behaves
#' like a standard ggplot and new layers, scales, etc can be added to them.
#'
#' @name multipage_align
#' @rdname multipage_align
#'
#' @examples
#' library(ggplot2)
#' p1 <- ggplot(mtcars) +
#' geom_point(aes(mpg, disp)) +
#' ggtitle('Plot 1')
#'
#' p2 <- ggplot(mtcars) +
#' geom_boxplot(aes(gear, disp, group = gear)) +
#' ggtitle('Plot 2')
#'
#' p3 <- ggplot(mtcars) +
#' geom_point(aes(hp, wt, colour = mpg)) +
#' ggtitle('Plot 3')
#'
#' p4 <- ggplot(mtcars) +
#' geom_bar(aes(gear)) +
#' facet_wrap(~cyl) +
#' ggtitle('Plot 4')
#'
#' # Align a plot to p4
#' p4_dim <- get_dim(p4)
#' set_dim(p1, p4_dim)
#'
#' # Align a plot to the maximum dimensions of a list of plots
#' max_dims <- get_max_dim(p1, p2, p3, p4)
#' set_dim(p2, max_dims)
#'
#' # Align a list of plots with each other
#' aligned_plots <- align_patches(p1, p2, p3, p4)
#' aligned_plots[[3]]
#'
#' # Aligned plots still behave like regular ggplots
#' aligned_plots[[3]] + theme_bw()
#'
NULL
#' @rdname multipage_align
#' @export
get_dim <- function(plot) {
UseMethod('get_dim')
}
is_plot_dimension <- function(x) inherits(x, 'plot_dimension')
#' @export
print.plot_dimension <- function(x, ...) {
cat('A plot dimension object to be applied to a ggplot or patchwork with `set_dim()`')
invisible(x)
}
#' @importFrom ggplot2 ggplot_build ggplot_gtable geom_blank
#' @export
get_dim.ggplot <- function(plot) {
table <- plot_table(plot, 'auto')
panel_pos <- find_panel(table)
widths <- convertWidth(table$widths, 'mm', TRUE)
heights <- convertHeight(table$heights, 'mm', TRUE)
dims <- list(l = widths[seq_len(panel_pos$l - 1)],
r = widths[seq(panel_pos$r + 1, ncol(table))],
t = heights[seq_len(panel_pos$t - 1)],
b = heights[seq(panel_pos$b + 1, nrow(table))])
class(dims) <- c('ggplot_dimension', 'plot_dimension')
dims
}
is_ggplot_dimension <- function(x) inherits(x, 'ggplot_dimension')
#' @export
get_dim.patchwork <- function(plot) {
cli_abort('Getting dimensions on patchworks are currently unsupported')
}
#' @rdname multipage_align
#' @export
set_dim <- function(plot, dim) {
if (!is_plot_dimension(dim)) {
cli_abort('{.arg dim} must be a {.cls plot_dimension} object created with {.fun get_dim}')
}
UseMethod('set_dim')
}
#' @export
set_dim.ggplot <- function(plot, dim) {
plot$fixed_dimensions <- dim
class(plot) <- c('fixed_dim_ggplot', class(plot))
plot
}
#' @export
set_dim.patchwork <- function(plot, dim) {
cli_abort('Setting dimensions on patchworks are currently unsupported')
}
#' @importFrom ggplot2 ggplot_build
#' @export
ggplot_build.fixed_dim_ggplot <- function(plot) {
plot <- NextMethod()
class(plot) <- c('fixed_dim_build', class(plot))
plot
}
#' @importFrom ggplot2 ggplot_gtable
#' @export
ggplot_gtable.fixed_dim_build <- function(data) {
dim <- data$plot$fixed_dimensions
table <- NextMethod()
table <- add_strips(table)
table <- add_guides(table, FALSE)
panel_pos <- find_panel(table)
table$widths[seq_len(panel_pos$l - 1)] <- unit(dim$l, 'mm')
table$widths[seq(panel_pos$r + 1, ncol(table))] <- unit(dim$r, 'mm')
table$heights[seq_len(panel_pos$t - 1)] <- unit(dim$t, 'mm')
table$heights[seq(panel_pos$b + 1, nrow(table))] <- unit(dim$b, 'mm')
table
}
#' @rdname multipage_align
#' @export
get_max_dim <- function(...) {
if (is.ggplot(..1)) {
plots <- list(...)
} else if (is.list(..1)) {
plots <- ..1
} else {
cli_abort('Can only get dimensions from {.cls ggplot} objects or a list of them')
}
dims <- lapply(plots, get_dim)
dims <- list(
l = exec(pmax, !!!lapply(dims, `[[`, 'l')),
r = exec(pmax, !!!lapply(dims, `[[`, 'r')),
t = exec(pmax, !!!lapply(dims, `[[`, 't')),
b = exec(pmax, !!!lapply(dims, `[[`, 'b'))
)
class(dims) <- c('ggplot_dimension', 'plot_dimension')
dims
}
#' @rdname multipage_align
#' @export
align_patches <- function(...) {
if (is.ggplot(..1)) {
plots <- list(...)
} else if (is.list(..1)) {
plots <- ..1
} else {
cli_abort('Can only align {.cls ggplot} objects or a list of them')
}
lapply(plots, set_dim, get_max_dim(plots))
}
#' Deprecated functions
#'
#' These functions are deprecated and should not be used.
#'
#' @export
#' @keywords internal
#' @usage NULL
align_plots <- function(...) {
.Deprecated('align_patches')
align_patches(...)
}
patchwork/R/collect_axes.R 0000644 0001762 0000144 00000034501 14665336707 015271 0 ustar ligges users
collect_axis_titles <- function(gt, dir = "x", merge = TRUE) {
names <- paste0(dir, "lab", switch(dir, x = c("-t", "-b"), y = c("-l", "-r")))
delete <- integer()
for (name in names) {
# Find titles
idx <- which(grepl(paste0("^", name), gt$layout$name))
if (length(idx) < 2) {
# No titles to collapse, leave as-is
next
}
if (all(is_zero(gt$grobs[idx]))) {
# No need to bother with non-existing titles
next
}
# We want patches to be able to break title runs
patch_index <- grep("panel-nested-patchwork", gt$layout$name)
# Simplify layout of grobs to matrix
layout <- grob_layout(gt, c(idx, patch_index))
nested <- layout %in% patch_index
layout[nested] <- NA # Remove patches
# Mark duplicated grobs
structure <- grob_id(gt$grobs, layout, byrow = dir == "x", merge = merge, unpack = TRUE)
# If all title grobs are unique, there is nothing to collapse
if (anyDuplicated(structure[!is.na(structure)]) == 0) {
next
}
structure[nested] <- 0
# Identify 'run'-rectangles in the structure
runs <- rle_2d(structure, byrow = dir == "y", ignore.na = TRUE)
runs <- runs[!is.na(runs$value) & runs$value != 0, , drop = FALSE]
# Get all panels in each run and put the keeper first
panels <- lapply(seq_len(nrow(runs)), function(i) {
rows <- runs$row_start[i]:runs$row_end[i]
cols <- runs$col_start[i]:runs$col_end[i]
first <- switch(name,
"xlab-t" = layout[runs$row_start[i], cols],
"xlab-b" = layout[runs$row_end[i], cols],
"ylab-l" = layout[rows, runs$col_start[i]],
"ylab-r" = layout[rows, runs$col_end[i]]
)
first <- first[!is.na(first)][1]
panels <- as.vector(layout[rows , cols])
panels <- panels[!is.na(panels)]
unique(c(first, panels))
})
title_grob <- vapply(panels, `[[`, numeric(1), 1)
# Mark every non-start grob for deletion
delete <- c(delete, setdiff(idx, title_grob))
if ((dir == "x" && all(runs$col_start == runs$col_end)) ||
(dir == "y" && all(runs$row_start == runs$row_end))) {
next
}
# Stretch titles over span
if (dir == "y") {
gt$layout$t[title_grob] <- vapply(panels, function(i) min(gt$layout$t[i]), numeric(1))
gt$layout$b[title_grob] <- vapply(panels, function(i) max(gt$layout$b[i]), numeric(1))
gt$layout$z[title_grob] <- max(gt$layout$z[idx])
} else {
gt$layout$l[title_grob] <- vapply(panels, function(i) min(gt$layout$l[i]), numeric(1))
gt$layout$r[title_grob] <- vapply(panels, function(i) max(gt$layout$r[i]), numeric(1))
gt$layout$z[title_grob] <- max(gt$layout$z[idx])
}
}
delete_grobs(gt, delete)
}
# Very similar to `collect_titles`, except there is no merging step involved
# and rows/columns are resized afterwards.
collect_axes <- function(gt, dir = "x") {
if (dir == "x") {
names <- c("axis-b", "axis-t")
} else {
names <- c("axis-l", "axis-r")
}
delete <- integer()
for (name in names) {
# Find axes
idx <- which(grepl(paste0("^", name), gt$layout$name))
if (length(idx) < 2) {
# No axes to collapse, leave as-is
next
}
if (all(is_zero(gt$grobs[idx]))) {
# No need to bother with non-existing axes
next
}
# We want patches to be able to break axis runs
patch_index <- grep("panel-nested-patchwork", gt$layout$name)
# Simplify layout of grobs to matrix
layout <- grob_layout(gt, c(idx, patch_index))
layout[layout %in% patch_index] <- NA # Remove patches
# Mark duplicated grobs
structure <- grob_id(gt$grobs, layout, byrow = dir == "x", merge = FALSE)
# If all grobs are unique, there is nothing to collapse
if (anyDuplicated(structure[!is.na(structure)]) == 0) {
next
}
# Identify 'run'-rectangles in the structure
runs <- rle_2d(structure, byrow = dir == "y")
runs <- runs[!is.na(runs$value), , drop = FALSE]
# Find first grob in run
start_runs <- c("row_start", "col_start")
if (name == "axis-b") start_runs[1] <- "row_end"
if (name == "axis-r") start_runs[2] <- "col_end"
start_idx <- layout[as.matrix(runs[, start_runs])]
# Mark every non-start grob for deletion
delete <- c(delete, setdiff(idx, start_idx))
}
deleted_rows <- unique(c(gt$layout$t[delete], gt$layout$b[delete]))
deleted_cols <- unique(c(gt$layout$l[delete], gt$layout$r[delete]))
new <- delete_grobs(gt, delete)
new <- retrofit_rows(new, deleted_rows, pattern = "^axis")
new <- retrofit_cols(new, deleted_cols, pattern = "^axis")
new
}
# For every given row, check if all non-zero grobs occupying that row have a
# name that has a pattern. If all these grobs in that row do, measure the
# grob heights and put that into the gtable's heights.
#' @importFrom ggplot2 max_height
retrofit_rows <- function(gt, rows, pattern = NULL) {
if (is.null(pattern) || length(rows) == 0) {
return(gt)
}
# zeroGrobs are ignored for fitting
layout <- gt$layout[!is_zero(gt$grobs), , drop = FALSE]
# Grab grob index and their rows
grob_idx <- which(layout$t %in% rows | layout$b %in% rows)
row_idx <- layout$t[grob_idx] # 'layout$b' is ignored, but that is probably fine
# Check if any grob in row does not have the pattern.
# If all grobs in a row have the pattern, include for resizing
is_pattern <- grepl(pattern, layout$name[grob_idx])
resize_row <- rowsum(as.integer(!is_pattern), group = row_idx) == 0
resize_row <- as.integer(rownames(resize_row)[resize_row[, 1]])
# Do resizing
for (row in resize_row) {
grobs <- gt$grobs[gt$layout$t == row | gt$layout$b == row]
size <- max_height(grobs[!is_zero(grobs)])
gt$heights[row] <- size
}
gt
}
# For every given column, check if all non-zero grobs occupying that column
# have a name that has a pattern. If all these grobs in that column do, measure
# the grob widths and put that into the gtable's widths.
#' @importFrom ggplot2 max_width
retrofit_cols <- function(gt, cols, pattern = NULL) {
if (is.null(pattern) || length(cols) == 0) {
return(gt)
}
# zeroGrobs are ignored for fitting
layout <- gt$layout[!is_zero(gt$grobs), , drop = FALSE]
# Grab grob index and their columns
grob_idx <- which(layout$l %in% cols | layout$r %in% cols)
col_idx <- layout$l[grob_idx] # 'layout$r' is ignored, but that is probably fine
# Check if any grob in column does not have the pattern.
# If all grobs in a column have the pattern, include for resizing
is_pattern <- grepl(pattern, layout$name[grob_idx])
resize_col <- rowsum(as.integer(!is_pattern), group = col_idx) == 0
resize_col <- as.integer(rownames(resize_col)[resize_col[, 1]])
# Do resizing
for (col in resize_col) {
grobs <- gt$grobs[gt$layout$l == col | gt$layout$r == col]
size <- max_width(grobs[!is_zero(grobs)])
gt$widths[col] <- size
}
gt
}
# Delete grobs from the gtable while preserving dimensions.
# If a row or column in the gtable becomes empty, optionally set size to 0.
delete_grobs <- function(gt, idx, resize = TRUE) {
if (length(idx) == 0) {
return(gt)
}
if (resize) {
# Candidate rows/cols for resizing
resize_rows <- unique(gt$layout[idx, "t"])
resize_cols <- unique(gt$layout[idx, "l"])
}
gt$layout <- gt$layout[-idx, , drop = FALSE]
gt$grobs <- gt$grobs[-idx]
if (!resize) {
return(gt)
}
# Only resize rows/columns that don't have any (non-zero) grobs associated
# with them.
# Note that this ignores grobs that 'span' the rows/columns, but these are
# typically background rectangles.
zero <- is_zero(gt$grobs)
resize_rows <- setdiff(resize_rows, unlist(gt$layout[!zero, c("t", "b")]))
resize_cols <- setdiff(resize_cols, unlist(gt$layout[!zero, c("l", "r")]))
if (length(resize_rows) > 0) {
gt$heights[resize_rows] <- unit(0, "pt")
}
if (length(resize_cols) > 0) {
gt$widths[resize_cols] <- unit(0, "pt")
}
gt
}
# Check if 'x' is 'empty': a zeroGrob or NULL
is_zero <- function(x) {
if (is_bare_list(x)) {
vapply(x, inherits, logical(1), what = "zeroGrob") | lengths(x) == 0
} else {
is.null(x) || inherits(x, "zeroGrob")
}
}
# Determine uniqueness of grobs
#' @importFrom stats ave
grob_id <- function(grobs, layout, byrow, merge = FALSE, unpack = FALSE) {
# Hash the grobs to determine unique grobs
valid <- !is.na(layout)
idx <- as.vector(layout)[valid]
hash <- vapply(grobs[idx], function(x) {
if (unpack && inherits(x, "gtable") && length(x$grobs) == 1) {
x <- x$grobs[[1]]
}
hash(unname_grob(x))
}, character(1))
# For multi-cell grobs, compute an extra identifier
if (!merge) {
index <- if (byrow) col(layout) else row(layout)
min <- ave(index, layout, FUN = min)
max <- ave(index, layout, FUN = max)
identifier <- paste0(min, ";", max)
# Include the multi-cell identifier in the hash
hash <- paste0(hash, identifier[valid])
}
layout[valid] <- match(hash, unique(hash))
layout
}
# Representing grob indices in a simplified layout matrix
# Assumes cell can be uniquely mapped to a grob, so no overlapping grobs
grob_layout <- function(gt, idx) {
layout <- gt$layout[idx, , drop = FALSE]
top <- sort(unique(c(layout$t, layout$b)))
left <- sort(unique(c(layout$l, layout$r)))
new <- matrix(NA_integer_, length(top), length(left))
# Account for fact that grobs may span multiple cells
right <- match(layout$r, left)
bottom <- match(layout$b, top)
top <- match(layout$t, top)
left <- match(layout$l, left)
for(i in seq_along(idx)) {
new[top[i]:bottom[i], left[i]:right[i]] <- idx[i]
}
new
}
# Backports of hash table functionality
hashtab <- function(type, size) {
new_environment()
}
gethash <- function(h, key, nomatch = NULL) {
get0(hash(key), envir = h, ifnotfound = nomatch)
}
sethash <- function(h, key, value) {
assign(hash(key), value, envir = h)
}
on_load({
if ("hashtab" %in% getNamespaceExports("utils")) {
hashtab <- utils::hashtab
}
if ("gethash" %in% getNamespaceExports("utils")) {
gethash <- utils::gethash
}
if ("sethash" %in% getNamespaceExports("utils")) {
sethash <- utils::sethash
}
})
# 2D equivalent of run-length encoding.
# Essentially, it tries to look for rectangular arrangements of cells in a
# matrix that have the same values, and reports back their positions.
#
# Worked example:
#
# # Let's say we have the following matrix
# (m <- matrix(c(1, 1, 2, 1, 1, 2, 3, 3, 1), 3, 3))
# #> [,1] [,2] [,3]
# #> [1,] 1 1 3
# #> [2,] 1 1 3
# #> [3,] 2 2 1
#
# # The `rle_2d()` function finds the `i` and `j` arguments that define the
# # rectangular areas with the same values. For this example so this finds:
# # m[1:2, 1:2], m[1:2, 3], m[3, 1:2] and m[3, 3] as runs.
#
# rle_2d(m)
# #> col_start col_end row_start row_end value
# #> 1 1 2 1 2 1
# #> 2 1 2 3 3 2
# #> 5 3 3 1 2 3
# #> 6 3 3 3 3 1
rle_2d <- function(m, byrow = FALSE, ignore.na = FALSE) {
n <- length(m)
# Return 0-row data.frame if matrix is empty
if (n == 0L) {
ans <- data.frame(
col_start = integer(),
col_end = integer(),
row_start = integer(),
row_end = integer(),
value = as.vector(m)
)
return(ans)
}
if (isTRUE(byrow)) {
m <- t(m)
rename <- function(x) {
names(x) <- c("row_start", "row_end", "col_start", "col_end", "value")
rownames(x) <- NULL
x
}
} else {
rename <- function(x) {
rownames(x) <- NULL
x
}
}
dim <- dim(m)
levels <- unique(as.vector(m))
# Simplified case when there is just a single level
if ((ignore.na && sum(!is.na(levels)) == 1) || length(levels) == 1L) {
ans <- data.frame(
col_start = 1L,
col_end = dim[2],
row_start = 1L,
row_end = dim[1],
value = sort(levels, na.last = TRUE)[1]
)
return(rename(ans))
}
# Simplified case when all levels are different
if (length(levels) == n) {
col <- as.vector(col(m))
row <- as.vector(row(m))
ans <- data.frame(
col_start = col,
col_end = col,
row_start = row,
row_end = row,
value = as.vector(m)
)
return(rename(ans))
}
# Treat matrix content as levels, so we can deal with NAs
m <- matrix(match(m, levels), nrow(m), ncol(m))
# Simplified case when m has only a single row
if (dim[1] == 1L) {
rle <- rle(as.vector(m))
ends <- cumsum(rle$lengths)
ans <- data.frame(
col_start = ends - rle$lengths + 1,
col_end = ends,
row_start = 1L,
row_end = 1L,
value = levels[rle$values]
)
}
# Run length encoding by column
# classic RLE column-wise RLE
# |------------------| |----------------------|
ends <- c(which(m[-1] != m[-n] | (row(m) == nrow(m))[-n]), n)
lengths <- diff(c(0L, ends))
values <- m[ends]
starts <- ends - lengths + 1L
# Simplified case when m has only a single column
if (dim[2] == 1L) {
ans <- data.frame(
col_start = 1L,
col_end = 1L,
row_start = starts,
row_end = ends,
value = levels[values]
)
return(rename(ans))
}
# Translate to indices
# `col_end` is initialised as `col_start` but will be updated throughout
# the coming for-loop
row_start <- arrayInd(starts, dim)[, 1]
row_end <- row_start + lengths - 1L
col_start <- col_end <- arrayInd(ends, dim)[, 2]
# Initialise hash table no longer than number of runs
# Inspiration for using hash tables for this problem taken from TimTaylor:
# https://fosstodon.org/@_TimTaylor/111266682218212785
htab <- hashtab("identical", size = length(values))
for (i in seq_along(values)) {
# Lookup if there has been a similar column
key <- c(row_start[i], row_end[i], values[i])
hsh <- gethash(htab, key)
if (!is.null(hsh) && col_start[i] == col_end[hsh] + 1L) {
# Matches run in previous column, merge by updating column end
# and deleting current run (NA value will be filtered out later)
col_end[hsh] <- col_start[i]
values[i] <- NA_integer_
} else {
# Add run-index to the table
sethash(htab, key, i)
}
}
ans <- data.frame(
col_start = col_start,
col_end = col_end,
row_start = row_start,
row_end = row_end,
value = levels[values]
)[!is.na(values), , drop = FALSE]
rename(ans)
}
patchwork/R/wrap_table.R 0000644 0001762 0000144 00000015052 14670021433 014723 0 ustar ligges users #' Wrap a table in a patchwork compliant patch
#'
#' This function works much like [wrap_elements()] in that it turns the input
#' into patchwork compliant objects that can be added to a composition. However,
#' `wrap_table()` uses the knowledge that the input is a table to provide some
#' very nifty layout options that makes it generally better to use than
#' [wrap_elements()] for this type of object.
#'
#' @param table A gt table or an object coercible to a data frame
#' @param panel what portion of the table should be aligned with the panel
#' region? `"body"` means that any column and row headers will be placed outside
#' the panel region, i.e. the topleft corner of the panel region will be aligned
#' with the topleft data cell. `"full"` means that the whole table will be
#' placed inside the panel region. `"rows"` means that all rows (including column
#' headers) will be placed inside the panel region but row headers will be
#' placed to the left. `"cols"` is the opposite, placing all columns within the
#' panel region but keeping the column header on top of it. If this is set to
#' `"body"` or `"cols"` and `space` is set to `"fixed"` or `"free_x"` then any
#' footnotes or source notes in the table will be placed outside the bottom of
#' the panel region.
#' @param space How should the dimension of the table influence the final
#' composition? `"fixed"` means that the table width will set the width of the
#' column it occupies and the table height will set the height of the row it
#' occupies. `"free"` is the opposite meaning that the table dimension will not
#' have any influence on the sizing. `"free_x"` and `"free_y"` allows you to
#' free either direction while keeping the remaining fixed. Do note that if you
#' set a specific width or height in [plot_layout()] it will have higher
#' priority than the table dimensions
#' @inheritParams wrap_elements
#'
#' @return A wrapped_table object
#'
#' @export
#'
#' @note This functionality requires v0.11.0 or higher of the gt package
#'
#' @examplesIf requireNamespace("gt", quietly = TRUE) && packageVersion("gt") >= "0.11.0"
#' library(ggplot2)
#' library(gt)
#'
#' p1 <- ggplot(airquality) +
#' geom_line(aes(x = Day, y = Temp, colour = month.name[Month])) +
#' labs(colour = "Month")
#'
#' table <- data.frame(
#' Month = month.name[5:9],
#' "Mean temp." = tapply(airquality$Temp, airquality$Month, mean),
#' "Min temp." = tapply(airquality$Temp, airquality$Month, min),
#' "Max temp." = tapply(airquality$Temp, airquality$Month, max)
#' )
#' gt_tab <- gt(table, rowname_col = "Month")
#'
#' # Default addition usees wrap_table
#' p1 + gt_tab
#'
#' # Default places column and row headers outside panel area. Use wrap_table
#' # to control this
#' p1 + wrap_table(gt_tab, panel = "full")
#'
#' # Tables generally have fixed dimensions and these can be used to control
#' # the size of the area they occupy
#' p2 <- ggplot(airquality) +
#' geom_boxplot(aes(y = month.name[Month], x = Temp)) +
#' scale_y_discrete(name = NULL, limits = month.name[9:5], guide = "none")
#'
#' wrap_table(gt_tab, space = "fixed") + p2
#'
wrap_table <- function(table, panel = c("body", "full", "rows", "cols"), space = c("free", "free_x", "free_y", "fixed"), ignore_tag = FALSE) {
check_installed("gt", version = "0.11.0")
if (!inherits(table, "gt_tbl")) {
table <- try_fetch(
gt::gt(as.data.frame(table)),
error = function(cnd, ...) cli::cli_abort("Unable to convert input table to {.cls gt_tbl}", parent = cnd)
)
}
n_row_headers <- (!all(is.na(table[["_stub_df"]]$row_id))) + (!all(is.na(table[["_stub_df"]]$group_id)))
if (n_row_headers == 2 && !table[["_options"]]$value[[which(table[["_options"]]$parameter == "row_group_as_column")]]) {
n_row_headers <- 1
}
table <- wrap_elements(table, ignore_tag = ignore_tag)
attr(table, "patch_settings")$panel <- arg_match(panel)
attr(table, "patch_settings")$n_row_headers <- n_row_headers
attr(table, "patch_settings")$space <- c(space %in% c("free", "free_x"), space %in% c("free", "free_y"))
class(table) <- c("wrapped_table", class(table))
table
}
#' @export
patchGrob.wrapped_table <- function(x, guides = 'auto') {
panel <- attr(x, "patch_settings")$panel
row_head <- attr(x, "patch_settings")$n_row_headers
space <- attr(x, "patch_settings")$space
x <- NextMethod()
table_loc <- which(x$layout$name == "panel")
table_width <- x$grobs[[table_loc]]$widths
if (all(is_abs_unit(table_width))) table_width <- convertWidth(table_width, "mm")
table_height <- x$grobs[[table_loc]]$heights
if (all(is_abs_unit(table_height))) table_height <- convertHeight(table_height, "mm")
if (panel %in% c("body", "cols")) {
table_body <- x$grobs[[table_loc]]$layout$name == "table_body"
col_head <- x$grobs[[table_loc]]$layout$t[table_body] - 1
col_tail <- x$grobs[[table_loc]]$layout$b[table_body] + 1
if (!space[2] && col_tail <= nrow(x$grobs[[table_loc]])) {
height <- sum(x$grobs[[table_loc]]$heights[col_tail:nrow(x$grobs[[table_loc]])])
x$heights[PANEL_ROW + 2] <- height
table_height <- table_height[-(col_tail:nrow(x$grobs[[table_loc]]))]
}
if (col_head > 0) {
height <- sum(x$grobs[[table_loc]]$heights[1:col_head])
x$grobs[[table_loc]]$vp$y <- x$grobs[[table_loc]]$vp$y + height
x$heights[PANEL_ROW - 2] <- height
table_height <- table_height[-(1:col_head)]
}
}
if (panel %in% c("body", "rows") && row_head > 0) {
width <- sum(x$grobs[[table_loc]]$widths[1:row_head])
x$grobs[[table_loc]]$vp$x <- x$grobs[[table_loc]]$vp$x - width
x$widths[PANEL_COL - 2] <- width
table_width <- table_width[-(1:row_head)]
}
if (!space[1]) {
# Something wonky is going on with unit addition sometimes where it looses
# it's unit type. So we make a dance to make sure
w <- if (inherits(table_width, "simpleUnit")) sum(table_width) else Reduce(`+`, table_width)
if (!is.unit(w)) w <- unit(w, unitType(table_width)[1])
x$widths[PANEL_COL] <- w
}
if (!space[2]) {
h <- if (inherits(table_height, "simpleUnit")) sum(table_height) else Reduce(`+`, table_height)
if (!is.unit(h)) h <- unit(h, unitType(table_height)[1])
x$heights[PANEL_ROW] <- h
}
x
}
#' @export
#' @importFrom grid viewport grobWidth grobHeight grobTree
as_patch.gt_tbl <- function(x, ...) {
check_installed("gt", version = "0.11.0")
grob <- gt::as_gtable(x)
loc <- grob$layout[grob$layout$name == "table",]
grob <- grob[loc$t:loc$b, loc$l:loc$r]
grob$vp <- viewport(
x = 0,
y = 1,
width = grobWidth(grob),
height = grobHeight(grob),
default.units = "npc",
just = c(0, 1)
)
grob
}
patchwork/R/inset_element.R 0000644 0001762 0000144 00000006617 14665304640 015455 0 ustar ligges users #' Create an inset to be added on top of the previous plot
#'
#' The standard approach of patchwork is to place plots next to each other based
#' on the provided layout. However, it may sometimes be beneficial to place one
#' or several plots or graphic elements freely on top or below another plot. The
#' `inset_element()` function provides a way to create such insets and gives you
#' full control over placement.
#'
#' @param p A grob, ggplot, patchwork, formula, raster, nativeRaster, or gt object
#' to add as an inset
#' @param left,bottom,right,top numerics or units giving the location of the
#' outer bounds. If given as numerics they will be converted to `npc` units.
#' @param align_to Specifies what `left`, `bottom`, etc should be relative to.
#' Either `'panel'` (default), `'plot'`, or `'full'`.
#' @param on_top Logical. Should the inset be placed on top of the other plot or
#' below (but above the background)?
#' @param clip Logical. Should clipping be performed on the inset?
#' @param ignore_tag Logical. Should autotagging ignore the inset?
#'
#' @return A `inset_path` object
#'
#' @export
#'
#' @examples
#' library(ggplot2)
#' p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))
#'
#' # Basic use
#' p1 + inset_element(p2, 0.6, 0.6, 1, 1)
#'
#' # Align to the full area instead
#' p1 + inset_element(p2, 0, 0.6, 0.4, 1, align_to = 'full')
#'
#' # Grobs and other objects can be added as insets as well
#' p1 + inset_element(grid::circleGrob(), 0.4, 0.4, 0.6, 0.6)
#'
#' if (requireNamespace('png', quietly = TRUE)) {
#' logo <- system.file('help', 'figures', 'logo.png', package = 'patchwork')
#' logo <- png::readPNG(logo, native = TRUE)
#' p1 + inset_element(logo, 0.8, 0.8, 1, 1, align_to = 'full')
#' }
#'
#' # Just as expected insets are still amenable to changes after the fact
#' p1 +
#' inset_element(p2, 0.6, 0.6, 1, 1) +
#' theme_classic()
#'
#' # Tagging also continues to work as expected
#' p1 +
#' inset_element(p2, 0.6, 0.6, 1, 1) +
#' plot_annotation(tag_levels = '1')
#'
#' # but can be turned off, like for wrapped plots
#' p1 +
#' inset_element(p2, 0.6, 0.6, 1, 1, ignore_tag = TRUE) +
#' plot_annotation(tag_levels = '1')
#'
inset_element <- function(p, left, bottom, right, top, align_to = 'panel', on_top = TRUE, clip = TRUE, ignore_tag = FALSE) {
align_to <- match.arg(align_to, c('panel', 'plot', 'full'))
if (!is.unit(left)) {
left <- unit(left, 'npc')
}
if (!is.unit(bottom)) {
bottom <- unit(bottom, 'npc')
}
if (!is.unit(right)) {
right <- unit(right, 'npc')
}
if (!is.unit(top)) {
top <- unit(top, 'npc')
}
if (!is.ggplot(p)) {
p <- wrap_elements(full = p, clip = FALSE)
}
if (!is.ggplot(p)) {
p <- wrap_elements(full = p, clip = clip)
}
clip <- if (clip) 'on' else 'off'
attr(p, 'inset_settings') <- list(left = left, bottom = bottom, right = right,
top = top, align_to = align_to, on_top = on_top,
clip = clip, ignore_tag = ignore_tag)
class(p) <- c('inset_patch', class(p))
p
}
is_inset_patch <- function(x) inherits(x, 'inset_patch')
#' @export
print.inset_patch <- function(x, newpage = is.null(vp), vp = NULL, ...) {
print(plot_spacer() + x, newpage = newpage, vp = vp, ...)
}
#' @export
plot.inset_patch <- print.inset_patch
#' @export
has_tag.inset_patch <- function(x) !attr(x, 'inset_settings')$ignore_tag
patchwork/R/guide_area.R 0000644 0001762 0000144 00000002647 13751212415 014677 0 ustar ligges users #' Add an area to hold collected guides
#'
#' Using the `guides` argument in [plot_layout()] you can collect and collapse
#' guides from plots. By default these guides will be put on the side like with
#' regular plots, but by adding a `guide_area()` to the plot you can tell
#' patchwork to place the guides in that area instead. If guides are not
#' collected or no guides exists to collect it behaves as a standard
#' [plot_spacer()] instead.
#'
#' @export
#'
#' @examples
#' library(ggplot2)
#' p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp, colour = factor(gear)))
#' p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))
#' p3 <- ggplot(mtcars) + geom_bar(aes(gear)) + facet_wrap(~cyl)
#'
#' # Guides are by default kept beeside their plot
#' p1 + p2 + p3
#'
#' # They can be collected and placed on the side (according to the patchwork
#' # theme)
#' p1 + p2 + p3 + plot_layout(guides = 'collect', ncol = 2)
#'
#' # Using guide_area() you can also designate an empty area for this
#' p1 + p2 + p3 + guide_area() + plot_layout(guides = 'collect')
#'
guide_area <- function() {
table <- make_patch()
class(table) <- c('guide_area', class(table))
table
}
#' @importFrom gtable gtable_add_grob
#' @export
patchGrob.guide_area <- function(x, guides = 'auto') {
table <- NextMethod()
gtable_add_grob(table, zeroGrob(), PANEL_ROW, PANEL_COL, name = 'panel-guide_area')
}
#' @export
has_tag.guide_area <- function(x) FALSE
patchwork/R/guides.R 0000644 0001762 0000144 00000020201 14670774554 014076 0 ustar ligges users unname_vp <- function(x) {
if (inherits(x, 'vpTree')) {
x$parent <- unname_vp(x$parent)
x$children <- lapply(x$children, unname_vp)
} else if (inherits(x, 'viewport')) {
x$name <- ''
if (!is.null(x$layout$widths)) {
x$layout$widths <- absolute.size(x$layout$widths)
}
if (!is.null(x$layout$heights)) {
x$layout$heights <- absolute.size(x$layout$heights)
}
}
unit_elements <- vapply(x, is.unit, logical(1))
x[unit_elements] <- lapply(.subset(x, unit_elements), absolute.size)
x
}
#' @importFrom grid is.grob is.unit absolute.size
#' @importFrom gtable is.gtable
#' @importFrom farver set_channel get_channel
unname_grob <- function(x) {
if (is.gtable(x)) {
x$name <- ''
x$rownames <- NULL
x$vp <- unname_vp(x$vp)
names(x$grobs) <- NULL
x$grobs <- lapply(x$grobs, unname_grob)
} else if (is.grob(x)) {
x$name <- ''
x$vp <- unname_vp(x$vp)
x$children <- unname(lapply(x$children, unname_grob))
x$childrenOrder <- rep_len('', length(x$childrenOrder))
}
unit_elements <- vapply(x, is.unit, logical(1))
x[unit_elements] <- lapply(.subset(x, unit_elements), absolute.size)
if (!is.null(x$gp)) {
if (is.character(x$gp$col)) x$gp$col <- set_channel(x$gp$col, "r", get_channel(x$gp$col, "r"))
if (is.character(x$gp$fill)) x$gp$fill <- set_channel(x$gp$fill, "r", get_channel(x$gp$fill, "r"))
if (is.numeric(x$gp$lty)) x$gp$lty <- c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash")[x$gp$lty + 1]
if (is.character(x$gp$lty)) {
rename <- match(x$gp$lty, c("44", "13", "1343", "73", "2262"))
matched <- !is.na(rename)
x$gp$lty[matched] <- c("dashed", "dotted", "dotdash", "longdash", "twodash")[rename[matched]]
}
if (is.numeric(x$gp$lineend)) x$gp$lineend <- c("round", "butt", "square")[x$gp$lineend]
if (is.numeric(x$gp$linejoin)) x$gp$linejoin <- c("round", "mitre", "bevel")[x$gp$linejoin]
}
x
}
collapse_guides <- function(guides) {
unnamed <- lapply(guides, unname_grob)
for (i in rev(seq_along(unnamed)[-1])) {
for (j in seq_len(i - 1)) {
if (isTRUE(all.equal(unnamed[[i]], unnamed[[j]], check.names = FALSE, check.attributes = FALSE))) {
guides[i] <- NULL
break
}
}
}
guides
}
#' @importFrom gtable gtable_width gtable_height gtable gtable_add_grob
#' @importFrom grid editGrob heightDetails widthDetails valid.just unit.c unit
#' @importFrom ggplot2 margin element_grob element_blank calc_element element_render
guides_build <- function(guides, theme) {
legend.spacing.y <- calc_element(theme, "legend.spacing.y")
legend.spacing.x <- calc_element(theme, "legend.spacing.x")
legend.box.margin <- calc_element("legend.box.margin", theme) %||% margin()
widths <- exec(unit.c, !!!lapply(guides, gtable_width))
heights <- exec(unit.c, !!!lapply(guides, gtable_height))
just <- valid.just(calc_element("legend.box.just", theme))
xjust <- just[1]
yjust <- just[2]
vert <- identical(calc_element("legend.box", theme), "horizontal")
guides <- lapply(guides, function(g) {
editGrob(g, vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust),
height = if (vert) heightDetails(g) else 1,
width = if (!vert) widthDetails(g) else 1))
})
guide_ind <- seq(by = 2, length.out = length(guides))
sep_ind <- seq(2, by = 2, length.out = length(guides) - 1)
if (vert) {
heights <- max(heights)
if (length(widths) != 1) {
w <- unit(rep_len(0, length(widths) * 2 - 1), 'mm')
w[guide_ind] <- widths
w[sep_ind] <- legend.spacing.x
widths <- w
}
} else {
widths <- max(widths)
if (length(heights) != 1) {
h <- unit(rep_len(0, length(heights) * 2 - 1), 'mm')
h[guide_ind] <- heights
h[sep_ind] <- legend.spacing.y
heights <- h
}
}
widths <- unit.c(legend.box.margin[4], widths, legend.box.margin[2])
heights <- unit.c(legend.box.margin[1], heights, legend.box.margin[3])
guides <- gtable_add_grob(
gtable(widths, heights, name = 'guide-box'),
guides,
t = 1 + if (!vert) guide_ind else 1,
l = 1 + if (vert) guide_ind else 1,
name = 'guides'
)
gtable_add_grob(
guides,
element_render(theme, "legend.box.background"),
t = 1, l = 1, b = -1, r = -1,
z = -Inf, clip = "off", name = "legend.box.background"
)
}
#' @importFrom ggplot2 calc_element
complete_guide_theme <- function(guide_pos, theme) {
if (guide_pos %in% c("top", "bottom")) {
theme$legend.box <- theme$legend.box %||% "horizontal"
theme$legend.direction <- theme$legend.direction %||% "horizontal"
theme$legend.box.just <- theme$legend.box.just %||% c("center", "top")
} else {
theme$legend.box <- theme$legend.box %||% "vertical"
theme$legend.direction <- theme$legend.direction %||% "vertical"
theme$legend.box.just <- theme$legend.box.just %||% c("left", "top")
}
theme
}
#' @importFrom utils getFromNamespace
#' @importFrom ggplot2 calc_element
assemble_guides <- function(guides, position, theme) {
# https://github.com/tidyverse/ggplot2/blob/57ba97fa04dadc6fd73db1904e39a09d57a4fcbe/R/guides-.R#L512
theme$legend.spacing <- theme$legend.spacing %||% unit(0.5, "lines")
theme$legend.spacing.y <- calc_element("legend.spacing.y", theme)
theme$legend.spacing.x <- calc_element("legend.spacing.x", theme)
# for every position, collect all individual guides and arrange them
# into a guide box which will be inserted into the main gtable
package_box <- try_fetch(
.subset2(getFromNamespace("Guides", "ggplot2"), "package_box"),
error = function(cnd) package_box
)
package_box(guides, position, theme)
}
#' @importFrom grid valid.just editGrob
package_box <- function(guides, guide_pos, theme) {
theme <- complete_guide_theme(guide_pos, theme)
guides <- guides_build(guides, theme)
# Set the justification of the legend box
# First value is xjust, second value is yjust
just <- valid.just(calc_element("legend.justification", theme))
xjust <- just[1]
yjust <- just[2]
guides <- editGrob(guides,
vp = viewport(x = xjust, y = yjust, just = c(xjust, yjust))
)
guides <- gtable_add_rows(guides, unit(yjust, 'null'))
guides <- gtable_add_rows(guides, unit(1 - yjust, 'null'), 0)
guides <- gtable_add_cols(guides, unit(xjust, 'null'), 0)
guides <- gtable_add_cols(guides, unit(1 - xjust, 'null'))
guides
}
#' @importFrom ggplot2 calc_element find_panel
#' @importFrom gtable gtable_width gtable_height
#' @importFrom grid unit.c
attach_guides <- function(table, guides, position, theme) {
guide_areas <- grepl("panel-guide_area", table$layout$name)
if (any(guide_areas)) {
area_ind <- which(guide_areas)
if (length(area_ind) != 1) {
warning("Only using the first guide area", call. = FALSE)
}
table$grobs[[area_ind[1]]] <- guides
return(table)
}
p_loc <- find_panel(table)
spacing <- calc_element("legend.box.spacing", theme) %||% unit(0.2, 'cm')
legend_width <- gtable_width(guides)
legend_height <- gtable_height(guides)
if (position == "left") {
table <- gtable_add_grob(table, guides, clip = "off", t = p_loc$t,
l = p_loc$l - 5, b = p_loc$b, name = "guide-box")
table <- set_border_sizes(table, l = unit.c(table$widths[seq_len(p_loc$l - 6)], legend_width, spacing))
} else if (position == "right") {
table <- gtable_add_grob(table, guides, clip = "off", t = p_loc$t,
l = p_loc$r + 5, b = p_loc$b, name = "guide-box")
table <- set_border_sizes(table, r = unit.c(spacing, legend_width, table$widths[seq(p_loc$r + 6, ncol(table))]))
} else if (position == "bottom") {
table <- gtable_add_grob(table, guides, clip = "off", t = p_loc$b + 5,
l = p_loc$l, r = p_loc$r, name = "guide-box")
table <- set_border_sizes(table, b = unit.c(spacing, legend_height, table$heights[seq(p_loc$b + 6, nrow(table))]))
} else if (position == "top") {
table <- gtable_add_grob(table, guides, clip = "off", t = p_loc$t - 5,
l = p_loc$l, r = p_loc$r, name = "guide-box")
table <- set_border_sizes(table, t = unit.c(table$heights[seq_len(p_loc$t - 6)], legend_height, spacing))
}
table
}
patchwork/R/merge.R 0000644 0001762 0000144 00000000322 14667764165 013722 0 ustar ligges users
#' @export
#'
merge.patchwork <- function(x, ...) {
patchwork <- new_patchwork()
patchwork$plots <- list(x)
add_patches(plot_filler(), patchwork)
}
#' @export
#'
merge.ggplot <- function(x, ...) {
x
}
patchwork/R/plot_spacer.R 0000644 0001762 0000144 00000001725 14277441660 015133 0 ustar ligges users #' Add a completely blank area
#'
#' This simple wrapper creates an empty transparent patch that can be added to
#' push your other plots apart. The patch responds to adding
#' [theme()][ggplot2::theme] specifications, but only `plot.background` will
#' have an effect.
#'
#' @return A `ggplot` object containing an empty plot
#'
#' @export
#'
#' @examples
#' library(ggplot2)
#'
#' p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp))
#' p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))
#'
#' p1 + plot_spacer() + p2
#'
#'
#' # To have more control over spacing, you can use the `plot.margin`
#' # parameter for `theme()` on each individual plot.
#'
#' (p1 + theme(plot.margin = unit(c(0,30,0,0), "pt"))) +
#' (p2 + theme(plot.margin = unit(c(0,0,0,30), "pt")))
#'
plot_spacer <- function() {
table <- make_patch()
class(table) <- c('spacer', class(table))
table
}
is_spacer <- function(x) inherits(x, 'spacer')
#' @export
has_tag.spacer <- function(x) FALSE
patchwork/R/add_plot.R 0000644 0001762 0000144 00000006340 14666524350 014404 0 ustar ligges users #' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.ggplot <- function(object, plot, object_name) {
patches <- get_patches(plot)
add_patches(object, patches)
}
#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.grob <- function(object, plot, object_name) {
table <- as_patch(object)
plot + wrap_elements(full = object)
}
#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.formula <- ggplot_add.grob
#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.raster <- ggplot_add.grob
#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.nativeRaster <- ggplot_add.grob
#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.gt_tbl <- function(object, plot, object_name) {
plot + wrap_table(object)
}
#' @importFrom grid is.grob
#' @importFrom grDevices is.raster
should_autowrap <- function(x) {
is.grob(x) || inherits(x, 'formula') || is.raster(x) || inherits(x, 'nativeRaster')
}
# Convert a plot with a (possible) list of patches into a self-contained
# patchwork to be attached to another plot
get_patches <- function(plot) {
empty <- is_empty(plot)
if (is_patchwork(plot)) {
patches <- plot$patches
plot$patches <- NULL
class(plot) <- setdiff(class(plot), 'patchwork')
if (is_free_plot(plot)) {
attr(plot, "patchwork_free_settings") <- NULL
if (is.null(attr(plot, "free_settings"))) {
class(plot) <- setdiff(class(plot), 'free_plot')
}
}
} else {
patches <- new_patchwork()
}
if (!empty) {
patches$plots <- c(patches$plots, list(plot))
}
patches
}
is_patchwork <- function(x) inherits(x, 'patchwork')
as_patchwork <- function(x) {
UseMethod('as_patchwork')
}
#' @export
as_patchwork.default <- function(x) {
cli_abort('Don\'t know how to convert an object of class {.cls {class(x)}} to a patchwork')
}
#' @export
as_patchwork.ggplot <- function(x) {
class(x) <- c('patchwork', class(x))
x$patches <- new_patchwork()
# Will ensure serialisation includes a link to the patchwork namespace
attr(x, 'patchwork_link') <- patchwork_namespace_link
x
}
#' @export
as_patchwork.patchwork <- function(x) x
add_patches <- function(plot, patches) {
UseMethod('add_patches')
}
#' @export
add_patches.ggplot <- function(plot, patches) {
plot <- as_patchwork(plot)
plot$patches <- patches
plot
}
#' @export
add_patches.patchwork <- function(plot, patches) {
patches$plots <- c(patches$plots, list(plot))
add_patches(plot_filler(), patches)
}
new_patchwork <- function() {
list(
plots = list(),
# We need to initialise layout and annotation with NULL values rather than waivers
layout = plot_layout(
ncol = NULL,
nrow = NULL,
byrow = NULL,
widths = NULL,
heights = NULL,
guides = NULL,
tag_level = NULL,
design = NULL,
axes = NULL,
axis_titles = NULL
),
annotation = plot_annotation(
title = NULL,
subtitle = NULL,
caption = NULL,
tag_levels = NULL,
tag_prefix = NULL,
tag_suffix = NULL,
tag_sep = NULL,
theme = NULL
)
)
}
#' @importFrom ggplot2 ggplot
plot_filler <- function() {
p <- ggplot()
class(p) <- c('plot_filler', class(p))
p
}
is_empty <- function(x) inherits(x, 'plot_filler')
#' @export
has_tag.plot_filler <- function(x) FALSE
patchwork/vignettes/ 0000755 0001762 0000144 00000000000 14671764320 014276 5 ustar ligges users patchwork/vignettes/patchwork.Rmd 0000644 0001762 0000144 00000007372 14277441660 016756 0 ustar ligges users ---
title: "Getting Started"
output:
rmarkdown::html_vignette:
fig_width: 6
fig_height: 4
vignette: >
%\VignetteIndexEntry{Getting Started}
%\VignetteEngine{knitr::rmarkdown}
%\VignetteEncoding{UTF-8}
---
```{r, include = FALSE}
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
```
```{r setup}
library(patchwork)
```
Patchwork is a package designed to make plot composition in R extremely simple
and powerful. It is mainly intended for users of ggplot2 and goes to great
lengths to make sure ggplots are properly aligned no matter the complexity of
your composition.
In this tutorial we'll work through the basics of using patchwork. In the end
you'll have a fairly good understanding of the API, and will be ready to dive
into some of the more advanced topics covered in the other vignettes.
## Example plots
We'll start by creating some example plots to use throughout this tutorial:
```{r}
library(ggplot2)
p1 <- ggplot(mtcars) +
geom_point(aes(mpg, disp)) +
ggtitle('Plot 1')
p2 <- ggplot(mtcars) +
geom_boxplot(aes(gear, disp, group = gear)) +
ggtitle('Plot 2')
p3 <- ggplot(mtcars) +
geom_point(aes(hp, wt, colour = mpg)) +
ggtitle('Plot 3')
p4 <- ggplot(mtcars) +
geom_bar(aes(gear)) +
facet_wrap(~cyl) +
ggtitle('Plot 4')
```
These plots are fairly meaningless and only serve to illustrate plot
composition - don't read anything into the resulting plots.
## Basic use
The absolute simplest use is the extension of the `+` operator used in ggplot2,
to allow adding plots together:
```{r}
p1 + p2
```
When adding plots together, the last added plot will be the active one, and will
receive any addition of new ggplot2 objects such as geoms, labels, etc:
```{r}
p1 + p2 + labs(subtitle = 'This will appear in the last plot')
```
## Controlling layout
By default, patchwork will try to keep the grid square, and fill it out in row
order
```{r}
p1 + p2 + p3 + p4
```
This can be controlled with the addition of a `plot_layout()`
```{r}
p1 + p2 + p3 + p4 + plot_layout(nrow = 3, byrow = FALSE)
```
`plot_layout()` have all sorts of amazing features for controlling the layout of
your composition. See the *Layout* vignette for a full rundown of all its
options.
## Stacking and packing plots
Often you want to place plots on top of each other, or beside each other, rather
than fill out a grid. While this can be accomplished by adding a one-row or
one-column layout, patchwork also provides two operators that does this directly
and further provides visual cues to the layout. `|` will place the plots beside
each other, while `/` will stack them:
```{r}
p1 / p2
```
As patchworks can be nested, these two operators are often enough to create
rather complex layouts:
```{r}
p1 | (p2 / p3)
```
## Annotating the composition
It is often necessary to add titles, captions, tags, etc. to a composition. This
can be achieved by adding a `plot_annotation()` to the patchwork:
```{r}
(p1 | (p2 / p3)) +
plot_annotation(title = 'The surprising story about mtcars')
```
Patchwork also provides auto-tagging capabilities, in order to identify subplots
in text:
```{r}
p1 + p2 + p3 +
plot_annotation(tag_levels = 'I')
```
The tagging can be either arabic or roman numbers, or latin letters, and
separate tags can be given for different nesting levels. See the *Annotation*
vignette for more information.
## Want more?
This is enough to get you started, but we have only scratched the surface of what
patchwork is capable of. Look into the other guides to find out more about, e.g.
how to
[collect all legends in one place and remove duplicates](https://patchwork.data-imaginist.com/articles/guides/layout.html#controlling-guides)
or [aligning plots across multiple pages](https://patchwork.data-imaginist.com/articles/guides/multipage.html).
patchwork/NAMESPACE 0000644 0001762 0000144 00000010742 14670774554 013522 0 ustar ligges users # Generated by roxygen2: do not edit by hand
S3method("&",gg)
S3method("*",gg)
S3method("-",ggplot)
S3method("/",ggplot)
S3method("[[",patchwork)
S3method("[[<-",patchwork)
S3method("|",ggplot)
S3method(add_patches,ggplot)
S3method(add_patches,patchwork)
S3method(as.list,patchwork)
S3method(as_patch,formula)
S3method(as_patch,gList)
S3method(as_patch,ggplot)
S3method(as_patch,grob)
S3method(as_patch,gt_tbl)
S3method(as_patch,nativeRaster)
S3method(as_patch,patchwork)
S3method(as_patch,raster)
S3method(as_patchwork,default)
S3method(as_patchwork,ggplot)
S3method(as_patchwork,patchwork)
S3method(c,patch_area)
S3method(get_dim,ggplot)
S3method(get_dim,patchwork)
S3method(ggplot_add,formula)
S3method(ggplot_add,ggplot)
S3method(ggplot_add,grob)
S3method(ggplot_add,gt_tbl)
S3method(ggplot_add,nativeRaster)
S3method(ggplot_add,plot_annotation)
S3method(ggplot_add,plot_layout)
S3method(ggplot_add,raster)
S3method(ggplot_build,fixed_dim_ggplot)
S3method(ggplot_gtable,fixed_dim_build)
S3method(has_tag,ggplot)
S3method(has_tag,guide_area)
S3method(has_tag,inset_patch)
S3method(has_tag,plot_filler)
S3method(has_tag,spacer)
S3method(has_tag,wrapped_patch)
S3method(length,patch_area)
S3method(length,patchwork)
S3method(merge,ggplot)
S3method(merge,patchwork)
S3method(names,patchwork)
S3method(patchGrob,guide_area)
S3method(patchGrob,patch)
S3method(patchGrob,table_patch)
S3method(patchGrob,wrapped_patch)
S3method(patchGrob,wrapped_table)
S3method(plot,inset_patch)
S3method(plot,patch)
S3method(plot,patch_area)
S3method(plot,patchwork)
S3method(plot_table,free_plot)
S3method(plot_table,ggplot)
S3method(plot_table,inset_patch)
S3method(plot_table,patch)
S3method(plot_table,patchwork)
S3method(print,inset_patch)
S3method(print,patch)
S3method(print,patch_area)
S3method(print,patchwork)
S3method(print,plot_dimension)
S3method(set_dim,ggplot)
S3method(set_dim,patchwork)
S3method(simplify_gt,free_table)
S3method(simplify_gt,gtable)
S3method(simplify_gt,gtable_patchwork)
S3method(simplify_gt,inset_table)
S3method(simplify_gt,patchgrob)
S3method(str,patchwork)
export(align_patches)
export(align_plots)
export(area)
export(free)
export(get_dim)
export(get_max_dim)
export(guide_area)
export(inset_element)
export(patchGrob)
export(patchworkGrob)
export(plot_annotation)
export(plot_layout)
export(plot_spacer)
export(set_dim)
export(wrap_elements)
export(wrap_ggplot_grob)
export(wrap_plots)
export(wrap_table)
import(cli)
import(rlang)
importFrom(farver,get_channel)
importFrom(farver,set_channel)
importFrom(ggplot2,aes)
importFrom(ggplot2,calc_element)
importFrom(ggplot2,element_blank)
importFrom(ggplot2,element_grob)
importFrom(ggplot2,element_line)
importFrom(ggplot2,element_render)
importFrom(ggplot2,element_text)
importFrom(ggplot2,find_panel)
importFrom(ggplot2,geom_blank)
importFrom(ggplot2,geom_rect)
importFrom(ggplot2,ggplot)
importFrom(ggplot2,ggplotGrob)
importFrom(ggplot2,ggplot_add)
importFrom(ggplot2,ggplot_build)
importFrom(ggplot2,ggplot_gtable)
importFrom(ggplot2,is.ggplot)
importFrom(ggplot2,is.theme)
importFrom(ggplot2,labs)
importFrom(ggplot2,margin)
importFrom(ggplot2,max_height)
importFrom(ggplot2,max_width)
importFrom(ggplot2,panel_cols)
importFrom(ggplot2,panel_rows)
importFrom(ggplot2,scale_x_continuous)
importFrom(ggplot2,scale_y_reverse)
importFrom(ggplot2,set_last_plot)
importFrom(ggplot2,theme)
importFrom(ggplot2,theme_get)
importFrom(ggplot2,theme_void)
importFrom(ggplot2,waiver)
importFrom(ggplot2,wrap_dims)
importFrom(ggplot2,zeroGrob)
importFrom(grDevices,is.raster)
importFrom(grid,absolute.size)
importFrom(grid,convertHeight)
importFrom(grid,convertWidth)
importFrom(grid,editGrob)
importFrom(grid,gTree)
importFrom(grid,grid.draw)
importFrom(grid,grid.newpage)
importFrom(grid,grobHeight)
importFrom(grid,grobTree)
importFrom(grid,grobWidth)
importFrom(grid,heightDetails)
importFrom(grid,is.grob)
importFrom(grid,is.unit)
importFrom(grid,pushViewport)
importFrom(grid,rasterGrob)
importFrom(grid,seekViewport)
importFrom(grid,unit)
importFrom(grid,unit.c)
importFrom(grid,unit.pmax)
importFrom(grid,upViewport)
importFrom(grid,valid.just)
importFrom(grid,viewport)
importFrom(grid,widthDetails)
importFrom(gtable,gtable)
importFrom(gtable,gtable_add_cols)
importFrom(gtable,gtable_add_grob)
importFrom(gtable,gtable_add_rows)
importFrom(gtable,gtable_height)
importFrom(gtable,gtable_width)
importFrom(gtable,is.gtable)
importFrom(stats,ave)
importFrom(stats,na.omit)
importFrom(utils,as.roman)
importFrom(utils,getFromNamespace)
importFrom(utils,modifyList)
importFrom(utils,str)
importFrom(utils,tail)
patchwork/LICENSE 0000644 0001762 0000144 00000000061 13207337010 013252 0 ustar ligges users YEAR: 2017
COPYRIGHT HOLDER: Thomas Lin Pedersen
patchwork/NEWS.md 0000644 0001762 0000144 00000012460 14671764257 013400 0 ustar ligges users # patchwork 1.3.0
* `free()` now better aligns plots in horizontal direction
* Plot backgrounds are now always placed beneath all other elements in the
patchwork (#370)
* Axis titles can now reliably be collected even with faceted plots (#367)
* Native support for gt objects, either adding them directly or controlling
their layout with `wrap_table()`
* Empty patches no longer breaks up axis title collection (#375)
* `wrap_ggplot_grob()` now respects auto-tagging (#363)
* Fix a bug where guide collecting would prevent proper axes collecting (#359)
* Fix a bug in `free()` where tags placed on top of the plot region would become
missing (#350)
* `free()` gains `type` and `side` argument. The first to control whether to
free the panel, the label, or the space occupied outside the panel, the second
to control which sides it applies to (#345 and #379)
* `as.list()` is now provided for patchwork objects to get the plots in a
patchwork as a list. This also allows the use of `lapply()` and friends on
patchwork objects (#381)
* The default arguments in `plot_annotation()` and `plot_layout()` are now
`waiver()` allowing the use of `NULL` to remove an already set value (#198)
* Guide and axis merging is slightly more robust when it comes to merging if
different graphical parameters that means the same are used (e.g. "black" and
"#000000") (#369)
* fix a bug when collecting guides with null unit key size (#390)
* Added `nest()` to explicitly nest a patchwork on the LHS of an operator
# patchwork 1.2.0
* Axes and axis titles can now be collected using the `plot_layout()` function.
Collecting axes will remove duplicated axes in the x- or y-direction.
Collecting axis titles will also remove duplicated titles in the x- or
y-direction, but also merge duplicated titles in the other direction (#150).
* Fix a bug that prevented faceted plots with axes on the right from being
used (#340)
* Added `free()` function to mark a plot to not be aligned with the rest. The
margin of the plot will still be aligned with the margins of the other plots
but everything inside of that will by unaligned.
# patchwork 1.1.3
* `NULL` can now be used with the different arithmetic operators and will result
in a non-operation (i.e. the non-null part will be returned unmodified) (#290)
* Fix a bug that prevented plots with multi-level strips from being merged
together (#277)
* Patchworks will now render correctly when unserialised in a fresh session,
providing the patchwork package is available (#242)
* Fixed a bug preventing faceted plots with strip placement outside the axis
from being aligned (#325)
* Fixed a bug that let to inconsistent results when combining fixed aspect plots
in different order (#274)
* Fixed a bug that prevented nested patchworks with empty columns or rows at the
bottom or to the right to be inserted into a layout (#273)
* Patchwork objects now behaves more correctly like an unnamed list of ggplots.
This makes `View()` work on them (#317), and allow one to use `length()` to
determine the number of patches in a patchwork (#293)
* Expressions and calls can now be used as plot annotations in the same way as
they can be used for titles in ggplot2 (#295)
# patchwork 1.1.2
* Better error message if rendering fails due to too small plotting space
# patchwork 1.1.1
* Use vdiffr conditionally to pass test on M1 mac
* Add `str()` method to patchwork objects (#217)
* Fix a bug in `inset_element()` when insetting plots with fixed dimensions
(#214)
* Make sure that `-`, `/`, and `|` works with all supported object types (#221)
# patchwork 1.1.0
* Add `inset_element()` to allow adding plots as insets
* patchwork now supports `raster` and `nativeRaster` objects
* Avoid incrementing tag counter when recursing into a nested plot without
additional tags to use (#147)
* Fix bug that prevented strips turned off with `element_blank()` from working
(#200)
* Add option to supply a custom sequence of tags to use for auto-tagging (#211,
#63)
# patchwork 1.0.1
* Renaming of `align_plots()` to `align_patches()` to avoid namespace clash
with cowplot (#130)
* Renaming of `as_grob()` (unexported) to `as_patch()` to avoid potential
future namespace clash with cowplot (#131)
* Fix bug in plot simplification with `theme(strip.placement = 'outside')`
(#132)
* Fix a bug in guide collection in R >= 4.0 due to the new unit implementation
in grid (#170)
* Collected guides now behave as ggplot2 guides when position is top or bottom
(#137)
* Fix a bug in base graphic support where the environment of the plot was not
captured (#138)
* Fix a bug when combining plots having guides placed manually in combination
with faceting (#144)
* Fix a bug where having negative margins around the legend would result in an
unintelligeble error (#148)
* Fix a bug when trying to combine faceted plots with fixed aspect ratio (#156)
* Fix alignments of strips when only a single strip is present (#163)
* Fix a bug that caused theme void to result in errors (#180)
* Make aligning multiple fixed aspect plots more consistent (#175)
* Correct alignment of guides when ssembling fixed aspect plots (#140,
@ilia-kats)
# patchwork 1.0.0
* First CRAN release. Provide utility and operators for assembling and nesting
plots into a composition, tag subplots, collect guides and remove duplicates,
and align plots across pages.
patchwork/inst/ 0000755 0001762 0000144 00000000000 14671764317 013251 5 ustar ligges users patchwork/inst/doc/ 0000755 0001762 0000144 00000000000 14671764317 014016 5 ustar ligges users patchwork/inst/doc/patchwork.R 0000644 0001762 0000144 00000003165 14671764317 016150 0 ustar ligges users ## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
## ----setup--------------------------------------------------------------------
library(patchwork)
## -----------------------------------------------------------------------------
library(ggplot2)
p1 <- ggplot(mtcars) +
geom_point(aes(mpg, disp)) +
ggtitle('Plot 1')
p2 <- ggplot(mtcars) +
geom_boxplot(aes(gear, disp, group = gear)) +
ggtitle('Plot 2')
p3 <- ggplot(mtcars) +
geom_point(aes(hp, wt, colour = mpg)) +
ggtitle('Plot 3')
p4 <- ggplot(mtcars) +
geom_bar(aes(gear)) +
facet_wrap(~cyl) +
ggtitle('Plot 4')
## -----------------------------------------------------------------------------
p1 + p2
## -----------------------------------------------------------------------------
p1 + p2 + labs(subtitle = 'This will appear in the last plot')
## -----------------------------------------------------------------------------
p1 + p2 + p3 + p4
## -----------------------------------------------------------------------------
p1 + p2 + p3 + p4 + plot_layout(nrow = 3, byrow = FALSE)
## -----------------------------------------------------------------------------
p1 / p2
## -----------------------------------------------------------------------------
p1 | (p2 / p3)
## -----------------------------------------------------------------------------
(p1 | (p2 / p3)) +
plot_annotation(title = 'The surprising story about mtcars')
## -----------------------------------------------------------------------------
p1 + p2 + p3 +
plot_annotation(tag_levels = 'I')
patchwork/inst/doc/patchwork.Rmd 0000644 0001762 0000144 00000007372 14277441660 016470 0 ustar ligges users ---
title: "Getting Started"
output:
rmarkdown::html_vignette:
fig_width: 6
fig_height: 4
vignette: >
%\VignetteIndexEntry{Getting Started}
%\VignetteEngine{knitr::rmarkdown}
%\VignetteEncoding{UTF-8}
---
```{r, include = FALSE}
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
```
```{r setup}
library(patchwork)
```
Patchwork is a package designed to make plot composition in R extremely simple
and powerful. It is mainly intended for users of ggplot2 and goes to great
lengths to make sure ggplots are properly aligned no matter the complexity of
your composition.
In this tutorial we'll work through the basics of using patchwork. In the end
you'll have a fairly good understanding of the API, and will be ready to dive
into some of the more advanced topics covered in the other vignettes.
## Example plots
We'll start by creating some example plots to use throughout this tutorial:
```{r}
library(ggplot2)
p1 <- ggplot(mtcars) +
geom_point(aes(mpg, disp)) +
ggtitle('Plot 1')
p2 <- ggplot(mtcars) +
geom_boxplot(aes(gear, disp, group = gear)) +
ggtitle('Plot 2')
p3 <- ggplot(mtcars) +
geom_point(aes(hp, wt, colour = mpg)) +
ggtitle('Plot 3')
p4 <- ggplot(mtcars) +
geom_bar(aes(gear)) +
facet_wrap(~cyl) +
ggtitle('Plot 4')
```
These plots are fairly meaningless and only serve to illustrate plot
composition - don't read anything into the resulting plots.
## Basic use
The absolute simplest use is the extension of the `+` operator used in ggplot2,
to allow adding plots together:
```{r}
p1 + p2
```
When adding plots together, the last added plot will be the active one, and will
receive any addition of new ggplot2 objects such as geoms, labels, etc:
```{r}
p1 + p2 + labs(subtitle = 'This will appear in the last plot')
```
## Controlling layout
By default, patchwork will try to keep the grid square, and fill it out in row
order
```{r}
p1 + p2 + p3 + p4
```
This can be controlled with the addition of a `plot_layout()`
```{r}
p1 + p2 + p3 + p4 + plot_layout(nrow = 3, byrow = FALSE)
```
`plot_layout()` have all sorts of amazing features for controlling the layout of
your composition. See the *Layout* vignette for a full rundown of all its
options.
## Stacking and packing plots
Often you want to place plots on top of each other, or beside each other, rather
than fill out a grid. While this can be accomplished by adding a one-row or
one-column layout, patchwork also provides two operators that does this directly
and further provides visual cues to the layout. `|` will place the plots beside
each other, while `/` will stack them:
```{r}
p1 / p2
```
As patchworks can be nested, these two operators are often enough to create
rather complex layouts:
```{r}
p1 | (p2 / p3)
```
## Annotating the composition
It is often necessary to add titles, captions, tags, etc. to a composition. This
can be achieved by adding a `plot_annotation()` to the patchwork:
```{r}
(p1 | (p2 / p3)) +
plot_annotation(title = 'The surprising story about mtcars')
```
Patchwork also provides auto-tagging capabilities, in order to identify subplots
in text:
```{r}
p1 + p2 + p3 +
plot_annotation(tag_levels = 'I')
```
The tagging can be either arabic or roman numbers, or latin letters, and
separate tags can be given for different nesting levels. See the *Annotation*
vignette for more information.
## Want more?
This is enough to get you started, but we have only scratched the surface of what
patchwork is capable of. Look into the other guides to find out more about, e.g.
how to
[collect all legends in one place and remove duplicates](https://patchwork.data-imaginist.com/articles/guides/layout.html#controlling-guides)
or [aligning plots across multiple pages](https://patchwork.data-imaginist.com/articles/guides/multipage.html).
patchwork/inst/doc/patchwork.html 0000644 0001762 0000144 00001424204 14671764317 016715 0 ustar ligges users
Getting Started
Getting Started
Patchwork is a package designed to make plot composition in R
extremely simple and powerful. It is mainly intended for users of
ggplot2 and goes to great lengths to make sure ggplots are properly
aligned no matter the complexity of your composition.
In this tutorial we’ll work through the basics of using patchwork. In
the end you’ll have a fairly good understanding of the API, and will be
ready to dive into some of the more advanced topics covered in the other
vignettes.
Example plots
We’ll start by creating some example plots to use throughout this
tutorial:
library(ggplot2)
p1 <- ggplot(mtcars) +
geom_point(aes(mpg, disp)) +
ggtitle('Plot 1')
p2 <- ggplot(mtcars) +
geom_boxplot(aes(gear, disp, group = gear)) +
ggtitle('Plot 2')
p3 <- ggplot(mtcars) +
geom_point(aes(hp, wt, colour = mpg)) +
ggtitle('Plot 3')
p4 <- ggplot(mtcars) +
geom_bar(aes(gear)) +
facet_wrap(~cyl) +
ggtitle('Plot 4')
These plots are fairly meaningless and only serve to illustrate plot
composition - don’t read anything into the resulting plots.
Basic use
The absolute simplest use is the extension of the +
operator used in ggplot2, to allow adding plots together:

When adding plots together, the last added plot will be the active
one, and will receive any addition of new ggplot2 objects such as geoms,
labels, etc:
p1 + p2 + labs(subtitle = 'This will appear in the last plot')

Controlling layout
By default, patchwork will try to keep the grid square, and fill it
out in row order

This can be controlled with the addition of a
plot_layout()
p1 + p2 + p3 + p4 + plot_layout(nrow = 3, byrow = FALSE)

plot_layout()
have all sorts of amazing features for
controlling the layout of your composition. See the Layout
vignette for a full rundown of all its options.
Stacking and packing plots
Often you want to place plots on top of each other, or beside each
other, rather than fill out a grid. While this can be accomplished by
adding a one-row or one-column layout, patchwork also provides two
operators that does this directly and further provides visual cues to
the layout. |
will place the plots beside each other, while
/
will stack them:

As patchworks can be nested, these two operators are often enough to
create rather complex layouts:

Annotating the composition
It is often necessary to add titles, captions, tags, etc. to a
composition. This can be achieved by adding a
plot_annotation()
to the patchwork:
(p1 | (p2 / p3)) +
plot_annotation(title = 'The surprising story about mtcars')

Patchwork also provides auto-tagging capabilities, in order to
identify subplots in text:
p1 + p2 + p3 +
plot_annotation(tag_levels = 'I')

The tagging can be either arabic or roman numbers, or latin letters,
and separate tags can be given for different nesting levels. See the
Annotation vignette for more information.
patchwork/README.md 0000644 0001762 0000144 00000005510 14666010403 013534 0 ustar ligges users
# patchwork
[](https://github.com/thomasp85/patchwork/actions/workflows/R-CMD-check.yaml)
[](https://CRAN.R-project.org/package=patchwork)
[](https://CRAN.R-project.org/package=patchwork)
[](https://app.codecov.io/gh/thomasp85/patchwork?branch=main)
The goal of `patchwork` is to make it ridiculously simple to combine
separate ggplots into the same graphic. As such it tries to solve the
same problem as `gridExtra::grid.arrange()` and `cowplot::plot_grid` but
using an API that incites exploration and iteration, and scales to
arbitrarily complex layouts.
## Installation
You can install patchwork from CRAN using
`install.packages('patchwork')`. Alternatively you can grab the
development version from github using devtools:
``` r
# install.packages("devtools")
devtools::install_github("thomasp85/patchwork")
```
## Basic example
The usage of `patchwork` is simple: just add plots together!
``` r
library(ggplot2)
library(patchwork)
p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp))
p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))
p1 + p2
```

patchwork provides rich support for arbitrarily complex layouts with
full alignment. As an example, check out this very readable code for
nesting three plots on top of a third:
``` r
p3 <- ggplot(mtcars) + geom_smooth(aes(disp, qsec))
p4 <- ggplot(mtcars) + geom_bar(aes(carb))
(p1 | p2 | p3) /
p4
```

## Learn more
patchwork can do so much more. Check out the guides for learning
everything there is to know about all the different features:
- [Getting
Started](https://patchwork.data-imaginist.com/articles/patchwork.html)
- [Assembling
Plots](https://patchwork.data-imaginist.com/articles/guides/assembly.html)
- [Defining
Layouts](https://patchwork.data-imaginist.com/articles/guides/layout.html)
- [Adding
Annotation](https://patchwork.data-imaginist.com/articles/guides/annotation.html)
- [Aligning across
pages](https://patchwork.data-imaginist.com/articles/guides/multipage.html)
## Code of Conduct
Please note that the patchwork project is released with a [Contributor
Code of
Conduct](https://patchwork.data-imaginist.com/CODE_OF_CONDUCT.html). By
contributing to this project, you agree to abide by its terms.
patchwork/build/ 0000755 0001762 0000144 00000000000 14671764317 013373 5 ustar ligges users patchwork/build/vignette.rds 0000644 0001762 0000144 00000000320 14671764317 015725 0 ustar ligges users mPK0-P?`P. 8.6P/eΓ$37,Ƙ8טn`j8ktqfi¸.
H B!K T9q}@"