[Rsiena-commits] r126 - in pkg: RSiena RSiena/R RSiena/data RSiena/inst/doc RSiena/man RSiena/src RSiena/src/data RSiena/src/model RSiena/src/model/effects RSiena/src/model/ml RSiena/src/model/variables RSiena/tests RSienaTest RSienaTest/R RSienaTest/doc RSienaTest/inst/doc RSienaTest/man RSienaTest/src RSienaTest/src/model/ml RSienaTest/src/model/variables RSienaTest/tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Nov 25 18:15:35 CET 2010
Author: ripleyrm
Date: 2010-11-25 18:15:33 +0100 (Thu, 25 Nov 2010)
New Revision: 126
Added:
pkg/RSiena/R/terminateFRAN.r
pkg/RSiena/src/model/effects/InStructuralEquivalenceEffect.cpp
pkg/RSiena/src/model/effects/InStructuralEquivalenceEffect.h
pkg/RSiena/src/siena07internals.cpp
pkg/RSiena/src/siena07internals.h
pkg/RSiena/src/siena07models.cpp
pkg/RSiena/src/siena07models.h
pkg/RSiena/src/siena07setup.cpp
pkg/RSiena/src/siena07setup.h
pkg/RSiena/src/siena07utilities.cpp
pkg/RSiena/src/siena07utilities.h
pkg/RSienaTest/R/terminateFRAN.r
Removed:
pkg/RSiena/src/siena07.cpp
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/R/Sienatest.r
pkg/RSiena/R/bayes.r
pkg/RSiena/R/effects.r
pkg/RSiena/R/effectsMethods.r
pkg/RSiena/R/maxlikec.r
pkg/RSiena/R/phase1.r
pkg/RSiena/R/phase3.r
pkg/RSiena/R/printDataReport.r
pkg/RSiena/R/robmon.r
pkg/RSiena/R/siena07.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienaModelCreate.r
pkg/RSiena/R/sienaTimeTest.r
pkg/RSiena/R/sienaeffects.r
pkg/RSiena/R/sienaprint.r
pkg/RSiena/R/simstatsc.r
pkg/RSiena/changeLog
pkg/RSiena/data/allEffects.csv
pkg/RSiena/inst/doc/s_man400.pdf
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/getEffects.Rd
pkg/RSiena/man/includeInteraction.Rd
pkg/RSiena/man/plot.sienaTimeTest.Rd
pkg/RSiena/man/print.sienaEffects.Rd
pkg/RSiena/man/siena07.Rd
pkg/RSiena/man/sienaDataCreate.Rd
pkg/RSiena/man/sienaModelCreate.Rd
pkg/RSiena/man/sienaNet.Rd
pkg/RSiena/man/sienaTimeTest.Rd
pkg/RSiena/src/Makevars
pkg/RSiena/src/Makevars.win
pkg/RSiena/src/data/BehaviorLongitudinalData.cpp
pkg/RSiena/src/data/BehaviorLongitudinalData.h
pkg/RSiena/src/data/LongitudinalData.h
pkg/RSiena/src/data/NetworkLongitudinalData.cpp
pkg/RSiena/src/data/NetworkLongitudinalData.h
pkg/RSiena/src/data/OneModeNetworkLongitudinalData.cpp
pkg/RSiena/src/data/OneModeNetworkLongitudinalData.h
pkg/RSiena/src/model/EpochSimulation.cpp
pkg/RSiena/src/model/EpochSimulation.h
pkg/RSiena/src/model/Model.cpp
pkg/RSiena/src/model/Model.h
pkg/RSiena/src/model/State.cpp
pkg/RSiena/src/model/State.h
pkg/RSiena/src/model/effects/AllEffects.h
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/ml/Chain.cpp
pkg/RSiena/src/model/ml/Chain.h
pkg/RSiena/src/model/ml/MLSimulation.cpp
pkg/RSiena/src/model/ml/MLSimulation.h
pkg/RSiena/src/model/ml/NetworkChange.cpp
pkg/RSiena/src/model/variables/BehaviorVariable.cpp
pkg/RSiena/src/model/variables/BehaviorVariable.h
pkg/RSiena/src/model/variables/DependentVariable.cpp
pkg/RSiena/src/model/variables/DependentVariable.h
pkg/RSiena/src/model/variables/NetworkVariable.cpp
pkg/RSiena/src/model/variables/NetworkVariable.h
pkg/RSiena/tests/parallel.Rout.save
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/R/Sienatest.r
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/effectsMethods.r
pkg/RSienaTest/R/initializeFRAN.r
pkg/RSienaTest/R/maxlikec.r
pkg/RSienaTest/R/phase1.r
pkg/RSienaTest/R/phase3.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaTimeTest.r
pkg/RSienaTest/R/sienaeffects.r
pkg/RSienaTest/R/simstatsc.r
pkg/RSienaTest/changeLog
pkg/RSienaTest/doc/RSIENAspec.tex
pkg/RSienaTest/doc/RSiena.bib
pkg/RSienaTest/doc/RSienaDeveloper.tex
pkg/RSienaTest/doc/Siena_algorithms4.tex
pkg/RSienaTest/doc/s_man400.tex
pkg/RSienaTest/inst/doc/s_man400.pdf
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/getEffects.Rd
pkg/RSienaTest/man/includeInteraction.Rd
pkg/RSienaTest/man/plot.sienaTimeTest.Rd
pkg/RSienaTest/man/print.sienaEffects.Rd
pkg/RSienaTest/man/siena07.Rd
pkg/RSienaTest/man/sienaDataCreate.Rd
pkg/RSienaTest/man/sienaNet.Rd
pkg/RSienaTest/man/sienaTimeTest.Rd
pkg/RSienaTest/src/model/ml/MLSimulation.cpp
pkg/RSienaTest/src/model/ml/MLSimulation.h
pkg/RSienaTest/src/model/variables/DependentVariable.cpp
pkg/RSienaTest/src/model/variables/DependentVariable.h
pkg/RSienaTest/src/siena07internals.cpp
pkg/RSienaTest/tests/parallel.Rout.save
Log:
New version of sienaTimeTest, sienaTimeFix. Bayesian with multiple dependent variables. RSiena up to RSienaTest.
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2010-11-07 12:38:33 UTC (rev 125)
+++ pkg/RSiena/DESCRIPTION 2010-11-25 17:15:33 UTC (rev 126)
@@ -1,8 +1,8 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.11.125
-Date: 2010-11-07
+Version: 1.0.12.126
+Date: 2010-11-25
Author: Various
Depends: R (>= 2.9.0), xtable
Imports: Matrix
Modified: pkg/RSiena/R/Sienatest.r
===================================================================
--- pkg/RSiena/R/Sienatest.r 2010-11-07 12:38:33 UTC (rev 125)
+++ pkg/RSiena/R/Sienatest.r 2010-11-25 17:15:33 UTC (rev 126)
@@ -178,8 +178,17 @@
dfra2 <- dfra + msf
else
dfra2 <- dfra
- dinv2 <- solve(dfra2)
- oneStep<- -dinv2 %*% fra
+ if (inherits(try(dinv2 <- solve(dfra2)), "try-error"))
+ {
+ Report("Error message for inversion to get onestep estimator: \n", cf)
+ dinv2 <- dfra2
+ dinv2[] <- NA
+ oneStep <- rep(NA, nrow(dfra2))
+ }
+ else
+ {
+ oneStep<- -dinv2 %*% fra
+ }
list(testresult=testresult, testresulto=testresulto,
testresOverall=testresOverall, covMatrix=covMatrix,
oneStep=oneStep, dinv2= dinv2, dfra2=dfra2)
@@ -188,47 +197,65 @@
EvaluateTestStatistic<- function(maxlike, test, dfra, msf, fra)
{
##uses local arrays set up in the calling procedure
- d11 <- dfra[!test,!test,drop=FALSE]
- d22 <- dfra[test,test,drop=FALSE]
- d21 <- dfra[test,!test,drop=FALSE]
+ d11 <- dfra[!test, !test, drop=FALSE]
+ d22 <- dfra[test, test, drop=FALSE]
+ d21 <- dfra[test, !test, drop=FALSE]
d12 <- t(d21)
- sigma11 <- msf[!test,!test,drop=FALSE]
- sigma22<- msf[test,test,drop=FALSE]
- sigma12 <- msf[!test,test,drop=FALSE]
+ sigma11 <- msf[!test, !test, drop=FALSE]
+ sigma22<- msf[test, test,drop=FALSE]
+ sigma12 <- msf[!test, test, drop=FALSE]
sigma21<- t(sigma12)
z1 <- fra[!test]
z2 <- fra[test]
- id11 <- solve(d11)
- rg<- d21%*%id11
- if (!maxlike)
+ if (inherits(try(id11 <- solve(d11)), "try-error"))
{
- ##orthogonalise deviation vector
- ov<- z2-rg%*%z1
- ##compute var(ov) = sigma22- (d21%*%id11) %*%sigma12 -
- ## sigma21 %*% t(id11)%*% t(d21) +
- ## d21%*%id11 %*% sigma11 %*% t(id11) %*% t(d21)
- v2<- sigma21 - rg%*%sigma11
- v6<- v2 %*% t(id11) %*% t(d21)
- v9<- sigma22 - rg %*% sigma12 -v6
+ Report('Error message for inversion of d11: \n', cf)
+ oneSided <- NA
+ v9 <- d22
+ v9[] <- NA
+ cvalue <- matrix(NA, 1, 1)
}
else
{
- ov <- -z2
- v9 <- d22 - rg %*% d12
- }
- vav<- solve(v9) ## vav is the inverse variance matrix of ov
- cvalue <- t(ov) %*% vav %*% ov
- if (cvalue < 0) cvalue <- 0
- if (sum(test)==1)
- {
- if (vav>0)
- oneSided <- ov * sqrt(vav)
+ rg <- d21 %*% id11
+ if (!maxlike)
+ {
+ ##orthogonalise deviation vector
+ ov <- z2 - rg %*% z1
+ ##compute var(ov) = sigma22 - (d21 %*% id11) %*% sigma12 -
+ ## sigma21 %*% t(id11)%*% t(d21) +
+ ## d21%*%id11 %*% sigma11 %*% t(id11) %*% t(d21)
+ v2 <- sigma21 - rg %*% sigma11
+ v6 <- v2 %*% t(id11) %*% t(d21)
+ v9 <- sigma22 - rg %*% sigma12 - v6
+ }
else
+ {
+ ov <- -z2
+ v9 <- d22 - rg %*% d12
+ }
+ if (inherits(try(vav <- solve(v9)), "try-error"))
+ ## vav is the inverse variance matrix of ov
+ {
+ Report('Error message for inversion of v9: \n', cf)
+ vav <- v9
+ vav[] <- NA
+ }
+ cvalue <- t(ov) %*% vav %*% ov
+ if (cvalue < 0) cvalue <- 0
+ if (sum(test) == 1)
+ {
+ if (vav > 0)
+ oneSided <- ov * sqrt(vav)
+ else
+ oneSided <- 0
+ if (!maxlike) oneSided <- - oneSided
+ ## change the sign for intuition for users
+ }
+ else
+ {
oneSided <- 0
- if (!maxlike) oneSided<- - oneSided
- ## change the sign for intuition for users
+ }
}
- else
- oneSided <- 0
list(cvalue=cvalue, oneSided=oneSided, covMatrix=v9)
}
Modified: pkg/RSiena/R/bayes.r
===================================================================
--- pkg/RSiena/R/bayes.r 2010-11-07 12:38:33 UTC (rev 125)
+++ pkg/RSiena/R/bayes.r 2010-11-25 17:15:33 UTC (rev 126)
@@ -24,9 +24,9 @@
z$candidates <- matrix(NA, nrow=nmain * nrunMHBatches,
ncol=sum(!basicRate))
z$acceptances <- rep(NA, nmain * nrunMHBatches)
- z$MHacceptances <- matrix(NA, nrow=nmain * nrunMHBatches, ncol=6)
- z$MHrejections <- matrix(NA, nrow=nmain * nrunMHBatches , ncol=6)
- z$MHproportions <- matrix(NA, nrow=nmain * nrunMHBatches, ncol=6)
+ z$MHacceptances <- matrix(NA, nrow=nmain * nrunMHBatches, ncol=7)
+ z$MHrejections <- matrix(NA, nrow=nmain * nrunMHBatches , ncol=7)
+ z$MHproportions <- matrix(NA, nrow=nmain * nrunMHBatches, ncol=7)
z
}
storeData <- function()
@@ -127,13 +127,13 @@
}
if (z$scaleFactor < tiny)
{
- cat('scalefactor < tiny\n')
+ cat('calefactor < tiny\n')
browser()
}
}
cat('fine tuning took ', iter, ' iterations. Scalefactor:',
z$scaleFactor, '\n')
- z
+ z
}
## initialise
@@ -151,6 +151,7 @@
z$maxlike <- TRUE
model$maxlike <- TRUE
model$FRANname <- "maxlikec"
+ z$print <- FALSE
z$int <- 1
z$int2 <- 1
model$cconditional <- FALSE
@@ -195,7 +196,8 @@
cat('main after ii',ii,numm, '\n')
dev.set(thetaplot)
thetadf <- data.frame(z$lambdas, z$betas)
- acceptsdf <- data.frame(z$MHproportions, z$acceptances)
+ acceptsdf <- data.frame(z$MHproportions[, 1:5],
+ z$acceptances)
lambdaNames <- paste(z$effects$name[basicRate],
z$effects$shortName[basicRate],
z$effects$period[basicRate],
@@ -204,7 +206,8 @@
z$effects$shortName[!basicRate], sep=".")
names(thetadf) <- c(lambdaNames, betaNames)
names(acceptsdf) <- c("InsDiag", "CancDiag", "Permute", "InsPerm",
- "CancPerm", "Missing", "BayesAccepts")
+ "CancPerm", #"Missing",
+ "BayesAccepts")
varnames <- paste(names(thetadf), sep="", collapse= " + ")
varcall <- paste("~ ", varnames, sep="", collapse="")
print(histogram(as.formula(varcall), data=thetadf, scales="free",
@@ -230,7 +233,7 @@
group <- 1
f <- FRANstore()
ans <- .Call("MCMCcycle", PACKAGE=pkgname, f$pData, f$pModel,
- f$pMLSimulation, f$myeffects, as.integer(period),
+ f$myeffects, as.integer(period),
as.integer(group),
z$scaleFactor, nrunMH, nrunMHBatches)
## process the return values
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2010-11-07 12:38:33 UTC (rev 125)
+++ pkg/RSiena/R/effects.r 2010-11-25 17:15:33 UTC (rev 126)
@@ -8,6 +8,67 @@
# * Description: This module contains the code for the creation of the
# * effects object to go with a Siena data object or group object.
# *****************************************************************************/
+##@substituteNames replace xxxxxx, yyyyyy, zzzzzz
+substituteNames <- function(nameVectors, xName=NULL, yName=NULL, zName=NULL)
+{
+ effects <- nameVectors[, c("effectName", "functionName",
+ "interaction1", "interaction2")]
+ if (!is.null(xName))
+ {
+ effects <- sapply(effects, function(x)
+ gsub("xxxxxx", xName, x))
+ }
+ if (!is.null(yName))
+ {
+ effects <- sapply(effects, function(x)
+ gsub("yyyyyy", yName, x))
+ }
+ if (!is.null(zName))
+ {
+ effects <- sapply(effects, function(x)
+ gsub("zzzzzz", zName, x))
+ }
+ nameVectors[, c("effectName", "functionName",
+ "interaction1", "interaction2")] <- effects
+ nameVectors
+}
+##@createEffects Extract required rows and change text
+createEffects <- function(effectGroup, xName=NULL, yName=NULL, name,
+ groupName, group, netType)
+{
+ effects <- allEffects[allEffects$effectGroup == effectGroup, ]
+ if (nrow(effects) == 0)
+ {
+ stop("empty effect group")
+ }
+ if (any(is.na(effects$effectName)))
+ {
+ stop("missing effect name")
+ }
+ effects <- substituteNames(effects, xName, yName)
+ effects$effectGroup <- NULL
+ nn <- nrow(effects)
+ if (!all(is.na(effects$endowment)))
+ {
+ neweffects <- effects[rep(1:nn,
+ times=(1 + as.numeric(effects$endowment))), ]
+ neweffects$type <- unlist(lapply(effects$endowment, function(x) if (x)
+ c('eval', 'endow') else 'eval'))
+ effects <- neweffects
+ nn <- nrow(effects)
+ }
+ effects$endowment <- NULL
+ effectFn <- vector('list', nn)
+ statisticFn <- vector('list', nn)
+ effects$effectFn <- effectFn
+ effects$statisticFn <- statisticFn
+ effects$netType <- netType
+ effects$groupName <- groupName
+ effects$group <- group
+ effectsname <- rep(name, nn)
+ effects <- data.frame(name=effectsname, effects, stringsAsFactors=FALSE)
+ effects
+}
##@getEffects DataCreate
getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE)
{
@@ -25,59 +86,27 @@
}
tmp
}
- ##@substituteNames internal getEffects replace xxxxxx, yyyyyy, zzzzzz
- substituteNames <- function(nameVectors, xName=NULL, yName=NULL, zName=NULL)
- {
- effects <- nameVectors[, c("effectName", "functionName",
- "interaction1", "interaction2")]
- if (!is.null(xName))
- {
- effects <- sapply(effects, function(x)
- gsub("xxxxxx", xName, x))
- }
- if (!is.null(yName))
- {
- effects <- sapply(effects, function(x)
- gsub("yyyyyy", yName, x))
- }
- if (!is.null(zName))
- {
- effects <- sapply(effects, function(x)
- gsub("zzzzzz", zName, x))
- }
- nameVectors[, c("effectName", "functionName",
- "interaction1", "interaction2")] <- effects
- nameVectors
- }
- ##@createEffects internal getEffects Extract required rows and change text
- createEffects <- function(effectGroup, xName=NULL, yName=NULL)
- {
- effects <- allEffects[allEffects$effectGroup == effectGroup, ]
- if (nrow(effects) == 0)
- {
- stop("empty effect group")
- }
- if (any(is.na(effects$effectName)))
- {
- stop("missing effect name")
- }
- effects <- substituteNames(effects, xName, yName)
- effects
- }
##@networkRateEffects internal getEffects create a set of rate effects
networkRateEffects <- function(depvar, varname, symmetric, bipartite)
{
if (symmetric)
{
- rateEffects <- createEffects("symmetricRate", varname)
+ rateEffects <- createEffects("symmetricRate", varname, name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
}
else if (bipartite)
{
- rateEffects <- createEffects("bipartiteRate", varname)
+ rateEffects <- createEffects("bipartiteRate", varname, name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
}
else
{
- rateEffects <- createEffects("nonSymmetricRate", varname)
+ rateEffects <- createEffects("nonSymmetricRate", varname,
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
}
if (observations == 1)
{
@@ -103,11 +132,17 @@
if (symmetric)
{
- objEffects <- createEffects("symmetricObjective", varname)
+ objEffects <- createEffects("symmetricObjective", varname,
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
}
else
{
- objEffects <- createEffects("nonSymmetricObjective", varname)
+ objEffects <- createEffects("nonSymmetricObjective", varname,
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
}
for (j in seq(along = xx$dycCovars))
{
@@ -115,7 +150,11 @@
{
objEffects <- rbind(objEffects,
createEffects("dyadObjective",
- names(xx$dycCovars)[j]))
+ names(xx$dycCovars)[j],
+ name=varname,
+ groupName=groupName,
+ group=group,
+ netType=netType))
}
}
for (j in seq(along = xx$dyvCovars))
@@ -124,7 +163,11 @@
{
objEffects <- rbind(objEffects,
createEffects("dyadObjective",
- names(xx$dyvCovars)[j]))
+ names(xx$dyvCovars)[j],
+ name=varname,
+ groupName=groupName,
+ group=group,
+ netType=netType))
}
}
for (j in seq(along = xx$cCovars))
@@ -134,7 +177,7 @@
tmp <- covarOneModeEff(names(xx$cCovars)[j],
attr(xx$cCovars[[j]], 'poszvar'),
attr(xx$cCovars[[j]], 'moreThan2'),
- symmetric)
+ symmetric, name=varname)
objEffects <- rbind(objEffects, tmp$objEff)
rateEffects <- rbind(rateEffects, tmp$rateEff)
}
@@ -147,7 +190,7 @@
tmp <- covarOneModeEff(names(xx$depvars)[j],
poszvar=TRUE,
attr(xx$depvars[[j]], 'moreThan2'),
- symmetric)
+ symmetric, name=varname)
objEffects <- rbind(objEffects, tmp$objEff)
rateEffects <- rbind(rateEffects, tmp$rateEff)
}
@@ -159,7 +202,7 @@
tmp <- covarOneModeEff(names(xx$vCovars)[j],
attr(xx$vCovars[[j]], 'poszvar'),
attr(xx$vCovars[[j]], 'moreThan2'),
- symmetric)
+ symmetric, name=varname)
objEffects <- rbind(objEffects,tmp$objEff)
rateEffects<- rbind(rateEffects,tmp$rateEff)
}
@@ -170,8 +213,11 @@
length(xx$dycCovars) + length(xx$dyvCovars) +
length(types=='behavior') > 0)
{
- interaction <- createEffects("unspecifiedNetInteraction")
- objEffects <- rbind(objEffects, interaction[rep(1, nintn), ])
+ interaction <- createEffects("unspecifiedNetInteraction",
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
+ objEffects <- rbind(objEffects, interaction[rep(1:2, nintn), ])
}
for (j in seq(along=xx$depvars))
@@ -186,14 +232,18 @@
objEffects <-
rbind(objEffects,
createEffects("nonSymmetricSymmetricObjective",
- otherName))
+ otherName, name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
else
{
objEffects <-
rbind(objEffects,
createEffects("nonSymmetricNonSymmetricObjective",
- otherName))
+ otherName, name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
if (types[j] == 'bipartite' &&
@@ -202,7 +252,9 @@
objEffects <-
rbind(objEffects,
createEffects("nonSymmetricBipartiteObjective",
- otherName))
+ otherName, name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
if (types[j] != "behavior" && varname != otherName)
{
@@ -213,7 +265,11 @@
objEffects <-
rbind(objEffects,
createEffects("covarNetNetObjective",
- otherName, names(xx$cCovars)[k]))
+ otherName,
+ names(xx$cCovars)[k],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
for (k in seq(along=xx$vCovars))
@@ -223,7 +279,11 @@
objEffects <-
rbind(objEffects,
createEffects("covarNetNetObjective",
- otherName, names(xx$vCovars)[k]))
+ otherName,
+ names(xx$vCovars)[k],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
for (k in seq(along=xx$depvars))
@@ -235,7 +295,10 @@
rbind(objEffects,
createEffects("covarNetNetObjective",
otherName,
- names(xx$depvars)[k]))
+ names(xx$depvars)[k],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
@@ -249,8 +312,8 @@
objEffects$effectName, sep = '')
}
## now create the real effects, extra rows for endowment effects etc
- objEffects <- createObjEffectList(objEffects, varname)
- rateEffects <- createRateEffectList(rateEffects, varname)
+ #objEffects <- createObjEffectList(objEffects, varname)
+ #rateEffects <- createRateEffectList(rateEffects, varname)
## replace the text for endowment effects
tmp <- objEffects$functionName[objEffects$type =='endow']
@@ -301,7 +364,9 @@
{
nodeSet <- attr(depvar,'nodeSet')
- rateEffects <- createEffects("behaviorRate", varname)
+ rateEffects <- createEffects("behaviorRate", varname, name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
if (observations == 1)
{
rateEffects <- rateEffects[-2, ] ## remove the extra period
@@ -314,30 +379,48 @@
rateEffects[-c(1, 2), ])
}
- objEffects <- createEffects("behaviorObjective", varname)
+ objEffects <- createEffects("behaviorObjective", varname, name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
for (j in seq(along=xx$depvars))
{
if (types[j] == 'oneMode' &&
attr(xx$depvars[[j]], 'nodeSet') == nodeSet)
{
- objEffects <- rbind(objEffects,
- createEffects("behaviorOneModeObjective",
- varname, names(xx$depvars)[j]))
- rateEffects <- rbind(rateEffects,
- createEffects("behaviorOneModeRate",
- varname, names(xx$depvars)[j]))
+ objEffects <-
+ rbind(objEffects,
+ createEffects("behaviorOneModeObjective",
+ varname, names(xx$depvars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
+ rateEffects <-
+ rbind(rateEffects,
+ createEffects("behaviorOneModeRate",
+ varname, names(xx$depvars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
if (types[j] == 'bipartite' &&
(attr(xx$depvars[[j]], 'nodeSet')[1] == nodeSet))
{
- objEffects <- rbind(objEffects,
- createEffects("behaviorBipartiteObjective",
- varname, names(xx$depvars)[j]))
- rateEffects <- rbind(rateEffects,
- createEffects("behaviorBipartiteRate",
- varname, names(xx$depvars)[j]))
- }
+ objEffects <-
+ rbind(objEffects,
+ createEffects("behaviorBipartiteObjective",
+ varname, names(xx$depvars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
+ rateEffects <-
+ rbind(rateEffects,
+ createEffects("behaviorBipartiteRate",
+ varname, names(xx$depvars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
+ }
}
for (j in seq(along = xx$cCovars))
@@ -345,7 +428,7 @@
if (attr(xx$cCovars[[j]], 'nodeSet') == nodeSet)
{
tmp <- covBehEff(varname, names(xx$cCovars)[j], nodeSet,
- type='')
+ type='', name=varname)
objEffects<- rbind(objEffects, tmp$objEff)
rateEffects<- rbind(rateEffects, tmp$rateEff)
}
@@ -356,7 +439,7 @@
attr(xx$depvars[[j]], 'nodeSet') == nodeSet)
{
tmp <- covBehEff(varname, names(xx$depvars)[j], nodeSet, j==i,
- type='Beh')
+ type='Beh', name=varname)
objEffects<- rbind(objEffects, tmp$objEff)
rateEffects<- rbind(rateEffects, tmp$rateEff)
}
@@ -366,7 +449,7 @@
if (attr(xx$vCovars[[j]], 'nodeSet') == nodeSet)
{
tmp <- covBehEff(varname, names(xx$vCovars)[j], nodeSet,
- type='Var')
+ type='Var', name=varname)
objEffects<- rbind(objEffects, tmp$objEff)
rateEffects<- rbind(rateEffects, tmp$rateEff)
}
@@ -378,23 +461,31 @@
{
objEffects <- rbind(objEffects,
createEffects("behaviorOneModeObjective2",
- varname, names(xx$depvars)[j]))
+ varname, names(xx$depvars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
if (types[j] == 'bipartite' &&
attr(xx$depvars[[j]], 'nodeSet')[1] == nodeSet)
{
objEffects <- rbind(objEffects,
createEffects("behaviorBipartiteObjective2",
- varname, names(xx$depvars)[j]))
+ varname, names(xx$depvars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
interaction <- createEffects("unspecifiedBehaviorInteraction",
- varname)
- objEffects <- rbind(objEffects, interaction[rep(1, behNintn),])
+ varname, name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
+ objEffects <- rbind(objEffects, interaction[rep(1:2, behNintn),])
## now create the real effects, extra rows for endowment effects etc
- objEffects <- createObjEffectList(objEffects, varname)
- rateEffects <- createRateEffectList(rateEffects, varname)
+ ##objEffects <- createObjEffectList(objEffects, varname)
+ ##rateEffects <- createRateEffectList(rateEffects, varname)
## get starting values
starts <- getBehaviorStartingVals(depvar)
@@ -439,7 +530,10 @@
rateEffects <- networkRateEffects(depvar, varname, symmetric=FALSE,
bipartite=TRUE)
- objEffects <- createEffects("bipartiteObjective", varname)
+ objEffects <- createEffects("bipartiteObjective", varname,
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
for (j in seq(along = xx$dycCovars))
{
@@ -447,7 +541,10 @@
{
objEffects <- rbind(objEffects,
createEffects("dyadBipartiteObjective",
- names(xx$dycCovars)[j] ))
+ names(xx$dycCovars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
for (j in seq(along = xx$dyvCovars))
@@ -456,7 +553,10 @@
{
objEffects <- rbind(objEffects,
createEffects("dyadBipartiteObjective",
- names(xx$dyvCovars)[j]))
+ names(xx$dyvCovars)[j],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
for (j in seq(along = xx$cCovars))
@@ -470,7 +570,7 @@
'poszvar'),
attr(xx$cCovars[[j]],
'moreThan2'),
- covNodeset)
+ covNodeset, name=varname)
objEffects <- rbind(objEffects, tmp$objEff)
rateEffects <- rbind(rateEffects, tmp$rateEff)
}
@@ -487,7 +587,7 @@
poszvar=TRUE,
attr(xx$depvars[[j]],
'moreThan2'),
- covNodeset)
+ covNodeset, name=varname)
objEffects <- rbind(objEffects,tmp$objEff)
rateEffects <- rbind(rateEffects,tmp$rateEff)
}
@@ -504,7 +604,7 @@
'poszvar'),
attr(xx$vCovars[[j]],
'moreThan2'),
- covNodeset)
+ covNodeset, name=varname)
objEffects <- rbind(objEffects, tmp$objEff)
rateEffects <- rbind(rateEffects, tmp$rateEff)
}
@@ -514,7 +614,10 @@
length(xx$dycCovars) + length(xx$dyvCovars) +
length(types=='behavior') > 0)
{
- interaction <- createEffects("unspecifiedNetInteraction")
+ interaction <- createEffects("unspecifiedNetInteraction",
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType)
objEffects <- rbind(objEffects, interaction[rep(1, nintn), ])
}
@@ -529,14 +632,20 @@
objEffects <-
rbind(objEffects,
createEffects("bipartiteSymmetricObjective",
- names(xx$depvars)[[j]]))
+ names(xx$depvars)[[j]],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
else
{
objEffects <-
rbind(objEffects,
createEffects("bipartiteNonSymmetricObjective",
- names(xx$depvars)[[j]]))
+ names(xx$depvars)[[j]],
+ name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
}
}
if (types[j] == 'bipartite' &&
@@ -546,7 +655,10 @@
objEffects <-
rbind(objEffects,
createEffects("bipartiteBipartiteObjective",
- names(xx$depvars)[[j]]))
+ names(xx$depvars)[[j]],
+ name=varname,
+ groupName=groupName, group=group,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 126
More information about the Rsiena-commits
mailing list