Loop over data.frame and display result immediately in DT

Question

I have a simple shiny app that holds a dataset as a reactive value. Once a button is pressed, a function should be applied to each row and the result is added as another variable to that dataset. The dataset is also shown as a DT. The result variable should be rendered as soon as the computation for that row is finished. At the moment, the loop/apply that applies the function to each row finishes and only afterwards the results are displayed.

As the function can run for a long time, I want the DT to be updated as soon as a run is finished, not when all runs finish.

I understand that this means I need to use promises/future so that the main shiny code block spawns new processes which do not block in this case the main thread from updating the values. Correct? However, I am not able to get it to work.

Here is a small MWE using a simple for loop

library(shiny)
library(DT)

ui <- fluidPage(
  actionButton("run", "RUN"),
  hr(),
  DT::dataTableOutput("table")
)

calc_fun <- function(val) {
  Sys.sleep(0.5)
  val * 10
}

server <- function(input, output, session) {
  set.seed(123)
  data_res <- reactiveVal(data.frame(id = 1:10, val = rnorm(10), val10 = NA))
  
  observe({
    for (i in seq(nrow(data_res()))) {
      print(paste("Looking at row", i))
      d <- data_res()
      d[i, "val10"] <- calc_fun(val = d[i, "val"])
      data_res(d)
    }
  }) %>% bindEvent(input$run)
  
  # This should be rendered whenever a round in the for-loop has finished
  # at the moment it is only run once the loop is finished
  output$table <- DT::renderDataTable(data_res())
}

shinyApp(ui, server)

user_3048453 · Answer

Thanks to @ismirsehregal, I came up with the following solution which uses futures to start the calculation in the background, which in turn write the current status to a file. Shiny then reactively reads the file and updates the values.

The full MWE looks like this:

library(shiny)
library(DT)
library(future)
library(promises)
library(qs) # for fast file read/write, replace with csv if needed
plan(multisession)

ui <- fluidPage(
  actionButton("run", "RUN"),
  hr(),
  textOutput("prog"),
  uiOutput("status"),
  hr(),
  fluidRow(
    column(6, 
           h2("Current Status"),
           DT::dataTableOutput("table")
    ),
    column(6,
           h2("Data in File"),
           tableOutput("file_data")
    )
  )
)

calc_fun <- function(val) {
  Sys.sleep(runif(1, 0, 2))
  val * 10
}

# main function that goes through the rows and starts the calculation
# note that the output is saved to a .qs file to be read in by another reactive
do_something_per_row <- function(df, outfile) {
  out <- tibble(id = numeric(0), res = numeric(0))
  
  for (i in seq(nrow(df))) {
    v <- df$val[i]
    out <- out %>% add_row(id = i, res = calc_fun(v))
    qsave(out, outfile)
  }
  return(out)
}

# create a data frame of tasks
set.seed(123)
N <- 13
tasks_init <- tibble(id = seq(N), val = round(rnorm(N), 2), status = "Open", res = NA)


server <- function(input, output, session) {
  # the temporary file to communicate over
  outfile <- "temp_progress_watch.qs"
  unlink(outfile)
  
  data <- reactiveVal(tasks_init) # holds the current status of the tasks
  data_final <- reactiveVal() # holds the results once all tasks are finished
  
  output$prog <- renderText(sprintf("Progress: 0 of %i (0.00%%)", nrow(data())))
  output$status <- renderUI(div(style = "color: black;", h3("Not yet started")))
  
  # on the button, start the do_something_per_row function as a future
  observeEvent(input$run, {
    # if a file exists => the code runs already
    if (file.exists(outfile)) return()
    
    print("Starting to Run the code")
    output$status <- renderUI(div(style = "color: orange;", h3("Working ...")))
    
    d <- data()
    future({do_something_per_row(d, outfile)}, seed = TRUE) %...>% data_final()
    print("Done starting the code, runs now in the background! freeing the session for interaction")
    # return(NULL) # hide future
  })
  
  observe({
    req(data_final())
    output$status <- renderUI(div(style = "color: green;", h3("Done")))
    print("All Done - Results came back from the future!")
  })
  
  output$file_data <- renderTable(req(df_done()))
  
  output$table <- DT::renderDataTable({
    # no need to fire on every refresh, this is handled automatically later
    DT::datatable(isolate(data())) %>% 
      formatStyle("status", color = styleEqual(c("Open", "Done"), c("white", "black")),
                  backgroundColor = styleEqual(c("Open", "Done"), c("red", "green")))
  })
  dt_proxy <- DT::dataTableProxy("table")
  
  # look for changes in the file and load it
  df_done <- reactiveFileReader(300, session, outfile, function(f) {
    r <- try(qread(f), silent = TRUE)
    if (inherits(r, "try-error")) return(NULL)
    r
  })
  
  observe({
    req(df_done())
    open_ids <- data() %>% filter(status == "Open") %>% pull(id)
    if (!any(df_done()$id %in% open_ids)) return()
    print(paste("- new entry found:", paste(intersect(df_done()$id, open_ids), collapse = ", ")))
    
    rr <- data() %>% select(-res) %>% left_join(df_done(), by = "id") %>% 
      mutate(status = ifelse(is.na(res), "Open", "Done"))
    data(rr)
    DT::replaceData(dt_proxy, rr)
    
    # replace the progress text
    txt <- sprintf("Progress: % 4i of % 4i (%05.2f%%)",
                   nrow(df_done()), nrow(data()), 100 * (nrow(df_done()) / nrow(data())))
    output$prog <- renderText(txt)
  })
}

shinyApp(ui, server)

or as a picture:

Loop over data.frame and display result immediately in DT

1 Answers