Is it possible to stop executing of R code inside shiny (without stopping the shiny process)?

Question

Let's say I have a shiny app that has a function that can take a long time to run. Is it possible to have a "stop" button that tells R to stop the long-running call, without having to stop the app?

Example of what I mean:

analyze <- function() {
  lapply(1:5, function(x) { cat(x); Sys.sleep(1) })
}

runApp(shinyApp(
  ui = fluidPage(
    actionButton("analyze", "Analyze", class = "btn-primary"),
    actionButton("stop", "Stop")
  ),
  server = function(input, output, session) {
    observeEvent(input$analyze, {
      analyze()
    })
    observeEvent(input$stop, {
      # stop the slow analyze() function
    })
  }
))

edit: x-post from shiny-discuss

Answer 1

So another answer, outside a loop : use a child process.

library(shiny)
library(parallel)

#
# reactive variables
# 
rVal <- reactiveValues()
rVal$process <- NULL
rVal$msg <- NULL
rVal$obs <- NULL
counter <- 0
results <- list()
dfEmpty <- data.frame(results = numeric(0))


#
# Long computation
#
analyze <- function() {
  out <- lapply(1:5, function(x) {
    Sys.sleep(1)
    rnorm(1)
})
  data.frame(results = unlist(out))
}

#
# Shiny app
#
shinyApp(
  ui = fluidPage(
    column(6,
      wellPanel(
        tags$label("Press start and wait 5 seconds for the process to finish"),
        actionButton("start", "Start", class = "btn-primary"),
        actionButton("stop", "Stop", class = "btn-danger"),
        textOutput('msg'),
        tableOutput('result')
        )
      ),
    column(6,
      wellPanel(
        sliderInput(
          "inputTest",
          "Shiny is responsive during computation",
          min = 10,
          max = 100,
          value = 40
          ),
        plotOutput("testPlot")
        ))),
  server = function(input, output, session)
  {
    #
    # Add something to play with during waiting
    #
    output$testPlot <- renderPlot({
      plot(rnorm(input$inputTest))
    })

    #
    # Render messages
    #
    output$msg <- renderText({
      rVal$msg
    })

    #
    # Render results
    #
    output$result <- renderTable({
      print(rVal$result)
      rVal$result
    })

    #
    # Start the process
    #
    observeEvent(input$start, {
      if (!is.null(rVal$process))
        return()
      rVal$result <- dfEmpty
      rVal$process <- mcparallel({
        analyze()
      })

      rVal$msg <- sprintf("%1$s started", rVal$process$pid)

    })


    #
    # Stop the process
    #
    observeEvent(input$stop, {
      rVal$result <- dfEmpty
      if (!is.null(rVal$process)) {
        tools::pskill(rVal$process$pid)
        rVal$msg <- sprintf("%1$s killed", rVal$process$pid)
        rVal$process <- NULL

        if (!is.null(rVal$obs)) {
          rVal$obs$destroy()
        }
      }
    })

    #
    # Handle process event
    #
    observeEvent(rVal$process, {
      rVal$obs <- observe({
        invalidateLater(500, session)
        isolate({
        result <- mccollect(rVal$process, wait = FALSE)
        if (!is.null(result)) {
          rVal$result <- result
          rVal$obs$destroy()
          rVal$process <- NULL
        }
      })
      })
    })
  }
  )

edit

See also :

• shiny-discuss : child process
• asynchronous-command-dispatch-in-interactive-r

Answer 2

Provided you can split the heavy duty calculations into several parts, or have access to the part of the code that is involved in the computation, you can insert a breaker part. I implemented this in a Shiny app that listens for a button press before continuing with the rest of the calculation. You can run the app from R by

library(shiny)
runGitHub("romunov/shinyapps", subdir = "breaker")

or copy/paste the code into a server.R and ui.R and run it using runApp().

#ui.R
library(shiny)

