let layout theme to define panel spacing for all plots

Yunuuuu · Dec 13, 2024 · 5a31b50 · 5a31b50
1 parent c3f8fa7
commit 5a31b50
Show file tree

Hide file tree

Showing 15 changed files with 218 additions and 156 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -135,6 +135,7 @@ S3method(grid.draw,alignpatches)
 S3method(grid.draw,ggalign_plot)
 S3method(grid.draw,patch_ggplot)
 S3method(heatmap_layout,default)
+S3method(inherit_scheme,"NULL")
 S3method(inherit_scheme,scheme_align)
 S3method(inherit_scheme,scheme_data)
 S3method(inherit_scheme,scheme_theme)
@@ -186,6 +187,7 @@ S3method(plot,ggalign_area)
 S3method(plot,ggalign_plot)
 S3method(plot_add,ggalign_align_plot)
 S3method(plot_add,ggalign_free_plot)
+S3method(plot_add_scheme,"NULL")
 S3method(plot_add_scheme,scheme_data)
 S3method(plot_add_scheme,scheme_theme)
 S3method(plot_build,ggalign_align_plot)

diff --git a/R/align-.R b/R/align-.R
@@ -266,8 +266,7 @@ Align <- ggproto("Align", AlignProto,
             object_name
         )
     },
