[Rsiena-commits] r158 - in pkg: RSiena RSiena/R RSiena/data RSiena/inst/doc RSiena/man RSiena/src/model/effects RSiena/src/model/variables RSienaTest RSienaTest/R RSienaTest/data RSienaTest/doc RSienaTest/inst/doc RSienaTest/inst/examples RSienaTest/man RSienaTest/src/model/effects RSienaTest/src/model/variables
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jun 22 20:57:43 CEST 2011
Author: ripleyrm
Date: 2011-06-22 20:57:42 +0200 (Wed, 22 Jun 2011)
New Revision: 158
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/R/effects.r
pkg/RSiena/R/effectsMethods.r
pkg/RSiena/R/initializeFRAN.r
pkg/RSiena/R/sienaTimeTest.r
pkg/RSiena/changeLog
pkg/RSiena/data/allEffects.csv
pkg/RSiena/inst/doc/RSiena_Manual.pdf
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/src/model/effects/AllEffects.h
pkg/RSiena/src/model/effects/AltersCovariateAverageEffect.cpp
pkg/RSiena/src/model/effects/AltersCovariateAverageEffect.h
pkg/RSiena/src/model/effects/AverageAlterEffect.cpp
pkg/RSiena/src/model/effects/AverageAlterEffect.h
pkg/RSiena/src/model/effects/BehaviorEffect.cpp
pkg/RSiena/src/model/effects/BehaviorEffect.h
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/effects/IndegreeEffect.cpp
pkg/RSiena/src/model/effects/IndegreeEffect.h
pkg/RSiena/src/model/effects/InteractionCovariateEffect.cpp
pkg/RSiena/src/model/effects/InteractionCovariateEffect.h
pkg/RSiena/src/model/effects/LinearShapeEffect.cpp
pkg/RSiena/src/model/effects/LinearShapeEffect.h
pkg/RSiena/src/model/effects/MainCovariateEffect.cpp
pkg/RSiena/src/model/effects/MainCovariateEffect.h
pkg/RSiena/src/model/effects/OutdegreeEffect.cpp
pkg/RSiena/src/model/effects/OutdegreeEffect.h
pkg/RSiena/src/model/effects/SimilarityEffect.cpp
pkg/RSiena/src/model/effects/SimilarityEffect.h
pkg/RSiena/src/model/variables/BehaviorVariable.cpp
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/effectsMethods.r
pkg/RSienaTest/R/initializeFRAN.r
pkg/RSienaTest/R/sienaTimeTest.r
pkg/RSienaTest/changeLog
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/doc/RSienaDeveloper.tex
pkg/RSienaTest/doc/RSiena_Manual.tex
pkg/RSienaTest/doc/Siena_algorithms4.tex
pkg/RSienaTest/doc/sienaTimeFixDoc.tex
pkg/RSienaTest/inst/doc/RSiena_Manual.pdf
pkg/RSienaTest/inst/examples/runalg.r
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/src/model/effects/AllEffects.h
pkg/RSienaTest/src/model/effects/AltersCovariateAverageEffect.cpp
pkg/RSienaTest/src/model/effects/AltersCovariateAverageEffect.h
pkg/RSienaTest/src/model/effects/AverageAlterEffect.cpp
pkg/RSienaTest/src/model/effects/AverageAlterEffect.h
pkg/RSienaTest/src/model/effects/BehaviorEffect.cpp
pkg/RSienaTest/src/model/effects/BehaviorEffect.h
pkg/RSienaTest/src/model/effects/EffectFactory.cpp
pkg/RSienaTest/src/model/effects/IndegreeEffect.cpp
pkg/RSienaTest/src/model/effects/IndegreeEffect.h
pkg/RSienaTest/src/model/effects/InteractionCovariateEffect.cpp
pkg/RSienaTest/src/model/effects/InteractionCovariateEffect.h
pkg/RSienaTest/src/model/effects/LinearShapeEffect.cpp
pkg/RSienaTest/src/model/effects/LinearShapeEffect.h
pkg/RSienaTest/src/model/effects/MainCovariateEffect.cpp
pkg/RSienaTest/src/model/effects/MainCovariateEffect.h
pkg/RSienaTest/src/model/effects/OutdegreeEffect.cpp
pkg/RSienaTest/src/model/effects/OutdegreeEffect.h
pkg/RSienaTest/src/model/effects/SimilarityEffect.cpp
pkg/RSienaTest/src/model/effects/SimilarityEffect.h
pkg/RSienaTest/src/model/variables/BehaviorVariable.cpp
Log:
Behavior interactions
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2011-06-18 23:40:21 UTC (rev 157)
+++ pkg/RSiena/DESCRIPTION 2011-06-22 18:57:42 UTC (rev 158)
@@ -1,8 +1,8 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.12.157
-Date: 2011-06-18
+Version: 1.0.12.158
+Date: 2011-06-22
Author: Various
Depends: R (>= 2.10.0)
Imports: Matrix
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2011-06-18 23:40:21 UTC (rev 157)
+++ pkg/RSiena/R/effects.r 2011-06-22 18:57:42 UTC (rev 158)
@@ -33,8 +33,8 @@
nameVectors
}
##@createEffects Extract required rows and change text
-createEffects <- function(effectGroup, xName=NULL, yName=NULL, name,
- groupName, group, netType)
+createEffects <- function(effectGroup, xName=NULL, yName=NULL, zName = NULL,
+ name, groupName, group, netType)
{
effects <- allEffects[allEffects$effectGroup == effectGroup, ]
if (nrow(effects) == 0)
@@ -45,7 +45,7 @@
{
stop("missing effect name")
}
- effects <- substituteNames(effects, xName, yName)
+ effects <- substituteNames(effects, xName, yName, zName)
effects$effectGroup <- NULL
nn <- nrow(effects)
if (!all(is.na(effects$endowment)))
@@ -218,7 +218,7 @@
name=varname,
groupName=groupName, group=group,
netType=netType)
- objEffects <- rbind(objEffects, interaction[rep(1:2, nintn), ])
+ objEffects <- rbind(objEffects, interaction[rep(1:3, nintn), ])
}
for (j in seq(along=xx$depvars))
@@ -303,9 +303,6 @@
objEffects$effectName <- paste(varname, ': ',
objEffects$effectName, sep = '')
}
- ## now create the real effects, extra rows for endowment effects etc
- #objEffects <- createObjEffectList(objEffects, varname)
- #rateEffects <- createRateEffectList(rateEffects, varname)
## replace the text for endowment and creation effects
tmp <- objEffects$functionName[objEffects$type =='endow']
@@ -449,39 +446,35 @@
rateEffects<- rbind(rateEffects, tmp$rateEff)
}
}
- for (j in seq(along=xx$depvars))
- {
- if (types[j] == 'oneMode' &&
- attr(xx$depvars[[j]], 'nodeSet') == nodeSet)
- {
- objEffects <- rbind(objEffects,
- createEffects("behaviorOneModeObjective2",
- 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],
- 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("behaviorOneModeObjective2",
+ ## 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],
+ ## name=varname,
+ ## groupName=groupName, group=group,
+ ## netType=netType))
+ ## }
+ ##}
interaction <- createEffects("unspecifiedBehaviorInteraction",
varname, name=varname,
groupName=groupName, group=group,
netType=netType)
- objEffects <- rbind(objEffects, interaction[rep(1:2, behNintn),])
+ objEffects <- rbind(objEffects, interaction[rep(1:3, behNintn),])
- ## now create the real effects, extra rows for endowment effects etc
- ##objEffects <- createObjEffectList(objEffects, varname)
- ##rateEffects <- createRateEffectList(rateEffects, varname)
-
## get starting values
starts <- getBehaviorStartingVals(depvar)
## set defaults
@@ -616,7 +609,7 @@
name=varname,
groupName=groupName, group=group,
netType=netType)
- objEffects <- rbind(objEffects, interaction[rep(1, nintn), ])
+ objEffects <- rbind(objEffects, interaction[rep(1:3, nintn), ])
}
for (j in seq(along=xx$depvars))
@@ -799,7 +792,6 @@
covObjEffects <- NULL
}
-
list(objEff=covObjEffects, rateEff=covRateEffects)
}
##@covBehEff internal getEffects
@@ -810,17 +802,16 @@
## type is no longer used
type=c('', 'Var', 'Beh'), name)
{
- objEffects <- createEffects("covarBehaviorObjective", varname,
- covarname, name=name,
- groupName=groupName, group=group,
- netType=netType)
covObjEffects <- NULL
if (!same)
{
- covObjEffects<- objEffects[objEffects$shortName == "effFrom", ]
+ covObjEffects <- createEffects("covarBehaviorObjective", varname,
+ covarname, name=name,
+ groupName=groupName, group=group,
+ netType=netType)
}
- covRateEffects <- createEffects("covarBehaviorRate", varname, covarname,
+ covRateEffects <- createEffects("covarBehaviorRate", varname, covarname,
name=name,
groupName=groupName, group=group,
netType=netType)
@@ -833,31 +824,26 @@
if (types[j] == 'oneMode' &&
attr(xx$depvars[[j]], 'nodeSet') == nodeSet)
{
- covObjEffects <-
- rbind(covObjEffects,
- substituteNames(objEffects[objEffects$shortName ==
- "inflIntX", ],
- zName=names(xx$depvars)[j]))
- }
- if ((types[j] =="oneMode" &&
- attr(xx$depvars[[j]], 'nodeSet') == nodeSet)
- || (types[j] == "bipartite" &&
+ newEffects <-
+ createEffects("covarBehaviorNetObjective", varname,
+ covarname, names(xx$depvars)[j],
+ groupName=groupName, group=group,
+ netType=netType, name=name)
+
+ covObjEffects <- rbind(covObjEffects, newEffects)
+ }
+ if ((types[j] == "bipartite" &&
attr(xx$depvars[[j]], 'nodeSet')[2] == nodeSet))
{
- covObjEffects <-
- rbind(covObjEffects,
- substituteNames(objEffects[objEffects$shortName ==
- "AltsAvAlt", ],
- zName=names(xx$depvars)[j]))
- }
+ newEffects <-
+ createEffects("covarBehaviorBipartiteObjective", varname,
+ covarname, names(xx$depvars)[j],
+ groupName=groupName, group=group,
+ netType=netType, name=name)
+ covObjEffects <- rbind(covObjEffects, newEffects)
+ }
}
}
- # if (!is.null(covObjEffects))
- # {
- # usestr <- paste("effFrom", type, sep="")
- # covObjEffects$shortName <-
- # sub("effFrom", usestr, covObjEffects$shortName)
- # }
list(objEff=covObjEffects, rateEff=covRateEffects)
}
Modified: pkg/RSiena/R/effectsMethods.r
===================================================================
--- pkg/RSiena/R/effectsMethods.r 2011-06-18 23:40:21 UTC (rev 157)
+++ pkg/RSiena/R/effectsMethods.r 2011-06-22 18:57:42 UTC (rev 158)
@@ -21,7 +21,7 @@
sink(fileName, split=TRUE)
}
- interactions <- x[x$shortName == "unspInt" & x$include &
+ interactions <- x[x$shortName %in% c("unspInt", "behUnspInt") & x$include &
x$effect1 > 0, ]
if (expandDummies)
{
Modified: pkg/RSiena/R/initializeFRAN.r
===================================================================
--- pkg/RSiena/R/initializeFRAN.r 2011-06-18 23:40:21 UTC (rev 157)
+++ pkg/RSiena/R/initializeFRAN.r 2011-06-22 18:57:42 UTC (rev 158)
@@ -114,8 +114,9 @@
data <- tmp$data
effects <- tmp$effects
## find any effects not included which are needed for interactions
- interactionNos <- unique(c(effects$effect1, effects$effect2,
- effects$effect3))
+ tmpEffects <- effects[effects$include, ]
+ interactionNos <- unique(c(tmpEffects$effect1, tmpEffects$effect2,
+ tmpEffects$effect3))
interactionNos <- interactionNos[interactionNos > 0]
interactions <- effects$effectNumber %in%
interactionNos
@@ -1632,118 +1633,215 @@
gsub("#", y$parm, y$functionName)
}, y=effects)
- if (any(effects$shortName == "behUnspInt" & effects$include &
- effects$effect1 > 0))
- {
- stop("User specified behavior interactions are not yet implemented")
- }
+ #if (any(effects$shortName == "behUnspInt" & effects$include &
+ # effects$effect1 > 0))
+ #{
+ # stop("User specified behavior interactions are not yet implemented")
+ #}
##validate user-specified network interactions
interactions <- effects[effects$shortName == "unspInt" & effects$include &
effects$effect1 > 0, ]
if (nrow(interactions) > 0)
{
- unspIntNames <- sapply(1:nrow(interactions), function(x, y, z)
- {
- y <- y[x, ] ## get the interaction effect
- twoway <- y$effect3 == 0
- ## now get the rows which are to interact
- inter1 <- z[z$effectNumber == y$effect1, ]
- if (nrow(inter1) != 1 )
+ unspIntNames <-
+ sapply(1:nrow(interactions), function(x, y, z)
{
- stop("invalid interaction specification effect number 1")
- }
- inter2 <- z[z$effectNumber == y$effect2, ]
- if (nrow(inter2) != 1 )
- {
- stop("invalid interaction specification effect number 2")
- }
- if (!twoway)
- {
- inter3 <- z[z$effectNumber == y$effect3, ]
- if (nrow(inter3) != 1)
+ y <- y[x, ] ## get the interaction effect
+ twoway <- y$effect3 == 0
+ ## now get the rows which are to interact
+ inter1 <- z[z$effectNumber == y$effect1, ]
+ if (nrow(inter1) != 1 )
{
- stop("invalid interaction specification effect number 3")
+ stop("invalid network interaction specification: ",
+ "effect number 1")
}
- }
- else
- {
- inter3 <- z[is.na(z$effectNumber),] ## should be empty row
- }
- if (twoway)
- {
- if (inter1$name != inter2$name)
+ inter2 <- z[z$effectNumber == y$effect2, ]
+ if (nrow(inter2) != 1 )
{
- stop("invalid interaction specification: ",
- "must be same network")
+ stop("invalid network interaction specification: ",
+ "effect number 2")
}
- if (inter1$type != inter2$type)
+ if (!twoway)
{
- # 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, endowment or creation")
+ inter3 <- z[z$effectNumber == y$effect3, ]
+ if (nrow(inter3) != 1)
+ {
+ stop("invalid network interaction specification: ",
+ "effect number 3")
+ }
}
- }
- else
- {
- if (inter1$name != inter2$name ||
- inter1$name != inter3$name)
+ else
{
- stop("invalid interaction specification:",
- "must all be same network")
+ inter3 <- z[is.na(z$effectNumber), ]
+ ## should be empty row
}
- if (inter1$type != inter2$type ||
- inter1$type != inter3$type)
+ if (twoway)
{
- stop("invalid interaction specification: must all be",
- "same type: evaluation, endowment or creation")
+ if (inter1$name != inter2$name)
+ {
+ stop("invalid network interaction specification: ",
+ "must all be same network")
+ }
+ if (inter1$type != inter2$type)
+ {
+ stop("invalid network interaction specification: ",
+ "must all be same type: ",
+ "evaluation, endowment or creation")
+ }
}
- }
- ## check types
- inters <- rbind(inter1, inter2, inter3)
- egos <- which(inters$interactionType == "ego")
- egoCount <- length(egos)
- dyads <- which(inters$interactionType == "dyadic")
- dyadCount <- length(dyads)
- if (twoway)
- {
- if (egoCount < 1 && dyadCount != 2)
+ else
{
- stop("invalid interaction specification:",
- "must be at least one ego or both dyadic effects")
+ if (inter1$name != inter2$name ||
+ inter1$name != inter3$name)
+ {
+ stop("invalid network interaction specification: ",
+ "must all be same network")
+ }
+ if (inter1$type != inter2$type ||
+ inter1$type != inter3$type)
+ {
+ stop("invalid network interaction specification: ",
+ "must all be ",
+ "same type: evaluation, endowment or creation ")
+ }
}
- }
- else
- {
- if (egoCount < 2 && dyadCount != 3)
+ ## check types
+ inters <- rbind(inter1, inter2, inter3)
+ egos <- which(inters$interactionType == "ego")
+ egoCount <- length(egos)
+ dyads <- which(inters$interactionType == "dyadic")
+ dyadCount <- length(dyads)
+ if (twoway)
{
- stop("invalid interaction specification:",
- "must be at least two ego or all dyadic effects")
+ if (egoCount < 1 && dyadCount != 2)
+ {
+ stop("invalid network interaction specification: ",
+ "must be at least one ego or both dyadic ",
+ "effects")
+ }
}
- }
- ## construct a name
- ### make sure the egos are at the front of inters
- if (egoCount > 0)
- {
- inters <- rbind(inters[egos, ], inters[-egos, ])
- }
- tmpname <- paste(inters$effectName, collapse = " x ")
- if (twoway && nchar(tmpname) < 38)
- {
- tmpname <- paste("int. ", tmpname)
- }
- if (!twoway)
- {
- tmpname <- paste("i3.", tmpname)
- }
- tmpname
- }, y=interactions, z=effects)
+ else
+ {
+ if (egoCount < 2 && dyadCount != 3)
+ {
+ stop("invalid network interaction specification: ",
+ "must be at least two ego or all dyadic ",
+ "effects")
+ }
+ }
+ ## construct a name
+ ## make sure the egos are at the front of inters
+ if (egoCount > 0)
+ {
+ inters <- rbind(inters[egos, ], inters[-egos, ])
+ }
+ tmpname <- paste(inters$effectName, collapse = " x ")
+ if (twoway && nchar(tmpname) < 38)
+ {
+ tmpname <- paste("int. ", tmpname)
+ }
+ if (!twoway)
+ {
+ tmpname <- paste("i3.", tmpname)
+ }
+ tmpname
+ }, y=interactions, z=effects)
effects[effects$shortName == "unspInt" & effects$include &
!is.na(effects$effect1), c("effectName", "functionName")] <-
unspIntNames
}
+ ##validate user-specified behavior interactions
+ interactions <- effects[effects$shortName == "behUnspInt" &
+ effects$include &
+ effects$effect1 > 0, ]
+ if (nrow(interactions) > 0)
+ {
+ unspIntNames <-
+ sapply(1:nrow(interactions), function(x, y, z)
+ {
+ y <- y[x, ] ## get the interaction effect
+ twoway <- y$effect3 == 0
+ ## now get the rows which are to interact
+ inter1 <- z[z$effectNumber == y$effect1, ]
+ if (nrow(inter1) != 1 )
+ {
+ stop("invalid behavior interaction specification: ",
+ "effect number 1")
+ }
+ inter2 <- z[z$effectNumber == y$effect2, ]
+ if (nrow(inter2) != 1 )
+ {
+ stop("invalid behavior interaction specification: ",
+ "effect number 2")
+ }
+ if (!twoway)
+ {
+ inter3 <- z[z$effectNumber == y$effect3, ]
+ if (nrow(inter3) != 1)
+ {
+ stop("invalid behavior interaction specification: ",
+ "effect number 3")
+ }
+ }
+ else
+ {
+ inter3 <- z[is.na(z$effectNumber), ]
+ ## should be empty row
+ }
+ if (twoway)
+ {
+ if (inter1$name != inter2$name)
+ {
+ stop("invalid behavior interaction specification: ",
+ "must all be same behavior variable")
+ }
+ if (inter1$type != inter2$type)
+ {
+ stop("invalid behavior interaction specification: ",
+ "must be same type: evaluation, endowment ",
+ "or creation")
+ }
+ }
+ else
+ {
+ if (inter1$name != inter2$name ||
+ inter1$name != inter3$name)
+ {
+ stop("invalid behavior interaction specification: ",
+ "must all be same behavior variable")
+ }
+ if (inter1$type != inter2$type ||
+ inter1$type != inter3$type)
+ {
+ stop("invalid behavior interaction specification: ",
+ "must all be ",
+ "same type: evaluation, endowment or creation")
+ }
+ }
+ ## check types - all should be OK here
+ inters <- rbind(inter1, inter2, inter3)
+ if (any(inters$interactionType != "OK"))
+ {
+ stop("invalid behavior interaction specification: ",
+ "only effects with interactionType OK are allowed")
+ }
+ ## construct a name
+ tmpname <- paste(inters$effectName, collapse = " x ")
+ if (twoway && nchar(tmpname) < 38)
+ {
+ tmpname <- paste("int. ", tmpname)
+ }
+ if (!twoway)
+ {
+ tmpname <- paste("i3.", tmpname)
+ }
+ tmpname
+ }, y=interactions, z=effects)
+ effects[effects$shortName == "behUnspInt" & effects$include &
+ !is.na(effects$effect1), c("effectName", "functionName")] <-
+ unspIntNames
+ }
effects
}
+
Modified: pkg/RSiena/R/sienaTimeTest.r
===================================================================
--- pkg/RSiena/R/sienaTimeTest.r 2011-06-18 23:40:21 UTC (rev 157)
+++ pkg/RSiena/R/sienaTimeTest.r 2011-06-22 18:57:42 UTC (rev 158)
@@ -29,8 +29,8 @@
fitEffects <- sienaFit$requestedEffects
- # There must be more than 2 observations (more than 1 wave)
- # to do a time test!
+ ## There must be more than 2 observations (more than 1 wave)
+ ## to do a time test!
if (nWaves < 2)
{
stop("You must have at least three time periods to test ",
@@ -62,10 +62,10 @@
{
use <- !fitEffects$basicRate
}
- # if (sienaFit$maxlike || sienaFit$FinDiff.method)
- # {
- # stop("Not yet implemented for finite differences or maxlike")
- # }
+ ## if (sienaFit$maxlike || sienaFit$FinDiff.method)
+ ## {
+ ## stop("Not yet implemented for finite differences or maxlike")
+ ## }
## Identify the effects which will potentially be tested
baseInFit <- use & !grepl("Dummy", fitEffects$effectName)
@@ -76,7 +76,7 @@
}
fixedDummies <- fitEffects$shortName=='egoX' &
- fitEffects$fix & grepl("Dummy", fitEffects$effectName)
+ fitEffects$fix & grepl("Dummy", fitEffects$effectName)
## establish effects for top left of derivative matrix D
estimatedInFit <- use & !fixedDummies
@@ -120,10 +120,10 @@
## index for the base effect and a time period, so store
## this information in rowInD -- this is used
## extensively in plot.sienaTimeTest
- toTest[thisRow, "rowInD"] <-
+ toTest[thisRow, "rowInD"] <-
match(fitEffects$effectNumber[i],
topleftEffectNumbers)
- }
+ }
}
## nEffects, nSims, nameslist, nDummies convert commonly used ingredients
## from sienaFit into an easily accessed form based on the screens
@@ -225,16 +225,17 @@
rownames(jointTestP) <- "Joint Significant Test"
colnames(jointTestP) <- "p-Val"
thetaOneStep <- c(sienaFit$theta[estimatedInFit], rep(0, nDummies)) +
- jointTest$oneStep
- effectTest <- as.vector(by(toTest, toTest$baseEffect, function (x)
- {
- doTests <- rep(FALSE, nEffects + nDummies)
- if (any(x$toTest))
- {
- doTests[toTest$baseEffect == x$baseEffect &
- toTest$toTest] <- TRUE
- test <- ScoreTest(nEffects + nDummies, D, sigma, fra,
- doTests, FALSE)
+ jointTest$oneStep
+ effectTest <-
+ as.vector(by(toTest, toTest$baseEffect, function (x)
+ {
+ doTests <- rep(FALSE, nEffects + nDummies)
+ if (any(x$toTest))
+ {
+ doTests[toTest$baseEffect == x$baseEffect &
+ toTest$toTest] <- TRUE
+ test <- ScoreTest(nEffects + nDummies, D, sigma, fra,
+ doTests, FALSE)
test$testresOverall
}
else
@@ -253,9 +254,9 @@
round(c(2 * (1 -
pnorm(abs(sienaFit$theta[estimatedInFit] /
sqrt(diag(sienaFit$covtheta)[estimatedInFit])))),
- individualTestP), 5)
+ individualTestP), 5)
thetaStar <- cbind(c(sienaFit$theta[estimatedInFit], rep(0, nDummies)),
- thetaOneStep, pvalues)
+ thetaOneStep, pvalues)
colnames(thetaStar) <- c("Initial Est.", "One Step Est.", "p-Value")
rownames(thetaStar) <- dimnames(G)[[3]]
## put things on toTest to make plot easier
@@ -294,7 +295,8 @@
sqrt(diag(sienaFit$covtheta))[estimatedInFit],
ToTest=toTest,
ScreenedEffects=which(!use),
- WaveNumbers=waveNumbers
+ WaveNumbers=waveNumbers,
+ IndividualTestsOrthogonalized=condition
)
class(returnObj) <- "sienaTimeTest"
returnObj
@@ -323,12 +325,20 @@
cat("\nParameter-wise joint significance tests (i.e. each
parameter across all dummies):\n")
print(x$EffectTest)
- if (x$Waves <=2)
+ if (x$Waves <=2 && ! x$IndividualTestsOrthogonalized)
{
cat("\n\nNote that these parameter-wise tests have a different
form than the individual tests, thus testing with 3 observations
may yield different individual and parameter-wise values.\n\n")
}
+ else
+ {
+ if (x$IndividualTestsOrthogonalized)
+ {
+ cat("\nNote that the individual test statistics were orthogonalized",
+ " with respect to each other (condition=TRUE).")
+ }
+ }
tmp <- paste(" (", 1:length(x$BaseRowInD), ") ",
rownames(x$IndividualTest)[x$BaseRowInD], "\n", sep="")
cat("\n2. Use the following indices for plotting:\n", tmp)
@@ -488,9 +498,9 @@
{
##@addEffect internal sienaTimeFix add one or more effects
addEffect <- function(newEffects, i, newname, effectGroup, shortName,
- timeDummy, fix=FALSE, include=TRUE)
+ timeDummy, fix=FALSE, include=TRUE, yName=NULL)
{
- tmprows <- createEffects(effectGroup, xName=newname,
+ tmprows <- createEffects(effectGroup, xName=newname, yName=yName,
name=effects$name[i][1],
groupName=effects$groupName[i][1],
group=effects$group[i][1],
@@ -499,7 +509,8 @@
tmprows$type %in% effects$type[i], ]
tmprows$fix <- fix
tmprows$include <- include
- tmprows$effectNumber <- max(newEffects$effectNumber) + (1:nrow(tmprows))
+ tmprows$effectNumber <- max(newEffects$effectNumber) +
+ (1:nrow(tmprows))
tmprows$timeDummy <- timeDummy
rownames(tmprows) <- paste(newname, effects$type[i], sep=".")
newEffects <- rbind(newEffects, tmprows)
@@ -541,34 +552,24 @@
effects$timeDummy <- ","
}
- # Josh tested these covariate effects, they work as-is for sienaTimeFix.
- # covar <- effects$interaction1 != ""
- # if (any(effects$timeDummy[covar] != ","))
- # {
- # warning("Time dummy not implemented for covariate effects")
- # effects$timeDummy[covar] <- ","
- # }
- # implemented <- (effects$type == "eval" | effects$shortName == "RateX")
-# if (any(effects$timeDummy[!implemented] !=","))
-# {
-# warning("Time dummy effects are only implemented",
-# " for network effects of type eval or for RateX.")
-# effects$timeDummy[!implemented] <- ","
-# }
- structuralRate <- effects$type == "rate" & effects$rateType %in% "structural"
+ structuralRate <- effects$type == "rate" & effects$rateType %in%
+ "structural"
if (any(effects$timeDummy[structuralRate] != ","))
{
warning("Time dummy effects are not implemented",
" for structural rate effects.")
effects$timeDummy[structuralRate] <- ","
}
- behaviorNonRateX <- effects$netType =="behavior" & effects$type != "rate"
- if (any(effects$timeDummy[behaviorNonRateX] != ","))
- {
- warning("Time dummy effects are not implemented",
- " for behavior effects of type eval or endow.")
- effects$timeDummy[behaviorNonRateX] <- ","
- }
+ # JAL: Implementing these 20-FEB-2011 in RSeinaTest
+ # TODO: Behavioral interactions need to be implemented for these to work.
+ # Once they are, we can comment lines 575-577 and 717-720 out.
+ ## behaviorNonRateX <- effects$netType =="behavior" & effects$type != "rate"
+ ## if (any(effects$timeDummy[behaviorNonRateX] != ","))
+ ## {
+## warning("Time dummy effects are not implemented",
+## " for behavior effects of type eval or endow.")
+## effects$timeDummy[behaviorNonRateX] <- ","
+## }
if (all(effects$timeDummy == ",") )
{
@@ -603,6 +604,10 @@
timesd <- lapply(timesd, function(x)as.numeric(x[x %in% periodNos]))
dummiedEffects <- sapply(timesd, function(x)length(x) > 0)
+ baseType <- list(number=which(dummiedEffects),
+ type=effects$netType[dummiedEffects],
+ name=effects$name[dummiedEffects])
+
rateXDummies <- effects$shortName == "RateX" & dummiedEffects
newEffects <- effects
@@ -637,7 +642,7 @@
vdvind <- match(effect$interaction1, atts$vCovars)
bdvind <- match(effect$interaction1, atts$netnames)
if (is.na(cdvind) && is.na(vdvind) &&
- (is.na(bdvind) || atts$types[bdvind] != "behavior"))
+ (is.na(bdvind))) #|| atts$types[bdvind] != "behavior"))
{
stop("Having trouble finding the covariate for your rate ",
"effect. Please contact the developers.")
@@ -702,10 +707,10 @@
types <- unique(effects$type[use ])
for (depvar in names(timeslist))
{
- if (!is.null(data) && atts$types[[depvar]] == "behavior")
- {
- stop ("Function is not specified for behavior effects")
- }
+ ##if (!is.null(data) && atts$types[[depvar]] == "behavior")
+ ##{
+ ## stop ("Function is not specified for behavior effects")
+ ##}
for (p in timeslist[[depvar]])
{
## create the dummy covariate
@@ -742,29 +747,62 @@
}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 158
More information about the Rsiena-commits
mailing list