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

Question

This is a follow-on or refinement to post How to add reactive object to secondary column header in output table?

The MWE code at the bottom produces a very nice secondary column header with embedded reactive object. This helps with the understandability of the transition table which shows the transitions FROM states along the columns (x-axis) and the transitions TO states along the rows (y-axis). The output is shown on the left side of the image below.

How would I do the same with a secondary row header with embedded reactive object, showing the TO periods (transTo object)? As shown in the right half of the image below. I'm open to any other suggestions for rendering an understandable and user-friendly transition matrix. This sort of vertical text alignment is how I used to present transition tables in XLS; if the vertical text alignment is not feasible in this case I'm open to any solution!!

Note the full transition-matrix generating code expands/contracts automatically depending on the number of unique states in the data. This MWE code is static in that sense whereby the complete code is dynamic.

MWE code, with the invaluable assistance of 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

See post How to merge 2 row cells in data table? which provides a solution to showing reactive to/from values in a transition matrix. I believe it is a cleaner and more understandable table presentation than what is requested in this OP.