顶部的 R 闪亮 DT 复选框到 tick/untick 下面的所有复选框
R shiny DT checkboxes on top to tick/untick all the checkboxes below
我正在寻找一种简单的方法来 select 按列组织具有某些属性（即，收集这些数据的年份）的行数据。这些列将是“2016”、“2017”、“2018”，并且在每一列下方的每一行上都应该有一个复选框，指示是否应该 selected 显示该行和今年的数据。
完成此 selection 后，可以通过此 selection 上的按钮执行某些操作（例如导出）。所以，没有什么特别的。
因为有大约。总共 1000 行我想通过允许用户 select 或 unselect 整列（即一整年）来加快 selection 进程。
如果可能的话，我想用 DT 来做。我已经看到了一些相关的线程，例如 and there，但没有像我在这里需要的那样“系统化”（即将 select/unselect 所有复选框放在列子集的顶部）。
您知道使用 DT 进行此操作的快速简单方法吗？
另一种方法是 rhandsontable，但我感觉这有点像用锤子打苍蝇...
[编辑]：在下面添加了 reprex
灵感来自 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")
类似的东西：
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)
我在最终寻找的方向上取得了进展，但我仍然有一个问题：在下面的 reprex 中，只有第一页上的复选框被激活或停用。
有人知道如何将 (un)select all 效果扩展到所有页面，即扩展到整个 table 吗？
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")
我正在寻找一种简单的方法来 select 按列组织具有某些属性（即，收集这些数据的年份）的行数据。这些列将是“2016”、“2017”、“2018”，并且在每一列下方的每一行上都应该有一个复选框，指示是否应该 selected 显示该行和今年的数据。 完成此 selection 后，可以通过此 selection 上的按钮执行某些操作（例如导出）。所以，没有什么特别的。 因为有大约。总共 1000 行我想通过允许用户 select 或 unselect 整列（即一整年）来加快 selection 进程。
如果可能的话，我想用 DT 来做。我已经看到了一些相关的线程，例如
您知道使用 DT 进行此操作的快速简单方法吗？
另一种方法是 rhandsontable，但我感觉这有点像用锤子打苍蝇...
[编辑]：在下面添加了 reprex
灵感来自 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")
类似的东西：
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)
我在最终寻找的方向上取得了进展，但我仍然有一个问题：在下面的 reprex 中，只有第一页上的复选框被激活或停用。 有人知道如何将 (un)select all 效果扩展到所有页面，即扩展到整个 table 吗？
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")