让用户在Shinydashboard应用中创建不同的按钮动作

Question

I want to build a shiny app that allows the user to select some columns to filter a data.table .

My real data has ~110 columns and the columns are numeric , character , factor , integer

I want to have a pre-selected filter in the sidebar panel but also to have a + button to allow the user to create custom filters based on the columns. I don't know if this can be done in shiny or not, I have read about insertUI and removeUI but I don't know if this could be applied to this case. Also the user-created filters should be applied consecutively, ie, if user creates three filters, then filter1 should be applied, then filter2, and then filter3.

I have this little example app where there is an initial filter based on Person using textAreaInput (my final user would like to paste some names on the box to filter out the table) but I would like to add some another filters, for example a sliderInput for votes or a dropdownMenu for letters .

library(shinydashboard)
library(dplyr)
library(shiny)
library(DT)

header <- dashboardHeader(title="Analysis and database")

sidebar <- dashboardSidebar(
  sidebarMenu(
   # Setting id makes input$tabs give the tabName of currently-selected tab
    id = "sidebarmenu",
    menuItem("Database", tabName="db"),
    menuItem("Search by Name", tabName = "Filt_table"),
      textAreaInput("name_", "Name")
 )
)

body <- dashboardBody(

 tabItems(
  tabItem("db","table content",
        fluidRow(DT::dataTableOutput('tabla'))),
  tabItem("Filt_table","Filtered table content",
        fluidRow(DT::dataTableOutput('tablafilt')))
 )
)

ui <- dashboardPage(header, sidebar, body)

### SERVER SIDE

server = function(input, output, session) {

my_data <- data.frame(Person=c("Anne", "Pete", "Rose", "Julian", "Tristan", "Hugh"), 
Votes=c(10,25,56,89.36,78,1500), 
Stuff=c("test|3457678", "exterm|4567sdf", "1001(hom);4.3.4|3456", "xdfrtg", "1234|trsef|456(het)", "hyggas|tertasga"),
 letters=replicate(6, paste(sample(LETTERS,6, replace=T), collapse="")))

output$tabla <- DT::renderDataTable({
  DT::datatable(my_data)
})

filtered <- reactive({
  if(is.null(input$name_))
    return()  
    glist <- isolate(input$name_)
    filter(my_data, Person %in% glist)
 })

output$tablafilt <- DT::renderDataTable({
  if(is.null(input$name_))
    return()  

   DT::datatable(filtered (), 
              filter = 'top', 
              extensions = 'Buttons',
              options = list(
                dom = 'Blftip',
                buttons = 
                  list('colvis', list(
                    extend = 'collection',
                    buttons = list(list(extend='csv',
                                        filename = 'results'),
                                   list(extend='excel',
                                        filename = 'results'),
                                   list(extend='pdf',
                                        filename= 'results')),
                    text = 'Download'
                  )),
                scrollX = TRUE,
                pageLength = 5,
                lengthMenu = list(c(5, 15, -1), list('5', '15', 'All'))
              ), rownames = FALSE
    )
  })



}
shinyApp(ui, server)

Answer 1

You can start by creating a selectInput() for all variables as well as add and remove buttons:

  output$potentialFilter <- renderUI({
    tagList(
      selectInput("createFilter", "Create Filter", names(my_data)),
      actionButton("remove", "remove"),
      actionButton("add", "add")
    )
  })

And then you can create inputs for the selected variables. Note: As you dont want to reset the inserted UIs when you add new ones you should use insertUI() instead of renderUI() .

  insertUI(selector = "#add", where = "afterEnd", 
           ui = selectizeInput(toBeIncluded, toBeIncluded, my_data[[toBeIncluded]], 
                               selected = my_data[[toBeIncluded]], multiple = TRUE)
  )

