我正在寻找一种简单的方法来选择按行组织的数据，并按列某些属性(即这些数据的收集年份)。这些列将为“2016”、“2017”、“2018”，并且在每列下方的每一行上都应该有一个复选框，指示是否应选择该行和今年的数据。 做出此选择后，可以通过此选择上的按钮执行某些操作(例如导出)。所以，没什么特别的。 因为有大约。总共 1 000 行 我希望通过允许用户选择或取消选择整列(即一整年)来加快选择过程。
如果可能的话，我想用DT来做到这一点。我已经看到一些相关的线程，here和 there例如，但没有我需要的“系统性”(即将选择/取消选择列子集顶部的所有复选框)。
您知道使用 DT 实现这一点的快速且简单的方法吗？
另一种选择是使用rhandsontable，但我感觉这有点像用锤子杀死苍蝇......
[编辑]:在下面添加了表示
灵感来自https://github.com/rstudio/DT/issues/93#issuecomment-111001538
library(shiny)
library(DT)
# create a character vector of shiny inputs
shinyInput <- function(FUN, len, id, ...)
{
inputs <- character(len)
for (i in seq_len(len))
{
inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
# obtain the values of inputs
shinyValue <- function(id, len)
{
unlist(lapply(seq_len(len), function(i)
{
value <- input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
Years <- paste0("Year_", 2016:2020)
MyDataFrame <- data.frame(matrix(nrow = 1000, ncol = 1 + length(Years)), stringsAsFactors = FALSE)
colnames(MyDataFrame) <- c("Group", Years)
MyDataFrame[names(MyDataFrame) == "Group"] <- paste0("Group_", 1:1000)
#MyDataFrame[names(MyDataFrame) %in% Years] <- TRUE
MyDataFrame[names(MyDataFrame) %in% Years] <- lapply(X = Years, FUN = function(x){shinyInput(checkboxInput, 1000, paste0('v_', x, '_'), value = TRUE)})
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
h4("Filter"),
width = 2
),
mainPanel(
DT::dataTableOutput("MyTable"),
width = 10
)
)
)
server <- function(input, output, session) {
output$MyTable = DT::renderDataTable(MyDataFrame, server = FALSE, escape = FALSE, selection = 'none', options = list(
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}
shinyApp(ui = ui, server = server, enableBookmarking = "server")
我在实现最终目标方面取得了进展，但仍然有一个问题:在下面的 reprex 中，只有第一页上的复选框被激活或停用。 有人知道如何将(取消)全选效果扩展到所有页面，即整个表格吗？
library(shiny)
#library(shinyjs)
library(DT)
Generate_shinyInputs <- function(FUN, Range, id, Label, ...)
{
vapply(Range, function(i){as.character(FUN(paste0(id, i), label = if(!is.null(Label)) i else NULL, width = "150px", ...))}, character(1))
}
Years <- 2016:2020
Years_Augmented <- c(Years, "All_Years")
nRows <- 400
MyDataFrame <- data.frame(matrix(nrow = nRows, ncol = 2 + length(Years_Augmented)), stringsAsFactors = FALSE)
colnames(MyDataFrame) <- c("Group", "Country", Years_Augmented)
MyDataFrame[names(MyDataFrame) == "Group"] <- paste0("Group_", 1:nRows)
MyDataFrame[names(MyDataFrame) == "Country"] <- rep(c("AT", "BE", "BG", "CY", "DE", "ES", "FI", "GR", "HU", "IE", "IT"), length.out = nRows)
MyDataFrame[names(MyDataFrame) %in% Years_Augmented] <- lapply(X = Years_Augmented, FUN = function(x){Generate_shinyInputs(checkboxInput, 1:nRows, paste0("CheckBox_", x, "_"), NULL, value = TRUE)})
colnames(MyDataFrame)[names(MyDataFrame) %in% Years_Augmented] <- Generate_shinyInputs(checkboxInput, Years_Augmented, "CheckBox_", TRUE, value = TRUE)
ui <- fluidPage(
mainPanel(
DT::dataTableOutput("MyTable"),
width = 10
)
)
server <- function(input, output, session) {
# Generate the observe events for the columns check boxes (i.e. on the top row) - Total number of check boxes to be observed = number of years + 1 ('All_Years')
Generate_observeEvent_Columns <- function(Year)
{
observeEvent(input[[paste0("CheckBox_", Year)]],
{
CheckBox.Value <- input[[paste0("CheckBox_", Year)]]
if(Year == "All_Years") # Each and every row of each and every column Years_Augmented
{
lapply(X = Years, FUN = function(y){lapply(X = 1:nRows, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", y, "_", x), value = CheckBox.Value)})})
lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x), value = CheckBox.Value)})
}
# Only each and every row of the column 'Year'
lapply(X = 1:nRows, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", Year, "_", x), value = CheckBox.Value)})
})#, ignoreNULL = TRUE, ignoreInit = TRUE)
}
# Generate the observe events for each row of the column 'All_Years' check boxes - Total number of check boxes to be observed = number of rows (groups)
Generate_observeEvent_Rows <- function(Row)
{
observeEvent(input[[paste0("CheckBox_All_Years_", Row)]],
{
CheckBox.Value <- input[[paste0("CheckBox_All_Years_", Row)]]
print(Row)
lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x, "_", Row), value = CheckBox.Value)})
})#, ignoreNULL = TRUE, ignoreInit = TRUE)
}
lapply(X = Years_Augmented, FUN = function(x){Generate_observeEvent_Columns(x)})
lapply(X = 1:nRows, FUN = function(x){Generate_observeEvent_Rows(x)})
# filter = 'top',
#output$MyTable = DT::renderDataTable(MyDataFrame, rownames = FALSE, server = FALSE, escape = FALSE, selection = 'none')
output$MyTable = DT::renderDataTable(MyDataFrame, rownames = FALSE, server = FALSE, escape = FALSE, selection = 'none', options = list(
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}
shinyApp(ui = ui, server = server, enableBookmarking = "server")
[编辑]:
我仍在研究这个问题。我最近将其分解为更简单的问题，通过这样做，我发现了一个新问题(在可重现示例之后进行了描述)。我现在动态打印相关输入的值，以更好地了解一切是如何工作的。这里的重点是函数 Generate_observeEvent_Rows。
下面是一个可重现的示例:
library(shiny)
#library(shinyjs)
library(DT)
Generate_shinyInputs <- function(FUN, Range, id, Label, ...)
{
vapply(Range, function(i){as.character(FUN(paste0(id, i), label = if(!is.null(Label)) i else NULL, width = "150px", ...))}, character(1))
}
Years <- 2016:2020
Years_Augmented <- c(Years, "All_Years")
nRows <- 40
# 2 + length(Years_Augmented): the first 2 columns are 'Group' and 'Country'
# The next columns are, at first, numbers (the reporting years), except for the last one, 'All_Years'
MyDataFrame <- data.frame(matrix(nrow = nRows, ncol = 2 + length(Years_Augmented)), stringsAsFactors = FALSE)
colnames(MyDataFrame) <- c("Group", "Country", Years_Augmented)
MyDataFrame[names(MyDataFrame) == "Group"] <- paste0("Group_", 1:nRows)
MyDataFrame[names(MyDataFrame) == "Country"] <- rep(c("AT", "BE", "BG", "CY", "DE", "ES", "FI", "GR", "HU", "IE", "IT"), length.out = nRows)
# The cells of the data.frame 'MyDataFrame' in the columns 'Years_Augmented' are checkboxInputs. They are named 'CheckBox_2016_1' where '2016' is the year from 'Years_Augmented' and '1' is the row ID.
MyDataFrame[names(MyDataFrame) %in% Years_Augmented] <- lapply(X = Years_Augmented, FUN = function(x){Generate_shinyInputs(checkboxInput, 1:nRows, paste0("CheckBox_", x, "_"), NULL, value = TRUE)})
# The very names of the last columns ('Years_Augmented') of the data.frame 'MyDataFrame' are thereafter transformed into checkboxInputs. They are named 'CheckBox_2016' where '2016' is the year of the original version of 'Years_Augmented'. The last column then generates 'CheckBox_All_Years'.
colnames(MyDataFrame)[names(MyDataFrame) %in% Years_Augmented] <- Generate_shinyInputs(checkboxInput, Years_Augmented, "CheckBox_", TRUE, value = TRUE)
ui <- fluidPage(
mainPanel(
DT::dataTableOutput("MyTable"),
width = 10
)
)
server <- function(input, output, session) {
# Generate the observe events for the columns check boxes (i.e. on the top row) - Total number of check boxes to be observed = number of years + 1 ('All_Years')
Generate_observeEvent_Columns <- function(Year)
{
observeEvent(input[[paste0("CheckBox_", Year)]],
{
CheckBox.Value <- input[[paste0("CheckBox_", Year)]]
print(paste0("Value of the observed variable '", paste0("CheckBox_", Year), "' = ", CheckBox.Value))
if(Year == "All_Years") # Each and every row of each and every column Years_Augmented
{
lapply(X = Years, FUN = function(y){lapply(X = 1:nRows, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", y, "_", x), value = CheckBox.Value); print(paste0("After update: ", input[[paste0("CheckBox_", y, "_", x)]]))})})
lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x), value = CheckBox.Value); print(paste0("After update: ", input[[paste0("CheckBox_", x)]]))})
}
else # Only one single year was (de)selected (checked/unchecked)
{
lapply(X = 1:nRows, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", Year, "_", x), value = CheckBox.Value); print(paste0("After update: ", input[[paste0("CheckBox_", Year, "_", x)]]))})
}
})#, ignoreNULL = TRUE, ignoreInit = TRUE)
}
# Generate the observe events for each row of the column 'All_Years' check boxes (not the top row but the rows below) - Total number of check boxes to be observed = number of rows (groups)
Generate_observeEvent_Rows <- function(Row)
{
observeEvent(input[[paste0("CheckBox_All_Years_", Row)]],
{
CheckBox.Value <- input[[paste0("CheckBox_All_Years_", Row)]]
#print(Row)
print(paste0("Value of the observed variable '", paste0("CheckBox_All_Years_", Row), "' = ", CheckBox.Value))
lapply(X = Years, FUN = function(x){print(paste0("Before update of '", paste0("CheckBox_", x, "_", Row), "': ", input[[paste0("CheckBox_", x, "_", Row)]]))})
lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x, "_", Row), value = CheckBox.Value)})
lapply(X = Years, FUN = function(x){print(paste0("After update of '", paste0("CheckBox_", x, "_", Row), "': ", input[[paste0("CheckBox_", x, "_", Row)]]))})
})#, ignoreNULL = TRUE, ignoreInit = TRUE)
}
#lapply(X = Years_Augmented, FUN = function(x){Generate_observeEvent_Columns(x)})
lapply(X = 1:nRows, FUN = function(x){Generate_observeEvent_Rows(x)})
# filter = 'top',
#output$MyTable = DT::renderDataTable(MyDataFrame, rownames = FALSE, server = FALSE, escape = FALSE, selection = 'none')
#'MyDataFrame' should be updated every time a check box is clicked!
output$MyTable <- DT::renderDataTable(MyDataFrame, rownames = FALSE, server = FALSE, escape = FALSE, selection = 'none', options = list(
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node());}')
)
)
#proxy <- DT::dataTableProxy("MyTable")
}
shinyApp(ui = ui, server = server, enableBookmarking = "server")
我不明白的是，当我单击任意行上的任何“All_Years”列复选框时(当然顶行标题除外)，同一行上的复选框的行为2016 到 2020 符合预期(即，当选中同一行上的 'All_Years' 时，它们会变为选中状态，当取消选中同一行上的 'All_Years' 时，它们会变为未选中状态)，但它们的值未正确更新:他们总是“落后一步”。
你知道为什么吗？
此外，有趣的是，我们看到只有输入值的前 10 行(表格的可见部分，当前页面)最初显示在控制台中(使用 print)。但这是下一个需要解决的问题。
最佳答案
类似的事情:
library(DT)
dat <- data.frame(
vapply(1:10, function(i){
as.character(
checkboxInput(paste0("cbox2018-", i), label = NULL, width = "150px")
)
}, character(1)),
rpois(10, 100),
rpois(10, 50)
)
names(dat) <- c(
as.character(
checkboxInput("cbox2018", label = "2018", width = "150px")
),
"foo",
"bar"
)
datatable(
dat,
escape = FALSE,
options = list(
columnDefs = list(
list(targets = 1, orderable = FALSE, className = "dt-center")
)
),
callback = JS(
"$('#cbox2018').on('click', function(){",
" var cboxes = $('[id^=cbox2018-]');",
" var checked = $('#cbox2018').is(':checked');",
" cboxes.each(function(i, cbox) {",
" $(cbox).prop('checked', checked);",
" });",
"});"
)
)
并为 Shiny 添加 preDrawCallback 和 drawCallback。
编辑
正如 @Olivier 在评论中指出的，仅在当前页面上执行框检查。以下是此问题的解决方案:
library(shiny)
library(DT)
dat <- data.frame(
vapply(1:100, function(i){
as.character(
checkboxInput(paste0("cbox2018-", i), label = NULL, width = "150px")
)
}, character(1)),
rpois(100, 100),
rpois(100, 50)
)
names(dat) <- c(
as.character(
checkboxInput("cbox2018", label = "2018", width = "150px")
),
"foo",
"bar"
)
ui <- basicPage(
br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(
dat,
escape = FALSE,
options = list(
columnDefs = list(
list(targets = 1, orderable = FALSE, className = "dt-center")
),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
),
callback = JS(
"$('#cbox2018').on('click', function(){",
" var cboxes = $('[id^=cbox2018-]');",
" var checked = $('#cbox2018').is(':checked');",
" cboxes.each(function(i, cbox) {",
" $(cbox).prop('checked', checked);",
" });",
"});",
"table.on('page.dt', function(){",
" setTimeout(function(){",
" var cboxes = $('[id^=cbox2018-]');",
" var checked = $('#cbox2018').is(':checked');",
" cboxes.each(function(i, cbox) {",
" $(cbox).prop('checked', checked);",
" });",
" });",
"});"
)
)
}, server = FALSE)
}
shinyApp(ui, server)
关于R 顶部 Shiny 的 DT 复选框可勾选/取消勾选下面的所有复选框，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/64637582/