使用其他 Selectinput 控制反应性 selectinput 的选择

Question

我闪亮的应用程序中有两个 select 输入，我正在努力使第一个 select 输入控制传单地图和另一个 [=18] 的数据集=] 输入。当“时间”select输入是“日”时，我希望“食物”select输入的选择是 dfmorn$food，我希望地图反映这一变化。同样对于“夜晚”，我希望“食物”输入显示 dfnight$food，并反映地图。目前地图和“食物”select输入都没有对“食物”select输入做出反应。

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

#Data Sample

longN <- c(-96.72363, -96.72880, -96.72700)
latN <- c(17.06167, 17.06200, 17.06170 )
nameN <- c("jim", "grant", "pablo")
foodN <- c("tacos", "burger", "elote")


dfnight <- data.frame(longN, latN, nameN, foodN)

longM <- c(-96.7261564, -96.7260505, -96.7259757)
latM <- c(17.0543072,17.0548387, 17.0553262)
nameM <- c("bob", "frank", "sue")
foodM <- c("memelas","tortas", "tacos")

dfmorn <- data.frame(longM, latM, nameM, foodM)
#icons

puestocolorsN = c ("tacos" = 'green',
                  "burger" = 'orange',
                  "elote" = 'red'
                  )

colorsN = puestocolorsN[dfnight$food]

iconsN <- awesomeIcons(icon = 'ios-close',
                      iconColor = 'black',
                      library = 'ion',
                      markerColor = unname(colors) )
puestocolorsM = c ("tacos" = 'green',
                   "memelas" = 'orange',
                   "tortas" = 'black')

colorsM = puestocolorsM[dfmorn$food]

iconsM <- awesomeIcons(icon = 'ios-close',
                       iconColor = 'black',
                       library = 'ion',
                       markerColor = unname(colorsM)  )

#ui 


ui <- fluidPage(
  titlePanel(title = "Street Food Oaxaca"),
  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId = "time",
        label = "Select Time",
        choices = c("Day", "Night"),
        selected = "Day"
      ),
      # uiOutput("conditionalUI")
      selectInput(
        inputId = "food",
        label = "Type of Food",
        choices = unique(dfmorn$food),
        selected = dfmorn$food[1:5],
        multiple = TRUE)),
    mainPanel(h3("Map"), leafletOutput("map", width = "800", height = "600"))))

#server
server <- function(input, output, session){ 
  
  
  observeEvent(input$time, {
    
    reactive(
      if(input$time == "Day") {
        renderUI({
          SelectInput(
            inputId = "food",
            label = "Type of Food",
            choices = unique(dfmorn$food),
            selected = dfmorn$food[1:5],
            multiple = TRUE
          )
        })
      }else {
        renderUI({
          updateSelectInput(
            inputId = "food",
            label = "Type of Food",
            choices = unique(dfnight$food),
            multiple = TRUE
          )
          
        })
      } 
    )
  })
  dfmorn1 <- eventReactive(input$food, {
    dfmorn %>% dplyr::filter(food %in% input$food)
  })
  dfnight1 <- eventReactive(input$food, {
    dfnight %>% dplyr::filter(food %in% input$food)
  })
  
  
  observeEvent(input$time, {
    
    reactive(
      if(input$time == "Day") {
        output$map = renderLeaflet({
          leaflet(data = dfmorn1()) %>%
            setView(lng = -96.725, lat = 17.0618, zoom =14)%>%
            addTiles() %>%
            addAwesomeMarkers(
              lng = ~long,
              lat = ~lat,
              icon = icons,
              label = ~as.character(dfmorn$name))
        })
      }else {
        output$map = renderLeaflet({
          leaflet(data = dfnight1()) %>%
            setView(lng = -96.725, lat = 17.0618, zoom =14)%>%
            addTiles() %>%
            addAwesomeMarkers(
              lng = ~long,
              lat = ~lat,
              icon = icons,
              label = ~as.character(dfmorn$name)
          )
          
        })
      } 
    )
  })

      }
  

 #Run the application 
shinyApp(ui = ui , server = server)

还试图根据此处讨论的 dfmorn$food 和 dfnight$food 对标记颜色进行分组：Assigning color to leaflet awesomemarkers based on chr column

非常感谢。

Answer 1

您有一些拼写错误和不正确的更新 selectInput 的方法。试试这个

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

#Data Sample

longN <- c(-96.72363, -96.72880, -96.72700)
latN <- c(17.06167, 17.06200, 17.06170 )
nameN <- c("jim", "grant", "pablo")
foodN <- c("tacos", "burger", "elote")


dfnight <- data.frame(long=longN, lat=latN, name = nameN, food=foodN)

longM <- c(-96.7261564, -96.7260505, -96.7259757)
latM <- c(17.0543072,17.0548387, 17.0553262)
nameM <- c("bob", "frank", "sue")
foodM <- c("memelas","tortas", "tacos")

dfmorn <- data.frame(long=longM, lat=latM, name = nameM, food=foodM)

puestocolorsN = c ("tacos" = 'green',
                   "burger" = 'orange',
                   "elote" = 'red'
)

colorsN = puestocolorsN[dfnight$food]

iconsN <- awesomeIcons(icon = 'ios-close',
                       iconColor = 'black',
                       library = 'ion',
                       markerColor = unname(colorsN) )
puestocolorsM = c ("tacos" = 'green',
                   "memelas" = 'orange',
                   "tortas" = 'black')

colorsM = puestocolorsM[dfmorn$food]

iconsM <- awesomeIcons(icon = 'ios-close',
                       iconColor = 'black',
                       library = 'ion',
                       markerColor = unname(colorsM)  )

#ui
ui <- fluidPage(
  titlePanel(title = "Street Food Oaxaca"),
  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId = "time",
        label = "Select Time",
        choices = c("Day", "Night"),
        selected = "Day"
      ),
      # uiOutput("conditionalUI")
      selectInput(
        inputId = "food",
        label = "Type of Food",
        choices = unique(dfmorn$food),
        selected = dfmorn$food[1:5],
        multiple = TRUE)),
    mainPanel(h3("Map"), leafletOutput("map", width = "800", height = "600")))
)

#server
server <- function(input, output, session){

  observeEvent(input$time, {

    if(input$time == "Day") choices <- unique(dfmorn$food)
    else choices <- unique(dfnight$food)

      updateSelectInput(
        inputId = "food",
        label = "Type of Food",
        choices = choices,
        select=choices[1:3]
      )
  })

  dfmrn <- eventReactive(input$food, {
    if(input$time == "Day") df <- dfmorn
    else df <- dfnight
    df %>% dplyr::filter(food %in% input$food)
  })

  observe({print(dfmrn())})

  output$map = renderLeaflet({
    req(dfmrn())
    leaflet(data = dfmrn()) %>%
      setView(lng = -96.725, lat = 17.0618, zoom =14)%>%
      addTiles()
  })

  observeEvent(input$food, {
    if(input$time == "Day") icons <- iconsM
    else icons <- iconsN
    popup <- paste( "<b>Name:</b>", dfmrn()$name,  "<br>",  "<b>Type of food:</b>", dfmrn()$food)
    leafletProxy("map", session) %>%
      clearShapes() %>%
      clearMarkers() %>%
      addAwesomeMarkers(
        data = dfmrn(),
        lng = ~long,
        lat = ~lat,
        icon = icons, popup = popup,
        label = ~as.character(name)
      )
  })

}

#Run the application
shinyApp(ui = ui , server = server)

使用其他 Selectinput 控制反应性 selectinput 的选择

Controlling choices for reactive selectinput with other Selectinput

r

input

leaflet

shiny

reactive