Dplyr Pivot Table RShiny

Question

Here's an example RShiny app using the dataset starwars from the dplyr library in R. It produces a pivot table where an end-user would be able to select as many 'dimension(s)', 'measure(s)', and 'aggregate function(s)' they want and it produces a resulting dataset accordingly.

However, I am running into the problem with the 'aggregate function' isn't working properly when testing out the RShiny app. The problem should be where the pivotData dataframe is defined. At the summarize_at dplyr chain, the object funsList is called out from its previous assignment of input$funChoices. However this doesn't work and produces and error.

Code below:

pivotData <- reactive({
    input$runit
    isolate({
      measuresVec <- input$measures
      dimensionsVec <- input$dimensions
      funsList <- input$funChoices
      
      pivotData <- data %>%
        group_by_at(vars(dimensionsVec)) %>%
        summarize_at(vars(measuresVec), funsList , na.rm = TRUE)
    })
    
    return(pivotData)
    
  })

If you substitute funsList to the functions object defined at the very beginning, you will see that the first two inputs (dimensions and measures) work. However, the number of functions is obviously predefined in the RShiny app and will automatically be displayed accordingly without the end-user getting that opportunity.

Ideally, the total number of columns should equal (# of Dimensions) + (# of Measures * # of Functions)

Any help would be greatly appreciated! Thanks so much!

Entire Code snippet below:

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

ui <- function(request) {
  dashboardPage(
    dashboardHeader(title = "SW Pivot"),
    dashboardSidebar(
      actionButton("runit", "RUN QUERY"),
      hr(),
      
      h4(HTML("&nbsp"), "Select Table Rows"),
      uiOutput('rowSelect'),
      hr(),
      h4(HTML("&nbsp"), "Select Table Columns"),
      uiOutput('colSelect'),
      hr(),
      h4(HTML("&nbsp"), "Select Table Cell Fill"),
      uiOutput('aggSelect'),
      hr()
      
    ),
    dashboardBody(dataTableOutput("data"))
    
  )
}

data <- starwars

server<-shinyServer(function(input, output, session) {
  
  # Identify Measures, Dimensions, and Functions --------------
  
  dimensions <- colnames(data)[!sapply(data, is.numeric)]
  measures <- colnames(data)[sapply(data, is.numeric)]
  functions <- list( mean = mean, 
                     sum = sum, 
                     max = max, 
                     min = min)
  
  # functions <- as.vector(unlist(functions))
  
  output$rowSelect <- renderUI({
    selectizeInput(
      inputId = "dimensions",
      label = NULL,
      multiple = TRUE,
      choices = dimensions,
      selected = c()
    )
  })
  
  output$colSelect <- renderUI({
    selectizeInput(
      inputId = "measures",
      label = NULL,
      multiple = TRUE,
      choices = measures,
      selected = c()
    )
  })
  
  output$aggSelect <- renderUI({
    selectizeInput(
      inputId = "funChoices",
      label = NULL,
      multiple = TRUE,
      choices = functions,
      selected = c()
    )
  })
  
  pivotData <- reactive({
    input$runit
    isolate({
      measuresVec <- input$measures
      dimensionsVec <- input$dimensions
      funsList <- input$funChoices
      
      pivotData <- data %>%
        group_by_at(vars(dimensionsVec)) %>%
        summarize_at(vars(measuresVec), functions, na.rm = TRUE)
    })
    
    return(pivotData)
    
  })
  
  output$data <- renderDataTable({
      tabledata <- pivotData()
      datatable(tabledata)
  })
  
})

shinyApp(ui, server)

Answer 1

The functions don't get properly stored when you define the function list. It is easier to just choose the string name of the function and later use match.fun to get the actual function.

A few things I've noticed:

• I've updated your dplyr code to 1.0.0 with across
• you get a faster UI when you don't use renderUI but use observeEvent/updateXInput when some variables change

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

ui <- function(request) {
  dashboardPage(
    dashboardHeader(title = "SW Pivot"),
    dashboardSidebar(
      actionButton("runit", "RUN QUERY"),
      hr(),
      
      h4(HTML("&nbsp"), "Select Table Rows"),
      uiOutput('rowSelect'),
      hr(),
      h4(HTML("&nbsp"), "Select Table Columns"),
      uiOutput('colSelect'),
      hr(),
      h4(HTML("&nbsp"), "Select Table Cell Fill"),
      uiOutput('aggSelect'),
      hr()
      
    ),
    dashboardBody(dataTableOutput("data"))
    
  )
}

data <- starwars

server<-shinyServer(function(input, output, session) {
  
  # Identify Measures, Dimensions, and Functions --------------
  
  dimensions <- colnames(data)[!sapply(data, is.numeric)]
  measures <- colnames(data)[sapply(data, is.numeric)]
  functions_string <- c("mean", "sum", "max", "min")
  
  # functions <- as.vector(unlist(functions))
  
  output$rowSelect <- renderUI({
    selectizeInput(
      inputId = "dimensions",
      label = NULL,
      multiple = TRUE,
      choices = dimensions,
      selected = c()
    )
  })
  
  output$colSelect <- renderUI({
    selectizeInput(
      inputId = "measures",
      label = NULL,
      multiple = TRUE,
      choices = measures,
      selected = c()
    )
  })
  
  output$aggSelect <- renderUI({
    selectizeInput(
      inputId = "funChoices",
      label = NULL,
      multiple = TRUE,
      choices = functions_string,
      selected = c()
    )
  })
  
  pivotData <- eventReactive(input$runit, {
    measuresVec <- input$measures
    dimensionsVec <- input$dimensions
    
    fun_list <- lapply(input$funChoices, match.fun)
    names(fun_list) <- input$funChoices
    pivotData <- data %>%
      group_by(across(all_of(dimensionsVec))) %>%
      summarize(across(all_of(measuresVec), fun_list, na.rm = TRUE))
    
    return(pivotData)
    
  })
  
  output$data <- renderDataTable({
    tabledata <- pivotData()
    datatable(tabledata)
  })
  
})

shinyApp(ui, server)