Implement transformer composition (#335)

Fixes #287

DESCRIPTION

@@ -20,7 +20,7 @@ Imports:
     munsell (>= 0.5),
     R6,
     RColorBrewer,
-    rlang,
+    rlang (>= 1.0.0),
     viridisLite
 Suggests: 
     bit64,
@@ -29,7 +29,8 @@ Suggests:
     ggplot2,
     hms (>= 0.5.0),
     stringi,
-    testthat (>= 3.0.0)
+    testthat (>= 3.0.0),
+    waldo (>= 0.4.0)
 Config/Needs/website: tidyverse/tidytemplate
 Encoding: UTF-8
 LazyLoad: yes

NAMESPACE

@@ -52,6 +52,7 @@ export(col_quantile)
 export(colour_ramp)
 export(comma)
 export(comma_format)
+export(compose_trans)
 export(cscale)
 export(date_breaks)
 export(date_format)

NEWS.md

@@ -1,5 +1,11 @@
 # scales (development version)
 
+* New `compose_trans()` allows arbitrary composition of transformers. This
+  is mostly easily achieved by passing a character vector whenever you might
+  previously have passed the name of a single transformer. For example,
+  `scale_y_continuous(trans = c("log10", "reverse"))` will create a 
+  reverse log-10 scale (#287).
+
 * `time_trans()` and `date_trans()` have `domains` of the correct type so that 
   they can be transformed without error (#298).
 

R/trans-compose.R

@@ -0,0 +1,51 @@
+#' Compose two or more transformations together
+#'
+#' This transformer provides a general mechanism for composing two or more
+#' transformers together. The most important use case is to combine reverse
+#' with other transformations.
+#'
+#' @param ... One or more transformers, either specified with string or
+#'   as individual transformer objects.
+#' @export
+#' @examples
+#' demo_continuous(10^c(-2:4), trans = "log10", labels = label_log())
+#' demo_continuous(10^c(-2:4), trans = c("log10", "reverse"), labels = label_log())
+compose_trans <- function(...) {
+  trans_list <- lapply(list2(...), as.trans)
+  if (length(trans_list) == 0) {
+    abort("Must include at least 1 transformer to compose")
+  }
+
+  # Resolve domains
+  suppressWarnings(
+    domain <- compose_fwd(trans_list[[1]]$domain, trans_list[-1])
+  )
+  if (any(is.na(domain))) {
+    abort("Sequence of transformations yields invalid domain")
+  }
+  domain <- range(domain)
+
+  names <- vapply(trans_list, "[[", "name", FUN.VALUE = character(1))
+
+  trans_new(
+    paste0("composition(", paste0(names, collapse = ","), ")"),
+    transform = function(x) compose_fwd(x, trans_list),
+    inverse   = function(x) compose_rev(x, trans_list),
+    breaks    = function(x) trans_list[[1]]$breaks(x),
+    domain = domain
+  )
+}
+
+compose_fwd <- function(x, trans_list) {
+  for (trans in trans_list) {
+    x <- trans$transform(x)
+  }
+  x
+}
+
+compose_rev <- function(x, trans_list) {
+  for (trans in rev(trans_list)) {
+    x <- trans$inverse(x)
+  }
+  x
+}

R/trans.r

@@ -48,7 +48,10 @@ trans_new <- function(name, transform, inverse, breaks = extended_breaks(),
 is.trans <- function(x) inherits(x, "trans")
 
 #' @export
-print.trans <- function(x, ...) cat("Transformer: ", x$name, "\n")
+print.trans <- function(x, ...) {
+  cat("Transformer: ", x$name, " [", x$domain[[1]], ", ", x$domain[[2]], "]\n", sep = "")
+  invisible(x)
+}
 
 #' @export
 plot.trans <- function(x, y, ..., xlim, ylim = NULL) {
@@ -79,13 +82,19 @@ lines.trans <- function(x, ..., xlim) {
 
 #' @rdname trans_new
 #' @export
-as.trans <- function(x) {
+as.trans <- function(x, arg = deparse(substitute(x))) {
   if (is.trans(x)) {
-    return(x)
+    x
+  } else if (is.character(x) && length(x) >= 1) {
+    if (length(x) == 1) {
+      f <- paste0(x, "_trans")
+      match.fun(f)()
+    } else {
+      compose_trans(!!!x)
+    }
+  } else {
+    abort(sprintf("`%s` must be a character vector or a transformer object", arg))
   }
-
-  f <- paste0(x, "_trans")
-  match.fun(f)()
 }
 
 #' Compute range of transformed values

scales.Rproj

@@ -17,5 +17,6 @@ StripTrailingWhitespace: Yes
 
 BuildType: Package
 PackageUseDevtools: Yes
+PackageCleanBeforeInstall: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
 PackageRoxygenize: rd,collate,namespace

tests/testthat/_snaps/colour-mapping.md

@@ -3,10 +3,12 @@
     Code
       x <- c(1:5, rep(10, 10))
       col <- col_quantile("RdYlBu", domain = x, n = 7)(x)
-    Warning <simpleWarning>
+    Condition
+      Warning:
       Skewed data means we can only allocate 4 unique colours not the 7 requested
     Code
       col <- col_quantile("RdYlBu", domain = NULL, n = 7)(x)
-    Warning <simpleWarning>
+    Condition
+      Warning:
       Skewed data means we can only allocate 4 unique colours not the 7 requested
 

tests/testthat/_snaps/trans-compose.md

@@ -0,0 +1,13 @@
+# produces informative errors
+
+    Code
+      compose_trans()
+    Condition
+      Error in `compose_trans()`:
+      ! Must include at least 1 transformer to compose
+    Code
+      compose_trans("reverse", "log10")
+    Condition
+      Error in `compose_trans()`:
+      ! Sequence of transformations yields invalid domain
+

tests/testthat/_snaps/trans.md

@@ -0,0 +1,20 @@
+# as.trans generates informative error
+
+    Code
+      as.trans(1)
+    Condition
+      Error in `as.trans()`:
+      ! `1` must be a character vector or a transformer object
+    Code
+      as.trans("x")
+    Condition
+      Error in `get()`:
+      ! object 'x_trans' of mode 'function' was not found
+
+# trans has useful print method
+
+    Code
+      trans_new("test", transform = identity, inverse = identity)
+    Output
+      Transformer: test [-Inf, Inf]
+

tests/testthat/test-trans-compose.R

@@ -0,0 +1,17 @@
+test_that("composes transforms correctly", {
+  t <- compose_trans("log10", "reverse")
+  expect_equal(t$transform(100), -2)
+  expect_equal(t$inverse(-2), 100)
+})
+
+test_that("uses breaks from first transformer", {
+  t <- compose_trans("log10", "reverse")
+  expect_equal(t$breaks(c(1, 1000)), log_breaks()(c(1, 1000)))
+})
+
+test_that("produces informative errors", {
+  expect_snapshot(error = TRUE, {
+    compose_trans()
+    compose_trans("reverse", "log10")
+  })
+})

tests/testthat/test-trans.r

@@ -5,3 +5,25 @@ test_that("Transformed ranges silently drop out-of-domain values", {
   r2 <- trans_range(sqrt_trans(), -1:10)
   expect_equal(r2, sqrt(c(0, 10)))
 })
+
+
+test_that("as.trans handles character inputs", {
+  expect_equal(as.trans("log10"), log10_trans())
+  expect_equal(
+    as.trans(c("log10", "reverse")),
+    compose_trans(log10_trans(), reverse_trans())
+  )
+})
+
+test_that("as.trans generates informative error", {
+  expect_snapshot(error = TRUE, {
+    as.trans(1)
+    as.trans("x")
+  })
+})
+
+test_that("trans has useful print method", {
+  expect_snapshot({
+    trans_new("test", transform = identity, inverse = identity)
+  })
+})