When running the reproducible code at the bottom, I get an error message when I try transposing the reactive data table. In the image below I show the error message when attempting to transpose (via click of the radio button), with an overlay of my comments.
I know the problem lies in the re-dimensioning of the data table when running the t() (transpose) function in the code (the line underneath the only # in the code in the server section, starting with data = if(input$transposeDT==...). I have tried many iterations of results()[ , ] in the t() function with no luck yet. Please, does anyone have any guidance here?
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(
# data = results(),
data = if(input$transposeDT=='Rows'){as.data.frame(t(results()))} else {results()},
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(rowspan = 2, sprintf('To state where end period = %s', input$transTo), 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())[-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)
Explanation and solution
The below code includes the solution posted by anuanand, and also adds my correction to swap the to/from column headers when transposing the matrix (my 2 additions are noted with comment # Add the below if-else to change to/from column headers when transposing below). Why bother transposing a transition matrix? Many in my industry are accustomed to reading these matrices with the "From" states shown in the columns across the top along an x-axis and the "To" states shown in the rows along the y-axis; the probabilities sum to 1 (or 100%) across the bottom row. On the other hand for Markov chain purposes, which these matrices will also be used for, standard practice is the opposite orientation so the column to the right sums to 1. Thus this code allows the user to switch between the 2 presentation modes.
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)
CodePudding user response：
instead of t() which is good for matrices() use transpose from data.table. Making changes only where required, its works for me now without any warning error. with t() now commented our and next row with the only change in code :
data = if(input$transposeDT=='Rows'){
#as.data.frame(t(results()))
results()%>%transpose(make.names = 'to_state',keep.names = 'to_state')
} else {results()},
You should see the transposition working by toggling the radioButton.
From this Default :
To this transposed. [I could not understand your logic but transposing is a reali life problem.
