为什么我转置数据 table 的努力不起作用？
Why is my effort in transposing a data table not working?
当 运行 底部的可重现代码时，我在尝试转置反应数据时收到错误消息 table。在下图中，我显示了尝试转置（通过单击单选按钮）时的错误消息，并叠加了我的评论。
我知道问题出在数据table的re-dimensioning当运行代码中的t()（转置）函数（唯一下面的行# 在 server 部分的代码中，以 data = if(input$transposeDT==...) 开头。我在 t() 函数中尝试了多次 results()[ , ] 的迭代，但还没有成功。拜托，这里有没有人有任何指导？
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)
说明及解决办法
下面的代码包括 anuanand 发布的解决方案，并且还添加了我的更正以在转置矩阵时交换 to/from 列 headers（我的 2 个添加用注释 # Add the below if-else to change to/from column headers when transposing below).为什么要费心转置转移矩阵？在我的行业中，许多人习惯于阅读这些矩阵，在 x-axis 顶部的列中显示“From”状态，在 y-axis 的行中显示“To”状态；最后一行的概率总和为 1（或 100%）。另一方面，对于这些矩阵也将用于马尔可夫链的目的，标准做法是相反的方向，因此右侧的列总和为 1。因此，此代码允许用户在 2 种表示模式之间切换。
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)
而不是 t() 这对 matrices() 使用来自 data.table 的转置。
只在需要的地方进行更改，它现在对我有用，没有任何警告错误。
with t() 现在评论了我们和下一行，代码中唯一的变化是：
data = if(input$transposeDT=='Rows'){
#as.data.frame(t(results()))
results()%>%transpose(make.names = 'to_state',keep.names = 'to_state')
} else {results()},
您应该可以通过切换单选按钮看到换位工作。
从这个默认值：
为此换位。 [我无法理解你的逻辑，但转置是一个现实生活中的问题。
当 运行 底部的可重现代码时，我在尝试转置反应数据时收到错误消息 table。在下图中，我显示了尝试转置（通过单击单选按钮）时的错误消息，并叠加了我的评论。
我知道问题出在数据table的re-dimensioning当运行代码中的t()（转置）函数（唯一下面的行# 在 server 部分的代码中，以 data = if(input$transposeDT==...) 开头。我在 t() 函数中尝试了多次 results()[ , ] 的迭代，但还没有成功。拜托，这里有没有人有任何指导？
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)
说明及解决办法
下面的代码包括 anuanand 发布的解决方案，并且还添加了我的更正以在转置矩阵时交换 to/from 列 headers（我的 2 个添加用注释 # Add the below if-else to change to/from column headers when transposing below).为什么要费心转置转移矩阵？在我的行业中，许多人习惯于阅读这些矩阵，在 x-axis 顶部的列中显示“From”状态，在 y-axis 的行中显示“To”状态；最后一行的概率总和为 1（或 100%）。另一方面，对于这些矩阵也将用于马尔可夫链的目的，标准做法是相反的方向，因此右侧的列总和为 1。因此，此代码允许用户在 2 种表示模式之间切换。
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)
而不是 t() 这对 matrices() 使用来自 data.table 的转置。 只在需要的地方进行更改，它现在对我有用，没有任何警告错误。 with t() 现在评论了我们和下一行，代码中唯一的变化是：
data = if(input$transposeDT=='Rows'){
#as.data.frame(t(results()))
results()%>%transpose(make.names = 'to_state',keep.names = 'to_state')
} else {results()},
您应该可以通过切换单选按钮看到换位工作。
从这个默认值：