Search code examples
rshinydtrhandsontable

R shiny DT checkboxes on top to tick/untick all the checkboxes below

I'm looking for a simple way to select data organised by row with some attributes (namely, year of collection of these data) by column. The columns would be '2016', '2017', '2018' and on each row below each of these columns there should be a checkbox indicating whether the data on this row and for this year should be selected. After this selection has been made, some action (e.g. export) could be performed through a button on this selection. So, nothing exceptional. As there are approx. 1 000 rows in total I would like to speed up a bit the selection proces by allowing the user to select or unselect a whole column (i.e. a whole year).

If possible I would like to do that with DT. I saw already some related threads, here and there, for instance, but nothing "systematic" (i.e. put select/unselect all checkboxes on top of a subset of columns) as I need here.

Do you know a quick and simple way to do that with DT?

An alternative would be with rhandsontable but I have the feeling it's somehow like using a hammer to kill a fly...

[EDIT]: Added reprex below

Inspired from 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")

I made progress towards what I am ultimately looking for but I still have an issue: in the reprex below, only the check boxes on the first page are activated or deactivated. Would someone know how to extend the (un)select all effect to all pages, i.e. to the whole 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")

[EDIT]: I'm still working on this problem. I recently split it into simpler problems and by doing so I found a new issue (described after the reproducible example). I am now dynamically printing the values of the relevant inputs to better understand how everything works. The focus is here on the function Generate_observeEvent_Rows.

Below is a reproducible example:


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 <- 40
# 2 + length(Years_Augmented): the first 2 columns are 'Group' and 'Country'
# The next columns are, at first, numbers (the reporting years), except for the last one, 'All_Years'
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)
# The cells of the data.frame 'MyDataFrame' in the columns 'Years_Augmented' are checkboxInputs. They are named 'CheckBox_2016_1' where '2016' is the year from 'Years_Augmented' and '1' is the row ID.
MyDataFrame[names(MyDataFrame) %in% Years_Augmented] <- lapply(X = Years_Augmented, FUN = function(x){Generate_shinyInputs(checkboxInput, 1:nRows, paste0("CheckBox_", x, "_"), NULL, value = TRUE)})
# The very names of the last columns ('Years_Augmented') of the data.frame 'MyDataFrame' are thereafter transformed into checkboxInputs. They are named 'CheckBox_2016' where '2016' is the year of the original version of 'Years_Augmented'. The last column then generates 'CheckBox_All_Years'.
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)]]
            
            print(paste0("Value of the observed variable '", paste0("CheckBox_", Year), "' = ", CheckBox.Value))
            
            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); print(paste0("After update: ", input[[paste0("CheckBox_", y, "_", x)]]))})})
                lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x), value = CheckBox.Value); print(paste0("After update: ", input[[paste0("CheckBox_", x)]]))})
            }
            else    # Only one single year was (de)selected (checked/unchecked)
            {
                lapply(X = 1:nRows, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", Year, "_", x), value = CheckBox.Value); print(paste0("After update: ", input[[paste0("CheckBox_", Year, "_", x)]]))})
            }
        })#, ignoreNULL = TRUE, ignoreInit = TRUE)
    }
    
    # Generate the observe events for each row of the column 'All_Years' check boxes (not the top row but the rows below) - 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)
            print(paste0("Value of the observed variable '", paste0("CheckBox_All_Years_", Row), "' = ", CheckBox.Value))
            
            lapply(X = Years, FUN = function(x){print(paste0("Before update of '", paste0("CheckBox_", x, "_", Row), "': ", input[[paste0("CheckBox_", x, "_", Row)]]))})
            lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x, "_", Row), value = CheckBox.Value)})
            lapply(X = Years, FUN = function(x){print(paste0("After update of '", paste0("CheckBox_", x, "_", Row), "': ", input[[paste0("CheckBox_", x, "_", Row)]]))})
        })#, 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')
    #'MyDataFrame' should be updated every time a check box is clicked!
    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());}')
        )
    )
    
    #proxy <- DT::dataTableProxy("MyTable")
}

shinyApp(ui = ui, server = server, enableBookmarking = "server")

What I don't understand is that when I click on any of the 'All_Years' column checkbox on one arbitrary row (except of course on the top row, the header), the behaviour of the checkboxes on the same row from 2016 to 2020 is in line with what is expected (i.e. when 'All_Years' on the same row is checked, they become checked, when 'All_Years' on the same row is unchecked, they become unchecked) but their value is not correctly updated: they are always "lagging one step behind".

Do you know why?

Besides, interestingly, we see that only the first 10 rows (the visible part of the table, the current page) of the inputs values are initially displayed in the console (with print). But that's the next problem to be tackled.

Solution

  • Something like that:

    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);",
    "  });",
    "});"
  )
)

    enter image description here

    And add the preDrawCallback and the drawCallback for Shiny.

    EDIT

    As noted by @Olivier in a comment, the box-checking is performed on the current page only. Here is a solution to this issue:

    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)