A `scales`/`ggplot2` implementation of the `symlog` transformation

symlog_trans.R

#' symlog transformation
#'
#' `symlog_trans()` transforms data using `log(x)` for `abs(x) > thr`, where
#' `thr` is a tuneable threshold, but leaves the data linear for `abs(x) < thr`.
#' (credit for base code to https://stackoverflow.com/users/1320535/julius-vainora)
#'
#'
#' @param base base of logarithm
#' @param thr numeric threshold for transitioning from log to linear
#' @param scale numeric scaling factor for data
#' @export
#' @examples
#' plot(symlog_trans(), xlim = c(-100, 100))
#' plot(pseudo_log_trans(), xlim = c(-100, 100))
#'
#' library(ggplot2)
#' library(patchwork)
#' options(scipen = 9)
#' data <- data.frame(x = 1:100, y = (rexp(1000))^rnorm(1000, 1, 2)* ifelse(runif(1000) > .5, 1, -1))
#' p1 <- ggplot(data, aes(x, y)) +
#'     geom_point() +
#'     ggtitle("Using regular scaling")
#' p2 <- ggplot(data, aes(x, y)) +
#'     geom_point() +
#'     scale_y_continuous(trans = pseudo_log_trans()) +
#'     ggtitle("Using pseudo_log scaling")
#' p3 <- ggplot(data, aes(x, y)) +
#'     geom_point() +
#'     scale_y_continuous(trans = symlog_trans()) +
#'     ggtitle("Using symlog scaling")
#' p4 <- ggplot(data, aes(x, y)) +
#'     geom_point() +
#'     scale_y_continuous(trans = symlog_trans(), n.breaks = 3) +
#'     ggtitle("Using symlog and n.breaks=3")
#' p1 + p2 + p3 + p4
symlog_trans <- function(base = 10, thr = 1, scale = 1){
    trans <- function(x)
        ifelse(abs(x) < thr, x, sign(x) *
                   (thr + scale * suppressWarnings(log(sign(x) * x / thr, base))))

    inv <- function(x)
        ifelse(abs(x) < thr, x, sign(x) *
                   base^((sign(x) * x - thr) / scale) * thr)

    trans_new(paste("symlog", thr, base, scale, sep = "-"), trans, inv, symlog_breaks(base = base, thr = thr))
}


#' create breaks for symlog transformation
#' (allows for use of the `n.breaks` argument)
#'
#' @export
symlog_breaks <- function(n = 5, base, thr) {
    n_default <- n
    function(x, n = n_default) {
        n <- ceiling(n / 2)
        sgn <- sign(x[which.max(abs(x))])
        if(all(abs(x) < thr))
            pretty_breaks(n = n)(x)
        else if(prod(x) >= 0){
            if(min(abs(x)) < thr)
                sgn * unique(c(pretty_breaks(n = n)(c(min(abs(x)), thr)),
                               log_breaks(base, n = n)(c(max(abs(x)), thr))))
            else
                sgn * log_breaks(base, n = n)(sgn * x)
        } else {
            if(min(abs(x)) < thr)
                unique(c(sgn * log_breaks(n = n)(c(max(abs(x)), thr)),
                         pretty_breaks(n = n)(c(sgn * thr, x[which.min(abs(x))]))))
            else
                unique(c(-log_breaks(base, n = n)(c(thr, -x[1])),
                         pretty_breaks(n = n)(c(-thr, thr)),
                         log_breaks(base, n = n)(c(thr, x[2]))))
        }
    }
}