Initiate downloadHandler with clientData in Shiny - r

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))
}
}
})
}
))

Related

render output functions inside the fucnctions

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:

R shiny to download files by selecting the checkbox

There is this piece of code in which basically from UI page in which I want to select the file names for through checkbox and after selecting those, then clicking on download button selected files will get downloaded. I am stuck at UI i am unable to get those checkboxes on UI.
its showing the output as
[object] [Object]
the code is below -
ui <- fluidPage(
verbatimTextOutput("links_list")
)
server <- function(input, output, session) {
get.files <- reactive({
list.files("/Users/harshmeetsingh/Downloads/")
})
obsList <- list()
output$links_list <- renderUI({
lapply(as.list(1:length(get.files())), function(i)
{
btName <- get.files()[i]
print(btName)
# creates an observer only if it doesn't already exists
if (is.null(obsList[[btName]])) {
obsList[[btName]] <<- btName
}
fluidRow(checkboxInput(btName, get.files()[i]) )
})
})
output$downloadzip<-downloadHandler(
filename = function(){
paste0("Extract.zip")
},
content = function(file){
files <- NULL;
for (i in 1:length(obsList)){
if(input[[obsList[[i]]]])
files <- c(paste("output_file/",obsList[[i]],sep=""),files)
}
#create the zip file
zip(file,files)
},
contentType = "application/zip"
)
tempText <- eventReactive({input$TempTest},{
l<-c()
for (i in 1:length(obsList)){
if(input[[obsList[[i]]]])
l<-c(l,paste("output_file/",obsList[[i]],sep=""))
}
return(paste(l) )
},
ignoreInit = TRUE)
output$Temp <- renderPrint({ tempText()})
}
shinyApp(ui=ui,server=server)
We can use checkboxGroupInput() to select all the files. input$files_chosen will be a list with all the filenames selected.
Notice that this app is showing the files in the home directory. This can be modified changing the path supplied in setwd().
app:
library(shiny)
#to use relative paths inside zip function
setwd('~')
ui <- fluidPage(
downloadButton('downloadzip'),
uiOutput("links_list")
)
server <- function(input, output, session) {
get.files <- reactive({
list.files()
})
output$links_list <- renderUI({checkboxGroupInput(inputId = 'files_chosen',
label = 'Choose Files',
choices = get.files())
})
output$downloadzip <- downloadHandler(
filename = function(){
"Extract.zip"
},
content = function(file){
#create the paths to look for the files.
files <- input$files_chosen
#create the zip file
zip(zipfile = file, files = files)
},
contentType = "application/zip"
)
}
shinyApp(ui=ui,server=server)

Why is my check box button non responsive in shinny app?

