Search code examples
rshinydt

R data table column headers over multiple rows

I have a question that has been somehow asked in the past but not exactly in the way I need. I have the following R dataframe:

df <- data.frame(Identifier=c(1,2,3,4), STATE=c('NY','CA','TX','FL'), STATE_NAME=c("New York","California","Texas","Florida"),CRIME_RATE=c(0.2, 0.3, 0.35, 0.4), EMPLOYMENT=c(0.8,0.8,0.7,0.5))

Now, I would need to display the dataframe like this: enter image description here

I read https://rstudio.github.io/DT/ section 2.6 however, the example there doesn't have multiple rows for each individual column header. Same problem here: Center custom data table container column headers in Shiny I found solution Rstudio shiny renderDataTable headers multi line? interesting in the sense that perhaps using html
could have allowed me to use one single column header but displayed over multiple rows, however it doesn't seem to work. This is my output code. Notice I use extensions = "Buttons", because the actual dataframe is way bigger and this allows users to export the data to csv and excel.

output$output_table <- renderDataTable({
df <- data.frame(Identifier=c(1,2,3,4), STATE=c(NY,CA,TX,FL), STATE_NAME=c("New York","California","Texas","Florida"),CRIME_RATE=c(0.2, 0.3, 0.35, 0.4), EMPLOYMENT=c(0.8,0.8,0.7,0.5))

df <- datatable(df, 
                  rownames= F,
                  filter = 'top',
                  extensions = "Buttons",
                  options = list(scrollX = TRUE
                                 , autoWidth = TRUE
                                 , pageLength = 66
                                 , dom = 'Blfrtip'
                                 ,buttons = c('copy', 'csv', 'excel', 'pdf')
                  ))  
return(df)
                        
})
Solution

  • I came up with a solution that does work:

    library(shiny)
library(shinydashboard)
library(shinyBS)
library(dplyr)
library(lubridate)
library(DT)

ui <- fluidPage(
  
  mainPanel(
    h3("Table:"),
    dataTableOutput("sample_table1"),
    br(),
    dataTableOutput("sample_table2"),
    br(),
    dataTableOutput("sample_table3")
  )
  
)

server <- function(input, output, session) {   
  
      output$sample_table1 <- renderDataTable({  #
              df <- head(mtcars, 5)
              
              cat("\n\n* IN THIS EXAMPLE,WE TEST SHOWING A TABLE WITH COLUMN HEADERS THAT CONSIST IN MULTIPLE ROWS")
              # https://rstudio.github.io/DT/  -->  table container
              
              sketch = htmltools::withTags(table(
                class = 'display',
                thead(
                  tr(
                    th(rowspan = 2, 'Metric'),
                    th(colspan = 1, 'mpg'),
                    th(colspan = 1, 'cyl'),
                    th(colspan = 1, 'disp'),
                    th(colspan = 1, 'hp'),
                    th(colspan = 1, 'drat'),
                    th(colspan = 1, 'wt'),
                    th(colspan = 1, 'qsec'),
                    th(colspan = 1, 'vs'),
                    th(colspan = 1, 'am'),
                    th(colspan = 1, 'gear'),
                    th(colspan = 1, 'carb')
                  ),
                  tr(
                    lapply(rep(colnames(df), 1), th)
                  )
                )
              ))
              
              datatable(df, container = sketch, rownames = T)
      })
      
      
      output$sample_table2 <- renderDataTable({  #
            df <- head(mtcars, 5)
            
            cat("\n\n* IN THIS EXAMPLE,WE TEST SHOWING A TABLE WITH COLUMN HEADERS THAT CONSIST IN 2 rows, WITH THE COL NAMES TAKEN DIRECTLY FROM THE DATAFRAME")
            # https://rstudio.github.io/DT/  -->  table container
            
            v_col_names_lowest_labels <- c("",colnames(df))
            
            sketch = htmltools::withTags(table(
              class = 'display',
              thead(
                      th(
                          lapply(colnames(df), th)
                      ),
                      
                      tr(
                          lapply(v_col_names_lowest_labels, th)
                      )
                   )
            ))
            
            datatable(df, container = sketch, rownames = T)
        
      })
      
      
      output$sample_table3 <- renderDataTable({  #
            df <- head(mtcars, 5)
            
            cat("\n\n* IN THIS EXAMPLE,WE TEST SHOWING A TABLE WITH COLUMN HEADERS THAT CONSIST IN MULTIPLE ROWS")
            # https://rstudio.github.io/DT/  -->  table container
            
            v_col_names_lowest_labels <- c("",colnames(df))
            
            sketch = htmltools::withTags(table(
              class = 'display',
              thead(
                tr(
                  lapply(v_col_names_lowest_labels, th)
                ),
                tr(
                  lapply(v_col_names_lowest_labels, th)
                ),
                tr(
                  lapply(v_col_names_lowest_labels, th)
                )
              )
            ))
            
            datatable(df, container = sketch, rownames = T)
        
      })
}


cat("\nLaunching   'shinyApp' ....")
shinyApp(ui, server)