r - 保存在 Shiny 的应用程序中收集的 react 数据

Question

我正在创建一个 Shiny 的应用程序来说明先验分布的导出，主要用于教学目的。

在应用程序中，人们被要求对利物浦下一次下雨需要多少天进行 10 次猜测。

他们的猜测被绘制在图表中，并在输入时显示在表格中以帮助理解。

当他们按下“提交”按钮时，包含其回复的单个 .csv 文件应上传到保管箱文件夹(用于后续分析)。

(此代码大部分取自 Persistent Data Storage in Shiny Apps 示例)。

一切都很顺利，当按下“提交”按钮时，多个 .csv 文件将上传到 dropbox 文件夹。

我不知道如何将输出保存为一个文件，但怀疑这与 observe 调用有关。

非常感谢您的帮助。

require(shiny)
#> Loading required package: shiny
library(tidyverse)
#> ── Attaching packages ────────────────────────────────────────────────────────── tidyverse 1.2.1 ──
#> ✔ ggplot2 2.2.1.9000     ✔ purrr   0.2.4     
#> ✔ tibble  1.4.1          ✔ dplyr   0.7.4     
#> ✔ tidyr   0.7.2          ✔ stringr 1.2.0     
#> ✔ readr   1.1.1          ✔ forcats 0.2.0
#> ── Conflicts ───────────────────────────────────────────────────────────── tidyverse_conflicts() ──
#> ✖ dplyr::filter() masks stats::filter()
#> ✖ dplyr::lag()    masks stats::lag()
library(rdrop2)
#Define output directory
outputDir <-
  "output"
#Define all variables to be collected
fieldsAll <- c("name", "type", "g1", "g2", "g3","g4",
               "g5", "g6", "g7", "g8", "g9", "g10")
#Define all mandatory variables
fieldsMandatory <- c("name", "type", "g1", "g2", "g3",
                     "g4", "g5", "g6", "g7", "g8", "g9",
                     "g10")
#Label mandatory fields
labelMandatory <- function(label) {
  tagList(label,
          span("*", class = "mandatory_star"))
}
#Get current Epoch time
epochTime <- function() {
  return(as.integer(Sys.time()))
}
#Get a formatted string of the timestamp
humanTime <- function() {
  format(Sys.time(), "%Y%m%d-%H%M%OS")
}
#CSS to use in the app
appCSS <-
  ".mandatory_star { color: red; }
