feat: add common generics to support extensions (#85)

* feat: add common generics to support extensions

* refactor: implement Scheme system using common generics

* feat: allow NA values as valid tags

* feat: implement layout_add using ggalign_update

Author: Yunuuuu

DESCRIPTION

@@ -62,10 +62,10 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Language: en-GB
 Collate: 
-    'active.R'
     'alignpatch-.R'
     'ggplot-theme.R'
     'alignpatch-theme.R'
+    'generics.R'
     'utils-ggplot.R'
     'alignpatch-tags.R'
     'alignpatch-title.R'
@@ -104,6 +104,7 @@ Collate:
     'craft-cross-none.R'
     'utils-assert.R'
     'scheme-.R'
+    'plot.R'
     'craftbox.R'
     'domain.R'
     'fortify-data-frame-.R'

NAMESPACE

@@ -102,7 +102,6 @@ S3method(free_space,ggalign_free_align)
 S3method(free_space,ggalign_free_space)
 S3method(free_vp,default)
 S3method(free_vp,ggalign_free_vp)
-S3method(ggalign_gtable,gtable)
 S3method(ggalign_stat,"ggalign::CraftBox")
 S3method(ggalign_stat,"ggalign::QuadLayout")
 S3method(ggalign_stat,"ggalign::StackLayout")
@@ -272,7 +271,6 @@ export(.mark_draw)
 export(CraftAlign)
 export(Patch)
 export(Scheme)
-export(Schemes)
 export(active)
 export(align)
 export(align_dendro)
@@ -332,9 +330,14 @@ export(geom_tile3d)
 export(ggalign)
 export(ggalignGrob)
 export(ggalign_attr)
+export(ggalign_build)
 export(ggalign_data_set)
+export(ggalign_gtable)
+export(ggalign_inherit)
+export(ggalign_init)
 export(ggalign_lvls)
 export(ggalign_stat)
+export(ggalign_update)
 export(ggcross)
 export(ggfree)
 export(ggheatmap)
@@ -404,10 +407,7 @@ export(scale_z_discrete)
 export(scale_z_ordinal)
 export(scheme_align)
 export(scheme_data)
-export(scheme_inherit)
-export(scheme_init)
 export(scheme_theme)
-export(scheme_update)
 export(stack_active)
 export(stack_align)
 export(stack_alignh)

R/active.R

@@ -113,38 +113,6 @@ make_patch_table <- function() {
     )
 }
 
-#' Initialize an S7 Object
-#'
-#' Helper generic to initialize an object before use. This may include
-#' setting properties or other elements to their default values, particularly
-#' if the object's internal defaults differ from the defaults required for
-#' normal usage.
-#'
-#' @param input An S7 object to initialize.
-#'
-#' @return The initialized object, ready for use.
-#'
-#' @noRd
-init_object <- S7::new_generic("init_object", "input")
-
-#' Generate a plot grob.
-#'
-#' @param x An object to be converted into a [grob][grid::grob].
-#' @return A [`grob()`][grid::grob] object.
-#' @examples
-#' ggalignGrob(ggplot())
-#' @export
-ggalignGrob <- function(x) ggalign_gtable(ggalign_build(x))
-
-# Now, we only define `ggalign_gtable` method for `alignpatches` and `ggplot`
-# `ggalign_build` must return these objects
-ggalign_build <- function(x) UseMethod("ggalign_build")
-
-ggalign_gtable <- function(x) UseMethod("ggalign_gtable")
-
-#' @export
-ggalign_gtable.gtable <- function(x) x
-
 #' Get Patch representation
 #'
 #' @description

R/alignpatch-.R

@@ -176,7 +176,7 @@ PatchAlignpatches <- ggproto(
             }
             out
         })
-        layout <- init_object(prop(self$plot, "layout"))
+        layout <- ggalign_init(prop(self$plot, "layout"))
 
         # get the design areas and dims ------------------
         panel_widths <- prop(layout, "widths")

R/alignpatch-alignpatches.R

