r - 具有反应面板编号但未渲染所有内容的导航栏/选项卡集

Question

这个问题似乎是重复的，但让我解释一下为什么不是。

我想创建一个 Shiny 的 navbarPage ，它具有固定元素和 react 数 tabPanels ，它对其他输入元素使用react。关于如何创建响应式 tabsetPanels/navbarPages 有很多问题，但他们主要针对 看起来像 的内容。最常见的答案(也是我不寻求的答案)是用更新的 navbarPage 集渲染整个 tabPanels 。我知道这个概念，我在下面的代码中使用了它。

这是我希望我的应用程序 看起来像 :

library(shiny)

runApp(
  shinyApp(
    ui = shinyUI(
      fluidPage(
        uiOutput("navPage")
      )
    ), 

    server = function(input, output, session){

      MemoryValue1 <- 1
      MemoryValue2 <- 1

      makeReactiveBinding("MemoryValue1")

      observeEvent(input$button, {
        output[[paste0("plot_", input$number)]] <- renderPlot({
          hist(rnorm(1000))
        })
      })

      observeEvent(input$insidepanels, {
        MemoryValue1 <<- input$insidepanels
      })

      observeEvent(input$number, {
        MemoryValue2 <<- input$number
      })

      output$navPage <- renderUI({

        OutsidePanel1 <- tabPanel("Outside1", 
                                  numericInput("insidepanels", label = "Number of panels inside NavMenu", value = isolate(MemoryValue1), step = 1, min = 1), 
                                  numericInput("number", label = "Panel to add Output-Element to",  value = 1, step = isolate(MemoryValue2), min = 1),
                                  actionButton("button", label = "Add Output-Element")
        )

        OutsidePanel2 <- tabPanel("Ouside2", "Outside 2")

        InsidePanels <- lapply(1:MemoryValue1, function(x){tabPanel(paste0("Inside", x), plotOutput(paste0("plot_", x)))})

        do.call(navbarPage, list("Nav", OutsidePanel1, OutsidePanel2, do.call(navbarMenu, c("Menu", InsidePanels))))

      })
    }
  )
)

正如您可能已经看到的，如果您的输入值位于其他面板中并且将被重新渲染 = 一直重置，则需要花费大量精力来存储它们。由于不必要的渲染，我发现此解决方案难以辨认且速度缓慢。它还会打断点击 input$insidepanels 值的用户。

我希望应用程序 像 一样是外部面板是固定的并且不会重新渲染。主要问题是内部 Shiny 的 navbarPage 渲染 将 HTML 元素分布到两个不同的位置。在导航面板内部和正文中作为选项卡内容。这意味着 a-posteori 添加的元素将无法正确嵌入。

到目前为止，我已经尝试使用自定义标签创建 navbarPage 并让动态输出仅更改其中的一部分。这对导航面板非常有效，但不适用于选项卡内容。原因是所有选项卡(它们的 div 容器)一个接一个地列出，一旦我想一次注入(inject)多个，我就会被 htmlOutput 抛弃，因为它(似乎) 必须有 和 container 并且不能只提供纯 HTML。因此，所有自定义选项卡都无法正确识别。

到目前为止，这是我的代码:

library(shiny)

runApp(
  shinyApp(
    ui = shinyUI(
      fluidPage(
        tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation", 
          tags$div(class = "container", 
            tags$div(class = "navbar-header", 
              tags$span(class = "navbar-brand", "Nav")
            ),
            tags$ul(class = "nav navbar-nav",
              tags$li( 
                tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
              ),
              tags$li( 
                tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
              ),
              tags$li(class = "dropdown", 
                tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
                htmlOutput("dropdownmenu", container = tags$ul, class = "dropdown-menu")
              )
            )
          )
        ),
        tags$div(class = "container-fluid", 
          tags$div(class = "tab-content", id = "tabContent", 
            tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1", 
              numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 1, step = 1, min = 1), 
              numericInput("number", label = "Panel to add Output-Element to",  value = 1, step = 1, min = 1),
              actionButton("button", label = "Add Output-Element")
            ),
            tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2"),
            htmlOutput("tabcontents")
          )
        )
      )
    ), 

    server = function(input, output, session){

      observeEvent(input$button, {
        output[[paste0("plot_", input$number)]] <- renderPlot({
          hist(rnorm(1000))
        })
      })

      output$dropdownmenu <- renderUI({
        lapply(1:input$insidepanels, function(x){tags$li(tags$a(href = paste0("#tab-menu-", x), "data-toggle" = "tab", "data-value" = paste0("Inside", x), paste("Inside", x)))})
      })

      output$tabcontents <- renderUI({
        tagList(
         lapply(1:input$insidepanels, function(x){div(class = "tab-pane", "data-value" = paste("Inside", x), id = paste0("tab-menu-", x), plotOutput(paste0("plot_", x)))})
        )
      })
    }
  )
)

