compute derivatives for compose_trans (r-lib#322)

R/trans-compose.R

@@ -27,11 +27,16 @@ compose_trans <- function(...) {
 
   names <- vapply(trans_list, "[[", "name", FUN.VALUE = character(1))
 
+  has_d_transform <- all(lengths(lapply(trans_list, "[[", "d_transform")) > 0)
+  has_d_inverse <- all(lengths(lapply(trans_list, "[[", "d_inverse")) > 0)
+
   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),
+    transform   = function(x) compose_fwd(x, trans_list),
+    inverse     = function(x) compose_rev(x, trans_list),
+    d_transform = if (has_d_transform) function(x) compose_deriv_fwd(x, trans_list),
+    d_inverse   = if (has_d_inverse) function(x) compose_deriv_rev(x, trans_list),
+    breaks      = function(x) trans_list[[1]]$breaks(x),
     domain = domain
   )
 }
@@ -49,3 +54,21 @@ compose_rev <- function(x, trans_list) {
   }
   x
 }
+
+compose_deriv_fwd <- function(x, trans_list) {
+  x_deriv <- 1
+  for (trans in trans_list) {
+    x_deriv <- trans$d_transform(x) * x_deriv
+    x <- trans$transform(x)
+  }
+  x_deriv
+}
+
+compose_deriv_rev <- function(x, trans_list) {
+  x_deriv <- 1
+  for (trans in rev(trans_list)) {
+    x_deriv <- trans$d_inverse(x) * x_deriv
+    x <- trans$inverse(x)
+  }
+  x_deriv
+}

tests/testthat/test-trans-compose.R

@@ -4,6 +4,18 @@ test_that("composes transforms correctly", {
   expect_equal(t$inverse(-2), 100)
 })
 
+test_that("composes derivatives correctly", {
+  t <- compose_trans("sqrt", "reciprocal", "reverse")
+  expect_equal(t$d_transform(0.25), 4)
+  expect_equal(t$d_inverse(-2), 0.25)
+})
+
+test_that("produces NULL derivatives if not all transforms have derivatives", {
+  t <- compose_trans("sqrt", trans_new("no_deriv", identity, identity))
+  expect_null(t$d_transform)
+  expect_null(t$d_inverse)
+})
+
 test_that("uses breaks from first transformer", {
   t <- compose_trans("log10", "reverse")
   expect_equal(t$breaks(c(1, 1000)), log_breaks()(c(1, 1000)))