Skip to content

Instantly share code, notes, and snippets.

@mrecos
Last active October 1, 2020 19:14
Show Gist options
  • Save mrecos/50545fbe2a77c50ca9fe836d552b1aa3 to your computer and use it in GitHub Desktop.
Save mrecos/50545fbe2a77c50ca9fe836d552b1aa3 to your computer and use it in GitHub Desktop.
A (mostly) minimal example of using sidebar drop downs to 1) filter counties within states, and 2) `flyTo` the centroid of the selected state in shiny + leaflet
library(shiny)
library(shinydashboard)
# devtools::install_github("nik01010/dashboardthemes")
library(dashboardthemes)
library(tidyverse)
library(sf)
library(leaflet)
library(usmap) # us counties and states as table
library(leaflet)
# Zoom to coordinates for each state centroid
state_coords <- data.frame(abbr = datasets::state.abb,
x = datasets::state.center["x"],
y = datasets::state.center["y"],
area = datasets::state.area,
stringsAsFactors = FALSE) %>%
rbind(., data.frame(abbr = "DC", # add D.C.
x = -77.0369,
y = 38.9072,
area = 68))
county_state <- countypop %>%
left_join(select(statepop, state = full, abbr), by = "abbr")
state_pop_coords <- statepop %>%
left_join(state_coords, by = "abbr") %>%
rename(state = full) %>%
st_as_sf(coords = c("x","y"), crs = 4326)
state_pop_coords <- cbind(state_pop_coords, st_coordinates(state_pop_coords))
header <- dashboardHeader(
title = 'Leaflet flyTo',
# task list for status of data processing
dropdownMenuOutput('task_menu'))
sidebar <- dashboardSidebar(
sidebarMenu(
htmlOutput("state_selector"),#add selectinput boxs
htmlOutput("county_selector")# from objects created in server
)
)
body <- dashboardBody(
shinyDashboardThemes(
# https://github.com/nik01010/dashboardthemes
theme = "grey_dark"
),
# the main leaflet map
box(leafletOutput('map'), width = 12)
)
# Shiny UI
ui <- dashboardPage(
header,
sidebar,
body
)
server <- function(input, output, session) {
output$state_selector = renderUI({
selectInput(inputId = "state", #name of input
label = "State:", #label displayed in ui
choices = c("Choose one" = "", usmap::statepop$full),
)
})
output$county_selector = renderUI({
data_available = county_state[county_state$state == input$state, "county"]
#creates a reactive list of available counties based on the State selection made
selectInput(inputId = "county", #name of input
label = "County:", #label displayed in ui
choices = unique(data_available), #calls list of available counties
selected = unique(data_available)[1])
})
output$map <- renderLeaflet({
leaflet() %>%
addTiles(urlTemplate = "//{s}.tiles.mapbox.com/v3/jcheng.map-5ebohr46/{z}/{x}/{y}.png",
attribution = 'Maps by <a href="http://www.mapbox.com/">Mapbox</a>'
) %>%
setView(lng = -98, lat = 39, zoom = 4)
})
center <- reactive({
subset(state_pop_coords, state == input$state)
# or whatever operation is needed to transform the selection
# to an object that contains lat and long
})
mymap_proxy <- leafletProxy("map")
observe({
#https://stackoverflow.com/questions/53090523/leaflet-map-zooms-based-on-a-dynamic-selectinput
fdata <- center()
mymap_proxy %>%
flyTo(lng = fdata$X, lat = fdata$Y, zoom = 8)
})
}
shinyApp(ui, server)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment