I'm working on a Shiny application. Part of it is to recommend to users a gallery of ML generated ggplot2 plots based on their own data (or example data from R packages). There will be at least 50 plots generated and displayed every for users to choose from, possibly many more.
My problem is that all plots are displayed at one time, with huge waiting times.
I would like to find a way to have them displayed one by one, as soon as one has been generated.
In the simple example below, instead of all 4 plots showing at one time, I'd like to have them shown individually as soon as they're ready.
ui <- fluidPage(
fluidRow(
splitLayout(
style = "height: 160px; text-align:center",
plotOutput("Mosaic_Plot1"), plotOutput("Mosaic_Plot2"), plotOutput("Mosaic_Plot3"), plotOutput("Mosaic_Plot4")
),
splitLayout(
style = "height: 40px; text-align:center",
actionButton("mosEdit1", "Edit this plot"), actionButton("mosEdit2", "Edit this plot"), actionButton("mosEdit3", "Edit this plot"),
actionButton("mosEdit4", "Edit this plot")
)
)
)
server <- function(input, output, session) {
output$Mosaic_Plot1 <- renderPlot({ggplot(data = diamonds, aes(carat, price)) + geom_point()}, width = 280, height = 160)
output$Mosaic_Plot2 <- renderPlot({ggplot(data = diamonds, aes(x = color, y = price, color = color)) + geom_point() + geom_jitter()}, width = 280, height = 160)
output$Mosaic_Plot3 <- renderPlot({ggplot(data = diamonds, aes(carat)) + geom_histogram()}, width = 280, height = 160)
output$Mosaic_Plot4 <- renderPlot({ggplot(data = diamonds, aes(depth, table)) + geom_point()}, width = 280, height = 160)
}
shinyApp(ui, server)
I tried several options with embedded uiOutputs, fillPage, ... but nothing worked so far.
Many thanks for any suggestions on how to make this work.
Sure, the trick is take control of the reactivity. We can use observe and invalidateLater to create a loop, and then output charts 1 by 1. Below is a minimal example:
library(shiny)
ui <- fluidPage(
selectInput("input_1", label = "input_1", choices = c(10, 20, 30)),
column(6,
plotOutput("plot_1"),
plotOutput("plot_2")
),
column(6,
plotOutput("plot_3"),
plotOutput("plot_4")
)
)
server <- function(input, output, session) {
#Function which produces plots
func_plot <- function(id) {
#Simulate long random processing time
Sys.sleep(sample(1:4, 1))
#Produce bar plot
barplot(seq(from = 1, to = isolate(input$input_1)), main = paste("Chart", id))
}
#Loop that runs once per second
counter <- 1
observe({
if(counter <= 4) {
if(counter == 1) {output$plot_1 <- renderPlot({func_plot(id = 1)})}
if(counter == 2) {output$plot_2 <- renderPlot({func_plot(id = 2)})}
if(counter == 3) {output$plot_3 <- renderPlot({func_plot(id = 3)})}
if(counter == 4) {output$plot_4 <- renderPlot({func_plot(id = 4)})}
counter <<- counter + 1
}
invalidateLater(1000)
})
#Watch for changes to inputs
observeEvent(input$input_1, {
#Optional: Clear plots before updating, to avoid having a mix of updated and un-updated plots
output$plot_1 <- renderPlot({NULL})
output$plot_2 <- renderPlot({NULL})
output$plot_3 <- renderPlot({NULL})
output$plot_4 <- renderPlot({NULL})
counter <<- 1
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
Related
I am using a brushed histogram to query samples in a shiny app. In my full application, I overlay a new histogram that highlights the selected region and update a DT data table showing properties of the filtered samples.
I've noticed that a reactive that depends on the brush gets called twice each time I move it. For example, the table_data reactive below gets called twice each time I brush the histogram.
app.R
library(ggplot2)
library(shiny)
df <- data.frame(x = rnorm(1000))
base_histogram <- ggplot(df, aes(x)) +
geom_histogram(bins = 30)
# Define UI for application that draws a histogram
ui <- fluidPage(
column(
plotOutput("histogram", brush = brushOpts(direction = "x", id = "brush", delay=500, delayType = "debounce")),
width = 6
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$histogram <- renderPlot({
p <- base_histogram
current <- table_data()
if (nrow(current) > 0) {
p <- p + geom_histogram(data = current, fill = "red", bins = 30)
}
p
})
table_data <- reactive({
print("called")
brushedPoints(df, input$brush)
})
}
# Run the application
shinyApp(ui = ui, server = server)
In this toy example, it's barely noticeable. But in my full app, a heavy calculation has to be done within the table_data reactive, and this the double call is unnecessarily slowing everything down.
Is there any way to structure the app so that the reactive only executes once whenever a brush is ended?
Here is a GIF that shows that the table_data is being executed twice per brush.
try this, only trigger once on each brush movement.
library(ggplot2)
library(shiny)
df <- data.frame(x = rnorm(1000))
base_histogram <- ggplot(df, aes(x)) +
geom_histogram(bins = 30)
# Define UI for application that draws a histogram
ui <- fluidPage(
column(
plotOutput("histogram", brush = brushOpts(direction = "x", id = "brush", delay=500, delayType = "debounce")),
width = 6
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$histogram <- renderPlot({
p <- base_histogram
if(!is.null(table_data())) {
p <- p + geom_histogram(data = table_data(), fill = "red", bins = 30)
}
p
})
table_data <- reactive({
if(is.null(input$brush)) return()
print("called")
brushedPoints(df, input$brush)
})
}
shinyApp(ui, server)
In my Shiny app, I produce a plot that is quite heavy. When I want to download this plot, R first produces the PNG file in the background and then opens the file system to choose where I want to save it.
The problem is that the plot creation takes some time after clicking on the download button, and therefore the user doesn't know if it worked.
Example below: the plot is a bit heavy so it takes some time to appear. Wait for it to appear before clicking on the "download" button.
library(shiny)
library(ggplot2)
foo <- data.frame(
x = sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE),
y = sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE)
)
ui <- fluidPage(
downloadButton('foo'),
plotOutput("test")
)
server <- function(input, output) {
output$test <- renderPlot(ggplot(foo, aes(x, y)) + geom_point())
output$foo = downloadHandler(
filename = 'test.png',
content = function(file) {
ggsave(file)
}
)
}
shinyApp(ui, server)
Is there a way to invert the process, i.e first let the user choose where to save the plot and then produce the PNG in the background? I think that would provide a better user experience.
Regarding your comment below #manro's answer: promises won't help here.
They are preventing other shiny sessions from being blocked by a busy session. They increase inter-session responsiveness not intra-session responsiveness - although there are (potentially dangerous) workarounds.
See this answer for testing:
R Shiny: async downloadHandler
In the end the downloadButton just provides a link (a-tag) with a download attribute.
If the linked resource does not exist when the client tries to access it the browser will throw an error (as it does when clicking the downloadButton before the plot is ready in your MRE).
Also the dialog to provide the file path is executed by the clients browser after clicking the link (and not by R).
I think somehow notifying the user is all you can do:
library(shiny)
library(ggplot2)
foo <- data.frame(
x = sample(seq(1, 20, by = 0.01), 1e5, replace = TRUE),
y = sample(seq(1, 20, by = 0.01), 1e5, replace = TRUE)
)
ui <- fluidPage(
tags$br(),
conditionalPanel(condition = 'output.test == null', tags$b("Generating plot...")),
conditionalPanel(condition = 'output.test != null', downloadButton('foo'), style = "display: none;"),
plotOutput("test")
)
server <- function(input, output, session) {
output$test <- renderPlot(ggplot(foo, aes(x, y)) + geom_point())
output$foo = downloadHandler(
filename = 'test.png',
content = function(file) {
showNotification(
ui = tags$b("Preparing download..."),
duration = NULL,
closeButton = TRUE,
id = "download_notification",
type = "message",
session = session
)
ggsave(file)
removeNotification(id = "download_notification", session = session)
}
)
}
shinyApp(ui, server)
This is my first Shiny App, so I'm sure it could be improved ;)
I think, that from the point of UX - it is better to do in the following way: "display a graph -> save the graph"
An addition:
So, I added a busy spinner, now an user of this app can know that this graph still rendering. You can use several styles, choose your favourite there:
library(shiny)
library(ggplot2)
library(shinybusy)
#your data
df <- data.frame(
x <- sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE),
y <- sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE)
)
#your plot
plot_df <- ggplot(df, aes(x, y)) + geom_point()
#my plot
my_plot <- ggplot(diamonds, aes(price, fill = cut)) +
geom_histogram(binwidth = 500)
ui <- fluidPage(
#our buttons
br(),
actionButton("button1", label = "View graph"),
br(),
br(),
plotOutput("button1"),
uiOutput("button2"),
add_busy_spinner(spin = "fading-circle")
)
server <- function(input, output) {
observeEvent(input$button1, {
output$button1 <- renderPlot(my_plot)
output$button2 <- renderUI({
br()
downloadButton("button3")
})
})
output$button3 <- downloadHandler(
filename <- 'test.png',
content <- function(file){
ggsave(file)
}
)
}
shinyApp(ui, server)
I seek a method in R shiny that I can include inside a render or an observe to check if a certain value has changed.
For example :
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
fluidRow(
column(5,
imageOutput("image") %>% withSpinner()
),
actionButton("button", "redo")
)
)
server <- function(input, output, session) {
data = reactiveVal(data.frame(
gp = factor(rep(letters[1:3], each = 10)),
y = rnorm(30)
))
getWidth = function(image)
paste0(session$clientData[[paste0("output_", image, "_width")]], "px")
output$image = renderImage({
input$button
outfile = tempfile(fileext = ".png")
p = ggplot(data(), aes(gp, y)) +
geom_point()
Sys.sleep(2) # to symbolise a plot which is very slow to appear
ggsave(filename = outfile, p)
return(list(src = outfile, width = getWidth("image")))
}, deleteFile = F)
}
shinyApp(ui, server)
Here just when I resize the window, the image is resaved, I do not want that. But I want that code to save the file if and only if data() or input$button is changed.
The only solution I see so far is to copy the data in an independent variable and to check if the value has changed. If the data change, save the new plot, change the value of the independent variable.
But I am not convinced that is it a good solution because the value data will be copied twice. For this dataset it not very severe, but for a dataset with millions lines the strain is harder. Or a graph that takes more than 10 seconds to save.
Thank you,
My suggestion would be
Use renderPlot instead of renderImage
Create the plot in a reactive expression
Save only when the plot changes (now it only reacts to data changes not to resizes) or the button is pressed, by using an observeEvent with those two events as triggers.
Find a working example below. If you want to change the size of the saved plot do it in the ggsave.
library(shiny)
library(shinycssloaders)
library(tidyverse)
ui <- fluidPage(
fluidRow(
column(5,
imageOutput("image") %>% withSpinner()
),
actionButton("button", "redo")
)
)
server <- function(input, output, session) {
data = reactiveVal(data.frame(
gp = factor(rep(letters[1:3], each = 10)),
y = rnorm(30)
))
p <- reactive({ggplot(data(), aes(gp, y)) +
geom_point()
})
observeEvent(c(p(), input$button), {
outfile = tempfile(fileext = ".png")
ggsave(filename = outfile, p())
})
output$image = renderPlot({
Sys.sleep(2) # to symbolise a plot which is very slow to appear
p()
})
}
shinyApp(ui, server)
I've looked through R Shiny tutorials and stackoverflow for answers related to my query. I usually wait for 3-4 days to solve a coding problem before I attempt to post.
I have an animated slider in my UI that loops through time interval in a column (column a) . I'm trying to produce an animated line plot that plots y values of another column (column b), corresponding to the nrow() of that time interval. The slider works perfectly, but I haven't been able to plot the output.
I mightve missed some concepts related to reactivity in Shiny app. Appreciate any guidance I can get related to my query. I'll be happy to post more info if needed.
a <- c(0,1,2,3,4,5,6)
b <- c(50,100,40,30,20,80)
mydata <- cbind(a,b)
mydata <- as.data.frame(mydata())
ui <- fluidPage (
headerPanel("basic app"),
sidebarPanel(
sliderInput("slider",
label = "Time elapsed",
min = 0,
max = nrow(mydata()),
value = 1, step = 1,
animate =
animationOptions(interval = 200, loop = TRUE))
),
mainPanel(
plotlyOutput("plot")
)
)
server <- function(input, output) {
sliderValues <- reactive({
data.frame(
Name = "slider",
Value = input$slider)
})
output$plot <- renderPlot({
x<- as.numeric(input$slider)
y <- as.numeric(b[x])
ggplot(mydata,aes_string(x,y))+ geom_line()
})
}
Just as a demo, I wanted the animated plot to come out like this, but in correspondance to UI slider values :
library(gganimate)
library(ggplot2)
fake <- c(1,10)
goods <- c(11,20)
fakegoods <- cbind(fake,goods)
fakegoods <- data.frame(fakegoods)
ggplot(fakegoods, aes(fake, goods)) + geom_line() + transition_reveal(1, fake)
Does this accomplish what you are looking for? Note that I removed the first element, 0, from vector a as your original example had more elements in a than b, and in order for them to be cbind together they must be the same length.
library(ggplot2)
library(shiny)
a <- c(1,2,3,4,5,6)
b <- c(50,100,40,30,20,80)
mydata <- cbind(a,b)
mydata <- as.data.frame(mydata)
ui <- fluidPage (
headerPanel("basic app"),
sidebarPanel(
sliderInput("slider",
label = "Time elapsed",
min = min(mydata$a),
max = max(mydata$a),
value = min(mydata$a), step = 1,
animate =
animationOptions(interval = 200, loop = TRUE))
),
mainPanel(
plotOutput("plot")
)
)
server <- function(input, output) {
output$plot <- renderPlot({
plotdata <- mydata[1:which(input$slider==mydata$a),]
p <- ggplot(plotdata,aes(x = a,y = b))
if(nrow(plotdata)==1) {
p + geom_point()
} else {
p + geom_line()
}
})
}
I want to see if I can create a line chart in a Shiny app that:
Draws a vertical line through, and
Labels
the data point closest to the x-value of the mouse hover point on each geom_line(), something like a combination of these two charts:
Vertical Line through Mouse Hover Point
Data Label for Point at x-value of Mouse Hover Point
This is my first attempt at making my ggplot graph interactive. I've run into some strange behavior that I'm hoping someone can explain to me. My reproducible example is below. It creates two series and plots them with geom_line(). I'm a few steps from my desired endstate (explained above), but my immediate questions are:
How can I get rid of the vertical line when the mouse is outside the bounds of the plot? Everything I've tried (like passing NULL to xintercept if input$plot_hover is NULL) causes the plot to error out.
Why, when the mouse is inside the bounds of the plot, does the geom_vline bounce all over the place? Why does it go back to x = 0 when the mouse stops moving?
Thank You.
library(shiny)
library(ggplot2)
library(tidyr)
library(dplyr)
ui <- fluidPage(
titlePanel("Interactive Plot"),
sidebarLayout(
sidebarPanel(
sliderInput("points",
"Number of points:",
min = 10,
max = 50,
value = 25),
textOutput(outputId = "x.pos"),
textOutput(outputId = "y.pos"),
textOutput(outputId = "num_points")
),
mainPanel(
plotOutput("distPlot", hover = hoverOpts(id = "plot_hover",
delay = 100,
delayType = "throttle")))))
server <- function(input, output) {
# Create dataframe and plot object
plot <- reactive({
x <- 1:input$points
y1 <- seq(1,10 * input$points, 10)
y2 <- seq(20,20 * input$points, 20)
df <- data.frame(x,y1,y2)
df <- df %>% gather(key = series, value = value, y1:y2)
ggplot(df,aes(x=x, y=value, group=series, color=series)) +
geom_line() +
geom_point() +
geom_vline(xintercept = ifelse(is.null(input$plot_hover),0,input$plot_hover$x))
})
# Render Plot
output$distPlot <- renderPlot({plot()})
# Render mouse position into text
output$x.pos <- renderText(paste0("x = ",input$plot_hover$x))
output$y.pos <- renderText(paste0("y = ",input$plot_hover$y))
}
# Run the application
shinyApp(ui = ui, server = server)
A suggested solution to fix the issue is to use reactiveValues and debounce instead of throttle.
The issue
distPlot depends on the input$plot_hover$x which changes continuously, or gets reset to null.
Suggested solution
use values <- reactiveValues(loc = 0) to hold the value of input$plot_hover$x and initiate it with zero or any value you want.
use observeEvent, to change the value of loc whenever input$plot_hover$x changes
observeEvent(input$plot_hover$x, {
values$loc <- input$plot_hover$x
})
use debounce instead of throttle to suspend events while the cursor is moving.
I am printing input$plot_hover$x and values$loc to show you the difference.
Note: I made some changes in the code, just to break things down.
library(shiny)
library(ggplot2)
library(tidyr)
library(dplyr)
library(shinySignals)
ui <- fluidPage(
titlePanel("Interactive Plot"),
sidebarLayout(
sidebarPanel(
sliderInput("points",
"Number of points:",
min = 10,
max = 50,
value = 25),
textOutput(outputId = "x.pos"),
textOutput(outputId = "y.pos"),
textOutput(outputId = "num_points")
),
mainPanel(
plotOutput("distPlot", hover = hoverOpts(id = "plot_hover",
delay = 100,
delayType = "debounce")))))
server <- function(input, output) {
# Create dataframe and plot object
plot_data <- reactive({
x <- 1:input$points
y1 <- seq(1,10 * input$points, 10)
y2 <- seq(20,20 * input$points, 20)
df <- data.frame(x,y1,y2)
df <- df %>% gather(key = series, value = value, y1:y2)
return(df)
})
# use reactive values -------------------------------
values <- reactiveValues(loc = 0)
observeEvent(input$plot_hover$x, {
values$loc <- input$plot_hover$x
})
# if you want to reset the initial position of the vertical line when input$points changes
observeEvent(input$points, {
values$loc <- 0
})
# Render Plot --------------------------------------
output$distPlot <- renderPlot({
ggplot(plot_data(),aes(x=x, y=value, group=series, color=series))+
geom_line() +
geom_point()+
geom_vline(aes(xintercept = values$loc))
})
# Render mouse position into text
output$x.pos <- renderText(paste0("values$loc = ",values$loc))
output$y.pos <- renderText(paste0("input$plot_hover$x = ",input$plot_hover$x ))
}
# Run the application
shinyApp(ui = ui, server = server)