È ansible interrompere l’esecuzione del codice R all’interno di un shiny (senza interrompere il processo shiny)?

Diciamo che ho un’app lucida che ha una funzione che può richiedere molto tempo per essere eseguita. È ansible avere un pulsante “stop” che dice a R di interrompere la chiamata di lunga durata, senza dover fermare l’app?

Esempio di cosa intendo:

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

modifica: x-post da shiny-discuss

Quindi un’altra risposta, al di fuori di un ciclo: usa un processo figlio.

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

modificare

Guarda anche :

  • discussione brillante: processo figlio
  • asincrono-command-dispatch-in-interactive-r

Se è ansible dividere i calcoli pesanti in più parti o accedere alla parte del codice coinvolta nel calcolo, è ansible inserire una parte dell’interruttore. L’ho implementato in un’app Shiny che ascolta la pressione di un pulsante prima di continuare con il resto del calcolo. Puoi eseguire l’app da R di

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

oppure copia / incolla il codice in un server.R e ui.R ed runApp() 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)) }) }) 

Che dire di 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() }) } ) 

forse anche non esattamente quello che stai cercando, ma potrebbe fare il trucco (almeno sul potente Linux). Per me funziona nel modo che preferisco, dal momento che utilizzo script di bash triggersti ​​da R shiny e voglio poterli abortire. Che ne dici di inserire il tuo codice R in uno script e triggersre lo script tramite il comando di sistema?

Nell’esempio seguente, utilizzo semplicemente un semplice script fittizio che esegue un comando di sospensione, mentre il primo argomento CL è la quantità di sospensione. Tutto sotto i 10 secondi non viene accettato e imposta lo stato di uscita su 1. Inoltre, ottengo un output in un file di log che posso monitorare e quindi il progresso in tempo reale.

Spero che ti sia d’aiuto.

 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)