在 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 的第二级，然后是第三级，最终每一级都会过滤 数据表
使用过的代码
图书馆(闪亮)图书馆(重塑2)图书馆(dplyr)图书馆(闪亮的小部件)hotdrinks<-list("茶","绿茶")果汁<-list("orange","mango")energydrinks<-list("powerhorse","redbull")饮料<-list("hotdrinks"=hotdrinks,"juices"=juices,"energydrinks"=energydrinks)饼干<-list("loacker","tuc")choc<-list("aftereight","lindt")口香糖<-list("三叉戟","clortes")糖果<-list(口香糖"=口香糖，饼干"=饼干，巧克力"=巧克力)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)]t1colnames(t1)<-c("CAT","PN","SP","数量","价格")t2<-list(唯一的(t1$CAT))t2all <- list("drinks"=drinks, "sweets"=sweets)app.R
图书馆(闪亮)图书馆(闪亮的小部件)图书馆(dplyr)ui <-fluidPage(titlePanel("TEST"),主面板(流体行(列(宽度= 9，对齐=中心"，radioGroupButtons(inputId = "item",标签 = "", 状态 = "成功",大小 =lg"，方向 =水平"，合理 = FALSE，宽度 = "100%", 个人 = TRUE,检查图标 = 列表(是"=图标(检查")，是"=图标(检查")),choiceNames = as.list(unique(t1$CAT)),choiceValues = as.list(1:length(unique(t1$CAT)))))),流体行(列(宽度= 9，对齐=中心"，radioGroupButtons(inputId = "item2",标签 = "", 状态 = "成功",大小 =lg"，方向 =水平"，合理 = FALSE，宽度 = "100%", 个人 = TRUE,检查图标 = 列表(是"=图标(检查")，是"=图标(检查")，是"=图标(检查")，是"=图标(检查")),选择名称 = NULL，选择值 = NULL))),流体行(列(宽度= 9，对齐=中心"，radioGroupButtons(inputId = "item3",标签 = "", 状态 = "成功",大小 =lg"，方向 =水平"，合理 = FALSE，宽度 = "100%", 个人 = TRUE,检查图标 = 列表(是"=图标(检查")，是"=图标(检查")，是"=图标(检查")，是"=图标(检查")),选择名称 = NULL，选择值 = NULL))),流体行(列(宽度 = 9，井面板(数据表输出(输出"))))))服务器 <- 功能(输入，输出){观察事件({打印(输入$项目)oi<-t1%>%filter(CAT==input$item)%>%select(PN)updateRadioGroupButtons(session, inputId="item2",选择名称 = 唯一(oi)，choiceValues = as.list(1:length(unique(t1$PN))))ox<-t1%>%filter(CAT==input$item2)%>%select(SP)updateRadioGroupButtons(session, inputId="item3",选择名称 = 唯一(牛)，choiceValues = as.list(1:length(unique(t1$SP))))})out_tbl <- 反应式({x <- ox[,c("数量","价格")]})输出$out <- renderDataTable({out_tbl()},options = list(pageLength = 5))}闪亮应用(用户界面=用户界面，服务器=服务器)想要的结果是这样的
我使用
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屋！
查看全文
