问题描述
我使用addHeatmap
制作了带有响应热图的传单图。不幸的是,这种工具的用处还不够,因为存在两个主要问题:1)使用新的缩放级别重新绘制热图,以及2)无法将热图和单独组中的点分别绘制。
addWebGLHeatmap
可能有类似的解决方案吗?
在this question之后有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);
}
"))
解决方法
此方法有点骇人听闻,但仍然可以使用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,15),long = rnorm(n,group=c(rep("Heatmap",n),rep("Markers",n)),mag=rep(as.integer(runif(n,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,leaflet(sd) %>%
addTiles() %>%
leaflet::setView(lat=0,zoom=4) %>%
addCircleMarkers(group=~group,opacity=~ifelse(group=="Heatmap",0.5),fillOpacity=~ifelse(group=="Heatmap",0.2)) %>%
leaflet.extras::addWebGLHeatmap(layerId = "heatmapwebgl") %>%
leaflet.extras::removeWebGLHeatmap("heatmapwebgl") %>%
addLayersControl(overlayGroups = c("Heatmap",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,redraw_heatmap);
}
"))