Click on a subregion and autoscale zoom to fit the subregion

Question

I'm developing an R Shiny app and want to have an interactive map, where the user clicks on a region (or subregion), and the map automatically zooms and scales the view to fit the selected region. This is essentially the same question as posted here, except in that solution, the solution involved manually-provided 'Zoom' levels for each state; I'm looking for a way to automate this (I have hundreds of subregions that vary dramatically in size).

So far, I have something similar to what that previous post has done, here I've manually set a zoom level to 7 based on where the mouse clicks. The problems with this approach are: 1) the zoom is the same for all clicks, 2) the view changes based on what part of the map is selected (ideally, I want the same view of each region/polygon regardless of where inside that polygon is clicked), and 3) once I click, the zoom seems fixed - I can't pan in or out of the map.

Current code:

library(shiny)
library(bcmaps)
library(sf)
library(leaflet)
library(dplyr)

# setup one map for use in the app - taken from 'bcmaps' package
ha <- health_ha() %>% 
  rename_with(tolower, everything()) %>% 
  dplyr::select(ha_code = hlth_authority_code, 
         ha_name = hlth_authority_name, 
         geometry) %>% 
  st_transform(crs = 4326) %>% 
  mutate(color = c("#3891A7",
                   "#C3860D",
                   "#C42E2E",
                   "#67A63C",
                   "#914FAB"))


# Shiny app:
ui <- page_fluid(
  layout_columns(leafletOutput("interactive_map"),
                 plotOutput("map")
  ))



server <- function(input, output, session) {

  output$interactive_map <- renderLeaflet({
    leaflet() %>% 
      addProviderTiles("Esri.WorldImagery", group = "Satellite") %>% 
      addPolygons(data = ha,
                  group = "Health Authority",
                  stroke = TRUE,
                  weight = 1,
                  color = ~color,
                  opacity = 0.5,
                  fillColor = ~color,
                  fillOpacity = 0.3,
                  # add highlight on hover:
                  highlight = highlightOptions(weight = 4, color = "darkblue",
                                               fillOpacity = 0.7,
                                               bringToFront = TRUE)) 
  })
  
  # add in zoom-on-click functionality:
  observe(
    {click <- input$interactive_map_shape_click

    # is the  _bounds function useful? 
    # the 'sf' package also has a st_bbox() function to return bounds of a polygon
    # lims <- input$interactive_map_bounds

    if(is.null(click))
      return()
    else
      leafletProxy("interactive_map") %>% 
      setView(lng = click$lng, lat = click$lat, zoom = 7)

    # is 'fitBounds' better to use? not sure if this is the right syntax:
    # fitBounds(lng1 = lims[[1]], lat1 = lims[[2]], 
    #           lng2 = lims[[3]], lat2 = lims[[4]])
    }
  )
  
  
}

# Run the application 
shinyApp(ui = ui, server = server)```

Answer 1

You were on the right track with st_bbox and fitBounds. The thing you were missing was adding a layerID in addPolygons to allow you to subset the data when you click.

library(shiny)
library(leaflet)
library(sf)

ui <- fluidPage(
  leafletOutput("map")
)

server <- function(input, output, session) {

  url <- glue::glue("https://www.geoboundaries.org/api/current/gbOpen/USA/ADM1/")
  req <- httr2::request(url) |> httr2::req_perform()
  cont <- httr2::resp_body_json(req)
  shape <- sf::st_read(cont$gjDownloadURL, quiet = TRUE)

  output$map <- renderLeaflet({
    leaflet() %>%
      addProviderTiles("Esri.WorldImagery", group = "Satellite") %>%
      addPolygons(data = shape,
                  layerId = shape$shapeName,
                  stroke = TRUE,
                  weight = 1,
                  color = "green",
                  opacity = 0.5,
                  fillColor = "blue",
                  fillOpacity = 0.3,
                  # add highlight on hover:
                  highlight = highlightOptions(weight = 4, color = "darkblue",
                                               fillOpacity = 0.7,
                                               bringToFront = TRUE))

  })

  observeEvent(input$map_shape_click, {
    selected_polygon <- shape[shape$shapeName == input$map_shape_click$id,]

    bounds <- st_bbox(selected_polygon)

    leafletProxy("map") %>%
      fitBounds(lng1 = bounds[[1]], lng2 = bounds[[3]], lat1 = bounds[[2]], lat2 = bounds[[4]])
  })
}

shinyApp(ui, server)