R闪亮：功能运行时显示“正在加载...”消息

Posted 2023-03-24

【中文标题】R闪亮：功能运行时显示“正在加载...”消息

【英文标题】：R shiny: display "loading..." message while function is running

【发布时间】：2013-06-23 21:56:05

【问题描述】：

我使用 Shiny GUI R 包。我正在寻找一种在按下 actionButton 后显示“正在加载...”之类的消息的方法。该函数需要几分钟才能执行，因此我需要以某种方式通知用户该按钮实际上触发了某个事件。现在 server.R 代码如下所示：

DATA <- reactive(
  if(input$DownloadButton>0) 
    RunDownload()
   else 
    NULL
  
)

output$Download <- renderText(
  if(NROW(DATA())>0) 
    paste0(Sys.time(),": ",NROW(DATA()), " items downloaded")
   else 
    ''
  
)

actionButton() 是一个从互联网下载数据的功能。 input$DownloadButton 是动作按钮。因此，在按下按钮后，用户等待几分钟，然后才看到一条消息说下载成功。我想在按下 actionButton 后显示一条消息“正在加载...”，然后在执行结束时显示另一条消息，如 paste0(Sys.time(),": ",NROW(DATA()), " items downloaded")。

【问题讨论】：

为了简化事情，我认为你需要一个进度条，在 R 中有很多方法可以将它添加到函数中。能不能给个RunDownload的版本看看怎么加进度条？

我不需要进度条，好吧，它可以称为二进制进度条。我需要显示 2 条消息：一条在函数开始，一条在函数结束。我想我忘了在消息正文中指定我正在使用 Shiny 包，它不仅仅是 R 代码。现在会解决这个问题。

【参考方案1】：

我通过将以下代码添加到 sidebarPanel() 解决了这个问题：

html('<script type="text/javascript">
        $(document).ready(function() 
          $("#DownloadButton").click(function() 
            $("#Download").text("Loading...");
          );
        );
      </script>
')

【参考方案2】：

我找到了一个适合我的解决方案。我正在使用 Bootstrap 模式。函数执行开始时显示，结束时再次隐藏。

modalBusy

 msgHandler =  singleton(tags$head(tags$script('Shiny.addCustomMessageHandler("jsCode",
                                            function(message) 
                                              console.log(message)
                                              eval(message.code);
                                            );'
                                            )
                                )
                      )

 label_id = paste(id, "label", sep='-')
 modal_tag <- div(id=id, 
               class="modal hide fade", 
               "aria-hidden"=FALSE, 
               "aria-labelledby"=label_id, 
               "role"="dialog", 
               "tabindex"="-1",
               "data-keyboard"=FALSE,
               "data-backdrop"="static")
 header_tag <- div(class="modal-header",
                h3(id=label_id, title))
 body_tag <- div(class="modal-body",
              Row(...))   
 footer_tag <- div(class="modal-footer")
 modal_tag <- tagAppendChildren(modal_tag, header_tag, body_tag, footer_tag)
 tagList(msgHandler, modal_tag) 

使用函数来显示和隐藏它

showModal <- function(id,session) 
  session$sendCustomMessage(type="jsCode",
                            list(code= paste("$('#",id,"').modal('show')"
                                             ,sep="")))


hideModal <- function(id,session) 
  session$sendCustomMessage(type="jsCode",
                            list(code= paste("$('#",id,"').modal('hide')"
                                             ,sep="")))

在你的函数调用之前调用 showModal 函数，之后调用 hideModal 函数！

希望这会有所帮助。

Seb

【讨论】：

我无法让它工作。 @Seb您能否分享一个工作示例。谢谢

【参考方案3】：

我已经在使用比我之前发布的更简单、更可靠的方法了。

组合

