停止用户闪耀的进程，并在计算过程中提供响应能力

Question

我正在使用ClusterProfiler包中的函数，需要0.1-10分钟才能完成。我想在计算过程中保持闪亮的响应速度，并提供终止执行的可能性。这仅是计算：

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

为此找到的最佳解决方案是来自用户fxi（https://stackoverflow.com/a/34517844/9950389）的简洁脚本。但是，我遇到了一个问题。在脚本中作为并行进程执行的函数analyze似乎为下游函数返回了错误的对象类型，在这种情况下为dotplot（unable to find an inherited method for function ‘dotplot’ for signature ‘"list"’）。下面有一个最小的问题示例（基于用户fxi编写的脚本，毫不客气）。您对此有任何解决方案吗？

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
  }
)

我也尝试了使用异步方法，但是两次尝试都失败了：

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)
  }