Ist es möglich, die Ausführung von R-Code innerhalb von glänzend zu stoppen (ohne den glänzenden Prozess zu stoppen)?

Question

Angenommen, ich habe eine glänzende App mit einer Funktion, die lange dauern kann. Ist es möglich, einen "Stop" -Knopf zu haben, der R mitteilt, dass der lang andauernde Anruf gestoppt werden soll, ohne dass die App gestoppt werden muss?

Beispiel von dem, was ich meine:

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

Sofern Sie die schweren Berechnungen in mehrere Teile aufgeteilt, oder Zugriff auf den Teil des Codes, die in der beteiligt ist Berechnung können Sie einen Breakerteil einfügen. Ich habe dies in einer Shiny app implementiert, die auf einen Tastendruck wartet, bevor Sie mit dem Rest der Berechnung fortfahren. Sie können

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

oder copy/paste den Code in ein server.R und ui.R die App aus R laufen und es mit runApp() laufen.

#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

Was ist mit 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 3

Also eine andere Antwort, außerhalb einer Schleife: Verwenden Sie einen Child-Prozess.

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

bearbeiten

Siehe auch:

• shiny-discuss : child process
• asynchronous-command-dispatch-in-interactive-r

Answer 4

vielleicht auch nicht genau das, was Sie suchen, konnte aber den Trick (zumindest auf m richtiges Linux). Für mich funktioniert es so, wie ich es möchte, da ich Bash-Skripte verwende, die von R-Shiny ausgelöst werden und ich möchte sie abbrechen können. Wie wäre es, wenn Sie Ihren R-Code in ein Skript schreiben und das Skript mit dem Systembefehl auslösen würden?

Im folgenden Beispiel verwende ich einfach ein dummy Bash-Skript, das einen Schlafbefehl ausführt, während das erste CL-Argument die Menge an Schlaf ist. Alles unter 10 Sekunden wird nicht akzeptiert und setzt den Exit-Status auf 1. Zusätzlich erhalte ich eine Ausgabe in einer Logdatei, die ich überwachen kann, und damit den Fortschritt in Echtzeit.

Ich hoffe, Sie finden das hilfreich.

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)