在R中制作线密度热图

Question

问题描述
我有数千行（~4000）要绘制。然而，使用 geom_line()绘制所有线条并仅使用 alpha = 0.1 来说明哪些地方具有高密度的线条和哪些不是不可行。我在Python中看到了类似的东西，特别是答案中的第二个图看起来非常好，但我不知道是否可以在 ggplot2 中实现类似的东西。因此，需要类似这样的东西：

示例数据集
用一组显示模式的数据集更有意义，但现在我只生成了随机正弦曲线：

set.seed(1)
gen.dat <- function(key) {
    c <- sample(seq(0.1,1, by = 0.1), 1)
    time <- seq(c*pi,length.out=100)
    val <- sin(time)
    time = 1:100
    data.frame(time,val,key)
}
dat <- lapply(seq(1,10000), gen.dat) %>% bind_rows()

尝试热力图
我尝试过一个热力图，就像这里回答的那样，但是这个热力图不会考虑点在整个坐标轴上的连接关系（就像在线上一样），而是显示每个时间点的“热度”。

问题
如何使用ggplot2在R中绘制类似于第一张图片所示的线条热力图？

- CodeNoob

Answer 1

仔细观察，您链接的图表由许多，许多，许多点而非线组成。 ggpointdensity软件包进行类似的可视化。请注意，由于有许多数据点，存在相当多的性能问题。我正在使用开发人员版本，因为它包含method参数，允许使用不同的平滑估计器，并且明显有助于更好地处理更大的数字。也有CRAN版本。

您可以使用adjust参数调整平滑度。

我已经增加了您代码的x间隔密度，使其看起来更像线条。虽然在图中稍微减少了“线”的数量。

library(tidyverse)
#devtools::install_github("LKremer/ggpointdensity")
library(ggpointdensity)

set.seed(1)
gen.dat <- function(key) {
  c <- sample(seq(0.1,1, by = 0.1), 1)
  time <- seq(c*pi,length.out=500)
  val <- sin(time)
  time = seq(0.02,100,0.1)
  data.frame(time,val,key)
}
dat <- lapply(seq(1, 1000), gen.dat) %>% bind_rows()

ggplot(dat, aes(time, val)) + 
  geom_pointdensity(size = 0.1, adjust = 10) 
#> geom_pointdensity using method='kde2d' due to large number of points (>20k)

^{由 reprex包 (v0.3.0) 于2020年03月19日创建}

更新 感谢user Robert Gertenbach提供了一些更有趣的样本数据。以下是在这些数据上建议使用ggpointdensity的方法：

library(tidyverse)
library(ggpointdensity)

gen.dat <- function(key) {
  has_offset <- runif(1) > 0.5
  time <- seq(1, 1000, length.out = 1000)
  val <- sin(time / 100 + rnorm(1, sd = 0.2) + (has_offset * 1.5)) * 
    rgamma(1, 20, 20)
  data.frame(time,val,key)
}

dat <- lapply(seq(1,1000), gen.dat) %>% bind_rows()
ggplot(dat, aes(time, val, group=key)) +stat_pointdensity(geom = "line", size = 0.05, adjust = 10) + scale_color_gradientn(colors = c("blue", "yellow", "red"))

^{本文创建于2020年3月24日，使用reprex包（v0.3.0）}

- tjebo

---

感谢您的回答。从技术上讲，每一行和散点（点）图都可以互换，但这取决于底层数据 - 在我提供的问题中，图像清楚地展示了模式/相关性而不是点的**"抖动"**。举个例子，在您的图中，底层的特征正弦结构并不明显。 - CodeNoob

@CodeNoob，样本数据可能不是理想的。我发现可以看到模式-它自然地创建了一个规则网格。通常，如果将线转换为点，则该方法应该有效。但这也是我在您的问题上悬赏的原因，因为可能有更好的解决方案。我觉得这是一个有趣的问题。 - tjebo

