My Shiny animation app needs to do lot of plotting. I can change the animation interval for the plot using a control slider.
This reproducible example plots and animates random points :
library(shiny)
library(ggplot2)
library(dplyr)
df <- data.frame(frame_no = rep(1:500,10), x = runif(5000), y=runif(5000))
ui <- fluidPage(
sliderInput("frameInterval", "Set frame Interval (ms.)", min=0,
max=2000, value=100,step=50),
uiOutput("frameSlider"),
plotOutput("plot.positions", height=500, width = 500)
)
server <- function(input, output, session) {
output$frameSlider <- renderUI( sliderInput("frame", label= h3("Animate"),
min=1, max = 5000,
value=1, step=1, sep=NULL,
animate = animationOptions(interval = input$frameInterval, loop =
TRUE))
)
output$plot.positions <- renderPlot( {
f <- filter(df, frame_no==input$frame)
ggplot(f, aes(x=x, y=y)) + xlim(0,1) + ylim(0,1) +
geom_point(aes(size=3)) +
annotate("text", x= 0.5, y= 0.5, label=paste("Frame ", input$frame),
size=6)
},
bg="transparent"
)
}
shinyApp(ui = ui, server = server)
The problem I have is that when the animation interval is low (say 100ms) the plot lags behind the slider, as shown by comparing the slider value and the plotted frame number.
Then, if I want to pause the animation by clicking the slider pause, the display continues running until it catches up again with the slider value.
Is there any way to stop the animation instantly, even if it is lagging behind?
Thanks for any advice.
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)
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)
I'm writing a shiny app, and there is a plot which is getting updated each 10 seconds. The app works perfectly and it is getting updated. However, after some number of updating, namely around 30 times, it stops with no reason.
Using for chart update:
invalidateLater
Would you please let me know what I should do?
library("shiny")
library("shinythemes")
library("ggplot2")
## generating the time of the system
t <- Sys.time()
n <- 101 # some time lage
df <- data.frame(c(1:1000), runif(1000, 0, 1) ) # in addition, df is just a dataframe in the memory
shinyUI(
tabPanel("Home", plotOutput(outputId = "plot0") )
)
shinyServer(function(input, output, session) {
output$plot0 <- renderPlot({ # Signal realtime View
invalidateLater(500, session) # updating the plot each 500 miliseconds
n <- as.integer(Sys.time() - t) + n # updating the new elements which should be visualized
ggplot() + geom_line(aes(x = df[((n-100) :n), 1], y = df[((n-100) :n) , 2] ), colour = "blue") +
xlab("Time [s]") + ylab("Channel") # normal ggplot :-)
})
})
Your time difference calculation doesnt take into account where the difference is in seconds, minutes or hours, so after 60 seconds the difference will be 1.
Try something like this:
#rm(list = ls())
library(shiny)
library("ggplot2")
t <- Sys.time()
n <- 101 # some evaluation
df <- data.frame(c(1:1000), c(1:1000) )
ui<- shinyUI(pageWithSidebar(
headerPanel("Distribution analysis"),
sidebarPanel(),
mainPanel(
plotOutput(outputId = "plot0"))
))
server<- shinyServer(function(input, output,session) {
mydata <- reactive({
invalidateLater(300, session) # updating the plot each 300 miliseconds
n <- as.integer(difftime(Sys.time(),t, units = "secs")) + n # updating the new elements which should be visualized
df[((n-100) :n),]
})
output$plot0 <- renderPlot({ # Signal realtime View
ggplot() + geom_line(aes(x = mydata()[,1], y = mydata()[,2]), colour = "blue") +
xlab("Time [s]") + ylab("Channel") # normal ggplot :-)
})
})
shinyApp(ui=ui, server=server)
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)
The object is gettig parameters from users to make them understand the forecasting techniques. Therefore, i would like to begin with moving average. Eventhough the work is quite simple, i couldnt manage and i have some issues.
One error occurs: ERROR: missing value where TRUE/FALSE needed.
I do not understand why do I get this?
I want to show forecasted values for next period. But with this ready formula does not provide that?
`
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Forecasting Methods"),
sidebarPanel(
h3(strong("Moving Average",style = "color:black")),
br(),
sliderInput("ord","Order Size:",min = 1, max = 100, step= 1, value = 15),
),
mainPanel(
plotOutput(outputId = "ma1", width = "700px",height = "400px"))
))
library(shiny)
library(ggplot2)
library(forecast)
library(TTR)
shinyServer(function(input, output){
output$ma1 <- renderPlot(
tmp <- data.frame(time = 1:100, sales = round(runif(100, 150, 879))),
sm <- SMA(tmp[,"sales"],order=input$ord),
y <-ggplot(tmp, aes(time, sales)) + geom_line() + geom_line(aes(time,sm),color="red") + xlab("Days") + ylab("Sales Quantity")+ ggtitle("Moving Average"),
y
)
})
How is this:
library(shiny)
library(ggplot2)
library(forecast)
library(TTR)
ui <- pageWithSidebar(
headerPanel("Forecasting Methods"),
sidebarPanel(
h3(strong("Moving Average",style = "color:black")),
br(),
sliderInput("ord","Order Size:",min = 1, max = 100, step= 1, value = 15)
),
mainPanel(
plotOutput(outputId = "ma1", width = "700px",height = "400px"))
)
server <- function(input, output){
n <- 0
output$ma1 <- renderPlot({
input$ord
tmp <- data.frame(time = 1:100, sales = round(runif(100, 150, 879)) )
sm <- SMA(tmp[,"sales"],order=input$ord)
title <- sprintf("Moving Average (%d)",n)
n <<- n+1
y <-ggplot(tmp, aes(time, sales)) +
geom_line() +
geom_line(aes(time,sm),color="red") +
xlab("Days") + ylab("Sales Quantity")+ ggtitle(title)
y
})
}
shinyApp(ui, server)
Yielding:
As to your program - I could not reproduce your errors exactly:
1 - the program as posted would not run. The server function code block was not enclosed in curly brackets ({}), but was structured like the ui function code (comma separated statements). This is wrong. The ui function code not a function like the server code, rather it series of function calls that output html/css/javascript. Try them from the R-console to see what I mean.
2 - the UI function had at least one extraneous comma that I had to get rid of in order for it to work.
3 - using input$ord in the output$ma1 code that initializes the sm dataframe was not enough to cause the function to be reactive, and be triggered on every update of the slider. Not sure why that was not enough, but when I added another instance of input$ord to the front of the function it worked.
4- I also put a counter in the title of the output$ma1 to help me debug the above-debugged lack of reactivity.
5 - I also combined both the shiny ui.R and server.R files into one file as this example is small and makes it easy to see everything at once. Note that it can be hard matching ui.R and server.R code with the Rstudio tabbed editor - it is worth getting another editor (like Atom or Notepad++) to help code if you need more than one file.