Shiny：在非活动的 tabPanel 上更新 DT

Question

TL;DR：如何在数据表处于非活动选项卡但其输入发生变化时强制绘制数据表？

有一个闪亮的应用程序，看起来像这样：

library(shiny)
library(DT)
shinyApp(

  ui = fluidPage(

    sidebarLayout(

      sidebarPanel(
        numericInput(
          inputId = "random_val",
          label = "pick random value",
          value = 1
        )
      ),

      mainPanel(
        tabsetPanel(
          id = "tabset",
          tabPanel(
            title = "some_other_tab",
            "Some other stuff"
          ),
          tabPanel(
            title = "test_render",
            textOutput("echo_test"),
            DTOutput("dt_test")
          )
        )
      )
    )
  ),

  server = function(input, output) {

    output$echo_test <- renderText({
      cat("renderText called \n")
      input$random_val
    })
    outputOptions(output, "echo_test", suspendWhenHidden = FALSE)

    output$dt_test <- renderDT({
      cat("renderDT called \n")
      df <- data.frame(
        a = 1:10^6,
        b = rep(input$random_val, 10^6)
      )
      datatable(df)
    })
    outputOptions(output, "dt_test", suspendWhenHidden = FALSE)
  }

)

我的问题如下：当标签test_render（即带有DT的标签）打开时输入（input$random_value）发生变化，一切正常。但是，当包含DT 的选项卡在用户更改其输入时未处于活动状态时，DT 不会更新，即使设置了suspendWhenHidden = FALSE 并且似乎调用了renderDT。

我发现一个open issue 抱怨类似的问题，但没有提供解决方案。

我也找到了这个question 并尝试将其调整为我的问题。到目前为止，我通过从浏览器控制台运行$("#dt_test table").DataTable().draw(); 成功更新了DT。 DT 在被点击时也会更新（例如，在排序按钮上）。

我正在寻找一种方法来更新DT 立即 输入更改（或其初始化），无论它是否在活动面板上。这个问题的一个特别麻烦的情况是应用程序启动时——DT 没有立即呈现。似乎绘图仅在它所在的选项卡打开时才开始（它显示 Processing...）。在我的实际应用中，这会导致几秒钟的延迟——这就是为什么我想在用户查看其他标签时强制处理DT。

我尝试包含一个在各种 events 上运行 $("#dt_test table").DataTable().draw(); 的 javascript 文件，但到目前为止没有成功。

有没有办法通过上述事件或任何其他方法来实现我正在寻找的东西？

Answer 1

我想出了两种可能的解决方案。

1. 通过使用观察者，但使用此解决方案，表格将在切换到数据表选项卡时更新，而不是之前。

这受到两个视频的启发，这些视频对更好地了解闪亮的工作原理很有帮助：

Shiny developer conference 2016 - 第一个列出的两个视频

1. 通过使用代理对象，此选项需要通过在呈现表格时设置适当的选项来进行服务器端处理（请参阅下面的此解决方案的代码）

解决方案 1

    library(shiny)
    library(DT)
    shinyApp(

            ui = fluidPage(

                    sidebarLayout(

                            sidebarPanel(
                                    numericInput(
                                            inputId = "random_val",
                                            label = "pick random value",
                                            value = 1
                                    )
                            ),

                            mainPanel(
                                    tabsetPanel(
                                            id = "tabset",
                                            tabPanel(
                                                    title = "some_other_tab",
                                                    "Some other stuff"
                                            ),
                                            tabPanel(
                                                    title = "test_render",
                                                    textOutput("echo_test"),
                                                    DTOutput("dt_test")
                                            )
                                    )
                            )
                    )
            ),

            server = function(input, output) {

                    output$echo_test <- renderText({
                            cat("renderText called \n")
                            input$random_val
                    })
                    outputOptions(output, "echo_test", suspendWhenHidden = FALSE)

                    observeEvent(input$random_val, {
                            cat("renderDT called \n")
                            df <- data.frame(
                                    a = 1:10^6,
                                    b = rep(input$random_val, 10^6)
                            )   
                            output$dt_test <- renderDT(df)
                    })
            }
    )

