Как динамически выбирать количество входов в Ршины с помощью ползунка

Question

У меня есть приложение с несколькими входами в зависимости друг от друга. Теперь я хочу динамически изменить количество элементов заполнения в моем объекте ggplot. Это необходимо для меня, поскольку в моих реальных данных много групп, и должна быть возможность отобразить их все (для полноты) или просто подмножество (для наглядности).
Итак, мои вопросы: как я могу использовать ползунок ввода, который принимает количество выбранных элементов в качестве максимального значения, чтобы ограничить количество разрешенных вариантов для пользователя?
Выбор должен следовать двум правилам:

1. Выберите n-элементов с наибольшим значением (relValue в моем примере)
2. Порядок возрастания n-элементов по имени (подгруппе)

Вот мой код:

tabA <- rep('A',1000)
tabB <- rep('B',1000)
tab <- c(tabA,tabB)
groupA <- rep(c('AA','BB'),500)
groupB <- rep(c('CC','DD'),500)
group <- c(groupA, groupB)
subgroupA <- rep(c('AAA','BBB','CCC','DDD'),125)
subgroupB <- rep(c('EEE','FFF','GGG','HHH'),125)
subgroupC <- rep(c('III','JJJ','KKK','LLL'),125)
subgroupD <- rep(c('MMM','NNN','OOO','PPP'),125)
subgroup1 <- c(subgroupA, subgroupB)
subgroup2 <- c(subgroupC, subgroupD)
subgroup <- c(subgroup1, subgroup2)
year <- rep(seq(1990,1999),100)
relValue <- rnorm(2000, 30, 10)
df <- data.frame(tab, group, subgroup, year, relValue, stringsAsFactors = FALSE)

library(shiny)
library(plotly)
library(ggplot2)
library(shinyWidgets)

ui <- fluidPage(
  sidebarPanel(
    uiOutput('selected_precision'),

    selectInput(inputId = 'selected_tab', label = 'tab', choices = ''),

    radioButtons(inputId = 'selected_group', label = 'group', choices = ''),

    pickerInput(inputId = 'selected_subgroup', label = 'subgroup', choices = '', multiple = TRUE)
    ),

    mainPanel(
      plotlyOutput('graph')
    )
  )

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

  output$selected_precision <- renderUI({ ### here the slider input is called
    req(input$selected_subgroup)

    sliderInput('selected_precision', label = 'precision', min = 1, max = length(input$selected_subgroup),
                value = length(input$selected_subgroup), round = TRUE, step = 1)
  })

  observe({
    updateSelectInput(session,
                      'selected_tab',
                      choices = df$tab)
  })

  observeEvent(input$selected_tab, {
    req(input$selected_tab)

    updateRadioButtons(
      session,
      'selected_group',
      choices = df %>%
        filter(tab == input$selected_tab) %>%
        select(group) %>%
        distinct(group) %>%
        .[[1]]
    )
  })

  filteredChoices <- reactive({
    df %>%
      #arrange(relValue) %>% ####I thought that was the way to go, but to no success...
      filter(tab == input$selected_tab) %>%
      filter(group == input$selected_group) %>%
      select(subgroup) %>%
      distinct(subgroup) %>%
      #top_n(length(subgroup)) %>%
      arrange(subgroup) %>%
      .[[1]]
  })

  observeEvent(c(input$selected_tab,input$selected_group),{
    req(input$selected_group)

    updatePickerInput(
      session,
      'selected_subgroup',
      choices = filteredChoices(),
      selected = filteredChoices()
    )
  })

  plotdata <- reactive({
      df %>%
        filter(group == input$selected_group) %>%
        filter(subgroup %in% input$selected_subgroup)
  })

  output$graph <- renderPlotly({
    req(nrow(plotdata()) > 0)

    plotdata() %>%
      plot_ly %>%
      ggplot()+
      geom_bar(plotdata(), mapping = aes(x = year, y = relValue, fill = subgroup)
                          ,stat = 'identity')
  })
}

