Skip to content

Instantly share code, notes, and snippets.

@antonkratz
Forked from davidtedfordholt/symlog_trans.R
Created May 31, 2022 18:14
Show Gist options
  • Save antonkratz/0862c12556f630b8ec7d87f844cdab79 to your computer and use it in GitHub Desktop.
Save antonkratz/0862c12556f630b8ec7d87f844cdab79 to your computer and use it in GitHub Desktop.
A `scales`/`ggplot2` implementation of the `symlog` transformation
#' 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]))))
}
}
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment