该应用程序目前托管在shinyapps上:
https://njed.shinyapps.io/race_seg_gap_map/
单击复选框时,点不会显示,地图也不会更新。
以下是闪亮的应用程序代码:
library(shiny)
library(leaflet)
library(dplyr)
library(leaflet.extras)
load('shiny_app_seg_gap.RData')
tags$head(tags$link(rel="shortcut icon", href="/www/noun_equals_133889.png"))
tags$style(type = "text/css", "html, body {width:100%;height:100%}")
ui <- shinyUI(navbarPage("NJ Residential Racial Segregation & Student-Teacher Gaps",
theme = "bootstrap.css",
tabPanel("Map",
div(class="outer",
leafletOutput("map", width = "100%", height = "100%"), #
absolutePanel(id = "controls", class = "panel panel-default",
style="opacity: 1",
fixed = TRUE,
draggable = TRUE, top = "10%", left = "auto", right = 20, bottom = "auto",
width = 330, height = "auto", cursor = "move",
br(),
htmlOutput("district_selector"), #add selectinput boxs
htmlOutput("school_selector"),
actionButton("clear", "Clear School Markers"),
checkboxInput("togglelatinx", tags$span("Latinx", style = "color: #11FF04;font-size: 15pt"), value = TRUE),
checkboxInput("togglewhite", tags$span("White", style = "color: #F40000;font-size: 15pt"), value = TRUE),
checkboxInput("toggleblack", tags$span("Black", style = "color: #0456FF;font-size: 15pt"), value = TRUE),
h4("1 Dot = 750 People"),
br(),
h4("Click on school markers for more info")
)
)
),
tabPanel("About",
fluidRow(
column(12,
wellPanel(
includeMarkdown("about.md"))
)
)
)
))
server <- shinyServer(function(input, output, session) {
# icon.ion <- makeAwesomeIcon(icon = 'apple',
# library='glyphicon')
# greenLeafIcon <- makeIcon(
# iconUrl = "http://leafletjs.com/examples/custom-icons/leaf-green.png",
# iconWidth = 38, iconHeight = 95,
# iconAnchorX = 22, iconAnchorY = 94,
# shadowUrl = "http://leafletjs.com/examples/custom-icons/leaf-shadow.png",
# shadowWidth = 50, shadowHeight = 64,
# shadowAnchorX = 4, shadowAnchorY = 62
# )
observeEvent(input$clear, {
proxy <- leafletProxy('map')
proxy %>%
clearGroup(group = schools$school_name)
})
output$district_selector = renderUI({ #creates District select box object called in ui
selectInput(inputId = "district", #name of input
label = "District:", #label displayed in ui
choices = unique.districts,
selected = "Newark City")
})
output$school_selector = renderUI({#creates County select box object called in ui
data_available = schools[schools$district_name == input$district, "school_name"]
#creates a reactive list of available counties based on the State selection made
selectInput(inputId = "school", #name of input
label = "School:", #label displayed in ui
choices = unique(data_available), #calls list of available counties
selected = "Ann Street School")
})
# weight.adjust <- reactive({
#
# # req(input$map_zoom)
#
# if(!is.null(input$map_zoom)) new_zoom <- input$map_zoom
#
# if (new_zoom < 7) {
# .1
# } else if (new_zoom >= 7 & new_zoom < 10){
# 1
# } else if (new_zoom >= 10){
# 3
# }
#
# })
selected.school <- reactive({
if (!is.null(input$school)){
schools[schools$school_name == input$school,]
}
})
output$map <- renderLeaflet({
leaflet(options = leafletOptions(preferCanvas = TRUE)) %>%
addMapPane(name = "underdots", zIndex = 410) %>%
addMapPane(name = "maplabels", zIndex = 420) %>% # higher zIndex rendered on topaddProviderTiles("CartoDB.PositronNoLabels", options = tileOptions(minZoom = 7, maxZoom = 13)) %>%
addProviderTiles("CartoDB.PositronNoLabels",
options = providerTileOptions(
updateWhenZooming = FALSE, # map won't update tiles until zoom is done
updateWhenIdle = TRUE ) # map won't load new tiles when panning
) %>%
addProviderTiles("CartoDB.PositronOnlyLabels",
options = leafletOptions(pane = "maplabels")) %>%
setView(schools[schools$school_name == "Ann Street School",]$lng + 0.02, schools[schools$school_name == "Ann Street School",]$lat, zoom = 13)
# addMiniMap(position = "bottomright", zoomLevelOffset = -5, tiles = "CartoDB")
})
observeEvent(input$school, {
proxy <- leafletProxy('map')
proxy %>%
# clearGroup(group = schools$school_name) %>%
addAwesomeMarkers(data = selected.school(),
icon = icon.ion,
lat = ~lat, lng = ~lng,
# icon=greenLeafIcon,
# weight= 15, fillOpacity = 1, stroke = FALSE,
group = selected.school()$school_name,
# color="black",#pal(td2$LifeExpectencyValue),
# labelOptions = labelOptions(noHide = T),
popup = paste0("<u>", selected.school()$school_name,"</u>", "<br>",
"Black Students: ", selected.school()$Percent_Black_Students,"%", "<br>",
"Black Teachers: ", selected.school()$Percent_Black_Teachers,"%", "<br>",
"Latinx Students: ", selected.school()$Percent_Latinx_Students,"%", "<br>",
"Latinx Teachers: ", selected.school()$Percent_Latinx_Teachers,"%", "<br>",
"White Students: ", selected.school()$Percent_White_Students,"%", "<br>",
"White Teachers: ", selected.school()$Percent_White_Teachers,"%"
)) %>%
setView(selected.school()$lng + 0.02, selected.school()$lat, zoom = 13)
})
observeEvent(input$togglewhite , { #| weight.adjust()
proxy <- leafletProxy('map') #Always clear the race first on the observed event
proxy %>% clearGroup(group = "White") #If checked
if (input$togglewhite){
race.dots.all <- filter(race.dots.all, group == "White") #Filter for the specific group
proxy %>% addCircles(group = race.dots.all$group, #Add the specific group's markers
race.dots.all$lng,
race.dots.all$lat,
weight=4.5,
fill = TRUE,
color = '#F40000',
fillOpacity = 0.5
)
}
})
#Repeat for the other groups
observeEvent(input$toggleblack, {
proxy <- leafletProxy('map')
proxy %>% clearGroup(group = "Black")
if (input$toggleblack){
race.dots.all <- filter(race.dots.all, group == "Black")
proxy %>% addCircles(group = race.dots.all$group,
race.dots.all$lng,
race.dots.all$lat,
weight=4.5,
fill = TRUE,
color = '#0456FF',
fillOpacity = 0.5
)
}
})
observeEvent(input$togglelatinx, {
proxy <- leafletProxy('map')
proxy %>% clearGroup(group = "Latinx")
if (input$togglelatinx){
race.dots.all <- filter(race.dots.all, group == "Latinx")
proxy %>% addCircles(group = race.dots.all$group,
race.dots.all$lng,
race.dots.all$lat,
weight=4.5,
fill = TRUE,
color = '#11FF04',
fillOpacity = 0.5
)
}
})
})
shinyApp(ui, server)
#
# library(profvis)
# app <-
# profvis({
#
# runApp(app)
# })