@@ -19,7 +19,7 @@ S7::method(ggalign_gtable, alignpatches) <- function(x) {
     matrix_respect <- is.matrix(.subset2(table, "respect"))
 
     # Add title, subtitle, and caption -------------------
-    titles <- init_object(prop(x, "titles"))
+    titles <- ggalign_init(prop(x, "titles"))
     # https://github.com/tidyverse/ggplot2/blob/2e08bba0910c11a46b6de9e375fade78b75d10dc/R/plot-build.R#L219C3-L219C9
     title <- element_render(
         theme, "plot.title", prop(titles, "title"),

R/alignpatch-build.R

@@ -114,50 +114,53 @@ layout_design <- S7::new_class("layout_design",
 )
 
 #' @importFrom S7 prop prop<-
-S7::method(init_object, layout_design) <- function(input) {
-    if (identical(prop(input, "ncol"), NA_real_)) {
-        prop(input, "ncol", check = FALSE) <- NULL
+S7::method(ggalign_init, layout_design) <- function(x) {
+    if (identical(prop(x, "ncol"), NA_real_)) {
+        prop(x, "ncol", check = FALSE) <- NULL
     }
-    if (identical(prop(input, "nrow"), NA_real_)) {
-        prop(input, "nrow", check = FALSE) <- NULL
+    if (identical(prop(x, "nrow"), NA_real_)) {
+        prop(x, "nrow", check = FALSE) <- NULL
     }
-    if (identical(prop(input, "byrow"), NA)) {
-        prop(input, "byrow", check = FALSE) <- TRUE
+    if (identical(prop(x, "byrow"), NA)) {
+        prop(x, "byrow", check = FALSE) <- TRUE
     }
-    prop(input, "widths", check = FALSE) <- prop(input, "widths") %||% NA
-    prop(input, "heights", check = FALSE) <- prop(input, "heights") %||% NA
-    prop(input, "area", check = FALSE) <- prop(input, "area") %|w|% NULL
-    if (identical(prop(input, "guides"), NA_character_)) {
-        prop(input, "guides", check = FALSE) <- waiver()
+    prop(x, "widths", check = FALSE) <- prop(x, "widths") %||% NA
+    prop(x, "heights", check = FALSE) <- prop(x, "heights") %||% NA
+    prop(x, "area", check = FALSE) <- prop(x, "area") %|w|% NULL
+    if (identical(prop(x, "guides"), NA_character_)) {
+        prop(x, "guides", check = FALSE) <- waiver()
     }
-    input
+    x
 }
 
 #' @importFrom ggplot2 is_waiver
+S7::method(ggalign_update, list(layout_design, layout_design)) <-
+    function(x, object) {
+        if (!identical(prop(object, "ncol"), NA_real_)) {
+            prop(x, "ncol", check = FALSE) <- prop(object, "ncol")
+        }
+        if (!identical(prop(object, "nrow"), NA_real_)) {
+            prop(x, "nrow", check = FALSE) <- prop(object, "nrow")
+        }
+        if (!identical(prop(object, "byrow"), NA)) {
+            prop(x, "byrow", check = FALSE) <- prop(object, "byrow")
+        }
+        if (!is.null(prop(object, "widths"))) {
+            prop(x, "widths", check = FALSE) <- prop(object, "widths")
+        }
+        if (!is.null(prop(object, "heights"))) {
+            prop(x, "heights", check = FALSE) <- prop(object, "heights")
+        }
+        if (!is_waiver(prop(object, "area"))) {
+            prop(x, "area", check = FALSE) <- prop(object, "area")
+        }
+        if (!identical(prop(object, "guides"), NA_character_)) {
+            prop(x, "guides", check = FALSE) <- prop(object, "guides")
+        }
+        x
+    }
+
 local(
     S7::method(`+`, list(layout_design, layout_design)) <-
-        function(e1, e2) {
-            if (!identical(prop(e2, "ncol"), NA_real_)) {
-                prop(e1, "ncol", check = FALSE) <- prop(e2, "ncol")
-            }
-            if (!identical(prop(e2, "nrow"), NA_real_)) {
-                prop(e1, "nrow", check = FALSE) <- prop(e2, "nrow")
-            }
-            if (!identical(prop(e2, "byrow"), NA)) {
-                prop(e1, "byrow", check = FALSE) <- prop(e2, "byrow")
-            }
-            if (!is.null(prop(e2, "widths"))) {
-                prop(e1, "widths", check = FALSE) <- prop(e2, "widths")
-            }
-            if (!is.null(prop(e2, "heights"))) {
-                prop(e1, "heights", check = FALSE) <- prop(e2, "heights")
-            }
-            if (!is_waiver(prop(e2, "area"))) {
-                prop(e1, "area", check = FALSE) <- prop(e2, "area")
-            }
-            if (!identical(prop(e2, "guides"), NA_character_)) {
-                prop(e1, "guides", check = FALSE) <- prop(e2, "guides")
-            }
-            e1
-        }
+        function(e1, e2) ggalign_update(e1, e2)
 )