Navbar / Tabset具有反应性面板编号但不渲染所有内容

时间：2016-03-15 13:40:58

标签： r shiny

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

我想创建一个闪亮的navbarPage，它具有固定元素和无效数tabPanels，可以对其他输入元素做出反应。有很多关于如何创建被动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的值的用户。

我希望应用好像是外部面板是固定的，不会重新渲染。主要问题是内部闪亮，渲染时navbarPage 将HTML元素分发到两个不同的位置。在导航面板内部和身体作为标签内容。这意味着a-posteori添加的元素将无法正确嵌入。

到目前为止，我尝试使用自定义标记创建navbarPage，并且只更改动态输出的部分内容。这对导航面板非常有效，但与标签内容无关。原因是所有标签（它们的div容器）都是一个接一个地列出，一旦我想一次注入多个，我就被htmlOutput抛弃了，因为它（貌似）必须拥有< / strong> a 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仍然具有闪亮的输出元素。我不知道我是如何适应JavaScript的。这就是我在代码中添加plotOutput内容的原因。

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

1 个答案:

答案 0 :(得分：3)

最后得出了一个自己的答案。 我希望这对于那些试图了解闪亮反应性的人来说是一个有用的参考。答案是自定义元素的JavaScript（重建标准闪亮元素）并使用Shiny.unbindAll() / Shiny.bindAll()来实现反应。< / p>

代码：

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元素并将它们链接到闪亮的侦听器。

相关问题
最新问题