How to render Checkboxes in a Tab Panel with render UI and also add a select all button in shiny dashboard?

shiny

#1

I am new to shiny and was wondering if the below is possible, i have not found any examples online via stackoverflow or any github issues either.

I have the following shiny dashboard seen below - i have 2 dataframes that are built into the app - for now these are dataframes, one called nodes_data_1 and one called edges_data_1.

the reason i want it in a renderUI is because i want it to use the reactive node_data_reactive() which is just a reactive version of nodes_data_1 - as I would probably be updating this nodes_data_1 dataframe therefore the reactive will update and then the tab panels and checkboxes will too.

The dataframe called nodes_data_1 is the one of importance here - I want a way so that when a user clicks in on the sidebar radio button "Food Type" -

Then tab panels will be created based on the unique values in the nodes_data_1$Food column - which has 5 values - so there would be 5 separate tab panels all sitting within this large tab box.

Then after doing this, within each tab panel, checkboxes would be rendered which correspond to the values in the nodes_data_1$Product_name which sit in the nodes_data_1$Food category -

So for example the app will look something like this:

Here you can see in the dashboard - that when i am on the "Edibles" Tab Panel which i have highlighted in yellow just to be clear - the available options to select are those in the data that are in the "Edibles" category for Food

In addition to getting all of the individual checkboxes - i also want a way of finding how to actually create a singular checkbox on each of the tab Panels, that is called "select all" and when this is checked, meaning its TRUE (or radio button etc) then it will automatically "check" those boxes in the associated tab Panel and not the other tab Panels, so here i am on the edibles panel and when i have checked the box select all, then all of those individual checkboxes in this tab panel have been selected and not the other checkboxes in the other tab panels:

so i would like it to have something like this as well:

Please see the following code below - i do not know how to create such a thing - any ideas are welcome - new to shiny so hope this is possible!

library(shiny)
library(shinydashboard) 
library(tidyverse)
library(magrittr)

header <- dashboardHeader(
  title = "My Dashboard",
  titleWidth = 500
)

siderbar <- dashboardSidebar(
  
  sidebarMenu(
    
    # Add buttons to choose the way you want to select your data
    radioButtons("select_by", "Select by:",
                 c("Food Type" = "Food",
                   "Gym Type" = "Gym",
                   "TV show" = "TV"))
    
  )   

)

body <- dashboardBody(
  
  fluidRow(
      uiOutput("Output_panel")
        
  ), 
   tabBox(title = "RESULTS", width = 12, 
      tabPanel("Visualisation", 
                 width = 12, 
                height = 800
              )
          
    
    )
  ) 

ui <- dashboardPage(header, siderbar, body, skin = "purple")


server <- function(input, output, session) {
  
nodes_data_1 <- data.frame(id = 1:15, 
                           Food = as.character(c("Edibles", "Fried", "Home Cooked", "packaged", "vending machine")), 
                           Product_name = as.character(c("Bacon", "Cheese", "eggs", "chips", "beans", "oast", "oats and beans", "fried beans", "chickpeas", "broad beans", "garbanzo", "oat bars", "dog meat", "cat food", "horse meat")),
                           Gym_type = as.character(paste("Gym", 1:15)), TV = 
                             sample(LETTERS[1:3], 15, replace = TRUE))

# build a edges dataframe

edges_data_1 <- data.frame(from = trunc(runif(15)*(15-1))+1,
                    to = trunc(runif(15)*(15-1))+1)

  
# create reactive of nodes 

  nodes_data_reactive <- reactive({
   nodes_data_1
 
  
  }) # end of reactive
  # create reacive of edges 
 
  edges_data_reactive <- reactive({
     
  edges_data_1
   
  }) # end of reactive
   


  # The output panel differs depending on the how the data is selected 
  # so it needs to be in the server section, not the UI section and created
  # with renderUI as it is reactive
  output$Output_panel <- renderUI({
  
    # When selecting by workstream and issues:
    if(input$select_by == "Food") {
    
      box(title = "Output PANEL", 
          collapsible = TRUE, 
          width = 12
          
               # something to do here - any ideas?
                             
                             ) # end of Tab box
             

      
    # When selecting by the strength of links connected to the issues:  
    } else if(input$select_by == "Gym") {
       box(title = "Output PANEL", collapsible = TRUE, width = 12,
          checkboxGroupInput("select_gyms", "Select gyms you want to display", choices = unique(nodes_data_reactive()$Gym_type)
                             ,
                             selected = NULL,
                             inline = FALSE
          )# end of checkboxGroupInput
      ) # end of box  
          
    } else if(input$select_by == "TV") {
       box(title = "Output PANEL", collapsible = TRUE, width = 12,
          checkboxGroupInput("select_tvs", 
                             "Select the tv shows you want to see",choices = sort(unique(nodes_data_reactive()$TV)),
                             selected = NULL,
                             inline = FALSE
          )# end of checkboxGroupInput
      ) # end of box  
      
  }  # end of else if
    
  }) # end of renderUI
  

    
} # end of server


