stopping a process in shiny by a user and providing responsiveness during computations

Question

I'm using a function from the ClusterProfiler package, which takes 0.1-10 min to complete. I'd like to keep shiny responsive during the computation, and also give a possibility to terminate the execution. This is the computation only:

library(org.Mm.eg.db)
library(clusterProfiler)
d <-
  data.frame(
    ENTREZ = c(
      "26394",
      "16765",
      "19143",
      "54214",
      "620695",
      "14232",
      "20262",
      "100732",
      "99681"
    ),
    Cell_Type = c(rep("A", 5), rep("B", 4)),
    Timepoint = rep("C", 9)
  )

r <- compareCluster(
  ENTREZ ~ Cell_Type + Timepoint,
  data = d,
  fun = "enrichGO",
  pvalueCutoff = 0.5,
  qvalueCutoff = 0.5,
  ont           = "MF",
  pAdjustMethod = "BH",
  readable = T,
  OrgDb         = org.Mm.eg.db,
  keyType       = 'ENTREZID'
)

  rp <- dotplot(r, showCategory=10, x = ~Cell_Type) +
    facet_wrap(~Timepoint)
rp

The best solution I found for that was a neat script from the user fxi (https://stackoverflow.com/a/34517844/9950389). However, I run into a problem. The function analyze executed in the script as a parallel process, seems to return an improper object type for the downstream function, in this case dotplot (unable to find an inherited method for function ‘dotplot’ for signature ‘"list"’). Below there is a minimal example of the problem (shamelessly based on the script written by the user fxi). Do you see any solution to this?

library(shiny)
library(parallel)
library(org.Mm.eg.db)
library(clusterProfiler)

#
# 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() {
  d <-
    data.frame(
      ENTREZ = c(
        "26394",
        "16765",
        "19143",
        "54214",
        "620695",
        "14232",
        "20262",
        "100732",
        "99681"
      ),
      Cell_Type = c(rep("A", 5), rep("B", 4)),
      Timepoint = rep("C", 9)
    )

  r <- compareCluster(
    ENTREZ ~ Cell_Type + Timepoint,
    data = d,
    fun = "enrichGO",
    pvalueCutoff = 0.5,
    qvalueCutoff = 0.5,
    ont           = "MF",
    pAdjustMethod = "BH",
    readable = T,
    OrgDb         = org.Mm.eg.db,
    keyType       = 'ENTREZID'
  )
}

#
# 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'),
             plotOutput('myplot', width = 200)
           )
    ),
    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
    # })

    output$myplot <-renderPlot({
      r <- rVal$result
      rp <- dotplot(r, showCategory=10, x = ~Cell_Type) +
        facet_wrap(~Timepoint) +
        scale_color_gradient(low = "lawngreen", high = "black") +
        guides(color=guide_colorbar(title = "Adj. P-value")) +
        theme(title = element_text(size = 16, face = "plain", lineheight = .8),
              panel.grid.major.x = element_blank(),
              panel.grid.major.y = element_line(size = 0.1),
              axis.title = element_text(size = 16),
              text = element_text(size = 14),
              strip.text.x = element_text(size = 18, face = "plain"),
              axis.text = element_text(size = 14, face = "plain"),
              legend.text = element_text(angle = 0, hjust=0, size = 16),
              legend.title.align = 0.5,
              legend.title = element_text(angle = 0, hjust=0, size = 18)) +
        coord_fixed(ratio = 0.4)
      rp
    })


    #
    # Start the process
    #
    observeEvent(input$start, {
      if (!is.null(rVal$process))
        return(NULL)
      rVal$result <- NULL
      rVal$process <- mcparallel({
        analyze()
      })

      rVal$msg <- sprintf("%1$s started", rVal$process$pid)

    })


    #
    # Stop the process
    #
    observeEvent(input$stop, {
      rVal$result <- NULL
      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
          }
        })
      })
    }) # observe
  }
)

I also tried using the async approach, but both attempts failed:

library(promises)
library(future)

future(
    compareCluster(
      ENTREZ ~ Cell_Type + Timepoint,
      data = d,
      fun = "enrichGO",
      pvalueCutoff = 0.5,
      qvalueCutoff = 0.5,
      ont           = "MF",
      pAdjustMethod = "BH",
      readable = T,
      OrgDb         = org.Mm.eg.db,
      keyType       = 'ENTREZID'
    )
  ) %...>% dotplot(., showCategory=10, x = ~Cell_Type) +
    facet_wrap(~Timepoint)


future(
  compareCluster(
    ENTREZ ~ Cell_Type + Timepoint,
    data = d,
    fun = "enrichGO",
    pvalueCutoff = 0.5,
    qvalueCutoff = 0.5,
    ont           = "MF",
    pAdjustMethod = "BH",
    readable = T,
    OrgDb         = org.Mm.eg.db,
    keyType       = 'ENTREZID'
  )
) %...>% {
  dotplot(., showCategory=10, x = ~Cell_Type) +
  facet_wrap(~Timepoint)
  }