r 热图 - stat_density2d（ggmap）与 addHeatmap（闪亮传单）

Question

我使用library(ggmap) 和stat_density2d() 函数制作了静态热图。为了在动态leaflet 地图上的闪亮应用程序中重新创建它，我找到了addHeatmap()。但是，生成的图像是不同的，ggmap 版本似乎提供了正确的结果。

GGMAP

传单

造成这种差异的原因是什么？

要运行以下两个可重现的示例，您可以下载我放在这里的一些数据（csv 文件）。 https://drive.google.com/drive/folders/0B8_GTHBuoKSRR1VIRmhOUTJKYU0?usp=sharing

请注意，leaflet 结果因缩放级别而异，但绝不与ggmap 结果匹配（例如，就最大热量的位置而言）。

这是ggmap 代码。

library(ggmap)
data <- read.csv("DATA.csv", sep=";")
data <- subset(data, !is.na(CrdLatDeg))
xmin <- min(data$CrdLonDeg)
xmax <- max(data$CrdLonDeg)
ymin <- min(data$CrdLatDeg)
ymax <- max(data$CrdLatDeg)
lon <- c(xmin,xmax)
lat <- c(ymin,ymax)
map <- get_map(location = c(lon = mean(lon), lat = mean(lat)), zoom = 17,
               maptype = "satellite", source = "google")
ggmap(map) + 
  labs(x="longitude", y="latitude") + 
  stat_density2d(data=data, aes(x=CrdLonDeg, y=CrdLatDeg, alpha= ..level.., fill= ..level..), colour=FALSE,
                 geom="polygon", bins=100) + 
  scale_fill_gradientn(colours=c(rev(rainbow(100, start=0, end=.7)))) + scale_alpha(range=c(0,.8)) + 
  guides(alpha=FALSE,fill=FALSE)

这是leaflet 代码。

library(leaflet.extras)
data <- read.csv("DATA.csv", sep=";")
data <- subset(data, !is.na(CrdLatDeg))
leaflet(data) %>%
  addTiles(group="OSM") %>%
  addHeatmap(group="heat", lng=~CrdLonDeg, lat=~CrdLatDeg, max=.6, blur = 60)

Answer 1

我在 GIS 上找到了this answer，我尝试创建一个函数并将其应用于此案例。到目前为止，我还没有弄清楚如何微调颜色渐变方案，但它似乎是一个不错的开始：

library(leaflet)
library(rlang)

addHeatMap <- function(data, lon, lat, intensity, show.legend, ...) {
  df <- data.table::as.data.table(data)
  df_expanded <- dplyr::slice(df, rep(1:dplyr::n(), times = !! enquo(intensity)))

  lon_var <- dplyr::pull(df_expanded, !! enquo(lon))
  lat_var <- dplyr::pull(df_expanded, !! enquo(lat))

  lon_bw <- MASS::bandwidth.nrd(lon_var)
  lat_bw <- MASS::bandwidth.nrd(lat_var)

  lon_lat_df <- dplyr::select(df_expanded, !! enquo(lon), !! enquo(lat))

  kde <- KernSmooth::bkde2D(lon_lat_df, bandwidth = c(lon_bw, lat_bw))
  CL <- contourLines(kde$x1 , kde$x2 , kde$fhat)
  LEVS <- as.factor(sapply(CL, `[[`, "level"))
  NLEV <- nlevels(LEVS)
  pgons <- lapply(1:length(CL), function(i)
  sp::Polygons(list(sp::Polygon(cbind(CL[[i]]$x, CL[[i]]$y))), ID = i))
  spgons <- sp::SpatialPolygons(pgons)

  if (show.legend) {
    leaflet::addPolygons(data = spgons, color = heat.colors(NLEV, NULL)[LEVS], stroke = FALSE, ...) %>% 
      leaflet::addLegend(colors = heat.colors(NLEV, NULL)[LEVS], labels = LEVS)
    } else {
    leaflet::addPolygons(data = spgons, color = heat.colors(NLEV, NULL)[LEVS], stroke = FALSE, ...)
    }
}

mydata <- read.csv("DATA.csv", sep=";")
mydata <- subset(mydata, !is.na(CrdLatDeg))

leaflet() %>%
  addTiles(group = "OSM") %>%
  addHeatMap(data = mydata, lon = CrdLonDeg, lat = CrdLatDeg, intensity = FsmIdf, show.legend = TRUE)

Answer 2

图像看起来不同，因为算法不同。

stat_density2d() 从离散数据中推断出probability density function。

热图的传单实现依赖于 simpleheat、heatmap.js 或 webgl-heatmap 等库。这些热图不依赖于概率密度。 （我不完全确定 r-leaflet 的 addHeatmap 使用了哪些）。

相反，这些热图的工作原理是为每个点绘制一个模糊的圆圈，将每个像素的值提高一个与点的强度成正比的量（在您的情况下为常数），与点之间的距离成反比和圆圈。每个数据点在热图中显示为一个圆圈。您可以通过在the heatmap.js webpage 中使用鼠标光标来查看这一点，或者查看图片右上角的这个单独的点：

将热图想象成函数的可视化

f(pixel) = ∑ ( max( 0, 半径 - 距离(pixel, point) ) · 强度(point) )

可以调整热图的半径和强度，但结果永远不会与统计密度估计相同。

Answer 3

两者都使用不同的算法。您需要调整addHeatmap 的radius 和blur 参数以及stat_density2d 的h 参数以获得相似的结果。