allow to pass function to referent argument & evaluate via LayerRef

Author: corybrunson

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: gggda
 Title: A 'ggplot2' Extension for Geometric Data Analysis
-Version: 0.1.1
+Version: 0.1.1.0009
 Authors@R: c(
   person("Jason Cory", "Brunson", email = "cornelioid@gmail.com",
     role = c("aut", "cre"), comment = c(ORCID = "0000-0003-3126-9494")),

NEWS.md

@@ -1,3 +1,8 @@
+# next version
+
+As with the `data` argument, the `referent` argument of `stat_referent()` can now be passed a function, which will be evaluated at `data` to obtain the reference data for the plot layer.
+The evaluation is done during addition of a layer of class `LayerRef`.
+
 # gggda 0.1.1
 
 This patch fixes a bug in the peel stat and adds unit tests for it and the scale stat.

R/stat-referent.r

@@ -10,21 +10,27 @@
 #' Often in geometric data analysis a statistical transformation applied to data
 #' \eqn{X} will also depend on data \eqn{Y}, for example when drawing the
 #' projections of vectors \eqn{X} onto vectors \eqn{Y}. The stat layer
-#' `stat_referent()` accepts \eqn{Y} as an argument to the `referent` parameter
+#' `stat_referent()` accepts \eqn{Y} as an argument to the `referent` argument
 #' and pre-processes them using the existing positional aesthetic mappings to
 #' `x` and `y`.
 #'
+#' If a function is passed to `referent`, then the reference data are obtained
+#' by evaluating the function at the primary `data`. Alongside borrowing the
+#' aesthetic mappings, the evaluation is done during addition via
+#' [ggplot2::ggplot_add()] of the layer of custom class `LayerRef`.
+#'
 #' The ggproto can be used as a parent to more elaborate statistical
 #' transformations, or the stat can be paired with geoms that expect the
-#' `referent` parameter and use it to position their transformations of \eqn{X}.
-#' It pairs by default to `[ggplot2::geom_blank()]` so as to prevent possibly
+#' `referent` argument and use it to position their transformations of \eqn{X}.
+#' It pairs by default to [ggplot2::geom_blank()] so as to prevent possibly
 #' confusing output.
 #' 
 
 #' @inheritParams ggplot2::layer
 #' @template param-layer
 #' @inheritParams ggplot2::ggplot_add
-#' @param referent The reference data set; see Details.
+#' @param referent The reference data set, admitting the same 3 options as
+#'   `data`; see Details.
 #' @template return-layer
 #' @family biplot layers
 #' @example inst/examples/ex-stat-referent.r
@@ -82,7 +88,9 @@ StatReferent <- ggproto(
     # required `x` and `y` aesthetics should be in `data`
     # (code adapted from `ggplot2:::Layer$compute_aesthetics()`)
     # NB: No checks are conducted here as in `$compute_aesthetics()`.
+    # TODO: Maybe do this in `LayerRef()` rather than here?
     if (! is.null(params$referent)) {
+      # replace with mappings as applied to primary data
       params$referent <- lapply(
         params$mapping,
         rlang::eval_tidy, data = as.data.frame(params$referent)
@@ -105,6 +113,11 @@ StatReferent <- ggproto(
 #' @export
 ggplot_add.LayerRef <- function(object, plot, ...) {
 
+  # if function, then replace with evaluation at primary data
+  if (is.function(object$stat_params$referent)) {
+    object$stat_params$referent <- object$stat_params$referent(plot$data)
+  }
+  
   # store global position mappings as a parameter
   object$stat_params$mapping <- plot$mapping[c("x", "y")]
 

inst/examples/ex-stat-referent.r

@@ -16,3 +16,19 @@ ggplot(subcars, aes(x = hp00, y = wt)) +
 ggplot(subcars, aes(x = hp00, y = wt)) +
   coord_equal() +
   stat_referent(geom = "point", referent = grad)
+
+# passing a function yields a transformation of the primary data
+p <- ggplot(subcars, aes(x = hp00, y = wt)) +
+  stat_referent(
+    data = head,
+    referent = function(d) as.data.frame(lapply(d, mean))
+  )
+b <- ggplot_build(p)
+# original data
+b@plot@data
+# head of original data
+b@data[[1]]
+# means of original data
+b@plot@layers$stat_referent$stat_params$referent
+# means of head of original data
+as.data.frame(lapply(layer_data(p, 1), mean))

man/stat_referent.Rd

@@ -42,3 +42,28 @@ test_that("mapping and referent parameters together yield new plotting data", {
   expect_equal(names(df2_setup), c("x", "y"))
   expect_equal(nrow(df2_setup), 4L)
 })
+
+test_that("passing a function to `referent` evaluates it at `data`", {
+  p <- ggplot(mtcars, aes(x = hp/100, y = wt)) +
+    stat_referent(
+      data = head,
+      referent = function(d) as.data.frame(lapply(d, mean))
+    )
+  b <- ggplot_build(p)
+  # original data
+  expect_identical(b@plot@data, mtcars)
+  # head of original data
+  expect_equal(nrow(b@data[[1]]), 6L)
+  # means of original data
+  expect_equal(
+    b@plot@layers$stat_referent$stat_params$referent,
+    as.data.frame(lapply(mtcars, mean))
+  )
+  # means of head of original data
+  expect_equal(
+    lapply(subset(layer_data(p, 1), select = c(x, y)), mean),
+    lapply(head(subset(transform(mtcars, x = hp/100, y = wt),
+                       select = c(x, y))), mean)
+  )
+  
+})