在 long 运行函数中强制更新 htmlOutput

Question

我有一个运行很长进程的 Shiny 应用程序，我想提醒用户该进程实际上是运行。在下面的示例中，我有一个切换开关，它以 1 秒的延迟执行代码块（我的实际应用程序运行大约 20 秒），并且我有一个 HTML 输出框，它应该让用户知道发生了什么事情。但是，由于底层 bootstrap 进程仅在函数退出后更新 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 package 代码找到了解决此问题的方法。带回家的消息是，通过使用 shinjs::html()，对 htmlOutput 的影响是立竿见影的。我什至在最后添加了一个花哨的淡出来隐藏消息。

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

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) 
  })
}

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

在 long 运行函数中强制更新 htmlOutput

Forcing updates to htmlOutput within a long running function

r

shinydashboardplus

shinycssloaders

在 long 运行 函数中强制更新 htmlOutput

Forcing updates to htmlOutput within a long running function

r

shinydashboardplus

shinycssloaders

在 long 运行函数中强制更新 htmlOutput