个人中心
gpt4 book ai didi

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

转载 作者：行者123 更新时间：2023-12-02 20:32:37 24 4
gpt4 key购买 nike

我正在创建一个 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)

最佳答案

更改了几件事:* 将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)

关于r - 保存在 Shiny 的应用程序中收集的 react 数据，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/48201169/

24 4 0
文章推荐： arrays - Angular 5 array.filter 内未定义
文章推荐： java - 即使在 Bluemix 中作为 header 传递到服务请求，Sleuth header X-B3-TraceId 值也会重新生成
文章推荐： powershell - 导出 Active Directory 中用户的所有属性和值
文章推荐： r - 一阶差分数据框
行者123
个人简介

我是一名优秀的程序员,十分优秀！

滴滴打车优惠券免费领取
滴滴打车优惠券
全站热门文章
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com