[Rsiena-commits] r41 - in pkg/RSienaTest: . R data doc inst/examples man src src/model/effects src/model/variables src/win32 tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jan 15 18:29:28 CET 2010
Author: ripleyrm
Date: 2010-01-15 18:29:19 +0100 (Fri, 15 Jan 2010)
New Revision: 41
Added:
pkg/RSienaTest/.Rbuildignore
pkg/RSienaTest/R/sienaeffects.r
pkg/RSienaTest/doc/
pkg/RSienaTest/doc/Covariates.png
pkg/RSienaTest/doc/LongitudinalData.png
pkg/RSienaTest/doc/RSIENAspec.tex
pkg/RSienaTest/doc/RSienaDeveloper.tex
pkg/RSienaTest/doc/classdesign.tex
pkg/RSienaTest/doc/ilcampo.jpg
pkg/RSienaTest/doc/s_man400.tex
pkg/RSienaTest/doc/siena1.png
pkg/RSienaTest/doc/siena2.png
pkg/RSienaTest/doc/siena3.png
pkg/RSienaTest/doc/simstats0c.tex
pkg/RSienaTest/man/includeEffects.Rd
pkg/RSienaTest/man/includeInteraction.Rd
pkg/RSienaTest/man/setEffect.Rd
pkg/RSienaTest/src/SienaProfile.cpp
Removed:
pkg/RSienaTest/inst/examples/sienafreshman.Rdata
pkg/RSienaTest/inst/examples/sienafreshman.out
Modified:
pkg/RSienaTest/NAMESPACE
pkg/RSienaTest/R/Sienatest.r
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/print07Report.r
pkg/RSienaTest/R/printDataReport.r
pkg/RSienaTest/R/siena01.r
pkg/RSienaTest/R/sienaprint.r
pkg/RSienaTest/R/simstatsc.r
pkg/RSienaTest/R/zzz.R
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/getEffects.Rd
pkg/RSienaTest/man/siena07.Rd
pkg/RSienaTest/man/sienaFit.Rd
pkg/RSienaTest/man/simstats0c.Rd
pkg/RSienaTest/src/Makefile.win
pkg/RSienaTest/src/model/effects/AllEffects.h
pkg/RSienaTest/src/model/effects/EffectFactory.cpp
pkg/RSienaTest/src/model/effects/PopularityAlterEffect.cpp
pkg/RSienaTest/src/model/variables/BehaviorVariable.cpp
pkg/RSienaTest/src/model/variables/BehaviorVariable.h
pkg/RSienaTest/src/win32/Makefile
pkg/RSienaTest/tests/parallel.R
pkg/RSienaTest/tests/parallel.Rout.save
Log:
1. Added developer documentation. 2. Removed necessity to include underlying effects for interactions. 3. Removed error bug fix (see 31). 4. New utility functions for effects. 5. Updated Makefiles for 64 bit windows. 5. Shortened check time by shrinking examples and tests.
Added: pkg/RSienaTest/.Rbuildignore
===================================================================
--- pkg/RSienaTest/.Rbuildignore (rev 0)
+++ pkg/RSienaTest/.Rbuildignore 2010-01-15 17:29:19 UTC (rev 41)
@@ -0,0 +1,7 @@
+^doc
+inst/*.txt
+src/SienaProfile.cpp
+src/SienaProfile.o
+src/SienaProfile.exe
+src/RMath.dll
+src/libpgSn.a
Property changes on: pkg/RSienaTest/.Rbuildignore
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: pkg/RSienaTest/NAMESPACE
===================================================================
--- pkg/RSienaTest/NAMESPACE 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/NAMESPACE 2010-01-15 17:29:19 UTC (rev 41)
@@ -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/RSienaTest/R/Sienatest.r
===================================================================
--- pkg/RSienaTest/R/Sienatest.r 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/Sienatest.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -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/RSienaTest/R/effects.r
===================================================================
--- pkg/RSienaTest/R/effects.r 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/effects.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -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)
@@ -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/RSienaTest/R/print07Report.r
===================================================================
--- pkg/RSienaTest/R/print07Report.r 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/print07Report.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -44,9 +44,9 @@
}
Report(format(round(z$rate[1], digits = 4), width = 9), outf)
Report(format(round(z$rate[1], digits = 4), width = 9), bof)
- Report(c(' (', format(round(sqrt(z$vrate[1]), digits = 4),
+ Report(c(' (', format(round(z$vrate[1], digits = 4),
width = 9), ')\n'), sep = '', outf)
- Report(c(' (', format(round(sqrt(z$vrate[1]), digits = 4),
+ Report(c(' (', format(round(z$vrate[1], digits = 4),
width = 9), ')\n'), sep = '', bof)
}
else ## observations > 2
@@ -58,14 +58,14 @@
tmp <- paste(' 0.', nnstr, ' Rate parameter period ',
1:nn, ' ',
format(round(z$rate,4),width=9),
- ' (',format(round(sqrt(z$vrate),4),width=9),
+ ' (',format(round(z$vrate,4),width=9),
')\n', sep = '')
} else{
tmp <- paste(' 0.', nnstr,
'Rate parameter cond. variable period ',
1:nn, ' ',
format(round(z$rate,4),width=9),
- ' (',format(round(sqrt(z$vrate),4),width=9),
+ ' (',format(round(z$vrate,4),width=9),
')\n', sep='')
}
Report(tmp, outf, sep='')
@@ -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/RSienaTest/R/printDataReport.r
===================================================================
--- pkg/RSienaTest/R/printDataReport.r 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/printDataReport.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -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/RSienaTest/R/siena01.r
===================================================================
--- pkg/RSienaTest/R/siena01.r 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/siena01.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -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/RSienaTest/R/sienaeffects.r
===================================================================
--- pkg/RSienaTest/R/sienaeffects.r (rev 0)
+++ pkg/RSienaTest/R/sienaeffects.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -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/RSienaTest/R/sienaprint.r
===================================================================
--- pkg/RSienaTest/R/sienaprint.r 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/sienaprint.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -210,7 +210,7 @@
mydf[1, 'text'] <- 'Rate parameter of conditioning variable'
}
mydf[1, 'value'] <- x$rate[1]
- mydf[1, 'se'] <- sqrt(x$vrate[1])
+ mydf[1, 'se'] <- x$vrate[1]
}
else ## observations > 2
{
@@ -303,13 +303,35 @@
tmp <- sienaFitThetaTable(x)
mydf <- tmp$mydf
addtorow <- tmp$addtorow
+ ## find out whether the type is html or latex
+ dots <- substitute(list(...))[-1] ##first entry is the word 'list'
+ if (!is.null(dots[["type"]]))
+ {
+ type <- dots[["type"]]
+ }
+ else
+ {
+ type <- "latex"
+ }
if (!is.null(addtorow$command))
{
- use <- addtorow$command != 'Network Dynamics'
- addtorow$command <- paste('\\multicolumn{4}{l}{', addtorow$command,
- '} \\\\ \n')
- use[1] <- FALSE
- addtorow$command[use] <- paste('\\\\ ', addtorow$command[use])
+ if (type =="latex")
+ {
+ use <- addtorow$command != 'Network Dynamics'
+ addtorow$command <- paste('\\multicolumn{4}{l}{', addtorow$command,
+ '} \\\\ \n')
+ use[1] <- FALSE
+ addtorow$command[use] <- paste('\\\\ ', addtorow$command[use])
+ }
+ else ##html
+ {
+ # use <- addtorow$command != 'Network Dynamics'
+ addtorow$command <- paste("<TR> <TD colspan=9 align=left>",
+ addtorow$command,
+ "</TD> </TR> <TR> </TR> \n")
+ # use[1] <- FALSE
+ # addtorow$command[use] <- paste('\\\\ ', addtorow$command[use])
+ }
}
else
{
@@ -320,7 +342,7 @@
mydf[mydf[,'row'] >= 1, 'row'] <- paste(format(mydf[mydf$row >= 1,
'row']), '.', sep='')
tmp <- list(xtable(mydf, caption=caption, label=label, align=align,
- digits=digits, display=display), addtorow=addtorow,
+ digits=digits, display=display), add.to.row=addtorow,
include.colnames=FALSE, include.rownames=FALSE, ...)
class(tmp) <- c("xtable.sienaFit", "xtable")
tmp
@@ -328,9 +350,10 @@
##@print.xtable.sienaFit Methods
print.xtable.sienaFit <- function(x, ...)
{
- addtorow <- x[["addtorow"]]
+ addtorow <- x[["add.to.row"]]
if (!is.null(addtorow))
{
+ x$add.to.row$pos <- lapply(x$add.to.row$pos, function(x)x-2)
do.call("print", x)
}
else
Modified: pkg/RSienaTest/R/simstatsc.r
===================================================================
--- pkg/RSienaTest/R/simstatsc.r 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/simstatsc.r 2010-01-15 17:29:19 UTC (rev 41)
@@ -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="RSienaTest",
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="RSienaTest",
@@ -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/RSienaTest/R/zzz.R
===================================================================
--- pkg/RSienaTest/R/zzz.R 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/R/zzz.R 2010-01-15 17:29:19 UTC (rev 41)
@@ -34,7 +34,7 @@
##@.onUnload Miscellaneous Unload processing
.onUnload <- function(libpath) {
- library.dynam.unload("RSiena", libpath)
+ library.dynam.unload("RSienaTest", libpath)
}
#.Last.lib <- function(libpath)
Modified: pkg/RSienaTest/data/allEffects.csv
===================================================================
--- pkg/RSienaTest/data/allEffects.csv 2010-01-15 15:45:33 UTC (rev 40)
+++ pkg/RSienaTest/data/allEffects.csv 2010-01-15 17:29:19 UTC (rev 41)
@@ -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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,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,FALSE,yyyyyy,,eval,FALSE,FALSE,FALSE,FALSE,FALSE,0,5,objective,NA,NA,0,,,,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 41
More information about the Rsiena-commits
mailing list