Peter MacPherson
Reputation: 733
Saving reactive data collected in shiny app
I am creating a shiny app to illustrate the elicitation of prior distributions, mainly for teaching purposes.
In the app, people are asked to make 10 guesses about how many days it will take until it will next rain in Liverpool.
Their guesses are plotted in a graph and displayed in a table as they are inputed to aid understanding.
When they press the Submit button, a single .csv file containing their responses should be uploaded to a dropbox folder (for subsequent analysis).
(Much of this code is taken from the Persistent Data Storage in Shiny Apps example).
Everything works beautifully, expect that when the Submit button is pressed, multiple .csv files are uploaded to the dropbox folder.
I can't figure out how to save output as only one file, but suspect it is something to do with the observe calls.
Any help gratefully received.
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)
Upvotes: 2
Views: 3703
Answers (2)
Tonio Liebrand
Reputation: 17689
I am aware that the question is older. But searching for "saving reactive data" in shiny, i did not find a MWE here and searched elsewhere.
As the question attracted over 2k views i share my findings and add a mwe myself:
Short answer:
To save reactive data, transform it to a list with reactiveValuesToList.
Minimal working example:
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)
Upvotes: 2
amrrs
Reputation: 6325
Changed a couple of things:
* Took the observeEvent Out of observe
* In fact, reduced the scope of observe
* isolate wasn't required while assigning in table creation
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)
Upvotes: 3
Related Questions
- How can I save previous reactive values?
- How to save reactive dataframe from one R session to the next?
- How to store previous states of reactive variables in R Shiny application?
- Reactive Shiny Application
- How to save reactive values in Shiny?
- How to use reactiveValues() in order to store changes in a shiny app
- Reactive app help in Shiny
- Reactive variables and input in R Shiny: Save everything, but not every time
- Store data locally on shinyapps.io
- how to store the result of working on input (R, Shiny, reactive)