在 R 中，如何创建多级 radioGroupButtons，因为每个级别都取决于 choiceNames 取决于上一级输入？

Question

我正在尝试创建 shinyapp，其中第一个 radioGroupButtons 会自动更新 radioGroupButtons 的第二级，然后是第三级，最终每个级别都会过滤 datatable

使用代码

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)

想要的结果是这样的

我用了

更新代码----------------


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)

Answer 1

正如@r2evans 所建议的，获得此行为的一种方法是使用 uiOutput 和 renderUI。这是一个最小的应用程序：

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

# make a data frame for choices

level1 <- LETTERS[1:3]
level2 <- 1:5

df <- expand.grid(level1, level2, stringsAsFactors = FALSE) %>% 
  mutate(Var2=paste(Var1, Var2)) %>% 
  arrange(Var1)

ui <- fluidPage(
  mainPanel(
    fluidRow(
      column(width = 3, "some space"),
      column(
        width = 9,
        align = "center",
        radioGroupButtons(
          inputId = "level1",
          label = "",
          status = "success",
          size = "lg",
          direction = "horizontal",
          justified = FALSE,
          width = "100%",
          individual = TRUE,
          checkIcon =  setNames(
            object = lapply(unique(df$Var1), function(x) icon("check")),
            nm = rep("yes", length(unique(df$Var1)))),
          choiceNames = unique(df$Var1),
          choiceValues = unique(df$Var1) 
        ),
        uiOutput("level2"),
        tags$hr(),
        dataTableOutput("tbl")
      )
    )
))

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

  # render the second level of buttons
  make_level <- reactive({

    df2 <- filter(df, Var1 %in% input$level1)

    radioGroupButtons(
      inputId = "level2",
      label = "",
      status = "primary",
      size = "lg",
      direction = "horizontal",
      justified = FALSE,
      width = "100%",
      individual = TRUE,
      checkIcon =  setNames(
        object = lapply(unique(df2$Var2), function(x) icon("check")),
        nm = rep("yes", length(unique(df2$Var2)))),
      choiceNames = as.list(unique(df2$Var2)),
      choiceValues = as.list(unique(df2$Var2))
    )
  })

  output$level2 <- renderUI({
    make_level()
  })

  output$tbl <- renderDataTable({
    df %>% filter(Var1 == req(input$level1), Var2 == req(input$level2))
  })

}

shinyApp(ui, server)

实现此目的的另一种方法是使用闪亮的模块。这是一个看起来如何的例子。这段代码更简洁，因为单选按钮被定义为模块的一部分，然后根据需要调用模块。因为层级之间存在依赖关系，所以模块中还需要renderUI

代码：

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

# make a data frame for choices

level1 <- LETTERS[1:3]
level2 <- 1:5

df <- expand.grid(level1, level2, stringsAsFactors = FALSE) %>%
  mutate(Var2 = paste(Var1, Var2)) %>%
  arrange(Var1)

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 = FALSE,
      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 = 3, "some space"),
  column(
    width = 9,
    align = "center",
    buttons_ui(id = "level1"),
    buttons_ui(id = "level2"),
    # buttons_ui(id = "level3"),
    # buttons_ui(id = "level4"),
    # and so on..
    tags$hr(),
    dataTableOutput("tbl")
  )
)))

server <- function(input, output, session) {
  selected1 <-
    callModule(module = buttons_server,
               id = "level1",
               button_names = reactive({ unique(df$Var1) }), 
               button_status = reactive({ "success"}) )

  selected2 <-
    callModule(
      module = buttons_server,
      id = "level2",
      button_names = reactive({ df %>% filter(Var1 == selected1() ) %>% pull(Var2) %>% unique }),
      button_status = reactive({ "primary" })
    )

  # add more calls to the module server as necessary

  output$tbl <- renderDataTable({
    df %>% filter(Var1 == req(selected1()), Var2 == req(selected2()))
  })
}

shinyApp(ui, server)

Answer 2

您可以在 observeEvents 中动态更新选项，这是一个演示：

# 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)

结果如下：

在 R 中，如何创建多级 radioGroupButtons，因为每个级别都取决于 choiceNames 取决于上一级输入？

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

datatable

r

shiny

shinywidgets