Full example would read:

  library(shinydashboard)
  library(dplyr)
  library(shiny)
  library(DT)

  header <- dashboardHeader(title="Analysis and database")

  sidebar <- dashboardSidebar(
    sidebarMenu(
      # Setting id makes input$tabs give the tabName of currently-selected tab
      id = "sidebarmenu",
      menuItem("Database", tabName="db"),
      menuItem("Search by Name", tabName = "Filt_table"),
      uiOutput("potentialFilter"),
      uiOutput("rendFilter")
    )
  )

  body <- dashboardBody(

    tabItems(
      tabItem("db","table content",
              fluidRow(DT::dataTableOutput('tabla'))),
      tabItem("Filt_table","Filtered table content",
              fluidRow(DT::dataTableOutput('tablafilt')))
    )
  )

  ui <- dashboardPage(header, sidebar, body)

  ### SERVER SIDE

  server = function(input, output, session) {

    my_data <- data.frame(Person=c("Anne", "Pete", "Rose", "Julian", "Tristan", "Hugh"), 
                          Votes=c(10,25,56,89.36,78,1500), 
                          Stuff=c("test|3457678", "exterm|4567sdf", "1001(hom);4.3.4|3456", "xdfrtg", "1234|trsef|456(het)", "hyggas|tertasga"),
                          letters=replicate(6, paste(sample(LETTERS,6, replace=T), collapse="")),
                          stringsAsFactors = FALSE)

    global <- reactiveValues(filter = c(), filteredData = my_data, tagList = tagList())

    output$potentialFilter <- renderUI({
      tagList(
        selectInput("createFilter", "Create Filter", names(my_data)),
        actionButton("remove", "remove"),
        actionButton("add", "add")
      )
    })


    observeEvent(input$add, {
      global$filter <- c(global$filter, input$createFilter)
      toBeIncluded <- input$createFilter
      data <- my_data[[toBeIncluded]]
      if(typeof(data) == "double"){
        ui <- numericInput(toBeIncluded, toBeIncluded, ceiling(min(data)), min = min(data), max = max(data))
      }else if(typeof(data) == "character"){
        ui <- textAreaInput(toBeIncluded, toBeIncluded, data[1], width = "200px")
      }
      insertUI(selector = "#add", where = "afterEnd", ui = ui)
    })

    observeEvent(input$remove, {  
      global$filter <- setdiff(global$filter, input$createFilter)
      removeUI(selector = paste0("div:has(> #", input$createFilter, ")"))
    })

    output$tabla <- DT::renderDataTable({
      DT::datatable(filtered())
    })

    filtered <- reactive({
      if(length(global$filter)){
        for(filterName in global$filter){
          if(is.character(input[[filterName]])){
            names <- unlist(strsplit(input[[filterName]], ";"))
            my_data <- my_data[my_data[[filterName]] %in% names, ]           
          }else if(is.numeric(input[[filterName]])){
            my_data <- my_data[my_data[[filterName]] >= input[[filterName]], ] 
          }
        }
      }
      return(my_data)
    })

    output$tablafilt <- DT::renderDataTable({
      DT::datatable(filtered(), 
                    filter = 'top', 
                    extensions = 'Buttons',
                    options = list(
                      dom = 'Blftip',
                      buttons = 
                        list('colvis', list(
                          extend = 'collection',
                          buttons = list(list(extend='csv',
                                              filename = 'results'),
                                         list(extend='excel',
                                              filename = 'results'),
                                         list(extend='pdf',
                                              filename= 'results')),
                          text = 'Download'
                        )),
                      scrollX = TRUE,
                      pageLength = 5,
                      lengthMenu = list(c(5, 15, -1), list('5', '15', 'All'))
                    ), rownames = FALSE
      )
    })



  }
  shinyApp(ui, server)

(I am not sure it makes a difference in which order you apply the filter, maybe you can ellaborate on this if I am mistaken).

Answer 2

You can always update your filters on the spot by using

updateSelectInput and others

https://shiny.rstudio.com/reference/shiny/0.13.2/updateSelectInput.html

Best!