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

Question

目标

我正在开发一个Shiny应用程序,允许用户上传自己的数据,并通过提供下图所描述的数据过滤小部件来关注整个数据或子集 选择输入" 变量1 "将显示用户上传的数据的所有列名称,并且选择性输入" 值 "将显示在" 变量1 "中选择的相应列的所有唯一值.理想情况下,用户可以通过某种触发器添加尽可能多的此类行(" 变量X "+" 值 "),一种可能是单击"添加更多"操作按钮.

可能的解决方案

网上通缉后,我发现给出一个可行的解决方案尼克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数据子集/过滤解决方案

正如hotoverflow所建议的那样,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应用程序中使用它,有一些值得注意的重要方面.

1. 过滤框类型
   • 对于数字/日期/时间列:范围滑块用于过滤范围内的行
   • 对于因子列:选择性输入用于显示所有可能的类别
   • 对于字符列:使用普通搜索框
2. 如何获取过滤后的数据
   • 假设表输出id是tableId,input$tableId_rows_all用作所有页面上的行索引(在表格被搜索字符串过滤之后).请注意,input$tableId_rows_all返回DT所有页面上的行索引(> = 0.1.26).如果您按常规使用DT版本,则install.packages('DT')仅返回当前页面的索引
   • 要安装DT(> = 0.1.26),请参阅其GitHub页面
3. 列宽
   • 如果数据有很多列,则列宽和过滤器框宽度将变窄,这使得很难在此处将文本视为报告

---

还有待解决

尽管存在一些已知问题,但datatable在DT包中,它仍然是Shiny中数据子集的一种有前景的解决方案.然而,问题本身,即如何在Shiny中动态附加任意数量的输入小部件是有趣且具有挑战性的.在人们找到解决问题的好方法之前,我会将这个问题保持开放:)

谢谢!

Answer 1

你在寻找这样的东西吗？

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)