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

Question

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

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

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...'）

此时我对所有 ideas/solutions.

开放

谢谢！

Answer 1

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

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

回调使用 bootstrap 工具提示。

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'。有关演示，请参见网站。还可以改变位置，设置隐藏效果等

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

Shorten column names, provide tooltip on hover of full name

r

datatables

shiny

dt

编辑