R/traceR.report.R
In agalecki/traceR: Utility package to trace execution of R functions
Defines functions
jsCode
traceR.report
jsCode <- function(){
extrasPath <- file.path(.Library, "traceR","extras")
jqPath <- file.path(extrasPath ,"jquery-1.3.2.min.js")
pPath <- file.path(extrasPath,"plusbox.gif")
mPath <- file.path(extrasPath,"minusbox.gif")
js <- c(
paste('<script type="text/javascript" src="', jqPath, '"></script>', sep =""),
'<script type="text/javascript">',
paste("var urlminusbox = 'url(",'"', mPath, '")',"';;", sep = ""),
paste("var urlplusbox = 'url(",'"', pPath, '")',"';;", sep = ""),
" $(function(){",
" $('li')",
" .css('pointer','default')",
" .css('list-style-image','none');",
" $('li:has(ul)')",
" .click(function(event){",
" if (this == event.target) {",
" $(this).css('list-style-image',",
" (!$(this).children().is(':hidden')) ? urlplusbox: urlminusbox);",
" $(this).children().toggle('slow');",
" }",
" return false;",
" })",
" .css({cursor:'pointer', 'list-style-image':urlplusbox})",
" .children().hide();",
" $('li:not(:has(ul))').css({cursor:'default', 'list-style-image':'none'});",
" });",
"</script>")
js
}
traceR.report <- function(con = "traceR.report.html", title, id = c("id", "recno"), staticTree = FALSE, traceRmap){
if (missing(traceRmap)) traceRmap <- get(".traceRmap", envir = .GlobalEnv)
fLbl <- traceRmap[, "fLbl"]
if (missing(title)){
txt <- paste("Tree for function ", fLbl[1], " generated by traceR.report")
title <- if (staticTree) paste("Static", txt) else paste("Collapsable", txt)
}
html1 <- c( # html head starts
'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">',
'<html xmlns="http://www.w3.org/1999/xhtml"><head>',
'<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"></meta>')
if (!staticTree) html1<-c(html1, jsCode())
html2 <- c(
"</head>",
"<body>",
"<fieldset>",
"<legend>", title, "</legend>")
# recno <- traceRmap[, "recno"]
first <- traceRmap[, "first"]
env <- traceRmap[, "env"]
fTree <- traceRmap[, "fTree"]
## recid <- traceRmap[, "id"]
idLbl <- traceRmap[, "idLbl"]
nObjAll <- traceRmap[, "nObjAll"]
fTree_lvl <- sapply(strsplit(fTree, "->", fixed = TRUE), length)
fTd <- diff(fTree_lvl)
fTd1 <- ifelse( fTd > 0, fTd, 0)
fTd1 <- c(1, fTd1)
fTd2 <- ifelse( fTd < 0, fTd, 0)
tmp <- -sum(fTd) -1
fTd2 <- c(fTd2, tmp)
# cbind(fLbl, id, first, fTree_lvl, fTd1, fTd2)
ulb <- "<ul>"
ule <- function(k) sapply(k, FUN = function(el) paste(rep("</ul>", abs(el)), collapse = ""))
li <- "<li>"
tmp <- paste(ulb, li, "Function", fLbl, "executed", ulb,"\n")
ulxb <- ifelse(fTd1 > 0, tmp, "")
tmp <- paste("\n", ule(2*fTd2))
ulxe <- ifelse(fTd2 < 0, tmp, "")
recx <- traceRmap[, id[1]]
txt1 <- sapply(seq_along(idLbl), FUN = function(i){
tmp <- unlist(strsplit(idLbl[i],"\n", fixed = TRUE))
tmp1 <- paste(recx[i], tmp[1], sep = ": ")
if (length(tmp)>1) paste(tmp1, " ...") else tmp1
})
txt2a <- sapply(seq_along(idLbl), FUN = function(i){
tmp <- unlist(strsplit(idLbl[i],"\n", fixed = TRUE))
if (length(tmp)>1) paste(tmp[-1], collapse ="<br>", sep ="\n") else ""
})
txt2abr <- paste(txt2a, "<br>", sep = "")
txt2a <- ifelse(nchar(txt2a), txt2abr, "")
txt2b <- paste("Desc: env=", env, "# of objects = ", nObjAll)
txt2 <- paste(txt2a, txt2b, sep = "" )
lix <- paste("<li>", txt1, ulb, txt2, ule(1), sep ="")
mtx <- cbind(ulxb, lix, ulxe)
tt <- apply (mtx, 1, FUN = function(x) {
paste(x, collapse = "")
}
)
tt <- c(html1, html2, tt)
writeLines(tt, con)
}
agalecki/traceR documentation built on May 29, 2019, 2:05 p.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 jsCode traceR.report
jsCode <- function(){
extrasPath <- file.path(.Library, "traceR","extras")
jqPath <- file.path(extrasPath ,"jquery-1.3.2.min.js")
pPath <- file.path(extrasPath,"plusbox.gif")
mPath <- file.path(extrasPath,"minusbox.gif")
js <- c(
paste('<script type="text/javascript" src="', jqPath, '"></script>', sep =""),
'<script type="text/javascript">',
paste("var urlminusbox = 'url(",'"', mPath, '")',"';;", sep = ""),
paste("var urlplusbox = 'url(",'"', pPath, '")',"';;", sep = ""),
" $(function(){",
" $('li')",
" .css('pointer','default')",
" .css('list-style-image','none');",
" $('li:has(ul)')",
" .click(function(event){",
" if (this == event.target) {",
" $(this).css('list-style-image',",
" (!$(this).children().is(':hidden')) ? urlplusbox: urlminusbox);",
" $(this).children().toggle('slow');",
" }",
" return false;",
" })",
" .css({cursor:'pointer', 'list-style-image':urlplusbox})",
" .children().hide();",
" $('li:not(:has(ul))').css({cursor:'default', 'list-style-image':'none'});",
" });",
"</script>")
js
}
traceR.report <- function(con = "traceR.report.html", title, id = c("id", "recno"), staticTree = FALSE, traceRmap){
if (missing(traceRmap)) traceRmap <- get(".traceRmap", envir = .GlobalEnv)
fLbl <- traceRmap[, "fLbl"]
if (missing(title)){
txt <- paste("Tree for function ", fLbl[1], " generated by traceR.report")
title <- if (staticTree) paste("Static", txt) else paste("Collapsable", txt)
}
html1 <- c( # html head starts
'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">',
'<html xmlns="http://www.w3.org/1999/xhtml"><head>',
'<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"></meta>')
if (!staticTree) html1<-c(html1, jsCode())
html2 <- c(
"</head>",
"<body>",
"<fieldset>",
"<legend>", title, "</legend>")
# recno <- traceRmap[, "recno"]
first <- traceRmap[, "first"]
env <- traceRmap[, "env"]
fTree <- traceRmap[, "fTree"]
## recid <- traceRmap[, "id"]
idLbl <- traceRmap[, "idLbl"]
nObjAll <- traceRmap[, "nObjAll"]
fTree_lvl <- sapply(strsplit(fTree, "->", fixed = TRUE), length)
fTd <- diff(fTree_lvl)
fTd1 <- ifelse( fTd > 0, fTd, 0)
fTd1 <- c(1, fTd1)
fTd2 <- ifelse( fTd < 0, fTd, 0)
tmp <- -sum(fTd) -1
fTd2 <- c(fTd2, tmp)
# cbind(fLbl, id, first, fTree_lvl, fTd1, fTd2)
ulb <- "<ul>"
ule <- function(k) sapply(k, FUN = function(el) paste(rep("</ul>", abs(el)), collapse = ""))
li <- "<li>"
tmp <- paste(ulb, li, "Function", fLbl, "executed", ulb,"\n")
ulxb <- ifelse(fTd1 > 0, tmp, "")
tmp <- paste("\n", ule(2*fTd2))
ulxe <- ifelse(fTd2 < 0, tmp, "")
recx <- traceRmap[, id[1]]
txt1 <- sapply(seq_along(idLbl), FUN = function(i){
tmp <- unlist(strsplit(idLbl[i],"\n", fixed = TRUE))
tmp1 <- paste(recx[i], tmp[1], sep = ": ")
if (length(tmp)>1) paste(tmp1, " ...") else tmp1
})
txt2a <- sapply(seq_along(idLbl), FUN = function(i){
tmp <- unlist(strsplit(idLbl[i],"\n", fixed = TRUE))
if (length(tmp)>1) paste(tmp[-1], collapse ="<br>", sep ="\n") else ""
})
txt2abr <- paste(txt2a, "<br>", sep = "")
txt2a <- ifelse(nchar(txt2a), txt2abr, "")
txt2b <- paste("Desc: env=", env, "# of objects = ", nObjAll)
txt2 <- paste(txt2a, txt2b, sep = "" )
lix <- paste("<li>", txt1, ulb, txt2, ule(1), sep ="")
mtx <- cbind(ulxb, lix, ulxe)
tt <- apply (mtx, 1, FUN = function(x) {
paste(x, collapse = "")
}
)
tt <- c(html1, html2, tt)
writeLines(tt, con)
}
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.