I have a shiny app which should run calculations on multiple cores while providing feedback via progress bars. This works fine as long as I do not process the results of the futures further (see working example below). As soon as I use the results afterwards the progress bars do not update until all futures are done.
I use the packages future, promises and ipc for interprocess communication. I think the problem is that R wants to continue working with the futures as soon as the results are coming in. I tried to stop the algorithm with commands like resolved() or resolve() but without any progress.
library(shiny)
library(future)
library(promises)
library(ipc)
plan(list(multiprocess, sequential))
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch calculation")
)
server <- function(input, output, session) {
observeEvent(input$go, {
x <- list()
N = availableCores()
Tasks = rep(10, N) #Number of sequential tasks per core
progress = list() #A list to maintain progress for each run
resultsvec <- c()
for(j in 1:N){
progress[[j]] = AsyncProgress$new(message = paste("analysis, core ",j))
x[[j]] <- future({
for(l in 1:Tasks[j]){
progress[[j]]$inc(1/Tasks[j])
resultsvec <- append(resultsvec, l)
Sys.sleep(1)
}
resultsvec
progress[[j]]$close()
})
}
result <- lapply(x, value)
#... do stuff with result
})
}
shinyApp(ui = ui, server = server)
Here is the server function where the progress bars are updated correctly.
server <- function(input, output, session) {
observeEvent(input$go, {
x <- list()
N = availableCores()
Tasks = rep(10, N) #Number of sequential tasks per core
progress = list() #A list to maintain progress for each run
for(j in 1:N){
progress[[j]] = AsyncProgress$new(message = paste("analysis, core ",j))
x[[j]] <- future({
for(l in 1:Tasks[j]){
progress[[j]]$inc(1/Tasks[j])
Sys.sleep(1)
}
progress[[j]]$close()
})
}
})
}
I managed to solve the problem for my needs, although the solution does not use futures anymore. I switched over to the doSNOW package. But as far as I am aware there is no option in doSNOW or other parallel packages other than the future/promises that allow interprocess communication. So this is my workaround. I used one progress bar for the whole process as opposed to above.
library(shiny)
library(doSNOW)
ui <- fluidPage(
actionButton(inputId = "go", label = "Launch calculation")
)
server <- function(input, output, session) {
observeEvent(input$go, {
Tasks <- 40 #now total tasks to do
runs <- 10 #splitting of progress bar. 10 means every 10% it gets updated. 20 every 5% etc.
taskvec <- rep(Tasks %/% runs, runs)
if (Tasks %% runs != 0){
taskvec[1:(Tasks %% runs)] <- taskvec[1:(Tasks %% runs)] + 1
}
resultsvec <- c()
cl <- makeCluster(2)
registerDoSNOW(cl)
withProgress(message = "Analysis", value = 0,{
for (j in 1:runs) {
resultsvec_sub <- foreach(i = 1:taskvec[j],
.combine = append) %dopar% {
f <- i
Sys.sleep(1)
return(f)
}
resultsvec <- append(resultsvec, resultsvec_sub)
incProgress(1/runs)
}
})
stopCluster(cl)
#do stuff with resultsvec..
})
}
shinyApp(ui = ui, server = server)
As you can see I split the Tasks before I assign them to the cores and update the progress bar when each split is done on all cores. This is of course more inefficient because when almost all of tasks within a split are done. Some cores may be idle until the other cores are done and the next split starts. One could improve the splitting process/distribution of tasks but it is working now.