shinyApp(ui,server)

РЕДАКТИРОВАТЬ: Код улучшен по запросу

Answer 1

tabA <- rep('A',1000)
tabB <- rep('B',1000)
tab <- c(tabA,tabB)
groupA <- rep(c('AA','BB'),500)
groupB <- rep(c('CC','DD'),500)
group <- c(groupA, groupB)
subgroupA <- rep(c('AAA','BBB','CCC','DDD'),125)
subgroupB <- rep(c('EEE','FFF','GGG','HHH'),125)
subgroupC <- rep(c('III','JJJ','KKK','LLL'),125)
subgroupD <- rep(c('MMM','NNN','OOO','PPP'),125)
subgroup1 <- c(subgroupA, subgroupB)
subgroup2 <- c(subgroupC, subgroupD)
subgroup <- c(subgroup1, subgroup2) #EDIT: changed to subgroup
year <- rep(seq(1990,1999),100)
relValue <- rnorm(2000, 30, 10)
df <- data.frame(tab, group, subgroup, year, relValue, stringsAsFactors = FALSE)


library(shiny)
library(plotly)
library(ggplot2)
library(shinyWidgets)

ui <- fluidPage(
    sidebarPanel(
        uiOutput('selected_precision'),

        selectInput(inputId = 'selected_tab', label = 'tab', choices = ''),

        radioButtons(inputId = 'selected_group', label = 'group', choices = ''),

        pickerInput(inputId = 'selected_subgroup', label = 'subgroup', choices = '', multiple = TRUE)
    ),

    mainPanel(
        plotlyOutput('graph')
    )
)

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

    output$selected_precision <- renderUI({ ### here the slider input is called
        req(input$selected_subgroup)

        sliderInput('selected_precision', label = 'precision', min = 1, max = length(input$selected_subgroup),
                    value = length(input$selected_subgroup), round = TRUE, step = 1)
    })

    observe({
        updateSelectInput(session,
                          'selected_tab',
                          choices = unique(df$tab))
    })


    observeEvent(input$selected_tab, {
        req(input$selected_tab)

        updateRadioButtons(
            session,
            'selected_group',
            choices = df %>%
                filter(tab == input$selected_tab) %>%
                select(group) %>%
                distinct(group) %>%
                .[[1]]
        )
    })

    filteredChoices <- reactive({
        df %>%
            #arrange(relValue) %>% ####I thought that was the way to go, but to no success...
            filter(tab == input$selected_tab) %>%
            filter(group == input$selected_group) %>%
            select(subgroup) %>%
            distinct(subgroup) %>%
            #top_n(length(subgroup)) %>%
            arrange(subgroup) %>%
            .[[1]]
    })

    observeEvent(c(input$selected_tab,input$selected_group),{
        req(input$selected_group)

        updatePickerInput(
            session,
            'selected_subgroup',
            choices = filteredChoices(),
            selected = filteredChoices()
        )
    })

    plotdata <- reactive({
        df %>%
            filter(group == input$selected_group) %>%
            filter(subgroup %in% input$selected_subgroup) %>%
            group_by(tab, group, subgroup) %>%
            arrange(desc(subgroup)) %>%
            top_n(input$selected_precision)
    })

    output$graph <- renderPlotly({
        req(nrow(plotdata()) > 0)

        plotdata() %>%
            plot_ly %>%
            ggplot()+
            geom_bar(plotdata(), mapping = aes(x = factor(year), y = relValue, fill = subgroup)
                     ,stat = 'identity')
    })
}

shinyApp(ui,server)

Передайте значение input$selected_precision в функцию top_n.Я также сделал некоторые улучшения, такие как использование переменной year в качестве переменной factor.Я также не понял, по какой причине вы сгруппировали фрейм данных, не сделав ничего другого после этого.