Parallel processes using CallR within Shiny with user inputs.

[brone11]

I'm trying to get my head around asynchronous programming in R - i want the user to be able to create "scenarios" using input dropdowns from which a table is generated the user can then click on a row within the table and "action" a function - the simplified case is wait for a set amount of seconds (from the user input) and then change the status to complete: this is an example i've been working on but I'm struggling to have multiple versions of my function running if I 'action' one scenario and then another the first one is stopped - any ideas on how i can alter my code to run in parallel in the background? currently the code runs but if another row is actioned while the another is ongoing the first is interrupted but i need them to run in parallel - ie launch multiple r_bg()

library(shiny)
library(DT)
library(callr)

# Define server logic
server <- function(input, output, session) {
  
  run_task <- function(sleep_duration) {
    Sys.sleep(sleep_duration)
  }
  
  # Define reactiveValues to store data
  data <- reactiveValues(table_data = NULL)
  bg_proc <- reactiveVal(NULL)
  check_finished <- reactiveVal(FALSE)
  row_index <- reactiveVal(NULL)
  
  observeEvent(input$add, {
    # Generate table based on user's selection
    # Append new selection to existing data
    new_data <- data.frame(
      Dropdown1 = input$dropdown1,
      Dropdown2 = input$dropdown2,
      Dropdown3 = input$dropdown3,
      Status = "Pending"
    )
    if (is.null(data$table_data)) {
      data$table_data <- new_data
    } else {
      data$table_data <- rbind(data$table_data, new_data)
    }
  })
  
  observeEvent(input$action, {
    # Get the index of the selected row
    row_index(input$output_table_rows_selected)
    
    if (length(row_index()) == 0) {
      return()  # No row selected, do nothing
    }
    
    # Execute the time-consuming operation in the background using callr::r_bg()
    p <- r_bg(
      func = function(run_task, sleep_duration) {
        return(run_task(sleep_duration))
      },
      supervise = TRUE,
      args = list(
        run_task = run_task,
        sleep_duration = as.numeric(data$table_data$Dropdown2[row_index()])
      )
    )
    # Set the status of the selected row to "Completed" after operation completes
    bg_proc(p)
    check_finished(TRUE)
    cat(paste0("\nStart at ", Sys.time()))
  })
  
  observe({
    req(check_finished())
    invalidateLater(1000)
    # Set the status of the selected row to "In Progress"
    data$table_data$Status[row_index()] <- "In Progress"
    cat(paste0("\nStill busy at ", Sys.time()))
    p <- bg_proc()
    if (p$is_alive() == FALSE) {
      check_finished(FALSE)
      bg_proc(NULL)
      data$table_data$Status[row_index()] <- "Completed"  
      cat(paste0("\nFINISHED ", Sys.time()))
    }
  })
  
  observeEvent(input$deleteRows, {
    # Delete selected rows
    if (!is.null(input$output_table_rows_selected)) {
      data$table_data <- data$table_data[-as.numeric(input$output_table_rows_selected), ]
    }
  })
  
  # Render table
  output$output_table <- renderDT({
    data$table_data
  })
}

# Define UI
ui <- fluidPage(
  titlePanel("Dashboard"),
  
  sidebarLayout(
    sidebarPanel(
      selectInput("dropdown1", "Dropdown 1", choices = c("Option 1", "Option 2", "Option 3")),
      selectInput("dropdown2", "Duration of Sleep", choices = c("1", "10", "60")),
      selectInput("dropdown3", "Dropdown 3", choices = c("Option X", "Option Y", "Option Z")),
      
      actionButton("add", "Add"),
      actionButton("edit", "Edit"),
      actionButton("deleteRows", "Delete Rows"),
      actionButton("action", "Action")
    ),
    
    mainPanel(
      DTOutput("output_table")
    )
  )
)

# Run the application
shinyApp(ui = ui, server = server)