isolate reactive function for displaying selections and filters after action button

Question

I am trying to create a reactive function with the isolate command from the following code in the ui.R file into the server.R file where the data table only populates after the user has inputed their selections and filters only.

Right now the data table just populates on its own after running the filters and selections without having to click on the Run Query button.

Any help would be appreciated!

actionButton("runit", "RUN QUERY")

Thank you so much!

Code below:

ui.R

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

ui <- function(request) {
  dashboardPage(
    dashboardHeader(title = "CL Pivot"),
    dashboardSidebar(
      actionButton("runit", "RUN QUERY"),
      h4(HTML(" "), "Select Table Rows"),
      uiOutput("rowSelect"),
      hr(),
      
      h4(HTML(" "), "Select Table Columns"),
      uiOutput("colSelect"),
      hr(),
      
      h4(HTML(" "), "Select Table Cell Fill"),
      selectizeInput(
        inputId = "funChoices",
        label = NULL,
        multiple = FALSE,
        choices = c("Count", "Average", "Median", "Sum", "Maximum", "Minimum"),
        selected = c()
      ),
      hr(),
      h4(HTML(" "), "Filter Data Set"),
      
      uiOutput("hairColorFilter"),
      uiOutput("skinColorFilter")
    ),
    dashboardBody(dataTableOutput("data"))
    
  )
}

server.R

library(DT)
library(shiny)
library(shinydashboard)
library(dplyr)
library(dbplyr)
library(tidyverse)
library(DBI)

data <- starwars

# Convenience Function to Make Upcoming Chain Less Messy
fun_across <- function(cols, fun, fun_name) {
  fun_list <- list(fun)
  names(fun_list) <- fun_name
  across(all_of(cols), fun_list, .names = "{fn}_{col}")
}

shinyServer(function(input, output, session) {
  
  # Identify Measures and Dimensions -------------
  
  dimensions <- colnames(data)[!sapply(data, is.numeric)]
  measures <- colnames(data)[sapply(data, is.numeric)]
  
  # Identify Filter Choices -----------------------------------------------
  
  hairColorChoices <- sort(unique(data$hair_color))
  skinColorChoices <- sort(unique(data$skin_color))
  
  # Define User Inputs ----------------------------------------------------
  
  output$rowSelect <- renderUI({
    selectizeInput(
      inputId = "rowChoices",
      label = NULL,
      multiple = TRUE,
      choices = dimensions,
      selected = c()
    )
  })
  
  output$colSelect <- renderUI({
    selectizeInput(
      inputId = "colChoices",
      label = NULL,
      multiple = TRUE,
      choices = measures,
      selected = c()
    )
  })
  
  output$hairColorFilter <- renderUI({
    sidebarMenu(
      menuItem(
        text = "Hair Color",
        icon = icon("briefcase"),
        checkboxGroupInput(
          inputId = "hairColorChoices",
          label = NULL,
          choices = hairColorChoices,
          selected = hairColorChoices
        )
      )
    )
  })
  
  output$skinColorFilter <- renderUI({
    sidebarMenu(
      menuItem(
        text = "Skin Color",
        icon = icon("thermometer-half"),
        checkboxGroupInput(
          inputId = "skinColorChoices",
          label = NULL,
          choices = skinColorChoices,
          selected = skinColorChoices
        )
      )
    )
  })
  
  # Define Reactive Functions ---------------------------------------------
  
  pairColFuns <- reactive({
    colChoices <- input$colChoices
    names(colChoices) <- input$funChoices
    
    return(colChoices)
  })
  
  # Construct DataFrame Based on User Inputs
  
  output$data <- renderDataTable({
    colChoices <- pairColFuns()
    rowChoices <- input$rowChoices
    
    countCols   <- unname(colChoices[names(colChoices) == "Count"])
    averageCols <- unname(colChoices[names(colChoices) == "Average"])
    medianCols  <- unname(colChoices[names(colChoices) == "Median"])
    sumCols     <- unname(colChoices[names(colChoices) == "Sum"])
    maxCols     <- unname(colChoices[names(colChoices) == "Maximum"])
    minCols     <- unname(colChoices[names(colChoices) == "Minimum"])
    
    displayTable <- as_tibble(data) %>%
      filter(
        hair_color %in% input$hairColorChoices,
        skin_color %in% input$skinColorChoices
      ) %>%
      group_by(across(all_of(rowChoices))) %>%
      summarize(
        # Once again we've sacrificed a bit of elegance for clarity. This chunk will
        # apply the specified function to whichever columns are included in the 
        # specified variable. If the variable is empty, no operation is performed.
        fun_across({{countCols}}, length, "count"),
        fun_across({{averageCols}}, ~mean(.x, na.rm = TRUE), "average"),
        fun_across({{medianCols}}, ~median(.x, na.rm = TRUE), "median"),
        fun_across({{sumCols}}, ~sum(.x, na.rm = TRUE), "total"),
        fun_across({{maxCols}}, ~max(.x, na.rm = TRUE), "max"),
        fun_across({{minCols}}, ~min(.x, na.rm = TRUE), "min"),
        .groups = "drop"
      )
    
    return(displayTable)
    
  })
})

starja · Accepted Answer

I would split the table rendering and data processing, then you can use the eventReactive approach. This saves you to wrap every input into isolate.

First make an eventReactive that calculates your data. It only updates if the first reactive/input changes. Then you can use this to render your table:

table_data <- eventReactive(input$runit, {
  colChoices <- pairColFuns()
  rowChoices <- input$rowChoices
  
  countCols   <- unname(colChoices[names(colChoices) == "Count"])
  averageCols <- unname(colChoices[names(colChoices) == "Average"])
  medianCols  <- unname(colChoices[names(colChoices) == "Median"])
  sumCols     <- unname(colChoices[names(colChoices) == "Sum"])
  maxCols     <- unname(colChoices[names(colChoices) == "Maximum"])
  minCols     <- unname(colChoices[names(colChoices) == "Minimum"])
  
  displayTable <- as_tibble(data) %>%
    filter(
      hair_color %in% input$hairColorChoices,
      skin_color %in% input$skinColorChoices
    ) %>%
    group_by(across(all_of(rowChoices))) %>%
    summarize(
      # Once again we've sacrificed a bit of elegance for clarity. This chunk will
      # apply the specified function to whichever columns are included in the 
      # specified variable. If the variable is empty, no operation is performed.
      fun_across({{countCols}}, length, "count"),
      fun_across({{averageCols}}, ~mean(.x, na.rm = TRUE), "average"),
      fun_across({{medianCols}}, ~median(.x, na.rm = TRUE), "median"),
      fun_across({{sumCols}}, ~sum(.x, na.rm = TRUE), "total"),
      fun_across({{maxCols}}, ~max(.x, na.rm = TRUE), "max"),
      fun_across({{minCols}}, ~min(.x, na.rm = TRUE), "min"),
      .groups = "drop"
    )
  
  displayTable
})

output$data <- renderDataTable({
  table_data()
  
})

isolate reactive function for displaying selections and filters after action button

Answers (2)

Related Questions