Shiny 异步：点击actionButton时显示进度，并禁用同一用户的其他操作，但允许并发用户

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

下面的

withProgress

代码仅显示设定时间的进度条，并消失，然后执行实际代码。我想在点击“Analyze”时显示“Status Message”或“Progress Bar”，并在命令运行时显示。只要进度条正在运行，当前用户（其他用户可以使用该应用程序）就无法从侧栏执行任何操作。因为在真正的应用程序中，边栏有更多的菜单项，这些菜单项可以执行类似的任务，每个任务都有一个

Analyze

按钮。如果允许用户浏览侧边栏页面并点击

Analyze

，则应用程序将无法执行多个任务。理想情况下，进度条功能应该与多个操作按钮一起使用

我读过关于

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)

库（闪亮）
图书馆（shinydashboard）
侧边栏这个问题已在

作为将来的参考，如果有人遇到这个问题，下面是完整的答案（我没有想出这个答案，是Joe Cheng的）


这似乎是您要问的主要代码：

  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（输入$run{
有进度（会话，最小值=1，最大值=15{
setProgress（消息='Analysis in progress'，
详细信息='这可能需要一段时间…'）
（我在1:15）{
设置进度（值=i）
系统睡眠（0.5）
}
})
系统（粘贴(
“猫”，
输入$uploadFile$datapath，
"|",
粘贴0（“头-”，输入$nrows），
">",
“out.txt”
),
实习生（正确）
总行数%
最后（~prog$close（））
})

只要future/promise管道是observeEvent中的最后一个表达式（在本例中是这样的，因为
file\u rows（）
和
finally（…）
是管道的一部分），那么Shiny将延迟代表用户处理任何消息

这个解决方案没有解决两件事

进度消息后退一步；我们不仅被迫使用
Progress$new（）
语法而不是cleaner
withProgress（）
，而且还失去了报告进度百分比的能力。您可以尝试使用新的ipc软件包来解决该问题
这不会阻止用户在UI中四处点击；当异步操作执行时，它不会做任何事情，但当操作完成时，这些交互将累积在队列中，并将按照它们到达的顺序进行处理。如果您想完全禁用UI，使其无法执行任何操作，那么目前在Shiny中没有内置的方法来执行此操作。尽管考虑到这一点，您可能会尝试用
showModal（modalDialog（title=“Analysis in Progress”，“这可能需要一段时间…”，footer=NULL）替换Progress的用法我认为这至少可以停止鼠标点击。
这里有一个基于（绝对低于星号的）库（）的解决方案

我偶然发现这个图书馆是因为一个关于@Dean Attali的问题，Joe Cheng在哪里找到了它

ipc包的快速启动提供了一个示例，说明了您的要求：
AsyncProgress

此外，它还提供了一个关于如何使用
AsyncInterruptor
杀死未来的示例。
然而，我还没有能够测试它

我使用@Dean Attali的优秀软件包解决了取消问题，只需启动一个新会话，忽略旧的未来（通过使用
AsyncInterruptor
，您可能能够改进这一点）

但是，尽管如此，我还是给了你的代码一个未来，放弃了你的
system（）
cmd，因为我目前正在Windows上运行R，并找到了一种方法，通过指定会话相关名称来禁用（向@Dean Attali致敬）分析按钮会话智能：

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)

库（闪亮）
图书馆（shinydashboard）
图书馆（ipc）
图书馆（承诺）
图书馆（未来）
图书馆（shinyjs）
图书馆（数据集）
图书馆（V8）
计划（多进程）
jsResetCode请查看withProgress的代码，withProgress不起作用。有什么不对劲吗？为了防止一个用户会话阻塞其他会话或取消任务，您可能需要查看新的异步支持。这篇博文有一个很好的介绍：您的system（）命令是实际代码的一部分，还是仅仅是一个示例？将wait设置为FALSE还提供异步行为。即使从长远来看，使用promises（也请参见库（future.callr））将是一条可行之路。是的，由于应用程序使用外部软件，实际代码具有system（）命令。我尝试使用上述代码，但应用程序处于空闲状态，在提供输入后没有响应。在我的计算机上运行良好，使用：
其他附加包：[1]shinyjs_1.0 future_1.10.0 Promissions_1.0.1 ipc_0.1.0[5]shinydashboard_0.7.1 shinydashboard_1.1.0.9001
（见截图），其他用户的反馈得到了赞赏。我明确地为iris数据添加了库（数据集）。我能想象到的唯一缺失的东西。请重试。PS：您不需要输入文件-只需单击“分析”。我删除了你的那部分代码，因为我在Windows上运行R，所以你的系统调用对我不起作用。应用程序的这一部分对于显示异步行为并不重要。
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)