【发布时间】：2020-11-15 20:51:16
【问题描述】：
我正在创建一个闪亮的应用程序来说明先前分布的启发，主要用于教学目的。
在应用程序中，人们被要求对利物浦下一次下雨需要多少天进行 10 次猜测。
他们的猜测被绘制在图表中，并在输入时显示在表格中以帮助理解。
当他们按下“提交”按钮时，应将包含其回复的单个 .csv 文件上传到保管箱文件夹（用于后续分析）。
（大部分代码取自Persistent Data Storage in Shiny Apps 示例）。
一切运行良好，预计按下提交按钮时，多个 .csv 文件会上传到保管箱文件夹。
我不知道如何将输出仅保存为一个文件，但怀疑这与 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)
【问题讨论】：
-
谢谢 - 这似乎仍然会导致输出多个文件，这表明这与我的
observe调用的嵌套有关。 -
@PeterMacPherson 理想情况下，您希望将显示的同一个表格写入 csv 或上传到 Dropbox，对吗？
-
@armrrs - 是的，这是正确的
-
虽然我仍在试图找出问题所在，但您似乎在一个观察中发现了 observeEvent，这似乎是多个文件的潜在原因。