I apologyse in advance if the question is a bit unclear!
I created a for-loop that generates a plot every 0.1 seconds (to simulate a video of a moving object). The code works smoothly, but I would like to allow the user to pause and resume the "video" when he/she wants to inspect in more detail one of the video frames.
I thought about reading an input from the console using readline() or scan() functions at the end of the loop. For example, the user types "p"+enter to pause the video. However, readline() would expect an input at the end of each iteration. In my case, the user would only provide an input in some of the iterations, so the loop must continue running when no input is given.
This would be a simplified version of the loop (printing a value in the console instead of plotting an image):
for(index in c(1:10)){
print(index) # In my script it generates a plot
Sys.sleep(0.1)
input = read.line() # If user types an input in the command, execution is paused
# If no input is given, the loops continues with the next iteration
...
...
}
Do you have any ideas/suggestions of how to deal with this?
Thanks :)
Something like this using library(shiny) to provide a pause/resume button could work:
ui = fluidPage(
actionButton("pause", "Pause"),
plotOutput("myplot")
)
server = function(input, output, session) {
rv <- reactiveValues(i = 0, go = TRUE)
maxIter = 1000
timer = reactiveTimer(100)
output$myplot = renderPlot({
x = seq_len(1000)
y = sin(x/20 + rv$i) * cos(x/50 + rv$i/2)
plot(x, y, type = "l", main = rv$i, ylim = c(-1,1))
})
observeEvent(input$pause, {
rv$go = !rv$go
updateActionButton(session, inputId = "pause",
label = c("Resume", "Pause")[rv$go + 1L])
})
observeEvent(timer(), {
req(rv$i < maxIter)
req(rv$go)
rv$i = rv$i + 1
})
}
shinyApp(ui = ui, server = server)
Related
I generate a dynamic number of valueBox in my shiny, and this number can change depending of the user input.
I managed to handle this with a renderUI where I put the wanted number of valueBoxOutput, and I have an observe that will feed them with the content using renderValueBox.
My problem is: the code in the renderValueBox, for some reason, is actually executed after the observe is finished, so because the renderValueBox is in a loop (to have a dynamic number of them) but the code is executed for all the output after the loop, all my output will get the last value of the loop.
Here is a min reprex:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
# Function
compute <- function(id)
{
print(paste("Compute ", id))
return(id)
}
# UI
ui = shinyUI(fluidPage(
titlePanel("Compare"),
useShinydashboard(),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items", min = 1, max = 10, value = 2)
),
mainPanel(
uiOutput("boxes")
)
)
))
# Server
server = shinyServer(function(input, output, session) {
data <- reactiveValues(
ids = list()
)
output$boxes <- renderUI({
print("boxes")
box_list <- list()
id_list <- list()
for(id in 1:(input$numitems)) {
id_box <- paste0("box_", id)
print(paste("boxes - ", id_box))
id_list <- append(id_list, id_box)
box_list <- append(
box_list,
tagList(
shinydashboard::valueBoxOutput(id_box)
)
)
data$ids <- id_list
}
print("boxes end")
fluidRow(box_list)
})
observe({
print("observe")
for(id_box in data$ids) {
print(paste("observe - ", id_box))
output[[id_box]] <- shinydashboard::renderValueBox(valueBox(id_box, compute(id_box), icon = icon("circle-info"), color = "teal"))
}
print("end observe")
})
})
# Run
shinyApp(ui = ui , server = server)
Here is the result:
And the console output:
As you can see the compute (and the render in general) is done after the end of the observe function, and both output will use the last id_box that were set (so the last loop, box_2), instead of correctly using box_1 and box_2.
I tried using force, computing valueBox outside the render, using reactive lists, nothing worked, because whatever I do the render is evaluated after the observe so only the last loop values will be used no matter what.
Do anyone know a way to force execution during the loop ? Or see another way of achieving the same result ?
Why it's always after spending hald a day on a problem, looking for dozens of posts and forum, don't find anything, finally decide to ask a question... that a few minutes later I finally find an answer.
Anyway, one way to correct this (found here) is to encapsulate the render inside the local function, like this:
observe({
print("observe")
for(id_box in data$ids) {
print(paste("observe - ", id_box))
local({
tmp <- id_box
output[[tmp]] <- shinydashboard::renderValueBox(valueBox(tmp, compute(tmp), icon = icon("circle-info"), color = "teal"))
})
}
print("end observe")
})
Now the compute is still called after the end of the observe, but the tmp variable has the correct value:
The result is what I wanted:
For the record, I had already tried to use the local function, but if you don't copy the id_box inside another variable just for the local bloc, it won't work.
I am trying to create a date input that automatically updates the inputted value to the end of the selected month. The problem I was having was when I ran this first bit of code (below) was that if the user tries to manually change the date by typing in a date, they are unable to because the input is updated instantly to the end of the month before the user can finish typing.
library(shinydashboard)
library(lubridate)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
dateInput(
inputId = "date",
label = "End of Month Date",
value = ceiling_date(x = Sys.Date() + 365, unit = "month") - 1,
startview = "year"
)
)
)
server <- function(input, output, session) {
observe({
if(is.Date(input$date) & length(input$date) > 0){
if(input$date != ceiling_date(input$date, unit = "month") - 1) {
updateDateInput(
session,
inputId = "date",
value = ceiling_date(x = input$date, unit = "month") - 1
)
}
}
})
}
shinyApp(ui, server)
So, I tried implementing debounce (as shown below - server code change only) so that it would delay the input from updating until the user was finished typing; however, I am running into an issue. The timer does not reset on each key stroke as I understand it should. Instead, the timer operates as if I were using the throttle function and starts when the input is first changed and doesn't reset when the input changes.
server <- function(input, output, session) {
observe({
dateinputdelay <- debounce(r = reactive(input$date), millis = 2000)
if(is.Date(dateinputdelay()) & length(dateinputdelay()) > 0){
if(dateinputdelay() != ceiling_date(dateinputdelay(), unit = "month") - 1) {
updateDateInput(
session,
inputId = "date",
value = ceiling_date(x = input$date, unit = "month") - 1
)
}
}
})
}
Edit: the best I can get is with the code below, but because the "fancy date input thingy" has its own internal updating mechanism separate from shiny's reactive concept, this debouncing is only addressing one source of problem.
The first trick is that the debounce needs to happen before the block of code is even started. That is, it "de-bounces" the start of the dependent code blocks; once they are started, it does not help.
The second is knowing that observe blocks attempt to run their code eagerly (see shiny docs and read "Details"), whereas reactive blocks are relatively lazy -- they only run dependent code as needed. It's the "eager" part that may be hurting.
Additionally, you use side-effect in the observe block to update the input field, but you never store the value elsewhere. I suggest that it might be better to calculate the new value in one place (in a functional manner, like a reactive block that should not operate in side-effect) and then use that later.
server <- function(input, output, session) {
dateinputdelay <- debounce(reactive(input$date), 2000)
end_of_month <- reactive({
# print("react!")
x <- dateinputdelay()
if (is.Date(x) & length(x) > 0) {
if (x != ceiling_date(x, unit = "month") - 1) {
x <- ceiling_date(x = input$date, unit = "month") - 1
}
}
x
})
observe({
# print("observe!")
updateDateInput(
session,
inputId = "date",
value = end_of_month()
)
})
}
(I've kept a couple of print statements in there, not because they help much here, but because they can be a good tool to see when/how-frequently reactitivity is causing code-blocks to run.)
As I said up top, I suspect this behavior is indicative of something within dateInput, not within the subsequent reactive or observe blocks.
I want to keep reflashing until 10:05, after 10:05 I got the tplus0_dt and stop to processing invalidaterLater().
Before 10:00, tplus0_dt doesn't exist, so I need to keep reflashing until 10:05. After 10:05, it is no need to refalsh, and when the tplus0_dt becomes very lage the invalidaterLater() will effects the displaying of table1, the screen and plots go GRAY every 1 seconds so it looks like the page is dead while the updating occurs.
So how can I do to stop processing the invalidateLater() and keep showing the data after 10:05? Thanks for help! My example code were below.
require(shiny)
require(data.table)
app <- shinyApp(
server = function(input, output, session){
get_tplus0_data <- reactive({
time <- substr(as.character(Sys.time()), 12, 16)
invalidateLater(1000)
if(time >= "10:05"){
# tplus0_dt<-data.table(read.csv("/data/df_highest_after_signal.csv",header = T, sep = ",", stringsAsFactors = F))
tplus0_dt<- data.table(a = c(1, 2, 3, 4), b = c(3, 4, 5, 8))
return(tplus0_dt)
}
})
output$table1 <- renderTable({get_tplus0_data()})
},
ui = fluidPage( tableOutput("table1") )
)
runApp(app)
Although you'd never realize it from the Shiny documentation, invalidateLater() actually only returns to your reactive once. The reason it seems to return repeatedly is that on each trip the invalidateLater() function gets run again.
So the solution is to use a conditional around the function so that you don't keep repeatedly calling it:
if(runMeAgain) {
invalidateLater(n)
}
runMeAgain = TRUE # your reactive re-runs every n milliseconds
runMeAgain = FALSE # your reactive does not re-run
Also note that:
invalidateLater() is non-blocking (other code can run while you
wait)
invalidateLater() doesn't stop the rest of the reactive from
running. If you want to stop the reactive at that point in the code, put a return() after invalidateLater()
invalidateLater() gets isolated() inside an observeEvent() or eventReactive() and consequently doesn't work; you have to use observe() or reactive(). It might also work inside a render function, but I haven't ever had a reason to try that.
In terms of the original question, the reactive should look like this:
get_tplus0_data <- reactive({
time <- substr(as.character(Sys.time()), 12, 16)
if(time >= "10:05"){
tplus0_dt<- data.table(a = c(1, 2, 3, 4), b = c(3, 4, 5, 8))
return(tplus0_dt)
} else {
invalidateLater(1000)
return()
}
})
How about you override the function to your needs?
If you enter invalidateLaterNew in the console, the code of the function will be printed.
To overwrite a function within a package this post will help: Override a function that is imported in a namespace
Then you will have to consider that the functions .getReactiveEnvironment() and timerCallbacks() are not accessible outside the namespace. But you can call them like this: shiny:::.getReactiveEnvironment()
Bring it together:
You add an additional parameter (e.g. update), which will enable you to stop the invalideLater() whenever you want.
invalidateLaterNew <- function (millis, session = getDefaultReactiveDomain(), update = TRUE)
{
if(update){
ctx <- shiny:::.getReactiveEnvironment()$currentContext()
shiny:::timerCallbacks$schedule(millis, function() {
if (!is.null(session) && session$isClosed()) {
return(invisible())
}
ctx$invalidate()
})
invisible()
}
}
unlockBinding("invalidateLater", as.environment("package:shiny"))
assign("invalidateLater", invalidateLaterNew, "package:shiny")
Example:
I used the example given in ?invalidateLater to demonstrate the effect:
(invalidateLater will stop when input$nis bigger than 800. So you can adapt this example to your time restriction).
I decided not to use your time restriction example as it wouldnt be that handy to test ;)
ui <- fluidPage(
sliderInput("n", "Number of observations", 2, 1000, 500),
plotOutput("plot")
)
server <- function(input, output, session) {
observe({
# Re-execute this reactive expression after 1000 milliseconds
invalidateLater(1000, session, input$n < 800)
# Do something each time this is invalidated.
# The isolate() makes this observer _not_ get invalidated and re-executed
# when input$n changes.
print(paste("The value of input$n is", isolate(input$n)))
})
# Generate a new histogram at timed intervals, but not when
# input$n changes.
output$plot <- renderPlot({
# Re-execute this reactive expression after 2000 milliseconds
invalidateLater(2000, session, input$n < 800)
hist(rnorm(isolate(input$n)))
})
}
shinyApp(ui, server)
I want the user to input a value in a text box in shiny and then be able to click on a button to review the value s/he typed before. I got this to work with the code below, but it is far from ideal. For one thing it requires me to click the "go back" button twice to work (no idea why). Any suggestions are appreciated. (Also, note that I included the table of iterations in the output just for reference).
library(shiny)
q <- new.env() # create new environment
assign("iteration",1,envir = q)
log <- data.frame(iteration=NULL,id=NULL)
assign("log",log,envir = q)
ui <- fluidPage(
actionButton("back", "go back"),
textInput("id","enter id",value=1),
tableOutput("x")
)
server <- function(input, output,clientData, session) {
observeEvent(input$id,{
id <- input$id
iteration <- get("iteration", envir = q) # get iteration
log <- get("log",envir = q) #'gets df'
temp <- data.frame(iteration=iteration,id=id,stringsAsFactors = F)
if (!nrow(log)) log <- rbind(log,temp) # for first iteration only
else log[iteration,] <- temp
assign("log",log,envir = q)
iteration <- iteration+1
assign("iteration",iteration,envir = q)
})
# back button
observeEvent(input$back,{
iteration <- get("iteration", envir = q) # get iteration
iteration <- iteration-1
assign("iteration",iteration,envir = q)
log <- get("log",envir = q) #'gets df'
#get data
id <- log$id[iteration]
updateTextInput(session,"id", value=id)
})
# for visualising table
x <- eventReactive(input$id,{
get("log",envir = q)
})
output$x <- renderTable({x()})
}
shinyApp(ui = ui, server = server)
I want a "go back" button than one clicked shows the value typed previously in the text box.
(A similar question exist, but I do believe mine is different enough).
I am trying to automate the interaction of a Shiny app so it displays a series of results while incrementing through a predetermined range of inputs, without having to repetitiously count and change input values. This automation will provide a systematic view of a set of inputs, such as displays of refreshed price charts for selected stocks, or plots of current performance indicators for real-time processes that are being monitored.
This is similar to question [Update graph/plot with fixed interval of time] (Update graph/plot with fixed interval of time) which runs a loop with a timer. Extending that approach, my objective is to:
a) Automatically set the invalidateLater pause high (1 hour) to effectively stop the cycle after a fixed (5) set of displays, pending new user input to restart it.
b) [When I can do that, I will add a counter-based control to cycle through a set of input$obs before it stops. For simplicity, that step, which has the same error and presumably same solution, is omitted here.]
Using the above referenced toy example, the following script does repeatedly cycle through its 5 displays, but it yields this error rather than changing the pause interval.
Listening on port 8100
Error in hist.default(dist, main = paste("Last Histogram count =", as.numeric(updater()), :
'x' must be numeric
as.numeric(autoControl())
Error: could not find function "autoControl"
I can not find the reactive conductor, reactiveValues or other methods that this task requires. Thank you for your help.
library(shiny)
updates <- 0
updater <- function(){ updates + 1 }
runApp(list(
ui = pageWithSidebar(
headerPanel("Hello Shiny!"),
sidebarPanel(
sliderInput("obs",
"Number of observations:",
min = 1,
max = 1000,
value = 50)
,
selectInput(inputId = "secPause",
label = "Seconds between displays:",
choices = c(1, 2, 3, 60*60),
selected = 2)
),
mainPanel(
plotOutput("distPlot")
)
),
server =function(input, output, session) {
updateTracker <- reactive( {
invalidateLater(as.numeric(input$secPause) * 1000, session)
updates <<- as.numeric(updater())
})
autoControl <- reactive( {
if(updateTracker() <= 5)
secPause <<- input$secPause
else
secPause <<- 60*60
return(secPause)
})
output$distPlot <- renderPlot( {
if(updateTracker() <= 5) {
# generate an rnorm distribution and plot it
dist <- rnorm(input$obs)
hist(dist, main = paste("Histogram count =" , updateTracker()))
}
else {
updates <<- 0
hist(dist, main = paste("Last Histogram count =",
as.numeric(updater()), "with secPause =",
as.numeric(autoControl())))
}
})
}
))
You are getting the error because the hist distribution is defined inside the if clause, but you are using it (after 5 intervals) inside the else clause, where it is not defined. That's why it works for the first 5 intervals.
if(updateTracker() <= 5) {
# generate an rnorm distribution and plot it
dist <- rnorm(input$obs)
hist(dist, main = paste("Histogram count =" , updateTracker()))
}
else {
updates <<- 0
hist(dist, main = paste("Last Histogram count =",
as.numeric(updater()), "with secPause =",
as.numeric(autoControl())))
}
After I moved the dist to before the if condition, I got your cycling to work. (I also split your code into UI.R and server.R to make it more manageable.) Not pasting here since it is essentially the same code, but you can find the working version of code in this gist.