in R, how to create multilevel radioGroupButtons, as each level depends choiceNames depend on the previous level input?

shiny
1

I am trying to create shinyapp in which the first radioGroupButtons will automatically update the second level of radioGroupButtons and then the 3rd level, eventually each level will filter the datatable

used code

library(shiny)
library(reshape2)
library(dplyr)
library(shinyWidgets)

hotdrinks<-list("tea","green tea") 
juices<-list("orange","mango") 
energydrinks<-list("powerhorse","redbull") 
drinks<-list("hotdrinks"=hotdrinks,"juices"=juices,"energydrinks"=energydrinks) 

biscuits<-list("loacker","tuc") 
choc<-list("aftereight","lindt") 
gum<-list("trident","clortes") 
sweets<-list("gum"=gum,"biscuits"=biscuits,"choc"=choc)

all_products<-list("sweets"=sweets,"drinks"=drinks)
mt<-melt(all_products)
mt2<-mt%>%mutate("Price"=c(23,34,23,23,54,32,45,23,12,56,76,43),
             "Quantity"=c(10,20,26,22,51,52,45,23,12,56,76,43))

t1<-mt2[,c(4,3,1,5,6)]
t1
colnames(t1)<-c("CAT","PN","SP","Quantity","Price")

t2<-list(unique(t1$CAT))
t2

all <- list("drinks"=drinks, "sweets"=sweets)

app.R

library(shiny)
library(shinyWidgets)
library(dplyr)


 ui <- fluidPage(titlePanel("TEST"),
            mainPanel(
              fluidRow(
                column( width = 9,  align = "center",
                  radioGroupButtons(inputId = "item",
                    label = "",  status = "success",
                    size = "lg",  direction = "horizontal", justified = FALSE,
                    width = "100%",individual = TRUE,
                    checkIcon = list(
                      "yes" = icon("check"),
                      "yes" = icon("check")
                    ), 
                    choiceNames = as.list(unique(t1$CAT)),
                    choiceValues = as.list(1:length(unique(t1$CAT)))
                  )
                )
              ),
              fluidRow(
                column( width = 9,  align = "center",
                        radioGroupButtons(inputId = "item2",
                                          label = "",  status = "success",
                                          size = "lg",  direction = "horizontal", justified = FALSE,
                                          width = "100%",individual = TRUE,
                                          checkIcon = list(
                                            "yes" = icon("check"),
                                            "yes" = icon("check"),
                                            "yes" = icon("check"),
                                            "yes" = icon("check")
                                          ), 
                                          choiceNames = NULL,
                                          choiceValues = NULL
                 ))),
              fluidRow(
                column( width = 9,  align = "center",
                        radioGroupButtons(inputId = "item3",
                                          label = "",  status = "success",
                                          size = "lg",  direction = "horizontal", justified = FALSE,
                                          width = "100%",individual = TRUE,
                                          checkIcon = list(
                                            "yes" = icon("check"),
                                            "yes" = icon("check"),
                                            "yes" = icon("check"),
                                            "yes" = icon("check")
                                          ), 
                                          choiceNames = NULL,
                                          choiceValues = NULL
                        ))),
              
              fluidRow(
                column( width = 9,
                wellPanel(dataTableOutput("out"))
              ))))

 server <- function(input, output) {
   observeEvent({
     print(input$item)
         oi<-t1%>%filter(CAT==input$item)%>%select(PN)
         updateRadioGroupButtons(session, inputId="item2", 
                        choiceNames =unique(oi),
                        choiceValues = as.list(1:length(unique(t1$PN))))

             ox<-t1%>%filter(CAT==input$item2)%>%select(SP)
             updateRadioGroupButtons(session, inputId="item3", 
                        choiceNames =unique(ox),
                        choiceValues = as.list(1:length(unique(t1$SP))))

             })
   out_tbl <- reactive({
     x <- ox[,c("Quantity","Price")]
     })
   output$out <- renderDataTable({
     out_tbl()
     },options = list(pageLength = 5)
   )
   }

 shinyApp(ui=ui,server=server)

