Dynamic tabs and checkbox group in R shiny with renderUI

Question

I am trying to make a dynamic UI in which some tabPanel and checkboxGroup are created dynamically depending on the data.

Below an example data frame:

df <- data.frame(
  "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
  "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
  "Value" = seq(1,10, length.out=5),
  stringsAsFactors = F
)

df
    Group   Name  Value
1 Group A    Bob   1.00
2 Group B   Paul   3.25
3 Group A  Peter   5.50
4 Group A   Emma   7.75
5 Group B   Jhon  10.00

I managed to create two tabPanel called "Group A" and "Group B" according to the unique values in column "Group" of my data frame. I can also create a checkboxGroupInput based on the unique values of column "Name" for each group.

However, I don't understand where to place the usual server block to output a table subsetted per Group and the values checked in the box. None of the similar discussions I saw can help with this particular situation.

See my attempt below:

library(shiny)
library(DT)

# UI
ui <- fluidPage(
  mainPanel(
      uiOutput('mytabs')
  )
)

# SERVER
server <- function(input, output, session) {

  output$mytabs <- renderUI({
    Tabs_titles = unique(df$Group)

    do.call(tabsetPanel,
            lapply(Tabs_titles,
                    function(x){
                      tabPanel(title = x,
                               checkboxGroupInput(inputId = "checkboxID",
                                                  label = "My Checkbox",
                                                  choices = df %>% subset(Group == x) %>% pull(Name),
                                                  selected = df %>% subset(Group == x) %>% pull(Name)
                               ),
                               DT::dataTableOutput("my_Table")
                      )
                    }
            )
    )
    })

  ### Where to place this 'usual' server code below? ###

  # Observe box values when changed
  box_values = reactive({input$checkboxID})

  # Output table
  output$my_Table <- DT::renderDataTable({
    subset(df, Group = <cannot catch the variable 'x' from above>, Name = box_values)
  })
}

shinyApp(ui, server)

Any explanation would be greatly appreciated.

Answer 1

I think you're making the problem more complicated than it needs to be, and as a result have created a couple of insoluble problems for yourself. Your first problem is that you are creating several checkboxGroupInputs with the same ID. This means that Shiny isn't going to be able to distinguish them from one another. And, as you've discovered, neither can you!

As I understand it, you want to display the data from a subset of the people in your data. The first filter is done by selecting the group in a selectInput. Then the required names are selected using checkboxGroupInput. The options available to the checkboxGroupInput depend on the group selected in the selectInput.

I think you can do all of that without having to resort to uiOutput and renderUI. The key is the updateCheckboxGroupInput (which needs the additional argument session in the definition of your server function). I think this does what you want:

library(shiny)
library(tidyverse)

ui <- fluidPage(
   titlePanel("Dynamic checkboxGroupInput"),
   sidebarLayout(
      sidebarPanel(
        selectInput("group", "Group", choices=c("Group A", "Group B")),
        checkboxGroupInput("name", "Name", choices=c())
      ),
      mainPanel(
        tableOutput("data")
      )
   )
)

server <- function(input, output, session) {
  df <- data.frame(
    "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
    "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
    "Value" = seq(1,10, length.out=5),
    stringsAsFactors = F
  )

  observeEvent(input$group, {
    updateCheckboxGroupInput(
      session, 
      "name",
      choices=df %>% subset(Group == input$group) %>% pull(Name),
      selected = df %>% subset(Group == input$group) %>% pull(Name)
    )
  })

  output$data <- renderTable({
    req(input$group, input$name)
    df %>% filter(Group == input$group, Name %in% input$name)
  })
}

shinyApp(ui = ui, server = server)

Answer 2

Here's a partial solution, following on from your comment to my first suggestion. The code below provides a dynamic checkboxGroupInput together with set of tabPanels whose labels and number updates with changes to the checkboxgroupInput. Unfortunately, I've not yet been able to put the filtered dataset on the tabPanels. As soon as I put any output on the tabPanels, the checkboxGroupInput disappears. Strangely, putting inputs on the tabPanel doesn't cause any problems.

I'm posting this partial solution in the hope that someone else can see what's wrong and provide you with a complete answer before I get the chance to look at it again.

My solution uses nested modules. I could probably get away without the nesting, but I think the nesting keeps the code clean.

The first module controls the tabPanels. It reacts to changes to input$group in the main server. It updates the checkboxgroupInput's choice list, creates a tabPanel and an instance of the data table module for each row in the filtered dataset.

