Как добавить вертикальную линию в заголовок первого столбца в таблице данных?

Я хотел бы добавить вертикальную линию в заголовок столбца таблицы DT. Есть руководство по добавлению этой строки в сообщение Как я могу добавить вертикальную линию в таблицу данных?, но оно относится к статической таблице, в которой столбцы задаются вручную, тогда как в моем коде MWE (внизу) столбцы задаются с помощью функции lapply() в реактивной настройке. Поэтому у меня возникли проблемы с использованием этого руководства в моих конкретных обстоятельствах.

Любые предложения по добавлению вертикальной линии справа от самого левого заголовка столбца с надписью «to_state»? Как показано на этом изображении, которое показывает часть окна вывода при запуске кода MWE:

Как добавить вертикальную линию в заголовок первого столбца в таблице данных?

Обратите внимание, что в более полном коде, из которого получен этот MWE, таблица динамически расширяется/сжимается в зависимости от количества уникальных состояний, обнаруженных в базовых данных. Поэтому я не могу использовать статическую таблицу, настроенную, как в упомянутом выше посте.

Как только это будет решено, у меня возникнет несколько дополнительных вопросов, поскольку я изо всех сил пытаюсь сделать таблицу перехода понятной для пользователей (например, изменить заголовок крайнего левого столбца «to_state» на «To end Period = [xxx]», но это будет рассмотрено в другом посте). Я постепенно решаю эту проблему форматирования.

Я очень не знаком с HTML, CSS.

Вот код MWE:

library(DT)
library(shiny)
library(htmltools)
library(data.table)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
    State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
  )

numTransit <- function(x, from=1, to=3){
  setDT(x)
  unique_state <- unique(x$State)
  all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
  dcast(x[, .(from_state = State[from], 
              to_state = State[to]), 
          by = ID]
        [,.N, c("from_state", "to_state")]
        [all_states,on = c("from_state", "to_state")], 
        to_state ~ from_state, value.var = "N"
  )
}

ui <- fluidPage(
  tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
  h4(strong("Base data frame:")), 
  tableOutput("data"),
  h4(strong("Transition table inputs:")),
  numericInput("transFrom", "From Period:", 1, min = 1, max = 3),
  numericInput("transTo", "To Period:", 2, min = 1, max = 3),
  h4(strong("Output transition table:")), 
  DTOutput("resultsDT"),
)

server <- function(input, output, session) {
  results <- 
    reactive({
      results <- numTransit(data, input$transFrom, input$transTo) %>% 
        replace(is.na(.), 0) %>%
        bind_rows(summarise_all(., ~(if (is.numeric(.)) sum(.) else "Sum")))
      results <- cbind(results, Sum = rowSums(results[,-1]))
    })
  
  output$data <- renderTable(data)
  
  output$resultsDT <- renderDT(server=FALSE, {
    req(results())
    datatable(
      data = results(),
      rownames = FALSE,
      filter = 'none',
      container = tags$table(
        class = 'display',
        tags$thead(
          tags$tr(
            tags$th(colspan = 1, '', style = "border-right: solid 1px;"),
            tags$th(colspan = 10, sprintf('From initial Period = %s', input$transFrom))
          ),
          tags$tr(
            lapply(colnames(results()), 
                   tags$th
                   )
          ),
        )
      ),
      options = list(scrollX = F
                     , dom = 'ft'
                     , lengthChange = T
                     , pagingType = "numbers"  # hides Next and Previous buttons
                     , autoWidth = T
                     , info = FALSE #  hide the "Showing 1 of 2..." at bottom of table
                     , searching = FALSE  # removes search box
      ),
      class = "display"
    ) %>%
      formatStyle(c(1), `border-right` = "solid 1px")
  })
  
}

shinyApp(ui, server)
Улучшение производительности загрузки с помощью Google Tag Manager и атрибута Defer
Улучшение производительности загрузки с помощью Google Tag Manager и атрибута Defer
В настоящее время производительность загрузки веб-сайта имеет решающее значение не только для удобства пользователей, но и для ранжирования в...
Введение в CSS
Введение в CSS
CSS является неотъемлемой частью трех основных составляющих front-end веб-разработки.
Как выровнять Div по центру?
Как выровнять Div по центру?
Чтобы выровнять элемент <div>по горизонтали и вертикали с помощью CSS, можно использовать комбинацию свойств и значений CSS. Вот несколько методов,...
Навигация по приложениям React: Исчерпывающее руководство по React Router
Навигация по приложениям React: Исчерпывающее руководство по React Router
React Router стала незаменимой библиотекой для создания одностраничных приложений с навигацией в React. В этой статье блога мы подробно рассмотрим...
Система управления парковками с использованием HTML, CSS и JavaScript
Система управления парковками с использованием HTML, CSS и JavaScript
Веб-сайт по управлению парковками был создан с использованием HTML, CSS и JavaScript. Это простой сайт, ничего вычурного. Основная цель -...
Toor - Ангулярный шаблон для бронирования путешествий
Toor - Ангулярный шаблон для бронирования путешествий
Toor - Travel Booking Angular Template один из лучших Travel & Tour booking template in the world. 30+ валидированных HTML5 страниц, которые помогут...
2
0
55
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Мы можем использовать mapply вместо lapply для управления параметром style:

library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
    State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
  )

numTransit <- function(x, from=1, to=3){
  setDT(x)
  unique_state <- unique(x$State)
  all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
  dcast(x[, .(from_state = State[from], 
              to_state = State[to]), 
          by = ID]
        [,.N, c("from_state", "to_state")]
        [all_states,on = c("from_state", "to_state")], 
        to_state ~ from_state, value.var = "N"
  )
}

ui <- fluidPage(
  tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
  h4(strong("Base data frame:")), 
  tableOutput("data"),
  h4(strong("Transition table inputs:")),
  numericInput("transFrom", "From Period:", 1, min = 1, max = 3),
  numericInput("transTo", "To Period:", 2, min = 1, max = 3),
  h4(strong("Output transition table:")), 
  DTOutput("resultsDT"),
)

server <- function(input, output, session) {
  results <- 
    reactive({
      results <- numTransit(data, input$transFrom, input$transTo) %>% 
        replace(is.na(.), 0) %>%
        bind_rows(summarise_all(., ~(if (is.numeric(.)) sum(.) else "Sum")))
      results <- cbind(results, Sum = rowSums(results[,-1]))
    })
  
  output$data <- renderTable(data)
  
  output$resultsDT <- renderDT(server=FALSE, {
    req(results())
    datatable(
      data = results(),
      rownames = FALSE,
      filter = 'none',
      container = tags$table(
        class = 'display',
        tags$thead(
          tags$tr(
            tags$th(colspan = 1, '', style = "border-right: solid 1px;"),
            tags$th(colspan = 10, sprintf('From initial Period = %s', input$transFrom))
          ),
          tags$tr(
            mapply(tags$th, colnames(results()), style = sprintf("border-right: solid %spx;", c(1L, rep(0, ncol(results())-1L))), SIMPLIFY = FALSE)
            )
          )
      ),
      options = list(scrollX = F
                     , dom = 'ft'
                     , lengthChange = T
                     , pagingType = "numbers"  # hides Next and Previous buttons
                     , autoWidth = T
                     , info = FALSE #  hide the "Showing 1 of 2..." at bottom of table
                     , searching = FALSE  # removes search box
      ),
      class = "display"
    ) %>%
      formatStyle(c(1), `border-right` = "solid 1px")
  })
  
}

shinyApp(ui, server)

result

Другие вопросы по теме