[Rsiena-commits] r341 - in pkg/RSienaTest: . R data doc man src src/data src/model src/model/effects src/model/ml src/model/tables src/model/variables tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Oct 16 22:25:34 CEST 2019
Author: tomsnijders
Date: 2019-10-16 22:25:33 +0200 (Wed, 16 Oct 2019)
New Revision: 341
Added:
pkg/RSienaTest/src/data/ContinuousLongitudinalData.cpp
pkg/RSienaTest/src/data/ContinuousLongitudinalData.h
pkg/RSienaTest/src/model/SdeSimulation.cpp
pkg/RSienaTest/src/model/SdeSimulation.h
pkg/RSienaTest/src/model/effects/AverageAlterContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/AverageAlterContinuousEffect.h
pkg/RSienaTest/src/model/effects/ContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/ContinuousEffect.h
pkg/RSienaTest/src/model/effects/CovariateDependentContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/CovariateDependentContinuousEffect.h
pkg/RSienaTest/src/model/effects/FeedbackEffect.cpp
pkg/RSienaTest/src/model/effects/FeedbackEffect.h
pkg/RSienaTest/src/model/effects/IndegreeContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/IndegreeContinuousEffect.h
pkg/RSienaTest/src/model/effects/InterceptEffect.cpp
pkg/RSienaTest/src/model/effects/InterceptEffect.h
pkg/RSienaTest/src/model/effects/IsolateOutContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/IsolateOutContinuousEffect.h
pkg/RSienaTest/src/model/effects/MainCovariateContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/MainCovariateContinuousEffect.h
pkg/RSienaTest/src/model/effects/MaxAlterContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/MaxAlterContinuousEffect.h
pkg/RSienaTest/src/model/effects/NetworkDependentContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/NetworkDependentContinuousEffect.h
pkg/RSienaTest/src/model/effects/OutdegreeContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/OutdegreeContinuousEffect.h
pkg/RSienaTest/src/model/effects/ReciprocalDegreeContinuousEffect.cpp
pkg/RSienaTest/src/model/effects/ReciprocalDegreeContinuousEffect.h
pkg/RSienaTest/src/model/effects/SettingSizeEffect.cpp
pkg/RSienaTest/src/model/effects/SettingSizeEffect.h
pkg/RSienaTest/src/model/effects/SettingsNetworkEffect.cpp
pkg/RSienaTest/src/model/effects/SettingsNetworkEffect.h
pkg/RSienaTest/src/model/effects/WienerEffect.cpp
pkg/RSienaTest/src/model/effects/WienerEffect.h
pkg/RSienaTest/src/model/variables/ContinuousVariable.cpp
pkg/RSienaTest/src/model/variables/ContinuousVariable.h
Modified:
pkg/RSienaTest/ChangeLog
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/R/bayesTest.r
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/effectsDocumentation.r
pkg/RSienaTest/R/initializeFRAN.r
pkg/RSienaTest/R/phase2.r
pkg/RSienaTest/R/phase3.r
pkg/RSienaTest/R/print01Report.r
pkg/RSienaTest/R/printInitialDescription.r
pkg/RSienaTest/R/robmon.r
pkg/RSienaTest/R/siena07.r
pkg/RSienaTest/R/sienaBayes.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaGOF.r
pkg/RSienaTest/R/sienaTimeTest.r
pkg/RSienaTest/R/sienaeffects.r
pkg/RSienaTest/R/sienaprint.r
pkg/RSienaTest/R/sienatable.r
pkg/RSienaTest/R/sienautils.r
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/doc/RSiena.bib
pkg/RSienaTest/doc/RSiena_Manual.pdf
pkg/RSienaTest/doc/RSiena_Manual.tex
pkg/RSienaTest/doc/Siena_algorithms.tex
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/coCovar.Rd
pkg/RSienaTest/man/extract.sienaBayes.Rd
pkg/RSienaTest/man/getEffects.Rd
pkg/RSienaTest/man/includeEffects.Rd
pkg/RSienaTest/man/includeInteraction.Rd
pkg/RSienaTest/man/print.sienaBayesFit.Rd
pkg/RSienaTest/man/setEffect.Rd
pkg/RSienaTest/man/sienaDataConstraint.Rd
pkg/RSienaTest/man/sienaDataCreate.Rd
pkg/RSienaTest/man/sienaDependent.Rd
pkg/RSienaTest/man/sienaGOF-auxiliary.Rd
pkg/RSienaTest/man/sienaGOF.Rd
pkg/RSienaTest/man/sienaGroupCreate.Rd
pkg/RSienaTest/man/sienaNodeSet.Rd
pkg/RSienaTest/man/sienaTimeTest.Rd
pkg/RSienaTest/man/varCovar.Rd
pkg/RSienaTest/man/varDyadCovar.Rd
pkg/RSienaTest/src/data/Data.cpp
pkg/RSienaTest/src/data/Data.h
pkg/RSienaTest/src/init.cpp
pkg/RSienaTest/src/model/EpochSimulation.cpp
pkg/RSienaTest/src/model/EpochSimulation.h
pkg/RSienaTest/src/model/Model.cpp
pkg/RSienaTest/src/model/Model.h
pkg/RSienaTest/src/model/State.cpp
pkg/RSienaTest/src/model/State.h
pkg/RSienaTest/src/model/StatisticCalculator.cpp
pkg/RSienaTest/src/model/StatisticCalculator.h
pkg/RSienaTest/src/model/effects/AllEffects.h
pkg/RSienaTest/src/model/effects/EffectFactory.cpp
pkg/RSienaTest/src/model/effects/NetworkEffect.cpp
pkg/RSienaTest/src/model/effects/NetworkEffect.h
pkg/RSienaTest/src/model/effects/TruncatedOutdegreeEffect.cpp
pkg/RSienaTest/src/model/effects/TruncatedOutdegreeEffect.h
pkg/RSienaTest/src/model/ml/MLSimulation.cpp
pkg/RSienaTest/src/model/tables/NetworkCache.h
pkg/RSienaTest/src/model/tables/TwoNetworkCache.cpp
pkg/RSienaTest/src/model/tables/TwoNetworkCache.h
pkg/RSienaTest/src/model/variables/DependentVariable.cpp
pkg/RSienaTest/src/model/variables/DependentVariable.h
pkg/RSienaTest/src/model/variables/NetworkVariable.cpp
pkg/RSienaTest/src/model/variables/NetworkVariable.h
pkg/RSienaTest/src/siena07internals.cpp
pkg/RSienaTest/src/siena07internals.h
pkg/RSienaTest/src/siena07setup.cpp
pkg/RSienaTest/src/siena07setup.h
pkg/RSienaTest/src/sources.list
pkg/RSienaTest/tests/parallel.R
pkg/RSienaTest/tests/parallel.Rout.save
Log:
This R-Forge revision only RSienaTest: continuous dependent variables, settings model, and more.
Modified: pkg/RSienaTest/ChangeLog
===================================================================
--- pkg/RSienaTest/ChangeLog 2019-05-21 13:00:49 UTC (rev 340)
+++ pkg/RSienaTest/ChangeLog 2019-10-16 20:25:33 UTC (rev 341)
@@ -1,3 +1,47 @@
+2019-10-16 R-Forge Revision 341, package version 1.2-18.
+In this R-forge revision, only RSienaTest is updated.
+Changes in RSiena and RSienaTest:
+ * Continuous dependent behavior variables implemented (Nynke Niezink).
+ This implies new effect types continuousFeedback, continuousIntercept,
+ continuousOneModeObjective, continuousRate, continuousWiener,
+ unspecifiedContinuousInteraction.
+ * imputationValues allowed in sienaDependent (Nynke Niezink)
+ * New effect outMore.
+ * component startingDate added to sienaFit object; this is reported in
+ siena.table(..., type='tex', ...).
+ * Speeded up calculation of IndegreeDistribution and OutdegreeDistribution
+ for sienaGOF if there are no missings or structurals.
+ * regrCoef and regrCor added to the sienaFit object also when !dolby.
+ * Some "warnings" changed back to "cat".
+ * EpochSimulation->totalRate renamed to grandTotalRate,
+ to avoid confusion with DependentVariable->totalRate.
+ * stop if useCluster and returnChains (in this case, no chains would
+ be returned anyway).
+ * sienaDataCreate: more informative message in case of constraints.
+ * Further explanation in help page for setEffect, and small extensions of
+ help pages for getEffects, includeEffects, and includeInteraction.
+ * small clarification in help page for sienaDependent.
+ * small clarifications about node sets in help pages for coCovar,
+ varCovar, coDyadCovar, varDyadCovar, and sienaDataCreate.
+ * small addition to help page for sienaTimeTest.
+ * Object names are given in sienaFit.print if simOnly.
+ * Settings model: corrected scores for rate parameters;
+ stepType in NetworkCache; new class settingNetworkEffects;
+ effect group nonSymmetricSymmetricObjective split in this and
+ nonSymmetricSymmetricSObjective (also operating for primary setting effects);
+ new effects settingSizeAct, settingSizeActSqrt, settingSizeActLog,
+ settingOppAct, settingOppActSqrt, settingOppActLog,
+ settingLogCreationAct, settingOppActD, settingOppActSqrtD,
+ settingOppActLogD, settingLogCreationActD.
+ These new effects are not yet operational (target statistics not calculated).
+ * inPopIntn and outActIntn dropped from effect group
+ nonSymmetricSymmetricObjective.
+Changes in RSienaTest:
+ * Corrected error in names of array returned by extract.posteriorMeans.
+ * New parameter excludeRates in extract.posteriorMeans, plotPostMeansMDS.
+ * Use parameter pmonly also in plotPostMeansMDS.
+
+
2019-05-20 R-Forge Revision 340, packages version 1.2-17.
Changes in RSiena and RSienaTest:
* New effects outAct.c, inAct.c, outPop.c., inPop.c, degPlus.c.
@@ -169,7 +213,7 @@
2018-03-24 R-Forge Revision 334, packages version 1.2-10.
Changes in RSiena and RSienaTest:
- * Example in help file siena07 for accessing generated networks for ML.
+ * Example in help page siena07 for accessing generated networks for ML.
2018-03-21 R-Forge Revision 332, packages version 1.2-9.
Changes in RSiena and RSienaTest:
@@ -236,7 +280,7 @@
* multipleBayesTest corrected (there was an error for testing 2 or more
linear combinations simultaneously) and adapted for cases with fixed
parameters;
- adapted help file text.
+ adapted help page text.
* All remaining parts of rsiena01gui removed.
* As a compensation of this, sienaDataCreateFromSession exported,
with a more informative help page.
@@ -471,7 +515,7 @@
if priorRatesFromData=2, change to different robust covariance matrix
estimator when this is necessary (i.e., for small number of groups);
in print.summary, also report nImproveMH;
- a few lines added to help file.
+ a few lines added to help page.
* test14 dropped from parallel.R (using clusters undesirable for basic testing)
and replaced by a test using maxlike.
@@ -1282,9 +1326,9 @@
* In print method for sienaAlgorithm, report of conditional corrected
in case !x$cconditional (sienaprint.r)
* If there is a composition change object, MoM estimation is forced
- to be non-conditional (initializeFRAN.r). This is reported in the help file
+ to be non-conditional (initializeFRAN.r). This is reported in the help page
(sienaCompositionChange.Rd).
- * Small changes in help files sienaAlgorithm.Rd, plot.sienaTimeTest.Rd,
+ * Small changes in help pages sienaAlgorithm.Rd, plot.sienaTimeTest.Rd,
2013-05-10 R-forge revision 230
@@ -1897,7 +1941,7 @@
returning of chains every iteration. Bug fixes for ML.
* R/algorithms.r: added to RSienaTest (from examples directory).
* man/profileLikelihoods.Rd, man/algorithms.Rd: (RSien aTest only)
- help files for functions in algorithms.r.
+ help pages for functions in algorithms.r.
2011-11-27 R-forge revision 185.
@@ -3080,7 +3124,7 @@
to terminate the epoch.
* tests/parallel.R, parallel.Rout.save: change in line number of effect
* man/plot.sienaTimeTest.Rd, man/sienaTimeTest.Rd,
- man/includeTimeDummy.Rd: split the help file into three.
+ man/includeTimeDummy.Rd: split the help page into three.
2010-06-04 R-forge revision 92 (RSienaTest only)
Modified: pkg/RSienaTest/DESCRIPTION
===================================================================
--- pkg/RSienaTest/DESCRIPTION 2019-05-21 13:00:49 UTC (rev 340)
+++ pkg/RSienaTest/DESCRIPTION 2019-10-16 20:25:33 UTC (rev 341)
@@ -2,8 +2,8 @@
Package: RSienaTest
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.2-17
-Date: 2019-05-20
+Version: 1.2-18
+Date: 2019-10-16
Author: Ruth Ripley, Krists Boitmanis, Tom A.B. Snijders, Felix Schoenenberger
Depends: R (>= 2.15.0)
Imports: Matrix, tcltk, lattice, parallel, MASS, RUnit, methods
@@ -19,6 +19,8 @@
An overview of these models is given in Tom A.B. Snijders (2017), Stochastic
Actor-Oriented Models for Network Dynamics, Annual Review of Statistics and
Its Application, 4, 343-363 <doi: 10.1146/annurev-statistics-060116-054035>.
+ An extensive manual, scripts, and much further information is at the Siena
+ website <http://www.stats.ox.ac.uk/~snijders/siena>.
License: GPL (>= 3)
LazyLoad: yes
LazyData: yes
Modified: pkg/RSienaTest/R/bayesTest.r
===================================================================
--- pkg/RSienaTest/R/bayesTest.r 2019-05-21 13:00:49 UTC (rev 340)
+++ pkg/RSienaTest/R/bayesTest.r 2019-10-16 20:25:33 UTC (rev 341)
@@ -260,6 +260,20 @@
lines(c(x$chisquared, x$chisquared), c(0, max(d1$y)),lwd=2)
}
+getNames <- function(x){
+ # effect names without duplicated rate parameters
+ # and with "unspecified interaction" replaced by
+ # information about the effects in question
+ b <- x$basicRate
+ tpar<- rep(NA,length(b))
+ # True Parameters, i.e., all except rate parameters for groups 2 and up.
+ for (i in (2:length(b))){tpar[i] <- !b[i]|(b[i]&!b[i-1])}
+ tpar[1] <- TRUE
+ # Take away the ' (period 1)' in the first rate parameter
+ sub(' (period 1)','', x$requestedEffects$effectName[tpar], fixed=TRUE)
+}
+
+
##@extract.sienaBayes extracts samples from sienaBayesFit objects
extract.sienaBayes <- function(zlist, nfirst=zlist[[1]]$nwarm+1, extracted,
sdLog=TRUE){
@@ -410,7 +424,8 @@
##@extract.posteriorMeans extracts posterior means from sienaBayesFit object
-extract.posteriorMeans <- function(z, nfirst=z$nwarm+1, verbose=TRUE){
+extract.posteriorMeans <- function(z, nfirst=z$nwarm+1, pmonly=1,
+ excludeRates=FALSE, verbose=TRUE){
# produces a matrix with the groups in the rows
# and all effects in the columns, with for each effect
# first the posterior mean ("p.m.") and then the posterior standard deviation ("psd.")
@@ -430,10 +445,16 @@
{
stop('z must be a sienaBayesFit object')
}
-
ntot <- max(which(!is.na(z$ThinPosteriorMu[,1])))
nit <- ntot - nfirst + 1
- nind <- sum(z$varyingParametersInGroup)
+ if (excludeRates)
+ {
+ nind <- sum(z$objectiveInVarying)
+ }
+ else
+ {
+ nind <- sum(z$varyingParametersInGroup)
+ }
res <- matrix(NA, z$nGroup, 2*nind)
if (nind <= 0)
{
@@ -442,6 +463,10 @@
else
{
EffName <- getNames(z)[z$varyingParametersInGroup]
+ if (excludeRates)
+ {
+ EffName <- EffName[z$objectiveInVarying]
+ }
if (verbose)
{
cat(z$nGroup, ' groups\n')
@@ -458,7 +483,15 @@
}
df <- sienaFitThetaTable(z, fromBayes=TRUE, tstat=FALSE,
groupOnly=h, nfirst=nfirst)$mydf
- seth <- union(z$ratePositions[[h]], which(z$varyingObjectiveParameters))
+ if (excludeRates)
+ {
+ seth <- which(z$varyingObjectiveParameters)
+ }
+ else
+ {
+ seth <- sort(union(z$ratePositions[[h]],
+ which(z$varyingObjectiveParameters)))
+ }
posttheta <- df[seth,"value"]
postsd <- df[seth,"se"]
res[h,1:nind] <- posttheta
@@ -465,16 +498,28 @@
res[h,(nind+1):(2*nind)] <- postsd
}
fName <- rep('',2*nind)
- fName[2*(1:nind)-1] <- paste('p.m.',EffName)
- fName[2*(1:nind)] <- paste('psd.',EffName)
+ fName[1:nind] <- paste('p.m.',EffName)
+ fName[nind + (1:nind)] <- paste('psd.',EffName)
dimnames(res) <- list(1:dim(res)[1], fName)
}
+ if (pmonly == 1)
+ {
+ res <- res[,1:nind]
+ }
+ else if (pmonly >= 2)
+ {
+ res <- res[,nind + (1:nind)]
+ }
+ if (verbose)
+ {
+ cat('*\n')
+ }
res
}
##@plotPostMeansMDS MDS plot of posterior means for sienaBayesFit object
-plotPostMeansMDS <- function(x, pmonly=0, nfirst=NULL, ...){
+plotPostMeansMDS <- function(x, pmonly=1, excludeRates=TRUE, nfirst=NULL, ...){
# This function makes an MDS plot of the posterior means in z;
# for the method: see MASS (book) p. 308.
# if pmonly=0 posterior means and standard deviations,
@@ -492,7 +537,8 @@
is.even <- function(k){k %% 2 == 0}
is.odd <- function(k){k %% 2 != 0}
message('extracting posterior means ...')
- pm <- extract.posteriorMeans(x, nfirst=nfirst)
+ pm <- extract.posteriorMeans(x, nfirst=nfirst, pmonly=pmonly,
+ excludeRates=excludeRates)
if (pmonly <= 0)
{
vars <- (1:dim(pm)[2])
Modified: pkg/RSienaTest/R/effects.r
===================================================================
--- pkg/RSienaTest/R/effects.r 2019-05-21 13:00:49 UTC (rev 340)
+++ pkg/RSienaTest/R/effects.r 2019-10-16 20:25:33 UTC (rev 341)
@@ -74,7 +74,7 @@
}
##@getEffects DataCreate create effects object
-getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE)
+getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE, onePeriodSde=FALSE)
{
##@duplicateDataFrameRow internal getEffects Put period numbers in
duplicateDataFrameRow <- function(x, n)
@@ -91,17 +91,6 @@
tmp
}
-# ##@addSettingseffects internal getEffects add effects for settings model
-# addSettingsEffects <- function(effects)
-# {
-# # depvar <- attr(effects, "depvar")
-# ## This processes the settings (constant dyadic covariate) structure.
-# ## Only for one-mode network.
-# # nbrSettings <- length(attr(depvar,"settings"))
-# ## This leads to a warning in R CMD Check.
-# ## Not important since this is just a stub, to be developed later.
-# # (used by sienaRI.r)
-# }
##@networkRateEffects internal getEffects create a set of rate effects
networkRateEffects <- function(depvar, varname, symmetric, bipartite)
{
@@ -202,7 +191,7 @@
}
for (j in seq(along=xx$depvars))
{
- if (types[j] == 'behavior' &&
+ if (types[j] %in% c('behavior', 'continuous') &&
attr(xx$depvars[[j]], 'nodeSet') == nodeSet)
{
tmp <- covarOneModeEff(names(xx$depvars)[j],
@@ -228,7 +217,7 @@
if (length(xx$cCovars) + length(xx$vCovars) +
length(xx$dycCovars) + length(xx$dyvCovars) +
- length(types=='behavior') > 0)
+ length(types=='behavior') + length(types=='continuous') > 0)
{
interaction <- createEffects("unspecifiedNetInteraction",
name=varname,
@@ -248,6 +237,12 @@
{
objEffects <-
rbind(objEffects,
+ createEffects("nonSymmetricSymmetricSObjective",
+ otherName, name=varname,
+ groupName=groupName, group=group,
+ netType=netType))
+ objEffects <-
+ rbind(objEffects,
createEffects("nonSymmetricSymmetricObjective",
otherName, name=varname,
groupName=groupName, group=group,
@@ -406,14 +401,18 @@
}
rateEffects$basicRate[1:observations] <- TRUE
- if (!is.null(attr(depvar,"settingsinfo"))) {
+ if (!is.null(attr(depvar,"settingsinfo")))
+ {
settingIds <- sapply(attr(depvar,"settingsinfo"), function(s) s$id)
nbrSettings <- length(settingIds)
if ("primary" %in% settingIds) {
+ objEffects <- rbind(objEffects, createEffects(
+ "settingsObjective", varname, name=varname,
+ groupName=groupName, group=group, netType=netType))
# append effects with an interaction on the primary settings network of `varname`
objEffects <- rbind(objEffects, createEffects(
- "nonSymmetricSymmetricObjective", paste0("primary(", varname, ")") , name=varname,
+ "nonSymmetricSymmetricSObjective", paste0("primary(", varname, ")") , name=varname,
groupName=groupName, group=group, netType=netType))
}
@@ -425,22 +424,31 @@
# for each period, set "setting" and modify "effectName"
setRateByPeriod <- lapply(setRateByPeriod, function(dd) {
dd$setting <- settingIds
- # prepend "rate" with the settings name
- i1 <- regexpr("rate", dd$effectName) # index of match
- dd$effectName <- paste(substr(dd$effectName, 1, i1 - 2), dd$setting, substring(dd$effectName, i1))
+ dd$interaction1 <- settingIds
+# also see below with 0.75
+ dd$initialValue[dd$setting != 'primary'] <- 0.5
+ dd$initialValue[dd$setting == 'primary'] <-
+ 0.75*dd$initialValue[dd$setting == 'primary']
+ dd$effectName <- paste(dd$setting, ' setting rate ',
+ varname,' (period ', dd$period, ')', sep='')
+ dd$functionName <- paste('distance in ',dd$setting,
+ ' setting (period ', dd$period, ')', sep='')
dd
})
-
setRate <- do.call(rbind, setRateByPeriod)
-
## add the extra column also to the other effects
rateEffects$setting <- rep("", nrow(rateEffects))
objEffects$setting <- rep("", nrow(objEffects))
-
+ # get the settings description
+ settingsDescription <- describeTheSetting(depvar)
rateEffects <- rbind(setRate, rateEffects[!rateEffects$basicRate, ])
}
+ else
+ {
+ settingsDescription <- ""
+ }
list(effects=rbind(rateEffects = rateEffects, objEffects = objEffects),
- starts=starts)
+ starts=starts, settingsDescription=settingsDescription)
}
##@behaviornet internal getEffects
@@ -686,7 +694,7 @@
}
for (j in seq(along=xx$depvars))
{
- if (types[j] == 'behavior' &&
+ if (types[j] %in% c('behavior', 'continuous') &&
attr(xx$depvars[[j]], 'nodeSet') == nodeSet)
{
tmp <- covBehEff(varname, names(xx$depvars)[j], nodeSet, j==i,
@@ -756,6 +764,136 @@
objEffects = objEffects), starts=starts)
}
+ ##@continuousNet internal getEffects
+ continuousNet <- function(depvars, varnames)
+ {
+ nodeSet <- attr(depvars[[1]],'nodeSet') ## NN: nodeset should be the same for
+ ## all continuous depvars
+
+ rateEffects <- createEffects("continuousRate", name="sde",
+ groupName=groupName, group=group,
+ netType=netType)
+ if (observations == 1)
+ {
+ rateEffects <- rateEffects[-2, ] ## remove the extra period
+ }
+ else
+ {
+ ## get correct number of rows
+ rateEffects <- rbind(duplicateDataFrameRow(rateEffects[2, ],
+ observations),
+ rateEffects[-c(1, 2), ])
+ }
+
+ objEffects <- fbicEffects <- wEffects <- NULL # general effects, feedback
+ # and intercept, wiener
+ for (j in seq(along=varnames)) # for all continuous variables
+ {
+ for (k in seq(along=varnames))
+ {
+ fbicEffects <- rbind(fbicEffects, createEffects("continuousFeedback",
+ xName = varnames[j], yName = varnames[k],
+ name=varnames[j], groupName=groupName, group=group,
+ netType=netType))
+ if (j <= k)
+ wEffects <- rbind(wEffects, createEffects("continuousWiener",
+ xName = varnames[k], yName = varnames[j],
+ name=varnames[k], groupName=groupName, group=group,
+ netType=netType))
+ }
+ fbicEffects <- rbind(fbicEffects, createEffects("continuousIntercept",
+ xName = varnames[j], name = varnames[j],
+ groupName=groupName, group=group, netType=netType))
+
+ for (k in seq(along=depvars))
+ {
+ if (types[k] == "oneMode" &&
+ attr(xx$depvars[[k]], "nodeSet") == nodeSet)
+ {
+ depvarname <- names(xx$depvars)[k]
+
+ tmpObjEffects <-
+ createEffects("continuousOneModeObjective",
+ varnames[j], depvarname, name=varnames[j],
+ groupName=groupName, group=group,
+ netType=netType)
+ }
+ if ((nOneModes) > 1) # add the network name, TODO: same for nBipartites
+ {
+ tmpObjEffects$functionName <-
+ paste(tmpObjEffects$functionName,
+ " (", depvarname, ")", sep="")
+ tmpObjEffects$effectName <-
+ paste(tmpObjEffects$effectName,
+ " (", depvarname, ")", sep = "")
+ }
+
+ objEffects <- rbind(objEffects, tmpObjEffects)
+ }
+ for (k in seq(along = xx$cCovars))
+ {
+ if (attr(xx$cCovars[[k]], 'nodeSet') == nodeSet)
+ {
+ tmp <- covContEff(varnames[j], names(xx$cCovars)[k], nodeSet,
+ type='', name=varnames[j])
+ objEffects <- rbind(objEffects, tmp$objEff)
+ }
+ }
+ for (k in seq(along=xx$depvars))
+ {
+ if (types[k] %in% c('behavior', 'continuous') &&
+ attr(xx$depvars[[k]], 'nodeSet') == nodeSet)
+ {
+ tmp <- covContEff(varnames[j], names(xx$depvars)[k], nodeSet,
+ varnames[j] == names(xx$depvars)[k],
+ type='Beh', name=varnames[j])
+ objEffects <- rbind(objEffects, tmp$objEff)
+ }
+ }
+ for (k in seq(along=xx$vCovars))
+ {
+ if (attr(xx$vCovars[[k]], 'nodeSet') == nodeSet)
+ {
+ tmp <- covContEff(varnames[j], names(xx$vCovars)[k], nodeSet,
+ type='Var', name=varnames[j])
+ objEffects <- rbind(objEffects, tmp$objEff)
+ }
+ }
+ interaction <- createEffects("unspecifiedContinuousInteraction",
+ varnames[j], name=varnames[j],
+ groupName=groupName, group=group,
+ netType=netType)
+
+ objEffects <- rbind(objEffects, interaction[rep(1, behNintn),])
+ }
+
+ fbicEffects$include <- TRUE
+
+ if (onePeriodSde)
+ {
+ wEffects$include <- TRUE
+ rateEffects$fix[1] <- TRUE
+ rateEffects$include[1] <- TRUE
+ }
+ else
+ {
+ wEffects$fix[1] <- TRUE
+ rateEffects$include[1:observations] <- TRUE
+ rateEffects$basicRate[1:observations] <- TRUE
+ }
+
+ if (nContinuous > 1)
+ wEffects$include <- TRUE
+
+ starts <- getContinuousStartingVals(depvars, onePeriodSde)
+ wEffects$initialValue <- starts$startWiener
+ rateEffects$initialValue[1:noPeriods] <- starts$startScale
+ fbicEffects$initialValue <- starts$startFbic
+
+ list(effects = rbind(rateEffects, wEffects, fbicEffects, objEffects),
+ starts = starts)
+ }
+
##@bipartiteNet internal getEffects
bipartiteNet <- function(depvar, varname)
{
@@ -1247,6 +1385,25 @@
}
objEffects
}
+
+ ##@covContEff internal getEffects
+ covContEff <- function(varname, covarname, nodeSet, same=FALSE,
+ ## same indicates that varname and covarname are
+ ## the same: just one rate effect required
+ ## type is no longer used
+ type=c('', 'Var', 'Beh'), name)
+ {
+ covObjEffects <- NULL
+ if (!same)
+ {
+ covObjEffects <- createEffects("covarContinuousObjective", varname,
+ covarname, name=name,
+ groupName=groupName, group=group,
+ netType=netType)
+ }
+ list(objEff=covObjEffects)
+ }
+
###################################
## start of function getEffects
##################################
@@ -1292,10 +1449,18 @@
nOneModes <- sum(types == 'oneMode')
#nBehaviors <- sum(types == 'behavior')
nBipartites <- sum(types =='bipartite')
- effects <- vector('list',n)
+ nContinuous <- sum(types == 'continuous')
+ effects <- vector('list',n+1) # n+1 th place for all sde parameters
#nodeSetNames <- sapply(xx$nodeSets, function(x)attr(x, 'nodeSetName'))
- names(effects) <- names(xx$depvars)
- for (i in 1:n)
+ names(effects) <- names(xx$depvars) # n+1 th place has no name
+
+ if (onePeriodSde && xx$observations > 2)
+ stop('onePeriodSde only possible in case of 2 observations')
+
+ if (onePeriodSde && groupx)
+ stop('onePeriodSde not possible in combination with multi-group')
+
+ for (i in 1:(n-nContinuous))
{
varname<- names(xx$depvars)[i]
groupName <- groupNames[1]
@@ -1326,6 +1491,7 @@
tmp <- behaviorNet(depvar, varname)
effects[[i]] <- tmp$effects
attr(effects[[i]], 'starts') <- tmp$starts
+ attr(effects[[i]], 'settings') <- ''
},
oneMode =
{
@@ -1333,6 +1499,7 @@
tmp <- oneModeNet(depvar, varname)
effects[[i]] <- tmp$effects
attr(effects[[i]], 'starts') <- tmp$starts
+ attr(effects[[i]], 'settings') <- tmp$settingsDescription
},
bipartite =
{
@@ -1340,9 +1507,29 @@
tmp <- bipartiteNet(depvar, varname)
effects[[i]] <- tmp$effects
attr(effects[[i]], 'starts') <- tmp$starts
+ attr(effects[[i]], 'settings') <- ''
},
stop('error type'))
}
+ settingsList <- lapply(effects, function(ef){attr(ef,'settings')})
+ if (nContinuous > 0)
+ {
+ groupName <- groupNames[1]
+ group <- 1
+ noPeriods <- xx$observations - 1
+ netType <- "continuous"
+ contIndices <- (n-nContinuous+1):n ## indicates continuous depvars
+ varnames <- names(xx$depvars)[contIndices]
+ depvars <- xx$depvars[contIndices]
+ tmp <- continuousNet(depvars,varnames)
+ effects[[n+1]] <- tmp$effects
+ attr(effects[[n+1]], 'starts') <- tmp$starts
+ for (i in contIndices)
+ {
+ # all the continuous variable specific effects are currently
+ # also part of effects[[n+1]]
+ }
+ }
## add starting values for the other objects
if (groupx && length(x) > 1)
{
@@ -1354,154 +1541,197 @@
n <- length(xx$depvars)
types <- sapply(xx$depvars, function(x)attr(x, 'type'))
noPeriods <- xx$observations - 1
- for (i in 1:n)
+ nContinuous <- sum(types == 'continuous')
+
+ for (i in 1:(n-nContinuous))
{
varname<- names(xx$depvars)[i]
depvar <- xx$depvars[[i]]
netnamesub <- match(varname, attr(x, 'netnames'))
if (types[i] == 'oneMode')
- attr(depvar, 'symmetric') <-
- attr(x, 'symmetric')[netnamesub]
- switch(types[i],
- behavior =
+ {
+ attr(depvar, 'symmetric') <- attr(x, 'symmetric')[netnamesub]
+ }
+ switch(types[i],
+ behavior =
+ {
+ starts <- getBehaviorStartingVals(depvar)
+ ## first for the rate parameters
+ ## find the appropriate set of effects
+ eff <- match(varname, names(effects))
+ if (is.na(eff))
{
- starts <- getBehaviorStartingVals(depvar)
- ## find the appropriate set of effects
- eff <- match(varname, names(effects))
- if (is.na(eff))
- stop("depvars don't match")
- effectname <- paste('rate ', varname,' (period ',
- period + 1:noPeriods,
- ')',sep='')
- use <- effects[[eff]]$effectName %in%
- effectname
- effects[[eff]][use, c('include','initialValue',
- 'groupName', 'group', 'period')] <-
- list(TRUE, starts$startRate,
- groupNames[group], group,
- 1:noPeriods)
- ## now sort out the tendency and update the
- ## attribute on the effects list:
- newdif <- c(starts$dif,
- attr(effects[[eff]], "starts")$dif)
- meandif <- mean(newdif, na.rm=TRUE)
- vardif <- var(as.vector(newdif), na.rm=TRUE)
- if (meandif < 0.9 * vardif)
- {
- tendency <- 0.5 * log((meandif + vardif)/
- (vardif - meandif))
- }
- else
- {
- tendency <- meandif / (vardif + 1)
- }
- untrimmed <- tendency
- tendency <- ifelse(tendency < -3.0, -3.0,
- ifelse(tendency > 3/0, 3.0, tendency))
- use <- (effects[[eff]]$shortName == "linear" &
- effects[[eff]]$type == "eval")
- effects[[eff]][use, c("include", "initialValue",
- "untrimmedValue")] <-
- list(TRUE, tendency,
- untrimmed)
- attr(effects[[eff]], 'starts')$dif <- newdif
- },
- oneMode =
+ stop("depvars don't match")
+ }
+ effectname <- paste('rate ', varname,' (period ',
+ period + 1:noPeriods, ')',sep='')
+ use <- effects[[eff]]$effectName %in% effectname
+ effects[[eff]][use, c('include','initialValue',
+ 'groupName', 'group', 'period')] <-
+ list(TRUE, starts$startRate,
+ groupNames[group], group, 1:noPeriods)
+ ## now sort out the tendency and update the
+ ## attribute on the effects list:
+ newdif <- c(starts$dif, attr(effects[[eff]], "starts")$dif)
+ meandif <- mean(newdif, na.rm=TRUE)
+ vardif <- var(as.vector(newdif), na.rm=TRUE)
+ if (meandif < 0.9 * vardif)
{
- starts <- getNetworkStartingVals(depvar)
- ## find the appropriate set of effects
- eff <- match(varname, names(effects))
- if (is.na(eff))
- {
- stop("depvars don't match")
- }
- effectname <- paste('constant ', varname,
- ' rate (period ',
+ tendency <- 0.5 * log((meandif + vardif)/
+ (vardif - meandif))
+ }
+ else
+ {
+ tendency <- meandif / (vardif + 1)
+ }
+ untrimmed <- tendency
+ tendency <- ifelse(tendency < -3.0, -3.0,
+ ifelse(tendency > 3/0, 3.0, tendency))
+ use <- (effects[[eff]]$shortName == "linear" &
+ effects[[eff]]$type == "eval")
+ effects[[eff]][use, c("include", "initialValue",
+ "untrimmedValue")] <- list(TRUE, tendency, untrimmed)
+ attr(effects[[eff]], 'starts')$dif <- newdif
+ },
+ oneMode =
+ {
+ starts <- getNetworkStartingVals(depvar)
+ ## first for the rate parameters
+ ## find the appropriate set of effects
+ eff <- match(varname, names(effects))
+ if (is.na(eff))
+ {
+ stop("depvars don't match")
+ }
+ thisSettingDescription <- paste(unlist(describeTheSetting(depvar)), collapse=" ")
+ if (thisSettingDescription !=
+ paste(unlist(settingsList[[varname]]), collapse=" "))
+ {
+ stop(paste('setting definitions do not match (group ',
+ group,', variable ', varname,')', sep=''))
+
+ }
+ if (thisSettingDescription == "")
+ {
+ effectname <- paste('constant ', varname, ' rate (period ',
period + 1:noPeriods,')', sep='')
use <- effects[[eff]]$effectName %in% effectname
effects[[eff]][use, c('include', 'initialValue',
+ "groupName", "group", "period")] <-
+ list(TRUE, starts$startRate,
+ groupNames[group], group, 1:noPeriods)
+ }
+ else
+ {
+ effectname <- paste('setting rate ', varname, ' (period ',
+ period + 1:noPeriods,')', sep='')
+ use <- grep(effectname, effects[[eff]]$effectName, fixed=TRUE)
+ effects[[eff]][use, c('include', 'initialValue',
"groupName", "group", "period")] <-
- list(TRUE, starts$startRate,
- groupNames[group], group,
- 1:noPeriods)
- ## now sort out the degree and
- ## update the attribute on the effects list
- oldstarts <- attr(effects[[eff]], "starts")
- alpha <- c(oldstarts$alpha, starts$alpha)
- prec <- c(oldstarts$prec, starts$prec)
- degree <- sum(alpha * prec) / sum(prec)
- untrimmed <- degree
- degree <- ifelse (degree < -3, -3,
- ifelse(degree > 3, 3, degree))
- attr(effects[[eff]], "starts")$alpha <- alpha
- attr(effects[[eff]], "starts")$prec <- prec
- if (attr(depvar, 'symmetric'))
- {
- effects[[eff]][effects[[eff]]$shortName ==
- 'density' &
- effects[[eff]]$type == 'eval',
- c('initialValue','untrimmedValue')] <-
- list(degree, untrimmed)
- }
- else
- {
- if (!(attr(x,'anyUpOnly') || attr(x, 'anyDownOnly')))
- {
- effects[[eff]][effects[[eff]]$shortName ==
- 'density' &
- effects[[eff]]$type == 'eval',
- c('initialValue',
- "untrimmedValue")] <-
- list(degree, untrimmed)
- }
- }
- effects
-
- },
- bipartite =
+ list(TRUE, starts$startRateSett,
+ groupNames[group], group, 1:noPeriods)
+ }
+ ## now sort out the degree and
+ ## update the attribute on the effects list
+ oldstarts <- attr(effects[[eff]], "starts")
+ alpha <- c(oldstarts$alpha, starts$alpha)
+ prec <- c(oldstarts$prec, starts$prec)
+ degree <- sum(alpha * prec) / sum(prec)
+ untrimmed <- degree
+ degree <- ifelse (degree < -3, -3,
+ ifelse(degree > 3, 3, degree))
+ attr(effects[[eff]], "starts")$alpha <- alpha
+ attr(effects[[eff]], "starts")$prec <- prec
+ if (attr(depvar, 'symmetric'))
{
- starts <- getBipartiteStartingVals(depvar)
- ## find the appropriate set of effects
- eff <- match(varname, names(effects))
- if (is.na(eff))
+ effects[[eff]][effects[[eff]]$shortName ==
+ 'density' &
+ effects[[eff]]$type == 'eval',
+ c('initialValue','untrimmedValue')] <-
+ list(degree, untrimmed)
+ }
+ else
+ {
+ if (!(attr(x,'anyUpOnly') || attr(x, 'anyDownOnly')))
{
- stop("depvars don't match")
+ effects[[eff]][effects[[eff]]$shortName ==
+ 'density' &
+ effects[[eff]]$type == 'eval',
+ c('initialValue',
+ "untrimmedValue")] <-
+ list(degree, untrimmed)
}
- effectname <- paste('constant ', varname,
- ' rate (period ',
- period + 1:noPeriods,')', sep='')
- use <- effects[[eff]]$effectName %in% effectname
- effects[[eff]][use, c('include', 'initialValue',
- 'groupName', 'group',
- 'period')] <-
- list(TRUE, starts$startRate,
- groupNames[group],
- group, 1:noPeriods)
- ## now sort out the degree and
- ## update the attribute on the effects list
- oldstarts <- attr(effects[[eff]], "starts")
- alpha <- c(oldstarts$alpha, starts$alpha)
- prec <- c(oldstarts$prec, starts$prec)
- degree <- sum(alpha * prec) / sum(prec)
- untrimmed <- degree
- degree <- ifelse (degree < -3, -3,
- ifelse(degree > 3, 3, degree))
- attr(effects[[eff]], "starts")$alpha <- alpha
- attr(effects[[eff]], "starts")$prec <- prec
- if (!(attr(x,'anyUpOnly') || attr(x, 'anyDownOnly')))
- {
- effects[[eff]][effects[[eff]]$shortName ==
- 'density' &
- effects[[eff]]$type == 'eval',
- c('initialValue',
- "untrimmedValue")] <-
- list(degree, untrimmed)
- }
- effects
-
- },
- stop('error type'))
+ }
+ },
+ bipartite =
+ {
+ starts <- getBipartiteStartingVals(depvar)
+ ## first for the rate parameters
+ ## find the appropriate set of effects
+ eff <- match(varname, names(effects))
+ if (is.na(eff))
+ {
+ stop("depvars don't match")
+ }
+ effectname <- paste('constant ', varname,
+ ' rate (period ',
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 341
More information about the Rsiena-commits
mailing list