# Run the application 
shinyApp(ui = ui, server = server)

I do believe this is possible in shiny so please do drop me any hints or tips or advise!


#2

Please check out these shiny functions for piece together your app:

The tabsets could be done within a renderUI, but I would try to get them as raw elements within the UI definition.


#3

Hi Barret - I actually looked at those and came up with this code:

library(shiny)
library(shinydashboard) 
library(tidyverse)
library(magrittr)

header <- dashboardHeader(
  title = "My Dashboard",
  titleWidth = 500
)

siderbar <- dashboardSidebar(
  
  sidebarMenu(
    
    # Add buttons to choose the way you want to select your data
    radioButtons("select_by", "Select by:",
                 c("Food Type" = "Food",
                   "Gym Type" = "Gym",
                   "TV show" = "TV"))
    
  )   
  
)

body <- dashboardBody(
  
  fluidRow(
    uiOutput("Output_panel")
    
  ), 
  tabBox(title = "RESULTS", width = 12, 
         tabPanel("Visualisation", 
                  width = 12, 
                  height = 800
         )
         
         
  )
) 

ui <- dashboardPage(header, siderbar, body, skin = "purple")


server <- function(input, output, session){
  
  nodes_data_1 <- data.frame(id = 1:15, 
                             Food = as.character(c("Edibles", "Fried", "Home Cooked", "packaged", "vending machine")), 
                             Product_name = as.character(c("Bacon", "Cheese", "eggs", "chips", "beans", "oast", "oats and beans", "fried beans", "chickpeas", "broad beans", "garbanzo", "oat bars", "dog meat", "cat food", "horse meat")),
                             Price = c(1:15), TV = 
                               sample(LETTERS[1:3], 15, replace = TRUE))
  
  # build a edges dataframe
  
  edges_data_1 <- data.frame(from = trunc(runif(15)*(15-1))+1,
                             to = trunc(runif(15)*(15-1))+1)
  
  
  # create reactive of nodes 
  
  nodes_data_reactive <- reactive({
    nodes_data_1
    
    
  }) # end of reactive
  # create reacive of edges 
  
  edges_data_reactive <- reactive({
    
    edges_data_1
    
  }) # end of reactive"che
  
  
  
  # The output panel differs depending on the how the data is selected 
  # so it needs to be in the server section, not the UI section and created
  # with renderUI as it is reactive
  output$Output_panel <- renderUI({
    
    # When selecting by workstream and issues:
    if(input$select_by == "Food") {
      
      box(title = "Output PANEL", 
          collapsible = TRUE, 
          width = 12,
          
          do.call(tabsetPanel, c(id='t',lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
            food <- unique(sort(as.character(nodes_data_reactive()$Food)))
            
            tabPanel(food[i], 
                     checkboxGroupInput(paste0("checkboxfood_", i), 
                                        label = "Random Stuff",
                                        choiceNames = unique(nodes_data_reactive()$Product_name[
                                          nodes_data_reactive()$Food == unique(nodes_data_reactive()$food)[i]]), choiceValues = unique(nodes_data_reactive()$Price[
                                            nodes_data_reactive()$Food == unique(nodes_data_reactive()$food)[i]])
                                       
                                        
                                        
                                        
                                        
                                        ),
                     checkboxInput(paste0("all_", i), "Select all", value = FALSE)
            )
          })))
          
      ) # end of Tab box
      
      
      
      # When selecting by the strength of links connected to the issues:  
    } else if(input$select_by == "Gym") {
      box(title = "Output PANEL", collapsible = TRUE, width = 12
      ) # end of box  
      
    } else if(input$select_by == "TV") {
      box(title = "Output PANEL", collapsible = TRUE, width = 12
      ) # end of box  
      
    }  # end of else if
    
  }) # end of renderUI
  
  observe({
    lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
      
      food <- unique(sort(as.character(nodes_data_reactive()$Food)))
      
      product_choices <- nodes_data_reactive() %>% 
        filter(Food == food[i]) %>%
        select(Product_name) %>%
        unlist(use.names = FALSE)
      
      View(product_choices)
      
      if(!is.null(input[[paste0("all_", i)]])){
        if(input[[paste0("all_", i)]] == TRUE) {
          updateCheckboxGroupInput(session,
                                   paste0("checkboxfood_", i), 
                                   label = NULL, 
                                   choices = product_choices,
                                   selected = product_choices)
        } else {
          updateCheckboxGroupInput(session,
                                   paste0("checkboxfood_", i), 
                                   label = NULL, 
                                   choices = product_choices)
        }
      }
      
    })
    
    
  })
  View(product_choices)
} # end of server