So I have this shiny app which includes a checkbox button:
library(bold)
library(stringr)
library(readr)
library(shiny)
library(shinyWidgets)
grades2<-function(groups,inputz,coordz){
taxon<-bold_seqspec(taxon=groups, format = "tsv")
taxon2<-taxon[taxon$species_name!=""|is.na(taxon$species_name),]
taxon2<-taxon2[!(taxon2$bin_uri == "" | is.na(taxon2$bin_uri)), ]
taxon2$base_number=str_count(taxon2$nucleotides, pattern="[A-Z]")
taxon2<-taxon2[taxon2$base_number>=inputz,]
if (coordz==TRUE){
taxon2<-taxon2[!(is.na(taxon2$lat)) | taxon2$country!="",]
}else{
taxon2<-taxon2
}
assign('taxon2',taxon2,envir=.GlobalEnv)
}
ui <- navbarPage(title=tags$h3("APP"),tabPanel(column(12,align="center",tags$h4("Download"),tags$br(),
sliderInput("seqsize", "Mininum number of base pairs for sequences in reference library:",min = 0, max = 1000, value = 500),textOutput("SliderText"),
checkboxInput("rmvpaises", "Remove records without data on country of origin or latitude", TRUE),
textInputAddon(inputId="taxa2",addon=icon("search"),width="500px",label=tags$h5(tags$strong("Enter the name of the taxonomic group or groups separated by commas, without spaces:")),placeholder="Example: Carnivora,Ursidae,Artiodactyla,Soricomorpha"),
downloadButton("downloadData_2","Download"))))
server <- function(input, output){
#sliderValues <- reactive({as.integer(input$seqsize)})
#output$values <- renderText({
# sliderValues()
#})
taxaInput_2 <- reactive({grades2(unlist(strsplit(input$taxa2, ",")),as.integer(input$seqsize),input$rmvpaises)})
output$downloadData_2 <- downloadHandler(
filename = function() {
paste(input$taxa2,sep_out=",", ".tsv")
},
content = function(file) {
shiny::withProgress(
value=10,
{
shiny::incProgress(10/10)
write_tsv(taxaInput_2(), file)
}
)
}
)
output$value <- renderText({ input$rmvpaises })
}
shinyApp(ui=ui,server=server)
For some reason while using the app, the check box is non-responsive. It doesn't change.
The input of the check box is being used in the initial function "grades2" and it is the "coordz" argument.
Thank you so much for any answer
You're missing the non-optional argument title for tabPanel. Consequently, it's using the column UI element as the title for the tab which I'm assuming is doing weird stuff with the z-index.
You need an observer to update the checkboxInput on the server side. The checkbox works fine in this code
grades2<-function(groups,inputz,coordz){
taxon<-bold_seqspec(taxon=groups, format = "tsv")
taxon2<-taxon[taxon$species_name!=""|is.na(taxon$species_name),]
taxon2<-taxon2[!(taxon2$bin_uri == "" | is.na(taxon2$bin_uri)), ]
taxon2$base_number=str_count(taxon2$nucleotides, pattern="[A-Z]")
taxon2<-taxon2[taxon2$base_number>=inputz,]
if (coordz) {
taxon2<-taxon2[!(is.na(taxon2$lat)) | taxon2$country!="",]
}else{
taxon2<-taxon2
}
assign('taxon2',taxon2,envir=.GlobalEnv)
}
ui <- navbarPage(title=tags$h3("APP"),tabPanel(value="Panel1" , column(12,align="center",tags$h4("Download"),tags$br(),
sliderInput("seqsize", "Mininum number of base pairs for sequences in reference library:",min = 0, max = 1000, value = 500),textOutput("SliderText"),
checkboxInput("rmvpaises", "Remove records without data on country of origin or latitude", TRUE),
textInputAddon(inputId="taxa2",addon=icon("search"),width="500px",label=tags$h5(tags$strong("Enter the name of the taxonomic group or groups separated by commas, without spaces:")),placeholder="Example: Carnivora,Ursidae,Artiodactyla,Soricomorpha"),
downloadButton("downloadData_2","Download"))))
server <- function(input, output, session){
#sliderValues <- reactive({as.integer(input$seqsize)})
#output$values <- renderText({
# sliderValues()
#})
observe({
updateCheckboxInput(session, "rmvpaises", value=input$rmvpaises)
})
taxaInput_2 <- reactive({grades2(unlist(strsplit(input$taxa2, ",")),as.integer(input$seqsize),input$rmvpaises)})
output$downloadData_2 <- downloadHandler(
filename = function() {
paste(input$taxa2,sep_out=",", ".tsv")
},
content = function(file) {
shiny::withProgress(
value=10,
{
shiny::incProgress(10/10)
write_tsv(taxaInput_2(), file)
}
)
}
)
output$value <- renderText({ input$rmvpaises })
}
shinyApp(ui=ui,server=server)

R Shiny automatically start download

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)

How to edit an uploaded data in rshiny

