通过下拉菜单选择数据行

Question

This code reads in the data, find unique values of a column ( Location ) and puts these values as options in the dropdown menu. My goal is to customize my data based on values that are chosen in the dropdown menu. My data looks like below:

I tried to view the data but I found it is not working properly. What should I do?

Update 1: The problem is in data()$Location == input$Locationscheck but I don't know how to fix it.

library(shiny)

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();
});")
  )
}

ui <- fluidPage(
  fileInput(inputId = "uploadedcsv","", accept = '.csv'),
  dropdownButton(label = "Choose the locations",status = "default",
                 width = 250,actionButton(inputId = "allLocations", label = "(Un)select all"),
                 checkboxGroupInput(inputId = "Locationscheck",label = "Choose",choices = "")),
  actionButton('Run', label = "Run!")
)

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

  data <- reactive({
    infile <- input$uploadedcsv

    if (is.null(infile))
      return(NULL)

    read.csv(infile$datapath, header = TRUE, sep = ",")
  })

  observe({
    locationnames <- unique(data()$Location)
    updateCheckboxGroupInput(session, "Locationscheck",
                             choices = locationnames,
                             selected = locationnames)

    ### selecting and de-selecting in step 2 ###
    observeEvent(input$allLocations, {
      if (is.null(input$Locationscheck)) {
        updateCheckboxGroupInput(session = session,
                                 inputId = "Locationscheck",
                                 selected = locationnames)
      } else {
        updateCheckboxGroupInput(session = session,
                                 inputId = "Locationscheck",
                                 selected = "")
      }
    })
    ### End of selecting and de-selecting ###

    observeEvent(input$Run, {
      Newdata <- data()[data()$Location == input$Locationscheck,]
      View(data())
      View(Newdata)
    })

  })
}
shinyApp(ui = ui, server = server)

Answer 1

The problem in the code data()$Location == input$Locationscheck is that it only considers first element in the input$Locationscheck vector and gives you the result as the values that are matched(eg: Location1) . You should use which(data()[data()$Location %in% input$Locationscheck,]) instead. which gives the indexes and %in% compares data()$Location with all the values in the input$Locationscheck vector.

I have modified your code and further added a table to illustrate the working:

library(shiny)

 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();
 });")
  )
   }

 ui <- fluidPage(
   fileInput(inputId = "uploadedcsv","", accept = '.csv'),
   dropdownButton(label = "Choose the locations",status = "default",
                  width = 250,actionButton(inputId = "allLocations", label = "(Un)select all"),
                  checkboxGroupInput(inputId = "Locationscheck",label = "Choose",choices = "")),
   actionButton('Run', label = "Run!"),
   tableOutput('table')
 )

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

   data <- reactive({
     infile <- input$uploadedcsv

     if (is.null(infile))
       return(NULL)

     read.csv(infile$datapath, header = TRUE, sep = ",", stringsAsFactors = FALSE)
   })

   observe({
     locationnames <- unique(data()$Location)

     updateCheckboxGroupInput(session, "Locationscheck",
                              choices = locationnames,
                              selected = locationnames)

     ### selecting and de-selecting in step 2 ###
     observeEvent(input$allLocations, {
       if (is.null(input$Locationscheck)) {
         updateCheckboxGroupInput(session = session,
                                  inputId = "Locationscheck",
                                  selected = locationnames)
       } else {
         updateCheckboxGroupInput(session = session,
                                  inputId = "Locationscheck",
                                  selected = "")
       }
     })
     ### End of selecting and de-selecting ###

     observeEvent(input$Run, {
       # Newdata <- data()[data()$Location == input$Locationscheck,]
       Newdata <- data()[which(data()$Location %in% input$Locationscheck),]
       # # View(data())
       # View(Newdata)
       output$table <- renderTable({
         Newdata
       })

     })

   })
 }
 shinyApp(ui = ui, server = server)

I suggest you use isolate when you access the value so that the reactive event is not triggered again and again, something like this Newdata <- isolate(data())[which(isolate(data())$Location %in% input$Locationscheck),]

Hope it helps!