Shiny modules for creating dynamic SelectInputs

dynamicSelectShinyModule.R

library(shiny)

#' Safe subset
#'
#' @param df Dataframe
#' @param column One name of column to subset within
#' @param subset Vector of entries in column to subset to
#'
#' If column not in df, returns back the df
safeSubset <- function(df, column, subset){

  testthat::expect_is(df, "data.frame")
  testthat::expect_is(column, "character")
  testthat::expect_equal(length(column), 1)

  if(!is.null(subset)){
    testthat::expect_is(subset, "character")
  } else {
    message("Subset is NULL, returning original")
    out <- df
  }

  message(" # subsetting # original rows: ",nrow(df) ," column:", column, " by ", paste(subset, collapse = ", "))

  col <- df[[column]]

  if(!is.null(col)){
    out <- df[col %in% subset,]
    message("Subset rows: ", nrow(out))
  } else {
    message("Column not found:", column)
    out <- df
  }

  out

}


#' Dynamical Update of a selectInput
#'
#' Shiny Module: useage details at \link{dynamicSelect}
#'
#' @param id shiny id
#'
#' @return dynamicSelectInput
#' @export
dynamicSelectInput <- function(id, label, multiple = FALSE){

  ns <- shiny::NS(id)

  shiny::selectInput(ns("dynamic_select"), label,
                     choices = NULL, multiple = multiple, width = "100%")

}

#' Dynamical Update of a selectInput
#'
#' Shiny Module
#'
#' Use via \code{callModule(dynamicSelect, "name_select", the_data, "cyl")}
#'
#' @param input shiny input
#' @param output shiny output
#' @param session shiny session
#' @param the_data data.frame containing column of choices
#' @param column The column to select from
#' @param default_select The choices to select on load
#'
#' @seealso \link{dynamicSelectInput}
#'
#' @return the_data filtered to the choice
#' @export
dynamicSelect <- function(input, output, session, the_data, column, default_select = NULL){

  ns <- session$ns

  ## update input$dynamic_select
  observe({
    shiny::validate(
      shiny::need(the_data(),"Fetching data")
    )
    dt <- the_data()

    testthat::expect_is(dt, "data.frame")
    testthat::expect_is(column, "character")

    choice <- unique(dt[[column]])

    updateSelectInput(session, "dynamic_select",
                      choices = choice,
                      selected = default_select)

  })

  new_data <- reactive({
    shiny::validate(
      shiny::need(input$dynamic_select,"Select data"),
      shiny::need(the_data(), "Waiting for data")
    )

    sd <- the_data()
    selected <- input$dynamic_select

    ## will return sd even if column is NULL
    safeSubset(sd, column, selected)

  })

  return(new_data)

}

### Useage

shinyApp(
    ui = fluidPage(
      dynamicSelectInput("cyl_select", "Cyl filter", multiple = TRUE),
      dynamicSelectInput("dis_select", "Disp filter", multiple = TRUE),
      tableOutput("table")
    ),
    server = function(input, output, session){
      
      the_data <- reactive({
        mtcars
      })
      
     cyl_filter <- shiny::callModule(dynamicSelect, "cyl_select", the_data, "cyl", default_select = 4)
     ## cyl_filter is then filtered by disp
     disp_filter <- shiny::callModule(dynamicSelect, "dis_select", cyl_filter, "disp", default_select = cyl_filter()$disp)
      
      output$table <- renderTable({
        table <- disp_filter()
        save(table, file = "testTable.RData")
        table
      })
    
    }
)

Hi Mark,

I came across this gist while looking into setting up unit tests for my shiny apps and was immediately drawn to your use of testthat:: tests implemented directly into your modules (very clever approach!)

May I ask, how do you run these unit tests? Are they only executed at application start-up during your development phase or are you running an automated test suite over them as well?

If the latter is true, would you mind sharing your setup?

Thanks,

JP

I would be interested to know this as well. This is the first time I've seen tests integrated within a Shiny app.

Sorry @JPHUNTER I didn't get git notifications until recently :)

@dwhdai - its not that sophisticated, its only checking the input data and these days I would use assert_that() instead. If you want reactive tests then AFAIK the only way is to use the library shinytest