Prevent to read file multiple times from dynamic fileInput - r

I've created a dynamic fileInput in shiny using lapply. When I want to read the file, I've also used lapply in an observer.
The problem of using lapply here is, it is triggered every time I upload a new file and thus, reads all files again and again if a new file is uploaded.
Here I provide a Hello World app. The lapply function depends on an input paramter which I abtracted from for simplicity.
library(shiny)
ui <- fluidPage(
titlePanel("Hello World"),
sidebarLayout(
sidebarPanel(),
mainPanel(
lapply(1:2, function(i) {
fileInput(
paste0("file", i),
label = NULL,
multiple = F,
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
),
buttonLabel = paste("File", i)
)
}),
verbatimTextOutput("list")
)
)
)
server <- function(input, output) {
r <- reactiveValues()
observe({
lapply(1:2, function(i) {
file <- input[[paste0("file",i)]]
if(is.null(file)) return()
isolate({
r$file[[paste(i)]] <- readr::read_csv2(file = file$datapath)
})
})
})
output$list <- renderPrint(reactiveValuesToList(r))
}
shinyApp(ui = ui, server = server)
How to replace the loop or add a requirement to lapply?

While I started down the road of cache-invalidation in the comments, I think something else may work better for you since you have a fixed number of fileInput fields: swap the lapply and observe lines in your code (plus a couple of other tweaks).
server <- function(input, output) {
lapply(paste0("file", 1:2), function(nm) {
observeEvent(input[[ nm ]], {
req(input[[nm]], file.exists(input[[nm]]$datapath))
readr::read_csv2(file = input[[nm]]$datapath)
})
})
}
Explanation:
I'm creating a list of reactive blocks instead of a reactive block operating on a list. This means "file1" won't react to "file2".
I short-cutted the definition of the input names by putting paste0(...) in the data of the lapply instead of in the function, though it'd be just as easy to do
lapply(1:2, function(i) {
nm <- paste0("file", i)
# ...
})
It's important to have nm defined outside of the observeEvent, and it has to do with delayed evaluation and namespace search order. I fell prey to this a few years ago and was straightened out by Joe Cheng: you can't use a for loop, it must be some environment-preserving operation like this.
N.B.: this is a stub of code, and it is far from complete: having an observe or observeEvent read the data and then discard it is wrong ... it's missing something. Ideally, this should really be a reactive or eventReactive block, or the processed data should be stored in a reactiveValues or reactiveVal. For example:
server <- function(input, output) {
mydata <- lapply(paste0("file", 1:2), function(nm) {
observeEvent(input[[ nm ]], {
req(input[[nm]], file.exists(input[[nm]]$datapath))
readr::read_csv2(file = input[[nm]]$datapath)
})
})
observe({
# the following are identical, the latter more declarative
mydata[[1]]
mydata[["file1"]]
})
}
(And another note about defensive programming: you cannot control perfectly how readr::read_csv2 reacts to that file ... it may error out for some reason. One further step would be to wrap it in tryCatch(..., error = function(e) { errfun(e); NULL; }) where errfun(e) does something meaningful with the error message (logs it and/or gives it to the user in a modal popup) and then returns NULL so that reactive blocks downstream can use req(mydata[[1]]) and will not try to process the NULL.
server <- function(input, output) {
mydata <- lapply(paste0("file", 1:2), function(nm) {
observeEvent(input[[ nm ]], {
req(input[[nm]])
file <- input[[nm]]
tryCatch(
readr::read_csv2(file = input[[nm]]$datapath),
error = function(e) { errfun(e); NULL; })
})
})
observe({
# the following are identical, the latter more declarative
mydata[[1]]
mydata[["file1"]]
})
}

Related

Read a file after taking user input(selection) in Shiny

I am trying to read a file after taking inputs from user - first a date and then a selection of file, but I can't get the code read any file and do anything with it. The Error message is following. Also is there a way to make this code more efficient?
ui <- fluidPage(
titlePanel("Select the execution date")
,dateInput("ME_DATE",label=h3("Execution Date Input"), value="2020-05-29")
,hr()
,fluidRow(column(3,verbatimTextOutput("Output_path")))
,hr()
,selectInput('selectfile','Select File in Above Location', choices=NULL)
,textOutput('fileselection_statement')
,tableOutput('selected_table')
)
server <- function(input, output, session) {
# Location for Outputs
Output_DIR <- "K:/Outputs/"
Output_loc <- reactive({
year_N_ME_DATE <- format(input$ME_DATE,"%Y")
month_N_ME_DATE <- format(input$ME_DATE,"%m")
month_T_ME_DATE <- months(input$ME_DATE)
file.path(paste(Output_DIR,month_N_ME_DATE,". ",month_T_ME_DATE, " ",year_N_ME_DATE,"/",sep=""))
})
# Output Path
output$Output_path <- renderPrint({ Output_loc() })
# files list
Updated_Output_files_list <- reactive({ list.files(Output_loc()) })
observeEvent(input$selectfile, {
updateSelectInput(session, "selectfile", choices=Updated_Output_files_list())
output$fileselection_statement <- renderText({paste0('You have selected: ', input$selectfile) })
})
selectfile <- reactive(get(input$selectfile))
output$selected_table <- renderTable({ read.csv(paste0(renderPrint({ Output_loc() }),renderPrint({ selectfile() }),sep="")) })
}
shinyApp(ui, server)
(Since changed) Make the block containing file.path(.) a reactive block and assign it to something so that other reactive components can use it. In your case, you changed it to Output_loc, so other blocks will refer to it as Output_loc().
Similarly, you cannot put output$... <- assignments or render* calls inside an observe or observeEvent block. So we'll move your output$fileselection_statement outside of the observeEvent.
renderPrint is its own rendering function, on the same level as renderTable. You cannot nest them. In this case, I'm just going to remove them from inside the renderTable call, they make no sense there.
This case did not need selectfile <- reactive(get(input$selectfile)), there is no apparent gain in that indirection. Just use input$selectfile. Removed.
After fixing all of the above, it is also the case that you were updating the selectInput every time the selectInput was changed, which is incorrect (and completely disallows any real use of this). Instead, you want to update it when the Updated_Output_files_list() changes.
Also, instead of repeatedly concatenating the path together to create the file to be read, I use list.files(..., full.names=TRUE). This will be a named vector, where the values are the full path and filename, but the names will be just the filename (no leading path). This useful because selectInput displays the name but returns the value (full path). There is rarely a time when I think not specifying full.names=TRUE is the right thing (I cannot think of any right now).
Here's a working copy. It is not perfectly-awesome, there are still areas where some grooming might be in order.
server <- function(input, output, session) {
# Location for Outputs
Output_DIR <- "K:/Outputs/"
Output_loc <- reactive({
year_N_ME_DATE <- format(input$ME_DATE, "%Y")
month_N_ME_DATE <- format(input$ME_DATE, "%m")
month_T_ME_DATE <- months(input$ME_DATE)
file.path(Output_DIR,
paste0(month_N_ME_DATE, ". ", month_T_ME_DATE, " ", year_N_ME_DATE),
"/")
})
# alternative
# Output_loc <- reactive({
# file.path(Output_DIR, format(Sys.Date(), format = "%m. %b %Y"))
# })
# Output Path
output$Output_path <- renderPrint({ req(Output_loc()) })
# files list
Updated_Output_files_list <- reactive({
lf <- list.files(Output_loc(), full.names = TRUE)
names(lf) <- basename(lf)
# in this example, 'lf' is now:
# c(iris.csv = "K:/Outputs/05. May 2020/iris.csv", mtcars.csv = "K:/Outputs/05. May 2020/mtcars.csv")
# ... the *name* will be displayed in the selectInput, but the
# *full path* will be the value of the selection
lf
})
output$fileselection_statement <- renderText({
paste0('You have selected: ', input$selectfile)
})
observeEvent(Updated_Output_files_list(), {
updateSelectInput(session, "selectfile", choices = Updated_Output_files_list())
})
output$selected_table <- renderTable({
req(input$selectfile)
read.csv(input$selectfile)
})
}

How to automatically collapse code in RShiny app server (reactives, renders, etc)

I am working with a very large RShiny app and want to take advantage of code folding to organize the server.R file in this application. However, when I use the code-fold hotkey, it does not fold the various elements defined in the server (the reactive, render, etc. elements).
I'd like to be able to take this
# observe some things
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['tab']])) {
updateTabItems(session, "sidebarMenu", selected = query[['tab']])
}
if (!is.null(query[['player']])) {
updateSelectInput(session, "profile", selected = query[['player']])
}
})
# Lots of "reactive" data fetching functions
league_stats <- reactive({
get1 <- fetch('yada')
return(get1)
})
# another reactive
shooting <- reactive({
get1$SHORT_MR_MADE<-sum(get1$short_mr_fgm,na.rm=T)
...
...
)}
and collapse it into this (or something like this) by just hitting the code-collapse hotkey.
# observe some things
observe({--})
# Lots of "reactive" data fetching functions
league_stats <- reactive({--})
# another reactive
shooting <- reactive({--})
Is this possible to do with R / RStudio? I would like to avoid using the 4 # signs #### above the function to code fold, as this will hide the shooting <- reactive({--}) strings as well, however I'd like to still have show (and just hide the code inside).
I will oftentimes wrap code in functions since functions collapse, however I cannot wrap RShiny reactive elements in functions (or, i'm not sure how), as it seems like this breaks the app.
Shiny reactives behave as other functions, but you need to take care about passing to them the input, session or other reactives (as function, not as value) they need.
As an illustration :
library(shiny)
generateUI <- function() {fluidPage(
actionButton("do", "Click Me"),
textOutput('counter')
)}
ui <- generateUI()
myobserver <- function(input,counter) {
observeEvent(input$do, {
cat('Clicked \n')
counter(counter()+1)
})
}
myformater <- function(counter) {
renderText(paste('count is',counter()))
}
server <- function(input, output, session) {
counter <- reactiveVal(0)
myobserver(input,counter)
output$counter <- myformater(counter)
}
shinyApp(ui, server)
Collapsed code :
Another way to do this without creating them as functions is to put an identifier above each code chunk:
library(shiny)
# Generate UI ----
generateUI <- function() {fluidPage(
actionButton("do", "Click Me"),
textOutput('counter')
)}
ui <- generateUI()
# Observer ----
myobserver <- function(input,counter) {
observeEvent(input$do, {
cat('Clicked \n')
counter(counter()+1)
})
}
# Formatter ----
myformater <- function(counter) {
renderText(paste('count is',counter()))
}
# Server ----
server <- function(input, output, session) {
counter <- reactiveVal(0)
myobserver(input,counter)
output$counter <- myformater(counter)
}
shinyApp(ui, server)
You will then be able to collapse code segments in between the two identifiers to view as shown below:

Object not found R Shiny

I am trying to access the data frame created in one render function into another render function.
There are two server outputs, lvi and Category, in lvi I have created Data1 data frame and Category I have created Data2 dataframe. I want to select Data2 where Data1 ID is matching.
I am following the below steps to achieve my objective but I get error "Object Data1 not found".
My UI is
ui <- fluidPage(
# App title ----
titlePanel("Phase1"),
fluidPage(
column(4,
# Input: Select a file ----
fileInput("file1", "Import file1")
)
),
fluidPage(
column(4,
# Input: Select a file ----
fileInput("file2", "Import File2")
)
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Data file ----
dataTableOutput("lvi"),
dataTableOutput("category")
)
)
My server code is
server <- function(input, output) {
output$lvi <- renderDataTable({
req(input$file1)
Data1 <- as.data.frame(read_excel(input$file1$datapath, sheet = "Sheet1"))
})
output$category <- renderDataTable({
req(input$file2)
Data2 <- as.data.frame(read_excel(input$file2$datapath, sheet = "Sheet1"))
Data2 <- Data2[,c(2,8)]
Data2 <- Data2[Data1$ID == "ID001",]
})
}
shinyApp(ui, server)
Once a reactive block is done executing, all elements within it go away, like a function. The only thing that survives is what is "returned" from that block, which is typically either the last expression in the block (or, when in a real function, something in return(...)). If you think of reactive (and observe) blocks as "functions", you may realize that the only thing that something outside of the function knows of what goes on inside the function is if the function explicitly returns it somehow.
With that in mind, the way you get to a frame inside one render/reactive block is to not calculate it inside that reactive block: instead, create that frame in its own data-reactive block and use it in both the render and the other render.
Try this (untested):
server <- function(input, output) {
Data1_rx <- eventReactive(input$file1, {
req(input$file1, file.exists(input$file1$datapath))
as.dataframe(read_excel(input$file1$datapath, sheet = "Sheet1"))
})
output$lvi <- renderDataTable({ req(Data1_rx()) })
output$category <- renderDataTable({
req(input$file2, file.exists(input$file2$datapath),
Data1_rx(), "ID" %in% names(Data1_rx()))
Data2 <- as.data.frame(read_excel(input$file2$datapath, sheet = "Sheet1"))
Data2 <- Data2[,c(2,8)]
Data2 <- Data2[Data1_rx()$ID == "ID001",]
})
}
shinyApp(ui, server)
But since we're already going down the road of "better design" and "best practices", let's break data2 out and the data2-filtered frame as well ... you may not be using it separately now, but it's often better to separate "loading/generate frames" from "rendering into something beautiful". That way, if you need to know something about the data you loaded, you don't have to (a) reload it elsewhere, inefficient; or (b) try to rip into the internals of the shiny DataTable object and get it manually. (Both are really bad ideas.)
So a slightly better solution might start with:
server <- function(input, output) {
Data1_rx <- eventReactive(input$file1, {
req(input$file1, file.exists(input$file1$datapath))
as.dataframe(read_excel(input$file1$datapath, sheet = "Sheet1"))
})
Data2_rx <- eventReactive(input$file2, {
req(input$file2, file.exists(input$file2$datapath))
dat <- as.dataframe(read_excel(input$file2$datapath, sheet = "Sheet1"))
dat[,c(2,8)]
})
Data12_rx <- reactive({
req(Data1_rx(), Data2_rx())
Data2_rx()[ Data1_rx()$ID == "ID001", ]
})
output$lvi <- renderDataTable({ req(Data1_rx()); })
output$category <- renderDataTable({ req(Data12_rx()); })
}
shinyApp(ui, server)
While this code is a little longer, it also groups "data loading/munging" together, and "render data into something beautiful" together. And if you need to look at early data or filtered data, it's all right there.
(Side note: one performance hit you might see from this is that you now have more copies of data floating around. As long you are not dealing with "large" data, this isn't a huge deal.)

Shiny - Inserting UI with a for loop returns the same elements in every outputs

I want to insert a non predefined number of graph inside my Shiny App. I use a for loop and a series of insertUI.
Thing is when I run it, the text elements behave as expected, but the graphs are all rendering the same image. How can I prevent that?
Here's a reprex:
library(shiny)
ui <- fluidPage(
tags$div(
class = "this",
actionButton("go", "go")
)
)
server <- function(input, output, session) {
observeEvent( input$go , {
x <- reactiveValues(x = list(iris, mtcars, airquality))
for (i in 1:3){
insertUI(
".this",
ui = tagList(
p(paste("Number", i)),
renderPlot({
plot(x$x[[i]])
})
))
}
})
}
shinyApp(ui, server)
Beware closures in for loops ;). There's no block scope in R, so each for loop iteration shares the same iterator variable i. And the renderXX functions essentially store expressions that aren't evaluated immediately, but only later when it's time to render.
So by the time the plots are ready to render, the for loop is done, i is now 3, and each plot(x$x[[i]]) expression is called as plot(x$x[[3]]).
You can get around this by creating a new scope for each loop iteration using local() or a function. My favorite solution is using lapply as you've found, to run each loop iteration in a function with i as a function-scoped variable.
Many languages without block scope have this same gotcha, like Python and JS:
JavaScript closure inside loops – simple practical example
How do lexical closures work?
So, found the answer to my own question — using lapply() makes this work:
library(shiny)
ui <- fluidPage(
tags$div(
class = "this",
actionButton("go", "go")
)
)
server <- function(input, output, session) {
observeEvent( input$go , {
x <- reactiveValues(x = list(iris, mtcars, airquality))
lapply(1:3, function(i){
insertUI(
".this",
ui = tagList(
p(paste("Number", i)),
renderPlot({
plot(x$x[[i]])
})
))
})
})
}
shinyApp(ui, server)

Multiple inputs to reactive value R Shiny

For part of a Shiny application I am building, I need to have the user select a directory. The directory path is stored in a reactive variable. The directory can either be selected by the user from a file window or the path can be manually entered by textInput. I have figured out how to do this, but I don't understand why the solution I have works! A minimal example of the working app:
library(shiny)
ui <- fluidPage(
actionButton("button1", "First Button"),
textInput("inText", "Input Text"),
actionButton("button2", "Second Button"),
textOutput("outText"),
textOutput("outFiles")
)
server <- function(input, output) {
values <- reactiveValues(inDir = NULL)
observeEvent(input$button1, {values$inDir <- tcltk::tk_choose.dir()})
observeEvent(input$button2, {values$inDir <- input$inText})
inPath <- eventReactive(values$inDir, {values$inDir})
output$outText <- renderText(inPath())
fileList <- reactive(list.files(path=inPath()))
output$outFiles <- renderPrint(fileList())
}
shinyApp(ui, server)
The first thing I tried was to just use eventReactive and assign the two sources of input to the reactive variable:
server <- function(input, output) {
inPath <- eventReactive(input$button1, {tcltk::tk_choose.dir()})
inPath <- eventReactive(input$button2, {input$inText})
output$outText <- renderText(inPath())
fileList <- reactive(list.files(path=inPath()))
output$outFiles <- renderPrint(fileList())
}
The effect of this as far as I can tell is that only one of the buttons does anything. What I don't really understand is why this doesn't work. What I thought would happen is that the first button pushed would create inPath and then subsequent pushes would update the value and trigger updates to dependent values (here output$outText). What exactly is happening here then?
The second thing I tried, which was almost there, was based off of this answer:
server <- function(input, output) {
values <- reactiveValues(inDir = NULL)
observeEvent(input$button1, {values$inDir <- tcltk::tk_choose.dir()})
observeEvent(input$button2, {values$inDir <- input$inText})
inPath <- reactive({if(is.null(values$inDir)) return()
values$inDir})
output$outText <- renderText(inPath())
fileList <- reactive(list.files(path=inPath()))
output$outFiles <- renderPrint(fileList())
}
This works correctly except that it shows an "Error: invalid 'path' argument" message for list.files. I think this may mean that fileList is being evaluated with inPath = NULL. Why does this happen when I use reactive instead of eventReactive?
Thanks!
You could get rid of the inPath reactive and just use values$inDir instead.
With req() you'll wait until values are available. Otherwise you'll get the same error (invalid 'path' argument).
The reactive triggers right away, while the eventReactive will wait until the given event occurs and the eventReactive is called.
And if(is.null(values$inDir)) return() won't work correctly, as it will return NULL if values$inDir is NULL, which is then passed to list.files. And list.files(NULL) gives the error: invalid 'path' argument.
Replace it with req(values$inDir) and you won't get that error.
And your example with 2 inPath - eventReactive's won't work, as the first one will be overwritten by the second one, so input$button1 won't trigger anything.
library(shiny)
ui <- fluidPage(
actionButton("button1", "First Button"),
textInput("inText", "Input Text"),
actionButton("button2", "Second Button"),
textOutput("outText"),
textOutput("outFiles")
)
server <- function(input, output) {
values <- reactiveValues(inDir = NULL)
observeEvent(input$button1, {values$inDir <- tcltk::tk_choose.dir()})
observeEvent(input$button2, {values$inDir <- input$inText})
output$outText <- renderText(values$inDir)
fileList <- reactive({
req(values$inDir);
list.files(path=values$inDir)
})
output$outFiles <- renderPrint(fileList())
}
shinyApp(ui, server)
You could also use an eventReactive for button1 and an observeEvent for button2, but note that you need an extra observe({ inPath() }) to make it work. I prefer the above solution, as it is more clear what's happening and also less code.
server <- function(input, output) {
values <- reactiveValues(inDir = NULL)
inPath = eventReactive(input$button1, {values$inDir <- tcltk::tk_choose.dir()})
observe({
inPath()
})
observeEvent(input$button2, {values$inDir <- input$inText})
output$outText <- renderText(values$inDir)
fileList <- reactive({
req(values$inDir);
list.files(path=values$inDir)
})
output$outFiles <- renderPrint(fileList())
}
And to illustrate why if(is.null(values$inDir)) return() won't work, consider the following function:
test <- function() { if (TRUE) return() }
test()
Although the if-condition evaluates to TRUE, there is still gonna be a return value (in this case NULL), which will be passed on to the following functions and in your case list.files, which will cause the error.

Resources