Question

我想在DT应用程序中显示带有自定义嵌套容器的shiny表。用户得出结论，很难区分不同的标题部分，即季度和年份。有没有一种方法可以使标头边框更明显，例如通过添加垂直边框？我宁愿避免按颜色区分标题部分，例如建议的here。这是数据表的示例，仅适用于一年（闪亮的应用程序支持多年）：

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


## quarterly breakdown
df_qrt <- data.frame(
  group = LETTERS[1:6],
  year = rep(2017, 6),
  Q1_2017A = rnorm(6),
  Q1_2017B = rnorm(6),
  Q2_2017A = rnorm(6),
  Q2_2017B = rnorm(6),
  Q3_2017A = rnorm(6),
  Q3_2017B = rnorm(6),
  Q4_2017A = rnorm(6),
  Q4_2017B = rnorm(6)
)

sketch_qrt = htmltools::withTags(
  table(class = 'display',
        thead(tr(
          th(class = 'dt-center', 
             rowspan = 3,
             'Group'),
          lapply(unique(df_qrt$year),
                 th, colspan = 8)
        ),
        tr(class = 'dt-center', 
          lapply(paste0('Q', 1:4),
                 th, colspan = 2)
        ),

        tr(lapply(rep(
          c('Alpha', 'Beta'), 4
        ), th))
        ))
)


DT::datatable(dplyr::select(df_qrt, -year),
              container = sketch_qrt,
              class = 'cell-border',
              rownames = FALSE,
              fillContainer = TRUE)

Answer 1

sketch_qrt = htmltools::withTags(
  table(class = 'display',
        thead(tr(
          th(class = 'dt-center', style = "border-top: solid 3px",
             rowspan = 3,
             'Group'),
          lapply(unique(df_qrt$year), style = "border-top: solid 3px",
                 th, colspan = 8)
        ),
        tr(class = 'dt-center', 
           lapply(paste0('Q', 1:4),
                  th, colspan = 2)
        ),

        tr(lapply(rep(
          c('Alpha', 'Beta'), 4
        ), th))
        ))
)

headerCallback <- c(
  "function(thead, data, start, end, display){",
  "  $(thead).closest('thead').find('th').css('border-right', 'solid 3px');",
  "  $(thead).closest('thead').find('th').eq(0).css('border-left', 'solid 3px');",
  "}"
)

DT::datatable(dplyr::select(df_qrt, -year),
              container = sketch_qrt,
              class = 'cell-border',
              rownames = FALSE,
              fillContainer = TRUE, 
              options = list(headerCallback = JS(headerCallback)))

要使用其他颜色，请执行"border-top: solid orange 3px"等。

DT和闪亮：使页眉边框更明显

1 个答案: