在 R 闪亮应用程序中的数据表中的字段名称上方添加附加标签

Question

I am attempting to add multiple additional labels above field names in a grouped datatable in R, which will then be rendered as a datatable in a Shiny app.

For example, using iris data, I would like each species to be grouped, then have their Sepal Lengths be summarized (max is longest, min is shortest, etc.), along with their Sepal Widths, Petal Lengths, and Petal Widths. In this example, the additional labels added would be "Sepal Length", "Sepal Width", "Petal Length", and "Petal Width" above their respective Max/Avg/Min sub columns. The image here is a Microsoft Excel recreation of what I am looking for.

This is a link to a possible solution , but I have had no luck trying to replicate this for multiple labels. Here is my code attempting to recreate the solution in the above link, using the iris data.

df3<-data.frame(iris)

grouped_df3<- df3 %>%
  group_by(Species) %>%
  summarize("#"=n(),
            Max_Sepal_W=max(Sepal.Width, na.rm = TRUE),
            Avg_Sepal_W=mean(Sepal.Width, na.rm = TRUE),
            Min_Sepal_W=min(Sepal.Width, na.rm = TRUE),
            Max_Sepal_L=max(Sepal.Length, na.rm = TRUE),
            Avg_Sepal_L=mean(Sepal.Length, na.rm = TRUE),
            Min_Sepal_L=min(Sepal.Length, na.rm = TRUE) )


class(grouped_df3) <- c( "Question", class(grouped_df3) )

print.Question <- function( x, ... ) {
  if( ! is.null( attr(x, "Question") ) ) {
    cat("Question:", attr(x, "Question"), "\n")
  }
  print.data.frame(x)
}
attr(grouped_df3, "Question") <- "Age"
attributes(grouped_df3)
head(grouped_df3)

# found here: https://stackoverflow.com/questions/9274548/add-a-row-above-row-headers-in-r
# does not work with datatables, or with multiple labels

Please let me know if additional info is needed. Thank you in advance for any help!

Answer 1

This answer and this answer were very helpful in providing an approach using DT which could be incorporated into your shiny app.

library(htmltools)
library(DT)

sketch <- withTags(
  table(
    class = "display",
    thead(
      tr(
        th(colspan = 1, "", style = "border-right: solid 2px;"),
        th(colspan = 1, "", style = "border-right: solid 2px;"),
        th(colspan = 3, "Sepal Width", style = "border-right: solid 2px;"),
        th(colspan = 3, "Sepal Length")
      ),
      tr(
        th("Species", style = "border-right: solid 2px;"),
        th("#", style = "border-right: solid 2px;"),
        th("Longest"),
        th("Avg"),
        th("Shortest", style = "border-right: solid 2px;"),
        th("Widest"),
        th("Avg"),
        th("Narrowest"),
      )
    )
  )
)

datatable(grouped_df3, rownames = FALSE, container = sketch, 
          options = list(
            columnDefs = list(
              list(targets = "_all", className = "dt-center")
            )
          )) %>%
  formatStyle(c(1,2,5), `border-right` = "solid 2px")

Output