add function layout_theme() and layout_annotation()

Author: Yunuuuu

NAMESPACE

@@ -35,7 +35,6 @@ S3method(alignpatch,spacer)
 S3method(alignpatch,trellis)
 S3method(alignpatch,wrapped_patch)
 S3method(alignpatch,wrapped_plot)
-S3method(as.list,alignpatches)
 S3method(as_areas,"NULL")
 S3method(as_areas,align_area)
 S3method(as_areas,character)
@@ -90,16 +89,15 @@ S3method(grid.draw,patch_ggplot)
 S3method(heatmap_add,facetted_pos_scales)
 S3method(heatmap_add,gg)
 S3method(heatmap_add,labels)
+S3method(heatmap_layout,"NULL")
+S3method(heatmap_layout,default)
+S3method(heatmap_layout,formula)
+S3method(heatmap_layout,functon)
+S3method(heatmap_layout,matrix)
 S3method(layout_add,HeatmapLayout)
 S3method(layout_add,StackLayout)
 S3method(layout_and_add,HeatmapLayout)
 S3method(layout_and_add,StackLayout)
-S3method(layout_heatmap,"NULL")
-S3method(layout_heatmap,default)
-S3method(layout_heatmap,formula)
-S3method(layout_heatmap,functon)
-S3method(layout_heatmap,matrix)
-S3method(layout_heatmap_add,"NULL")
 S3method(layout_heatmap_add,Align)
 S3method(layout_heatmap_add,data.frame)
 S3method(layout_heatmap_add,default)
@@ -120,13 +118,6 @@ S3method(layout_heatmap_subtract,facetted_pos_scales)
 S3method(layout_heatmap_subtract,gg)
 S3method(layout_heatmap_subtract,ggplot)
 S3method(layout_heatmap_subtract,labels)
-S3method(layout_stack,"NULL")
-S3method(layout_stack,character)
-S3method(layout_stack,data.frame)
-S3method(layout_stack,default)
-S3method(layout_stack,matrix)
-S3method(layout_stack,numeric)
-S3method(layout_stack_add,"NULL")
 S3method(layout_stack_add,Align)
 S3method(layout_stack_add,HeatmapLayout)
 S3method(layout_stack_add,default)
@@ -180,6 +171,12 @@ S3method(set_context,HeatmapLayout)
 S3method(set_context,StackLayout)
 S3method(set_layout,HeatmapLayout)
 S3method(set_layout,StackLayout)
+S3method(stack_layout,"NULL")
+S3method(stack_layout,character)
+S3method(stack_layout,data.frame)
+S3method(stack_layout,default)
+S3method(stack_layout,matrix)
+S3method(stack_layout,numeric)
 export(Align)
 export(GeomDraw)
 export(align)
@@ -207,16 +204,18 @@ export(ggpanel)
 export(ggstack)
 export(gpar)
 export(hclust2)
+export(heatmap_layout)
 export(hmanno)
 export(inset)
 export(is.ggheatmap)
 export(is.ggstack)
-export(layout_heatmap)
-export(layout_stack)
+export(layout_annotation)
+export(layout_theme)
 export(patch)
 export(patch_titles)
 export(read_example)
 export(stack_active)
+export(stack_layout)
 export(unit)
 export(wrap)
 exportMethods("$")

R/activate.R

@@ -29,11 +29,11 @@
 #' Used to modify the data after layout has been created, but before the data is
 #' handled of to the ggplot2 for rendering. Use this hook if the you needs
 #' change the default data for all `geoms`.
-#' @param theme `r rd_theme()` Only used when position is `NULL`.
+#' @param theme `r rd_layout_theme()` Only used when position is `NULL`.
 #' @param what What should get activated for the anntoation stack? Only used
 #' when position is not `NULL`. See [stack_active] for details.
 #' @return A `heatmap_active` object which can be added into
-#' [HeatmapLayout][layout_heatmap].
+#' [HeatmapLayout][heatmap_layout].
 #' @examples
 #' ggheatmap(matrix(rnorm(81), nrow = 9)) +
 #'     hmanno("top") +
