r heatmap - stat_density2d（ggmap）与addHeatmap（闪亮的传单）

Question

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

GGMAP

LEAFLET

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

要运行以下两个可重现的示例，您可以下载我放在这里的一些数据（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

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

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

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

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

想象一个热图，就像功能的可视化一样

  

f（像素）=Σ（最大值（0，半径 - 距离（像素，点））·强度（点））

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

Answer 2

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

library(leaflet)
library(rlang)

addHeatMap <- function(data, lon, lat, intensity, ...) {
  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)

  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)

Answer 3

两者都使用不同的算法。您需要调整radius的{​​{1}}和blur参数以及addHeatmap的{​​{1}}参数，以获得类似的结果。