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

Question

Below is MWE code for running a reactive transition table, whereby the user inputs the starting period (from) and ending period (to). In the first image at the bottom, you can see the output format as the MWE code is drafted. However I would like a more descriptive table output, more like that shown in the second image at the bottom, where the columns are labeled "From" (reflecting transitions states from) and the rows are labeled "To" (reflecting transitions states to), with the reactive user inputs reflected in both.

Any suggestions for accomplishing this?

MWE code:

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)

Desired format (more or less...):

Answer 1

See related question and solution at this post, which presents an alternative (and ultimately better) solution to this question regarding descriptive column headers for to/from transition matrices: How to merge 2 row cells in data table?

Also here is code that works for that solution:

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)