Progress bar closes too soon with ggplot - r

I wonder if someone can explain the behavior of the progressBar().
I have trimmed my shiny app to the bare minimum to reproduce this post.
Now to the problem. When I select "AllRuns", the progress bar pops up and then goes away
before the graphic is displayed. But when I select "scatter", the progress bar nicely waits
until the scatter plot is displayed on the main panel. Is this a normal behavior?
How can I make the progress bar wait until the graphic displays when "AllRuns" is selected?
UPDATE The dataset can be read into R from google docs. it takes about 20 seconds to load into R.
library(shiny)
library(tidyverse)
library(DT)
library(data.table)
final <- fread("https://docs.google.com/spreadsheets/d/170235QwbmgQvr0GWmT-8yBsC7Vk6p_dmvYxrZNfsKqk/pub?output=csv")
runs<- c("AllRuns","scatter")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput(inputId = "run",
label = "Chinook Runs",
choices = runs,
selected = "AllRuns"),
sliderInput(inputId = "Yearslider",
label="Years to plot",
sep="",
min=2000,
max=2014,
value=c(2010,2012))),
mainPanel(
plotOutput("plot")
)))
server <- function(input, output,session) {
session$onSessionEnded(function() {
stopApp()
})
plot_all <- reactive({
final[final$year >= input$Yearslider[1] & final$year <= input$Yearslider[2], ]
})
plotscatter <- reactive({
rnorm(100000)
})
dataInput <- reactive({
if (input$run == "AllRuns") {
plot_all()
}else{
plotscatter()
}
})
# Plot data
create_plots <- reactive({
withProgress(message="Creating graphic....",value = 0, {
n <- 10
for (i in 1:n) {
incProgress(1/n, detail = input$run)
Sys.sleep(0.1)
}
#Make the plots
theme_set(theme_classic())
switch(input$run,
"AllRuns" = ggplot(plot_all(),aes(SampleDate,Count,color = race2)) +
geom_point() + theme_bw() +
labs(x="",y="Number in thousands",title="All Salmon Runs combined"),
"scatter" = plot(plotscatter(),col="lightblue")
)
})#Progress bar closing brackets
})#create_plots closing brackets
output$plot <- renderPlot({
create_plots()
})
}
# Run the application
shinyApp(ui = ui, server = server)

It is simple that the progress bar is updated by the for-loop and the plot code only run after the for-loop. So the progress-bar reach the end, then plot code started. This kind of progress-bar would work if you are process something along with for-loop for example
list_of_files # assume you have a list of data file to read and process
max_progress <- length(list_of_files)
withProgress(message="Creating graphic....",value = 0, {
for (i in 1:max_progress) {
data <- read_csv(list_of_files[i])
... # doing something here
# once the processing code done next line of code will update the progress bar
incProgress(1/n, detail = input$run)
}
})
If you want to display loading one way to do it is using shinycssloaders::withSpinner() on the UI part which would show an animation of loading while UI is updating by server side.
The withProgress would be more useful when you have a list of items to process.
library(shiny)
library(tidyverse)
library(DT)
library(data.table)
library(shinycssloaders)
final <- fread("https://docs.google.com/spreadsheets/d/170235QwbmgQvr0GWmT-8yBsC7Vk6p_dmvYxrZNfsKqk/pub?output=csv")
runs<- c("AllRuns","scatter")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput(inputId = "run",
label = "Chinook Runs",
choices = runs,
selected = "AllRuns"),
sliderInput(inputId = "Yearslider",
label="Years to plot",
sep="",
min=2000,
max=2014,
value=c(2010,2012))),
mainPanel(
withSpinner(plotOutput("plot"))
)))
server <- function(input, output,session) {
session$onSessionEnded(function() {
stopApp()
})
plot_all <- reactive({
final[final$year >= input$Yearslider[1] & final$year <= input$Yearslider[2], ]
})
plotscatter <- reactive({
rnorm(100000)
})
dataInput <- reactive({
if (input$run == "AllRuns") {
plot_all()
}else{
plotscatter()
}
})
# Plot data
create_plots <- reactive({
#Make the plots
theme_set(theme_classic())
switch(input$run,
"AllRuns" = ggplot(plot_all(),aes(SampleDate,Count,color = race2)) +
geom_point() + theme_bw() +
labs(x="",y="Number in thousands",title="All Salmon Runs combined"),
"scatter" = plot(plotscatter(),col="lightblue")
)
})#create_plots closing brackets
output$plot <- renderPlot({
create_plots()
})
}
# Run the application
shinyApp(ui = ui, server = server)