@@ -86,11 +86,11 @@ hmanno <- function(position = NULL, size = NULL, width = NULL, height = NULL,
 #'      Usually you are waive to use this, since the adding procedure can be
 #'      easily changed.
 #'    * `NULL`: Remove any active context, this is useful when the active
-#'      context is a [layout_heatmap()] object, where any `Align` objects will
+#'      context is a [heatmap_layout()] object, where any `Align` objects will
 #'      be added into the heatmap. By removing the active context, we can add
-#'      `Align` object into the [layout_stack()] .
+#'      `Align` object into the [stack_layout()] .
 #' @return A `stack_active` object which can be added into
-#' [StackLayout][layout_stack].
+#' [StackLayout][stack_layout].
 #' @examples
 #' ggstack(matrix(1:9, nrow = 3L)) +
 #'     ggheatmap() +

R/align-.R

@@ -14,12 +14,12 @@
 #' the observations. It means the `NROW(data)` must return the same number with
 #' the parallel `layout` axis.
 #'
-#'  - `layout_heatmap`: for column annotation, the `layout` data will be
+#'  - `heatmap_layout`: for column annotation, the `layout` data will be
 #'  transposed before using (If data is a `function`, it will be applied with
 #'  the transposed matrix). This is necessary because column annotation uses
 #'  heatmap columns as observations, but we need rows.
 #'
-#'  - `layout_stack`: the `layout` data will be used as it is since we place all
+#'  - `stack_layout`: the `layout` data will be used as it is since we place all
 #'    plots along a single axis.
 #'
 #' @param size Plot size, can be an [unit][grid::unit] object.

R/alignpatch-align_plots.R

@@ -17,7 +17,7 @@
 #' @param guides Which guide should be collected? A string containing one or
 #' more of `r rd_values(.tlbr)`.
 #' @inheritParams ggplot2::labs
-#' @param theme `r rd_theme()`
+#' @param theme `r rd_layout_theme()`
 #' @return A `alignpatches` object.
 #' @examples
 #' # directly copied from patchwork
@@ -52,11 +52,6 @@ align_plots <- function(..., ncol = NULL, nrow = NULL, byrow = TRUE,
                         title = NULL, subtitle = NULL, caption = NULL,
                         theme = NULL) {
     plots <- rlang::dots_list(..., .ignore_empty = "all")
-    assert_bool(byrow)
-    if (!is.null(guides)) {
-        assert_position(guides)
-        guides <- setup_position(guides)
-    }
     assert_s3_class(theme, "theme", null_ok = TRUE)
     nms <- names(plots)
     if (!is.null(nms) && is.character(design)) {
@@ -71,27 +66,85 @@ align_plots <- function(..., ncol = NULL, nrow = NULL, byrow = TRUE,
     }
     design <- as_areas(design)
     patches <- lapply(plots, alignpatch)
-    new_alignpatches(patches, list(
+    new_alignpatches(patches,
+        design = layout_design(
+            ncol = ncol,
+            nrow = nrow,
+            byrow = byrow,
+            widths = widths,
+            heights = heights,
+            design = design,
+            guides = guides
+        ),
+        annotation = layout_annotation(
+            title = title,
+            subtitle = subtitle,
+            caption = caption
+        ),
+        theme = theme
+    )
+}
+
+new_alignpatches <- function(patches, design, annotation, theme) {
+    structure(
+        list(
+            patches = patches, design = design,
+            annotation = annotation, theme = theme
+        ),
+        # Will ensure serialisation includes a link to the `ggalign`
+        # namespace
+        `_namespace` = namespace_link,
+        class = "alignpatches"
+    )
+}
+
+#############################################################
+#' @inherit patchwork::plot_layout
+#' @inheritParams patchwork::plot_layout
+#' @importFrom ggplot2 waiver
+#' @noRd
+layout_design <- function(ncol = waiver(), nrow = waiver(), byrow = waiver(),
+                          widths = waiver(), heights = waiver(),
+                          design = waiver(), guides = waiver()) {
+    if (!is.waive(byrow)) assert_bool(byrow)
+    if (!is.waive(design)) design <- as_areas(design)
+    if (!is.waive(guides) && !is.null(guides)) {
+        assert_position(guides)
+        guides <- setup_position(guides)
+    }
+    structure(list(
         ncol = ncol,
         nrow = nrow,
         byrow = byrow,
         widths = widths,
         heights = heights,
         design = design,
-        guides = guides,
-        title = title, subtitle = subtitle, caption = caption
-    ), theme = theme)
+        guides = guides
+    ), class = c("layout_design", "plot_layout"))
 }
 
-new_alignpatches <- function(patches, layout, theme) {
+#' Annotate the whole layout
+#'
+#' @inheritParams ggplot2::labs
+#' @return A `layout_annotation` object to be added into `r rd_layout()`.
+#' @importFrom ggplot2 waiver
+#' @export
+layout_annotation <- function(title = waiver(), subtitle = waiver(),
+                              caption = waiver()) {
     structure(
-        list(patches = patches, layout = layout, theme = theme),
-        # Will ensure serialisation includes a link to the `ggalign`
-        # namespace
-        `_namespace` = ggalign_namespace_link,
-        class = "alignpatches"
+        list(title = title, subtitle = subtitle, caption = caption),
+        class = c("layout_annotation", "plot_annotation")
     )
 }
 
+#' Modify components of the layout theme
+#' @inherit ggplot2::theme description sections references author source note format
+#' @inheritDotParams ggplot2::theme
+#' @note Only used to render the `guides`, `title`, `subtitle`, `caption`,
+#' `margins` and `background`.
+#' @return A `layout_theme` object to be added into `r rd_layout()`.
+#' @examples
+#' layout_theme(plot.background = element_rect(fill = "green"))
+#' @importFrom ggplot2 theme
 #' @export
-as.list.alignpatches <- function(x, ...) .subset2(x, "patches")
+layout_theme <- function(...) add_class(ggplot2::theme(...), "layout_theme")

R/alignpatch-alignpatches.R

@@ -11,7 +11,7 @@ PatchAlignpatches <- ggproto("PatchAlignpatches", Patch,
     #' @importFrom ggplot2 wrap_dims calc_element zeroGrob
     patch_gtable = function(self, guides, plot = self$plot) {
         patches <- .subset2(plot, "patches")
-        layout <- .subset2(plot, "layout")
+        layout <- .subset2(plot, "design")
 
         # complete the theme object
         theme <- complete_theme(.subset2(plot, "theme"))

R/alignpatch-build.R

@@ -44,15 +44,17 @@ grid.draw.alignpatches <- function(x, recording = TRUE) {
 #' @export
 ggalign_build.alignpatches <- function(x) x
 
-#' @importFrom ggplot2 find_panel element_render theme
+#' @importFrom ggplot2 find_panel element_render theme theme_get
 #' @importFrom gtable gtable_add_grob gtable_add_rows gtable_add_cols
 #' @importFrom rlang arg_match0
 #' @export
 ggalign_gtable.alignpatches <- function(x) {
-    layout <- .subset2(x, "layout")
-    theme <- .subset2(x, "theme")
+    annotation <- .subset2(x, "annotation")
 
-    # use complete_theme() when ggplot2 release
+    # ensure theme has no missing value
+    theme <- .subset2(x, "theme") %||% theme_get()
+
+    # `TODO`: use `complete_theme()` from ggplot2 release
     theme <- complete_theme(theme)
     x$theme <- theme
     table <- alignpatch(x)$patch_gtable()
@@ -62,21 +64,22 @@ ggalign_gtable.alignpatches <- function(x) {
     # Add title, subtitle, and caption -------------------
     # https://github.com/tidyverse/ggplot2/blob/2e08bba0910c11a46b6de9e375fade78b75d10dc/R/plot-build.R#L219C3-L219C9
     title <- element_render(
-        theme, "plot.title", .subset2(layout, "title"),
+        theme = theme, "plot.title",
+        .subset2(annotation, "title"),
         margin_y = TRUE, margin_x = TRUE
     )
     title_height <- grobHeight(title)
 
     # Subtitle
     subtitle <- element_render(
-        theme, "plot.subtitle", .subset2(layout, "subtitle"),
+        theme, "plot.subtitle", .subset2(annotation, "subtitle"),
         margin_y = TRUE, margin_x = TRUE
     )
     subtitle_height <- grobHeight(subtitle)
 
     # whole plot annotation
     caption <- element_render(
-        theme, "plot.caption", .subset2(layout, "caption"),
+        theme, "plot.caption", .subset2(annotation, "caption"),
         margin_y = TRUE, margin_x = TRUE
     )
     caption_height <- grobHeight(caption)