r - 带有眼球追踪数据的热图(加权二维密度)

Question

我正在尝试创建注 View ，其中二维密度图上每个注视的权重由其持续时间决定。据我了解，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 用户，但基本上您想估计加权二维密度并从中制作图像。你的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一个古老的 r-help 帖子，它提供了一个 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')

---

摘自r-help(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))
}