the desired result is like this image

I used this as reference

2

You can create a chain of reactivity.

library(shiny)
library(reshape2)
library(dplyr)
library(shinyWidgets)
library(DT)

hotdrinks <- list("tea", "green tea")
juices <- list("orange", "mango")
energydrinks <- list("powerhorse", "redbull")
drinks <- list("hotdrinks" = hotdrinks, "juices" = juices, "energydrinks" = energydrinks)

biscuits <- list("loacker", "tuc")
choc <- list("aftereight", "lindt")
gum <- list("trident", "clortes")
sweets <- list("gum" = gum, "biscuits" = biscuits, "choc" = choc)

all_products <- list("sweets" = sweets, "drinks" = drinks)
mt <- melt(all_products)
mt2 <- mt %>% mutate(
  "Price" = c(23, 34, 23, 23, 54, 32, 45, 23, 12, 56, 76, 43),
  "Quantity" = c(10, 20, 26, 22, 51, 52, 45, 23, 12, 56, 76, 43)
)

t1 <- mt2[, c(4, 3, 1, 5, 6)]
colnames(t1) <- c("CAT", "PN", "SP", "Quantity", "Price")
t1 <- t1 %>% mutate(SP = as.character(SP)) # avoid factors

ui <- fluidPage(
  titlePanel("TEST"),
  mainPanel(
    fluidRow(
      column(
        width = 9, align = "center",
        radioGroupButtons(
          inputId = "item",
          label = "", status = "success",
          size = "lg", direction = "horizontal", justified = FALSE,
          width = "100%", individual = TRUE,
          checkIcon = list(
            "yes" = icon("check"),
            "yes" = icon("check")
          ),
          choices = as.list(unique(t1$CAT))
        )
      )
    ),
    fluidRow(
      column(
        width = 9, align = "center",
        radioGroupButtons(
          inputId = "item2",
          label = "", status = "success",
          size = "lg", direction = "horizontal", justified = FALSE,
          width = "100%", individual = TRUE,
          checkIcon = list(
            "yes" = icon("check"),
            "yes" = icon("check"),
            "yes" = icon("check"),
            "yes" = icon("check")
          ),
          choices = as.list(unique(t1$PN))
        )
      )
    ),
    fluidRow(
      column(
        width = 9, align = "center",
        radioGroupButtons(
          inputId = "item3",
          label = "", status = "success",
          size = "lg", direction = "horizontal", justified = FALSE,
          width = "100%", individual = TRUE,
          checkIcon = list(
            "yes" = icon("check"),
            "yes" = icon("check"),
            "yes" = icon("check"),
            "yes" = icon("check")
          ),
          choices = as.list(unique(t1$SP))
        )
      )
    ),

    fluidRow(
      column(
        width = 9,
        wellPanel(dataTableOutput("out"))
      )
    )
  )
)

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

  observeEvent(input$item, {
    cat("item = ", input$item, "\n")
    oi <- t1 %>%
      filter(CAT == input$item)
    updateRadioGroupButtons(session,
      inputId = "item2",
      choices = as.list(unique(oi$PN))
    )
  })

  observeEvent(input$item2, {
  	cat("item2 = ", input$item2, "\n")
  	ox <- t1 %>%
      filter(CAT == input$item, PN == input$item2)
    updateRadioGroupButtons(session,
      inputId = "item3",
      choices = as.list(unique(ox$SP))
    )
  })

  output$out <- DT::renderDataTable(
	  	t1 %>%
	  		filter(CAT == input$item,  PN == input$item2, SP == input$item3) %>%
	  		print()
  		,
	  	options = list(pageLength = 5)
	  	)

}

shinyApp(ui = ui, server = server)
3

thanks for your response it's very helpful and works like charm

1 Like
4

This topic was automatically closed 54 days after the last reply. New replies are no longer allowed.