R中的动态选项卡和复选框组与renderUI闪亮答案

【问题标题】：Dynamic tabs and checkbox group in R shiny with renderUIR中的动态选项卡和复选框组与renderUI闪亮
【发布时间】：2020-10-01 09:10:50
【问题描述】：

我正在尝试制作一个动态 UI，其中一些 tabPanel 和 checkboxGroup 是根据数据动态创建的。

下面是一个示例数据框：

df <- data.frame(
  "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
  "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
  "Value" = seq(1,10, length.out=5),
  stringsAsFactors = F
)

df
    Group   Name  Value
1 Group A    Bob   1.00
2 Group B   Paul   3.25
3 Group A  Peter   5.50
4 Group A   Emma   7.75
5 Group B   Jhon  10.00

根据我的数据框“组”列中的唯一值，我设法创建了两个名为“A 组”和“B 组”的tabPanel。我还可以根据每个组的“名称”列的唯一值创建一个checkboxGroupInput。

但是，我不明白在哪里放置通常的服务器块以输出每个组子集的表以及框中选中的值。我看到的任何类似讨论都无法解决这种特殊情况。

请参阅下面的尝试：

library(shiny)
library(DT)

# UI
ui <- fluidPage(
  mainPanel(
      uiOutput('mytabs')
  )
)

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

  output$mytabs <- renderUI({
    Tabs_titles = unique(df$Group)

    do.call(tabsetPanel,
            lapply(Tabs_titles,
                    function(x){
                      tabPanel(title = x,
                               checkboxGroupInput(inputId = "checkboxID",
                                                  label = "My Checkbox",
                                                  choices = df %>% subset(Group == x) %>% pull(Name),
                                                  selected = df %>% subset(Group == x) %>% pull(Name)
                               ),
                               DT::dataTableOutput("my_Table")
                      )
                    }
            )
    )
    })

  ### Where to place this 'usual' server code below? ###

  # Observe box values when changed
  box_values = reactive({input$checkboxID})

  # Output table
  output$my_Table <- DT::renderDataTable({
    subset(df, Group = <cannot catch the variable 'x' from above>, Name = box_values)
  })
}

shinyApp(ui, server)

任何解释将不胜感激。

【问题讨论】：

我不确定我是否完全理解您想要实现的目标，但也许您可以在这里获得一些灵感：mastering-shiny.org/action-dynamic.html
目标是通过首先创建基于 tabPanel 的动态 UI 来对数据框进行子集化。我看到了你提到的页面，以及this、that 和其他类似this one。

标签： r shiny

【解决方案1】：

这是一个部分解决方案，从您的评论到我的第一个建议。下面的代码提供了一个动态的checkboxGroupInput 以及一组tabPanels，其标签和编号随着checkboxgroupInput 的更改而更新。不幸的是，我还不能将过滤后的数据集放在tabPanels 上。只要我将 any 输出放在tabPanels 上，checkboxGroupInput 就会消失。奇怪的是，将输入放在tabPanel 上不会导致任何问题。

我发布此部分解决方案是希望其他人可以看到问题所在并在我有机会再次查看之前为您提供完整的答案。

我的解决方案使用嵌套的modules。我可能没有嵌套就可以逃脱，但我认为嵌套保持代码干净。

第一个模块控制tabPanels。它对主服务器中input$group 的更改做出反应。它更新checkboxgroupInput 的选择列表，为过滤数据集中的每一行创建tabPanel 和数据表模块的实例。

这是代码，后面还有更多的 cmets。

library(shiny)
library(tidyverse)

df <- data.frame(
  "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
  "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
  "Value" = seq(1,10, length.out=5),
  stringsAsFactors = F
)

# dataTable module definition
dataTableUI <- function(id) {
  ns <- NS("id")

  paste0("Content for ", stringr::str_split(id, fixed("-"))[[1]][2])
}

dataTableController <- function(input, output, session, group, nameList) {
  ns <- session$ns

  rv <- reactive({
  })

  return(rv)
}

# tabPanel module definition
tabPanelsUI <- function(id) {
  ns <- NS(id)

  tagList(
    checkboxGroupInput(ns("names"), label="Select names:", choices=c(), selected=c()),
    uiOutput(ns("tabPanel"))
  )
}

tabPanelsController <- function(input, output, session, selector) {
  ns <- session$ns

  output$tabPanel <- renderUI({
    req(v$filteredData)
    tabList <- lapply(v$filteredData$Name, function(x) tabPanel(title=x, dataTableUI(ns(x))))
    do.call(tabsetPanel, tabList)
  })

  v <- reactiveValues(
    filteredData=NA
  )

  observe({
    req(selector())
    v$filteredData <- df %>% subset(Group == selector())
    lapply(
      v$filteredData$Name, 
      function(x) {
        callModule(dataTableController, x, group=reactive({selector()}), nameList=reactive({input$names}))
      }
    )
  })

  observeEvent(v$filteredData, {
    nameList <- v$filteredData %>% pull(Name)
    updateCheckboxGroupInput(session, "names", choices=nameList, selected=nameList)
  })

  rv <- reactive({
  })

  return(rv)
}

# Main UI
ui <- fluidPage(
  titlePanel("Dynamic checkboxGroupInput"),
  sidebarLayout(
    sidebarPanel(
      selectInput("group", "Group", choices=c("Group A", "Group B"))
    ),
    mainPanel(
      tabPanelsUI("tabs")
    )
  )
)

