Skip to content

Commit

Permalink
add layout_* function to control the layout behaviour
Browse files Browse the repository at this point in the history
  • Loading branch information
Yunuuuu committed Oct 8, 2024
1 parent e8939ad commit ddc82a0
Show file tree
Hide file tree
Showing 9 changed files with 360 additions and 121 deletions.
9 changes: 8 additions & 1 deletion NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
# Generated by roxygen2: do not edit by hand

S3method("$<-",Align)
S3method("+",alignpatches)
S3method("[",align_area)
S3method(align_add,Coord)
S3method(align_add,default)
Expand Down Expand Up @@ -36,6 +37,11 @@ S3method(alignpatch,spacer)
S3method(alignpatch,trellis)
S3method(alignpatch,wrapped_patch)
S3method(alignpatch,wrapped_plot)
S3method(alignpatches_add,layout_annotation)
S3method(alignpatches_add,layout_design)
S3method(alignpatches_add,layout_titles)
S3method(alignpatches_add,plot_annotation)
S3method(alignpatches_add,plot_layout)
S3method(as_areas,"NULL")
S3method(as_areas,align_area)
S3method(as_areas,character)
Expand Down Expand Up @@ -200,7 +206,8 @@ export(inset)
export(is.ggheatmap)
export(is.ggstack)
export(layout_annotation)
export(layout_theme)
export(layout_design)
export(layout_titles)
export(order2)
export(patch)
export(patch_titles)
Expand Down
16 changes: 10 additions & 6 deletions R/alignpatch-.R
Original file line number Diff line number Diff line change
Expand Up @@ -10,16 +10,17 @@
# - `free_vp()`: not added
# 3. Added titles around the plot top, left, bottom, and right
# (`patch_titles()`)
TABLE_ROWS <- 18L + 2L
TABLE_COLS <- 15L + 2L
TABLE_ROWS <- 18L + 2L + 2L
TABLE_COLS <- 15L + 2L + 2L

TOP_BORDER <- 9L + 1L
LEFT_BORDER <- 7L + 1L
BOTTOM_BORDER <- 8L + 1L
RIGHT_BORDER <- 7L + 1L
TOP_BORDER <- 9L + 1L + 1L
LEFT_BORDER <- 7L + 1L + 1L
BOTTOM_BORDER <- 8L + 1L + 1L
RIGHT_BORDER <- 7L + 1L + 1L

# top-bottom
# 1: margin
# feature: insert layout patch title
# 2: tag
# 3: title
# 4: subtitle
Expand All @@ -39,11 +40,13 @@ RIGHT_BORDER <- 7L + 1L
# 15: guide-box-bottom
# 16: caption
# 17: tag
# feature: insert layout patch title
# 18: margin

# left-right
#
# 1: margin
# feature: insert layout patch title
# 2: tag
# 3: guide-box-left
# 4: legend.box.spacing
Expand All @@ -57,6 +60,7 @@ RIGHT_BORDER <- 7L + 1L
# 12: legend.box.spacing
# 13: guide-box-right
# 14: tag
# feature: insert layout patch title
# 15: margin

