[Rsiena-commits] r13 - in pkg/RSiena: . R inst/doc man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 23 01:35:10 CEST 2009
Author: ripleyrm
Date: 2009-09-23 01:35:09 +0200 (Wed, 23 Sep 2009)
New Revision: 13
Added:
pkg/RSiena/R/RSienaRDocumentation.r
pkg/RSiena/R/globals.r
pkg/RSiena/R/siena07gui.r
pkg/RSiena/R/sienaModelCreate.r
pkg/RSiena/man/sienaModelCreate.Rd
Removed:
pkg/RSiena/R/interrupt.r
pkg/RSiena/man/model.create.Rd
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/NAMESPACE
pkg/RSiena/R/Sienatest.r
pkg/RSiena/R/effects.r
pkg/RSiena/R/effectsInfo.R
pkg/RSiena/R/getTargets.r
pkg/RSiena/R/phase1.r
pkg/RSiena/R/phase2.r
pkg/RSiena/R/phase3.r
pkg/RSiena/R/print01Report.r
pkg/RSiena/R/print07Report.r
pkg/RSiena/R/printDataReport.r
pkg/RSiena/R/printInitialDescription.r
pkg/RSiena/R/robmon.r
pkg/RSiena/R/siena01.r
pkg/RSiena/R/siena07.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienaDataCreateFromSession.r
pkg/RSiena/R/sienaprint.r
pkg/RSiena/R/sienautils.r
pkg/RSiena/R/simstatsc.r
pkg/RSiena/R/zzz.R
pkg/RSiena/inst/doc/s_man400.pdf
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/getEffects.Rd
pkg/RSiena/man/print01Report.Rd
pkg/RSiena/man/siena01Gui.Rd
pkg/RSiena/man/siena07.Rd
pkg/RSiena/man/sienaDataCreate.Rd
pkg/RSiena/man/sienaDataCreateFromSession.Rd
pkg/RSiena/man/sienaGroupCreate.Rd
pkg/RSiena/man/simstats0c.Rd
Log:
Changes for documentation, reports, manuals.A few fixes
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/DESCRIPTION 2009-09-22 23:35:09 UTC (rev 13)
@@ -6,7 +6,7 @@
Author: Various
Depends: R (>= 2.7.0)
Imports: Matrix
-Suggests: tcltk, snow, rlecuyer, network
+Suggests: tcltk, snow, rlecuyer, network, codetools, xtable
SystemRequirements: GNU make, tcl/tk 8.5, Tktable
Maintainer: <ruth at stats.ox.ac.uk>
Description: Fits models to longitudinal networks
@@ -14,4 +14,4 @@
LazyLoad: yes
LazyData: yes
URL: http://www.stats.ox.ac.uk/~snijders/siena
-Packaged: 2009-08-12 16:13:02 UTC; ruth
+Packaged: 2009-09-22 21:01:10 UTC; ruth
Modified: pkg/RSiena/NAMESPACE
===================================================================
--- pkg/RSiena/NAMESPACE 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/NAMESPACE 2009-09-22 23:35:09 UTC (rev 13)
@@ -2,7 +2,7 @@
export(coCovar, coDyadCovar, getEffects, model.create, print01Report,
siena01Gui, siena07, sienaCompositionChange,
sienaCompositionChangeFromFile, sienaDataCreate, sienaDataCreateFromSession,
-sienaGroupCreate, sienaNet, sienaNodeSet, simstats0c, varCovar, varDyadCovar,
+sienaGroupCreate, sienaModelCreate, sienaNet, sienaNodeSet, simstats0c, varCovar, varDyadCovar,
installGui)
import(Matrix)
Added: pkg/RSiena/R/RSienaRDocumentation.r
===================================================================
--- pkg/RSiena/R/RSienaRDocumentation.r (rev 0)
+++ pkg/RSiena/R/RSienaRDocumentation.r 2009-09-22 23:35:09 UTC (rev 13)
@@ -0,0 +1,253 @@
+#/******************************************************************************
+# * SIENA: Simulation Investigation for Empirical Network Analysis
+# *
+# * Web: http://www.stats.ox.ac.uk/~snidjers/siena
+# *
+# * File: RSienaRDocumentation.r
+# *
+# * Description: This module contains the code for documenting the
+# * RSiena R source.
+# *****************************************************************************/
+##
+##@getInternals Documentation
+getInternals <- function()
+{
+ fnlist <- read.csv("RSienafnlist.csv", as.is=TRUE)
+ mylist <- ls(parent.frame())
+ ## print(mylist)
+ library(codetools)
+ mylist <- mylist[mylist %in% fnlist[, 3]]
+ mytt <- lapply(mylist, function(x)
+ {
+ x <- get(x, envir=parent.frame(3))
+ if (is.function(x))
+ {
+ tt <- findGlobals(x, merge=FALSE)[[1]]
+ tt2 <- findLocals(body(x))
+ tt <- c(tt, tt2)
+ tt[tt %in% fnlist[, 3]]
+ }
+ else
+ {
+ NULL
+ }
+ }
+ )
+ names(mytt) <- mylist
+ mytt
+}
+##@getRSienaDocumentation Documentation
+getRSienaRDocumentation <- function(Rdir)
+{
+ library(xtable)
+ library(codetools)
+
+ thisdir <- getwd()
+ ## temporarily move directory
+ setwd(Rdir)
+
+ ## extract comment lines
+ shell('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)]
+ ## 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, "RSiena"), silent=TRUE)
+ if (is.function(x))
+ {
+ tmp1 <- findGlobals(x, merge=FALSE)[[1]]
+ tmp2 <- 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
+ ttmp <- unique(comms3[grepl("internal to", comms3[, 4]), 4])
+ ttmp <- sub("internal to ", "", ttmp)
+ ttmp2 <- comms3[match(ttmp, 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(1:length(ttmp), function(x, y, z)
+ {
+ yy <- y[x]
+ zz <- z[[x]]
+ yy <- getFromNamespace(yy, "RSiena")
+ 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, z=ttmp2)
+ 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:length(yy), 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)
+ t2 <- 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"], row.names(tmp12)), ]
+ tmp12 <- tmp12[, c(3, 2, 5, 6, 4, 1)]
+ ff <- xtable(tmp12)
+ ## go back to start directory
+ setwd(thisdir)
+ print(ff, tabular.environment="longtable",
+ file="RSienaRDocumentation.tex", floating=FALSE)
+
+ write.csv(tmp12, "RSienaRDocumentation.csv")
+}
Modified: pkg/RSiena/R/Sienatest.r
===================================================================
--- pkg/RSiena/R/Sienatest.r 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/R/Sienatest.r 2009-09-22 23:35:09 UTC (rev 13)
@@ -1,3 +1,15 @@
+#/******************************************************************************
+# * SIENA: Simulation Investigation for Empirical Network Analysis
+# *
+# * Web: http://www.stats.ox.ac.uk/~snidjers/siena
+# *
+# * File: Sienatest.r
+# *
+# * Description: This module contains the function for instability analysis and
+# * score tests.
+# *
+# *****************************************************************************/
+##@InstabilityAnalysis siena07 Not currently used
InstabilityAnalysis<- function(z)
{
##I think this is not correct, because of scaling. cond number of var matrix of X
@@ -47,13 +59,14 @@
Report(c('\n\n',date(),'\n'),sep='',lf)
}
+##@MatrixNorm siena07 Not currently used. May be incorrect.
MatrixNorm<- function(mat)
{
tmp<- apply(mat,2,function(x)x/sqrt(crossprod(x)))
##or sweep(mat,2,apply(mat,2,function(x)x/sqrt(crossprod(x))
tmp
}
-
+##@TestOutput siena07 Print report
TestOutput <- function(z,x)
{
testn<- sum(z$test)
@@ -127,6 +140,7 @@
Report('\n',outf)
}
}
+##@ScoreTest siena07 Do score tests
ScoreTest<- function(z,x)
{
z$testresult<- rep(NA,z$pp) ##for chisq per parameter
@@ -164,6 +178,7 @@
z$oneStep<- -dinv2%*%z$fra
z
}
+##@EvaluateTestStatistic siena07 Calculate score test statistics
EvaluateTestStatistic<- function(x,test,dfra,msf,fra)
{
##uses local arrays set up in the calling procedure
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/R/effects.r 2009-09-22 23:35:09 UTC (rev 13)
@@ -8,8 +8,10 @@
# * Description: This module contains the code for the creation of the
# * effects object to go with a Siena data object or group object.
# *****************************************************************************/
-getEffects<- function(x, nintn = 10)
+##@getEffects DataCreate
+getEffects<- function(x, nintn = 10, getDocumentation=FALSE)
{
+ ##@oneModeNet internal getEffects
oneModeNet <- function(depvar, varname)
{
nodeSet <- attr(depvar, 'nodeSet')
@@ -281,6 +283,7 @@
starts=starts)
}
+ ##@behaviornet internal getEffects
behaviorNet <- function(depvar, varname)
{
nodeSet <- attr(depvar,'nodeSet')
@@ -426,6 +429,7 @@
objEffects = objEffects), starts=starts)
}
+ ##@dyadNetObjEff internal getEffects
dyadNetObjEff<- function(covarname, symmetric)
{
if (symmetric)
@@ -451,6 +455,7 @@
varname, varname2=covarname)
list(objEff=objEff)
}
+ ##@covSymmNetEff internal getEffects
covSymmNetEff<- function(covarname, poszvar, moreThan2)
{
covEffects <- paste(covarname,covarSymmetricObjEffects[, 1])
@@ -484,6 +489,7 @@
rateTypes, varname, varname2=covarname)
list(objEff=objEff, rateEff=rateEff)
}
+ ##@covNonSymmNetEff internal getEffects
covNonSymmNetEff<- function(covarname, poszvar, moreThan2)
{
covEffects<- paste(covarname, covarNonSymmetricObjEffects[, 1])
@@ -535,6 +541,7 @@
rateTypes, varname, varname2=covarname)
list(objEff=objEff, rateEff=rateEff)
}
+ ##@covBehEff internal getEffects
covBehEff<- function(varname, covarname, nodeSet, same=FALSE,
## same indicates that varname and covarname are the same:
## just one rate effect required
@@ -595,6 +602,7 @@
rateTypes, varname, varname2=covarname)
list(objEff=objEff, rateEff=rateEff)
}
+ ##@netBehEff internal getEffects
netBehEff<- function(varname, netname)
{
netObjEffects <- paste('behavior', varname,
@@ -619,6 +627,7 @@
varname2=netname)
list(objEff=objEff, rateEff=rateEff)
}
+ ##@createObjEffectList internal getEffects
createObjEffectList<- function(effectnames, functionnames, endowment,
shortnames, parms, varname, varname2="",
varname3=NULL)
@@ -659,6 +668,7 @@
tmp$statisticFn <- statisticFn
tmp
}
+ ##@createRateEffectList internal getEffects
createRateEffectList<- function(effectnames, functionnames, shortnames,
ratePeriods, rateTypes,
varname, varname2="")
@@ -689,7 +699,12 @@
tmp$statisticFn <- statisticFn
tmp
}
-#### start of function createEffects
+ ## start of function getEffects
+ if (getDocumentation)
+ {
+ tt <- getInternals()
+ return(tt)
+ }
if (!inherits(x, 'sienaGroup') && !inherits(x, 'siena'))
{
stop('Not a valid siena data object or group')
@@ -702,7 +717,7 @@
{
groupx <- FALSE
}
-### validate the object?
+ ## validate the object?
## find the total number of periods to be processed = local var observations
## then process the first or only data object. Fill in starting values
## for other periods from the other objects, if any.
@@ -769,7 +784,7 @@
effects[[i]]$effectName <- as.character(effects[[i]]$effectName)
attr(effects[[i]], 'starts') <- tmp$starts
},
- bipartite = {},
+ bipartite = {stop("not yet implemented")},
stop('error type'))
effects[[i]]$groupName <- groupNames[1]
effects[[i]]$group <- 1
@@ -904,12 +919,12 @@
attr(effects, "starts") <- NULL
cl <- class(effects)
if (groupx)
- class(effects) <- c('groupEffects','effects', cl)
+ class(effects) <- c('sienaGroupEffects','sienaEffects', cl)
else
- class(effects) <- c('effects', cl)
+ class(effects) <- c('sienaEffects', cl)
effects
}
-
+##@getBehaviorStartingVals DataCreate
getBehaviorStartingVals <- function(depvar)
{
drange <- attr(depvar, 'range')
@@ -966,6 +981,7 @@
ifelse (tendency > 3, 3, tendency))
list(startRate=startRate, tendency=tendency, untrimmed = untrimmed, dif=dif)
}
+##@getNetworkStartingVals DataCreate
getNetworkStartingVals <- function(depvar, structValid=TRUE)
{
noPeriods <- attr(depvar, "netdims")[3] - 1
Modified: pkg/RSiena/R/effectsInfo.R
===================================================================
--- pkg/RSiena/R/effectsInfo.R 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/R/effectsInfo.R 2009-09-22 23:35:09 UTC (rev 13)
@@ -1,3 +1,4 @@
+##@symmetricRateEffects Object/Effects Defined in effectsInfo.R
symmetricRateEffects <-
structure(list(EffectName = c("basic rate parameter", "constant rate (period ",
"degree effect on rate", "indegree effect on rate", "reciprocity effect on rate",
@@ -8,6 +9,7 @@
"degreeRate", "indegRate", "recipRate", "degRateInv")), .Names = c("EffectName",
"FunctionName", "ShortName"), class = "data.frame", row.names = c(NA,
-6L))
+##@nonsymmetricRateEffects Objects/Effects Defined in effectsInfo.R
nonSymmetricRateEffects <-
structure(list(EffectName = c("basic rate parameter", "constant rate (period ",
"outdegree effect on rate", "indegree effect on rate", "reciprocity effect on rate",
@@ -18,6 +20,7 @@
"outRate", "inRate", "recipRate", "outRateInv")), .Names = c("EffectName",
"FunctionName", "ShortName"), class = "data.frame", row.names = c(NA,
-6L))
+##@nonsymmetricObjEffects Objects/Effects Defined in effectsInfo.R
nonSymmetricObjEffects <-
structure(list(EffectName = c("outdegree (density)", "reciprocity",
"transitive triplets", "transitive mediated triplets", "3-cycles",
@@ -50,6 +53,7 @@
), parm = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 0, 0, 0, 0, 0,
0, 0, 1, 1, 2, 2, 2, 2)), .Names = c("EffectName", "FunctionName",
"Endowment.", "ShortName", "parm"), row.names = c(NA, -25L), class = "data.frame")
+##@symmetricObjEffects Objects/Effects Defined in effectsInfo.R
symmetricObjEffects <-
structure(list(EffectName = c("degree (density)", "transitive triads",
"transitive ties", "betweenness", "balance", "number of actor pairs at distance 2",
@@ -69,6 +73,7 @@
0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2)), .Names = c("EffectName",
"FunctionName", "Endowment.", "ShortName", "parm"), row.names = c(NA,
13L), class = "data.frame")
+##@behaviorObjEffects Objects/Effects Defined in effectsInfo.R
behaviorObjEffects <-
structure(list(EffectName = c("linear shape", "quadratic shape",
"average similarity", "total similarity", "indegree", "outdegree",
@@ -95,6 +100,7 @@
"behDenseTriads", "simDenseTriads", "recipDeg", "avSimPopEgo")), .Names = c("EffectName",
"Function.Name", "Endowment.", "ShortName"), class = "data.frame", row.names = c(NA,
-19L))
+##@behaviorRateEffects Objects/Effects Defined in effectsInfo.R
behaviorRateEffects <-
structure(list(EffectName = c("rate (period ", "outdegree effect on rate",
"indegree effect on rate", "reciprocated effect on rate"), FunctionName = c("Amount of behavioral change on",
@@ -102,20 +108,25 @@
"outRate", "inRate", "recipRate")), .Names = c("EffectName",
"FunctionName", "ShortName"), class = "data.frame", row.names = c(NA,
-4L))
+##@covarBehObjEffects Objects/Effects Defined in effectsInfo.R
covarBehObjEffects <-
structure(c("effect from", "influence interaction? x", "x", "influ. int. possible x",
"effFrom", "inflIntX"), .Dim = 2:3)
+##@covarBehObjInteractions Objects/Effects Defined in effectsInfo.R
covarBehObjInteractions <-
structure(c("av.sim. x ", "tot. sim. x ", "av. alters x ", "avSimX",
"totSimX", "avAltX"), .Dim = c(3L, 2L))
+##@dyadObjEffects Objects/Effects Defined in effectsInfo.R
dyadObjEffects <-
structure(c("WW=>X closure of", "WX=>X closure of", "XW=>X closure of",
"WWX", "WXX", "XWX"), .Dim = c(3L, 2L))
+##@covarNonSymmetricObjEffects Objects/Effects Defined in effectsInfo.R
covarNonSymmetricObjEffects <-
structure(c("alter", "squared alter", "ego", "similarity", "similarity x reciprocity",
"Sum of indegrees x", "Sum of indegrees x squared", "Sum of outdegrees x",
"Similarity on", "Similarity x reciprocity on", "altX", "altSqX",
"egoX", "simX", "simRecipX"), .Dim = c(5L, 3L))
+##@covarSymmetricObjEffects Objects/Effects Defined in effectsInfo.R
covarSymmetricObjEffects <-
structure(c("", "squared", "similarity", "X", "sqX", "simX"), .Dim = c(3L,
2L))
Modified: pkg/RSiena/R/getTargets.r
===================================================================
--- pkg/RSiena/R/getTargets.r 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/R/getTargets.r 2009-09-22 23:35:09 UTC (rev 13)
@@ -1,3 +1,4 @@
+##@getTargets Miscellaneous Written for Krista. Use as RSiena:::getTargets
getTargets <- function(data, effects)
{
f <- unpackData(data)
Added: pkg/RSiena/R/globals.r
===================================================================
--- pkg/RSiena/R/globals.r (rev 0)
+++ pkg/RSiena/R/globals.r 2009-09-22 23:35:09 UTC (rev 13)
@@ -0,0 +1,163 @@
+##/*****************************************************************************
+## * SIENA: Simulation Investigation for Empirical Network Analysis
+## *
+## * Web: http://www.stats.ox.ac.uk/~snidjers/siena
+## *
+## * File: globals.r
+## *
+## * Description: This file contains the code to create and use global objects
+## *
+## ****************************************************************************/
+##@outf Objects/File project .out file
+outf <- NULL
+##@lf Objects/File suppressed or to console
+lf <- NULL
+##@bof Objects/File suppressed or to console
+bof <- NULL
+##@cf Objects/File suppressed or to console
+cf <- NULL
+
+##@Reportfun Reporting Part of global mechanism
+Reportfun<- function(x, verbose = FALSE)
+{
+ x <- x
+ beverbose <- verbose
+ function(txt, dest, fill=FALSE, sep=" ", hdest,
+ open=FALSE, close=FALSE,
+ type=c("a", "w"), projname="Siena" , verbose=FALSE)
+ {
+ if (open)
+ {
+ type <- match.arg(type)
+ beverbose <<- verbose
+ if (type =='w')
+ {
+ x$outf <<- file(paste(projname, ".out", sep=""), open="w")
+ }
+ else
+ {
+ x$outf <<- file(paste(projname, ".out", sep=""), open="a")
+ }
+
+ }
+ else if (close)
+ {
+ close(x[["outf"]])
+ }
+ else
+ {
+ if (missing(dest) && missing(hdest))
+ {
+ cat(txt, fill = fill, sep = sep)
+ }
+ else
+ {
+ if (missing(dest))
+ {
+ if (hdest %in% c("cf", "lf", "bof"))
+ {
+ if (beverbose)
+ {
+ cat(txt, fill=fill, sep=sep)
+ }
+ }
+ else
+ {
+ cat(txt, file = x[[hdest]], fill = fill, sep = sep)
+ }
+ }
+ else
+ {
+ if (deparse(substitute(dest)) %in% c("cf", "lf", "bof"))
+ {
+ if (beverbose)
+ {
+ cat(txt, fill=fill, sep=sep)
+ }
+ }
+ else
+ {
+ cat(txt, file=x[[deparse(substitute(dest))]],
+ fill=fill, sep=sep)
+ }
+ }
+ }
+ }
+ }
+}
+
+##@Report Globals
+Report <- local({verbose <- NULL;
+ Reportfun(list(outf=outf, lf=lf, cf=cf, bof=bof), verbose)})
+##@UserInterrupt Siena07/GlobalFunctions Global (within siena07)
+UserInterrupt <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;A}})
+##@EarlyEndPhase2 siena07/GlobalFunctions
+EarlyEndPhase2 <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;A}})
+##@UserRestart siena07/GlobalFunctions Global (within siena07)
+UserRestart <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;A}})
+##@UserInterruptFlag siena07/GlobalFunctions Global (within siena07)
+UserInterruptFlag <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;A}})
+##@EarlyEndPhase2Flag siena07/GlobalFunctions Global (within siena07)
+EarlyEndPhase2Flag <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;A}})
+##@UserRestartFlag siena07/GlobalFunctions Global (within siena07)
+UserRestartFlag <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;A}})
+##@is.batch siena07/GlobalFunctions Global (within siena07)
+is.batch <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;A}})
+##@DONE siena01/GlobalFunctions Used to communicate with siena.exe and sienaScript
+DONE <- local({A <- FALSE;function(x){if (!missing(x))A<<-x;invisible(A)}})
+##@FRANstore siena07/GlobalFunctions Used to pass data to other processes
+FRANstore <- local({A <- NULL;function(x){if (!missing(x)) A<<-x;A}})
+
+##@Heading Reporting Global function
+Heading<- function(level=1, dest, text, fill=FALSE)
+{
+ ch <- c("=", "-", " ")[level]
+ if (missing(dest))
+ {
+ Report(c("@", level, "\n", text, "\n"), sep="", fill=fill)
+ Report(rep(ch, sum(nchar(text)) + 3), sep="", fill=fill)
+ Report("\n\n")
+ }
+ else
+ {
+ dest <- deparse(substitute(dest))
+ Report(c("@", level, "\n", text, "\n"), hdest=dest, sep="", fill=fill)
+ Report(rep(ch, sum(nchar(text))), hdest=dest, sep="", fill=fill)
+ if (level < 3)
+ Report("\n\n", hdest = dest)
+ else
+ Report("\n", hdest = dest)
+ }
+}
+
+##@PrtOutMat Reporting
+PrtOutMat<- function(mat, dest)
+{
+ if (missing(dest))
+ Report(format(t(mat)), sep=c(rep.int(" ", ncol(mat) - 1), "\n"))
+ else
+ {
+ Report(format(t(mat)), sep=c(rep.int(" ", ncol(mat) - 1), "\n"),
+ hdest=deparse(substitute(dest)))
+ Report("\n", hdest=deparse(substitute(dest)))
+ }
+}
+##@NullChecks siena07/GlobalFunctions Resets global flags
+NullChecks <- function()
+{
+ UserInterrupt(FALSE)
+ EarlyEndPhase2(FALSE)
+ UserRestart(FALSE)
+ UserInterruptFlag(FALSE)
+ EarlyEndPhase2Flag(FALSE)
+ UserRestartFlag(FALSE)
+}
+
+##@CheckBreaks siena07/GlobalFunctions Reads global flags
+
+CheckBreaks <- function()
+{
+ UserInterruptFlag(UserInterrupt())
+ EarlyEndPhase2Flag(EarlyEndPhase2())
+ UserRestartFlag(UserRestart())
+}
Deleted: pkg/RSiena/R/interrupt.r
===================================================================
--- pkg/RSiena/R/interrupt.r 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/R/interrupt.r 2009-09-22 23:35:09 UTC (rev 13)
@@ -1,96 +0,0 @@
-#/******************************************************************************
-# * SIENA: Simulation Investigation for Empirical Network Analysis
-# *
-# * Web: http://www.stats.ox.ac.uk/~snidjers/siena
-# *
-# * File: interrupt.r
-# *
-# * Description: This module contains the code controlling the gui for siena07.
-# *
-# *****************************************************************************/
-runtk<- function(tt)
-{
- myInterrupt<- function()
- {
- UserInterrupt(TRUE)
- }
- myEndPhase2<- function()
- {
- EarlyEndPhase2(TRUE)
- }
- myRestart<- function()
- {
- UserRestart(TRUE)
- }
- if (is.null(tt))
- {
- library(tcltk)
- tt <- tktoplevel()
- }
- tkwm.title(tt,'Siena07')
- frame <- tkframe(tt, width=300, height=300, relief='ridge')
- tkpack(frame, side='top', padx=5)
- button1 <- tkbutton(frame, command=myInterrupt, text='Interrupt')
- button2 <- tkbutton(frame, command=myEndPhase2, text='End Phase2',
- state='disabled')
- button3 <- tkbutton(frame, command=myRestart, text='Restart')
- tkgrid.configure(button1, column=1, columnspan=2, row=1, padx=20, pady=20)
- tkgrid.configure(button2, column=3, row=1, padx=20)
- tkgrid.configure(button3, column=4, row=1, padx=20)
- phaselabel <- tklabel(frame, text='Phase')
- subphaselabel <- tklabel(frame, text='Subphase', state='disabled')
- iterationlabel <- tklabel(frame, text='Iteration')
- label1 <- tklabel(frame, text='ProgressBar')
-
- phase <- tkentry(frame, width=2)
-
- subphase <- tkentry(frame, width=2, state='disabled')
- iteration <- tkentry(frame, width=6)
- progressbar <- ttkprogressbar(frame, max=2000, length=120)
-
- tkgrid.configure(phaselabel, column=1, row=2, pady=5)
- tkgrid.configure(subphaselabel, column=2, row=2)
- tkgrid.configure(iterationlabel, column=3, row=2)
- tkgrid.configure(label1, column=4, row=2, padx=5)
- tkgrid.configure(phase, column=1, row=3, pady=3)
- tkgrid.configure(subphase, column=2, row=3, padx=10)
- tkgrid.configure(iteration, column=3, row=3, padx=10)
-
- tkgrid.configure(progressbar, column=4, padx=5, row=3)
- label2 <- tklabel(frame, text='Current parameter values')
- label3 <- tklabel(frame, text='Quasi-autocorrelations')
- label4 <- tklabel(frame, text='Deviation values')
-
- tkgrid.configure(label2, column=1, columnspan=2, row=4, padx=10)
- tkgrid.configure(label3, column=3, row=4, padx=10)
- tkgrid.configure(label4, column=4, row=4, padx=10)
-
- text1 <- tktext(frame, height=6, width=14)
-
- text2 <- tktext(frame, height=6, width=14)
- text3 <- tktext(frame, height=6, width=14)
- tkgrid.configure(text1, column=1, columnspan=2, row=5, padx=20, pady=5)
-
- tkgrid.configure(text2, column=3, row=5, padx=20)
- tkgrid.configure(text3, column=4, row=5, padx=20)
- ilcampo <- tclVar()
- tcl("image", "create", "photo", ilcampo, file=imagepath)
- frame2 <- tkframe(tt, width=300, height=300, relief='ridge')
- tkpack(frame2, side='bottom', padx=5)
- imgAsLabel <- tklabel(frame2, image=ilcampo)
- tkgrid.configure(imgAsLabel, pady=10)
- tkinsert(phase, 0, ' 1')
- tkgrab.set(tt)
- tcl('update')
- # browser()
- tkfocus(tt)
- # cat('here\n')
- list(tt=tt, pb=progressbar, earlyEndPhase2=button2, current=text1,
- quasi=text2, deviations=text3, phase=phase, subphase=subphase,
- iteration=iteration, subphaselabel=subphaselabel)
-}
-
-
-#tkconfigure(button2,state='normal')
-
-
Modified: pkg/RSiena/R/phase1.r
===================================================================
--- pkg/RSiena/R/phase1.r 2009-09-13 16:33:09 UTC (rev 12)
+++ pkg/RSiena/R/phase1.r 2009-09-22 23:35:09 UTC (rev 13)
@@ -1,7 +1,7 @@
-##/******************************************************************************
+##/*****************************************************************************
## * SIENA: Simulation Investigation for Empirical Network Analysis
## *
-## * Web: http://stat.gamma.rug.nl/siena.html
+## * Web: http://www.stats.ox.ac.uk/~snidjers/siena
## *
## * File: phase1.r
## *
@@ -11,9 +11,10 @@
## * restart. Phase 1.2 does the rest of the iterations and then calculates
## * the derivative estimate. doPhase1it does one iteration, is called by
## * phase1.1 and phase1.2.
-## *****************************************************************************/
+## ****************************************************************************/
##args: x model object (readonly), z control object
##
+##@phase1.1 siena07 Do first 10 iterations (before check if using finite differences)
phase1.1 <- function(z, x, ...)
{
## initialise phase 1
@@ -156,6 +157,7 @@
z
}
+##@doPhase1it siena07 does 1 iteration in Phase 1
doPhase1it<- function(z, x, cl, int, zsmall, xsmall, ...)
{
DisplayIteration(z)
@@ -183,6 +185,7 @@
fra <- fra - z$targets
z$sf[z$nit, ] <- fra
z$sf2[z$nit, , ] <- zz$fra
+ z$sims[[z$nit]] <- zz$nets
}
else
{
@@ -192,6 +195,7 @@
fra <- fra - z$targets
z$sf[z$nit + (i - 1), ] <- fra
z$sf2[z$nit + (i - 1), , ] <- zz[[i]]$fra
+ z$sims[[z$nit + (i - 1)]] <- zz[[i]]$nets
}
}
@@ -254,6 +258,7 @@
#browser()
z
}
+##@phase1.2 siena07 Do rest of phase 1 iterations
phase1.2 <- function(z, x, ...)
{
##finish phase 1 iterations and do end-of-phase processing
@@ -381,6 +386,7 @@
z
}
+##@CalculateDerivative siena07 Calculates derivative in Phase 1
CalculateDerivative <- function(z, x)
{
f <- FRANstore()
@@ -465,12 +471,13 @@
z
}
+##@FiniteDifferences siena07 Does the extra iterations for finite differences
FiniteDifferences <- function(z, x, fra, cl, int=1, ...)
{
fras <- array(0, dim = c(int, z$pp, z$pp))
xsmall<- NULL
xsmall$cconditional <- x$cconditional
- # browser()
+ ##browser()
for (i in 1 : z$pp)
{
zdummy <- z[c('theta', 'Deriv')]
Modified: pkg/RSiena/R/phase2.r
===================================================================
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 13
More information about the Rsiena-commits
mailing list