Блог

Я использую R Shiny, в частности shinydashboard , для создания панели мониторинга как с картой листовки, так и с графическим рисунком. На рисунке plotly используется ввод из selectizeInput . Карта позволяет пользователям нажимать на округ, который затем фильтрует данные, используемые для создания графика. Я использую renderUI для поля plotly, потому что хочу, чтобы заголовок поля менялся при выборе разных округов. Все это работает правильно.

Я бы хотел, чтобы входные данные, выбранные пользователями, были постоянными при выборе разных местоположений. Например, если я удалю num.parcels выделение, я бы хотел, чтобы оно оставалось удаленным при выборе нового местоположения на карте. Аналогично, если я добавлю новые входные данные, я бы хотел, чтобы они оставались на месте при выборе новых местоположений. Я пробовал разные вещи с observe and observeEvent , но не смог заставить его работать правильно.

Приведенный здесь пример кода упрощен по сравнению с моей фактической панелью мониторинга, и я понимаю, что нет вывода plotly. Я не думаю, что это должно быть проблемой.

 lapply(c('data.table','dplyr','ggplot2','shiny','shinydashboard','leaflet','DT',
         'USAboundaries','sf','plotly'), 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(
              uiOutput('trend_box'),
            )
    )
  ))
)

#====================================================================================================

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
    if(!is.null(click_county()) amp;amp; click_county() == input$parcels_map_shape_click$id)
      click_county(NULL)     # Reset filter
    else
      click_county(input$parcels_map_shape_click$id)
  })
  
  # Parcels plotly
  output$trend_box <- renderUI({
    if (!is.null(click_county())) {
      plot_title <- paste0(input$parcels_map_shape_click$id, ' Homicides, 1985 - 2019')
    }
    else {
      plot_title <- paste0('United States Homicides, 1985 - 2019')
    }
    box(width = 8, solidHeader = T, status = 'primary',
        title = plot_title,
        plotlyOutput('trend_demog'),
        selectizeInput('demog_plotly',
                       label = 'Select Demographics',
                       choices = 'num.parcels',
                       multiple = T,
                       options = list(maxItems = 7,
                                      placeholder = 'Choose up to seven groups')
                       ,
                       selected = c('num.parcels')
        )
    )
  })
  
}

shinyApp(ui, server)