shiny - 异步 : Display progress when actionButton is hit and disable other operations for the same user but allow concurrent users

Question

下面是一个示例代码，它接受两个输入:1) 输入文件和 2) 输入行数。单击“分析”按钮后，服务器命令的输出返回到“结果”选项卡集中的“表”。这是一个简单的示例，其中将快速执行命令并切换到“结果”选项卡面板。

以下 withProgress代码只显示设定时间的进度条并消失，然后执行实际代码。我想在点击“分析”时显示“状态消息”或“进度条”，并在运行命令时显示。只要进度条正在运行，当前用户(其他用户可以使用该应用程序)就无法从侧边栏中执行任何操作。因为在真正的应用程序中，侧边栏有更多的菜单项，它们执行类似的任务，每个任务都有一个 Analyze按钮。如果允许用户浏览侧边栏页面并点击 Analyze那么应用程序将有执行多个任务的过载。理想情况下，我们应该将进度条功能与多个 actionButtons 一起使用。

我阅读了关于 async 的博客但无法将正确的代码放在正确的位置。感谢您的帮助!

library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(width = 200,
                    sidebarMenu(id = "tabs",
                                menuItem(
                                  "File", tabName = "tab1", icon = icon("fas fa-file")
                                )))
body <- tabItem(tabName = "tab1",
        h2("Input File"),
        fluidRow(
          tabPanel(
            "Upload file",
            value = "upload_file",
            fileInput(
              inputId = "uploadFile",
              label = "Upload Input file",
              multiple = FALSE,
              accept = c(".txt")
            ),
            checkboxInput('header', label = 'Header', TRUE)
          ),
          box(
            title = "Filter X rows",
            width = 7,
            status = "info",
            tabsetPanel(
              id = "input_tab",
              tabPanel(
                "Parameters",
                numericInput(
                  "nrows",
                  label = "Entire number of rows",
                  value = 5,
                  max = 10
                ),
                actionButton("run", "Analyze")
              ),
              tabPanel(
                "Results",
                value = "results",
                navbarPage(NULL,
                           tabPanel(
                             "Table", DT::dataTableOutput("res_table"), 
icon = icon("table")
                           )),
                downloadButton("downList", "Download")
              )
            )
          )
        ))
ui <-
shinyUI(dashboardPage(
dashboardHeader(title = "TestApp", titleWidth = 150),
sidebar,dashboardBody(tabItems(body))
))


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

observeEvent(input$run, {
withProgress(session, min = 1, max = 15, {
  setProgress(message = 'Analysis in progress',
              detail = 'This may take a while...')
  for (i in 1:15) {
    setProgress(value = i)
    Sys.sleep(0.5)
  }
})
system(paste(
  "cat",
  input$uploadFile$datapath,
  "|",
  paste0("head -", input$nrows) ,
  ">",
  "out.txt"
),
intern = TRUE)
head_rows <- read.delim("out.txt")
file_rows(head_rows)
  })

observeEvent(file_rows(), {
updateTabsetPanel(session, "input_tab", "results")
output$res_table <-
DT::renderDataTable(DT::datatable(
file_rows(),
options = list(
  searching = TRUE,
  pageLength = 10,
  rownames(NULL),
  scrollX = T
  )
  ))
 })

output$downList <- downloadHandler(
filename = function() {
paste0("output", ".txt")
}, content = function(file) {
write.table(file_rows(), file, row.names = FALSE)
}
)
}

shinyApp(ui = ui, server = server)

Answer 1

这是基于(绝对未加星标的)库( ipc )的解决方案。

由于@Dean Attali 的一个问题，我遇到了这个图书馆，Joe Cheng mentioned它。

快速入门 guide ipc-package 给出了您要求的示例:AsyncProgress .

此外，它还提供了一个关于如何使用 AsyncInterruptor 终止 future 的示例。 .
但是，我还没有能够测试它。

我通过使用@Dean Attali 的大包shinyjs 解决了取消问题简单地开始一个新 session 并忽略旧的 Future (您可以使用 AsyncInterruptor 改进这一点)。

但是，我给了你的代码一个 Future，放弃了你的 system() cmd 因为我目前在 Windows 上运行 R 并找到了一种方法来禁用(向@Dean Attali 致敬)分析按钮 session 方式，方法是为其提供依赖于 session 的名称:

