2016-03-15 17 views
3

這個問題似乎是重複的,但讓我解釋它爲什麼不是。Navbar/Tabset與反應面板號碼,但沒有呈現所有內容

我想創建一個閃亮的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元素到兩個不同的位置。在導航面板內部以及作爲標籤內容的正文。這意味着添加了posteori的元素將不會被正確嵌入。

到目前爲止,我試圖創建帶有自定義標籤的navbarPage,並且動態輸出只改變其中的一部分。這對導航面板非常有效,但與選項卡內容無關。原因是所有標籤(他們的div容器)都是一個接一個地列出來的,一旦我想一次注入多個標籤,我就排除在htmlOutput之外,因爲它(看起來)必須有 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的HTML大塊。這適用於簡單的標籤內容,我希望我的tabPanels仍然有閃亮的輸出元素。我沒有看到如何使用JavaScript來適應這一點。這就是爲什麼我在我的代碼中包含plotOutput內容的原因。

感謝任何人誰可以幫助解決這個問題!

回答

3

終於想出了一個自己的答案。 我希望這可以成爲其他人嘗試理解光鮮反應性的有用參考。答案是用於自定義元素的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元素「手動」,並將其鏈接到閃亮的聽衆。