¿Es posible detener la ejecución del código R dentro de shiny (sin detener el proceso shiny)?

Digamos que tengo una aplicación shiny que tiene una función que puede llevar mucho tiempo ejecutar. ¿Es posible tener un botón “detener” que le indique a R que detenga la llamada de larga duración, sin tener que detener la aplicación?

Ejemplo de lo que quiero decir:

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

editar: x-post de shiny-discuss

Entonces, otra respuesta, fuera de un bucle: use un proceso hijo.

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

editar

Ver también :

  • shiny-discuss: proceso de niño
  • asynchronous-command-dispatch-in-interactive-r

Siempre que pueda dividir los cálculos de servicio pesado en varias partes o tener acceso a la parte del código que está involucrada en el cálculo, puede insertar una parte de interruptor. Implementé esto en una aplicación shiny que escucha presionar un botón antes de continuar con el rest del cálculo. Puede ejecutar la aplicación desde R por

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

o copiar / pegar el código en un servidor.R y ui.R y ejecutarlo usando 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)) }) }) 

¿Qué pasa con 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() }) } ) 

tal vez tampoco sea exactamente lo que está buscando, pero podría hacer el truco (al menos en el poderoso Linux). Para mí funciona de la manera que quiero ya que utilizo scripts bash que son activados por R shiny y quiero poder abortarlos. Entonces, ¿qué hay de poner su código R en una secuencia de comandos y desencadenar la secuencia de comandos por el comando del sistema?

En el siguiente ejemplo, simplemente uso un simple script dummy bash que ejecuta un comando sleep, mientras que el primer argumento CL es la cantidad de sueño. No se acepta todo lo que esté por debajo de 10 segundos y pone el estado de salida en 1. Además, obtengo algunos resultados en un archivo de registro que puedo monitorear y, por lo tanto, el progreso en tiempo real.

Espero que esto te sea útil.

 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)