add basic derivatives of transforms and inverses (r-lib#322)

R/trans-numeric.r

@@ -10,7 +10,9 @@ asn_trans <- function() {
   trans_new(
     "asn",
     function(x) 2 * asin(sqrt(x)),
-    function(x) sin(x / 2)^2
+    function(x) sin(x / 2)^2,
+    d_transform = function(x) 1 / sqrt(x - x^2),
+    d_inverse = function(x) sin(x) / 2
   )
 }
 
@@ -20,7 +22,13 @@ asn_trans <- function() {
 #' @examples
 #' plot(atanh_trans(), xlim = c(-1, 1))
 atanh_trans <- function() {
-  trans_new("atanh", "atanh", "tanh")
+  trans_new(
+    "atanh",
+    "atanh",
+    "tanh",
+    d_transform = function(x) 1 / (1 - x^2),
+    d_inverse = function(x) 1 / cosh(x)^2
+  )
 }
 
 #' Box-Cox & modulus transformations
@@ -183,7 +191,9 @@ exp_trans <- function(base = exp(1)) {
   trans_new(
     paste0("power-", format(base)),
     function(x) base^x,
-    function(x) log(x, base = base)
+    function(x) log(x, base = base),
+    d_transform = function(x) base^x * log(base),
+    d_inverse = function(x) 1 / x / log(base)
   )
 }
 
@@ -193,7 +203,13 @@ exp_trans <- function(base = exp(1)) {
 #' @examples
 #' plot(identity_trans(), xlim = c(-1, 1))
 identity_trans <- function() {
-  trans_new("identity", "force", "force")
+  trans_new(
+    "identity",
+    "force",
+    "force",
+    d_transform = function(x) 1,
+    d_inverse = function(x) 1
+  )
 }
 
 
@@ -222,11 +238,13 @@ identity_trans <- function() {
 #' lines(log_trans(), xlim = c(1, 20), col = "red")
 log_trans <- function(base = exp(1)) {
   force(base)
-  trans <- function(x) log(x, base)
-  inv <- function(x) base^x
-
-  trans_new(paste0("log-", format(base)), trans, inv,
-    log_breaks(base = base),
+  trans_new(
+    paste0("log-", format(base)),
+    function(x) log(x, base),
+    function(x) base^x,
+    d_transform = function(x) 1 / x / log(base),
+    d_inverse = function(x) base^x * log(base),
+    breaks = log_breaks(base = base),
     domain = c(1e-100, Inf)
   )
 }
@@ -245,7 +263,13 @@ log2_trans <- function() {
 #' @rdname log_trans
 #' @export
 log1p_trans <- function() {
-  trans_new("log1p", "log1p", "expm1")
+  trans_new(
+    "log1p",
+    "log1p",
+    "expm1",
+    d_transform = function(x) 1 / (1 + x),
+    d_inverse = "exp"
+  )
 }
 
 #' @rdname log_trans
@@ -255,15 +279,18 @@ pseudo_log_trans <- function(sigma = 1, base = exp(1)) {
   trans_new(
     "pseudo_log",
     function(x) asinh(x / (2 * sigma)) / log(base),
-    function(x) 2 * sigma * sinh(x * log(base))
+    function(x) 2 * sigma * sinh(x * log(base)),
+    d_transform = function(x) 1 / (sqrt(4 + x^2/sigma^2) * sigma * log(base)),
+    d_inverse = function(x) 2 * sigma * cosh(x * log(base)) * log(base)
   )
 }
 
 #' Probability transformation
 #'
 #' @param distribution probability distribution.  Should be standard R
-#'   abbreviation so that "p" + distribution is a valid probability density
-#'   function, and "q" + distribution is a valid quantile function.
+#'   abbreviation so that "p" + distribution is a valid cumulative distribution
+#'   function, "q" + distribution is a valid quantile function, and
+#'   "d" + distribution is a valid probability density function.
 #' @param ... other arguments passed on to distribution and quantile functions
 #' @export
 #' @examples
@@ -272,11 +299,14 @@ pseudo_log_trans <- function(sigma = 1, base = exp(1)) {
 probability_trans <- function(distribution, ...) {
   qfun <- match.fun(paste0("q", distribution))
   pfun <- match.fun(paste0("p", distribution))
+  dfun <- match.fun(paste0("d", distribution))
 
   trans_new(
     paste0("prob-", distribution),
     function(x) qfun(x, ...),
-    function(x) pfun(x, ...)
+    function(x) pfun(x, ...),
+    d_transform = function(x) 1 / dfun(qfun(x, ...), ...),
+    d_inverse = function(x) dfun(x, ...)
   )
 }
 #' @export
@@ -295,7 +325,9 @@ reciprocal_trans <- function() {
   trans_new(
     "reciprocal",
     function(x) 1 / x,
-    function(x) 1 / x
+    function(x) 1 / x,
+    d_transform = function(x) -1 / x^2,
+    d_inverse = function(x) -1 / x^2
   )
 }
 
@@ -309,6 +341,8 @@ reverse_trans <- function() {
     "reverse",
     function(x) -x,
     function(x) -x,
+    d_transform = function(x) -1,
+    d_inverse = function(x) -1,
     minor_breaks = regular_minor_breaks(reverse = TRUE)
   )
 }
@@ -326,6 +360,8 @@ sqrt_trans <- function() {
     "sqrt",
     "sqrt",
     function(x) x^2,
+    d_transform = function(x) 0.5 / sqrt(x),
+    d_inverse = function(x) 2 * x,
     domain = c(0, Inf)
   )
 }

R/trans.r

@@ -5,13 +5,18 @@
 #' function is applied on the transformed range of the range, and it's
 #' expected that the labels function will perform some kind of inverse
 #' transformation on these breaks to give them labels that are meaningful on
-#' the original scale.
+#' the original scale. Transformations may also include the derivatives of the
+#' transformation and its inverse, but are not required to.
 #'
 #' @param name transformation name
 #' @param transform function, or name of function, that performs the
 #'   transformation
 #' @param inverse function, or name of function, that performs the
 #'   inverse of the transformation
+#' @param d_transform Optional function, or name of function, that gives the
+#'   derivative of the transformation. May be `NULL`.
+#' @param d_inverse Optional function, or name of function, that gives the
+#'   derivative of the inverse of the transformation. May be `NULL`.
 #' @param breaks default breaks function for this transformation. The breaks
 #'   function is applied to the raw data.
 #' @param minor_breaks default minor breaks function for this transformation.
@@ -23,17 +28,23 @@
 #' @export
 #' @keywords internal
 #' @aliases trans
-trans_new <- function(name, transform, inverse, breaks = extended_breaks(),
+trans_new <- function(name, transform, inverse,
+                      d_transform = NULL, d_inverse = NULL,
+                      breaks = extended_breaks(),
                       minor_breaks = regular_minor_breaks(),
                       format = format_format(), domain = c(-Inf, Inf)) {
   if (is.character(transform)) transform <- match.fun(transform)
   if (is.character(inverse)) inverse <- match.fun(inverse)
+  if (is.character(d_transform)) d_transform <- match.fun(d_transform)
+  if (is.character(d_inverse)) d_inverse <- match.fun(d_inverse)
 
   structure(
     list(
       name = name,
       transform = transform,
       inverse = inverse,
+      d_transform = d_transform,
+      d_inverse = d_inverse,
       breaks = breaks,
       minor_breaks = minor_breaks,
       format = format,