# Run the application 
shinyApp(ui = ui, server = server)

How can i ensure that when a user clicks select all on a tab, that the underlying code is actually pulling out the Price columns values and not just the names? as i want to subset it


#4

I changed your last observe statement to the code below. When updating the checkboxes, it will update everything when using choices. To keep the prices as the value and the label as the name, both product prices and product names must be used.

  observe({
    lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
      
      food <- unique(sort(as.character(nodes_data_reactive()$Food)))
      
      product_choices <- nodes_data_reactive() %>% 
        filter(Food == food[i]) %>%
        select(Product_name) %>%
        unlist(use.names = FALSE) %>%
        as.character()

      product_prices <- nodes_data_reactive() %>% 
        filter(Food == food[i]) %>%
        select(Price) %>%
        unlist(use.names = FALSE)
      
      if(!is.null(input[[paste0("all_", i)]])){
        if(input[[paste0("all_", i)]] == TRUE) {
          updateCheckboxGroupInput(session,
                                   paste0("checkboxfood_", i), 
                                   label = NULL, 
                                   choiceNames = product_choices,
                                   choiceValues = product_prices,
                                   selected = product_prices)
        } else {
          updateCheckboxGroupInput(session,
                                   paste0("checkboxfood_", i), 
                                   label = NULL, 
                                   choiceNames = product_choices,
                                   choiceValues = product_prices,
                                   selected = c()
                                 )
        }
      }
      
    })

#5

Thanks Barret! Really cool stuff - never knew this was possible in shiny before!

I am now trying to actually get the actual values which are being selected and turning them into a list, then unlisting them so that i can use these downstream for when i want to create some plots, i have the following code - but alas it does not work - i feel i am close though! Any ideas on what the problem is here?

  
  chosen_items <- reactive({
    
    if(input$select_by == "Food"){
      
      # obtain all of the underlying price values 
      unlist(lapply(1:length(unique(na.omit(nodes_data_reactive()$Food ))), 
                    function(i){
                      
                      eval(parse(text = paste("input$`", unique(na.omit(
                        
                        nodes_data_reactive()$Food
                        
                      ))[i], "`", sep = ""
                      
                      
                      )))
                      
                    } # end of function
                    
                    
                    
                    )) # end of lapply and unlist
      
    }
    
    
    
    
  })

