How to copy multiple row and column headers in a rendered table when using DT table copy function?

Question

A similar question was posted but never answered: r shiny problem with datatable to copy a table with table head (colspan)

When running the below reproducible code, I'd like the DT "copy" button to include ALL table column and row headers, when there are multiple headers. So far DT copy only copies one header.

I have the code to do this using an action button/observeEvent() outside of DT (not shown in below code), but if possible I'd instead like to use DT's native copy clipboard function (like in the code below) because of other benefits it offers including but not limited to simplicity.

The images at the bottom better explain.

Maybe it's not possible. But maybe it is!

Reproducible code:

library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
    State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X9")
  )

numTransit <- function(x, from=1, to=3){
  setDT(x)
  unique_state <- unique(x$State)
  all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
  dcast(x[, .(from_state = State[from], 
              to_state = State[to]), 
          by = ID]
        [,.N, c("from_state", "to_state")]
        [all_states,on = c("from_state", "to_state")], 
        to_state ~ from_state, value.var = "N"
  )
}

ui <- fluidPage(
  tags$head(tags$style(".datatables .display {margin-left: 0;}")), 
  h4(strong("Transition table inputs:")),
  numericInput("transFrom", "From period:", 1, min = 1, max = 3),
  numericInput("transTo", "To period:", 2, min = 1, max = 3),
  h4(strong("Output transition table:")), 
  DTOutput("resultsDT"),
)

server <- function(input, output, session) {
  results <- 
    reactive({
      results <- numTransit(data, input$transFrom, input$transTo) %>% 
        replace(is.na(.), 0) %>%
        bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
      results <- cbind(results, Sum = rowSums(results[,-1]))
    })
 
  output$data <- renderTable(data)
  
  output$resultsDT <- renderDT(server=FALSE, {
    datatable(
      data = results(),
      rownames = FALSE,
      extensions = c("Buttons", "Select"), # for Copy button
      selection = 'none', # for Copy button
      filter = 'none',
      container = tags$table(
        class = 'display',
        tags$thead(
          tags$tr(
            tags$th(rowspan = 2,sprintf('To state where end period = %s',input$transTo),style="border-right: solid 1px;"),
            tags$th(colspan = 10,sprintf('From state where initial period = %s', input$transFrom))),
          tags$tr(mapply(tags$th, colnames(results())[-1], 
                         style = sprintf("border-right: solid %spx;", rep(0, ncol(results()) - 1L)), 
                         SIMPLIFY = FALSE))
        )
      ),
      options = list(scrollX = F, 
                     buttons = list(list(extend = "copy",text = 'Copy',exportOptions = list(modifier = list(selected = TRUE)))), # for Copy button
                     dom = 'Bft', # added 'B' for Copy button
                     lengthChange = T, 
                     pagingType = "numbers", 
                     autoWidth = T, 
                     info = FALSE, 
                     searching = FALSE)
    ) %>%formatStyle(c(1), `border-right` = "solid 1px")
  })
  
}

shinyApp(ui, server)

Additional example:

Below is another, simpler example of trying to copy/paste all headers using DT, starting with the example used in post How to copy tableOutput to clipboard? (however adding the "sketch" container to datatable for a second column header to illustrate the copy/paste issue I'm trying to address):

library(shiny)
library(dplyr)
library(DT)
library(htmltools)

df <- mtcars

one <- function(.data, var, na = TRUE) {
  return({
    .data %>% 
      group_by(.data[[var]]) %>% 
      filter(!is.na(.data[[var]])) %>%
      tally() %>% 
      mutate(`%` = 100*n/sum(n))
    
  })
}

# ADDED SKETCH TO ORIGINAL EXAMPLE:
sketch = htmltools::withTags(table(
  class = 'display',
  thead(tr(th(colspan = 3, 'Table')),
        tr(lapply(c('Variable','n','%'),th))
  )
))

ui <- fluidPage(
  selectInput("var", label = "Select Variable", choices = c("", names(df))),
  DTOutput("valu", width = "15%")
)
server <- function(input, output) {
  
  output$valu <- renderDT({
    if(input$var != '') {
      data <- df %>% one(input$var, na = input$check)
      
      DT::datatable(data, 
                    class = 'cell-border stripe',
                    rownames = FALSE,
                    extensions = c("Buttons", "Select"),
                    selection = 'none',
                    container = sketch, # ADDED SKETCH CONTAINER TO ORIGINAL EXAMPLE
                    options = 
                      list(
                        select = TRUE,
                        dom = "Bt",  
                        buttons = list(
                          list(
                            extend = "copy",
                            text = 'Copy'))
                      )) %>% formatStyle(
                        0,
                        target = "row",
                        fontWeight = styleEqual(1, "bold")
                      ) 
    }
    
  }, server = FALSE)
  
  output$value <- renderTable({ 
    if(input$var != '') {
      data <- df %>% one(input$var, na = input$check)
      return(data)
    }
  },  spacing = "xs",  bordered = TRUE)
}
shinyApp(ui, server)

Answer 1

Hmm... for Copy I don't know yet. But you can export such a table to Excel and then copy from Excel. I agree this is not highly convenient, but I don't know another way. This requires some JS libraries:

tags$script(src = "xlsx.core.min.js"),  # https://github.com/SheetJS/sheetjs/blob/master/dist/xlsx.core.min.js
tags$script(src = "FileSaver.min.js"),  # https://raw.githubusercontent.com/eligrey/FileSaver.js/master/dist/FileSaver.min.js
tags$script(src = "tableexport.min.js"), # https://github.com/clarketm/TableExport/tree/master/dist
tags$link(rel = "stylesheet", href = "tableexport.min.css")

library(shiny)
library(DT)
library(shinyjs)

js_export <- 
  "
var $table = $('#DTtable').find('table');
var instance = $table.tableExport({
  formats: ['xlsx'],
  exportButtons: false,
  filename: 'myTable',
  sheetname: 'Sheet1'
});
var exportData0 = instance.getExportData();
var exportData = exportData0[Object.keys(exportData0)[0]]['xlsx'];
instance.export2file(exportData.data, exportData.mimeType, exportData.filename, 
                     exportData.fileExtension, exportData.merges, 
                     exportData.RTL, exportData.sheetname);
"

ui <- fluidPage(
  useShinyjs(),
  tags$head(
    # put these files in the www subfolder
    tags$script(src = "xlsx.core.min.js"),
    tags$script(src = "FileSaver.min.js"),
    tags$script(src = "tableexport.min.js")
  ),
  
  DTOutput("DTtable"),
  
  actionButton("export", "Export table", class = "btn-primary")
)

sketch <- htmltools::withTags(table(
  class = "display",
  thead(
    tr(
      th(rowspan = 2, "Species"),
      th(colspan = 2, "Sepal"),
      th(colspan = 2, "Petal")
    ),
    tr(
      lapply(rep(c("Length", "Width"), 2), th)
    )
  )
))

server <- function(input, output, session){
  
  output[["DTtable"]] <- renderDT({
    datatable(
      head(iris, 6),
      container = sketch, rownames = FALSE
    ) %>%
      formatPercentage("Sepal.Length") %>%
      formatCurrency("Sepal.Width") 
  })
  
  observeEvent(input[["export"]], {
    runjs(js_export)
  })
  
}

shinyApp(ui, server)

Note that it also takes the formatting into account, but I'm wondering why there are some dates :-/