在长时间运行的函数中强制更新 htmlOutput

Question

我有一个运行很长进程的 Shiny 应用程序，我想提醒用户该进程实际上正在运行。 在下面的示例中，我有一个切换开关，它以 1 秒的延迟执行代码块（我的实际应用程序运行了大约 20 秒），我有一个 HTML 输出框，可以让用户知道正在发生的事情。 但是，由于底层引导过程仅在函数退出后更新 UI 元素，因此用户只能看到最后一条消息“完成”。

我已经看到其他类似这样的问题，其答案建议创建一个反应值，然后将 renderUI() 函数包装在一个 observe() 函数中（例如， here ），但这有同样的问题。

我还尝试将 htmlOutput() 包装在 Shinycssloaders 包中的 withSpinner() 中，但我收到一条错误消息，提示“缺少 TRUE/FALSE 需要的值”。 我认为这是来自shinydashboardPlus，因为它不喜欢 tagList() 元素中的 withspinner() 输出。 我希望这至少会给我一个 HTML 输出上的动画微调器，表明它正在运行。

非常感谢有关使此特定设置工作的任何输入或向用户提供该过程处于活动状态的一些反馈的替代方法。

library(shiny)
library(shinycssloaders)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)

# Define UI for application that draws a histogram
ui <- dashboardPage(skin = 'blue', 
                    
shinydashboardPlus::dashboardHeader(title = 'Example',
    leftUi = tagList(
        switchInput(inputId = 'swtLabels', label = 'Labels', value = TRUE,
                    onLabel = 'Label 1', offLabel = 'Label 2',
                    onStatus = 'info', offStatus = 'info', size = 'mini', 
                    handleWidth = 230),
        htmlOutput(outputId = 'labelMessage')
        #withSpinner(htmlOutput(outputId = 'labelMessage')) # leads to error noted in text
        )
    ),
    dashboardSidebar(),
    dashboardBody()
)

server <- function(input, output) {
  rv <- reactiveValues() 
  rv$labelMessage <- 'Start' 

  observeEvent(input$swtLabels, {
     rv$labelMessage <- 'Updating labels...'
     Sys.sleep(1)
     rv$labelMessage <- 'Done'
  })

  output$labelMessage <- renderUI(HTML(rv$labelMessage))
}

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

Answer 1

我使用shinyjs包找到了一个解决方法，代码如下。 带回家的消息是，通过使用 shinjs::html()，对 htmlOutput 的影响是立竿见影的。 我什至在最后添加了一个花哨的淡出来隐藏消息。

它确实创建了另一个包依赖项，但它解决了问题。 我确信有一种方法可以编写一个小的 JavaScript 函数并将其添加到 Shiny 应用程序中以实现相同的结果。 不幸的是，我不懂 JavaScript。 （在 Shiny 应用程序中包含 JS 代码的参考 - Shiny 中的JavaScript 事件，在 Shiny中添加 JavaScript 和 CSS ）

library(shiny)
library(shinycssloaders)
library(shinydashboard)
library(shinyjs)
library(shinydashboardPlus)
library(shinyWidgets)

# Define UI for application that draws a histogram
ui <- dashboardPage(skin = 'blue', 
                    
shinydashboardPlus::dashboardHeader(title = 'Example',
    leftUi = tagList(
        useShinyjs(),
        switchInput(inputId = 'swtLabels', label = 'Labels', value = TRUE,
                    onLabel = 'Label 1', offLabel = 'Label 2',
                    onStatus = 'info', offStatus = 'info', size = 'mini', 
                    handleWidth = 230),
        htmlOutput(outputId = 'labelMessage')
        #withSpinner(htmlOutput(outputId = 'labelMessage')) # leads to error noted in text
        )
    ),
    dashboardSidebar(),
    dashboardBody()
)

server <- function(input, output) {  
  observeEvent(input$swtLabels, {
     shinyjs::html(id = 'labelMessage', html = 'Starting...')
     shinyjs::showElement(id = 'labelMessage')
     Sys.sleep(1)
     shinyjs::html(id = 'labelMessage', html = 'Done') 
     shinyjs::hideElement(id = 'labelMessage', anim = TRUE, animType = 'fade', time = 2.0) 
  })

  output$labelMessage <- renderUI(HTML(rv$labelMessage))
}

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