shinyUI(fluidPage(

  titlePanel("Interrupting calculation"),

  sidebarLayout(
    sidebarPanel(
      sliderInput(inputId = "num.rows", 
                  label = "Generate number of rows",
                  min = 1e1,
                  max = 1e7,
                  value = 3e3),
      actionButton(inputId = "ok", label = "Stop computation")
    ),
    mainPanel(
      verbatimTextOutput("result")
    )
  )
))

#server.R
library(shiny)

shinyServer(function(input, output) {
  initial.ok <- 0

  part1 <- reactive({
    nr.f <- floor(input$num.rows/2)
    out1 <- data.frame(col = sample(letters[1:5], size = nr.f, 
                                    replace = TRUE), 
                       val = runif(nr.f))
    out1
  })

  part2 <- reactive({

    nr.c <- ceiling(input$num.rows/2)
    out2 <- data.frame(col = sample(letters[1:5], size = nr.c, 
                                    replace = TRUE),
                       val = runif(nr.c))
    out2
  })

  output$result <- renderPrint({

    out1 <- part1()

    if (initial.ok < input$ok) {
      initial.ok <<- initial.ok + 1
      stop("Interrupted")
    }

    out2 <- part2()
    out <- rbind(out1, out2)

    print("Successful calculation")
    print(str(out))
  })
})

Answer 3

I've already linked a related post in a comment above, but due to @Julien asking for a simple solution I applied the library(callr) approach to the example given here.

We have to be aware of the fact that R is single threaded. Accordingly, If we want to interrupt a function we need to run it in a separate process, so that the parent process isn't blocked.

Usually when it comes to async processes in shiny I'd recommend using promises. However, currently the processes spawned via future_promise are not intended to be terminated.

Please check the following example:

library(shiny)
library(callr)
library(shinyjs)

analyze <- function() {
  lapply(1:5, function(x) { cat(x); Sys.sleep(1) })
}

runApp(shinyApp(
  ui = fluidPage(
    useShinyjs(),
    actionButton("analyze", "Analyze", class = "btn-primary"),
    disabled(actionButton("stop", "Stop"))
  ),
  server = function(input, output, session) {
    rv <- reactiveValues()
    
    # run analyze() in a background process
    observeEvent(input$analyze, {
      disable("analyze")
      enable("stop")
      rv$analyze_process <- r_bg(
        func = analyze
      )
    })
    
    # interrupt analyze()
    observeEvent(input$stop, {
      # stop the slow analyze() function
      rv$analyze_process$kill()
      enable("analyze")
      disable("stop")
    })
    
    # retrieve result from background process
    observe({
      if (!is.null(rv$analyze_process) && rv$analyze_process$poll_io(0)["process"] == "ready") {
        cat("Result:\n")
        print(rv$analyze_process$get_result())
        enable("analyze")
        disable("stop")
      } else {
        invalidateLater(1000)
      }
    })
  }
))

PS: Another approach would be using library(ipc).

Answer 4

What about httpuv::service() ?

library(shiny)
analyze <- function(session=shiny::getDefaultReactiveDomain()){
  continue = TRUE
  lapply(1:100, function(x) {
    if(continue){
      print(x)
      Sys.sleep(1)
      # reload inputs
      httpuv:::service()
      continue <<- !isTRUE(session$input$stopThis)
    }
  }
  )
}

shinyApp(
  ui = fluidPage(
    actionButton("start","Start",class="btn-primary", onclick="Shiny.onInputChange('stopThis',false)"),
    actionButton("stop","Stop",class="btn-danger", onclick="Shiny.onInputChange('stopThis',true)")
  ),
  server = function(input, output, session) {
    observeEvent(input$start, {
      analyze()
    })
  }
)

Answer 5

A nice solution was published here: https://www.r-bloggers.com/2018/07/long-running-tasks-with-shiny-challenges-and-solutions/

library(shiny)
library(promises)
library(future)
plan(multiprocess)

