在this帖子中，用户可以使用下拉列表从数据框中选择一列，使用一些复选框从该列中选择一些值进行比较，然后在同一帧中添加一个新列，以反映比较他们想做。
我意识到我需要更复杂的东西，用户可以从数据框中选择多个列并在数据框中生成类似的结果。以下是更复杂的决赛桌的说明。在此示例中，用户选择了Author.Name和Fav.Color列以查看并选择了填充值：Bob，Tom，Green，Red。然后，这将产生两个新列，一个将绿色与红色与鲍勃相比，另一个与汤姆相比较。
Project.ID Author.ID Author.Name Fav.Color Bob_GreenvRed Tom_GreenvRed
Test_Project1 1234 Bob Green Green NA
Test_Project1 2345 Jane Blue NA NA
Test_Project1 2687 Bob Blue NA NA
Test_Project1 8765 Tom Red NA Red
我修改了我的代码（如下所示），允许选择多个列和值，但似乎无法用列生成来解决“set”问题。我尽力从@Bertil Baron友好提供的答案中应用我的理解，但我还没有到那里。我认为这个问题存在于finalTable被动的某个地方。
server <- function(input, output, session) {
# update datatable
project <- reactive({
if(input$viewType == "Projects"){
projectDT <- read.table(header = TRUE,
text = "Project.ID,Author.ID,Author.Name,Fav.Color
Test_Project1,1234,Bob,Green
Test_Project1,2345,Jane,Blue
Test_Project1,2687,Bob,Blue
Test_Project1,8765,Tom,Red",
sep = ",")
#replace spaces with dots in headers
names(projectDT) <- gsub(" ", ".", names(projectDT))
projectDT
}
})
observeEvent({input$addCol},{
insertUI(
selector = "#addCol",
where = "afterEnd",
ui = div(
uiOutput(paste0("showMeta",input$addCol)),
uiOutput(paste0("showVal",input$addCol))
)
)
lapply(1:input$addCol, function(idx){ #apply for as many columns as you want
output[[paste0("showMeta",idx)]] <- renderUI({
selectInput(inputId = paste0("metalab",idx),
label = "Metadata Label:",
choices = c(" ", unique(as.vector(colnames(project())))),
selected = input[[paste0("metalab",idx)]],
multiple = TRUE,
selectize = TRUE
)
})
})
lapply(1:input$addCol, function(idx){
output[[paste0("showVal",idx)]] <- renderUI({
req(input$addCol >= idx)
labelList <- input[[paste0("metalab",idx)]]
choiceList <- NULL
for(aLabel in labelList){
choiceList <- cbind(choiceList, as.vector(unlist(project()[aLabel])))
}
checkboxGroupInput(paste0("metaval",idx),
"Metadata Value:",
choices = unique(as.vector(choiceList)), #flatten frame to vector and grab only unique values
selected = input[[paste0("metaval",idx)]]
)
})
})
})
#Update the table with comparison columns
finalTable <- reactive({
projectDT <- project()
dta <- NULL
if(input$addCol > 0) {
dta <- lapply(seq(input$addCol), function(idx){
if(!is.null(input[[paste0("metalab", idx)]]) &&
input[[paste0("metalab",idx)]] != " "){
labelList <- input[[paste0("metalab",idx)]]
choiceList <- input[[paste0("metaval", idx)]]
for(aLabel in labelList){
ifelse(projectDT[[aLabel]] %in% input[[paste0("metaval", idx)]], as.character(projectDT[[aLabel]]),"NA")
}
}
})
names(dta) <- sapply(seq(input$addCol),function(idx){ #add names to column
paste0("Compare",idx,"_",paste0(input[[paste0("metaval",idx)]],collapse = "vs"))
})
dta <- as.data.frame(dta[!sapply(dta,is.null)])
}
if(!is.null(dta) &&
!is.null(projectDT) &&
nrow(dta) == nrow(projectDT)){
projectDT <- cbind(projectDT,dta)
}
return(projectDT)
})
#Display the updated table
output$mytable <- DT::renderDataTable({DT::datatable(finalTable(), extensions = c('FixedColumns', 'Buttons'),
options = list(
dom = 'Bfrtip',
scrollX = TRUE, buttons = c('csv', I('colvis'))
))
})
#Download file
output$downloadData <- downloadHandler(
filename = function() {
paste(input$lab, ".csv", sep = "")
},
content = function(file) {
write.csv(as.matrix(finalTable()), file, row.names = FALSE)
}
)
}
非常感谢任何帮助！我觉得我差不多了，但只需要最后的推动！
答案 0 :(得分：0)
我明白了！或者尽可能接近现在。
按照上面的示例，它现在询问用户在进一步按Fav.Color值进行子集化之前，他们希望如何首先（通过Author.Name）和任何值对数据进行子集化。希望如果有人遇到这个问题，这会有所帮助！
observeEvent({input$addCol},{
insertUI(
selector = "#addCol", #some string to determine the element(s) relative to which you want to insert your UI object.
where = "afterEnd", #where UI object should go relative to the selector
ui = div( #object you want to insert, if multiple, wrap in div
uiOutput(paste0("subsetCheckbox", input$addCol)), #subset box
uiOutput(paste0("showSubmeta", input$addCol)),
uiOutput(paste0("showSubval", input$addCol)),
uiOutput(paste0("showMeta",input$addCol)), #showMeta selector
uiOutput(paste0("showVal",input$addCol)) #showVal selector
)
)
lapply(1:input$addCol, function(idx){
output[[paste0("subsetCheckbox", idx)]] <- renderUI({
checkboxInput('subset', strong("Subset"), value = FALSE)
})
})
lapply(1:input$addCol, function(idx){ #apply for as many columns as you want
output[[paste0("showSubmeta",idx)]] <- renderUI({
selectInput(inputId = paste0("submeta",idx),
label = "Subset Label:",
choices = c(" ", unique(as.vector(colnames(project())))),
selected = input[[paste0("submeta",idx)]]
)
})
})
lapply(1:input$addCol, function(idx){
output[[paste0("showSubval",idx)]] <- renderUI({
req(input$addCol >= idx)
checkboxGroupInput(paste0("subval",idx),
"Subset Value:",
choices = unique(as.vector(unlist(project()[[input[[paste0("submeta",idx)]]]]))),
selected = input[[paste0("subval",idx)]]
)
})
})
#insert metadata selection menus
lapply(1:input$addCol, function(idx){
output[[paste0("showMeta",idx)]] <- renderUI({
selectInput(inputId = paste0("metalab",idx),
label = "Metadata Label:",
choices = c(" ", unique(as.vector(colnames(project())))),
selected = input[[paste0("metalab",idx)]]
)
})
})
lapply(1:input$addCol, function(idx){
output[[paste0("showVal",idx)]] <- renderUI({
req(input$addCol >= idx)
checkboxGroupInput(paste0("metaval",idx),
"Metadata Value:",
choices = unique(as.vector(unlist(project()[[input[[paste0("metalab",idx)]]]]))),
selected = input[[paste0("metaval",idx)]]
)
})
})
})
#Update the table with comparison columns
finalTable <- reactive({
projectDT <- project()
dta <- NULL #initiate an empty dataframe
if(input$addCol > 0) { #if button has been clicked
dta <- lapply(seq(input$addCol), function(idx){
#subset logic
if(input$subset == TRUE && !is.null(input[[paste0("submeta", idx)]]) &&
input[[paste0("submeta",idx)]] != " " && !is.null(input[[paste0("metalab", idx)]]) &&
input[[paste0("metalab",idx)]] != " " ){
ifelse(projectDT[[input[[paste0("submeta", idx)]]]] %in% input[[paste0("subval", idx)]],
ifelse(projectDT[[input[[paste0("metalab", idx)]]]] %in% input[[paste0("metaval", idx)]],
as.character(projectDT[[input[[paste0("metalab", idx)]]]]),"NA"), "NA")
}
#no subset logic
else if(!is.null(input[[paste0("metalab", idx)]]) && #if metalab isn't null
input[[paste0("metalab",idx)]] != " "){ #if metalab isn't " ", add values into column by magic
ifelse(projectDT[[input[[paste0("metalab", idx)]]]] %in% input[[paste0("metaval", idx)]], as.character(projectDT[[input[[paste0("metalab", idx)]]]]),"NA")
}
})
#sapply - apply function to each element of a list in turn and return a VECTOR
names(dta) <- sapply(seq(input$addCol),function(idx){ #add names to column
paste0("Compare",idx,"_",paste0(input[[paste0("metaval",idx)]],collapse = "vs"))
})
dta <- as.data.frame(dta[!sapply(dta,is.null)])
}
if(!is.null(dta) &&
!is.null(projectDT) &&
nrow(dta) == nrow(projectDT)){
projectDT <- cbind(projectDT,dta)
}
return(projectDT)
})