R Shiny：如何动态附加任意数量的输入小部件
Posted
技术标签:
【中文标题】R Shiny：如何动态附加任意数量的输入小部件【英文标题】：R Shiny: How to dynamically append arbitrary number of input widgets 【发布时间】：2016-10-31 04:46:06 【问题描述】：目标
我正在开发一个 Shiny 应用程序，该应用程序允许用户上传自己的数据并通过提供下图描述的数据过滤小部件来关注整个数据或子集 select输入“Variable 1”会显示用户上传数据的所有列名，selectize输入“Value”会显示对应的所有唯一值在“变量 1”中选择的列。理想情况下，用户将能够通过某种触发器添加尽可能多的此类行（“Variable X”+“Value”），一种可能性是单击“添加更多”操作按钮。
一个可能的解决方案
在网上查了一下，发现下面贴了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 应用中使用它，有一些重要方面值得注意。
-
过滤箱型
对于数字/日期/时间列：范围滑块用于过滤范围内的行
对于因子列：选择输入用于显示所有可能的类别
对于字符列：使用普通搜索框
如何获取过滤后的数据
假设表输出id为
tableId，使用input$tableId_rows_all作为所有页面的行索引（在表被搜索字符串过滤后）。 请注意，input$tableId_rows_all 返回所有页面上 DT (>= 0.1.26) 的行索引。如果你通过常规install.packages('DT')使用DT版本，则只返回当前页面的索引
要安装DT (>= 0.1.26)，请参考其GitHub page
列宽
如果数据有很多列，列宽和过滤框宽度会变窄，导致很难看到文本作为报告here
还有待解决
尽管存在一些已知问题，DT 包中的datatable 仍是 Shiny 中数据子集化的有前途的解决方案。然而，问题本身，即如何在 Shiny 中动态附加任意数量的输入小部件，既有趣又具有挑战性。在人们找到解决问题的好方法之前，我将保留这个问题:)
谢谢！
【问题讨论】：
如果您预先创建了多个uiOutput，您可以将这些uiOutput 分别填充到您的输入小部件中，那么以前的小部件将不会被重置。限制是您将限制用户可以添加的最大输入。但由于您的输入取决于列数，我认为这不是问题。
不过，如果您使用具有过滤器和其他表格功能的现有解决方案，例如 DT rstudio.github.io/DT，则要容易得多。
@warmoverflow DT 看起来很棒。谢谢（你的）信息！是否可以返回过滤列的子集？
是的，您可以使用input$tbl_rows_all 来引用过滤结果（注意tbl 是您的表名，根据需要更改）。有关示例，请参见 ***.com/questions/30042456/…。
【参考方案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)
【讨论】：
您的解决方案非常好。但是我不明白它是如何工作的。 selectInput 的 ID 是可变的，但是有多个“变量”。在 variables 函数中，当编写“input$variable”时，我们如何知道使用了哪个 selectInput... 我可以看到它有效但我不明白为什么。你能解释一下吗？ 我还有一个问题：如何使LHSchoices动态化？例如，它可能取决于选项卡的选择。
@Xiaoshi 对于您的第一个问题，基本上“跟踪”是 NS() 函数（请参阅此处的命名空间：shiny.rstudio.com/articles/modules.html）。因此，当我在 variablesUI 中定义 NS(id) 并调用 variablesUI("var1", 1) 时，NS 接受 "var1" 并使用 ns("variable") 为该元素创建一个唯一的 html id（在这种情况下， html id 将是“var1-variable”）。当我调用 callModule(variables, paste0("var", 1), 1) 时，此 ID 将被传递到 'variables' 函数，因此 input$variable 将获取具有此 ID 的变量。至于你的第二个问题，开一个新的。
@Xiaoshi 我最终为这个问题写了另一个答案，它包含一个动态的 LHSchoices （现在我称之为 columnNames() ）。【参考方案2】：
如果您正在 Shiny 模块中寻找数据子集/过滤：
filterData from package 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())
【讨论】：
【参考方案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)
可以在此处找到 gist 的工作版本（没有重置问题）：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为指导）
【讨论】：
【参考方案4】：现在，我认为我更好地理解了这个问题。
假设用户选择datasets::airquality 数据集（这里，我只显示前 10 行）：
“选择变量 1”字段根据所述数据集的列名显示所有可能的变量：
然后，用户选择条件和值来过滤数据集：
然后，我们要添加第二个过滤器（仍然保持第一个）：
最后我们得到两个条件过滤的数据集：
如果我们要添加第三个过滤器：
您可以继续添加过滤器，直到数据用完为止。
您还可以更改条件以适应因素或字符变量。您需要做的就是将selectInput 和numericInput 更改为您想要的任何内容。
如果这是您想要的，我已经使用模块并通过创建一个包含所有选择（变量 + 条件 + 值）的 reactiveValue (tmpFilters) 来解决它。从中，我创建了一个包含所有过滤器 (tmpList) 的列表，并从中创建了与 subset 一起使用的正确过滤器 (tmpListFilters)。
这是可行的，因为最终数据集“始终”是该反应值（tmpFilters）的子集。一开始tmpFilters是空的，所以我们得到了原始数据集。每当用户添加第一个过滤器（以及之后的其他过滤器）时，这个 reactiveValue 就会更新，数据集也会更新。
这是它的代码：
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 中两个相关的 selectizeInput 小部件的反应式更新