I'm having trouble creating a sequence of events in a Shiny app. I know there are other ways of handling parts of this issue (with JS), and also different Shiny functions I could use to a similar end (e.g. withProgress), but I'd like to understand how to make this work with reactivity.
The flow I hope to achieve is as follows:
1) user clicks action button, which causes A) a time-consuming calculation to begin and B) a simple statement to print to the UI letting the user know the calculation has begun
2) once calculation returns a value, trigger another update to the previous text output alerting the user the calculation is complete
I've experimented with using the action button to update the text value, and setting an observer on that value to begin the calculation (so that 1B runs before 1A), to ensure that the message isn't only displayed in the UI once the calculation is complete, but haven't gotten anything to work. Here is my latest attempt:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("run", "Pull Data")
mainPanel(
textOutput("status")
)
)
)
server <- function(input, output, session) {
# slow function for demonstration purposes...
test.function <- function() {
for(i in seq(5)) {
print(i)
Sys.sleep(i)
}
data.frame(a=c(1,2,3))
}
report <- reactiveValues(
status = NULL,
data = NULL
)
observeEvent(input$run, {
report$status <- "Pulling data..."
})
observeEvent(report$status == "Pulling data...", {
report$data <- test.function()
})
observeEvent(is.data.frame(report$data), {
report$status <- "Data pull complete"
}
)
observe({
output$status <- renderText({report$status})
})
}
Eventually, I hope to build this into a longer cycle of calculation + user input, so I'm hoping to find a good pattern of observers + reactive elements to handle this kind of ongoing interaction. Any help is appreciated!
Related
Let's say I have created 10 selectInput dropdowns for a multi plot export and these selectInputs are called "xaxis_1", "xaxis_2", ..... , "xaxis_10"
for a single 1 I can write:
if(!is.null(input$xaxis_1)) { .... do stuff } to stop it running export when the user hasn't entered any name, and presses submit, to avoid crashes.
A bit more general you can check this:
if(!is.null(input[[paste('xaxis', i, sep = '_')]])) { ...}
how can you write it elegantly so that 1 line of code checks whether ANY of the 1:10 input[[...]] is empty, i.e. NULL?
The nr of inputs depends on how many plots the user wants to export per file, so all is build with lapply(1:input$nrofplots, function(i) { .... } renderUI structure, and my if statement needs to have the same flexibility of 1:n
In a situation like below in the image, pressing Initiate export should give a sweetalert (got that covered) saying there is at least 1 value missing
Here a snippet I used in the UI side to validate the user's inputs.
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(), # Set up shinyjs
numericInput('axis1','Val 1',1),
numericInput('axis2','Val 2',1),
numericInput('axis3','Val 3',1),
actionButton('Go','Plot')
)
server <- function(input, output, session) {
#Try 1, space, AAA and check what shiny will return
observe(print(input$axis1))
observe({
All_Inputs <- vapply(paste0('axis',1:3),
function(x){isTruthy(input[[x]])},
logical(1))
All_InputsCP <- all(All_Inputs)
shinyjs::toggleState(id="Go", condition = All_InputsCP) #This is to make the button Go able or disable according to condition All_InputsCP #
})
}
shinyApp(ui, server)
I hope it helps.
I have developed a Shiny app that allows the user conditional selection of some dependent events. A very simplified toy example is below to help illustrate my question/problem.
In my real problem, the server code contains multiple computationally expensive procedures that are optional to run. There is a "baseline" function that must run to produce output and then firstObject or secondObject take that as input and produce more output if it is selected by the user to do so.
Each function can take upwards of 30 to 40 minutes. So, I wrote the code to allow the user to select using the checkInputBox which functions they want to run and then after selecting them, there is a single action button that runs them all allowing the user to leave and let the process take its course over many hours. This was more convenient than having an actionButton associated with each possible event.
The code below is successful in yielding all the desired output. But, I am not sure from a design point of view if it is "right". In my toy example, the code is simple, but suppose the code for baseObject takes 30 minutes to run. While baseObject is running, the code for firstObject and secondObject were also executed because they depend on the same action button. But, they cannot do anything until the function for baseObject is done. Similarly secondObject cannot do anything until firstObject is done.
Again, this all works and yields the correct output (in my real code as well as in the toy code). But, is there a way to maintain the single action button, but for firstObject to not do anything UNTIL baseline Object has produced its output and then secondObject would wait for firstObject to yield its output if the user selected it.
My worry is that I am creating additional computational overhead in the firstObject is trying to do something it cannot do until baseObject is done and it is cycling over and over until it can properly execute.
I know I can create different action buttons. For instance I could create an action button for baseline and then the user could wait until it is done and then click the action button for firstObject and so on. But, functionally this would not work as in the real problem this allows the entire selected process to run, which can take hours and the user does not need to be in front of their machine.
Thank you and I hope this code helps illustrate the problem as I have described it.
ui <- {
fluidPage(
h3('Run Stuff'),
checkboxInput("runModel1", "Model 1"),
checkboxInput("runModel2", "Model 2"),
actionButton('runAll', 'Run Models'),
verbatimTextOutput("out1"),
verbatimTextOutput("out2")
)
}
server <- function(input, output, session) {
baseObject <- eventReactive(input$runAll, {
if(input$runModel1){
runif(100)
}
})
firstObject <- eventReactive(input$runAll, {
if(input$runModel1){
runif(100) + baseObject()
}
})
secondObject <- eventReactive(input$runAll, {
if(input$runModel2){
runif(100) + firstObject()
}
})
output$out1 <- renderPrint({
if (input$runModel1)
firstObject()
})
output$out2 <- renderPrint({
if (input$runModel2)
secondObject()
})
} # end server
shinyApp(ui, server) #run
Two things to remember about reactive expressions:
Reactive expressions are lazy and only execute when called by something else. This is different from observers, which execute immediately any time their dependencies change.
Reactive expression results are cached. As long as their dependencies have not changed, subsequent calls won't cause the expression to re-execute, but instead retrieve the cached value.
Based on these two points, I don't think you have a problem and your example does what you're looking for. With both checkboxes ticked, each reactive expression would only run once per action button click.
Although I can suggest removing the unnecessary if statements in the eventReactives. That would allow the user to only check runModel2 and have all its dependencies run properly. Modified example below - I also added some message(...) statements so you can see the execution flow in the R console.
library(shiny)
ui <- fluidPage(
h3('Run Stuff'),
checkboxInput("runModel1", "Model 1"),
checkboxInput("runModel2", "Model 2"),
actionButton('runAll', 'Run Models'),
verbatimTextOutput("out1"),
verbatimTextOutput("out2")
)
server <- function(input, output, session) {
baseObject <- eventReactive(input$runAll, {
message("calculating baseObject...")
result <- runif(100)
message("...baseObject done")
return(result)
})
firstObject <- eventReactive(input$runAll, {
message("calculating firstObject...")
result <- runif(100) + baseObject()
message("...firstObject done")
return(result)
})
secondObject <- eventReactive(input$runAll, {
message("calculating secondObject...")
result <- runif(100) + firstObject()
message("...secondObject done")
return(result)
})
output$out1 <- renderPrint({
if (input$runModel1)
firstObject()
})
output$out2 <- renderPrint({
if (input$runModel2)
secondObject()
})
}
shinyApp(ui, server)
I have a small shiny app for annotating text files.
The UI provides fileInput to select .txt files. One of the files is the default when the app is launched.
Next, Previous buttons allow user to display the contents of the file, one sentence at a time.
User may select any text within a sentence and click the Add Markup button to annotate the sentence. The Action Button triggers javascript function addMarkup().
The sentence is displayed after being marked up.
I am only posting the shiny app code here. Complete code of the app is available on github repository
library(shiny)
ui <- fluidPage(
tags$head(tags$script(src="textselection.js")),
titlePanel("Corpus Annotation Utility"),
sidebarLayout(
sidebarPanel(
fileInput('fileInput', 'Select Corpus', accept = c('text', 'text','.txt')),
actionButton("Previous", "Previous"),
actionButton("Next", "Next"),
actionButton("mark", "Add Markup")
),
mainPanel(
tags$h1("Sentence: "),
htmlOutput("sentence"),
tags$h1("Sentence marked up: "),
htmlOutput("sentenceMarkedUp")
)
)
)
server <- function(input, output) {
sourceData <- reactive({
corpusFile <- input$fileInput
if(is.null(corpusFile)){
return(readCorpus('data/news.txt'))
}
readCorpus(corpusFile$datapath)
})
corpus <- reactive({sourceData()})
values <- reactiveValues(current = 1)
observeEvent(input$Next,{
if(values$current >=1 & values$current < length(corpus())){
values$current <- values$current + 1
}
})
observeEvent(input$Previous,{
if(values$current > 1 & values$current <= length(corpus())){
values$current <- values$current - 1
}
})
output$sentence <- renderText(corpus()[values$current])
}
shinyApp(ui = ui, server = server)
readCorpus() function looks like this:
readCorpus <- function(pathToFile){
con <- file(pathToFile)
sentences <- readLines(con, encoding = "UTF-8")
close(con)
return(sentences)
}
My question is how can I persist the sentences to a file after they have been annotated?
Update:
I have gone through Persistent data storage in Shiny apps, and hope that I will be able to follow along the documentation regarding persistent storage. However I am still unsure how to capture the sentence after it has been marked up.
You have two issues here - persisting the changes, and then saving the output. I solved the problem using a bit of JS and a bit of R code. I'll do a pull request on Github to submit the broader code. However, here's the core of it.
In your Javascript that you use to select things, you can use Shiny.onInputChange() to update an element of the input vector. Doing this, you can create a reactiveValues item for the corpus, and then update it with inputs from your interface.
Below, you'll notice that I switched from using a textnode to using just the inner HTML. Using a node, and firstChild, as you had it before, you end up truncating the sentence after the first annotation (since it only picks the stuff before <mark>. Doing it this way seems to work better.
window.onload = function(){
document.getElementById('mark').addEventListener('click', addMarkup);
}
function addMarkup(){
var sentence = document.getElementById("sentence").innerHTML,
selection="";
if(window.getSelection){
selection = window.getSelection().toString();
}
else if(document.selection && document.selection.type != "Control"){
selection = document.selection.createRange().text;
}
if(selection.length === 0){
return;
}
marked = "<mark>".concat(selection).concat("</mark>");
result = sentence.replace(selection, marked);
document.getElementById("sentence").innerHTML = result;
Shiny.onInputChange("textresult",result);
}
Next, I've tried to simplify your server.R code. You were using a reactive context to pull from another reactive context (sourceData into corpus), which seemed unnecessary. So, I tried to refactor it a bit.
library(shiny)
source("MyUtils.R")
ui <- fluidPage(
tags$head(tags$script(src="textselection.js")),
titlePanel("Corpus Annotation Utility"),
sidebarLayout(
sidebarPanel(
fileInput('fileInput', 'Select Corpus', accept = c('text', 'text','.txt')),
actionButton("Previous", "Previous"),
actionButton("Next", "Next"),
actionButton("mark", "Add Markup"),
downloadButton(outputId = "save",label = "Download")),
mainPanel(
tags$h1("Sentence: "),
htmlOutput("sentence"))
)
)
server <- function(input, output) {
corpus <- reactive({
corpusFile <- input$fileInput
if(is.null(corpusFile)) {
return(readCorpus('data/news.txt'))
} else {
return(readCorpus(corpusFile$datapath))
}
})
values <- reactiveValues(current = 1)
observe({
values$corpus <- corpus()
})
output$sentence <- renderText(values$corpus[values$current])
observeEvent(input$Next,{
if(values$current >=1 & values$current < length(corpus())) {
values$current <- values$current + 1
}
})
observeEvent(input$Previous,{
if(values$current > 1 & values$current <= length(corpus())) {
values$current <- values$current - 1
}
})
observeEvent(input$mark,{
values$corpus[values$current] <- input$textresult
})
output$save <- downloadHandler(filename = "marked_corpus.txt",
content = function(file) {
writeLines(text = values$corpus,
con = file,
sep = "\n")
})
}
Now, the code has a few changes. The loading from file is basically the same. I was right about my skepticism on isolate - replacing it with an observe accomplishes what I wanted to do, whereas isolate would only give you the initial load. Anyway, we use observe to load the corpus values into the reactiveValues object you created - this is to give us a place to propagate changes to the data.
We keep the remaining logic for moving forward and backward. However, we change the way the output is rendered so that it looks at the reactiveValues object. Then, we create an observer that updates the reactiveValues object with the input from our updated Javascript. When this happens, the data gets stored permanently, and you can also mark more than one sequence in the string (though I have not done anything with nested marking or with removing marks). Finally, a save function is added - the resulting strings are saved out with <mark> used to show the marked areas.
If you load a previously marked file, the marks will show up again.
Note : I have read almost all the discussions on this object in shiny googlegroups and here in SO.
I need an indicator that shows the shiny server is busy. I have tried shiny-incubator, however, the problem is that I can't set a max for progress bar.
I don't want something like this : https://shiny.rstudio.com/gallery/progress-bar-example.html
What I need is something that:
shows a busy indicator message and bar (i.e just a simple animated bar, do not need to show a filling bar) as long as the server is calculating
it is shown in no matter which tab you are viewing. (not only in the related tab, but on top of the tabset)
Update 2018: Currently there is a great package to help you display loaders: shinycssloaders (source: https://github.com/andrewsali/shinycssloaders)
I've been looking for this as well. Most people suggest a conditional panel like so:
conditionalPanel(
condition="!($('html').hasClass('shiny-busy'))",
img(src="images/busy.gif")
)
You could always give yourself more control and create the conditional handling (maybe depending on more stuff) like this in your ui.R:
div(class = "busy",
p("Calculation in progress.."),
img(src="images/busy.gif")
)
where some JavaScript handles the showing and hiding of that div:
setInterval(function(){
if ($('html').attr('class')=='shiny-busy') {
$('div.busy').show()
} else {
$('div.busy').hide()
}
},100)
with some extra css you could make sure your animated busy image gets a fixed postion where it will always be visible.
In any of the above cases i found that the "shiny-busy" condition is somewhat imprecise and unreliable: the div shows for a split second and disappears while computations are still going on...
I found a dirty solution to fix that problem, at least in my apps. Feel free to try it out and maybe someone could give an insight to how and why this solves the issue.
In your server.R you'll need to add two reactiveValues:
shinyServer(function(input, output, session) {
# Reactive Value to reset UI, see render functions for more documentation
uiState <- reactiveValues()
uiState$readyFlag <- 0
uiState$readyCheck <- 0
then, in your renderPlot function (or other output function where computations go on), you use these reactive values to reset the function:
output$plot<- renderPlot({
if (is.null(input$file)){
return()
}
if(input$get == 0){
return()
}
uiState$readyFlag
# DIRTY HACK:
# Everytime "Get Plot" is clicked we get into this function
# In order for the ui to be able show the 'busy' indicator we
# somehow need to abort this function and then of course seamlessly
# call it again.
# We do this by using a reactive value keeping track of the ui State:
# renderPlot is depending on 'readyFlag': if that gets changed somehow
# the reactive programming model will call renderPlot
# If readyFlag equals readyCheck we exit the function (= ui reset) but in the
# meantime we change the readyFlag, so the renderHeatMap function will
# immediatly be called again. At the end of the function we make sure
# readyCheck gets the same value so we are back to the original state
isolate({
if (uiState$readyFlag == uiState$readyCheck) {
uiState$readyFlag <- uiState$readyFlag+1
return(NULL)
}
})
isolate({plot <- ...})
# Here we make sure readyCheck equals readyFlag once again
uiState$readyCheck <- uiState$readyFlag
return(plot)
})
Alternatively, you can use shinycssloaders package https://github.com/andrewsali/shinycssloaders
library(shiny)
library(dplyr)
library(shinycssloaders)
ui <- fluidPage(
actionButton("plot","plot"),
plotOutput("Test") %>% withSpinner(color="#0dc5c1")
)
server <- function(input, output, session) {
data <- eventReactive(input$plot,{
rnorm(1:100000)
})
output$Test <- renderPlot({
plot(data())
})
}
shinyApp(ui = ui, server = server)
Using waiter
library(shiny)
library(waiter)
ui <- fluidPage(
use_waiter(),
actionButton("plot","plot"),
plotOutput("Test")
)
server <- function(input, output, session) {
w <- Waiter$new(id = "Test")
data <- eventReactive(input$plot,{
w$show()
rnorm(1:100000)
})
output$Test <- renderPlot({
plot(data())
})
}
shinyApp(ui = ui, server = server)
I found using fadeIn() as opposed to show() helps mitigate this blinking occurence:
setInterval(function(){
if ($('html').attr('class')=='shiny-busy') {
setTimeoutConst = setTimeout(function(){
$('#loading-page').fadeIn(500);
}, delay);
} else {
clearTimeout(setTimeoutConst );
$('#loading-page').hide();
}
},10)
The busy div also appears for split seconds for the latest versions of shiny, even though no apparent calculations are going on (it was not an issue in older versions). Shiny seems to be regularly in its busy-mode for a short time. As a solution (complementing the above discussion), one can include another 2nd delayed validation of the shiny-busy html class for the conditional handling. The JavaScript-part would look something like that (example also includes check for two different div.busy-states depending on the reactive textit):
if( ($('html').attr('class')=='shiny-busy') ){
setTimeout(function() {
if ($('html').attr('class')=='shiny-busy') {
if($('#textit').html()!='Waiting...' ){
$('div.busy1').show()
}
if($('#textit').html()=='Waiting...'){
$('div.busy2').show()
}
}
},1000)
} else {
$('div.busy1').hide()
$('div.busy2').hide()
}
},100)
I am running into an issue because observe is being called first before the UI loads.
Here is my ui.R
sidebarPanel(
selectInput("Desk", "Desk:" , as.matrix(getDesksUI())),
uiOutput("choose_Product"), #this is dynamically created UI
uiOutput("choose_File1"), #this is dynamically created UI
uiOutput("choose_Term1"), #this is dynamically created UI ....
Here is my Server.R
shinyServer(function(input, output,session) {
#this is dynamic UI
output$choose_Product <- renderUI({
selectInput("Product", "Product:", as.list(getProductUI(input$Desk)))
})
#this is dynamic UI
output$choose_File1 <- renderUI({
selectInput("File1", "File 1:", as.list(getFileUI(input$Desk, input$Product)))
})
#this is dynamic UI and I want it to run before the Observe function so the call
# to getTerm1UI(input$Desk, input$Product, input$File1) has non-null parameters
output$choose_Term1 <- renderUI({
print("Rendering UI for TERM")
print(paste(input$Desk," ", input$Product, " ", input$File1,sep=""))
selectInput("Term1", "Term:", getTerm1UI(input$Desk, input$Product, input$File1))
})
This is my observe function and it runs before the input$Product and input$File1 are populated so I get an error because they are both NULL. But I need to use the input from the UI.
observe({
print("in observe")
print(input$Product)
max_plots<-length(getTerm2UI(input$Desk, input$Product, input$File1))
#max_plots<-5
# Call renderPlot for each one. Plots are only actually generated when they
# are visible on the web page.
for (i in 1:max_plots ) {
# Need local so that each item gets its own number. Without it, the value
# of i in the renderPlot() will be the same across all instances, because
# of when the expression is evaluated.
local({
my_i <- i
plotname <- paste("plot", my_i, sep="")
output[[plotname]] <- renderPlot({
plot(1:my_i, 1:my_i,
xlim = c(1, max_plots ),
ylim = c(1, max_plots ),
main = paste("1:", my_i, ". n is ", input$n, sep = "") )
})
})
}##### End FoR Loop
},priority = -1000)
Any idea how to get the input$Product and input$File1 to be populated BEFORE observe runs?
Thank you.
EDIT: Scroll down to TClavelle's answer for a better solution. While this answer has the most upvotes, I wrote it when Shiny had fewer features than it does today.
The simplest way is to add an is.null(input$Product) check at the top of each observe, to prevent it from running before the inputs it uses are initialized.
If you don't want your observers to do the null-check each time they're run, you can also use the suspended = TRUE argument when registering them to prevent them from running; then write a separate observer that performs the check, and when it finds that all inputs are non-null, calls resume() on the suspended observers and suspends itself.
You need to use the Shiny Event Handler and use observeEvent instead of observe. It seems to be about the only way to get rid of the "Unhandled error" message caused by NULL values on app startup. This is so because unlike observe the event handler ignores NULL values by default.
So your observe function could end up looking something like this (no need for priorities, or resume/suspended etc!)
observeEvent(input$Product, ({
max_plots<-length(getTerm2UI(input$Desk, input$Product, input$File1))
... (etc)
})# end of the function to be executed whenever input$Product changes
)
I could not copy paste your example code easily to make it run, so I'm not entirely sure what your full observe function would look like.
You can use req() to "require" an input before a reactive expression executes, as per the Shiny documentation here: https://shiny.rstudio.com/articles/req.html and the function documentation here: https://shiny.rstudio.com/reference/shiny/latest/req.html
e.g.
observeEvent({
req(input$Product)
req(input$File1)
# ...
})
We'd need an MRE to provide a working answer, but, assuming you need input$Product and input$File1, but do not want to take a dependency on them, only on input$Desk, you could:
observe({
product <- isolate(input$Product)
file1 <- isolate(input$File1)
print("in observe")
print(product)
max_plots<-length(getTerm2UI(input$Desk, product, file1))
for (i in 1:max_plots ) {
# ...
}
})
this is probably effectively equivalent to an observeEvent(input$Desk, ....), but might offer more flexibility.