tags$style(type="text/css", "
           #loadmessage 
             position: fixed;
             top: 0px;
             left: 0px;
             width: 100%;
             padding: 5px 0px 5px 0px;
             text-align: center;
             font-weight: bold;
             font-size: 100%;
             color: #000000;
             background-color: #CCFF66;
             z-index: 105;
           
  ")

与

conditionalPanel(condition="$('html').hasClass('shiny-busy')",
                 tags$div("Loading...",id="loadmessage")
)

例子：

runApp(list(
  ui = pageWithSidebar(
      headerPanel("Test"),
         sidebarPanel(
           tags$head(tags$style(type="text/css", "
             #loadmessage 
               position: fixed;
               top: 0px;
               left: 0px;
               width: 100%;
               padding: 5px 0px 5px 0px;
               text-align: center;
               font-weight: bold;
               font-size: 100%;
               color: #000000;
               background-color: #CCFF66;
               z-index: 105;
             
          ")),
           numericInput('n', 'Number of obs', 100),
           conditionalPanel(condition="$('html').hasClass('shiny-busy')",
                            tags$div("Loading...",id="loadmessage"))
         ),
         mainPanel(plotOutput('plot'))
  ),
  server = function(input, output) 
    output$plot <- renderPlot( Sys.sleep(2); hist(runif(input$n)) )
  
))

tags$head() 不是必需的，但最好将所有样式保留在 head 标签内。

【讨论】：

可以对页面内需要一些时间加载的renderDataTable 表执行类似操作吗？

喜欢这个解决方案，但我很难让它与shinydashboard 一起工作。任何想法为什么？在开发人员控制台中，我可以看到条件被触发，但尽管尝试了许多不同的位置和 conditionalPanel 周围的包装器，但我无法让消息真正显示出来。

如果有人和我有同样的问题，我调整了这个错误解决方法，以获得更好的外观和更自然的使用进度条，也适用于shinydashboard：github.com/rstudio/shiny/issues/609

在这种情况下，如何使用textOutput 将“正在加载...”替换为动态消息？例如，如果我想指出正在运行的函数正在处理多少行（例如“挖掘 50,000 条记录”）。？

【参考方案4】：

你可以使用 ShinyJS：https://github.com/daattali/shinyjs

当actionButton被按下时，您可以轻松切换显示“正在加载...”的文本组件，当计算完成后，您可以将该组件切换为隐藏状态。

【参考方案5】：

非常简单，您可以在函数开头使用内置闪亮函数showModal()，在函数末尾使用removeModal()。如果你去掉了footer，就不能点击掉所说的modal。

例子：

observeEvent(input$button, 
     showModal(modalDialog("Doing a function", footer=NULL))
     #Do the stuff here....
     #...
     #...
     #Finish the function
     removeModal()
)

【参考方案6】：

虽然这个问题很老，但我认为它仍然相关。我提供了另一种解决方案，它在按钮上显示活动指示器，在按钮标签旁边开始一个冗长的过程。

我们需要一个带有span 中标签的操作按钮以及某种标识该标签的方法。

actionButton("btnUpdate", span("Update", id="UpdateAnimate", class=""))

我们还需要一些可以添加到按钮标签的 CSS 动画，例如像这样：

            tags$head(tags$style(type="text/css", '
            .loading 
                display: inline-block;
                overflow: hidden;
                height: 1.3em;
                margin-top: -0.3em;
                line-height: 1.5em;
                vertical-align: text-bottom;
                box-sizing: border-box;
            
            .loading.dots::after 
                text-rendering: geometricPrecision;
                content: "⠋\\A⠙\\A⠹\\A⠸\\A⠼\\A⠴\\A⠦\\A⠧\\A⠇\\A⠏";
                animation: spin10 1s steps(10) infinite;
                animation-duration: 1s;
                animation-timing-function: steps(10);
                animation-delay: 0s;
                animation-iteration-count: infinite;
                animation-direction: normal;
                animation-fill-mode: none;
                animation-play-state: running;
                animation-name: spin10;
            
            .loading::after 
                display: inline-table;
                white-space: pre;
                text-align: left;
            
            @keyframes spin10  to  transform: translateY(-15.0em);  
            '))

现在我们可以使用shinyjs 来操作span 类，它会在按钮标签后面动态添加动画。一旦用户按下按钮，我们就会添加动画：

    observeEvent(input$btnUpdate,  # User requests update
        # ... 

        shinyjs::addClass(id = "UpdateAnimate", class = "loading dots")
        shinyjs::disable("btnUpdate")
        
        # ...
    )

当操作完成后，我们可以从 span 中移除类并结束动画：

    output$distPlot <- renderPlot(
        # ...
        
        Sys.sleep(1) # just for show, you probably want to remove it in a real app
        # Button settings        
        shinyjs::enable("btnUpdate")
        shinyjs::removeClass(id = "UpdateAnimate", class = "loading dots")

        # ...
    )

full code of the sample app is available as gist on GitHub。