R/R2rflow.R
In lukaszdaniel/r2rflow: R code to rflow (xml) format converter
Defines functions
PrintEdges
TunnelNodeModel
Preambule
Settings
Task
ReplaceChr
CurlyBracket
uid
crdate
#' @import codetools
NULL
#' @title Convert R code to rflow file
#'
#' @description Takes a file or text argument and prints out rflow xml
#' @author Lukasz Daniel
#' @param file A file containing R code.
#' @param text A text containing R code.
#' @param max.level Non-negative integer or NA value. Maximum level to which diagram may be expanded. NA means no limit.
#' @param connect.top Specifies if top level elements should be connected.
#' @param output An output rflow file. If a 'file' argument is specified, 'output' argument is
#' assumed to have the same file name as in 'file' but with rflow extension.
#' @return xml formated R code
#' @export
R2rflow <- function (text = NULL, file = NULL, output = NULL, max.level = NA, connect.top = FALSE) {
if(!is.na(max.level) && (!is.integer(max.level) || (max.level < 0L)))
stop("'max.level' argument must be non-negative integer or NA value", domain = "R-R2rflow")
if (missing(text) && (missing(file) || nchar(file) == 0L)) {
stop("No R code to convert", domain = "R-R2rflow")
}
else if(!missing(text) && !missing(file)) {
stop("Cannot specify both 'text' and 'file' arguments", domain = "R-R2rflow")
}
else if(!missing(text) && missing(output)) {
stop("'output' argument must be specified", domain = "R-R2rflow")
}
else if(!missing(file) && missing(output)) {
output <- sub("(\\.[RrSq])?$", "\\.rflow", file)
}
codes <- parse(text = text, file = file)
env <- new.env()
functionSet <- function (v, e) assign(v, e, envir = env)
functionGet <- function (v, e) get(v, envir = env)
w <- makeCodeWalker(call = functionCall, leaf = functionLeaf, set = functionSet, get = functionGet)
edge <- NULL
w$set("ypos", length(edge))
w$set("nodeID", 0L)
w$set("output", output)
w$set("level", 0L)
w$set("max.level", max.level)
Preambule(output)
cat('<rflow>\n', append = TRUE, file = output)
cat(' <graph version="0.7" width="894" height="742" locationtype="a" offsetx="0" offsety="0">\n', append = TRUE, file = output)
Settings(output)
if(is.na(max.level) || (max.level > 0L)) {
w$set("level", w$get("level") + 1L)
for(i in seq_len(length(codes))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(codes[[i]], w)
}
w$set("level", w$get("level") - 1L)
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
FreeNodeModel(codes, w)
}
if(connect.top) PrintEdges(edge, file = output)
cat(' </graph>\n', append = TRUE, file = output)
Task(output)
cat('</rflow>\n', append = TRUE, file = output)
}
deparseTreeExp <- function (e) {
if(!is.expression(e))
e <- deparse(e, width.cutoff = 400L, backtick = TRUE)
return(ReplaceChr(paste(e, sep = "", collapse = "\n")))
}
functionCall <- function (e, w) {
w$set("nodeID", w$get("nodeID") + 1L)
if(is.na(w$get("max.level")) || (w$get("level") < w$get("max.level"))) {
if ((e[[1]] == "<-") && (length(e[[3]]) == 4L) && (e[[3]][[1]] == "function")) {
FunctionNodeModel(e,w)
} else if (e[[1]] == "if") {
IfNodeModel(e,w)
} else if (e[[1]] == "for") {
ForNodeModel(e,w)
} else if (e[[1]] == "while") {
WhileNodeModel(e,w)
} else if (e[[1]] == "repeat") {
RepeatNodeModel(e,w)
} else if (CurlyBracket(e[[1]])) {
SubflowNodeModel(e,w)
} else {
FreeNodeModel(e,w)
}
} else
FreeNodeModel(e,w)
}
functionLeaf <- function (e, w) {
w$set("nodeID", w$get("nodeID") + 1L)
FreeNodeModel(e,w)
NULL
}
FunctionNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.FunctionNodeModel">\n', append = TRUE, file = output)
cat(sprintf(' <entry key="function">%s</entry>\n', deparseTreeExp(e[[2]])), append = TRUE, file = output)
cat(sprintf(' <entry key="args">(%s)</entry>\n', gsub("= (,|$)", "\\1", gsub("^(pair)?list\\(|\\)$|^NULL$", "", deparseTreeExp(e[[3]][[2]])))), append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[3]][[3]]) > 1L) && CurlyBracket(e[[3]][[3]][[1]])) {
for (ee in as.list(e[[3]][[3]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[3]][[3]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
IfNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(' <property/>\n', append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.IfNodeModel">\n', append = TRUE, file = output)
cat(sprintf(' <entry key="condition">%s</entry>\n', deparseTreeExp(e[[2]])), append = TRUE, file = output)
cat('<subflow>\n', append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[3]]) > 1L) && CurlyBracket(e[[3]][[1]])) {
for (ee in as.list(e[[3]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[3]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(' </graph>\n', append = TRUE, file = output)
cat('</subflow>\n', append = TRUE, file = output)
cat('<subflow>\n', append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if (length(e) == 4L) {
if ((length(e[[4]]) > 1L) && CurlyBracket(e[[4]][[1]])) {
for (ee in as.list(e[[4]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[4]], w)
}
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
if(length(edge) > 2L) PrintEdges(edge, file = output)
cat(' </graph>\n', append = TRUE, file = output)
cat('</subflow>\n', append = TRUE, file = output)
cat(' </option>\n', append = TRUE, file = output)
cat('</node>\n', append = TRUE, file = output)
}
ForNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.LoopNodeModel">\n', append = TRUE, file = output)
cat(' <entry key="loop">for</entry>\n', append = TRUE, file = output)
cat(sprintf(' <entry key="condition">%s</entry>\n', paste(deparseTreeExp(e[[2]]), " in ", deparseTreeExp(e[[3]]), sep = "", collase = "")), append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[4]]) > 1L) && CurlyBracket(e[[4]][[1]])) {
for (ee in as.list(e[[4]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[4]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
WhileNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.LoopNodeModel">\n', append = TRUE, file = output)
cat(' <entry key="loop">while</entry>\n', append = TRUE, file = output)
cat(sprintf(' <entry key="condition">%s</entry>\n', deparseTreeExp(e[[2]])), append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[3]]) > 1L) && CurlyBracket(e[[3]][[1]])) {
for (ee in as.list(e[[3]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[3]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
RepeatNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.LoopNodeModel">\n', append = TRUE, file = output)
cat(' <entry key="loop">repeat</entry>\n', append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[2]]) > 1L) && CurlyBracket(e[[2]][[1]])) {
for (ee in as.list(e[[2]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[2]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
SubflowNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.SubflowNodeModel">\n', append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="100" offsety="50">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
for (ee in as.list(e)) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
FreeNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.FreeNodeModel"/>\n', append = TRUE, file = output)
cat('</node>\n', append = TRUE, file = output)
}
PrintEdges <- function(x, file) {
if(length(x) > 1L) for(i in seq_len(length(x)-1L)) {
cat(sprintf('<edge from="%d" to="%d"/>\n', x[i], x[i + 1L]), append = TRUE, file = file)
}
}
TunnelNodeModel <- function(type = "in", w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(' <command></command>\n', append = TRUE, file = output)
cat(' <property/>\n', append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.TunnelNodeModel">\n', append = TRUE, file = output)
cat(sprintf(' <entry key="io">%s</entry>\n', type), append = TRUE, file = output)
cat(' </option>\n', append = TRUE, file = output)
cat('</node>\n', append = TRUE, file = output)
}
Preambule <- function(output) {
cat('<?xml version="1.0" encoding="UTF-8"?>\n', append = FALSE, file = output)
cat('<!DOCTYPE rflow [\n', append = TRUE, file = output)
cat('<!ENTITY lt "&#60;">\n', append = TRUE, file = output)
cat('<!ENTITY gt ">">\n', append = TRUE, file = output)
cat('<!ENTITY amp "&#38;">\n', append = TRUE, file = output)
cat('<!ENTITY apos "'">\n', append = TRUE, file = output)
cat('<!ENTITY quot """>\n', append = TRUE, file = output)
cat(']>\n', append = TRUE, file = output)
}
Settings <- function(output) {
cat(' <setting>\n', append = TRUE, file = output)
cat(' <entry key="OUTPUT_DIRECTORY"></entry>\n', append = TRUE, file = output)
cat(' <entry key="SAVE_CACHE">false</entry>\n', append = TRUE, file = output)
cat(' <entry key="FONT_SCREEN">monospace</entry>\n', append = TRUE, file = output)
cat(' <entry key="TEXT_ENCODING">UTF-8</entry>\n', append = TRUE, file = output)
cat(' <entry key="LOAD_CACHE">false</entry>\n', append = TRUE, file = output)
cat(' <entry key="IGNORE_ERROR">false</entry>\n', append = TRUE, file = output)
cat(' <entry key="SAVE_WORKSPACE"></entry>\n', append = TRUE, file = output)
cat(' <entry key="OUTPUT_REPORT">true</entry>\n', append = TRUE, file = output)
cat(' <entry key="RUN_TYPE">2</entry>\n', append = TRUE, file = output)
cat(' <entry key="OUTPUT_ITEMS">script</entry>\n', append = TRUE, file = output)
cat(' <entry key="USE_GRID">true</entry>\n', append = TRUE, file = output)
cat(' <entry key="REPORT_TYPES">pdf,html</entry>\n', append = TRUE, file = output)
cat(' <entry key="FOLDER">empty</entry>\n', append = TRUE, file = output)
cat(' <entry key="GRID_DISTANCE2">10</entry>\n', append = TRUE, file = output)
cat(' <entry key="IMAGE_SIZE">480,480</entry>\n', append = TRUE, file = output)
cat(' <entry key="FONT_OTHER">sans-serif</entry>\n', append = TRUE, file = output)
cat(' </setting>\n', append = TRUE, file = output)
cat('<properties>\n', append = TRUE, file = output)
cat(' <v key="packages"/>\n', append = TRUE, file = output)
cat('</properties>\n', append = TRUE, file = output)
}
Task <- function(output) {
cat(' <task>\n', append = TRUE, file = output)
cat(' <taskgroup>\n', append = TRUE, file = output)
cat(' <taskproperty>\n', append = TRUE, file = output)
cat(' <entry key="title">Task</entry>\n', append = TRUE, file = output)
cat(' </taskproperty>\n', append = TRUE, file = output)
cat(' </taskgroup>\n', append = TRUE, file = output)
cat(' </task>\n', append = TRUE, file = output)
}
ReplaceChr <- function(text) {
text <- gsub("&", "&", text)
text <- gsub("<", "<", text)
text <- gsub(">", ">", text)
text <- gsub("\"", """, text)
text <- gsub("'", "'", text)
return(text)
}
CurlyBracket <- function(x) {
if(length(x) > 1L) return(FALSE)
grepl(pattern = "^`?\\{`?$", x = x)
}
uid <- function() {
return(paste(sample(c(0:9, letters[1:6]), size = 17, replace = TRUE), collapse =""))
}
crdate <- function() {
return(as.character(floor(1000*as.numeric(Sys.time()))))
}
lukaszdaniel/r2rflow documentation built on May 21, 2019, 8:57 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions PrintEdges TunnelNodeModel Preambule Settings Task ReplaceChr CurlyBracket uid crdate
#' @import codetools
NULL
#' @title Convert R code to rflow file
#'
#' @description Takes a file or text argument and prints out rflow xml
#' @author Lukasz Daniel
#' @param file A file containing R code.
#' @param text A text containing R code.
#' @param max.level Non-negative integer or NA value. Maximum level to which diagram may be expanded. NA means no limit.
#' @param connect.top Specifies if top level elements should be connected.
#' @param output An output rflow file. If a 'file' argument is specified, 'output' argument is
#' assumed to have the same file name as in 'file' but with rflow extension.
#' @return xml formated R code
#' @export
R2rflow <- function (text = NULL, file = NULL, output = NULL, max.level = NA, connect.top = FALSE) {
if(!is.na(max.level) && (!is.integer(max.level) || (max.level < 0L)))
stop("'max.level' argument must be non-negative integer or NA value", domain = "R-R2rflow")
if (missing(text) && (missing(file) || nchar(file) == 0L)) {
stop("No R code to convert", domain = "R-R2rflow")
}
else if(!missing(text) && !missing(file)) {
stop("Cannot specify both 'text' and 'file' arguments", domain = "R-R2rflow")
}
else if(!missing(text) && missing(output)) {
stop("'output' argument must be specified", domain = "R-R2rflow")
}
else if(!missing(file) && missing(output)) {
output <- sub("(\\.[RrSq])?$", "\\.rflow", file)
}
codes <- parse(text = text, file = file)
env <- new.env()
functionSet <- function (v, e) assign(v, e, envir = env)
functionGet <- function (v, e) get(v, envir = env)
w <- makeCodeWalker(call = functionCall, leaf = functionLeaf, set = functionSet, get = functionGet)
edge <- NULL
w$set("ypos", length(edge))
w$set("nodeID", 0L)
w$set("output", output)
w$set("level", 0L)
w$set("max.level", max.level)
Preambule(output)
cat('<rflow>\n', append = TRUE, file = output)
cat(' <graph version="0.7" width="894" height="742" locationtype="a" offsetx="0" offsety="0">\n', append = TRUE, file = output)
Settings(output)
if(is.na(max.level) || (max.level > 0L)) {
w$set("level", w$get("level") + 1L)
for(i in seq_len(length(codes))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(codes[[i]], w)
}
w$set("level", w$get("level") - 1L)
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
FreeNodeModel(codes, w)
}
if(connect.top) PrintEdges(edge, file = output)
cat(' </graph>\n', append = TRUE, file = output)
Task(output)
cat('</rflow>\n', append = TRUE, file = output)
}
deparseTreeExp <- function (e) {
if(!is.expression(e))
e <- deparse(e, width.cutoff = 400L, backtick = TRUE)
return(ReplaceChr(paste(e, sep = "", collapse = "\n")))
}
functionCall <- function (e, w) {
w$set("nodeID", w$get("nodeID") + 1L)
if(is.na(w$get("max.level")) || (w$get("level") < w$get("max.level"))) {
if ((e[[1]] == "<-") && (length(e[[3]]) == 4L) && (e[[3]][[1]] == "function")) {
FunctionNodeModel(e,w)
} else if (e[[1]] == "if") {
IfNodeModel(e,w)
} else if (e[[1]] == "for") {
ForNodeModel(e,w)
} else if (e[[1]] == "while") {
WhileNodeModel(e,w)
} else if (e[[1]] == "repeat") {
RepeatNodeModel(e,w)
} else if (CurlyBracket(e[[1]])) {
SubflowNodeModel(e,w)
} else {
FreeNodeModel(e,w)
}
} else
FreeNodeModel(e,w)
}
functionLeaf <- function (e, w) {
w$set("nodeID", w$get("nodeID") + 1L)
FreeNodeModel(e,w)
NULL
}
FunctionNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.FunctionNodeModel">\n', append = TRUE, file = output)
cat(sprintf(' <entry key="function">%s</entry>\n', deparseTreeExp(e[[2]])), append = TRUE, file = output)
cat(sprintf(' <entry key="args">(%s)</entry>\n', gsub("= (,|$)", "\\1", gsub("^(pair)?list\\(|\\)$|^NULL$", "", deparseTreeExp(e[[3]][[2]])))), append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[3]][[3]]) > 1L) && CurlyBracket(e[[3]][[3]][[1]])) {
for (ee in as.list(e[[3]][[3]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[3]][[3]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
IfNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(' <property/>\n', append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.IfNodeModel">\n', append = TRUE, file = output)
cat(sprintf(' <entry key="condition">%s</entry>\n', deparseTreeExp(e[[2]])), append = TRUE, file = output)
cat('<subflow>\n', append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[3]]) > 1L) && CurlyBracket(e[[3]][[1]])) {
for (ee in as.list(e[[3]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[3]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(' </graph>\n', append = TRUE, file = output)
cat('</subflow>\n', append = TRUE, file = output)
cat('<subflow>\n', append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if (length(e) == 4L) {
if ((length(e[[4]]) > 1L) && CurlyBracket(e[[4]][[1]])) {
for (ee in as.list(e[[4]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[4]], w)
}
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
if(length(edge) > 2L) PrintEdges(edge, file = output)
cat(' </graph>\n', append = TRUE, file = output)
cat('</subflow>\n', append = TRUE, file = output)
cat(' </option>\n', append = TRUE, file = output)
cat('</node>\n', append = TRUE, file = output)
}
ForNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.LoopNodeModel">\n', append = TRUE, file = output)
cat(' <entry key="loop">for</entry>\n', append = TRUE, file = output)
cat(sprintf(' <entry key="condition">%s</entry>\n', paste(deparseTreeExp(e[[2]]), " in ", deparseTreeExp(e[[3]]), sep = "", collase = "")), append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[4]]) > 1L) && CurlyBracket(e[[4]][[1]])) {
for (ee in as.list(e[[4]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[4]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
WhileNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.LoopNodeModel">\n', append = TRUE, file = output)
cat(' <entry key="loop">while</entry>\n', append = TRUE, file = output)
cat(sprintf(' <entry key="condition">%s</entry>\n', deparseTreeExp(e[[2]])), append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[3]]) > 1L) && CurlyBracket(e[[3]][[1]])) {
for (ee in as.list(e[[3]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[3]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
RepeatNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.LoopNodeModel">\n', append = TRUE, file = output)
cat(' <entry key="loop">repeat</entry>\n', append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="0" offsety="0">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
if ((length(e[[2]]) > 1L) && CurlyBracket(e[[2]][[1]])) {
for (ee in as.list(e[[2]])) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
} else {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(e[[2]], w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
SubflowNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
x <- 688L
y <- 700L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.SubflowNodeModel">\n', append = TRUE, file = output)
cat(" <subflow>\n", append = TRUE, file = output)
cat(sprintf(' <graph version="0.7" width="%d" height="%d" locationtype="a" offsetx="100" offsety="50">\n', x, y), append = TRUE, file = output)
w$set("nodeID", w$get("nodeID") + 1L)
In <- w$get("nodeID")
edge <- In
w$set("ypos", length(edge))
TunnelNodeModel(type = "in", w = w)
w$set("level", w$get("level") + 1L)
for (ee in as.list(e)) if (!missing(ee) && !CurlyBracket(deparseTreeExp(ee))) {
edge <- c(edge, w$get("nodeID") + 1L)
w$set("ypos", length(edge))
walkCode(ee, w)
}
w$set("level", w$get("level") - 1L)
w$set("nodeID", w$get("nodeID") + 1L)
Out <- w$get("nodeID")
edge <- c(edge, Out)
w$set("ypos", length(edge))
TunnelNodeModel(type = "out", w = w)
PrintEdges(edge, file = output)
cat(" </graph>\n", append = TRUE, file = output)
cat(" </subflow>\n", append = TRUE, file = output)
cat(" </option>\n", append = TRUE, file = output)
cat("</node>\n", append = TRUE, file = output)
}
FreeNodeModel <- function (e, w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(sprintf(' <command>%s</command>\n', deparseTreeExp(e)), append = TRUE, file = output)
cat(" <property/>\n", append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.FreeNodeModel"/>\n', append = TRUE, file = output)
cat('</node>\n', append = TRUE, file = output)
}
PrintEdges <- function(x, file) {
if(length(x) > 1L) for(i in seq_len(length(x)-1L)) {
cat(sprintf('<edge from="%d" to="%d"/>\n', x[i], x[i + 1L]), append = TRUE, file = file)
}
}
TunnelNodeModel <- function(type = "in", w) {
xpos <- 440L
ypos <- w$get("ypos") * 80L
output <- w$get("output")
cat(sprintf('<node id="%d" date="%s" uid="%s" x="%d" y="%d">\n', w$get("nodeID"), crdate(), uid(), xpos, ypos), append = TRUE, file = output)
cat(' <command></command>\n', append = TRUE, file = output)
cat(' <property/>\n', append = TRUE, file = output)
cat(' <option type="com.ef_prime.rflow.node.base.TunnelNodeModel">\n', append = TRUE, file = output)
cat(sprintf(' <entry key="io">%s</entry>\n', type), append = TRUE, file = output)
cat(' </option>\n', append = TRUE, file = output)
cat('</node>\n', append = TRUE, file = output)
}
Preambule <- function(output) {
cat('<?xml version="1.0" encoding="UTF-8"?>\n', append = FALSE, file = output)
cat('<!DOCTYPE rflow [\n', append = TRUE, file = output)
cat('<!ENTITY lt "&#60;">\n', append = TRUE, file = output)
cat('<!ENTITY gt ">">\n', append = TRUE, file = output)
cat('<!ENTITY amp "&#38;">\n', append = TRUE, file = output)
cat('<!ENTITY apos "'">\n', append = TRUE, file = output)
cat('<!ENTITY quot """>\n', append = TRUE, file = output)
cat(']>\n', append = TRUE, file = output)
}
Settings <- function(output) {
cat(' <setting>\n', append = TRUE, file = output)
cat(' <entry key="OUTPUT_DIRECTORY"></entry>\n', append = TRUE, file = output)
cat(' <entry key="SAVE_CACHE">false</entry>\n', append = TRUE, file = output)
cat(' <entry key="FONT_SCREEN">monospace</entry>\n', append = TRUE, file = output)
cat(' <entry key="TEXT_ENCODING">UTF-8</entry>\n', append = TRUE, file = output)
cat(' <entry key="LOAD_CACHE">false</entry>\n', append = TRUE, file = output)
cat(' <entry key="IGNORE_ERROR">false</entry>\n', append = TRUE, file = output)
cat(' <entry key="SAVE_WORKSPACE"></entry>\n', append = TRUE, file = output)
cat(' <entry key="OUTPUT_REPORT">true</entry>\n', append = TRUE, file = output)
cat(' <entry key="RUN_TYPE">2</entry>\n', append = TRUE, file = output)
cat(' <entry key="OUTPUT_ITEMS">script</entry>\n', append = TRUE, file = output)
cat(' <entry key="USE_GRID">true</entry>\n', append = TRUE, file = output)
cat(' <entry key="REPORT_TYPES">pdf,html</entry>\n', append = TRUE, file = output)
cat(' <entry key="FOLDER">empty</entry>\n', append = TRUE, file = output)
cat(' <entry key="GRID_DISTANCE2">10</entry>\n', append = TRUE, file = output)
cat(' <entry key="IMAGE_SIZE">480,480</entry>\n', append = TRUE, file = output)
cat(' <entry key="FONT_OTHER">sans-serif</entry>\n', append = TRUE, file = output)
cat(' </setting>\n', append = TRUE, file = output)
cat('<properties>\n', append = TRUE, file = output)
cat(' <v key="packages"/>\n', append = TRUE, file = output)
cat('</properties>\n', append = TRUE, file = output)
}
Task <- function(output) {
cat(' <task>\n', append = TRUE, file = output)
cat(' <taskgroup>\n', append = TRUE, file = output)
cat(' <taskproperty>\n', append = TRUE, file = output)
cat(' <entry key="title">Task</entry>\n', append = TRUE, file = output)
cat(' </taskproperty>\n', append = TRUE, file = output)
cat(' </taskgroup>\n', append = TRUE, file = output)
cat(' </task>\n', append = TRUE, file = output)
}
ReplaceChr <- function(text) {
text <- gsub("&", "&", text)
text <- gsub("<", "<", text)
text <- gsub(">", ">", text)
text <- gsub("\"", """, text)
text <- gsub("'", "'", text)
return(text)
}
CurlyBracket <- function(x) {
if(length(x) > 1L) return(FALSE)
grepl(pattern = "^`?\\{`?$", x = x)
}
uid <- function() {
return(paste(sample(c(0:9, letters[1:6]), size = 17, replace = TRUE), collapse =""))
}
crdate <- function() {
return(as.character(floor(1000*as.numeric(Sys.time()))))
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.