缩短列名，在全名悬停时提供工具提示

Question

我有一个datatable，我在一个简单的 R Shiny 应用程序中显示它。我有很多长列名，这使我无法最大限度地使用水平屏幕空间。我想做两件事：

1. 缩写或截断每列名称，使每列都很窄（与当前状态相比，请参阅下面的 MRE）。理想情况下，我希望每列的宽度仅与包含最长数据字符串的单元格一样宽（例如，在下面的第 1 列中，列宽不应超过“AAAAA”占用的空间量）。默认情况下，datatable 表格看起来很厚实，而且它们并没有最大限度地利用屏幕空间。
2. 将鼠标悬停在缩写/截断的列名上时，会向用户显示全长名称。

x<-data.frame(a_long_column_name = c("AAAAA", "AAA", "AAA", "BBB", "BBB", "CCC"), 
              a_really_unnecessarily_long_column_name = c("Alice", "Alice", "Alice", "Bob", "Bob", "Charlie"),
              a_silly_and_unnecessarily_long_column_name_which_i_cant_change = c("T-Shirt", "Pants", "Socks", "Socks", "Pants", "T-Shirt"),
              another_silly_and_unnecessarily_long_column_name_which_i_cant_change = c("Red", "Orange", "Green", "Blue", "Purple", "Yellow"))


library(shiny)
library(tidyverse)
library(DT)

runApp(list(

  ui = basicPage(
    DT::dataTableOutput('mytable')
  ),

  server = function(input, output) {
    output$mytable = DT::renderDataTable({
      x<-datatable(x, selection = "single", filter = "top")
    })
  }
))

我相信可以使用基本 abbreviate() 来缩写列名，例如：

colnames(x) <- sapply(names(x), function(x) abbreviate(x, minlength = 16))

但缩写词变得难以阅读，我仍然无法弄清楚如何实现上面第 2 点中概述的悬停功能。

我认为最好的解决方案可能是将每个列名截断 x 个字符（例如，如果 x = 12，那么第 1 列将变为 'a_long_colum...' 而第 2 列将变为 'a_really_unn...'）

在这一点上，我对任何和所有想法/解决方案持开放态度。

谢谢！

Answer 1

只要对您有意义，您可以使用任何方法来缩写列名。

要创建工具提示，您需要将列名文本转换为 HTML 并添加 title、data-toggle 属性以在回调中使用。

回调使用引导工具提示。

library(shiny)
library(tidyverse)
library(DT)
library(glue) # for easier text concatenation

runApp(list(

    ui = basicPage(
        tags$head(
            tags$style(
                # this line is added because some column names are way too long
                # and the default max width of tooltip cannot contain them
                ".tooltip-inner {max-width: 500px; /* the minimum width */}" 
            )
        ),
        DT::dataTableOutput('mytable')
    ),

    server = function(input, output) {
        output$mytable = DT::renderDataTable({
            x<-datatable(
                x, 
                selection = "single", 
                filter = "top",
                # title is the content displayed in tooltip
                # data-toggle='tooltip' is used as selector in callback function
                # Now I'm using first 5 characters and ... as default column names, but you're free to use other abbreviation methods
                colnames = glue(
                    "<span title={colnames(x)} data-toggle='tooltip'>{substr(colnames(x),1,5)}...</span>"
                ),
                # bind pop-up to table headers
                callback = JS("$('#mytable').tooltip({selector:'[data-toggle=\"tooltip\"]'})"),
                # parse content as HTML(don't escape)
                escape = FALSE
            )
        })
    }
))

Answer 2

这是一个带有headerCallback 的解决方案。

library(shiny)
library(DT)
library(glue) # for easier text concatenation

x <- data.frame(a_long_column_name = c("AAAAA", "AAA", "AAA", "BBB", "BBB", "CCC"), 
                a_really_unnecessarily_long_column_name = c("Alice", "Alice", "Alice", "Bob", "Bob", "Charlie"),
                a_silly_and_unnecessarily_long_column_name_which_i_cant_change = c("T-Shirt", "Pants", "Socks", "Socks", "Pants", "T-Shirt"),
                another_silly_and_unnecessarily_long_column_name_which_i_cant_change = c("Red", "Orange", "Green", "Blue", "Purple", "Yellow"))

headerCallback <- c(
  "function(thead, data, start, end, display){",
  sprintf("  var tooltips = [%s];", toString(paste0("'", colnames(x), "'"))),
  "  for(var i = 1; i <= tooltips.length; i++){",
  "    $('th:eq('+i+')',thead).attr('title', tooltips[i-1]);",
  "  }",
  "}"
)

runApp(list(

  ui = basicPage(
    DTOutput('mytable')
  ),

  server = function(input, output) {
    output$mytable = renderDT({
      datatable(
        x, 
        selection = "single", 
        filter = "top",
        colnames = glue(
          "{substr(colnames(x),1,5)}..."
        ),
        options = list(
          headerCallback= JS(headerCallback)
        )
      )
    })
  }
))

---

编辑

这是使用qTip2 library 的解决方案。

library(shiny)
library(DT)
library(glue) # for easier text concatenation

x <- data.frame(a_long_column_name = c("AAAAA", "AAA", "AAA", "BBB", "BBB", "CCC"), 
                a_really_unnecessarily_long_column_name = c("Alice", "Alice", "Alice", "Bob", "Bob", "Charlie"),
                a_silly_and_unnecessarily_long_column_name_which_i_cant_change = c("T-Shirt", "Pants", "Socks", "Socks", "Pants", "T-Shirt"),
                another_silly_and_unnecessarily_long_column_name_which_i_cant_change = c("Red", "Orange", "Green", "Blue", "Purple", "Yellow"))

qTips <- function(titles){
  settings <- sprintf(paste(
    "{",
    "  content: {",
    "    text: '%s'",
    "  },",
    "  show: {",
    "    ready: false",
    "  },",
    "  position: {",
    "    my: 'bottom %%s',",
    "    at: 'center center'",
    "  },",
    "  style: {",
    "    classes: 'qtip-youtube'",
    "  }",
    "}",
    sep = "\n"
  ), titles)
  n <- length(titles)
  settings <- sprintf(settings, ifelse(1:n > n/2, "right", "left"))
  sprintf("var tooltips = [%s];", paste0(settings, collapse=","))
}

headerCallback <- c(
  "function(thead, data, start, end, display){",
  qTips(colnames(x)),
  "  for(var i = 1; i <= tooltips.length; i++){",
  "    $('th:eq('+i+')',thead).qtip(tooltips[i-1]);",
  "  }",
  "}"
)

runApp(list(

  ui = basicPage(
    tags$head(
      tags$link(rel = "stylesheet", type = "text/css", href = "https://cdnjs.cloudflare.com/ajax/libs/qtip2/3.0.3/jquery.qtip.css"), 
      tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/qtip2/3.0.3/jquery.qtip.js")
    ),
    br(),
    DTOutput('mytable')
  ),

  server = function(input, output) {
    output$mytable = renderDT({
      datatable(
        x, 
        selection = "single", 
        filter = "top",
        colnames = glue("{substr(colnames(x),1,5)}..."),
        options = list(
          headerCallback= JS(headerCallback)
        )
      )
    })
  }
))

这些工具提示可通过设置style.classes 属性进行自定义。例如使用这个 CSS：

           .myqtip { 
             font-size: 15px;
             line-height: 18px;
             background-color: rgb(245,245,245,0.8);
             border-color: rgb(54,57,64);
           }

并设置classes: 'myqtip' 而不是classes: 'qtip-youtube'。有关演示，请参见网站。还可以改变位置，设置隐藏效果等。