R Shiny中的下限和上限的多个滤波器

Question

所有这些代码都改编自Shiny - dynamic data filters using insertUI。

我目前正在使用R Shiny代码，该代码应该允许创建多个过滤器（与Shiny服务器允许的数量一样多）。

每个过滤器包括要过滤的变量的选择，上限，下限，以及是否仅通过采用上限和下限之间的值（即，lwr <x <upr）或相反的值来过滤值（即x <lwr∪x> upr）。我已将相关代码编译成与此问题特别相关的代码。

源代码（简化代码）如下：

library(shiny)
library(ggplot2)

# Column names of file.
logColumns <- names(read.csv("file.csv"))

ui <- fluidPage(

   titlePanel("Testing Filters"),

   sidebarLayout(
      sidebarPanel(
        # Data type to display as Y value in graph.
        selectInput("display", label = "Data Type", choice = logColumns),

        # Button to activate addFilter actions.
        fluidRow(
          column(6, actionButton('addFilter', "Add Filter")),
          offset=6
        ),
        tags$hr(),
        # Area to generate new filters.
        tags$div(id='filters'),
        width = 4
      ),

      mainPanel(
         # Displays plot.
         plotOutput("distPlot")
      )
   )
)

server <- function(input, output, session) {
  # File to use.
  usefile <- reactive({
    # Placeholder code, does basic file reading for now.
    # Basic (unedited) file format is time (in milliseconds) in first column
    # followed by other columns with different types of data, e.g., voltage.
    usefile <- read.csv("file.csv", header=TRUE)
    usefile$time <- usefile$time / 1000
    usefile
  })
  # Column names of above file.
  logNames <- reactive({
    names(usefile())
  })

  # Turns aggregFilterObserver into a reactive list.
  makeReactiveBinding("aggregFilterObserver")
  aggregFilterObserver <- list()

  observeEvent(input$addFilter, {

    # Generates unique IDs for each filter.
    add <- input$addFilter
    filterId <- paste0('filter', add)
    colFilter <- paste0('colFilter', add)
    lwrBoundNum <- paste0('lowerBound', add)
    uprBoundNum <- paste0('upperBound', add)
    removeFilter <- paste0('removeFilter', add)
    exclusivity <- paste0('exclusivity', add)

    # Dictates which items are in each generated filter, 
    #   and where each new UI element is generated.
    insertUI(
      selector = '#filters',
      ui = tags$div(id = filterId,
                    actionButton(removeFilter, label = "Remove filter", style = "float: right;"),
                    selectInput(colFilter, label = paste("Filter", add), choices = logNames()),
                    numericInput(lwrBoundNum, label = "Lower Bound", value=0, width = 4000),
                    numericInput(uprBoundNum, label = "Upper Bound", value=0, width = 4000),
                    checkboxInput(exclusivity, label = "Within Boundaries?", value=TRUE)
      )
    )

    # Generates a filter and updates min/max values.
    observeEvent(input[[colFilter]], {

      # Selects a data type to filter by.
      filteredCol <- usefile()[[input[[colFilter]]]]

      # Updates min and max values for lower and upper bounds.
      updateNumericInput(session, lwrBoundNum, min=min(filteredCol), max=max(filteredCol))
      updateNumericInput(session, uprBoundNum, min=min(filteredCol), max=max(filteredCol))

      # Stores data type to filter with in col, and nulls rows.
      aggregFilterObserver[[filterId]]$col <<- input[[colFilter]]
      aggregFilterObserver[[filterId]]$rows <<- NULL
    })

    # Creates boolean vector by which to filter data.
    observeEvent(c(input[[lwrBoundNum]], input[[uprBoundNum]], input[[colFilter]], input[[exclusivity]]), {
      # Takes only data between lower and upper bound (inclusive), or
      if (input[[exclusivity]]){
        rows <- usefile()[[input[[colFilter]]]] >= input[[lwrBoundNum]]
        rows <- "&"(rows, usefile()[[input[[colFilter]]]] <= input[[uprBoundNum]])
      }
      # Takes only data NOT between lower and upper bounds (inclusive).
      else{
        rows <- usefile()[[input[[colFilter]]]] < input[[lwrBoundNum]]
        rows <- "|"(rows, usefile()[[input[[colFilter]]]] > input[[uprBoundNum]])
      }

      aggregFilterObserver[[filterId]]$rows <<- rows
    })

    # Removes filter.
    observeEvent(input[[removeFilter]], {
      # Deletes UI object...
      removeUI(selector = paste0('#', filterId))

      # and nulls the respective vectors in aggregFilterObserver.
      aggregFilterObserver[[filterId]] <<- NULL
    })
  })

  # Filters data based on boolean vectors contained in aggregFitlerObserver
  adjusted <- reactive({
    toAdjust <- rep(TRUE,nrow(usefile()))
    lapply(aggregFilterObserver, function(filter){
      toAdjust <- "&"(toAdjust, filter$rows)
    })
    subset(usefile(), toAdjust)
  })

  # Creates plot based on filtered data and selected data type
  output$distPlot <- renderPlot({
    xData <- adjusted()$time
    yData <- adjusted()[[input$display]]
    curData <- data.frame(xData, yData)
    plot <- ggplot(data=curData, aes(x=xData, y=yData)) + geom_point() + labs(x = "Time (seconds)", y = input$display)
    plot
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

我的问题是通过布尔向量进行子集化不起作用 - 即，过滤器根本没有任何效果。

另外，我不太清楚应该如何应用上限和下限的措辞和变量名称（即“内部边界？”按钮和exclusivity变量）。如果可以使用更好（尽管仍然简洁）的措辞，我也会对此有所帮助。

任何输入都表示赞赏。

编辑：用我当前的答案修复我的代码后，我意识到[修复] adjusted()所拥有的代码并不完全是我想要的，而且我误解了lapply实际上做了什么。我一直在尝试将多个逻辑向量编译成一个，这是通过执行以下操作实现的：

adjusted <- reactive({
  toAdjust <- rep(TRUE,nrow(usefile()))
  for (filter in aggregFilterObserver){
    toAdjust <- "&"(toAdjust, filter$rows)
  }
  if (length(toAdjust) == 0){
    usefile()
  } else {
    subset(usefile(), toAdjust)
  }
})

感谢您的帮助！

Answer 1

问题来自于您从未存储过滤结果。定义adjusted时，永远不会存储lapply的结果。

# Filters data based on boolean vectors contained in aggregFitlerObserver
adjusted <- reactive({
  toAdjust <- rep(TRUE,nrow(usefile()))
  tmp <- lapply(aggregFilterObserver, function(filter){
           toAdjust <- "&"(toAdjust, filter$rows)
         })
  if (length(tmp$filter1) == 0) {
    return(usefile())
  } else {
    subset(usefile(), tmp$filter1)
  }
})

条件length(tmp$filter1) == 0用于防止在没有过滤器时过滤所有行。