来自 selectInput 的具有多个条件的闪亮 R 观察事件

Posted 2023-03-24

【中文标题】来自 selectInput 的具有多个条件的闪亮 R 观察事件

【英文标题】：Shiny R observeEvent with Multiple Conditions from selectInput

【发布时间】：2019-08-27 21:01:45

【问题描述】：

我正在开发一个闪亮的应用程序，在创建一个包含多个输入的复杂表达式时，我遇到了observeEvent() 函数的困难，这些输入都是从selectInput() 派生的。

我的问题是observeEvent() 函数中的一些表达式在启动时被触发，导致事件过早执行（即我的actionButton() 在启动时被禁用，这是应该的，但在至少一个时启用理想情况下，我希望它仅在选择所有输入时才启用）。如下图：

  observeEvent(
    #input$cohort_file
    input$cohort_IDvar
    input$cohort_index_date
    input$cohort_EOF_date
    input$cohort_EOF_type
    input$cohort_Y_name
    input$cohort_L0
  , 
    enable("set_cohort_button")
  )

作为参考，我正在使用@daattali 在 github 上找到的 shinyjs 包来启用/禁用 actionButton()。

除了最后一个输入（即input$cohort_L0）之外的所有输入似乎都在启动时被初始化，因此observeEvent() 仅在选择input$cohort_L0 时启用actionButton。如果您运行我的应用程序并按从上到下的顺序选择输入，那么observeEvent() 似乎正在按预期工作。当我决定随机选择输入时，我才发现它没有按预期工作，并发现选择 input$cohort_L0 是我需要选择启用 actionButton() 的唯一输入。

代码的 UI 部分如下所示：

# Variable selection
                          selectInput('cohort_IDvar', 'ID', choices = ''),
                          selectInput('cohort_index_date', 'Index date', choices = ''),
                          selectInput('cohort_EOF_date', 'End of follow-up date', choices = ''),
                          selectInput('cohort_EOF_type', 'End of follow-up reason', choices = ''),
                          selectInput('cohort_Y_name', 'Outcome', choices = ''),
                          selectInput('cohort_L0', 'Baseline covariate measurements', choices = '', multiple=TRUE, selectize=TRUE),

我正在使用observe() 收集上传数据集的列名，以将它们定向到selectInput()，如下所示：

  ### Collecting column names of dataset and making them selectable input
  observe(
    value <- c("",names(cohort_data()))
    updateSelectInput(session,"cohort_IDvar",choices = value)
    updateSelectInput(session,"cohort_index_date",choices = value)
    updateSelectInput(session,"cohort_EOF_date",choices = value)
    updateSelectInput(session,"cohort_EOF_type",choices = value)
    updateSelectInput(session,"cohort_L0",choices = value)
  )

我已经研究过使用参数ignoreInit = TRUE，但它对于我在observeEvent() 中有多个表达式的情况没有任何作用。我还研究过在selectInput() 中强制没有默认选择，但没有运气。

所以我的两部分问题是我如何在仅选择所有输入时执行observEvent()/如何停止输入在启动时被初始化？

我的整个代码：

library(shiny)
library(shinyjs)

ui <- fluidPage(

  useShinyjs(),
  navbarPage("Test",
             tabPanel("Cohort",
                      sidebarLayout(
                        sidebarPanel(
                          fileInput("cohort_file", "Choose CSV File",
                                    multiple = FALSE,
                                    accept = c("text/csv",
                                               "text/comma-separated-values,text/plain",
                                               ".csv")),
                          # Horizontal line ----
                          tags$hr(),
                          # Variable selection
                          selectInput('cohort_IDvar', 'ID', choices = ''),
                          selectInput('cohort_index_date', 'Index date', choices = ''),
                          selectInput('cohort_EOF_date', 'End of follow-up date', choices = ''),
                          selectInput('cohort_EOF_type', 'End of follow-up reason', choices = ''),
                          selectInput('cohort_Y_name', 'Outcome', choices = ''),
                          selectInput('cohort_L0', 'Baseline covariate measurements', choices = '', multiple=TRUE, selectize=TRUE),
                          # Horizontal line ----
                          tags$hr(),
                          disabled(
                            actionButton("set_cohort_button","Set cohort")
                          )
                          #actionButton("refresh_cohort_button","Refresh")
                        ),
                        mainPanel(
                          DT::dataTableOutput("cohort_table"),
                          tags$div(id = 'cohort_r_template')
                        )
                      )
             )
  )
)

