[Rsiena-commits] r194 - in pkg: RSiena RSiena/R RSiena/inst/doc RSiena/inst/scripts RSiena/man RSiena/src/data RSiena/src/model/filters RSiena/src/model/ml RSiena/src/model/variables RSiena/src/network RSienaTest RSienaTest/R RSienaTest/doc RSienaTest/inst/doc RSienaTest/man RSienaTest/src/data RSienaTest/src/model/filters RSienaTest/src/model/ml RSienaTest/src/model/variables RSienaTest/src/network
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jan 17 23:08:37 CET 2012
Author: ripleyrm
Date: 2012-01-17 23:08:36 +0100 (Tue, 17 Jan 2012)
New Revision: 194
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/R/effects.r
pkg/RSiena/R/globals.r
pkg/RSiena/R/initializeFRAN.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienautils.r
pkg/RSiena/changeLog
pkg/RSiena/inst/doc/RSiena_Manual.pdf
pkg/RSiena/inst/scripts/RSienaSNADescriptives.R
pkg/RSiena/inst/scripts/Rscript01DataFormat.R
pkg/RSiena/inst/scripts/Rscript02SienaVariableFormat.R
pkg/RSiena/inst/scripts/Rscript03SienaRunModel.R
pkg/RSiena/inst/scripts/Rscript04SienaBehaviour.R
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/coDyadCovar.Rd
pkg/RSiena/man/varDyadCovar.Rd
pkg/RSiena/src/data/Data.cpp
pkg/RSiena/src/data/NetworkLongitudinalData.cpp
pkg/RSiena/src/data/NetworkLongitudinalData.h
pkg/RSiena/src/data/OneModeNetworkLongitudinalData.cpp
pkg/RSiena/src/model/filters/LowerFilter.cpp
pkg/RSiena/src/model/ml/NetworkChange.cpp
pkg/RSiena/src/model/variables/NetworkVariable.cpp
pkg/RSiena/src/model/variables/NetworkVariable.h
pkg/RSiena/src/network/Network.h
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/globals.r
pkg/RSienaTest/R/initializeFRAN.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienautils.r
pkg/RSienaTest/changeLog
pkg/RSienaTest/doc/RSIENAspec.tex
pkg/RSienaTest/doc/RSiena_Manual.tex
pkg/RSienaTest/inst/doc/RSiena_Manual.pdf
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/coDyadCovar.Rd
pkg/RSienaTest/man/varDyadCovar.Rd
pkg/RSienaTest/src/data/Data.cpp
pkg/RSienaTest/src/data/NetworkLongitudinalData.cpp
pkg/RSienaTest/src/data/NetworkLongitudinalData.h
pkg/RSienaTest/src/data/OneModeNetworkLongitudinalData.cpp
pkg/RSienaTest/src/model/filters/LowerFilter.cpp
pkg/RSienaTest/src/model/ml/NetworkChange.cpp
pkg/RSienaTest/src/model/variables/NetworkVariable.cpp
pkg/RSienaTest/src/model/variables/NetworkVariable.h
pkg/RSienaTest/src/network/Network.h
Log:
Make validation of bipartite networks consistent. minor fixes to prtOutMat and initializeFRAN. Copy over updated scripts from RSienaTest.
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2012-01-17 15:36:52 UTC (rev 193)
+++ pkg/RSiena/DESCRIPTION 2012-01-17 22:08:36 UTC (rev 194)
@@ -1,7 +1,7 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.12.192
+Version: 1.0.12.194
Date: 2012-01-17
Author: Various
Depends: R (>= 2.10.0)
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2012-01-17 15:36:52 UTC (rev 193)
+++ pkg/RSiena/R/effects.r 2012-01-17 22:08:36 UTC (rev 194)
@@ -147,7 +147,8 @@
}
for (j in seq(along = xx$dycCovars))
{
- if (attr(xx$dycCovars[[j]], 'nodeSet')[1] == nodeSet)
+ if (attr(xx$dycCovars[[j]], "type") == "oneMode" &&
+ attr(xx$dycCovars[[j]], 'nodeSet')[1] == nodeSet)
{
objEffects <- rbind(objEffects,
createEffects("dyadObjective",
@@ -160,7 +161,8 @@
}
for (j in seq(along = xx$dyvCovars))
{
- if (attr(xx$dyvCovars[[j]], 'nodeSet')[1] == nodeSet)
+ if (attr(xx$dyvCovars[[j]], "type") == "oneMode" &&
+ attr(xx$dyvCovars[[j]], 'nodeSet')[1] == nodeSet)
{
objEffects <- rbind(objEffects,
createEffects("dyadObjective",
@@ -265,7 +267,8 @@
objEffects <-
rbind(objEffects,
covarNetNetEff(otherName, names(xx$cCovars)[k],
- attr(xx$cCovars[[k]], 'poszvar'),
+ attr(xx$cCovars[[k]],
+ 'poszvar'),
name=varname))
}
}
@@ -276,7 +279,8 @@
objEffects <-
rbind(objEffects,
covarNetNetEff(otherName, names(xx$vCovars)[k],
- attr(xx$vCovars[[k]], 'poszvar'),
+ attr(xx$vCovars[[k]],
+ 'poszvar'),
name=varname))
}
}
@@ -533,7 +537,8 @@
for (j in seq(along = xx$dycCovars))
{
- if (all(nodeSets == attr(xx$dycCovars[[j]], 'nodeSet')))
+ if (attr(xx$dycCovars[[j]], "type") == "bipartite" &&
+ all(nodeSets == attr(xx$dycCovars[[j]], 'nodeSet')))
{
objEffects <- rbind(objEffects,
createEffects("dyadBipartiteObjective",
@@ -545,7 +550,8 @@
}
for (j in seq(along = xx$dyvCovars))
{
- if (all(nodeSets == attr(xx$dyvCovars[[j]], 'nodeSet')))
+ if (attr(xx$dyvCovars[[j]], "type") == "bipartite" &&
+ all(nodeSets == attr(xx$dyvCovars[[j]], 'nodeSet')))
{
objEffects <- rbind(objEffects,
createEffects("dyadBipartiteObjective",
Modified: pkg/RSiena/R/globals.r
===================================================================
--- pkg/RSiena/R/globals.r 2012-01-17 15:36:52 UTC (rev 193)
+++ pkg/RSiena/R/globals.r 2012-01-17 22:08:36 UTC (rev 194)
@@ -167,6 +167,10 @@
##@PrtOutMat Reporting
PrtOutMat<- function(mat, dest)
{
+ if (is.null(mat))
+ {
+ return()
+ }
testing <- Sys.getenv("RSIENATESTING")
testing <- testing != ""
if (missing(dest))
Modified: pkg/RSiena/R/initializeFRAN.r
===================================================================
--- pkg/RSiena/R/initializeFRAN.r 2012-01-17 15:36:52 UTC (rev 193)
+++ pkg/RSiena/R/initializeFRAN.r 2012-01-17 22:08:36 UTC (rev 194)
@@ -31,9 +31,9 @@
}
if (!initC) ## ie first time round
{
- if (!inherits(data,'siena'))
+ if (!inherits(data,"siena"))
{
- stop('not valid siena data object')
+ stop("not valid siena data object")
}
## check the effects object
defaultEffects <- getEffects(data)
@@ -59,22 +59,22 @@
stop("invalid effect requested: see above ")
}
}
- if (!inherits(effects, 'data.frame'))
+ if (!inherits(effects, "data.frame"))
{
- stop('effects is not a data.frame')
+ stop("effects is not a data.frame")
}
if (x$useStdInits)
{
if (any(effects$effectName != defaultEffects$effectName))
{
- stop('Cannot use standard initialisation with a ',
- 'different effect list')
+ stop("Cannot use standard initialisation with a ",
+ "different effect list")
}
effects$initialValue <- defaultEffects$initialValue
}
## get data object into group format to save coping with two
## different formats
- if (inherits(data, 'sienaGroup'))
+ if (inherits(data, "sienaGroup"))
{
nGroup <- length(data)
}
@@ -148,7 +148,7 @@
x$condvarno <- 1
}
}
- types <- sapply(data[[1]]$depvars, function(x) attr(x, 'type'))
+ types <- sapply(data[[1]]$depvars, function(x) attr(x, "type"))
## now check if conditional estimation is OK and copy to z if so
z$cconditional <- FALSE
if (x$cconditional)
@@ -253,7 +253,7 @@
{
attr(f, "change") <-
sapply(f, function(xx)attr(xx$depvars[[z$condname]],
- 'distance'))
+ "distance"))
attr(f,"condEffects") <- requestedEffects[z$condvar,]
effcondvar <-
(1:nrow(effects))[effects$name==
@@ -290,24 +290,24 @@
nGroup <- f$nGroup
f[(nGroup + 1): length(f)] <- NULL
}
- pData <- .Call('setupData', PACKAGE=pkgname,
+ pData <- .Call("setupData", PACKAGE=pkgname,
lapply(f, function(x)(as.integer(x$observations))),
lapply(f, function(x)(x$nodeSets)))
- ans <- .Call('OneMode', PACKAGE=pkgname,
+ ans <- .Call("OneMode", PACKAGE=pkgname,
pData, lapply(f, function(x)x$nets))
- ans <- .Call('Bipartite', PACKAGE=pkgname,
+ ans <- .Call("Bipartite", PACKAGE=pkgname,
pData, lapply(f, function(x)x$bipartites))
- ans <- .Call('Behavior', PACKAGE=pkgname,
+ ans <- .Call("Behavior", PACKAGE=pkgname,
pData, lapply(f, function(x)x$behavs))
- ans <-.Call('ConstantCovariates', PACKAGE=pkgname,
+ ans <-.Call("ConstantCovariates", PACKAGE=pkgname,
pData, lapply(f, function(x)x$cCovars))
- ans <-.Call('ChangingCovariates', PACKAGE=pkgname,
+ ans <-.Call("ChangingCovariates", PACKAGE=pkgname,
pData, lapply(f, function(x)x$vCovars))
- ans <-.Call('DyadicCovariates', PACKAGE=pkgname,
+ ans <-.Call("DyadicCovariates", PACKAGE=pkgname,
pData, lapply(f, function(x)x$dycCovars))
- ans <-.Call('ChangingDyadicCovariates', PACKAGE=pkgname,
+ ans <-.Call("ChangingDyadicCovariates", PACKAGE=pkgname,
pData, lapply(f, function(x)x$dyvCovars))
- ans <-.Call('ExogEvent', PACKAGE=pkgname,
+ ans <-.Call("ExogEvent", PACKAGE=pkgname,
pData, lapply(f, function(x)x$exog))
## split the names of the constraints
higher <- attr(f, "allHigher")
@@ -327,9 +327,9 @@
if (!initC)
{
- storage.mode(effects$parm) <- 'integer'
- storage.mode(effects$group) <- 'integer'
- storage.mode(effects$period) <- 'integer'
+ storage.mode(effects$parm) <- "integer"
+ storage.mode(effects$group) <- "integer"
+ storage.mode(effects$period) <- "integer"
effects$effectPtr <- rep(NA, nrow(effects))
splitFactor <- factor(effects$name, levels=attr(f, "netnames"))
if (!all(attr(f,"netnames") %in% effects$name))
@@ -379,7 +379,7 @@
interactionEffectsl <- ff$interactionEffectsl
types <- ff$types
}
- ans <- .Call('effects', PACKAGE=pkgname, pData, basicEffects)
+ ans <- .Call("effects", PACKAGE=pkgname, pData, basicEffects)
pModel <- ans[[1]][[1]]
for (i in seq(along=(ans[[2]]))) ## ans[[2]] is a list of lists of
## pointers to effects. Each list corresponds to one
@@ -397,7 +397,7 @@
basicEffects[[i]]$effectPtr[match(interactionEffects[[i]]$effect3,
basicEffects[[i]]$effectNumber)]
}
- ans <- .Call('interactionEffects', PACKAGE=pkgname,
+ ans <- .Call("interactionEffects", PACKAGE=pkgname,
pData, pModel, interactionEffects)
## copy these pointers to the interaction effects and then insert in
## effects object in the same rows for later use
@@ -426,7 +426,7 @@
{
ans <- .Call("getTargets", PACKAGE=pkgname, pData, pModel, myeffects,
z$parallelTesting)
- ##stop('done')
+ ##stop("done")
## create a grid of periods with group names in case want to
## parallelize using this or to access chains easily
groupPeriods <- attr(f, "groupPeriods")
@@ -447,8 +447,8 @@
z$maxlikeTargets2 <- ans
z$mult <- x$mult
z$nrunMH <-
- z$mult * colSums(z$maxlikeTargets2[z$effects$basicRate, ,
- drop=FALSE ])
+ z$mult * colSums(z$maxlikeTargets2[z$requestedEffects$basicRate,
+ , drop=FALSE ])
z$nrunMH < pmax(z$nrunMH, 2)
## make the number pretty
z$nrunMH <- ifelse (z$nrunMH > 100,
@@ -474,7 +474,7 @@
{
CONDVAR <- z$condname
CONDTARGET <- attr(f, "change")
- ## cat(CONDTARGET, '\n')
+ ## cat(CONDTARGET, "\n")
}
else
{
@@ -522,10 +522,10 @@
{
z$prmib <- rep(0, length(nbrMissBeh))
}
- ## cat (z$prmin, z$prmib, '\n')
+ ## cat (z$prmin, z$prmib, "\n")
z$probs <- c(x$pridg, x$prcdg, x$prper, x$pripr, x$prdpr, x$prirms,
x$prdrms)
- ##cat(z$probs,'\n')
+ ##cat(z$probs,"\n")
ans <- .Call("mlMakeChains", PACKAGE=pkgname, pData, pModel,
z$probs, z$prmin, z$prmib,
x$minimumPermutationLength,
@@ -638,21 +638,21 @@
mat3[, 3] <- 1
mat1 <- mat1[!mat1[,3] == 0, , drop=FALSE] ##remove any zeros just created
##fix up storage mode to be integer
- storage.mode(mat1) <- 'integer'
- storage.mode(mat2) <- 'integer'
- storage.mode(mat3) <- 'integer'
+ storage.mode(mat1) <- "integer"
+ storage.mode(mat2) <- "integer"
+ storage.mode(mat3) <- "integer"
## add attribute of size
if (bipartite)
{
- attr(mat1, 'nActors') <- c(nrow(mat), ncol(mat))
- attr(mat2, 'nActors') <- c(nrow(mat), ncol(mat))
- attr(mat3, 'nActors') <- c(nrow(mat), ncol(mat))
+ attr(mat1, "nActors") <- c(nrow(mat), ncol(mat))
+ attr(mat2, "nActors") <- c(nrow(mat), ncol(mat))
+ attr(mat3, "nActors") <- c(nrow(mat), ncol(mat))
}
else
{
- attr(mat1, 'nActors') <- nrow(mat)
- attr(mat2, 'nActors') <- nrow(mat)
- attr(mat3, 'nActors') <- nrow(mat)
+ attr(mat1, "nActors") <- nrow(mat)
+ attr(mat2, "nActors") <- nrow(mat)
+ attr(mat3, "nActors") <- nrow(mat)
}
list(mat1 = t(mat1), mat2 = t(mat2), mat3 = t(mat3))
@@ -680,15 +680,15 @@
}, y = matorig)
mat2 <- do.call(rbind, tmp)
## add attribute of size
- attr(mat1, 'nActors1') <- nrow(mat)
- attr(mat1, 'nActors2') <- ncol(mat)
+ attr(mat1, "nActors1") <- nrow(mat)
+ attr(mat1, "nActors2") <- ncol(mat)
list(mat1=t(mat1), mat2=t(mat2))
}
##@unpackOneMode siena07 Reformat data for C++
unpackOneMode <- function(depvar, observations, compositionChange)
{
- edgeLists <- vector('list', observations)
- networks <- vector('list', observations)
+ edgeLists <- vector("list", observations)
+ networks <- vector("list", observations)
actorSet <- attr(depvar, "nodeSet")
compActorSets <- sapply(compositionChange, function(x)attr(x, "nodeSet"))
thisComp <- match(actorSet, compActorSets)
@@ -705,7 +705,7 @@
}
## sort out composition change
## convertToStructuralZeros()?
- sparse <- attr(depvar, 'sparse')
+ sparse <- attr(depvar, "sparse")
if (sparse)
{
## require(Matrix)
@@ -739,7 +739,7 @@
else
{
netmiss1 <- netmiss[[i]][, 1:2]
- storage.mode(netmiss1) <- 'integer'
+ storage.mode(netmiss1) <- "integer"
networks[[i]][netmiss1[, 1:2]] <-
networks[[i-1]][netmiss1[, 1:2]]
}
@@ -897,13 +897,13 @@
}
}
##fix up storage mode to be integer
- storage.mode(mat1) <- 'integer'
- storage.mode(mat2) <- 'integer'
- storage.mode(mat3) <- 'integer'
+ storage.mode(mat1) <- "integer"
+ storage.mode(mat2) <- "integer"
+ storage.mode(mat3) <- "integer"
## add attribute of size
- attr(mat1,'nActors') <- nActors
- attr(mat2,'nActors') <- nActors
- attr(mat3,'nActors') <- nActors
+ attr(mat1,"nActors") <- nActors
+ attr(mat2,"nActors") <- nActors
+ attr(mat3,"nActors") <- nActors
if (i < observations)
{
## recreate the distance etc
@@ -919,12 +919,16 @@
diag(mymat1) <- 0
diag(mymat2) <- 0
mydiff <- mymat2 - mymat1
- attr(depvar, 'distance')[i] <- sum(mydiff != 0,
+ attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
if (all(mydiff at x >= 0, na.rm=TRUE))
- attr(depvar, 'uponly')[i] <- TRUE
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
if (all(mydiff at x <= 0, na.rm=TRUE))
- attr(depvar, 'downonly')[i] <- TRUE
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
edgeLists[[i]] <- list(mat1 = t(mat1), mat2 = t(mat2),
mat3 = t(mat3))
@@ -1032,40 +1036,45 @@
diag(mymat1[, ,1]) <- 0
diag(mymat2[, ,1]) <- 0
mydiff <- mymat2 - mymat1
- attr(depvar, 'distance')[i] <- sum(mydiff != 0,
+ attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
if (all(mydiff >= 0, na.rm=TRUE))
- attr(depvar, 'uponly')[i] <- TRUE
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
if (all(mydiff <= 0, na.rm=TRUE))
- attr(depvar, 'downonly')[i] <- TRUE
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
diag(networks[[i]]) <- 0
- edgeLists[[i]] <- createEdgeLists(networks[[i]], depvar[, , i], FALSE)
+ edgeLists[[i]] <- createEdgeLists(networks[[i]], depvar[, , i],
+ FALSE)
}
}
## add attribute of nodeset
- attr(edgeLists, 'nodeSet') <- attr(depvar, 'nodeSet')
+ attr(edgeLists, "nodeSet") <- attr(depvar, "nodeSet")
## add attribute of name
- attr(edgeLists, 'name') <- attr(depvar, 'name')
+ attr(edgeLists, "name") <- attr(depvar, "name")
## add attribute of distance
- attr(edgeLists, 'distance') <- attr(depvar, 'distance')
+ attr(edgeLists, "distance") <- attr(depvar, "distance")
## attr uponly and downonly
- attr(edgeLists, 'uponly') <- attr(depvar, 'uponly')
- attr(edgeLists, 'downonly') <- attr(depvar, 'downonly')
+ attr(edgeLists, "uponly") <- attr(depvar, "uponly")
+ attr(edgeLists, "downonly") <- attr(depvar, "downonly")
## attr symmetric
- attr(edgeLists, 'symmetric') <- attr(depvar, 'symmetric')
+ attr(edgeLists, "symmetric") <- attr(depvar, "symmetric")
## attr balmean
- attr(edgeLists, 'balmean') <- attr(depvar, 'balmean')
- attr(edgeLists, 'structmean') <- attr(depvar, 'structmean')
- attr(edgeLists, 'averageInDegree') <- attr(depvar, 'averageInDegree')
- attr(edgeLists, 'averageOutDegree') <- attr(depvar, 'averageOutDegree')
+ attr(edgeLists, "balmean") <- attr(depvar, "balmean")
+ attr(edgeLists, "structmean") <- attr(depvar, "structmean")
+ attr(edgeLists, "averageInDegree") <- attr(depvar, "averageInDegree")
+ attr(edgeLists, "averageOutDegree") <- attr(depvar, "averageOutDegree")
return(edgeLists = edgeLists)
}
##@unpackBipartite siena07 Reformat data for C++
unpackBipartite <- function(depvar, observations, compositionChange)
{
- edgeLists <- vector('list', observations)
- networks <- vector('list', observations)
+ edgeLists <- vector("list", observations)
+ networks <- vector("list", observations)
actorSet <- attr(depvar, "nodeSet")
compActorSets <- sapply(compositionChange, function(x)attr(x, "nodeSet"))
thisComp <- match(actorSet, compActorSets)
@@ -1082,7 +1091,7 @@
ccOption <- 0
action <- matrix(0, nrow=attr(depvar, "netdims")[1], ncol=observations)
}
- sparse <- attr(depvar, 'sparse')
+ sparse <- attr(depvar, "sparse")
if (sparse)
{
## require(Matrix)
@@ -1114,7 +1123,7 @@
else
{
netmiss1 <- netmiss[[i]][, 1:2]
- storage.mode(netmiss1) <- 'integer'
+ storage.mode(netmiss1) <- "integer"
networks[[i]][netmiss1[, 1:2]] <-
networks[[i-1]][netmiss1[, 1:2]]
}
@@ -1241,13 +1250,13 @@
}
}
##fix up storage mode to be integer
- storage.mode(mat1) <- 'integer'
- storage.mode(mat2) <- 'integer'
- storage.mode(mat3) <- 'integer'
+ storage.mode(mat1) <- "integer"
+ storage.mode(mat2) <- "integer"
+ storage.mode(mat3) <- "integer"
## add attribute of size
- attr(mat1,'nActors') <- c(nActors, nReceivers)
- attr(mat2,'nActors') <- c(nActors, nReceivers)
- attr(mat3,'nActors') <- c(nActors, nReceivers)
+ attr(mat1,"nActors") <- c(nActors, nReceivers)
+ attr(mat2,"nActors") <- c(nActors, nReceivers)
+ attr(mat3,"nActors") <- c(nActors, nReceivers)
if (i < observations)
{
## recreate the distance etc
@@ -1261,12 +1270,16 @@
mymat1 at x <- x1
mymat2 at x <- x2
mydiff <- mymat2 - mymat1
- attr(depvar, 'distance')[i] <- sum(mydiff != 0,
+ attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
if (all(mydiff at x >= 0, na.rm=TRUE))
- attr(depvar, 'uponly')[i] <- TRUE
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
if (all(mydiff at x <= 0, na.rm=TRUE))
- attr(depvar, 'downonly')[i] <- TRUE
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
edgeLists[[i]] <- list(mat1 = t(mat1), mat2 = t(mat2),
mat3 = t(mat3))
@@ -1357,33 +1370,37 @@
mymat1[mymat1 %in% c(10,11)] <- NA
mymat2[mymat2 %in% c(10,11)] <- NA
mydiff <- mymat2 - mymat1
- attr(depvar, 'distance')[i] <- sum(mydiff != 0,
+ attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
if (all(mydiff >= 0, na.rm=TRUE))
- attr(depvar, 'uponly')[i] <- TRUE
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
if (all(mydiff <= 0, na.rm=TRUE))
- attr(depvar, 'downonly')[i] <- TRUE
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
edgeLists[[i]] <- createEdgeLists(networks[[i]], depvar[, , i], TRUE)
}
}
## add attribute of nodeset
- attr(edgeLists, 'nodeSet') <- attr(depvar, 'nodeSet')
+ attr(edgeLists, "nodeSet") <- attr(depvar, "nodeSet")
## add attribute of name
- attr(edgeLists, 'name') <- attr(depvar, 'name')
+ attr(edgeLists, "name") <- attr(depvar, "name")
## add attribute of distance
- attr(edgeLists, 'distance') <- attr(depvar, 'distance')
+ attr(edgeLists, "distance") <- attr(depvar, "distance")
## attr uponly and downonly
- attr(edgeLists, 'uponly') <- attr(depvar, 'uponly')
- attr(edgeLists, 'downonly') <- attr(depvar, 'downonly')
+ attr(edgeLists, "uponly") <- attr(depvar, "uponly")
+ attr(edgeLists, "downonly") <- attr(depvar, "downonly")
## attr symmetric
- attr(edgeLists, 'symmetric') <- attr(depvar, 'symmetric')
+ attr(edgeLists, "symmetric") <- attr(depvar, "symmetric")
## attr balmean
- attr(edgeLists, 'balmean') <- attr(depvar, 'balmean')
+ attr(edgeLists, "balmean") <- attr(depvar, "balmean")
## attr structmean
- attr(edgeLists, 'structmean') <- attr(depvar, 'structmean')
- attr(edgeLists, 'averageOutDegree') <- attr(depvar, 'averageOutDegree')
+ attr(edgeLists, "structmean") <- attr(depvar, "structmean")
+ attr(edgeLists, "averageOutDegree") <- attr(depvar, "averageOutDegree")
return(edgeLists = edgeLists)
}
##@unpackBehavior siena07 Reformat data for C++
@@ -1411,21 +1428,21 @@
## behstruct[!struct] <- 0
## add attribute of nodeset
- attr(beh, 'nodeSet') <- attr(depvar, 'nodeSet')
+ attr(beh, "nodeSet") <- attr(depvar, "nodeSet")
## add attribute of name
- attr(beh, 'name') <- attr(depvar, 'name')
+ attr(beh, "name") <- attr(depvar, "name")
## attr uponly and downonly
- attr(beh, 'uponly') <- attr(depvar, 'uponly')
- attr(beh, 'downonly') <- attr(depvar, 'downonly')
+ attr(beh, "uponly") <- attr(depvar, "uponly")
+ attr(beh, "downonly") <- attr(depvar, "downonly")
## attr symmetric
- attr(beh, 'symmetric') <- attr(depvar, 'symmetric')
+ attr(beh, "symmetric") <- attr(depvar, "symmetric")
## attr distance
- attr(beh, 'distance') <- attr(depvar, 'distance')
+ attr(beh, "distance") <- attr(depvar, "distance")
## attr simMean
- attr(beh, 'simMean') <- attr(depvar, 'simMean')
+ attr(beh, "simMean") <- attr(depvar, "simMean")
## attr simMeans
- attr(beh, 'simMeans') <- attr(depvar, 'simMeans')
- storage.mode(beh) <- 'integer'
+ attr(beh, "simMeans") <- attr(depvar, "simMeans")
+ storage.mode(beh) <- "integer"
list(beh=beh, behmiss=behmiss)
}
##@convertToStructuralZeros Miscellaneous To be implemented
@@ -1436,8 +1453,8 @@
##@unpackCDyad siena07 Reformat data for C++
unpackCDyad<- function(dycCovar)
{
- sparse <- attr(dycCovar, 'sparse')
- nodeSets <- attr(dycCovar, "nodeSet")
+ sparse <- attr(dycCovar, "sparse")
+ bipartite <- attr(dycCovar, "type") == "bipartite"
if (sparse)
{
## have a list containing 1 sparse matrix in triplet format
@@ -1449,7 +1466,7 @@
stop("duplicate entries in sparse matrix dyadic covariate")
}
##drop the diagonal, if present - not for bipartite
- if (nodeSets[1] == nodeSets[2])
+ if (!bipartite)
{
varmat <- varmat[varmat[,1] != varmat[, 2],]
}
@@ -1457,18 +1474,18 @@
mat1[is.na(varmat[, 3]), 3] <- attr(dycCovar, "mean")
mat1 <- mat1[!mat1[, 3] == 0, ]
## add attribute of dim
- attr(mat1, 'nActors1') <- nrow(dycCovar[[1]])
- attr(mat1, 'nActors2') <- ncol(dycCovar[[1]])
+ attr(mat1, "nActors1") <- nrow(dycCovar[[1]])
+ attr(mat1, "nActors2") <- ncol(dycCovar[[1]])
mat2 <- varmat[is.na(varmat[, 3]), , drop=FALSE]
mat2[, 3] <- 1
## add attribute of dim
- attr(mat2,'nActors1') <- nrow(dycCovar[[1]])
- attr(mat2,'nActors2') <- ncol(dycCovar[[1]])
+ attr(mat2,"nActors1") <- nrow(dycCovar[[1]])
+ attr(mat2,"nActors2") <- ncol(dycCovar[[1]])
edgeLists <- list(t(mat1), t(mat2))
}
else
{
- if (nodeSets[1] == nodeSets[2])
+ if (!bipartite)
{
diag(dycCovar) <- 0
}
@@ -1477,11 +1494,13 @@
edgeLists <- createCovarEdgeList(dycCovar1, dycCovar)
}
## add attribute of nodesets
- attr(edgeLists, 'nodeSet') <- attr(dycCovar, 'nodeSet')
+ attr(edgeLists, "nodeSet") <- attr(dycCovar, "nodeSet")
+ ## add attribute of type
+ attr(edgeLists, "type") <- attr(dycCovar, "type")
## add attribute of name
- attr(edgeLists, 'name') <- attr(dycCovar, 'name')
+ attr(edgeLists, "name") <- attr(dycCovar, "name")
## add attribute of mean
- attr(edgeLists, 'mean') <- attr(dycCovar, 'mean')
+ attr(edgeLists, "mean") <- attr(dycCovar, "mean")
return(edgeLists = edgeLists)
}
@@ -1489,10 +1508,10 @@
##@unpackVDyad siena07 Reformat data for C++
unpackVDyad<- function(dyvCovar, observations)
{
- edgeLists <- vector('list', observations)
- sparse <- attr(dyvCovar, 'sparse')
+ edgeLists <- vector("list", observations)
+ sparse <- attr(dyvCovar, "sparse")
means <- attr(dyvCovar, "meanp")
- nodeSets <- attr(dyvCovar, "nodeSet")
+ bipartite <- attr(dyvCovar, "type") == "bipartite"
if (sparse)
{
## have a list of sparse matrices in triplet format
@@ -1502,7 +1521,7 @@
thisvar <- dyvCovar[[i]]
varmat <- cbind(thisvar at i+1, thisvar at j+1, thisvar at x)
## drop the diagonal, if present no - bipartite?
- if (nodeSets[1] == nodeSets[2])
+ if (!bipartite)
{
varmat <- varmat[varmat[,1] != varmat[, 2],]
}
@@ -1512,10 +1531,10 @@
mat2 <- varmat[is.na(varmat[, 3]),, drop=FALSE ]
mat2[, 3] <- 1
## add attribute of size
- attr(mat1, 'nActors1') <- nrow(dyvCovar[[i]])
- attr(mat1, 'nActors2') <- ncol(dyvCovar[[i]])
- attr(mat2, 'nActors1') <- nrow(dyvCovar[[i]])
- attr(mat2, 'nActors2') <- ncol(dyvCovar[[i]])
+ attr(mat1, "nActors1") <- nrow(dyvCovar[[i]])
+ attr(mat1, "nActors2") <- ncol(dyvCovar[[i]])
+ attr(mat2, "nActors1") <- nrow(dyvCovar[[i]])
+ attr(mat2, "nActors2") <- ncol(dyvCovar[[i]])
edgeLists[[i]] <- list(t(mat1), t(mat2))
}
}
@@ -1523,7 +1542,7 @@
{
for (i in 1:(observations - 1))
{
- if (nodeSets[1] == nodeSets[2])
+ if (!bipartite)
{
diag(dyvCovar[, , i]) <- 0
}
@@ -1533,11 +1552,13 @@
}
}
## add attribute of nodeset
- attr(edgeLists, 'nodeSet') <- attr(dyvCovar, 'nodeSet')
+ attr(edgeLists, "nodeSet") <- attr(dyvCovar, "nodeSet")
+ ## add attribute of type
+ attr(edgeLists, "type") <- attr(dyvCovar, "type")
## add attribute of name
- attr(edgeLists, 'name') <- attr(dyvCovar, 'name')
+ attr(edgeLists, "name") <- attr(dyvCovar, "name")
## add attribute of mean
- attr(edgeLists, 'mean') <- attr(dyvCovar, 'mean')
+ attr(edgeLists, "mean") <- attr(dyvCovar, "mean")
return(edgeLists = edgeLists)
}
@@ -1546,11 +1567,11 @@
{
f <- NULL
observations<- data$observations
- types <- sapply(data$depvars, function(x) attr(x, 'type'))
+ types <- sapply(data$depvars, function(x) attr(x, "type"))
f$nDepvars <- length(data$depvars)
- oneModes <- data$depvars[types == 'oneMode']
- Behaviors <- data$depvars[types == 'behavior']
- bipartites <- data$depvars[types == 'bipartite']
+ oneModes <- data$depvars[types == "oneMode"]
+ Behaviors <- data$depvars[types == "behavior"]
+ bipartites <- data$depvars[types == "bipartite"]
f$nets <- lapply(oneModes, function(x, n, comp) unpackOneMode(x, n, comp),
n = observations, comp=data$compositionChange)
names(f$nets) <- names(oneModes)
@@ -1562,16 +1583,16 @@
n = observations)
names(f$behavs) <- names(Behaviors)
f$observations <- observations
- f$seed<- vector('list', observations - 1)
+ f$seed<- vector("list", observations - 1)
f$depvars <- data$depvars
f$nodeSets <- data$nodeSets
f$oneModes <- oneModes
f$Behaviors <- Behaviors
- f$oneModeUpOnly <- sapply(oneModes, function(x) attr(x, 'uponly'))
- f$oneModeDownOnly <- sapply(oneModes, function(x) attr(x, 'downonly'))
- f$behaviorUpOnly <- sapply(Behaviors, function(x) attr(x, 'uponly'))
+ f$oneModeUpOnly <- sapply(oneModes, function(x) attr(x, "uponly"))
+ f$oneModeDownOnly <- sapply(oneModes, function(x) attr(x, "downonly"))
+ f$behaviorUpOnly <- sapply(Behaviors, function(x) attr(x, "uponly"))
f$behaviorDownOnly <- sapply(Behaviors, function(x) attr(x,
- 'downonly'))
+ "downonly"))
f$distances <- sapply(data$depvars, function(x) attr(x, "distance"))
f$cCovars <- data$cCovars
f$vCovars <- data$vCovars
@@ -1818,19 +1839,19 @@
"same type: evaluation, endowment or creation")
}
}
- ## check types - all should be OK here
+ ## check types - at most one should be not OK here
inters <- rbind(inter1, inter2, inter3)
- ##if (length(which(inters$interactionType != "OK")) > 1)
- ##{
- ## stop("invalid behavior interaction specification: ",
- ## "at most one effect with interactionType ",
- ## "not OK is allowed")
+ if (length(which(inters$interactionType != "OK")) > 1)
+ {
+ stop("invalid behavior interaction specification: ",
+ "at most one effect with interactionType ",
+ "not OK is allowed")
+ }
+ ##if (any(inters$interactionType != "OK"))
+ ##{
+ ## stop("invalid behavior interaction specification: ",
+ ## "only effects with interactionType OK are allowed")
##}
- if (any(inters$interactionType != "OK"))
- {
- stop("invalid behavior interaction specification: ",
- "only effects with interactionType OK are allowed")
- }
## construct a name
tmpnames <- inters$effectName
tmpnames[-1] <- sub(paste("behavior ", inters$name[1], " ",
Modified: pkg/RSiena/R/sienaDataCreate.r
===================================================================
--- pkg/RSiena/R/sienaDataCreate.r 2012-01-17 15:36:52 UTC (rev 193)
+++ pkg/RSiena/R/sienaDataCreate.r 2012-01-17 22:08:36 UTC (rev 194)
@@ -376,7 +376,7 @@
for (i in seq(along=dycCovars))
{
nattr <- attr(dycCovars[[i]], 'nodeSet')
- bipartite <- nattr[1] != nattr[2]
+ bipartite <- attr(dycCovars[[i]], "type") == "bipartite"
if (attr(dycCovars[[i]], "sparse"))
{
thisdycCovar <- dycCovars[[i]][[1]]
@@ -386,10 +386,14 @@
thisdycCovar <- dycCovars[[i]]
}
if (!validNodeSet(nattr[1], nrow(thisdycCovar)))
- stop('dyadic covariate incorrect nbr rows', names(dycCovars)[i])
+ {
+ stop("dyadic covariate incorrect nbr rows", names(dycCovars)[i])
+ }
if (!validNodeSet(nattr[2], ncol(thisdycCovar)))
- stop('dyadic covariate incorrect nbr columns',
+ {
+ stop("dyadic covariate incorrect nbr columns",
names(dycCovars)[i])
+ }
dycCovars[[i]] <- addAttributes(dycCovars[[i]], names(dycCovars)[i],
bipartite)
}
@@ -401,7 +405,7 @@
}
nattr <- attr(dyvCovars[[i]],'nodeSet')
sparse <- attr(dyvCovars[[i]], "sparse")
- bipartite <- nattr[1] != nattr[2]
+ bipartite <- attr(dyvCovars[[i]], "type") == "bipartite"
vardims <- attr(dyvCovars[[i]], "vardims")
if (!validNodeSet(nattr[1], vardims[1]))
{
@@ -1405,6 +1409,8 @@
cvnodeSets <- namedVector(NA, vCovars)
dycnodeSets <- namedVector(NA, dycCovars, listType=TRUE)
dyvnodeSets <- namedVector(NA, dyvCovars, listType=TRUE)
+ dyctype <- namedVector(NA, dycCovars)
+ dyvtype <- namedVector(NA, dyvCovars)
# totalMissings <- namedVector(0, netnames, listType=TRUE)
# nonMissingCount <- namedVector(0, netnames, listType=TRUE)
observations <- 0
@@ -1556,11 +1562,19 @@
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 194
More information about the Rsiena-commits
mailing list