反应tabtabnel在navbarMenu与DT包

Question

我想创建一个简单的应用程序与反应tabPanel/tabPanels这将取决于值在selectInput（我已经找到了解决方案here）。此外，在我选择这个小部件中的一个值之后，我会看到不同数量的tabPanels，它们也应该用作过滤器。 例如在我的应用程序中，我使用了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)) 
     }) 
     } 
    }) 
    } 
))