How to add reactive object to secondary column header in output table? - html

Question

I am working on a transition table module and am wrestling with how to make the output understandable for the user. I used to prepare transition tables in Excel; making the table legible was super easy but deriving the data for table output took hours. Now my problem is the opposite with R: takes a few seconds to generate the table output from millions of rows of data but table presentation is far from simple.
To start, I would like to reflect the user's "From" input (object transFrom) in this reactive table's secondary column header as shown in the image below; any suggestions for how to do this? I am completely clueless with respect to html. I had found this solution here R Shiny app - Render Data Table with double header, and I like it because it uses DT, which I use throughout (though I would have preferred the base R table, using Shiny renderTable(), but I could not make that work). I have researched this and found other packages for drafting nice tables but I am avoiding "package bloat" and would rather stick with base R, Shiny, data.table, and DT package IF POSSIBLE.
Note that the columns reflect the transition states FROM, and the rows reflect the transition states TO.
Here is the MWE code for actively rendering the above:
library(data.table)
library(dplyr)
library(shiny)
# custom table container
sketch = htmltools::withTags(table(
class = 'display',
thead(
tr(
th(colspan = 1, ''),
th(colspan = 10, 'From state where initial period is = ')
),
tr(
lapply(colnames(results), th)
)
)
))
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(
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("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 <- renderDT(server=FALSE,{
results() %>%
datatable(rownames = FALSE,
filter = 'none',
container = sketch,
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

It seems that htmltools::withTags doesn't play well with using shiny inputs (I filed an issue here).
Please check the following:
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)