r - 如何根据 R Shiny 中 Leaflet map 的输入来过滤数据表？

Question

我正在使用shiny制作一个仪表板，其中包含传单 map 和数据表。我希望能够单击 map 上的多边形(即特定县)，将该县存储为 react 值，然后过滤数据表以仅显示该县的结果。

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

这是我创建的一个基本工作示例。我可以单击 map 并获取正确的县，但在 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)

我已经尝试过类似的方法来呈现数据表，这样我就可以默认获取所有行，并且在单击 map 时仅获取过滤后的行:

# 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())
        )
  })