[Rsiena-commits] r230 - in pkg: RSiena RSiena/R RSiena/inst/doc RSiena/man RSiena/src/model/variables RSiena/tests RSienaTest RSienaTest/R RSienaTest/doc RSienaTest/inst/doc RSienaTest/inst/scripts RSienaTest/man RSienaTest/src/model/variables RSienaTest/tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 10 18:31:09 CEST 2013
Author: tomsnijders
Date: 2013-05-10 18:31:08 +0200 (Fri, 10 May 2013)
New Revision: 230
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/NAMESPACE
pkg/RSiena/R/initializeFRAN.r
pkg/RSiena/R/printDataReport.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienaprint.r
pkg/RSiena/changeLog
pkg/RSiena/inst/doc/RSiena_Manual.pdf
pkg/RSiena/inst/doc/RSiena_Manual.tex
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/includeEffects.Rd
pkg/RSiena/src/model/variables/NetworkVariable.cpp
pkg/RSiena/tests/scriptfile.Rout.save
pkg/RSiena/tests/scriptfile.Rout.win
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/NAMESPACE
pkg/RSienaTest/R/initializeFRAN.r
pkg/RSienaTest/R/printDataReport.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaprint.r
pkg/RSienaTest/changeLog
pkg/RSienaTest/doc/
pkg/RSienaTest/doc/RSIENAspec.tex
pkg/RSienaTest/doc/RSienaDeveloper.tex
pkg/RSienaTest/doc/simstats0c.tex
pkg/RSienaTest/inst/doc/RSiena_Manual.pdf
pkg/RSienaTest/inst/doc/RSiena_Manual.tex
pkg/RSienaTest/inst/doc/effects.pdf
pkg/RSienaTest/inst/scripts/Rscript01DataFormat.R
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/includeEffects.Rd
pkg/RSienaTest/src/model/variables/NetworkVariable.cpp
pkg/RSienaTest/tests/parallel.Rout.save
pkg/RSienaTest/tests/scriptfile.Rout.win
pkg/RSienaTest/tests/scripts.Rout.save
Log:
For both RSiena and RSienaTest:
Bug in implementation of maxDegree corrected (thsnks to Nynke Niezink).
Changes to print.siena (correction & extension).
Print method for class sienaDependent added.
Further details in changelogs.
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2013-05-10 02:53:27 UTC (rev 229)
+++ pkg/RSiena/DESCRIPTION 2013-05-10 16:31:08 UTC (rev 230)
@@ -1,8 +1,8 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.1-227
-Date: 2013-04-19
+Version: 1.1-230
+Date: 2013-05-10
Author: Various
Depends: R (>= 2.15.0)
Imports: Matrix
Modified: pkg/RSiena/NAMESPACE
===================================================================
--- pkg/RSiena/NAMESPACE 2013-05-10 02:53:27 UTC (rev 229)
+++ pkg/RSiena/NAMESPACE 2013-05-10 16:31:08 UTC (rev 230)
@@ -2,19 +2,20 @@
export(coCovar, coDyadCovar, getEffects, model.create, print01Report,
siena01Gui, siena07, sienaCompositionChange, updateTheta,
sienaCompositionChangeFromFile, sienaDataCreate, sienaDataCreateFromSession,
-sienaGroupCreate, sienaModelCreate, sienaAlgorithmCreate, sienaNet,
-sienaDependent, sienaNodeSet, xtable.sienaFit,
-varCovar, varDyadCovar, setEffect, includeEffects, includeInteraction,
-effectsDocumentation, sienaDataConstraint, print.xtable.sienaFit,
-installGui, siena08, iwlsm, sienaTimeTest, includeTimeDummy,
-sienaGOF, sparseMatrixExtraction, networkExtraction, behaviorExtraction,
-OutdegreeDistribution, IndegreeDistribution, BehaviorDistribution,
-siena.table, xtable)
+sienaGroupCreate, sienaModelCreate, sienaAlgorithmCreate, sienaNet,
+ sienaDependent, sienaNodeSet, xtable.sienaFit,
+ varCovar, varDyadCovar, setEffect, includeEffects, includeInteraction,
+ effectsDocumentation, sienaDataConstraint, print.xtable.sienaFit,
+ installGui, siena08, iwlsm, sienaTimeTest, includeTimeDummy,
+ sienaGOF, sparseMatrixExtraction, networkExtraction, behaviorExtraction,
+ OutdegreeDistribution, IndegreeDistribution, BehaviorDistribution,
+ siena.table, xtable)
import(Matrix)
S3method(print, siena)
S3method(print, sienaGroup)
+S3method(print, sienaDependent)
S3method(print, sienaFit)
S3method(print, summary.sienaFit)
S3method(print, sienaAlgorithm)
Modified: pkg/RSiena/R/initializeFRAN.r
===================================================================
--- pkg/RSiena/R/initializeFRAN.r 2013-05-10 02:53:27 UTC (rev 229)
+++ pkg/RSiena/R/initializeFRAN.r 2013-05-10 16:31:08 UTC (rev 230)
@@ -96,12 +96,12 @@
}
## add any effects needed for settings model
# this now is replaced by adding the settings in getEffects,
-# which is the more logical place.
+# which is the more logical place.
# If all works, this can be deleted,
# and also the function addSettingsEffects can be deleted.
# I used this function as a template for the change to getEffects.
# I wonder why the next 8 lines cannot be dropped;
-# gives error message "cannot find setting col".
+# gives error message "cannot find setting col".
if (!is.null(x$settings))
{
effects <- addSettingsEffects(effects, x)
@@ -504,7 +504,7 @@
}
else
{
- MAXDEGREE <- as.integer(x$MaxDegree)
+ MAXDEGREE <- x$MaxDegree
storage.mode(MAXDEGREE) <- "integer"
}
if (z$cconditional)
@@ -529,7 +529,6 @@
ans <- .Call("setupModelOptions", PACKAGE=pkgname,
pData, pModel, MAXDEGREE, CONDVAR, CONDTARGET,
profileData, z$parallelTesting, x$modelType, z$simpleRates)
-
if (x$maxlike)
{
if (!initC)
Modified: pkg/RSiena/R/printDataReport.r
===================================================================
--- pkg/RSiena/R/printDataReport.r 2013-05-10 02:53:27 UTC (rev 229)
+++ pkg/RSiena/R/printDataReport.r 2013-05-10 16:31:08 UTC (rev 230)
@@ -1,6 +1,6 @@
# * SIENA: Simulation Investigation for Empirical Network Analysis
# *
-# * Web: http://www.stats.ox.ac.uk/~snidjers/siena
+# * Web: http://www.stats.ox.ac.uk/~snijders/siena
# *
# * File: printDatareport.r
# *
@@ -154,6 +154,18 @@
{
mdnet <- names(x$MaxDegree)[i]
Report(c("Dependent network variable", mdnet, ':\n'), outf)
+ maxod <- max(
+ attr(f$Data1$depvars[[match(mdnet, attr(f, "netnames"))]],
+ "maxObsOutDegree"))
+ if (maxod > x$MaxDegree[i])
+ {
+ Report(c("The algorithm object requires outdegrees not",
+ "larger than", x$MaxDegree[i], '\n',
+ "but the maximum observed outdegree is", maxod,
+ ".\n"), outf)
+ Report("This is incompatible.\n", outf)
+ stop("Incompatibility between data and MaxDegree in algorithm object.")
+ }
if (attr(f, 'symmetric')[match(mdnet, attr(f, "netnames"))])
{
Report(c("All graphs are constrained to having degrees not",
Modified: pkg/RSiena/R/sienaDataCreate.r
===================================================================
--- pkg/RSiena/R/sienaDataCreate.r 2013-05-10 02:53:27 UTC (rev 229)
+++ pkg/RSiena/R/sienaDataCreate.r 2013-05-10 16:31:08 UTC (rev 230)
@@ -14,585 +14,585 @@
##@addAttributes.coCovar DataCreate
addAttributes.coCovar <- function(x, name, ...)
{
- varmean <- mean(x, na.rm=TRUE)
- range2 <- range(x, na.rm=TRUE)
- attr(x, 'moreThan2') <- length(table(x)) > 2
- vartotal <- sum(x, na.rm=TRUE)
- nonMissingCount <- sum(!is.na(x))
- x <- x - varmean
- attr(x, 'mean') <- varmean
- rr <- rangeAndSimilarity(x, range2)
- if (rr$range[2] == rr$range[1] && !any(is.na(x)))
- attr(x, 'poszvar') <- FALSE
- else
- attr(x, 'poszvar') <- TRUE
- attr(x, 'range') <- rr$range[2] - rr$range[1]
- storage.mode(attr(x, 'range')) <- 'double'
- attr(x, 'range2') <- range2
- ## attr(x, 'simTotal') <- rr$simTotal
- attr(x, 'simMean') <- rr$simMean
- ## attr(x, 'simCnt') <- rr$simCnt
- attr(x, "name") <- name
- attr(x, "vartotal") <- vartotal
- attr(x, "nonMissingCount") <- nonMissingCount
- x
+ varmean <- mean(x, na.rm=TRUE)
+ range2 <- range(x, na.rm=TRUE)
+ attr(x, 'moreThan2') <- length(table(x)) > 2
+ vartotal <- sum(x, na.rm=TRUE)
+ nonMissingCount <- sum(!is.na(x))
+ x <- x - varmean
+ attr(x, 'mean') <- varmean
+ rr <- rangeAndSimilarity(x, range2)
+ if (rr$range[2] == rr$range[1] && !any(is.na(x)))
+ attr(x, 'poszvar') <- FALSE
+ else
+ attr(x, 'poszvar') <- TRUE
+ attr(x, 'range') <- rr$range[2] - rr$range[1]
+ storage.mode(attr(x, 'range')) <- 'double'
+ attr(x, 'range2') <- range2
+ ## attr(x, 'simTotal') <- rr$simTotal
+ attr(x, 'simMean') <- rr$simMean
+ ## attr(x, 'simCnt') <- rr$simCnt
+ attr(x, "name") <- name
+ attr(x, "vartotal") <- vartotal
+ attr(x, "nonMissingCount") <- nonMissingCount
+ x
}
##@addAttributes.varCovar DataCreate
addAttributes.varCovar <- function(x, name, ...)
{
- tmpmat <- x
- varmean <- mean(x, na.rm=TRUE)
- vartotal <- sum(x, na.rm=TRUE)
- nonMissingCount <- sum(!is.na(x))
- attr(x, "rangep") <- apply(x, 2, range, na.rm=TRUE)
- attr(x, "meanp") <- colMeans(x, na.rm=TRUE)
- cr <- range(x, na.rm=TRUE)
- attr(x, 'range') <- cr[2] - cr[1]
- storage.mode(attr(x, 'range')) <- 'double'
- attr(x, 'mean') <- varmean
- x <- x - varmean
- rr <- rangeAndSimilarity(tmpmat, cr)
- if (rr$range[2] == rr$range[1] && !any(is.na(tmpmat)))
- attr(x, 'poszvar') <- FALSE
- else
- attr(x, 'poszvar') <- TRUE
- attr(x, 'simMean') <- rr$simMean
- attr(x, 'moreThan2') <- length(unique(x)) > 2
- attr(x, 'name') <- name
- attr(x, "vartotal") <- vartotal
- attr(x, "nonMissingCount") <- nonMissingCount
- x
+ tmpmat <- x
+ varmean <- mean(x, na.rm=TRUE)
+ vartotal <- sum(x, na.rm=TRUE)
+ nonMissingCount <- sum(!is.na(x))
+ attr(x, "rangep") <- apply(x, 2, range, na.rm=TRUE)
+ attr(x, "meanp") <- colMeans(x, na.rm=TRUE)
+ cr <- range(x, na.rm=TRUE)
+ attr(x, 'range') <- cr[2] - cr[1]
+ storage.mode(attr(x, 'range')) <- 'double'
+ attr(x, 'mean') <- varmean
+ x <- x - varmean
+ rr <- rangeAndSimilarity(tmpmat, cr)
+ if (rr$range[2] == rr$range[1] && !any(is.na(tmpmat)))
+ attr(x, 'poszvar') <- FALSE
+ else
+ attr(x, 'poszvar') <- TRUE
+ attr(x, 'simMean') <- rr$simMean
+ attr(x, 'moreThan2') <- length(unique(x)) > 2
+ attr(x, 'name') <- name
+ attr(x, "vartotal") <- vartotal
+ attr(x, "nonMissingCount") <- nonMissingCount
+ x
}
##@addAttributes.coDyadCovar DataCreate
addAttributes.coDyadCovar <- function(x, name, bipartite, ...)
{
- sparse <- attr(x, "sparse")
- if (!bipartite) ## remove diagonal for calculation of mean
- {
- if (!sparse)
- {
- diag(x) <- NA
- }
- else
- {
- diag(x[[1]]) <- NA
- }
- }
- if (sparse)
- {
- nonMissingCount <- sum(!is.na(x[[1]]))
- varmean <- sum(x[[1]], na.rm=TRUE) / nonMissingCount
- ## sparse mean is incorrect
- rr <- range(x[[1]], na.rm=TRUE)
- }
- else
- {
- varmean <- mean(x, na.rm=TRUE)
- rr <- range(x, na.rm=TRUE)
- nonMissingCount <- sum(!is.na(x))
- }
- attr(x,'mean') <- varmean
- attr(x,'range') <- rr[2] - rr[1]
- storage.mode(attr(x, 'range')) <- 'double'
- attr(x,'range2') <- rr
- attr(x, 'name') <- name
- attr(x, "nonMissingCount") <- nonMissingCount
- if (!bipartite) #zero the diagonal
- {
- if (sparse)
- {
- diag(x[[1]]) <- 0
- }
- else
- {
- diag(x) <- 0
- }
- }
- x
+ sparse <- attr(x, "sparse")
+ if (!bipartite) ## remove diagonal for calculation of mean
+ {
+ if (!sparse)
+ {
+ diag(x) <- NA
+ }
+ else
+ {
+ diag(x[[1]]) <- NA
+ }
+ }
+ if (sparse)
+ {
+ nonMissingCount <- sum(!is.na(x[[1]]))
+ varmean <- sum(x[[1]], na.rm=TRUE) / nonMissingCount
+ ## sparse mean is incorrect
+ rr <- range(x[[1]], na.rm=TRUE)
+ }
+ else
+ {
+ varmean <- mean(x, na.rm=TRUE)
+ rr <- range(x, na.rm=TRUE)
+ nonMissingCount <- sum(!is.na(x))
+ }
+ attr(x,'mean') <- varmean
+ attr(x,'range') <- rr[2] - rr[1]
+ storage.mode(attr(x, 'range')) <- 'double'
+ attr(x,'range2') <- rr
+ attr(x, 'name') <- name
+ attr(x, "nonMissingCount") <- nonMissingCount
+ if (!bipartite) #zero the diagonal
+ {
+ if (sparse)
+ {
+ diag(x[[1]]) <- 0
+ }
+ else
+ {
+ diag(x) <- 0
+ }
+ }
+ x
}
##@addAttributes.varDyadCovar DataCreate
addAttributes.varDyadCovar <- function(x, name, bipartite, ...)
{
- sparse <- attr(x, "sparse")
- vardims <- attr(x, "vardims")
- if (!bipartite) ## remove the diagonal before calculating the mean
- {
- for (obs in 1:vardims[3])
- {
- if (sparse)
- {
- diag(x[[obs]]) <- NA
- }
- else
- {
- diag(x[, , obs]) <- NA
- }
- }
- }
- if (sparse)
- {
- totalValue <- 0
- totalCount <- 0
- meanp <- rep(NA, vardims[3])
- nonMissingCounts <- rep(NA, vardims[3])
- for (obs in 1:vardims[3])
- {
- totalValue <- totalValue + sum(x[[obs]], na.rm=TRUE)
- nonMissingCounts[obs] <- sum(!is.na(x[[obs]]))
- totalCount <- totalCount + nonMissingCounts[obs]
- meanp[obs] <- sum(x[[obs]], na.rm=TRUE) /
- nonMissingCounts[obs]
- }
- varmean <- totalValue / totalCount
- rr <- range(sapply(x, range, na.rm=TRUE), na.rm=TRUE)
- attr(x, "meanp") <- meanp
- }
- else
- {
- varmean <- mean(x, na.rm=TRUE)
- rr <- range(x, na.rm=TRUE)
- attr(x, "meanp") <- colMeans(x, dims=2, na.rm=TRUE)
- nonMissingCounts <- colSums(!is.na(x), dims=2)
- }
- attr(x, "mean") <- varmean
- attr(x, "range") <- rr[2] - rr[1]
- storage.mode(attr(x, "range")) <- "double"
- attr(x, "name") <- name
- attr(x, "nonMissingCount") <- nonMissingCounts
- if (!bipartite) ## put diagonal to zero
- {
- for (obs in 1:vardims[3])
- {
- if (!sparse)
- {
- diag(x[, , obs]) <- 0
- }
- else
- {
- diag(x[[obs]]) <- 0
- }
- }
- }
- x
+ sparse <- attr(x, "sparse")
+ vardims <- attr(x, "vardims")
+ if (!bipartite) ## remove the diagonal before calculating the mean
+ {
+ for (obs in 1:vardims[3])
+ {
+ if (sparse)
+ {
+ diag(x[[obs]]) <- NA
+ }
+ else
+ {
+ diag(x[, , obs]) <- NA
+ }
+ }
+ }
+ if (sparse)
+ {
+ totalValue <- 0
+ totalCount <- 0
+ meanp <- rep(NA, vardims[3])
+ nonMissingCounts <- rep(NA, vardims[3])
+ for (obs in 1:vardims[3])
+ {
+ totalValue <- totalValue + sum(x[[obs]], na.rm=TRUE)
+ nonMissingCounts[obs] <- sum(!is.na(x[[obs]]))
+ totalCount <- totalCount + nonMissingCounts[obs]
+ meanp[obs] <- sum(x[[obs]], na.rm=TRUE) /
+ nonMissingCounts[obs]
+ }
+ varmean <- totalValue / totalCount
+ rr <- range(sapply(x, range, na.rm=TRUE), na.rm=TRUE)
+ attr(x, "meanp") <- meanp
+ }
+ else
+ {
+ varmean <- mean(x, na.rm=TRUE)
+ rr <- range(x, na.rm=TRUE)
+ attr(x, "meanp") <- colMeans(x, dims=2, na.rm=TRUE)
+ nonMissingCounts <- colSums(!is.na(x), dims=2)
+ }
+ attr(x, "mean") <- varmean
+ attr(x, "range") <- rr[2] - rr[1]
+ storage.mode(attr(x, "range")) <- "double"
+ attr(x, "name") <- name
+ attr(x, "nonMissingCount") <- nonMissingCounts
+ if (!bipartite) ## put diagonal to zero
+ {
+ for (obs in 1:vardims[3])
+ {
+ if (!sparse)
+ {
+ diag(x[, , obs]) <- 0
+ }
+ else
+ {
+ diag(x[[obs]]) <- 0
+ }
+ }
+ }
+ x
}
##@sienaDataCreate DataCreate
sienaDataCreate<- function(..., nodeSets=NULL, getDocumentation=FALSE)
{
- ##@validNodeSet internal sienaDataCreate
- validNodeSet <- function(nodeSetName, n)
- {
+ ##@validNodeSet internal sienaDataCreate
+ validNodeSet <- function(nodeSetName, n)
+ {
sub <- match(nodeSetName, nodeSetNames)
if (is.na(sub))
{
stop("node set not found")
}
n == length(nodeSets[[sub]])
- }
- if (getDocumentation)
- {
- return(getInternals())
- }
- narg <- nargs()
- ## find a set of names for the objects: either the names given in the
- ## argument list or the names of the objects in the argument list
- dots <- as.list(substitute(list(...)))[-1] ##first entry is the word 'list'
- if (length(dots) == 0)
- {
- stop('need some networks')
- }
- nm <- names(dots)
- if (is.null(nm))
- {
- fixup <- seq(along=dots)
- }
- else
- {
- fixup <- nm == ''
- }
- dep <- sapply(dots[fixup], function(x) deparse(x)[1])
- if (is.null(nm))
- {
- nm <- dep
- }
- else if (length(dep) > 0)
- {
- nm[fixup] <- dep
- }
- dots <- list(...)
- names(dots) <- nm
- if (any(duplicated(nm)))
- {
- stop('names must be unique')
- }
- ## process the inputs: check dimensions,
- ## sort out missings and structural zeros and symmetric etc
- ## check sizes match the corresponding nodeSets
- observations <- 0
- depvars <- vector('list',narg)
- cCovars <- vector('list',narg)
- vCovars <- vector('list',narg)
- dycCovars <- vector('list',narg)
- dyvCovars <- vector('list',narg)
- compositionChange <- vector('list',narg)
- v1 <- 0; v2 <- 0; v3 <- 0; v4 <- 0; v5 <- 0; v6 <- 0
- for (i in seq(along = dots))
- switch(class(dots[[i]]),
- sienaDependent = {
- if (attr(dots[[i]],'sparse'))
- {
- ## require(Matrix)
- netdims <- c(dim(dots[[i]][[1]]), length(dots[[i]]))
- }
- else
- {
- netdims <- dim(dots[[i]])
- }
- if (observations == 0)
- {
- observations <- netdims[3]
- }
- else if (observations != netdims[3])
- {
- stop('differing number of observations')
- }
- v1 <- v1 + 1
- depvars[[v1]] <- dots[[i]]
- names(depvars)[v1] <- nm[i]
- },
- coCovar = {
- v2 <- v2 + 1
- cCovars[[v2]] <- dots[[i]]
- names(cCovars)[v2] <- nm[i]
- },
- varCovar = {
- v3 <- v3 + 1
- vCovars[[v3]] <- dots[[i]]
- names(vCovars)[v3] <- nm[i]
- },
- coDyadCovar = {
- v4 <- v4 + 1
- dycCovars[[v4]] <- dots[[i]]
- names(dycCovars)[v4] <- nm[i]
- },
- varDyadCovar = {
- v5 <- v5 + 1
- dyvCovars[[v5]] <- dots[[i]]
- names(dyvCovars)[v5] <- nm[i]
- },
- compositionChange = {
- v6 <- v6 + 1
- compositionChange[[v6]] <- dots[[i]]
- names(compositionChange)[v6] <- nm[i]
- },
- stop(paste("invalid object in sienaDataCreate",
- class(dots[[i]])), call.=FALSE)
- )
- if (v1 == 0)
- {
- stop("need a dependent variable")
- }
- depvars <- depvars[1:v1]
- if (is.null(nodeSets))
- {
- nodeSets <- list(sienaNodeSet(attr(depvars[[1]], "netdims")[1]))
- }
- nodeSetNames <- sapply(nodeSets,function(x) attr(x,"nodeSetName"))
- names(nodeSets) <- nodeSetNames
- if (v2 == 0)
- {
- cCovars <- list()
- }
- else
- {
- cCovars <- cCovars[1:v2]
- }
- if (v3 == 0)
- {
- vCovars <- list()
- }
- else
- {
- vCovars <- vCovars[1:v3]
- }
- if (v4 == 0)
- {
- dycCovars <- list()
- }
- else
- {
- dycCovars <- dycCovars[1:v4]
- }
- if (v5 == 0)
- {
- dyvCovars <- list()
- }
- else
- {
- dyvCovars <- dyvCovars[1:v5]
- }
- if (v6 == 0)
- {
- compositionChange <- list()
- }
- else
- {
- compositionChange <- compositionChange[1:v6]
- }
- ##now can check dimensions and find ranges
- for (i in seq(along = cCovars))
- {
- if (!validNodeSet(attr(cCovars[[i]], 'nodeSet'), length(cCovars[[i]])))
- {
- stop('constant covariate incorrect node set: ', names(cCovars)[i])
- }
- cCovars[[i]] <- addAttributes(cCovars[[i]], names(cCovars)[i])
- }
- for (i in seq(along=vCovars)) ## note that behaviour variables are not here!
- {
- if (observations < 3)
- {
- stop("Changing covariates are not possible with only two waves")
- }
- if (!validNodeSet(attr(vCovars[[i]], 'nodeSet'), nrow(vCovars[[i]])))
- stop('changing covariate incorrect size: ', names(vCovars)[i])
- if (ncol(vCovars[[i]]) < (observations - 1))
- stop('changing covariate not enough columns')
- if (ncol(vCovars[[i]]) != (observations - 1))
- {
- tmpatt <- attributes(vCovars[[i]])
- vCovars[[i]] <- vCovars[[i]][, 1:(observations - 1), drop=FALSE]
- attnames <- names(tmpatt)
- for (att in seq(along=attnames))
- {
- if (!attnames[att] %in% c('dim', 'dimnames'))
- {
- attr(vCovars[[i]], attnames[att]) <- tmpatt[[att]]
- }
- }
- }
- vCovars[[i]] <- addAttributes(vCovars[[i]], names(vCovars)[i])
- }
- for (i in seq(along=dycCovars))
- {
- nattr <- attr(dycCovars[[i]], 'nodeSet')
- bipartite <- attr(dycCovars[[i]], "type") == "bipartite"
- if (attr(dycCovars[[i]], "sparse"))
- {
- thisdycCovar <- dycCovars[[i]][[1]]
- }
- else
- {
- thisdycCovar <- dycCovars[[i]]
- }
- if (!validNodeSet(nattr[1], nrow(thisdycCovar)))
+ }
+ if (getDocumentation)
+ {
+ return(getInternals())
+ }
+ narg <- nargs()
+ ## find a set of names for the objects: either the names given in the
+ ## argument list or the names of the objects in the argument list
+ dots <- as.list(substitute(list(...)))[-1] ##first entry is the word 'list'
+ if (length(dots) == 0)
+ {
+ stop('need some networks')
+ }
+ nm <- names(dots)
+ if (is.null(nm))
+ {
+ fixup <- seq(along=dots)
+ }
+ else
+ {
+ fixup <- nm == ''
+ }
+ dep <- sapply(dots[fixup], function(x) deparse(x)[1])
+ if (is.null(nm))
+ {
+ nm <- dep
+ }
+ else if (length(dep) > 0)
+ {
+ nm[fixup] <- dep
+ }
+ dots <- list(...)
+ names(dots) <- nm
+ if (any(duplicated(nm)))
+ {
+ stop('names must be unique')
+ }
+ ## process the inputs: check dimensions,
+ ## sort out missings and structural zeros and symmetric etc
+ ## check sizes match the corresponding nodeSets
+ observations <- 0
+ depvars <- vector('list',narg)
+ cCovars <- vector('list',narg)
+ vCovars <- vector('list',narg)
+ dycCovars <- vector('list',narg)
+ dyvCovars <- vector('list',narg)
+ compositionChange <- vector('list',narg)
+ v1 <- 0; v2 <- 0; v3 <- 0; v4 <- 0; v5 <- 0; v6 <- 0
+ for (i in seq(along = dots))
+ switch(class(dots[[i]]),
+ sienaDependent = {
+ if (attr(dots[[i]],'sparse'))
+ {
+ ## require(Matrix)
+ netdims <- c(dim(dots[[i]][[1]]), length(dots[[i]]))
+ }
+ else
+ {
+ netdims <- dim(dots[[i]])
+ }
+ if (observations == 0)
+ {
+ observations <- netdims[3]
+ }
+ else if (observations != netdims[3])
+ {
+ stop('differing number of observations')
+ }
+ v1 <- v1 + 1
+ depvars[[v1]] <- dots[[i]]
+ names(depvars)[v1] <- nm[i]
+ },
+ coCovar = {
+ v2 <- v2 + 1
+ cCovars[[v2]] <- dots[[i]]
+ names(cCovars)[v2] <- nm[i]
+ },
+ varCovar = {
+ v3 <- v3 + 1
+ vCovars[[v3]] <- dots[[i]]
+ names(vCovars)[v3] <- nm[i]
+ },
+ coDyadCovar = {
+ v4 <- v4 + 1
+ dycCovars[[v4]] <- dots[[i]]
+ names(dycCovars)[v4] <- nm[i]
+ },
+ varDyadCovar = {
+ v5 <- v5 + 1
+ dyvCovars[[v5]] <- dots[[i]]
+ names(dyvCovars)[v5] <- nm[i]
+ },
+ compositionChange = {
+ v6 <- v6 + 1
+ compositionChange[[v6]] <- dots[[i]]
+ names(compositionChange)[v6] <- nm[i]
+ },
+ stop(paste("invalid object in sienaDataCreate",
+ class(dots[[i]])), call.=FALSE)
+ )
+ if (v1 == 0)
+ {
+ stop("need a dependent variable")
+ }
+ depvars <- depvars[1:v1]
+ if (is.null(nodeSets))
+ {
+ nodeSets <- list(sienaNodeSet(attr(depvars[[1]], "netdims")[1]))
+ }
+ nodeSetNames <- sapply(nodeSets,function(x) attr(x,"nodeSetName"))
+ names(nodeSets) <- nodeSetNames
+ if (v2 == 0)
+ {
+ cCovars <- list()
+ }
+ else
+ {
+ cCovars <- cCovars[1:v2]
+ }
+ if (v3 == 0)
+ {
+ vCovars <- list()
+ }
+ else
+ {
+ vCovars <- vCovars[1:v3]
+ }
+ if (v4 == 0)
+ {
+ dycCovars <- list()
+ }
+ else
+ {
+ dycCovars <- dycCovars[1:v4]
+ }
+ if (v5 == 0)
+ {
+ dyvCovars <- list()
+ }
+ else
+ {
+ dyvCovars <- dyvCovars[1:v5]
+ }
+ if (v6 == 0)
+ {
+ compositionChange <- list()
+ }
+ else
+ {
+ compositionChange <- compositionChange[1:v6]
+ }
+ ##now can check dimensions and find ranges
+ for (i in seq(along = cCovars))
+ {
+ if (!validNodeSet(attr(cCovars[[i]], 'nodeSet'), length(cCovars[[i]])))
{
- stop("dyadic covariate incorrect nbr rows", names(dycCovars)[i])
+ stop('constant covariate incorrect node set: ', names(cCovars)[i])
}
- if (!validNodeSet(nattr[2], ncol(thisdycCovar)))
+ cCovars[[i]] <- addAttributes(cCovars[[i]], names(cCovars)[i])
+ }
+ for (i in seq(along=vCovars)) ## note that behaviour variables are not here!
+ {
+ if (observations < 3)
{
- stop("dyadic covariate incorrect nbr columns",
- names(dycCovars)[i])
+ stop("Changing covariates are not possible with only two waves")
+ }
+ if (!validNodeSet(attr(vCovars[[i]], 'nodeSet'), nrow(vCovars[[i]])))
+ stop('changing covariate incorrect size: ', names(vCovars)[i])
+ if (ncol(vCovars[[i]]) < (observations - 1))
+ stop('changing covariate not enough columns')
+ if (ncol(vCovars[[i]]) != (observations - 1))
+ {
+ tmpatt <- attributes(vCovars[[i]])
+ vCovars[[i]] <- vCovars[[i]][, 1:(observations - 1), drop=FALSE]
+ attnames <- names(tmpatt)
+ for (att in seq(along=attnames))
+ {
+ if (!attnames[att] %in% c('dim', 'dimnames'))
+ {
+ attr(vCovars[[i]], attnames[att]) <- tmpatt[[att]]
+ }
+ }
+ }
+ vCovars[[i]] <- addAttributes(vCovars[[i]], names(vCovars)[i])
+ }
+ for (i in seq(along=dycCovars))
+ {
+ nattr <- attr(dycCovars[[i]], 'nodeSet')
+ bipartite <- attr(dycCovars[[i]], "type") == "bipartite"
+ if (attr(dycCovars[[i]], "sparse"))
+ {
+ thisdycCovar <- dycCovars[[i]][[1]]
+ }
+ else
+ {
+ thisdycCovar <- dycCovars[[i]]
+ }
+ if (!validNodeSet(nattr[1], nrow(thisdycCovar)))
+ {
+ stop("dyadic covariate incorrect nbr rows", names(dycCovars)[i])
+ }
+ if (!validNodeSet(nattr[2], ncol(thisdycCovar)))
+ {
+ stop("dyadic covariate incorrect nbr columns",
+ names(dycCovars)[i])
}
- dycCovars[[i]] <- addAttributes(dycCovars[[i]], names(dycCovars)[i],
- bipartite)
- }
- for (i in seq(along=dyvCovars))
- {
- if (observations < 3)
- {
- stop("Changing covariates are not possible with only two waves")
- }
- nattr <- attr(dyvCovars[[i]],'nodeSet')
- sparse <- attr(dyvCovars[[i]], "sparse")
- bipartite <- attr(dyvCovars[[i]], "type") == "bipartite"
- vardims <- attr(dyvCovars[[i]], "vardims")
- if (!validNodeSet(nattr[1], vardims[1]))
- {
- stop('dyadic changing covariate incorrect number of rows ',
- names(dyvCovars)[i])
- }
- if (!validNodeSet(nattr[2], vardims[2]))
- {
- stop('dyadic changing covariate incorrect number of columns ',
- names(dyvCovars)[i])
- }
- if (vardims[3] < (observations - 1))
- {
- stop('Dyadic changing covariate not enough observations')
- }
- if (vardims[3] != (observations - 1))
- {
- tmpatt <- attributes(dyvCovars[[i]])
- if (sparse)
- {
- dyvCovars[[i]] <- dyvCovars[[i]][1:(observations - 1)]
- }
- else
- {
- dyvCovars[[i]] <- dyvCovars[[i]][, 1:(observations - 1)]
- }
- attnames <- names(tmpatt)
- for (att in seq(along=attnames))
- {
- if (attnames[att] != "dim")
- {
- attr(dyvCovars[[i]], attnames[att]) <- tmpatt[[att]]
- }
- }
- }
- dyvCovars[[i]] <- addAttributes(dyvCovars[[i]], names(dyvCovars)[i],
- bipartite)
- }
- compnodesets <- sapply(compositionChange, function(x) attr(x, 'nodeSet'))
- if (any(duplicated(compnodesets)))
- stop('Only one composition change allowed for each nodeSet')
- for (i in seq(along = compositionChange))
- {
- thisNodeSet <- attr(compositionChange[[i]], 'nodeSet')
- nodeSetSize <- length(compositionChange[[i]])
- if (!validNodeSet(thisNodeSet, nodeSetSize))
- stop('composition change incorrect size: ',
- names(compositionChange)[i])
- if (any(sapply(compositionChange[[i]], function(x)
- any(x < 1.0 | x > observations))))
- stop("invalid times of composition change")
- if (!all(sapply(compositionChange[[i]], length) %% 2 == 0))
- stop(" Each composition change entry must have an ",
- "even number of digits")
- ## generate events and active flags
- activeStart <- matrix(FALSE, nrow=nodeSetSize, ncol=observations)
- action <- matrix(0, nrow=nodeSetSize, ncol=observations)
- events <- vector("list", nodeSetSize * 2 * observations)
- evSubs <- 1
- for (j in 1:nodeSetSize)
- {
- xsubs <- 1
- x <- compositionChange[[i]][[j]]
- repeat
- {
- ##process one interval
- ##start <- x[xsubs]
- ##end <- x[xsubs+1]
- startIndex <- ceiling(x[xsubs])
- endIndex <- trunc(x[xsubs + 1])
- # if (startIndex < observations && startIndex <= activeEndIndex)
- # {
- activeStart[j, startIndex:endIndex] <- TRUE
- # }
- if (x[xsubs] > 1.0)
- {
- period <- trunc(x[xsubs])
- evTime <- x[xsubs] - period
- events[[evSubs]] <- data.frame(event="join",
- period=period,
- actor = j, time=evTime)
- evSubs <- evSubs + 1
- }
- if (x[xsubs+1] < observations)
- {
- period <- trunc(x[xsubs+1])
- evTime <- x[xsubs+1] - period
- events[[evSubs]] <- data.frame(event="leave",
- period=period,
- actor = j, time=evTime)
- evSubs <- evSubs + 1
- }
- xsubs <- xsubs + 2
- if (xsubs > length(x))
- {
- break
- }
- }
- # cat(j, 'active',activeStart[j,], x, '\n')
- if (any(!activeStart[j, ]))
- {
- notActive <- which(!activeStart[j, ])
- for (jj in notActive)
- {
- precActive <- jj > 1 && sum(activeStart[j, 1:(jj - 1)]) > 0
- len <- length(activeStart[i,])
- succActive <- (jj < len) &&
- (sum(activeStart[j, (jj + 1):len]) > 0)
+ dycCovars[[i]] <- addAttributes(dycCovars[[i]], names(dycCovars)[i],
+ bipartite)
+ }
+ for (i in seq(along=dyvCovars))
+ {
+ if (observations < 3)
+ {
+ stop("Changing covariates are not possible with only two waves")
+ }
+ nattr <- attr(dyvCovars[[i]],'nodeSet')
+ sparse <- attr(dyvCovars[[i]], "sparse")
+ bipartite <- attr(dyvCovars[[i]], "type") == "bipartite"
+ vardims <- attr(dyvCovars[[i]], "vardims")
+ if (!validNodeSet(nattr[1], vardims[1]))
+ {
+ stop('dyadic changing covariate incorrect number of rows ',
+ names(dyvCovars)[i])
+ }
+ if (!validNodeSet(nattr[2], vardims[2]))
+ {
+ stop('dyadic changing covariate incorrect number of columns ',
+ names(dyvCovars)[i])
+ }
+ if (vardims[3] < (observations - 1))
+ {
+ stop('Dyadic changing covariate not enough observations')
+ }
+ if (vardims[3] != (observations - 1))
+ {
+ tmpatt <- attributes(dyvCovars[[i]])
+ if (sparse)
+ {
+ dyvCovars[[i]] <- dyvCovars[[i]][1:(observations - 1)]
+ }
+ else
+ {
+ dyvCovars[[i]] <- dyvCovars[[i]][, 1:(observations - 1)]
+ }
+ attnames <- names(tmpatt)
+ for (att in seq(along=attnames))
+ {
+ if (attnames[att] != "dim")
+ {
+ attr(dyvCovars[[i]], attnames[att]) <- tmpatt[[att]]
+ }
+ }
+ }
+ dyvCovars[[i]] <- addAttributes(dyvCovars[[i]], names(dyvCovars)[i],
+ bipartite)
+ }
+ compnodesets <- sapply(compositionChange, function(x) attr(x, 'nodeSet'))
+ if (any(duplicated(compnodesets)))
+ stop('Only one composition change allowed for each nodeSet')
+ for (i in seq(along = compositionChange))
+ {
+ thisNodeSet <- attr(compositionChange[[i]], 'nodeSet')
+ nodeSetSize <- length(compositionChange[[i]])
+ if (!validNodeSet(thisNodeSet, nodeSetSize))
+ stop('composition change incorrect size: ',
+ names(compositionChange)[i])
+ if (any(sapply(compositionChange[[i]], function(x)
+ any(x < 1.0 | x > observations))))
+ stop("invalid times of composition change")
+ if (!all(sapply(compositionChange[[i]], length) %% 2 == 0))
+ stop(" Each composition change entry must have an ",
+ "even number of digits")
+ ## generate events and active flags
+ activeStart <- matrix(FALSE, nrow=nodeSetSize, ncol=observations)
+ action <- matrix(0, nrow=nodeSetSize, ncol=observations)
+ events <- vector("list", nodeSetSize * 2 * observations)
+ evSubs <- 1
+ for (j in 1:nodeSetSize)
+ {
+ xsubs <- 1
+ x <- compositionChange[[i]][[j]]
+ repeat
+ {
+ ##process one interval
+ ##start <- x[xsubs]
+ ##end <- x[xsubs+1]
+ startIndex <- ceiling(x[xsubs])
+ endIndex <- trunc(x[xsubs + 1])
+ # if (startIndex < observations && startIndex <= activeEndIndex)
+ # {
+ activeStart[j, startIndex:endIndex] <- TRUE
+ # }
+ if (x[xsubs] > 1.0)
+ {
+ period <- trunc(x[xsubs])
+ evTime <- x[xsubs] - period
+ events[[evSubs]] <- data.frame(event="join",
+ period=period,
+ actor = j, time=evTime)
+ evSubs <- evSubs + 1
+ }
+ if (x[xsubs+1] < observations)
+ {
+ period <- trunc(x[xsubs+1])
+ evTime <- x[xsubs+1] - period
+ events[[evSubs]] <- data.frame(event="leave",
+ period=period,
+ actor = j, time=evTime)
+ evSubs <- evSubs + 1
+ }
+ xsubs <- xsubs + 2
+ if (xsubs > length(x))
+ {
+ break
+ }
+ }
+ # cat(j, 'active',activeStart[j,], x, '\n')
+ if (any(!activeStart[j, ]))
+ {
+ notActive <- which(!activeStart[j, ])
+ for (jj in notActive)
+ {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 230
More information about the Rsiena-commits
mailing list