rdatatableshinyshinywidgets
in R, how to create multilevel radioGroupButtons, as each level depends choiceNames depend on the previous level input?
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 
I used this as reference
UPDATED CODE----------------
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")
mtx<-t1
df<-mtx
library(shiny)
library(shinyWidgets)
library(dplyr)
# make a data frame for choices
buttons_ui <- function(id) {
ns <- NS(id)
uiOutput(ns("buttons"))
}
buttons_server <- function(input, output, session, button_names, button_status) {
output$buttons <- renderUI({
ns <- session$ns
radioGroupButtons(
inputId = ns("level"),
label = "",
status = button_status(),
size = "lg",
direction = "horizontal",
justified = TRUE,
width = "100%",
individual = TRUE,
checkIcon = setNames(
object = lapply(button_names(), function(x)
icon("check")),
nm = rep("yes", length(button_names()))
),
choiceNames = button_names(),
choiceValues = button_names()
)
})
selected <- reactive({
input$level
})
return(selected)
}
ui <- fluidPage(mainPanel(fluidRow(
column(
width =9,
align = "center",
buttons_ui(id = "level1"),
buttons_ui(id = "level2"),
buttons_ui(id = "level3"),
tags$hr(),
dataTableOutput("tbl")
)
)))
server <- function(input, output, session) {
selected1 <-
callModule(module = buttons_server,
id = "level1",
button_names = reactive({ unique(mtx$CAT) }),
button_status = reactive({ "success"}) )
selected2 <-
callModule(
module = buttons_server,
id = "level2",
button_names = reactive({ mtx %>% filter(CAT == selected1() ) %>% pull(PN) %>% unique }),
button_status = reactive({ "primary" })
)
selected3 <-
callModule(
module = buttons_server,
id = "level3",
button_names = reactive({ mtx %>% filter(CAT == selected1(),PN==selected2() )%>%pull(SP) %>% unique }),
button_status = reactive({ "warning" })
)
# add more calls to the module server as necessary
output$tbl <- renderDataTable({
df %>% filter(CAT == req(selected1()), PN == req(selected2()),SP == req(selected3()))
})
}
shinyApp(ui, server)
Solution
You can update choices dynamically in observeEvents, here's a demo:
# Data
dat <- data.frame(
stringsAsFactors=FALSE,
L3 = c(1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L),
L2 = c("gum", "gum", "biscuits", "biscuits", "choc", "choc",
"hotdrinks", "hotdrinks", "juices", "juices", "energydrinks",
"energydrinks"),
L1 = c("sweets", "sweets", "sweets", "sweets", "sweets", "sweets",
"drinks", "drinks", "drinks", "drinks", "drinks", "drinks"),
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),
value = c("trident", "clortes", "loacker", "tuc",
"aftereight", "lindt", "tea", "green tea", "orange",
"mango", "powerhorse", "redbull")
)
# Packages
library(dplyr)
library(shiny)
library(shinyWidgets)
# App
ui <- fluidPage(
tags$br(),
# Custom CSS
tags$style(
".btn-group {padding: 5px 10px 5px 10px;}",
"#l1 .btn {background-color: #5b9bd5; color: #FFF;}",
"#l2 .btn {background-color: #ed7d31; color: #FFF;}",
"#value .btn {background-color: #ffd966; color: #FFF;}"
),
tags$br(),
fluidRow(
column(
width = 4,
offset = 4,
radioGroupButtons(
inputId = "l1",
label = NULL,
choices = unique(dat$L1),
justified = TRUE,
checkIcon = list(
"yes" = icon("check")
),
individual = TRUE
),
radioGroupButtons(
inputId = "l2",
label = NULL,
choices = unique(dat$L2),
justified = TRUE,
checkIcon = list(
"yes" = icon("check")
),
individual = TRUE
),
radioGroupButtons(
inputId = "value",
label = NULL,
choices = unique(dat$value),
justified = TRUE,
checkIcon = list(
"yes" = icon("check")
),
individual = TRUE
),
tags$br(),
DT::DTOutput("table")
)
)
)
server <- function(input, output, session) {
observeEvent(input$l1, {
updateRadioGroupButtons(
session = session,
inputId = "l2",
choices = dat %>%
filter(L1 == input$l1) %>%
pull(L2) %>%
unique,
checkIcon = list(
"yes" = icon("check")
)
)
})
observeEvent(input$l2, {
updateRadioGroupButtons(
session = session,
inputId = "value",
choices = dat %>%
filter(L1 == input$l1, L2 == input$l2) %>%
pull(value) %>%
unique,
checkIcon = list(
"yes" = icon("check")
)
)
})
output$table <- DT::renderDataTable({
dat %>%
filter(L1 == input$l1,
L2 == input$l2,
value == input$value)
})
}
shinyApp(ui, server)
Result lokk like:
- Determining as to whether the function call is stored in a variable
- How to increase resolution of ggplots without using ggsave in officer?
- How to apply a function within a for loop for a set of existing variables of a predifined structure in R?
- How to change the number of decimal places of the mean in a data frame
- Forestplot in R superscript in tabletext matrix
- Converting colnames from character to numeric when extracting them from a dataframe
- With different seeds can Random States repeat in R
- How to Stack Painted Phylogenetic Trees in R Like ggdensitree but with Colored Regimes
- How to import/rbind multiple files with different indexed columns?
- Pivot wider in R return list instead of data frame
- R workspace doesn't load anything in Visual Studio Code
- Search for multiple occurrences of substring within string
- Looking for faster way to implement logSumExp across multidimensional array
- How to get \bm{} to work in an R markdown (to HTML) file?
- Leaving a space in geom_bar with stat='bin', position='dodge' and zeroes
- Where are the 1st stage F statistics located in a "fixest" object?
- Collapsing data per family
- How to set default template for new ".R" files in rstudio
- Adding two-way fixed effects for zero inflated Poisson model
- How to Move R Code and Output to the Right in a Quarto PDF Document?
- What does runif() mean when used inside if_else()?
- Remove columns from dataframe where ALL values are NA
- How to pass unquoted argument to filter() within user defined function
- Optimizing the distribution of random integers across data frame rows
- R dplyr conditional join with "join_by" not working
- How to hide a reappearing hover label for a trace in R-Plotly within Shiny?
- Estimating non-monotonic bi-exponential curve fit
- Problem minimising a function using L-BFGS-B method in R?
- trying to obtain TRUE/FALSE response to the question "is argument name x valid for function y?"
- Retrieve whole lyrics from URL