[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