R中的observeEvent中的未处理错误

时间:2017-05-28 17:51:16

标签: mysql r shiny

library(shiny)
fieldsAll <- c("name", "favourite_pkg", "used_shiny", "r_num_years", "os_type")
fieldsMandatory <- c("name", "favourite_pkg")
labelMandatory <- function(label) {
  tagList(
    label,
    span("*", class = "mandatory_star")
  )
}
epochTime <- function() {
  return(as.integer(Sys.time()))
}
humanTime <- function() {
  format(Sys.time(), "%Y%m%d-%H%M%OS")
}
saveData <- function(data) {
  fileName <- sprintf("%s_%s.csv",
                      humanTime(),
                      digest::digest(data))

  write.csv(x = data, file = file.path(responsesDir, fileName),
            row.names = FALSE, quote = TRUE)
}
loadData <- function() {
  files <- list.files(file.path(responsesDir), full.names = TRUE)
  data <- lapply(files, read.csv, stringsAsFactors = FALSE)
  #data <- dplyr::rbind_all(data)
  data <- do.call(rbind, data)
  data
}

responsesDir <- file.path("responses")

appCSS <-
  ".mandatory_star { color: red; }
   .shiny-input-container { margin-top: 25px; }
   #submit_msg { margin-left: 15px; }
   #error { color: red; }
   body { background: #fcfcfc; }
   #header { background: #fff; border-bottom: 1px solid #ddd; margin: -20px -15px 0; padding: 15px 15px 10px; }
  "
adminUsers <- c("admin", "prof")

share <- list(
)

shinyApp(
  ui = fluidPage(
    shinyjs::useShinyjs(),
    shinyjs::inlineCSS(appCSS),
    title = "My Form with Shiny code",
    tags$head(
    ),

    div(id = "header",
      h1("My Form with Shiny code"),
      strong( 

      a("Sai Mahesh")
      )
    ),

    fluidRow(
      column(6,
        div(
          id = "form",

          textInput("name", labelMandatory("Name"), ""),
          textInput("favourite_pkg", labelMandatory("Favourite R package")),
          checkboxInput("used_shiny", "I've built a Shiny app in R before", FALSE),
          sliderInput("r_num_years", "Number of years using R", 0, 25, 2, ticks = FALSE),
          selectInput("os_type", "Operating system used most frequently",
                      c("",  "Windows", "Mac", "Linux")),
          actionButton("submit", "Submit", class = "btn-primary"),

          shinyjs::hidden(
            span(id = "submit_msg", "Submitting..."),
            div(id = "error",
                div(br(), tags$b("Error: "), span(id = "error_msg"))
            )
          )
        ),

        shinyjs::hidden(
          div(
            id = "thankyou_msg",
            h3("Thanks, your response was submitted successfully!"),
            actionLink("submit_another", "Submit another response")
          )
        )
      ),
      column(6,
        uiOutput("adminPanelContainer")
      )
    )
  ),
  server = function(input, output, session) {


    observe({
      mandatoryFilled <-
        vapply(fieldsMandatory,
               function(x) {
                 !is.null(input[[x]]) && input[[x]] != ""
               },
               logical(1))
      mandatoryFilled <- all(mandatoryFilled)

      shinyjs::toggleState(id = "submit", condition = mandatoryFilled)
    })


    formData <- reactive({
      data <- sapply(fieldsAll, function(x) input[[x]])
      data <- c(data, timestamp = epochTime())
      data <- t(data)
      data
    })    


    observeEvent(input$submit, {


      shinyjs::disable("submit")
      shinyjs::show("submit_msg")
      shinyjs::hide("error")


      tryCatch({
        saveData(formData())
        shinyjs::reset("form")
        shinyjs::hide("form")
        shinyjs::show("thankyou_msg")
      },
      error = function(err) {
        shinyjs::html("error_msg", err$message)
        shinyjs::show(id = "error", anim = TRUE, animType = "fade")
      },
      finally = {
        shinyjs::enable("submit")
        shinyjs::hide("submit_msg")
      })
    })


    observeEvent(input$submit_another, {
      shinyjs::show("form")
      shinyjs::hide("thankyou_msg")
    })


    output$adminPanelContainer <- renderUI({
      if (!isAdmin()) return()

      div(
        id = "adminPanel",
        h2("Previous responses "),
        downloadButton("downloadBtn", "Download responses"), br(), br(),
        DT::dataTableOutput("responsesTable") 
      )
    })


    isAdmin <- reactive({
      is.null(session$user) || session$user %in% adminUsers
    })    


    output$responsesTable <- DT::renderDataTable(
      loadData(),
      rownames = FALSE,
      options = list(searching = FALSE, lengthChange = FALSE)
    )


    output$downloadBtn <- downloadHandler(
      filename = function() { 
        sprintf("mimic-google-form_%s.csv", humanTime())
        #sprintf("get_me_responses.csv", humanTime())
      },
      content = function(file) {
        write.csv(loadData(), file, row.names = FALSE)
      }
    )    
  }
)

我创建了一个表单,其中提交按钮显示错误。我无法提交表格。我创建了五个必填字段,在填写所有这些字段后,提交按钮被启用,当按下提交按钮时,它需要显示表单已提交。

0 个答案:

没有答案