Related
I have a shiny app that works well when I run it locally from R. However, the code doesn't run the same after I've deployed it as a website.
The published website does not ignore repeat key presses like it does when I run the shiny app locally.
Moreover, it saves all previous sessions. If I open the website to start the timer then close the website it saves the previous session. I would like the datatableOutput to reset. erikor solved this for me
Below is how I would like the app to run, and also how it runs when I run it locally in Rstudio:
[<img src="https://i.imgur.com/tPMPHaN.gif" title="Click to enlarge.">]
Below is how the app runs after I have deployed it with shinyapp.io
[<img src="https://i.imgur.com/UjmHbsm.gif" title="Click to enlarge.">]
------Background------
The shiny app is a timer for experiments my lab conducts. It starts a count up timer for the duration that a key is pressed. After the first key press it starts the "Time Lapse Since first Pre-Test Trial: " stopwatch which is just a way to keep track of the time that has lapsed since the experiment first started.
When the key is pressed it resets the "Time Lapsed: " stopwatch to keep track of the duration of time each experimental trial lasts. When the key is released it saves the time that the key was held for in DT::dataTableOutput("TailFlickTrials") and it also resets the "Time Lapsed: " stopwatch, so we can keep track of the time that has lapsed between each experimental trial.
Then at the end of the experiment we can click on the "Download the data" button to save the data as a .csv file locally.
I want to make this app a website so everyone in my lab who are not comfortable using R can also use this.
However, when I publish this app as a website it doesn't function the same way. It registers repeat key presses. So as I hold a key it resets the timer every millisecond. I solved this issue locally with if (!e.repeat). That function in context in the code is:
tags$script(HTML('document.addEventListener("keypress", function(e) {
if (!e.repeat) {
Shiny.setInputValue("start", e.key == 32, {priority: "event"});
}
}
)
Moreover, it saves sessions that were previous run after I close the tab and re-open the website. I would like DT::dataTableOutput("TailFlickTrials") to reset for ever new session.
Necessary libraries:
# install.packages("shinythemes")
# install.packages("shiny")
# install.packages("DT")
# install.packages("lubridate")
# install.packages("keys")
# install.packages("vtable")
# install.packages('rsconnect')
library(shinythemes)
library(shiny)
library(DT)
library(lubridate)
library(keys)
library(vtable)
The code, I'm sorry it is so long I do not believe I can make a reproducible issue with less code:
my_options <- options(digits.secs = 3) # setting the digits for the timer to round up to
ui <- fluidPage(
title = NULL,
lang = NULL,
hr(),
tags$script(HTML('document.addEventListener("keypress", function(e) {
if (!e.repeat) {
Shiny.setInputValue("t_exp_timer", e.key == 13, {priority: "event"});
}
}
);
')),
tags$script(HTML('document.addEventListener("keypress", function(e) {
if (!e.repeat) {
Shiny.setInputValue("start", e.key == 32, {priority: "event"});
}
}
);
')),
tags$script(HTML('document.addEventListener("keyup", function(e) {
Shiny.setInputValue("lapsing_timer", e.key == 32, {priority: "event"});
}
);
')),
tags$script(HTML('document.addEventListener("keyup", function(e) {
if (!e.repeat) {
Shiny.setInputValue("reset", e.key == 32, {priority: "event"});
}
}
);
')),
tags$script(HTML('document.addEventListener("keydown", function(e) {
Shiny.setInputValue("stop", e.key == 83, {priority: "event"});
b }
);
')),
titlePanel("Tail Flick Latency StopWatch"),
sidebarPanel(
textOutput('stopwatch')
),
sidebarPanel(
textOutput('exp_stopwatch')
),
tags$hr(),
mainPanel(
DT::dataTableOutput("TailFlickTrials")
),
downloadButton('download',"Download the data")
)
#create data frame with 0 rows and 5 columns. this is an empty data frame that will fill with values as they are generate by user
v <- reactiveValues()
v$df <- data.frame(Start_Time = numeric(),
End_Time = numeric(),
TimeLapsed = numeric(),
stringsAsFactors = FALSE)
server <- function(input, output, session) {
exp_timer <- reactiveVal(0)
exp_timer_active <- reactiveVal(FALSE)
timer <- reactiveVal(0)
active <- reactiveVal(FALSE)
tmp_Start_Time <- numeric(0)
tmp_End_Time <- numeric(0)
observe({
invalidateLater(100, session)
isolate({
if(active())
{
timer(round(timer()+0.1,3))
}
})
})
observe({
invalidateLater(100, session)
isolate({
if(exp_timer_active())
{
exp_timer(round(exp_timer()+0.1,2))
}
})
})
# observeEvent for the keydown event
observeEvent(input$start,{
timer(0)
start_timing <- as.numeric(Sys.time())
will_it_work <- as.numeric(Sys.time())
# on keydown event erase values of tmp_End_Time and tmp_Time_Lapsed previous saved
tmp_End_Time <- numeric(0)
# on keydown add one to tmp_Trial
# on keydown, input new values for tmp_Trial, tmp_Trial_Date, and tmp_Start_Time
tmp_Start_Time <- Sys.time()
# append tmp_Trial, tmp_Trial_date, tmp_Start_time to df
# this method allows for the new row to have NA values for the End_Time and TimeLapsed columns. the code below will append those values to the row.
new_row <- head(v$df[NA,], 1)
new_row[c('Start_Time')] <- list(Start_Time = tmp_Start_Time)
v$df <- rbind(v$df, new_row)
})
# observeEvent for the keyup event
observeEvent(input$reset,{
timer(0)
start_timing <- as.numeric(Sys.time())
will_it_work <- as.numeric(Sys.time())
# on keyup event erase values of tmp_Trial_Date, and tmp_Start_Time, previously saved
tmp_Start_Time <- numeric(0)
new_row <- head(v$df[NA,], 1)
# on keyup, input new values for tmp_End_Time and tmp_Time_Lapsed
tmp_End_Time <- Sys.time()
tmp_TimeLapsed <- round(as.numeric(difftime(tmp_End_Time, v$df[nrow(v$df), 1], units ="secs")),3)
# on keyup, combine tmp_End_Time and tmp_TimeLapsed into new vector called tmp
# append tmp_End_Time and tmp_Time_Lapsed to df's last row by called nrow() in the row and the last two columns.
v$df[nrow(v$df), 2] <- tmp_End_Time
v$df[nrow(v$df), 3] <- tmp_TimeLapsed
})
observeEvent(input$lapsing_timer, {active(TRUE)})
output$stopwatch <- renderText({
paste("Time Lapsed: ", seconds_to_period(timer()))
})
observeEvent(input$t_exp_timer, exp_timer_active(TRUE))
output$exp_stopwatch <- renderText({
paste("Time Lapse Since first Pre-Test Trial: ", seconds_to_period(exp_timer()))
})
output$TailFlickTrials <- DT::renderDataTable({
v$df
})
output$download <-
downloadHandler(
filename = function () {
paste("MyData.csv")
},
content = function(file) {
write.csv(v$df, file)
}
)
}
# Run the application
options(shiny.maxRequestSize=30*1024^2)
options(rsconnect.max.bundle.files = 500000000)
shinyApp(ui = ui, server = server)
I would like the deployed website to run the same as the shiny app does when I run it locally. I hope my code and what my problem is are both clear.
Please let me know if I need to provide additional information. Thanks!
The reason your previous runs are persisting is your v variable is global and so will be shared across sessions. Put v <- reactiveValues() and the line that follows it inside your server function and then each session will get its own dataframe to store things in. So instead of:
v <- reactiveValues()
v$df <- data.frame(Start_Time = numeric(),
End_Time = numeric(),
TimeLapsed = numeric(),
stringsAsFactors = FALSE)
server <- function(input, output, session) {
...
}
it should be
server <- function(input, output, session) {
v <- reactiveValues()
v$df <- data.frame(Start_Time = numeric(),
End_Time = numeric(),
TimeLapsed = numeric(),
stringsAsFactors = FALSE)
...
}
(Unfortunately I am unable to reproduce the e.repeat issue, as this works as expected when I deploy to shinyapps.io.)
I have a simple shiny app that holds a dataset as a reactive value.
Once a button is pressed, a function should be applied to each row and the result is added as another variable to that dataset.
The dataset is also shown as a DT.
The result variable should be rendered as soon as the computation for that row is finished.
At the moment, the loop/apply that applies the function to each row finishes and only afterwards the results are displayed.
As the function can run for a long time, I want the DT to be updated as soon as a run is finished, not when all runs finish.
I understand that this means I need to use promises/future so that the main shiny code block spawns new processes which do not block in this case the main thread from updating the values. Correct?
However, I am not able to get it to work.
Here is a small MWE using a simple for loop
library(shiny)
library(DT)
ui <- fluidPage(
actionButton("run", "RUN"),
hr(),
DT::dataTableOutput("table")
)
calc_fun <- function(val) {
Sys.sleep(0.5)
val * 10
}
server <- function(input, output, session) {
set.seed(123)
data_res <- reactiveVal(data.frame(id = 1:10, val = rnorm(10), val10 = NA))
observe({
for (i in seq(nrow(data_res()))) {
print(paste("Looking at row", i))
d <- data_res()
d[i, "val10"] <- calc_fun(val = d[i, "val"])
data_res(d)
}
}) %>% bindEvent(input$run)
# This should be rendered whenever a round in the for-loop has finished
# at the moment it is only run once the loop is finished
output$table <- DT::renderDataTable(data_res())
}
shinyApp(ui, server)
Thanks to #ismirsehregal, I came up with the following solution which uses futures to start the calculation in the background, which in turn write the current status to a file.
Shiny then reactively reads the file and updates the values.
The full MWE looks like this:
library(shiny)
library(DT)
library(future)
library(promises)
library(qs) # for fast file read/write, replace with csv if needed
plan(multisession)
ui <- fluidPage(
actionButton("run", "RUN"),
hr(),
textOutput("prog"),
uiOutput("status"),
hr(),
fluidRow(
column(6,
h2("Current Status"),
DT::dataTableOutput("table")
),
column(6,
h2("Data in File"),
tableOutput("file_data")
)
)
)
calc_fun <- function(val) {
Sys.sleep(runif(1, 0, 2))
val * 10
}
# main function that goes through the rows and starts the calculation
# note that the output is saved to a .qs file to be read in by another reactive
do_something_per_row <- function(df, outfile) {
out <- tibble(id = numeric(0), res = numeric(0))
for (i in seq(nrow(df))) {
v <- df$val[i]
out <- out %>% add_row(id = i, res = calc_fun(v))
qsave(out, outfile)
}
return(out)
}
# create a data frame of tasks
set.seed(123)
N <- 13
tasks_init <- tibble(id = seq(N), val = round(rnorm(N), 2), status = "Open", res = NA)
server <- function(input, output, session) {
# the temporary file to communicate over
outfile <- "temp_progress_watch.qs"
unlink(outfile)
data <- reactiveVal(tasks_init) # holds the current status of the tasks
data_final <- reactiveVal() # holds the results once all tasks are finished
output$prog <- renderText(sprintf("Progress: 0 of %i (0.00%%)", nrow(data())))
output$status <- renderUI(div(style = "color: black;", h3("Not yet started")))
# on the button, start the do_something_per_row function as a future
observeEvent(input$run, {
# if a file exists => the code runs already
if (file.exists(outfile)) return()
print("Starting to Run the code")
output$status <- renderUI(div(style = "color: orange;", h3("Working ...")))
d <- data()
future({do_something_per_row(d, outfile)}, seed = TRUE) %...>% data_final()
print("Done starting the code, runs now in the background! freeing the session for interaction")
# return(NULL) # hide future
})
observe({
req(data_final())
output$status <- renderUI(div(style = "color: green;", h3("Done")))
print("All Done - Results came back from the future!")
})
output$file_data <- renderTable(req(df_done()))
output$table <- DT::renderDataTable({
# no need to fire on every refresh, this is handled automatically later
DT::datatable(isolate(data())) %>%
formatStyle("status", color = styleEqual(c("Open", "Done"), c("white", "black")),
backgroundColor = styleEqual(c("Open", "Done"), c("red", "green")))
})
dt_proxy <- DT::dataTableProxy("table")
# look for changes in the file and load it
df_done <- reactiveFileReader(300, session, outfile, function(f) {
r <- try(qread(f), silent = TRUE)
if (inherits(r, "try-error")) return(NULL)
r
})
observe({
req(df_done())
open_ids <- data() %>% filter(status == "Open") %>% pull(id)
if (!any(df_done()$id %in% open_ids)) return()
print(paste("- new entry found:", paste(intersect(df_done()$id, open_ids), collapse = ", ")))
rr <- data() %>% select(-res) %>% left_join(df_done(), by = "id") %>%
mutate(status = ifelse(is.na(res), "Open", "Done"))
data(rr)
DT::replaceData(dt_proxy, rr)
# replace the progress text
txt <- sprintf("Progress: % 4i of % 4i (%05.2f%%)",
nrow(df_done()), nrow(data()), 100 * (nrow(df_done()) / nrow(data())))
output$prog <- renderText(txt)
})
}
shinyApp(ui, server)
or as a picture:
I am creating an app to allow user to upload two excel files and carry over the comments one to the other one, then to download the merged file. The downloadhandler is not working when I tried to run it on the published server, however it running properly locally in rstudio. Any thoughts/suggestions?
library(plyr)
library(dplyr)
library(tidyr)
library(readxl)
library(xlsx)
library(openxlsx)
ui <- fluidPage(
br(),
titlePanel("Excel File Merging Tool"),
br(),
br(),
sidebarLayout(
sidebarPanel(
fileInput("file1", label = h3("Upload New File"), multiple = FALSE, buttonLabel = "Browse", placeholder = "No file selected"),
fileInput("file2", label = h3("Upload Old File"), multiple = FALSE, buttonLabel = "Browse", placeholder = "No file selected"),
actionButton("actionMerge", label = "Merge Uploaded Files"),
hr(),
downloadButton('downloadData', 'Download Merged File')
),
mainPanel(
)
)
)
#Defined Funtions
read_excel_allsheets <- function(filename, tibble = FALSE) {
sheets <- readxl::excel_sheets(filename)
x <- lapply(sheets, function(X) readxl::read_excel(filename, sheet = X))
if(!tibble) x <- lapply(x, as.data.frame)
names(x) <- sheets
x
}
server <- function(input, output) {
getData <- eventReactive(input$actionMerge, {
inFile1 <- input$file1
if (is.null(inFile1)){
return(NULL)
} else {
mydata1= read_excel_allsheets(inFile1$datapath)}
inFile2 <- input$file2
if (is.null(inFile2)){
return(NULL)
} else {
mydata2= read_excel_allsheets(inFile2$datapath)}
wb <- createWorkbook()
#find tabs not in old file
newSheets <- (names(mydata1))[which(!(names(mydata1)) %in% (names(mydata2)))]
if (length(newSheets) > 0){
for (n in newSheets)
{
mydata6 <- bind_rows(mydata1[n])
addWorksheet(wb, sheetName = names(mydata1[n]))
writeData(wb, names(mydata1[n]), mydata6)
}}
for (i in names(mydata1)){
for (j in names(mydata2)){
if (i == j ){
if ((nrow(as.data.frame(mydata1[i]))) == 0 | (nrow(as.data.frame(mydata2[j]))) == 0 )
{
mydata6 <- bind_rows(mydata1[i])
addWorksheet(wb, sheetName = names(mydata1[i]))
writeData(wb, names(mydata1[i]), mydata6)
}
else {
if (ncol(bind_rows(mydata1[i])) == ncol(bind_rows(mydata2[j])) )
{
mydata6 <- bind_rows(mydata1[i])
addWorksheet(wb, sheetName = names(mydata1[i]))
writeData(wb, names(mydata1[i]), mydata6)
}
else {
# validate(
# column_mismatch(mydata1[i], mydata2[j])
# )
drop_in_key <- c("Earliest data creation time", "Latest data update time", "Timestamp of last save in clinical views", "Date time value from the source file name",
"Lowest Date of Rec, Pg, Inst or Subj", "Record Minimum Created Datetime Stamp", "Record Maximum Updated Datetime Stamp", "Accessible to Jreview Timestamp")
mydatax0 = bind_rows(mydata1[i])
mydatax = bind_rows(mydata1[i])[,!(names(bind_rows(mydata1[i])) %in% drop_in_key)]
mydatanew <- mydatax %>% unite(col="Key", 1:(ncol(mydatax)-1), sep=";", remove=FALSE)
mydatanew$Newflag <- "New"
mydatanew0 = mydatanew %>% select(Key, Newflag)
mydatanew1 = bind_cols(mydatanew0,mydatax0)
mydatay0 = bind_rows(mydata2[j])
mydatay = bind_rows(mydata2[j])[,!(names(bind_rows(mydata2[j])) %in% drop_in_key)]
mydataold <- mydatay %>% unite(col="Key", 1:(ncol(mydatay)-1), sep=";", remove=FALSE)
mydataold$Oldflag <- "Old"
mydataold0 <- mydataold %>% select(Oldflag, Key)
mydataold1 <- bind_cols(mydataold0,mydatay0)
mydataold2 = select(mydataold1, Key, Oldflag, (ncol(bind_rows(mydata1[i]))+3):((ncol(mydataold1))))
mydata3 <- merge(x=mydatanew0, y=mydataold2, by="Key", all=TRUE)
mydata4 <- subset(mydata3, Newflag == "New")
mydata5 <- merge(x=mydatanew1, y=mydata4, by="Key", all.y=TRUE)
drop <- c("Key", "Newflag.x", "Oldflag", "Newflag.y")
mydata6 = mydata5[,!(names(mydata5) %in% drop)]
addWorksheet(wb, sheetName = names(mydata1[i]))
writeData(wb, names(mydata1[i]), mydata6)
}}}
else
NULL
}
}
saveWorkbook(wb, file = "aaa.xlsx" , overwrite = TRUE)
})
output$downloadData <- downloadHandler(
filename = function() {
paste0(input$file2, ".xlsx")
},
content = function(file) {
file.copy("aaa.xlsx", file)
})
}
shinyApp(ui = ui, server = server)```
Here's a toy shiny app that provides a solution that is safe for concurrent users. All operations are done on either (a) temporary files that shiny controls, or (b) in the directory of one of these temp files, using tempfile to create the new filename. Both of those assure new-file uniqueness, so no filename collisions. (I believe shiny's method is temporary directories under a temp-directory, at least that's what I'm seeing in my dev env here. So ... seemingly robust.)
The some_magic_function function is mostly because I didn't want to generate an example with openxlsx and sample datas and such, mostly my laziness. For your code, remove all of the if (runif... within the tryCatch and replace with whatever you need, ensuring your code ends by returning the filename with the new data (or updated) data.
... but keep the tryCatch! It will ensure that the function always returns "something". If all code succeeds, then the function will return the filename with new/updated data. If something goes wrong, it returns a class "error" string that can be used to communicate to the user (or otherwise react/recover).
Last thing, though it's just icing on my cupcake here: I use the shinyjs package to disable the 'merge' and 'download' buttons until there is valid data. Frankly, once the two file-selection inputs have something set, the "merge" button will likely never be disabled. However, if there's ever a problem during the merge/update, then the download button will be disabled (until a merge/update happens without error).
library(shiny)
library(shinyjs)
# a naive function that just concatenates the files, first removing
# the header row from the second file
some_magic_function <- function(f1, f2) {
# put the output file in the same directory as 'f2'
d <- dirname(f2)
if (!length(d)) d <- "."
output_file <- tempfile(tmpdir = d, fileext = paste0(".", tools::file_ext(f2)))
tryCatch({
if (runif(1) < 0.2) {
# purely for StackOverflow demonstration
stop("Something went wrong")
} else {
# add your stuff here (and remove the runif if/else)
writeLines(c(readLines(f1), readLines(f2)[-1]), output_file)
output_file # you must return this filename
}
}, error = function(e) e)
# implicitly returning the output_file or an error (text with class 'error')
}
shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
titlePanel("Tool"),
sidebarLayout(
sidebarPanel(
fileInput("file1", label = "File #1", multiple = FALSE, placeholder = "No file selected"),
fileInput("file2", label = "File #2", multiple = FALSE, placeholder = "No file selected"),
actionButton("btn", label = "Merge uploaded files"),
hr(),
downloadButton("dnld", "Download merged file")
),
mainPanel(
tableOutput("tbl"),
hr(),
verbatimTextOutput("bigtext")
)
)
),
server = function(input, output, session) {
# start with neither button enabled
for (el in c("btn", "dnld")) shinyjs::disable(el)
# disable the 'merge' button until both files are set
observeEvent({
input$file1
input$file2
}, {
req(input$file1, input$file2)
shinyjs::toggleState("btn", isTRUE(file.exists(input$file1$datapath) && file.exists(input$file2$datapath)))
})
# this is the "workhorse" of the shiny app
newfilename <- eventReactive(input$btn, {
req(input$file1, input$file2)
some_magic_function(input$file1$datapath, input$file2$datapath)
})
# prevent the download handler from being used if the new file does not exist
observeEvent(newfilename(), {
cond <- !is.null(newfilename()) &&
!inherits(newfilename(), "error") &&
file.exists(newfilename())
shinyjs::toggleState("dnld", cond)
})
output$dnld <- downloadHandler(
filename = function() paste0("merged_", input$file2),
content = function(f) {
file.copy(newfilename(), f)
}
)
# some sample output, for fun
output$tbl <- renderTable({
req(newfilename(),
!inherits(newfilename(), "error"),
file.exists(newfilename()))
read.csv(newfilename(), nrows = 10, stringsAsFactors = FALSE)
})
output$bigtext <- renderText({
if (inherits(newfilename(), "error")) {
# if we get here then there was a problem
as.character(newfilename())
} else "(No problem)"
})
}
)
Notes:
shiny::req is supposed to ensure the data has something useful and "truthy" in it (see shiny::isTruthy). Normally it is good with detecting nulls, NA, empty variables, etc ... but it "passes" something that has class "error", perhaps counter-intuitive. That's why I had to be a little more explicit with conditions in some of the reactive blocks.
One impetus for having the merge/update functionality within an external not-shiny-requiring function (some_magic_function here) is that it facilitates testing of the merge functionality before adding the shiny scaffolding. It's difficult to test basic functionality when one is required to interact with a browser for every debugging step of basic functionality.
Below is my code. It might seem a bit long but actually it's a VERY simple app.
The user is supposed to upload a tiny data frame (x.csv if you are in the US or x_Europe.csv if you are in Europe). Then the user should click on the button to start calculations. And then at the end the user should be able to download the results of those calculations as a data frame.
My problem: after I upload the file, when I click on the 'do_it' action button - nothing happens. I can see it because nothing is being printed to my console. WHY? After all, my function 'main_calc' should be eventReactive to input$do_it? Why do all the calculations inside main_calc start happening ONLY after the user tries to download the results?
Important: It is important to me to keep the 'Data' function separately from main_calc.
Thank you very much!
First, generate one of these 2 files in your working directory:
# generate file 'x.csv' to read in later in the app:
write.csv(data.frame(a = 1:4, b = 2:5), "x.csv", row.names = F) # US file
write.csv2(data.frame(a = 1:4, b = 2:5), "x_Europe.csv", row.names = F)
This is the code for the shiny app:
library(shiny)
ui <- fluidPage(
# User should upload file x here:
fileInput("file_x", label = h5("Upload file 'x.csv'!")),
br(),
actionButton("do_it", "Click Here First:"),
br(),
br(),
textInput("user_filename","Save your file as:", value = "My file x"),
downloadButton('file_down',"Save the output File:")
)
server <- function(input, output, session) {
#----------------------------------------------------------------------
# Function to read in either European (csv2) or American (csv) input:
#----------------------------------------------------------------------
ReadFile <- function(pathtofile, withheader = TRUE){
test <- readLines(pathtofile, n = 1)
if (length(strsplit(test, split = ";")[[1]]) > 1) {
print("Reading European CSV file")
outlist <- list(myinput = read.csv2(pathtofile, header = TRUE),
europe.file = 1)
} else {
print("Reading US CSV file")
outlist <- list(myinput = read.csv(pathtofile, header = TRUE),
europe.file = 0)
}
return(outlist)
}
#----------------------------------------------------------------------
# Data-related - getting the input file
#----------------------------------------------------------------------
Data <- reactive({
print("Starting reactive function 'Data'")
# Input file:
infile_x <- input$file_x
myx <- ReadFile(infile_x$datapath)$myinput
# European file?
europe <- ReadFile(infile_x$datapath)$europe.file
print("Finishing reactive function 'Data'")
return(list(data = myx, europe = europe))
})
#----------------------------------------------------------------------
# Main function that should read in the input and 'calculate' stuff
# after the users clicks on the button 'do_it' - takes about 20 sec
#----------------------------------------------------------------------
main_calc <- eventReactive(input$do_it, {
req(input$file_x)
# Reading in the input file:
x <- Data()$data
print("Done reading in the data inside main_calc")
# Running useless calculations - just to kill time:
myvector <- matrix(unlist(x), ncol = 1, nrow = 1000)
print("Starting calculations")
for (i in seq_len(10)) {
set.seed(12)
mymatr <- matrix(abs(rnorm(1000000)), nrow = 1000)
temp <- solve(mymatr) %*% myvector
}
print("Finished calculations")
# Creating a new file:
y <- temp
result = list(x = x, y = y)
print("End of eventReactive function main_calc.")
return(result)
}) # end of main_calc
#----------------------------------------------------------------------
# The user should be able to save the output of main_calc as a csv file
# using a string s/he specified for the file name:
#----------------------------------------------------------------------
output$file_down <- downloadHandler(
filename = function() {
paste0(input$user_filename, " ", Sys.Date(), ".csv")
},
content = function(file) {
print("Europe Flag is:")
print(Data()$europe)
if (Data()$europe == 1) {
x_out <- main_calc()$x
print("Dimensions of x in downloadHandler are:")
print(dim(x_out))
write.csv2(x_out,
file,
row.names = FALSE)
} else {
x_out <- main_calc()$x
print("Dimensions of x in downloadHandler are:")
print(dim(x_out))
write.csv(x_out,
file,
row.names = FALSE)
}
}
)
} # end of server code
shinyApp(ui, server)
Below is the solution - based on MrFlick's suggestions:
# generate file 'x.csv' to read in later in the app:
# write.csv(data.frame(a = 1:4, b = 2:5), "x.csv", row.names = F)
# write.csv2(data.frame(a = 1:4, b = 2:5), "x_Europe.csv", row.names = F)
library(shiny)
library(shinyjs)
ui <- fluidPage(
# User should upload file x here:
fileInput("file_x", label = h5("Upload file 'x.csv'!")),
br(),
actionButton("do_it", "Click Here First:"),
br(),
br(),
textInput("user_filename","Save your file as:", value = "My file x"),
downloadButton('file_down',"Save the output File:")
)
server <- function(input, output, session) {
#----------------------------------------------------------------------
# Function to read in either European (csv2) or American (csv) input:
#----------------------------------------------------------------------
ReadFile <- function(pathtofile, withheader = TRUE){
test <- readLines(pathtofile, n = 1)
if (length(strsplit(test, split = ";")[[1]]) > 1) {
print("Reading European CSV file")
outlist <- list(myinput = read.csv2(pathtofile, header = TRUE),
europe.file = 1)
} else {
print("Reading US CSV file")
outlist <- list(myinput = read.csv(pathtofile, header = TRUE),
europe.file = 0)
}
return(outlist)
}
#----------------------------------------------------------------------
# Data-related - getting the input file
#----------------------------------------------------------------------
Data <- reactive({
print("Starting reactive function Data")
# Input file:
infile_x <- input$file_x
myx <- ReadFile(infile_x$datapath)$myinput
# European file?
europe <- ReadFile(infile_x$datapath)$europe.file
print("Finishing reactive function 'Data'")
return(list(data = myx, europe = europe))
})
#----------------------------------------------------------------------
# Main function that should read in the input and 'calculate' stuff
# after the users clicks on the button 'do_it' - takes about 20 sec
#----------------------------------------------------------------------
# Creating reactive Values:
forout_reactive <- reactiveValues()
observeEvent(input$do_it, {
print("STARTING observeEvent")
req(input$file_x)
# Reading in the input file:
x <- Data()$data
print("Done reading in the data inside observeEvent")
# Running useless calculations - just to kill time:
myvector <- matrix(unlist(x), ncol = 1, nrow = 1000)
print("Starting calculations")
for (i in seq_len(10)) {
set.seed(12)
mymatr <- matrix(abs(rnorm(1000000)), nrow = 1000)
temp <- solve(mymatr) %*% myvector
} # takes about 22 sec on a laptop
print("Finished calculations")
# Creating a new file:
y <- temp
forout_reactive$x = x
forout_reactive$y = y
print("End of observeEvent")
}) # end of main_calc
#----------------------------------------------------------------------
# The user should be able to save the output of main_calc as a csv file
# using a string s/he specified for the file name:
#----------------------------------------------------------------------
output$file_down <- downloadHandler(
filename = function() {
paste0(input$user_filename, " ", Sys.Date(), ".csv")
},
content = function(file) {
print("Europe Flag is:")
print(Data()$europe)
if (Data()$europe == 1) {
y_out <- forout_reactive$y
print("Dimensions of y in downloadHandler are:")
print(dim(y_out))
write.csv2(y_out,
file,
row.names = FALSE)
} else {
y_out <- forout_reactive$y
print("Dimensions of y in downloadHandler are:")
print(dim(y_out))
write.csv(y_out,
file,
row.names = FALSE)
}
}
)
} # end of server code
shinyApp(ui, server)
Here is a simple app that may help elucidate how eventReactive() works:
library(shiny)
run_data <- function() {
paste0("Random number generated in eventReactive: ", runif(1))
}
ui <- basicPage(
actionButton("run1", "Invalidate eventReative()"),
actionButton("run2", "Trigger observeEvent()"),
verbatimTextOutput("data")
)
server <- function(input, output, session) {
# Initialize reactiveValues list
# to use inside observeEvent()
rv <- reactiveValues(data = NULL)
# This eventReactive() doesn't run when run1 button is
# clicked. Rather, it becomes invalidated. Only when
# data() (the reactive being returned) is actually
# called, does the expression inside actually run.
# If eventReactive is not invalidated by clicking run1
# then even if data() is called, it still won't run.
data <- eventReactive(input$run1, {
showNotification("eventReactive() triggered...")
run_data()
})
# Every time run2 button is clicked,
# this observeEvent is triggered and
# will run. If run1 is clicked before run2,
# thus invalidating the eventReactive
# that produces data(), then data() will
# contain the output of run_data() and
# rv$data will be assigned this value.
observeEvent(input$run2, {
showNotification("observeEvent() triggered")
rv$data <- data()
})
# Renders the text found in rv$data
output$data <- renderText({
rv$data
})
}
shinyApp(ui, server)
In this example, run1 invalidates the eventReactive(), and run2 triggers the observeEvent() expression. In order for the data (in this case just a random number) to print, run1 must be clicked prior to run2.
The key takeaway is that the input(s) (buttons) that eventReactive() listens to don't trigger eventReactive(). Instead, they invalidate eventReactive() such that when the output from eventReactive() is required, then the expression inside eventReactive() will run. If it is not invalidated or the output is not needed, it will not run.
I have a big shiny app with about 60 different inputs and it's still growing. Since I use this program a lot, I wanted the settings to be stored until next time I run the app. I made a csv-file that looks something like this:
input,value
input_a,10
input_b,#FFF000
input_c,hide
input_d,65400
I load the csv-file in ui.R and server.R with (not sure why I have to load it two times...)
config <- data.frame(lapply(read.csv(".//config.csv"), as.character), stringsAsFactors = FALSE)
and have inputs like this
sliderInput(
"input_a",
"Number of cats:",
min = 1,max = 50,
value = config[config$input %in% "input_a", "value"]
)
In server.R, I let input changes replace the value in the table and also save the table to the file
observe({
config[config$input %in% "input_a", "value"] <- input$input_a
config[config$input %in% "input_b", "value"] <- input$input_b
config[config$input %in% "input_c", "value"] <- input$input_c
config[config$input %in% "input_d", "value"] <- input$input_d
write.table(config, file = ".//config.csv", col.names = TRUE, row.names = FALSE, quote = FALSE, sep = ",")
})
I'm sure there is a better way to do this, I searched and checked the other similar questions, I started with dget and dput, but then decided to have all relevant settings in one simple file. Sorry if I missed the most relevant question when I searched.
What I don't like about this is that the program also saves the table when it loads the program, before I make any input changes.
How can I get rid of that unnecessary save every time I run the program?
I don't understand all the "reactivity" in shiny, it's still a bit to complicated for me, I don't really know anything about R or programming, just trying to optimize my program since it gets slower with every new "feature" I add.
I don't see any problem with keeping settings like that, but there might be a better way, and in anycase I would wrap it in a function like I did here.
And here is how you implement writing only "on exit" though (also please note the session parameter which is often not used):
library(shiny)
settingsdf <- data.frame(input=c("input_a","input_b","input_c"),
value=c(10,"#FF000","hide"),
stringsAsFactors=F)
setSetting <- function(pname,pval){
idx <- which(settingsdf$input==pname)
if (length(idx)==1){
print(pval)
settingsdf[ idx,2] <<- pval
}
}
shinyApp(
ui = fluidPage(
selectInput("region", "Region:", choices = colnames(WorldPhones)),
plotOutput("phonePlot")
),
server = function(input, output, session) {
output$phonePlot <- renderPlot({
if (length(input$region)>0){
setSetting("input_a",input$region)
barplot(WorldPhones[,input$region]*1000,
ylab = "Number of Telephones", xlab = "Year")
}
})
session$onSessionEnded(function() {
write.csv(settingsdf,"settings.csv")
})
},
options = list(height = 500)
)
Note that I am compressing the ui.R and server.R files into a single file which is not normally done but is nicer for these little examples.
This is not perfect code, I don't read the settings in and initialize the variables, and I use the <<- operator, which some people frown on. But it should help you along.
Update
Here is a more complex version that loads and saves the parameters, and encapsulates them for use. It is better, although it probably should use S3 objects...
library(shiny)
# Settings code
settingsdf <- data.frame(input=c("input_a","region"),
value=c(10,"Asia"),stringsAsFactors=F)
setfname <- "settings.csv"
setSetting <- function(pname,pval){
idx <- which(settingsdf$input==pname)
if (length(idx)==1){
settingsdf[ idx,"value"] <<- pval
}
}
getSetting <- function(pname){
idx <- which(settingsdf$input==pname)
if (length(idx)==1){
rv <- settingsdf[ idx,"value"]
return(rv)
} else {
return("")
}
}
readSettings <- function(){
if (file.exists(setfname)){
settingsdf <<- read.csv(setfname,stringsAsFactors=F)
}
}
writeSettings <- function(){
write.csv(settingsdf,setfname,row.names=F)
}
# ShinyApp
shinyApp(
ui = fluidPage(
selectInput("region","Region:", choices = colnames(WorldPhones)),
plotOutput("phonePlot")
),
server = function(input, output, session) {
readSettings()
vlastinput <- getSetting("region")
if (vlastinput!=""){
updateSelectInput(session, "region", selected = vlastinput )
}
output$phonePlot <- renderPlot({
if (length(input$region)>0){
vlastinput <- input$region
setSetting("region",vlastinput)
barplot(WorldPhones[,input$region]*1000,
ylab = "Number of Telephones", xlab = "Year")
}
})
session$onSessionEnded(function() {
writeSettings()
})
},
options = list(height = 500)
)
Yielding: