r heatmap - stat_density2d (ggmap) vs. addHeatmap (shiny leaflet)

Question

I made static heatmaps with the library(ggmap) and the stat_density2d() function. Looking to recreate this in a shiny app on a dynamic leaflet map, I found addHeatmap(). However, the resulting images are dissimilar, with the ggmap version seemingly offering the correct result.

GGMAP

LEAFLET

What is causing this difference?

To run both of the below reproducible examples, you can download some data (csv file) I put here. https://drive.google.com/drive/folders/0B8_GTHBuoKSRR1VIRmhOUTJKYU0?usp=sharing

Note that the leaflet result differs with zoom level, but never matches the ggmap result (e.g. in terms location of maximum heat).

This is the ggmap code.

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)

This is the leaflet code.

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

The images look different because the algorithms are different.

stat_density2d() extrapolates a probability density function from the discrete data.

Leaflet implementation of heatmaps rely on libraries like simpleheat, heatmap.js or webgl-heatmap. These heatmaps do not rely on probability density. (I'm not fully sure which of these is used by r-leaflet's addHeatmap).

Instead, these heatmaps work by drawing a blurred circle for each point, raising the value of each pixel by an amount directly proportional to the intensity of the point (constant in your case), and inversely proportional to the distance between the point and the circle. Every data point is shown in the heatmap as a circle. You can see this by playing with your mouse cursor in the heatmap.js webpage, or by looking at this lone point in the top-right of your image:

Think of a heatmap like a visualization of the function

f(pixel) = ∑ ( max( 0, radius - distance(pixel, point) ) · intensity(point) )

One can tweak the radius and intensity of heatmaps, but the result will never be the same as a statistical density estimation.

Answer 2

I've found this answer over at GIS, and I've attempted to create a function and applied it to this case. I haven't figured out how to finetune the colour gradient scheme as of yet, but it seems like a good first start otherwise:

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)