在R中，如何创建多级radioGroupButtons，因为每个级别都取决于choiceNames取决于前一级别的输入？ [英] in R, how to create multilevel radioGroupButtons, as each level depends choiceNames depend on the previous level input?
本文介绍了在R中，如何创建多级radioGroupButtons，因为每个级别都取决于choiceNames取决于前一级别的输入？的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我正在尝试创建Shinyapp，其中第一个 radioGroupButtons 将自动更新第二个级别的 radioGroupButtons ，然后第三级，最终每个级别都会过滤 datatable
使用的代码
库（发光）
库（reshape2）
库（dplyr）
库（shinyWidgets）
hotdrinks< -list（ tea， green tea）
juices--list（ orange， mango）
energydrinks< -list（ powerhorse， redbull）
饮料< -list（ hotdrinks =热饮， juices =果汁， energydrinks = energydrinks）
biscuits <-list（ loacker， tuc）
choc< -list（ aftereight， lindt）
gum< -list（ trident， clortes）
sweets< -list（ gum = gum， 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），
数量 = 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，数量，价格）
t2<-列表（唯一（t1 $ CAT））
t2
全部<-list（ drinks = drinks， sweets = sweets）
app.R
库（发光）
库（shinyWidgets）
库（dplyr）
ui<-fluidPage（titlePanel（ TEST），
mainPanel（
fluidRow（
column（width = 9，align = center，
radioGroupButtons（inputId = item，
label =，status =成功，
大小= lg，方向=水平，对齐=否，
宽度= 100％，个人= 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 =成功，
大小= lg，方向=水平，对齐=否，
宽度= 100％，个人= TRUE，
checkIcon = list（
yes = icon（ check），
yes = icon（ check），
yes = icon（ check），
yes = icon（ 检查）
），
choiceNames = NULL，
choiceValues = NULL
））），
fluidRow（
column（width = 9，align = center，
radioGroupButtons（inputId = item3，
标签=，状态=成功，
大小= lg，方向=水平，对齐=假，
宽度= 100％，个人= 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））
））））
服务器<-函数（输入，输出）{
watchEvent（{
print（input $ item）
oi< -t1％>％filter（CAT == input $ item）％>％select（PN）
updateRadioGroupButtons（session，inputId = item2，
choiceNames = unique（oi），
选择值= 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 （唯一（t1 $ SP））））
}）
out_tbl<-反应性（{
x<-ox [，c（ Quantity， Price）]
}）
output $ out<- renderDataTable（{
out_tbl（）
}，options = list（pageLength = 5）
）
}
ShinyApp（ui = ui，server =服务器）
所需的结果是这样的
我使用了
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)
解决方案
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:
这篇关于在R中，如何创建多级radioGroupButtons，因为每个级别都取决于choiceNames取决于前一级别的输入？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
