CODEWITHSUNDEEP
rshinydtrhandsontable
Olivier7121
Olivier7121

Reputation: 333

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.

Upvotes: 2

Views: 1073

Answers (2)

Olivier7121
Olivier7121

Reputation: 333

After 2 long sessions of intensive programming, I finally managed to get exactly what I was ultimately looking for. It was a painful but interesting and rewarding journey. The workaround posted by @ismirsehregal here was pivotal for me to find this solution: many thanks!

Below the code (a bit long):

library(shiny)
library(DT)
#library(magrittr)

Generate_shinyInputs <- function(FUN, Range, id, Label, Value)
{
    vapply(Range, function(i){as.character(FUN(inputId = paste0(id, i), label = if(!is.null(Label)) i else NULL, value = Value[which(Range == i)], width = "150px"))}, character(1))
}

Years <- 2016:2020
Years_Augmented <- c(Years, "All_Years")
nRows <- 400
# ncol of 'DataFrame4ShinySelection' = 2 + length(Years_Augmented): the first 2 columns are 'Group' and 'Country'
# The next columns are, at first, figures/numbers (the reporting years), except for the last one, 'All_Years'
# The very first line/row is for the header of 'DataFrame4ShinyDisplay'
# The subsequent lines/rows (from 2 onwards) are for the subsequent lines/rows of 'DataFrame4ShinyDisplay'
# Actually, it is not necessary to have the first row (header of 'DataFrame4ShinyDisplay') and the last column ('All_Years') in 'DataFrame4ShinySelection' as they drive the other cells; these other cells are the real target.
DataFrame4ShinySelection <- data.frame(matrix(nrow = 1 + nRows, ncol = 2 + length(Years_Augmented)), stringsAsFactors = FALSE)
colnames(DataFrame4ShinySelection) <- c("Group", "Country", Years_Augmented)
DataFrame4ShinySelection[names(DataFrame4ShinySelection) == "Group"] <- c("Group_Header", paste0("Group_", 1:nRows))
DataFrame4ShinySelection[names(DataFrame4ShinySelection) == "Country"] <- c("Country_Header", rep(c("AT", "BE", "BG", "CY", "DE", "ES", "FI", "GR", "HU", "IE", "IT"), length.out = nRows))
# Within the columns 'Years_Augmented', the cells of the data.frame:
#   - 'DataFrame4ShinyDisplay' are checkboxInputs. They are named 'CheckBox_2016_1' where '2016' is the year from 'Years_Augmented' and '1' is the row ID.
#   - 'DataFrame4ShinySelection' are booleans (TRUE/FALSE) storing the results of the associated checkboxes. All checkboxes are initialised as checked (TRUE).
DataFrame4ShinySelection[names(DataFrame4ShinySelection) %in% Years_Augmented] <- TRUE

# First line/row of 'DataFrame4ShinySelection' is the header of 'DataFrame4ShinyDisplay'
DataFrame4ShinyDisplay <- DataFrame4ShinySelection[-1,]

Generate_DataFrame4ShinyDisplay <- function(InputDataFrame, Vector_Columns, Vector_Rows)
{
    # checkboxInputs are named 'CheckBox_2016_1' where '2016' is the year from 'Years_Augmented' and '1' is the row ID.
    DataFrame4ShinyDisplay[which(names(InputDataFrame) %in% Vector_Columns)][Vector_Rows,] <<- lapply(X = Vector_Columns, FUN = function(x){Generate_shinyInputs(checkboxInput, Vector_Rows, paste0("CheckBox_", x, "_"), NULL, Value = InputDataFrame[names(InputDataFrame) == x][1 + Vector_Rows,])})
    # The very names of the last columns ('Years_Augmented') of the data.frame 'DataFrame4ShinyDisplay' are thereafter transformed into checkboxInputs.
    # They are named 'CheckBox_2016' where '2016' is the year of 'Years_Augmented'. The last column then generates 'CheckBox_All_Years'.
    colnames(DataFrame4ShinyDisplay)[which(names(InputDataFrame) %in% Vector_Columns)] <<- Generate_shinyInputs(checkboxInput, Vector_Columns, "CheckBox_", TRUE, Value = unlist(unname(InputDataFrame[names(InputDataFrame) %in% Vector_Columns][1,])))
    DataFrame4ShinyDisplay
}

#Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection, Years_Augmented, 1:nRows)

