offspring <- function(path, win) {
DF <- attr(win, 'env')$offspringDF
self.gc <- attr(win, 'env')$self.gc
if(length(path) > 0){
pathLength <- length(path)
path <- paste(path, collapse=" -> ")
offspringDF <- DF[path == sapply(strsplit(DF$path, " -> "),
function(x){ if(length(x) > pathLength)
x <- x[1:pathLength]
paste(x, collapse=" -> ")}),]
sonsDepth <- offspringDF$depth[1]+1
sons <- which(offspringDF$depth==sonsDepth)
if(sons[length(sons)] == nrow(offspringDF))
nextDepths <- c(offspringDF$depth[sons[-length(sons)]+1], 0)
else nextDepths <- offspringDF$depth[sons+1]
haveSons <- (nextDepths > offspringDF$depth[sons])
offspringDF <- data.frame(Function=offspringDF$name[sons],
haveSons=haveSons,
total=offspringDF$total[sons],
self=offspringDF$self[sons],
GC=offspringDF$GC[sons],
GC.Self=offspringDF$GC.Self[sons],
alloc=offspringDF$alloc[sons],
allocself=offspringDF$allocself[sons],
stringsAsFactors=FALSE)
}
else{
foundingFathers <- which(DF$depth==1)
if(foundingFathers[length(foundingFathers)] == nrow(DF))
nextDepths <- c(DF$depth[foundingFathers[-length(foundingFathers)]+1]
, 0)
else nextDepths <- DF$depth[foundingFathers+1]
haveSons <- (nextDepths > DF$depth[foundingFathers])
offspringDF <- data.frame(Function=DF$name[foundingFathers],
haveSons=haveSons,
total=DF$total[foundingFathers],
self=DF$self[foundingFathers],
GC=DF$GC[foundingFathers],
GC.Self=DF$GC.Self[foundingFathers],
alloc = DF$alloc[foundingFathers],
allocself = DF$allocself[foundingFathers],
stringsAsFactors=FALSE)
}
if(!self.gc[1]) {
offspringDF$self = NULL
offspringDF$GC.Self = NULL
offspringDF$allocself = NULL
}
if(!self.gc[2]) {
offspringDF$GC = NULL
offspringDF$GC.Self = NULL
}
if(!self.gc[3]) {
offspringDF$alloc = NULL
offspringDF$allocself = NULL
}
return(offspringDF)
}
setOffspringDF <- function(pd, value = c("pct", "time", "hits"),
self = FALSE, srclines = TRUE, gc = TRUE, memory = FALSE,
maxdepth = 10){
pathData <- hotPaths(pd, value, self, srclines, gc, memory, maxdepth = maxdepth, short = "-> ")
x <- strsplit(pathData$path, "-> ")
## Plugs function names into paths and gets depth of each line
y <- sapply(1:length(x),
function(i) {
x[[i]][length(x[[i]])] <<- sub("^(.+?) *$", "\\1",
x[[i]][length(x[[i]])])
if(length(x[[i]])>1)
x[[i]][1:length(x[[i]])-1] <<- x[[i-1]][1:length(x[[i]])-1]
c(paste(x[[i]], collapse=" -> "), x[[i]][length(x[[i]])],
length(x[[i]]))
}
)
pathData <- fixSumDF(pathData, self, gc, value, memory)
## Reason for global assignment is tcltk toolkit has problems passing the
## dataframe to get children of foundingFathers
data.frame(path=as.character(y[1,]),
name=as.character(y[2,]), depth=as.numeric(y[3,]),
total=pathData$total, self=pathData$self,
GC=pathData$gc, GC.Self=pathData$gcself,
alloc=pathData$alloc, allocself = pathData$allocself,
stringsAsFactors = FALSE)
}
fixSumDF <- function(DF, self, gc, value, memory){
names(DF) <- sub(paste(".", value[1], sep=""), "", names(DF), fixed=T)
if(!gc){
DF$gc <- rep("", nrow(DF))
DF$gcself <- rep("", nrow(DF))
}
if(!memory){
DF$alloc <- rep("", nrow(DF))
DF$allocself <- rep("", nrow(DF))
}
if(!self){
DF$self <- rep("", nrow(DF))
DF$gcself <- rep("", nrow(DF))
DF$allocself <- rep("", nrow(DF))
}
DF
}
offspringFunSum <- function(path, win) {
callSum <- attr(win, 'env')$callSum
fcnSummary <- attr(win, 'env')$fcnSummary
self.gc <- attr(win, 'env')$self.gc
if(length(path) > 0){
fcnName <- path[length(path)]
calledFcns <- grep(fcnName, callSum$callers, fixed=TRUE)
calledFcns <- callSum[calledFcns,]
haveSons <- sapply(calledFcns$callees,
function(x) { any(grepl(x, callSum$callers,
fixed=TRUE)) })
offspringDF <- data.frame(Function = calledFcns$callees,
haveSons = haveSons,
total=calledFcns$total,
self=calledFcns$self,
GC=calledFcns$gc,
GC.Self=calledFcns$gcself,
alloc = calledFcns$alloc,
allocself = calledFcns$allocself,
stringsAsFactors=FALSE)
}
else{
foundingFathers <- fcnSummary$fun
haveSons <- sapply(foundingFathers,
function(x) { any(grepl(x, callSum$callers,
fixed=TRUE)) })
offspringDF <- data.frame(Function = foundingFathers,
haveSons = haveSons,
total=fcnSummary$total,
self=fcnSummary$self,
GC=fcnSummary$gc,
GC.Self=fcnSummary$gcself,
alloc=fcnSummary$alloc,
allocself=fcnSummary$allocself,
stringsAsFactors=FALSE)
}
if(!self.gc[1]) {
offspringDF$self = NULL
offspringDF$GC.Self = NULL
offspringDF$allocself = NULL
}
if(!self.gc[2]) {
offspringDF$GC = NULL
offspringDF$GC.Self = NULL
}
if(!self.gc[3]) {
offspringDF$alloc = NULL
offspringDF$allocself = NULL
}
return(offspringDF)
}
proftoolsGUI <- function(pd = NULL, method = c("gwidgets", "shiny"),
value = c("pct", "time", "hits"), self = FALSE,
gc = TRUE, memory = FALSE, srclines = TRUE){
value <- match.arg(value)
if(method == "gwidgets")
startWidget(pd, value, self, gc, memory, srclines)
else if(method == "shiny")
runShiny(pd, value, self, gc, memory, srclines)
}
startWidget <- function(pd = NULL, value = c("pct", "time", "hits"),
self = FALSE, gc = TRUE, memory = FALSE, srclines = TRUE,
maxdepth = 10, interval = NULL,
treeType="funSum", toolkit="RGtk2"){
if (is.character(pd))
pd <- readProfileData(pd)
value <- match.arg(value)
options(guiToolkit = toolkit)
win <- gWidgets2::gwindow("Hot Path Tree", height=700, width=1000)
## Remove widgetMenu from previous session
# if(exists("widgetMenu"))
# remove(widgetMenu, pos=.GlobalEnv)
processWidget(pd, value, self, srclines, gc, memory, maxdepth, interval, treeType,
win)
}
attemptAnnot <- function(pd, value, gc, show=FALSE){
tryCatch(srcAnnotate <- annotateSource(pd, value, gc, show=FALSE),
error = function(e) srcAnnotate <<- NULL,
warning = function(w){srcAnnotate <<- NULL})
srcAnnotate
}
processWidget <- function(pd, value = c("pct", "time", "hits"),
self = FALSE, srclines = TRUE, gc = TRUE, memory = FALSE,
maxdepth = 10, interval, treeType="funSum", win){
group <- gWidgets2::ggroup(horizontal=FALSE,container=win)
# we use if statement below to preserve the menu if it exists
# if it does, we modify its svalue later
if(is.null(attr(win, 'env')))
attr(win, 'env') <- new.env()
attr(win, 'env')$self.gc <- c(self, gc, memory)
if(!is.null(pd)){
buttonCont <- gWidgets2::ggroup(container=group)
passedList <- list(pd=pd, value=value, self=self, srclines=srclines,
gc=gc, memory = memory, maxdepth=maxdepth, interval=interval,
treeType=treeType, win=win, group=group)
gWidgets2::glabel("Summary: ", container=buttonCont)
SummaryView <- ifelse(treeType == "funSum", "Function", "Hot Paths")
summaryCombo <- gWidgets2::gcombobox(c(SummaryView, "Function", "Hot Paths"),
container=buttonCont, handler=summaryHandler,
action=passedList)
gWidgets2::size(summaryCombo) <- c(100, -1)
gWidgets2::glabel("Units: ", container=buttonCont)
units <- gWidgets2::gcombobox(c(value[1], "pct", "time", "hits"), container=buttonCont,
handler=unitsHandler, action=passedList)
gWidgets2::size(units) <- c(50, -1)
checkBoxes <- c("self", "gc", "memory", "srclines"); checked=c(self,gc,memory,srclines)
if(!pd$haveGC){
checkBoxes <- checkBoxes[-2]
checked <- checked[-2]
gc <- FALSE
}
if(!pd$haveMem){
checkBoxes <- checkBoxes[-3]
checked <- checked[-3]
memory <- FALSE
}
gWidgets2::gcheckboxgroup(checkBoxes, checked=checked,
container=buttonCont, horizontal=T,
handler=checkHandler, action=passedList)
addSpinners(pd, value, self, srclines, gc, memory, maxdepth, interval, treeType, win, group)
spinnerCont <- gWidgets2::gpanedgroup(container=group)
gWidgets2::ggroup(container=spinnerCont)
spinnerGroup <- gWidgets2::ggroup(container=spinnerCont)
gWidgets2::svalue(spinnerCont) <- .5
gWidgets2::glabel("Max Nodes: ", container=spinnerGroup)
maxnodes <- gWidgets2::gspinbutton(from=5, to=200, by=1, value=30, cont=spinnerGroup)
gWidgets2::glabel("Drop Threshold: ", container=spinnerGroup)
dropBelow <- gWidgets2::gspinbutton(from=0, to=99, by=1, value=0, cont=spinnerGroup)
trimCallgraph <- gWidgets2::gbutton("Show trimmed Callgraph", cont=spinnerGroup)
if(!is.null(interval))
filteredPD <- filterProfileData(pd, interval = interval)
else filteredPD <- pd
srcAnnotate <- attemptAnnot(filteredPD, value, gc, show=FALSE); conf <- FALSE
if(is.null(srcAnnotate))
conf <- gWidgets2::gconfirm(paste0('Could not find source files in the ',
'working directory, press OK to locate the',
' directory with source files, or Cancel',
' to continue without source annotations.'),
title="Source files not found", icon="warning")
if(conf){
directory <- gWidgets2::gfile(type="selectdir")
setwd(directory)
srcAnnotate <- attemptAnnot()
}
if(treeType=="funSum")
funSumTree(filteredPD, value, self, srclines, gc, memory, srcAnnotate,
maxnodes, dropBelow, trimCallgraph, win, group)
else
hotPathsTree(filteredPD, value, self, srclines, gc, memory, maxdepth,
srcAnnotate, maxnodes, dropBelow, trimCallgraph, win,
group)
stats::update(win)
}
graphics::plot.new()
plotProfileCallGraph(pd, style = google.style, maxnodes = gWidgets2::svalue(maxnodes),
total.pct = gWidgets2::svalue(dropBelow))
}
addSpinners <- function(pd, value = c("pct", "time", "hits"), self = FALSE,
srclines = TRUE, gc = TRUE, memory = FALSE, maxdepth=10, interval,
treeType, win, group){
if(is.null(interval)) interval <- c(1, pd$total)
spinnerCont <- gWidgets2::gframe(text = "Filter Selection", container=group,
horizontal = FALSE)
sCont <- gWidgets2::ggroup(container=spinnerCont)
gWidgets2::glabel("Start: ", container=sCont)
s1Handler <- function(h, ...){
if(gWidgets2::svalue(s1) > gWidgets2::svalue(s2))
gWidgets2::svalue(s1) <- gWidgets2::svalue(s2)
interval <<- c(gWidgets2::svalue(s1), gWidgets2::svalue(s2))
}
s2Handler <- function(h, ...){
if(gWidgets2::svalue(s2) < gWidgets2::svalue(s1))
gWidgets2::svalue(s2) <- gWidgets2::svalue(s1)
interval <<- c(gWidgets2::svalue(s1), gWidgets2::svalue(s2))
}
filterHandler <- function(h, ...){
gWidgets2::delete(win, group)
processWidget(pd, value, self, srclines, gc, memory, maxdepth,
interval, treeType, win)
}
s1 <- gWidgets2::gspinbutton(from=1, to=pd$total, by=1, value=interval[1],
handler = s1Handler, cont=sCont)
gWidgets2::glabel("Stop: ", container=sCont)
s2 <- gWidgets2::gspinbutton(from=1, to=pd$total, by=1, value=interval[2],
handler = s2Handler, cont=sCont)
gWidgets2::gbutton("Filter Selection", handler = filterHandler,
cont=sCont)
}
# addMenu <- function(pd, value = c("pct", "time", "hits"), self = FALSE,
# srclines = TRUE, gc = TRUE, maxdepth=10, interval, treeType,
# win, group){
# browseStack <- function(h, ...){
# stackBrowse <- gWidgets2::gfile("Choose a Stack file", quote=FALSE, filter =
# list("Stack files"=list(patterns=c("*.out", "*.txt"))))
# pd <- readProfileData(stackBrowse)
# stopIfEmpty(pd, group)
# gWidgets2::delete(win, group)
# processWidget(pd, value, self, srclines, gc, maxdepth, interval,
# treeType, win)
# }
# browseR <- function(h, ...){
# sourceBrowse <- gWidgets2::gfile("Source and profile an R file", quote=FALSE,
# filter = list("Stack files"=
# list(patterns=c("*.R", "*.txt"))))
# Rprof(tmp <- tempfile(), gc.profiling = TRUE, line.profiling = TRUE)
# source(sourceBrowse)
# Rprof(NULL)
# pd <- readProfileData(tmp)
# stopIfEmpty(pd, group)
# gWidgets2::delete(win, group)
# processWidget(filterProfileData(pd, focus = "source"), value, self,
# srclines, gc, maxdepth, interval, treeType, win)
# unlink(tmp)
# }
# profileRCode <- function(h, ...){
# profileCode(pd, value, self, srclines, gc, maxdepth, NULL, treeType, win, group)
# }
# mn <- list(); mn$File <- list();
# mn$File[['Select a stack file']] <- gWidgets2::gaction("Select a stack file",
# handler=browseStack)
# mn$File[['Source an R file']] <- gWidgets2::gaction("Source an R file", handler=browseR)
# mn$File[['Profile some R code']] <- gWidgets2::gaction("Profile some R code",
# handler=profileRCode)
# if(!is.null(interval))
# filteredPD <- filterProfileData(pd, interval = interval)
# else filteredPD <- pd
# mn$Plot <- list();
# attr(win, 'env')$plotType <- 'plotCallgraph'
# mn$Plot[['Plot Callgraph']] <- gWidgets2::gaction('Plot Callgraph', handler=function(h,...){
# gWidgets2::visible(gg) <- TRUE
# attr(win, 'env')$plotObj <- plotProfileCallGraph(filteredPD, style = google.style)
# attr(win, 'env')$plotType <- 'plotCallgraph'
# })
# mn$Plot[['Plot Tree Map']] <- gWidgets2::gaction('Plot Tree Map', handler=function(h,...){
# gWidgets2::visible(gg) <- TRUE
# attr(win, 'env')$plotObj <- calleeTreeMap(filteredPD)
# attr(win, 'env')$plotType <- 'plotTreemap'
# })
# mn$Plot[['Plot Flame Graph']] <- gWidgets2::gaction('Plot Flame Graph', handler=function(h,...){
# gWidgets2::visible(gg) <- TRUE
# attr(win, 'env')$plotObj <- flameGraph(filteredPD, order="hot")
# attr(win, 'env')$plotType <- 'plotFlamegraph'
# })
# mn$Plot[['Plot Time Graph']] <- gWidgets2::gaction('Plot Time Graph', handler=function(h,...){
# gWidgets2::visible(gg) <- TRUE
# attr(win, 'env')$plotObj <- flameGraph(filteredPD, order="time")
# attr(win, 'env')$plotType <- 'plotTimegraph'
# })
# trying the below was problematic because 'menu' object exists by default
# if(exists("menu", envir = attr(win, 'env')))
# gWidgets2::svalue(attr(win, 'env')$menu) <- mn
# if(exists("m", envir = attr(win, 'env')))
# gWidgets2::svalue(attr(win, 'env')$m) <- mn
# else
# attr(win, 'env')$m <- gmenu(mn, container=win)
# }
addMenu <- function(pd, value = c("pct", "time", "hits"), self = FALSE,
srclines = TRUE, gc = TRUE, memory = FALSE, maxdepth=10, treeType,
win, group, gg){
browseStack <- function(h, ...){
stackBrowse <- gWidgets2::gfile("Choose a Stack file", quote=FALSE, filter =
list("Stack files"=list(patterns=c("*.out", "*.txt"))))
pd <- readProfileData(stackBrowse)
stopIfEmpty(pd, group)
gWidgets2::delete(win, group)
processWidget(pd, value, self, srclines, gc, memory, maxdepth, NULL, treeType, win)
}
browseR <- function(h, ...){
sourceBrowse <- gWidgets2::gfile("Source and profile an R file", quote=FALSE,
filter = list("Stack files"=
list(patterns=c("*.R", "*.txt"))))
utils::Rprof(tmp <- tempfile(), gc.profiling = TRUE, line.profiling = TRUE, memory.profiling = memory)
source(sourceBrowse)
utils::Rprof(NULL)
pd <- readProfileData(tmp)
stopIfEmpty(pd, group)
gWidgets2::delete(win, group)
processWidget(filterProfileData(pd, focus = "source"), value, self,
srclines, gc, memory, maxdepth, NULL, treeType, win)
unlink(tmp)
}
profileRCode <- function(h, ...){
profileCode(pd, value, self, srclines, gc, memory, maxdepth, NULL, treeType, win, group)
}
mn <- list(); mn$File <- list();
mn$File[['Select a stack file']] <- gWidgets2::gaction("Select a stack file",
handler=browseStack)
mn$File[['Source an R file']] <- gWidgets2::gaction("Source an R file", handler=browseR)
mn$File[['Profile some R code']] <- gWidgets2::gaction("Profile some R code",
handler=profileRCode)
mn$Plot <- list();
attr(win, 'env')$plotType <- 'plotCallgraph'
mn$Plot[['Plot Callgraph']] <- gWidgets2::gaction('Plot Callgraph', handler=function(h,...){
gWidgets2::visible(gg) <- TRUE
attr(win, 'env')$plotObj <- plotProfileCallGraph(pd, style = google.style)
attr(win, 'env')$plotType <- 'plotCallgraph'
})
mn$Plot[['Plot Tree Map']] <- gWidgets2::gaction('Plot Tree Map', handler=function(h,...){
gWidgets2::visible(gg) <- TRUE
attr(win, 'env')$plotObj <- calleeTreeMap(pd)
attr(win, 'env')$plotType <- 'plotTreemap'
})
mn$Plot[['Plot Flame Graph']] <- gWidgets2::gaction('Plot Flame Graph', handler=function(h,...){
gWidgets2::visible(gg) <- TRUE
attr(win, 'env')$plotObj <- flameGraph(pd, order="hot")
attr(win, 'env')$plotType <- 'plotFlamegraph'
})
mn$Plot[['Plot Time Graph']] <- gWidgets2::gaction('Plot Time Graph', handler=function(h,...){
gWidgets2::visible(gg) <- TRUE
attr(win, 'env')$plotObj <- flameGraph(pd, order="time")
attr(win, 'env')$plotType <- 'plotTimegraph'
})
# trying the below was problematic because 'menu' object exists by default
# if(exists("menu", envir = attr(win, 'env')))
# gWidgets2::svalue(attr(win, 'env')$menu) <- mn
if(exists("m", envir = attr(win, 'env')))
gWidgets2::svalue(attr(win, 'env')$m) <- mn
else
attr(win, 'env')$m <- gWidgets2::gmenu(mn, container=win)
}
profileCode <- function(pd, value = c("pct", "time", "hits"), self = FALSE,
srclines = TRUE, gc = TRUE, memory = FALSE, maxdepth=10, interval,
treeType, win, group){
codeWindow <- gWidgets2::gwindow("Profile R code", width=500, height=500)
codeGroup <- gWidgets2::ggroup(horizontal=FALSE,container=codeWindow)
profileText <- gWidgets2::gtext("## Enter some R code here to profile",
container=codeGroup, wrap=FALSE,
font.attr=list(family="monospace"), expand=TRUE,
fill="both")
btn <- gWidgets2::gbutton("Profile It", container=codeGroup)
gWidgets2::addHandlerChanged(btn, handler = function(h, ...) {
tmp1 <- paste(tempfile(), ".R", sep="")
write(gWidgets2::svalue(profileText), file=tmp1)
utils::Rprof(tmp <- tempfile(), gc.profiling = TRUE, line.profiling = TRUE, memory.profiling = memory)
source(tmp1)
utils::Rprof(NULL)
pd <- readProfileData(tmp)
stopIfEmpty(pd, group)
mydepth <- length(sys.calls())
pd <- proftools:::skipPD(pd, mydepth+4)
gWidgets2::delete(win, group)
gWidgets2::dispose(codeWindow)
processWidget(pd, value, self, srclines, gc, memory, maxdepth, NULL, treeType,
win)
})
}
# Give an error message if stack file is empty
stopIfEmpty <- function(pd, group){
if(pd$total == 0){
gWidgets2::gmessage('Your code produced a stack file of zero lines', title = "Error",
icon = "error", parent=group)
stop('Your code produced a stack file of zero lines')
}
}
prepareCallSum <- function(pd, byTotal = TRUE, value, srclines, gc, memory){
callSum <- format(callSummary(pd, byTotal = TRUE, value, srclines, gc, memory))
callerCallee <- do.call(rbind, strsplit(callSum[,1], " -> "))
callSum <- cbind(callerCallee, callSum[,-1])
names(callSum)[1:2] <- c("callers", "callees")
callSum
# callSumDF <- data.frame(row.names = 1:nrow(callSum))
#
# callSumDF$callers <- callerCallee[,1]
# callSumDF$callees <- callerCallee[,2]
# callSum <- callSum[,2:ncol(callSum)]
# class(callSum) <- "numeric"
# callSumDF <- cbind(callSumDF, callSum)
# callSumDF
}
prepareFcnSummary <- function(pd, byTotal = TRUE, value, srclines, gc, memory){
fcnSumm <- format(funSummary(pd, byTotal = TRUE, value, srclines, gc, memory))
fcnSumm[,1] <- trimws(fcnSumm[,1])
names(fcnSumm)[1] <- "fun"
fcnSumm
# fcnSummary <- data.frame(row.names = 1:nrow(fcnSumm))
# fcnSummary$fun <- fcnSumm[,1]
# fcnSumm <- fcnSumm[,2:ncol(fcnSumm)]
# class(fcnSumm) <- "numeric"
# fcnSummary <- cbind(fcnSummary, fcnSumm)
# fcnSummary
}
funSumTree <- function(pd, value = c("pct", "time", "hits"), self = FALSE,
srclines = TRUE, gc = TRUE, memory = FALSE, srcAnnotate,maxnodes,
dropBelow, trimCallgraph, win, group){
treeType <- "funSum"
# callers <- paste0(callSum$caller, ifelse(is.na(callSum$caller.line), '',
# paste0(' ', '(', callSum$caller.file,
# ':', callSum$caller.line, ')')))
# callees <- paste0(callSum$callee, ifelse(is.na(callSum$callee.line), '',
# paste0(' ', '(', callSum$callee.file,
# ':', callSum$callee.line, ')')))
callSumDF <- prepareCallSum(pd, byTotal = TRUE, value, srclines, gc, memory)
attr(win, 'env')$callSum <- fixSumDF(callSumDF, self, gc, value, memory)
fcnSummary <- prepareFcnSummary(pd, byTotal = TRUE, value, srclines, gc, memory)
attr(win, 'env')$fcnSummary <- fixSumDF(fcnSummary, self, gc, value, memory)
gPane <- gWidgets2::gpanedgroup(horizontal=FALSE, container=group, expand=TRUE)
g <- gWidgets2::gpanedgroup(container=gPane)
treeCont <- gWidgets2::gframe(text="Function Summary", container=g, expand=TRUE)
gg <- gWidgets2::ggraphics(container=g, expand=TRUE)
gWidgets2::svalue(g) <- .5
fcnAnnotCont <- gWidgets2::gframe(text="Function Annotations", container=gPane,
expand=TRUE, fill="both")
tree <- gWidgets2::gtree(offspring=offspringFunSum, offspring.data = win,
container=treeCont, expand=TRUE, fill="both")
fcnAnnot <- gWidgets2::gtext("", container=fcnAnnotCont, wrap=FALSE,
font.attr=list(family="monospace"), expand=TRUE,
fill="both")
addMenu(pd, value, self, srclines, gc, memory, maxdepth=10, treeType, win, group, gg)
addHandlers(tree, fcnAnnot, treeType, srcAnnotate, pd, maxnodes,
dropBelow, trimCallgraph, gg, win)
}
hotPathsTree <- function(pd, value = c("pct", "time", "hits"), self = FALSE,
srclines = TRUE, gc = TRUE, memory = FALSE, maxdepth = 10, srcAnnotate,
maxnodes, dropBelow, trimCallgraph, win, group){
treeType <- "hotPaths"
attr(win, 'env')$offspringDF <- setOffspringDF(pd, value, self, srclines, gc, memory, maxdepth)
gPane <- gWidgets2::gpanedgroup(horizontal=FALSE, container=group, expand=TRUE)
g <- gWidgets2::gpanedgroup(container=gPane)
treeCont <- gWidgets2::gframe(text="Hot Paths", container=g, expand=TRUE,
fill="both")
gg <- gWidgets2::ggraphics(container=g, expand=TRUE)
gWidgets2::svalue(g) <- .5
fcnAnnotCont <- gWidgets2::gframe(text="Function Annotations", container=gPane,
expand=TRUE, fill="both")
tree <- gWidgets2::gtree(offspring = offspring, offspring.data = win,
container=treeCont, expand=TRUE, fill="both")
fcnAnnot <- gWidgets2::gtext("", container=fcnAnnotCont, wrap=FALSE,
font.attr=list(family="monospace"), expand=TRUE,
fill="both")
addMenu(pd, value, self, srclines, gc, memory, maxdepth=10, treeType, win, group, gg)
addHandlers(tree, fcnAnnot, treeType, srcAnnotate, pd, maxnodes,
dropBelow, trimCallgraph, gg, win)
}
parseOffspring <- function(path, treetype, win, id=NULL){
if(treetype == 'hotpaths')
offspringDF <- offspring(path, win)
else offspringDF <- offspringFunSum(path, win)
paste(sapply(1:nrow(offspringDF), parseSon, offspringDF, path, id, treetype, win),
collapse=",")
}
## gets function name without line info
getFname <- function(annotName){
fcnName <- annotName
hasLine <- regexpr("(", fcnName, fixed=T)
if(hasLine[1]>0)
fcnName <- substr(fcnName, 1, hasLine[1]-2)
fcnName
}
## Matches a vector in a sequence
vecIn <- function(a,b){
which(Reduce('+', lapply(seq_along(y <- lapply(b, '==', a)),
function(x){
y[[x]][x:(length(a) - length(b) +x)]
})) == length(b))
}
## this is old parseSon, uses hardcoded column names
parseSon <- function(i, offspringDF, path, id, treetype, win){
if(length(path)) parent <- paste0(',"_parentId":', id)
else parent <- NULL
#parentID <- substr(id[1], 1, nchar(id[1])-1)
newID <- paste0(length(path)+1,id,i)
x <- paste("{\"id\":", newID, ",\"name\":\"", offspringDF$Function[i],
"\",\"total\":\"", offspringDF$total[i], "\",\"self\":\"",
offspringDF$self[i], "\",\"GC\":\"", offspringDF$GC[i], "\",\"GCself\":\"",
offspringDF$GC.Self[i], "\"", parent, sep="")
if(length(path) && (treetype == "funSum")){
# lastTwo <- c(getFname(path[length(path)]),
# getFname(as.character(offspringDF$Function[i])))
# makeSons <- !(any(as.logical(lapply(cycles, vecIn, lastTwo)), na.rm=TRUE)
# || (lastTwo[1] == lastTwo[2])
# || (length(path) >= 2))
makeSons <- !(length(path) >= 2)
}
else
makeSons <- TRUE
if(offspringDF$haveSons[i] && makeSons)
x <- paste(x, "},",
parseOffspring(c(path, as.character(offspringDF$Function[i]))
, treetype, win, newID))
else
x <- paste(x,"}")
x
}
parseSon <- function(i, offspringDF, path, id, treetype, win){
if(length(path)) parent <- paste0(',"_parentId":', id)
else parent <- NULL
#parentID <- substr(id[1], 1, nchar(id[1])-1)
newID <- paste0(length(path)+1,id,i)
fieldNames <- names(offspringDF)
fields <- paste(sapply(fieldNames,
function(x) paste0('"',x,'":"', offspringDF[[x]][i], '"')),
collapse = ",")
fields <- paste('{"id":', newID, ',', fields, parent)
if(length(path) && (treetype == "funSum")){
# lastTwo <- c(getFname(path[length(path)]),
# getFname(as.character(offspringDF$Function[i])))
# makeSons <- !(any(as.logical(lapply(cycles, vecIn, lastTwo)), na.rm=TRUE)
# || (lastTwo[1] == lastTwo[2])
# || (length(path) >= 2))
makeSons <- !(length(path) >= 2)
}
else
makeSons <- TRUE
if(offspringDF$haveSons[i] && makeSons)
fields <- paste(fields, ',"state":"closed"},',
parseOffspring(c(path, as.character(offspringDF$Function[i]))
, treetype, win, newID))
else
fields <- paste(fields,"}")
fields
}
generateJSON <- function(pd, path, winHotpaths, winFunsum){
# cycles <- profileDataCycles(pd, TRUE)
# cycles <<- lapply(cycles, function(x) c(x, x[1]))
write(c("{\"rows\":[",parseOffspring(c(), 'hotpaths', winHotpaths),"]}"),
file.path(path, "tempDir", "hotpaths.JSON"))
write(c("{\"rows\":[",parseOffspring(c(), 'funSum', winFunsum),"]}"),
file.path(path, "tempDir", "funsum.JSON"))
}
shinyPD <- local({
pd <- NULL
function(new) {
if (! missing(new))
pd <<- new
pd
}
})
arg <- local({
arg <- NULL
function(new) {
if (! missing(new))
arg <<- new
arg
}
})
shinyFilename <- local({
shinyFilename <- NULL
function(new) {
if (! missing(new))
shinyFilename <<- new
shinyFilename
}
})
runShiny <- function(pd, value = c("pct", "time", "hits"),
self = FALSE, gc = TRUE, memory = FALSE, srclines = TRUE,
maxdepth = 10){
value <- match.arg(value)
if(!pd$haveMem) memory <- FALSE
if(!pd$haveGC) gc <- FALSE
pd$files <- normalizePath(pd$files)
shinyPD(pd)
arg(list(self, gc, memory, value, srclines))
# srcAnnotate <<- annotateSource(pd, value, gc, show=FALSE)
# cols <- c("<th field=\"self\" width=\"150\">Self</th>",
# "<th field=\"GC\" width=\"150\">GC</th>",
# "<th field=\"GCself\" width=\"150\">GC.Self</th>")
# if(!gc)
# cols[2:3] <- ""
# if(!self)
# cols[c(1,3)] <- ""
path <- system.file("appdir", package="proftoolsGUI")
#path <- "C:/Users/Big-Rod/Documents/GitHub/Rpkg-proftools-GUI/inst/appdir"
# index <- readLines(file.path(path, "www", "index.html"))
# index[288] <- paste0(' <option value="', value, '" selected>', value, '</option>')
# checked <- ifelse(c(self, gc), rep(' checked', 2), c('', ''))
# index[293:295] <- paste0(c('<input id="total" type="hidden" name="count" value="',
# '<input id="self" type="checkbox" name="self" value="1"',
# '<input id="gc" type="checkbox" name="gc" value="1" '),
# c(pd$total, checked), c('">', '> Self', '> GC'))
# write(index,file.path(path, "www", "index.html"))
winHotpaths <- winFunsum <- c(1)
attr(winHotpaths, 'env') <- attr(winFunsum, 'env') <- new.env()
attr(winHotpaths, 'env')$self.gc <- attr(winFunsum, 'env')$self.gc <- c(self, gc, memory)
attr(winHotpaths, 'env')$offspringDF <- setOffspringDF(pd, value, self, srclines=TRUE,
gc, memory, maxdepth=10)
# callSum <- callSummary(pd, byTotal = TRUE, value, srclines=TRUE, gc)
# callSum$fun <- paste(" ", callSum$fun, sep="")
callSumDF <- prepareCallSum(pd, byTotal = TRUE, value, srclines, gc, memory)
attr(winFunsum, 'env')$callSum <- fixSumDF(callSumDF, self, gc, value, memory)
fcnSummary <- prepareFcnSummary(pd, byTotal = TRUE, value, srclines, gc, memory)
attr(winFunsum, 'env')$fcnSummary <- fixSumDF(fcnSummary, self, gc, value, memory)
tempDir <- tempdir()
dir.create(file.path(tempDir, "tempDir"), showWarnings = FALSE)
shiny::addResourcePath("tempDir", file.path(tempDir, "tempDir"))
generateJSON(pd, tempDir, winHotpaths, winFunsum)
shiny::runApp(path)
}
prepareShiny <- function(pd, value = c("pct", "time", "hits"),
self = FALSE, gc = TRUE, memory = FALSE, srclines = TRUE,
maxdepth = 10){
value <- match.arg(value)
if(!pd$haveMem) memory <- FALSE
if(!pd$haveGC) gc <- FALSE
pd$files <- normalizePath(pd$files)
shinyPD(pd)
arg(list(self, gc, memory, value, srclines))
# srcAnnotate <<- attemptAnnot(pd, value, gc, show=FALSE)
# cols <- c("<th field=\"self\" width=\"150\">Self</th>",
# "<th field=\"GC\" width=\"150\">GC</th>",
# "<th field=\"GCself\" width=\"150\">GC.Self</th>")
# if(!gc)
# cols[2:3] <- ""
# if(!self)
# cols[c(1,3)] <- ""
# path <- system.file("appdir", package="proftoolsGUI")
#path <- "C:/Users/Big-Rod/Documents/GitHub/Rpkg-proftools-GUI/inst/appdir"
# index <- readLines(file.path(path, "www", "index.html"))
# index[288] <- paste0(' <option value="', value, '" selected>', value, '</option>')
# checked <- ifelse(c(self, gc), rep(' checked', 2), c('', ''))
# index[293:295] <- paste0(c('<input id="total" type="hidden" name="count" value="',
# '<input id="self" type="checkbox" name="self" value="1"',
# '<input id="gc" type="checkbox" name="gc" value="1" '),
# c(pd$total, checked), c('">', '> Self', '> GC'))
# write(index,file.path(path, "www", "index.html"))
winHotpaths <- winFunsum <- c(1)
attr(winHotpaths, 'env') <- attr(winFunsum, 'env') <- new.env()
attr(winHotpaths, 'env')$self.gc <- attr(winFunsum, 'env')$self.gc <- c(self, gc, memory)
attr(winHotpaths, 'env')$offspringDF <- setOffspringDF(pd, value, self, srclines=TRUE,
gc, memory, maxdepth=10)
# callSum <- callSummary(pd, byTotal = TRUE, value, srclines=TRUE, gc)
# callSum$fun <- paste(" ", callSum$fun, sep="")
callSumDF <- prepareCallSum(pd, byTotal = TRUE, value, srclines, gc, memory)
attr(winFunsum, 'env')$callSum <- fixSumDF(callSumDF, self, gc, value, memory)
fcnSummary <- prepareFcnSummary(pd, byTotal = TRUE, value, srclines, gc, memory)
attr(winFunsum, 'env')$fcnSummary <- fixSumDF(fcnSummary, self, gc, value, memory)
tempDir <- tempdir()
dir.create(file.path(tempDir, "tempDir"), showWarnings = FALSE)
shiny::addResourcePath("tempDir", file.path(tempDir, "tempDir"))
generateJSON(pd, tempDir, winHotpaths, winFunsum)
}
outputAnnot <- function(output, fcnAnnot = NULL, font.attr = NULL, where = 'end'){
## Below runs only if Shiny, since fcnAnnot (which is the annotion textbox)
## will be null in this case
if(is.null(fcnAnnot))
if(is.null(font.attr))
cat('<br />', paste(output, collapse='<br />'), sep='')
else
cat('<br />', paste('<span id="selectedLine" class="red">',
paste(output, collapse='<br />'),
'</span>',sep=''), sep='')
else
gWidgets2::insert(fcnAnnot, output, font.attr = font.attr, where = where)
}
# annotName is the name along with possible line info, fcnName strips those
functionAnnotate <- function(fcnName, annotName, path, srcAnnotate, fileName,
lineNumber, treeType, fcnAnnot, win){
## fileName used in Shiny
# fileName <<- NULL
if(is.null(srcAnnotate)) {
outputAnnot("R file could not be found in the working directory", fcnAnnot)
return()
}
fcnAnnotate <- functionAnnotation(fcnName, srcAnnotate, fileName, lineNumber,
fcnAnnot)
# Can't find function annotation or code, try the same for its first child
if(is.null(fcnAnnotate) && (length(path) > 1)){
if(treeType=="hotPaths")
siblingsDF <- offspring(path[-length(path)], win)
else siblingsDF <- offspringFunSum(path[-length(path)],win)
fcnDF <- siblingsDF[siblingsDF$Function==annotName,]
if(fcnDF$haveSons){
if(treeType=="hotPaths")
sonsDF <- offspring(path, win)
else sonsDF <- offspringFunSum(path, win)
for(i in 1:nrow(sonsDF)){
fcnInfo <- parseLineInfo(as.character(sonsDF$Function[i]),
srcAnnotate)
fcnAnnotate <- unlist(lapply(fcnInfo$fcnName, functionAnnotation,
srcAnnotate, fcnInfo$fileName,
fcnInfo$lineNumber, fcnAnnot))
if(!is.null(fcnAnnotate)){
return(invisible(TRUE))
}
}
outputAnnot("Selected Function has no available annotations", fcnAnnot)
}
else
outputAnnot("Selected Function has no available annotations", fcnAnnot)
}
}
functionAnnotation <- function(fcnName, srcAnnotate, fileName, lineNumber,
fcnAnnot){
if(length(fileName)){
# Not needed for now
# x <- srcAnnotate[[fileName]][lineNumber]
fileEnd <- length(srcAnnotate[[fileName]])
ends <- min(lineNumber+7, fileEnd)
if(lineNumber != 1)
outputAnnot(srcAnnotate[[fileName]][1:(lineNumber-1)],fcnAnnot)
outputAnnot(srcAnnotate[[fileName]][lineNumber], fcnAnnot,
font.attr=list(color="red"))
if(lineNumber != ends)
outputAnnot(srcAnnotate[[fileName]][(lineNumber+1):ends], fcnAnnot)
if(ends != fileEnd)
outputAnnot(srcAnnotate[[fileName]][(ends+1):fileEnd],
fcnAnnot=fcnAnnot, where="at.cursor")
return(TRUE)
}
else{
unlist(lapply(seq_along(srcAnnotate), findFunction, fcnName, fcnAnnot, srcAnnotate))
}
}
findFunction <- function(i, fcnName, fcnAnnot, srcAnnotate){
srcCode <- srcAnnotate[[i]]
defineFcns <- grep("function", srcCode, fixed=T)
haveFcn <- grep(paste("[[:blank:]]+",
sub(".", "\\.", fcnName, fixed=T),
"[[:blank:]]*(<-|=)[[:blank:]]*function",
sep=""), srcCode[defineFcns])
if(length(haveFcn)){
# Not needed for now
# x <- srcCode[defineFcns[haveFcn]]
lineNumber <- defineFcns[haveFcn]
fileEnd <- length(srcCode)
ends <- min(lineNumber+7, fileEnd)
if(lineNumber != 1)
outputAnnot(srcCode[1:(lineNumber-1)], fcnAnnot)
outputAnnot(srcCode[lineNumber], fcnAnnot,
font.attr=list(color="red"))
if(lineNumber != ends)
outputAnnot(srcCode[(lineNumber+1):ends], fcnAnnot)
if(ends != fileEnd)
outputAnnot(srcCode[(ends+1):fileEnd], fcnAnnot=fcnAnnot,
where="at.cursor")
## fileName used in Shiny
shinyFilename(names(srcAnnotate)[i])
return(TRUE)
}
else{
shinyFilename(NULL)
NULL
}
}
parseLineInfo <- function(fcnName, srcAnnotate){
hasLine <- regexpr("(", fcnName, fixed=T)
if(hasLine[1]>0){
lineProf <- unlist(strsplit(substr(fcnName, hasLine[1]+1,
nchar(fcnName)-1), ":", fixed=T))
fileName <- lineProf[1]
fileName <- grep(fileName, names(srcAnnotate), value=TRUE, fixed=TRUE)
lineNumber <- as.numeric(lineProf[2])
fcnName <- substr(fcnName, 1, hasLine[1]-2)
}
else{
fileName <- lineNumber <- NULL
}
list(fcnName=fcnName,lineNumber=lineNumber,fileName=fileName)
}
addHandlers <- function(tree, fcnAnnot, treeType, srcAnnotate, pd, maxnodes,
dropBelow, trimCallgraph, gg, win){
fcnNameRClick <- NULL
gWidgets2::addHandlerClicked(tree, handler=function(h,...) {
gWidgets2::visible(gg) <- TRUE
fcnAnnot <- h$action
path <- gWidgets2::svalue(h$obj, drop=FALSE)
if(length(path) == 0){
plotProfileCallGraph(pd, style = google.style)
return(FALSE)
}
annotName <- path[length(path)]
parseLine <- parseLineInfo(annotName, srcAnnotate)
fcnNameRClick <<- parseLine$fcnName
do.call(attr(win, 'env')$plotType, list())
gWidgets2::svalue(fcnAnnot) <- ''
functionAnnotate(parseLine$fcnName, annotName, path,
srcAnnotate, parseLine$fileName,
parseLine$lineNumber, treeType, fcnAnnot, win)
}, action=fcnAnnot)
gWidgets2::addHandlerClicked(gg, handler=function(h,...) {
if(attr(win, 'env')$plotType != 'plotCallgraph'){
p <- attr(win, 'env')$plotObj
idx <- which(h$x >= p$left & h$x <= p$right &
h$y >= p$bottom & h$y <= p$top)
if (length(idx) > 0)
if(attr(win, 'env')$plotType == 'plotTreemap'){
# we skip the first element because it's empty
len <- length(p$label[idx])
if(len < 12)
gWidgets2::tooltip(h$obj) <- p$label[idx][-1]
else
gWidgets2::tooltip(h$obj) <- c(p$label[idx][2:6], "...",
p$label[idx][(len-4):len])
}
else
gWidgets2::tooltip(h$obj) <- p$label[idx]
}
})
plotCallgraph <- function(h, ...){
filtered <- filterProfileData(pd, focus = fcnNameRClick)
plotProfileCallGraph(filtered, style = google.style,
maxnodes = gWidgets2::svalue(maxnodes),
total.pct = gWidgets2::svalue(dropBelow))
attr(win, 'env')$plotType <- 'plotCallgraph'
}
plotTreemap <- function(h, ...){
filtered <- filterProfileData(pd, focus = fcnNameRClick)
attr(win, 'env')$plotObj <- calleeTreeMap(filtered)
attr(win, 'env')$plotType <- 'plotTreemap'
}
plotFlamegraph <- function(h, ...){
filtered <- filterProfileData(pd, focus = fcnNameRClick)
attr(win, 'env')$plotObj <- flameGraph(filtered, order="hot")
attr(win, 'env')$plotType <- 'plotFlamegraph'
}
plotTimegraph <- function(h, ...){
filtered <- filterProfileData(pd, focus = fcnNameRClick)
attr(win, 'env')$plotObj <- flameGraph(filtered, order="time")
attr(win, 'env')$plotType <- 'plotTimegraph'
}
gWidgets2::addHandlerClicked(trimCallgraph, plotCallgraph)
ml <- list()
ml[['Plot Callgraph']] <- gWidgets2::gaction('Plot Callgraph', handler=plotCallgraph)
ml[['Plot Tree Map']] <- gWidgets2::gaction('Plot Tree Map', handler=plotTreemap)
ml[['Plot Flamegraph']] <- gWidgets2::gaction('Plot Flamegraph', handler=plotFlamegraph)
ml[['Plot Timegraph']] <- gWidgets2::gaction('Plot Timegraph', handler=plotTimegraph)
gWidgets2::addRightclickPopupMenu(tree,menulist=ml)
}
summaryHandler <- function(h, ...){
summaryView <- ifelse(gWidgets2::svalue(h$obj) == "Function", "funSum", "hotPaths")
gWidgets2::delete(h$action$win, h$action$group)
processWidget(h$action$pd, h$action$value, h$action$self, h$action$srclines,
h$action$gc,h$action$memory, h$action$maxdepth, h$action$interval, summaryView, h$action$win)
}
unitsHandler <- function(h, ...){
value <- gWidgets2::svalue(h$obj)
gWidgets2::delete(h$action$win, h$action$group)
processWidget(h$action$pd, value, h$action$self, h$action$srclines,
h$action$gc, h$action$memory, h$action$maxdepth, h$action$interval, h$action$treeType, h$action$win)
}
checkHandler <- function(h, ...){
self.gc <- c("self", "gc", "memory", "srclines") %in% gWidgets2::svalue(h$obj)
gWidgets2::delete(h$action$win, h$action$group)
processWidget(h$action$pd, h$action$value, self.gc[1], self.gc[4],
self.gc[2], self.gc[3], h$action$maxdepth, h$action$interval, h$action$treeType, h$action$win)
}
file.choose2 <- function(...) {
pathname <- NULL;
tryCatch({
pathname <- file.choose();
}, error = function(ex) {
})
pathname;
}
myShiny <- function(input, output, session) {
# shiny::observe({
# insertUI(
# selector = "#uploadHolder",
# where = "beforeBegin",
# ui = fileInput(paste0("uploadStack", input$self), "Upload Stack File", multiple = FALSE, accept = ".Rprof",
# buttonLabel = "Browse...", placeholder = "No file selected")
# )
# })
pdFun <- shiny::reactive({
if(!is.null(input$uploadStack)){
pdTemp <- readProfileData(input$uploadStack$datapath)
cat(input$uploadStack$datapath)
prepareShiny(pdTemp)
pdTemp
}
else shinyPD()
})
arg <- arg()
filtered <- shiny::reactive({
pd <- pdFun()
if(input$sliderLower != '')
filterProfileData(pd, interval = c(input$sliderLower, input$sliderUpper))
else
pd
})
shiny::observe({
pd <- pdFun()
session$sendCustomMessage(type = 'have',
message = list(haveMem = as.numeric(pd$haveMem),
haveGC = as.numeric(pd$haveGC),
self = as.numeric(arg[[1]]),
gc = as.numeric(arg[[2]]),
memory = as.numeric(arg[[3]]),
value = arg[[4]],
srclines = arg[[5]],
total = pd$total))
})
dataInput <- shiny::reactive({
filteredPD <- filtered()
winHotpaths <- winFunsum <- c(1)
if(is.null(input$ready)){
self <- arg[[1]]
gc <- arg[[2]]
memory <- arg[[3]]
value <- arg[[4]]
srclines <- arg[[5]]
}
else{
self <- input$self
gc <- input$gc
memory <- input$memory
value <- input$value
srclines <- ifelse(input$srcLines==1, TRUE, FALSE)
}
attr(winHotpaths, 'env') <- attr(winFunsum, 'env') <- new.env()
attr(winHotpaths, 'env')$self.gc <- attr(winFunsum, 'env')$self.gc <- c(self, gc, memory)
attr(winHotpaths, 'env')$offspringDF <- setOffspringDF(filteredPD, value, self, srclines=srclines, gc, memory, maxdepth=10)
callSumDF <- prepareCallSum(filteredPD, byTotal = TRUE, value, srclines=srclines, gc, memory)
attr(winFunsum, 'env')$callSum <- fixSumDF(callSumDF, self, gc, value, memory)
fcnSummary <- prepareFcnSummary(filteredPD, byTotal = TRUE, value, srclines=srclines, gc, memory)
attr(winFunsum, 'env')$fcnSummary <- fixSumDF(fcnSummary, self, gc, value, memory)
list(winHotpaths = winHotpaths, winFunsum = winFunsum)
})
srcAnnotate <- shiny::reactive({
filteredPD <- filtered()
if(nchar(input$value))
temp <- annotateSource(filteredPD, input$value, input$gc, show=FALSE)
temp
})
shiny::observe({
filteredPD <- filtered()
# path <- system.file("appdir", package="proftoolsGUI")
#path <- "C:/Users/Big-Rod/Documents/GitHub/Rpkg-proftools-GUI/inst/appdir"
wins <- dataInput()
generateJSON(filteredPD, file.path(tempdir()), wins$winHotpaths,
wins$winFunsum)
session$sendCustomMessage(type = 'updateTable',
message = list(value = input$value))
})
shiny::observe({
session$sendCustomMessage(type = 'tickBox',
message = list(self = input$self,
gc = input$gc,
memory = input$memory))
})
output$fileChoose <- shiny::renderPrint({ cat(input$uploadStack$datapath) })
session$onSessionEnded(function() {
shiny::stopApp()
})
shiny::observe({
if(input$closing == 'closing')
shiny::stopApp()
})
fName <- shiny::reactive({
if(nchar(input$fcnName))
fileName <- shinyFilename()
fileName
})
output$fcnAnnot <- shiny::renderPrint({
if(nchar(input$fcnName)){
## get srcAnnotate from reactive expression
srcAnnotate <- srcAnnotate()
path <- rev(unlist(strsplit(input$fcnName, ",", fixed = TRUE)))
parseLine <- parseLineInfo(path, srcAnnotate)
if(input$treeType == 'hotpaths')
win <- dataInput()$winHotpaths
else
win <- dataInput()$winFunsum
functionAnnotate(parseLine$fcnName, path[length(path)], path,
srcAnnotate, parseLine$fileName,
parseLine$lineNumber, "hotPaths", NULL, win)
if(!is.null(parseLine$fileName))
shinyFilename(parseLine$fileName)
cat()
session$sendCustomMessage(type = 'scrollAnnot', message = list())
}
})
output$fileName <- shiny::renderPrint({
if(nchar(input$fcnName)){
fileName <- fName()
cat(paste('File: ', fileName))
}
else
cat('File: ')
})
plotObj <- NULL
output$labelObj <- shiny::renderPrint({
if(input$plotType != 'plotCallgraph'){
p <- plotObj
idx <- which(input$plot_hover$x >= p$left & input$plot_hover$x <= p$right &
input$plot_hover$y >= p$bottom & input$plot_hover$y <= p$top)
if (length(idx) > 0)
if(input$plotType == 'plotTreemap'){
# we skip the first element because it's empty
len <- length(p$label[idx])
if(len < 12)
cat(paste(p$label[idx][-1], "<br />"))
else
cat(paste(c(p$label[idx][2:6], "...",
p$label[idx][(len-4):len]), "<br />"))
}
else
cat(p$label[idx])
}
})
output$plot <- shiny::renderPlot({
maxNodes <- as.numeric(input$maxNodes)
dropBelow <- as.numeric(input$dropBelow)
filteredPD <- filtered()
if(nchar(input$fcnName)){
## get srcAnnotate from reactive expression
srcAnnotate <- srcAnnotate()
path <- rev(unlist(strsplit(input$fcnName, ",", fixed = TRUE)))
parseLine <- parseLineInfo(path[length(path)], srcAnnotate)
filtered <- filterProfileData(filteredPD, focus = parseLine$fcnName)
if(input$plotType == 'plotCallgraph')
plotProfileCallGraph(filtered, style = google.style,
maxnodes = maxNodes,
total.pct = dropBelow)
else if(input$plotType == 'plotTreemap')
plotObj <<- calleeTreeMap(filtered)
else if(input$plotType == 'plotFlamegraph')
plotObj <<- flameGraph(filtered, order="hot")
else if(input$plotType == 'plotTimegraph')
plotObj <<- flameGraph(filtered, order="time")
}
else if(input$plotType == 'plotCallgraph')
plotProfileCallGraph(filteredPD, style = google.style,
maxnodes = maxNodes,
total.pct = dropBelow)
else if(input$plotType == 'plotTreemap')
plotObj <<- calleeTreeMap(filteredPD)
else if(input$plotType == 'plotFlamegraph')
plotObj <<- flameGraph(filteredPD, order="hot")
else if(input$plotType == 'plotTimegraph')
plotObj <<- flameGraph(filteredPD, order="time")
})
}
GUIGadget <- function(){
path <- system.file("appdir", package="proftoolsGUI")
# if(.Platform$OS.type == 'unix'){
# profDir <- '~/.rstudio-desktop/profiles-cache/'
# }
# else {
# profDir <- paste0(Sys.getenv("USERPROFILE"), '\\AppData\\Local\\RStudio-Desktop\\profiles-cache')
# }
profDir <- options("profvis.prof_output")$profvis.prof_output
stackFiles <- list.files(profDir,pattern="*.Rprof")
if(length(stackFiles) > 0){
details = file.info(paste0(profDir, .Platform$file.sep, stackFiles))
details = details[order(as.POSIXct(details$mtime), decreasing = TRUE), ]
files = rownames(details)
files <- files[1]
pd <- readProfileData(files)
}
else pd <- readProfileData(system.file("samples", "Rprof-lmfit-mem.out", package = "proftoolsGUI"))
prepareShiny(pd)
shiny::runGadget(shiny::shinyAppDir(path),
viewer = shiny::browserViewer())
}
# Always keep an empty final line or annotateSource will break
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.