Logo Questions Linux Laravel Mysql Ubuntu Git Menu
 

Shiny - dynamic data filters using insertUI

Tags:

r

filter

shiny

I am new to shiny and was trying to write an app where the user can dynamically add data filters (see code below). I thought insertUI and remove UI are pretty cool for that purpose. However, I have several problems:

    1) I cannot address dynamically generates input$ids (see filterId in the code, l. 36 and l. 58)
    2) in updateCheckboxGroupInput (l. 62) checkboxes are not preselected.
    3) I cannot select data rows using which() (l. 74)
    4) The checkboxes are not displayed inside the column, but spread over the whole page.

I highly appreciate any hints.

Thanks, Jordi

here the code:

library(shiny)

rowvalues <- function(col,data) {
  as.list(unique(data[col]))
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      fluidRow(
        column(6, actionButton('addFilter', 'Add filter')),
        column(6, actionButton('removeFilter', 'Remove filter')),
        offset = 6
      ),
      tags$hr(),
      tags$div(id = 'placeholderAddRemFilt'),
      tags$div(id = 'placeholderFilter'),
      width = 4 # sidebar
    ),
    mainPanel(
      tableOutput("data")
    )
  )
)

server <- function(input, output,session) {
  filter <- character(0)

  observeEvent(input$addFilter, {
    add <- input$addFilter
    filterId <- paste0('Filter', add)
    headers <- names(mtcars)
    insertUI(
      selector = '#placeholderFilter',
      ui = tags$div(
        # selectInput(filterId, label = paste0("Filter ",add), # does not work
        selectInput("ColFilter", label = paste0("Filter ",add), 
                    choices = as.list(headers), 
                    selected = 1),
        checkboxGroupInput("RowFilter", label = "Select variable values",
                           choices = NULL, selected = NULL, 
                           inline = TRUE, width = 4000),
        id = filterId
      )
    )

    filter <<- c(filter,filterId)
  })

  observeEvent(input$removeFilter, {
    removeUI(
      ## pass in appropriate div id
      selector = paste0('#', filter[length(filter)])
    )
    filter <<- filter[-length(filter)]
  })

  # observeEvent(input$filterId, { # does ntót work
  observeEvent(input$ColFilter, {
    col <- input$ColFilter
    values <- as.list(unique(mtcars[col]))[[1]]
    updateCheckboxGroupInput(session,"RowFilter", label = "Select variable    values", 
                              choices = values, selected = values, 
                              inline = TRUE)
  })

  output$data <- renderTable({
    col <- input$ColFilter
    rows <- input$RowFilter
    print(c("selected col: ",col))
    print(c("selected rows: ",as.vector(rows)))
    if(is.null(col)) mtcars
    else {
      mtcars[which(mtcars$col != rows),]
    }
  })
 }

shinyApp(ui = ui, server = server)
like image 381
Jordi Avatar asked Mar 30 '26 20:03

Jordi


1 Answers

Please see the code below for my suggestions. I basically did what you were hoping/trying to do, namely to add observers dynamically such that each new filter element has its own observer. It turns out: you can just do it. Just like that. So I added observers inside the exact observeEvent where the ui elements are rendered, to give them the reactivity they need. I even added "personal" remove buttons, which will be more convenient than just removing the bottommost one. Also, the logic to handle all those filters will be an aggregated list that stores all the information currently selected in the various filters. This makes the renderTable part much easier.

Make yourself familiar with the code and please ask, if there are any uncertainties.

Best Regards

library(shiny)

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      fluidRow(
        column(6, actionButton('addFilter', 'Add filter')),
        offset = 6
      ),
      tags$hr(),
      tags$div(id = 'placeholderAddRemFilt'),
      tags$div(id = 'placeholderFilter'),
      width = 4 # sidebar
    ),
    mainPanel(
      tableOutput("data")
    )
  )
)

server <- function(input, output,session) {
  filter <- character(0)

  makeReactiveBinding("aggregFilterObserver")
  aggregFilterObserver <- list()

  observeEvent(input$addFilter, {
    add <- input$addFilter
    filterId <- paste0('Filter_', add)
    colfilterId <- paste0('Col_Filter_', add)
    rowfilterId <- paste0('Row_Filter_', add)
    removeFilterId <- paste0('Remove_Filter_', add)
    headers <- names(mtcars)
    insertUI(
      selector = '#placeholderFilter',
      ui = tags$div(id = filterId,
        actionButton(removeFilterId, label = "Remove filter", style = "float: right;"),
        selectInput(colfilterId, label = "Some Filter", choices = as.list(headers), selected = 1),
        checkboxGroupInput(rowfilterId, label = "Select variable values",
                           choices = NULL, selected = NULL, width = 4000)
      )
    )

    observeEvent(input[[colfilterId]], {

      col <- input[[colfilterId]]
      values <- as.list(unique(mtcars[col]))[[1]]

      updateCheckboxGroupInput(session, rowfilterId , label = "Select variable    values", 
                              choices = values, selected = values, inline = TRUE)

      aggregFilterObserver[[filterId]]$col <<- col
      aggregFilterObserver[[filterId]]$rows <<- NULL
    })

    observeEvent(input[[rowfilterId]], {

      rows <- input[[rowfilterId]]

      aggregFilterObserver[[filterId]]$rows <<- rows

    })

    observeEvent(input[[removeFilterId]], {
      removeUI(selector = paste0('#', filterId))

      aggregFilterObserver[[filterId]] <<- NULL

    })
  })

  output$data <- renderTable({

    dataSet <- mtcars

    invisible(lapply(aggregFilterObserver, function(filter){

      dataSet <<- dataSet[which(!(dataSet[[filter$col]] %in% filter$rows)), ]

    }))

    dataSet
  })
 }

shinyApp(ui = ui, server = server)
like image 95
K. Rohde Avatar answered Apr 02 '26 13:04

K. Rohde



Donate For Us

If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!