This is the next step in my attempt to build a user-friendly transition matrix in R, a follow-on to post How to add a vertical line to the first column header in a data table?. I have been spoiled by the ease of drafting eye-friendly tables in Excel and have been struggling with this in R Shiny.
Running the MWE code at the bottom generates the transition table shown on the left side of the image below (with my comments overlaying). Expressing my question in Excel-speak, I'm trying to merge the top 2 cells (rows) in the left-most column (call them cells A1 and A2), eliminate the small bit of line just above "to_state" (cell A2)(item #1 in the image), eliminate that first column's header "to_state" (in cell A2)(item #2 in the image), and into that merged column header space insert an object similar to the object hovering over the "From" columns to the right, that states "To state where end period = x", where x is the value of object transTo() (item #3 in the image). Any suggestions for doing this? Using DT for the table rendering if possible.
I'm open to any other suggestion for drafting a user-friendly, understandable state transition matrix that delineates to/from columns/rows and reactively shows the to/from periods.
Post Shiny: Merge cells in DT::datatable seems promising but it addresses merging rows in the body of the table and not header rows.
Please note that in the fuller code, the table dynamically contracts/expands based on the number of unique states detected in the underlying data. States can range from 2 to 12.
MWE code:
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 state where 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)
