在 shiny 中使用两个相互依赖的反应物

Question

我一直在尝试创建一个最多包含 3 个输入的仪表板，然后绘制一些数据。我已经完成了这一部分，但现在的要求已经改变，每次选择一个新变量时，他们也应该能够根据新输入过滤数据。到目前为止，这是我的尝试：

UI:

library(shiny)

ui <- fluidPage(
  
  sidebarPanel(
    tags$br(),
    uiOutput("textbox_ui"),
    uiOutput("filter_ui"),
    tags$br(),
    actionButton("add_btn", "Add Factor"),
    actionButton("rm_btn", "Remove Factor"),
    tags$br(),
    
    actionButton("make","Create Graph and Tables")
    
  ),
  
  mainPanel(
    tabsetPanel(type = "tabs",
                tabPanel("Data stuff")
                         
    )
  )
)

服务器：

server <- function(input, output) {
  
  
  # Track the number of input boxes to render
  counter <- reactiveValues(n = 0)
  
  AllInputs <- reactive({
    x <- reactiveValuesToList(input)
  })
  
  observeEvent(input$add_btn, {
    if(counter$n >2){
      2
    }else{
      counter$n <- counter$n + 1
    }
    
  })
  observeEvent(input$rm_btn, {
    if (counter$n > 0) counter$n <- counter$n - 1
  })
  
  
  textboxes <- reactive({
    
    n <- counter$n
    
    if (n > 0) {
      isolate({
        lapply(seq_len(n), function(i) {
          selectInput(inputId = paste0("var", i+1),
                      label = "", 
                      choices = colnames(mtcars),
                      selected = AllInputs()[[paste0("var", i+1)]])
        })
      })
    }
  })
  
  filterboxes <- reactive({
    n <- counter$n
    
    extrainputs <- sapply(seq_len(n), function(i) {
      AllInputs()[[paste0("var", i+1)]]
    })
    summvar <- c(input$var1, extrainputs)
    
    if(n > 0 ){
      isolate({
        lapply(1:length(summvar), function(x){
          text <- summvar[x]
          
          val_level <- unique(mtcars[[text]])
          
          selectInput(inputId =  paste0("fil",x+1),
                      label = paste0("Filter for ", text),
                      choices = val_level,
                      multiple = TRUE,
                      selected = val_level)
        })
      })
    }
    
  })
  
  output$textbox_ui <- renderUI({ textboxes() })
  output$filter_ui <- renderUI({ filterboxes() })
   
}

到目前为止，此设置出现了两个问题。第一，当它们出现在过滤器中时，我无法取消选择任何值；第二，我在服务器端看到这个警告“警告：.subset2 中的错误：无效的下标类型 'list'”。我的反应能力很差，任何建议（反应性或非反应性）将不胜感激。

Answer 1

正如我评论中所建议的...

library(shiny)

myfun <- function(df, var1) {
  df %>% mutate(newvar = !!sym(var1))   # create newvar
}

ui <- fluidPage(
  
  sidebarPanel(
    tags$br(),
    # uiOutput("textbox_ui"),
    # uiOutput("filter_ui"),
    tags$br(),
    tags$div(id = 'placeholder'),
    actionButton("add_btn", "Add Factor"),
    actionButton("removeBtn", "Remove Factor"),
    
    tags$br(),
    
    actionButton("make","Create Graph and Tables")
    
  ),
  
  mainPanel(
    tabsetPanel(type = "tabs",
                tabPanel("Data stuff")
                
    )
  )
)

server <- function(input, output, session) {
  # Track the number of variables 
  numvars <- reactiveVal(0)
  
  ### keep track of elements/lines inserted and not yet removed
  inserted <- c()
  
  observeEvent(input$add_btn, {
   
    if(input$add_btn==0) {
      return(NULL)
    }
    else {  
      if (numvars()<0) {
        numvars(0)  #  clicking on remove button too many times yields negative number; reset it to zero
      }
      
      newValue <- numvars() + 1     # newValue    <- rv$numvars + 1
      numvars(newValue)             # rv$numvars <- newValue
      # btn needs to be adjusted if removing and adding factors 
      if (input$removeBtn==0){
        btn <- input$add_btn
      }else {
        if (input$add_btn > input$removeBtn) {
          btn <- input$add_btn - input$removeBtn  #  add_btn counter does not decrease
        }else btn <- numvars()
      } 
      
      id <- paste0('txt', btn)
      
      insertUI(
        selector = '#placeholder',
        ## wrap element in a div with id for ease of removal
        ui = tags$div(
          selectInput(inputId = paste0("var", btn),
                      label = "",
                      choices = colnames(mtcars)
                      ),
          selectInput(inputId =  paste0("fil",btn),
                      label = paste0("Filter for ", id),
                      choices = "",
                      multiple = TRUE),
          id = id
        )
      )
      
    }
    # inserted <<- c(id, inserted)  ##  removes first one first
    inserted <<- c(inserted, id)  ##  removes last one first
  }, ignoreInit = TRUE)  ## end of observeevent for add_btn
  
  observe({
    #print(numvars())
    lapply(1:numvars(), function(i){
      observeEvent(input[[paste0("var",i)]], {
        mydf <- mtcars
        mydf2 <- myfun(mydf,input[[paste0("var",i)]])
        mysub <- unique(mydf2$newvar)
        nam <- as.character(input[[paste0("var",i)]])
        updateSelectInput(session = session,
                          inputId = paste0("fil",i),
                          label = paste0("Filter for ", nam),
                          choices = mysub, 
                          selected = mysub
                          )
      })
    })
  })
  
  observeEvent(input$removeBtn, {
    newValue <- numvars() - 1     
    numvars(newValue)             
    removeUI(
      ## pass in appropriate div id
      selector = paste0('#', inserted[length(inserted)])
    )
    inserted <<- inserted[-length(inserted)]
    print(inserted)
  }, ignoreInit = TRUE)
  
  
}

shinyApp(ui = ui, server = server)

在 shiny 中使用两个相互依赖的反应物

Using two reactives in shiny that depend on each other

r

shiny

reactive