【发布时间】：2016-12-21 17:29:45
【问题描述】：
我正在开发一个应用程序，它允许用户向 UI 动态添加新的 selectInput 框，我希望所有这些 selectInput 框都将数据集的列名作为他们的“选择”。数据集也应该是用户选择的，这就是为什么我让 selectInput 选择对数据集选择的变化做出反应。
这听起来很简单，但我似乎无法让它正常工作。当我第一次打开应用程序时，第一个 selectInput 是空的；这没关系，因为我希望用户能够上传他们自己的数据集，所以默认数据集无论如何都是 NULL（这里使用预加载的数据集以实现可重复性，因此略有不同）。
我从下拉选择框中选择了一个（不同的）数据集“iris”，“iris”数据集的列名会自动加载到 selectInput 框中（表 1）。这可以根据需要完美地工作。
接下来，我通过单击表 1 上的加号添加一个新的 selectInput 框，它旁边会出现一个新的 selectInput 框（表 2）。
这就是问题所在：我希望新创建的子 selectInput 框自动使用数据集的列名，但我不知道该怎么做。填充新的 selectInput 框的唯一方法是再次更改数据集选择，这是不可取的。
这是本例中使用的代码：
library(shiny)
library(datasets)
server <- function(input, output, session) {
### FUNCTIONS ###
newNode <- function(id, parentId) {
node <- list(
parent = parentId,
children = list()
)
# Create the UI for this node
createSliceBox(id, parentId)
return(node)
}
createSliceBox <- function(id, parentId) {
# Div names
containerDivID <- paste0('container',id,'_div')
nodeDivID <- paste0('node',id,'_div')
childrenDivID <- paste0('children',id,'_div')
if (parentId == 0) { # Root node case
parentDivID <- 'allSliceBoxes'
} else {
parentDivID <- paste0('children',parentId,'_div')
}
# Input names
selectID <- paste0("sliceBoxSelect", id)
buttonID <- paste0("sliceBoxButton", id)
# Insert the UI element for the node under the parent's children_div
insertUI(
selector = paste0('#',parentDivID),
where = 'afterBegin',
ui = tagList(
tags$div(id=containerDivID, style='float:left',
tags$div(id=nodeDivID, style='float:left; margin: 5px; min-width:250px',
actionButton(buttonID, "",
icon("plus-circle fa-1x"), style="float:right; border:none; color:#00bc8c; background-color:rgba(0,0,0,0)"),
wellPanel(class="well well-sm",
selectInput(selectID, paste0("Table ", id, ", child of ", parentId, "."), c(''), multiple=FALSE)
)
),
tags$div(id=childrenDivID, style='float:left') # Container for children, starts empty
),
tags$br('')
)
)
# Observer for selectors
observe(
updateSelectInput(session, selectID, choices=names(d.Preview()) ) # Doesn't work as expected?
)
}
### CODE STARTS HERE
tags$head(tags$script(src="https://use.fontawesome.com/15c2608d79.js")) # Import FontAwesome for icons
# File upload
d.Preview <- reactive({
switch(input$dataset,
"mtcars" = mtcars,
"iris" = iris,
"esoph" = esoph)
})
# We'll store our nodes as a 1D list, so parent and child ID's are recorded as their indices in the list
sliceBox.data <- reactiveValues(display=list(), selected=list())
rootNode <- newNode(1, 0) # Page loads with NULL first node, before input is chosen
sliceBox.tree <- reactiveValues(tree=list(rootNode))
# Special case for loading data into first node, needs reactive parentData - not the case for children nodes
observeEvent(input$dataset, {
slice <- reactive({
sliceData(d.Preview(), input$sliceBoxSelect1)
})
# Creating data for the first node
sliceBox.data$display[[1]] <- reactive(slice())
sliceBox.data$selected[[1]] = reactive({
selectedRows <- input[[paste0("sliceBoxTable", 1, "_rows_selected")]]
filterData(d.Preview(), sliceBox.data$display[[1]](), selectedRows, input[[paste0("sliceBoxSelect",1)]])
})
})
# Keep a total count of all the button presses (also used loosely as the number of tables created)
v <- reactiveValues(counter = 1L)
# Every time v$counter is increased, create new handler for the new button at id=v$counter
observeEvent(v$counter, {
parentId <- v$counter
buttonID <- paste0("sliceBoxButton", parentId)
# Button handlers to create new sliceBoxes
observeEvent(input[[buttonID]], {
v$counter <- v$counter + 1L
childId <- v$counter
# Note that because the ObserveEvents are run separately on different triggers, (childId != parentId+1)
# Create new child
sliceBox.tree$tree[[childId]] <- newNode(childId, parentId)
# Append new childId to parent's list of children
numChildren <- length(sliceBox.tree$tree[[parentId]]$children)
sliceBox.tree$tree[[parentId]]$children[numChildren+1] <- childId
})
})
}
ui <- fluidPage(theme = "bootstrap.css",
# Main display body
fluidRow(style="padding:5px",
selectInput("dataset", "Choose a dataset:", choices = c("mtcars", "iris", "esoph"), selected=NULL),
tags$div(uiOutput("allSliceBoxes"), style="padding:20px")
)
)
shinyApp(ui = ui, server = server)
希望有人可以帮助解决这个问题，网上有很多关于 selectInput 的问题，但我还没有找到任何解决方案来解决我遇到的这个特定问题。
【问题讨论】：