I apologize that the reproducible example is not quite minimal.
I have a large shiny app, the example here is just an excerpt. I am trying to produce a DT table with checkboxes. The application has DT of available values on the left and three DT on the right where selected values can be moved with buttons. The input of the checkbox table below is a reactive object with all unique combinations of the values from the three reactiveValues' objects with selected values which are displayed in the other three DT tables of selected values from above. It all works fine when I render the table with the checkboxes. However, when I click on the checkboxes, not all are actually selected and displayed in the last DT output. There is some patterns of the unwanted behavior:
- If there are names only in the first (or the second, or the third)
DTon the right, all works fine, clicking on the checkbox produces the desired result. - When there are selected values in the first and the second
DTs then clicking on the first checkbox has no effect. - If there are values in all three
DTs on the right, then clicking on the first few checkboxes does not have any effect, but it works for the subsequent.
Different other scenarios are possible, depending on the number of selected values in the three DT outputs on the right. I can't reach any explanation why not all of the checkbox values are collected. When the checkboxes are generated with the shinyInput function, their number matches the number of all possible pairs. However, the shinyValue function collects just part of them.
Here is the code:
library(shiny)
library(DT)
library(data.table)
mydt <- data.table(Variables = c("IDCNTRY", "ASBG01", "ASBG03", "ASBG04", "ASBG05A", "ASBG05B", "ASBG05C", "ASBG05D", "ASBG05E", "ASBG05F", "ASBG05G", "ASBG05H", "ASBG06", "ASBG07A", "ASBG07B", "ASBG08", "ASBG09A", "ASBG09B", "ASBG09C", "ASBG10A", "ASBG10B"), Variable_Labels = c("COUNTRY ID", "SEX OF STUDENT", "OFTEN SPEAK <LANG OF TEST> AT HOME", "AMOUNT OF BOOKS IN YOUR HOME", "HOME POSSESS/COMPUTER OR TABLET", "HOME POSSESS/STUDY DESK", "HOME POSSESS/OWN ROOM", "HOME POSSESS/INTERNET CONNECTION", "HOME POSSESS/<COUNTRY SPECIFIC>", "HOME POSSESS/<COUNTRY SPECIFIC>", "HOME POSSESS/<COUNTRY SPECIFIC>", "HOME POSSESS/<COUNTRY SPECIFIC>", "ABOUT HOW OFTEN ABSENT FROM SCHOOL", "HOW OFTEN FEEL THIS WAY/TIRED", "HOW OFTEN FEEL THIS WAY/HUNGRY", "HOW OFTEN BREAKFAST ON SCHOOL DAYS", "USE COMPUTER TABLET/HOME", "USE COMPUTER TABLET/SCHOOL", "USE COMPUTER TABLET/OTHER", "USE COMPUTER TABLET SCHOOLWORK/READING", "USE COMPUTER TABLET SCHOOLWORK/PREPARING"), order_col = 1:21)
shinyApp(
ui <- fluidPage(
fluidRow(
column(width = 6, align = "center",
DTOutput(outputId = "allAvailableVars"),
),
column(width = 6,
fluidRow(
column(width = 2, align = "center",
br(), br(), br(),
uiOutput(outputId = "arrowSelGroup1VarsRight"),
uiOutput(outputId = "arrowSelGroup1VarsLeft")
),
column(width = 10,
DTOutput(outputId = "group1Vars")
)
),
fluidRow(
column(width = 2, align = "center",
br(), br(), br(),
uiOutput(outputId = "arrowSelGroup2VarsRight"),
uiOutput(outputId = "arrowSelGroup2VarsLeft")
),
column(width = 10,
DTOutput(outputId = "group2Vars"),
),
br()
),
fluidRow(
column(width = 2, align = "center",
br(), br(), br(),
uiOutput(outputId = "arrowSelGroup3Right"),
uiOutput(outputId = "arrowSelGroup3Left")
),
column(width = 10,
DTOutput(outputId = "group3Vars"),
)
)
)
),
fluidRow(
column(width = 6,
DTOutput(outputId = "checkBoxTable")
),
column(width = 6,
DTOutput(outputId = "selectedCheckBoxTable")
)
)
),
server <- function(input, output, session) {
observe({
# Create initial values for the available and selected variables.
initial.available.vars <- mydt
initial.selected.split.vars <- data.table(Variables = as.character(), Variable_Labels = as.character(), order_col = as.numeric())
initial.selected.bckg.vars <- data.table(Variables = as.character(), Variable_Labels = as.character(), order_col = as.numeric())
initial.selected.PV.vars <- data.table(Variables = as.character(), Variable_Labels = as.character(), order_col = as.numeric())
initial.checkboxes <- data.table(Variable1 = as.character(), Check = as.character(), Variable2 = as.character())
allVars <- reactiveValues(availVars = initial.available.vars, selectedGroup1Vars = initial.selected.split.vars, selectedGroup2Vars = initial.selected.bckg.vars, selectedGroup3Vars = initial.selected.PV.vars)
output$arrowSelGroup1VarsRight <- renderUI({
actionButton(inputId = "arrowSelGroup1VarsRight", label = NULL, icon("angle-right"), width = "50px")
})
output$arrowSelGroup1VarsLeft <- renderUI({
actionButton(inputId = "arrowSelGroup1VarsLeft", label = NULL, icon("angle-left"), width = "50px")
})
output$arrowSelGroup2VarsRight <- renderUI({
actionButton(inputId = "arrowSelGroup2VarsRight", label = NULL, icon("angle-right"), width = "50px")
})
output$arrowSelGroup2VarsLeft <- renderUI({
actionButton(inputId = "arrowSelGroup2VarsLeft", label = NULL, icon("angle-left"), width = "50px")
})
output$arrowSelGroup3Right <- renderUI({
actionButton(inputId = "arrowSelGroup3Right", label = NULL, icon("angle-right"), width = "50px")
})
output$arrowSelGroup3Left <- renderUI({
actionButton(inputId = "arrowSelGroup3Left", label = NULL, icon("angle-left"), width = "50px")
})
observeEvent(input$arrowSelGroup1VarsRight, {
req(input$allAvailableVars_rows_selected)
allVars$selectedGroup1Vars <- rbind(isolate(allVars$selectedGroup1Vars), allVars$availVars[input$allAvailableVars_rows_selected, , drop = FALSE])
allVars$selectedGroup1Vars <- allVars$selectedGroup1Vars[complete.cases(allVars$selectedGroup1Vars[ , "Variables"]), , drop = FALSE]
allVars$availVars <- isolate(allVars$availVars[-input$allAvailableVars_rows_selected, , drop = FALSE])
})
observeEvent(input$arrowSelGroup1VarsLeft, {
req(input$group1Vars_rows_selected)
allVars$availVars <- rbind(isolate(allVars$availVars), allVars$selectedGroup1Vars[input$group1Vars_rows_selected, , drop = FALSE])
allVars$availVars <- allVars$availVars[complete.cases(allVars$availVars[ , "Variables"]), , drop = FALSE]
allVars$selectedGroup1Vars <- isolate(allVars$selectedGroup1Vars[-input$group1Vars_rows_selected, , drop = FALSE])
})
observeEvent(input$arrowSelGroup2VarsRight, {
req(input$allAvailableVars_rows_selected)
allVars$selectedGroup2Vars <- rbind(isolate(allVars$selectedGroup2Vars), allVars$availVars[input$allAvailableVars_rows_selected, , drop = FALSE])
allVars$selectedGroup2Vars <- allVars$selectedGroup2Vars[complete.cases(allVars$selectedGroup2Vars[ , "Variables"]), , drop = FALSE]
allVars$availVars <- isolate(allVars$availVars[-input$allAvailableVars_rows_selected, , drop = FALSE])
})
observeEvent(input$arrowSelGroup2VarsLeft, {
req(input$group2Vars_rows_selected)
allVars$availVars <- rbind(isolate(allVars$availVars), allVars$selectedGroup2Vars[input$group2Vars_rows_selected, , drop = FALSE])
allVars$availVars <- allVars$availVars[complete.cases(allVars$availVars[ , "Variables"]), , drop = FALSE]
allVars$selectedGroup2Vars <- isolate(allVars$selectedGroup2Vars[-input$group2Vars_rows_selected, , drop = FALSE])
})
observeEvent(input$arrowSelGroup3Right, {
req(input$allAvailableVars_rows_selected)
allVars$selectedGroup3Vars <- rbind(isolate(allVars$selectedGroup3Vars), allVars$availVars[input$allAvailableVars_rows_selected, , drop = FALSE])
allVars$selectedGroup3Vars <- allVars$selectedGroup3Vars[complete.cases(allVars$selectedGroup3Vars[ , "Variables"]), , drop = FALSE]
allVars$availVars <- isolate(allVars$availVars[-input$allAvailableVars_rows_selected, , drop = FALSE])
})
observeEvent(input$arrowSelGroup3Left, {
req(input$group3Vars_rows_selected)
allVars$availVars <- rbind(isolate(allVars$availVars), allVars$selectedGroup3Vars[input$group3Vars_rows_selected, , drop = FALSE])
allVars$availVars <- allVars$availVars[complete.cases(allVars$availVars[ , "Variables"]), , drop = FALSE]
allVars$selectedGroup3Vars <- isolate(allVars$selectedGroup3Vars[-input$group3Vars_rows_selected, , drop = FALSE])
})
output$allAvailableVars <- renderDT({
setkeyv(x = allVars$availVars, cols = "order_col")
},
rownames = FALSE, colnames = c("Names", "Labels", "sortingcol"), extensions = list("Scroller"),
options = list(dom = "ti", ordering = FALSE, autoWidth = TRUE, pageLength = 5000, deferRender = TRUE, scrollY = 455, scroller = TRUE))
output$group1Vars <- renderDT({
allVars$selectedGroup1Vars
},
rownames = FALSE, colnames = c("Names", "Labels", "sortingcol"), extensions = list("Scroller"),
options = list(dom = "ti", ordering = FALSE, pageLength = 5000, autoWidth = TRUE, deferRender = TRUE, scrollY = 100, scroller = TRUE))
output$group2Vars <- renderDT({
allVars$selectedGroup2Vars
},
rownames = FALSE, class = "cell-border stripe;compact cell-border;", extensions = list("Scroller"),
options = list(dom = "ti", ordering = FALSE, pageLength = 5000, autoWidth = TRUE, deferRender = TRUE, scrollY = 100, scroller = TRUE))
output$group3Vars <- renderDT({
allVars$selectedGroup3Vars
},
rownames = FALSE, class = "cell-border stripe;compact cell-border;", extensions = list("Scroller"),
options = list(dom = "ti", ordering = FALSE, pageLength = 5000, autoWidth = TRUE, rowCallback = JS("function(r,d) {$(r).attr('height', '40px')}"), deferRender = TRUE, scrollY = 100, scroller = TRUE))
# Define a function to generate the checkboxes in the table.
shinyInput = function(FUN, len, id, ...) {
inputs <- character(len)
lapply(seq_len(len), function(i) {
inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
})
}
# Define a function to read back the input from the checkboxes.
shinyValue <- function(id, len) {
sapply(seq_len(len), function(i) {
value <- input[[paste0(id, i)]]
if(is.null(value)) {
NA
} else {
value
}
})
}
# Combine a data.table with the unique combinations of the selected variables.
possibleCheckboxes <- reactive({
if(nrow(rbindlist(l = list(allVars$selectedGroup1Vars, allVars$selectedGroup2Vars, allVars$selectedGroup3Vars))) > 1) {
selected.vars <- c(allVars$selectedGroup1Vars[ , Variables], allVars$selectedGroup2Vars[ , Variables], allVars$selectedGroup3Vars[ , Variables])
tmp <- transpose(as.data.table(combn(x = selected.vars, m = 2)))
data.table(Variable1 = tmp[ , V1], Check = shinyInput(FUN = checkboxInput, len = nrow(tmp), id = "cbox_", width = "5px"), Variable2 = tmp[ , V2])
} else {
initial.checkboxes
}
})
# Render the data table for the checkboxes.
output$checkBoxTable <- renderDT({
possibleCheckboxes()
},
server = FALSE, escape = FALSE, rownames = FALSE, colnames = c("Variable 1", "", "Variable 2"), extensions = list("Scroller"), selection="none",
options = list(dom = "ti", ordering = FALSE, autoWidth = TRUE, preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'), drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '), deferRender = TRUE, scrollY = 450, scroller = TRUE))
selectedCheckboxes <- reactive({
if(nrow(possibleCheckboxes()) > 0) {
possibleCheckboxes()[shinyValue(id = "cbox_", len = nrow(possibleCheckboxes())) == TRUE]
} else {
initial.checkboxes
}
})
output$selectedCheckBoxTable <- renderDT({
selectedCheckboxes()[ , mget(c("Variable1", "Variable2"))]
},
server = FALSE, escape = FALSE, rownames = FALSE, colnames = c("Variable 1", "Variable 2"), extensions = list("Scroller"), selection="none",
options = list(dom = "ti",
ordering = FALSE,
autoWidth = TRUE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
deferRender = TRUE, scrollY = 450, scroller = TRUE
))
})
}
)
Here is a screenshot in the final outputs:
Can someone help with this?
Aucun commentaire:
Enregistrer un commentaire