绘制转移概率矩阵的最新方法？
An up-to-date method for plotting a transition probability matrix?
我正在尝试寻找一种简单、最新的方法来绘制转移矩阵。有人可以推荐一种方法或包吗？我在 Stack 上找到了建议，但是 post 非常旧，或者引用的包不再存在（例如 2015 年 10 月 23 日对 post R transition plot 的回答）。
请注意，我的转换矩阵是动态的：根据用户输入，状态数和 to/from 周期因基础数据的组成而异。所以进入代码并手动调整 box/arrow 大小不会有太大帮助。
我一直倾向于 2013 年 4 月 20 日对 Graph flow chart of transition from states 的回答，使用 Diagram 包，但我想知道是否有更新的方法。
我不需要太复杂的东西。我喜欢这张图片中显示的情节类型（我相信是通过上面引用的 post、“MmgraphR”中不再存在的包生成的）：
或者这个更简单的形式也适用于我：
下面是我用来生成转换的代码的精简版：
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","X9")
)
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),
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]))
# Express results as percentages:
results %>%
mutate(across(-1, ~ .x / .x[length(.x)])) %>%
replace(is.na(.), 0) %>%
mutate(across(-1, scales::percent_format(accuracy = 0.1)))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
datatable(
data = results(),
rownames = FALSE,
container = tags$table(
tags$thead(
tags$tr(
tags$th(rowspan = 2,sprintf('To state where end period = %s', input$transTo)),
tags$th(colspan = 10,sprintf('From state where initial period = %s',input$transFrom))),
tags$tr(mapply(tags$th, colnames(results())[-1], SIMPLIFY = FALSE))
)
),
)
})
}
shinyApp(ui, server)
在研究了选项之后，我只能找到用于绘制转换矩阵的 Gmisc 和 diagram 包。 Gmisc 包在视觉上非常吸引人，尽管它不利于显示传输值。 Diagram 包在视觉上不太吸引人，但很容易促进转换值的显示 - 尽管在图的 left-side 和 [=25] 上显示 From 状态=]To states on the right-side of the plot，我不得不使用 for-loop 和其他代码旋转来使矩阵的大小加倍并填充矩阵值跳过 rows/columns。由于此代码的转换矩阵适用于 8 x 8 或更大的尺寸，因此在绘图中显示的数字太多。因此，我将在 post 的完整代码中使用 Gmisc；箭头 thicken/narrow 表示过渡体积，用户可以轻松访问过渡矩阵 table 及其 >= 64 个值。顺便说一句，我没花时间让这些情节更漂亮。
这是修改后的 OP 代码以显示两个图：
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
# Add two packages for plotting transitions in different manners:
library(diagram)
library(Gmisc)
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","X9")
)
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("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"),
h4(strong("Transition plot using Gmisc package:")),
plotOutput("resultsPlot1"),
h4(strong("Transition plot using diagram package:")),
plotOutput("resultsPlot2")
)
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]))
results %>%
mutate(across(-1, ~ .x / .x[length(.x)])) %>%
replace(is.na(.), 0) %>%
mutate(across(-1, scales::percent_format(accuracy = 0.1)))
})
# extractResults below used for both Gmisc and diagram plots:
extractResults <-
reactive({
extractResults <-
data.frame(lapply(results()[1:nrow(results())-1,2:nrow(results())],
function(x) as.numeric(sub("%", "", x))/100))
row.names(extractResults) <- colnames(extractResults)
t(as.matrix(extractResults))
})
# M below used only for diagram plots; extractResults matrix must be doubled in size
M <-
reactive({
M <- matrix(nrow = nrow(extractResults())*2, ncol = ncol(extractResults())*2, byrow = TRUE, data = 0)
for (i in 1:(nrow(extractResults()))){
for (j in 1: ncol(extractResults()))
{M[i*2-1,j*2] <- extractResults()[i,j]
}}
t(M)
})
output$resultsDT <- renderDT(server=FALSE, {
datatable(
data = results(),
rownames = FALSE,
container = tags$table(
tags$thead(
tags$tr(
tags$th(rowspan = 2,sprintf('To state where end period = %s', input$transTo)),
tags$th(colspan = 10,sprintf('From state where initial period = %s',input$transFrom))),
tags$tr(mapply(tags$th, colnames(results())[-1], SIMPLIFY = FALSE))
)
),
)
})
output$resultsPlot1 <- # transition plot using Gmisc package
renderPlot({
suppressWarnings(
transitionPlot(extractResults(),
tot_spacing = 0.01,
fill_start_box = "#8DA0CB",
fill_end_box = "#FFFF00",
txt_end_clr ="#000000"
)
)
})
output$resultsPlot2 <- # transition plot using diagram package
renderPlot({
plotmat(M(),
pos = rep(2,times = nrow(extractResults())),
name = rep(colnames(extractResults()), each = 2),
curve = 0, # the closer to 1 the more arced the curve
arr.width = 0.3, # the greater the nbr the larger the arrowhead
lwd = 1,
box.lwd = 2,
cex.txt = 0.8,
box.size = 0.1,
box.type = "square",
box.prop = 0.25
)
})
}
shinyApp(ui, server)
在下图中，您可以看到上述代码渲染的两种过渡图：
我正在尝试寻找一种简单、最新的方法来绘制转移矩阵。有人可以推荐一种方法或包吗？我在 Stack 上找到了建议，但是 post 非常旧，或者引用的包不再存在（例如 2015 年 10 月 23 日对 post R transition plot 的回答）。
请注意，我的转换矩阵是动态的：根据用户输入，状态数和 to/from 周期因基础数据的组成而异。所以进入代码并手动调整 box/arrow 大小不会有太大帮助。
我一直倾向于 2013 年 4 月 20 日对 Graph flow chart of transition from states 的回答，使用 Diagram 包，但我想知道是否有更新的方法。
我不需要太复杂的东西。我喜欢这张图片中显示的情节类型（我相信是通过上面引用的 post、“MmgraphR”中不再存在的包生成的）：
或者这个更简单的形式也适用于我：
下面是我用来生成转换的代码的精简版：
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","X9")
)
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),
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]))
# Express results as percentages:
results %>%
mutate(across(-1, ~ .x / .x[length(.x)])) %>%
replace(is.na(.), 0) %>%
mutate(across(-1, scales::percent_format(accuracy = 0.1)))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
datatable(
data = results(),
rownames = FALSE,
container = tags$table(
tags$thead(
tags$tr(
tags$th(rowspan = 2,sprintf('To state where end period = %s', input$transTo)),
tags$th(colspan = 10,sprintf('From state where initial period = %s',input$transFrom))),
tags$tr(mapply(tags$th, colnames(results())[-1], SIMPLIFY = FALSE))
)
),
)
})
}
shinyApp(ui, server)
在研究了选项之后，我只能找到用于绘制转换矩阵的 Gmisc 和 diagram 包。 Gmisc 包在视觉上非常吸引人，尽管它不利于显示传输值。 Diagram 包在视觉上不太吸引人，但很容易促进转换值的显示 - 尽管在图的 left-side 和 [=25] 上显示 From 状态=]To states on the right-side of the plot，我不得不使用 for-loop 和其他代码旋转来使矩阵的大小加倍并填充矩阵值跳过 rows/columns。由于此代码的转换矩阵适用于 8 x 8 或更大的尺寸，因此在绘图中显示的数字太多。因此，我将在 post 的完整代码中使用 Gmisc；箭头 thicken/narrow 表示过渡体积，用户可以轻松访问过渡矩阵 table 及其 >= 64 个值。顺便说一句，我没花时间让这些情节更漂亮。
这是修改后的 OP 代码以显示两个图：
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
# Add two packages for plotting transitions in different manners:
library(diagram)
library(Gmisc)
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","X9")
)
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("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"),
h4(strong("Transition plot using Gmisc package:")),
plotOutput("resultsPlot1"),
h4(strong("Transition plot using diagram package:")),
plotOutput("resultsPlot2")
)
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]))
results %>%
mutate(across(-1, ~ .x / .x[length(.x)])) %>%
replace(is.na(.), 0) %>%
mutate(across(-1, scales::percent_format(accuracy = 0.1)))
})
# extractResults below used for both Gmisc and diagram plots:
extractResults <-
reactive({
extractResults <-
data.frame(lapply(results()[1:nrow(results())-1,2:nrow(results())],
function(x) as.numeric(sub("%", "", x))/100))
row.names(extractResults) <- colnames(extractResults)
t(as.matrix(extractResults))
})
# M below used only for diagram plots; extractResults matrix must be doubled in size
M <-
reactive({
M <- matrix(nrow = nrow(extractResults())*2, ncol = ncol(extractResults())*2, byrow = TRUE, data = 0)
for (i in 1:(nrow(extractResults()))){
for (j in 1: ncol(extractResults()))
{M[i*2-1,j*2] <- extractResults()[i,j]
}}
t(M)
})
output$resultsDT <- renderDT(server=FALSE, {
datatable(
data = results(),
rownames = FALSE,
container = tags$table(
tags$thead(
tags$tr(
tags$th(rowspan = 2,sprintf('To state where end period = %s', input$transTo)),
tags$th(colspan = 10,sprintf('From state where initial period = %s',input$transFrom))),
tags$tr(mapply(tags$th, colnames(results())[-1], SIMPLIFY = FALSE))
)
),
)
})
output$resultsPlot1 <- # transition plot using Gmisc package
renderPlot({
suppressWarnings(
transitionPlot(extractResults(),
tot_spacing = 0.01,
fill_start_box = "#8DA0CB",
fill_end_box = "#FFFF00",
txt_end_clr ="#000000"
)
)
})
output$resultsPlot2 <- # transition plot using diagram package
renderPlot({
plotmat(M(),
pos = rep(2,times = nrow(extractResults())),
name = rep(colnames(extractResults()), each = 2),
curve = 0, # the closer to 1 the more arced the curve
arr.width = 0.3, # the greater the nbr the larger the arrowhead
lwd = 1,
box.lwd = 2,
cex.txt = 0.8,
box.size = 0.1,
box.type = "square",
box.prop = 0.25
)
})
}
shinyApp(ui, server)
在下图中，您可以看到上述代码渲染的两种过渡图：