ui <- fluidPage(
  titlePanel("Long Run Stoppable Async"),
  sidebarLayout(
    sidebarPanel(
      actionButton('run', 'Run'),
      actionButton('cancel', 'Cancel'),
      actionButton('status', 'Check Status')
    ),
    mainPanel(
      tableOutput("result")
    )
  )
)

server <- function(input, output) {
  N <- 10
  
  # Status File
  status_file <- tempfile()
  
  get_status <- function(){
    scan(status_file, what = "character",sep="\n")
  }
  
  set_status <- function(msg){
    write(msg, status_file)
  }
  
  fire_interrupt <- function(){
    set_status("interrupt")
  }
  
  fire_ready <- function(){
    set_status("Ready")
  }
  
  fire_running <- function(perc_complete){
    if(missing(perc_complete))
      msg <- "Running..."
    else
      msg <- paste0("Running... ", perc_complete, "% Complete")
    set_status(msg)
  }
  
  interrupted <- function(){
    get_status() == "interrupt"
  }
  
  # Delete file at end of session
  onStop(function(){
    print(status_file)
    if(file.exists(status_file))
      unlink(status_file)
  })
  
  # Create Status File
  fire_ready()
  
  
  nclicks <- reactiveVal(0)
  result_val <- reactiveVal()
  observeEvent(input$run,{
    
    # Don't do anything if analysis is already being run
    if(nclicks() != 0){
      showNotification("Already running analysis")
      return(NULL)
    }
    
    # Increment clicks and prevent concurrent analyses
    nclicks(nclicks() + 1)
    
    result_val(data.frame(Status="Running..."))
    
    fire_running()
    
    result <- future({
      print("Running...")
      for(i in 1:N){
        
        # Long Running Task
        Sys.sleep(1)
        
        # Check for user interrupts
        if(interrupted()){ 
          print("Stopping...")
          stop("User Interrupt")
        }
        
        # Notify status file of progress
        fire_running(100*i/N)
      }
      
      #Some results
      quantile(rnorm(1000))
    }) %...>% result_val()
    
    # Catch inturrupt (or any other error) and notify user
    result <- catch(result,
                    function(e){
                      result_val(NULL)
                      print(e$message)
                      showNotification(e$message)
                    })
    
    # After the promise has been evaluated set nclicks to 0 to allow for anlother Run
    result <- finally(result,
                      function(){
                        fire_ready() 
                        nclicks(0)
                      })
    
    # Return something other than the promise so shiny remains responsive
    NULL
  })
  
  output$result <- renderTable({
    req(result_val())
  })
  
  # Register user interrupt
  observeEvent(input$cancel,{
    print("Cancel")
    fire_interrupt()
  })
  
  # Let user get analysis progress
  observeEvent(input$status,{
    print("Status")
    showNotification(get_status())
  })
}

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

Answer 6

maybe also not exactly what you are looking for, but could do the trick (at least on mighty Linux). For me it works the way I want since I use bash scripts that are triggered by R shiny and I want to be able to abort them. So how about putting your R code in a script and trigger the script by the system command?

In the example below I just use a simple dummy bash script that runs a sleep command, while the first CL argument is the amount of sleep. Everything below 10 secs is not accepted and puts the exit status to 1. In addition, I get some output in a logfile that I can monitor, and thus the progress in realtime.

Hope you find this helpful.

library(shiny)

ui <- fluidPage(

# we need this to send costumized messages
tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode",function(message) {eval(message.value);});'))),

# Sidebar with a slider input for number of bins 
sidebarLayout(
sidebarPanel(

    textInput("duration", "How long you want to wait?"),hr(),
    p("Are you experienced?"),
    actionButton("processbtn", "Yes"),hr(),
    p("Show me what's going on"),
    actionButton("logbtn", "Show me by clicking here."),hr(),
    p("Tired of being experienced?"),
    actionButton("abortbtn", "Yes")

    ), # close sidebar panel 

  # Show a plot of the generated distribution
  mainPanel(
     textOutput("outText"),hr(),
     verbatimTextOutput("outLog")
  ) # close mainpanel
 ) # close sidebar
) # close fluidpage

