保存在闪亮应用程序中收集的反应性数据

Question

我正在创建一个闪亮的应用程序来说明以前发行版的启发，主要是为了教学目的。

在这个应用程序中，人们被要求对利物浦下一次下雨要花多少天的时间做10次猜测。

它们的猜测被绘制在图表中，并显示在表格中，因为它们是为了帮助理解而输入的。

当他们按下提交按钮时，一个包含他们的响应的.csv文件应该被上传到一个dropbox文件夹中(用于后续的分析)。

(大部分代码取自应用程序中的持久化数据存储示例)。

一切都工作得很好，预计当按下提交按钮时，会将多个.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)

Answer 2

我知道这个问题比较老。但是我在这里搜索“保存反应性数据”时，并没有在这里找到一个MWE，而是在其他地方搜索。

由于这个问题吸引了超过2k的意见，我分享我的发现，并加上一个mwe本人：

简短回答：

若要保存反应性数据，请将其转换为带有reactiveValuesToList的列表。

最小工作示例：

library(shiny)

ui <- fluidPage(
  textInput("txt", "enter text", "default"),
  actionButton("save", label = "Save reactive value to disk")
)

server <- function(input, output, session) {
  
  global <- reactiveValues()
        
  observeEvent(input$save,{
    global$txt <- input$txt
    to_save <- reactiveValuesToList(global)
    saveRDS(to_save, file = "saved.rds")
    Sys.sleep(0.5)
    
    loaded <- readRDS("saved.rds")
    print(loaded$txt)
  })
  
}

shinyApp(ui, server)