r 闪亮的条件行为

Posted 2021-05-23

# UI ==========================================================================
toolUI <- function(id, label) {
  ns <- NS(id)
  tagList(
    actionButton(ns("tool"), label)
  )
}

# Server ======================================================================
toolServer <- function(input, output, session) {
}

library(shiny)
library(shinyjs)
source("module.R")

# UI ==========================================================================
ui <- fluidPage(
  useShinyjs(),
  radioButtons("mode", "Mode",
               choices = c("Entry" = "entry",
                           "Validation" = "validation"),
               selected = "entry", inline = TRUE),
  selectInput("status", "Status", 
              choices = c("NA" = "NA",
                          "Entered" = "entered",
                          "Skipped" = "skipped",
                          "Issue" = "issue",
                          "Validated" = "validated",
                          "Removed" = "removed"),
              selected = "NA"
  ),
  hr(),
  textInput("form", "Form Object"),
  div(strong("Actions")),
  div(
    toolUI("submit", "Submit"),
    toolUI("skip", "Skip"),
    toolUI("issue", "Report Issue"),
    toolUI("validate", "Validate"),
    toolUI("remove", "Confirm Skip")
  ),
  br(),
  div(strong("Comment")),
  textOutput("comment")
)

# Server ======================================================================
server <- function(input, output, session) {
  values <- reactiveValues(
    status = "NA",
    mode = "entry",
    comment = NULL
  )
  
  observe({ values$status <- input$status })
  observe({ values$mode <- input$mode })
  
  fill_form <- function() { updateTextInput(session, "form", value = "User entered values") }
  empty_form <- function() { updateTextInput(session, "form", value = "") }
  
  update_comment <- function(comment) { values$comment <- comment }
  
  observe({
    if (values$mode == "entry") {
      if (values$status == "NA" | values$status == "issue") {
        empty_form()
        sapply(list("submit-tool", "skip-tool"), show)
        sapply(list("issue-tool", "validate-tool", "remove-tool"), hide)
        update_comment(NULL)
      } else if (values$status == "entered") {
        fill_form()
        sapply(list("submit-tool", "skip-tool", "issue-tool", "validate-tool", "remove-tool"), hide)
        update_comment(NULL)
      } else if (values$status == "skipped") {
        empty_form()
        sapply(list("submit-tool", "skip-tool", "issue-tool", "validate-tool", "remove-tool"), hide)
        update_comment("User's reason to skip")
      } else {
        empty_form()
        sapply(list("submit-tool", "skip-tool", "issue-tool", "validate-tool", "remove-tool"), hide)
        update_comment(NULL)
      }
    } else if (values$mode == "validation") {
      if (values$status == "entered") {
        fill_form()
        sapply(list("issue-tool", "validate-tool"), show)
        sapply(list("submit-tool", "skip-tool", "remove-tool"), hide)
        update_comment(NULL)
      } else if (values$status == "skipped") {
        empty_form()
        sapply(list("issue-tool", "remove-tool"), show)
        sapply(list("submit-tool", "skip-tool", "validate-tool"), hide)
        update_comment("User's reason to skip")
      } else if (values$status == "validated") {
        fill_form()
        sapply(list("submit-tool", "skip-tool", "issue-tool", "validate-tool", "remove-tool"), hide)
        update_comment(NULL)
      } else if (values$status == "removed") {
        empty_form()
        sapply(list("submit-tool", "skip-tool", "issue-tool", "validate-tool", "remove-tool"), hide)
        update_comment("User's reason to remove")
      } else {
        empty_form()
        sapply(list("submit-tool", "skip-tool", "issue-tool", "validate-tool", "remove-tool"), hide)
        update_comment(NULL)
      }
    }
  })
  
  output$comment <- renderText({ values$comment })
  
  callModule(toolServer, "submit")
  callModule(toolServer, "skip")
  callModule(toolServer, "issue")
  callModule(toolServer, "validate")
  callModule(toolServer, "remove")
}

shinyApp(ui, server)