ui <- fluidPage(
        
        mainPanel(
            DT::dataTableOutput("MyTable"),
            actionButton(inputId = "Button_Export_Selection", label = "Export selection"),
            #submitButton("Export selection", icon("file-export")),
            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)]]
            # Indices of rows on all pages (after the table is filtered by the search strings)
            FilteredRows <- input[["MyTable_rows_all"]]
            #print(paste0("Filtered rows = ", FilteredRows))
            Vector_Rows <- intersect(FilteredRows, 1:nRows)
            #print(paste0("Vector_Rows = ", Vector_Rows))
            
            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)]]))})
                if(CheckBox.Value != DataFrame4ShinySelection[names(DataFrame4ShinySelection) == 'All_Years'][1,])
                {
                    DataFrame4ShinySelection[c(1, Vector_Rows + 1), names(DataFrame4ShinySelection) %in% Years_Augmented] <<- CheckBox.Value
                    DT::replaceData(MyTable_proxy, Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection, Years_Augmented, Vector_Rows), resetPaging = FALSE, rownames = FALSE)
                    lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x), value = CheckBox.Value)})
                }
            }
            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)]]))})
                if(CheckBox.Value != DataFrame4ShinySelection[names(DataFrame4ShinySelection) == Year][1,])
                {
                    DataFrame4ShinySelection[c(1, Vector_Rows + 1), names(DataFrame4ShinySelection) == Year] <<- CheckBox.Value
                    DT::replaceData(MyTable_proxy, Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection, Year, Vector_Rows), resetPaging = FALSE, rownames = FALSE)
                }
            }
        })#, 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)]]
            if(CheckBox.Value != DataFrame4ShinySelection[names(DataFrame4ShinySelection) == 'All_Years'][Row + 1,])
            {
                #lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x, "_", Row), value = CheckBox.Value)})
                DataFrame4ShinySelection[names(DataFrame4ShinySelection) %in% Years_Augmented][Row + 1,] <<- CheckBox.Value
                DT::replaceData(MyTable_proxy, Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection, Years_Augmented, Row), resetPaging = FALSE, rownames = FALSE)
            }
            
            #lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x, "_", Row), value = CheckBox.Value)})
        })#, ignoreNULL = TRUE, ignoreInit = TRUE)
    }
    
    #Generate the observe events for all the other checkboxes ("CheckBox_", x, "_", Row) because the selection of these (individual and without side effects on other checkboxes) checkboxes is not saved when e.g. a filter is applied
    # Actually adapt 'Generate_observeEvent_Rows' with 2 arguments: c(Year, Row). Not necessarily...
    Generate_observeEvent_StandaloneCells <- function(Year, Row)
    {
        observeEvent(input[[paste0("CheckBox_", Year, "_", Row)]],
        {
            CheckBox.Value <- input[[paste0("CheckBox_", Year, "_", Row)]]
            if(CheckBox.Value != DataFrame4ShinySelection[names(DataFrame4ShinySelection) == Year][Row + 1,])
            {
                #lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x, "_", Row), value = CheckBox.Value)})
                DataFrame4ShinySelection[names(DataFrame4ShinySelection) == Year][Row + 1,] <<- CheckBox.Value
                DT::replaceData(MyTable_proxy, Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection, Year, Row), resetPaging = FALSE, rownames = FALSE)
            }
        })
    }
    
    lapply(X = Years_Augmented, FUN = function(x){Generate_observeEvent_Columns(x)})
    lapply(X = 1:nRows, FUN = function(x){Generate_observeEvent_Rows(x)})
    lapply(X = Years, FUN = function(Year){lapply(X = 1:nRows, FUN = function(Row){Generate_observeEvent_StandaloneCells(Year, Row)})})
    
    observeEvent(input[["Button_Export_Selection"]],
    {
        #DataFrame4ShinySelection[names(DataFrame4ShinySelection) == 2016] <<- !DataFrame4ShinySelection[names(DataFrame4ShinySelection) == 2016][1,]
        #DT::replaceData(MyTable_proxy, Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection))
        # Copy the Shiny inputs (checkboxes) to 'DataFrame4ShinySelection'
        # First, the header (not really necessary but useful for debugging purposes)
        #lapply(X = Years_Augmented, FUN = function(x){print(paste0(paste0("CheckBox_", x), " = ", input[[paste0("CheckBox_", x)]]))})
        #print(input[[paste0("CheckBox_", Years_Augmented)]])
        #lapply(X = Years_Augmented, FUN = function(x){DataFrame4ShinySelection[names(DataFrame4ShinySelection) == x][1,] <<- input[[paste0("CheckBox_", x)]]})
        #print("Before second lapply")
        #DataFrame4ShinySelection[names(DataFrame4ShinySelection) %in% Years_Augmented][1,] <<- input[[paste0("CheckBox_", Years_Augmented)]]
        # Second, the other (main) checkboxes
        #lapply(X = Years_Augmented, FUN = function(x){DataFrame4ShinySelection[names(DataFrame4ShinySelection) == x][2:(1 + nRows),] <<- input[[paste0("CheckBox_", x, "_", 1:nRows)]]}})
        #lapply(X = Years_Augmented, FUN = function(x){for (i in seq(nRows)){print(paste0(paste0("CheckBox_", x, "_", i), " = ", input[[paste0("CheckBox_", x, "_", i)]])); DataFrame4ShinySelection[names(DataFrame4ShinySelection) == x][1 + i,] <<- ifelse(is.null(input[[paste0("CheckBox_", x, "_", i)]]), DataFrame4ShinySelection[names(DataFrame4ShinySelection) == x][1 + i,], input[[paste0("CheckBox_", x, "_", i)]])}})
        #for (i in seq(nRows)){DataFrame4ShinySelection[names(DataFrame4ShinySelection) == 2017][1 + i,] <<- input[[paste0("CheckBox_", 2017, "_", i)]]}
        #print("After second lapply")
        #TmpData <- DataFrame4ShinySelection
        #TmpData[names(TmpData) %in% Years_Augmented] <- TRUE
        #DT::replaceData(MyTable_proxy, Generate_DataFrame4ShinyDisplay(TmpData))
    })
    
    # output$MyTable = DT::renderDataTable(MyDataFrame, rownames = FALSE, server = FALSE, escape = FALSE, selection = 'none')
    # 'MyDataFrame' should be updated every time a check box is clicked! No, not necessarily
    # For filters below each column name: filter = 'top'
    output$MyTable <- DT::renderDataTable({
        DT::datatable(Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection, Years_Augmented, 1:nRows), rownames = FALSE, escape = FALSE, filter = 'none', selection = 'none', options = list(
        ordering = F,
        #pageLength = 10,
        preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
    }, server = TRUE)
    
    MyTable_proxy <- DT::dataTableProxy("MyTable")
}

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

