混合滑块和下拉菜单

Question

I am trying to put both these answers( 1 , 2 ) into one app.R. Everything works, except parts of the drop down menu part is unresponsive.

data<-structure(list(Date = c("2016-01", "2016-02", "2016-03", "2016-04", 
"2016-05", "2016-06", "2016-07", "2016-08", "2016-09", "2016-10", 
"2016-11", "2016-12", "2017-01", "2017-02", "2017-03", "2017-04", 
"2017-05", "2017-06", "2017-07", "2017-08", "2017-09", "2017-10", 
"2017-11", "2017-12", "2018-01", "2018-02", "2018-03", "2018-04", 
"2018-05", "2018-06", "2018-07", "2018-08", "2018-09", "2018-10", 
"2018-11", "2018-12"), `Brand Name` = c("Oreo", "Lindt", "Snickers", 
"OMO", "Oreo", "Lindt", "Snickers", "OMO", "Oreo", "Lindt", "Lindt", 
"Snickers", "Oreo", "Lindt", "Snickers", "OMO", "Oreo", "Lindt", 
"Snickers", "OMO", "Oreo", "Lindt", "Lindt", "Snickers", "OMO", 
"Oreo", "Lindt", "Snickers", "OMO", "Oreo", "Lindt", "Snickers", 
"OMO", "OMO", "Oreo", "Lindt"), Profit = c(3542.07, 6024.91, 
4739.9, 2344.03, 3294.06, 7478.54, 4482.91, 2760.74, 4195.26, 
6424.08, 7100.65, 5712.05, 3542.07, 6024.91, 4739.9, 2344.03, 
3294.06, 7478.54, 4482.91, 2760.74, 4195.26, 6424.08, 7100.65, 
5712.05, 2746.28, 5892.93, 9774.93, 6659.96, 3121.69, 4753.31, 
9652.76, 5990.85, 2838.11, 3354.48, 4495.58, 10483.94)), class = c("spec_tbl_df", 
"tbl_df", "tbl", "data.frame"), row.names = c(NA, -36L), spec = structure(list(
    cols = list(Date = structure(list(), class = c("collector_character", 
    "collector")), `Brand Name` = structure(list(), class = c("collector_character", 
    "collector")), Profit = structure(list(), class = c("collector_double", 
    "collector"))), default = structure(list(), class = c("collector_guess", 
    "collector")), skip = 1), class = "col_spec"))


#here's what I tried 
dropdownButton <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {

  status <- match.arg(status)
  # dropdown button content
  html_ul <- list(
    class = "dropdown-menu",
    style = if (!is.null(width))
      paste0("width: ", validateCssUnit(width), ";"),
    lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
  )
  # dropdown button apparence
  html_button <- list(
    class = paste0("btn btn-", status," dropdown-toggle"),
    type = "button",
    `data-toggle` = "dropdown"
  )
  html_button <- c(html_button, list(label))
  html_button <- c(html_button, list(tags$span(class = "caret")))
  # final result
  tags$div(
    class = "dropdown",
    do.call(tags$button, html_button),
    do.call(tags$ul, html_ul),
    tags$script(
      "$('.dropdown-menu').click(function(e) {
      e.stopPropagation();
});")
  )
}

