Question

我有一个具有多个输入的应用程序，这取决于彼此。我现在想做的是动态更改ggplot对象中fill元素的数量。这对我来说是必要的，因为我的真实数据中有很多组，并且应该可以全部显示它们（出于完整性）或仅显示一个子集（出于可见性）。
所以我的问题是：如何使用输入滑块将所选元素的数量作为最大值，以限制用户允许的选择数量？
选择应遵循两个规则：

选择具有最高值的n个元素（在我的示例中为relValue）
按名称（子组）的顺序排列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变量。我也不明白您是出于什么原因对数据框进行了分组，然后又不做其他任何事情。

如何使用滑块动态选择RShiny中的输入数量

1 个答案: