Run Shiny Reactive after Another Finishes - r

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)

Related

Progress bar closes too soon with ggplot

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)

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)

Can we check shiny applications using testthat and usethis

is there a way to check the below applications. This is a sample application to display selected rows. But in general is there a way to acheive this. For example the below code is perfect. Suppose I may some errors in this and I need to check all in once. Can we do that? I have also pasted the error code down
Correct
library(shiny)
library(DT)
ui <- basicPage(
mainPanel(DT::dataTableOutput('mytable')),
textOutput("selected")
)
server <- function(input, output,session) {
mydata <- reactive({mtcars})
output$mytable = DT::renderDataTable(
datatable(mydata())
)
selectedRow <- eventReactive(input$mytable_rows_selected,{
row.names(mtcars)[c(input$mytable_rows_selected)]
})
output$selected <- renderText({
selectedRow()
})
}
runApp(list(ui = ui, server = server))
Wrong/Error code
library(shiny)
library(DT)
ui <- basicPage(
mainPanel(DT::dataTableOutput('mytable')),
textOutput("selected")
)
server <- function(input, output,session) {
mydata <- reactive({mtcars})
output$mytable = DT::renderDataTable(
datatable(mydata())
)
selectedRow <- eventReactive(input$mytable_rows_selected,{
row.names(mtcars)[c(input$[mytable_rows_selected])]
})
output$selected <- renderText({
selectedRow
})
}
runApp(list(ui = ui, server = server))
I use the package shinytest to test my shiny apps. shinytest uses phantomJS to manipulate the app (i.e. simulate button presses etc.)
An entry in testthat/test-shinyapp.R looks something like:
test_that("Shiny template works", {
app <- shinytest::ShinyDriver$new("Path_To_ShinyApp/"))
# plot changes
# first click makes plot
testthat::expect_false(length(grepl("^(data:image/png;base64)",
app$getAllValues()$output$plot1$src)) > 0)
app$setInputs(apply = "click")
testthat::expect_true(length(grepl("^(data:image/png;base64)",
app$getAllValues()$output$plot1$src)) > 0)
testthat::expect_true(grepl("^(data:image/png;base64)",
app$getAllValues()$output$plot1$src))
# are subsequent changes applied?
testthat::expect_identical(app$getAllValues()$input$xVar, "mpg")
testthat::expect_true(
grepl(" mpg cyl", app$getAllValues()$output$summary1))
app$setInputs(xVar = "drat")
app$setInputs(apply = "click")
testthat::expect_true(
grepl(" drat cyl", app$getAllValues()$output$summary1))
# # test for reactive
# shinytest::expectUpdate(app, xVar = "wt", output = "plot1" )
# shinytest::expectUpdate(app, yVar = "drat", output = "plot1" )
# shinytest::expectUpdate(app, xVar = "cyl", output = "summary1" )
# shinytest::expectUpdate(app, yVar = "mpg", output = "summary1" )
# cleanup
app$stop()
unlink(paste0(ws2us(testDir),"_ShinyApp"), recursive = TRUE)
})

attempt to apply non-function

I'm trying to build a simple application that draws a histogram of a selected variable based on a subset filtered by the other input. I get the error in the line hist(dataX()$datasetInput()) which should return dataX$mpg. How can I fix it?
Full code:
library(shiny)
u <- shinyUI(pageWithSidebar(
headerPanel("Staz w bezrobociu"),
sidebarPanel(
selectInput("variable", "Variable:",
list("Milles/gallon",
"Horse power")
),
textInput("nc","Number of cylinders",value = 6)
),
mainPanel(
plotOutput("Plot")
)
))
s <- shinyServer(function(input, output)
{
dataX <- reactive({mtcars[mtcars$cyl==input$nc,,drop = FALSE]})
datasetInput <- reactive({
switch(input$variable,
"Milles/gallon" = mpg,
"Horse power" = hp)
})
output$Plot <- renderPlot({
hist(dataX()$datasetInput())
})
})
shinyApp(u,s)
You complicated the simple app.
You do not need to list all the columns in selectInput. You can just render it from the server side.
Same applies to the cylinders
Shortcuts like u and sare acceptable, but just stick to the naming conventions. It makes your life easy.
Below is a complete working app
library(shiny)
ui <- shinyUI(pageWithSidebar(
headerPanel("Staz w bezrobociu"),
sidebarPanel(uiOutput("SelectColname"),
uiOutput("Cylinders")),
mainPanel(plotOutput("Plot"))
))
server <- shinyServer(function(input, output){
# Create a reactive dataset
dataX <- reactive({
mtcars
})
# Output number cylinders as select box
output$Cylinders <- renderUI({
selectInput("cylinders", "cylinders:", unique(dataX()$cyl))
})
# Output column names as selectbox
output$SelectColname <- renderUI({
selectInput("variable", "Variable:", colnames(dataX()[,c(1,4)]))
})
# Based on the selection by user, create an eventreactive plotdata object
plotdata <- eventReactive(input$cylinders, {
plotdata = dataX()[dataX()$cyl == input$cylinders, , drop = FALSE]
})
# Render the plot, the plot changes when new cylinder is selected
output$Plot <- renderPlot({
if (is.null(plotdata()))
return(NULL)
hist(
plotdata()[, input$variable],
xlab = input$variable,
main = paste(
"Histogram of" ,
input$variable
)
)
})
})
shinyApp(ui, server)

Create and reuse data within R Shiny server

I'd like to create data once and reuse it in multiple plots. The example below creates the data in each plot, but how can I create it once (x) and have each plot use x?
ui <- shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
numericInput(inputId = "mean", label = "Mean", value = 50)
),
mainPanel(
column(6,plotOutput(outputId = "hist1")
),
column(6,plotOutput(outputId = "hist2")
)
)
)
)
)
server <- function(input,output){
# I'd like to create the data just once here, and then reuse it in each plot
# x <- rnorm(100,input$mean,5)
output$hist1 <- renderPlot({
hist(rnorm(100,input$mean,5))
#hist(x)
})
output$hist2 <- renderPlot({
hist(rnorm(100,input$mean,5))
#hist(x)
})
}
runApp(list(ui = ui, server = server))
You can wrap your rnorm in a reactive expression to create a reactive conductor. Then, use the conductor in your endpoints (output$). See http://shiny.rstudio.com/articles/reactivity-overview.html.
server <- function(input,output){
# I'd like to create the data just once here, and then reuse it in each plot
x <- reactive(rnorm(100, input$mean, 5))
output$hist1 <- renderPlot({
hist(x())
})
output$hist2 <- renderPlot({
hist(x())
})
}
Wrapping the server codes with observe would do the job.
server <- function(input,output){
# I'd like to create the data just once here, and then reuse it in each plot
observe({
data <- rnorm(100,input$mean,5)
output$hist1 <- renderPlot({
hist(data)
#hist(rnorm(100,x,5))
})
output$hist2 <- renderPlot({
hist(data)
#hist(rnorm(100,x,5))
})
})
}

Resources