tidy up codes, reduce rebundant codes

Yunuuuu · Dec 15, 2024 · b478987 · b478987
1 parent 3e41296
commit b478987
Show file tree

Hide file tree

Showing 7 changed files with 68 additions and 81 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -22,8 +22,7 @@ S3method(alignpatch,Heatmap)
 S3method(alignpatch,HeatmapAnnotation)
 S3method(alignpatch,HeatmapList)
 S3method(alignpatch,LayoutProto)
-S3method(alignpatch,align_line_plot)
-S3method(alignpatch,align_range_plot)
+S3method(alignpatch,align_link_plot)
 S3method(alignpatch,alignpatches)
 S3method(alignpatch,default)
 S3method(alignpatch,formula)
@@ -151,6 +150,8 @@ S3method(layout_and_add,QuadLayout)
 S3method(layout_and_add,StackLayout)
 S3method(layout_subtract,QuadLayout)
 S3method(layout_subtract,StackLayout)
+S3method(link_gtable_class,align_line_plot)
+S3method(link_gtable_class,align_range_plot)
 S3method(makeContent,alignLineGtable)
 S3method(makeContent,alignRangeGtable)
 S3method(makeContext,ggalign_raster_magick)

diff --git a/R/align-.R b/R/align-.R
@@ -62,7 +62,8 @@
 #' @importFrom ggplot2 ggproto
 #' @export
 #' @keywords internal
