Question

让我们说我有一个闪亮的应用程序，其功能可能需要很长时间才能运行。是否有可能停止＆＃34;停止＆＃34;告诉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 from shiny-discuss

Answer 1

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

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

修改的

另见：

Answer 2

如果您可以将重型计算分成几个部分，或者可以访问计算中涉及的部分代码，则可以插入断路器部件。我在Shiny app中实现了这一点，在继续计算的其余部分之前，它会监听按钮按下。您可以通过

从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 3

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 4

也许也不是你想要的，但可以做到这一点（至少在强大的Linux上）。对我而言，它按我想要的方式工作，因为我使用由R闪亮触发的bash脚本，我希望能够中止它们。那么如何将R代码放入脚本并通过系统命令触发脚本？

在下面的示例中，我只使用一个运行sleep命令的简单虚拟bash脚本，而第一个CL参数是睡眠量。不接受10秒以内的所有内容并将退出状态设置为1.此外，我在日志文件中得到一些输出，我可以监控，从而实时进行。

希望您觉得这很有帮助。

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)

Answer 5

绝对！未来+ IPC +承诺对我个人而言效果很好。

请参见https://cran.r-project.org/web/packages/ipc/vignettes/shinymp.html#killing-a-long-running-process

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

5 个答案: