Сократите имена столбцов, предоставьте всплывающую подсказку при наведении полного имени - PullRequest
Новая
       7

Сократите имена столбцов, предоставьте всплывающую подсказку при наведении полного имени

1 голос
/ 24 сентября 2019

У меня есть 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 ... ')

На данный момент я открыт для любых идей и решений.

Спасибо!

Ответы [ 2 ]

2 голосов
/ 24 сентября 2019

Вы можете использовать любые методы для сокращения имен столбцов, если это имеет смысл для вас.

Для создания всплывающих подсказок необходимо преобразовать текст названия столбца в 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
            )
        })
    }
))
1 голос
/ 24 сентября 2019

Вот решение с 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(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)
        )
      )
    })
  }
))

enter image description here

Эти всплывающие подсказки можно настраивать путем установки атрибута 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'.Смотрите сайт для демонстраций.Вы также можете изменить положение, установить эффект скрытия и т. Д.

...