在多页数据中注册所有输入 table
Register all inputs inside a multi-page data table
我有一个数据table，我在其中为我的用户添加了select 各种选项的复选框。不幸的是，闪亮似乎唯一看到的输入是 table 中显示的输入。所以如果我有多个页面，我只能看到前 10 个输入。
在下面的示例中，我打印了我能看到的所有在数据table 对象上注册的输入。目前，我只看到前 10 个输入 (A - J)。我希望能够在 table 首次加载时看到全部 26 个页面（无需切换页面）。
在我的实际应用程序中，我有多列复选框，因此行 selection 是不够的。关于如何一次注册所有 26 个输入的任何提示或建议？
library(shiny)
library(DT)
shinyInput <- function (FUN, id_base, suffix, label = "", ...)
{
inputId <- paste0(id_base, suffix)
args <- list(...)
args <- c(list(label = label), args)
args <- lapply(args, function(a) rep(a, length.out = length(inputId)))
rv <- character(length(inputId))
for (i in seq_along(rv)) {
this_arg <- lapply(args, `[`, i)
ctrl <- do.call(FUN, c(list(inputId = inputId[i]), this_arg))
rv[i] <- as.character(ctrl)
}
rv
}
X <- data.frame(id = LETTERS,
selected = sample(c(TRUE, FALSE),
size = length(LETTERS),
replace = TRUE))
X$IsSelected <-
shinyInput(
shiny::checkboxInput,
id_base = "new_input_",
suffix = X$id,
value = X$selected
)
shinyApp(
ui = fluidPage(
verbatimTextOutput("value_check"),
textOutput("input_a_value"),
DT::dataTableOutput("dt")
),
server = shinyServer(function(input, output, session){
Data <- reactiveValues(
X = X
)
output$value_check <-
renderPrint({
sort(names(input))
})
output$dt <-
DT::renderDataTable({
DT::datatable(X,
selection = "none",
escape = FALSE,
filter = "top",
#rownames = FALSE,
class = "compact cell-border",
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
})
)
附录
下一个例子有点复杂，但更能说明问题的动机。看来最大的问题是我想使用诸如“select 全部”之类的按钮。此外，当与框交互时，我不会立即处理任何操作。相反，用户制造了他们的 select 离子，并且在单击“保存 Select 离子”按钮之前不会保存 select 离子。
发生的事情是我点击“Select 全部”按钮，它会检查所有已经绘制的输入框。如果我只查看了 table 的第一页，它只会更新那些输入，以及接下来几页的 none 输入。这确实是我需要改变的行为。
# Set up environment ------------------------------------------------
library(shiny)
library(DT)
library(magrittr)
# Example of data coming from the database. -------------------------
set.seed(pi^2)
SourceData <-
data.frame(sample_id = 1:25,
is_selected = sample(c(TRUE, FALSE), 25, replace = TRUE))
# Support Functions -------------------------------------------------
# These would exist, for example, in an internal package
shinyInput <- function (FUN, id_base, suffix, label = "", ...)
{
inputId <- paste0(id_base, suffix)
args <- list(...)
args <- c(list(label = label), args)
args <- lapply(args, function(a) rep(a, length.out = length(inputId)))
rv <- character(length(inputId))
for (i in seq_along(rv)) {
this_arg <- lapply(args, `[`, i)
ctrl <- do.call(FUN, c(list(inputId = inputId[i]), this_arg))
rv[i] <- as.character(ctrl)
}
rv
}
prepareDataForDisplay <- function(Data){
Data$is_selected <-
shinyInput(shiny::checkboxInput,
id_base = "is_selected_",
suffix = Data$sample_id,
value = Data$is_selected)
Data
}
# User Interface ----------------------------------------------------
ui <-
fluidPage(
verbatimTextOutput("value_check"),
actionButton(inputId = "btn_saveSelection",
label = "Save Selection"),
actionButton(inputId = "btn_selectAll",
label = "Select All"),
actionButton(inputId = "btn_unselectAll",
label = "Unselect All"),
actionButton(inputId = "btn_restoreDefault",
label = "Restore Default (select odd only)"),
DT::dataTableOutput("dt")
)
# Server ------------------------------------------------------------
server <-
shinyServer(function(input, output, session){
# Event Observers -----------------------------------------------
observeEvent(
input$btn_selectAll,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
lapply(check_input,
function(ci){
updateCheckboxInput(session = session,
inputId = ci,
value = TRUE)
})
}
)
observeEvent(
input$btn_unselectAll,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
lapply(check_input,
function(ci){
updateCheckboxInput(session = session,
inputId = ci,
value = FALSE)
})
}
)
observeEvent(
input$btn_restoreDefault,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
lapply(check_input,
function(ci){
id <- as.numeric(sub("is_selected_", "", ci))
updateCheckboxInput(session = session,
inputId = ci,
value = id %% 2 == 1)
})
}
)
observeEvent(
input$btn_saveSelection,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
id <- as.numeric(sub("is_selected_", "", check_input))
for (i in seq_along(check_input)){
SourceData$is_selected[SourceData$sample_id == id[i]] <-
input[[check_input[i]]]
}
# At this point, I would also save changes to the remote database.
DT::replaceData(proxy = dt_proxy,
data = prepareDataForDisplay(SourceData))
}
)
# Output elements -----------------------------------------------
output$value_check <-
renderPrint({
sort(names(input))
})
output$dt <-
DT::renderDataTable({
SourceData %>%
prepareDataForDisplay() %>%
DT::datatable(selection = "none",
escape = FALSE,
filter = "top",
class = "compact cell-border",
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
dt_proxy <- DT::dataTableProxy("dt")
})
# Run the application -----------------------------------------------
shinyApp(
ui = ui,
server = server
)
这是基于您的附录的解决方法（不确定您是否需要对 btn_restoreDefault 和 btn_saveSelection 进行更改），但一般过程应该很清楚：
# Set up environment ------------------------------------------------
library(shiny)
library(DT)
library(magrittr)
# Example of data coming from the database. -------------------------
set.seed(pi^2)
SourceData <-
data.frame(sample_id = 1:25,
is_selected = sample(c(TRUE, FALSE), 25, replace = TRUE))
# Support Functions -------------------------------------------------
# These would exist, for example, in an internal package
shinyInput <- function (FUN, id_base, suffix, label = "", ...)
{
inputId <- paste0(id_base, suffix)
args <- list(...)
args <- c(list(label = label), args)
args <- lapply(args, function(a) rep(a, length.out = length(inputId)))
rv <- character(length(inputId))
for (i in seq_along(rv)) {
this_arg <- lapply(args, `[`, i)
ctrl <- do.call(FUN, c(list(inputId = inputId[i]), this_arg))
rv[i] <- as.character(ctrl)
}
rv
}
prepareDataForDisplay <- function(Data){
Data$is_selected <-
shinyInput(shiny::checkboxInput,
id_base = "is_selected_",
suffix = Data$sample_id,
value = Data$is_selected)
Data
}
# User Interface ----------------------------------------------------
ui <-
fluidPage(
verbatimTextOutput("value_check"),
actionButton(inputId = "btn_saveSelection",
label = "Save Selection"),
actionButton(inputId = "btn_selectAll",
label = "Select All"),
actionButton(inputId = "btn_unselectAll",
label = "Unselect All"),
actionButton(inputId = "btn_restoreDefault",
label = "Restore Default (select odd only)"),
DT::dataTableOutput("dt")
)
# Server ------------------------------------------------------------
server <-
shinyServer(function(input, output, session){
# Event Observers -----------------------------------------------
observeEvent(
input$btn_selectAll,
{
TmpData <- SourceData
TmpData$is_selected <- TRUE
replaceData(dt_proxy, prepareDataForDisplay(TmpData))
}
)
observeEvent(
input$btn_unselectAll,
{
TmpData <- SourceData
TmpData$is_selected <- FALSE
replaceData(dt_proxy, prepareDataForDisplay(TmpData))
}
)
observeEvent(
input$btn_restoreDefault,
{
replaceData(dt_proxy, prepareDataForDisplay(SourceData))
}
)
observeEvent(
input$btn_saveSelection,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
id <- as.numeric(sub("is_selected_", "", check_input))
TmpData <- SourceData
for (i in seq_along(check_input)){
TmpData$is_selected[TmpData$sample_id == id[i]] <-
input[[check_input[i]]]
}
# At this point, I would also save changes to the remote database.
DT::replaceData(proxy = dt_proxy,
data = prepareDataForDisplay(TmpData))
}
)
# Output elements -----------------------------------------------
output$value_check <-
renderPrint({
sort(names(input))
})
output$dt <-
DT::renderDataTable({
SourceData %>%
prepareDataForDisplay() %>%
DT::datatable(selection = "none",
escape = FALSE,
filter = "top",
class = "compact cell-border",
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
dt_proxy <- DT::dataTableProxy("dt")
})
# Run the application -----------------------------------------------
shinyApp(
ui = ui,
server = server
)
我有一个数据table，我在其中为我的用户添加了select 各种选项的复选框。不幸的是，闪亮似乎唯一看到的输入是 table 中显示的输入。所以如果我有多个页面，我只能看到前 10 个输入。
在下面的示例中，我打印了我能看到的所有在数据table 对象上注册的输入。目前，我只看到前 10 个输入 (A - J)。我希望能够在 table 首次加载时看到全部 26 个页面（无需切换页面）。
在我的实际应用程序中，我有多列复选框，因此行 selection 是不够的。关于如何一次注册所有 26 个输入的任何提示或建议？
library(shiny)
library(DT)
shinyInput <- function (FUN, id_base, suffix, label = "", ...)
{
inputId <- paste0(id_base, suffix)
args <- list(...)
args <- c(list(label = label), args)
args <- lapply(args, function(a) rep(a, length.out = length(inputId)))
rv <- character(length(inputId))
for (i in seq_along(rv)) {
this_arg <- lapply(args, `[`, i)
ctrl <- do.call(FUN, c(list(inputId = inputId[i]), this_arg))
rv[i] <- as.character(ctrl)
}
rv
}
X <- data.frame(id = LETTERS,
selected = sample(c(TRUE, FALSE),
size = length(LETTERS),
replace = TRUE))
X$IsSelected <-
shinyInput(
shiny::checkboxInput,
id_base = "new_input_",
suffix = X$id,
value = X$selected
)
shinyApp(
ui = fluidPage(
verbatimTextOutput("value_check"),
textOutput("input_a_value"),
DT::dataTableOutput("dt")
),
server = shinyServer(function(input, output, session){
Data <- reactiveValues(
X = X
)
output$value_check <-
renderPrint({
sort(names(input))
})
output$dt <-
DT::renderDataTable({
DT::datatable(X,
selection = "none",
escape = FALSE,
filter = "top",
#rownames = FALSE,
class = "compact cell-border",
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
})
)
附录
下一个例子有点复杂，但更能说明问题的动机。看来最大的问题是我想使用诸如“select 全部”之类的按钮。此外，当与框交互时，我不会立即处理任何操作。相反，用户制造了他们的 select 离子，并且在单击“保存 Select 离子”按钮之前不会保存 select 离子。
发生的事情是我点击“Select 全部”按钮，它会检查所有已经绘制的输入框。如果我只查看了 table 的第一页，它只会更新那些输入，以及接下来几页的 none 输入。这确实是我需要改变的行为。
# Set up environment ------------------------------------------------
library(shiny)
library(DT)
library(magrittr)
# Example of data coming from the database. -------------------------
set.seed(pi^2)
SourceData <-
data.frame(sample_id = 1:25,
is_selected = sample(c(TRUE, FALSE), 25, replace = TRUE))
# Support Functions -------------------------------------------------
# These would exist, for example, in an internal package
shinyInput <- function (FUN, id_base, suffix, label = "", ...)
{
inputId <- paste0(id_base, suffix)
args <- list(...)
args <- c(list(label = label), args)
args <- lapply(args, function(a) rep(a, length.out = length(inputId)))
rv <- character(length(inputId))
for (i in seq_along(rv)) {
this_arg <- lapply(args, `[`, i)
ctrl <- do.call(FUN, c(list(inputId = inputId[i]), this_arg))
rv[i] <- as.character(ctrl)
}
rv
}
prepareDataForDisplay <- function(Data){
Data$is_selected <-
shinyInput(shiny::checkboxInput,
id_base = "is_selected_",
suffix = Data$sample_id,
value = Data$is_selected)
Data
}
# User Interface ----------------------------------------------------
ui <-
fluidPage(
verbatimTextOutput("value_check"),
actionButton(inputId = "btn_saveSelection",
label = "Save Selection"),
actionButton(inputId = "btn_selectAll",
label = "Select All"),
actionButton(inputId = "btn_unselectAll",
label = "Unselect All"),
actionButton(inputId = "btn_restoreDefault",
label = "Restore Default (select odd only)"),
DT::dataTableOutput("dt")
)
# Server ------------------------------------------------------------
server <-
shinyServer(function(input, output, session){
# Event Observers -----------------------------------------------
observeEvent(
input$btn_selectAll,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
lapply(check_input,
function(ci){
updateCheckboxInput(session = session,
inputId = ci,
value = TRUE)
})
}
)
observeEvent(
input$btn_unselectAll,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
lapply(check_input,
function(ci){
updateCheckboxInput(session = session,
inputId = ci,
value = FALSE)
})
}
)
observeEvent(
input$btn_restoreDefault,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
lapply(check_input,
function(ci){
id <- as.numeric(sub("is_selected_", "", ci))
updateCheckboxInput(session = session,
inputId = ci,
value = id %% 2 == 1)
})
}
)
observeEvent(
input$btn_saveSelection,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
id <- as.numeric(sub("is_selected_", "", check_input))
for (i in seq_along(check_input)){
SourceData$is_selected[SourceData$sample_id == id[i]] <-
input[[check_input[i]]]
}
# At this point, I would also save changes to the remote database.
DT::replaceData(proxy = dt_proxy,
data = prepareDataForDisplay(SourceData))
}
)
# Output elements -----------------------------------------------
output$value_check <-
renderPrint({
sort(names(input))
})
output$dt <-
DT::renderDataTable({
SourceData %>%
prepareDataForDisplay() %>%
DT::datatable(selection = "none",
escape = FALSE,
filter = "top",
class = "compact cell-border",
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
dt_proxy <- DT::dataTableProxy("dt")
})
# Run the application -----------------------------------------------
shinyApp(
ui = ui,
server = server
)
这是基于您的附录的解决方法（不确定您是否需要对 btn_restoreDefault 和 btn_saveSelection 进行更改），但一般过程应该很清楚：
# Set up environment ------------------------------------------------
library(shiny)
library(DT)
library(magrittr)
# Example of data coming from the database. -------------------------
set.seed(pi^2)
SourceData <-
data.frame(sample_id = 1:25,
is_selected = sample(c(TRUE, FALSE), 25, replace = TRUE))
# Support Functions -------------------------------------------------
# These would exist, for example, in an internal package
shinyInput <- function (FUN, id_base, suffix, label = "", ...)
{
inputId <- paste0(id_base, suffix)
args <- list(...)
args <- c(list(label = label), args)
args <- lapply(args, function(a) rep(a, length.out = length(inputId)))
rv <- character(length(inputId))
for (i in seq_along(rv)) {
this_arg <- lapply(args, `[`, i)
ctrl <- do.call(FUN, c(list(inputId = inputId[i]), this_arg))
rv[i] <- as.character(ctrl)
}
rv
}
prepareDataForDisplay <- function(Data){
Data$is_selected <-
shinyInput(shiny::checkboxInput,
id_base = "is_selected_",
suffix = Data$sample_id,
value = Data$is_selected)
Data
}
# User Interface ----------------------------------------------------
ui <-
fluidPage(
verbatimTextOutput("value_check"),
actionButton(inputId = "btn_saveSelection",
label = "Save Selection"),
actionButton(inputId = "btn_selectAll",
label = "Select All"),
actionButton(inputId = "btn_unselectAll",
label = "Unselect All"),
actionButton(inputId = "btn_restoreDefault",
label = "Restore Default (select odd only)"),
DT::dataTableOutput("dt")
)
# Server ------------------------------------------------------------
server <-
shinyServer(function(input, output, session){
# Event Observers -----------------------------------------------
observeEvent(
input$btn_selectAll,
{
TmpData <- SourceData
TmpData$is_selected <- TRUE
replaceData(dt_proxy, prepareDataForDisplay(TmpData))
}
)
observeEvent(
input$btn_unselectAll,
{
TmpData <- SourceData
TmpData$is_selected <- FALSE
replaceData(dt_proxy, prepareDataForDisplay(TmpData))
}
)
observeEvent(
input$btn_restoreDefault,
{
replaceData(dt_proxy, prepareDataForDisplay(SourceData))
}
)
observeEvent(
input$btn_saveSelection,
{
check_input <- names(input)[grepl("is_selected_", names(input))]
id <- as.numeric(sub("is_selected_", "", check_input))
TmpData <- SourceData
for (i in seq_along(check_input)){
TmpData$is_selected[TmpData$sample_id == id[i]] <-
input[[check_input[i]]]
}
# At this point, I would also save changes to the remote database.
DT::replaceData(proxy = dt_proxy,
data = prepareDataForDisplay(TmpData))
}
)
# Output elements -----------------------------------------------
output$value_check <-
renderPrint({
sort(names(input))
})
output$dt <-
DT::renderDataTable({
SourceData %>%
prepareDataForDisplay() %>%
DT::datatable(selection = "none",
escape = FALSE,
filter = "top",
class = "compact cell-border",
options = list(preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
dt_proxy <- DT::dataTableProxy("dt")
})
# Run the application -----------------------------------------------
shinyApp(
ui = ui,
server = server
)