Downloading the output from Shiny APP (need some advice) - shiny

I want to download the output of this App which I made but there is an error and when I open the downloaded data it is empty.I make a data set by output$other_val_show and I want to download it. Any advice?
The following code in for the UI section.
library(shiny)
library(quantreg)
library(quantregGrowth)
library(plotly)
library(rsconnect)
library(ggplot2)
library(lattice)
ui = tagList(
tags$head(tags$style(HTML("body{ background: aliceblue; }"))),
navbarPage(title="",
tabPanel("Data Import",
sidebarLayout(sidebarPanel( fileInput("file","Upload your CSV",multiple = FALSE),
tags$hr(),
h5(helpText("Select the read.table parameters below")),
checkboxInput(inputId = 'header', label = 'Header', value = FALSE),
checkboxInput(inputId = "stringAsFactors", "StringAsFactors", FALSE),
radioButtons (inputId = 'sep', label = 'Separator',
choices = c(Comma=',',Semicolon=';',Tab='\t', Space=''), selected = ',')
),
mainPanel(uiOutput("tb1"))
)),
tabPanel("Interval",
sidebarLayout(sidebarPanel(
uiOutput("model_select"),
uiOutput("var1_select"),
uiOutput("rest_var_select"),
#uiOutput("testText1"), br(),
#textInput("Smooting Parameter min value", "Smooting Parameter max value", value = "")
sliderInput("range", "Smooth Parameter range:",min = 0, max = 1000, value = c(0,100)),
downloadButton('downloadData', 'Download')
),
mainPanel(helpText("Selected variables and Fitted values"),
verbatimTextOutput("other_val_show")))),
tabPanel("Model Summary", verbatimTextOutput("summary")),
tabPanel("Scatterplot", plotOutput("scatterplot"))#, # Plot
#tabPanel("Distribution", # Plots of distributions
#fluidRow(
#column(6, plotOutput("distribution1")),
#column(6, plotOutput("distribution2")))
#)
,inverse = TRUE,position="static-top",theme ="bootstrap.css"))
The following code in for the Server section. (I want to download the output which is "gr" and I want to download it by downloadHandler function.
server<-function(input,output) {
data <- reactive({
lower <- input$range[1]
upper <- input$range[2]
file1 <- input$file
if(is.null(file1)){return()}
read.table(file=file1$datapath, sep=input$sep, header = input$header, stringsAsFactors = input$stringAsFactors)
})
output$table <- renderTable({
if(is.null(data())){return ()}
data()
})
output$tb1 <- renderUI({
tableOutput("table")
})
#output$model_select<-renderUI({
#selectInput("modelselect","Select Algo",choices = c("Reference Interval"="Model"))
#})
output$var1_select<-renderUI({
selectInput("ind_var_select","Select Independent Variable", choices =as.list(names(data())),multiple = FALSE)
})
output$rest_var_select<-renderUI({
checkboxGroupInput("other_var_select","Select Dependent Variable",choices =as.list(names(data()))) #Select other Var
})
output$other_val_show<-renderPrint({
input$other_var_select
input$ind_var_select
f<-data()
lower <- input$range[1]
upper <- input$range[2]
library(caret)
library(quantregGrowth)
dep_vars <- paste0(input$ind_var_select, collapse = "+")
after_tilde <- paste0("ps(", dep_vars, ", lambda = seq(",lower,",",upper,",l=100))")
dyn_string <- paste0(input$other_var_select, " ~ ", after_tilde)
Model<-quantregGrowth::gcrq(as.formula(dyn_string),tau=c(0.025,0.975), data=f)
temp <- data.frame(Model$fitted)
gr <- cbind(f, temp)
print(gr)
})
output$downloadData <- downloadHandler(
write.csv(gr, file, row.names = FALSE)
)
}
shinyApp(ui=ui,server=server)

It's hard to fully answer this without a minimal reproducibile example, but here's what I would try:
Create gr outside of renderPrint
Use gr() in downloadHandler
Rewrite downloadHandler to include content and filename arguments
Here's a minimal example with the same logic as your app, i.e. create a reactive dataframe which is both printed (renderPrint) and downloadable (downloadHandler).
library(shiny)
ui <- navbarPage(title = "Example",
tabPanel("First",
selectInput("fruit", "Fruit", c("apple", "orange", "pear")),
h4("Output from renderPrint:"),
textOutput("other_val_show"),
h4("Download Button: "),
downloadButton("downloadData")))
server <- function(input, output) {
gr <- reactive({
data.frame(fruit = input$fruit)
})
output$other_val_show <- renderPrint({
print(gr())
})
output$downloadData <- downloadHandler(
filename = "example.csv",
content = function(file) {
write.csv(gr(), file)
})
}
shinyApp(ui, server)

You define gr inside the scope of that renderPrint function so it isn't available to downloadHandler. You should define gr as a reactive value somewhere outside that function. That way, when you assign it in the renderPrint function, it will be accessible to the entire scope of your program.
In the future, it would be helpful to provide the text of any error messages you get - they are often quite helpful to solving problems.

Related

Is there a good way to merge data based on a drop down menu in R?

I have been trying to merge data with another data set based on input from a drop down. I have just started learning R and have run into some problems and want to know if there is a better way of going about this.
I am getting an error that it cannot coerce class c(ReactiveExpr, reactive) to a data frame.
library(shiny)
library(plyr)
library(dplyr)
library(xlsx)
server <- function(input, output){
annotation1 <- read.xlsx("input1.xlsx", sheetIndex = 1, header = TRUE)
annotation2 <- read.xlsx("input2.xlsx", sheetIndex = 1, header = TRUE)
data_input <- eventReactive(input$userfile, {
df <- read.xlsx(input$userfile$datapath, sheetIndex = 1, header = TRUE)
})
output$data_input <- renderTable(data_input())
output$annotation <- renderTable(annotation)
data_species <- c("Set1", "Set2")
# Drop-down selection box for which data set
output$choose_species <- renderUI ({
selectInput("species", "Species", as.list(data_species))
})
output$mergeddata <- renderTable({
if(input$species == "Set1"){
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
}
else if(input$species == "Set2"){
eventReactive("Set2",({left_join(data_input(), annotation2, by = c("Column1" = "Column1"))}))
}
})
}
ui <- fluidPage(
titlePanel(
div("Test")
),
sidebarLayout(
sidebarPanel(
fileInput("userfile", "Input File", multiple =FALSE,
buttonLabel = "Browse Files", placeholder = "Select File"),
uiOutput("choose_species"),
uiOutput("choose_annotations"),
),
mainPanel(
tableOutput("mergeddata"),
br()
),
),
)
# Run the application
shinyApp(ui = ui, server = server)
In general, you approach seems ok. The error you get is from the line
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
An eventReactive returns an (unevaluated) reactive expression which you try to render as data.frame with renderTable. To circumvent this, you could use:
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))()
However, here you don't need eventReactive, because your reactivity comes from input$species (you want to change the table output based on this input). Therefore, you can just use:
output$mergeddata <- renderTable({
if(input$species == "Set1"){
merge_data <- annotation1
} else {
merge_data <- annotation2
}
left_join(data_input(), merge_data, by = c("Column1"))
})

