[Rsiena-commits] r88 - in pkg/RSienaTest: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 28 19:27:57 CEST 2010
Author: jalospinoso
Date: 2010-05-28 19:27:56 +0200 (Fri, 28 May 2010)
New Revision: 88
Modified:
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaTimeTest.r
pkg/RSienaTest/R/simstatsc.r
pkg/RSienaTest/man/sienaTimeTest.Rd
Log:
Added sienaTimeTest functionality for RateX effects, including the includeTimeDummy() function.
Modified: pkg/RSienaTest/R/sienaDataCreate.r
===================================================================
--- pkg/RSienaTest/R/sienaDataCreate.r 2010-05-27 18:31:07 UTC (rev 87)
+++ pkg/RSienaTest/R/sienaDataCreate.r 2010-05-28 17:27:56 UTC (rev 88)
@@ -158,8 +158,39 @@
{
nm[fixup] <- dep
}
- dots <- list(...)
- names(dots) <- nm
+ ## Josh inserting this code: #####################################
+ ## Adding this list flattening routine so that sienaDataCreate can
+ ## accept a list of lists. Useful for expanding time dummies, etc.
+ ## Also attaches meaningful names to the flattened items.
+ listContainsList <- function (x) {
+ which(sapply(seq(along=x), function(i) class(x[[i]])=='list'))
+ }
+ args <- list(...)
+ toFlatten <- listContainsList(args)
+ if (length(toFlatten)>0) {
+ numberOfOldArgs <- length(args[-toFlatten])
+ numberOfNewArgs <- sum(sapply(toFlatten, function(i) length(args[[i]])))
+ flattened <- vector("list", numberOfNewArgs + numberOfOldArgs)
+ newNames <- rep("", numberOfNewArgs + numberOfOldArgs)
+ newNames[1:numberOfOldArgs] <- nm[-toFlatten]
+ flattened[seq(numberOfOldArgs)] <- args[-toFlatten]
+ count <- numberOfOldArgs
+ for (i in toFlatten) {
+ for (j in seq(along=args[[i]])) {
+ count = count + 1
+ flattened[[count]] <- args[[i]][[j]]
+ newNames[count] <- names(args[[i]][j])
+ }
+ }
+ names(flattened) <- newNames
+ narg <- length(flattened)
+ nm <- newNames
+ dots <- flattened
+ } else {
+ dots <- list(...)
+ }
+ ################################################################
+
if (any(duplicated(nm)))
{
stop('names must be unique')
Modified: pkg/RSienaTest/R/sienaTimeTest.r
===================================================================
--- pkg/RSienaTest/R/sienaTimeTest.r 2010-05-27 18:31:07 UTC (rev 87)
+++ pkg/RSienaTest/R/sienaTimeTest.r 2010-05-28 17:27:56 UTC (rev 88)
@@ -131,9 +131,10 @@
SF <- array(0, dim=c(nSims, observations - 1, nEffects + nDummies))
if (sum(dim(G[, , 1:nEffects]) != dim(moment))+
sum(dim(SF[, , 1:nEffects]) != dim(scores))>0) {
- stop("The moments and scores in your sienaFit have unexpected dimensions.
- It is possible that your model specifications are not yet implemented
- in sienaTimeTest. Please contact the developers")
+ stop("The moments and scores in your sienaFit have unexpected dimensions.\n
+ It is possible that your model specifications are not yet implemented\n
+ in sienaTimeTest. Please contact the developers.\n\nDid you include
+ the base effect?\n")
}
## Will be used to construct the dummy names for output
dummyNames <- rep("", nDummies)
@@ -559,12 +560,12 @@
# warning("Time dummy not implemented for covariate effects")
# effects$timeDummy[covar] <- ","
# }
- eval <- effects$type =="eval"
- if (any(effects$timeDummy[!eval] !=','))
+ implemented <- (effects$type == "eval" | effects$shortName == "RateX")
+ if (any(effects$timeDummy[!implemented] !=','))
{
warning("Time dummy effects are only implemented",
- " for one mode network effects of type eval.")
- effects$timeDummy[!eval] <- ","
+ " for one mode network effects of type eval or for RateX.")
+ effects$timeDummy[!implemented] <- ","
}
if (all(effects$timeDummy==',') )
{
@@ -573,6 +574,7 @@
}
else
{
+## One mode, eval effects, or RateX effects:
alreadyDummied <- grep("isDummy", effects$timeDummy)
effects$timeDummy[effects$timeDummy=="all"] <-
paste(2:(data$observations-1), collapse = ",")
@@ -583,8 +585,9 @@
## all of the previous dummied effects within the column.
effects <- effects[-alreadyDummied, ]
}
- dummiedEffects <- effects$effectNumber[effects$timeDummy != ',']
+ dummiedEffects <- effects$effectNumber[effects$timeDummy != ',' & (effects$type=='eval' | effects$shortName=='RateX')]
covToAdd <- NULL
+ rateCovToAdd <- NULL
dummyCombos <- list()
ctr=1
## This might need to be changed for sienaGroup:
@@ -611,9 +614,49 @@
}
if (length(tmp) > 0)
{
- dummyCombos[[ctr]]=list(effectNumber=i, periods=tmp)
- ctr=ctr + 1
- covToAdd <- unique(c(covToAdd, tmp))
+ if (effects$type[effects$effectNumber==i]=='eval') {
+ dummyCombos[[ctr]]=list(effectNumber=i, periods=tmp)
+ ctr=ctr + 1
+ covToAdd <- unique(c(covToAdd, tmp))
+ } else if (effects$shortName[effects$effectNumber==i]=='RateX') {
+ ## RateX effect, has to be dealt with differently. Just add them now:
+ for (p in tmp) {
+ dname <- paste(effects$interaction1[effects$effectNumber==i],
+ "Dummy",p,sep="")
+ base <- matrix(0,nact,nper-1)
+ ## Figure out the base values:
+ dvind <- which(names(data$cCovars) ==
+ effects$interaction1[effects$effectNumber==i])
+ ## Stick them into the right time spot
+ base[,p] <- data$cCovars[[dvind]]
+ ## make a new varCovar:
+ base <- varCovar(base)
+ base <- addAttributes.varCovar(base, name=dname)
+ data$vCovars[[length(data$vCovars)+1]] <- base
+ names(data$vCovars)[length(data$vCovars)] <- dname
+ ## Now add the rate term:
+ tmprow <- allEffects[allEffects$functionName==
+ 'Amount of change x xxxxxx' & allEffects$type=='rate'
+ & allEffects$effectGroup=='covarNonSymmetricRate', ]
+ tmprow$name <- effects$name[effects$shortName=='RateX' &
+ effects$type=='rate'][1]
+ tmprow$effectFn <- 'NULL'
+ tmprow$statisticFn <- 'NULL'
+ tmprow$netType <- 'oneMode'
+ tmprow$groupName <- 'Group1'
+ tmprow$group <- 1
+ tmprow$fix <- FALSE
+ tmprow$include <- TRUE
+ tmprow$effectNumber <- max(effects$effectNumber) + 1
+ tmprow <- tmprow[, colnames(effects)]
+ tmprow$effectName <- gsub('xxxxxx', dname, tmprow$effectName)
+ tmprow$functionName <- gsub('xxxxxx', dname, tmprow$functionName)
+ tmprow$interaction1 <- dname
+ tmprow$timeDummy <- paste('isDummy', p, i, sep=',')
+ rownames(tmprow) <- dname
+ effects <- rbind(effects, tmprow)
+ }
+ }
}
}
## Add the required covariate effects to the effect objects
@@ -651,10 +694,10 @@
rownames(tmprow) <- dname
effects <- rbind(effects, tmprow)
}
- for (i in 1:length(dummyCombos))
+ for (i in seq(along=dummyCombos))
{
baseNum=dummyCombos[[i]]$effectNumber
- for (j in 1:length(dummyCombos[[i]]$periods))
+ for (j in seq(along=dummyCombos[[i]]$periods))
{
dname <- paste("Dummy", dummyCombos[[i]]$periods[j], sep="")
dummyNum <- effects$effectNumber[rownames(effects)==dname]
Modified: pkg/RSienaTest/R/simstatsc.r
===================================================================
--- pkg/RSienaTest/R/simstatsc.r 2010-05-27 18:31:07 UTC (rev 87)
+++ pkg/RSienaTest/R/simstatsc.r 2010-05-28 17:27:56 UTC (rev 88)
@@ -1100,8 +1100,12 @@
}
if (inter1$type != inter2$type)
{
- stop("invalid interaction specification: ",
- "must be same type: evaluation or endowment")
+ warning("Interaction specification gives effects ",
+ "with different specifications eval/endow/rate ",
+ "trying with experimental code. Remove these ",
+ "Interactions if this does not work.")
+## stop("invalid interaction specification: ",
+## "must be same type: evaluation or endowment")
}
}
else
Modified: pkg/RSienaTest/man/sienaTimeTest.Rd
===================================================================
--- pkg/RSienaTest/man/sienaTimeTest.Rd 2010-05-27 18:31:07 UTC (rev 87)
+++ pkg/RSienaTest/man/sienaTimeTest.Rd 2010-05-28 17:27:56 UTC (rev 88)
@@ -28,7 +28,8 @@
timetest <- sienaTimeTest(sienaFit)
\method{plot}{sienaTimeTest}(x, pairwise=FALSE, effects=1:2,
dims=c(2, 1), scale=.2, plevels=c(.1, .05, .025), multiplot=FALSE, ...)
-myeffects <- includeTimeDummy(sienaEffects, outdegree, timeDummy="all")
+myeffects <- includeTimeDummy(sienaEffects, outdegree,
+ timeDummy="all", type="eval")
}
\arguments{
\item{sienaFit}{ A sienaFit object returned by \code{siena07}. }
@@ -167,5 +168,20 @@
## Time test plots show
plot(ttp, effects=1:4, dims=c(2,2))
}
+## A demonstration of RateX heterogeneity. Note that rate
+## interactions are not implemented in general, just for
+## Rate x cCovar.
+\dontrun{
+mymodel <- sienaModelCreate(fn=simstats0c, nsub=2, n3=100)
+mynet1 <- sienaNet(array(c(s501, s502, s503), dim=c(50, 50, 3)))
+myccov <- coCovar(s50a[,1])
+mydata <- sienaDataCreate(mynet1, myccov)
+myeff <- getEffects(mydata)
+myeff <- includeEffects(myeff, transTrip, balance)
+myeff <- includeEffects(myeff, RateX, type="rate",
+ interaction1="myccov")
+myeff <- includeTimeDummy(myeff, RateX, type="rate",
+ interaction1="myccov")
+ans <- siena07(mymodel, data=mydata, effects=myeff, batch=TRUE)
}
\keyword{models}
More information about the Rsiena-commits
mailing list