带有 DT 包的 navbarMenu 中的反应式 tabPanel

Question

我想用 tabPanel/tabPanels 创建一个简单的应用程序，它取决于 selectInput 中的值（我已经找到了解决方案 here）。此外，在我在此小部件中选择一个值后，我将看到不同数量的 tabPanel，它们也应该用作过滤器。例如。在我的应用程序中，我使用 diamonds 数据集。如果我选择一个词 'Very Good'，我将看到一个数据集，其中包含所有具有该值的行。在它的顶部，我还将看到过滤数据集中所有唯一的 color 值。我想要实现的是使用上面的 tabPanels 再次过滤的可能性。

library(shiny)
library(shinyTree)
library(dplyr)
library(DT)
library(ggplot2)

diamonds_test <- sample_n(diamonds, 100)
diam_cut <- 
  list(
    `Very Good` = "Very Good",
    Ideal = "Ideal",
    Fair = "Fair",
    Premium = "Premium",
    Good = "Good"
  )

runApp(list(
  ui = pageWithSidebar(
    headerPanel('Dynamic Tabs'),
    sidebarPanel(
      selectInput('name','',choices = diam_cut)
    ),
    mainPanel(
      uiOutput('mytabs'),
      dataTableOutput('table')
    )
  ),
  server = function(input, output, session){

    output$mytabs = renderUI({
      colorVector <- diamonds_test %>%
        filter(cut == input$name) %>% 
        distinct(color) %>% 
        .[['color']] %>% 
        as.character()

      myTabs = lapply(colorVector, tabPanel)
      do.call(tabsetPanel, c(myTabs, type = 'pills'))
    })

    output$table <- renderDataTable({
      data <- diamonds_test %>%
        filter(cut == input$name)
      datatable(data)
    })
  }
))

Answer 1

经过几个小时的搜索和尝试不同的配置，我创建了我想要实现的目标。

library(shiny)
library(shinyTree)
library(dplyr)
library(DT)

diamonds_test <- sample_n(diamonds, 100)
diam_cut <- 
  list(
    `Very Good` = "Very Good",
    Ideal = "Ideal",
    Fair = "Fair",
    Premium = "Premium",
    Good = "Good"
  )

runApp(list(
  ui = pageWithSidebar(
    headerPanel('Dynamic Tabs'),
    sidebarPanel(
      selectInput('name','',choices = diam_cut)
    ),
    mainPanel(
      uiOutput('mytabs')
    )
  ),
  server = function(input, output, session){

    colorVector <- reactive({
      colorVector <- diamonds_test %>%
        filter(cut == input$name) %>% 
        distinct(color) %>% 
        .[['color']] %>% 
        as.character()
    })

    output$mytabs <- renderUI({
      colorVector_use <- colorVector()
      myTabs = lapply(colorVector_use, tabPanel)

      do.call(tabsetPanel,
              c(type = 'pills',
                lapply(colorVector_use, function(x) {
                  call("tabPanel",x ,call('dataTableOutput',paste0("table_",x)))
                })
              ))
    })

    data <- reactive({
      df <- diamonds_test %>% 
        filter(cut == input$name)
    })

    observe({
      if (!is.null(colorVector())){
        lapply(colorVector(), function(color_value){
          output[[paste0('table_',color_value)]] <- renderDataTable(
            data() %>% filter(color == color_value))
        })
      }
    })
  }
))

带有 DT 包的 navbarMenu 中的反应式 tabPanel

reactive tabPanel in a navbarMenu with DT package

r

shiny

navbar

dt