future.detached.Process.Rmd

---
title: "Untitled"
author: "Bernd Jagla"
date: "2023-01-05"
output: html_document
---


# reactive.R
```{r, eval=FALSE}
  # detached Process, currently only scaterPNG
  detachedProc <- reactiveValues()
  detachedProc$process <- NULL
  detachedProc$msg <- NULL
  detachedProc$obs <- NULL
  detachedProc$startTime= NULL
  detachedProc$result = NULL
  
  activateObserver <- reactiveVal(0)
```
# ui.R
```{r, eval=FALSE}
                   actionButton("runScater", "Start", class = "btn-primary")
                   actionButton("stopScater", "Stop", class = "btn-danger")
```
# output.R

```{r, eval=FALSE}
emptyImage = list(
  src =  normalizePath("/Users/bernd/Rstudio/UTechSCB-SCHNAPPs/inst/www/images/schnappsLogo.png",mustWork = F),
  contentType = "image/png",
  width = 500,
  height = 500,
  alt = "Scater plot will be here when 'apply changes' is checked"
)

# function to be executed in background
# make sure that all variables and packes are loaded
createScaterPNG <- function(scaterReads, n, scols, width=NULL, height=NULL, DEBUG, outfile) {
  if (DEBUG) cat(file = stderr(), "function: createScaterPNG\n")
  # save(file = "~/SCHNAPPsDebug/createScaterPNG.RData", list = c(ls()))
  # cp=load(file='~/SCHNAPPsDebug/createScaterPNG.RData')
  p1 = pltHighExp( scaterReads, n, scols) 
  # calculations
  if (is.null(width)) {
    width <- 96 * 7
  }
  if (is.null(height)) {
    height <- 96 * 7
  }
  myPNGwidth <- width / 96
  myPNGheight <- height / 96
  
  tryCatch(
    ggsave(file = normalizePath(outfile, mustWork = FALSE), plot = p1, width = myPNGwidth, height = myPNGheight, units = "in"),
    error = function(e) {
      if (!is.null(getDefaultReactiveDomain())) {
        showNotification("Problem saving ggplot", type = "warning", duration = NULL)
      }
      return(emptyImage)
    }
  )
  retVal <- list(
    src = normalizePath(outfile, mustWork = FALSE),
    contentType = "image/png",
    width = width,
    height = height,
    alt = "Scater plot should be here"
  )
  
  return(retVal)
}

# click on start button
observeEvent(input$runScater,{
  if (.schnappsEnv$DEBUG) cat(file = stderr(), "observeEvent: detachedProc$runScater\n")
  if (!is.null(detachedProc$process)){
    return()
    }
  start.time <- base::Sys.time()
  if (!is.null(getDefaultReactiveDomain())) {
    showNotification("DE_scaterPNG", id = "DE_scaterPNG", duration = NULL)
  }
  scaterReads <- isolate(scaterReads())
  scols <- isolate(sampleCols$colPal)
  
  if (is.null(scaterReads)){
    removeNotification(id="DE_scaterPNG")
    detachedProc$result <- emptyImage
    return()
    }
  # width <- session$clientData$output_plot_width
  # height <- session$clientData$output_plot_height
  width <- NULL
  height <- NULL
  # outfile has to be set outside of the future since it will be removed after the session closes.
  outfile <- paste0(tempdir(), "/scaterPlot.png")
  
  n <- min(nrow(scaterReads), 50)
  if (.schnappsEnv$DEBUGSAVE) {
    save(file = "~/SCHNAPPsDebug/scater.RData", list = c(ls()))
  }
  # cp=load(file='~/SCHNAPPsDebug/scater.RData')
  detachedProc$result <- emptyImage
  pl=plan()
 
  #span the process/function call
  detachedProc$process <- future({
    createScaterPNG(scaterReads=scaterReads, n=n, scols=scols, width=NULL, height=NULL, DEBUG = DEBUG, outfile=outfile)
  },seed=NULL,
  # list all packages needed
  packages = "scater",
  # list all variables to not transfer too much
  globals = list(createScaterPNG=createScaterPNG, emptyImage=emptyImage, DEBUG=.schnappsEnv$DEBUG, pltHighExp=pltHighExp,
                 scaterReads=scaterReads, n=n, scols=scols, width=NULL, height=NULL, outfile=outfile), # we specify all variables with the function call
  lazy = FALSE, #start immediatly
  stdout = structure(TRUE, drop = TRUE)
  )
  # tell the system we are working
  activateObserver(1)
  cat(file = stderr(), paste("input$start",detachedProc$process$process$get_pid(),"me:",Sys.getpid(),"\n"))
  # in order to be able to stop the calculations we need the PID, this is only easily available using callr in plan
  # there are other ways to get the PID when using other plans
  if("callr" %in% class(pl)){
    detachedProc$PID = detachedProc$process$process$get_pid()
  }else{
    # if("multisession" %in% class(pl)){
    #   currentWorkerPIDs = getWorkerPIDs()
    # }
    # please use callr otherwise we cannot kill process (for now)
    # 
  }
  detachedProc$startTime = start.time
  detachedProc$msg <- sprintf("%1$s started", detachedProc$process$pid)
})
#
# Stop the process
#
observeEvent(input$stopScater, {
  if(.schnappsEnv$DEBUG) cat(file = stderr(), "input$stopScater\n")
  if (!is.null(detachedProc$PID)) {
    if("running" == detachedProc$process$state){
      #For windows
      # system(sprintf("taskkill /F /PID %s", v[[i]]))
      
      #For Linux
      system(sprintf("kill -9 %s", detachedProc$PID))
      activateObserver(0)
      detachedProc$PID = NULL
      detachedProc$process = NULL
      if (!is.null(getDefaultReactiveDomain())) {
        removeNotification(id = "DE_scaterQC")
        removeNotification(id = "DE_scaterPNG")
      }
      
    }
  }
})

#
# Handle process event
#
detachedProc$obs <- observe({
  if (.schnappsEnv$DEBUG) cat(file = stderr(), "observeEvent: detachedProc$process\n")
  # invalidate = reexecute every 500 ms while activeObserver is activated
  if(activateObserver()>0)
    invalidateLater(500, session)
  isolate({
    # check future without asking for value (blocking)
    if(resolved(detachedProc$process))
    # if the process is NULL resolved still returns true
      if(!is.null(detachedProc$process)){
        # we know the result is available, so get it 
        detachedProc$result <- value(detachedProc$process)
        # to be able to store it we get the non-reactive value
        result = detachedProc$result
        # save(file = "~/SCHNAPPsDebug/createScaterPNGprocess.RData", list = c("result"))
        # cp=load(file='~/SCHNAPPsDebug/createScaterPNGprocess.RData')
        detachedProc$process <- NULL
        activateObserver(0)
        printTimeEnd(detachedProc$startTime, "DE_scaterPNG")
        if (!is.null(getDefaultReactiveDomain())) {
          removeNotification( id = "DE_scaterPNG")
        }
      }
  })
})

output$DE_scaterQC <- renderImage(deleteFile = F, {
  start.time <- base::Sys.time()
  on.exit(
    if (!is.null(getDefaultReactiveDomain())) {
      removeNotification(id = "DE_scaterQC")
    }
  )
  if (!is.null(getDefaultReactiveDomain())) {
    showNotification("DE_scaterQC", id = "DE_scaterQC", duration = NULL)
  }
  if (DEBUG) cat(file = stderr(), "renderImage. output$DE_scaterQC\n")
  result = detachedProc$result
  scaterReads <- isolate(scaterReads())
  if (is.null(scaterReads) | is.null(result)) {
    return(emptyImage)
  }
  af = pltHighExp
  # remove env because it is too big
  environment(af) = new.env(parent = emptyenv())
  n <- min(nrow(scaterReads), 50)
  scols <- isolate(sampleCols$colPal)
  .schnappsEnv[["DE_scaterPNG"]] <- list(plotFunc = af,
                                         # plotHighestExprs = plotHighestExprs,
                                         scaterReads = scaterReads, 
                                         n = n,
                                         scols = scols
  )
  setRedGreenButton(
    vars = list(
      c("scaterRan", 1)
    ),
    button = "runScater"
  )
  
  exportTestValues(DE_scaterPNG = {
    result
  })
  result
})

```