I try to create the included and excluded checkbox in DT table.
If the user selects included TRUE, then excluded will auto update FALSE. If the user selects included FALSE, then excluded will auto update TRUE.
It can be FALSE for both but NOT TRUE for both, I couldn't find any solution here
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
DT::dataTableOutput('x1'),
verbatimTextOutput('x2')
),
server = function(input, output, session) {
# create a character vector of shiny inputs
shinyInput = function(FUN, len, id, value, ...) {
if (length(value) == 1) value <- rep(value, len)
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = value[i]))
}
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)) TRUE else value
}))
}
n = 6
df = data.frame(
included = shinyInput(checkboxInput, n, 'in_', value = TRUE, width='1px'),
excluded = shinyInput(checkboxInput, n, 'ex_', value = FALSE, width='1px'),
ID = seq_len(n),
stringsAsFactors = FALSE)
loopData = reactive({
df$included <<- shinyInput(checkboxInput, n, 'in_', value = shinyValue('in_', n), width='1px')
df$excluded <<- shinyInput(checkboxInput, n, 'ex_', value = FALSE, width='1px')
df
})
output$x1 = DT::renderDataTable(
isolate(loopData()),
escape = FALSE, selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))
proxy = dataTableProxy('x1')
observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})
output$x2 = renderPrint({
data.frame(Inclusion = shinyValue('in_', n),
Exclusion = shinyValue('ex_', n))
})
}
)
You can define a reactiveVal
which keeps track of the current checkbox values (here checkboxValues
). Additionally, we generate several observeEvent
using lapply
which get triggered if one of the inputs is changed. And then we change the respective other inputs such that two checkboxes never have the same value. This would look like this for the included
column as the trigger:
lapply(1:n, function(x) {
observeEvent(input[[paste0("in_", x)]], {
ins <- shinyValue('in_', n)
exs <- shinyValue('ex_', n)
checkBoxValues(data.frame(ins = ins, exs = !ins))
}, ignoreInit = TRUE)
})
You can modify the behavior of the update of checkBoxValues
if you would like to allow other combinations.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
DT::dataTableOutput('x1'),
verbatimTextOutput('x2')
),
server = function(input, output, session) {
# create a character vector of shiny inputs
shinyInput = function(FUN, len, id, value, ...) {
if (length(value) == 1) value <- rep(value, len)
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = value[i]))
}
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)) TRUE else value
}))
}
n = 6
df = data.frame(
included = shinyInput(checkboxInput, n, 'in_', value = TRUE, width='1px'),
excluded = shinyInput(checkboxInput, n, 'ex_', value = FALSE, width='1px'),
ID = seq_len(n),
stringsAsFactors = FALSE)
checkBoxValues <- reactiveVal(
data.frame(ins = rep(TRUE, n), exs = rep(FALSE, n))
)
loopData = reactive({
df$included <<- shinyInput(checkboxInput, n, 'in_', value = checkBoxValues()$ins, width='1px')
df$excluded <<- shinyInput(checkboxInput, n, 'ex_', value = checkBoxValues()$exs, width='1px')
df
})
output$x1 = DT::renderDataTable(
isolate(loopData()),
escape = FALSE, selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))
proxy = dataTableProxy('x1')
observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})
lapply(1:n, function(x) {
observeEvent(input[[paste0("in_", x)]], {
ins <- shinyValue('in_', n)
exs <- shinyValue('ex_', n)
checkBoxValues(data.frame(ins = ins, exs = !ins))
}, ignoreInit = TRUE)
})
lapply(1:n, function(x) {
observeEvent(input[[paste0("ex_", x)]], {
exs <- shinyValue('ex_', n)
checkBoxValues(data.frame(ins = !exs, exs = exs))
}, ignoreInit = TRUE)
})
output$x2 = renderPrint({
data.frame(Inclusion = shinyValue('in_', n),
Exclusion = shinyValue('ex_', n))
})
}
)