Here's the code, more comments afterwards.

library(shiny)
library(tidyverse)

df <- data.frame(
  "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
  "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
  "Value" = seq(1,10, length.out=5),
  stringsAsFactors = F
)

# dataTable module definition
dataTableUI <- function(id) {
  ns <- NS("id")

  paste0("Content for ", stringr::str_split(id, fixed("-"))[[1]][2])
}

dataTableController <- function(input, output, session, group, nameList) {
  ns <- session$ns

  rv <- reactive({
  })

  return(rv)
}

# tabPanel module definition
tabPanelsUI <- function(id) {
  ns <- NS(id)

  tagList(
    checkboxGroupInput(ns("names"), label="Select names:", choices=c(), selected=c()),
    uiOutput(ns("tabPanel"))
  )
}

tabPanelsController <- function(input, output, session, selector) {
  ns <- session$ns

  output$tabPanel <- renderUI({
    req(v$filteredData)
    tabList <- lapply(v$filteredData$Name, function(x) tabPanel(title=x, dataTableUI(ns(x))))
    do.call(tabsetPanel, tabList)
  })

  v <- reactiveValues(
    filteredData=NA
  )

  observe({
    req(selector())
    v$filteredData <- df %>% subset(Group == selector())
    lapply(
      v$filteredData$Name, 
      function(x) {
        callModule(dataTableController, x, group=reactive({selector()}), nameList=reactive({input$names}))
      }
    )
  })

  observeEvent(v$filteredData, {
    nameList <- v$filteredData %>% pull(Name)
    updateCheckboxGroupInput(session, "names", choices=nameList, selected=nameList)
  })

  rv <- reactive({
  })

  return(rv)
}

# Main UI
ui <- fluidPage(
  titlePanel("Dynamic checkboxGroupInput"),
  sidebarLayout(
    sidebarPanel(
      selectInput("group", "Group", choices=c("Group A", "Group B"))
    ),
    mainPanel(
      tabPanelsUI("tabs")
    )
  )
)

server <- function(input, output, session) {
  selectedNames <- callModule(tabPanelsController, "tabs", reactive({input$group}))
}

shinyApp(ui = ui, server = server)

You will see that the data panel module simply prints out a static text:

dataTableUI <- function(id) {
  ns <- NS("id")

  paste0("Content for ", stringr::str_split(id, fixed("-"))[[1]][2])
}

reflecting the name of the person to which the tabPanel relates. It should be a simple matter to replace the static text with a datatable

dataTableUI <- function(id) {
  ns <- NS("id")

  DT::dataTableOutput(ns("my_Table"))
}

and make the appropriate changes to the server function. But when I do, the checkboxGroupInput disappears. I can't figure out why.

Both the tabPanel and data table modules currently return NULL. That means that

  rv <- reactive({
  })

  return(rv)

is strictly unnecessary in both cases, but I've put it there as a placeholder should your full solution need it.

The modularisation solves the problem of letting the main server function know which data table it needs to modify by removing the need for it to do so. The module would handle all its own updates internally (once the data table is displayed!). If the main server needs to know the result of the update (or anything else about what the module is doing, then the main server can monitor the module's return value.

Answer 3

library(shiny)

df <- data.frame(
  "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
  "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
  "Value" = seq(1,10, length.out=5),
  stringsAsFactors = F
)

# UI
ui <- fluidPage(
  mainPanel(
      uiOutput('mytabs')
  )
)

# SERVER
server <- function(input, output) {

  Tabs_titles = unique(df$Group)

  output$mytabs <- renderUI({
    myTabs <- lapply(Tabs_titles,
                    function(x){
                      tabPanel(title = x,
                               checkboxGroupInput(inputId = paste0("checkboxID_", x),
                                                  label = "My Checkbox",
                                                  choices = df %>% subset(Group == x) %>% pull(Name),
                                                  selected = df %>% subset(Group == x) %>% pull(Name)
                               ),
                               tableOutput(paste0("my_Table_", x))
                      )
                    }
    )

    do.call(tabsetPanel, myTabs)

  })

  observe(
    lapply(Tabs_titles,
           function(x){
             checked_names <- reactive({input[[paste0("checkboxID_", x)]]})

             output[[paste0("my_Table_", x)]] <-renderTable({
               df %>%
               subset(Group == x & Name %in% checked_names())
             })
           }
    )
  )
}


shinyApp(ui, server)