rshinyr-leaflet

Lasso-ability on leaflet heatmap


I have a shiny app which displayes a leaflet heatmap. I would like to know if is possible to use a lasso like in this video to select certain data points.

library(shiny)
library(DT)
library(leaflet)
library(leaflet.extras)
# ui object

ui <- fluidPage(
    titlePanel(p("Spatial app", style = "color:#3474A7")),
    sidebarLayout(
        sidebarPanel(
            
        ),
        
        mainPanel(
            leafletOutput("map"),
            DTOutput("table1") 

        )
    )
)

# server()
server <- function(input, output, session) {
    output$map<-renderLeaflet({
        leaflet(quakes) %>%
            addProviderTiles(providers$CartoDB.DarkMatter) %>%
            setView( 178, -20, 5 ) %>%
            addHeatmap(
                lng = ~long, lat = ~lat, intensity = ~mag,
                blur = 20, max = 0.05, radius = 15
            ) %>% 
            addCircleMarkers(lng = quakes$long, lat = quakes$lat, 
                             fillOpacity = 0, weight = 0,
                             popup = paste("Depth:", quakes$depth, "<br>",
                                           "Stations:", quakes$stations),
                             labelOptions = labelOptions(noHide = TRUE)) 
    })
    
    
}

# shinyApp()
shinyApp(ui = ui, server = server)

Solution

  • Below is an adaptation of this answer for your heat map which provides a lasso functionality for selecting points similar to the one in the linked video.

    enter image description here

    library(shiny)
    library(DT)
    library(leaflet)
    library(leaflet.extras)
    library(htmltools)
    library(crosstalk)
    library(dplyr)
    
    lassoPlugin <- htmlDependency(
      "Leaflet.lasso",
      "2.2.13",
      src = c(href = "https://unpkg.com/leaflet-lasso@2.2.13/dist/"),
      script = "leaflet-lasso.umd.min.js"
    )
    
    registerPlugin <- function(map, plugin) {
      map$dependencies <- c(map$dependencies, list(plugin))
      map
    }
    
    sdf <- SharedData$new(quakes |> 
                            mutate(ID = row_number()), 
                          key =  ~ ID, 
                          group = "SharedData")
    
    # ui object
    ui <- fluidPage(
      titlePanel(p("Spatial app", style = "color:#3474A7")),
      sidebarLayout(
        sidebarPanel(),
        mainPanel(
          leafletOutput("map"),
          DTOutput("table1") 
        )
      )
    )
    
    server <- function(input, output, session) {
      output$map<-renderLeaflet({
        leaflet(quakes) %>%
          addProviderTiles(providers$CartoDB.DarkMatter) %>%
          setView( 178, -20, 5 ) %>%
          addHeatmap(
            lng = ~long, lat = ~lat, intensity = ~mag,
            blur = 20, max = 0.05, radius = 15
          ) %>% 
          addCircleMarkers(data = sdf,
                           radius = 3,
                           layerId = ~ ID,
                           fillOpacity = 10, weight = 5,
                           popup = paste("Depth:", quakes$depth, "<br>",
                                         "Stations:", quakes$stations),
                           labelOptions = labelOptions(noHide = TRUE)) %>%
          registerPlugin(lassoPlugin) %>%
            htmlwidgets::onRender("
              function(el, x) {
    
                setTimeout(() => {
                  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('SharedData');
                  ct_filter.setGroup('SharedData');
    
                  var ct_sel = new crosstalk.SelectionHandle('SharedData');
                  ct_sel.setGroup('SharedData');
    
                  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;
    
                }, '50');
              }"
          ) %>%
            addEasyButton(
              easyButton(
                icon = "fa-ban",
                title = "Clear Selection",
                id = "clearbutton",
                onClick = JS("function(btn, map){
                  return
                }")
              )
            )
      })
    }
    
    shinyApp(ui = ui, server = server)