如何根据R Shiny中传单地图的输入筛选数据表

Question

我正在使用shine制作一个面板，该面板将有一个传单地图和一个数据表。我希望能够点击地图上的多边形(即特定的县(，将该县存储为反应值，然后过滤数据表，只显示该县的结果。

如果没有单击多边形，我还希望数据表在默认情况下显示所有行，如果未选择多边形，则返回显示所有行。

这是我创建的一个基本的工作示例。我可以点击地图并获得正确的县，但我似乎在click_county中存储值时遇到了问题。

lapply(c('data.table','dplyr','ggplot2','shiny','shinydashboard','leaflet','DT',
'USAboundaries','sf'), library, character.only = TRUE)
ca_counties <- USAboundaries::us_counties(states = 'CA')
parcels <- structure(list(county = c("Yuba", "Sacramento", "Inyo"), num.parcels = c(27797L, 
              452890L, 6432L)), row.names = c(NA, -3L), class = "data.frame")
parcels <- st_as_sf(left_join(parcels, ca_counties[,c('name')], by = c("county" = "name")))
parcels_df <- parcels
parcels_df$geometry <- NULL
#====================================================================================================
ui <- dashboardPage(
skin = 'green',
dashboardHeader(),
dashboardSidebar(sidebarMenu(
menuItem('Use of Force Incidents', tabName = 'dallas_maps', icon = icon('city'))
)),
dashboardBody(tabItems(
#===== Dallas Map Tab =====#
tabItem(tabName = 'dallas_maps',
fluidRow(
box(
width = 12, collapsible = T,
title = 'Dallas County Census Block Groups',
solidHeader = T, status = 'primary',
leafletOutput('parcels_map')
)
),
fluidRow(
box(
width = 12, collapsible = T,
title = 'Use of Force Incidents, 2014 - 2016',
solidHeader = T, status = 'primary',
dataTableOutput('parcels_table')
)
)
)
))
)
#====================================================================================================
server <- function(input, output, session) {
#===== Dallas Map Tab =====#
# Map of Census block groups
output$parcels_map <- renderLeaflet({
bins <- c(1, 10000, 50000, 100000, 500000, 600000)
pal <- colorBin("Blues", domain = parcels$num.parcels, bins = bins)

labels <- sprintf(
"<strong>%s County</strong><br/>
Parcels: %g<br/>",
parcels$county, parcels$num.parcels
) %>% lapply(htmltools::HTML)

leaflet(parcels) %>%
setView(-119, 37.9, 6) %>%
addTiles() %>%
addPolygons(
layerId = ~county,
fillColor = ~pal(num.parcels),
weight = 2,
opacity = 1,
color = 'black',
dashArray = '2',
fillOpacity = 0.7,
highlightOptions = highlightOptions(color = "red", weight = 3,
bringToFront = TRUE),
label = labels,
labelOptions = labelOptions(
style = list("font-weight" = "normal", padding = "4px 8px"),
textsize = "15px",
direction = 'auto')) %>%
addLegend(pal = pal, values = ~num.parcels, opacity = 0.7, title = "Number of Parcels",
position = "bottomleft")
})

click_county <- reactiveVal()

observeEvent(input$parcels_map_shape_click, {
# Capture the info of the clicked polygon
click_county <- input$parcels_map_shape_click$id
})

print(click_county)

# Parcels data table
output$parcels_table <- DT::renderDataTable({
DT::datatable(parcels_df,
# colnames = c(''),
options = list(lengthMenu = c(10, 25, 50, 100),
pageLength = 10,
columnDefs = list(list(className = 'dt-center', targets = '_all'))),
filter = 'top')
})

}
shinyApp(ui, server)

我已经尝试过这样的方法来渲染数据表，这样我就可以在默认情况下获得所有行，并在点击地图时只获得过滤后的行：

# Parcels data table
output$parcels_table <- DT::renderDataTable({
if (is.null(click_county())) {
DT::datatable(parcels_df,
options = list(lengthMenu = c(10, 25, 50, 100),
pageLength = 10,
columnDefs = list(list(className = 'dt-center', targets = '_all'))),
filter = 'top')
}
else if (!is.null(click_county())) {
DT::datatable(parcels_df[parcels_df$county == click_county(),],
options = list(lengthMenu = c(10, 25, 50, 100),
pageLength = 10,
columnDefs = list(list(className = 'dt-center', targets = '_all'))),
filter = 'top')
}
})

Answer 1

您需要使用语法click_county(input$parcels_map_shape_click$id)为reactiveVal赋值。

在这里，我通过重新点击同一个县来删除过滤器，因为我可以找到点击县外的事件：

observeEvent(input$parcels_map_shape_click, {
# Capture the info of the clicked polygon
if(!is.null(click_county()) && click_county() == input$parcels_map_shape_click$id)
click_county(NULL)     # Reset filter
else
click_county(input$parcels_map_shape_click$id)
})
# Parcels data table
output$parcels_table <- DT::renderDataTable({
DT::datatable( 
if(is.null(click_county())) 
parcels_df    # Not filtered
else 
parcels_df %>% filter( county==click_county())
)
})