Dynamic input creation - Some reactives are executed unnecessarily often

[markusdumke]

I have written a shiny module that allows users to select variables to filter a dataset. Based on the type of variable then the correct type of input (i.e. selectizeInput for character columns, numericInput for numeric variables etc.) is created. Then the dataset is filtered according to the currently selected inputs.

This works fine, but looking at the printed messages I see that some of the reactives are executed unnecessarily often. For example when a new input is created, the dataset is filtered which is unnecessary because the result of the filtering will be the same as before (an empty selectInput means no filtering in my context). This is bad because the filtering step is actually a (potentially) long-running database query in my usecase, which I have simplified for the example.

Any ideas on how to solve this problem, so the Data.R reactive is executed only when necessary?

library(purrr)
library(shiny)
library(magrittr)
library(data.table)

cats <- function(...) cat(file = stderr(), ..., "\n")

filter.vars <- c("num1", "num2", "char1", "char2")
Data <- data.table(num1 = 1:6,
                   num2 = 20:25,
                   char1 = letters[1:6],
                   char2 = c("a", "b"))


mod_filter_ui <- function(id, .filter.vars) {
  ns <- NS(id)
  tag.list <- tagList()

  tag.list <- tagAppendChildren(
    tag.list,
    selectizeInput(
      ns("select.filter.var"), label = "Select Filters",
      multiple = TRUE,
      choices = c(Choose = "", .filter.vars),
      options = list(closeAfterSelect = TRUE)
    ),
    uiOutput(ns("filter.var"))
  )

  tag.list
}

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

  ns <- session$ns

  values <- reactiveValues(
    input.vars = NULL,
    tag.list = tagList(),
    update.inputs = FALSE
  )

  observe({
    # Check if variable already has an input widget
    new.var <- setdiff(input$select.filter.var, values$input.vars)

    if (length(new.var) > 0) {
      cats("Creating new filter variable", new.var)

      # Based on type of variable create selectInput or sliderInput and append to tag.list
      if (is.character(Data[[new.var]])) {
        choices <- unique(Data[[new.var]])

        new.input <- selectizeInput(ns(new.var),
                                    label = new.var,
                                    selected = FALSE,
                                    choices = choices,
                                    multiple = TRUE)
      }

      if (is.numeric(Data[[new.var]])) {
        min.var <- min(Data[[new.var]])
        max.var <- max(Data[[new.var]])

        new.input <- sliderInput(ns(new.var),
                                 label = new.var,
                                 step = 1L,
                                 min = min.var,
                                 max = max.var,
                                 value = c(min.var,
                                           max.var))
      }

      values$update.inputs <- TRUE
      values$tag.list <- tagAppendChild(values$tag.list, new.input)
    }

    ##
    ## Because all inputs are recreated when adding or deleting a new input,
    ## we need to update all existing inputs to their current values.
    ## It is important not to update the newly created input (if it ever existed before)
    ## because it otherwise has these old values and not the fresh initialized values.
    ##

    if (values$update.inputs) {
      cats("Update filter variables")
      for (j in seq_along(values$input.vars)) {
        update.var <- values$input.vars[j]

        if (is.character(Data[[update.var]])) {
          choices <- unique(Data[[update.var]])

          updated.input <- selectizeInput(ns(update.var),
                                          label = update.var,
                                          selected = input[[update.var]],
                                          choices = choices,
                                          multiple = TRUE
          )
        }

        if (is.numeric(Data[[update.var]])) {
          min.var <- min(Data[[update.var]])
          max.var <- max(Data[[update.var]])

          updated.input <- sliderInput(ns(update.var),
                                       label = update.var,
                                       step = 1L,
                                       min = min.var,
                                       max = max.var,
                                       value =  c(input[[update.var]][1], input[[update.var]][2]))
        }

        values$tag.list[[1]][[j]] <- updated.input
      }
      values$update.inputs <- FALSE
    }

    ## Delete input widget if variable is not selected anymore
    for (i in seq_along(values$input.vars)) {
      if (!(values$input.vars[[i]] %in% input$select.filter.var)) {
        cats("Delete filter variable", values$input.vars[[i]])
        values$tag.list[[1]][i] <- NULL
        values$update.inputs <- TRUE
      }
    }

    ## Keep track of which filters are currently selected
    values$input.vars <- input$select.filter.var
  })

  ## Render filter inputs
  output$filter.var <- renderUI({
    values$tag.list
  })

  ## List of current inputs
  inputs <- reactive({
    cats("Get current input values")
    dyn.filters <- purrr::map(values$input.vars, ~input[[.x]])
    names(dyn.filters) <- values$input.vars

    dyn.filters %>%
      discard(is.null)
  })

  # Filter the data based on selected inputs
  Data.R <- reactive({
    cats("Filter data based on inputs")
    D <- Data
    for (i in seq_along(inputs())) {
      if (is.character(inputs()[[i]])) {
        D <- D[get(names(inputs())[i]) %in%  inputs()[[i]]]
      }
      if (is.numeric(inputs()[[i]])) {
        D <- D[get(names(inputs())[i]) %between% c(inputs()[[i]][1], inputs()[[i]][2])]
      }
    }
    D
  })

  Data.R
}


ui <- fluidPage(
  mod_filter_ui("filter", .filter.vars = filter.vars),
  uiOutput("table")
)

server <- function(input, output, session) {
  Data <- callModule(mod_filter, "filter")

  output$table <- renderTable({Data()})
}

shinyApp(ui, server)