问题描述
我正在构建一个应用程序，用户可以在其中加载.RData数据集（可以从here下载文件）并从列表（DT）中选择变量，然后将其移至另一个列表（也是DT），然后可用的因子水平显示在下面的第三个DT中。第三个DT还具有一列动态生成的textInput字段，这些字段与变量的可用因子水平数匹配，用户可以在其中为现有因子水平添加新值。输入的值存储在reactiveValues对象中。现在，该对象只是在R控制台中打印。该应用程序如下所示：
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
ui <- fluidPage(
shinyFilesButton(id = "recodeChooseSrcFile",label = "Choose data file",title = "Navigate and select a file",multiple = FALSE),fluidRow(
column(width = 6,DTOutput(outputId = "recodeAllAvailableVars"),),column(width = 1,align = "center",br(),uIoUtput(outputId = "recodeArrowSelVarsRight"),uIoUtput(outputId = "recodeArrowSelVarsLeft"),column(width = 5,DTOutput(outputId = "recodeVaRSSelection"),br()
),DTOutput(outputId = "recodeScheme")
)
server <- function(input,output,session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL,var.levels = NULL)
# Select file and extract the variables.
shinyFileChoose(input,"recodeChooseSrcFile",roots = available.volumes,filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile,{
if(length(parseFilePaths(available.volumes,input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes,input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null),lapply(X = file.var.recode$loaded,FUN = function(i) {
if(is.null(attr(x = i,which = "levels"))) {
NULL
} else {
attr(x = i,which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),order_col = 1:ncol(file.var.recode$loaded))
}
},ignoreInit = TRUE)
observe({
var.props.initial.available.vars <- data.table(Variables = as.character(),order_col = as.numeric())
var.props.initial.selected.vars <- data.table(Variables = as.character(),order_col = as.numeric())
recodeAllVars <- reactiveValues(recodeAvailVars = var.props.initial.available.vars,recodeselectedVars = var.props.initial.selected.vars)
# Observe if the file is loaded,and if yes,update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight",label = NULL,icon("angle-right"),width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft",icon("angle-left"),width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars,cols = "order_col")
}
},caption = "Available variables",rownames = FALSE,colnames = c("Names","sortingcol"),options = list(
ordering = FALSE,columnDefs = list(list(visible = FALSE,targets = 1))
))
# Render the table with the selected variables.
output$recodeVaRSSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeselectedVars,cols = "order_col")
}
},targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight,{
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeselectedVars <- rbind(isolate(recodeAllVars$recodeselectedVars),recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected,drop = F])
recodeAllVars$recodeselectedVars <- recodeAllVars$recodeselectedVars[complete.cases(recodeAllVars$recodeselectedVars[,"Variables"]),drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected,drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft,{
req(input$recodeVaRSSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars),recodeAllVars$recodeselectedVars[input$recodeVaRSSelection_rows_selected,drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[,drop = FALSE]
recodeAllVars$recodeselectedVars <- isolate(recodeAllVars$recodeselectedVars[-input$recodeVaRSSelection_rows_selected,drop = F])
})
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj),FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp",i),value = NULL,width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id,len) {
unlist(lapply(seq_len(len),function(i) {
input[[paste0(id,i)]]
}))
}
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeselectedVars[,Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,V2 = initial.recode.new.values$values,V3 = rep(x = "->",times = length(initial.recode.new.values$values)),V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeselectedVars[,Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp",len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeselectedVars[,Variables]]))))
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeselectedVars[,Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},colnames = c("Available variable values","Old","->","New"),class = "cell-border stripe;compact cell-border;",selection="none",escape = FALSE,options = list(
pageLength = 1500,dom = 'BRrt',rowCallback = JS("function(r,d) {$(r).attr('height','40px')}"),preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
})
}
shinyApp(ui,server)
选择变量后，所有输入都可以正常工作，新输入的值将立即更新并显示在控制台中。但是，如果用户决定从选定的DT中删除变量，则new.recoding.values$values无功值立即变为NULL（如预期），但是当另一个变量添加到{ {1}}个选定变量中，先前变量的旧值将立即恢复，并且永远不会更新。另外，如果新变量的级别比第一个输入的级别高，则可以更新最后一个级别，但不能更新前一个级别（尝试输入DT，然后将其替换为ASBG03来查看我）。
我真的不明白为什么会这样。到目前为止，我试图在以下位置将ASBG04设置为new.recoding.values$values：
2。在shinyValue中，按向右箭头按钮，即：
observeEvent更新：
3。按照Tonio Liebrand的建议，我尝试如下更新文本输入（在渲染最后一个observeEvent(input$recodeArrowSelVarsLeft,{
req(input$recodeVaRSSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars),drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[,drop = FALSE]
recodeAllVars$recodeselectedVars <- isolate(recodeAllVars$recodeselectedVars[-input$recodeVaRSSelection_rows_selected,drop = F])
new.recoding.values$values <- NULL
})
之后添加）：
DT这些都没有帮助。每次删除最初选择的变量时，observe({
if(nrow(entered.new.values$values) == 0) {
lapply(seq_len(length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeselectedVars[,Variables]])))),function(i) {
updateTextInput(session,input[[paste0("numinp",i)]],label = NULL)
})
}
})
在控制台中都显示为new.recoding.values$values，但是随后添加另一个变量NULL会突然恢复首先输入的第一个值，就像它仍然“记住“第一个输入。
我不太了解这种行为，有人可以帮助克服这个问题，也就是真的对变量更改进行更新吗？
解决方法
由于textFields是在datatable中创建的，因此您需要先解除绑定，然后才能再次使用该表（updateTextInput不起作用）。使用this答案中的代码，我添加了带有unbind函数的JS脚本，并且该函数在观察器中被向左箭头调用。然后，您将获得一个可运行的应用程序：
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
ui <- fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT',function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),shinyFilesButton(id = "recodeChooseSrcFile",label = "Choose data file",title = "Navigate and select a file",multiple = FALSE),fluidRow(
column(width = 6,DTOutput(outputId = "recodeAllAvailableVars"),),column(width = 1,align = "center",br(),uiOutput(outputId = "recodeArrowSelVarsRight"),uiOutput(outputId = "recodeArrowSelVarsLeft"),column(width = 5,DTOutput(outputId = "recodeVarsSelection"),br()
),DTOutput(outputId = "recodeScheme")
)
server <- function(input,output,session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL,var.levels = NULL)
# Select file and extract the variables.
shinyFileChoose(input,"recodeChooseSrcFile",roots = available.volumes,filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile,{
if(length(parseFilePaths(available.volumes,input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes,input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null),lapply(X = file.var.recode$loaded,FUN = function(i) {
if(is.null(attr(x = i,which = "levels"))) {
NULL
} else {
attr(x = i,which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),order_col = 1:ncol(file.var.recode$loaded))
}
},ignoreInit = TRUE)
observe({
var.props.initial.available.vars <- data.table(Variables = as.character(),order_col = as.numeric())
var.props.initial.selected.vars <- data.table(Variables = as.character(),order_col = as.numeric())
recodeAllVars <- reactiveValues(recodeAvailVars = var.props.initial.available.vars,recodeSelectedVars = var.props.initial.selected.vars)
# Observe if the file is loaded,and if yes,update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight",label = NULL,icon("angle-right"),width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft",icon("angle-left"),width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars,cols = "order_col")
}
},caption = "Available variables",rownames = FALSE,colnames = c("Names","sortingcol"),options = list(
ordering = FALSE,columnDefs = list(list(visible = FALSE,targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars,cols = "order_col")
}
},targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight,{
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars),recodeAllVars$recodeAvailVars[input$recodeAllAvailableVars_rows_selected,drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[,"Variables"]),drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected,drop = F])
})
observeEvent(input$recodeArrowSelVarsLeft,{
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars),recodeAllVars$recodeSelectedVars[input$recodeVarsSelection_rows_selected,drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[,drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected,drop = F])
session$sendCustomMessage("unbindDT","recodeScheme")
})
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj),FUN = function(i) {
i <- paste0(textInput(inputId = paste0("numinp",i),value = NULL,width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id,len) {
unlist(lapply(seq_len(len),function(i) {
input[[paste0(id,i)]]
}))
}
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[,Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,V2 = initial.recode.new.values$values,V3 = rep(x = "->",times = length(initial.recode.new.values$values)),V4 = shinyInput(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[,Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp",len = length(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[,Variables]]))))
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[,Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},colnames = c("Available variable values","Old","->","New"),class = "cell-border stripe;compact cell-border;",selection="none",escape = FALSE,options = list(
pageLength = 1500,dom = 'BRrt',rowCallback = JS("function(r,d) {$(r).attr('height','40px')}"),preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
})
}
shinyApp(ui,server)
但是，我建议您阅读有关反应性的更多信息，例如here。您使用很多观察者，并将它们嵌套。我不建议这样做，因为这可能导致奇怪的行为。另外，请尝试使用更多的reactive / reactiveExpression，因为observe / observeEvent会使您的应用变慢。在找到正确的解决方案之前，我尝试对您的代码进行一些嵌套，但它仍然有效！这表明您实际上不需要使用应用程序的复杂性：
library(shiny)
library(DT)
library(data.table)
library(shinyFiles)
# additional functions
shinyInput <- function(obj) {
tmp <- unlist(lapply(X = seq_along(obj),width = "50px"))
}))
return(tmp)
}
shinyValue <- function(id,len,input) {
unlist(lapply(seq_len(len),i)]]
}))
}
ui <- fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT',function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),fluidRow(
column(width = 6,br()
),DTOutput(outputId = "recodeScheme")
)
server <- function(input,session) {
available.volumes <- getVolumes()()
file.var.recode <- reactiveValues(loaded = NULL,var.levels = NULL)
# define variables
# Render the table with the text inputs.
initial.recode.new.values <- reactiveValues(values = NULL)
entered.new.values <- reactiveValues(values = NULL)
new.recoding.values <- reactiveValues(values = NULL)
# Select file and extract the variables.
shinyFileChoose(input,filetype = list(RData = "RData"))
observeEvent(eventExpr = input$recodeChooseSrcFile,{
if(length(parseFilePaths(available.volumes,input$recodeChooseSrcFile)$datapath) > 0) {
file.var.recode$loaded <- get(load(parseFilePaths(available.volumes,input$recodeChooseSrcFile)$datapath))
file.var.recode$var.levels <- Filter(Negate(is.null),FUN = function(i) {
if(is.null(attr(x = i,which = "levels"))) {
NULL
} else {
attr(x = i,which = "levels")
}
}))
file.var.recode$loaded <- data.table(Variables = names(file.var.recode$loaded),order_col = 1:ncol(file.var.recode$loaded))
}
},ignoreInit = TRUE)
recodeAllVars <- reactiveValues(recodeAvailVars = data.table(Variables = as.character(),order_col = as.numeric()),recodeSelectedVars = data.table(Variables = as.character(),order_col = as.numeric()))
# Observe if the file is loaded,update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})
# Render the arrow buttons for selecting the variables.
output$recodeArrowSelVarsRight <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsRight",width = "50px")
}
})
output$recodeArrowSelVarsLeft <- renderUI({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
actionButton(inputId = "recodeArrowSelVarsLeft",width = "50px")
}
})
# Render the data table with the available variables.
output$recodeAllAvailableVars <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeAvailVars,cols = "order_col")
}
},options = list(
ordering = FALSE,targets = 1))
))
# Render the table with the selected variables.
output$recodeVarsSelection <- renderDT({
if(is.null(file.var.recode$loaded)) {
return(NULL)
} else {
setkeyv(x = recodeAllVars$recodeSelectedVars,cols = "order_col")
}
},targets = 1))
))
# Observe the events of moving variables from available to selected.
observeEvent(input$recodeArrowSelVarsRight,{
req(input$recodeAllAvailableVars_rows_selected)
recodeAllVars$recodeSelectedVars <- rbind(isolate(recodeAllVars$recodeSelectedVars),drop = F])
recodeAllVars$recodeSelectedVars <- recodeAllVars$recodeSelectedVars[complete.cases(recodeAllVars$recodeSelectedVars[,drop = FALSE]
recodeAllVars$recodeAvailVars <- isolate(recodeAllVars$recodeAvailVars[-input$recodeAllAvailableVars_rows_selected,{
req(input$recodeVarsSelection_rows_selected)
recodeAllVars$recodeAvailVars <- rbind(isolate(recodeAllVars$recodeAvailVars),drop = F])
recodeAllVars$recodeAvailVars <- recodeAllVars$recodeAvailVars[complete.cases(recodeAllVars$recodeAvailVars[,drop = FALSE]
recodeAllVars$recodeSelectedVars <- isolate(recodeAllVars$recodeSelectedVars[-input$recodeVarsSelection_rows_selected,drop = F])
session$sendCustomMessage("unbindDT","recodeScheme")
})
# Observe the changes in user selection and update the reactive values from above.
observe({
initial.recode.new.values$values <- unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[,Variables]]))
entered.new.values$values <- data.table(
V1 = initial.recode.new.values$values,Variables]])))
)
new.recoding.values$values <- shinyValue(id = "numinp",Variables]]))),input = input)
})
# Render the table with available levels and empty input fields where the user can enter his desired new values.
output$recodeScheme <- renderDT({
if(!is.null(unlist(unique(file.var.recode$var.levels[recodeAllVars$recodeSelectedVars[,Variables]])))) {
entered.new.values$values
} else {
return(NULL)
}
},options = list(
pageLength = 1500,drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
observe({
print(new.recoding.values$values)
})
# end of server
}
shinyApp(ui,server)
仍有一些改进空间，例如您可以尝试使用reactive而不是observe作为以下代码段：
# Observe if the file is loaded,update the table of available variables.
observe({
if(!is.null(file.var.recode$loaded)) {
recodeAllVars$recodeAvailVars <- file.var.recode$loaded
}
})