future_promise 仍然挂起我的 Shiny 应用程序

Question

我有一个 R Shiny 应用程序，它通过 downloadHandler 生成 R markdown pdf。生成可供下载的 pdf 需要几秒钟的时间，并且它会挂起我的 Shiny 应用程序，在下载可用之前没有任何迹象表明它正在处理它。我正在尝试使用 future_promise 功能来生成 R markdown，同时用户仍然可以使用 Shiny 应用程序。

我创建了一个简单的示例，尝试使用 future_promise 但未成功；单击下载按钮后，应用程序不会对滑块输入更改做出反应，直到下载可用为止。

闪亮的应用程序：

library(shiny)
library(promises)
library(future)

plan(multisession)

# Define UI for application that draws a histogram
ui <- fluidPage(
  
    titlePanel("Old Faithful Geyser Data"),

    sidebarLayout(
        sidebarPanel(
            sliderInput("bins",
                        "Number of bins:",
                        min = 1,
                        max = 50,
                        value = 30),
            downloadButton("makePDF", "Download PDF")
        ),

        mainPanel(
           plotOutput("distPlot")
        )
    )
)

server <- function(input, output) {

    output$distPlot <- renderPlot({
        x    <- faithful[, 2]
        bins <- seq(min(x), max(x), length.out = input$bins + 1)

        hist(x, breaks = bins, col = 'darkgray', border = 'white',
             xlab = 'Waiting time to next eruption (in mins)',
             main = 'Histogram of waiting times')
    })
    
    output$makePDF <- downloadHandler(
      
      filename = function() {
        paste("Histogram", ".pdf", sep = "")
      },
      
      content = function(file) {
        req(input$bins)
        varbins <- input$bins
        
        future_promise({
        tempReport <- file.path(tempdir(), "Histogram.Rmd")
        file.copy("Histogram.Rmd", tempReport, overwrite = TRUE)
        Sys.sleep(5)
        rmarkdown::render(tempReport, output_file = file,
                          params = list(vbins = varbins),
                          envir = new.env(parent = globalenv()))
        })
      }
    )
}

shinyApp(ui = ui, server = server)`

直方图.Rmd:

    ---
    title: "Untitled"
    output: 
      pdf_document:
        latex_engine: xelatex

    params:
      vbins: 10
    ---

    ```{r setup, include=FALSE}
    knitr::opts_chunk$set(echo = TRUE)
    ```
    ## Including Plots

    You can also embed plots, for example:

    ```{r pressure, echo=FALSE}
    plot(pressure)

        # generate bins based on input$bins from ui.R
        x    <- faithful[, 2]
        bins <- seq(min(x), max(x), length.out = params$vbins + 1)

        # draw the histogram with the specified number of bins
    hist(x, breaks = bins, col = 'darkgray', border = 'white',
         xlab = 'Waiting time to next eruption (in mins)',
         main = 'Histogram of waiting times')

    ```

如有任何帮助，我们将不胜感激！谢谢你

Answer 1

您的示例的问题在于，期货是在

downloadHandler

内部调用的，因此在结果可用之前会很忙。您需要在

downloadHandler

之外渲染文档，并在准备好后复制它。

这是一个示例 - 需要两个按钮，以便渲染和下载是单独的操作，但它们对用户来说就像一个按钮，因为

downloadButton

不可见，并且在渲染完成后由

{shinyjs}

触发。

library(shiny)
library(promises)
library(future)
library(bslib)
library(shinyjs)
plan(multisession)

ui <- fluidPage(
  useShinyjs(),
      sliderInput("bins",
                  "Number of bins:",
                  min = 1,
                  max = 50,
                  value = 30),
      textOutput("time"),
      bslib::input_task_button("download", "Download", icon = shiny::icon("download")),
      div(style = "visibility: hidden;",
        downloadButton("makePDF", "Download PDF")
      )
)

server <- function(input, output, session) {

  # function to create report
  make_report <- function(bins){
    output_file <- tempfile(fileext = ".pdf")
    Sys.sleep(5)
    rmarkdown::render("Histogram.Rmd", output_file = output_file,
                      params = list(vbins = bins))
    output_file
  }

  # task that calls the function
  task <- ExtendedTask$new(function(...){
    future_promise(make_report(...))
  }) |> bslib::bind_task_button("download")

  # start the task
  observeEvent(input$download, {
    req(input$bins)
    task$invoke(input$bins)
  })

  # wait for the render to complete and then trigger the download
  observe({
    task$result()
    shinyjs::runjs("document.getElementById('makePDF').click();")
  })

  output$makePDF <- downloadHandler(
    filename = function() {"Histogram.pdf"},
    content = function(file) {file.copy(task$result(), file)}
  )

  output$time <- renderText({
      invalidateLater(1000, session = session)
      Sys.time()
    })
}

shinyApp(ui = ui, server = server)