动态反应对象与 observe 和 if 相冲突

Question

我尝试在 Shiny 中创建一个应用程序，所有 selectInput 都是动态反应对象，但目前他们使用变量 select 和 if(){} 条件使用 observe({})，我的情节不起作用 (PEST == unique(stands_ds$PEST) : length of larger object is not multiple of length of smaller object)。问题是最终的 selection 对象 selectedvariable4 并尝试使用 selectedvariable4, selectedvariable4(),selectedvariable4()$ID_UNIQUE 和 unique(selectedvariable4()$ID_UNIQUE) 没有成功。在我的例子中：

# Packages
library(rgdal)
library(shiny)
library(leaflet)
library(leaflet.providers)
library(ggplot2)
library(shinythemes)
library(sf)
library(lubridate)
library(dplyr)
library(anytime)


# get AOI
download.file(
  "https://github.com/Leprechault/trash/raw/main/stands_example.zip",
  zip_path <- tempfile(fileext = ".zip")
)
unzip(zip_path, exdir = tempdir())

# Open the files
setwd(tempdir())
stands_extent <- readOGR(".", "stands_target") # Border
stands_ds <- read.csv("pred_target_stands.csv", sep=";") # Data set
stands_ds <- stands_ds %>%
  mutate(DATA_S2 = ymd(DATA_S2))
stands_ds$PEST<-c(rep("A",34),rep("B",225))
  
# Create the shiny dash
ui <- fluidPage(
  theme = shinytheme("cosmo"),
  titlePanel(title="My Map Dashboard"),  
  sidebarLayout(
    sidebarPanel(
      selectInput(inputId = "selectedvariable0", "Type", choices = c(unique(stands_ds$PEST))),
      selectInput(inputId = "selectedvariable1", "Date",choices = NULL),
      selectInput(inputId = "selectedvariable2", "Project",choices = NULL),
      selectInput(inputId = "selectedvariable3", "Stand",choices = NULL),
      selectInput(inputId = "selectedvariable4", "ID-Unique",choices = NULL)
    
    ),
    mainPanel(
      textOutput("idSaida"),
      fluidRow(
        splitLayout(plotOutput("myplot")))
    )
  )
)

server <- function(input, output, session){
  
  
  selectedvariable0 <- reactive({
    filter(stands_ds, PEST == unique(stands_ds$PEST))
  })
  observeEvent(selectedvariable0(), {
    choices <- anytime::anydate(unique(selectedvariable0()$DATA_S2))
    updateSelectInput(inputId = "selectedvariable1", choices = choices) 
  })
  
  selectedvariable1 <- reactive({
    req(input$selectedvariable1)
    filter(selectedvariable0(), DATA_S2 == anytime::anydate(input$selectedvariable1))
  })
  observeEvent(selectedvariable1(), {
    choices <- unique(selectedvariable1()$PROJETO)
    updateSelectInput(inputId = "selectedvariable2", choices = choices)
  })
  
  selectedvariable2 <- reactive({
    req(input$selectedvariable2)
    filter(selectedvariable0(), PROJETO == input$selectedvariable2)
  })
  observeEvent(selectedvariable2(), {
    choices <- unique(selectedvariable2()$CD_TALHAO)
    updateSelectInput(inputId = "selectedvariable3", choices = choices)
  })
  
  selectedvariable3 <- reactive({
    req(input$selectedvariable3)
    filter(selectedvariable0(), CD_TALHAO == input$selectedvariable3)
  })
  observeEvent(selectedvariable3(), {
    choices <- unique(selectedvariable3()$ID_UNIQUE)
    updateSelectInput(inputId = "selectedvariable4", choices = choices)
  })
  selectedvariable4 <- reactive({
    req(input$selectedvariable4)
    filter(selectedvariable0(), ID_UNIQUE == input$selectedvariable4)
  })
  
  
  #Create plot and maps
  
  observe({
    
    req(selectedvariable0())
    
    if(selectedvariable0()=="B"){
      
      
  output$myplot <- renderPlot({

    #Subset stand
    stands_sel <- subset(stands_extent, stands_extent@data$ID_UNIQUE==unique(selectedvariable4()$ID_UNIQUE))

    #Subset for input$var and assign this subset to new object, "fbar"
    ds_sel<- stands_ds[stands_ds$ID_UNIQUE==unique(selectedvariable4()$ID_UNIQUE),]

    #Create a map
    polys <- st_as_sf(stands_sel)
    ggplot() +
      geom_sf(data=polys) +
      geom_point(data=ds_sel,
                 aes(x=X, y=Y), color="red") +
      coord_sf() +
      theme_bw() +
      theme(text = element_text(size=10))
  })
  
    } else {
      
      output$myplot <- renderPlot({
        
        #Subset stand
        stands_sel <- subset(stands_extent, stands_extent@data$ID_UNIQUE==unique(selectedvariable4()$ID_UNIQUE))
        
        #Subset for input$var and assign this subset to new object, "fbar"
        ds_sel<- stands_ds[stands_ds$ID_UNIQUE==unique(selectedvariable4()$ID_UNIQUE),]
        
        #Create a map
        polys <- st_as_sf(stands_sel)
        ggplot() +
          geom_sf(data=polys) +
          geom_point(data=ds_sel,
                     aes(x=X, y=Y), color="blue") +
          coord_sf() +
          theme_bw() +
          theme(text = element_text(size=10))
      })
      }
    }) #end of observe function.
 }
shinyApp(ui, server)
##

拜托，有什么解决办法吗？

Answer 1