如果你很难看出图案，可以把图片缩小一点，这样你就不会只看到单个的点了。在你提供的示例图片中也是同样的情况，这是一个分辨率的问题。 - tjebo

使用以下代码在我的数据上进行绘图：ggplot(dat, aes(time, val, group=key)) +stat_pointdensity(geom = "line", size = 0.05, adjust = 10) + scale_color_gradientn(colors = c("blue", "yellow", "red"))，结果非常好看！ - Robin Gertenbach

Answer 2

您的数据将导致相当均匀的波点密度。

我生成了一些稍微有趣一点的数据，像这样：

gen.dat <- function(key) {
  has_offset <- runif(1) > 0.5
  time <- seq(1, 1000, length.out = 1000)
  val <- sin(time / 100 + rnorm(1, sd = 0.2) + (has_offset * 1.5)) * 
    rgamma(1, 20, 20)
  data.frame(time,val,key)
}
dat <- lapply(seq(1,1000), gen.dat) %>% bind_rows()

然后我们得到一个二维密度估计。由于 kde2d 没有 predict 函数，因此我们使用 LOESS 模型进行建模。

dens <- MASS::kde2d(dat$time, dat$val, n = 400)
dens_df <- data.frame(with(dens, expand_grid( y, x)), z = as.vector(dens$z))
fit <- loess(z ~ y * x, data = dens_df, span = 0.02)
dat$z <- predict(fit, with(dat, data.frame(x=time, y=val)))

绘制它，然后得到以下结果：

ggplot(dat, aes(time, val, group = key, color = z)) +
  geom_line(size = 0.05) +
  theme_minimal() +
  scale_color_gradientn(colors = c("blue", "yellow", "red"))

这完全取决于：

• 系列的数量
• 系列的分辨率
• kde2d的密度
• loess的跨度

因此，您的结果可能会有所不同。

- Robin Gertenbach

---

使用Tjebo的库建议在我的数据上尝试 ggplot(dat, aes(time, val, group=key)) +stat_pointdensity(geom = "line", size = 0.05, adjust = 10) + scale_color_gradientn(colors = c("blue", "yellow", "red"))。 - Robin Gertenbach

确实很不错。感谢提供漂亮的样本数据，使用ggpointdensity看起来非常棒。 - tjebo

已经使用您的数据更新了我的答案。再次感谢。 - tjebo

谢谢您的慷慨奖励，Tjebo :) 我认为最终 ggpointdensity 实现了一个更漂亮的热力图。我想知道它的密度是否准确，因为在 ~250，-0.5 的密度与在 375 -0.5 的密度相似，但这可能只是渐变效果。 - Robin Gertenbach

Answer 3

我想到了以下解决方案，使用geom_segment()，但我不确定geom_segment()是否是正确的选择，因为它只检查成对值是否完全相同，而在热图（如我的问题中），彼此接近的值也会影响“热度”，而不仅仅是完全相同。

# Simple stats to get all possible line segments
vals <- unique(dat$time)
min.val = min(vals)
max.val = max(vals)

# Get all possible line segments
comb.df <- data.frame(
  time1 = min.val:(max.val - 1),
  time2 = (min.val + 1): max.val
)

# Join the original data to all possible line segments
comb.df <- comb.df %>% 
  left_join(dat %>% select(time1 = time, val1 = val, key )) %>%
  left_join(dat %>% select(time2 = time, val2 = val, key ))

# Count how often each line segment occurs in the data
comb.df <- comb.df %>% 
  group_by(time1, time2, val1, val2) %>%
  summarise(n = n_distinct(key))

# ggplot2 to plot segments
ggplot(comb.df %>% arrange(n)) +
  geom_segment(aes(x = time1, y = val1, xend = time2, yend = val2, color = n), alpha =0.9) +
  scale_colour_gradient( low = 'green', high = 'red')  +
  theme_bw()

- CodeNoob