Get PID for subprocesses for asynchronous futures in R shiny - r

server <- function(input, output, session) {
out1_rows <- reactiveVal()
observeEvent(input$run1, {
prog <- Progress$new(session)
prog$set(message = "Analysis in progress",
detail = "This may take a while...",
value = NULL)
fut1 = future({
system(paste("Command1" , input$file ">", "out1.txt"))
system(paste("Command2" , out1.txt ">", "out2.txt"))
head_rows <- read.delim("out2.txt")
return(head_rows)
}) %...>%
out1_rows() %>%
finally( ~ prog$close())
NULL
})
observeEvent(req(out1_rows()), {
output$out_table <-
DT::renderDataTable(DT::datatable(
out1_rows(),
)
))
observeEvent(input$cancel, {
async_pid <- fut1$job$pid ##this is empty
#async_pid <- Sys.getpid() ##this return PID for main process and kills "/opt/shiny-server/R/SockJSAdapter.R" but not for subprocesses inside future()
system(paste("kill -15", async_pid))
})
}
Here, i would need to kill the process running the commands inside future(). I tried in the above way to fetch the PID running the future() process and kill when input$cancel is triggered. However, fut1$job$pid is not returning any PID value and hence the kill operation is not successful.
This link from future vignettes shows how to fetch PID for future() jobs. However, in my case i am not able to use Sys.getpid() inside future() as i am not sure how to store the PID value as the process is already returning some output from my system commands.
This page future GIT shows an alternate way of External Kill with the syntax fut1$job$pid. But this fails to fetch the PID.
I couldn't figure this out after trying different ways or blinded with the syntax. Could someone hint the way to do this.

Can you please provide us with a full reproducible example?
You might want to have a look at library(future.callr):
using plan(callr) you can get the pid and kill the process like this:
library(future)
library(promises)
library(future.callr)
plan(callr)
myFuture <- future({
Sys.sleep(5)
return(runif(1))
})
myFuture$process$get_pid()
myFuture$process$is_alive()
# myFuture$process$kill()
# myFuture$process$is_alive()
then(myFuture, onFulfilled = function(value){
print(value)
}, onRejected = NULL)
Edit - adapted from your code:
library(shiny)
library(DT)
library(future)
library(promises)
library(future.callr)
library(shinyjs)
library(V8)
plan(callr)
ui <- fluidPage(
useShinyjs(),
titlePanel("Trigger & kill future"),
sidebarLayout(
sidebarPanel(
actionButton(inputId="run1", label="run future"),
actionButton(inputId="cancel", label="kill future")
),
mainPanel(
dataTableOutput('out_table')
)
)
)
server <- function(input, output, session) {
disable("cancel")
out1 <- reactiveValues(rows=NULL)
observeEvent(input$run1, {
disable("run1")
enable("cancel")
out1$rows <- NULL
prog <- Progress$new(session)
prog$set(message = "Analysis in progress",
detail = "This may take a while...",
value = NULL)
fut1 <<- future({
# system(paste("Command1" , input$file, ">", "out1.txt"))
# system(paste("Command2" , out1.txt, ">", "out2.txt"))
# head_rows <- read.delim("out2.txt")
head_rows <- data.frame(replicate(5, sample(runif(20, 0, 1), 20, rep=TRUE)))
Sys.sleep(5)
return(head_rows)
})
print(paste("Running async process with PID:", fut1$process$get_pid()))
then(fut1, onFulfilled = function(value){
out1$rows <<- value
}, onRejected = function(error){NULL})
finally(fut1, function(){
prog$close()
disable("cancel")
enable("run1")
})
return(NULL)
}, ignoreInit = TRUE)
observeEvent(req(out1$rows), {
output$out_table <- DT::renderDataTable(DT::datatable(out1$rows))
})
observeEvent(input$cancel, {
async_pid <- fut1$process$get_pid()
print(paste("Killing PID:", async_pid))
# system(paste("kill -9", async_pid)) # Linux - kill
# system(paste("taskkill /f /pid", async_pid)) # Windows - kill
fut1$process$kill() # library(future.callr) - kill
out1$rows <- NULL
disable("cancel")
enable("run1")
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)
Errors occuring occasionally:
Unhandled promise error: callr failed, could not start R, exited with non-zero status, has crashed or was killed
Warning: Error in : callr failed, could not start R, exited with non-zero status, has crashed or was killed
95: <Anonymous>
Maybe this statement from #HenrikB tells us what we are running into:
However, to get this working properly you probably also need to make
your future expression / future code interrupt aware using
withCallingHandlers() etc. It'll also unknown to me what happens if
you signal too many interrupts in a row - it might be that you manage
to interrupt the main R-loop of the worker, which then will cause the
R worker to terminate. That'll result in a missing R worker and you've
got that problem you mention at the beginning.
The error is also mentioned here but currently in the future.callr-context I don't know how to work around it.
2nd Edit:
By now I got some further feedback from Henrik Bengtsson. He once again mentions that the core future API currently isn't supporting the termination of futures. So, in the end no matter what backend we use, we might run into problems.
Disregarding this info, I'd have another look at the library(ipc) vignette which provides two examples on the topic Killing a long running process. But I pointed to this here already - which probably led to this question.
In the end all of this might be useless regarding your scenario because you are using system() calls which create subprocesses of their own (and have their own pid accordingly). Therefore why don't you use wait = FALSE in your system command (as I mentioned in the comments here already) to get your async behaviour and catch their pid using something like myCommand & echo $! (see this). This way you don't need any futures.

Could find the PID by insetring cat() as such:
future({
cat('future process PID \n', Sys.getpid(), '\')
<expensive operation>
})
the PID number will appear in console when running the app. This is how I have found out that, in my case, the PID outside and inside the future were identical.

Related

R, httr, and an unstoppable error message

In summary, I'm finding that when running httr::POST against a plumber api, within an R.utils::withTimeout, the post is throwing an error message which can't be suppressed. The error message is:
Error in .Call(R_curl_fetch_memory, enc2utf8(url), handle, nonblocking) : reached elapsed time limit
Things I've tried:
suppressmessages/warnings
tryCatch with no error response
Using sinks
I can't think of any other way of stopping this error. The code carries on running but it's resulting in users of the api getting spammed with error messages when checking for an available port to call. Any ideas welcome.
Reproducible example (note this uses rstudio jobs pkg and a separate plumber file, but i've tried without the jobs pkg and the issue persists so it's not connected to that.) :
plumber.R:
#* quick ping
#* #post /ping
function() {
list(msg = "you got here!")
}
#* slow 10s call
#* #post /slowfxn
function() {
Sys.sleep(10)
1
}
code which calls and produces errors:
#run the plumber file in a separate job:
r <- plumber::plumb("errortest/plumber.R")
job::job({r$run(swagger = F,port = 1111)})
#this function will throw the error if no response comes within 3s:
call_with_timeout = function() {
R.utils::withTimeout(
rawToChar(httr::POST("http://127.0.0.1:1111/echo")$content)
,timeout = 3,onTimeout = "silent")
}
#now call the fxn (again in a job) which takes 10 s to run:
job::job({httr::POST(url = "http://127.0.0.1:1111/slowfxn")})
#wait a second for that job to be initiated:
Sys.sleep(1)
#while that's running, try and call the quick fxn, with a 3 second timeout:
#try wrap it in a trycatch to suppress:
tryCatch( {
call_with_timeout()
},
error = function(x) {},
TimeoutException = function(x){},
warning = function(x) {}
)
suppressMessages(suppressWarnings(call_with_timeout()))
#not even a sink can stop it!
sink("delete.txt")
call_with_timeout()
sink(NULL)

Return system console output to user interface

I have a bash script that i'm running using shiny and system. It takes a long time to run so I'd like to provide feedback to the user about progress. In the bash script I have messages that periodically updates the user and I'm trying to find a way to have them printed in the UI.
Here is a minimal working example for which I'd like to have "Output 1" and "Output 2" returned to the user as they appear in the console.
Any help is greatly appreciated.
library(shiny)
ui <- fluidPage(
actionButton("run", "Print to Console")
)
server <- function(input, output, session) {
observeEvent(input$run,{
system(c("echo output 1; sleep 2; echo output 2"))
})
}
shinyApp(ui, server)
I'd suggest to run your system command asynchronously and redirect the output to a log file. In parallel you can continuously read in the logfile via reactiveFileReader.
In contrast, when intern = TRUE the R session (and shiny) is blocked while the command is executed.
Please check the following:
library(shiny)
file.create("commands.sh", "output.log")
Sys.chmod("commands.sh", mode = "0777", use_umask = TRUE)
writeLines(c("#!/bin/bash", "echo output 1","sleep 2", "echo output 2"), con = "commands.sh")
ui <- fluidPage(
actionButton("run_intern", "Run intern"),
textOutput("myInternTextOutput"),
hr(),
actionButton("run_extern", "Run extern"),
textOutput("myExternTextOutput")
)
server <- function(input, output, session) {
systemOutputIntern <- eventReactive(input$run_intern,{
system(command = "echo output 1; sleep 2; echo output 2", intern = TRUE)
})
output$myInternTextOutput <- renderText(systemOutputIntern())
observeEvent(input$run_extern,{
system(command = "./commands.sh 2>&1 | tee output.log", intern = FALSE, wait = FALSE)
})
log <- reactiveFileReader(200, session, filePath = "output.log", readLines)
output$myExternTextOutput <- renderText(log())
}
shinyApp(ui, server)
PS: As an alternative you might want to check AsyncProgress from library(ipc).

Quit a Plumber API once a condition is met

I am trying to run a Plumber API inline to receive an input, and once the proper input is received and a specified condition is met, the input is returned to the globalenv and the API closes itself such that the script can continue to run.
I've specified a condition within a #get endpoint that calls quit(), stop() etc, none of which successfully shut down the API.
I've attempted to run the API in parallel using future such that the parent script can close the Plumber API.
It appears that there isn't actually a method in the Plumber API class object to close the Plumber API, and the API can't be closed from within itself.
I've been through the extended documentation, SO, and the Github Issues in search of a solution. The only semi-relevant solution suggested is to use R.Utils::withTimeout to create a time-bounded timeout. However, this method is also unable to close the API.
A simple use case:
Main Script:
library(plumber)
code_api <- plumber::plumb("code.R")
code_api$run(port = 8000)
code.R
#' #get /<code>
function(code) {
print(code)
if (nchar(code) == 3) {
assign("code",code,envir = globalenv())
quit()}
return(code)
}
#' #get /exit
function(exit){
stop()
}
The input is successfully returned to the global environment, but the API does not shut down afterward, nor after calling the /exit endpoint.
Any ideas on how to accomplish this?
You could look at Iterative testing with plumber #Irène Steve's, Dec 23 2018 with:
trml <- rstudioapi::terminalCreate()
rstudioapi::terminalKill(trml)
excerpt of her article (2nd version of 3):
.state <- new.env(parent = emptyenv()) #create .state when package is first loaded
start_plumber <- function(path, port) {
trml <- rstudioapi::terminalCreate(show = FALSE)
rstudioapi::terminalSend(trml, "R\n")
Sys.sleep(2)
cmd <- sprintf('plumber::plumb("%s")$run(port = %s)\n', path, port)
rstudioapi::terminalSend(trml, cmd)
.state[["trml"]] <- trml #store terminal name
invisible(trml)
}
kill_plumber <- function() {
rstudioapi::terminalKill(.state[["trml"]]) #access terminal name
}
Running a Plumber in the terminal might work in some cases but as I needed access to the R session (for insertText) I had to come up with the different approach. While not ideal the following solution worked:
# plumber.R
#* Insert
#* #param msg The msg to insert to the cursor location
#* #post /insert
function(msg="") {
rstudioapi::insertText(paste0(msg))
stop_plumber(Sys.getpid())
}
.state <- new.env(parent = emptyenv()) #create .state when package is first loaded
stop_plumber <- function(pid) {
trml <- rstudioapi::terminalCreate(show = FALSE)
Sys.sleep(2) # Wait for the terminal to initialize
# Wait a bit for the Plumber to flash the buffers and then send a SIGINT to the R session process,
# to terminate the Plumber
cmd <- sprintf("sleep 2 && kill -SIGINT %s\n", pid)
rstudioapi::terminalSend(trml, cmd)
.state[["trml"]] <- trml # store terminal name
invisible(trml)
Sys.sleep(2) # Wait for the Plumber to terminate and then kill the terminal
rstudioapi::terminalKill(.state[["trml"]]) # access terminal name
}

shiny sourced function stdout to logfile to UI issue

I made a portable shiny app with portable chrome and R. I launch rscript with vbs script in which stdout is redirected to a logfile with:
RScriptFile & " 1> " & logfile & " 2>&1"
What I want to do is to read in the log file so that the user has feedback about the calculation progress. The following reactivePoll works if the "main" shiny script is writing to the console, but it does not if a sourced function writes. Note that both are displayed in the log file, therefore the fault is surely not in the redirection, but somewhere in my logic or in shiny.
If I set bool_for_testing = T the test button works, on the other hand if I set it False not even the first "Go!" is printed on the console until the script is finished, but both are displayed real time in the logfile:
library(shiny)
bool_for_testing = F # note its use below!
logfile_name = "some_log_file_that_exists" # this is created by the vbs (command line) script!
ui = shinyUI(fluidPage(
actionButton("btn_test", "push meh!"),
fluidRow(
column(12, wellPanel(style = "overflow-y:scroll; max-height: 600px",
tags$b(paste("log file is this one:", logfile_name)),
verbatimTextOutput("logText")
))
)
)
) # end UI
server = shinyServer(function(input, output, session) {
observe({
if(input$btn_test > 0){
if(bool_for_testing) {
# this works!
print("Go!")
} else {
# not a letter on log here
print("Go!")
source("some_barely_interesting_function.R")
some_barely_interesting_function()
}
}
})
logFile <- reactivePoll(1000, session,
checkFunc = function() {
if (file.exists(logfile_name))
# should always refresh
runif(1) # Sys.time() does not work either
else
""
},
valueFunc = function() {
readLines(logfile_name)
}
)
# # this does not work either
# fileReaderData <- reactiveFileReader(500, session,
# logfile_name, readLines)
output$logText <- renderText({
text <- logFile()
paste(text, collapse = '\n')
})
session$onSessionEnded(function() {
# for portable R and chrome application
stopApp()
q("no")
})
})
shinyApp(ui = ui, server = server)
If I manually open the log file it shows the progress continuously, therefore I think the GUI thread is held up until the sourced calculation is finished (if I open a new shiny window only for reading the log file, it will work well, too). Is this truly the case, and is there a workaround for this?

Shiny server: socket hang up

Update: I added the solution below
The problem
A little background: I am running Shiny server v1.5 on an Ubuntu precise server. Basically I have an rmarkdown page that allows the user to play with some parameters and then has a download button that generates a document using shiny like so:
```{r,echo=FALSE}
downloadHandler(
filename = "report.pdf",
content = function(file) {
knitr::knit2pdf("report.Rnw",envir=environment())
file.rename(normalizePath('report.pdf'), file)
}
)
```
The Shiny application works fine on my local machine, but crashes on the server. More specifically, the r markdown webpage works fine, but once I click the download button, the app crashes after about 30 seconds. The server logs indicate a socket time-out error:
[2016-02-24 03:38:52.240] [INFO] shiny-server - Starting listener on 0.0.0.0:3838
[2016-02-24 03:49:30.183] [ERROR] shiny-server - Uncaught exception: Error: socket hang up
[2016-02-24 03:49:30.184] [ERROR] shiny-server - Error: socket hang up
at createHangUpError (_http_client.js:215:15)
at Socket.socketCloseListener (_http_client.js:247:23)
at Socket.emit (events.js:129:20)
at TCP.close (net.js:485:12)
[2016-02-24 03:49:30.184] [INFO] shiny-server - Stopping listener on 0.0.0.0:3838
[2016-02-24 03:49:30.185] [INFO] shiny-server - Shutting down worker processes (with notification)
/opt/shiny-server/lib/main.js:364
throw err;
^
Error: socket hang up
at createHangUpError (_http_client.js:215:15)
at Socket.socketCloseListener (_http_client.js:247:23)
at Socket.emit (events.js:129:20)
at TCP.close (net.js:485:12)
This pdf takes quite a long time to generate (about five minutes), so I'm suspecting that I missed some time-out parameter somewhere. This is what I did in my shiny configuration:
run_as shiny;
app_init_timeout 999999;
app_idle_timeout 999999;
# Define a server that listens on port 3838
server {
listen 3838;
....
}
... but to no avail, because I'm still getting the error. Any suggestions would be greatly appreciated!
The solution
As mentioned by #daattali, you cannot have something take that long inside downloadButton, changing the server settings will not change anything about that. So I ended up splitting the generation & download functionality in two parts like so:
```{r, echo=FALSE}
shinyApp(
ui = fluidPage(
fluidRow(
column(2,
conditionalPanel(
condition = "!$('makeReport').hasClass('shiny-busy')",
actionButton("makeReport","Generate Report",icon=icon("file"))
)
),
column(4,
conditionalPanel(
condition = "!$('makeReport').hasClass('shiny-busy')",
uiOutput("downloadButton")
#downloadButton("downloadReport", "Download Report")
)
)
)
),
server = function(input, output) {
output$download_button <- renderUI({
downloadButton("downloadReport", "Download Results")
})
makeReportAction <- eventReactive(input$makeReport, {
...
knitr::knit2pdf("report.Rnw",envir=globalenv())
})
output$downloadButton <- renderUI({
makeReportAction() #only appear after first click on generate
downloadButton("downloadReport", "Download Report")
})
output$downloadReport <- downloadHandler(
filename = "report.pdf",
content = function(file) {
cat(paste("Does the pdf exist?",file.exists("report.pdf")))
file.rename(normalizePath('report.pdf'), file)
}
)
}
)
```
It might be the same problem someone else asked Joe Cheng about in the Google board last week
https://groups.google.com/forum/#!topic/shiny-discuss/4bL9jFaYly0
It looks like there's a time limit on the download handler, so maybe try seeing if it's possible to generate the file beforehand and only serving the file when the button is clicked

Resources