# app ---------------------------------------------------------------------
library("shiny")
ui <- fluidPage(
  tags$h1("Example dropdown button"),
  br(),
  sidebarPanel (
    sliderInput("yearrange", "Select Years",
                min = 2016, max = 2018,
                value = c(min,max) ),
    sliderInput("monthrange", "Select Months",
                min = 1, max = 12,
                value = c(min,max) ),
      dropdownButton(
        label = "Choose Brand", status = "default", width = 80,
        actionButton(inputId = "a2z", label = "Sort A to Z", icon = icon("sort-alpha-asc")),
        actionButton(inputId = "z2a", label = "Sort Z to A", icon = icon("sort-alpha-desc")),
        br(),
        actionButton(inputId = "all", label = "(Un)select all"),
        checkboxGroupInput(inputId = "check2", label = "Choose", choices = unique(data$`Brand Name`))
      )),
  mainPanel(
      DT::dataTableOutput("table")
  )
)
server <- function(input, output, session) {

  # Select all / Unselect all
  observeEvent(input$all, {
    if (is.null(input$check2)) {
      updateCheckboxGroupInput(
        session = session, inputId = "check2", selected = unique(data$`Brand Name`)
      )
    } else {
      updateCheckboxGroupInput(
        session = session, inputId = "check2", selected = ""
      )
    }
  })

  # Sorting asc
  observeEvent(input$a2z, {
    updateCheckboxGroupInput(
      session = session, inputId = "check2", choices = sort(unique(data$`Brand Name`)), selected = input$check2
    )
  })
  # Sorting desc
  observeEvent(input$z2a, {
    updateCheckboxGroupInput(
      session = session, inputId = "check2", choices = sort(unique(data$`Brand Name`), decreasing = T), selected = input$check2
    )
  })
  output$table <- DT::renderDataTable({
    temp <- as.data.frame(data) # just reformats the data as dataframe, if your data is large you will want to do this outside runtime
    selectedBrand <- input$check2 # gets selected brands
    temp[which(temp$`Brand Name` %in% selectedBrand),] # returns data matching your selected brand
    year_table = temp[temp$Date >= input$yearrange[1] & temp$Date <= input$yearrange[2]+1,]
    year_table[unlist(str_split(year_table$Date, '-'))[c(F,T)] >= sprintf("%02d",  input$monthrange[1]) & unlist(str_split(year_table$Date, '-'))[c(F,T)] <= sprintf("%02d",  input$monthrange[2]),]
  })

}
shinyApp(ui = ui, server = server)

I feel like the issue is in the server part, in the output$table section but I can't pin it down. The sliders work, the sorting works, but if I (un)select all or select a single brand, the table doesn't respond to it.

Answer 1

I'm not sure but I think you just forgot an assignment in the last function of your script, ie the following code

temp[which(temp$`Brand Name` %in% selectedBrand),]

should be

temp <- temp[which(temp$`Brand Name` %in% selectedBrand),]

The following code works for me and the table responds to the menu.

# packages ----------------------------------------------------------------
library(shiny)
library(stringr)

data <- structure(
  list(
    Date = c(
      "2016-01", "2016-02", "2016-03", "2016-04", "2016-05", "2016-06",
      "2016-07", "2016-08", "2016-09", "2016-10", "2016-11", "2016-12",
      "2017-01", "2017-02", "2017-03", "2017-04", "2017-05", "2017-06",
      "2017-07", "2017-08", "2017-09", "2017-10", "2017-11", "2017-12",
      "2018-01", "2018-02", "2018-03", "2018-04", "2018-05", "2018-06",
      "2018-07", "2018-08", "2018-09", "2018-10", "2018-11", "2018-12"
    ),
    `Brand Name` = c(
      "Oreo", "Lindt", "Snickers", "OMO", "Oreo", "Lindt",
      "Snickers", "OMO", "Oreo", "Lindt", "Lindt", "Snickers",
      "Oreo", "Lindt", "Snickers", "OMO", "Oreo", "Lindt",
      "Snickers", "OMO", "Oreo", "Lindt", "Lindt", "Snickers",
      "OMO", "Oreo", "Lindt", "Snickers", "OMO", "Oreo",
      "Lindt", "Snickers", "OMO", "OMO", "Oreo", "Lindt"
    ),
    Profit = c(
      3542.07, 6024.91, 4739.9, 2344.03, 3294.06, 7478.54, 4482.91,
      2760.74, 4195.26, 6424.08, 7100.65, 5712.05, 3542.07, 6024.91,
      4739.9, 2344.03, 3294.06, 7478.54, 4482.91, 2760.74, 4195.26,
      6424.08, 7100.65, 5712.05, 2746.28, 5892.93, 9774.93, 6659.96,
      3121.69, 4753.31, 9652.76, 5990.85, 2838.11, 3354.48, 4495.58,
      10483.94
    )
  ),
  class = c("spec_tbl_df", "tbl_df", "tbl", "data.frame"),
  row.names = c(NA, -36L),
  spec = structure(
    list(
      cols = list(
        Date = structure(
          list(), class = c("collector_character", "collector")
          ), 
        `Brand Name` = structure(
          list(), class = c("collector_character", "collector")
          ), 
        Profit = structure(
          list(), class = c("collector_double", "collector")
          )
      ), 
      default = structure(
        list(), class = c("collector_guess", "collector")
        ), 
      skip = 1
    ),
    class = "col_spec"
  )
)