Related

How can I stop rhandsontable from starting an infinite loop after inputs in quick succession?

I'm using rhandsontable in a shiny app to manually update a dataframe to be displayed with ggplot2.
When adding/changing values in the rhandsontable in quick succession, the table starts an infinite loop, which immobilizes the entire shiny application.
Below an example. By quickly changing the values in the table, the app gets stuck.
library(shiny)
library(rhandsontable)
library(ggplot2)
ui <- fluidPage(
rHandsontableOutput("hot"),
plotOutput("plot")
)
server <- function(input, output, session) {
reactive.table <- reactiveValues(values = data.frame(x = c(1,2), y = c(1,2)))
observe({
if (!is.null(input$hot)) {
reactive.table$values <<- hot_to_r(input$hot)
}
})
output$hot <- renderRHandsontable({
rhandsontable(reactive.table$values)
})
output$plot <- renderPlot({
Sys.sleep(2)
ggplot(reactive.table$values, aes(x = x, y = y)) +
geom_point()
})
}
shinyApp(ui = ui, server = server)
Is there a way to stop the infinite loop or to disable further inputs until the plot is rendered?
Thanks.
I don't know how to stop rhandsontable from starting the infinite loop, but you can avoid inputs in quick succession altogether.
Taking your reprex, I restrict changes to be at least 1 second apart, and it works just fine.
library(shiny)
library(rhandsontable)
library(ggplot2)
ui <- fluidPage(
rHandsontableOutput("hot"),
plotOutput("plot")
)
server <- function(input, output, session) {
reactive.table <- reactiveValues(values = data.frame(x = c(1,2), y = c(1,2)))
rv_timer <- reactiveValues(
prev = NULL, current = NULL
)
observe({
if (!is.null(input$hot)) {
# if it's first time editing table:
if (is.null(rv_timer$prev)) {
rv_timer$prev <- Sys.time()
reactive.table$values <- hot_to_r(input$hot)
return(NULL)
}
# if it's not the first time to edit table, get current clock time:
rv_timer$current <- Sys.time()
# if the difference btwn prev recorded time and current time is less
# than 1second, don't do anything, just return:
if ((rv_timer$current - rv_timer$prev) < 1) {
return(NULL)
}
# otherwise proceed as normal:
reactive.table$values <- hot_to_r(input$hot)
# finally set current clock time as `rv_timer$prev` for use in the next
# invalidation:
rv_timer$prev <- Sys.time()
}
})
output$hot <- renderRHandsontable({
rhandsontable(reactive.table$values)
})
output$plot <- renderPlot({
Sys.sleep(2)
ggplot(reactive.table$values, aes(x = x, y = y)) +
geom_point()
})
}
shinyApp(ui = ui, server = server)
Might be a bug in {rhansontable}.

R Shiny: Using assign() to compose the name of reactive output elements fails

