реактивный tabPanel в navbarMenu с пакетом DT

Question

Я хотел бы создать простое приложение с реактивной tabPanel/tabPanels, которая будет зависеть от значения в selectInput (я уже нашел решение here). Кроме того, после того, как я выберу одно значение в этом виджетах, я увижу разное количество tabPanels, которое также должно работать как фильтр. . в моем приложении я использую набор данных diamonds. Если я выберу слово «Очень хорошо», я увижу набор данных со всеми строками с этим значением. В верхней части я также увижу все уникальные значения color в отфильтрованном наборе данных. То, что я хочу достичь, - это получить возможность фильтровать еще раз, используя tabPanels выше.

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