在 Leaflet 中使用套索代替矩形 select 统治
Use lasso instead Rectangle for select reign in Leaflet
我正在尝试使用 R 显示传单地图（我不能使用 Shiny 包）。我使用 'DT'、'crosstalk' 和 'leaflet' 包来计算地图中 selected 数据的列的平均值。在地图中，它 select 只有矩形的点。是否可以通过套索 select？
#R code
library(dplyr)
library(leaflet)
library(DT)
library(crosstalk)
data_2 <- data.frame(ID=c(1:8),
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12,43,54,34,23,77,44,22),
Value2 = c(6,5,2,7,5,6,4,3),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0))
data_2<-data_2 %>%
mutate(
lab_DB = case_when(
Name1 == unique(data_2$Name1)[1] ~ "blue",
Name1 == unique(data_2$Name1)[2] ~ "green",
Name1 == unique(data_2$Name1)[3] ~ "red"
)
)
sdf <- SharedData$new(data_2, ~data_2$ID)
DT1<-datatable(
sdf, filter = 'top',
extensions = c('Select', 'Buttons'), selection = 'none', options = list(select = list(style = 'os', items = 'row'),dom = 'Bfrtip',autoWidth = TRUE,buttons = list('copy' ,
list(extend = 'collection', buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download')
,list(extend = 'collection', text = 'Mean',
action = DT::JS("function ( e, dt, node, config ) {
let columnData = dt.column(4,{search:'applied'}).data().toArray();
var amean= Math.round(columnData.reduce((sum, item) => sum+=item)/columnData.length);
alert('mean Value1: ' +amean);
}"))
,list(extend='collection',buttons=c('selectAll', 'selectNone', 'selectRows', 'selectColumns', 'selectCells'),text='sel')
)))
ltlf5<- leaflet(sdf) %>%
#addProviderTiles(providers$CartoDB.Positron) %>%
addTiles() %>%
addCircleMarkers(
lng = ~Lat,
lat = ~Lon,
group = ~Name1,popup = ~paste(Name1, ' <br/> ',
Name2,' <br/> ' ),
color =~lab_DB ,
radius = 3
) %>%
addLayersControl(
overlayGroups = c('A','B','C')
,options = layersControlOptions(collapsed = FALSE)
) %>%
addLegend(
position = 'bottomleft',
labels = c('Group A','Group B','Group C'),
colors = c("blue","red", "green"),
title = "Group color"
)
bscols(ltlf5 ,DT1)
我找到了 leaflet-lasso(Lasso selection plugin (Demo),Jan Zak Jan Zak ) 但我不知道如何使用它？
leaflet-lasso 是一个 JS 插件。我也找到了Using arbitrary Leaflet JS plugins with Leaflet for R但是还是不能解决问题
我们可以使用 'plotly' 包而不是 'leaflet'。这不需要闪亮太多。您有多项选择和套索选择地图上的点。要重置所选点，请双击地图。
library(dplyr)
library(plotly)
library(DT)
library(crosstalk)
data_2 <- data.frame(ID=c(1:8),
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12,43,54,34,23,77,44,22),
Value2 = c(6,5,2,7,5,6,4,3),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0))
data_2<-data_2 %>%
mutate(
lab_DB = case_when(
Name1 == unique(data_2$Name1)[1] ~ "blue",
Name1 == unique(data_2$Name1)[2] ~ "green",
Name1 == unique(data_2$Name1)[3] ~ "red"
)
)
sdf <- SharedData$new(data_2, ~data_2$ID)
DT1<-datatable(
sdf, filter = 'top',
extensions = c('Select', 'Buttons'), selection = 'none', options = list(select = list(style = 'os', items = 'row'),dom = 'Bfrtip',autoWidth = TRUE,buttons = list('copy' ,
list(extend = 'collection', buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download')
,list(extend = 'collection', text = 'Mean',
action = DT::JS("function ( e, dt, node, config ) {
let columnData = dt.column(4,{search:'applied'}).data().toArray();
var amean= Math.round(columnData.reduce((sum, item) => sum+=item)/columnData.length);
alert('mean Value1: ' +amean);
}"))
,list(extend='collection',buttons=c('selectAll', 'selectNone', 'selectRows', 'selectColumns', 'selectCells'),text='sel')
)))
fig <- sdf %>%
plot_ly(height=900,
lat = ~Lat,
lon = ~Lon,
marker = list(color = ~lab_DB),
type = 'scattermapbox'
)
fig <- fig %>%
layout(
mapbox = list(
style = 'open-street-map',
zoom =2.5,
center = list(lon = -2, lat = 51)))
fig<-fig %>%
highlight("plotly_selected", dynamic = F,color = NULL)
options(persistent = TRUE)
bscols(widths = c(6, 4), fig, DT1)
这也是我非常喜欢的相声功能。不幸的是，我认为目前无法完成。也许您可以向串扰 GitHub 页面添加功能请求。
目前，我尝试了一个非常令人作呕的解决方法，它可能适合您的需要。它基本上使用以下 links 并试图让它们一起工作：
- https://rstudio.github.io/crosstalk/authoring.html
- https://github.com/zakjan/leaflet-lasso/blob/master/docs/index.html
这些是 crosstalk 和 lasso-leaflet 的文档页面。可以在下面找到以下解决方案的演示（单击套索按钮绘制套索，单击取消按钮清除当前选择）：
它并没有完全按照串扰的方式工作，但它可能工作得很好。也许其他人可以提出更好的解决方案。以下代码生成了上面的 link，但对于您的代码：
library(leaflet)
library(crosstalk)
library(DT)
library(dplyr)
library(htmltools)
library(summarywidget)
data_2 <- data.frame(ID=c(1:8),
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12,43,54,34,23,77,44,22),
Value2 = c(6,5,2,7,5,6,4,3),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0))
data_2<-data_2 %>%
mutate(
lab_DB = case_when(
Name1 == unique(data_2$Name1)[1] ~ "blue",
Name1 == unique(data_2$Name1)[2] ~ "green",
Name1 == unique(data_2$Name1)[3] ~ "red"
)
)
sdf <- SharedData$new(data_2, key=~ID, group="SharedDataqwertyui")
lmap <- leaflet() %>%
addTiles() %>%
addMarkers(data=sdf, group="test", layerId = ~ID) %>%
htmlwidgets::prependContent(tags$script(src="https://unpkg.com/leaflet-lasso@2.2.4/dist/leaflet-lasso.umd.min.js")) %>%
htmlwidgets::onRender("
function(el, x) {
var sheet = window.document.styleSheets[0];
sheet.insertRule('.selectedMarker { filter: hue-rotate(135deg); }', sheet.cssRules.length);
var map = this;
const lassoControl = L.control.lasso(options={'position':'topleft'}).addTo(map);
function resetSelectedState() {
map.eachLayer(layer => {
if (layer instanceof L.Marker) {
layer.setIcon(new L.Icon.Default());
} else if (layer instanceof L.Path) {
layer.setStyle({ color: '#3388ff' });
}
});
}
function setSelectedLayers(layers) {
resetSelectedState();
let ids = [];
layers.forEach(layer => {
if (layer instanceof L.Marker) {
layer.setIcon(new L.Icon.Default({ className: 'selected selectedMarker'}));
} else if (layer instanceof L.Path) {
layer.setStyle({ color: '#ff4620' });
}
ids.push(layer.options.layerId);
});
ct_filter.set(ids);
}
var ct_filter = new crosstalk.FilterHandle('SharedDataqwertyui');
ct_filter.setGroup('SharedDataqwertyui');
var ct_sel = new crosstalk.SelectionHandle('SharedDataqwertyui');
ct_sel.setGroup('SharedDataqwertyui');
map.on('mousedown', () => {
ct_filter.clear();
ct_sel.clear();
resetSelectedState();
});
map.on('lasso.finished', event => {
setSelectedLayers(event.layers);
});
lassoControl.setOptions({ intersect: true});
var clearSel = function(){
ct_filter.clear();
ct_sel.clear();
resetSelectedState();
}
document.getElementById('clearbutton').onclick = clearSel;
}") %>%
addEasyButton(
easyButton(
icon = "fa-ban",
title = "Clear Selection",
id="clearbutton",
onClick = JS("function(btn, map){
return
}")
)
)
dtable <- datatable(sdf , width = "100%",editable=TRUE, caption=tags$caption("Mean of Value1: ",summarywidget(sdf, statistic='mean', column='Value1')))
bscols( widths=c(6,6,0), lmap, dtable, htmltools::p(summarywidget(sdf, statistic='mean', column='Value1'), style="display:none;"))
我正在尝试使用 R 显示传单地图（我不能使用 Shiny 包）。我使用 'DT'、'crosstalk' 和 'leaflet' 包来计算地图中 selected 数据的列的平均值。在地图中，它 select 只有矩形的点。是否可以通过套索 select？
#R code
library(dplyr)
library(leaflet)
library(DT)
library(crosstalk)
data_2 <- data.frame(ID=c(1:8),
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12,43,54,34,23,77,44,22),
Value2 = c(6,5,2,7,5,6,4,3),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0))
data_2<-data_2 %>%
mutate(
lab_DB = case_when(
Name1 == unique(data_2$Name1)[1] ~ "blue",
Name1 == unique(data_2$Name1)[2] ~ "green",
Name1 == unique(data_2$Name1)[3] ~ "red"
)
)
sdf <- SharedData$new(data_2, ~data_2$ID)
DT1<-datatable(
sdf, filter = 'top',
extensions = c('Select', 'Buttons'), selection = 'none', options = list(select = list(style = 'os', items = 'row'),dom = 'Bfrtip',autoWidth = TRUE,buttons = list('copy' ,
list(extend = 'collection', buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download')
,list(extend = 'collection', text = 'Mean',
action = DT::JS("function ( e, dt, node, config ) {
let columnData = dt.column(4,{search:'applied'}).data().toArray();
var amean= Math.round(columnData.reduce((sum, item) => sum+=item)/columnData.length);
alert('mean Value1: ' +amean);
}"))
,list(extend='collection',buttons=c('selectAll', 'selectNone', 'selectRows', 'selectColumns', 'selectCells'),text='sel')
)))
ltlf5<- leaflet(sdf) %>%
#addProviderTiles(providers$CartoDB.Positron) %>%
addTiles() %>%
addCircleMarkers(
lng = ~Lat,
lat = ~Lon,
group = ~Name1,popup = ~paste(Name1, ' <br/> ',
Name2,' <br/> ' ),
color =~lab_DB ,
radius = 3
) %>%
addLayersControl(
overlayGroups = c('A','B','C')
,options = layersControlOptions(collapsed = FALSE)
) %>%
addLegend(
position = 'bottomleft',
labels = c('Group A','Group B','Group C'),
colors = c("blue","red", "green"),
title = "Group color"
)
bscols(ltlf5 ,DT1)
我找到了 leaflet-lasso(Lasso selection plugin (Demo),Jan Zak Jan Zak ) 但我不知道如何使用它？
leaflet-lasso 是一个 JS 插件。我也找到了Using arbitrary Leaflet JS plugins with Leaflet for R但是还是不能解决问题
我们可以使用 'plotly' 包而不是 'leaflet'。这不需要闪亮太多。您有多项选择和套索选择地图上的点。要重置所选点，请双击地图。
library(dplyr)
library(plotly)
library(DT)
library(crosstalk)
data_2 <- data.frame(ID=c(1:8),
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12,43,54,34,23,77,44,22),
Value2 = c(6,5,2,7,5,6,4,3),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0))
data_2<-data_2 %>%
mutate(
lab_DB = case_when(
Name1 == unique(data_2$Name1)[1] ~ "blue",
Name1 == unique(data_2$Name1)[2] ~ "green",
Name1 == unique(data_2$Name1)[3] ~ "red"
)
)
sdf <- SharedData$new(data_2, ~data_2$ID)
DT1<-datatable(
sdf, filter = 'top',
extensions = c('Select', 'Buttons'), selection = 'none', options = list(select = list(style = 'os', items = 'row'),dom = 'Bfrtip',autoWidth = TRUE,buttons = list('copy' ,
list(extend = 'collection', buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download')
,list(extend = 'collection', text = 'Mean',
action = DT::JS("function ( e, dt, node, config ) {
let columnData = dt.column(4,{search:'applied'}).data().toArray();
var amean= Math.round(columnData.reduce((sum, item) => sum+=item)/columnData.length);
alert('mean Value1: ' +amean);
}"))
,list(extend='collection',buttons=c('selectAll', 'selectNone', 'selectRows', 'selectColumns', 'selectCells'),text='sel')
)))
fig <- sdf %>%
plot_ly(height=900,
lat = ~Lat,
lon = ~Lon,
marker = list(color = ~lab_DB),
type = 'scattermapbox'
)
fig <- fig %>%
layout(
mapbox = list(
style = 'open-street-map',
zoom =2.5,
center = list(lon = -2, lat = 51)))
fig<-fig %>%
highlight("plotly_selected", dynamic = F,color = NULL)
options(persistent = TRUE)
bscols(widths = c(6, 4), fig, DT1)
这也是我非常喜欢的相声功能。不幸的是，我认为目前无法完成。也许您可以向串扰 GitHub 页面添加功能请求。
目前，我尝试了一个非常令人作呕的解决方法，它可能适合您的需要。它基本上使用以下 links 并试图让它们一起工作：
- https://rstudio.github.io/crosstalk/authoring.html
- https://github.com/zakjan/leaflet-lasso/blob/master/docs/index.html
这些是 crosstalk 和 lasso-leaflet 的文档页面。可以在下面找到以下解决方案的演示（单击套索按钮绘制套索，单击取消按钮清除当前选择）：
它并没有完全按照串扰的方式工作，但它可能工作得很好。也许其他人可以提出更好的解决方案。以下代码生成了上面的 link，但对于您的代码：
library(leaflet)
library(crosstalk)
library(DT)
library(dplyr)
library(htmltools)
library(summarywidget)
data_2 <- data.frame(ID=c(1:8),
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12,43,54,34,23,77,44,22),
Value2 = c(6,5,2,7,5,6,4,3),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0))
data_2<-data_2 %>%
mutate(
lab_DB = case_when(
Name1 == unique(data_2$Name1)[1] ~ "blue",
Name1 == unique(data_2$Name1)[2] ~ "green",
Name1 == unique(data_2$Name1)[3] ~ "red"
)
)
sdf <- SharedData$new(data_2, key=~ID, group="SharedDataqwertyui")
lmap <- leaflet() %>%
addTiles() %>%
addMarkers(data=sdf, group="test", layerId = ~ID) %>%
htmlwidgets::prependContent(tags$script(src="https://unpkg.com/leaflet-lasso@2.2.4/dist/leaflet-lasso.umd.min.js")) %>%
htmlwidgets::onRender("
function(el, x) {
var sheet = window.document.styleSheets[0];
sheet.insertRule('.selectedMarker { filter: hue-rotate(135deg); }', sheet.cssRules.length);
var map = this;
const lassoControl = L.control.lasso(options={'position':'topleft'}).addTo(map);
function resetSelectedState() {
map.eachLayer(layer => {
if (layer instanceof L.Marker) {
layer.setIcon(new L.Icon.Default());
} else if (layer instanceof L.Path) {
layer.setStyle({ color: '#3388ff' });
}
});
}
function setSelectedLayers(layers) {
resetSelectedState();
let ids = [];
layers.forEach(layer => {
if (layer instanceof L.Marker) {
layer.setIcon(new L.Icon.Default({ className: 'selected selectedMarker'}));
} else if (layer instanceof L.Path) {
layer.setStyle({ color: '#ff4620' });
}
ids.push(layer.options.layerId);
});
ct_filter.set(ids);
}
var ct_filter = new crosstalk.FilterHandle('SharedDataqwertyui');
ct_filter.setGroup('SharedDataqwertyui');
var ct_sel = new crosstalk.SelectionHandle('SharedDataqwertyui');
ct_sel.setGroup('SharedDataqwertyui');
map.on('mousedown', () => {
ct_filter.clear();
ct_sel.clear();
resetSelectedState();
});
map.on('lasso.finished', event => {
setSelectedLayers(event.layers);
});
lassoControl.setOptions({ intersect: true});
var clearSel = function(){
ct_filter.clear();
ct_sel.clear();
resetSelectedState();
}
document.getElementById('clearbutton').onclick = clearSel;
}") %>%
addEasyButton(
easyButton(
icon = "fa-ban",
title = "Clear Selection",
id="clearbutton",
onClick = JS("function(btn, map){
return
}")
)
)
dtable <- datatable(sdf , width = "100%",editable=TRUE, caption=tags$caption("Mean of Value1: ",summarywidget(sdf, statistic='mean', column='Value1')))
bscols( widths=c(6,6,0), lmap, dtable, htmltools::p(summarywidget(sdf, statistic='mean', column='Value1'), style="display:none;"))