What I am trying to achieve is to handle dynamically generated UI elements with names based on a counter that is triggered on a button click. This works fine, but I cannot compose the names of these output elements using assign(). Here is a simple example that demonstrates the problem:
library(shiny)
ui <- fluidPage(
actionButton("run_btn", "Run"),
plotOutput('Plot1'),
plotOutput('Plot2'),
plotOutput('Plot3')
)
server <- function(input, output, clientData, session) {
observeEvent(input$run_btn, {
myplot <- renderPlot({
boxplot(1:100)
})
assign(paste('output$Plot', sep = "", input$run_btn), myplot) # DOES NOT WORK!
# output$Plot1 <- myplot # THIS WORKS!
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm inferring that you want to stack new plots in some fashion, additive, potentially with some cleanup?
Actions:
Press the Run button, it creates a plot of mtcars with a random car highlighted.
Repeat this multiple times, each time a new plot is added, stacked before/above all other plots.
Press the Trim button, and all plots except the most-recent are removed from the UI completely.
library(shiny)
ui <- fluidPage(
actionButton("trim_btn", "Trim"),
actionButton("run_btn", "Run")
)
someplot <- function(nm) {
rand <- sample(nrow(mtcars), size = 1)
plot(disp ~ mpg, data = mtcars, main = paste(nm, "-", rownames(mtcars)[rand]), pch = 16, cex = 1)
points(disp ~ mpg, data = mtcars[rand,,drop=FALSE], pch = 16, cex = 2, col = "red")
}
server <- function(input, output, session) {
idcount <- reactiveVal(0)
observeEvent(input$run_btn, {
thisid <- idcount() + 1
idcount(thisid)
thisid <- paste0("plot", thisid)
insertUI(selector = "#run_btn", where = "afterEnd",
ui = plotOutput(thisid))
output[[thisid]] <- renderPlot({ someplot(thisid) })
})
observeEvent(input$trim_btn, {
curid <- idcount() - 1
if (curid > 0) {
selectors <- paste0("#plot", seq_len(curid))
# this could be improved to only remove existing selectors
for (sel in selectors) removeUI(selector = sel)
}
})
}
# # Run the application
shinyApp(ui = ui, server = server)

How to show a progressBar in a single function in shiny?

Here is an example. The progress bar just jumps from 0% to 100% due a single function getres(). How to indicate the progress smoothly?
library("shiny")
library("shinyWidgets")
library("DESeq2")
library("airway")
data(airway)
getres <- function(eset){
dds<-DESeqDataSet(eset, design = ~cell + dex)
keep <- rowSums(counts(dds)) >= 10
dds <- dds[keep,]
dds <- DESeq(dds)
res <- results(dds)
return(res)
}
ui <- fluidPage(
tags$h1("Progress bar in Sweet Alert"),
useSweetAlert(), # /!\ needed with 'progressSweetAlert'
actionButton(
inputId = "go",
label = "Launch long calculation !"
)
)
server <- function(input, output, session) {
observeEvent(input$go, {
progressSweetAlert(
session = session, id = "myprogress",
title = "Work in progress",
display_pct = TRUE, value = 0
)
for (i in seq_len(1)) {
Sys.sleep(0.1)
updateProgressBar(
session = session,
id = "myprogress",
res<-getres(airway),
value = i
)
}
closeSweetAlert(session = session)
sendSweetAlert(
session = session,
title =" Calculation completed !",
type = "success"
)
})
}
shinyApp(ui = ui, server = server)
I was unable to run your example as airway and DESeq2 are not available for R 3.6+. BUT there is an interesting package that I have been meaning to try out called waiter.
Within waiter there is waitress which will "let you display loading bars on the entire screen or specific elements only."
There is a great demo app where you play with the different functions.
Here is an example from the docs!
library(shiny)
library(waiter)
ui <- navbarPage(
"Waitress on nav",
tabPanel(
"home",
use_waitress(),
plotOutput("plot")
)
)
server <- function(input, output){
# now waitress ranges from 0 to 100
waitress <- Waitress$new("nav", theme = "overlay", min = 0, max = 10)
output$plot <- renderPlot({
for(i in 1:10){
waitress$inc(1) # increase by 10%
Sys.sleep(.5)
}
hist(runif(100))
waitress$close() # hide when done
})
}
shinyApp(ui, server)
Hope this helps or gives you other ideas!

Display and save a grid's gtable/gTree/grob/gDesc in a shiny app

I have a function that's arranging a plot in a grid:
plotFunc <- function(a,b)
{
p <- qplot(a,b)
p2 <- xyplot(1~1)
r <- grid::rectGrob(gp=gpar(fill="grey90"))
t <- grid::textGrob("text")
g <- gridExtra::grid.arrange(t, p, p2, r, ncol=2)
return(g)
}
So the return value is:
"gtable" "gTree" "grob" "gDesc"
I want to use a shiny app in order to be able to select a and b values display the resulting plot and also have the option to save it to a file.
Here's my code:
data:
set.seed(1)
vals.df <- data.frame(b=1:6,a=sample(1:2,6,replace=T))
Shiny code:
library(shiny)
library(ggplot2)
library(lattice)
library(SpaDES)
library(devtools)
server <- function(input, output)
{
output$b <- renderUI({
selectInput("b", "B", choices = unique(dplyr::filter(vals.df,a == input$a)$b))
})
my.plot <- reactive({function(){plotFunc(a = input$a,b == input$b)}})
output$plot <- renderPlot({
my.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0(input$a,"_",input$b,".png")
},
content = function(file) {
ggsave(my.plot(),filename=file)
}
)
}
ui <- fluidPage(
# App title ----
titlePanel("Feature Plots"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# select name
selectInput("a", "A", choices = unique(vals.df$a)),
uiOutput("b"),
downloadButton('save', 'Save to File')
),
# Main panel for displaying outputs ----
mainPanel(
# The plot is called feature.plot and will be created in ShinyServer part
plotOutput("plot")
)
)
)
When I run shinyApp(ui = ui, server = server) and select a and b values from their lists a figure is not displayed to the screen and when I click the Save to File button I get this error:
ERROR: no applicable method for 'grid.draw' applied to an object of class "function"
I tried wrapping the my.plot() calls with grid.draw but I get the same error:
no applicable method for 'grid.draw' applied to an object of class "function"
Any idea?
Note that I can't get it to work even if plotFunc returns the ggplot2 object (i.e., the grid calls are commented out). But solving this for the example above is more general and would also solve it for the ggplot2 more specific case.
You can do like this:
my.plot <- reactive({
if(!is.null(input$a) & !is.null(input$b)){
plotFunc(a = input$a,b = input$b)
}
})
The change i did was to remove the function. I wasnt sure why you need it and i think it caused the error in the download. Moreover, the second input you give over as a logical statement == which will create an error.
Full code would read:
set.seed(1)
vals.df <- data.frame(b=1:6,a=sample(1:2,6,replace=T))
plotFunc <- function(a,b)
{
p <- qplot(a,b)
p2 <- xyplot(1~1)
r <- grid::rectGrob(gp=gpar(fill="grey90"))
t <- grid::textGrob("text")
g <- gridExtra::grid.arrange(t, p, p2, r, ncol=2)
return(g)
}
library(shiny)
library(ggplot2)
library(lattice)
library(SpaDES)
library(devtools)
server <- function(input, output)
{
output$b <- renderUI({
selectInput("b", "B", choices = unique(dplyr::filter(vals.df,a == input$a)$b))
})
my.plot <- reactive({
if(!is.null(input$a) & !is.null(input$b)){
plotFunc(a = input$a,b = input$b)
}
})
output$plot <- renderPlot({
my.plot()
})
output$save <- downloadHandler(
filename = function() {
paste0(input$a,"_",input$b,".png")
},
content = function(file) {
ggsave(my.plot(),filename=file)
}
)
}
ui <- fluidPage(
# App title ----
titlePanel("Feature Plots"),
# Sidebar layout with a input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# select name
selectInput("a", "A", choices = unique(vals.df$a)),
uiOutput("b"),
downloadButton('save', 'Save to File')
),
# Main panel for displaying outputs ----
mainPanel(
# The plot is called feature.plot and will be created in ShinyServer part
plotOutput("plot")
)
)
)
shinyApp(ui = ui, server = server)

