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