server <- function(input, output, session) {
  selectedNames <- callModule(tabPanelsController, "tabs", reactive({input$group}))
}

shinyApp(ui = ui, server = server)

您会看到数据面板模块只是打印出一个静态文本：

dataTableUI <- function(id) {
  ns <- NS("id")

  paste0("Content for ", stringr::str_split(id, fixed("-"))[[1]][2])
}

反映与tabPanel 相关的人的姓名。用数据表替换静态文本应该是一件简单的事情

dataTableUI <- function(id) {
  ns <- NS("id")

  DT::dataTableOutput(ns("my_Table"))
}

并对服务器功能进行适当的更改。但是当我这样做时，checkboxGroupInput 消失了。我不知道为什么。

tabPanel 和数据表模块当前都返回NULL。这意味着

  rv <- reactive({
  })

  return(rv)

在这两种情况下都完全没有必要，但如果您的完整解决方案需要它，我会将它作为占位符放在那里。

模块化解决了让主服务器功能知道它需要修改哪个数据表的问题，因为它不需要这样做。该模块将在内部处理它自己的所有更新（一旦显示数据表！）。如果主服务器需要知道更新的result（或者关于模块正在做什么的任何其他信息，那么主服务器可以监控模块的返回值。

【讨论】：

【解决方案2】：

我认为你让问题变得比它需要的更复杂，结果给你自己带来了几个无法解决的问题。您的第一个问题是您正在创建多个具有相同 ID 的 checkboxGroupInputs。这意味着 Shiny 无法将它们彼此区分开来。而且，正如您所发现的，您也不能！

据我了解，您希望显示数据中一部分人的数据。第一个过滤器是通过选择selectInput 中的组来完成的。然后使用checkboxGroupInput 选择所需的名称。 checkboxGroupInput 可用的选项取决于selectInput 中选择的组。

我认为您无需求助于uiOutput 和renderUI 即可完成所有这些工作。关键是updateCheckboxGroupInput（在server 函数的定义中需要附加参数session）。我认为这可以满足您的要求：

library(shiny)
library(tidyverse)

ui <- fluidPage(
   titlePanel("Dynamic checkboxGroupInput"),
   sidebarLayout(
      sidebarPanel(
        selectInput("group", "Group", choices=c("Group A", "Group B")),
        checkboxGroupInput("name", "Name", choices=c())
      ),
      mainPanel(
        tableOutput("data")
      )
   )
)

server <- function(input, output, session) {
  df <- data.frame(
    "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
    "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
    "Value" = seq(1,10, length.out=5),
    stringsAsFactors = F
  )

  observeEvent(input$group, {
    updateCheckboxGroupInput(
      session, 
      "name",
      choices=df %>% subset(Group == input$group) %>% pull(Name),
      selected = df %>% subset(Group == input$group) %>% pull(Name)
    )
  })

  output$data <- renderTable({
    req(input$group, input$name)
    df %>% filter(Group == input$group, Name %in% input$name)
  })
}

shinyApp(ui = ui, server = server)

【讨论】：

感谢您的回复。在这里，我使用了一个简单的数据集来说明动态 UI。我必须使用动态 UI 根据数据框列的值而不是 selectInput 菜单显示 tabPanels。但是应用程序的最终结果确实与您的相同（即对原始数据框进行子集化）。我只是看不到如何将输出链接到动态 UI。
好的。您的意思是显示的tabPanels 取决于所选的组，并且每个tabPanel 都需要显示过滤后的数据集？（这可以解释uiOutput 的必要性！）每个tabPanel 中相同数据集的过滤是否相同？
正确。 tabPanels 是从“组”列中的唯一值向量创建的，checkboxGroupInput 选项来自“名称”列的唯一“组”特定值。所有这一切都通过使用相同的原始数据框df，以便在每个选项卡中获取一个表，其中包含每个“组”和框中选择的每个值的df 子集。

【解决方案3】：

library(shiny)

df <- data.frame(
  "Group" = c("Group A", "Group B", "Group A", "Group A", "Group B"),
  "Name" = c("Bob", "Paul", "Peter", "Emma", "John"),
  "Value" = seq(1,10, length.out=5),
  stringsAsFactors = F
)

# UI
ui <- fluidPage(
  mainPanel(
      uiOutput('mytabs')
  )
)

# SERVER
server <- function(input, output) {

  Tabs_titles = unique(df$Group)

  output$mytabs <- renderUI({
    myTabs <- lapply(Tabs_titles,
                    function(x){
                      tabPanel(title = x,
                               checkboxGroupInput(inputId = paste0("checkboxID_", x),
                                                  label = "My Checkbox",
                                                  choices = df %>% subset(Group == x) %>% pull(Name),
                                                  selected = df %>% subset(Group == x) %>% pull(Name)
                               ),
                               tableOutput(paste0("my_Table_", x))
                      )
                    }
    )

    do.call(tabsetPanel, myTabs)

  })

  observe(
    lapply(Tabs_titles,
           function(x){
             checked_names <- reactive({input[[paste0("checkboxID_", x)]]})

             output[[paste0("my_Table_", x)]] <-renderTable({
               df %>%
               subset(Group == x & Name %in% checked_names())
             })
           }
    )
  )
}


shinyApp(ui, server)

【讨论】：