I created a dashboard with 15 data tables in Shiny. Each table draws data from an API and this process takes some time. So I want to output each table to ui at a time such that users can read the first table while the other ones load. But it seems Shiny always holds all output until server function finishes execution. Is there a way to change this?
I had a similar problem with an app once. What I did was to do the calculations that take much time in another R session. Maybe now there are packages that make it easier, but here is how I solved it:
You can make an observeEvent which is triggered by an actionButton. In this observer you start another R session (with a system call to Rscript for example).
Then the app is still responsive while an R session in the background is doing all the calculations.
To retrieve information from the background process you can use shiny's reactivePoll function.
In your case the background R session would do the process each table and write the result into a file once it is done with a table. The reactivePoll would watch out for these files. Once such a file appear the reactivePoll function can read it and present it as a reactive. The value of this reactive can then be rendered somehow for the user to see.
This way each table is processed 1 by 1, while the app is still responsive and able to show results while the background process is still running.
Here is a app that shows the principle.
server
library(shiny)
# batch process communicates via file
write("", "tmp.info")
# cheap function to check for results
cheap <- function() scan("tmp.info", what = "")
shinyServer(function(input, output, session) {
# start process
observeEvent(input$go, {
system2("Rscript", args = c("batch.r", input$num1, input$num2),
stdout = "", stderr = "", wait = FALSE)
})
# watch file
watch <- reactivePoll(500, NULL, cheap, cheap)
# retrieve result from batch process
result1 <- reactive(if(length(watch()) > 0) watch()[1] else NULL)
result2 <- reactive(if(length(watch()) > 1) watch()[2] else NULL)
# show results
output$add <- renderPrint(result1())
output$multiply <- renderPrint(result2())
})
ui
library(shiny)
shinyUI(fluidPage(sidebarLayout(
sidebarPanel(
h2("Add and multiply"),
numericInput("num1", "Number 1", value = 1),
numericInput("num2", "Number 2", value = 1),
helpText("Both numbers are added, and multiplied. Each calculation takes 4 sec."),
br(),
actionButton('go', 'Start')
),
mainPanel(
h4("Result of Addition"),
verbatimTextOutput("add"),
h4("Result of Multiplication"),
verbatimTextOutput("multiply")
)
)))
batch.r
# read info
args <- commandArgs(TRUE)
args <- as.numeric(args)
# add
res <- args[1] + args[2]
Sys.sleep(4)
write(res, "tmp.info")
# mult
res <- args[1] * args[2]
Sys.sleep(4)
write(res, "tmp.info", append = TRUE)
quit(save = "no")
server.r ui.r and batch.r must be in the same directory. A file "tmp.info" is created which is used for communication. The results are directly read from this file and batch.r is started with the input as parameters. You can also use files for all that.
Related
I generate a dynamic number of valueBox in my shiny, and this number can change depending of the user input.
I managed to handle this with a renderUI where I put the wanted number of valueBoxOutput, and I have an observe that will feed them with the content using renderValueBox.
My problem is: the code in the renderValueBox, for some reason, is actually executed after the observe is finished, so because the renderValueBox is in a loop (to have a dynamic number of them) but the code is executed for all the output after the loop, all my output will get the last value of the loop.
Here is a min reprex:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
# Function
compute <- function(id)
{
print(paste("Compute ", id))
return(id)
}
# UI
ui = shinyUI(fluidPage(
titlePanel("Compare"),
useShinydashboard(),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items", min = 1, max = 10, value = 2)
),
mainPanel(
uiOutput("boxes")
)
)
))
# Server
server = shinyServer(function(input, output, session) {
data <- reactiveValues(
ids = list()
)
output$boxes <- renderUI({
print("boxes")
box_list <- list()
id_list <- list()
for(id in 1:(input$numitems)) {
id_box <- paste0("box_", id)
print(paste("boxes - ", id_box))
id_list <- append(id_list, id_box)
box_list <- append(
box_list,
tagList(
shinydashboard::valueBoxOutput(id_box)
)
)
data$ids <- id_list
}
print("boxes end")
fluidRow(box_list)
})
observe({
print("observe")
for(id_box in data$ids) {
print(paste("observe - ", id_box))
output[[id_box]] <- shinydashboard::renderValueBox(valueBox(id_box, compute(id_box), icon = icon("circle-info"), color = "teal"))
}
print("end observe")
})
})
# Run
shinyApp(ui = ui , server = server)
Here is the result:
And the console output:
As you can see the compute (and the render in general) is done after the end of the observe function, and both output will use the last id_box that were set (so the last loop, box_2), instead of correctly using box_1 and box_2.
I tried using force, computing valueBox outside the render, using reactive lists, nothing worked, because whatever I do the render is evaluated after the observe so only the last loop values will be used no matter what.
Do anyone know a way to force execution during the loop ? Or see another way of achieving the same result ?
Why it's always after spending hald a day on a problem, looking for dozens of posts and forum, don't find anything, finally decide to ask a question... that a few minutes later I finally find an answer.
Anyway, one way to correct this (found here) is to encapsulate the render inside the local function, like this:
observe({
print("observe")
for(id_box in data$ids) {
print(paste("observe - ", id_box))
local({
tmp <- id_box
output[[tmp]] <- shinydashboard::renderValueBox(valueBox(tmp, compute(tmp), icon = icon("circle-info"), color = "teal"))
})
}
print("end observe")
})
Now the compute is still called after the end of the observe, but the tmp variable has the correct value:
The result is what I wanted:
For the record, I had already tried to use the local function, but if you don't copy the id_box inside another variable just for the local bloc, it won't work.
I've written a script to calculate glicko ratings and produce odds and historic plots for sport teams. A separate script is responsible for querying the SQL server that holds historic data and extracting the relevant info to make a local tsv file of the info I need for the rating calculation. To make it more user-friendly, I've put the functions into a simple shiny app.
My problem is that I would like to put in a button that automatically executes the code of the second script that adds recent matches to the data file, so the ratings can be updated.
I've proved a simplified example of my code, showing that I'm handling the bulk of the data wrangling and preparation of the ratings object, from where I can get probabilities, before defining the UI. I tried a simple example of modifying the teams_list with my action button, but this did not recalculate the list of teams available to enter in selectInput(); because of how observeEvent() handles the code with isolate() to avoid recalculations, I'm guessing. So simply duplicating all the code that loads data and prepares the ratings object will not do unless it makes all the rest of the code re-evaluate its input.
I considered moving all of that into the action button and deleting it from the start of the script, but that would mean that there is no data at all until the action button would be pressed and that is not desirable either. I don't want to query the database more often than is necessary, so it is a must to be able to run the app from the existing data rather than querying it every time the app is launched.
Does anyone have a suggestion for how this could be accomplished?
### Toy example
## Prep: This input data normally exists before app is run.
library(tidyverse)
tibble(team1 = c("Name1", "Name2", "Name3", "Name2"),
team2 = c("Name2", "Name1", "Name1", "Name3"),
team1Won = c(T, T, F, T)) %>%
write_tsv("example_match_file.tsv")
## Here the app code starts.
# Loading data and calculating team ratings
match_df <- read_tsv("example_match_file.tsv")
rating_calculation <- function(match_data = match_df) {
match_data %>%
group_by(team1) %>%
summarize(matchesWon = sum(team1Won)) %>%
arrange(desc(matchesWon))
}
rating_df <- rating_calculation(match_df)
team_list <- rating_df$team1
odds_calculation <- function(team1, team2, ratingObject = rating_df) {
#Real calculation omitted for brevity
p <- runif(1)
}
## Define Shiny UI
library(shiny)
ui <- fluidPage(
titlePanel("Odds"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "team1",
label = "Team 1",
choices = team_list),
selectInput(inputId = "team2",
label = "Team 2",
choices = team_list),
#actionButton("update", "Update match data")
),
mainPanel(
tableOutput("odds")
)
)
)
## Define Shiny server logic
server <- function(input, output) {
#Generate Odds
output$odds <- renderTable({
p <- odds_calculation(rating_df, input$team1, input$team2)
tibble(Team = c(input$team1, input$team2), Win = c(p, 1-p)) %>%
mutate(Odds = (1/Win))
})
### Make Action Button update database, re-read example_match_file.tsv and rerun all calculations.
# datasetInput <- observeEvent(input$update, {
# ???
# })
}
# Run the application
shinyApp(ui = ui, server = server)
If I'm reading this right you'd like to spare your query limit by providing a local set of data to your shiny application. But if a user requests an update you'd like to trigger a query to be used in calculations.
I cannot recommend enough that you make full use of reactivity in Shiny. It is fairly rare to use an object from the global environment, especially when you intend for user inputs to manipulate those objects. You should have your base data ( in your case the tsv) load into the global environment, and then call that information into your application via a reactive dataframe. I built the below minimal example using mpg subset to the first 5 rows to simulate the .tsv on your local machine. mpg subset to 10 rows is to simulate the results of a query to a database. These two data sets get called via an if else statement dependent on an actionbutton.
library(tidyverse)
library(shiny)
# using partial mpg data to simulate un-updated data
mpg <- ggplot2::mpg[1:5,]
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("update", "Update Data"),
uiOutput('selectOpts')
),
mainPanel(
h2("This is our base data layer"),
verbatimTextOutput('print_interval1'),
h2("This is our output data"),
verbatimTextOutput('print_interval2')
)
)
)
server <- function(input, output) {
# The core of shiny is the reactivity. It's the workhorse of interactive apps.
# If possible, a data calculation should always happen in a reactive context.
working_data <- reactive({
# actionbuttons increment a value by 1, starting with 0. If input < 0 the
# user has not interacted yet. If incremented again, the reactive context
# will invalidate and re-calculate the working_data() object
if (input$update < 1) {
base_dat <-
mpg %>%
mutate(ratio = cty/hwy)
} else {
base_dat <-
ggplot2::mpg[1:10,] %>% # calling from namespace to simulate a query. Full data
mutate(ratio = cty/hwy)
}
# return our base data. Can be called with `working_data()`
data.frame(base_dat)
})
output$print_interval1 <- renderPrint({
working_data()
})
output$selectOpts <- renderUI({
# using the reactive data inside renderUI we can be flexible in our options
# this lets us adapt the UI to reactive data.
radioButtons('model',
"Select Model",
sort(unique(working_data()$model)))
})
# You can also chain reactive objects.
output_data <- reactive({
working_data() %>%
group_by(model) %>%
filter(model == input$model) %>%
summarise(m.ratio = mean(ratio))
})
output$print_interval2 <- renderPrint({
output_data() %>%
data.table()
})
}
shinyApp(ui = ui, server = server)
I also recommend looking into this post about database syncing for setting up triggers and using reactive objects as your applications get more complex. I hope that's enough to get you on the right track for both your initial question about updating data, and your comments about having your inputs react to updated data.
I am currently working on a shiny app that runs a series of calculations on a dataset on the fly when someone presses "Calculate". The dataset is very large and a lot of calculations are made via a lapply, which allows the user to track the progress with a progress bar.
This means the generation of the output data frame can be quite slow even when there are potentially results already sitting there just waiting to be displayed. The problem I'm having is that the data is potentially quite time sensitive when something is found and therefore if the calculations take, say, 15 minutes to run, there may have been something to display on the first calculation that is 15 minutes out of date.
Is there a way that after each iteration of the lapply (or feel free to suggest another method) the app can look to see whether there is data there and immediately show it, essentially refreshing the output table after each iteration? Essentially updating the reactive value during the observe rather than after.
I've put below a short example app that may help visualise the problem I'm having:
library(shiny)
testDF <- data.frame(number = c(1:10),
letter = letters[1:10])
ui <- fluidPage(
# UI Input
numericInput(inputId = "attemptDivide", label = "Number to divide by",
value = 1, min = 1, max = 10),
actionButton(inputId = "calculate", label = "Calculate"),
# UI Output
dataTableOutput("dividedTable")
)
# Define server logic
server <- function(input, output) {
# Create a bucket for results
results <- reactiveVal()
# Observe when "Calculate" is pushed and we should work out whether the
# number is perfectly divisible by the input given
observeEvent(input$calculate, {
divisibleDF <- lapply(testDF$number, function(x) {
# Set to sleep for 1 second to simulate for the the lapply being
# bigger and taking more time than this example
Sys.sleep(1)
# Find the row we're interested in
interest <- subset(testDF, number == x)
# Find whether the number is perfectly divisible by the one given
divisible <- (x / input$attemptDivide) %% 1 == 0
# If divisible is TRUE we keep, else we return an empty data frame
if (divisible) {
return(interest)
} else {
return(data.frame(number = integer(), letter = character()))
}
}) %>%
do.call(rbind, .)
# Save the results to bucket
results(divisibleDF)
})
# Create the table
output$dividedTable <- renderDataTable({
results()
})
}
# Run the app
shinyApp(ui = ui, server = server)
Thanks in advance for any help.
In my Shiny app, users can upload a file which is stored as a reactive dataframe. Inside the reactive expression that is shown below, I call an external time-consuming function (called performDigestion) which requires several seconds to complete.
fastafile_data <- reactive(){
inFile_fastafile <- input$fastaFile
req(inFile_fastafile)
ext <- tools::file_ext(inFile_fastafile$datapath)
validate(need(ext == "fasta", "Please upload a fasta file"))
dt.seq <- readAAStringSet(inFile_fastafile$datapath)
tbl <- performDigestion(dt.seq) ##the time-consuming step
return(tbl)
}
Next, I render a Datatable to present the results of the fastafile_data in the UI:
output$dt_fastafile <- DT::renderDataTable({
withProgress(message = 'Computation in progress, this step might take a while. Please wait...', {
incProgress(1/1)
fastafile_data()
})
}, options = list(scrollX = TRUE, dom = 'lfrtip', pageLength = 10, lengthMenu = c(10, 25, 50, 100)), rownames = FALSE)
In the UI, I also have two additional components (a sliderInput and a numericInput) and in the server-side I handle their values through two observeEvents .
What I would like to achieve is to update the fastafile_data dataframe every time any of these two additional components is triggered without reading the input$fastaFile again and re-running the time consuming performDigestion() function. I would ideally like to trigger the above reactive process again only when a new file is uploaded by the user.
I think the problem here is in my logic and/or there exists a smarter way to do it in ShinyR that I'm currently missing? Can you please point me to the right direction?
EDIT:
When I try to handle the reactive fastafile_data through a second reactive fastafile_data_new the first fastafile_data is re-executed.
fastafile_data_new <- reactive({
dt <- fastafile_data()
##### the condition I'd like to apply
dt$identifiable <- ifelse(dt$length >= min_peptide_length$choice & dt$length <= max_peptide_length$choice & dt$`mass [Da]` < max_peptide_mass$choice, 1, 0)
return(dt)
})
In shiny, it is possible to call client-side callbacks written in javascript from the server's logic. Say in ui.R you have some JavaScript including a function called setText:
tags$script('
Shiny.addCustomMessageHandler("setText", function(text) {
document.getElementById("output").innerHTML = text;
})
')
then in your server.R you can call session$sendCustomMessage(type='foo', 'foo').
Suppose I have a long-running function which returns some data to plot. If I do this normally, the R thread is busy while running this function, and so can't handle additional requests in this time. It would be really useful to be able to run this function using the futures package, so that it runs asynchronously to the code, and call the callback asyncronously. However, when I tried this is just didn't seem to work.
Sorry if this isn't very clear. As a simple example, the following should work until you uncomment the two lines trying to invoke future in server.R. Once those lines are uncommented, the callback never gets called. Obviously it's not actually useful in the context of this example, but I think it would be very useful in general.
ui.R:
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("max",
"Max random number:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
verbatimTextOutput('output'),
plotOutput('plot')
)
),
tags$script('
Shiny.addCustomMessageHandler("setText", function(text) {
document.getElementById("output").innerHTML = text;
})
')
))
server.R:
library(shiny)
library(future)
plan(multiprocess)
shinyServer(function(input, output, session) {
output$plot <- reactive({
max <- input$max
#f <- future({
session$sendCustomMessage(type='setText', 'Please wait')
Sys.sleep(3)
x <- runif(1,0,max)
session$sendCustomMessage(type='setText', paste('Your random number is', x))
return(NULL)
#})
})
})
Here is a solution on how you could use the future package in a shiny app.
It is possible to have multiple sessions with no session blocking another session when running a computationally intensive task or waiting for a sql query to be finished. I suggest to open two sessions (just open http://127.0.0.1:14072/ in two tabs) and play with the buttons to test the functionality.
run_app.R:
library(shiny)
library(future)
library(shinyjs)
runApp(host = "127.0.0.1", port = 14072, launch.browser = TRUE)
ui.R:
ui <- fluidPage(
useShinyjs(),
textOutput("existsFutureData"),
numericInput("duration", "Duration", value = 5, min = 0),
actionButton("start_proc", h5("get data")),
actionButton("start_proc_future", h5("get data using future")),
checkboxInput("checkbox_syssleep", label = "Use Sys.sleep", value = FALSE),
h5('Table data'),
dataTableOutput('tableData'),
h5('Table future data'),
dataTableOutput('tableFutureData')
)
server.R:
plan(multiprocess)
fakeDataProcessing <- function(duration, sys_sleep = FALSE) {
if(sys_sleep) {
Sys.sleep(duration)
} else {
current_time <- Sys.time()
while (current_time + duration > Sys.time()) { }
}
return(data.frame(test = Sys.time()))
}
#fakeDataProcessing(5)
############################ SERVER ############################
server <- function(input, output, session) {
values <- reactiveValues(runFutureData = FALSE, futureDataLoaded = 0L)
future.env <- new.env()
output$existsFutureData <- renderText({ paste0("exists(futureData): ", exists("futureData", envir = future.env)," | futureDataLoaded: ", values$futureDataLoaded) })
get_data <- reactive({
if (input$start_proc > 0) {
shinyjs::disable("start_proc")
isolate({ data <- fakeDataProcessing(input$duration) })
shinyjs::enable("start_proc")
data
}
})
observeEvent(input$start_proc_future, {
shinyjs::disable("start_proc_future")
duration <- input$duration # This variable needs to be created for use in future object. When using fakeDataProcessing(input$duration) an error occurs: 'Warning: Error in : Operation not allowed without an active reactive context.'
checkbox_syssleep <- input$checkbox_syssleep
future.env$futureData %<-% fakeDataProcessing(duration, sys_sleep = checkbox_syssleep)
future.env$futureDataObj <- futureOf(future.env$futureData)
values$runFutureData <- TRUE
check_if_future_data_is_loaded$resume()
},
ignoreNULL = TRUE,
ignoreInit = TRUE
)
check_if_future_data_is_loaded <- observe({
invalidateLater(1000)
if (resolved(future.env$futureDataObj)) {
check_if_future_data_is_loaded$suspend()
values$futureDataLoaded <- values$futureDataLoaded + 1L
values$runFutureData <- FALSE
shinyjs::enable("start_proc_future")
}
}, suspended = TRUE)
get_futureData <- reactive({ if(values$futureDataLoaded > 0) future.env$futureData })
output$tableData <- renderDataTable(get_data())
output$tableFutureData <- renderDataTable(get_futureData())
session$onSessionEnded(function() {
check_if_future_data_is_loaded$suspend()
})
}
I retooled André le Blond's excellent answer to and made a gist showing a generic asynchronous task processor which can be used either by itself or with Shiny: FutureTaskProcessor.R
Note it contains two files: FutureProcessor.R which is the stand alone asynchronous task handler and app.R which is a Shiny App showing use of the async handler within Shiny.
One admittedly complicated workaround to the single-threaded nature of R within Shiny apps is to do the following:
Splinter off an external R process (run another R script located in
the Shiny app directory, or any directory accessible from within the
Shiny session) from within R (I've tried this splintering before,
and it works).
Configure that script to output its results to a temp directory (assuming you're running Shiny on a Unix-based system) and give the output file a unique filename (preferably named within the namespace of the current session (i.e. "/tmp/[SHINY SESSION HASH ID]_example_output_file.RData".
Use Shiny's invalidateLater() function to check for the presence of that output file.
Load the output file into the Shiny session workspace.
Finally, trash collect by deleting the generated output file after loading.
I hope this helps.