是否有可能停止在闪亮的内部执行R代码(不停止闪亮的过程)？

Question

假设我有一个闪亮的应用程序,其功能可能需要很长时间才能运行.是否有可能有一个"停止"按钮告诉R停止长时间运行的呼叫,而不必停止应用程序？

我的意思是:

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
    })
  }
))

编辑:发光讨论的x-post

Answer 1

如果您可以将繁重的计算分成几个部分，或者可以访问计算中涉及的代码部分，则可以插入一个断路器部分。我在一个Shiny 应用程序中实现了这一点，该应用程序会在继续进行其余计算之前侦听按钮按下情况。您可以通过以下方式从 R 运行该应用程序

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

或将代码复制/粘贴到 server.R 和 ui.R 中并使用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 2

因此，在循环之外的另一个答案是：使用子进程。

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
        }
      })
      })
    })
  }
  )

编辑

也可以看看 ：

• 闪亮讨论：子进程
• 异步命令在交互式R中调度