Keep formatting when exporting table with DT (DataTables buttons extension)

Question

I made a shiny app where someone uploads a file, some ratios are computed, and those ratios can be formatted using sliders for thresholds. I use DT::formatStyle for this and it is working really fine. As far as I understand this function, it creates a callback to handle the conditional formatting.

Then, I want to export the data, using the buttons extension in DT. I want to keep the formatting when exporting to pdf or printing. It turns out that this doesn't work: the data is exported without any formatting. I tried to set exportOptions(list(stripHtml = FALSE)), but it still doesn't work.

What surprises me as well, is that even when I print directly from Firefox (as File/Print... ; I have tried with Firefox only, and the app will only be run in Firefox), the color is dropped, but font weight is kept. I suspect that I may have to tweak the CSS but I do not know how to do that.

I would like to have a way to make the pdf and/or the print "as is", the closest to what I see in the browser. Below is an example:

library(shiny)
library(DT)
library(dplyr)
data("starwars")

ui <- fluidPage(title = "Ratios",
  sidebarLayout(
    sidebarPanel(width = 2,
                 actionButton("button", "Go"), # Emulates data loading
                 sliderInput("seuil_j", "Threshold J",
                             min = 0,  max = 80, value = 35, step = 0.5)),
    mainPanel( 
      fluidRow(column(width = 12,
                      DT::dataTableOutput("ratios"))))
  )
)

server <- function(input, output, session) {
  donnees_ratios <- reactive({
    req(input$button)
    set.seed(14)
    starwars %>% 
      select(1:10) %>% # DataTables is not happy with list columns
      mutate(signe = sample(c(1, -1), replace = TRUE, size = nrow(.)),
             ratio_j = signe * mass / height) %>% 
      select(name, mass, height, signe, ratio_j, everything())
  })

  output$ratios <- DT::renderDataTable({
    donnees_ratios() %>% 
      creer_DT() %>% 
      formatter_DT(input)
  })
}

creer_DT <- function(donnees) {
  datatable(donnees, 
            rownames = FALSE, 
            class = 'cell-border stripe compact hover',
            extensions = c("Buttons"),
            options = list(
              dom = 'Blfrtip',
              buttons = list(
                list(extend = "pdf", 
                     exportOptions = list(stripHtml = FALSE,
                                                     columns = ':visible'),
                     orientation = 'landscape'),
                list(extend = "print", 
                     exportOptions = list(stripHtml = FALSE,
                                          columns = ':visible')),
               "excel", "csv", "colvis"),
              language = list(
                decimal = ",",
                thousands = "&#8239;"  # small unbreakable space
              )
            )
  )
}

formatter_DT <- function(table, input) {
  table %>% 
    formatPercentage(columns = c("ratio_j"),
                     digits = 1L, dec.mark = ",", mark = "&#8239;") %>%
    formatRound(columns = c("height", "mass"),
                digits = 1L, dec.mark = ",", mark = "&#8239;") %>%
    format_seuil("ratio_j", input$seuil_j)
}

format_seuil <- function(table, column, seuil) {
  # Threshold for the aboslute value, and different coloring if higher or lower
  formatStyle(table, column, 
              fontWeight = styleInterval(
                c(-seuil / 100, seuil / 100), c("bold", "normal", "bold")),
              color = styleInterval(
                c(-seuil / 100, seuil / 100), c("red", "black", "orange")
              ))
}

shinyApp(ui, server)

I can export to pdf or print, but the display is modified. I could also generate a pdf with rmarkdown and knitr, but this would be twice the work, and it feels like I miss something using the buttons extension.

I hope that is clear and thanks for helping!

Florian

Answer 1

tl;dr You cannot keep formatting; you have to write a custom JavaScript function.

PDF and print buttons have very different behaviors.

The print button behavior

When you click the print button, you use the user agent (in this use case, the browser) to render the HTML document as a paged document (PDF). There's a W3C standard named CSS Paged Media that defines how CSS rules are applied for paged media.
Theses CSS rules are enclosed in CSS @media print at-rule.
There's a comprehensive guide about CSS Paged Media here: print-css.rocks.

Dealing with CSS Paged Media is not straightforward:

• browsers badly implement CSS Paged Media standards; headless user agents (wkhtmltopdf, weasyprint, XML Prince...) are used to generate PDF with CSS Paged Media. Using one of these user agents is quite easy since pandoc 2.0: they can replace a LaTeX engine.
• when you open a HTML file, browsers do not apply @media print by default (they apply @media screen at-rule). So, it can be hard to figure out @media print rules. The only mean I know to track theses rules is to use the Chrome Developer Tools (open the menu, select More tools and Rendering. In the Rendering panel, you can emulate a paged media selecting print).

Since you want to use a browser to generate a styled PDF, I think CSS paged media rules is an impracticable way. Moreover, using a headless user agent with a dynamic HTML document as a Shiny App is extremely complex. So, my advise is to forget the print button.

The PDF button behavior

DataTables library relies on pdfmake JavaScript library to generate a PDF file. You can apply custom styles passing a JavaScript function to the customize option of the pdfHtml5 button. This function customizes the document object sent to the pdfmake API.

In order to understand the structure of the JSON document object passed by DataTables to pdfmake, you can output it to the browser console:

library(shiny)
library(DT)
library(dplyr)
data("starwars")

ui <- fluidPage(title = "Ratios",
                sidebarLayout(
                  sidebarPanel(width = 2,
                               actionButton("button", "Go"), # Emulates data loading
                               sliderInput("seuil_j", "Threshold J",
                                           min = 0,  max = 80, value = 35, step = 0.5)),
                  mainPanel( 
                    fluidRow(column(width = 12,
                                    DT::dataTableOutput("ratios"))))
                )
)

server <- function(input, output, session) {
  donnees_ratios <- reactive({
    req(input$button)
    set.seed(14)
    starwars %>% 
      select(1:10) %>% # DataTables is not happy with list columns
      mutate(signe = sample(c(1, -1), replace = TRUE, size = nrow(.)),
             ratio_j = signe * mass / height) %>% 
      select(name, mass, height, signe, ratio_j, everything())
  })

  output$ratios <- DT::renderDataTable({
    donnees_ratios() %>% 
      creer_DT() %>% 
      formatter_DT(input)
  })
}

creer_DT <- function(donnees) {
  datatable(donnees, 
            rownames = FALSE, 
            class = 'cell-border stripe compact hover',
            extensions = c("Buttons"),
            options = list(
              dom = 'Blfrtip',
              buttons = list(
                list(extend = "pdf", 
                     exportOptions = list(stripHtml = FALSE,
                                          columns = ':visible'),
                     orientation = 'landscape',
                     customize = JS("function(doc){console.dir(doc);}")),
                list(extend = "print", 
                     exportOptions = list(stripHtml = FALSE,
                                          columns = ':visible')),
                "excel", "csv", "colvis"),
              language = list(
                decimal = ",",
                thousands = "&#8239;"  # small unbreakable space
              )
            )
  )
}

formatter_DT <- function(table, input) {
  table %>% 
    formatPercentage(columns = c("ratio_j"),
                     digits = 1L, dec.mark = ",", mark = "&#8239;") %>%
    formatRound(columns = c("height", "mass"),
                digits = 1L, dec.mark = ",", mark = "&#8239;") %>%
    format_seuil("ratio_j", input$seuil_j)
}

format_seuil <- function(table, column, seuil) {
  # Threshold for the aboslute value, and different coloring if higher or lower
  formatStyle(table, column, 
              fontWeight = styleInterval(
                c(-seuil / 100, seuil / 100), c("bold", "normal", "bold")),
              color = styleInterval(
                c(-seuil / 100, seuil / 100), c("red", "black", "orange")
              ))
}

shinyApp(ui, server)

You can modify a default style. Here's one example changing the font color of the tableHeader style:

customize = JS("function(doc){doc.styles.tableHeader.color='yellow';}"))

For further customization, you have to write your own JavaScript function. Here's an example to format the fifth column with percent:

customize = JS("function(doc){doc.content[1].table.body.forEach(function(el,idx){if(idx>0){el[4].text=String((parseFloat(el[4].text)*100).toFixed(1))+'%'}})}"))