Run Shiny Reactive after Another Finishes

I have two outputs, a print and a plot. I would like to execute the print after the run button is pressed (working) and then when the print completes the plot part executes.
The reason for this is the print part does some calculations that take a few minutes and the output from that needs to go to the plot command.
Simple example:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton('run','Run')
),
mainPanel(
verbatimTextOutput("Descriptive"),
plotOutput("plotData",width = "700px", height = "500px")
)
)
)
server <- function(input, output) {
output$Descriptive <- renderPrint({
if(input$run>0){
return(isolate({
cat('Number of rows:', nrow(mtcars))
mpg2 <<- mtcars$mpg+3
cyl2 <<- mtcars$cyl+3
}))
}else{return(invisible())}
})
#### RUN AFTER DESCRIPTIVE COMPLETES ####
output$plotData <- renderPlot({
plot(mpg2,cyl2)
})
}
shinyApp(ui = ui, server = server)
I would suggest you to store the variable as reactiveValues and make the plot dependent on them. By this you can avoid the current global assignment and also make the plot update dependent on a change in its variables.
It could look like this:
global <- reactiveValues(mpg2 = mtcars$mpg, cyl2 = mtcars$cyl, txt = "")
observe({
if(input$run > 0){
Sys.sleep(5) # simulate minutes of calculating
global$txt <- paste('Number of rows:', nrow(mtcars))
global$mpg2 <- mtcars$mpg + 3
global$cyl2 <- mtcars$cyl + 3
}
})
Your app would look like this:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton('run','Run')
),
mainPanel(
verbatimTextOutput("Descriptive"),
plotOutput("plotData",width = "700px", height = "500px")
)
)
)
server <- function(input, output) {
global <- reactiveValues(mpg2 = mtcars$mpg, cyl2 = mtcars$cyl, txt = "")
observe({
if(input$run > 0){
Sys.sleep(5) # simulate minutes of calculating
global$txt <- paste('Number of rows:', nrow(mtcars))
global$mpg2 <- mtcars$mpg + 3
global$cyl2 <- mtcars$cyl + 3
}
})
output$Descriptive <- renderPrint({
if(nchar(global$txt)) return(global$txt)
})
#### RUN AFTER DESCRIPTIVE COMPLETES ####
output$plotData <- renderPlot({
plot(global$mpg2, global$cyl2)
})
}
shinyApp(ui = ui, server = server)

Resources