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

我想创建一个具有固定元素的闪亮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抛弃了,因为它(似乎)必须有一个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-Chunk创建HTML。这适用于简单的选项卡内容,但是我希望我的tabPanels仍然具有闪亮的输出元素。我看不到如何在JavaScript中适应它。这就是为什么我在代码中包含plotOutput内容的原因。

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

最佳答案

最后想出了一个自己的答案。我希望这可以为其他尝试了解闪亮反应性的人提供有用的参考。答案是使用JavaScript来定制元素(重建标准的闪亮元素)并使用Shiny.unbindAll() / Shiny.bindAll()来实现反应性。

码:

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

关于r - Navbar/Tabset具有反应性面板编号,但不呈现所有内容,我们在Stack Overflow上找到一个类似的问题:https://stackoverflow.com/questions/36012995/

10-11 19:41