很受启发!让我忍不住接着不务正业了一下:
<br />
FlowChart <- function(flow) {<br />
if ( ! any(search() == "package:diagram")) {<br />
library(diagram);<br />
on.exit(detach("package:diagram"), add = TRUE);<br />
}<br />
<br />
openplotmat();<br />
<br />
minX = min(unlist(lapply(flow, function(step) step$x)));<br />
maxX = max(unlist(lapply(flow, function(step) step$x)));<br />
minY = min(unlist(lapply(flow, function(step) step$y)));<br />
maxY = max(unlist(lapply(flow, function(step) step$y)));<br />
<br />
posMatrix <- matrix(FALSE, nrow = maxX - minX + 1, ncol = maxY - minY + 1);<br />
lapply(flow, function(step) posMatrix[step$x - minX + 1, step$y - minY + 1] <<- TRUE);<br />
<br />
itemWidth <- 1 / (maxX - minX + 1);<br />
itemHeight <- 1 / (maxY - minY + 1);<br />
<br />
idToIndex <- function(id) which(unlist(lapply(flow, function(step) (step$id == id))));<br />
getStep <- function(id) flow[[ idToIndex(id) ]];<br />
<br />
posX <- function(x) (x - minX + 0.5) * itemWidth;<br />
posY <- function(y) ((maxY - minY + 1) - y + 0.5) * itemHeight;<br />
<br />
drawArrow <- function(fromX, fromY, toX, toY, label = "") {<br />
signX <- sign(toX - fromX);<br />
signY <- sign(toY - fromY);<br />
if ((signX != 0) && (signY != 0)) {<br />
path <- ifelse(posMatrix[fromX, (fromY + signY) - minY + 1], "H", "V");<br />
if (path == "H") {<br />
bentarrow(lwd = 1, from = c(posX(fromX) + signX * itemWidth / 3, posY(fromY)), to = c(posX(toX), posY(toY) + signY * itemHeight / 3), path = "H");<br />
if (label != "") text(posX(fromX) + signX * itemWidth / 3, posY(fromY), label, adj = c(-signX * 1.1, 1.1));<br />
} else {<br />
bentarrow(lwd = 1, from = c(posX(fromX), posY(fromY) - signY * itemHeight / 3), to = c(posX(toX) - signX * itemWidth / 3, posY(toY)), path = "V");<br />
if (label != "") text(posX(fromX), posY(fromY) - signY * itemHeight / 3, label, adj = c(-1.1, signY * 1.1));<br />
}<br />
}<br />
else if ((signX != 0) && (signY == 0)) {<br />
straightarrow(lwd = 1, from = c(posX(fromX) + signX * itemWidth / 3, posY(fromY)), to = c(posX(toX) - signX * itemWidth / 3, posY(toY)));<br />
if (label != "") text(posX(fromX) + signX * itemWidth / 3, posY(fromY), label, adj = c(-signX * 1.1, 1.1));<br />
}<br />
else if ((signX == 0) && (signY != 0)) {<br />
straightarrow(lwd = 1, from = c(posX(fromX), posY(fromY) - signY * itemHeight / 3), to = c(posX(toX), posY(toY) + signY * itemHeight / 3));<br />
if (label != "") text(posX(fromX), posY(fromY) - signY * itemHeight / 3, label, adj = c(-1.1, signY * 1.1));<br />
}<br />
}<br />
<br />
drawStep <- function(step) {<br />
if (step$type == "rect") {<br />
textrect(c(posX(step$x), posY(step$y)), itemWidth / 3, itemHeight / 3, lab = step$label, cex = 0.8);<br />
}<br />
else if (step$type == "diamond") {<br />
textdiamond(c(posX(step$x), posY(step$y)), itemWidth / 3, itemHeight / 3, lab = step$label, cex = 0.8);<br />
}<br />
else if (step$type == "round") {<br />
textround(c(posX(step$x), posY(step$y)), (itemWidth - itemHeight) / 3, itemHeight / 3, lab = step$label, cex = 0.8);<br />
}<br />
}<br />
<br />
for (step in flow) {<br />
drawStep(step);<br />
if (step$type == "rect") {<br />
toStep <- getStep(step$to)<br />
drawArrow(step$x, step$y, toStep$x, toStep$y);<br />
}<br />
else if (step$type == "diamond") {<br />
yesStep <- getStep(step$yes)<br />
drawArrow(step$x, step$y, yesStep$x, yesStep$y, label = "是");<br />
noStep <- getStep(step$no)<br />
drawArrow(step$x, step$y, noStep$x, noStep$y, label = "否");<br />
}<br />
}<br />
}<br />
<br />
flow <- list(<br />
list(id = 1, x = 1, y = 1, type = "rect", label = "阶段I试验", to = 2),<br />
list(id = 2, x = 1, y = 2, type = "diamond", label = "达到目的?", yes = 3, no = 8),<br />
list(id = 3, x = 1, y = 3, type = "rect", label = "阶段II试验", to = 4),<br />
list(id = 4, x = 1, y = 4, type = "diamond", label = "达到目的?", yes = 5, no = 8),<br />
list(id = 5, x = 1, y = 5, type = "rect", label = "阶段III试验", to = 6),<br />
list(id = 6, x = 1, y = 6, type = "diamond", label = "达到目的?", yes = 7, no = 8),<br />
list(id = 7, x = 1, y = 7, type = "round", label = "删除审批提交"),<br />
list(id = 8, x = 2, y = 4, type = "rect", label = "返回研究", to = 9),<br />
list(id = 9, x = 3, y = 4, type = "diamond", label = "继续", yes = 1, no = 10),<br />
list(id = 10, x = 4, y = 4, type = "round", label = "取消项目")<br />
)<br />
<br />
FlowChart(flow);<br />