-align <- function(align, data, params = list(), plot = NULL,
+align <- function(align, data, ...,
+                  params = list(), plot = NULL,
                   size = NULL, schemes = NULL,
                   limits = TRUE, facet = TRUE, no_axes = NULL, active = NULL,
                   free_guides = deprecated(), free_spaces = deprecated(),
@@ -107,6 +108,7 @@ align <- function(align, data, params = list(), plot = NULL,
 
         # additional field for `align` object
         no_axes = no_axes,
+        ...,
 
         # Following fields will be initialzed when added into the layout
         # and will be saved and accessed across the plot rendering process

diff --git a/R/align-link.R b/R/align-link.R
@@ -62,28 +62,18 @@ align_line <- function(data = waiver(), mapping = aes(),
             "i" = "Have you misspelled the {.arg data} argument in {.fn ggalign}"
         ))
     }
-    assert_active(active)
-    active <- update_active(active, new_active(use = TRUE))
-    align(
-        new_align_link(
-            "AlignLine",
-            arg = "lines",
-            class = "align_line_plot",
-            element = "plot.ggalign_lines"
-        ),
-        plot = ggplot(mapping = mapping),
+    new_align_link(
+        class = "align_line_plot",
+        element = "plot.ggalign_lines",
+        position = position,
+        arg = "lines", value = lines,
         size = size, data = data,
-        params = list(lines = lines, position = position),
-        schemes = default_schemes(th = theme_add_panel()),
-        active = active
+        active = active, plot = ggplot(mapping = mapping)
     )
 }
 
-#' @importFrom ggplot2 ggproto
 #' @export
-alignpatch.align_line_plot <- function(x) {
-    ggproto(NULL, PatchAlignLinePlot, plot = x)
-}
+link_gtable_class.align_line_plot <- function(x) "alignLineGtable"
 
 #' @export
 `[.alignLineGtable` <- function(x, i, j) {
@@ -247,18 +237,50 @@ makeContent.alignLineGtable <- function(x) {
 }
 
 ####################################################################
+#' @param arg A string indicates the argument name for the link observations.
+#' @param value The actual value for the `arg`.
+#' @param class The plot class.
+#' @param element A string of the element to control the link
 #' @importFrom ggplot2 ggproto
-new_align_link <- function(`_class` = NULL, arg, class, element, ...) {
-    ggproto(`_class`, AlignLinkProto,
-        extra_params = c(arg, "position"),
-        arg = arg, class = class, element = element, ...
+#' @noRd
+new_align_link <- function(class, element, position, arg, value, ...,
+                           active, call = caller_call()) {
+    assert_active(active, call = call)
+    active <- update_active(active, new_active(use = TRUE))
+    params <- list(value, position)
+    names(params) <- c(arg, "position")
+    align(
+        ggproto(NULL, AlignLink,
+            class = class, # `class` is an argument of `new_ggalign_plot`
+            extra_params = c(arg, "position")
+        ),
+        arg = arg, element = element,
+        params = params,
+        schemes = default_schemes(th = theme_add_panel()),
+        ..., active = active,
+        call = call
     )
 }
 
+link_gtable_class <- function(x) UseMethod("link_gtable_class")
+
+#' @importFrom ggplot2 ggproto
+#' @export
+alignpatch.align_link_plot <- function(x) {
+    ggproto(NULL, PatchAlignLink, plot = x)
+}
+
 #' @importFrom ggplot2 ggproto ggproto_parent
 #' @include alignpatch-ggplot2.R
-PatchAlignLinkProto <- ggproto(
-    "PatchAlignLinkProto", PatchGgplot,
+PatchAlignLink <- ggproto(
+    "PatchAlignLink", PatchGgplot,
+    patch_gtable = function(self, plot = self$plot) {
+        ans <- ggproto_parent(PatchGgplot, self)$patch_gtable(plot = plot)
+        # re-define the draw method, we assign new class
+        ans <- add_class(ans, link_gtable_class(plot))
+        ans$links_data <- .subset2(plot, "links_data")
+        ans
+    },
     add_plot = function(self, gt, plot, t, l, b, r, name, z = 2L) {
         gtable_add_grob(
             gt,
@@ -286,21 +308,8 @@ PatchAlignLinkProto <- ggproto(
     }
 )
 
-PatchAlignLinePlot <- ggproto(
-    "PatchAlignLinePlot", PatchAlignLinkProto,
-    patch_gtable = function(self, plot = self$plot) {
-        ans <- ggproto_parent(PatchAlignLinkProto, self)$patch_gtable(
-            plot = plot
-        )
-        # re-define the draw method, we assign new class
-        ans <- add_class(ans, "alignLineGtable")
-        ans$links_data <- .subset2(plot, "links_data")
-        ans
-    }
-)
-
 #' @importFrom ggplot2 ggproto ggplot margin element_rect
-AlignLinkProto <- ggproto("AlignLinkProto", AlignGg,
+AlignLink <- ggproto("AlignLink", AlignGg,
     class = NULL, element = NULL,
     finish_plot = function(self, plot, schemes, theme) {
         plot <- plot_add_schemes(plot, schemes)
@@ -437,7 +446,10 @@ AlignLinkProto <- ggproto("AlignLinkProto", AlignGg,
                 breaks = breaks, direction = direction,
                 link_position = link_position
             )
-            plot <- add_class(plot, self$class, "patch_ggplot")
+            plot <- add_class(
+                plot, self$class,
+                "align_link_plot", "patch_ggplot"
+            )
         }
         plot
     }

diff --git a/R/align-range.R b/R/align-range.R
@@ -10,28 +10,19 @@ align_range <- function(data = waiver(), mapping = aes(),
             "i" = "Have you misspelled the {.arg data} argument in {.fn ggalign}"
         ))
     }
-    assert_active(active)
-    active <- update_active(active, new_active(use = TRUE))
-    align(
-        new_align_link(
-            "AlignRange",
-            arg = "ranges",
-            class = "align_range_plot",
-            element = "plot.ggalign_ranges"
-        ),
-        plot = ggplot(mapping = mapping),
+    new_align_link(
+        class = "align_range_plot",
+        element = "plot.ggalign_ranges",
+        position = position,
+        arg = "ranges", value = ranges,
         size = size, data = data,
-        params = list(ranges = ranges, position = position),
-        schemes = default_schemes(th = theme_add_panel()),
-        active = active
+        active = active, 
+        plot = ggplot(mapping = mapping)
     )
 }
 
-#' @importFrom ggplot2 ggproto
 #' @export
-alignpatch.align_range_plot <- function(x) {
-    ggproto(NULL, PatchAlignRangePlot, plot = x)
-}
+link_gtable_class.align_range_plot <- function(x) "alignRangeGtable"
 
 #' @export
 `[.alignRangeGtable` <- function(x, i, j) {
@@ -42,20 +33,6 @@ alignpatch.align_range_plot <- function(x) {
     NextMethod()
 }
 
-#' @include align-link.R
-PatchAlignRangePlot <- ggproto(
-    "PatchAlignRangePlot", PatchAlignLinkProto,
-    patch_gtable = function(self, plot = self$plot) {
-        ans <- ggproto_parent(PatchAlignLinkProto, self)$patch_gtable(
-            plot = plot
-        )
-        # re-define the draw method, we assign new class
-        ans <- add_class(ans, "alignRangeGtable")
-        ans$links_data <- .subset2(plot, "links_data")
-        ans
-    }
-)
-
 # preDraw:
 #  - makeContext
 #  - pushvpgp

diff --git a/R/layout-coords.R b/R/layout-coords.R
@@ -68,8 +68,6 @@ update_layout_coords.QuadLayout <- function(layout, ..., direction, coords,
 #' @importFrom methods slot slot<-
 #' @export
 update_layout_coords.StackLayout <- function(layout, ..., coords, object_name) {
-    # for quad annotation stack, we may update coords even the annotation stack
-    # won't align observations
     if (is.null(coords) || is.null(slot(layout, "layout"))) {
         return(layout)
     }
@@ -88,8 +86,6 @@ update_layout_coords.StackLayout <- function(layout, ..., coords, object_name) {
 #' @export
 update_layout_coords.CrossLayout <- function(layout, ..., coords, object_name,
                                              from_head = FALSE) {
-    # for quad annotation stack, we may update coords even the annotation stack
-    # won't align observations
     if (is.null(coords) || is.null(slot(layout, "layout"))) {
         return(layout)
     }

diff --git a/R/plot-.R b/R/plot-.R
@@ -120,7 +120,7 @@ summary.AlignProto <- function(object, ...) c(FALSE, FALSE)
 AlignProto <- ggproto("AlignProto",
     locked = TRUE,
     # A boolean value indicates whether this plot is free
-    # if `FALSE`, we'll check whether the layout can add this object
+    # if `FALSE`, we'll check whether the layout need align observations
     free_align = FALSE,
     lock = function(self) {
         assign("locked", value = TRUE, envir = self)
@@ -230,12 +230,11 @@ stack_layout_add.ggalign_plot <- function(object, stack, object_name) {
         stack@plot_list[[active_index]] <- plot
         new_coords <- slot(plot, stack@direction)
     }
-    stack <- update_layout_coords(
+    update_layout_coords(
         stack,
         coords = new_coords,
         object_name = object_name
     )
-    stack
 }
 
 #' @importFrom methods slot slot<-
@@ -282,11 +281,10 @@ quad_layout_add.ggalign_plot <- function(object, quad, object_name) {
         !is_empty(stack@cross_points)) {
         new_coords["index"] <- list(.subset2(stack@index_list, 1L))
     }
-    quad <- update_layout_coords(
+    update_layout_coords(
         quad,
         direction = direction,
         coords = new_coords,
         object_name = object_name
     )
-    quad
 }
diff --git a/man/align.Rd b/man/align.Rd