server <- function(input, output, session) 

  ################################################
  ################# Cohort code
  ################################################

  cohort_data <- reactive(
    inFile_cohort <- input$cohort_file
    if (is.null(inFile_cohort))
      return(NULL)
    df <- read.csv(inFile_cohort$datapath, 
                   sep = ',')
    return(df)
  )

  rv <- reactiveValues(cohort.data = NULL)
  rv <- reactiveValues(cohort.id = NULL)
  rv <- reactiveValues(cohort.index.date = NULL)
  rv <- reactiveValues(cohort.eof.date = NULL)
  rv <- reactiveValues(cohort.eof.type = NULL)

  ### Creating a reactiveValue of the loaded dataset
  observeEvent(input$cohort_file, rv$cohort.data <- cohort_data())

  ### Displaying loaded dataset in UI
  output$cohort_table <- DT::renderDataTable(
    df <- cohort_data()
    DT::datatable(df,options=list(scrollX=TRUE, scrollCollapse=TRUE))
  )

  ### Collecting column names of dataset and making them selectable input
  observe(
    value <- c("",names(cohort_data()))
    updateSelectInput(session,"cohort_IDvar",choices = value)
    updateSelectInput(session,"cohort_index_date",choices = value)
    updateSelectInput(session,"cohort_EOF_date",choices = value)
    updateSelectInput(session,"cohort_EOF_type",choices = value)
    updateSelectInput(session,"cohort_L0",choices = value)
  )

  ### Creating selectable input for Outcome based on End of Follow-Up unique values
  observeEvent(input$cohort_EOF_type,
    updateSelectInput(session,"cohort_Y_name",choices = unique(cohort_data()[,input$cohort_EOF_type]))
  )

  ### Series of observeEvents for creating vector reactiveValues of selected column
  observeEvent(input$cohort_IDvar, 
    rv$cohort.id <- cohort_data()[,input$cohort_IDvar]
  )
  observeEvent(input$cohort_index_date, 
    rv$cohort.index.date <- cohort_data()[,input$cohort_index_date]
  )
  observeEvent(input$cohort_EOF_date, 
    rv$cohort.eof.date <- cohort_data()[,input$cohort_EOF_date]
  )
  observeEvent(input$cohort_EOF_type, 
    rv$cohort.eof.type <- cohort_data()[,input$cohort_EOF_type]
  )

  ### ATTENTION: Following eventReactive not needed for example so commenting out
  ### Setting id and eof.type as characters and index.date and eof.date as Dates
  #cohort_data_final <- eventReactive(input$set_cohort_button,
  #  rv$cohort.data[,input$cohort_IDvar] <- as.character(rv$cohort.id)
  #  rv$cohort.data[,input$cohort_index_date] <- as.Date(rv$cohort.index.date)
  #  rv$cohort.data[,input$cohort_EOF_date] <- as.Date(rv$cohort.eof.date)
  #  rv$cohort.data[,input$cohort_EOF_type] <- as.character(rv$cohort.eof.type)
  #  return(rv$cohort.data)
  #)

  ### Applying desired R function
  #set_cohort <- eventReactive(input$set_cohort_button,
    #function::setCohort(data.table::as.data.table(cohort_data_final()), input$cohort_IDvar, input$cohort_index_date, input$cohort_EOF_date, input$cohort_EOF_type, input$cohort_Y_name, input$cohort_L0)
  #)

  ### R code template of function
  cohort_code <- eventReactive(input$set_cohort_button,
    paste0("cohort <- setCohort(data = as.data.table(",input$cohort_file$name,"), IDvar = ",input$cohort_IDvar,", index_date = ",input$cohort_index_date,", EOF_date = ",input$cohort_EOF_date,", EOF_type = ",input$cohort_EOF_type,", Y_name = ",input$cohort_Y_name,", L0 = c(",paste0(input$cohort_L0,collapse=","),"))")
  )

  ### R code template output fo UI
  output$cohort_code <- renderText(
    paste0("cohort <- setCohort(data = as.data.table(",input$cohort_file$name,"), IDvar = ",input$cohort_IDvar,", index_date = ",input$cohort_index_date,", EOF_date = ",input$cohort_EOF_date,", EOF_type = ",input$cohort_EOF_type,", Y_name = ",input$cohort_Y_name,", L0 = c(",paste0(input$cohort_L0,collapse=","),"))")
  )

  ### Disables cohort button when "Set cohort" button is clicked
  observeEvent(input$set_cohort_button, 
    disable("set_cohort_button")
  )

  ### Disables cohort button if different dataset is loaded
  observeEvent(input$cohort_file, 
    disable("set_cohort_button")
  )

  ### This is where I run into trouble
  observeEvent(
    #input$cohort_file
    input$cohort_IDvar
    input$cohort_index_date
    input$cohort_EOF_date
    input$cohort_EOF_type
    input$cohort_Y_name
    input$cohort_L0
  , 
    enable("set_cohort_button")
  )

  ### Inserts heading and R template code in UI when "Set cohort" button is clicked
  observeEvent(input$set_cohort_button, 
    insertUI(
      selector = '#cohort_r_template',
      ui = tags$div(id = "cohort_insertUI", 
                    h3("R Template Code"),
                    verbatimTextOutput("cohort_code"))
    )
  )

  ### Removes heading and R template code in UI when new file is uploaded or when input is changed
  observeEvent(
    input$cohort_file
    input$cohort_IDvar
    input$cohort_index_date
    input$cohort_EOF_date
    input$cohort_EOF_type
    input$cohort_Y_name
    input$cohort_L0
  , 
    removeUI(
      selector = '#cohort_insertUI'
    )
  )



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

【参考方案1】：

作为触发事件传递给 observeEvent 的代码块是

  input$cohort_IDvar
  input$cohort_index_date
  input$cohort_EOF_date
  input$cohort_EOF_type
  input$cohort_Y_name
  input$cohort_L0

这意味着，就像任何其他响应式代码块一样，当这些值中的任何一个发生更改时，该响应式块将被视为无效，因此观察者将触发。所以你看到的行为是有道理的。

听起来您想要的只是在设置所有值时才执行。这听起来像是对req() 函数的极大使用！试试这样的：

observe(
  req(input$cohort_IDvar, input$cohort_index_date, input$cohort_EOF_date, ...)
  enable("set_cohort_button")
)

请注意，对于shinyjs::enable()，您可以改用shinyjs::toggleState() 函数。我认为在这种情况下，req() 函数是更好的选择。