解决方案 2

    library(shiny)
    library(DT)
    shinyApp(

            ui = fluidPage(

                    sidebarLayout(

                            sidebarPanel(
                                    numericInput(
                                            inputId = "random_val",
                                            label = "pick random value",
                                            value = 1
                                    )
                            ),

                            mainPanel(
                                    tabsetPanel(
                                            id = "tabset",
                                            selected = "test_render",
                                            tabPanel(
                                                    title = "some_other_tab",
                                                    "Some other stuff"
                                            ),
                                            tabPanel(
                                                    title = "test_render",
                                                    textOutput("echo_test"),
                                                    DTOutput("dt_test")
                                            )
                                    )
                            )
                    )
            ),

            server = function(input, output, session) {

                    output$echo_test <- renderText({
                            cat("renderText called \n")
                            input$random_val
                    })
                    outputOptions(output, "echo_test", suspendWhenHidden = FALSE)
                    output$dt_test <- renderDT({
                            cat("renderDT called \n")
                            df <- data.frame(
                                    a = 1:10^6,
                                    b = rep(1, 10^6)
                            )
                            datatable(df)
                    }, server = TRUE)
                    observeEvent(input$random_val, {
                            df <- data.frame(
                                    a = 1:10^6,
                                    b = rep(input$random_val, 10^6)
                            )
                            dt_test_proxy <- dataTableProxy("dt_test", session = shiny::getDefaultReactiveDomain(),
                                                            deferUntilFlush = TRUE)
                            replaceData(dt_test_proxy, df)
                            cat("table updated \n")
                    })
                    updateTabsetPanel(session, "tabset", selected = "some_other_tab")
            }
    )

如果这有帮助，请告诉我......

Answer 2

根据thread，如果 DT 小部件隐藏在页面上，则它们不会呈现： https://github.com/rstudio/DT/blob/ca5e7645b42c021137d4333c2f781b62abf32ad1/inst/htmlwidgets/datatables.js#L113

更具体地说，如果他们的 DOM 元素的 offsetWidth 和 offsetHeight 为 0，如果他们或他们的父母之一被 display: none 隐藏，就会发生这种情况。这就是tabPanel 和conditionalPanel 隐藏其内容的方式。

一种解决方法可能是绕过tabPanel 并使用visibility 属性有条件地自己呈现DT。当一个元素有visibility: hidden时，它不会显示，但它确实会占用空间。

这是一个例子：

library(shiny)
library(DT)

hiddenPanel <- function(...) {
  div(style = "visibility: hidden;", ...)
}

toggleVisibility <- function(id, visible, session = getDefaultReactiveDomain()) {
  session$sendCustomMessage("toggle-visibility", list(id = id, visible = visible))
}

shinyApp(
  ui = fluidPage(
    tags$head(
      tags$script("
        Shiny.addCustomMessageHandler('toggle-visibility', function(msg) {
          $('#' + msg.id).css('visibility', msg.visible ? 'visible' : 'hidden');
        });
      ")
    ),

    sidebarLayout(
      sidebarPanel(
        numericInput(
          inputId = "random_val",
          label = "pick random value",
          value = 1
        )
      ),

      mainPanel(
        tabsetPanel(
          id = "tabset",
          tabPanel(
            title = "some_other_tab",
            "Some other stuff"
          ),
          tabPanel(
            title = "test_render"
          )
        ),

        hiddenPanel(
          id = "dt_test_panel",
          DTOutput("dt_test")
        )
      )
    )
  ),

  server = function(input, output, session) {
    output$dt_test <- renderDT({
      cat("renderDT called \n")
      df <- data.frame(
        a = 1:10^4,
        b = rep(input$random_val, 10^4)
      )
      datatable(df)
    })

    observeEvent(input$tabset, {
      toggleVisibility("dt_test_panel", input$tabset == "test_render")
    })
  }
)

注意这里不需要设置suspendWhenHidden = FALSE。我也会谨慎使用它，因为我认为当suspendWhenHidden = FALSE 时 DT 可能不会更新的错误仍然存​​在，并且 DT 在 tabPanel 或 conditionalPanel 中。