长时间运行的任务充满挑战：挑战和解决方案

Question

Shiny在反应式编程框架中运行。从根本上讲，这意味着任何会影响结果的UI元素都会随时更改，结果也会更改。这会自动发生，每次更改小部件时都会运行您的分析代码。在很多情况下，这正是您想要的，它使Shiny程序简洁明了且易于制作。但是，对于长时间运行的流程而言，这可能会导致冻结的UI元素和令人沮丧的用户体验。

我进行了一些搜索，找到了Ian在R-Blogger中提供的解决方案。我现在正在尝试使用自己的数据和要求复制Ian给出的代码。

library(shiny)
library(promises)
library(future)
library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(lubridate)
#> 
#> Attaching package: 'lubridate'
#> The following object is masked from 'package:base':
#> 
#>     date
library(ggplot2)
#> Registered S3 methods overwritten by 'ggplot2':
#>   method         from 
#>   [.quosures     rlang
#>   c.quosures     rlang
#>   print.quosures rlang
plan(multiprocess)

# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("Long run Stoppable MBA Async"),

    # Sidebar with a slider input for number of bins 
    sidebarLayout(
        sidebarPanel(
            actionButton('run', 'Run'),
            actionButton('cancel', 'Cancel'),
            actionButton('status', 'Check Status')
        ),

        # Show the plot 
        mainPanel(
           plotOutput("result")
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  data <- read.csv("data/MBA_Online.csv")
  transPlot <- reactive({
    # renderPlot(
      data %>%
        # mutate(tDate=as.Date(Date)) %>%
        # filter(tDate >= as.Date(input$dRange[1]) & tDate <= as.Date(input$dRange[2])) %>%
        # dplyr::mutate(Month = as.factor(month(as.Date(Date)))) %>%
        mutate(Month=as.factor(month(Date))) %>%
        # dplyr::rename(item = Item) %>% 
        dplyr::group_by(Month) %>%
        # dplyr::summarise(n_distinct(Transaction)) %>%
        dplyr::summarize(Transactions = n_distinct(Transaction)) %>%
        # dplyr::summarise(Count=n()) %>%
        ggplot(aes(x=Month, y = Transactions, fill = Month)) +
        geom_bar(stat="identity") +
        geom_label(aes(label= format(Transactions, big.mark = ",")))+
        theme(legend.position="none")+
        theme(panel.background = element_blank())+
        labs(x = "Month", y = "Transactions", title = "Transactions per month")
    # )
  })

  N <- 10

  # status file 
  status_file <- tempfile()

  get_status <- function(){
    scan(status_file, what = "character",sep = "\n")
  }

  set_status <- function(msg){
    write(msg, status_file)
  }

  fire_interupt <- function(){
    set_status("interrupt")
  }

  fire_ready <- function(){
    set_status("Ready")
  }

  fire_running <- function(perc_complete){

    if(missing(perc_complete))
      msg <- "Running..."
    else
      msg <- paste0("Running...", perc_complete, "%
                    Complete")
          set_status(msg)

  }

  interrupted <- function(){
    get_status() == "interrupt"
  }

  #Delete file at end of session
  onStop(function(){
    print(status_file)
    if(file.exists(status_file))
      unlink(status_file)
  })

  # create status file
  fire_ready()

  nclicks <- reactiveVal(0)
  result_val <- reactiveVal()
  observeEvent(input$run,{

    # Don't do anything if analysis is already being run
    if(nclicks() !=0){
      showNotification("Already running analysis")
      return(NULL)
    }

    #increment clicks and prevent concurent analysis
    nclicks(nclicks() + 1)

    result_val(data.frame(Status = "Running..."))

    fire_running()

    result <- future({
      print("Running...")
      for(i in 1:N){

        #  Long running task
        Sys.sleep(1)

        # Check for user interrupts
        if(interrupted()){
          print("Stopping...")
        }

        # Notify staus file of progress
        fire_running(100*i/N)
      }

      # Some results
      transPlot()

      ###
    }) %...>% result_val()

    # Catch interrupt (or any other error) and notify user
    result <- catch(result,
                    function(e){
                      result_val(NULL)
                      print(e$message)
                      showNotification(e$message)
                    })
    # After the promise has been evaluated set nclicks to 0
    #to allow for another run
    result <- finally(result,
                      function(){
                        fire_ready()
                        nclicks(0)
                      })
    # Return something other than the promise so shiny remains responsive
    NULL
  })

  output$result <- renderPlot({
    req(result_val())
  })

  # Register user interrupt
  observeEvent(input$cancel,{
    print("Cancel")
    fire_interupt
  })

  # Let user get analysis progress
  observeEvent(input$status,{
    print("Status")
    showNotification(get_status)
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

静态R Markdown文档中不支持闪亮的应用程序

^{由reprex package（v0.2.1）于2019-06-23创建}