我们 filtering 和 subset 所在的行将有 == 并且其中一些在运算符的 rhs 上是 unique 值即它可以是单个值或多个值。使用==时，是按元素比较，只有当rhs对象为length 1或与lhs对象具有相同的length时才有效。使用 length 1，它回收并且没有问题，但是如果 length 大于 1 并且不等于另一个对象，回收将进行错误输出并且它也可能给出 length 如果长度不是其他对象的倍数，则发出警告。

使用 %in% 可能更安全。下面是更新后的代码（虽然没有测试）

library(rgdal)
library(shiny)
library(leaflet)
library(leaflet.providers)
library(ggplot2)
library(shinythemes)
library(sf)
library(lubridate)
library(dplyr)
library(anytime)


# get AOI
download.file(
  "https://github.com/Leprechault/trash/raw/main/stands_example.zip",
  zip_path <- tempfile(fileext = ".zip")
)
unzip(zip_path, exdir = tempdir())

# Open the files
setwd(tempdir())
stands_extent <- readOGR(".", "stands_target") # Border
stands_ds <- read.csv("pred_target_stands.csv", sep=";") # Data set
stands_ds <- stands_ds %>%
  mutate(DATA_S2 = ymd(DATA_S2))
stands_ds$PEST<-c(rep("A",34),rep("B",225))
  
# Create the shiny dash
ui <- fluidPage(
  theme = shinytheme("cosmo"),
  titlePanel(title="My Map Dashboard"),  
  sidebarLayout(
    sidebarPanel(
      selectInput(inputId = "selectedvariable0", "Type", choices = c(unique(stands_ds$PEST))),
      selectInput(inputId = "selectedvariable1", "Date",choices = NULL),
      selectInput(inputId = "selectedvariable2", "Project",choices = NULL),
      selectInput(inputId = "selectedvariable3", "Stand",choices = NULL),
      selectInput(inputId = "selectedvariable4", "ID-Unique",choices = NULL)
    
    ),
    mainPanel(
      textOutput("idSaida"),
      fluidRow(
        splitLayout(plotOutput("myplot")))
    )
  )
)

server <- function(input, output, session){
  
  
  selectedvariable0 <- reactive({
    filter(stands_ds, PEST %in% unique(stands_ds$PEST))
  })
  observeEvent(selectedvariable0(), {
    choices <- anytime::anydate(unique(selectedvariable0()$DATA_S2))
    updateSelectInput(inputId = "selectedvariable1", choices = choices) 
  })
  
  selectedvariable1 <- reactive({
    req(input$selectedvariable1)
    filter(selectedvariable0(), DATA_S2 %in% anytime::anydate(input$selectedvariable1))
  })
  observeEvent(selectedvariable1(), {
    choices <- unique(selectedvariable1()$PROJETO)
    updateSelectInput(inputId = "selectedvariable2", choices = choices)
  })
  
  selectedvariable2 <- reactive({
    req(input$selectedvariable2)
    filter(selectedvariable0(), PROJETO %in% input$selectedvariable2)
  })
  observeEvent(selectedvariable2(), {
    choices <- unique(selectedvariable2()$CD_TALHAO)
    updateSelectInput(inputId = "selectedvariable3", choices = choices)
  })
  
  selectedvariable3 <- reactive({
    req(input$selectedvariable3)
    filter(selectedvariable0(), CD_TALHAO %in% input$selectedvariable3)
  })
  observeEvent(selectedvariable3(), {
    choices <- unique(selectedvariable3()$ID_UNIQUE)
    updateSelectInput(inputId = "selectedvariable4", choices = choices)
  })
  selectedvariable4 <- reactive({
    req(input$selectedvariable4)
    filter(selectedvariable0(), ID_UNIQUE %in% input$selectedvariable4)
  })
  
  
  #Create plot and maps
  
  observe({
    
    req(selectedvariable0())
    
    if("B" %in% input$selectedvariable0  ){
      
      
  output$myplot <- renderPlot({

    #Subset stand
    stands_sel <- subset(stands_extent, stands_extent@data$ID_UNIQUE %in% unique(selectedvariable4()$ID_UNIQUE))

    #Subset for input$var and assign this subset to new object, "fbar"
    ds_sel<- stands_ds[stands_ds$ID_UNIQUE %in% unique(selectedvariable4()$ID_UNIQUE),]

    #Create a map
    polys <- st_as_sf(stands_sel)
    ggplot() +
      geom_sf(data=polys) +
      geom_point(data=ds_sel,
                 aes(x=X, y=Y), color="red") +
      coord_sf() +
      theme_bw() +
      theme(text = element_text(size=10))
  })
  
    } else {
      
      output$myplot <- renderPlot({
        
        #Subset stand
        stands_sel <- subset(stands_extent, stands_extent@data$ID_UNIQUE %in% unique(selectedvariable4()$ID_UNIQUE))
        
        #Subset for input$var and assign this subset to new object, "fbar"
        ds_sel<- stands_ds[stands_ds$ID_UNIQUE %in% unique(selectedvariable4()$ID_UNIQUE),]
        
        #Create a map
        polys <- st_as_sf(stands_sel)
        ggplot() +
          geom_sf(data=polys) +
          geom_point(data=ds_sel,
                     aes(x=X, y=Y), color="blue") +
          coord_sf() +
          theme_bw() +
          theme(text = element_text(size=10))
      })
      }
    }) #end of observe function.
 }
shinyApp(ui, server)

动态反应对象与 observe 和 if 相冲突

Dynamic reactive objects conflits with observe combined with if

r

shiny

shiny-reactivity