我正在创建一个闪亮的应用程序来说明先前发行版的启发，主要用于教学目的。
在应用程序中，人们被要求做出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)
答案 0 :(得分：2)
我知道这个问题比较老。但是搜索“闪亮地保存反应性数据”时，我在这里找不到MWE并在其他地方搜索。
这个问题吸引了超过2千次浏览，因此我分享了自己的发现并亲自添加了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)
答案 1 :(得分：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)