Dplyr 数据透视表 R 闪亮

Question

这是一个示例 RShiny 应用程序，它使用 R 中 dplyr 库中的数据集 starwars。它会生成一个数据透视表，最终用户可以在其中选择尽可能多的“维度”、“测量( s)'和他们想要的'聚合函数'，并相应地生成结果数据集。

但是，在测试 RShiny 应用程序时，我遇到了“聚合函数”无法正常工作的问题。问题应该是定义pivotData 数据框的位置。在summarize_atdplyr 链中，对象funsList 从其先前的input$funChoices 分配中调用。但是，这不起作用并产生错误。

代码如下：

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)
    
  })

如果您将funsList 替换为一开始定义的functions 对象，您将看到前两个输入（维度和度量）有效。但是，功能的数量显然是在 RShiny 应用程序中预定义的，并且会自动相应地显示，而最终用户没有机会获得。

理想情况下，总列数应等于（维度数）+（度量数 * 函数数）

任何帮助将不胜感激！非常感谢！

下面的完整代码sn-p：

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

当您定义function 列表时，函数没有得到正确存储。选择函数的字符串名称，稍后使用match.fun 获取实际函数更容易。

我注意到的一些事情：

• 我已使用across 将您的dplyr 代码更新为1.0.0
• 如果不使用renderUI，但在某些变量发生变化时使用observeEvent/updateXInput，您会获得更快的用户界面

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)