.shiny-input-container { margin-top: 25px; }
#thankyou_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; }
"
#UI
ui <- shinyUI(
  fluidPage(
    shinyjs::useShinyjs(),
    shinyjs::inlineCSS(appCSS),

    headerPanel(
      'How many days until it next rains in Liverpool?'
    ),

    sidebarPanel(
      id = "form",
      textInput("name", labelMandatory("Enter name"), value = ""),
      selectInput(
        "type",
        labelMandatory("Select which group best describes you"),
        choices = c("", "Manager", "IT",
                    "Finance"),
        selected = ""
      ),
      numericInput(
        "g1",
        labelMandatory("Guess 1"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g2",
        labelMandatory("Guess 2"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g3",
        labelMandatory("Guess 3"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g4",
        labelMandatory("Guess 4"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g5",
        labelMandatory("Guess 5"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g6",
        labelMandatory("Guess 6"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g7",
        labelMandatory("Guess 7"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g8",
        labelMandatory("Guess 8"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g9",
        labelMandatory("Guess 9"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g10",
        labelMandatory("Guess 10"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      )
    ),
    mainPanel(
      br(),
      p("Your guesses will appear here:"),
      br(),
      br(),
      plotOutput("plot"),
      br(),
      p(
        "After you are happy with your guesses, press submit to send data to the database."
      ),
      br(),
      tableOutput("table"),
      br(),
      actionButton("Submit", "Submit"),

      fluidRow(shinyjs::hidden(div(
        id = "thankyou_msg",
        h3("Thanks, your response was submitted successfully!")
      )))
    )
  )
)
#Server
server <- shinyServer(function(input, output, session) {
  # Gather all the form inputs
  formData <- reactive({
    x <- reactiveValuesToList(input)
    data.frame(names = names(x),
               values = unlist(x, use.names = FALSE))
  })

  #Save the results to a file
  saveData <- function(data) {
    # Create a unique file name
    fileName <-
      sprintf("%s_%s_drive_time.csv",
              humanTime(),
              digest::digest(data))
    # Write the data to a temporary file locally
    filePath <- file.path(tempdir(), fileName)
    write.csv(data, filePath, row.names = TRUE, quote = TRUE)
    # Upload the file to Dropbox
    drop_upload(filePath, path = outputDir)
  }

  #Observe for when all mandatory fields are completed
  observe({
    fields_filled <-
      fieldsMandatory %>%
      sapply(function(x)
        ! is.na(input[[x]]) && input[[x]] != "") %>%
      all

    shinyjs::toggleState("Submit", fields_filled)



    # When the Submit button is clicked, submit the response
    observeEvent(input$Submit, {
      # User-experience stuff
      shinyjs::disable("Submit")
      shinyjs::show("thankyou_msg")

      tryCatch({
        saveData(formData())
        shinyjs::reset("form")
        shinyjs::hide("form")
        shinyjs::show("thankyou_msg")
      })
    })

    # isolate data input
    values <- reactiveValues()

    output$table <- renderTable({
      input$addButton

      Name <- isolate({
        input$name
      })
      Type <- isolate({
        input$type
      })
      Guess1 <- isolate({
        input$g1
      })
      Guess2 <- isolate({
        input$g2
      })
      Guess3 <- isolate({
        input$g3
      })
      Guess4 <- isolate({
        input$g4
      })
      Guess5 <- isolate({
        input$g5
      })
      Guess6 <- isolate({
        input$g6
      })
      Guess7 <- isolate({
        input$g7
      })
      Guess8 <- isolate({
        input$g8
      })
      Guess9 <- isolate({
        input$g9
      })
      Guess10 <- isolate({
        input$g10
      })

      df <-
        data_frame(Name, Type, Guess1, Guess2, Guess3, Guess4, 
                   Guess5, Guess6, Guess7, Guess8, Guess9, Guess10)

      df
       })

    output$plot <- renderPlot({
      input$addButton

      x1 <- isolate({
        input$g1
      })
      x2 <- isolate({
        input$g2
      })
      x3 <- isolate({
        input$g3
      })
      x4 <- isolate({
        input$g4
      })
      x5 <- isolate({
        input$g5
      })
      x6 <- isolate({
        input$g6
      })
      x7 <- isolate({
        input$g7
      })
      x8 <- isolate({
        input$g8
      })
      x9 <- isolate({
        input$g9
      })
      x10 <- isolate({
        input$g10
      })

      df2 <-
        data_frame(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) %>%
        gather()

      ggplot(df2) +
        geom_histogram(aes(x = as.numeric(value)), fill = "#18a7b5", stat =
                         "count") +
        geom_hline(yintercept = seq(1, 10, 1),
                   col = "white",
                   lwd = 1) +
        geom_vline(aes(xintercept = 4),
                   linetype = "dashed",
                   colour = "black") +
        stat_function(
          fun = function(x, mean, sd, n, bw) {
            dnorm(x = x,
                  mean = mean,
                  sd = sd) * n * bw
          },
          args = c(
            mean = mean(df2$value),
            sd = sd(df2$value),
            n = length(df2$value),
            bw = 1
          ),
          colour = "#b5185f"
        ) +
        theme_bw() +
        scale_x_continuous(limits = c(0, 10),
                           breaks = c(0, 1,2,3,4,5,6,7,8,9,10)) +
        scale_y_continuous(limits = c(0, 10),
                           breaks = c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)) +
        labs(x = "Number of days until rains", y = "",
             title = "Estimated number of days until rain") +
        theme(legend.position = "none")

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

Answer 1

更改了几件事:* 将observeEvent从observe中取出* 事实上，缩小了observe的范围* 在表创建中分配时不需要 isolate

require(shiny)
#> Loading required package: shiny
library(tidyverse)
#> ── Attaching packages ────────────────────────────────────────────────────────── tidyverse 1.2.1 ──
#> ✔ ggplot2 2.2.1.9000     ✔ purrr   0.2.4     
#> ✔ tibble  1.4.1          ✔ dplyr   0.7.4     
#> ✔ tidyr   0.7.2          ✔ stringr 1.2.0     
#> ✔ readr   1.1.1          ✔ forcats 0.2.0
#> ── Conflicts ───────────────────────────────────────────────────────────── tidyverse_conflicts() ──
#> ✖ dplyr::filter() masks stats::filter()
#> ✖ dplyr::lag()    masks stats::lag()
library(rdrop2)
#Define output directory
outputDir <-
  "output"
#Define all variables to be collected
fieldsAll <- c("name", "type", "g1", "g2", "g3","g4",
               "g5", "g6", "g7", "g8", "g9", "g10")
#Define all mandatory variables
fieldsMandatory <- c("name", "type", "g1", "g2", "g3",
                     "g4", "g5", "g6", "g7", "g8", "g9",
                     "g10")
#Label mandatory fields
labelMandatory <- function(label) {
  tagList(label,
          span("*", class = "mandatory_star"))
}
#Get current Epoch time
epochTime <- function() {
  return(as.integer(Sys.time()))
}
#Get a formatted string of the timestamp
humanTime <- function() {
  format(Sys.time(), "%Y%m%d-%H%M%OS")
}
#CSS to use in the app
appCSS <-
  ".mandatory_star { color: red; }
.shiny-input-container { margin-top: 25px; }
#thankyou_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; }
"
#UI
ui <- shinyUI(
  fluidPage(
    shinyjs::useShinyjs(),
    shinyjs::inlineCSS(appCSS),

    headerPanel(
      'How many days until it next rains in Liverpool?'
    ),

    sidebarPanel(
      id = "form",
      textInput("name", labelMandatory("Enter name"), value = ""),
      selectInput(
        "type",
        labelMandatory("Select which group best describes you"),
        choices = c("", "Manager", "IT",
                    "Finance"),
        selected = ""
      ),
      numericInput(
        "g1",
        labelMandatory("Guess 1"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g2",
        labelMandatory("Guess 2"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g3",
        labelMandatory("Guess 3"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g4",
        labelMandatory("Guess 4"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g5",
        labelMandatory("Guess 5"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g6",
        labelMandatory("Guess 6"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g7",
        labelMandatory("Guess 7"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g8",
        labelMandatory("Guess 8"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g9",
        labelMandatory("Guess 9"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      ),
      numericInput(
        "g10",
        labelMandatory("Guess 10"),
        value = "",
        min = 1,
        max = 10,
        step = 1
      )
    ),
    mainPanel(
      br(),
      p("Your guesses will appear here:"),
      br(),
      br(),
      plotOutput("plot"),
      br(),
      p(
        "After you are happy with your guesses, press submit to send data to the database."
      ),
      br(),
      tableOutput("table"),
      br(),
      actionButton("Submit", "Submit"),

      fluidRow(shinyjs::hidden(div(
        id = "thankyou_msg",
        h3("Thanks, your response was submitted successfully!")
      )))
    )
  )
)
#Server
server <- shinyServer(function(input, output, session) {
  # Gather all the form inputs
  formData <- reactive({
    x <- reactiveValuesToList(input)
    data.frame(names = names(x),
               values = unlist(x, use.names = FALSE))
  })

  #Save the results to a file
  saveData <- function(data) {
    # Create a unique file name
    fileName <-
      sprintf("%s_%s_drive_time.csv",
              humanTime(),
              digest::digest(data))
    # Write the data to a temporary file locally
    filePath <- file.path('C:\\Users\\SA31\\Desktop\\btc', fileName)
    write.csv(data, filePath, row.names = TRUE, quote = TRUE)
    # Upload the file to Dropbox
    #drop_upload(filePath, path = outputDir)
  }



  # When the Submit button is clicked, submit the response
  observeEvent(input$Submit, {
    # User-experience stuff
    shinyjs::disable("Submit")
    shinyjs::show("thankyou_msg")

    tryCatch({
      #saveData(formData())
      shinyjs::reset("form")
      shinyjs::hide("form")
      shinyjs::show("thankyou_msg")
    })
    #write.csv(create_table(),'submitted.csv')
    saveData(create_table())
  }, ignoreInit = TRUE, once = TRUE, ignoreNULL = T)



  #Observe for when all mandatory fields are completed
  observe({
    fields_filled <-
      fieldsMandatory %>%
      sapply(function(x)
        ! is.na(input[[x]]) && input[[x]] != "") %>%
      all

    shinyjs::toggleState("Submit", fields_filled)

  })

        # isolate data input
    values <- reactiveValues()


      create_table <- reactive({
        input$addButton

        Name <- input$name
        Type <- input$type
        Guess1 <- input$g1
        Guess2 <- input$g2
        Guess3 <- input$g3
        Guess4 <- input$g4
        Guess5 <- input$g5
        Guess6 <- input$g6
        Guess7 <- input$g7
        Guess8 <- input$g8
        Guess9 <- input$g9
        Guess10 <- input$g10
        df <-
          data_frame(Name, Type, Guess1, Guess2, Guess3, Guess4, 
                     Guess5, Guess6, Guess7, Guess8, Guess9, Guess10)

        df
      })



    output$table <- renderTable(create_table())

    output$plot <- renderPlot({
      input$addButton

      x1 <- isolate({
        input$g1
      })
      x2 <- isolate({
        input$g2
      })
      x3 <- isolate({
        input$g3
      })
      x4 <- isolate({
        input$g4
      })
      x5 <- isolate({
        input$g5
      })
      x6 <- isolate({
        input$g6
      })
      x7 <- isolate({
        input$g7
      })
      x8 <- isolate({
        input$g8
      })
      x9 <- isolate({
        input$g9
      })
      x10 <- isolate({
        input$g10
      })

      df2 <-
        data_frame(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) %>%
        gather()

      ggplot(df2) +
        geom_histogram(aes(x = as.numeric(value)), fill = "#18a7b5", stat =
                         "count") +
        geom_hline(yintercept = seq(1, 10, 1),
                   col = "white",
                   lwd = 1) +
        geom_vline(aes(xintercept = 4),
                   linetype = "dashed",
                   colour = "black") +
        stat_function(
          fun = function(x, mean, sd, n, bw) {
            dnorm(x = x,
                  mean = mean,
                  sd = sd) * n * bw
          },
          args = c(
            mean = mean(df2$value),
            sd = sd(df2$value),
            n = length(df2$value),
            bw = 1
          ),
          colour = "#b5185f"
        ) +
        theme_bw() +
        scale_x_continuous(limits = c(0, 10),
                           breaks = c(0, 1,2,3,4,5,6,7,8,9,10)) +
        scale_y_continuous(limits = c(0, 10),
                           breaks = c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)) +
        labs(x = "Number of days until rains", y = "",
             title = "Estimated number of days until rain") +
        theme(legend.position = "none")


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