Merge pull request #73 from corybrunson/elements

standardize the subset and elements parameters across biplot layers (and remove them from base layers)
corybrunson · Dec 31, 2024 · 852d823 · 852d823
2 parents 135c134 + 9239cb7
commit 852d823
Show file tree

Hide file tree

Showing 13 changed files with 116 additions and 94 deletions.
diff --git a/R/stat-matrix.r b/R/stat-matrix.r
@@ -27,7 +27,7 @@
 stat_rows <- function(
   mapping = NULL, data = data,
   geom = "point", position = "identity",
-  subset = NULL, elements = "all",
+  subset = NULL, elements = "active",
   ...,
   show.legend = NA, inherit.aes = TRUE
 ) {
@@ -52,7 +52,7 @@ stat_rows <- function(
 stat_cols <- function(
   mapping = NULL, data = data,
   geom = "axis", position = "identity",
-  subset = NULL, elements = "all",
+  subset = NULL, elements = "active",
   ...,
   show.legend = NA, inherit.aes = TRUE
 ) {
@@ -82,7 +82,7 @@ StatRows <- ggproto(
   setup_data = setup_rows_data,
 
   compute_group = function(data, scales,
-                           subset = NULL, elements = "all") {
+                           subset = NULL, elements = "active") {
     data
   }
 )
@@ -97,7 +97,7 @@ StatCols <- ggproto(
   setup_data = setup_cols_data,
 
   compute_group = function(data, scales,
-                           subset = NULL, elements = "all") {
+                           subset = NULL, elements = "active") {
     data
   }
 )
diff --git a/R/stat-rule.r b/R/stat-rule.r
@@ -100,7 +100,7 @@ StatRule <- ggproto(
     fun.lower = "minpp", fun.upper = "maxpp",
     fun.offset = "minabspp",
     fun.args = list(),
-    subset = NULL, elements = "all", referent = NULL
+    referent = NULL
   ) {
 
     # include computed variables even if trivial

diff --git a/R/stat-scale.r b/R/stat-scale.r
@@ -43,39 +43,8 @@ StatScale <- ggproto(
 
   required_aes = c("x", "y"),
 
-  compute_group = function(data, scales,
-                           mult = 1) {
+  compute_group = function(data, scales, mult = 1) {
     data[, c("x", "y")] <- data[, c("x", "y")] * mult
     data
   }
 )
-
-#' @rdname ordr-ggproto
-#' @format NULL
-#' @usage NULL
-#' @export
-StatRowsScale <- ggproto(
-  "StatRowsScale", StatScale,
-
-  setup_data = setup_rows_xy_data,
-
-  compute_group = function(data, scales,
-                           subset = NULL, elements = "all", mult = 1) {
-    StatScale$compute_group(data, scales, mult = mult)
-  }
-)
-
-#' @rdname ordr-ggproto
-#' @format NULL
-#' @usage NULL
-#' @export
-StatColsScale <- ggproto(
-  "StatColsScale", StatScale,
-
-  setup_data = setup_cols_xy_data,
-
-  compute_group = function(data, scales,
-                           subset = NULL, elements = "all", mult = 1) {
-    StatScale$compute_group(data, scales, mult = mult)
-  }
-)
diff --git a/R/utils.r b/R/utils.r
@@ -63,27 +63,27 @@ get_ord_aes <- function(data) {
   ord_cols
 }
 
+.ord_elements <- c("active", "score", "structure")
+
 # restrict to specified elements
 setup_elts_data <- function(data, params) {
 
-  # if specified and possible, restrict to active or supplementary elements
-  if (! is.null(params$elements) && ".element" %in% names(data)) {
-    # ensure that `elements` is a character singleton
-    stopifnot(
-      is.character(params$elements),
-      length(params$elements) == 1L
+  if (is.null(params$elements))
+    # default to active elements
+    params$elements <- "active"
+  else
+    # match `elements` to a list of recognized options (excluding `"all"`)
+    params$elements <- match.arg(params$elements, .ord_elements)
+
+  # subset accordingly
+  data <- data[data$.element == params$elements, , drop = FALSE]
+
+  # print note if both `elements` and `subset` are passed
+  if (! is.null(params$subset)) {
+    message(
+      "`subset` will be applied after data are restricted to ",
+      params$elements, " elements."
     )
-    # subset accordingly
-    data <- if ("all" %in% params$elements) {
-      data
-    } else {
-      data[data$.element == params$elements, , drop = FALSE]
-    }
-    # print note if both `elements` and `subset` are passed
-    if (! is.null(params$subset)) {
-      message("`subset` will be applied after data are restricted to ",
-              params$elements, " elements.")
-    }
   }
 
   # by default, render elements for all rows
@@ -99,6 +99,7 @@ setup_elts_data <- function(data, params) {
 
   data
 }
+
 # restrict to a matrix factor
 setup_rows_data <- function(data, params) {
 
@@ -170,3 +171,9 @@ setup_referent_params <- function(self, data, params) {
 }
 
 is_const <- function(x) length(unique(x)) == 1L
+
+ord_formals <- function(`_class`, method) {
+  fun <- environment(`_class`[[method]])[[method]]
+  formals(fun) <- c(formals(fun), list(subset = NULL, elements = "active"))
+  fun
+}
diff --git a/R/zzz-biplot-stats.r b/R/zzz-biplot-stats.r
@@ -38,7 +38,9 @@ NULL
 StatRowsEllipse <- ggproto(
   "StatRowsEllipse", StatEllipse,
 
-  setup_data = setup_rows_xy_data
+  setup_data = setup_rows_xy_data,
+
+  compute_group = ord_formals(StatEllipse, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -81,7 +83,9 @@ stat_rows_ellipse <- function(
 StatColsEllipse <- ggproto(
   "StatColsEllipse", StatEllipse,
 
-  setup_data = setup_cols_xy_data
+  setup_data = setup_cols_xy_data,
+
+  compute_group = ord_formals(StatEllipse, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -124,7 +128,9 @@ stat_cols_ellipse <- function(
 StatRowsCenter <- ggproto(
   "StatRowsCenter", StatCenter,
 
-  setup_data = setup_rows_xy_data
+  setup_data = setup_rows_xy_data,
+
+  compute_group = ord_formals(StatCenter, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -170,7 +176,9 @@ stat_rows_center <- function(
 StatColsCenter <- ggproto(
   "StatColsCenter", StatCenter,
 
-  setup_data = setup_cols_xy_data
+  setup_data = setup_cols_xy_data,
+
+  compute_group = ord_formals(StatCenter, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -216,7 +224,9 @@ stat_cols_center <- function(
 StatRowsStar <- ggproto(
   "StatRowsStar", StatStar,
 
-  setup_data = setup_rows_xy_data
+  setup_data = setup_rows_xy_data,
+
+  compute_group = ord_formals(StatStar, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -258,7 +268,9 @@ stat_rows_star <- function(
 StatColsStar <- ggproto(
   "StatColsStar", StatStar,
 
-  setup_data = setup_cols_xy_data
+  setup_data = setup_cols_xy_data,
+
+  compute_group = ord_formals(StatStar, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -300,7 +312,9 @@ stat_cols_star <- function(
 StatRowsChull <- ggproto(
   "StatRowsChull", StatChull,
 
-  setup_data = setup_rows_data
+  setup_data = setup_rows_data,
+
+  compute_group = ord_formals(StatChull, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -336,7 +350,9 @@ stat_rows_chull <- function(
 StatColsChull <- ggproto(
   "StatColsChull", StatChull,
 
-  setup_data = setup_cols_data
+  setup_data = setup_cols_data,
+
+  compute_group = ord_formals(StatChull, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -372,7 +388,9 @@ stat_cols_chull <- function(
 StatRowsCone <- ggproto(
   "StatRowsCone", StatCone,
 
-  setup_data = setup_rows_data
+  setup_data = setup_rows_data,
+
+  compute_group = ord_formals(StatCone, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -410,7 +428,9 @@ stat_rows_cone <- function(
 StatColsCone <- ggproto(
   "StatColsCone", StatCone,
 
-  setup_data = setup_cols_data
+  setup_data = setup_cols_data,
+
+  compute_group = ord_formals(StatCone, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -450,7 +470,9 @@ StatRowsProjection <- ggproto(
 
   setup_params = setup_referent_params,
 
-  setup_data = setup_rows_xy_data
+  setup_data = setup_rows_xy_data,
+
+  compute_group = ord_formals(StatProjection, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -494,7 +516,9 @@ StatColsProjection <- ggproto(
 
   setup_params = setup_referent_params,
 
-  setup_data = setup_cols_xy_data
+  setup_data = setup_cols_xy_data,
+
+  compute_group = ord_formals(StatProjection, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -538,7 +562,9 @@ StatRowsRule <- ggproto(
 
   setup_params = setup_referent_params,
 
-  setup_data = setup_rows_xy_data
+  setup_data = setup_rows_xy_data,
+
+  compute_group = ord_formals(StatRule, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -588,7 +614,9 @@ StatColsRule <- ggproto(
 
   setup_params = setup_referent_params,
 
-  setup_data = setup_cols_xy_data
+  setup_data = setup_cols_xy_data,
+
+  compute_group = ord_formals(StatRule, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -636,7 +664,9 @@ stat_cols_rule <- function(
 StatRowsScale <- ggproto(
   "StatRowsScale", StatScale,
 
-  setup_data = setup_rows_xy_data
+  setup_data = setup_rows_xy_data,
+
+  compute_group = ord_formals(StatScale, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -674,7 +704,9 @@ stat_rows_scale <- function(
 StatColsScale <- ggproto(
   "StatColsScale", StatScale,
 
-  setup_data = setup_cols_xy_data
+  setup_data = setup_cols_xy_data,
+
+  compute_group = ord_formals(StatScale, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -712,7 +744,9 @@ stat_cols_scale <- function(
 StatRowsSpantree <- ggproto(
   "StatRowsSpantree", StatSpantree,
 
-  setup_data = setup_rows_data
+  setup_data = setup_rows_data,
+
+  compute_group = ord_formals(StatSpantree, "compute_group")
 )
 
 #' @rdname biplot-stats
@@ -752,7 +786,9 @@ stat_rows_spantree <- function(
 StatColsSpantree <- ggproto(
   "StatColsSpantree", StatSpantree,
 
-  setup_data = setup_cols_data
+  setup_data = setup_cols_data,
+
+  compute_group = ord_formals(StatSpantree, "compute_group")
 )
 
 #' @rdname biplot-stats

diff --git a/build-pre/build-layers.r b/build-pre/build-layers.r
@@ -113,6 +113,7 @@ build_biplot_layer <- function(
     stat = ggplot2:::camelize(biplot_layer_name, first = TRUE),
     geom = ggplot2:::camelize(layer_name, first = TRUE)
   )
+  ggparent_name <- ggplot2:::camelize(layer_name, first = TRUE)
 
   # get uniplot formals (and insert any additional biplot formals)
   # -+- extract this into a function that can handle `...` -+-
@@ -171,10 +172,11 @@ build_biplot_layer <- function(
       "#' @usage NULL\n",
       "#' @export\n",
       "{ggproto_name} <- ggproto(\n",
-      "  \"{ggproto_name}\", {ggplot2:::camelize(layer_name, first = TRUE)},\n",
+      "  \"{ggproto_name}\", {ggparent_name},\n",
       "  \n",
       if (ref) "  setup_params = setup_referent_params,\n  \n" else "",
-      "  setup_data = setup_{.matrix}{if_xy}_data\n",
+      "  setup_data = setup_{.matrix}{if_xy}_data,\n  \n",
+      "  compute_group = ord_formals({ggparent_name}, \"compute_group\")\n",
       ")\n",
       "\n\n",
     ),

diff --git a/inst/examples/ex-dplyr-verbs-iris-lda.r b/inst/examples/ex-dplyr-verbs-iris-lda.r
@@ -18,7 +18,11 @@ transmute_cols(iris_lda, vec.length = sqrt(LD1^2 + LD2^2))
 # bind data frames of annotations
 iris_medians <-
   stats::aggregate(iris[, 1:4], median, by = iris[, 5, drop = FALSE])
+# TODO: Requirement of `.elements` for matching is fragile.
 iris_lda %>%
   # retain '.element' in order to match by `elements`
   select_rows(.element) %>%
   cbind_rows(iris_medians, elements = "active")
+iris_lda %>%
+  select_rows(name, Species) %>%
+  left_join_rows(iris_medians, by = c("name" = "Species"))