r - 如何在 ggplot 或lattice 中获得类似Matplotlib 的符号刻度的东西？

Question

对于正号和负号的重尾数据，我有时喜欢查看绘图上的所有数据，而不隐藏单位间隔中的结构。

在 Python 中使用 Matplotlib 进行绘图时，我可以通过选择 symlog scale 来实现此目的，它在某个区间外使用对数变换，并在其中使用线性绘图。

之前在 R 中，我通过使用 arcsinh 转换数据来构建类似的行为。一次性的。然而，刻度标签之类的东西要正确执行是非常棘手的(见下文)。

现在，我面临着一堆数据，其中 lattice 中的子集或ggplot会非常方便。由于子集设置，我不想使用 Matplotlib，但我确实缺少 symlog!

编辑:

我看到ggplot uses a package called scales ，这解决了很多这个问题(如果有效的话)。自动选择刻度线和标签放置看起来仍然很难做好。也许是 log_breaks 和 cbreaks 的某种组合？

编辑2:

下面的代码还不错

sinh.scaled <- function(x,scale=1){ sinh(x)*scale }
asinh.scaled <- function(x,scale=1) { asinh(x/scale) }



asinh_breaks <- function (n = 5, scale = 1, base=10) 
{
    function(x) {
        log_breaks.callable <- log_breaks(n=n,base=base)
        rng <- rng <- range(x, na.rm = TRUE)
        minx <- floor(rng[1])
        maxx <- ceiling(rng[2])
        if (maxx == minx) 
            return(sinh.scaled(minx, scale=scale))
        big.vals <- 0
        if (minx < (-scale)) {
            big.vals = big.vals + 1
        }
        if (maxx>scale) {
            big.vals = big.vals + 1
        }
        brk <- c()
        if (minx < (-scale)) {
            rbrk <- log_breaks.callable(  c(-min(maxx,-scale), -minx ) )
            rbrk <- -rev(rbrk)
            brk <- c(brk,rbrk)
        }
        if ( !(minx>scale | maxx<(-scale))  ) {
            rng <- c(max(minx,-scale), min(maxx,scale))
            minc <- floor(rng[1])
            maxc <- ceiling(rng[2])
            by <- floor((maxc - minc)/(n-big.vals)) + 1
            cb <- seq(minc, maxc, by = by)
            brk <- c(brk,cb)
        } 
        if (maxx>scale) {
            brk <- c(brk,log_breaks.callable( c(max(minx,scale), maxx )))
        }

        brk

    }
}

asinh_trans <- function(scale = 1) {
    trans <- function(x) asinh.scaled(x, scale)
    inv <- function(x) sinh.scaled(x, scale)
    trans_new(paste0("asinh-", format(scale)), trans, inv, 
              asinh_breaks(scale = scale), 
              domain = c(-Inf, Inf))
}

Answer 1

基于包 scales 的解决方案，并受到 @Dennis 提到的 Brian Diggs 帖子的启发:

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)

  breaks <- function(x){
    sgn <- sign(x[which.max(abs(x))])
    if(all(abs(x) < thr))
      pretty_breaks()(x)
    else if(prod(x) >= 0){
      if(min(abs(x)) < thr)
        sgn * unique(c(pretty_breaks()(c(min(abs(x)), thr)),
                       log_breaks(base)(c(max(abs(x)), thr))))
      else
        sgn * log_breaks(base)(sgn * x)
    } else {
      if(min(abs(x)) < thr)
        unique(c(sgn * log_breaks()(c(max(abs(x)), thr)),
                 pretty_breaks()(c(sgn * thr, x[which.min(abs(x))]))))
      else
        unique(c(-log_breaks(base)(c(thr, -x[1])),
                 pretty_breaks()(c(-thr, thr)),
                 log_breaks(base)(c(thr, x[2]))))
    }
  }
  trans_new(paste("symlog", thr, base, scale, sep = "-"), trans, inv, breaks)
}

我不确定参数 scale 的影响是否与 Python 中相同，但这里有一些比较(请参阅 Python 版本 here ):

data <- data.frame(x = seq(-50, 50, 0.01), y = seq(0, 100, 0.01))
data$y2 <- sin(data$x / 3)
# symlogx
ggplot(data, aes(x, y)) + geom_line() + theme_bw() +
  scale_x_continuous(trans = symlog_trans())

# symlogy
ggplot(data, aes(y, x)) + geom_line() + theme_bw()
  scale_y_continuous(trans="symlog")

# symlog both, threshold = 0.015 for y
# not too pretty because of too many breaks in short interval
ggplot(data, aes(x, y2)) + geom_line() + theme_bw()
  scale_y_continuous(trans=symlog_trans(thr = 0.015)) + 
  scale_x_continuous(trans = "symlog")

# Again symlog both, threshold = 0.15 for y
ggplot(data, aes(x, y2)) + geom_line() + theme_bw()
  scale_y_continuous(trans=symlog_trans(thr = 0.15)) + 
  scale_x_continuous(trans = "symlog")