Here are the requirements.
1)I need to browse and upload an excel file (with package readxl), which is used to arrive at some calculations which I need to display in shiny window as a different table output
2) Manually edit some data in the uploaded file and it should automatically reflect in the results displayed
3) We should be able to download the edited file.
I have written so far. I have columns ID, exposure and frequency in input data. For each ID I need to calculate a variable using corresponding exposure and frequency which would be displayed. I need to manually edit frequency and Exposure using ID ( which is unique ). I have added an "update" button. But change is not permanent. It goes back as soon as I click update button once more
library(shiny)
ui = fluidPage(
titlePanel("HEllo world"),
sidebarLayout(
sidebarPanel(
fileInput('file1', 'Choose xlsx file',
accept = c(".xlsx")),
actionButton("go", "update"),
numericInput('NewVal', 'Enter new Frequency',NULL),
numericInput('NewExp', 'Enter new Exposure',NULL)),
mainPanel(
textInput('ID', 'Enter ID'),
dataTableOutput('contents')
)))
server = function(input,output){
ef <- eventReactive(input$go, {
infile <- input$file1
if(is.null(infile))
return(NULL)
file.rename(infile$datapath,paste(infile$datapath, ".xlsx", sep=""))
data<-read_excel(paste(infile$datapath, ".xlsx", sep=""), 1)
if(input$ID!="" && input$go>0){
for( i in 1:nrow(data)){
if( input$ID == data$'ID'[i]){
if(!is.na(input$NewVal)){
data$' Frequency'[i] <- input$NewVal
}
if(!is.na(input$NewExp)){
data$'Exposure'[i] <- input$NewExp
}
}}}
data
}, ignoreNULL = FALSE)
output$contents <- renderDataTable({ef()})}
shinyApp(ui,server)
UPDATE!:As per one answer, I have made some changes to my code. The new code seems to be working fine. Here is the working code, for anyone who might need help with the same issue.
ui = fluidPage(
titlePanel("HEllo world"),
sidebarLayout(
sidebarPanel(
fileInput('file1', 'Choose xlsx file',
accept = c(".xlsx")),
actionButton("go", "update"),
numericInput('NewVal', 'Enter new Frequency',NULL),
numericInput('NewExp', 'Enter new Exposure',NULL)),
mainPanel(
textInput('ID', 'Enter ID'),
tableOutput('contents')
)))
server = function(input,output){
# Reactive value to save input data frame for use elsewhere
original <- reactiveValues()
observeEvent(input$file1, {
theFile <- input$file1
if(is.null(theFile)) {
return(NULL)}
**file.rename(theFile$datapath,paste(theFile$datapath, ".xlsx", sep=""))**
original$oldData <- read_excel(paste(theFile$datapath, ".xlsx", sep = ""), 1)
})
observeEvent(input$go, {
original$newData <- original$oldData
if(input$ID !="") {
for( i in 1:nrow(original$oldData)){
if( input$ID == original$oldData$'ID'[i]){
if(!is.na(input$NewVal)){
original$newData$'Frequency'[i] <- input$NewVal
}
if(!is.na(input$NewExp)){
original$newData$'Exposure'[i] <- input$NewExp
}
}
}
**original$oldData<-original$newData** }
})
output$contents <- renderTable({
if(!is.null(original$newData)) {
original$newData}
else {
original$oldData}
})
}
shinyApp(ui = ui, server = server)
Some of the comments seem to be on the right track of what's going on here. There's several solutions that could be used, but I'll just share what's most intuitive to me. Also, I'll only be changing the server function.
server = function(input,output){
# Reactive value to save input data frame for use elsewhere
original <- reactiveValues()
observeEvent(input$file1, {
theFile <- input$file1
if(is.null(theFile)) {return(NULL)}
original$oldData <- read_excel(paste(theFile$datapath, ".xlsx", sep = ""), 1)
})
observeEvent(input$goButton2, {
original$newData <- original$oldData
if(input$ID !="") {
for( i in 1:nrow(data)){
if( input$ID == dat$'ID'[i]){
if(!is.na(input$NewVal)){
original$newData$' Frequency'[i] <- input$NewVal
}
if(!is.na(input$NewExp)){
original$newData$'Exposure'[i] <- input$NewExp
}
}
}
}
})
output$contents <- renderDataTable({
if(!is.null(original$newData)) {original$newData}
else {original$oldData}
})
}
This won't change the table output until the go button is clicked. I haven't tested it fully, since I don't have your data, but I believe this should set you on the right track at the bare minimum... I like observe statements, because they cause side effects and seem more open ended than eventReactives or functions.
This only helps with the initial issues of having the correct changes made and continued showing in the output. If this works, it should be fairly easy to add a download function, which saves the file whenever it's updated.
Update 1
The code below should do what you would want it to do. I've added two different capabilities for saving the new data frame. The commented out code saves the data automatically whenever the update button is pressed. The code that's there without comments around it creates a download button for downloading the data. I've also added a line that calculates a new value based off frequency and exposure. Named this column Value in data set. Hope this helps!
#### Example app for Exchange answer
library(shiny)
library(readxl)
ui = fluidPage(
titlePanel("HEllo world"),
sidebarLayout(
sidebarPanel(
fileInput('file1', 'Choose xlsx file',
accept = c(".xlsx")),
actionButton("go", "update"),
numericInput('NewVal', 'Enter new Frequency',NULL),
numericInput('NewExp', 'Enter new Exposure',NULL),
# Download button (goes with download handler below)
# Use if desire is to save at press of button
downloadButton("save", "Download")
),
mainPanel(
textInput('ID', 'Enter ID'),
dataTableOutput('contents')
)
)
)
server = function(input,output){
# Reactive value to save input data frame for use elsewhere
original <- reactiveValues()
observeEvent(input$file1, {
theFile <- input$file1
if(is.null(theFile)) {
original$oldData <- NULL
} else {
original$oldData <- read_excel(theFile$datapath, 1)
}
})
observeEvent(input$go, {
original$newData <- original$oldData
if(input$ID !="") {
for(i in 1:nrow(original$oldData)){
if(input$ID == original$oldData$'ID'[i]){
if(!is.na(input$NewVal)){
original$newData$'Frequency'[i] <- input$NewVal
}
if(!is.na(input$NewExp)){
original$newData$'Exposure'[i] <- input$NewExp
}
### Make sure a column in your data set is named Value for this
# Calculate a new column
original$newData$'Value'[i] <- (original$newData$'Exposure'[i]*
original$newData$'Frequency'[i])
}
}
original$oldData<-original$newData
}
### Use this to automatically save table when update is clicked
# write.csv(original$newData,
# file = #Desired Pathname,
# row.names = FALSE)
})
output$contents <- renderDataTable({
if(!is.null(original$newData)) {
original$newData}
else {
original$oldData
}
})
### Use this code below if desired saving is through download button
# Server code for download button
output$save <- downloadHandler(
filename = function() {
paste0("newData - ", Sys.Date(), ".csv")
},
content = function(con) {
if (!is.null(original$newData)) {
dataSave <- original$newData
} else {
dataSave <- original$oldData
}
con <- ## Desired save location... could just use `getwd()` to
# save to working directory
write.csv(dataSave, con)
}
)
}
shinyApp(ui = ui, server = server)

Resources