CODEWITHSUNDEEP
rshiny
K. Rohde
K. Rohde

Reputation: 9686

Navbar/Tabset with reactive Panel number but NOT rendering everything

This question might seem to be a duplicate, but let me explain why it's not.

I want to create a shiny navbarPage that has fixed elements and a reactive number of tabPanels, that reacts to other input elements. There are many questions about how to create reactive tabsetPanels/navbarPages but they mostly aim for what it has to look like. The most common answer (and the answer i don't seek) is to render the whole navbarPage with updated set of tabPanels. I am aware of that concept and I used it in the code below.

Here is what I want my app to look like:

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))))

      })
    }
  )
)

As you might have seen, it takes a lot of effort to store your input values if they are inside other panels and will be re-rendered = reset all the time. I find this solution to be illegible and slow, because of unnecessary rendering. It also interrupts the user who is clicking through values of input$insidepanels.

What I want the app to be like is that the Outside Panels are fixed and dont re-render. The main problem is that inside shiny, navbarPage on rendering distributes HTML elements to two different locations. Inside the navigation panel and to the body as tab content. That means a-posteori added elements will not be properly embedded.

So far, I have tried to create the navbarPage with custom tags and have dynamic output alter only parts of it. That works pretty well with the navigation panel, but not with tab contents. The reason is that all tabs (their div containers) are listed one after another and as soon as I want to inject multiple at once, I am offthrown by htmlOutput, since it (seemingly) has to have a container and cannot just deliver plain HTML. Thus, all custom tabs are not recongnized properly.

Here my code so far:

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)))})
        )
      })
    }
  )
)

Note: I also tried to create HTML with JavaScript-Chunks that is triggered from inside server. This works for simple tab content, but I want my tabPanels to still have shiny output elements. I don't see how I can fit that in with JavaScript. That is why I included the plotOutput content in my code.

Thanks to anybody who can help solve this issue!

Upvotes: 4

Views: 1229

Answers (1)

K. Rohde
K. Rohde

Reputation: 9686

Finally came up with an own answer. I hope this can be a useful reference to others who try to understand shiny reactiveness. The answer is JavaScript for custom elements (rebuilding standard shiny elements) and using Shiny.unbindAll() / Shiny.bindAll() to achieve the reactivity.

Code:

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
)

It is basically adding the HTML Elements "by hand" and linking them to shiny listeners.

Upvotes: 4

Related Questions