混合滑块和下拉菜单

时间：2019-07-18 14:29:25

标签： html r shiny

我正在尝试将这两个答案（1，2）放在一个app.R中。一切正常，除了下拉菜单部分无响应。 

%

我觉得问题出在服务器部分的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) 部分，但我无法确定。滑块起作用，排序起作用，但是如果我（取消）选择全部或选择单个品牌，则表格将不响应它。

1 个答案:

答案 0 :(得分：1)

我不确定，但是我认为您只是忘记了脚本的最后一个功能（即以下代码）中的赋值

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

应该是

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

以下代码对我有用，并且表格会响应菜单。 

# 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)
相关问题
最新问题