library(shiny)
library(shinydashboard)
library(ipc)
library(promises)
library(future)
library(shinyjs)
library(datasets)
library(V8)

plan(multiprocess)

jsResetCode <- "shinyjs.reset = function() {history.go(0)}"

header <- dashboardHeader(title = "TestApp", titleWidth = 150)

sidebar <- dashboardSidebar(width = 200,
                            sidebarMenu(id = "tabs",
                                        menuItem(
                                          "File", tabName = "tab1", icon = icon("fas fa-file")
                                        )))

body <- dashboardBody(useShinyjs(),
                      extendShinyjs(text = jsResetCode),
                      fluidRow(column(
                        12, tabItem(
                          tabName = "tab1",
                          h2("Input File"),
                          textOutput("shiny_session"),
                          tabPanel(
                            "Upload file",
                            value = "upload_file",
                            fileInput(
                              inputId = "uploadFile",
                              label = "Upload Input file",
                              multiple = FALSE,
                              accept = c(".txt")
                            ),
                            checkboxInput('header', label = 'Header', TRUE)
                          ),
                          box(
                            title = "Filter X rows",
                            width = 7,
                            status = "info",
                            tabsetPanel(
                              id = "input_tab",
                              tabPanel(
                                "Parameters",
                                numericInput(
                                  "nrows",
                                  label = "Entire number of rows",
                                  value = 5,
                                  max = 10
                                ),
                                column(1, uiOutput("sessionRun")),
                                column(1, uiOutput("sessionCancel"))
                              ),
                              tabPanel(
                                "Results",
                                value = "results",
                                navbarPage(NULL,
                                           tabPanel(
                                             "Table", DT::dataTableOutput("res_table"),
                                             icon = icon("table")
                                           )),
                                downloadButton("downList", "Download")
                              )
                            )
                          )
                        )
                      )))



ui <- shinyUI(dashboardPage(
  header = header,
  sidebar = sidebar,
  body = body,
  title = "TestApp"
))


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

  output$shiny_session <-
    renderText(paste("Shiny session:", session$token))

  file_rows <- reactiveVal()

  run_btn_id <- paste0("run_", session$token)
  cancel_btn_id <- paste0("cancel_", session$token)

  output$sessionRun <- renderUI({
    actionButton(run_btn_id, "Analyze")
  })

  output$sessionCancel <- renderUI({
    actionButton(cancel_btn_id, "Cancel")
  })

  paste("Shiny session:", session$token)


  observeEvent(input[[run_btn_id]], {
    file_rows(NULL)

    shinyjs::disable(id = run_btn_id)

    progress <- AsyncProgress$new(message = 'Analysis in progress',
                                  detail = 'This may take a while...')
    row_cnt <- isolate(input$nrows)
    get_header <- isolate(input$header)

    future({
      fileCon <- file("out.txt", "w+", blocking = TRUE)
      linesCnt <- nrow(iris)
      for (i in seq(linesCnt)) {
        Sys.sleep(0.1)
        progress$inc(1 / linesCnt)
        writeLines(as.character(iris$Species)[i],
                   con = fileCon,
                   sep = "\n")
      }
      close(fileCon)
      head_rows <- read.delim("out.txt", nrows = row_cnt, header=get_header)
      progress$close() # Close the progress bar
      return(head_rows)
    }) %...>% file_rows

    return(NULL) # Return something other than the future so we don't block the UI
  })

  observeEvent(input[[cancel_btn_id]],{
    js$reset() # reset shiny session)
  })

  observeEvent(file_rows(), {
    shinyjs::enable(id = run_btn_id)
    updateTabsetPanel(session, "input_tab", "results")
    output$res_table <-
      DT::renderDataTable(DT::datatable(
        req(file_rows()),
        options = list(
          searching = TRUE,
          pageLength = 10,
          rownames(NULL),
          scrollX = T
        )
      ))
  })

  output$downList <- downloadHandler(
    filename = function() {
      paste0("output", ".txt")
    },
    content = function(file) {
      write.table(file_rows(), file, row.names = FALSE)
    }
  )
}

shinyApp(ui = ui, server = server)

应用程序运行: