在ggplot2散点图中使用伪彩色来表示密度

Question

有人知道如何创建截图中的图形吗？我试图通过调整alpha来获得类似的效果，但这会使异常值几乎不可见。我只从一个名为FlowJo的软件中知道这种类型的图形，这里它们将它称为＆＃34;伪彩色点图＆＃34;。不确定这是否是一个官方用语。

我想在ggplot2中专门做，因为我需要faceting选项。我附上了我的一张图表的另一张截图。垂直线描绘了某些基因组区域的突变簇。其中一些集群比其他集群密集得多。我想用密度颜色来说明这一点。

数据非常庞大且难以模拟，但这是一次尝试。我看起来不像实际数据，但数据格式是相同的。

chr <- c(rep(1:10,1000))
position <- runif(10000, min=0, max=5e8)
distance <- runif(10000, min=1, max=1e5)
log10dist <- log10(distance)

df1 <- data.frame(chr, position, distance, log10dist)

ggplot(df1, aes(position, log10dist)) + 
  geom_point(shape=16, size=0.25, alpha=0.5, show.legend = FALSE) +
  facet_wrap(~chr, ncol = 5, nrow = 2, scales = "free_x")

非常感谢任何帮助。

Answer 1

library(ggplot2)
library(ggalt)
library(viridis)

chr <- c(rep(1:10,1000))
position <- runif(10000, min=0, max=5e8)
distance <- runif(10000, min=1, max=1e5)
log10dist <- log10(distance)

df1 <- data.frame(chr, position, distance, log10dist)

ggplot(df1, aes(position, log10dist)) + 
  geom_point(shape=16, size=0.25, show.legend = FALSE) +
  stat_bkde2d(aes(fill=..level..), geom="polygon") +
  scale_fill_viridis() +
  facet_wrap(~chr, ncol = 5, nrow = 2, scales = "free_x")

在实践中，我会考虑初始带宽，然后找出最佳带宽。除了采用惰性方法并且仅绘制没有过滤的点（smoothScatter()过滤掉除了基于npoints的异常值之外的所有内容）之外，这就像您发布的示例一样生成“平滑的散点图”。

smoothScatter()使用不同的默认值，因此它有点不同：

par(mfrow=c(nr=2, nc=5))
for (chr in unique(df1$chr)) {
  plt_df <- dplyr::filter(df1, chr==chr)
  smoothScatter(df1$position, df1$log10dist, colramp=viridis)
}

geom_hex()将显示异常值，但不是明确的点：

ggplot(df1, aes(position, log10dist)) + 
  geom_point(shape=16, size=0.25, show.legend = FALSE, color="red") +
  scale_fill_viridis() +
  facet_wrap(~chr, ncol = 5, nrow = 2, scales = "free_x")

此：

ggplot(df1, aes(position, log10dist)) + 
  geom_point(shape=16, size=0.25) +
  stat_bkde2d(bandwidth=c(18036446, 0.05014539), 
              grid_size=c(128, 128), geom="polygon", aes(fill=..level..)) +
  scale_y_continuous(limits=c(3.5, 5.1)) +
  scale_fill_viridis() +
  facet_wrap(~chr, ncol = 5, nrow = 2, scales = "free_x") +
  theme_bw() +
  theme(panel.grid=element_blank())

让您非常接近smoothScatter()使用的默认值，但仅仅通过限制y轴限制，实现了nrpoints过滤代码在smoothScatter()函数中的大部分功能。

Answer 2

叫我oldschool，但为什么不使用 latticeExtra 包中的panel.smoothScatter。它提供对smoothScatter的直接访问，但鉴于它是一个面板功能，它会自动将其应用于定义的面板的每个子集。你说你需要＆＃34; facetting＆＃34;所以 lattice 是一个明显的选择，因为它明确地设计用于产生小的倍数（即小平面，或者在格子中，小组）。可以使用y ~ x | g轻松创建面板，其中g是用于定义小倍数的变量。对于您的示例，这只是：

library(latticeExtra)

chr <- c(rep(1:10,1000))
position <- runif(10000, min=0, max=5e8)
distance <- runif(10000, min=1, max=1e5)
log10dist <- log10(distance)

df1 <- data.frame(chr, position, distance, log10dist)

clrs <- colorRampPalette(brewer.pal(9, "Reds"))

xyplot(log10dist ~ position | chr, data = df1,
       panel = panel.smoothScatter, layout = c(5, 2),
       as.table = TRUE)

通过这种方式，您可以完全控制平滑功能，无需黑客攻击。

Answer 3

虽然生成可能包含数百万个点的图可能会占用大量计算资源，但是这是一种根据每个点的局部密度（即“伪彩色”点图）对每个点进行着色的解决方案。

用于计算局部密度的通用函数（相当快）。

densVals <- function(x, y = NULL, nbin = 128, bandwidth, range.x) {
  dat <- cbind(x, y)
  # limit dat to strictly finite values
  sel <- is.finite(x) & is.finite(y)
  dat.sel <- dat[sel, ]
  # density map with arbitrary graining along x and y
  map   <- grDevices:::.smoothScatterCalcDensity(dat.sel, nbin, bandwidth)
  map.x <- findInterval(dat.sel[, 1], map$x1)
  map.y <- findInterval(dat.sel[, 2], map$x2)
  # weighted mean of the fitted density map according to how close x and y are
  # to the arbitrary grain of the map
  den <- mapply(function(x, y) weighted.mean(x = c(
    map$fhat[x, y], map$fhat[x + 1, y + 1],
    map$fhat[x + 1, y], map$fhat[x, y + 1]), w = 1 / c(
    map$x1[x] + map$x2[y], map$x1[x + 1] + map$x2[y + 1],
    map$x1[x + 1] + map$x2[y], map$x1[x] + map$x2[y + 1])),
    map.x, map.y)
  # replace missing density estimates with NaN
  res <- rep(NaN, length(sel))
  res[sel] <- den
  res
}

在给定染色体分组的每个点上应用此方法。

library(dplyr)
library(ggplot2)

df1 %>% group_by(chr) %>% mutate(point_density = densVals(position, log10dist)) %>% 
  arrange(chr, point_density) %>% 
  ggplot(aes(x = position, y = log10dist, color = point_density)) +
  geom_point(size = .5) +
  scale_color_viridis_c() +
  facet_wrap(vars(chr), ncol = 5, scales = "free_x")

(pseudo-colored dot plot)