diff --git a/R/trans-numeric.r b/R/trans-numeric.r index 4832da23..2c307f12 100644 --- a/R/trans-numeric.r +++ b/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) ) } diff --git a/R/trans.r b/R/trans.r index 93849a3b..7ca9b437 100644 --- a/R/trans.r +++ b/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,