带有眼球追踪数据的热图（加权二维密度）

Question

我正在尝试创建一个注视图，其中二维密度图上每个注视的权重由其持续时间决定。据我了解，stat_density2d() 函数接受权重参数但不处理它 (ggplot2 2d Density Weights)

有办法解决这个问题吗？ 另外，我怎样才能平滑热图的粒度？我一定在这里遗漏了一些很明显的东西

#sample data
set.seed(42)  ## for sake of reproducibility
df <- data.frame(x=sample(0:1920, 1000, replace=TRUE), 
                 y=sample(0:1080, 1000, replace=TRUE), 
                 dur=sample(50:1000, 1000, replace=TRUE))

#what I have so far
library(ggplot2)
ggplot(df, aes(x=x, y =y)) +
  stat_density2d(geom='raster', 
                 aes(fill=..count.., alpha=..count..), contour=FALSE) + 
  geom_point(aes(size=dur), alpha=0.2, color="red") +
  scale_fill_gradient(low="green", high="red") +
  scale_alpha_continuous(range=c(0, 1) , guide="none") +
  theme_void()

Answer 1

不是 ggplot2 用户，但基本上你想估计一个加权二维密度并从中得到一个 image。您的 linked answer 表示 ggplot2::geom_density2d 内部使用 MASS::kde2d，但它只计算未加权的二维密度。

膨胀观察

相近@AllanCameron的建议（但不需要使用tidyr）我们可以简单地通过按毫秒持续时间复制每一行来膨胀数据框，

dfa <- df[rep(seq_len(nrow(df)), times=df$dur), -3]

并手动计算kde2d。

n <- 1e3

system.time(
  dens1 <- MASS::kde2d(dfa$x, dfa$y, n=n)  ## this runs a while!
)
#     user   system  elapsed 
# 2253.285 2325.819  661.632 

n= 参数表示每个方向上的网格点数，我们选择的越大，热图图像中的粒度就越平滑。

system.time(
  dens1 <- MASS::kde2d(dfa$x, dfa$y, n=n)  ## this runs a while
)
#     user   system  elapsed 
# 2253.285 2325.819  661.632 

image(dens1, col=heat.colors(n, rev=TRUE))

这几乎永远运行，尽管 n=1000...

加权二维密度估计

在对上述答案的评论中，@IRTFM links一个古老的帮助帖子提供了一个kde2d.weighted 函数，它快如闪电，我们可以尝试（见底部的代码）。

dens2 <- kde2d.weighted(x=df$x, y=df$y, w=proportions(df$dur), n=n) 
image(dens2, col=heat.colors(n, rev=TRUE))

然而，这两个版本看起来很不一样，我不知道哪个是对的，因为我不是这个方法的专家。但至少与未加权的图像有明显的区别：

未加权图像

dens0 <- MASS::kde2d(df$x, df$y, n=n)
image(dens0, col=heat.colors(n, rev=TRUE))

积分

仍然添加点可能毫无意义，但您可以在image 之后运行此行：

points(y ~ x, df, cex=proportions(dur)*2e3, col='green')

---

摘自帮助（Ort 2006）：

kde2d.weighted <- function(x, y, w, h, n=n, lims=c(range(x), range(y))) {
  nx <- length(x)
  if (length(y) != nx) 
    stop("data vectors must be the same length")
  gx <- seq(lims[1], lims[2], length=n)  ## gridpoints x
  gy <- seq(lims[3], lims[4], length=n)  ## gridpoints y
  if (missing(h)) 
    h <- c(MASS::bandwidth.nrd(x), MASS::bandwidth.nrd(y))
  if (missing(w)) 
    w <- numeric(nx) + 1
  h <- h/4
  ax <- outer(gx, x, "-")/h[1]  ## distance of each point to each grid point in x-direction
  ay <- outer(gy, y, "-")/h[2]  ## distance of each point to each grid point in y-direction
  z <- (matrix(rep(w,n), nrow=n, ncol=nx, byrow=TRUE)*
          matrix(dnorm(ax), n, nx)) %*% 
    t(matrix(dnorm(ay), n, nx))/(sum(w)*h[1]*h[2])  ## z is the density
  return(list(x=gx, y=gy, z=z))
}

Answer 2

最简单的方法是使用 tidyr::uncount 复制数据框的行，使用 dur 作为权重：

library(ggplot2)

ggplot(tidyr::uncount(df, dur), aes(x=x, y =y)) +
  stat_density2d(geom='raster', 
                 aes(fill=..count.., alpha=..count..), contour=FALSE) + 
  geom_point(data = df, aes(size=dur), alpha=0.2, color="red") +
  scale_fill_gradient(low="green", high="red") +
  scale_alpha_continuous(range=c(0, 1) , guide="none") +
  theme_void()

删除点后效果可能更容易看到：

ggplot(tidyr::uncount(df, dur), aes(x=x, y =y)) +
  stat_density2d(geom='raster', 
                 aes(fill=..count.., alpha=..count..), contour=FALSE) + 
  scale_fill_gradient(low="green", high="red") +
  scale_alpha_continuous(range=c(0, 1) , guide="none") +
  theme_void()

Answer 3

前面的回答很有帮助！我根据这些代码绘制了热图。但是，我想知道如何在热图上添加背景图片。