-    build = function(self, plot, schemes,
-                     coords, extra_coords, previous_coords = NULL) {
+    build = function(self, plot, coords, extra_coords, previous_coords = NULL) {
         direction <- self$direction
         panel <- .subset2(coords, "panel")
         index <- .subset2(coords, "index")

diff --git a/R/align-ranges.R b/R/align-ranges.R
@@ -1,7 +1,7 @@
 align_ranges <- function(data = waiver(), mapping = aes(),
-                         ranges = waiver(), link = waiver(),
+                         ranges = waiver(), position = waiver(),
                          size = NULL, active = NULL) {
-    assert_layout_position(link)
+    assert_layout_position(position)
     if (inherits(data, "uneval")) {
         cli_abort(c(
             "{.arg data} cannot be {.obj_type_friendly {data}}",
@@ -15,15 +15,15 @@ align_ranges <- function(data = waiver(), mapping = aes(),
     align(AlignRanges,
         plot = ggplot(mapping = mapping),
         size = size, data = data,
-        params = list(ranges = ranges, link = link),
+        params = list(ranges = ranges, position = position),
         schemes = new_schemes(),
         active = active
     )
 }
 
 #' @importFrom ggplot2 ggproto ggplot margin element_rect
 AlignRanges <- ggproto("AlignRanges", AlignGG,
-    extra_params = c("ranges", "link"),
+    extra_params = c("ranges", "position"),
     setup_params = function(self, nobs, params) {
         if (!is.waive(.subset2(params, "ranges"))) {
             params$ranges <- lapply(
@@ -53,29 +53,28 @@ AlignRanges <- ggproto("AlignRanges", AlignGG,
     },
 
     #' @importFrom stats reorder
-    build = function(self, plot,
-                     coords, extra_coords, previous_coords = NULL) {
+    build = function(self, plot, coords, extra_coords, previous_coords = NULL) {
         params <- .subset2(self, "params")
         direction <- self$direction
         position <- self$position
         # parse link
         support_link <- switch_direction(
             direction, c("left", "right"), c("top", "bottom")
         )
-        if (is.waive(link <- .subset2(params, "link"))) {
+        if (is.waive(link_position <- .subset2(params, "position"))) {
             if (is.null(position)) {
-                link <- support_link
+                link_position <- support_link
             } else {
-                link <- opposite_pos(position)
+                link_position <- opposite_pos(position)
             }
-        } else if (!is.null(link)) {
-            link <- complete_pos(split_position(link))
-            warn <- setdiff(link, support_link)
+        } else if (!is.null(link_position)) {
+            link_position <- complete_pos(split_position(link_position))
+            warn <- setdiff(link_position, support_link)
             if (length(warn)) {
-                cli_warn(sprintf("Cannot add links in {.field %s}", warn))
+                cli_warn(sprintf("Cannot add link ranges in {.field %s}", warn))
             }
-            link <- intersect(link, support_link)
-            if (length(link) == 0L) link <- NULL
+            link_position <- intersect(link_position, support_link)
+            if (length(link_position) == 0L) link_position <- NULL
         }
 
         # parse ranges
@@ -131,14 +130,38 @@ AlignRanges <- ggproto("AlignRanges", AlignGG,
             default_facet <- ggplot2::facet_null()
         }
         plot <- plot + align_melt_facet(plot$facet, default_facet, direction)
-        if (!is.null(link)) {
+        if (!is.null(link_position)) {
             plot$align_ranges_data <- list(
                 full_breaks = full_breaks,
-                breaks = breaks, direction = direction, link = link
+                breaks = breaks, direction = direction,
+                link_position = link_position
             )
             plot <- add_class(plot, "align_ranges_plot", "patch_ggplot")
         }
         plot
+    },
+    finish_plot = function(self, plot, schemes, theme) {
+        plot <- plot_add_schemes(plot, schemes)
+        if (inherits(plot, "align_ranges_plot")) {
+            theme <- complete_theme(theme)
+            element <- calc_element("plot.ggalign_ranges", theme)
+            if (inherits(element, "element_blank")) {
+                class(plot) <- setdiff(class(plot), "align_ranges_plot")
+                plot$align_ranges_data <- NULL
+            } else {
+                # save spacing for usage
+                plot$align_ranges_data$spacing <- calc_element(
+                    switch_direction(
+                        self$direction,
+                        "panel.spacing.y",
+                        "panel.spacing.x"
+                    ),
+                    theme
+                ) %||% unit(0, "mm")
+                plot$align_ranges_data$element <- element
+            }
+        }
+        plot
     }
 )
 
@@ -150,7 +173,7 @@ alignpatch.align_ranges_plot <- function(x) {
 
 #' @export
 `[.alignRangesGtable` <- function(x, i, j) {
-    # subset will violate the RangesGtable `shape`
+    # subset will violate the `alignRangesGtable` `shape`
     # we always use the next method
     class(x) <- setdiff(class(x), "alignRangesGtable")
     x$align_ranges_data <- NULL
@@ -162,27 +185,9 @@ PatchAlignRangesPlot <- ggproto(
     "PatchAlignRangesPlot", PatchGgplot,
     patch_gtable = function(self, plot = self$plot) {
         ans <- ggproto_parent(PatchGgplot, self)$patch_gtable(plot = plot)
-        theme <- complete_theme(plot$theme)
-        element <- calc_element("plot.ggalign_ranges", theme)
-        if (inherits(element, "element_blank")) {
-            return(ans)
-        }
-
         # re-define the draw method, we assign new class
-        align_ranges_data <- .subset2(plot, "align_ranges_data")
         ans <- add_class(ans, "alignRangesGtable")
-
-        # save spacing for usage
-        align_ranges_data$spacing <- calc_element(
-            switch_direction(
-                .subset2(align_ranges_data, "direction"),
-                "panel.spacing.y",
-                "panel.spacing.x"
-            ),
-            theme
-        ) %||% unit(0, "mm")
-        align_ranges_data$element <- element
-        ans$align_ranges_data <- align_ranges_data
+        ans$align_ranges_data <- .subset2(plot, "align_ranges_data")
         ans
     },
     add_plot = function(self, gt, plot, t, l, b, r, name, z = 2L) {
@@ -191,15 +196,15 @@ PatchAlignRangesPlot <- ggproto(
             grobs = plot,
             # t = 8, l = 6, b = 14, r = 12
             # t = t + 7L, l = l + 5L, b = b - 6L, r = r - 5L,
-            t = t + 10L, l = l + 8,
+            t = t + TOP_BORDER, l = l + LEFT_BORDER,
             name = name, z = z
         )
     },
     add_background = function(self, gt, bg, t, l, b, r, name, z = 1L) {
         gtable_add_grob(
             gt,
             grobs = bg,
-            t = t + 10L, l = l + 8,
+            t = t + TOP_BORDER, l = l + LEFT_BORDER,
             name = name, z = z
         )
     },
@@ -208,7 +213,7 @@ PatchAlignRangesPlot <- ggproto(
     },
     align_border = function(self, t = NULL, l = NULL, b = NULL, r = NULL,
                             gt = self$gt) {
-        gt
+        gt # free from alignment
     }
 )
 
@@ -239,7 +244,7 @@ makeContent.alignRangesGtable <- function(x) {
     panel_loc <- find_panel(x)
     range_data <- .subset2(x, "align_ranges_data")
     breaks <- .subset2(range_data, "breaks")
-    link <- .subset2(range_data, "link")
+    link_position <- .subset2(range_data, "link_position")
     full_breaks <- .subset2(range_data, "full_breaks")
     direction <- .subset2(range_data, "direction")
     spacing <- convertHeight(
@@ -260,8 +265,8 @@ makeContent.alignRangesGtable <- function(x) {
 
     # then, we define the link grobs
     coord_x <- coord_y <- numeric()
-    if (is_horizontal(direction)) { # left and right
-        # from bottom to the top
+    if (is_horizontal(direction)) { # the link should be in left or right
+        # from bottom to the top, following the ordering of the `breaks`
         panel_index <- seq(
             from = .subset2(panel_loc, "b"),
             to = .subset2(panel_loc, "t"),
@@ -273,7 +278,7 @@ makeContent.alignRangesGtable <- function(x) {
         # for a gtable, heights are from top to the bottom,
         # we reverse the heights
         plot_cum_heights <- cumsum(rev(plot_heights))
-        for (position in link) {
+        for (position in link_position) {
             for (i in seq_along(panel_index)) {
                 # we match the observations
                 pos <- match(.subset2(breaks, i), obs)
@@ -300,6 +305,8 @@ makeContent.alignRangesGtable <- function(x) {
                 }
             }
         }
+    } else {
+
     }
     layout <- .subset2(x, "layout")
     panels <- layout[grepl("^panel", .subset2(layout, "name")), , drop = FALSE]

diff --git a/R/layout-.R b/R/layout-.R
@@ -79,6 +79,31 @@ default_layout <- function(layout) {
     layout
 }
 
+###########################################################
+inherit_parent_layout_schemes <- function(layout, schemes) {
+    if (is.null(schemes)) {
+        return(layout@schemes)
+    }
+    inherit_schemes(layout@schemes, schemes)
+}
+
+inherit_parent_layout_theme <- function(layout, theme, direction) {
+    if (is.null(theme)) return(layout@theme) # styler: off
+    # parent theme, set the global panel spacing,
+    # so that every panel aligns well
+    if (is_horizontal(direction)) {
+        theme <- theme(
+            panel.spacing.y = calc_element("panel.spacing.y", theme)
+        )
+    } else {
+        theme <- theme(
+            panel.spacing.x = calc_element("panel.spacing.x", theme)
+        )
+    }
+    if (is.null(layout@theme)) return(layout@theme) # styler: off
+    layout@theme + theme
+}
+
 ############################################################
 #' Get the statistics from the layout
 #'

diff --git a/R/layout-cross-.R b/R/layout-cross-.R
@@ -61,7 +61,8 @@ cross_align.default <- function(data = NULL, direction, ...) {
 
 #' @importFrom grid unit.c
 #' @importFrom rlang is_empty is_string
-stack_build_composer.CrossLayout <- function(stack, schemes, extra_coords) {
+stack_build_composer.CrossLayout <- function(stack, schemes, theme,
+                                             extra_coords) {
     # check if we should initialize the layout observations
     layout_coords <- stack@layout
     if (!is.null(layout_coords) &&
@@ -139,6 +140,7 @@ stack_build_composer.CrossLayout <- function(stack, schemes, extra_coords) {
             plots,
             composer,
             schemes = schemes,
+            theme = theme,
             coords = coords,
             extra_coords = extra_coords,
             direction = direction,

diff --git a/R/layout-heatmap-build.R b/R/layout-heatmap-build.R
@@ -1,5 +1,6 @@
 #' @export
-quad_build.HeatmapLayout <- function(quad, schemes = quad@schemes) {
+quad_build.HeatmapLayout <- function(quad, schemes = NULL, theme = NULL,
+                                     direction = NULL) {
     ans <- NextMethod()
 
     # add heatmap filling in the first layer --------------

diff --git a/R/layout-quad-build.R b/R/layout-quad-build.R
@@ -41,16 +41,23 @@ ggalign_build.QuadLayout <- function(x) {
     )
 }
 
-quad_build <- function(quad, schemes = quad@schemes) UseMethod("quad_build")
+quad_build <- function(quad, schemes = NULL, theme = NULL,
+                       direction = NULL) {
+    UseMethod("quad_build")
+}
 
 #######################################################################
+#' @param schemes,theme Parameters from parent layout
 #' @importFrom ggplot2 aes
 #' @importFrom rlang is_empty
 #' @importFrom grid unit is.unit unit.c
 #' @export
-quad_build.QuadLayout <- function(quad, schemes = quad@schemes) {
+#' @noRd
+quad_build.QuadLayout <- function(quad, schemes = NULL, theme = NULL,
+                                  direction = NULL) {
     data <- quad@data
-
+    schemes <- inherit_parent_layout_schemes(quad, schemes)
+    theme <- inherit_parent_layout_theme(quad, theme, direction = direction)
     row_coords <- setup_layout_coords(quad@horizontal)
     column_coords <- setup_layout_coords(quad@vertical)
     if (!(is.null(row_coords) && is.null(column_coords)) &&
@@ -98,54 +105,21 @@ quad_build.QuadLayout <- function(quad, schemes = quad@schemes) {
         if (is_empty(stack <- slot(quad, position))) {
             return(list(plot = NULL, size = NULL))
         }
-        stack_schemes <- schemes
+        pschemes <- schemes
         # inherit from horizontal align or vertical align
         if (is_horizontal(to_direction(position))) {
             extra_coords <- column_coords
-            stack_schemes$scheme_align <- horizontal_align
+            pschemes$scheme_align <- horizontal_align
         } else {
             extra_coords <- row_coords
-            stack_schemes$scheme_align <- vertical_align
+            pschemes$scheme_align <- vertical_align
         }
-        stack_schemes <- inherit_schemes(stack@schemes, stack_schemes)
         plot <- stack_build(stack,
-            schemes = stack_schemes,
+            schemes = pschemes,
+            theme = theme,
             extra_coords = extra_coords
         )
         if (!is.null(plot)) {
-            # for annotation, we should always make them next to
-            # the main body
-            plot <- free_vp(
-                plot,
-                x = switch(position,
-                    left = 1L,
-                    right = 0L,
-                    0.5
-                ),
-                y = switch(position,
-                    top = 0L,
-                    bottom = 1L,
-                    0.5
-                ),
-                just = switch(position,
-                    top = "bottom",
-                    left = "right",
-                    bottom = "top",
-                    right = "left"
-                )
-            )
-
-            # whether we should override the `guides` collection for the whole
-            # annotation stack
-            free_guides <- .subset2(stack@heatmap, "free_guides")
-            if (!is.waive(free_guides)) plot <- free_guide(plot, free_guides)
-            # we also apply the `free_spaces` for the whole annotation stack
-            free_spaces <- .subset2(
-                .subset2(stack_schemes, "scheme_align"), "free_spaces"
-            ) %|w|% NULL
-            if (!is.null(free_spaces)) {
-                plot <- free_space(free_border(plot, free_spaces), free_spaces)
-            }
             size <- .subset2(stack@heatmap, "size")
         } else {
             size <- NULL