reactiveValuesToList 的行为不符合预期

Question

我希望reactiveValuesToList() 返回一个普通的 ol' 列表，但似乎我必须在开始我的业务之前触发存储在结果对象中的反应式表达式。是否有一个原因？我是不是对函数有误解？

在这种特殊情况下，我想知道为什么获取vals2 的第一种方法不起作用，我必须立即使用解决方法。它抛出错误消息Error in : 'match' requires vector arguments。

#' Packages
#' ================================================================= #

load_pkgs <- function(pkgs){
  #' Loads a list of packages, installing them if not already
  #' installed pkgs is a vector of package names as strings
  #' =============================================================== #
  for(pkg in pkgs){
    if(!(require(pkg, character.only = TRUE))){
      install.packages(pkg)
      library(pkg, character.only = TRUE)
    }
  }
}

load_pkgs(
  c('bit64', 'data.table', 'magrittr', 'shiny', 'shinydashboard',
    'shinyWidgets')
)

#' Data
#' ================================================================= #

dataset <- data.table(
  sample(letters, size = 1000, replace = T),
  sample(LETTERS, size = 1000, replace = T),
  sample.int(10, size = 1000, replace = T)
)

#' Functions
#' ================================================================= #

subsel <- function(x, sub, sel = NULL,
                   nomatch = getOption('datatable.nomatch')){
  #' function to subset a data.table (x) using a named list (sub). sel
  #' can be used to return only the specified columns. algorithms
  #' copied from https://stackoverflow.com/questions/55728200/subsetting-a-data-table-based-on-a-named-list
  #' and cutoff decided on some ad hoc testing.
  if(is.null(sel)) sel <- names(x)
  if(x[, .N] < 200000L){
    return(
      x[
        do.call(
          pmin,
          Map(`%in%`, x[, .SD, .SDcols = names(sub)], sub)
        ) == 1L,
        .SD,
        .SDcols = sel,
        nomatch = nomatch
        ]
    )
  } else {
    return(
      x[
        do.call(CJ, sub),
        .SD,
        .SDcols = sel,
        on = names(sub),
        nomatch = nomatch
        ]
    )
  }
}

excelStyleFilterUI <- function(field, dataset){
  #' server for filter on one variable
  #' args -
  #' - field - character string naming field in dataset
  #' - dataset - base dataset
  #' =============================================================== #
  nm <- paste0('filter_', field)
  ns <- NS(nm)
  vals <- dataset[, sort(unique(get(field)))]
  pickerInput(
    inputId = ns('filter'),
    choices = vals,
    selected = vals,
    options = pickerOptions(
      actionsBox = TRUE,
      selectedTextFormat = 'count',
      virtualScroll = TRUE,
      dropupAuto = F,
      liveSearch = TRUE,
      dropdownAlignRight = 'auto'
    ),
    multiple = T
  )
}

excelStyleFilterServer <- function(field, dataset){
  #' server for filter on one variable
  #' args -
  #' - field - character string naming field in dataset
  #' - dataset - reactive, filtered version of dataset
  #' =============================================================== #
  nm <- paste0('filter_', field)
  moduleServer(
    nm,
    function(input, output, session){
      # observer to update selection with allowable choices
      observeEvent(
        dataset(),
        {
          updatePickerInput(
            session = session,
            inputId = 'filter',
            selected = dataset()[, sort(unique(get(field)))]
          )
        }
      )
      
      return(reactive({ input$filter }))
    }
  )
}

#' App
#' ================================================================= #

ui <- dashboardPage(
  dashboardHeader(disable = T),
  dashboardSidebar(
    sidebarMenu(
      actionButton('apply', label = 'Apply')
    )
  ),
  dashboardBody(
    fluidRow(
      box(
        title = 'letters filter',
        excelStyleFilterUI('V1', dataset = dataset),
        width = 4
      ),
      box(
        title = 'LETTERS filter',
        excelStyleFilterUI('V2', dataset = dataset),
        width = 4
      ),
      box(
        title = 'numbers filter',
        excelStyleFilterUI('V3', dataset = dataset),
        width = 4
      )
    ),
    box(
      title = 'Dataset',
      tableOutput('tab')
    )
  )
)

server <- function(input, output, session){
  # reactive, filtered version of dataset
    # initial version of filter vectors
  vals <- reactiveValues()
    # reactive code
  filterset <- eventReactive(
    {
      input$apply
    },
    {
      # vals2 <- isolate(reactiveValuesToList(vals)) # Why doesn't this work below?
      
      vals2 <- lapply(
        names(vals),
        function(x) vals[[x]]()
      )
      names(vals2) <- names(vals)
      
      subsel(dataset, vals2)
    }
  )
  
  # pickers + filter values
  vals[['V1']] <- excelStyleFilterServer('V1', filterset)
  vals[['V2']] <- excelStyleFilterServer('V2', filterset)
  vals[['V3']] <- excelStyleFilterServer('V3', filterset)
  
  # table output
  output$tab <- renderTable({
    filterset()
  })
}

shinyApp(ui, server)

Answer 1

问题是您的vals 是一个reactiveValues 对象，其中包含reactive 对象。 reactiveValuesToList 实际上将您的reactiveValues 对象转换为一个列表，其中仍然包含reactives。也就是说，您必须“调用”它们才能获得它们的价值（例如 vals[[1]]()）。

事实上，你并不真的需要 vals 本身具有响应性，除非你想添加一些逻辑来响应 ive（双关语）添加了一个新元素。

将vals <- reactiveValues() 替换为vals <- list() 也同样有效（并减少了一些小开销）。

无论您决定什么，在某些时候您都必须遍历vals 的reactive 元素并检索它们的值。

因此，我会这样写你的服务器：

server <- function(input, output, session){
   vals <- list() # can also be changed to reactiveValues()...
   # reactive code
   filterset <- eventReactive(
      {
         input$apply
      },
      {
         vals2 <- lapply( 
            # ...however the implicit transformation to a list here 
            # is better done explicitly in this case 
            # reactiveValuesToList(vals)
            vals, 
            function(x) x()
         )
         
         subsel(dataset, vals2)
      }
   )
   
   # pickers + filter values
   vals[['V1']] <- excelStyleFilterServer('V1', filterset)
   vals[['V2']] <- excelStyleFilterServer('V2', filterset)
   vals[['V3']] <- excelStyleFilterServer('V3', filterset)
   
   # table output
   output$tab <- renderTable({
      filterset()
   })
}

---

奖励答案

您应该将box 与表格放在fluidRow 中以避免内容溢出框：

fluidRow(
   box(
         title = 'Dataset',
         tableOutput('tab')
      )
)