在 Shiny 中使用 InvalidateLater 和带有 observeEvent 的反应事件

Question

I'm trying to display periodic updates on the UI for a real-time data feed that may last several hours. I found a nice example of doing type this reactivity with the Shiny observe function in the code below.

library(shiny)
ui <- pageWithSidebar(
  
  # Application title
  headerPanel("New Application"),
  
  sidebarPanel(
    "Progress: ",
    textOutput("counter"),
    hr(),
    "Elapsed Time (seconds):",
    textOutput("elapsed")
  ),
  
  mainPanel(
    textOutput("x")
  )
)

server <- function(input, output, session) {
  # The number of iterations to perform
  maxIter <- 50
  
  # Track the start and elapsed time
  startTime <- Sys.time()  
  output$elapsed <- renderText({
    vals$x
    round(Sys.time() - startTime)
  })
  
  # Create a reactiveValues object where we can track some extra elements
  # reactively.
  vals <- reactiveValues(x = 0, counter = 0)
  
  # Update the percentage complete
  output$counter <- renderText({
    paste0(round(vals$counter/maxIter * 100, 1), "%")
  })
  
  # Show the value of x
  output$x <- renderText({
    round(vals$x,2)
  })
  
  # Do the actual computation here.
  observe({
    isolate({
      # This is where we do the expensive computing
      sum <- 0
      for (i in 1:100000){
        sum <- sum + rnorm(1)
      }
      vals$x <- vals$x + sum
      
      # Increment the counter
      vals$counter <- vals$counter + 1  
    })
    
    # If we're not done yet, then schedule this block to execute again ASAP.
    # Note that we can be interrupted by other reactive updates to, for
    # instance, update a text output.
    if (isolate(vals$counter) < maxIter){
      invalidateLater(0, session)
    }
  })
  
}

shinyApp(ui, server)

This code sample provides periodic UI updates, just like I want to see, except I'd like to select some parameters and click a button to start the real-time data feed. When I try to modify the code above by changing the observe function to the observeEvent function, I can't seem to get it to work and I don't know why. When I run my version (see code below), it does NOT provide periodic updates about its progress and waits until it's finished to update the UI. Here's my code:

library(shiny)

ui <- pageWithSidebar(
  
  # Application title
  headerPanel("New Application"),
  
  sidebarPanel(
    numericInput("startNumber","Start Number",value=0),
    numericInput("iterations","Interations",value=5),
    actionButton(inputId = "go",label="Go"),
    br(),
    "Progress: ",
    textOutput("counter"),
    hr(),
    "Elapsed Time (seconds):",
    textOutput("elapsed")
  ),
  
  mainPanel(
    textOutput("x")
  )
)

server <- function(input, output, session) {

  # Track the start and elapsed time
  startTime <- Sys.time()  
  output$elapsed <- renderText({
    vals$x
    round(Sys.time() - startTime)
  })
  
  # Create a reactiveValues object where we can track some extra elements
  # reactively.
  vals <- reactiveValues(x = 0, counter = 0)
  
  # Update the percentage complete
  output$counter <- renderText({
    paste0(round(vals$counter/input$iterations * 100, 1), "%")
  })
  
  # Show the value of x
  output$x <- renderText({
    round(vals$x,2)
  })
  
  # Do the actual computation here.
  observeEvent (input$go,
    {
      # The number of iterations to perform
      while (vals$counter < isolate(input$iterations)) {
        #isolate({
          # This is where we do the expensive computing
          sum <- input$startNumber
          for (i in 1:100000){
            sum <- sum + rnorm(1)
          }
          vals$x <- vals$x + sum
      
          # Increment the counter
          vals$counter <- vals$counter + 1  
        #})
    
        # If we're not done yet, then schedule this block to execute again ASAP.
        # Note that we can be interrupted by other reactive updates to, for
        # instance, update a text output.
        if (vals$counter < isolate(input$iterations)){
          invalidateLater(0, session)
        }
      }
    })
  
}

shinyApp(ui, server)

I'm pretty sure I'm missing an important concept, but I'm baffled.

Answer 1

The issue is that invalidateLater only works inside a reactive context. observeEvent wraps all its innards in an implied isolate rendering it non-reactive.

This observe should do it

  observe({
    req(input$go)
    isolate({
      # This is where we do the expensive computing
      sum <- 0
      for (i in 1:100000){
        sum <- sum + rnorm(1)
      }
      vals$x <- vals$x + sum
      
      # Increment the counter
      vals$counter <- vals$counter + 1  
    })
    
    # If we're not done yet, then schedule this block to execute again ASAP.
    # Note that we can be interrupted by other reactive updates to, for
    # instance, update a text output.
    if (isolate(vals$counter < input$iterations)){
      invalidateLater(0, session)
    }
  })

Answer 2

I think it is difficult to do it within an observeEvent , so I sticked to the original approach using observe and isolate . After playing around with it I came up with the solution below, but I think it can be simplified. One advantage of this solution is, that after clicking the "go" button the first time, the next run is also triggered by clicking on "go" instead of running automatically when the inputs are updated. Further, the 100% label does not change, when input$iterations is updated, but will only change after click go . It is also possible to set the number of iterations in a second run to a lower value.

library(shiny)

ui <- pageWithSidebar(
  
  # Application title
  headerPanel("New Application"),
  
  sidebarPanel(
    numericInput("startNumber","Start Number",value=0),
    numericInput("iterations","Interations",value=5),
    actionButton(inputId = "go",label="Go"),
    br(),
    "Progress: ",
    textOutput("counter"),
    hr(),
    "Elapsed Time (seconds):",
    textOutput("elapsed")
  ),
  
  mainPanel(
    textOutput("x")
  )
)

server <- function(input, output, session) {

  # Create a reactiveValues object where we can track some extra elements
  # reactively.
  vals <- reactiveValues(x = 0,
                         counter = 0,
                         go_btn = NULL,
                         itr = NULL,
                         tstart = NULL)
  
  
  # Track the start and elapsed time
    
  output$elapsed <- renderText({
    req(vals$tstart)
    vals$x
    round(Sys.time() - vals$tstart)
  })

  # Update the percentage complete
  output$counter <- renderText({
    req(vals$itr)
    paste0(round(vals$counter/ vals$itr * 100, 1), "%") 
  })
  
  # Show the value of x
  output$x <- renderText({
    round(vals$x,2)
  })
  
  observeEvent(input$go, {
    if (is.null(vals$go_btn)) {
      vals$counter <- 0
      vals$go_btn <- 0
      vals$itr <- input$iterations
      vals$tstart <- Sys.time()  
    } else {
      vals$go_btn <- vals$go_btn + 1
    }
  })
  
  # Do the actual computation here.
  observe({vals$go_btn
    req(vals$go_btn)
    isolate({    
      if (vals$counter < input$iterations){
        sum <- input$startNumber 
        for (i in 1:100000){
          sum <- sum + rnorm(1)
        }
        vals$x <- vals$x + sum
        
        vals$counter <- vals$counter + 1  
      } # close if
    }) # close isolate
    if (isolate(vals$counter < input$iterations)){
      invalidateLater(0, session)
    } else {
      isolate({   
        vals$go_btn <- NULL
      })
    }
    
  }) # close observe
  
}

shinyApp(ui, server)