javascriptrshinyr-leaflet

How to add popupmovable plugin to a leaflet map?

I'm using R shiny to build a web application for users to plot past and present data. Many of these data points are close together, so when the user opens the popups, they overlap. The user needs all popups they want to be open at once to view the data from the station, and shift them so that they can view them at one time, save the map, and export it into a report.

I've tried adding in this java plugin, but to no success. I'm not very experienced with creating and adding plugins, have only done it a couple times for minor things, so I know that I am missing something, but cannot seem to figure it out. Below is some R script showing a small example of how I'm trying to use it.

library(leaflet)
library(leaflet.esri)
library(htmltools)
library(htmlwidgets)
library(shiny)
library(shinyjs)

data <-data.frame(lat=c(34.85,34.89,34.92,34.89),
                  lon=c(-72.89,-72.96,-72.95,-72.85),
                  station=c('1A','2A','3A','4A'),year=c(2017,2018,2019,2020))

addPopupMove = htmltools::htmlDependency("leaflet.PopupMovable","1.0.0",
                                         src = c(href = 'https://raw.githubusercontent.com/wrwrh/leaflet-popupmovable/refs/heads/main/leaflet.PopupMovable.js'),
                                         script = 'leaflet.PopupMovable.js')

registerPlugin <- function(map, plugin) {
  map$dependencies <- c(map$dependencies, list(plugin))
  map}

ui =  fluidPage(
  tags$head(
    includeScript("https://raw.githubusercontent.com/wrwrh/leaflet-popupmovable/refs/heads/main/leaflet.PopupMovable.js"),
    useShinyjs()),
  mainPanel(leafletOutput("map",width = 900,height = 600)))


server = shinyServer(function(input, output, session){

  map = function(){leaflet(options = leafletOptions(worldCopyJump = FALSE, preferCanvas = TRUE)) %>%
  setView(lng = 0,lat = 0,zoom = 2)%>%
  addEsriBasemapLayer(esriBasemapLayers$Oceans,
                      autoLabels = TRUE, 
                      options = providerTileOptions(noWrap = FALSE,updateWhenIdle = TRUE),
                      group = 'Oceans') %>% 
      addMarkers(lat = data$lat,lng = data$lon,
                 popup = paste(data$station,"<br>",
                               "Lat: ",data$lat,"<br>",
                               "Lon: ",data$lon,"<br>",
                               "Est.: ",data$year),
                 popupOptions = popupOptions(autoClose = FALSE, closeOnClick = FALSE))%>% 
      registerPlugin(addPopupMove)%>%
      onRender("function (el,x){
        var popmove = L.Map.PopupMovable(options = { popupMovable: true
             });
              popmove.addTo(this);
               ")
    }
  
  react_map = reactiveVal(map())
  output$map = renderLeaflet({react_map() })

})


shinyApp(ui,server)

The goal is to allow the user to click and drag the popups out of the way, but still have the lead lines to the marker.

Solution

  • Your approach using includeScript() is suitable. Additionally one needs to set the popupMovable option to true to enable the plugin. This can be done without Javascript: If l is the leaflet() object, you can add

    if (is.null(l$x$options)) l$x$options <- list()
l$x$options$popupMovable <- TRUE

    enter image description here

    library(leaflet)
library(leaflet.esri)
library(shiny)

data <- data.frame(
  lat = c(34.85, 34.89, 34.92, 34.89),
  lon = c(-72.89, -72.96, -72.95, -72.85),
  station = c('1A', '2A', '3A', '4A'),
  year = c(2017, 2018, 2019, 2020)
)

ui <- fluidPage(
  tags$head(
    includeScript(
      "https://raw.githubusercontent.com/wrwrh/leaflet-popupmovable/refs/heads/main/leaflet.PopupMovable.js")
    ),
  mainPanel(leafletOutput("map",width = 900,height = 600))
)

server <- function(input, output, session){
  map <- function(){
    l <- leaflet(
      options = leafletOptions(
        worldCopyJump = FALSE, 
        preferCanvas = TRUE)
      ) |> 
      setView(lng = 0,lat = 0,zoom = 2) |> 
      addEsriBasemapLayer(esriBasemapLayers$Oceans,
                          autoLabels = TRUE,
                          options = providerTileOptions(
                            noWrap = FALSE,
                            updateWhenIdle = TRUE
                          ),
                          group = 'Oceans') |> 
      addMarkers(lat = data$lat,lng = data$lon,
                 popup = paste(data$station,"<br>",
                               "Lat: ",data$lat,"<br>",
                               "Lon: ",data$lon,"<br>",
                               "Est.: ",data$year),
                 popupOptions = popupOptions(
                   autoClose = FALSE, 
                   closeOnClick = FALSE)
                 )
    
    if (is.null(l$x$options)) l$x$options <- list()
    l$x$options$popupMovable <- TRUE
    l
  }
  react_map = reactiveVal(map())
  output$map = renderLeaflet({react_map()})
}

shinyApp(ui, server)