#6

@dataquestions Glad you like it!

No need to call eval on an input object. Asking for input[[KEY]] will work just fine.

Somewhere within your server...

chosen_food <- reactive({
  unlist(lapply(seq_along(unique(nodes_data_reactive()$Food)), function(i) {
    # retrieve checkboxfood_NUMBER value
    input[[paste0("checkboxfood_", i)]]
  }))
})
chosen_food_names <- reactive({
  # turn selected chosen food values into names
  nodes_data_reactive()$Product_name[as.numeric(chosen_food())]
})

#7

@barret, thanks for helping me out here - i would like to ask you a question on this - whenever i change tabs and press select all on a new tab - it disregards what is already selected and instead just outputs what checkboxes have been selected with the "select all" button - is there a way to get the underlying reactive of chosen_food_names() to update properly, when checkboxes are checked and unchecked, across tabs and when select/deselect button is checked across tabs also?

for example - if we take this situation - i have 2 tabs, each has 5 checkboxes, when i am on tab 1 and press select all (5 checkboxes are selected) - when i move to tab 2 and press select all - it does not add those new values to the dataframe - instead it just puts the 5 checkbox values from tab 2 and tab 1 is removed - when i uncheck tab 2 - tab 1 reappears in the dataframe values

it is a odd behaviour any idea why its doing this?


#8

When switching tabs, the renderUI code is called. This completely wipes any existing html from the browser.

Side note... if your data is fixed, I would recommend looking into building out the UI elements rather than doing a renderUI. If your data is actually reactive, renderUI is a great way to handle it, but must handle more complex situations (like setting the previously selected values).

Since we are using renderUI in this example, we need to set the selected values of the check box. When the checkboxes are created, we need to set the value of selected to the previously checked choiceValues values.

I've updated the start of output$Output_panel code below.

  output$Output_panel <- renderUI({

    # When selecting by workstream and issues:
    if(input$select_by == "Food") {

      food <- unique(as.character(nodes_data_reactive()$Food))
      food_panel <- lapply(seq_along(food), function(i) {
        ### filter the data only once
        food_dt <- dplyr::filter(nodes_data_reactive(), Food == food[i])

        ### Use the id, not the price, as the id is unique
        food_ids <- as.character(food_dt$id)
        selected_ids <- food_ids[food_ids %in% isolate({chosen_food()})] ### use isolate, so as to not be reactive to it

        tabPanel(food[i],
          checkboxGroupInput(
            paste0("checkboxfood_", i),
            label = "Random Stuff",
            choiceNames = as.character(food_dt$Product_name), ### for some reason it likes characters, not factors with extra levels
            choiceValues = food_ids,
            selected = selected_ids
          ),
          checkboxInput(
            paste0("all_", i),
            "Select all",
            value = all(food_ids %in% isolate({chosen_food()}))
          )
        )
      })

      box(title = "Output PANEL",
          collapsible = TRUE,
          width = 12,
          do.call(tabsetPanel, c(id = 't', food_panel)),
          "Items: ", renderText(paste0(chosen_food(), collapse = ", ")),
          "Names: ", renderText(paste0(chosen_food_names(), collapse = ", "))

      ) # end of Tab box
    } 
   ### continue the ifelse statements here
}

#9

@barret Cool solution - Thanks for showing me that - looks awesome - however it now has a funny behaviour, whenever you press select all, then un check one of the 3 boxes, then switch tabs and press select all - suddenly all of the 3 checkboxes in the previous tab are now checked - even though you unchecked one

It has a really odd behaviour - i think its because of the original dplyr cleaning - it makes no sense as to why it would be updating 2/3 boxes in one tab to 3/3 boxes when you click "select all" in another tab!

Seems abit odd! any thoughts on this?


#10

@barret - also data is not fixed and i only have the option of using the render UI for the tab panel creation - also if you select a singular checkbox on multiple tab panels - (but not 3) then you press select all - it resets all of the checkboxes to nothing and checks all the boxes for which you are on that tab panel