I want to initialize the download of a file in R Shiny when a button is pressed and do some checks before generating the file.
I've fooled arround with the downloadHandler (https://shiny.rstudio.com/gallery/file-download.html). But I want to catch the event of another button, do some things and checks with the data and when everything went well generate the file and initialize the download without having to press the download button from downloadHandler.
I've implemented most checks for now in the downloadHandler, but it now generates a failed download when some checks aren't fulfilled. I don't like the behavior.
output$downloadData <- downloadHandler(
filename = function() { paste("DATA_EXPORT-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
withProgress(message = 'Export data', value = 0, {
# Number of steps
n <- 3
incProgress(1/n, detail = "Pre checks and get data")
# checks if inputs for get_data are well defined
dataSet <- get_data(blabla)
incProgress(1/n, detail = "Post Proces and check")
incProgress(1/n, detail = "generate flatfile")
write.csv(dataSet, file, row.names = FALSE)
})
}
)
To elaborate my comment, a minimal example:
library(shiny)
library(shinyjs)
# function which checks the data; returns TRUE or FALSE
checkData <- function(dat){
TRUE
}
# function which transforms the data; returns NULL if check not TRUE
processData <- function(dat){
if(checkData(dat)){
# do something with dat
names(dat) <- toupper(names(dat)) # for our example
return(dat)
}else{
return(NULL)
}
}
ui <- fluidPage(
useShinyjs(),
conditionalPanel(
"false", # always hide the download button
downloadButton("downloadData")
),
actionButton("check", "Download")
)
server <- function(input, output, session){
dat <- mtcars
finalData <- reactiveVal() # to store the processed data
observeEvent(input$check, {
if(!is.null(df <- processData(dat))){
finalData(df)
runjs("$('#downloadData')[0].click();")
}else{
# something which throws an alert message "invalid data"
# (eg with shinyBS::createAlert or shinyWidgets::sendSweetAlert)
}
})
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
write.csv(finalData(), file)
}
)
}
shinyApp(ui, server)
Related
I have a download handler (say 10 times) that needs to be put in shiny as shown below. So instead of writing it 10 times, I have written a function so that after passing 3 parameters, the render functions should get executed
Button 1
output$downloadData_sec1 <- downloadHandler(
filename = function() {
paste(str_replace("title",pattern = " ", "_"), Sys.Date(), ".csv", sep="_")
},
content = function(file) {
write.csv(display_data$asd, file)
}
)
Button 2
output$downloadData_sec2 <- downloadHandler(
filename = function() {
paste(str_replace("title2",pattern = " ", "_"), Sys.Date(), ".csv", sep="_")
},
content = function(file) {
write.csv(display_data$asd2, file)
}
)
function
download_function <- function (id, title, data){
output[["id"]] <- downloadHandler(
filename = function() {
paste(str_replace(title,pattern = " ", "_"), Sys.Date(), ".csv", sep="_")
},
content = function(file) {
write.csv(display_data[["data"]], file)
}
)
}
But looks like there is some error here . I get output not defined
Can anyone help me here?
Here's MWE showing how to implement the your function as a Shiny module. In the interests of brevity, I've limited myself to three instances of the module rather than ten. I've also generated random data within each instance of the module. You can make the obvious changes for your real use case.
Next time, please provide a MRE.
library(shiny)
# Download UI
demoUI <- function(id) {
ns <- NS(id)
wellPanel(
id,
tableOutput(ns("data")),
downloadButton(ns("downloadData"), "Download")
)
}
# Download server
demoServer <- function(id, title) {
moduleServer(
id,
function(input, output, session) {
# Generate some random data
d <- data.frame(X=runif(5), y=rnorm(5))
output$data <- renderTable({ d })
output$downloadData <- downloadHandler(
filename = function() {
paste(stringr::str_replace(title, pattern = " ", "_"), Sys.Date(), ".csv", sep="_")
},
content = function(file) {
write.csv(d, file)
}
)
}
)
}
# Main UI
ui <- function() {
fluidPage(
demoUI("demo1"),
demoUI("demo2"),
demoUI("demo3")
)
}
# Main server
server <- function(input, output, session) {
demoServer("demo1", "Random title")
demoServer("demo2", "Another title")
demoServer("demo3", "Something else")
}
shinyApp(ui, server)
Here's a screenshot of (part of) the app:
And of part of my Downloads folder after clicking each Download button and accepting the default filename:
And, finally, the contents of one of the CSV files:
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.
So I want to have a Shiny page which:
A) Allows the user to upload a .xls file;
B) Offers that file back to the user for download as a .csv file;
C) Prints the head of the file in the Shiny app to ensure that it was properly read.
Here is the code I am using:
# Want to read xls files with readxl package
library(readxl)
library(shiny)
## Only run examples in interactive R sessions
if (interactive()) {
ui <- fluidPage(
fileInput("file1", "Choose File", accept = ".xls"),
tags$hr(),
uiOutput("downloader"),
htmlOutput("confirmText", container = tags$h3),
tableOutput("listContents")
)
server <- function(input, output) {
theOutput <- reactiveValues(temp = NULL, df = NULL, msg = NULL, fn = NULL)
observeEvent(input$file1, {
theOutput$fn <- paste('data-', Sys.Date(), '.csv', sep='')
theOutput$temp <- read_xls(input$file1$datapath)
theOutput$msg <- paste("File Contents:")
theOutput$df <- write.csv(theOutput$temp,
file = theOutput$fn,
row.names = FALSE)
})
output$confirmText <- renderText({
theOutput$msg
})
output$listContents <- renderTable({
head(theOutput$temp)
})
output$downloader <- renderUI({
if(!is.null(input$file1)) {
downloadButton("theDownload", label = "Download")
}
})
output$theDownload <- downloadHandler(
filename = theOutput$fn,
content = theOutput$df
)
}
shinyApp(ui, server)
}
The Shiny page renders correctly, it accepts the upload with no problems, it prints out the head of the .csv with no problems, and it creates a properly formatted "data-{today's date}.csv" file in the same directory as the app.R file.
Problem is, when I hit the download button I get the error message:
Warning: Error in download$func: attempt to apply non-function
[No stack trace available]
Can someone tell me what I am doing wrong?
Thanks to the comments above, this is the solution I found (with my comments added, to show where the code changed):
library(readxl)
library(shiny)
if (interactive()) {
ui <- fluidPage(
fileInput("file1", "Choose File", accept = ".xls"),
tags$hr(),
uiOutput("downloader"),
htmlOutput("confirmText", container = tags$h3),
tableOutput("listContents")
)
server <- function(input, output) {
theOutput <- reactiveValues(temp = NULL, msg = NULL)
observeEvent(input$file1, {
# Do not try to automate filename and the write.csv output here!
theOutput$temp <- read_xls(input$file1$datapath)
theOutput$msg <- paste("File Contents:")
})
output$confirmText <- renderText({
theOutput$msg
})
output$listContents <- renderTable({
head(theOutput$temp)
})
output$downloader <- renderUI({
if(!is.null(input$file1)) {
downloadButton("theDownload", label = "Download")
}
})
output$theDownload <- downloadHandler(
# Filename and content need to be defined as functions
# (even if, as with filename here, there are no inputs to those functions)
filename = function() {paste('data-', Sys.Date(), '.csv', sep='')},
content = function(theFile) {write.csv(theOutput$temp, theFile, row.names = FALSE)}
) }
shinyApp(ui, server) }
The fact that content takes an argument (named here "theFile"), which is not called anywhere else, is what was throwing me off.
Is it possible to set reactiveValues inside the content part of the downloadHandler? I tried it and don't understand the behavior.
A simple example could be a counter showing how often the download button has been clicked:
library(shiny)
ui <- fluidPage(
downloadButton("downloadData", "Download"),
textOutput("nDownloads"),
actionButton("trig", "get number")
)
server <- function(input, output) {
# Our dataset
data <- mtcars
r.nDownloads <- reactiveValues(n=0)
output$nDownloads <- renderText({
input$trig
paste("number of downloads:", r.nDownloads$n)
})
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
r.nDownloads$n <- r.nDownloads$n + 1
write.csv(data, file)
}
)
}
shinyApp(ui, server)
If the download button is clicked, the textOutput is grayed out, but not updated. I added an action button as a trigger to force the renderText to be updated. Surprisingly (at least to me) that works: the correct number is shown.
So, somehow the reactiveValue is changed by the downloadHandler, but its dependencies are only invalidated, not updated.
Of course, the proper way to do it would be making the "data"-object reactive and doing the counting there. But I'm curious how the described behavior can be explained.
EDIT:
OK, now I get really confused: I tried what I mentioned above: making "data" reactive and doing the counting there. This could not be simple counting of downloads anymore, because the data-reactive gets only recalculated if it's invalid.
Here is an example with an additional input for the invalidation of "data":
library(shiny)
ui <- fluidPage(
numericInput("nRows", label = "nRows", min=1, max=32, value=15),
downloadButton("downloadData", "Download"),
textOutput("nDownloads")
)
server <- function(input, output) {
r.nDownloads <- reactiveValues(n=0)
# Our dataset
data <- reactive({
isolate({
r.nDownloads$n <- r.nDownloads$n + 1
})
mtcars[1:input$nRows,]
})
output$nDownloads <- renderText({
paste("number of downloads:", r.nDownloads$n)
})
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep="")
},
content = function(file) {
write.csv(data(), file)
}
)
}
shinyApp(ui, server)
But still, I see a similar behavior: Clicking the download button grays the text out, changing "nRows" makes the expected number of downloads (which is now downloads after a change in nRows ;-)) to show up.
Now it gets an actual problem for me: In my real app, a rather complex Excel file can be downloaded. While preparing and formatting the Excel file there can occur events that should lead to some reaction of the app. That's why the download should trigger something. The alternative I can see is, to prepare the Excel file before the user clicks on download (what I would like to avoid, because this can take a few seconds depending on the complexity of the file/formatting).
Am I missing something obvious? If not, I'd appreciate any ideas, how the download event can trigger something in the rest of the app.
The solution is to remove the isolation of the reactiveValues as this prevents the counter from being updated until the numericInput is triggered. This is because data() is dependent on input$nrows.
library(shiny)
ui <- fluidPage(
numericInput("nRows", label = "nRows", min = 1, max = 32, value = 15),
downloadButton("downloadData", "Download"),
textOutput("nDownloads")
)
server <- function(input, output) {
r.nDownloads <- reactiveValues(n = 0)
# Our dataset
data <- reactive({
r.nDownloads$n <- r.nDownloads$n + 1
mtcars[1:input$nRows,]
})
output$nDownloads <- renderText({
paste("number of downloads:", r.nDownloads$n)
})
output$downloadData <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".csv", sep = "")
},
content = function(file) {
write.csv(data(), file)
}
)
}
shinyApp(ui, server)
With regards to the deeper problem, it would be inefficient to constantly prepare a complex Excel file if there is no guarantee that the user would download the file. What you can try to do is:
Keep your data in a reactive method (e.g. data()).
Write a method to prep your data for downloading (e.g. prepExcel(data)) which returns your prepped data.
Pass (1) and (2) into the content of the downloadHandler() like this: write_xx(prepExcel(data())) or pipe the data into the write_xx function like this data() %>% prepExcel() %>% write_xx() where xx is the method used to output your final file e.g. write_xlsx or write_csv etc.
I hope this helps.
I have created a shiny app that uses session$clientData to get parameter values to the server. It works great, however, I would also like to be able to initiate a download through the url, e.g:
localhost:8100/?plot=a&title=mytitle&download=1
and then in server.R, something like:
if(session$clientData$download == "1"){
download()
}
Hence, is it possible to initiate the downloadHandler() in server.R?
Thanks!
I am not sure I have correctly understood what you are trying to do. What I have understood is that you would like a download to be initiated when the query string download=1 is present in the url. You could do this by injecting some javascript to open the link when the required query string is detected. There will be some problems however.
Your browser will most likely block the pop up. You will need to wait a sufficient length of time before you fire the code (I have chosen 5 seconds).
require(shiny)
runApp(list(
ui = bootstrapPage(
tags$head(tags$script(HTML('
Shiny.addCustomMessageHandler("jsCode",
function(message) {
eval(message.value);
}
);
'))),
downloadLink('downloadData', 'Download'),
verbatimTextOutput("summary")
),
server = function(input, output, session) {
data <- seq(100)
output$downloadData <- downloadHandler(
filename = function() {
paste('data-', Sys.Date(), '.csv', sep='')
},
content = function(file) {
write.csv(data, file)
}
)
output$summary <- renderText({
cnames <- names(session$clientData)
allvalues <- lapply(cnames, function(name) {
item <- session$clientData[[name]]
if (is.list(item)) {
list_to_string(item, name)
} else {
paste(name, item, sep=" = ")
}
})
paste(allvalues, collapse = "\n")
})
observe({
query <- parseQueryString(session$clientData$url_search)
if(!is.null(query$download)){
if(query$download == 1){
jsinject <- "setTimeout(function(){window.open($('#downloadData').attr('href'))}, 5000);"
session$sendCustomMessage(type = 'jsCode', list(value = jsinject))
}
}
})
}
))