如何使用嵌入式反应式 object 添加次要行 header 以输出 table？

Question

这是 follow-on 或对 post

的改进

底部的 MWE 代码生成了一个非常漂亮的辅助列 header，其中嵌入了反应式 object。这有助于转换 table 的可理解性，它显示沿列 (x-axis) 的状态转换和沿行 (y-axis) 的状态转换。输出显示在下图的左侧。

我如何对带有嵌入式反应 object 的次要行 header 执行相同操作，显示 TO 周期 (transTo object)？如下图右半部分所示。我愿意接受任何其他关于呈现可理解且 user-friendly 转换矩阵的建议。这种垂直文本对齐方式是我过去在 XLS 中呈现过渡 tables 的方式；如果垂直文本对齐在这种情况下不可行，我愿意接受任何解决方案！！

请注意完整的 transition-matrix 生成代码 expands/contracts 根据数据中唯一状态的数量自动生成。这个 MWE 代码在这个意义上是静态的，而完整的代码是动态的。

MWE 代码，在 ismirsehregal 的宝贵帮助下：

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, ''),
            tags$th(colspan = 10, sprintf('From state where initial period is = %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"
    )
  })
  
}

shinyApp(ui, server)

Answer 1

请参阅 post ，它提供了在转换矩阵中显示反应性 to/from 值的解决方案。我相信它比本 OP 中要求的内容更清晰、更易于理解 table。

如何使用嵌入式反应式 object 添加次要行 header 以输出 table？

How to add a secondary row header to output table with an embedded reactive object?

html

transition

r

shiny

dt