Some lessons learnt - some are really tricky and even cryptic:

  1. My function Generate_shinyInputs defined in the 3rd 'answer' was buggy when the Shiny inputs were to be initialised not with a single value but with a whole vector of values: it didn't set the value of the Shiny input correctly when the input as a vector was entered (just interpreted it as a scalar, so only its first value).
  2. I didn't know/never used the functions DT::replaceData and DT::dataTableProxy: that's powerful and clean (no need to write explicit JS code).
  3. I didn't know DT::datatable was necessary within DT::renderDataTable. Without that it doesn't work. I don't understand why to be honest.
  4. To avoid a systematic crash when rownames = FALSE is set in the options of DT::renderDataTable, the same option has to be set in DT::replaceData, e.g. DT::replaceData(MyTable_proxy, Generate_DataFrame4ShinyDisplay(DataFrame4ShinySelection, Years_Augmented, Row), resetPaging = FALSE, rownames = FALSE).
  5. To avoid a systematic crash and unintended sorting operations when checking the header checkboxes, the option ordering = F should be set in the options of DT::renderDataTable.
  6. The option server = TRUE should be set in the options of DT::renderDataTable.
  7. Bookmarking causes a crash when launching the app, hence shinyApp(ui = ui, server = server)#, enableBookmarking = "server").
  8. For some obscure reasons, the header checkboxes (except of course All_Years) are not updated/refreshed automatically when clicking on All_Years; the data are correctly updated but graphically they stay in the same state. That's why I had to add lapply(X = Years, FUN = function(x){updateCheckboxInput(session, paste0("CheckBox_", x), value = CheckBox.Value)}) - again, for pure refreshing graphical reasons as the underlying data are correctly updated.
  9. Perhaps obvious but still, I didn't think about it immediately: even the 'standalone' checkboxes (i.e. the ones that are not on the header and not in the right-hand side column All_Years) should be updated dynamically 'under the hood' with replaceData; indeed, when a filter is applied ('Search' box in the top right-hand corner), the selection is lost.

[EDIT]: Amended the code so that the year selections (in the header) are only applied to the filtered rows if the search function (the filter) is used and not to the whole table/rows:

FilteredRows <- input[["MyTable_rows_all"]]
Vector_Rows <- intersect(FilteredRows, 1:nRows)

Upvotes: 1

St&#233;phane Laurent
St&#233;phane Laurent

Reputation: 84529

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)

Upvotes: 3

Related Questions