注意: 我还尝试使用从 server 内部触发的 JavaScript-Chunks 创建 HTML。这适用于简单的选项卡内容， 但 我希望我的 tabPanels 仍然具有 Shiny 的输出元素。我看不出我怎么能用 JavaScript 来适应它。这就是我在代码中包含 plotOutput 内容的原因。

感谢任何可以帮助解决此问题的人!

Answer 1

终于想出了一个自己的答案。 我希望这可以成为其他试图理解 Shiny react 性的人的有用引用。 答案是用于自定义元素的 JavaScript(重建标准 Shiny 元素)并使用 Shiny.unbindAll() / Shiny.bindAll()达到 react 性。

代码:

runApp(
  shinyApp(
    ui = shinyUI(
      fluidPage(
        tags$script('
          Shiny.addCustomMessageHandler("createTab",
            function(nr){
              Shiny.unbindAll();

              var dropdownContainer = document.getElementById("dropdown-menu");
              var liNode = document.createElement("li");
              liNode.setAttribute("id", "dropdown-element-" + nr);
              var aNode = document.createElement("a");
              aNode.setAttribute("href", "#tab-menu-" + nr);
              aNode.setAttribute("data-toggle", "tab");
              aNode.setAttribute("data-value", "Inside" + nr);
              var textNode = document.createTextNode("Inside " + nr);

              aNode.appendChild(textNode);
              liNode.appendChild(aNode);
              dropdownContainer.appendChild(liNode);

              var tabContainer = document.getElementById("tabContent");
              var tabNode = document.createElement("div");
              tabNode.setAttribute("id", "tab-menu-" + nr);
              tabNode.setAttribute("class", "tab-pane");
              tabNode.setAttribute("data-value", "Inside" + nr);

              var plotNode = document.createElement("div");
              plotNode.setAttribute("id", "plot-" + nr);
              plotNode.setAttribute("class", "shiny-plot-output");
              plotNode.setAttribute("style", "width: 100% ; height: 400px");

              tabNode.appendChild(document.createTextNode("Content Inside " + nr));
              tabNode.appendChild(plotNode);
              tabContainer.appendChild(tabNode);

              Shiny.bindAll();
            }
          );
          Shiny.addCustomMessageHandler("deleteTab",
            function(nr){
              var dropmenuElement = document.getElementById("dropdown-element-" + nr);
              dropmenuElement.parentNode.removeChild(dropmenuElement);

              var tabElement = document.getElementById("tab-menu-" + nr);
              tabElement.parentNode.removeChild(tabElement);
            }
          );
        '),
        tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation", 
          tags$div(class = "container", 
            tags$div(class = "navbar-header", 
              tags$span(class = "navbar-brand", "Nav")
            ),
            tags$ul(class = "nav navbar-nav",
              tags$li( 
                tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
              ),
              tags$li( 
                tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
              ),
              tags$li(class = "dropdown",
                tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
                tags$ul(id = "dropdown-menu", class = "dropdown-menu")
              )
            )
          )
        ),
        tags$div(class = "container-fluid", 
          tags$div(class = "tab-content", id = "tabContent", 
            tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1", 
              numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 0, step = 1), 
              numericInput("number", label = "Panel to add Output-Element to",  value = 0, step = 1),
              actionButton("button", label = "Add Output-Element")
            ),
            tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2")
          )
        )
      )
    ), 

    server = function(input, output, session){

      allOpenTabs <- NULL

      observeEvent(input$insidepanels, {
        if(!is.na(input$insidepanels)){
          localList <- 0:input$insidepanels

          lapply(setdiff(localList, allOpenTabs), function(x){
            session$sendCustomMessage(type = "createTab", message = x)
          })

          lapply(setdiff(allOpenTabs, localList), function(x){
            session$sendCustomMessage(type = "deleteTab", message = x)
          })

          allOpenTabs <<- localList
        }
      })

      observeEvent(input$button, {
        output[[paste0("plot-", input$number)]] <- renderPlot({
          hist(rnorm(1000))
        })
      })
    }
  ), launch.browser = TRUE
)

它基本上是“手动”添加 HTML 元素并将它们链接到 Shiny 的监听器。