使用套索代替矩形在传单中选择统治

Question

我正在尝试使用 R 显示传单地图（我不能使用 Shiny 包）。我使用“DT”、“crosstalk”和“leaflet”包来计算地图中选定数据的列的平均值。在地图中，它仅通过矩形形状选择点。是否可以通过套索选择？

#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，但还是不能解决问题。

Answer 1

这是我在串音中也非常喜欢的一个功能。不幸的是，我认为目前无法完成。也许你可以在串扰 GitHub 页面上添加一个功能请求。

目前，我尝试了一种非常恶心的变通方法，它可能适合您的需求。它基本上是使用以下链接并试图让它们一起工作：

• https://rstudio.github.io/crosstalk/authoring.html
• https://github.com/zakjan/leaflet-lasso/blob/master/docs/index.html

这些是串扰和套索传单的文档页面。下面有一个解决方案的demo（点击套索按钮绘制套索，点击取消按钮清除当前选择）：

• https://rpubs.com/Jumble/crosstalk_leaflet_lasso_selection

它的工作方式与串扰不完全一样，但它可能工作得很好。也许其他人可以提出更好的解决方案。以下代码生成了上面的链接，但适用于您的代码：

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;"))

Answer 2

我们可以使用 '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)