多行的 R 数据表列标题

Question

我有一个问题在过去以某种方式被问过，但不完全是我需要的方式。我有以下 R 数据框：

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))

现在，我需要像这样显示数据框：

我阅读了https://rstudio.github.io/DT/ 第 2.6 节，但是，每个单独的列标题没有多行的示例。 同样的问题：Center custom data table container column headers in Shiny 我发现解决方案 Rstudio shiny renderDataTable headers multi line? 很有趣，因为也许使用 html
可以让我使用一个列标题但显示在多行上，但它似乎不起作用。 这是我的输出代码。请注意，我使用 extensions = "Buttons"，因为实际的数据框要大得多，这允许用户将数据导出到 csv 和 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)
                        
})

Answer 1

作为一个完全不懂 HTML/CSS 的新手，我发现很难做到这一点，并想出了一个我敢肯定不是最优雅但确实有效的解决方案！ 我在这里分享一个脚本的完整代码，人们可以简单地完全复制和粘贴这些代码，以便在他们的机器上查看这个示例。 我希望它可能会有所帮助。

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)