Question

目标

我正在制作一个Shiny应用程序，允许用户上传自己的数据，并通过提供下图所示的数据过滤小部件来关注整个数据或子集选择输入＆＃34; 变量1 ＆＃34;将显示用户上传的数据的所有列名称和选择性输入＆＃34; 值＆＃34;将显示在＆＃34; 变量1 ＆＃34;中选择的相应列的所有唯一值。理想情况下，用户可以添加尽可能多的此类行（＆＃34; 变量X ＆＃34; +＆＃34; 值＆＃34;）可能通过某种触发器，一种可能性是点击＆＃34;添加更多＆＃34;动作按钮。

可能的解决方案

在网上查询后，我发现了Nick Carchedi贴在下面的一个很有希望的解决方案

ui.R

library(shiny)

shinyUI(pageWithSidebar(

    # Application title
    headerPanel("Dynamically append arbitrary number of inputs"),

    # Sidebar with a slider input for number of bins
    sidebarPanel(
        uiOutput("allInputs"),
        actionButton("appendInput", "Append Input")
    ),

    # Show a plot of the generated distribution
    mainPanel(
        p("The crux of the problem is to dynamically add an arbitrary number of inputs
          without resetting the values of existing inputs each time a new input is added.
          For example, add a new input, set the new input's value to Option 2, then add
          another input. Note that the value of the first input resets to Option 1."),

        p("I suppose one hack would be to store the values of all existing inputs prior
          to adding a new input. Then,", code("updateSelectInput()"), "could be used to 
          return inputs to their previously set values, but I'm wondering if there is a 
          more efficient method of doing this.")
    )
))

server.R

library(shiny)

shinyServer(function(input, output) {

    # Initialize list of inputs
    inputTagList <- tagList()

    output$allInputs <- renderUI({
        # Get value of button, which represents number of times pressed
        # (i.e. number of inputs added)
        i <- input$appendInput
        # Return if button not pressed yet
        if(is.null(i) || i < 1) return()
        # Define unique input id and label
        newInputId <- paste0("input", i)
        newInputLabel <- paste("Input", i)
        # Define new input
        newInput <- selectInput(newInputId, newInputLabel,
                                c("Option 1", "Option 2", "Option 3"))
        # Append new input to list of existing inputs
        inputTagList <<- tagAppendChild(inputTagList, newInput)
        # Return updated list of inputs
        inputTagList
    })

})

缺点

正如Nick Carchedi本人指出的那样，每次添加新的小部件时，所有现有的输入小部件都会被重置。

Shiny

中数据子集化/过滤的有希望的解决方案

根据warmoverflow的建议，DT包中的datatable函数提供了一种很好的方法来过滤Shiny中的数据。请参阅下面的启用数据过滤的最小示例。

library(shiny)
shinyApp(
    ui = fluidPage(DT::dataTableOutput('tbl')),
    server = function(input, output) {
        output$tbl = DT::renderDataTable(
            iris, filter = 'top', options = list(autoWidth = TRUE)
        )
    }
)

如果您打算在Shiny应用中使用它，有一些值得注意的重要方面。

过滤框类型
- 对于数字/日期/时间列：范围滑块用于过滤范围
- 对于因子列：选择性输入用于显示所有可能的类别
- 对于字符列：使用普通搜索框
如何获取过滤后的数据
- 假设表输出标识为tableId，使用input$tableId_rows_all作为所有页面上行的索引（在表格被搜索字符串过滤后）。 请注意，input$tableId_rows_all会返回DT所有页面上的行索引（＆gt; = 0.1.26）。如果您使用常规install.packages('DT')的DT版本，则仅返回当前页面的索引
- 要安装 DT （＆gt; = 0.1.26），请参阅其GitHub page
列宽
- 如果数据包含多列，则列宽和过滤框宽度会变窄，这使得很难将文本视为报告here

还有待解决

尽管存在一些已知问题，DT包中的datatable仍然是Shiny中数据子集的有希望的解决方案。然而，问题本身，即如何在Shiny中动态附加任意数量的输入小部件是有趣且具有挑战性的。在人们找到解决问题的好方法之前，我会打开这个问题：）

谢谢！

Answer 1

如果您要在Shiny Module中查找数据子集/过滤器：

软件包filterData中的

shinytools可以完成工作。它以call的形式返回表达式，但也可以返回数据（如果您的数据集不太大）。

library(shiny)
# remotes::install_github("ardata-fr/shinytools")
library(shinytools)

ui <- fluidPage(
  fluidRow(
    column(
      3,
      filterDataUI(id = "ex"),
      actionButton("AB", label = "Apply filters")
    ),
    column(
      3,
      tags$strong("Expression"),
      verbatimTextOutput("expression"),
      tags$br(),
      DT::dataTableOutput("DT")
    )
  )
)

server <- function(input, output) {

  x <- reactive({iris})

  res <- callModule(module = filterDataServer, id = "ex", x = x, return_data = FALSE)

  output$expression <- renderPrint({
    print(res$expr)
  })

  output$DT <- DT::renderDataTable({
    datatable(data_filtered())
  })

  data_filtered <- eventReactive(input$AB, {
    filters <- eval(expr = res$expr, envir = x())
    x()[filters,]

  })
}

shinyApp(ui, server)

您还可以使用lazyeval或rlang来计算表达式：

filters <- lazyeval::lazy_eval(res$expr, data = x())
filters <- rlang::eval_tidy(res$expr, data = x())

Answer 2

您是否正在寻找类似的东西？

library(shiny)


LHSchoices <- c("X1", "X2", "X3", "X4")


#------------------------------------------------------------------------------#

# MODULE UI ----
variablesUI <- function(id, number) {

  ns <- NS(id)

  tagList(
    fluidRow(
      column(6,
             selectInput(ns("variable"),
                         paste0("Select Variable ", number),
                         choices = c("Choose" = "", LHSchoices)
             )
      ),

      column(6,
             numericInput(ns("value.variable"),
                          label = paste0("Value ", number),
                          value = 0, min = 0
             )
      )
    )
  )

}

#------------------------------------------------------------------------------#

# MODULE SERVER ----

variables <- function(input, output, session, variable.number){
  reactive({

    req(input$variable, input$value.variable)

    # Create Pair: variable and its value
    df <- data.frame(
      "variable.number" = variable.number,
      "variable" = input$variable,
      "value" = input$value.variable,
      stringsAsFactors = FALSE
    )

    return(df)

  })
}

#------------------------------------------------------------------------------#

# Shiny UI ----

ui <- fixedPage(
  verbatimTextOutput("test1"),
  tableOutput("test2"),
  variablesUI("var1", 1),
  h5(""),
  actionButton("insertBtn", "Add another line")

)

# Shiny Server ----

server <- function(input, output) {

  add.variable <- reactiveValues()

  add.variable$df <- data.frame("variable.number" = numeric(0),
                                "variable" = character(0),
                                "value" = numeric(0),
                                stringsAsFactors = FALSE)

  var1 <- callModule(variables, paste0("var", 1), 1)

  observe(add.variable$df[1, ] <- var1())

  observeEvent(input$insertBtn, {

    btn <- sum(input$insertBtn, 1)

    insertUI(
      selector = "h5",
      where = "beforeEnd",
      ui = tagList(
        variablesUI(paste0("var", btn), btn)
      )
    )

    newline <- callModule(variables, paste0("var", btn), btn)

    observeEvent(newline(), {
      add.variable$df[btn, ] <- newline()
    })

  })

  output$test1 <- renderPrint({
    print(add.variable$df)
  })

  output$test2 <- renderTable({
    add.variable$df
  })

}

#------------------------------------------------------------------------------#

shinyApp(ui, server)

Answer 3

您需要检查现有的输入值，并在可用时使用它们：

  # Prevent dynamic inputs from resetting
  newInputValue <- "Option 1"
  if (newInputId %in% names(input)) {
    newInputValue <- input[[newInputId]]
  }
  # Define new input
  newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)

要点的工作版本（无重置问题）可以在这里找到：https://gist.github.com/motin/0d0ed0d98fb423dbcb95c2760cda3a30

复制如下：

ui.R

library(shiny)

shinyUI(pageWithSidebar(

  # Application title
  headerPanel("Dynamically append arbitrary number of inputs"),

  # Sidebar with a slider input for number of bins
  sidebarPanel(
    uiOutput("allInputs"),
    actionButton("appendInput", "Append Input")
  ),

  # Show a plot of the generated distribution
  mainPanel(
    p("This shows how to add an arbitrary number of inputs
      without resetting the values of existing inputs each time a new input is added.
      For example, add a new input, set the new input's value to Option 2, then add
      another input. Note that the value of the first input does not reset to Option 1.")
  )
))

server.R

图书馆（闪亮）

shinyServer(function(input, output) {

  output$allInputs <- renderUI({
    # Get value of button, which represents number of times pressed (i.e. number of inputs added)
    inputsToShow <- input$appendInput
    # Return if button not pressed yet
    if(is.null(inputsToShow) || inputsToShow < 1) return()
    # Initialize list of inputs
    inputTagList <- tagList()
    # Populate the list of inputs
    lapply(1:inputsToShow,function(i){
      # Define unique input id and label
      newInputId <- paste0("input", i)
      newInputLabel <- paste("Input", i)
      # Prevent dynamic inputs from resetting
      newInputValue <- "Option 1"
      if (newInputId %in% names(input)) {
        newInputValue <- input[[newInputId]]
      }
      # Define new input
      newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)
      # Append new input to list of existing inputs
      inputTagList <<- tagAppendChild(inputTagList, newInput)
    })
    # Return updated list of inputs
    inputTagList
  })

})

（该解决方案基于Nick's hints in the original gist from where you got the code of the promising solution）

Answer 4

现在，我认为我对问题更了解了。

假设用户选择了datasets::airquality数据集（此处，我仅显示前10行）：

“选择变量1”字段根据所述数据集的列名显示所有可能的变量：

然后，用户选择条件和值以通过以下方式过滤数据集：

然后，我们要添加第二个过滤器（仍保持第一个过滤器）：

最后，我们得到按以下两个条件过滤的数据集：

如果我们要添加第三个过滤器：

您可以继续添加过滤器，直到用完数据为止。

您还可以更改条件以适应因素或字符变量。您所需要做的就是将selectInput和numericInput更改为所需的内容。

如果这是您想要的，我已经使用模块并通过创建一个包含所有选择（变量+条件+值）的reactValue（tmpFilters）来解决了它。从中，我创建了一个包含所有过滤器（tmpList）的列表，并从中创建了适用于tmpListFilters的适当过滤器（subset）。

之所以可行，是因为最终数据集“恒定地”是此reactValue（tmpFilters）的子集。首先，tmpFilters为空，因此我们得到了原始数据集。每当用户添加第一个过滤器（之后添加其他过滤器）时，此reactValue都会更新，数据集也会更新。

这是它的代码：

library(shiny)

# > MODULE #####################################################################

## |__ MODULE UI ===============================================================

variablesUI <- function(id, number, LHSchoices) {
  
  ns <- NS(id)
  
  tagList(
    fluidRow(
      column(
        width = 4,
        selectInput(
          inputId = ns("variable"),
          label   = paste0("Select Variable ", number),
          choices = c("Choose" = "", LHSchoices)
        )
      ),
      
      column(
        width = 4,
        selectInput(
          inputId = ns("condition"),
          label   = paste0("Select condition ", number),
          choices = c("Choose" = "", c("==", "!=", ">", ">=", "<", "<="))
        )
      ),
      
      column(
        width = 4,
        numericInput(
          inputId = ns("value.variable"),
          label   = paste0("Value ", number),
          value   = NA, 
          min     = 0
        )
      )
    )
  )
}

## |__ MODULE SERVER ===========================================================

filter <- function(input, output, session){
  reactive({
    
    req(input$variable, input$condition, input$value.variable)

    fullFilter <- paste0(
      input$variable,
      input$condition, 
      input$value.variable
    )
    
    return(fullFilter)
    
  })
}

# Shiny ########################################################################

## |__ UI ======================================================================

ui <- fixedPage(
  fixedRow(
    column(
      width = 5,
      selectInput(
        inputId = "userDataset",
        label   = paste0("Select dataset"),
        choices = c("Choose" = "", ls("package:datasets"))
      ),
      h5(""),
      actionButton("insertBtn", "Add another filter")
    ),
    column(
      width = 7, 
      tableOutput("finalTable")
    )
  )
)

## |__ Server ==================================================================

server <- function(input, output) {
  
  ### \__ Get dataset from user selection ------------------------------------
  
  originalDF <- reactive({
    
    req(input$userDataset)
    
    tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
    
    if (!class(tmpData) == "data.frame") {
      stop("Please select a dataset of class data.frame")
    }
    
    tmpData
    
  })
  
  ### \__ Get the column names -----------------------------------------------
  
  columnNames <- reactive({
    
    req(input$userDataset)
    
    tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
    
    names(tmpData)  
      
  })
  
  ### \__ Create Reactive Filter ---------------------------------------------
  
  tmpFilters <- reactiveValues()
  
  ### \__ First UI Element ---------------------------------------------------
  ### Add first UI element with column names
  
  observeEvent(input$userDataset, {
    insertUI(
      selector = "h5",
      where    = "beforeEnd",
      ui       = tagList(variablesUI(paste0("var", 1), 1, columnNames()))
    )
  })
  
  ### Update Reactive Filter with first filter
  
  filter01 <- callModule(filter, paste0("var", 1))
  
  observe(tmpFilters[['1']] <- filter01())
  
  ### \__ Other UI Elements --------------------------------------------------
  ### Add other UI elements with column names and update the filter 
  
  observeEvent(input$insertBtn, {
    
    btn <- sum(input$insertBtn, 1)
    
    insertUI(
      selector = "h5",
      where    = "beforeEnd",
      ui       = tagList(variablesUI(paste0("var", btn), btn, columnNames()))
    )
    
    newFilter <- callModule(filter, paste0("var", btn))
    
    observeEvent(newFilter(), {
      tmpFilters[[paste0("'", btn, "'")]] <- newFilter()
    })
    
  })
  
  ### \__ Dataset with Filtered Results --------------------------------------
  
  resultsFiltered <- reactive({
    
    req(filter01())
    
    tmpDF <- originalDF()
    
    tmpList <- reactiveValuesToList(tmpFilters)
    
    if (length(tmpList) > 1) {
      tmpListFilters <- paste(tmpList, "", collapse = "& ")
    } else {
      tmpListFilters <- unlist(tmpList)
    }
    
    tmpResult <- subset(tmpDF, eval(parse(text = tmpListFilters)))
    
    tmpResult
    
  })
  
  ### \__ Print the Dataset with Filtered Results ----------------------------
  
  output$finalTable <- renderTable({
    
    req(input$userDataset)
    
    if (is.null(tmpFilters[['1']])) {
      head(originalDF(), 10)
      
    } else {
      head(resultsFiltered(), 10)
    }

  })
}

#------------------------------------------------------------------------------#
shinyApp(ui, server)

# End

R Shiny：如何动态附加任意数量的输入小部件

目标

可能的解决方案

缺点

Shiny

还有待解决

4 个答案: