[Rsiena-commits] r43 - in pkg/RSiena: . R data inst/doc man src src/model src/model/effects src/model/effects/generic src/model/variables tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jan 18 20:42:52 CET 2010
Author: ripleyrm
Date: 2010-01-18 20:42:50 +0100 (Mon, 18 Jan 2010)
New Revision: 43
Added:
pkg/RSiena/R/sienaeffects.r
pkg/RSiena/man/includeEffects.Rd
pkg/RSiena/man/includeInteraction.Rd
pkg/RSiena/man/setEffect.Rd
pkg/RSiena/src/model/effects/AverageReciprocatedAlterEffect.cpp
pkg/RSiena/src/model/effects/AverageReciprocatedAlterEffect.h
pkg/RSiena/src/model/effects/CovariateDependentBehaviorEffect.cpp
pkg/RSiena/src/model/effects/CovariateDependentBehaviorEffect.h
pkg/RSiena/src/model/effects/DenseTriadsBehaviorEffect.cpp
pkg/RSiena/src/model/effects/DenseTriadsBehaviorEffect.h
pkg/RSiena/src/model/effects/DenseTriadsSimilarityEffect.cpp
pkg/RSiena/src/model/effects/DenseTriadsSimilarityEffect.h
pkg/RSiena/src/model/effects/InteractionCovariateEffect.cpp
pkg/RSiena/src/model/effects/InteractionCovariateEffect.h
pkg/RSiena/src/model/effects/IsolateEffect.cpp
pkg/RSiena/src/model/effects/IsolateEffect.h
pkg/RSiena/src/model/effects/MainCovariateEffect.cpp
pkg/RSiena/src/model/effects/MainCovariateEffect.h
pkg/RSiena/src/model/effects/NetworkInteractionEffect.cpp
pkg/RSiena/src/model/effects/NetworkInteractionEffect.h
pkg/RSiena/src/model/effects/PopularityAlterEffect.cpp
pkg/RSiena/src/model/effects/PopularityAlterEffect.h
pkg/RSiena/src/model/effects/ReciprocalDegreeBehaviorEffect.cpp
pkg/RSiena/src/model/effects/ReciprocalDegreeBehaviorEffect.h
pkg/RSiena/src/model/effects/ReciprocatedSimilarityEffect.cpp
pkg/RSiena/src/model/effects/ReciprocatedSimilarityEffect.h
pkg/RSiena/src/model/effects/SimilarityEffect.cpp
pkg/RSiena/src/model/effects/SimilarityEffect.h
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/NAMESPACE
pkg/RSiena/R/Sienatest.r
pkg/RSiena/R/effects.r
pkg/RSiena/R/print07Report.r
pkg/RSiena/R/printDataReport.r
pkg/RSiena/R/siena01.r
pkg/RSiena/R/simstatsc.r
pkg/RSiena/changeLog
pkg/RSiena/data/allEffects.csv
pkg/RSiena/inst/doc/s_man400.pdf
pkg/RSiena/man/getEffects.Rd
pkg/RSiena/src/model/EffectInfo.cpp
pkg/RSiena/src/model/EffectInfo.h
pkg/RSiena/src/model/Model.cpp
pkg/RSiena/src/model/Model.h
pkg/RSiena/src/model/effects/AllEffects.h
pkg/RSiena/src/model/effects/AverageAlterEffect.cpp
pkg/RSiena/src/model/effects/AverageAlterEffect.h
pkg/RSiena/src/model/effects/BalanceEffect.cpp
pkg/RSiena/src/model/effects/BalanceEffect.h
pkg/RSiena/src/model/effects/BehaviorEffect.cpp
pkg/RSiena/src/model/effects/BehaviorEffect.h
pkg/RSiena/src/model/effects/BetweennessEffect.cpp
pkg/RSiena/src/model/effects/BetweennessEffect.h
pkg/RSiena/src/model/effects/CovariateAlterEffect.cpp
pkg/RSiena/src/model/effects/CovariateAlterEffect.h
pkg/RSiena/src/model/effects/CovariateEgoAlterEffect.cpp
pkg/RSiena/src/model/effects/CovariateEgoAlterEffect.h
pkg/RSiena/src/model/effects/CovariateEgoEffect.cpp
pkg/RSiena/src/model/effects/CovariateEgoEffect.h
pkg/RSiena/src/model/effects/CovariateIndirectTiesEffect.cpp
pkg/RSiena/src/model/effects/CovariateIndirectTiesEffect.h
pkg/RSiena/src/model/effects/CovariateSimilarityEffect.cpp
pkg/RSiena/src/model/effects/CovariateSimilarityEffect.h
pkg/RSiena/src/model/effects/DenseTriadsEffect.cpp
pkg/RSiena/src/model/effects/DenseTriadsEffect.h
pkg/RSiena/src/model/effects/DensityEffect.cpp
pkg/RSiena/src/model/effects/DensityEffect.h
pkg/RSiena/src/model/effects/DistanceTwoEffect.cpp
pkg/RSiena/src/model/effects/DistanceTwoEffect.h
pkg/RSiena/src/model/effects/DyadicCovariateMainEffect.cpp
pkg/RSiena/src/model/effects/DyadicCovariateMainEffect.h
pkg/RSiena/src/model/effects/DyadicCovariateReciprocityEffect.cpp
pkg/RSiena/src/model/effects/DyadicCovariateReciprocityEffect.h
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/effects/FourCyclesEffect.cpp
pkg/RSiena/src/model/effects/FourCyclesEffect.h
pkg/RSiena/src/model/effects/HigherCovariateEffect.cpp
pkg/RSiena/src/model/effects/HigherCovariateEffect.h
pkg/RSiena/src/model/effects/InInDegreeAssortativityEffect.cpp
pkg/RSiena/src/model/effects/InInDegreeAssortativityEffect.h
pkg/RSiena/src/model/effects/InOutDegreeAssortativityEffect.cpp
pkg/RSiena/src/model/effects/InOutDegreeAssortativityEffect.h
pkg/RSiena/src/model/effects/IndegreeActivityEffect.cpp
pkg/RSiena/src/model/effects/IndegreeActivityEffect.h
pkg/RSiena/src/model/effects/IndegreeEffect.cpp
pkg/RSiena/src/model/effects/IndegreeEffect.h
pkg/RSiena/src/model/effects/IndegreePopularityEffect.cpp
pkg/RSiena/src/model/effects/IndegreePopularityEffect.h
pkg/RSiena/src/model/effects/InverseOutdegreeEffect.cpp
pkg/RSiena/src/model/effects/InverseOutdegreeEffect.h
pkg/RSiena/src/model/effects/InverseSquaredOutdegreeEffect.cpp
pkg/RSiena/src/model/effects/InverseSquaredOutdegreeEffect.h
pkg/RSiena/src/model/effects/LinearShapeEffect.cpp
pkg/RSiena/src/model/effects/LinearShapeEffect.h
pkg/RSiena/src/model/effects/NetworkEffect.cpp
pkg/RSiena/src/model/effects/NetworkEffect.h
pkg/RSiena/src/model/effects/OutInDegreeAssortativityEffect.cpp
pkg/RSiena/src/model/effects/OutInDegreeAssortativityEffect.h
pkg/RSiena/src/model/effects/OutOutDegreeAssortativityEffect.cpp
pkg/RSiena/src/model/effects/OutOutDegreeAssortativityEffect.h
pkg/RSiena/src/model/effects/OutdegreeActivityEffect.cpp
pkg/RSiena/src/model/effects/OutdegreeActivityEffect.h
pkg/RSiena/src/model/effects/OutdegreeActivitySqrtEffect.cpp
pkg/RSiena/src/model/effects/OutdegreeActivitySqrtEffect.h
pkg/RSiena/src/model/effects/OutdegreeEffect.cpp
pkg/RSiena/src/model/effects/OutdegreeEffect.h
pkg/RSiena/src/model/effects/OutdegreePopularityEffect.cpp
pkg/RSiena/src/model/effects/OutdegreePopularityEffect.h
pkg/RSiena/src/model/effects/QuadraticShapeEffect.cpp
pkg/RSiena/src/model/effects/QuadraticShapeEffect.h
pkg/RSiena/src/model/effects/ReciprocityEffect.cpp
pkg/RSiena/src/model/effects/ReciprocityEffect.h
pkg/RSiena/src/model/effects/SameCovariateEffect.cpp
pkg/RSiena/src/model/effects/SameCovariateEffect.h
pkg/RSiena/src/model/effects/ThreeCyclesEffect.cpp
pkg/RSiena/src/model/effects/ThreeCyclesEffect.h
pkg/RSiena/src/model/effects/TransitiveMediatedTripletsEffect.cpp
pkg/RSiena/src/model/effects/TransitiveMediatedTripletsEffect.h
pkg/RSiena/src/model/effects/TransitiveTiesEffect.cpp
pkg/RSiena/src/model/effects/TransitiveTiesEffect.h
pkg/RSiena/src/model/effects/TransitiveTriadsEffect.cpp
pkg/RSiena/src/model/effects/TransitiveTriadsEffect.h
pkg/RSiena/src/model/effects/TransitiveTripletsEffect.cpp
pkg/RSiena/src/model/effects/TransitiveTripletsEffect.h
pkg/RSiena/src/model/effects/WWXClosureEffect.cpp
pkg/RSiena/src/model/effects/WWXClosureEffect.h
pkg/RSiena/src/model/effects/WXXClosureEffect.cpp
pkg/RSiena/src/model/effects/WXXClosureEffect.h
pkg/RSiena/src/model/effects/XWXClosureEffect.cpp
pkg/RSiena/src/model/effects/XWXClosureEffect.h
pkg/RSiena/src/model/effects/generic/GenericNetworkEffect.cpp
pkg/RSiena/src/model/effects/generic/GenericNetworkEffect.h
pkg/RSiena/src/model/variables/BehaviorVariable.cpp
pkg/RSiena/src/model/variables/BehaviorVariable.h
pkg/RSiena/src/siena07.cpp
pkg/RSiena/tests/parallel.R
Log:
1. new behavior effects
2. user-specified interactions
3. new utilities to update effects object
4. new version
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/DESCRIPTION 2010-01-18 19:42:50 UTC (rev 43)
@@ -1,12 +1,12 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.8
-Date: 2009-11-22
+Version: 1.0.9
+Date: 2010-01-18
Author: Various
Depends: R (>= 2.7.0), xtable
Imports: Matrix
-Suggests: tcltk, snow, rlecuyer, network, codetools
+Suggests: tcltk, rlecuyer, snow, network, codetools
SystemRequirements: GNU make, tcl/tk 8.5, Tktable
Maintainer: Ruth Ripley <ruth at stats.ox.ac.uk>
Description: Fits models to longitudinal networks
Modified: pkg/RSiena/NAMESPACE
===================================================================
--- pkg/RSiena/NAMESPACE 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/NAMESPACE 2010-01-18 19:42:50 UTC (rev 43)
@@ -2,7 +2,7 @@
export(coCovar, coDyadCovar, getEffects, model.create, print01Report,
siena01Gui, siena07, sienaCompositionChange,
sienaCompositionChangeFromFile, sienaDataCreate, sienaDataCreateFromSession,
-sienaGroupCreate, sienaModelCreate, sienaNet, sienaNodeSet, simstats0c, varCovar, varDyadCovar,
+sienaGroupCreate, sienaModelCreate, sienaNet, sienaNodeSet, simstats0c, varCovar, varDyadCovar, setEffect, includeEffects, includeInteraction,
installGui)#, sienaTimeTest)
import(Matrix)
Modified: pkg/RSiena/R/Sienatest.r
===================================================================
--- pkg/RSiena/R/Sienatest.r 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/R/Sienatest.r 2010-01-18 19:42:50 UTC (rev 43)
@@ -83,12 +83,13 @@
if (z$test[k])
{
j<- j+1
- Report(c(' (',j,') ',format(paste(z$effects$type[k],': ',
- z$effects$effectName[k],
- sep=''),
- width=50),' = ',
- sprintf("%8.4f",z$theta[k]),'\n'),
- sep = '', outf)
+ Report(c(" (",j,") ",
+ format(paste(z$requestedEffects$type[k], ": ",
+ z$requestedEffects$effectName[k],
+ sep=""),
+ width=50), " = ",
+ sprintf("%8.4f",z$theta[k]),"\n"),
+ sep = "", outf)
}
Report('_________________________________________________\n',outf)
Report(' ',outf)
@@ -132,8 +133,8 @@
for (i in 1 : z$pp)
{
onestepest<- z$oneStep[i]+z$theta[i]
- Report(c(format(paste(z$effects$type[i],': ',
- z$effects$effectName[i], sep = ''),
+ Report(c(format(paste(z$requestedEffects$type[i],': ',
+ z$requestedEffects$effectName[i], sep = ''),
width=50),
sprintf("%8.4f", onestepest), '\n'), sep = '', outf)
}
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/R/effects.r 2010-01-18 19:42:50 UTC (rev 43)
@@ -9,7 +9,7 @@
# * effects object to go with a Siena data object or group object.
# *****************************************************************************/
##@getEffects DataCreate
-getEffects<- function(x, nintn = 10, getDocumentation=FALSE)
+getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE)
{
##@duplicateDataFrameRow internal getEffects Put period numbers in
duplicateDataFrameRow <- function(x, n)
@@ -391,7 +391,7 @@
}
interaction <- createEffects("unspecifiedBehaviorInteraction",
varname)
- objEffects <- rbind(objEffects, interaction[rep(1, 4),])
+ objEffects <- rbind(objEffects, interaction[rep(1, behNintn),])
## now create the real effects, extra rows for endowment effects etc
objEffects <- createObjEffectList(objEffects, varname)
@@ -686,12 +686,12 @@
}
}
}
- if (!is.null(covObjEffects))
- {
- usestr <- paste("effFrom", type, sep="")
- covObjEffects$shortName <-
- sub("effFrom", usestr, covObjEffects$shortName)
- }
+ # if (!is.null(covObjEffects))
+ # {
+ # usestr <- paste("effFrom", type, sep="")
+ # covObjEffects$shortName <-
+ # sub("effFrom", usestr, covObjEffects$shortName)
+ # }
list(objEff=covObjEffects, rateEff=covRateEffects)
}
@@ -1004,6 +1004,14 @@
class(effects) <- c('sienaGroupEffects','sienaEffects', cl)
else
class(effects) <- c('sienaEffects', cl)
+ myrownames <- paste(sapply(strsplit(row.names(effects), ".", fixed=TRUE),
+ function(x)paste(x[1:2], collapse='.')),
+ effects$type, sep='.')
+ myrownames <- paste(myrownames,
+ as.vector(unlist(sapply(table(myrownames),
+ function(x)1:x))), sep=".")
+ myrownames <- sub("Effects", "", myrownames)
+
effects
}
##@getBehaviorStartingVals DataCreate
Modified: pkg/RSiena/R/print07Report.r
===================================================================
--- pkg/RSiena/R/print07Report.r 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/R/print07Report.r 2010-01-18 19:42:50 UTC (rev 43)
@@ -92,7 +92,8 @@
' ---')
if (nBehavs > 0)
{
- behEffects <- z$effects[z$effects$netType == 'behavior',]
+ behEffects <-
+ z$requestedEffects[z$requestedEffects$netType == 'behavior',]
behNames <- unique(behEffects$name)
if (nBehavs > 1)
{
@@ -101,18 +102,21 @@
behNames)],
'> ', behEffects$effectName,
sep='')
- z$effects$effectName[z$effects$netType=='behavior'] <-
+ z$requestedEffects$effectName[z$requestedEffects$netType=='behavior'] <-
behEffects$effectName
}
}
- typesp <- ifelse (z$effects$type== "endow", ": ", ": ")
- tmp <- paste(sprintf("%2d", 1:length(z$effects$effectName)),
- '. ',format(paste(z$effects$type,
- typesp, z$effects$effectName, sep = ''), width=50),
- theta, ses, '\n', sep='', collapse = '')
+ typesp <- ifelse (z$requestedEffects$type== "endow", ": ", ": ")
+ tmp <- paste(sprintf("%2d", 1:length(z$requestedEffects$effectName)),
+ '. ', format(paste(z$requestedEffects$type,
+ typesp,
+ z$requestedEffects$effectName,
+ sep = ''),
+ width=50),
+ theta, ses, '\n', sep='', collapse = '')
if (nBehavs > 0 && nOneModes > 0)
{
- nOneModeEff <- nrow(z$effects) - nrow(behEffects)
+ nOneModeEff <- nrow(z$requestedEffects) - nrow(behEffects)
tmpstr <- paste(nOneModeEff + 1, '. ', sep='')
tmpsub <- regexpr(tmpstr, tmp, fixed=TRUE)
tmp1 <- substring(tmp, 1, tmpsub - 2)
Modified: pkg/RSiena/R/printDataReport.r
===================================================================
--- pkg/RSiena/R/printDataReport.r 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/R/printDataReport.r 2010-01-18 19:42:50 UTC (rev 43)
@@ -190,21 +190,23 @@
}
fixed <- ifelse(z$fixed, ' (fixed) ', '')
- tmp <- paste(sprintf("%3d",1:length(z$effects$effectName)), '. ',
- format(paste(z$effects$type, ': ', z$effects$effectName,
+ tmp <- paste(sprintf("%3d",1:length(z$requestedEffects$effectName)), '. ',
+ format(paste(z$requestedEffects$type, ': ',
+ z$requestedEffects$effectName,
sep = ''), width = 52),
- sprintf("%9.4f", z$effects$initialValue), fixed, '\n',
+ sprintf("%9.4f", z$requestedEffects$initialValue), fixed, '\n',
sep = '', collapse = '')
Report(tmp, outf)
## targets:
Report("\n\nObserved values of target statistics are\n", outf)
- tmp <- paste(sprintf("%3d",1:length(z$effects$effectName)), '. ',
- format(z$effects$functionName, width = 66),
+ tmp <- paste(sprintf("%3d",1:length(z$requestedEffects$effectName)), '. ',
+ format(z$requestedEffects$functionName, width = 66),
sprintf("%9.4f",
- ifelse(z$effects$type=='endow', -z$targets,
+ ifelse(z$requestedEffects$type=='endow', -z$targets,
z$targets)),
'\n', sep = '', collapse = '')
Report(tmp, outf)
- Report(c('\n', nrow(z$effects), 'parameters,', nrow(z$effects),
+ Report(c('\n', nrow(z$requestedEffects), 'parameters,',
+ nrow(z$requestedEffects),
'statistics\n'),outf)
}
Modified: pkg/RSiena/R/siena01.r
===================================================================
--- pkg/RSiena/R/siena01.r 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/R/siena01.r 2010-01-18 19:42:50 UTC (rev 43)
@@ -512,9 +512,9 @@
if (is.null(myeffcopy$effectNumber))
{
myeffcopy <- cbind(effectNumber=1:nrow(myeff), myeff,
- effect1=rep(NA, nrow(myeff)),
- effect2=rep(NA, nrow(myeff)),
- effect3=rep(NA,nrow(myeff)))
+ effect1=rep(0, nrow(myeff)),
+ effect2=rep(0, nrow(myeff)),
+ effect3=rep(0,nrow(myeff)))
}
editCols <- c("name", "effectName", "type", "include", "fix",
"test", "initialValue", "parm", "effectNumber",
Added: pkg/RSiena/R/sienaeffects.r
===================================================================
--- pkg/RSiena/R/sienaeffects.r (rev 0)
+++ pkg/RSiena/R/sienaeffects.r 2010-01-18 19:42:50 UTC (rev 43)
@@ -0,0 +1,161 @@
+#/******************************************************************************
+# * SIENA: Simulation Investigation for Empirical Network Analysis
+# *
+# * Web: http://www.stats.ox.ac.uk/~snidjers/siena
+# *
+# * File: sienaeffects.r
+# *
+# * Description: This module contains utilities for updating an effects object
+# *****************************************************************************/
+
+##@includeEffect DataCreate
+includeEffects <- function(myeff, ..., include=TRUE, name=myeff$name[1],
+ type="eval", interaction1="", interaction2="")
+{
+ dots <- substitute(list(...))[-1] ##first entry is the word 'list'
+ if (length(dots) == 0)
+ {
+ stop("need some effect short names")
+ }
+ effectNames <- sapply(dots, function(x)deparse(x))
+ use <- myeff$shortName %in% effectNames &
+ myeff$type==type &
+ myeff$name==name &
+ myeff$interaction1 == interaction1 &
+ myeff$interaction2 == interaction2
+ myeff[use, "include"] <- include
+ print(myeff[use, c("name", "shortName", "type", "interaction1",
+ "interaction2", "include")])
+ myeff
+}
+##@includeInteraction DataCreate
+includeInteraction <- function(myeff, ...,
+ include=TRUE, name=myeff$name[1],
+ type="eval", interaction1=rep("", 3),
+ interaction2=rep("", 3))
+{
+ ## check we have 2 or 3 short names
+ dots <- substitute(list(...))[-1] ##first entry is the word 'list'
+ if (length(dots) == 0)
+ {
+ stop("need some effect short names")
+ }
+ if (length(dots) < 2 || length(dots) > 3)
+ {
+ stop("need exactly two or three effect short names")
+ }
+ shortNames <- sapply(dots, function(x)deparse(x))
+ ## check that we have a spare row
+ ints <- myeff[myeff$name == name & myeff$shortName %in%
+ c("unspInt", "behUnspInt") &
+ (is.na(myeff$effect1) | myeff$effect1 == 0)&
+ myeff$type == type, ]
+ if (nrow(ints) == 0)
+ {
+ stop("No more interactions available:",
+ "recreate the effects object requesting more interactions")
+ }
+ ints <- ints[1, ]
+ ## find the first underlying effect
+ shortName <- shortNames[1]
+ interact1 <- interaction1[1]
+ interact2 <- interaction2[1]
+ use <- myeff$shortName == shortName &
+ myeff$type==type &
+ myeff$name==name &
+ myeff$interaction1 == interact1 &
+ myeff$interaction2 == interact2
+ if (sum(use) == 0)
+ {
+ stop("First effect not found")
+ }
+ if (sum(use) > 1)
+ {
+ stop("First effect not unique")
+ }
+ effect1 <- myeff[use, "effectNumber"]
+ ## find the second underlying effect
+ shortName <- shortNames[2]
+ interact1 <- ifelse (length(interaction1) > 1, interaction1[2], "")
+ interact2 <- ifelse (length(interaction2) > 1, interaction2[2], "")
+ use <- myeff$shortName == shortName &
+ myeff$type==type &
+ myeff$name==name &
+ myeff$interaction1 == interact1 &
+ myeff$interaction2 == interact2
+ if (sum(use) == 0)
+ {
+ stop("Second effect not found")
+ }
+ if (sum(use) > 1)
+ {
+ stop("Second effect not unique")
+ }
+ effect2 <- myeff[use, "effectNumber"]
+ ## find the third underlying effect, if any
+
+ if (length(shortNames) > 2)
+ {
+ shortName <- shortNames[3]
+ interact1 <- ifelse (length(interaction1) > 2, interaction1[2], "")
+ interact2 <- ifelse (length(interaction2) > 2, interaction2[2], "")
+ use <- myeff$shortName == shortName &
+ myeff$type==type &
+ myeff$name==name &
+ myeff$interaction1 == interact1 &
+ myeff$interaction2 == interact2
+ if (sum(use) == 0)
+ {
+ stop("Second effect not found")
+ }
+ if (sum(use) > 1)
+ {
+ stop("Second effect not unique")
+ }
+ effect3 <- myeff[use, "effectNumber"]
+ }
+ else
+ {
+ effect3 <- 0
+ }
+ intn <- myeff$effectNumber == ints$effectNumber
+ myeff[intn, "include"] <- include
+ myeff[intn, c("effect1", "effect2", "effect3")] <-
+ c(effect1, effect2, effect3)
+
+ print(myeff[intn, c("name", "shortName", "type", "interaction1",
+ "interaction2", "include", "effect1", "effect2",
+ "effect3")])
+ myeff
+}
+
+##@setEffect DataCreate
+setEffect <- function(myeff, shortName, parameter=0,
+ fix=FALSE, test=FALSE, initialValue=0,
+ include=TRUE, name=myeff$name[1],
+ type="eval", interaction1="", interaction2="")
+{
+ shortName <- deparse(substitute(shortName))
+ use <- myeff$shortName == shortName &
+ myeff$name == name &
+ myeff$type == type &
+ myeff$interaction1 == interaction1 &
+ myeff$interaction2 == interaction2
+ if (sum(use) == 0)
+ {
+ stop("Effect not found")
+ }
+ if (sum(use) > 1)
+ {
+ stop("Effect not unique")
+ }
+ myeff[use, "parm"] <- parameter
+ myeff[use, "include"] <- include
+ myeff[use, "fix"] <- fix
+ myeff[use, "test"] <- test
+ myeff[use, "initialValue"] <- initialValue
+ print(myeff[use, c("name", "shortName", "type", "interaction1",
+ "interaction2", "include", "parm", "fix", "test",
+ "initialValue")])
+ myeff
+}
Modified: pkg/RSiena/R/simstatsc.r
===================================================================
--- pkg/RSiena/R/simstatsc.r 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/R/simstatsc.r 2010-01-18 19:42:50 UTC (rev 43)
@@ -50,24 +50,45 @@
}
effects$initialValue <- defaultEffects$initialValue
}
+ ## find any effects not included which are needed for interactions
+ interactionNos <- unique(c(effects$effect1, effects$effect2,
+ effects$effect3))
+ interactionNos <- interactionNos[interactionNos > 0]
+ interactionMainEffects <- effects[interactionNos, ]
+ effects$requested <- effects$include
+ requestedEffects <- effects[effects$include, ]
+
+ effects$include[interactionNos] <- TRUE
effects <- effects[effects$include,]
- ## should split and rejoin before continuing
- effects1 <- split(effects, effects$name)
+
+ ## split and rejoin both versions before continuing
+ effects1 <- split(requestedEffects, requestedEffects$name)
if (inherits(data, "sienaGroup"))
depvarnames <- names(data[[1]]$depvars)
else
depvarnames <- names(data$depvars)
effects1order <- match(names(effects1), depvarnames)
+ requestedEffects <- do.call(rbind, effects1[effects1order])
+ row.names(requestedEffects) <- 1:nrow(requestedEffects)
+ effects1 <- split(effects, effects$name)
+ effects1order <- match(names(effects1), depvarnames)
effects <- do.call(rbind, effects1[effects1order])
row.names(effects) <- 1:nrow(effects)
- z$theta <- effects$initialValue
- z$fixed <- effects$fix
- z$test <- effects$test
+ z$theta <- requestedEffects$initialValue
+ z$fixed <- requestedEffects$fix
+ z$test <- requestedEffects$test
z$pp <- length(z$test)
z$posj <- rep(FALSE,z$pp)
- z$posj[effects$basicRate] <- TRUE
+ z$posj[requestedEffects$basicRate] <- TRUE
z$BasicRateFunction <- z$posj
effects <- fixUpEffectNames(effects)
+
+ ## copy interaction names to the requested effects
+ requestedEffects$effectName <- effects[effects$requested,
+ "effectName"]
+ requestedEffects$functionName <- effects[effects$requested,
+ "functionName"]
+
if (inherits(data, 'sienaGroup'))
{
nGroup <- length(data)
@@ -111,8 +132,9 @@
else
z$symmetric <- FALSE
## find the positions of basic rate effects for this network
- z$condvar <- (1:nrow(effects))[effects$name==z$condname][1:
- observations]
+ z$condvar <-
+ (1:nrow(requestedEffects))[requestedEffects$name==
+ z$condname][1:observations]
z$theta<- z$theta[-z$condvar]
z$fixed<- z$fixed[-z$condvar]
z$test<- z$test[-z$condvar]
@@ -121,7 +143,8 @@
z$BasicRateFunction <- z$posj[-z$condvar]
z$posj <- z$posj[-z$condvar]
z$theta[z$posj] <-
- z$theta[z$posj] / effects$initialValue[z$condvar]
+ z$theta[z$posj] /
+ requestedEffects$initialValue[z$condvar]
z$ntim<- matrix(NA, nrow=x$n3, ncol=observations)
}
}
@@ -150,13 +173,17 @@
attr(f, "change") <-
sapply(f, function(xx)attr(xx$depvars[[z$condname]],
'distance'))
- attr(f,"condEffects") <- effects[z$condvar,]
- effects <- effects[-z$condvar, ]
+ attr(f,"condEffects") <- requestedEffects[z$condvar,]
+ effcondvar <-
+ (1:nrow(effects))[effects$name==
+ z$condname][1:observations]
+ effects <- effects[-effcondvar, ]
+ requestedEffects <- requestedEffects[-z$condvar,]
}
## see if we can use the original dfra
if (!is.null(prevAns) && inherits(prevAns, "sienaFit"))
{
- if (all(rownames(prevAns$dfra) == effects$shortName)
+ if (all(rownames(prevAns$dfra) == requestedEffects$shortName)
&& !is.null(prevAns$sf))
{
z$haveDfra <- TRUE
@@ -165,21 +192,23 @@
## use thetas too, unless use standard values
if (!x$useStdInits)
{
- effects$initialValue <- prevAns$theta
+ requestedEffects$initialValue <- prevAns$theta
if (!is.null(prevAns$condvar))
{
## z$condvar has the subscripts of included
## parameters
## that correspond to the conditional variable
## need to scale the other rates again
- effects$initialValue[z$posj] <-
- effects$initialValue[z$posj] / prevAns$rate
+ requestedEffects$initialValue[z$posj] <-
+ requestedEffects$initialValue[z$posj] /
+ prevAns$rate
}
- z$theta <- effects$initialValue
+ z$theta <- requestedEffects$initialValue
}
}
}
z$effects <- effects
+ z$requestedEffects <- requestedEffects
}
else
{
@@ -270,7 +299,7 @@
}
ans <- .Call('interactionEffects', PACKAGE="RSiena",
pData, pModel, interactionEffects)
- ## copy these pointer to the interaction effects and then rejoin
+ ## copy these pointers to the interaction effects and then rejoin
for (i in 1:length(ans[[1]])) ## ans is a list of lists of
## pointers to effects. Each list corresponds to one
## dependent variable
@@ -282,6 +311,13 @@
}
myeffects[[i]] <- rbind(basicEffects[[i]], interactionEffects[[i]])
}
+ ## remove the effects only created as underlying effects
+ ## for interaction effects
+ myeffects <- lapply(myeffects, function(x)
+ {
+ x[x$requested, ]
+ }
+ )
if (!initC)
{
ans <- .Call('getTargets', PACKAGE="RSiena",
@@ -369,7 +405,7 @@
z <- c(z, ans)
TestOutput(z, x)
}
- dimnames(z$dfra)[[1]] <- as.list(z$effects$shortName)
+ dimnames(z$dfra)[[1]] <- as.list(z$requestedEffects$shortName)
return(z)
}
## iteration entry point
@@ -1259,13 +1295,13 @@
##validate user-specified network interactions
interactions <- effects[effects$shortName == "unspInt" &
- !is.na(effects$effect1), ]
+ effects$effect1 > 0, ]
if (nrow(interactions) > 0)
{
unspIntNames <- sapply(1:nrow(interactions), function(x, y, z)
{
y <- y[x, ] ## get the interaction effect
- twoway <- is.na(y$effect3)
+ twoway <- y$effect3 == 0
## now get the rows which are to interact
inter1 <- z[z$effectNumber == y$effect1, ]
if (nrow(inter1) != 1 )
@@ -1296,6 +1332,11 @@
stop("invalid interaction specification: ",
"must be same network")
}
+ if (inter1$type != inter2$type)
+ {
+ stop("invalid interaction specification: ",
+ "must be same type: evaluation or endowment")
+ }
}
else
{
@@ -1305,6 +1346,12 @@
stop("invalid interaction specification:",
"must all be same network")
}
+ if (inter1$type != inter2$type ||
+ inter1$type != inter3$type)
+ {
+ stop("invalid interaction specification:",
+ "must all be same type: evaluation or endowment")
+ }
}
## check types
inters <- rbind(inter1, inter2, inter3)
Modified: pkg/RSiena/changeLog
===================================================================
--- pkg/RSiena/changeLog 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/changeLog 2010-01-18 19:42:50 UTC (rev 43)
@@ -1,3 +1,17 @@
+2010-01-18 R-forge revision 43
+
+ * DESCRIPTION: new version 1.0.9
+ * NAMESPACE: new utility functions
+ * data/alleffects.csv : new behavior effects, user-specified
+ interactions.
+ * R/sienaeffects.r, man/includeEffects.Rd,
+ man/includeInteractions.Rd, man/setEffect.Rd: utilities to update
+ effects object.
+ * R/effects.r, man/getEffects.Rd: new parameter for number of
+ behavior interaction effects.
+ * src/model/effects/many: new behavior effects, user-specified
+ interactions.
+
2010-01-15 R-forge revision 40
* R/print01report.r, R/sienaprint.r: remove extra sqrt roots in
Modified: pkg/RSiena/data/allEffects.csv
===================================================================
--- pkg/RSiena/data/allEffects.csv 2010-01-15 17:45:45 UTC (rev 42)
+++ pkg/RSiena/data/allEffects.csv 2010-01-18 19:42:50 UTC (rev 43)
@@ -1,170 +1,172 @@
effectGroup,effectName,functionName,shortName,endowment,interaction1,interaction2,type,basicRate,include,randomEffects,fix,test,initialValue,parm,functionType,period,rateType,untrimmedValue,effect1,effect2,effect3,interactionType
-behaviorOneModeObjective,behavior xxxxxx average similarity,beh. xxxxxx average similarity ,avSim,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx total similarity,beh. xxxxxx total similarity ,totSim,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx indegree,beh. xxxxxx indegrees ,indeg,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx outdegree,beh. xxxxxx outdegrees ,outdeg,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx isolate,beh. xxxxxx isolate ,isolate,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx ave. sim. x reciprocity,beh. xxxxxx ave. similarity x reciprocity ,avSimRecip,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx tot. sim. x reciprocity,beh. xxxxxx tot. similarity x reciprocity ,totSimRecip,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx ave. sim. x popularity alter,beh. xxxxxx ave. sim. x indegrees(one-sided) ,avSimPopAlt,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx tot. sim. x popularity alter,beh. xxxxxx tot. sim. x indegrees(one-sided) ,totSimPopAlt,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx ave. sim. x rec. x pop. (alter),beh. xxxxxx ave. sim. x rec. x i.d.(one-sided) ,avSimRecPop,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx tot. sim. x rec. x pop. (alter),beh. xxxxxx tot. sim. x rec. x i.d.(one-sided) ,totSimRecPop,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx average alter,beh. xxxxxx average alters ,avAlt,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx average rec. alters,beh. xxxxxx average rec. alters ,avRecAlt,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx dense triads <maybe wrong>,beh. xxxxxx dense triads <<<maybe wrong>>> ,behDenseTriads,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx similarity in dense triads <maybe wrong>,beh. xxxxxx homogeneity of dense triads <<<maybe wrong>>> ,simDenseTriads,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx reciprocated degree,beh. xxxxxx reciprocated degrees ,recipDeg,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective,behavior xxxxxx ave. sim. x popularity ego,beh. xxxxxx ave. sim. x indegrees ego ,avSimPopEgo,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorOneModeObjective2,behavior xxxxxx: infl. one-sided ? x xxxxxx alter,beh. xxxxxx: infl. interaction? x xxxxxx alter,behInfl1sid,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx average similarity,beh. xxxxxx average similarity ,avSim,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx total similarity,beh. xxxxxx total similarity ,totSim,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx outdegree,beh. xxxxxx outdegrees ,outdeg,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx isolate,beh. xxxxxx isolate ,isolate,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx ave. sim. x popularity alter,beh. xxxxxx ave. sim. x indegrees(one-sided) ,avSimPopAlt,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx tot. sim. x popularity alter,beh. xxxxxx tot. sim. x indegrees(one-sided) ,totSimPopAlt,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx average alter,beh. xxxxxx average alters ,avAlt,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx dense triads <maybe wrong>,beh. xxxxxx dense triads <<<maybe wrong>>> ,behDenseTriads,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx similarity in dense triads <maybe wrong>,beh. xxxxxx homogeneity of dense triads <<<maybe wrong>>> ,simDenseTriads,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective,behavior xxxxxx ave. sim. x popularity ego,beh. xxxxxx ave. sim. x indegrees ego ,avSimPopEgo,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorBipartiteObjective2,behavior xxxxxx: infl. one-sided ? x xxxxxx alter,beh. xxxxxx: infl. interaction? x xxxxxx alter,behInfl1sid,TRUE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorObjective,behavior xxxxxx linear shape,beh. xxxxxx cent. sum ,linear,TRUE,,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
-behaviorObjective,behavior xxxxxx quadratic shape,beh. xxxxxx sum of cent. squares,quad,TRUE,,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,0,objective,NA,NA,0,,,,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 43
More information about the Rsiena-commits
mailing list