具有串扰和传单的响应式“addWebGLHeatmap”

Question

我使用 addHeatmap 制作了带有响应式热图的传单地图。不幸的是，这种工具不够有用，因为有两个主要问题：1）热图随着每个新级别的缩放而重新绘制，以及 2）您不能将热图和单独组中的点分别制作。

addWebGLHeatmap?

可能有类似的解决方案

有 addHeatmap 解决方案的代码，在

之后

library(crosstalk)
library(leaflet)
library(leaflet.extras)
library(dplyr)

# Wrap data frame in SharedData
sd <- SharedData$new(quakes[sample(nrow(quakes), 10),])

bscols(widths=c(3,9),
  # Create a filter input
  filter_slider("mag", "Magnitude", sd, column=~mag, step=0.1),
  leaflet(sd) %>% 
    addTiles() %>% 
    addMarkers() %>% 
    addHeatmap(layerId="heatmap") %>%
    removeHeatmap("heatmap") %>%
    htmlwidgets::onRender("
      function(el,x){
        var myMap = this;
        var coord_state;
        var coords;
        
        function get_markers(){
          coord_state = [];
          myMap.eachLayer(function(layer){
            if (typeof layer.options.lat != 'undefined'){
              coord_state.push([layer.options.lat, layer.options.lng, 0.5]);
            }
          })
          return(coord_state)
        }
        
        function update_layer(){
          coords = get_markers()
          heat1.setLatLngs(coords);
          heat1.redraw();
        }
        
        var heat1 = L.heatLayer(get_markers(), {radius: 25}).addTo(myMap);
        myMap.on('layerremove', update_layer);
        myMap.on('layeradd', update_layer);
      }
    "))

Answer 1

此方法有点 hack，但仍然应该能够与 addWebGLHeatmap 一起使用。它添加了两组相同的标记并隐藏了一组控制热图的标记。这允许层控制。可以在这里找到一个工作示例：

https://rpubs.com/Jumble/leaflet_webgl_heatmap

下面是生成此代码的代码。此代码解决了主要的两个问题，尽管如果您不想绘制超过 1000 个点，它会很困难。

如果您想绘制数千个点，而不是使用串扰，最好结合使用 leafgl、shiny 和 addWebGLHeatmap 之类的东西。

n <- 200
data <- data.frame(id = seq(1, n*2), lat = rnorm(n, 0, 15), long = rnorm(n, 0, 15), group=c(rep("Heatmap",n), rep("Markers", n)), mag=rep(as.integer(runif(n, 0, 20)),2))
sd <- SharedData$new(data)

bscols(widths=c(3,9),
       filter_slider("mag", "Magnitude", sd, column=~mag, step=0.1),
       leaflet(sd, options=leafletOptions(preferCanvas = TRUE)) %>% 
         addTiles() %>% 
         leaflet::setView(lat=0, lng=0, zoom=4) %>%
         addMarkers(group=~group) %>%
         leaflet.extras::addWebGLHeatmap(layerId = "heatmapwebgl") %>%
         leaflet.extras::removeWebGLHeatmap("heatmapwebgl") %>%
         addLayersControl(overlayGroups = c("Heatmap", "Markers"), options=layersControlOptions(collapsed=FALSE)) %>%
         htmlwidgets::onRender("
          function(el,x){
            var myMap = this;
            var coord_state;
            
            // hide heatmap markers 
            setTimeout(function(){
              myMap.eachLayer(function(layer){
                if (layer.options.group=='Heatmap'){
                  layer.setOpacity(0);
                  layer.getElement().style.pointerEvents = 'none';
                }
              })
            }, 100)
            
            function get_markers(){
              coord_state = [];
              myMap.eachLayer(function(layer){
                if (layer.options.group=='Heatmap'){
                  coord_state.push([layer.options.lat, layer.options.lng, 0.5]);
                  layer.getElement().style.pointerEvents = 'none';
                }
              })
              return(coord_state)
            }
            
            function redraw_heatmap(){
              heatmap.setData(get_markers());
            }
            
            var heatmap = L.webGLHeatmap({size: 1000000,units: 'm',alphaRange: 1});
            heatmap.setData(get_markers());
            myMap.addLayer(heatmap);
            
            myMap.on('layerremove', redraw_heatmap);
            myMap.on('layeradd', redraw_heatmap);
          }
      "))

下方为圆形标记

n <- 200
data <- data.frame(id = seq(1, n*2), lat = rnorm(n, 0, 15), long = rnorm(n, 0, 15), group=c(rep("Heatmap",n), rep("Markers", n)), mag=rep(as.integer(runif(n, 0, 20)),2))
sd <- SharedData$new(data)

bscols(widths=c(3,9),
       filter_slider("mag", "Magnitude", sd, column=~mag, step=0.1),
       leaflet(sd) %>% 
         addTiles() %>% 
         leaflet::setView(lat=0, lng=0, zoom=4) %>%
         addCircleMarkers(group=~group, opacity=~ifelse(group=="Heatmap", 0, 0.5), fillOpacity=~ifelse(group=="Heatmap", 0, 0.2)) %>%
         leaflet.extras::addWebGLHeatmap(layerId = "heatmapwebgl") %>%
         leaflet.extras::removeWebGLHeatmap("heatmapwebgl") %>%
         addLayersControl(overlayGroups = c("Heatmap", "Markers"), options=layersControlOptions(collapsed=FALSE)) %>%
         htmlwidgets::onRender("
          function(el,x){
            var myMap = this;
            var coord_state;
            
            function get_markers(){
              coord_state = [];
              myMap.eachLayer(function(layer){
                if (layer.options.group=='Heatmap'){
                  coord_state.push([layer.options.lat, layer.options.lng, 0.5]);
                  layer.getElement().style.pointerEvents = 'none';
                }
              })
              return(coord_state)
            }
            
            function redraw_heatmap(){
              heatmap.setData(get_markers());
            }
            
            var heatmap = L.webGLHeatmap({size: 1000000,units: 'm',alphaRange: 1});
            heatmap.setData(get_markers());
            myMap.addLayer(heatmap);
            
            myMap.on('layerremove', redraw_heatmap);
            myMap.on('layeradd', redraw_heatmap);
          }
      "))

具有串扰和传单的响应式“addWebGLHeatmap”

Responsive `addWebGLHeatmap` with crosstalk and leaflet in

r

leaflet

crosstalk