r-动态反应对象与observe结合if

Question

我试图在Shiny中创建一个应用程序，所有的selectInput都是动态反应对象，但目前他们使用observe({})结合变量select和if(){}条件进行了一些绘图(输出$myplot(，我的绘图不起作用(PEST == unique(stands_ds$PEST) : length of larger object is not multiple of length of smaller object(。问题是最终选择对象selectedvariable4，并尝试使用selectedvariable 4、selectedvariable4((、selectedvariable4(($ID_UNIQUE和UNIQUE(selectedvariaple4(($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对象为length1或具有与lhs对象相同的length时，它才能工作。对于length1，它可以回收并且没有问题，但是如果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)