Nothing
#/******************************************************************************
# * SIENA: Simulation Investigation for Empirical Network Analysis
# *
# * Web: https://www.stats.ox.ac.uk/~snijders/siena
# *
# * File: RSienaRDocumentation.r
# *
# * Description: This module contains the code for documenting the
# * RSiena R source.
# *****************************************************************************/
##
##@getInternals Documentation
getInternals <- function()
{
fnlist <- utils::read.csv("RSienafnlist.csv", as.is=TRUE)
mylist <- ls(parent.frame())
## print(mylist)
## require(codetools)
## fnlist has a row number at the front: column 3 contains the function names
mylist <- mylist[mylist %in% fnlist[, 3]]
mytt <- lapply(mylist, function(x)
{
x <- get(x, envir=parent.frame(3))
if (is.function(x))
{
tt <- codetools::findGlobals(x, merge=FALSE)[[1]]
tt2 <- codetools::findLocals(body(x))
tt <- c(tt, tt2)
tt[tt %in% fnlist[, 3]]
}
else
{
NULL
}
}
)
names(mytt) <- mylist
mytt
}
##@getRSienaDocumentation Documentation
getRSienaRDocumentation <- function(Rdir)
{
## require(xtable)
## require(codetools)
thisdir <- getwd()
## temporarily move directory
on.exit(setwd(thisdir))
setwd(Rdir)
## extract comment lines
if (.Platform$OS.type == "windows")
{
shell('grep "##@" *.r *.R > comments.lis')
}
else
{
system('grep "##@" *.r *.R > comments.lis')
}
## read them in
comms <- readLines('comments.lis')
## remove the file
file.remove("comments.lis")
## remove the shell line
comms <- comms[!grepl("comments.lis", comms)]
## get rid of tabs
comms <- gsub("\t", "", comms)
## split off
mystr <- paste("##", "@", sep="")
comms1 <- strsplit(comms, mystr)
## join up rest
## comms2 <- do.call(rbind, comms1)
## turn into dataframe
comms3 <- sapply(comms1, function(x)
{
tmp <- strsplit(x[2], " ")[[1]]
if (tmp[2] == "internal")
{
c(x[1], tmp[1], tmp[2], paste('internal to', tmp[3],
collapse=" "))
}
else
{
c(x[1], tmp[1], tmp[2], paste(tmp[-c(1, 2)],
collapse=" "))
}
}
)
comms3 <- t(comms3)
## get the calls (global)
codet <- lapply(comms3[,2], function(x)
{
x <- try(getFromNamespace(x, pkgname), silent=TRUE)
if (is.function(x))
{
tmp1 <- codetools::findGlobals(x, merge=FALSE)[[1]]
tmp2 <- codetools::findLocals(body(x))
tmp <- c(tmp1, tmp2)
}
else
tmp <- NULL
unique(as.vector(tmp[tmp %in% comms3[,2]]))
}
)
names(codet) <- comms3[, 2]
## now the internal ones
## find the list of files from comms3
# browser()
internals <- comms3[grepl("internal to", comms3[, 4]), ]
ttmp <- unique(comms3[grepl("internal to", comms3[, 4]), 4])
ttmp1 <- sub("internal to ", "", ttmp)
ttmp3 <- lapply(ttmp1, function(x)
{
tmp <- x
while(!is.na(sub <- match(tmp[1], internals[, 2])))
{
tmp1 <- internals[sub, 4]
tmp1 <- sub("internal to ", "", tmp1)
tmp <- c(tmp1, tmp)
}
tmp
})
#ttmp2 <- comms3[match(ttmp1, comms3[, 2]), 1]
#ttmp2 <- sub(":", "", ttmp2)
## write out the fnlist in the Rdir
write.csv(data.frame(comms3), "RSienafnlist.csv")
## get the list of internals
tt <- lapply(ttmp3, function(x)
{
yy <- getFromNamespace(x[1], pkgname)
targs <- formals(yy)
targs[1:length(targs)] <- 1
if (length(x) > 1)
{
targs['getDocumentation'] <- x[-1]
}
else
{
targs['getDocumentation'] <- TRUE
}
do.call(yy, targs)
})
#tt <- lapply(1:length(ttmp3), function(x, y)
# {
# yy <- y[x]
# yy <- getFromNamespace(yy, pkgname)
# targs <- formals(yy)
# n <- length(targs)
# myargs <- targs
# for (i in 1:n)
# {
# myargs[[i]] <- 1#
#}
#myargs['getDocumentation'] <- TRUE
#do.call(yy, myargs)
#}, y=ttmp)
names(tt) <- ttmp
## remove the file
file.remove("RSienafnlist.csv")
## reformat this
ttt <- lapply(1:length(tt), function(x,y)
{
yy <- y[[x]]
n <- length(y[[x]])
bb <- names(yy)
t1<- lapply(1:n, function(x, b, a)
{
y <- a[[x]]
bb <- b[[x]]
n <- length(y)
if ( n > 0)
cbind( rep(bb, n), y)
else
c( bb, " ")
}, a=yy, b=bb)
do.call(rbind,t1)
}, y=tt
)
tttt <- as.data.frame(do.call(rbind,ttt))
names(tttt) <- c('Function', 'Calls')
## create an object that will tabify to the right output
tmp2 <- codet
tmp4 <- lapply(1 : length(tmp2), function(x, y, z, a)
{
n <- length(y[[x]])
if (n > 0)
{
cbind( rep(a[x, 1], n), rep(z[x], n), y[[x]],
rep(a[x, 3], n), rep(a[x, 4], n))
}
else
{
cbind(a[x, 1], z[x], " ", a[x, 3], a[x, 4])
}
}, y=tmp2, z=names(tmp2), a=comms3)
tmp5 <- do.call(rbind, tmp4)
tmp5 <- as.data.frame(tmp5, stringsAsFactors=FALSE)
names(tmp5) <- c('Source File', 'Function', 'Calls', 'Type', 'Notes')
## now merge in the internals
tmp5bit <- tmp5[tmp5$Function %in%tttt$Function,]
tmerge <- merge(tmp5bit, tttt, by="Function")
tmerge <- tmerge[, -3]
tmerge <- tmerge[, c(2, 1, 5, 3, 4)]
names(tmerge)[3] <- "Calls"
tmp5new <- rbind(tmp5[!tmp5$Function %in% tttt$Function,], tmerge)
tmp55 <- split(tmp5new, tmp5new$Function)
## same for called by
tmp6 <- lapply(1 : length(tmp2), function(x, y, z)
{
n <- length(y[[x]])
if (n > 0)
{
cbind( rep(z[x], n), y[[x]] )
}
else
{
cbind(z[x], " ")
}
}, y=tmp2, z=names(tmp2))
tmp7 <- do.call(rbind, tmp6)
tmp7 <- as.data.frame(tmp7, stringsAsFactors=FALSE)
names(tmp7) <- c( 'Called from', 'Function')
tmp7 <- tmp7[order(tmp7[,2],tmp7[,1]), ]
tttt7 <- tttt
names(tttt7) <- c("Called from", "Function")
tttt7 <- tttt7[order(tttt7[,2],tttt7[,1]), ]
## tmp7bit <- tmp7[tmp7$Function %in% tttt7$Function, ]
tmp7new <- merge(tmp7, tttt7, by=c("Function", "Called from"), all=TRUE)
tmp7new <- tmp7new[order(tmp7new[,1], tmp7new[,2]),]
tmp77new <- split(tmp7new, tmp7new$Function)
tmp77new <- tmp77new[-1]
## create desired output format
tmp11 <- lapply(1:length(names(tmp55)), function(x,y,z)
{
thisone <- names(tmp55)[x]
yy <- y[[thisone]]
zz <- z[[thisone]]
d <- max(nrow(yy), nrow(zz))
fn <- yy$Function[1]
src<- yy$`Source File`[1]
type<- yy$Type[1]
notes<- yy$Notes[1]
if (!is.null(zz))
{
called <- c(zz[,2], rep(' ', d-nrow(zz)))
}
else
{
called <- rep(' ', d)
}
tmp <- data.frame(src=rep(src,d),
fun=rep(fn, d),
type=rep(type, d),
notes=rep(notes, d),
calls=c(yy[,3], rep(' ', d-nrow(yy))),
called=called, stringsAsFactors=FALSE)
tmp
}, y=tmp55, z=tmp77new)
## join into a data frame
tmp12 <- do.call(rbind, tmp11)
names(tmp12)[2] <- "Function"
tmp12 <- tmp12[order(tmp12[, "type"], as.numeric(row.names(tmp12))), ]
tmp12 <- tmp12[, c(3, 2, 5, 6, 4, 1)]
ff <- xtable::xtable(tmp12)
## go back to start directory
setwd(thisdir)
print(ff, tabular.environment="longtable",
file="RSienaRDocumentation.tex", floating=FALSE)
write.csv(tmp12, "RSienaRDocumentation.csv")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.