Save DT table with additional information (Shiny)

I was wondering if it is possible to save DT table content together with some additional information which is not part of the data frame/table like app version number, date of execution, sliderInput value etc.
Thank you!
Reprex below:
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1)
),
mainPanel(
DT::dataTableOutput("table")
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
}
shinyApp(ui = ui, server = server)
You could save the contents of the data frame and the other information in a list and then save the list.
Or, any R object can have attributes which are completely arbitrary and under your control. You could set attributes of the data frame to record the information you want.
Personally, I'd use the list approach, purely because I don't like attributes.
Here's a suggestion in response to OP's request below.
library(shiny)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "range", "Set range", 1, 10, 5, 1),
actionButton("saveRds", "Save to Rds"),
actionButton("loadRds", "Load from Rds")
),
mainPanel(
DT::dataTableOutput("table"),
wellPanel(h4("Current data"), verbatimTextOutput("text")),
wellPanel(h4("File data"), verbatimTextOutput("loadedData"))
)
)
)
server <- function(input, output) {
dfr <- data.frame(var1 <- c(1,2,3),
var2 <- c(11, 22, 33))
output$table <- DT::renderDataTable(
datatable(dfr, extensions = 'Buttons',
class="cell-border stripe",
rownames = FALSE, colnames = c("var1", "var2"),
options = list(dom = "Blfrtip",
buttond = list("copy", list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")), pageLength=10, autoWidth = TRUE,
searchHighlight = TRUE, filter = "top"))
)
listInfo <- reactive({
list("data"=dfr, "version"="WebApp Version 1.0", "runDate"=date(), "sliderValue"=input$range)
})
output$text <- renderPrint({
listInfo()
})
observeEvent(input$saveRds, {
saveRDS(listInfo(), "data.Rds")
})
fileData <- reactive({
req(input$loadRds)
readRDS("data.Rds")
})
output$loadedData <- renderPrint({
fileData()
})
}
shinyApp(ui = ui, server = server)
The way you implement "save to file" will depend on the file format: Excel files will clearly have different requirements to PDF files, for example. As a minimum effort demonstation, I've created "Save to Rds" and "Load from RDS" buttons in the sidebar and added a verbatimTextOutput to display the contents of the file when it's loaded. [I'm not sufficiently familiar with DT to know how to add the buttons in the table toolbar.]
OP's effort was pretty close: it's just that writing a list to CSV file takes a little more effort than just calling write.csv...

Can I call a function (not a module) from within shiny modile- can I pass the module reactive values as arguments of function

I am pretty new to Shiny modules.
I am trying to call a function (not a module) from one of my modules.
I would like to pass in the contents of my current reactive values (in my module) as arguments into the function.
The function make a sql query command based on the mrn number, startdate and enddate that is supposed to be fed into the function from 'modemtab'.
this is the error that I get:
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
I understand that this is because I'm passing the reactive values not contents of them into the function. My question is how can I pass the contents of these reactive values.
I included a piece of my code here.
Thanks.
app_server <- function(input, output,session) {
.
.
# getting csvupload_values from the first module and feeding it into the next.
csvupload_values <- callModule(csvupload, 'csv-upload')
callModule(modemtab,'mrntab', csvupload_values)
modemtab <- function(input, output, session, csvupload_values){
# the ouput$query is made in the UI part, but it's not the cause of issue.
output$query <- renderText({
if(!is.null(csvupload_values$file_uploaded())){
make_query(mrns = csvupload_values$file_uploaded()$mrns,
startDate = csvupload_values$dates()[1],
endDate = csvupload_values$dates()[2])
}
#This is the function called from within the second module (modemtab)
#this function is saved as a separate file in R folder
make_query <- function(...){
glue_sql("
select *
FROM table
WHERE
rgn_cd = {`rgn_cd`}
AND prdct_lne_cd = {`lob`}
AND ENCTR_STRT_TS >= {`startDate`}
AND ENCTR_END_TS <= {`endDate`}
"
,...
,.con = DBI::ANSI())
}
csvuploadUI <- function(id){
ns <- NS(id)
tagList(
fileInput(ns('file'), "Choose CSV File",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
dateRangeInput(
ns('mrn_date_range'), label = 'Select the range of date:',
start = NULL, end = NULL, min = NULL,
max = NULL, format = "mm/dd/yyyy",
startview = "month", weekstart = 0,
language = "en", separator = " to ", width = NULL),
# Input: Checkbox if file has header ----
checkboxInput(ns('header'), "Header", TRUE)
)
}
# Module Server
csvupload <- function(input, output, session){
userFile <- reactive({
# If no file is selected, don't do anything
validate(need(input$file, message = FALSE))
input$file
})
dataframe <- reactive({
read.csv(userFile()$datapath,
header = input$header)
})
Here:
csvupload_values <- callModule(csvupload, 'csv-upload')
callModule(modemtab,'mrntab', csvupload_values)
csvupload_values is a reactive conductor, so you can't do callModule(modemtab,'mrntab', csvupload_values) outside of a reactive context. You can do:
server <- function(input, output,session) {
csvupload_values <- callModule(csvupload, 'csv-upload')
observeEvent(csvupload_values(),{
if(!is.null(csvupload_values())){
callModule(modemtab, 'mrntab', csvupload_values)
}
})
}
Now, csvupload_values() is a dataframe once you have uploaded the file, so I don't understand why you do csvupload_values$file_uploaded(). Here is a full example:
modemtabUI <- function(id){
ns <- NS(id)
textOutput(ns("query"))
}
modemtab <- function(input, output, session, csvupload_values){
output$query <- renderText({
colnames(csvupload_values())
})
}
csvuploadUI <- function(id){
ns <- NS(id)
tagList(
fileInput(ns('file'), "Choose CSV File",
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
checkboxInput(ns('header'), "Header", TRUE),
dateRangeInput(
ns('mrn_date_range'), label = 'Select the range of date:',
start = NULL, end = NULL, min = NULL, max = NULL, format = "mm/dd/yyyy",
startview = "month", weekstart = 0,
language = "en", separator = " to ", width = NULL)
)
}
csvupload <- function(input, output, session){
userFile <- reactive({
# If no file is selected, don't do anything
validate(need(input$file, message = FALSE))
input$file
})
reactive({
read.csv(userFile()$datapath, header = input$header)
})
}
ui <- fluidPage(
csvuploadUI("csv-upload")
modemtabUI("mrntab")
)
server <- function(input, output,session) {
csvupload_values <- callModule(csvupload, 'csv-upload')
observeEvent(csvupload_values(),{
if(!is.null(csvupload_values())){
callModule(modemtab, 'mrntab', csvupload_values)
}
})
}
shinyApp(ui, server)

How to add a folder on Shinyio to upload multiple files

I have close to 30 files with different names to upload. I was looking to choose a local data path which then can be used to upload the many files.
I have added a very simplified version of my code so I do not confuse people. This is using library(shinyFiles), specifically shinyDirButton in the ui and shinyDirChoose in the server.
This is running locally on R Studio, but when I add it to my shinyio app, I am unable to get the local folders to show up on my app.
Is there a solution? I tried fileInput, but it does not seem to be working either.
ui<-fluidPage(
mainPanel("Hydro-BID-Opt",
tabsetPanel(
tabPanel("Information required for the model",
numericInput("Res", label = h3("Total Res"),
min = 1, max = 25,
value = 3),
numericInput("Muns", label = h3("Total Users"),
min = 1, max = 150,
value = 5),
numericInput("Time", label = h3("Total Number of Months"),
min = 0, max = 60,
value = 12)
),
tabPanel("Adding the folder",
shinyDirButton("directory", "Please add your data path where the csv files are stored", "Please select a folder", FALSE)
),
tabPanel("Results",
h3("Results for Cost"),
textOutput("Table_Cost")
)
)))
server<-function(input, output, session) {
Mo <- reactive({input$Time})
R <- reactive({input$Res})
Mu <- reactive({input$Muns})
volumes <- getVolumes()
shinyDirChoose(input, 'directory', roots=volumes, session=session)
path1 <- reactive({
return(print(parseDirPath(volumes, input$directory)))
})
## ResMax
Resmaxcsv <- eventReactive(input$directory, {
datpath_two <- paste0(path1(),"/MRC.csv")
dataruw_Resmaxcsv <- read.csv(datpath_two, check.names=F, header = T)
dataruw_Resmaxcsv
})
## Cost
Costcsv <- eventReactive(input$directory, {
datpath_seven <- paste0(path1(),"/Cost.csv")
dataruw_Costcsv <- read.csv(datpath_seven, check.names=F, header = T)
dataruw_Costcsv
})
#### Running the model
Test <- reactive({
nT<-Mo()
nR<-R()
nM<-Mu()
## ResMax
resmaxcapacity<-Resmaxcsv()
SCmax_rt<-array(data = resmaxcapacity[,2] * 1e-6, dim = c(nR, nT))
## Cost
costcsv<-Costcsv()
cost<-as.matrix(costcsv[,2:(nM+1)])
costQ <- array(data = cost[1:nR, 1:nM], dim = c( nR, nM, nT))
App<-apply(costQ, MARGIN = c(1,3), mean)
TOTAL<-SCmax_rt+App
print(TOTAL)
})
output$Table_Cost<-renderPrint({Test()})
}
shinyApp(ui = ui, server = server)
I know it is a little late but I think I have figured out the solution to upload a folder into a shiny app. I have tested it on a chrome browser and it will work fine for Edge & Firefox as well.
You can check the demo here:
https://absuag.shinyapps.io/FileExplorer/
Upload a folder and it will print all the files selected in the main panel.
I have used HTMLInputElement.webkitdirectory to upload the folder. Here is the source code for the shiny app.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(skin = "yellow",
# Title
dashboardHeader(title = "File-Explorer",titleWidth=140,uiOutput("logoutbtn")),
dashboardSidebar(
tags$button(HTML('<input id = "folderPath1" type="file" webkitdirectory mozdirectory />
<input id = "folderPath2" type="file" webkitdirectory mozdirectory />'))),
dashboardBody(
textOutput("text1"),
textOutput("text2"),
tableOutput("table1")
)
)
server <- function(input,output){
observeEvent(input$folderPath1,{
output$text1 <- renderText({
print(paste0(input$folderPath1$name,collapse=","))
})
output$table1 <- renderTable({
df <- read.csv(input$folderPath1$datapath[1])
})
})
observeEvent(input$folderPath2,{
output$text2 <- renderText({
print(paste0(input$folderPath2$name,collapse=","))
})
})
}
shinyApp(ui,server)

Using embedded do.call() in Shiny

I'm trying to use Shiny + ShinyBS to create a collapsible panel whitch contains a bunch of column values per column.
However, I'm having trouble in applying do.call correctly (or in the sequence I want).
Source code for server.R:
require(shiny)
library(lazyeval)
library(shinyBS)
l <- lapply(mtcars, function(x) unique(x))
shinyServer(function(input, output) {
output$plot <- renderUI({
col_list <- lapply(1:length(l), function(i) {
col <- l[[i]]
a <- lapply(1:min(length(col), 10), function(j) {
interp(quote(bsToggleButton(nm,lb)),
.values=list(nm = paste0(names(l)[i],
'_val_',
j),
lb = col[j]))
})
pars <- list(inputId = paste0('btng_',
names(l)[i]),
label = '', value = '', a)
interp(quote(bsCollapsePanel(names(l)[i],
fluidRow(
column(4,
do.call(bsButtonGroup,
unlist(pars))
)
),
id = nm, value = val)),
.values = list(i = i,
nm = paste0('test_',i),
val = '')
)
})
pars2 <- list(multiple = TRUE,
open = "test_1",
id = "collapse1",
col_list)
do.call(bsCollapse, unlist(pars2))
})
})
Source code for ui.R:
require(shiny)
shinyUI(
fluidPage(
uiOutput('plot')
)
)
The code can NOT run! The problem is pars seems to be static, it only contains the value of the first iteration.
Firstly, the code was still not reproducible as is. I suspect you had run parts of the provided code within your environment (e.g. the 'pars' object was not found with your provided code on my machine).
Second, I think you have just made your apply statements too complex. The idea of apply statements is to improve readability of your code as opposed to for loops. Here you have crammed so much in to the lapply statements that it is difficult to parse out anything.
To address this, I broke the components apart into their own lapply statements (which is far more approachable now). What was happening with your previous code is that your pars object was taking all the variables from the a object. Once these components were separated, I could easily just alter the pars statement to iterate through each a element. This provides the different values for each iteration (i.e. variable). I have only included the server.R as there is not changes to your ui.R
As a followup to your comments below, you are correct that the interp and quote arguments are unnecessary (I generally avoid them again for clarity, my personal preference). As for best practices, I sum it up in one concept 'clarity then performance'. If you are unsure about your objects then LOOK AT THEM! Below you will find an updated server.R file. I have also minimally commented it. You will also find an example of accessing the bsGroupButton values. You can see it is the group id that you must reference. This should get you started (be sure to add tableOutput('result') to your ui.R. I highly recommend you look into the documentation of ShinyBS or at least the demo page.
Concise and annotated server.R
require(shiny)
library(shinyBS)
l <- lapply(mtcars,function(x)unique(x))
shinyServer(function(input, output) {
output$plot <- renderUI({
# Create your buttons
a <- lapply(1:length(l), function(i){
col <- l[[i]]
lapply(1:min(length(col),10), function(j){
bsButton(paste0(names(l)[i], '_val_', j), label=col[j], value=col[j])
})
})
# add the additional arguments for your future bsButtonGroup call
pars <- lapply(1:length(l), function(i) {
list(inputId =paste0('btng_',names(l)[i]), label = '', value = '',a[[i]])
})
col_list<-lapply(1:length(l), function(i) {
# separate the components for clarity
rawButtons <- unlist(pars[i], recursive=F)
buttons <- do.call(bsButtonGroup, c(rawButtons[[4]], inputId=rawButtons$inputId))
# collapse the groups into panels
bsCollapsePanel(title=names(l)[i],
buttons, id=paste0('test_',i), value='')
})
# Collapse everything, no need for pars2, just add elements in a vector
do.call(bsCollapse, c(col_list, multiple=TRUE, open="test_1", id="collapse1"))
})
output$result<- renderTable({
df <- cbind(c("mpg toggle button", c(deparse(input$btng_mpg))))
return(df)
})
})
original answer for server.R
require(shiny)
library(shinyBS)
require(lazyeval)
l <- lapply(mtcars,function(x)unique(x))
shinyServer(function(input, output) {
output$plot <- renderUI({
a <- lapply(1:length(l), function(i) {
col <- l[[i]]
lapply(1:min(length(col),10), function(j) {
interp(
quote(bsToggleButton(nm,lb))
,.values=list(nm=paste0(names(l)[i],'_val_', j),lb=col[j]))
})
})
pars <- lapply(1:length(l), function(i) {
list(inputId =paste0('btng_',names(l)[i]), label = '', value = '',a[[i]])
})
col_list<-lapply(1:length(l), function(i) {
interp(
quote(
bsCollapsePanel(names(l)[i],
fluidRow(
column(4,
do.call(bsButtonGroup,unlist(pars[i]))
)
),
id=nm,value=val))
,.values=list(i=i,nm=paste0('test_',i),val='')
)
})
pars2 <- list(multiple = TRUE, open = "test_1", id = "collapse1",col_list)
do.call(bsCollapse,unlist(pars2))
})
})