StackCross gain new slot break_points

NAMESPACE

@@ -273,7 +273,6 @@ S3method(stack_cross,default)
 S3method(stack_discrete,"function")
 S3method(stack_discrete,default)
 S3method(stack_discrete,formula)
-S3method(summary,Cross)
 S3method(update_design,CircleLayout)
 S3method(update_design,QuadLayout)
 S3method(update_design,StackCross)

R/align-.R

@@ -128,12 +128,12 @@ AlignDiscrete <- ggproto("AlignDiscrete", AlignProto,
     },
     setup_design = function(self, layout_data, design) {
         layout_name <- self$layout_name
-        object_name <- self$object_name
+        object_name <- object_name(self)
         # check plot is compatible with the layout
         if (is_continuous_design(design)) {
             # `AlignDiscrete` object is special for discrete variables
             cli_abort(c(
-                sprintf("Cannot add {.var {object_name}} to %s", layout_name),
+                sprintf("Cannot add %s to %s", object_name, layout_name),
                 i = sprintf("%s cannot align discrete variables", layout_name)
             ))
         }
@@ -152,15 +152,21 @@ AlignDiscrete <- ggproto("AlignDiscrete", AlignProto,
             if (is.waive(input_data)) { # inherit from the layout
                 if (is.null(data <- layout_data)) {
                     cli_abort(c(
-                        "you must provide {.arg data} in {.var {object_name}}",
+                        sprintf(
+                            "you must provide {.arg data} in %s",
+                            object_name
+                        ),
                         i = sprintf("no data was found in %s", layout_name)
                     ))
                 }
             } else {
                 if (is.function(input_data)) {
                     if (is.null(layout_data)) {
                         cli_abort(c(
-                            "{.arg data} in {.var {object_name}} cannot be a function",
+                            sprintf(
+                                "{.arg data} in %s cannot be a function",
+                                object_name
+                            ),
                             i = sprintf("no data was found in %s", layout_name)
                         ))
                     }
@@ -174,7 +180,7 @@ AlignDiscrete <- ggproto("AlignDiscrete", AlignProto,
                 layout_nobs <- NROW(data)
             } else if (NROW(data) != layout_nobs) {
                 cli_abort(sprintf(
-                    "{.var %s} (nobs: %d) is not compatible with the %s (nobs: %d)",
+                    "%s (nobs: %d) is not compatible with the %s (nobs: %d)",
                     object_name, NROW(data), layout_name, layout_nobs
                 ))
             }
@@ -206,21 +212,21 @@ AlignDiscrete <- ggproto("AlignDiscrete", AlignProto,
         )
 
         # make the new layout -------------------------------
-        new_design <- align_inject(
+        panel_and_index <- align_inject(
             self$align,
             c(list(panel = layout_panel, index = layout_index), params)
         )
+        new_design <- discrete_design(
+            .subset2(panel_and_index, 1L),
+            .subset2(panel_and_index, 2L),
+            layout_nobs
+        )
 
-        # we check the the design
         check_discrete_design(
             design,
-            discrete_design(
-                .subset2(new_design, 1L),
-                .subset2(new_design, 2L),
-                layout_nobs
-            ),
-            layout_name,
-            object_name
+            new_design,
+            old_name = layout_name,
+            new_name = object_name
         )
     },
 

R/align-group.R

@@ -31,7 +31,7 @@ AlignGroup <- ggproto("AlignGroup", AlignDiscrete,
     setup_params = function(self, nobs, params) {
         assert_mismatch_nobs(
             self, nobs, self$nobs(params),
-            msg = "must be an atomic vector",
+            action = "must be an atomic vector",
             arg = "group"
         )
         params

R/align-kmeans.R

@@ -34,16 +34,15 @@ AlignKmeans <- ggproto("AlignKmeans", AlignDiscrete,
         ans <- fortify_matrix(data)
         assert_(
             ans, is.numeric, "a numeric matrix",
-            arg = "data", call = .subset2(self, "call")
+            arg = "data", call = self$call
         )
         ans
     },
     compute = function(self, panel, index, centers, params) {
-        data <- .subset2(self, "data")
-        inject(stats::kmeans(x = data, centers = centers, !!!params))
+        inject(stats::kmeans(x = self$data, centers = centers, !!!params))
     },
     align = function(self, panel, index) {
-        list(.subset2(.subset2(self, "statistics"), "cluster"), index)
+        list(.subset2(self$statistics, "cluster"), index)
     },
     summary_align = function(self) c(FALSE, TRUE)
 )

R/align-order.R

@@ -84,7 +84,7 @@ AlignOrder <- ggproto("AlignOrder", AlignDiscrete,
         if (!is.function(weights <- .subset2(params, "weights"))) {
             assert_mismatch_nobs(
                 self, nobs, length(weights),
-                msg = "must be an ordering integer or character index of",
+                action = "must be an ordering integer or character index of",
                 arg = "weights"
             )
         }
@@ -103,7 +103,7 @@ AlignOrder <- ggproto("AlignOrder", AlignDiscrete,
             }
             assert_mismatch_nobs(
                 self, nrow(data), length(ans),
-                msg = "must return weights with",
+                action = "must return weights with",
                 arg = "weights"
             )
         } else {

R/align-reorder.R

@@ -68,7 +68,7 @@ AlignReorder <- ggproto("AlignReorder", AlignDiscrete,
         )
         assert_mismatch_nobs(
             self, nrow(.subset2(self, "data")), length(index),
-            msg = "must return a statistic with",
+            action = "must return a statistic with",
             arg = "stat"
         )
         if (reverse) index <- rev(index)

R/alignpatch-inset.R

@@ -225,7 +225,7 @@ patch.trellis <- function(x, ..., device = NULL) {
 patch.Heatmap <- function(x, ..., device = NULL) {
     rlang::check_installed(
         "ComplexHeatmap",
-        sprintf("to make grob from {%s} plot", obj_type_friendly(x))
+        sprintf("to make grob from %s plot", obj_type_friendly(x))
     )
     draw <- getFromNamespace("draw", "ComplexHeatmap")
     grid::grid.grabExpr(

R/alignpatch-patchwork.R

@@ -62,7 +62,7 @@ alignpatch.free_plot <- function(x) {
 #' @export
 alignpatch.patch <- function(x) {
     rlang::check_installed(
-        "patchwork", sprintf("to align {%s} plot", obj_type_friendly(x))
+        "patchwork", sprintf("to align %s plot", obj_type_friendly(x))
     )
     ggproto(NULL, PatchPatchworkPatch, plot = x)
 }

R/cross-.R

@@ -7,12 +7,11 @@ cross <- function(cross, ..., call = caller_call()) {
     new_ggalign_plot(align = cross, ..., call = call)
 }
 
-#' @export
-summary.Cross <- function(object, ...) c(TRUE, FALSE)
-
 #' @importFrom ggplot2 ggproto ggplot
 #' @include plot-.R
 Cross <- ggproto("Cross", AlignProto,
+    reset_panel = FALSE,
+    reset_nobs = FALSE,
     setup_layout = function(self, layout) {
         if (!is_cross_layout(layout)) {
             cli_abort(c(
@@ -29,25 +28,29 @@ Cross <- ggproto("Cross", AlignProto,
 
         # udpate cross_points
         layout@cross_points <- c(layout@cross_points, length(layout@plot_list))
-        # update index
-        layout@index_list <- c(
-            layout@index_list,
-            list(.subset2(layout@design, "index"))
-        )
+
+        # update old design list
+        layout@odesign <- c(layout@odesign, list(layout@design))
         layout
     },
-    setup_design = function(self, layout_data, design) {
-        object_name <- .subset2(self, "object_name")
-        layout_name <- .subset2(self, "layout_name")
-        if (is.null(.subset2(design, "nobs"))) {
+    setup_design = function(self, data, design) {
+        if (self$reset_nobs && is.null(.subset2(design, "nobs"))) {
+            layout_name <- .subset2(self, "layout_name")
             cli_abort(sprintf(
-                "layout observations for %s must be initialized before adding {.var {%s}}",
-                layout_name, object_name
+                "layout observations for %s must be initialized before adding %s",
+                layout_name, object_name(self)
             ))
         }
+
         # we keep the names from the layout data for usage
-        self$labels <- vec_names(layout_data)
-        design["index"] <- list(NULL) # reset the index
+        self$labels <- vec_names(data)
+        design["index"] <- list(NULL) # always reset the index
+        if (self$reset_nobs || self$reset_panel) {
+            design["panel"] <- list(NULL)
+        }
+        if (self$reset_nobs) {
+            design["nobs"] <- list(NULL)
+        }
         design
     }
 )

R/ggalign.R

@@ -98,7 +98,7 @@ ggalign <- function(data = waiver(), mapping = aes(), ..., size = NULL,
     active <- update_active(active, new_active(use = TRUE))
     new_ggalign_plot(
         AlignGg,
-        input_data = allow_lambda(data), 
+        input_data = allow_lambda(data),
         params = list2(...),
         plot = ggplot(mapping = mapping),
         size = size,
@@ -111,14 +111,17 @@ ggalign <- function(data = waiver(), mapping = aes(), ..., size = NULL,
 #' @importFrom ggplot2 ggproto ggplot
 AlignGg <- ggproto("AlignGg", AlignProto,
     setup_design = function(self, layout_data, design) {
-        object_name <- self$object_name
         layout_name <- self$layout_name
         input_data <- self$input_data
+        object_name <- object_name(self)
         # inherit data from the layout
         if (is.function(input_data)) {
             if (is.null(layout_data)) {
                 cli_abort(c(
-                    "{.arg data} in {.var {object_name}} cannot be a function",
+                    sprintf(
+                        "{.arg data} in %s cannot be a function",
+                        object_name
+                    ),
                     i = sprintf("no data was found in %s", layout_name)
                 ))
             }
@@ -137,7 +140,7 @@ AlignGg <- ggproto("AlignGg", AlignProto,
                     layout_nobs <- NROW(data)
                 } else if (NROW(data) != layout_nobs) {
                     cli_abort(sprintf(
-                        "{.var %s} (nobs: %d) is not compatible with the %s (nobs: %d)",
+                        "%s (nobs: %d) is not compatible with the %s (nobs: %d)",
                         object_name, NROW(data), layout_name, layout_nobs
                     ))
                 }

R/ggfree.R

@@ -93,10 +93,12 @@ FreeGg <- ggproto("FreeGg", AlignProto,
             data <- layout_data
         } else if (is.function(input_data)) {
             if (is.null(layout_data)) {
-                object_name <- .subset2(self, "object_name")
                 cli_abort(c(
-                    "{.arg data} in {.var {object_name}} cannot be a function",
-                    i = sprintf("no data was found in %s", object_name(layout))
+                    sprintf(
+                        "{.arg data} in %s cannot be a function",
+                        object_name(self)
+                    ),
+                    i = sprintf("no data was found in %s", self$layout_name)
                 ))
             }
             data <- input_data(layout_data)

R/ggmark.R

@@ -97,10 +97,9 @@ MarkGg <- ggproto("MarkGg", AlignProto,
     setup_design = function(self, data, design) {
         if (is_continuous_design(design)) { # only used for discrete variable
             layout_name <- self$layout_name
-            object_name <- self$object_name
             # `AlignDiscrete` object is special for discrete variables
             cli_abort(c(
-                sprintf("Cannot add {.var {object_name}} to %s", layout_name),
+                sprintf("Cannot add %s to %s", object_name(self), layout_name),
                 i = sprintf("%s cannot align discrete variables", layout_name)
             ))
         }