.TLBR <- c("top", "left", "bottom", "right")
Expand Down
240 changes: 196 additions & 44 deletions R/alignpatch-align_plots.R
Original file line number Diff line number Diff line change
Expand Up @@ -15,10 +15,11 @@
#' either be specified as a text string or by concatenating calls to
#' [area()] together.
#' @param guides `r rd_guides()`
#' @inheritParams ggplot2::labs
#' @param theme A [`theme()`][ggplot2::theme] object to rendering the guides
#' title, subtitle, caption, margins and background.
#' @return A `alignpatches` object.
#' @return An `alignpatches` object.
#' @seealso
#' - [layout_design()]
#' - [layout_titles()]
#' - [layout_annotation()]
#' @examples
#' # directly copied from patchwork
#' p1 <- ggplot(mtcars) +
Expand Down Expand Up @@ -49,11 +50,8 @@
#' @export
align_plots <- function(..., ncol = NULL, nrow = NULL, byrow = TRUE,
widths = NA, heights = NA,
design = NULL, guides = waiver(),
title = NULL, subtitle = NULL, caption = NULL,
theme = NULL) {
design = NULL, guides = waiver()) {
plots <- rlang::dots_list(..., .ignore_empty = "all")
assert_s3_class(theme, "theme", null_ok = TRUE)
nms <- names(plots)
if (!is.null(nms) && is.character(design)) {
area_names <- unique(trimws(.subset2(strsplit(design, ""), 1L)))
Expand All @@ -65,12 +63,11 @@ align_plots <- function(..., ncol = NULL, nrow = NULL, byrow = TRUE,
plots <- plot_list
}
}
design <- as_areas(design)
patches <- lapply(plots, alignpatch)

# setup layout
if (!is.waive(byrow)) assert_bool(byrow)
if (!is.waive(design)) design <- as_areas(design)
# setup layout parameters
assert_bool(byrow)
design <- as_areas(design)
if (!is.waive(guides) && !is.null(guides)) {
assert_position(guides)
guides <- setup_pos(guides)
Expand All @@ -80,26 +77,26 @@ align_plots <- function(..., ncol = NULL, nrow = NULL, byrow = TRUE,
widths = widths, heights = heights, design = design,
guides = guides
)
# setup annotation
annotation <- layout_annotation(
title = title,
subtitle = subtitle,
caption = caption
)
annotation <- annotation[
!vapply(annotation, is.waive, logical(1L), USE.NAMES = FALSE)
]
new_alignpatches(patches,
layout = layout, annotation = annotation,
theme = theme
)
new_alignpatches(patches, layout = layout)
}

new_alignpatches <- function(patches, layout, annotation, theme) {
new_alignpatches <- function(patches,
layout = NULL,
titles = list(),
patch_titles = list(),
theme = NULL) {
layout <- layout %||% list(
ncol = NULL, nrow = NULL, byrow = TRUE,
widths = NA, heights = NA,
design = NULL, guides = waiver()
)
structure(
list(
patches = patches, layout = layout,
annotation = annotation, theme = theme
patches = patches,
layout = layout,
patch_titles = patch_titles,
titles = titles,
theme = theme
),
# Will ensure serialisation includes a link to the `ggalign`
# namespace
Expand All @@ -108,11 +105,47 @@ new_alignpatches <- function(patches, layout, annotation, theme) {
)
}

#' @export
`+.alignpatches` <- function(e1, e2) {
if (missing(e2)) {
cli::cli_abort(c(
"Cannot use {.code +} with a single argument.",
"i" = "Did you accidentally put {.code +} on a new line?"
))
}

# Get the name of what was passed in as e2, and pass along so that it
# can be displayed in error messages
e2name <- deparse(substitute(e2))
alignpatches_add(e2, e1, e2name)
}

alignpatches_add <- function(object, plot, object_name) {
UseMethod("alignpatches_add")
}

#############################################################
#' @inherit patchwork::plot_layout
#' @inheritParams patchwork::plot_layout
#' Define the grid to compose plots in
#'
#' To control how different plots are laid out, you need to add a layout design
#' specification. If you are nesting grids, the layout is scoped to the current
#' nesting level.
#' @inheritParams align_plots
#' @return A `layout_design` object.
#' @examples
#' 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)
#' align_plots(p1, p2, p3) +
#' layout_design(nrow = 1L)
#' align_plots(p1, p2, p3) +
#' layout_design(ncol = 1L)
#' @importFrom ggplot2 waiver
#' @noRd
#' @export
layout_design <- function(ncol = waiver(), nrow = waiver(), byrow = waiver(),
widths = waiver(), heights = waiver(),
design = waiver(), guides = NA) {
Expand All @@ -133,30 +166,149 @@ layout_design <- function(ncol = waiver(), nrow = waiver(), byrow = waiver(),
), class = c("layout_design", "plot_layout"))
}

#' @importFrom utils modifyList
alignpatches_update <- function(old, new) {
modifyList(old, new[!vapply(new, is.waive, logical(1L))], keep.null = TRUE)
}

update_layout_design <- function(old, new) {
guides <- .subset2(new, "guides")
new <- .subset(new, setdiff(names(new), "guides"))
old <- alignpatches_update(old, new)
if (!identical(guides, NA)) old$guides <- guides
old
}

#' @export
alignpatches_add.layout_design <- function(object, plot, object_name) {
plot$layout <- update_layout_design(.subset2(plot, "layout"), object)
plot
}

#' @export
alignpatches_add.plot_layout <- function(object, plot, object_name) {
object <- .subset(object, names(layout_design()))
if (is.waive(object$guides)) {
object$guides <- NA
} else if (identical(object$guides, "auto")) {
object$guides <- waiver()
} else if (identical(object$guides, "collect")) {
object$guides <- .TLBR
} else if (identical(object$guides, "keep")) {
object["guides"] <- list(NULL)
}
plot$layout <- update_layout_design(.subset2(plot, "layout"), object)
plot
}

##############################################################
#' Annotate the whole layout
#'
#' @inheritParams ggplot2::labs
#' @return A `layout_annotation` object to be added into `r rd_layout()`.
#' @return A `layout_titles` object.
#' @examples
#' 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)
#' align_plots(p1, p2, p3) +
#' layout_titles(title = "I'm title")
#' @importFrom ggplot2 waiver
#' @export
layout_annotation <- function(title = waiver(), subtitle = waiver(),
caption = waiver()) {
layout_titles <- function(title = waiver(), subtitle = waiver(),
caption = waiver()) {
structure(
list(title = title, subtitle = subtitle, caption = caption),
class = c("layout_annotation", "plot_annotation")
class = c("layout_titles", "plot_annotation")
)
}

#' Modify components of the layout theme
#' @export
alignpatches_add.layout_titles <- function(object, plot, object_name) {
plot$titles <- alignpatches_update(.subset2(plot, "titles"), object)
plot
}

##############################################################
#' Modify components of the layout
#'
#' - Add patch titles to the layout
#' - modify the theme of the layout
#' @inheritParams patch_titles
#' @param theme A [`theme()`][ggplot2::theme] used to render the `guides`,
#' `title`, `subtitle`, `caption`, `margins`, `patch.title`, `panel.border`, and
#' `background`.
#'
#' @details
#' - `guides`, `patch.title`, `panel.border`, and `background` will always be
#' added even for the nested `alignpatches` object.
#'
#' Used to render the `guides`, `title`, `subtitle`, `caption`,
#' `margins`, `panel.border` `background`.
#' - `title`, `subtitle`, `caption`, and `margins` will be added for the
#' top-level `alignpatches` object only.
#'
#' @inherit ggplot2::theme description sections references author source note format
#' @param ... Additional arguments passed to [theme()][ggplot2::theme].
#' @return A `layout_theme` object to be added to `r rd_layout()`.
#' @examples
#' layout_theme(plot.background = element_rect(fill = "green"))
#' @importFrom ggplot2 theme
#' 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)
#' align_plots(
#' p1 + theme(plot.background = element_blank()),
#' p2 + theme(plot.background = element_blank()),
#' p3 + theme(plot.background = element_blank())
#' ) +
#' layout_annotation(
#' theme = theme(plot.background = element_rect(fill = "red"))
#' )
#' @importFrom ggplot2 waiver
#' @export
layout_annotation <- function(top = waiver(), left = waiver(),
bottom = waiver(), right = waiver(),
theme = NULL) {
titles <- patch_titles(
top = top, left = left, bottom = bottom,
right = right
)
if (!is.null(theme) && !is.waive(theme)) assert_s3_class(theme, "theme")
structure(
list(titles = titles, theme = theme),
class = c("layout_annotation", "plot_annotation")
)
}

#' @export
layout_theme <- function(...) add_class(ggplot2::theme(...), "layout_theme")
alignpatches_add.layout_annotation <- function(object, plot, object_name) {
plot$patch_titles <- alignpatches_update(
.subset2(plot, "patch_titles"),
.subset2(object, "titles")
)
if (!is.null(theme <- .subset2(object, "theme"))) {
if (is.waive(theme)) {
plot$theme <- theme
} else {
plot$theme <- ggfun("add_theme")(
.subset2(plot, "theme"), theme, object_name
)
}
}
plot
}

#' @export
alignpatches_add.plot_annotation <- function(object, plot, object_name) {
plot$titles <- alignpatches_update(
.subset2(plot, "titles"),
.subset(object, names(layout_titles()))
)
if (!is.waive(new_theme <- .subset2(object, "theme"))) {
plot$theme <- ggfun("add_theme")(
.subset2(plot, "theme"), new_theme, object_name
)
}
plot
}
Loading

0 comments on commit ddc82a0

Please sign in to comment.