#------SERVER------------

# Define server logic required to draw a histogram
server <- function(input, output, session) {

# our reactive values that change on button click by the observe functions below
values <- reactiveValues(process = 0, abort = 0, log = 0)

observeEvent(input$processbtn, {
  values$process = 1
  values$abort = 0
  values$log = 0
})

observeEvent(input$abortbtn, {
  values$process = 0
  values$abort = 1
})

observeEvent(input$logbtn, {
   values$log = 1
})

current_state = function(exitfile) {
# get the pid
pid = as.integer(system2("ps", args = "-ef | grep \"bash ~/dummy_script.sh\" | grep -v grep | awk '{print $2}'", stdout = TRUE))
print(pid)

if (length(pid) > 0)
 return("RUNNING")

if (file.exists(exitfile))
 return("TERMINATED")

return("NOT_STARTED")
} 

start_function = function(exitfile) {
 if(input$duration == "") {
  end_message="The text input field is empty!"
  js_string <- 'alert("SUCCESS");'
  js_string <- sub("SUCCESS",end_message,js_string)
  session$sendCustomMessage(type='jsCode', list(value = js_string)) 
  values$process = 0
  return("NOT_STARTED")

 } else { # all checks are fine. send a message and start processing
    end_message="We start waiting, yeah!!!"
   js_string <- 'alert("SUCCESS");'
   js_string <- sub("SUCCESS",end_message,js_string)
   session$sendCustomMessage(type='jsCode', list(value = js_string))  

 # here we execute the outsourced script and
 # write the exit status to a file, so we can check for that and give an error message
 system(paste("( bash ~/dummy_script.sh", input$duration,"; echo $? >", exitfile, ")"), wait = FALSE)
 return("RUNNING")
 }  
}

on_terminated = function(exitfile) {
  # get the exit state of the script
  status = readLines(exitfile)
  print(status)
  # we want to remove the exit file for the next run
  unlink(exitfile, force = TRUE)

  # message when we finished
  if ( status != 0 ){
    end_message="Duration is too short."
    js_string <- 'alert("SUCCESS");'
    js_string <- sub("SUCCESS",end_message,js_string)
    session$sendCustomMessage(type='jsCode', list(value = js_string))
  }
  else {
    end_message="Success"
    js_string <- 'alert("SUCCESS");'
    js_string <- sub("SUCCESS",end_message,js_string)
    session$sendCustomMessage(type='jsCode', list(value = js_string))
  }
  values$process = 0
}

# our main processing fucntion
output$outText = renderText({
   # trigger processing when action button clicked
   if(values$process) {

    # get the homefolder
     homedir=Sys.getenv("HOME")

     # create the path for an exit file (we'll need to evaluate the end of the script)
     exitfile=file.path(homedir, "dummy_exit")
     print(exitfile)

     state = current_state(exitfile) # Can be NOT_STARTED, RUNNING, COMPLETED
     print(state)
     if (state == "NOT_STARTED")
        state = start_function(exitfile)

     if (state == "RUNNING")
        invalidateLater(2000, session = getDefaultReactiveDomain())

     if (state == "TERMINATED")
        on_terminated(exitfile)



   # Abort processing
   } else
   if(values$abort) {
      pid = as.integer(system2("ps", args = "-ef | grep \"bash ~/dummy_script.sh\" | grep -v grep | awk '{print $2}'", stdout = TRUE))
    print(pid)
    system(paste("kill", pid), wait = FALSE)
   }

 }) # close renderText function 

 output$outLog = renderText({

 if(values$log) {

   homedir=Sys.getenv("HOME")
   logfile=file.path(homedir, "/dummy_log")

 if(file.exists(logfile)){
   invalidateLater(2000)
   paste(readLines(logfile), collapse = "\n")
 }
 else {
   print("Nothing going on here")
 }
}

})


} # close server

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