How to turn off the double-click/zoom behaviour of a leaflet map?

40 Views Asked by At

I am building a shiny app that contains a leaflet map object and the following functionality. Basically, I want to single-click on the map, grab the coordinates of the clicked spot, use sf to filter my data using these coordinates, and then display the filtered data as table in another widget. Here is my issue now:

  • When I click once on the map, only the tooltip is shown.
  • When I double-click, my functionality works but the maps zooms in
  • Alternatively, I can click once (the tooltip comes up) and then click the second time to show my table.

Is there a way I can prevent this? (i.e. not show the tooltip when I single-click, or prevent the map from zooming in when I double-click)

Here is a reproducible example of my app: Input files are found in this Google Drive folder

# install required packages in they are not already installed
if(!"remotes" %in% installed.packages()){
  install.packages("remotes")
}
# list my required packages
required_pkgs = c("magrittr", "dplyr", "shiny", "bslib", "leaflet", "sf", "tmap", "viridis")

# Get the missing required packages and install them
missing_pkgs <- setdiff(required_pkgs, installed.packages()[, "Package"])
if(length(missing_pkgs) != 0){
  remotes::install_cran(missing_pkgs)
}

# load the libraries of my required packages
lapply(required_pkgs, require, character.only = T)
#> Loading required package: magrittr
#> Loading required package: dplyr
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
#> Loading required package: shiny
#> Loading required package: bslib
#> 
#> Attaching package: 'bslib'
#> The following object is masked from 'package:utils':
#> 
#>     page
#> Loading required package: leaflet
#> Loading required package: sf
#> Linking to GEOS 3.11.2, GDAL 3.7.2, PROJ 9.3.0; sf_use_s2() is TRUE
#> Loading required package: tmap
#> Breaking News: tmap 3.x is retiring. Please test v4, e.g. with
#> remotes::install_github('r-tmap/tmap')
#> Loading required package: viridis
#> Loading required package: viridisLite
#> [[1]]
#> [1] TRUE
#> 
#> [[2]]
#> [1] TRUE
#> 
#> [[3]]
#> [1] TRUE
#> 
#> [[4]]
#> [1] TRUE
#> 
#> [[5]]
#> [1] TRUE
#> 
#> [[6]]
#> [1] TRUE
#> 
#> [[7]]
#> [1] TRUE
#> 
#> [[8]]
#> [1] TRUE

# Load data
district <- readRDS("district.RDS")
sectors <- readRDS("sectors.RDS")
locations <- readRDS("locations.RDS")

# Create the map with shiny
#=========================
ui <- fluidPage(
  titlePanel("My test map title"),
  fluidRow(
      column(4,
            card(
              id = "detailsCard",
              style = "height: 60vh;",
              full_screen = FALSE,
              card_header("Details at click point"),
              card_body(
                tableOutput("details")
                )
            )
        ),
      column(8,
      card(
        id = "mapCard",
        style = "height: 100vh;",
        full_screen = TRUE,
        card_header("Map"),
        card_body(
          leafletOutput("map")
        )
      )
   )
  )
)

server <- function(input, output, session) {
  output$map <- renderLeaflet({
    # create the tmap object
    tmap_object <- tm_shape(sectors) +
      tm_borders() +
      tm_fill(col = "number_of_clients",
              title = "number of clients",
              style = "jenks", 
              palette = cividis(6),
              id = "sector", # to specify which column to use for tooltips
              alpha = .6) + 
      tm_view(bbox = st_bbox(district))  # Set the initial extent to fit the AoI layer
    
    # convert the tmap object to a leaflet map 
    tmap_leaflet(tmap_object) 
  })
  
  
  # Map click logic
  observe({
    # clear previous click
    leaflet::leafletProxy("map") |>
      leaflet::clearMarkers()
    
    # get new click
    click <- input$map_click
    
    # add click to map
    leaflet::leafletProxy("map") |>
      leaflet::addMarkers(lng = click$lng, lat = click$lat)
  }, priority = 100) |>
    shiny::bindEvent(input$map_click)
  
  # pt
  pt <- shiny::reactive({
    if (!is.null(input$map_click$lat)) {
      pt <- sf::st_point(
        c(
          input$map_click$lng,
          input$map_click$lat
        )
      ) |>
        sf::st_sfc(crs = 4326) |>
        sf::st_as_sf() |>
        sf::st_transform(st_crs(district))
      
      return(pt)
    } else {
      NULL
    }
  })
  
  # intersects
  intersects <- shiny::reactive({
    if (!is.null(pt())) {
      sectors %>% st_filter(pt(), .predicate = st_intersects) 
    } else {
      NULL
    }
  })
  
  # table
  output$details <- shiny::renderTable({
    if (is.null(intersects())) {
      return(NULL)
    }
    if (nrow(intersects()) > 0) {
      locations %>% st_filter(intersects(), .predicate = st_intersects) %>% st_drop_geometry()
    } else {
      NULL
    }
  })
  
}

