[Rsiena-commits] r227 - in pkg: RSiena RSiena/R RSiena/data RSiena/inst/doc RSiena/inst/scripts RSiena/man RSiena/src RSiena/src/data RSiena/src/model RSiena/src/model/effects RSiena/src/model/effects/generic RSiena/src/model/filters RSiena/src/model/variables RSiena/src/network RSiena/tests RSienaTest RSienaTest/R RSienaTest/data RSienaTest/doc RSienaTest/inst/doc RSienaTest/inst/examples RSienaTest/inst/scripts RSienaTest/man RSienaTest/src RSienaTest/src/model RSienaTest/src/model/effects RSienaTest/src/model/effects/generic RSienaTest/tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Apr 19 19:29:02 CEST 2013
Author: tomsnijders
Date: 2013-04-19 19:29:01 +0200 (Fri, 19 Apr 2013)
New Revision: 227
Added:
pkg/RSiena/R/sienaGOF.r
pkg/RSiena/R/sienatable.r
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/hn3401.Rd
pkg/RSiena/man/n3401.Rd
pkg/RSiena/man/siena07.Rd
pkg/RSiena/man/sienaAlgorithmCreate.Rd
pkg/RSiena/man/sienaDependent.Rd
pkg/RSiena/src/Makevars
pkg/RSiena/src/model/effects/DiffusionRateEffect.cpp
pkg/RSiena/src/model/effects/DiffusionRateEffect.h
pkg/RSiena/src/model/effects/InIsolateDegreeEffect.cpp
pkg/RSiena/src/model/effects/InIsolateDegreeEffect.h
pkg/RSiena/src/model/effects/IsolateNetEffect.cpp
pkg/RSiena/src/model/effects/IsolateNetEffect.h
pkg/RSiena/src/model/effects/IsolatePopEffect.cpp
pkg/RSiena/src/model/effects/IsolatePopEffect.h
pkg/RSiena/src/model/effects/JumpCovariateTransitiveTripletsEffect.cpp
pkg/RSiena/src/model/effects/JumpCovariateTransitiveTripletsEffect.h
pkg/RSiena/src/model/effects/SameCovariateTransitiveTripletsEffect.cpp
pkg/RSiena/src/model/effects/SameCovariateTransitiveTripletsEffect.h
pkg/RSiena/src/model/effects/SimilarityTransitiveTripletsEffect.cpp
pkg/RSiena/src/model/effects/SimilarityTransitiveTripletsEffect.h
pkg/RSiena/src/model/effects/TransitiveReciprocatedTripletsEffect.cpp
pkg/RSiena/src/model/effects/TransitiveReciprocatedTripletsEffect.h
pkg/RSiena/src/model/effects/generic/CovariateMixedNetworkAlterFunction.cpp
pkg/RSiena/src/model/effects/generic/CovariateMixedNetworkAlterFunction.h
pkg/RSiena/src/model/effects/generic/GwespFunction.cpp
pkg/RSiena/src/model/effects/generic/GwespFunction.h
pkg/RSiena/src/model/effects/generic/OutStarFunction.cpp
pkg/RSiena/src/model/effects/generic/OutStarFunction.h
pkg/RSiena/src/model/effects/generic/ReverseTwoPathFunction.cpp
pkg/RSiena/src/model/effects/generic/ReverseTwoPathFunction.h
pkg/RSiena/src/model/effects/generic/SameCovariateMixedTwoPathFunction.cpp
pkg/RSiena/src/model/effects/generic/SameCovariateMixedTwoPathFunction.h
pkg/RSiena/src/model/effects/generic/SameCovariateTwoPathFunction.cpp
pkg/RSiena/src/model/effects/generic/SameCovariateTwoPathFunction.h
pkg/RSienaTest/R/sienaBayes.r
pkg/RSienaTest/man/hn3401.Rd
pkg/RSienaTest/man/n3401.Rd
pkg/RSienaTest/man/sienaAlgorithmCreate.Rd
pkg/RSienaTest/man/sienaBayes.Rd
pkg/RSienaTest/man/sienaDependent.Rd
pkg/RSienaTest/man/sienaGOF-auxiliary.Rd
Removed:
pkg/RSiena/R/bayes.r
pkg/RSiena/man/HN3401.Rd
pkg/RSiena/man/N3401.Rd
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/bayes.Rd
pkg/RSiena/man/siena07.Rd
pkg/RSiena/man/sienaModelCreate.Rd
pkg/RSiena/man/sienaNet.Rd
pkg/RSiena/src/Makevars
pkg/RSienaTest/R/bayes.r
pkg/RSienaTest/man/HN3401.Rd
pkg/RSienaTest/man/N3401.Rd
pkg/RSienaTest/man/bayes.Rd
pkg/RSienaTest/man/sienaModelCreate.Rd
pkg/RSienaTest/man/sienaNet.Rd
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/NAMESPACE
pkg/RSiena/R/effects.r
pkg/RSiena/R/effectsDocumentation.r
pkg/RSiena/R/initializeFRAN.r
pkg/RSiena/R/maxlike.r
pkg/RSiena/R/maxlikec.r
pkg/RSiena/R/phase1.r
pkg/RSiena/R/phase2.r
pkg/RSiena/R/phase3.r
pkg/RSiena/R/print01Report.r
pkg/RSiena/R/print07Report.r
pkg/RSiena/R/printInitialDescription.r
pkg/RSiena/R/robmon.r
pkg/RSiena/R/siena01.r
pkg/RSiena/R/siena07.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienaDataCreateFromSession.r
pkg/RSiena/R/sienaModelCreate.r
pkg/RSiena/R/sienaTimeTest.r
pkg/RSiena/R/sienaeffects.r
pkg/RSiena/R/sienaprint.r
pkg/RSiena/R/sienautils.r
pkg/RSiena/R/terminateFRAN.r
pkg/RSiena/changeLog
pkg/RSiena/data/allEffects.csv
pkg/RSiena/inst/doc/RSiena.bib
pkg/RSiena/inst/doc/RSiena_Manual.pdf
pkg/RSiena/inst/doc/RSiena_Manual.tex
pkg/RSiena/inst/scripts/RSienaSNADescriptives.R
pkg/RSiena/inst/scripts/Rscript01DataFormat.R
pkg/RSiena/inst/scripts/Rscript02SienaVariableFormat.R
pkg/RSiena/inst/scripts/Rscript03SienaRunModel.R
pkg/RSiena/inst/scripts/Rscript04SienaBehaviour.R
pkg/RSiena/man/coCovar.Rd
pkg/RSiena/man/coDyadCovar.Rd
pkg/RSiena/man/edit.sienaEffects.Rd
pkg/RSiena/man/effectsDocumentation.Rd
pkg/RSiena/man/getEffects.Rd
pkg/RSiena/man/includeEffects.Rd
pkg/RSiena/man/includeInteraction.Rd
pkg/RSiena/man/includeTimeDummy.Rd
pkg/RSiena/man/iwlsm.Rd
pkg/RSiena/man/maxlikefn.Rd
pkg/RSiena/man/plot.sienaTimeTest.Rd
pkg/RSiena/man/print.sienaEffects.Rd
pkg/RSiena/man/print.sienaMeta.Rd
pkg/RSiena/man/print01Report.Rd
pkg/RSiena/man/s50.Rd
pkg/RSiena/man/s503.Rd
pkg/RSiena/man/s50a.Rd
pkg/RSiena/man/setEffect.Rd
pkg/RSiena/man/siena01Gui.Rd
pkg/RSiena/man/siena08.Rd
pkg/RSiena/man/sienaCompositionChange.Rd
pkg/RSiena/man/sienaDataConstraint.Rd
pkg/RSiena/man/sienaDataCreate.Rd
pkg/RSiena/man/sienaFit.Rd
pkg/RSiena/man/sienaGroupCreate.Rd
pkg/RSiena/man/sienaNodeSet.Rd
pkg/RSiena/man/sienaTimeTest.Rd
pkg/RSiena/man/simstats0c.Rd
pkg/RSiena/man/summary.iwlsm.Rd
pkg/RSiena/man/tmp3.Rd
pkg/RSiena/man/tmp4.Rd
pkg/RSiena/man/updateTheta.Rd
pkg/RSiena/man/varCovar.Rd
pkg/RSiena/man/varDyadCovar.Rd
pkg/RSiena/man/xtable.Rd
pkg/RSiena/src/data/
pkg/RSiena/src/data/ChangingDyadicCovariate.cpp
pkg/RSiena/src/data/ChangingDyadicCovariate.h
pkg/RSiena/src/data/ConstantDyadicCovariate.cpp
pkg/RSiena/src/data/ConstantDyadicCovariate.h
pkg/RSiena/src/data/NetworkLongitudinalData.cpp
pkg/RSiena/src/data/NetworkLongitudinalData.h
pkg/RSiena/src/model/EffectInfo.cpp
pkg/RSiena/src/model/Model.cpp
pkg/RSiena/src/model/Model.h
pkg/RSiena/src/model/StatisticCalculator.cpp
pkg/RSiena/src/model/StatisticCalculator.h
pkg/RSiena/src/model/effects/
pkg/RSiena/src/model/effects/AllEffects.h
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/effects/OutdegreePopularityEffect.cpp
pkg/RSiena/src/model/effects/WWXClosureEffect.cpp
pkg/RSiena/src/model/effects/WWXClosureEffect.h
pkg/RSiena/src/model/effects/generic/
pkg/RSiena/src/model/effects/generic/AlterPredicate.h
pkg/RSiena/src/model/effects/generic/CovariatePredicate.h
pkg/RSiena/src/model/effects/generic/MixedNetworkAlterFunction.cpp
pkg/RSiena/src/model/effects/generic/OutDegreeFunction.cpp
pkg/RSiena/src/model/effects/generic/OutDegreeFunction.h
pkg/RSiena/src/model/filters/PermittedChangeFilter.h
pkg/RSiena/src/model/variables/DependentVariable.cpp
pkg/RSiena/src/model/variables/DependentVariable.h
pkg/RSiena/src/model/variables/NetworkVariable.cpp
pkg/RSiena/src/model/variables/NetworkVariable.h
pkg/RSiena/src/network/NetworkUtils.cpp
pkg/RSiena/src/network/NetworkUtils.h
pkg/RSiena/src/siena07internals.cpp
pkg/RSiena/src/siena07internals.h
pkg/RSiena/src/siena07setup.cpp
pkg/RSiena/tests/parallel.R
pkg/RSiena/tests/parallel.Rout.save
pkg/RSiena/tests/scriptfile.Rout.save
pkg/RSiena/tests/scriptfile.Rout.win
pkg/RSiena/tests/scripts.Rout.save
pkg/RSienaTest/
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/NAMESPACE
pkg/RSienaTest/R/
pkg/RSienaTest/R/algorithms.r
pkg/RSienaTest/R/document.r
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/effectsDocumentation.r
pkg/RSienaTest/R/initializeFRAN.r
pkg/RSienaTest/R/maxlike.r
pkg/RSienaTest/R/maxlikec.r
pkg/RSienaTest/R/phase1.r
pkg/RSienaTest/R/phase2.r
pkg/RSienaTest/R/phase3.r
pkg/RSienaTest/R/print01Report.r
pkg/RSienaTest/R/robmon.r
pkg/RSienaTest/R/siena01.r
pkg/RSienaTest/R/siena07.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaDataCreateFromSession.r
pkg/RSienaTest/R/sienaGOF.r
pkg/RSienaTest/R/sienaModelCreate.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/changeLog
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/doc/
pkg/RSienaTest/doc/RSIENAspec.tex
pkg/RSienaTest/doc/RSienaDeveloper.tex
pkg/RSienaTest/doc/Siena_algorithms4.tex
pkg/RSienaTest/doc/missingsEtc.tex
pkg/RSienaTest/inst/doc/
pkg/RSienaTest/inst/doc/RSiena.bib
pkg/RSienaTest/inst/doc/RSiena_Manual.pdf
pkg/RSienaTest/inst/doc/RSiena_Manual.tex
pkg/RSienaTest/inst/examples/runalg.r
pkg/RSienaTest/inst/scripts/RSienaSNADescriptives.R
pkg/RSienaTest/inst/scripts/Rscript01DataFormat.R
pkg/RSienaTest/inst/scripts/Rscript02SienaVariableFormat.R
pkg/RSienaTest/inst/scripts/Rscript03SienaRunModel.R
pkg/RSienaTest/inst/scripts/Rscript04SienaBehaviour.R
pkg/RSienaTest/man/
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/algorithms.Rd
pkg/RSienaTest/man/coCovar.Rd
pkg/RSienaTest/man/coDyadCovar.Rd
pkg/RSienaTest/man/edit.sienaEffects.Rd
pkg/RSienaTest/man/effectsDocumentation.Rd
pkg/RSienaTest/man/getEffects.Rd
pkg/RSienaTest/man/includeEffects.Rd
pkg/RSienaTest/man/includeInteraction.Rd
pkg/RSienaTest/man/includeTimeDummy.Rd
pkg/RSienaTest/man/iwlsm.Rd
pkg/RSienaTest/man/maxlikefn.Rd
pkg/RSienaTest/man/plot.sienaTimeTest.Rd
pkg/RSienaTest/man/print.sienaBayesFit.Rd
pkg/RSienaTest/man/print.sienaEffects.Rd
pkg/RSienaTest/man/print.sienaMeta.Rd
pkg/RSienaTest/man/print01Report.Rd
pkg/RSienaTest/man/profileLikelihoods.Rd
pkg/RSienaTest/man/s50.Rd
pkg/RSienaTest/man/s503.Rd
pkg/RSienaTest/man/s50a.Rd
pkg/RSienaTest/man/setEffect.Rd
pkg/RSienaTest/man/siena01Gui.Rd
pkg/RSienaTest/man/siena07.Rd
pkg/RSienaTest/man/siena08.Rd
pkg/RSienaTest/man/sienaCompositionChange.Rd
pkg/RSienaTest/man/sienaDataConstraint.Rd
pkg/RSienaTest/man/sienaDataCreate.Rd
pkg/RSienaTest/man/sienaFit.Rd
pkg/RSienaTest/man/sienaGOF.Rd
pkg/RSienaTest/man/sienaGroupCreate.Rd
pkg/RSienaTest/man/sienaNodeSet.Rd
pkg/RSienaTest/man/sienaTimeTest.Rd
pkg/RSienaTest/man/simstats0c.Rd
pkg/RSienaTest/man/summary.iwlsm.Rd
pkg/RSienaTest/man/tmp3.Rd
pkg/RSienaTest/man/tmp4.Rd
pkg/RSienaTest/man/updateTheta.Rd
pkg/RSienaTest/man/varCovar.Rd
pkg/RSienaTest/man/varDyadCovar.Rd
pkg/RSienaTest/man/xtable.Rd
pkg/RSienaTest/src/Makevars
pkg/RSienaTest/src/model/EffectInfo.cpp
pkg/RSienaTest/src/model/Model.cpp
pkg/RSienaTest/src/model/effects/
pkg/RSienaTest/src/model/effects/OutdegreePopularityEffect.cpp
pkg/RSienaTest/src/model/effects/generic/OutDegreeFunction.cpp
pkg/RSienaTest/src/model/effects/generic/OutDegreeFunction.h
pkg/RSienaTest/tests/
pkg/RSienaTest/tests/effectsTest.R
pkg/RSienaTest/tests/parallel.R
pkg/RSienaTest/tests/parallel.Rout.save
pkg/RSienaTest/tests/sampson.r
pkg/RSienaTest/tests/scriptfile.Rout.save
pkg/RSienaTest/tests/scriptfile.Rout.win
pkg/RSienaTest/tests/scripts.Rout.save
Log:
Changes in RSiena as well as RSienaTest;
both now are very similar; sienaBayes, algorithms, and profileLikelihoods
are the only functions in RSienaTest not in RSiena.
Available effects now are the same.
For Siena only:
* function bayes() removed.
* Attributes "allowOnly" and "simOnly" ported from RSienaTest.
* Improved error messages in includeEffects ported from RSienaTest.
* sienaGOF ported from RSienaTest.
* siena.table() ported from RSienaTest, in file sienatable.r.
* Changes of revision 226 ported from RSienaTest.
For RSienaTest only:
* bayes() renamed to sienaBayes() and considerably changed,
with print method.
* Some invisible developments for settings model.
For RSiena and RSienaTest:
* Changes to sienaGOF.
* The function sienaModelCreate() now called sienaAlgorithmCreate(),
but the earlier name is still retained as an alias;
the class name of the object created by this function now called
sienaAlgorithm.
* The function sienaNet() now called sienaDependent(),
but the earlier name is still retained as an alias;
the class name of the object created by this function is now
sienaDependent.
* The function effectsDocumentation() extended.
* Effect type "covarBehaviorOneModeRate" was added.
* Many added effects (some existed already in RSienaTest).
* Added to siena07: options "Dolby" and "diagonalize".
* sienaTimeTest() updated.
* Truncation of update steps in phase2.r modified.
* Overall maximum convergence ratio, x$tconv.max, added tro siena07.
* The print method for objects of class siena extended.
* A bug in the starting values for two-mode networks was corrected.
* Small bug fixed in print01Report().
* Changed almost all .Rd documentation files.tions.
* Updated:
pkg\RSiena(Test)\inst\scripts\Rscript01DataFormat.R,
pkg\RSiena(Test)\inst\scripts\Rscript02VariableFormat.R,
pkg\RSiena(Test)\inst\scripts\Rscript03SienaRunModel.R,
pkg\RSiena(Test)\inst\scripts\Rscript04SienaBehaviour.R.
(of pkg\RSiena(Test)\inst\scripts\RSienaDescriptives
only the date was changed.)
* Updated tests\scriptfile.Rout.win to current version
(scriptfile.Rout.save).
* Manual and siena.bib updated.
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2013-04-17 05:18:22 UTC (rev 226)
+++ pkg/RSiena/DESCRIPTION 2013-04-19 17:29:01 UTC (rev 227)
@@ -1,10 +1,10 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.1-223
-Date: 2013-01-01
+Version: 1.1-227
+Date: 2013-04-19
Author: Various
-Depends: R (>= 2.10.0)
+Depends: R (>= 2.15.0)
Imports: Matrix
Suggests: tcltk, snow, rlecuyer, network, codetools, lattice, MASS, parallel,
xtable, tools
Modified: pkg/RSiena/NAMESPACE
===================================================================
--- pkg/RSiena/NAMESPACE 2013-04-17 05:18:22 UTC (rev 226)
+++ pkg/RSiena/NAMESPACE 2013-04-19 17:29:01 UTC (rev 227)
@@ -1,11 +1,15 @@
useDynLib(RSiena)
export(coCovar, coDyadCovar, getEffects, model.create, print01Report,
-siena01Gui, siena07, sienaCompositionChange, bayes, updateTheta,
+siena01Gui, siena07, sienaCompositionChange, updateTheta,
sienaCompositionChangeFromFile, sienaDataCreate, sienaDataCreateFromSession,
-sienaGroupCreate, sienaModelCreate, sienaNet, sienaNodeSet, xtable.sienaFit,
- varCovar, varDyadCovar, setEffect, includeEffects, includeInteraction,
- effectsDocumentation, sienaDataConstraint, print.xtable.sienaFit,
- installGui, siena08, iwlsm, sienaTimeTest, includeTimeDummy, xtable)
+sienaGroupCreate, sienaModelCreate, sienaAlgorithmCreate, sienaNet,
+sienaDependent, sienaNodeSet, xtable.sienaFit,
+varCovar, varDyadCovar, setEffect, includeEffects, includeInteraction,
+effectsDocumentation, sienaDataConstraint, print.xtable.sienaFit,
+installGui, siena08, iwlsm, sienaTimeTest, includeTimeDummy,
+sienaGOF, sparseMatrixExtraction, networkExtraction, behaviorExtraction,
+OutdegreeDistribution, IndegreeDistribution, BehaviorDistribution,
+siena.table, xtable)
import(Matrix)
@@ -13,7 +17,7 @@
S3method(print, sienaGroup)
S3method(print, sienaFit)
S3method(print, summary.sienaFit)
-S3method(print, sienaModel)
+S3method(print, sienaAlgorithm)
S3method(summary, sienaFit)
S3method(print, sienaMeta)
S3method(print, summary.sienaMeta)
@@ -39,4 +43,7 @@
S3method(summary, sienaEffects)
S3method(print, summary.sienaEffects)
S3method(edit, sienaEffects)
+S3method(summary, sienaGOF)
+S3method(print, sienaGOF)
+S3method(plot, sienaGOF)
S3method(print, chains.data.frame)
Deleted: pkg/RSiena/R/bayes.r
===================================================================
--- pkg/RSiena/R/bayes.r 2013-04-17 05:18:22 UTC (rev 226)
+++ pkg/RSiena/R/bayes.r 2013-04-19 17:29:01 UTC (rev 227)
@@ -1,608 +0,0 @@
-##/*****************************************************************************
-## * SIENA: Simulation Investigation for Empirical Network Analysis
-## *
-## * Web: http://www.stats.ox.ac.uk/~snidjers/siena
-## *
-## * File: bayes.r
-## *
-## * Description: This file contains the code to run Bayesian simulation.
-## * Many functions are defined within others to reduce copying of objects.
-## *
-## ****************************************************************************/
-##@bayes Bayesian fit a Bayesian model
-bayes <- function(data, effects, model, nwarm=100, nmain=100, nrunMHBatches=20,
- plotit=FALSE, nbrNodes=1, dfra=NULL, n=10,
- priorSigma=NULL, prevAns=NULL, clusterType=c("PSOCK", "FORK"),
- getDocumentation=FALSE)
-{
- ##@createStores internal bayes Bayesian set up stores
- createStores <- function()
- {
- npar <- length(z$theta)
- numberRows <- nmain * nrunMHBatches
- z$posteriorTot <<- matrix(0, nrow=z$nGroup, ncol=npar)
- z$posteriorMII <<- array(0, dim=c(z$nGroup, npar, npar))
- z$candidates <<- array(NA, dim=c(numberRows, z$nGroup, npar))
- z$acceptances <<- matrix(NA, ncol=z$nGroup, nrow=numberRows)
- z$MHacceptances <<- array(NA, dim=c(numberRows, z$nGroup,
- z$nDependentVariables, 9))
- z$MHrejections <<- array(NA, dim=c(numberRows, z$nGroup,
- z$nDependentVariables, 9))
- z$MHproportions <<- array(NA, dim=c(numberRows, z$nGroup,
- z$nDependentVariables, 9))
- }
- ##@storeData internal bayes Bayesian put data in stores
- storeData <- function()
- {
- start <- z$sub + 1
- nrun <- nrow(z$parameters)
- end <- start + nrun - 1
- z$acceptances[start:end, ] <<- z$accepts
- z$candidates[start:end,, ] <<- z$parameters
- z$posteriorTot <<- z$posteriorTot + colSums(z$parameters)
- for (group in 1:z$nGroup)
- {
- for (i in dim(z$parameters)[1])
- {
- z$posteriorMII[group, , ] <<- z$posteriorMII[group, ,] +
- outer(z$parameters[i, group, ], z$parameters[i, group, ])
- }
- }
- z$MHacceptances[start:end, , , ] <<- z$MHaccepts
- z$MHrejections[start:end, , , ] <<- z$MHrejects
- z$MHproportions[start:end, , , ] <<- z$MHaccepts /
- (z$MHaccepts + z$MHrejects)
- z$sub <<- z$sub + nrun
-
- }
- ##@improveMH internal bayes Bayesian find scale factors
- improveMH <- function(tiny=1.0e-15, desired=40, maxiter=100,
- tolerance=15, getDocumentation=FALSE)
- {
- ##@rescaleCGD internal improveMH Bayesian
- rescaleCGD <- function(iter)
- {
- u <- ifelse (actual > desired,
- 2 - ((iter - actual) / (iter - desired)),
- 1 / (2 - (actual / desired)))
- number <<- ifelse(abs(actual - desired) <= tolerance,
- number + 1, 0 )
- success <<- number >= 2
- u
- }
- if (getDocumentation)
- {
- tt <- getInternals()
- return(tt)
- }
- iter <- 0
- number <- rep(0, z$nGroup)
- success <- rep(FALSE, z$nGroup)
- repeat
- {
- iter <- iter + 1
- MCMCcycle(nrunMH=1, nrunMHBatches=100, change=FALSE)
- actual <- z$BayesAcceptances ## acceptances
- ans <- rescaleCGD(100)
- update <- number < 3
- z$scaleFactors[update] <<- z$scaleFactors[update] * ans[update]
- cat(actual, ans, z$scaleFactors, '\n')
- if (all(success) || iter == maxiter)
- {
- break
- }
- if (any(z$scaleFactors < tiny))
- {
- cat('scalefactor < tiny\n')
- browser()
- }
- }
- cat('fine tuning took ', iter, ' iterations. Scalefactor:',
- z$scaleFactors, '\n')
- }
- ##@MCMCcycle internal Bayes do some loops of (MH steps and sample parameters)
- MCMCcycle <- function(nrunMH, nrunMHBatches, change=TRUE)
- {
- z$accepts <<- matrix(NA, nrow=z$nGroup, nrunMHBatches)
- z$parameters <<- array(NA, dim=c(nrunMHBatches, z$nGroup, z$pp))
- z$MHaccepts <<- array(NA, dim=c(nrunMHBatches, z$nGroup,
- z$nDependentVariables, 9))
- z$MHrejects <<- array(NA, dim=c(nrunMHBatches, z$nGroup,
- z$nDependentVariables, 9))
- z$MHaborts <<- array(NA, dim=c(nrunMHBatches, z$nGroup,
- z$nDependentVariables, 9))
- storeNrunMH <- z$nrunMH
- z$nrunMH <<- nrunMH
- for (i in 1:nrunMHBatches)
- {
- # cc <- proc.time()[1]
-
- ans <- z$FRAN(z, byGroup=TRUE, returnLoglik=TRUE, onlyLoglik=TRUE)
- # c2 <- proc.time()[1]
- # cat ('fran',c2-cc,'\n')
- z$loglik <<- ans$loglik
- # cc <- proc.time()[1]
- sampleParameters(change)
- # cc1 <- proc.time()[1]
- # cat('samp',cc1-cc, '\n')
- z$accepts[, i] <<- z$accept
- z$parameters[i, , ] <<- z$thetaMat
- z$MHaccepts[i, , , ] <<-
- t(do.call(cbind,
- tapply(ans$accepts, factor(z$callGrid[, 1]),
- function(x)Reduce("+", x))))
- z$MHrejects[i, , , ] <<-
- t(do.call(cbind, tapply(ans$rejects, factor(z$callGrid[, 1]),
- function(x)Reduce("+", x))))
- z$MHaborts[i, , , ] <<- t(do.call(cbind,
- tapply(ans$aborts,
- factor(z$callGrid[, 1]),
- function(x)Reduce("+", x))))
- }
- z$BayesAcceptances <<- rowSums(z$accepts)
- z$nrunMH <<- storeNrunMH
- }
- ##@sampleParameters algorithms propose new parameters and accept them or not
- sampleParameters <- function(change=TRUE)
- {
- ## get a multivariate normal with covariance matrix dfra multiplied by a
- ## scale factor which varies between groups
- require(MASS)
- thetaChanges <- t(sapply(1:z$nGroup, function(i)
- {
- tmp <- z$thetaMat[i, ]
- use <- !is.na(z$thetaMat[i, ])
- tmp[use] <-
- mvrnorm(1, mu=rep(0, sum(use)),
- Sigma=z$scaleFactors[i] *
- z$dfra[use, use])
- tmp
- }
- ))
-
- thetaOld <- z$thetaMat
- thetaOld[, z$basicRate] <- log(thetaOld[, z$basicRate])
- thetaNew <- thetaOld + thetaChanges
-
- priorOld <- sapply(1:z$nGroup, function(i)
- {
- tmp <- thetaOld[i, ]
- use <- !is.na(tmp)
- dmvnorm(tmp[use], mean=rep(0, sum(use)),
- sigma=z$priorSigma[use, use])
- }
- )
- priorNew <- sapply(1:z$nGroup, function(i)
- {
- tmp <- thetaNew[i, ]
- use <- !is.na(tmp)
- dmvnorm(tmp[use], mean=rep(0, sum(use)),
- sigma=z$priorSigma[use, use])
- }
- )
- logpOld <- z$loglik
-
- thetaNew[, z$basicRate] <- exp(thetaNew[, z$basicRate])
- z$thetaMat <<- thetaNew
- logpNew <- getProbabilitiesFromC(z)[[1]]
- proposalProbability <- priorNew - priorOld + logpNew - logpOld
- ##cat(proposalProbability, priorNew, priorOld, logpNew, logpOld, '\n')
- z$accept <<- log(runif(length(proposalProbability))) <
- proposalProbability
- thetaOld[, z$basicRate] <- exp(thetaOld[, z$basicRate])
- if (!change)
- {
- z$thetaMat <<- thetaOld
- }
- else
- {
- ##print(z$thetaMat)
- z$thetaMat[!z$accept, ] <<- thetaOld[!z$accept, ]
- }
-## print(thetaNew)
- }
- ## ################################
- ## start of function proper
- ## ################################
- if (getDocumentation != FALSE)
- {
- if (getDocumentation == TRUE)
- {
- tt <- getInternals()
- return(tt)
- }
- else ## need to run getInternals on the argument value
- {
- targs <- formals(getDocumentation[1])
- targs[1:length(targs)] <- 1
- targs['getDocumentation'] <- TRUE
- if (length(getDocumentation) > 1)
- {
- targs['getDocumentation'] <- getDocumentation[-1]
- }
- return(do.call(getDocumentation[1], targs))
- }
- }
- ctime <- proc.time()[1]
-
- z <- initializeBayes(data, effects, model, nbrNodes, priorSigma,
- prevAns=prevAns, clusterType=clusterType)
- createStores()
-
- z$sub <- 0
-
- if (is.null(z$dfra) && is.null(dfra))
- {
- z <- getDFRA(z, n)
- }
- else
- {
- if (!is.null(dfra))
- {
- z$dfra <- dfra
- }
- else
- {
- if (is.null(z$sf))
- {
- stop("need some scores to scale dfra")
- }
- z$dfra <- scaleDfra(z)
- }
-
- }
- ctime1 <- proc.time()[1]
- cat(ctime1-ctime,'\n')
- improveMH()
- ctime2<- proc.time()[1]
-
- cat('improvMh', ctime2-ctime1,'\n')
-
- if (plotit)
- {
- require(lattice)
- dev.new()
- thetaplot = dev.cur()
- dev.new()
- ratesplot = dev.cur()
- dev.new()
- tseriesplot = dev.cur()
- dev.new()
- tseriesratesplot = dev.cur()
- }
-
- for (ii in 1:nwarm)
- {
- MCMCcycle(nrunMH=4, nrunMHBatches=20)
- }
- print('endof warm')
- ctime3<- proc.time()[1]
-
- cat('warm', ctime3-ctime2,'\n')
- for (ii in 1:nmain)
- {
- MCMCcycle(nrunMH=z$nrunMH, nrunMHBatches=nrunMHBatches)
- storeData()
- ctime4<- proc.time()[1]
- cat('main', ii, ctime4-ctime3,'\n')
- ctime3 <- ctime4
-
- if (ii %% 10 == 0 && plotit) ## do some plots
- {
- cat('main after ii', ii, '\n')
- dev.set(thetaplot)
- thetadf <-
- lapply(1:z$nGroup, function(i)
- {
- data.frame(Group=rep(i, ii * nrunMHBatches),
- z$candidates[1:(ii * nrunMHBatches), i, ])
- }
- )
- thetadf <- do.call(rbind, thetadf)
- basicRate <- z$basicRate
- ##thetadf <- data.frame(z$candidates)
- acceptsdf <- data.frame(z$MHproportions,
- z$acceptances)
- ratesdf <- thetadf[, -1, drop=FALSE][, z$basicRate, drop=FALSE]
- thetadf <- cbind(Group=thetadf[, 1, drop=FALSE],
- thetadf[, -1, drop=FALSE][,
- !z$basicRate, drop=FALSE])
- thetaNames<- paste(z$effects$name[!z$basicRate],
- z$effects$shortName[!z$basicRate], sep=".")
- rateNames <- paste(z$effects$name[basicRate],
- z$effects$shortName[basicRate],
- z$effects$period[basicRate],
- z$effects$group[basicRate], sep=".")
- names(ratesdf) <- rateNames
- ratesdf <- cbind(Group=thetadf[, 1, drop=FALSE], ratesdf)
- names(thetadf)[-1] <- make.names(thetaNames, unique=TRUE)
- names(acceptsdf) <- c("InsDiag", "CancDiag", "Permute", "InsPerm",
- "DelPerm", "InsMissing", "DelMissing",
- "BayesAccepts")
- varnames <- paste(names(thetadf)[-1], sep="", collapse= " + ")
- if (z$nGroup > 1)
- {
- varcall <- paste("~ ", varnames, " | Group", sep="",
- collapse="")
- }
- else
- {
- varcall <- paste("~ ", varnames, sep="", collapse="")
-
- }
- print(histogram(as.formula(varcall), data=thetadf, scales="free",
- outer=TRUE, breaks=NULL, type="density",
- panel=function(x, ...)
- {
- panel.histogram(x, ...)
- panel.densityplot(x, darg=list(na.rm=TRUE), ...)
- }
- ))
- dev.set(ratesplot)
- varnames <- paste(names(ratesdf)[-1], sep="", collapse= " + ")
- varcall <- paste("~ ", varnames, sep="", collapse="")
- print(histogram(as.formula(varcall), data=ratesdf, scales="free",
- outer=TRUE, breaks=NULL, type="density",
- panel=function(x, ...)
- {
- panel.histogram(x, ...)
- panel.densityplot(x, darg=list(na.rm=TRUE), ...)
- }
- ))
- varnames <- paste(names(thetadf)[-1], sep="", collapse= " + ")
- if (z$nGroup > 1)
- {
- varcall <- paste(varnames, "~ 1:", ii *
- nrunMHBatches * z$nGroup,
- " | Group", sep="", collapse="")
- }
- else
- {
- varcall <- paste(varnames, "~ 1:", ii *
- nrunMHBatches * z$nGroup,
- sep="", collapse="")
- }
- dev.set(tseriesplot)
- print(xyplot(as.formula(varcall), data=thetadf, scales="free",
- outer=TRUE))
- varnames <- paste(names(ratesdf)[-1], sep="", collapse= " + ")
- varcall <- paste(varnames, "~ 1:", ii * nrunMHBatches * z$nGroup,
- sep="", collapse="")
- dev.set(tseriesratesplot)
- print(xyplot(as.formula(varcall), data=ratesdf, scales="free",
- outer=TRUE))
- ## dev.set(acceptsplot)
- ## varnames <- paste(names(acceptsdf), sep="", collapse= " + ")
- ## varcall <- paste("~ ", varnames, sep="", collapse="")
- ## print(histogram(as.formula(varcall), data=acceptsdf,
- ## scales=list(x="same", y="free"),
- ## outer=TRUE, breaks=NULL, type="density",
- ## panel=function(x, ...)
- ## {
- ## panel.histogram(x, ...)
- ## panel.densityplot(x, darg=list(na.rm=TRUE), ...)
- ## }))
- }
- }
- z$FRAN <- NULL
- z
-}
-
-##@initializeBayes algorithms do set up for Bayesian model
-initializeBayes <- function(data, effects, model, nbrNodes, priorSigma,
- prevAns, clusterType=c("PSOCK", "FORK"))
-{
- ## initialise
- Report(openfiles=TRUE, type="n") #initialise with no file
- z <- NULL
- z$Phase <- 1
- z$Deriv <- FALSE
- z$FinDiff.method <- FALSE
- z$maxlike <- TRUE
- model$maxlike <- TRUE
- model$FRANname <- "maxlikec"
- z$print <- FALSE
- z$int <- 1
- z$int2 <- nbrNodes
- model$cconditional <- FALSE
- if (!is.null(model$randomSeed))
- {
- set.seed(model$randomSeed)
- ##seed <- model$randomSeed
- }
- else
- {
- if (exists(".Random.seed"))
- {
- rm(.Random.seed, pos=1)
- }
- newseed <- trunc(runif(1) * 1000000)
- set.seed(newseed) ## get R to create a random number seed for me.
- ##seed <- NULL
- }
- z$FRAN <- getFromNamespace(model$FRANname, pkgname)
- z <- initializeFRAN(z, model, data=data, effects=effects,
- prevAns=prevAns, initC=FALSE, onlyLoglik=TRUE)
- z$basicRate <- z$effects$basicRate
- z$nGroup <- z$f$nGroup
- is.batch(TRUE)
-
- WriteOutTheta(z)
-
- if (nbrNodes > 1 && z$observations > 1)
- {
- require(parallel)
- clusterType <- match.arg(clusterType)
- if (clusterType == "PSOCK")
- {
- clusterString <- rep("localhost", nbrNodes)
- z$cl <- makeCluster(clusterString, type = "PSOCK",
- outfile = "cluster.out")
- }
- else
- {
- z$cl <- makeCluster(nbrNodes, type = "FORK",
- outfile = "cluster.out")
- }
- clusterCall(z$cl, library, pkgname, character.only = TRUE)
- clusterCall(z$cl, storeinFRANstore, FRANstore())
- clusterCall(z$cl, FRANstore)
- clusterCall(z$cl, initializeFRAN, z, model,
- initC = TRUE, profileData=FALSE, returnDeps=FALSE)
- clusterSetRNGStream(z$cl, iseed = as.integer(runif(1,
- max=.Machine$integer.max)))
- }
-
- z$scaleFactors <- rep(1, z$nGroup)
- ## z$returnDataFrame <- TRUE # chains come back as data frames not lists
- z$returnChains <- FALSE
- if (is.null(priorSigma))
- {
- z$priorSigma <- diag(z$pp) * 10000
- }
- else
- {
- z$priorSigma <- priorSigma
- }
- groupPeriods <- attr(z$f, "groupPeriods")
- netnames <- z$f$depNames
- z$rateParameterPosition <-
- lapply(1:z$nGroup, function(i, periods, data)
- {
- lapply(1:periods[i], function(j)
- {
- rateEffects <-
- z$effects[z$effects$basicRate &
- z$effects$period == j &
- z$effects$group == i,]
- rateEffects <-
- rateEffects[match(netnames,
- rateEffects$name), ]
- tmp <- as.numeric(row.names(rateEffects))
- names(tmp) <- netnames
- tmp
- }
- )
- }, periods=groupPeriods - 1, data=z$f[1:z$nGroup]
- )
- z$ratePositions <- lapply(z$rateParameterPosition, unlist)
- for (i in 1:z$nGroup)
- {
- use <- rep(FALSE, z$pp)
- use[z$ratePositions[[i]]] <- TRUE
- use[!z$basicRate] <- TRUE
- z$thetaMat[i, !use] <- NA
- }
- z
-}
-##@getDFRA algorithms do a few ML iterations and calculate a derivative matrix
-getDFRA <- function(z, n)
-{
- ## do n MLmodelsteps with the initial thetas and get
- ## derivs
- z$sdf <- vector("list", n)
- z$sf <- matrix(0, nrow=n, ncol=z$pp)
- z$Deriv <- TRUE
- for (i in 1:n)
- {
- ans <- z$FRAN(z)
- z$sdf[[i]] <- ans$dff
- z$sf[i, ] <- colSums(ans$fra)
- }
- dfra <- t(as.matrix(Reduce("+", z$sdf) / length(z$sdf)))
- z$dfra <- dfra
- z$dfra <- scaleDfra(z)
- z$Deriv <- FALSE
- z
-}
-scaleDfra <- function(z)
-{
- lambda <- z$theta[z$basicRate]
- dfra <- z$dfra
- z$dfra[z$basicRate, ] <- z$dfra[z$basicRate,] * lambda
- z$dfra[, z$basicRate] <- z$dfra[, z$basicRate] * lambda
- diag(z$dfra)[z$basicRate] <- lambda *
- diag(dfra)[z$basicRate] + lambda * lambda *
- colMeans(z$sf)[z$basicRate]
- chol2inv(chol(z$dfra))
-}
-
-##@flattenChains algorithms converts a nested list of chains to a single list
-flattenChains <- function(zz)
-{
- for (i in 1:length(zz)) ##group
- {
- for (j in 1:length(zz[[i]])) ## period
- {
- attr(zz[[i]][[j]], "group") <- i
- attr(zz[[i]][[j]], "period") <- j
- }
- }
- zz <- do.call(c, zz)
- zz
-}
-##@dmvnorm algorithms calculated multivariate normal density:
-##inefficient: should not call mahalanobis and eigen with same sigma repeatedly
-dmvnorm <- function(x, mean , sigma)
-{
- if (is.vector(x))
- {
- x <- matrix(x, ncol=length(x))
- }
- distval <- mahalanobis(x, center=mean, cov=sigma)
- logdet <- sum(log(eigen(sigma, symmetric=TRUE, only.values=TRUE)$values))
- -(ncol(x) * log(2 * pi) + logdet + distval) / 2
-}
-
-##@getProbabilitiesFromC bayes gets loglik from chains in C
-getProbabilitiesFromC <- function(z, index=1, getScores=FALSE)
-{
- ## expects maximum likelihood parallelisations
- f <- FRANstore()
-
- callGrid <- z$callGrid
- ## z$int2 is the number of processors if iterating by period, so 1 means
- ## we are not. Can only parallelize by period1
- if (nrow(callGrid) == 1)
- {
- theta <- z$thetaMat[1,]
- ans <- .Call("getChainProbabilities", PACKAGE = pkgname, f$pData,
- f$pModel, as.integer(1), as.integer(1),
- as.integer(index), f$myeffects, theta, getScores)
- anss <- list(ans)
- }
- else
- {
- if (z$int2 == 1 )
- {
- anss <- apply(callGrid, 1,
- doGetProbabilitiesFromC, z$thetaMat, index, getScores)
- }
- else
- {
- use <- 1:(min(nrow(callGrid), z$int2))
- anss <- parRapply(z$cl[use], callGrid,
- doGetProbabilitiesFromC, z$thetaMat, index,
- getScores)
- }
- }
- ans <- list()
- ans[[1]] <- sum(sapply(anss, "[[", 1))
- if (getScores)
- {
- ans[[2]] <- rowSums(sapply(anss, "[[", 2))
- }
- ans[[3]] <- sapply(anss, "[[", 3)
- ans
-}
-
-##@doGetProbabilitiesFromC Maximum likelihood
-doGetProbabilitiesFromC <- function(x, thetaMat, index, getScores)
-{
- f <- FRANstore()
- theta <- thetaMat[x[1], ]
- .Call("getChainProbabilities", PACKAGE = pkgname, f$pData,
- f$pModel, as.integer(x[1]), as.integer(x[2]),
- as.integer(index), f$myeffects, theta, getScores)
-
-}
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2013-04-17 05:18:22 UTC (rev 226)
+++ pkg/RSiena/R/effects.r 2013-04-19 17:29:01 UTC (rev 227)
@@ -1,7 +1,7 @@
#/******************************************************************************
# * SIENA: Simulation Investigation for Empirical Network Analysis
# *
-# * Web: http://www.stats.ox.ac.uk/~snidjers/siena
+# * Web: http://www.stats.ox.ac.uk/~snijders/siena
# *
# * File: effects.r
# *
@@ -87,6 +87,17 @@
}
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.
+}
##@networkRateEffects internal getEffects create a set of rate effects
networkRateEffects <- function(depvar, varname, symmetric, bipartite)
{
@@ -350,7 +361,38 @@
objEffects$type == 'eval', 'include'] <- TRUE
}
rateEffects$basicRate[1:observations] <- TRUE
- list(effects=rbind(rateEffects = rateEffects, objEffects = objEffects),
+ ## The following adding of settings effects should perhaps have been
+ ## placed earlier; but for the moment it is here.
+ ## This uses the results of addSettings
+ ## which adds the settings to the sienaDependent object.
+ if (!is.null(attr(depvar,"settings")))
+ {
+ ## add settings effects
+ nbrSettings <- ifelse(attr(depvar,"settings") == "", 0,
+ length(attr(depvar,"settings")))
+ dupl <- rateEffects[1:observations, ]
+ ## make extra copies
+ newEffects <- dupl[rep(1:nrow(dupl), each = nbrSettings[i] + 2), ]
+ newEffects <- split(newEffects,
+ list(newEffects$group, newEffects$period))
+ newEffects <- lapply(newEffects, function(dd)
+ {
+ dd$setting <- c("universal", "primary",
+ names(attr(depvar,"settings")))
+ i1 <- regexpr("rate", dd$effectName)
+ dd$effectName <-
+ paste(substr(dd$effectName, 1, i1 - 2),
+ dd$setting, substring(dd$effectName, i1))
+ dd
+ })
+ newEffects <- do.call(rbind, newEffects)
+ ## add the extra column also to the other effects
+ rateEffects$setting <- rep("", nrow(rateEffects))
+ objEffects$setting <- rep("", nrow(objEffects))
+ rateEffects <-
+ rbind(newEffects, rateEffects[!rateEffects$basicRate, ])
+ }
+ list(effects=rbind(rateEffects = rateEffects, objEffects = objEffects),
starts=starts)
}
@@ -848,7 +890,19 @@
netType=netType, name=name)
covObjEffects <- rbind(covObjEffects, newEffects)
- }
+ if (!attr(xx$depvars[[j]], "symmetric"))
+ {
+ covOneModeRateEffects <-
+ createEffects("covarBehaviorOneModeRate", varname,
+ yName=names(xx$depvars)[j],
+ zName=covarname,
+ groupName=groupName, group=group,
+ netType=netType, name=name)
+
+ covRateEffects <- rbind(covRateEffects,
+ covOneModeRateEffects)
+ }
+ }
if ((types[j] == "bipartite" &&
attr(xx$depvars[[j]], 'nodeSet')[2] == nodeSet))
{
@@ -1232,7 +1286,14 @@
diag(z[ , , x]) <- NA
diag(z[, , x + 1]) <- NA
matdiff <- sum(z[, , x + 1] != z[, , x], na.rm=TRUE)
- matchange <- table(z[, , x + 1], z[, , x])
+# matchange0 <- table(z[, , x + 1], z[, , x])
+# Changed to protect against zero rows or columns
+ mc00 <- sum((1 - z[ , , x+1])*(1 - z[ , , x]), na.rm=TRUE)
+ mc01 <- sum(z[ , , x+1]*(1 - z[ , , x]), na.rm=TRUE)
+ mc10 <- sum((1 - z[ , , x+1])*z[ , , x], na.rm=TRUE)
+ mc11 <- sum(z[ , , x+1]*z[ , , x], na.rm=TRUE)
+ matchange <- matrix(c(mc00, mc01, mc10, mc11), 2, 2)
+#cat(matchange0,'\n',matchange,'\n')
matcnt <- nactors * nactors -
sum(is.na(z[, , x + 1]) | is.na(z[, , x]))
tmp <- c(matcnt=matcnt, matdiff=matdiff, matchange=matchange)
@@ -1263,6 +1324,10 @@
mydif <- mymat2 - mymat1
matdiff[i] <- sum(abs(mydif), na.rm=TRUE)
tmp <- table(mydif at x)
+ dummy <- factor(NA, levels=c(-1,0,1))
+ dummy <- table(dummy)
+ dummy[names(tmp)] <- tmp
+ tmp <- dummy
tmp00 <- nactors * nactors - length(mydif at x)
tmp <- c(tmp00, tmp[c(3, 1, 2)])
matchange[, i] <- tmp
@@ -1341,7 +1406,14 @@
depvar[use] <- depvar[use] - 10 ## remove structural values
tmp <- sapply(1:noPeriods, function(x, z){
matdiff <- sum(z[, , x + 1] != z[, , x], na.rm=TRUE)
- matchange <- table(z[, , x + 1], z[, , x])
+# matchange0 <- table(z[, , x + 1], z[, , x])
+ # Changed to protect against zero rows or columns
+ mc00 <- sum((1 - z[ , , x+1])*(1 - z[ , , x]), na.rm=TRUE)
+ mc01 <- sum(z[ , , x+1]*(1 - z[ , , x]), na.rm=TRUE)
+ mc10 <- sum((1 - z[ , , x+1])*z[ , , x], na.rm=TRUE)
+ mc11 <- sum(z[ , , x+1]*z[ , , x], na.rm=TRUE)
+ matchange <- matrix(c(mc00, mc01, mc10, mc11), 2, 2)
+#cat(matchange0,'\n',matchange,'\n')
matcnt <- nsenders * nreceivers -
sum(is.na(z[, , x + 1]) | is.na(z[, , x]))
tmp <- c(matcnt=matcnt, matdiff=matdiff, matchange=matchange)
@@ -1354,7 +1426,7 @@
else
{
nsenders <- nrow(depvar[[1]])
- nreceivers <- ncol(depvar[[2]])
+ nreceivers <- ncol(depvar[[1]]) # CS: Was 2, but why?
matdiff<- rep(NA, noPeriods)
matcnt<- rep(NA, noPeriods)
matchange<- matrix(NA, nrow=4, ncol=noPeriods)
@@ -1384,7 +1456,12 @@
"matchangeFrom1To0", "matchangeFrom1To1")
}
distance <- attr(depvar, "distance" )
- startRate <- nsenders * (0.2 + 2 * distance)/(tmp['matcnt',] + 1)
+ startRate <- nreceivers * (0.2 + 2 * distance)/(tmp['matcnt',] + 1)
+ # CS: the above used to be 'nsenders' instead of 'nreceivers';
+ # this was a wrong calculation and led to extremely high
+ # rate parameters for comparatively small receiver nodesets
+ # slowing down estimation and prohibiting identification
+ # of parameters.
startRate <- pmax(0.1, startRate)
startRate <- pmin(100, startRate)
##degree
Modified: pkg/RSiena/R/effectsDocumentation.r
===================================================================
--- pkg/RSiena/R/effectsDocumentation.r 2013-04-17 05:18:22 UTC (rev 226)
+++ pkg/RSiena/R/effectsDocumentation.r 2013-04-19 17:29:01 UTC (rev 227)
@@ -1,7 +1,7 @@
#/******************************************************************************
# * SIENA: Simulation Investigation for Empirical Network Analysis
# *
-# * Web: http://www.stats.ox.ac.uk/~snidjers/siena
+# * Web: http://www.stats.ox.ac.uk/~snijders/siena
# *
# * File: effectsDocumentation.r
# *
@@ -10,18 +10,34 @@
# *****************************************************************************/
##@effectsDocumentation Documentation
-effectsDocumentation <- function(type="html", display=type=="html",
- filename="effects")
+effectsDocumentation <- function(effects= NULL, type="html", display=(type=="html"),
+ filename=ifelse(is.null(effects), "effects", deparse(substitute(effects))))
{
+ if (is.null(effects))
+ {
x <- allEffects[, c("effectGroup", "effectName", "shortName",
"endowment", "interaction1", "interaction2",
"parm", "interactionType")]
+ }
+ else
+ {
+ x <- as.data.frame(effects[, c("name", "effectName", "shortName", "type",
+ "interaction1", "interaction2",
+ "parm", "interactionType")])
+ }
storage.mode(x$parm) <- "integer"
- names(x)[4] <- "endow?"
+ names(x)[4] <- ifelse(is.null(effects), "endow?", "type")
names(x)[5] <- "inter1"
names(x)[6] <- "inter2"
- names(x)[8] <- "ego?"
- x$row <- as.integer(row.names(x))
+ names(x)[8] <- "interactionType"
+ if (is.null(effects))
+ {
+ x$row <- as.integer(row.names(x))
+ }
+ else
+ {
+ x$row <- 1:dim(x)[1]
+ }
x <- x[, c(9, 1:8)]
myorder <- c("nonSymmetricRate",
@@ -36,6 +52,7 @@
"behaviorRate",
"behaviorOneModeRate",
"behaviorSymmetricRate",
+ "covarBehaviorOneModeRate",
"behaviorBipartiteRate",
"covarBehaviorRate",
@@ -73,6 +90,8 @@
addtorowPos <- cumsum(c(0, mytab[myorder]))[1:length(myorder)]
addtorowText <- names(mytab[myorder])
+ x[is.na(x)] <- "FALSE" ## endow? field
+
if (type=="latex")
{
addtorowText <- paste(" \\hline \\multicolumn{4}{l}{",
@@ -81,21 +100,25 @@
}
else
{
- x[is.na(x)] <- "FALSE" ## endow? field
- x[x==""] <- "<br>"
- addtorowText <- paste(' <TR> <TD colspan="8" >',
+ x[x==""] <- "<br>"
+ addtorowText <- paste(' <TR> <TD colspan="8" >',
addtorowText, "</TD> </TR>")
}
add.to.row <- NULL
- add.to.row$pos <- lapply(addtorowPos, function(x)x)
- add.to.row$command <- as.vector(sapply(addtorowText, function(x)x))
-
- order2 <- match(myorder, x[, 2])
- order3 <- as.vector(mytab[myorder])
-
- order4 <- unlist(apply(cbind(order2, order3), 1,
+ if (is.null(effects))
+ {
+ add.to.row$pos <- lapply(addtorowPos, function(x)x)
+ add.to.row$command <- as.vector(sapply(addtorowText, function(x)x))
+ order2 <- match(myorder, x[, 2])
+ order3 <- as.vector(mytab[myorder])
+ order4 <- unlist(apply(cbind(order2, order3), 1,
function(x)x[1]:(x[1] + x[2] -1)))
- y <- x[order4, -2]
+ y <- x[order4, -2]
+ }
+ else
+ {
+ y <- x
+ }
row.names(y) <- 1:nrow(y)
if (type =="latex")
Modified: pkg/RSiena/R/initializeFRAN.r
===================================================================
--- pkg/RSiena/R/initializeFRAN.r 2013-04-17 05:18:22 UTC (rev 226)
+++ pkg/RSiena/R/initializeFRAN.r 2013-04-19 17:29:01 UTC (rev 227)
@@ -1,7 +1,7 @@
#/******************************************************************************
# * SIENA: Simulation Investigation for Empirical Network Analysis
# *
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 227
More information about the Rsiena-commits
mailing list