Search code examples
rshinymouseeventr-leaflet

Click on Shape and Zoom to Bounds (using maps package)


For reasons, I am limited to using the "maps" package to generate maps for a leaflet-centered R Shiny app (i.e. I cannot use shape files, rasters, etc. It must be a map object); however, i am running into a wall with some functionality I would like to add.

I'm aiming to allow the user to click on a state in the US and have the app zoom to the bounds of the state. I have found a not-really solution, but what I really need is to use fitBounds() or setMaxBounds(); however, I have no idea how to retrieve the bounds of the state that is selected from the mouse click event.

As of right now, I've found a "pretty good" zoom level for many states using setView(). But, for large states and small states, this just does not work.

Here's the code:

ui.R

 library(shiny)
 library(leaflet)

 shinyUI(fluidPage(
      fluidRow(
           tags$style(type = "text/css", "#livemap {height: calc(100vh - 80px) !important;}"),
           leafletOutput("livemap")
      )
 ))

server.R

 library(shiny)
 library(leaflet)
 library(maps)

 shinyServer(function(input, output){
      output$livemap <- renderLeaflet({
          mapStates <- map("state", fill = TRUE, plot = FALSE)

          leaflet(mapStates) %>%
               addTiles() %>%
               addPolygons(color = "#444444",
                           weight = 1,
                           smoothFactor = 0.5,
                           opacity = 1.0,
                           fillOpacity = 0.5,
                           fillColor = terrain.colors(50, alpha = 1),
                           highlightOptions = highlightOptions(color = "black", weight = 2, bringToFront = TRUE))
      })
      observe({
           click <- input$livemap_shape_click
           proxy <- leafletProxy("livemap")
           if(is.null(click))
                return()
           proxy %>% setView(lng = click$lng, lat = click$lat, zoom = 7)
      })
 })

Solution

  • With a huge thanks to @SymbolixAU and @JohnFriel, I was able to achieve the functionality that I was looking for. The key was setting the "layer" ID. The code below allows me to zoom to the appropriate level for each state. Additionally, when the user clicks outside of the shape area, the map is reverted to the default "USA" map and zoom level.

    ui.R

     library(shiny)
     library(leaflet)
    
     shinyUI(fluidPage(
          fluidRow(
               tags$style(type = "text/css", "#livemap {height: calc(100vh - 80px) !important;}),
               leafletOutput("livemap")
          )
      ))  
    

    server.R

      library(shiny)
      library(leaflet)
      library(maps)
    
      shinyServer(function(input, output){
           output$livemap <- renderLeaflet({
                mapStates <- map("state", fill = TRUE, plot = FALSE)
                mapStates$zoom <- c(7.3, 7.1, 7.5, 6.2, 7.2, 9.2, 4.0, 7.0,
                                    7.3, 6.5, 7.0, 7.4, 7.5, 7.5, 7.8, 7.4,
                                    7.1, 8.3, 8.6, 8.6, 8.6, 7.0, 7.0, 6.7,
                                    7.3, 7.2, 7.0, 7.5, 6.6, 7.8, 8.0, 7.0,
                                    7.2, 7.2, 7.2, 7.2, 7.6, 7.6, 7.6, 7.4,
                                    7.6, 7.6, 7.2, 7.6, 9.4, 7.8, 7.4, 7.6,
                                    6.2, 7.0, 8.0, 7.6, 7.6, 7.6, 7.3, 7.3,
                                    7.3, 7.3, 7.3, 7.6, 7.2, 7.2)
               leaflet(mapStates) %>%
                    addTiles() %>%
                    addPolygons(color = "#444444",
                                weight = 1,
                                layer = ~mapStates$names,
                                smoothFactor = 0.5,
                                opacity = 1.0,
                                fillOpacity = 0.5,
                                fillColor = terrain.colors(50, alpha = 1),
                                highlightOptions = highlightOptions(color = "black",
                                                                    weight = 2,
                                                                    bringToFront = TRUE))
           })
           # Observe click on shapes (i.e., states)
           observe({
                click <- input$livemap_shape_click
                if(is.null(click))
                     return()
                idx <- which(mapStates$names == click$id)
                # Get zoom level for the state
                z <- mapStates$zoom[[idx]]
                # Get state name to render new map
                idx <- mapStates$names[[idx]]
                mapInd <- map("county", idx, fill = TRUE, plot = FALSE)
    
                leafletProxy("livemap") %>%
                     clearShapes() %>%
                     addPolygons(data = mapInd,
                                 color = "#444444",
                                 weight = 1,
                                 smoothFactor = 0.5,
                                 opacity = 1.0,
                                 fillOpacity = 0.5,
                                 fillColor = terrain.colors(10, alpha = 1)) %>%
                     setView(lng = ((mapInd$range[[1]] + mapInd$range[[2]])/2),
                             lat = ((mapInd$range[[3]] + mapInd$range[[4]])/2),
                             zoom = z)
           })
           # Observe click outside of shapes (i.e., reset the map to the "USA" original)
           observe({
                click <- input$livemap_click
                if(is.null(click))
                     return()
                leafletProxy("livemap") %>%
                     clearShapes() %>%
                     addPolygons(data = mapStates,
                                 color = "#444444",
                                 weight = 1,
                                 layer = ~mapStates$names,
                                 smoothFactor = 0.5,
                                 opacity = 1.0,
                                 fillOpacity = 0.5,
                                 fillColor = terrain.colors(50, alpha = 1),
                                 highlightOptions = highlightOptions(color = "black",
                                                                     weight = 2,
                                                                     bringToFront = TRUE)) %>%
                     setView(lng = ((mapStates$range[[1]] + mapStates$range[[2]])/2),
                             lat = ((mapStates$range[[3]] + mapStates$range[[4]])/2),
                             zoom = 4)
           })
    
      })