shinyApp(ui, server)
Shiny applications not supported in static R Markdown documents

Created on 2024-02-21 with reprex v2.1.0

Session info
sessionInfo()
#> R version 4.3.2 (2023-10-31 ucrt)
#> Platform: x86_64-w64-mingw32/x64 (64-bit)
#> Running under: Windows 11 x64 (build 22631)
#> 
#> Matrix products: default
#> 
#> 
#> locale:
#> [1] LC_COLLATE=English_Rwanda.utf8  LC_CTYPE=English_Rwanda.utf8   
#> [3] LC_MONETARY=English_Rwanda.utf8 LC_NUMERIC=C                   
#> [5] LC_TIME=English_Rwanda.utf8    
#> 
#> time zone: Africa/Kigali
#> tzcode source: internal
#> 
#> attached base packages:
#> [1] stats     graphics  grDevices utils     datasets  methods   base     
#> 
#> other attached packages:
#> [1] viridis_0.6.5     viridisLite_0.4.2 tmap_3.3-4        sf_1.0-15        
#> [5] leaflet_2.2.1     bslib_0.6.1       shiny_1.8.0       dplyr_1.1.4      
#> [9] magrittr_2.0.3   
#> 
#> loaded via a namespace (and not attached):
#>  [1] gtable_0.3.4            ggplot2_3.4.4           xfun_0.42              
#>  [4] raster_3.6-26           htmlwidgets_1.6.4       lattice_0.21-9         
#>  [7] leaflet.providers_2.0.0 vctrs_0.6.5             tools_4.3.2            
#> [10] crosstalk_1.2.1         generics_0.1.3          parallel_4.3.2         
#> [13] tibble_3.2.1            proxy_0.4-27            fansi_1.0.6            
#> [16] pkgconfig_2.0.3         KernSmooth_2.23-22      RColorBrewer_1.1-3     
#> [19] lifecycle_1.0.4         compiler_4.3.2          munsell_0.5.0          
#> [22] terra_1.7-71            codetools_0.2-19        leafsync_0.1.0         
#> [25] httpuv_1.6.14           stars_0.6-4             htmltools_0.5.7        
#> [28] class_7.3-22            sass_0.4.8              yaml_2.3.8             
#> [31] later_1.3.2             pillar_1.9.0            jquerylib_0.1.4        
#> [34] ellipsis_0.3.2          classInt_0.4-10         cachem_1.0.8           
#> [37] lwgeom_0.2-13           abind_1.4-5             mime_0.12              
#> [40] tidyselect_1.2.0        digest_0.6.34           fastmap_1.1.1          
#> [43] grid_4.3.2              colorspace_2.1-0        cli_3.6.2              
#> [46] base64enc_0.1-3         dichromat_2.0-0.1       XML_3.99-0.16.1        
#> [49] utf8_1.2.4              leafem_0.2.3            e1071_1.7-14           
#> [52] withr_3.0.0             scales_1.3.0            promises_1.2.1         
#> [55] sp_2.1-3                rmarkdown_2.25          gridExtra_2.3          
#> [58] png_0.1-8               memoise_2.0.1           evaluate_0.23          
#> [61] knitr_1.45              tmaptools_3.1-1         rlang_1.1.3            
#> [64] Rcpp_1.0.12             xtable_1.8-4            glue_1.7.0             
#> [67] DBI_1.2.1               reprex_2.1.0            rstudioapi_0.15.0      
#> [70] jsonlite_1.8.8          R6_2.5.1                fs_1.6.3               
#> [73] units_0.8-5
0

There are 0 best solutions below