R Shiny - сделать дополнительную строку заголовка таблицы kable «липкой» - PullRequest
Новая
       25

R Shiny - сделать дополнительную строку заголовка таблицы kable «липкой»

1 голос
/ 03 марта 2020

В пакете kableExtra есть отличная функция под названием add_header_above(), которая создает дополнительную строку заголовка в выходной таблице поверх фактических имен столбцов. Это может быть очень полезно для группировки данных. При настройке fixed_thead = TRUE в kable_styling() фактические имена столбцов при прокрутке останавливаются, но эта дополнительная строка заголовка отсутствует.

Вот минимальное приложение shiny, которое показывает, что я имею в виду. Обратите внимание, что если вы просматриваете приложение в средстве просмотра RStudio, ни заголовок обычного столбца, ни дополнительные не являются липкими. Вместо этого запустите его в соответствующем веб-браузере. 

library(shiny)
library(magrittr)

ui <- fluidPage(
  tableOutput("table")
)

server <- function(input, output, session) {
  output$table <- function() {
    knitr::kable(mtcars) %>%
      kableExtra::kable_styling(fixed_thead = TRUE) %>%
      kableExtra::add_header_above(c(" " = 1, "Header 1" = 5, "Header 2" = 6))
  }
}

shinyApp(ui, server)

Как сделать дополнительную строку заголовка, созданную с помощью add_header_above() sticky? Думаю, мне нужно будет включить некоторые CSS или JavaScript в приложении для этого.

Ответы [ 2 ]

3 голосов
/ 04 марта 2020

Вдохновение приходит от ответа @ Стефана Лорана. Ниже приведен более общий c подход для применения свойства sticky к любому количеству заголовков. 

library(shiny)
library(magrittr)

JS <- "
$(document).ready(function() {
  var myInterval = setInterval(function() {
    // clear interval after the table's DOM is available
    if ($('thead').length) {
      clearInterval(myInterval);
    }

    // setting css
    $('thead tr th').css('position', 'sticky').css('background', 'white');

    var height = 0;

    for (var i = 0, length = $('thead tr').length; i < length; i++) {
      var header = $('thead tr:nth-child(' + i + ')');
      height += header.length ? header.height() : 0;
      $('thead tr:nth-child(' + (i + 1) + ') th').css('top', height);
    }

  }, 500);
});
"

ui <- fluidPage(
  tags$head(
    tags$script(HTML(JS))
  ),
  tableOutput("table")
)

server <- function(input, output, session) {
  output$table <- function() {
    knitr::kable(mtcars) %>%
      kableExtra::add_header_above(c(" " = 1, "Header 1" = 5, "Header 2" = 6)) %>%
      kableExtra::add_header_above(c(" " = 1, "Header" = 11)) %>%
      kableExtra::kable_styling()
  }
}

shinyApp(ui, server)

Если вы не хотите, чтобы ваш основной app.R имел все это Javascript, вы можете переместите код в другой файл, см .: Включите файл javascript в приложение Shiny .

2 голосов
/ 04 марта 2020 
library(shiny)
library(magrittr)

CSS <- "
thead tr th {
  position: sticky;
  background-color: white;
}
thead tr:nth-child(1) th {
  top: 0;
}
"

JS <- "
$(document).ready(function(){
  setTimeout(function(){
    var h = $('thead tr:nth-child(1)').height();
    $('thead tr:nth-child(2) th').css('top', h);
  }, 500);
});
"

ui <- fluidPage(
  tags$head(
    tags$style(HTML(CSS)),
    tags$script(HTML(JS))
  ),
  uiOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderUI({
    tabl <- knitr::kable(mtcars) %>%
      kableExtra::add_header_above(c(" " = 1, "Header 1" = 5, "Header 2" = 6)) %>% 
      kableExtra::kable_styling()
    HTML(tabl)
  })
}

shinyApp(ui, server)
...