[Rsiena-commits] r10 - in pkg/RSiena: . R man src src/model/effects src/model/variables
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Aug 12 20:01:21 CEST 2009
Author: ripleyrm
Date: 2009-08-12 20:01:21 +0200 (Wed, 12 Aug 2009)
New Revision: 10
Added:
pkg/RSiena/src/model/effects/FourCyclesEffect.cpp
pkg/RSiena/src/model/effects/FourCyclesEffect.h
pkg/RSiena/src/model/effects/HigherCovariateEffect.cpp
pkg/RSiena/src/model/effects/HigherCovariateEffect.h
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/R/effects.r
pkg/RSiena/R/effectsInfo.R
pkg/RSiena/R/phase1.r
pkg/RSiena/R/phase2.r
pkg/RSiena/R/phase3.r
pkg/RSiena/R/print01Report.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/simstatsc.r
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/siena07.Rd
pkg/RSiena/man/simstats0c.Rd
pkg/RSiena/src/model/effects/DensityEffect.cpp
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/variables/NetworkVariable.cpp
pkg/RSiena/src/siena07.cpp
Log:
Added clusterString parameter. Added (partial) return of simulated values. Four cycles and Higher Covariate effects (not in effect factory yet).
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/DESCRIPTION 2009-08-12 18:01:21 UTC (rev 10)
@@ -1,8 +1,8 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.4
-Date: 2009-08-02
+Version: 1.0.5
+Date: 2009-08-10
Author: Various
Depends: R (>= 2.7.0)
Imports: Matrix
@@ -14,3 +14,4 @@
LazyLoad: yes
LazyData: yes
URL: http://www.stats.ox.ac.uk/~snijders/siena
+Packaged: 2009-08-12 16:13:02 UTC; ruth
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/effects.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -36,14 +36,13 @@
rateEffects <- c(rateEffects,
paste(symmetricRateEffects[-(1:2), 1], varname))
rateFunctions <- c(rateFunctions, symmetricRateEffects[-(1:2), 2])
- rateShortNames <- symmetricRateEffects[, 3]
ratePeriods <- c(ratePeriods, rep(NA, nrow(symmetricRateEffects)-2))
rateTypes <- c(rateTypes, rep('structural',
nrow(symmetricRateEffects)-2))
objEffects <- symmetricObjEffects[, 1]
objFunctions <- symmetricObjEffects[, 2]
objEndowment <- symmetricObjEffects[, 3]
- objShortnames <- symmetricObjEffects[, 4]
+ objShortNames <- symmetricObjEffects[, 4]
objParms <- symmetricObjEffects[, 5]
objEffects <- createObjEffectList(objEffects, objFunctions,
objEndowment, objShortNames,
@@ -1032,7 +1031,7 @@
}
distance <- attr(depvar, "distance" )
if (attr(depvar,'symmetric'))
- startRate<- nactors * (0.2 + distance)/(tmp['matcnt',]+1)
+ startRate<- nactors * (0.2 + distance)/(tmp['matcnt',] %/% 2 +1)
else
startRate<- nactors * (0.2 + 2 * distance)/(tmp['matcnt',]+1)
startRate <- pmax(0.1, startRate)
@@ -1042,7 +1041,7 @@
if (attr(depvar,'symmetric'))
{
matchange <- matchange %/% 2
- matcnt <- matcnt %/% 2
+ ## matcnt <- matcnt %/% 2
}
p01 <- ifelse (matchange[1,] + matchange[2,] >=1,
matchange[2,]/(matchange[1,]+matchange[2,]),0.5)
Modified: pkg/RSiena/R/effectsInfo.R
===================================================================
--- pkg/RSiena/R/effectsInfo.R 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/effectsInfo.R 2009-08-12 18:01:21 UTC (rev 10)
@@ -25,8 +25,8 @@
"number pairs at doubly achieved distance 2", "dense triads",
"indegree - popularity", "indegree - popularity (sqrt)", "outdegree - popularity",
"outdegree - popularity (sqrt)", "indegree - activity", "indegree - activity (sqrt)",
-"outdegree - activity", "outdegree - activity (sqrt)", "1/(outdegree + 2)",
-"1/(outdegree+2)(outdegree+1+2)", "out-out degree^(1/2) assortativity",
+"outdegree - activity", "outdegree - activity (sqrt)", "1/(outdegree + #)",
+"1/(outdegree+#)(outdegree+1+#)", "out-out degree^(1/2) assortativity",
"out-in degree^(1/2) assortativity", "in-out degree^(1/2) assortativity",
"in-in degree^(1/2) assortativity"), FunctionName = c("Number of ties",
"Number of reciprocated ties", "Number of transitive triplets",
@@ -36,8 +36,8 @@
"Sum of squared indegrees", "Sum of indegrees x sqrt(indegree)",
"Sum of crossproducts indegree x outdegree", "Sum of indegrees x sqrt(outdegree)",
"Sum of crossproducts indegree x outdegree", "Sum of outdegrees x sqrt(indegree)",
-"Sum of squared outdegrees", "Sum of outdegrees^(1.5)", "Sum 1/(outdegrees + 2)",
-"Sum 1/(outdegrees + 2)(outdegrees + 1 + 2)", "Sum of out-out degree^(1/2) products",
+"Sum of squared outdegrees", "Sum of outdegrees^(1.5)", "Sum 1/(outdegrees + #)",
+"Sum 1/(outdegrees + #)(outdegrees + 1 + #)", "Sum of out-out degree^(1/2) products",
"Sum of out-in degree^(1/2) products", "Sum of in-out degree^(1/2) products",
"Sum of in-in degree^(1/2) products"), Endowment. = c(TRUE, TRUE,
TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE, TRUE,
@@ -55,18 +55,18 @@
"transitive ties", "betweenness", "balance", "number of actor pairs at distance 2",
"number pairs at doubly achieved distance 2", "degree of alter",
"sqrt degree of alter", "degree^(1.5)", "1/(degree + #)", "1/(degree+#)(degree+1+#)",
-"degree^(1/#) assortativity"), FunctionName = c("Number of edges",
+"degree^(1/2) assortativity"), FunctionName = c("Number of edges",
"Number of transitive triads", "Number of ties wth transitive closure",
"betweenness count", "Amount of balance", "Number of distances equal to 2",
"Number of doubly achieved distances 2", "Sum of squared degrees",
"Sum of degrees ", "Sum of degrees^(1.5)", "Sum 1/(degrees + #)",
-"Sum 1/(degrees + #)(degrees + 1 + #)", "Sum of degree^(1/#) products"
-), Endowment. = c("TRUE", "TRUE", "TRUE", "FALSE", "TRUE", "FALSE",
-"FALSE", "", "???? removed", "???? combined with previous", "",
-"", ""), ShortName = c("density", "transTriads", "transTies",
-"between", "balance", "nbrDist2", "nbrDist2Twice", "degAlt",
-"sqrtDegAlt", "deg1.5", "degInv", "degSqInv", "degAss"), parm = c(0,
-0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)), .Names = c("EffectName",
+"Sum 1/(degrees + #)(degrees + 1 + #)", "Sum of degree^(1/2) products"
+), Endowment. = c(TRUE, TRUE, TRUE, FALSE, TRUE, FALSE,
+FALSE, TRUE, TRUE, FALSE, FALSE,
+FALSE, TRUE), ShortName = c("density", "transTriads", "transTies",
+"between", "balance", "nbrDist2", "nbrDist2Twice", "inPop",
+"inPopSqrt", "outActSqrt", "outInv", "outSqInv", "outOutAss"), parm = c(0,
+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 <-
Modified: pkg/RSiena/R/phase1.r
===================================================================
--- pkg/RSiena/R/phase1.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/phase1.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -161,7 +161,7 @@
DisplayIteration(z)
if (int == 1)
{
- zz <- x$FRAN(zsmall, xsmall)
+ zz <- x$FRAN(zsmall, xsmall, ...)
if (!zz$OK)
{
z$OK <- zz$OK
@@ -173,7 +173,7 @@
}
else
{
- zz <- clusterCall(cl, usesim, zsmall, xsmall)
+ zz <- clusterCall(cl, usesim, zsmall, xsmall, ...)
z$n <- z$n + z$int
z$phase1Its <- z$phase1Its + int
}
@@ -482,7 +482,7 @@
if (int == 1)
{
zz <- x$FRAN(zdummy, xsmall, INIT=FALSE,
- fromFiniteDiff=TRUE)
+ fromFiniteDiff=TRUE, ...)
if (!zz$OK)
{
z$OK <- zz$OK
@@ -492,7 +492,7 @@
else
{
zz <- clusterCall(cl, x$FRAN, zdummy, xsmall,
- INIT=FALSE, fromFiniteDiff=TRUE)
+ INIT=FALSE, fromFiniteDiff=TRUE, ...)
}
if (int == 1)
{
Modified: pkg/RSiena/R/phase2.r
===================================================================
--- pkg/RSiena/R/phase2.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/phase2.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -19,34 +19,11 @@
{
FRANstore(...)
}
-phase2.1<- function(z, x, useCluster, noClusters, initC,...)
+phase2.1<- function(z, x, ...)
{
#initialise phase2
int <- 1
- # cl <- NULL
f <- FRANstore()
- # if (useCluster)
- # {
- # if (!is.null(x$simstats0c) && !x$simstats0c)
- # {
- # stop("Multiple processors only for simstats0c at present")
- # }
- # cl <- makeCluster(rep("localhost", noClusters), type = "SOCK",
- # outfile = 'cluster.out')
- # clusterSetupRNG(cl, seed = rep(1, 6))
- # clusterCall(cl, library, 'RSiena', character.only = TRUE)
- # clusterCall(cl, storeinFRANstore, f)
- # ans <- clusterCall(cl, storeinFRANstore)
- # int <- noClusters
- # if (initC)
- # {
- # ## ans <- clusterCall(cl, x$FRAN, z, x, INIT=FALSE, initC = initC)
- # ans <- clusterCall(cl, usesim, z, x,
- # INIT=FALSE, initC = initC)
- # }
- # }
- # z$cl <- cl
- # z$int <- int
z$Phase <- 2
z$writefreq <- 1
if (!is.batch())
@@ -261,7 +238,7 @@
}
if (z$int == 1)
{
- zz <- x$FRAN(zsmall, xsmall)
+ zz <- x$FRAN(zsmall, xsmall, ...)
fra <- colSums(zz$fra) - z$targets
if (!zz$OK)
{
@@ -271,7 +248,7 @@
}
else
{
- zz <- clusterCall(z$cl, usesim, zsmall, xsmall)
+ zz <- clusterCall(z$cl, usesim, zsmall, xsmall, ...)
fra <- rowMeans(sapply(zz, function(x) colSums(x$fra)- z$targets))
zz$OK <- sapply(zz, function(x) x$OK)
if (!all(zz$OK))
Modified: pkg/RSiena/R/phase3.r
===================================================================
--- pkg/RSiena/R/phase3.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/phase3.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -42,6 +42,7 @@
z$sf2 <- array(0, dim = c(z$n3, f$observations - 1, z$pp))
z$ssc <- array(0, dim = c(z$n3, f$observations - 1, z$pp))
z$sdf <- array(0, dim = c(z$n3, z$pp, z$pp))
+ z$sims <- vector("list", z$n3)
## revert to original requested method for phase 3
z$Deriv <- !x$FinDiff.method
if (x$FinDiff.method)
@@ -194,11 +195,11 @@
z
}
-doPhase3it<- function(z, x, nit, cl, int, zsmall, xsmall,...)
+doPhase3it<- function(z, x, nit, cl, int, zsmall, xsmall, ...)
{
if (int == 1)
{
- zz <- x$FRAN(zsmall, xsmall)
+ zz <- x$FRAN(zsmall, xsmall, ...)
if (!zz$OK)
{
z$OK <- zz$OK
@@ -210,7 +211,7 @@
else
{
##zz <- clusterCall(cl, simstats0c, zsmall, xsmall)
- zz <- clusterCall(cl, usesim, zsmall, xsmall)
+ zz <- clusterCall(cl, usesim, zsmall, xsmall, ...)
z$n <- z$n + z$int
# browser()
}
@@ -220,6 +221,7 @@
fra <- fra - z$targets
z$sf[nit, ] <- fra
z$sf2[nit, , ] <- zz$fra
+ z$sims[[nit]] <- zz$nets
}
else
{
@@ -229,7 +231,8 @@
fra <- fra - z$targets
z$sf[nit + (i - 1), ] <- fra
z$sf2[nit + (i - 1), , ] <- zz[[i]]$fra
- }
+ z$sims[[nit + (i - 1)]] <- zz[[i]]$nets
+ }
}
if (x$cconditional)
{
Modified: pkg/RSiena/R/print01Report.r
===================================================================
--- pkg/RSiena/R/print01Report.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/print01Report.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -656,8 +656,19 @@
modelname, ">>.\n\n"), sep="", outf)
Report(c("Date and time:", format(Sys.time(), "%d/%m/%Y %X"), "\n\n"), outf)
packageValues <- packageDescription("RSiena", fields=c("Version", "Date"))
+ rforgeRevision <- packageDescription("RSiena",
+ fields="Repository/R-Forge/Revision")
+ if (is.na(rforgeRevision))
+ {
+ revision <- ""
+ }
+ else
+ {
+ revision <- paste(" R-forge revision: ", rforgeRevision, " ", sep="")
+ }
Report(c("SIENA version ", packageValues[[1]], " (",
- format(as.Date(packageValues[[2]]), "%d %m %Y"), ")\n\n"), sep="", outf)
+ format(as.Date(packageValues[[2]]), "%d %m %Y"), ")",
+ revision, "\n\n"), sep="", outf)
if (!inherits(data, 'sienaGroup'))
{
Modified: pkg/RSiena/R/printDataReport.r
===================================================================
--- pkg/RSiena/R/printDataReport.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/printDataReport.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -85,10 +85,15 @@
}
Report('is 1.0.\n', outf)
}
- if (x$FinDiff.method)
+ if (z$FinDiff.method)
{
Report(c('Standard errors are estimated with the finite difference',
'method.\n'), outf)
+ if (!x$FinDiff.method)
+ {
+ Report("Note that the option requested has been over-ridden\n",
+ outf)
+ }
}
else
{
Modified: pkg/RSiena/R/printInitialDescription.r
===================================================================
--- pkg/RSiena/R/printInitialDescription.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/printInitialDescription.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -122,11 +122,20 @@
if (gpatts$symmetric[net])
{
tmp$tmp <- tmp$tmp %/% 2
+ matchange <- matchange %/% 2
}
for (per in 1:(atts$netdims[3] - 1))
{
ntot <- tmp$tmp["matcnt", per]
- misd <- atts$netdims[1] * (atts$netdims[1] - 1) - ntot
+ if (gpatts$symmetric[net])
+ {
+ misd <- atts$netdims[1] * (atts$netdims[1] - 1) / 2 -
+ ntot
+ }
+ else
+ {
+ misd <- atts$netdims[1] * (atts$netdims[1] - 1) - ntot
+ }
if (valmin == 0 && valmax == 1)
{
jaccard <- format(round(matchange[4, per] /
Modified: pkg/RSiena/R/robmon.r
===================================================================
--- pkg/RSiena/R/robmon.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/robmon.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -11,7 +11,7 @@
##args:x: model object - intended to be read only
## z: model fitting object
## returns updated z
-robmon <- function(z, x, useCluster, noClusters, initC, clusterString, ...)
+robmon <- function(z, x, useCluster, nbrNodes, initC, clusterString, ...)
{
z$FinDiff.method<- x$FinDiff.method
z$n <- 0
@@ -39,7 +39,7 @@
stop("Multiple processors only for simstats0c at present")
}
cl <- makeCluster(clusterString, type = "SOCK",
- outfile = 'cluster.out')
+ outfile = 'cluster.out', homogeneous=FALSE)
clusterSetupRNG(cl, seed = rep(1, 6))
clusterCall(cl, library, "RSiena", character.only = TRUE)
clusterCall(cl, storeinFRANstore, FRANstore())
@@ -49,7 +49,7 @@
INIT=FALSE, initC = initC)
}
z$cl <- cl
- z$int <- noClusters
+ z$int <- nbrNodes
}
else
{
Modified: pkg/RSiena/R/siena01.r
===================================================================
--- pkg/RSiena/R/siena01.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/siena01.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -428,11 +428,11 @@
}
if (tclvalue(clustVar) == '0')
{
- model$nbrClusters <- 1
+ model$nbrNodes <- 1
}
else
{
- model$nbrClusters <- as.numeric(tclvalue(clustspinVar))
+ model$nbrNodes <- as.numeric(tclvalue(clustspinVar))
}
model$FinDiff.method <- tclvalue(derivVar) == '0. crude Monte Carlo'
model$n3 <- as.numeric(tclvalue(ph3spinVar))
@@ -494,11 +494,11 @@
{
##create mymodel
mymodel <<- modelFromTcl()
- if (mymodel$nbrClusters > 1)
+ if (mymodel$nbrNodes > 1)
{
resp <- try(siena07(mymodel, data=mydata, effects=myeff,
useCluster=TRUE, initC=TRUE,
- noClusters=mymodel$nbrClusters),
+ nbrNodes=mymodel$nbrnodes),
silent=TRUE)
}
else
Modified: pkg/RSiena/R/siena07.r
===================================================================
--- pkg/RSiena/R/siena07.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/siena07.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -16,8 +16,8 @@
cf <- NULL
siena07<- function(x, batch = FALSE, verbose = FALSE, useCluster = FALSE,
- noClusters = 2, initC=FALSE,
- clusterString=rep("localhost", noClusters), tt=NULL,
+ nbrNodes = 2, initC=FALSE,
+ clusterString=rep("localhost", nbrNodes), tt=NULL,
parallelTesting=FALSE, ...)
{
exitfn <- function()
@@ -40,8 +40,8 @@
{
require(snow)
require(rlecuyer)
- x$firstg <- x$firstg * noClusters
- z$int <- noClusters
+ x$firstg <- x$firstg * nbrNodes
+ z$int <- nbrNodes
}
else
{
@@ -101,7 +101,7 @@
z$pb <- list(pb=NULL, pbval=0, pbmax=1)
}
- z <- robmon(z, x, useCluster, noClusters, initC, clusterString,...)
+ z <- robmon(z, x, useCluster, nbrNodes, initC, clusterString,...)
time1 <- proc.time()['elapsed']
Report(c("Total computation time", round(time1 - time0, digits=2),
@@ -120,10 +120,21 @@
Report(c("Date and time:", format(Sys.time(),"%d/%m/%Y %H:%M:%S")), outf)
Report("\nNew results follow.\n", outf)
Report("-----------------------------------\n", outf)
+ rforgeRevision <- packageDescription("RSiena",
+ fields="Repository/R-Forge/Revision")
+ if (is.na(rforgeRevision))
+ {
+ revision <- ""
+ }
+ else
+ {
+ revision <- paste(" R-forge revision: ", rforgeRevision, " ", sep="")
+ }
Report(c("\nSiena version ",
packageDescription("RSiena", fields = "Version"), " (",
format(as.Date(packageDescription("RSiena", fields = "Date")),
- "%d %b %y"), ")\n\n"), sep = '', outf )
+ "%d %b %y"), ")",
+ revision, "\n\n"), sep = '', outf )
Heading(1, outf, "Estimation by stochastic approximation algorithm.")
if (is.null(seed))
{
Modified: pkg/RSiena/R/simstatsc.r
===================================================================
--- pkg/RSiena/R/simstatsc.r 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/R/simstatsc.r 2009-08-12 18:01:21 UTC (rev 10)
@@ -10,7 +10,7 @@
# *****************************************************************************/
simstats0c <-function(z, x, INIT=FALSE, TERM=FALSE, initC=FALSE, data=NULL,
effects=NULL, fromFiniteDiff=FALSE,
- profileData=FALSE, prevAns=NULL)
+ profileData=FALSE, prevAns=NULL, returnDeps=FALSE)
{
if (INIT || initC) ## initC is to initialise multiple C processes in phase3
{
@@ -81,6 +81,19 @@
sub("^(1/2)", "", effects$effectName[assort],
fixed=TRUE))
}
+ ## and inverse out degree
+ outinv <- effects$shortName %in% c("outInv", "outSqInv")
+ if (sum(outinv) > 0)
+ {
+
+ effects$functionName[outinv] <-
+ gsub("#", effects$parm[outinv],
+ effects$functionName[outinv])
+
+ effects$effectName[outinv] <-
+ gsub("#", effects$parm[outinv],
+ effects$effectName[outinv])
+ }
## and dense triads
dense <- effects$shortName == "denseTriads"
if (sum(dense) > 0)
@@ -144,8 +157,14 @@
attr(f, "observations") <- attr(data, "observations")
attr(f, "compositionChange") <- attr(data, "compositionChange")
attr(f, "exooptions") <- attr(data, "exooptions")
- if (x$cconditional)
+ ## if any networks symmetric must use finite differences
+ syms <- attr(data,"symmetric")
+ if (any(!is.na(syms) & syms))
{
+ z$FinDiff.method <- TRUE
+ }
+ if (x$cconditional)
+ {
attr(f, "change") <-
sapply(f, function(xx)attr(xx$depvars[[z$condname]],
'distance'))
@@ -320,8 +339,7 @@
ans <- .Call('model', PACKAGE="RSiena",
z$Deriv, f$pData, f$seeds,
fromFiniteDiff, f$pModel, f$myeffects, z$theta,
- randomseed2)
- # browser()
+ randomseed2, returnDeps)
if (!fromFiniteDiff)
{
f$seeds <- ans[[3]]
@@ -338,7 +356,8 @@
fra <- t(ans[[1]])
f$randomseed2 <- ans[[5]]
FRANstore(f)
- list(sc = sc, fra = fra, ntim0 = ntim, feasible = TRUE, OK = TRUE)
+ list(sc = sc, fra = fra, ntim0 = ntim, feasible = TRUE, OK = TRUE,
+ nets=ans[[6]])
}
clearData <- function(pData)
{
Modified: pkg/RSiena/man/RSiena-package.Rd
===================================================================
--- pkg/RSiena/man/RSiena-package.Rd 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/man/RSiena-package.Rd 2009-08-12 18:01:21 UTC (rev 10)
@@ -30,8 +30,8 @@
\tabular{ll}{
Package: \tab RSiena\cr
Type: \tab Package\cr
-Version: \tab 1.0.4\cr
-Date: \tab 2009-08-02\cr
+Version: \tab 1.0.5\cr
+Date: \tab 2009-08-10\cr
License: \tab GPL-2 \cr
LazyLoad: \tab yes\cr
}
Modified: pkg/RSiena/man/siena07.Rd
===================================================================
--- pkg/RSiena/man/siena07.Rd 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/man/siena07.Rd 2009-08-12 18:01:21 UTC (rev 10)
@@ -11,7 +11,8 @@
(See examples)}
\usage{
siena07(x, batch=FALSE, verbose=FALSE, useCluster=FALSE,
-noClusters=2, initC=FALSE, tt=NULL, parallelTesting=FALSE, ...)
+nbrNodes=2, initC=FALSE, clusterString=rep("localhost", nbrNodes),
+tt=NULL, parallelTesting=FALSE, ...)
}
\arguments{
\item{x}{ A model object}
@@ -19,10 +20,13 @@
to the console}
\item{verbose}{Produces various output to the console if TRUE}
\item{useCluster}{Boolean: whether to use a cluster of processes}
- \item{noClusters}{Number of processes to use if useCluster is TRUE}
+ \item{nbrNodes}{Number of processes to use if useCluster is TRUE}
\item{initC}{Boolean: set to TRUE if the simulation will use C
routines (currently always needed). Only for use if using
- multiple processors, to ensure all copies are initialised correctly.}
+ multiple processors, to ensure all copies are initialised
+ correctly.}
+ \item{clusterString}{Definitions of clusters. Default set up to use
+ the localmachine only.}
\item{tt}{A \code{tcltk} toplevel window. Used if called from the
model options screen.}
\item{parallelTesting}{Boolean. If TRUE, sets up random numbers to
Modified: pkg/RSiena/man/simstats0c.Rd
===================================================================
--- pkg/RSiena/man/simstats0c.Rd 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/man/simstats0c.Rd 2009-08-12 18:01:21 UTC (rev 10)
@@ -7,7 +7,7 @@
\usage{
simstats0c(z, x, INIT = FALSE, TERM = FALSE, initC=FALSE,
data=NULL, effects=NULL, fromFiniteDiff=FALSE,
- profileData=FALSE, prevAns=NULL)
+ profileData=FALSE, prevAns=NULL, returnDeps=FALSE)
}
\arguments{
\item{z}{control object, passed in automatically in Siena07}
@@ -28,12 +28,17 @@
parameters which will be used as the initial values, unless the
model requests the use of standard initial values. Phase 1 will then
be omitted.}
+ \item{returnDeps}{Boolean. Whether to return the simulated networks in
+ Phase 3. Currently only returns the first network.}
}
\details{
This should be used for the element FRAN of the model object.
The arguments with no defaults must be passed in on the call to siena07.
}
-\value{Returns a list containing:
+\value{Depends on the call. If \code{INIT} or \code{initC} or
+ \code{TERM}
+ are true, returns \code{z}, the control object. Otherwise,
+ returns a list containing:
\item{fra}{Simulated statistics}
\item{sc}{Scores with which to calculate the derivative (not phase 2
or if using finite differences or maximum likelihood)}
@@ -41,6 +46,8 @@
\item{ntim}{For conditional processing, time taken}
\item{feasible}{currently set to TRUE}
\item{OK}{could be set to FALSE if serious error has occurred}
+ \item{nets}{A list of simulated networks, as a list of edgelists for
+ each period. Only if \code{returnDeps} is TRUE.}
}
\references{See \url{http://www.stats.ox.ac.uk/~snijders/siena/}}
\author{Ruth Ripley }
Modified: pkg/RSiena/src/model/effects/DensityEffect.cpp
===================================================================
--- pkg/RSiena/src/model/effects/DensityEffect.cpp 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/src/model/effects/DensityEffect.cpp 2009-08-12 18:01:21 UTC (rev 10)
@@ -1,17 +1,19 @@
/******************************************************************************
* SIENA: Simulation Investigation for Empirical Network Analysis
- *
+ *
* Web: http://www.stats.ox.ac.uk/~snijders/siena/
- *
+ *
* File: DensityEffect.cpp
- *
+ *
* Description: This file contains the implementation of the class
* DensityEffect.
*****************************************************************************/
+#include <stdexcept>
#include "DensityEffect.h"
#include "data/Network.h"
#include "model/variables/NetworkVariable.h"
+#include "data/OneModeNetworkLongitudinalData.h"
namespace siena
{
@@ -31,13 +33,14 @@
double DensityEffect::calculateTieFlipContribution(int alter) const
{
double change = 1;
-
+
if (this->pVariable()->outTieExists(alter))
{
// The ego would loose one tie
change = -1;
}
+
return change;
}
@@ -48,7 +51,18 @@
*/
double DensityEffect::evaluationStatistic(Network * pNetwork) const
{
- return pNetwork->tieCount();
+ double statistic = pNetwork->tieCount();
+ const OneModeNetworkLongitudinalData * pData =
+ dynamic_cast<const OneModeNetworkLongitudinalData *>(this->pData());
+
+ if (pData)
+ {
+ if (pData->symmetric())
+ {
+ statistic /= 2;
+ }
+ }
+ return statistic;
}
@@ -62,7 +76,18 @@
double DensityEffect::endowmentStatistic(Network * pInitialNetwork,
Network * pLostTieNetwork) const
{
- return pLostTieNetwork->tieCount();
+ double statistic = pLostTieNetwork->tieCount();
+ const OneModeNetworkLongitudinalData * pData =
+ dynamic_cast<const OneModeNetworkLongitudinalData *>(this->pData());
+
+ if (pData)
+ {
+ if (pData->symmetric())
+ {
+ statistic /= 2;
+ }
+ }
+ return statistic;
}
}
Modified: pkg/RSiena/src/model/effects/EffectFactory.cpp
===================================================================
--- pkg/RSiena/src/model/effects/EffectFactory.cpp 2009-08-06 15:21:47 UTC (rev 9)
+++ pkg/RSiena/src/model/effects/EffectFactory.cpp 2009-08-12 18:01:21 UTC (rev 10)
@@ -39,6 +39,10 @@
{
pEffect = new TransitiveTripletsEffect(pEffectInfo);
}
+ else if (effectName == "transTriads")
+ {
+ pEffect = new TransitiveTriadsEffect(pEffectInfo);
+ }
else if (effectName == "transMedTrip")
{
pEffect = new TransitiveMediatedTripletsEffect(pEffectInfo);
Added: pkg/RSiena/src/model/effects/FourCyclesEffect.cpp
===================================================================
--- pkg/RSiena/src/model/effects/FourCyclesEffect.cpp (rev 0)
+++ pkg/RSiena/src/model/effects/FourCyclesEffect.cpp 2009-08-12 18:01:21 UTC (rev 10)
@@ -0,0 +1,234 @@
+/******************************************************************************
+ * SIENA: Simulation Investigation for Empirical Network Analysis
+ *
+ * Web: http://www.stats.ox.ac.uk/~snijders/siena/
+ *
+ * File: FourCyclesEffect.cpp
+ *
+ * Description: This file contains the implementation of the
+ * FourCyclesEffect class.
+ *****************************************************************************/
+
+#include <stdexcept>
+#include "FourCyclesEffect.h"
+#include "utils/SqrtTable.h"
+#include "data/Network.h"
+#include "data/IncidentTieIterator.h"
+#include "model/EffectInfo.h"
+#include "model/variables/NetworkVariable.h"
+
+namespace siena
+{
+
+/**
+ * Constructor.
+ */
+FourCyclesEffect::FourCyclesEffect(const EffectInfo * pEffectInfo) :
+ NetworkEffect(pEffectInfo)
+{
+ this->lcounters = 0;
+
+ if (pEffectInfo->internalEffectParameter() != 1 &&
+ pEffectInfo->internalEffectParameter() != 2)
+ {
+ throw invalid_argument(
+ "FourCyclesEffect: Parameter value 1 or 2 expected");
+ }
+
+ this->lroot = pEffectInfo->internalEffectParameter() == 2;
+ this->lpSqrtTable = SqrtTable::instance();
+}
+
+
+/**
+ * Destructor.
+ */
+FourCyclesEffect::~FourCyclesEffect()
+{
+ delete[] this->lcounters;
+ this->lcounters = 0;
+}
+
+
+/**
+ * Initializes this effect for the use with the given epoch simulation.
+ */
+void FourCyclesEffect::initialize(EpochSimulation * pSimulation)
+{
+ NetworkEffect::initialize(pSimulation);
+
+ delete[] this->lcounters;
+ this->lcounters = new int[this->pVariable()->m()];
+}
+
+
+/**
+ * Initializes this effect for calculating the corresponding statistics.
+ * @param[in] pData the observed data
+ * @param[in] pState the current state of the dependent variables
+ * @param[in] period the period of interest
+ */
+void FourCyclesEffect::initialize(const Data * pData,
+ State * pState,
+ int period)
+{
+ NetworkEffect::initialize(pData, pState, period);
+}
+
+
+/**
+ * Does the necessary preprocessing work for calculating the tie flip
+ * contributions for a specific ego. This method must be invoked before
+ * calling NetworkEffect::calculateTieFlipContribution(...).
+ */
+void FourCyclesEffect::preprocessEgo()
+{
+ int ego = this->pVariable()->ego();
+ Network * pNetwork = this->pVariable()->pNetwork();
+
+ // Count the number of three paths i -> h <- k -> j from i to each j
+ this->countThreePaths(ego, pNetwork, this->lcounters);
+
+ if (this->lroot)
+ {
+ // Count the number of 4-cycles the ego i is currently involved in.
+ // This count is required for the sqrt case only.
+
+ this->lcurrentCycleCount = 0;
+
+ for (IncidentTieIterator iter = pNetwork->outTies(ego);
+ iter.valid();
+ iter.next())
+ {
+ int j = iter.actor();
+ this->lcurrentCycleCount += this->lcounters[j];
+ }
+
+ // The above loop counted each 4-cycle twice
+ this->lcurrentCycleCount /= 2;
+ }
+}
+
+
+/**
+ * For each j and the given i, this method calculates the number of three-paths
+ * i -> h <- k -> j.
+ */
+void FourCyclesEffect::countThreePaths(int i,
+ Network * pNetwork,
+ int * counters) const
+{
+ int m = pNetwork->m();
+
+ // Initialize
+
+ for (int j = 0; j < m; j++)
+ {
+ counters[j] = 0;
+ }
+
+ // Enumerate all three-paths i -> h <- k -> j and update the counters.
+ // The (average) time complexity is obviously O(d^3), where d is the
+ // average degree.
+
+ for (IncidentTieIterator iterI = pNetwork->outTies(i);
+ iterI.valid();
+ iterI.next())
+ {
+ int h = iterI.actor();
+
+ for (IncidentTieIterator iterH = pNetwork->inTies(h);
+ iterH.valid();
+ iterH.next())
+ {
+ int k = iterH.actor();
+
+ if (i != k)
+ {
+ for (IncidentTieIterator iterK = pNetwork->outTies(k);
+ iterK.valid();
+ iterK.next())
+ {
+ int j = iterK.actor();
+
+ if (j != h)
+ {
+ counters[j]++;
+ }
+ }
+ }
+ }
+ }
+}
+
+
+/**
+ * Calculates the contribution of a tie flip to the given actor.
+ */
+double FourCyclesEffect::calculateTieFlipContribution(int alter) const
+{
+ double change;
+
+ if (this->lroot)
+ {
+ int newCycleCount = this->lcurrentCycleCount;
+
+ if (this->pVariable()->outTieExists(alter))
+ {
+ newCycleCount -= this->lcounters[alter];
+ }
+ else
+ {
+ newCycleCount += this->lcounters[alter];
+ }
+
+ change = this->lpSqrtTable->sqrt(newCycleCount) -
+ this->lpSqrtTable->sqrt(this->lcurrentCycleCount);
+ }
+ else
+ {
+ change = this->lcounters[alter];
+
+ if (this->pVariable()->outTieExists(alter))
+ {
+ change = -change;
+ }
+ }
+
+ return change;
+}
+
+
+/**
+ * Detailed comment in the base class.
+ */
+double FourCyclesEffect::statistic(Network * pNetwork,
+ Network * pSummationTieNetwork) const
+{
+ double statistic = 0;
+ int n = pNetwork->n();
+ int m = pNetwork->m();
+ int * counters = new int[m];
+
+ for (int i = 0; i < n; i++)
+ {
+ // Count the number of three paths i -> h <- k -> j from i to each j
+ this->countThreePaths(i, pNetwork, counters);
+
+ for (IncidentTieIterator iter = pSummationTieNetwork->outTies(i);
+ iter.valid();
+ iter.next())
+ {
+ statistic += counters[iter.actor()];
+ }
+ }
+
+ delete[] counters;
+
+ // In case of the evaluation statistic, we counted each 4-cycle four times.
+ // TODO: Is it okay to divide by 4 for endowment statistic as well?
+
+ return statistic * 0.25;
+}
+
+}
Added: pkg/RSiena/src/model/effects/FourCyclesEffect.h
===================================================================
--- pkg/RSiena/src/model/effects/FourCyclesEffect.h (rev 0)
+++ pkg/RSiena/src/model/effects/FourCyclesEffect.h 2009-08-12 18:01:21 UTC (rev 10)
@@ -0,0 +1,72 @@
+/******************************************************************************
+ * SIENA: Simulation Investigation for Empirical Network Analysis
+ *
+ * Web: http://www.stats.ox.ac.uk/~snijders/siena/
+ *
+ * File: FourCyclesEffect.h
+ *
+ * Description: This file contains the definition of the
+ * FourCyclesEffect class.
+ *****************************************************************************/
+
+#ifndef FOURCYCLESEFFECT_H_
+#define FOURCYCLESEFFECT_H_
+
+#include "NetworkEffect.h"
+
+namespace siena
+{
+
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 10
More information about the Rsiena-commits
mailing list