active: reduce the rebundant codes

R/active.R

@@ -33,10 +33,12 @@ active <- function(order = waiver(), use = waiver(), name = waiver()) {
             allow_null = FALSE
         )
     }
-    new_active(order, use, name)
+    new_active(order = order, use = use, name = name)
 }
 
-new_active <- function(order, use, name) {
+# for internal function, we only adjust to the `use` argument
+# here, we put it in the first
+new_active <- function(use, order = NA_integer_, name = NA_character_) {
     structure(
         list(order = order, use = use, name = name),
         class = "ggalign_active"

R/align-dendrogram.R

@@ -99,9 +99,7 @@ align_dendro <- function(mapping = aes(), ...,
         }
     }
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = TRUE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = TRUE))
     active <- deprecate_active(active, "align_dendro",
         set_context = set_context, order = order, name = name
     )

R/align-gg.R

@@ -107,9 +107,7 @@ align_gg <- function(data = waiver(), mapping = aes(), size = NULL,
         ))
     }
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = TRUE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = TRUE))
     active <- deprecate_active(active, "align_gg",
         set_context = set_context, order = order, name = name
     )

R/align-group.R

@@ -17,9 +17,7 @@
 align_group <- function(group, active = NULL, set_context = deprecated(),
                         name = deprecated()) {
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = FALSE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = FALSE))
     active <- deprecate_active(active, "align_group",
         set_context = set_context, name = name
     )

R/align-hclust.R

@@ -65,9 +65,7 @@ align_hclust <- function(distance = "euclidean",
         }
     }
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = FALSE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = FALSE))
     align(
         align = AlignHclust,
         params = list(

R/align-kmeans.R

@@ -20,9 +20,7 @@ align_kmeans <- function(centers, ..., data = NULL,
                          active = NULL, set_context = deprecated(),
                          name = deprecated()) {
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = FALSE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = FALSE))
     active <- deprecate_active(active, "align_group",
         set_context = set_context, name = name
     )

R/align-order.R

@@ -63,9 +63,7 @@ align_order <- function(weights = rowMeans, ...,
     assert_bool(strict)
     assert_bool(reverse)
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = FALSE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = FALSE))
     active <- deprecate_active(active, "align_order",
         set_context = set_context, name = name
     )

R/align-ranges.R

@@ -9,9 +9,7 @@ align_ranges <- function(data = waiver(), mapping = aes(),
         ))
     }
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = TRUE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = TRUE))
     align(AlignRanges,
         plot = ggplot(mapping = mapping),
         size = size, data = data,

R/align-reorder.R

@@ -40,9 +40,7 @@ align_reorder <- function(stat, ..., reverse = FALSE,
     assert_bool(strict)
     assert_bool(reverse)
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = FALSE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = FALSE))
     active <- deprecate_active(active, "align_order",
         set_context = set_context, name = name
     )

R/layout-heatmap-.R

@@ -110,9 +110,7 @@ heatmap_layout.default <- function(data = NULL, mapping = aes(),
         ncols <- NULL
     }
     assert_active(active)
-    active <- update_active(active, new_active(
-        use = TRUE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = TRUE))
     active <- deprecate_active(active, "ggheatmap",
         set_context = set_context, order = order, name = name
     )

R/layout-quad-.R

@@ -314,9 +314,7 @@ new_quad_layout <- function(name, data, horizontal, vertical,
         # used by the layout
         data = data, theme = theme,
         schemes = schemes,
-        plot_active = update_active(active, new_active(
-            order = NA_integer_, use = TRUE, name = NA_character_
-        )),
+        plot_active = update_active(active, new_active(use = TRUE)),
         name = name,
         # used by the main body
         body_schemes = new_schemes(new_scheme_data(waiver())),

R/plot-align-cross.R

@@ -35,9 +35,7 @@
 #' @export
 cross_link <- function(mapping = aes(), size = NULL,
                        no_axes = NULL, active = NULL) {
-    active <- update_active(active, new_active(
-        use = TRUE, order = NA_integer_, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = TRUE))
     new_align_plot(
         align = ggproto(NULL, CrossLink),
         plot = ggplot(mapping = mapping),

R/plot-free-gg.R

@@ -66,9 +66,7 @@ free_gg.ggplot <- function(data = waiver(), ..., size = NULL, active = NULL) {
 
 new_free_gg <- function(plot, data, size, active,
                         call = caller_call()) {
-    active <- update_active(active, new_active(
-        order = NA_integer_, use = TRUE, name = NA_character_
-    ))
+    active <- update_active(active, new_active(use = TRUE))
     new_free_plot(
         plot = plot, data = data,
         size = size, active = active,

tests/testthat/_snaps/active.md

@@ -0,0 +1,21 @@
+# `active()` works well
+
+    `order` must be a single number
+
+---
+
+    `order` must be a single number
+
+---
+
+    Can't convert from `order` <double> to <integer> due to loss of precision.
+    * Locations: 1
+
+---
+
+    `use` must be `TRUE` or `FALSE`, not `NA`.
+
+---
+
+    `name` must be a single string or `NA`, not `FALSE`.
+

tests/testthat/test-active.R

@@ -0,0 +1,15 @@
+test_that("`active()` works well", {
+    expect_identical(active(NULL)$order, NA_integer_)
+    expect_snapshot_error(active(1:2))
+    expect_snapshot_error(active("a"))
+    expect_snapshot_error(active(1.2))
+    expect_identical(active(1)$order, 1L)
+
+    expect_snapshot_error(active(use = NA)$use)
+    expect_identical(active(use = TRUE)$use, TRUE)
+    expect_identical(active(use = FALSE)$use, FALSE)
+
+    expect_identical(active(name = NA)$name, NA)
+    expect_identical(active(name = "my_name")$name, "my_name")
+    expect_snapshot_error(active(name = FALSE))
+})