# here's what I tried
dropdownButton <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {
  status <- match.arg(status)
  # dropdown button content
  html_ul <- list(
    class = "dropdown-menu",
    style = if (!is.null(width)) {
      paste0("width: ", validateCssUnit(width), ";")
    },
    lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
  )
  # dropdown button apparence
  html_button <- list(
    class = paste0("btn btn-", status, " dropdown-toggle"),
    type = "button",
    `data-toggle` = "dropdown"
  )
  html_button <- c(html_button, list(label))
  html_button <- c(html_button, list(tags$span(class = "caret")))
  # final result
  tags$div(
    class = "dropdown",
    do.call(tags$button, html_button),
    do.call(tags$ul, html_ul),
    tags$script(
      "$('.dropdown-menu').click(function(e) {
      e.stopPropagation();
});"
    )
  )
}

# app ---------------------------------------------------------------------
ui <- fluidPage(
  tags$h1("Example dropdown button"),
  br(),
  sidebarPanel(
    sliderInput("yearrange", "Select Years",
      min = 2016, max = 2018,
      value = c(min, max)
    ),
    sliderInput("monthrange", "Select Months",
      min = 1, max = 12,
      value = c(min, max)
    ),
    dropdownButton(
      label = "Choose Brand", status = "default", width = 80,
      actionButton(inputId = "a2z", label = "Sort A to Z", icon = icon("sort-alpha-asc")),
      actionButton(inputId = "z2a", label = "Sort Z to A", icon = icon("sort-alpha-desc")),
      br(),
      actionButton(inputId = "all", label = "(Un)select all"),
      checkboxGroupInput(inputId = "check2", label = "Choose", choices = unique(data$`Brand Name`))
    )
  ),
  mainPanel(
    DT::dataTableOutput("table")
  )
)
server <- function(input, output, session) {

  # Select all / Unselect all
  observeEvent(input$all, {
    if (is.null(input$check2)) {
      updateCheckboxGroupInput(
        session = session, inputId = "check2", selected = unique(data$`Brand Name`)
      )
    } else {
      updateCheckboxGroupInput(
        session = session, inputId = "check2", selected = ""
      )
    }
  })

  # Sorting asc
  observeEvent(input$a2z, {
    updateCheckboxGroupInput(
      session = session, inputId = "check2", choices = sort(unique(data$`Brand Name`)), selected = input$check2
    )
  })
  # Sorting desc
  observeEvent(input$z2a, {
    updateCheckboxGroupInput(
      session = session, inputId = "check2", choices = sort(unique(data$`Brand Name`), decreasing = T), selected = input$check2
    )
  })
  output$table <- DT::renderDataTable({
    # browser()
    temp <- as.data.frame(data) # just reformats the data as dataframe, if your data is large you will want to do this outside runtime
    selectedBrand <- input$check2 # gets selected brands
    temp <- temp[which(temp$`Brand Name` %in% selectedBrand), ] # returns data matching your selected brand
    year_table <- temp[temp$Date >= input$yearrange[1] & temp$Date <= input$yearrange[2] + 1, ]
    year_table[unlist(stringr::str_split(year_table$Date, "-"))[c(F, T)] >= sprintf("%02d", input$monthrange[1]) & unlist(stringr::str_split(year_table$Date, "-"))[c(F, T)] <= sprintf("%02d", input$monthrange[2]), ]
  })
}
shinyApp(ui = ui, server = server)