rshinydt

How to create mutually dependent checkbox columns in a DT table?


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))
    })
  }
)


enter image description here


Solution

  • 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)
        })
    

    enter image description here

    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))
        })
      }
    )