Search code examples
rshinyshiny-reactivity

How to keep Shiny reactive objects from bouncing when a time-consuming function is executed that is slower than the downstream reactivity chain?

In running the example code presented at the bottom, the user inputs into a table at the top of the rendered window and the code then executes a very time-consuming example calculation function (calculate(x)) and outputs the results into the table shown at the bottom of the window. That single action button adds a column to both of the Shiny-rendered tables, the input table at the top and the output table at the bottom of the window.

If the user inputs into the top table and then hits ENTER before clicking the single action button (which sets off a chain of reactive events, including adding a column to both tables), then the code works fine. But on the other hand, if the user inputs into the table and then clicks on the single action button without having hit ENTER first, then the code and output starts bouncing. I've tried the shiny::debounce() function, but you must specify the milliseconds for allowing the downstream calculations that depend on the reactive expression. The problem in this case is that it's hard to define how much time to allow because processing time depends on the user's inputs. For example, an input of 1 is the quickest, and higher input values take more time to process. So, in this code example, the reactivity chain is quicker than the processing function that is called.

My question is, how can I control the reactivity downstream when timing is indeterminate? Seems that one solution is to force the user to halt all reactivity unless and until the user clicks another button, "Execute", which then sets the reactivity chain in motion and stops the weird bouncing. Does anyone have guidance on this topic?

Below is an illustration with comments when running the code. Note that the image below reflects a slightly more complex original version of the code where the calculation() function was longer and there were 2 rhandsontable input rows for the user that drove calculation(). The code has since been simplified to a shorter calculation() function and only 1 row of rhandsontable inputs. The below is still illustrative of the running the code, however.

enter image description here

Code:

library(rhandsontable)
library(shiny)

options(scipen=5)

seriesGenTrm <- data.frame('Series_1' = c(1), row.names = c("Input_1"))

calculation <- function(x) {
  x <- max(x, 1)
  start.time <- Sys.time()
  while (as.numeric(difftime(Sys.time(), start.time, units = "secs")) < x) {
    result <- sum(runif(10000))
  }
  result <- data.frame(Results = rep(result, 5))
  result
}

ui <- fluidPage(
  rHandsontableOutput('hottable_1'), br(),
  actionButton("addSeries", "Add series"), br(),
  tableOutput("alloc_tbl")
)

server <- function(input, output, session) {
  seriesTbl_1 <- reactiveVal(seriesGenTrm)
  
  observeEvent(input$hottable_1, {
    seriesTbl_1(hot_to_r(input$hottable_1))
  })
  
  output$hottable_1 <- renderRHandsontable({
    rhandsontable(
      data.frame(seriesTbl_1(), check.names = FALSE),
      rowHeaderWidth = 100
    )
  })
  
  observeEvent(input$addSeries, {
    newSeriesCol_1 <- data.frame(c(1))
    names(newSeriesCol_1) <- paste0("Series_", ncol(hot_to_r(input$hottable_1)) + 1)
    seriesTbl_1(cbind(seriesTbl_1(), newSeriesCol_1))
  })
  
  addCol <- function(allocData, columnName, seriesTbl_1) {
    allocData[[columnName]] <-
      calculation(seriesTbl_1()[1, colnames(seriesTbl_1()) == columnName])
    return(allocData)
  }
  
  allocData <- reactive({
    allocDataTmp <- data.frame(Row = 1:5)
    for (colName in colnames(seriesTbl_1())) {
      allocDataTmp <- addCol(allocDataTmp, colName, seriesTbl_1)
    }
    return(allocDataTmp)
  })
  
  output$alloc_tbl <- renderTable({allocData()})
}

shinyApp(ui, server)
Solution

  • We can disable the button as long as the user is editing the table or your long running function is busy:

    result

    library(rhandsontable)
library(shinyjs)
library(shiny)

jsCode <- "function(el, x, inputId) {
  hot = this.hot;
  afterBeginEditing = function(row, column){
    Shiny.setInputValue(inputId, true);
  }
  afterChange = function(changes, source){
    setTimeout(function(){Shiny.setInputValue(inputId, false);}, 0);
  }
  hot.addHook('afterBeginEditing', afterBeginEditing);
  hot.addHook('afterChange', afterChange);
}"

options(scipen=5)

seriesGenTrm <- data.frame('Series_1' = c(1), row.names = c("Input_1"))

calculation <- function(x) {
  x <- max(x, 1)
  start.time <- Sys.time()
  while (as.numeric(difftime(Sys.time(), start.time, units = "secs")) < x) {
    result <- sum(runif(10000))
  }
  result <- data.frame(Results = rep(result, 5))
  result
}

ui <- fluidPage(
  useShinyjs(),
  rHandsontableOutput('hottable_1'), br(),
  actionButton("addSeries", "Add series"), br(),
  tableOutput("alloc_tbl")
)

server <- function(input, output, session) {
  seriesTbl_1 <- reactiveVal(seriesGenTrm)
  
  observeEvent(input$hottable_1, {
    seriesTbl_1(hot_to_r(input$hottable_1))
  })
  
  observe({
    if(isTRUE(input$hottable_1_editor_active)){
      disable("addSeries")
    } else {
      enable("addSeries")
    }
  })
  
  output$hottable_1 <- renderRHandsontable({
    rhandsontable(
      data.frame(seriesTbl_1(), check.names = FALSE),
      rowHeaderWidth = 100
    ) |> htmlwidgets::onRender(jsCode, data = "hottable_1_editor_active")
  })
  
  observeEvent(input$addSeries, {
    newSeriesCol_1 <- data.frame(c(1))
    names(newSeriesCol_1) <- paste0("Series_", ncol(hot_to_r(input$hottable_1)) + 1)
    seriesTbl_1(cbind(seriesTbl_1(), newSeriesCol_1))
  })
  
  addCol <- function(allocData, columnName, seriesTbl_1) {
    allocData[[columnName]] <-
      calculation(seriesTbl_1()[1, colnames(seriesTbl_1()) == columnName])
    return(allocData)
  }
  
  allocData <- reactive({
    disable("addSeries")
    allocDataTmp <- data.frame(Row = 1:5)
    for (colName in colnames(seriesTbl_1())) {
      allocDataTmp <- addCol(allocDataTmp, colName, seriesTbl_1)
    }
    enable("addSeries")
    return(allocDataTmp)
  })
  
  output$alloc_tbl <- renderTable({allocData()})
}

shinyApp(ui, server)

    As an alternative you could execute your long running function in a separate R process.