如何使用额外的列和行 headers 格式化 table，包括垂直对齐和反应式输入？

Question

下面是运行反应式转换 table 的 MWE 代码，用户输入开始时间段 (from) 和结束时间段 (to)。在底部的第一张图片中，您可以看到起草 MWE 代码时的输出格式。但是，我想要一个更具描述性的 table 输出，更像是底部第二张图片中显示的输出，其中列标记为“From”（反映转换状态自），行标记为“To”（反映将状态转换为），反应性用户输入反映在两者中。

有什么建议可以实现吗？

MWE 代码：

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

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")
  )

ui <- fluidPage(
  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:")), 
  tableOutput("results"),
)

server <- function(input, output) {

  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"
    )
  }
  
  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$results <- renderTable(results()) 
   
}

shinyApp(ui, server)

所需格式（或多或少...）：

Answer 1

请参阅此 post 上的相关问题和解决方案，它针对 to/from 转换矩阵的描述列 headers 提出了一个替代（最终更好）的解决方案：How to merge 2 row cells in data table?

这里还有适用于该解决方案的代码：

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;}")), 
  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),
  radioButtons("transposeDT",
               label = "From state along:",
               choiceNames = c('Columns','Rows'),
               choiceValues = c('Columns','Rows'),
               selected = 'Columns',
               inline = TRUE
               ),
  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, {
    datatable(
      #StackPost solution from anuanand added the below...
      data = if(input$transposeDT=='Rows')
                {results()%>%transpose(make.names = 'to_state',keep.names = 'to_state')} 
             else {results()},
      rownames = FALSE,
      filter = 'none',
      container = tags$table(
        class = 'display',
        tags$thead(
          tags$tr(
            tags$th(rowspan = 2, # Add the below if-else to change to/from column headers when transposing
                    if(input$transposeDT=='Rows')
                      {sprintf('From state where initial period = %s', input$transFrom)}
                    else{sprintf('To state where end period = %s', input$transTo)}
                    , style = "border-right: solid 1px;"),
            tags$th(colspan = 10, # Add the below if-else to change to/from column headers when transposing
                    if(input$transposeDT=='Rows')
                      {sprintf('To state where end period = %s', input$transTo)}
                    else{sprintf('From state where initial period = %s', input$transFrom)}
                    )
          ),
          tags$tr(
            mapply(tags$th, colnames(results())[-1], style = sprintf("border-right: solid %spx;", rep(0, ncol(results()) - 1L)), SIMPLIFY = FALSE)
          )
        )
      ),
      options = list(scrollX = F
                     , dom = 'ft'
                     , lengthChange = T
                     , pagingType = "numbers"
                     , autoWidth = T
                     , info = FALSE 
                     , searching = FALSE
      ),
      class = "display"
    ) %>%
      formatStyle(c(1), `border-right` = "solid 1px")
  })
  
}

shinyApp(ui, server)

如何使用额外的列和行 headers 格式化 table，包括垂直对齐和反应式输入？

How to format table with additional column and row headers including vertical alignment and reactive inputs?

datatable

transition

r

shiny

shiny-reactivity