Is it possible to stop executing of R code inside shiny (without stopping the shiny process)?
Solution 1
So another answer, outside a loop : use a child process.
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
}
})
})
})
}
)
edit
See also :
Solution 2
Provided you can split the heavy duty calculations into several parts, or have access to the part of the code that is involved in the computation, you can insert a breaker part. I implemented this in a Shiny app that listens for a button press before continuing with the rest of the calculation. You can run the app from R by
library(shiny)
runGitHub("romunov/shinyapps", subdir = "breaker")
or copy/paste the code into a server.R and ui.R and run it using 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))
})
})
Solution 3
What about 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()
})
}
)
Solution 4
maybe also not exactly what you are looking for, but could do the trick (at least on mighty Linux). For me it works the way I want since I use bash scripts that are triggered by R shiny and I want to be able to abort them. So how about putting your R code in a script and trigger the script by the system command?
In the example below I just use a simple dummy bash script that runs a sleep command, while the first CL argument is the amount of sleep. Everything below 10 secs is not accepted and puts the exit status to 1. In addition, I get some output in a logfile that I can monitor, and thus the progress in realtime.
Hope you find this helpful.
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)
Related videos on Youtube
DeanAttali
R-Shiny consultant with a MSc in Bioinformatics and a Bachelor of Computer Science. Work experience as a software engineer and web developer. Life experience as a restless traveller with too many homes. Founder of AttaliTech Ltd. Author of the R packages shinyjs, timevis, ggExtra, ezknitr, and more. Creator of "Use Cases in Shiny" course - an interactive, online video course. See my projects page for more info or my shiny server for some of my R-Shiny apps.
Updated on July 29, 2022Comments
-
DeanAttali almost 2 years
Let's say I have a shiny app that has a function that can take a long time to run. Is it possible to have a "stop" button that tells R to stop the long-running call, without having to stop the app?
Example of what I mean:
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 }) } ))
-
DeanAttali almost 9 yearsSure, but I mean if you're calling a function where a single expression takes minutes, I'm not sure how you'd make it stop without terminating the session. And if you're calling some function from a different package that takes a while, you could copy-n-paste that function's code and add these checks within the code to achieve this, but there's no really native R way to do this
-
ismirsehregalHere a related post using
library(callr)
can be found.
-
-
DeanAttali over 8 yearsThank you, but the problem with this solution is that it can only stop between iterations of something. I want to be able to call a function that takes a long time, which I don't have access to so I can't enter "breakpoints" inside it, and be able to just stop "ok, nevermind, stop that function call!"
-
fxi over 8 yearsYeah. I see. I just realised that I have exactly the same problem.
-
DeanAttali over 8 yearsI can't run that code as-is because
mcparallel
is not defined (maybe I need a newer version of theparallel
package? or is it from a different package?). But I do see what you're doing, and yes I think that would work. It's not the prettiest solution but it's good you posted this here so that if someone needs to do this, they'll know of a way. Thanks! -
fxi over 8 yearsWith R being single threaded, there is no other way, for now. I think. Are you on Windows ? This will not run on that platform: see parallel doc. You could ask Shiny team for a reactiveChildProcess(). Haha.
-
DeanAttali over 8 yearsYep, on Windows. As are many (most?) of Shiny users. This isn't a big deal, I don't think it'll get priority, I'm not pressed to file an issue about it... but it's good this solution is now out there
-
Martin Smith almost 3 yearsThis stopped working in 2018: see github.com/rstudio/httpuv/issues/148 and the alternative solution at gist.github.com/jcheng5/1ff1efbc539542ecedde92f25458a872