Search code examples
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)