I want to be able to click on a polygon to update the dropdown menu. This would update the map, which gets the selected polygon from the dropdown.
Right now, clicking the map doesn't work. The leaflet map is in a module, but the dropdown is outside of it. How would I do this? Thanks.
# libraries ---------------------------------------------------------------
library(shiny)
library(sf)
library(tidyverse)
library(leaflet)
# data --------------------------------------------------------------------
# data in the sf package
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>%
select(NAME, AREA, SID74) %>%
st_transform(4326)
# names for dropdown
nc_names <- sort(unique(nc$NAME))
# modules -----------------------------------------------------------------
map_ui <- function(id) {
ns <- NS(id)
tagList(
leafletOutput(ns("map"))
)
}
map_server <- function(id, dropdown){
moduleServer(id, function(input, output, session){
output$map <- renderLeaflet({
# initial map
leaflet() %>%
addProviderTiles("Stamen.TonerHybrid") %>%
# base layer
addPolygons(data = nc,
fillColor = "grey",
fillOpacity = 0.1,
weight = 1,
stroke = TRUE,
color = "black",
opacity = 1,
layerId = ~NAME) %>%
# initial selected layer
addPolygons(data = nc %>% filter(NAME == "Alamance"),
fillColor = "blue",
fillOpacity = 0.5,
weight = 1,
stroke = TRUE,
color = "black",
opacity = 1,
layerId = ~NAME)
})
# new polygon
new_poly <- reactive({nc %>%
filter(NAME == dropdown())})
# update polygon for new map
observe({
leafletProxy("map") %>%
clearShapes() %>%
# base layer
addPolygons(data = nc,
fillColor = "grey",
fillOpacity = 0.1,
weight = 1,
stroke = TRUE,
color = "black",
opacity = 1,
layerId = ~NAME) %>%
# highlighted
addPolygons(data = new_poly(),
weight = 3,
stroke = TRUE,
opacity = 1,
fillOpacity = 0,
layerId = ~NAME
)
})
# update dropdown based on clicked map (thus updating map)
observe({
event <- input$map_shape_click
updateSelectInput(session,
"name", # this is not in the module
selected = event$id)
})
})
}
# app ---------------------------------------------------------------------
# Define UI for application that draws a histogram
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("name",
label = "Name",
selected = nc_names[1],
choices = nc_names)
),
mainPanel(
map_ui("map")
)
)
)
server <- function(input, output) {
# map from server
map_server("map", dropdown = drop_val)
# reactive values
drop_val <- reactive(input$name)
}
shinyApp(ui, server)
