在操作按钮后隔离用于显示选择和过滤器的反应功能

Question

我正在尝试使用 isolate 命令从 ui.R 文件中的以下代码创建一个 reactive 函数到 server.R 文件，其中数据 table 仅在用户输入他们的选择和过滤器后才会填充。

现在，数据 table 仅在运行过滤器和选择后自行填充，无需单击 Run Query 按钮。

如有任何帮助，我们将不胜感激！

actionButton("runit", "RUN QUERY")

非常感谢！

代码如下：

ui.R

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

ui <- function(request) {
  dashboardPage(
    dashboardHeader(title = "CL Pivot"),
    dashboardSidebar(
      actionButton("runit", "RUN QUERY"),
      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"),
      selectizeInput(
        inputId = "funChoices",
        label = NULL,
        multiple = FALSE,
        choices = c("Count", "Average", "Median", "Sum", "Maximum", "Minimum"),
        selected = c()
      ),
      hr(),
      h4(HTML("&nbsp"), "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)
    
  })
})

Answer 1

您需要 isolate() 所有不应触发事件的输入，您可以使用 req() 启用提交按钮：

  pairColFuns <- reactive({
    colChoices <- isolate(input$colChoices) #isolated
    names(colChoices) <- isolate(input$funChoices) #isolated
    
    return(colChoices)
  })
  
  # Construct DataFrame Based on User Inputs
  
  output$data <- renderDataTable({
    req(input$runit) # submit button should trigger
    colChoices <- pairColFuns()
    rowChoices <- isolate(input$rowChoices) #isolated
    
    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% isolate(input$hairColorChoices), #isolated
        skin_color %in% isolate(input$skinColorChoices) #isolated
    ...

Answer 2

我会拆分 table 渲染和数据处理，然后您可以使用 eventReactive 方法。这样可以节省您将每个输入包装到 isolate.

首先制作一个 eventReactive 来计算您的数据。它仅在第一个 reactive/input 更改时更新。然后你可以用它来渲染你的 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

r

function

shiny

reactive