以智能间距垂直分布多条线

Question

下面使用光谱数据（强度与波长）的常见显示来比较多个光谱中数据中的峰位置。假设它们都在 0 处共享一条基线，则可以方便地将多条线垂直偏移一个恒定的间距，以避免重叠线的干扰。

这样就变成了

我正在寻找一种更好的策略来自动执行这种垂直移动，从长格式的数据开始。这是一个最小的例子。

# fake data (5 similar-looking spectra)
spec <- function(){
  x <- runif(100, 0, 100)
  data.frame(x=x, y=jitter(dnorm(x, mean=jitter(50), sd=jitter(5)), amount=0.01))
}
require(plyr)
all <- ldply(1:5, function(ii) data.frame(spec(), id=ii))

我目前的策略如下：

• 将光谱从长格式转换为宽格式。这涉及插值，因为光谱不一定具有相同的 x 轴值。

• 找到光谱之间的最小偏移以避免相邻之间的重叠

• 将光谱移动该距离的倍数

• 融回长格式

我使用 plyr 实现了这个，

# function that evenly spaces the spectra to avoid overlap
# d is in long format, s is a scaling factor for the vertical shift
require(plyr); require(ggplot2)

spread_plot <- function(d, s=1){
  ranges <- ddply(d, "id", with, each(min,max,length)(x))
  common_x <- seq(max(ranges$min), min(ranges$max), length=max(ranges$length))
  new_y <- dlply(d, "id", function(x) approx(x$x, x$y, common_x)$y)
  mat <- do.call(cbind, new_y)
  test <- apply(mat, 1, diff)
  shift <- max(-test[test < 0])
  origins <- s*seq(0, by=shift, length=ncol(mat))

  for(ii in seq_along(origins)){
    current <- unique(d[["id"]])[ii]
    d[d[["id"]] == current, "y"] <- 
      d[d[["id"]] == current, "y"] + origins[ii]
  }
  d
}

test <- spread_plot(all)

ggplot(test, aes(x, y, colour=id, group=id))+
  geom_line() + guides(colour=guide_legend())

这种策略有一些缺点：

• 很慢

• 偏移量不是一个漂亮的数字；我不知道如何自动将其很好地舍入以使光谱偏移，例如0.02 或 50 等，取决于强度的范围。 pretty(origins) 的问题在于它可以返回不同数量的值。

我觉得我缺少一个更简单的解决方案，也许是直接使用长格式的原始数据。

Answer 1

有趣的问题。

这是一种可能性，没有详细评论，只是指出它：

• 应该非常快，因为它避免了 plyr、使用 data.table 以及以原始长格式对数据进行操作。李>
• 使用pretty() 选择漂亮的偏移量。
• 与您的代码一样，不能保证不会产生线交点，因为common_x 形成的点阵之间可能会发生重叠。

这是代码

## Setup
library(data.table)
library(plyr)
library(ggplot2)

spec <- function(){
  x <- runif(100, 0, 100)
  data.frame(x=x, y=jitter(dnorm(x, mean=jitter(50), sd=jitter(5)), amount=0.01))
}
all <- ldply(1:5, function(ii) data.frame(spec(), id=ii))

## Function that uses data.table rather than plyr to compute and add offsets
spread_plot <- function(d, s=1){
    d <- data.table(d, key="id")
    ranges <- d[, list(min=min(x), max=max(x), length=length(x)),by="id"]
    common_x <- seq(max(ranges$min), min(ranges$max), length=max(ranges$length))
    new_y <- d[,list(y=approx(x, y, common_x)$y, N=seq_along(common_x)),
               by="id"]
    shift <- max(new_y[, max(abs(diff(y))), by = "N"][[2]])
    shift <- pretty(c(0, shift), n=0)[2]
    origins <- s*seq(0, by=shift, length=length(unique(d$id)))
    d[,y:=(y + origins[.GRP]),by="id"]
    d
}

## Try it out
test <- spread_plot(all)
ggplot(test, aes(x, y, colour=id, group=id))+
  geom_line() + guides(colour=guide_legend())

Answer 2

我仍然认为您可以依赖一些关于光谱学典型数据的假设。通常，x 值是排序的，它们的数量对于所有光谱都是相等的，并且它们非常相似：

# new fake data (5 similar-looking spectra)
spec <- function(){
  x <- jitter(seq(0,100,1),0.1)
  data.frame(x=x, y=jitter(dnorm(x, mean=jitter(50), sd=jitter(5)), amount=0.01))
}
require(plyr)
all <- ldply(1:5, function(ii) data.frame(spec(), id=ii))

如果这些假设成立，您可以将光谱视为具有相同的 x 值：

library(ggplot2)
spread_plot  <- function(d, s=0.05) {
  #add some checks here, e.g., for equal length 
  d <- d[order(d$x),]
  d$id <- factor(d$id)
  l <- levels(d$id)
  pretty_offset <- pretty(s*min(tapply(d$y, d$id, function(x) abs(diff(range(x))))))[2]

  for (i in seq_len(length(l)-1)+1) {
      mean_delta_y <- mean(d[d$id == l[i], "y"] - d[d$id == l[i-1], "y"])
      d[d$id == l[i], "y"] <-  d[d$id == l[i], "y"] - mean_delta_y
      min_delta_y <- abs(1.05 * min(d[d$id == l[i], "y"] - d[d$id == l[i-1], "y"]))
      pretty_delta_y <- max(min_delta_y, pretty_offset)
      d[d$id == l[i], "y"] <-  d[d$id == l[i], "y"] + pretty_delta_y
      }
  p <- ggplot(d, aes(x=x, y=y, col=id)) + geom_line()
  print(p)
}
spread_plot(all, s=0)

spread_plot(all, s=0.5)

Answer 3

正如 hadley 所建议的，for 循环可以非常简单地避免，

d$y <- d$y + origins[d$id]

完整代码：

spread_plot <- function(d, s=1){
  ranges <- ddply(d, "id", with, each(min,max,length)(x))
  common_x <- seq(max(ranges$min), min(ranges$max), length=max(ranges$length))
  new_y <- dlply(d, "id", function(x) approx(x$x, x$y, common_x)$y)
  mat <- do.call(cbind, new_y)
  test <- apply(mat, 1, diff)
  shift <- max(-test[test < 0])
  origins <- s*seq(0, by=shift, length=ncol(mat))

  d$y <- d$y + origins[d$id]

  d
}

test <- spread_plot(all)

ggplot(test, aes(x, y, colour=id, group=id))+
  geom_line() + guides(colour=guide_legend())