如何根据先前的选择根据向下钻取 selectInput() 显示动态更改的地图？

Posted 2023-03-24

【中文标题】如何根据先前的选择根据向下钻取 selectInput() 显示动态更改的地图？

【英文标题】：How to display map dynamically changed as per drilldown selectInput() based on previous selections?

【发布时间】：2021-02-13 23:30:27

【问题描述】：

我想根据selectInput() 渲染地图。我有两个selectInput()s：第一个是product_type，第二个是product_name。在第二个selectInput() 中，下拉选项应仅显示与第一个selectInput() 相关。基于这些向下钻取输入，地图应该会动态变化。

代码如下：

ui <- shinyUI(dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    fluidPage(
      box("", 
          leafletOutput("abc", width = '100%', height = 300),
      
          height = 350, width = 12),
  
      box("", 
          selectInput('vtype', label = 'Prod Type',choices = brand$prod_type),
          selectInput('vname', label = 'Prod Name',choices = brand$prod_name),
          width = 4),
  
      valueBoxOutput("gr", width = 8)
  
    )
  )
))

server <- shinyServer(function(input,output,session)
  a <- ship %>% select(prod_name,prod_type,LON,LAT) %>% filter(prod_type == input$vtype)
  output$gr <- renderValueBox(
    box(table(a))
  )
  output$abc <- renderLeaflet(

      leaflet() %>% addProviderTiles(providers$OpenTopoMap ) 
%>% setView(lat = a$LAT ,lng = A$LON, zoom = 4)
  ) 

)

shinyApp(ui,server)

应标记地图中动态变化的点。我试过了，但无法构建代码。

对此代码的任何帮助对我来说都是优雅的。

【参考方案1】：

我希望我的例子有所帮助。我发明了一个 data.frame 'ship' 并让一切都依赖于它。这意味着它用于您的变量“品牌”以及“船舶”。

我不确定您是如何设想价值框​​的，所以我将类别和产品放入其中。

library(shiny)
library(shinydashboard)
library(dplyr)
library(leaflet)

ship <- data.frame(
    product_type = c("food","food","tool","tool","tool","accessories","accessories","lighting","lighting","lighting"),
    product_name=c("eggs", "bread","clamp","hammer","screw driver", "watch" ,"sun glases","LED","bulb","briquette"),
    LON=c(-61.783,2.632,47.395,20.068,44.563,17.544,-170.730,-65.167,136.189,50.562),
    LAT=c(17.078 ,28.163 ,40.430 ,41.143 ,40.534 ,-12.296 ,-14.318 ,-35.377 ,-24.973 ,26.019),
    stringsAsFactors = F)

ui <- dashboardPage(
    dashboardHeader(),
    dashboardSidebar(collapsed = TRUE, disable = FALSE),
    dashboardBody(
        # fluidPage(
            box(
                leafletOutput("abc", width = '100%', height = 300),
                height = 350,
                width = 12),

            box(
                selectInput('vtype', label = 'Prod Type', choices = c("< select product type>"="", ship$product_type)),
                selectInput('vname', label = 'Prod Name', choices = c("< select item>"="", ship$product_name)),
                width = 4),
            
            valueBoxOutput("gr", width = 8)
        #)
    )
)

server <- shinyServer(function(input,output,session)

    a <- reactive(
        ship %>%
            select(product_name, product_type, LON, LAT) %>%
            filter(product_type %in% input$vtype)
    )
    
    output$gr <- renderValueBox(
        valueBox( input$vtype, paste(a()$product_name, collapse=' - ') )
    )
    
    observe(
        updateSelectInput(session, 
                          inputId='vname', 
                          choices = c("< select item>"="", a()$product_name ))
    )
    
    output$abc <- renderLeaflet(
        leaflet() %>% 
            addProviderTiles(providers$OpenTopoMap ) %>%
            setView(lng=0, lat=0, zoom = 1)
    ) 
    
    observe(
        selection <- a() %>% filter(product_name %in% input$vname)
        leafletProxy("abc") %>%
            flyTo(lat = selection$LAT,
                    lng = selection$LON,
                    zoom = 4)
    ) 
)

shinyApp(ui,server)

下次请提供示例数据。

【讨论】：

我真的很感谢这段代码。但是，如何根据 selectInput() 'Prod Type' 和 'Prod Name' 向协调点添加标记？ .

您可以修改代理功能：leafletProxy("abc") %>% addMarkers(lat = selection$LAT, lng = selection$LON) %>% flyTo(lat = selection$LAT, lng = selection$LON, zoom = 4)。这是一个环顾四周的好地方：rstudio.github.io/leaflet/markers.html

您可能还想添加clearMarkers() 以删除之前添加的一次。 leafletProxy("abc") %>% clearMarkers() %>% addMarkers(lat = selection$LAT, lng = selection$LON) %>% flyTo(lat = selection$LAT, lng = selection$LON, zoom = 4).