[Rsiena-commits] r284 - in pkg: RSiena RSiena/R RSiena/data RSiena/inst/doc RSiena/man RSiena/src/model/effects RSiena/src/model/effects/generic RSiena/tests RSienaTest RSienaTest/R RSienaTest/data RSienaTest/doc RSienaTest/inst/doc RSienaTest/man 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
Thu Apr 2 16:58:41 CEST 2015
Author: tomsnijders
Date: 2015-04-02 16:58:39 +0200 (Thu, 02 Apr 2015)
New Revision: 284
Added:
pkg/RSiena/src/model/effects/SameCovariateActivityEffect.cpp
pkg/RSiena/src/model/effects/SameCovariateActivityEffect.h
pkg/RSiena/src/model/effects/generic/CovariateDistance2EgoAltSimNetworkFunction.cpp
pkg/RSiena/src/model/effects/generic/CovariateDistance2EgoAltSimNetworkFunction.h
pkg/RSienaTest/src/model/effects/SameCovariateActivityEffect.cpp
pkg/RSienaTest/src/model/effects/SameCovariateActivityEffect.h
pkg/RSienaTest/src/model/effects/generic/CovariateDistance2EgoAltSimNetworkFunction.cpp
pkg/RSienaTest/src/model/effects/generic/CovariateDistance2EgoAltSimNetworkFunction.h
Removed:
pkg/RSiena/R/.Rhistory
Modified:
pkg/RSiena/ChangeLog
pkg/RSiena/DESCRIPTION
pkg/RSiena/NAMESPACE
pkg/RSiena/R/RSienaRDocumentation.r
pkg/RSiena/R/effects.r
pkg/RSiena/R/effectsDocumentation.r
pkg/RSiena/R/phase2.r
pkg/RSiena/R/phase3.r
pkg/RSiena/R/print07Report.r
pkg/RSiena/R/robmon.r
pkg/RSiena/R/siena01.r
pkg/RSiena/R/siena07.r
pkg/RSiena/R/siena07gui.r
pkg/RSiena/R/siena08.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienaDataCreateFromSession.r
pkg/RSiena/R/sienaGOF.r
pkg/RSiena/R/sienaModelCreate.r
pkg/RSiena/R/sienaTimeTest.r
pkg/RSiena/R/sienautils.r
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/man/RSiena-package.Rd
pkg/RSiena/man/effectsDocumentation.Rd
pkg/RSiena/man/siena07.Rd
pkg/RSiena/man/siena08.Rd
pkg/RSiena/man/sienaAlgorithmCreate.Rd
pkg/RSiena/man/sienaDataCreate.Rd
pkg/RSiena/man/sienaGOF.Rd
pkg/RSiena/src/model/effects/AllEffects.h
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/effects/generic/CovariateDistance2NetworkFunction.cpp
pkg/RSiena/src/model/effects/generic/CovariateDistance2NetworkFunction.h
pkg/RSiena/src/model/effects/generic/CovariateDistance2SimilarityNetworkFunction.cpp
pkg/RSiena/src/model/effects/generic/NetworkAlterFunction.cpp
pkg/RSiena/src/model/effects/generic/NetworkAlterFunction.h
pkg/RSiena/src/model/effects/generic/SameCovariateInTiesFunction.cpp
pkg/RSiena/src/model/effects/generic/SameCovariateInTiesFunction.h
pkg/RSiena/tests/parallel.Rout.save
pkg/RSienaTest/ChangeLog
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/NAMESPACE
pkg/RSienaTest/R/RSienaRDocumentation.r
pkg/RSienaTest/R/algorithms.r
pkg/RSienaTest/R/document.r
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/effectsDocumentation.r
pkg/RSienaTest/R/phase2.r
pkg/RSienaTest/R/phase3.r
pkg/RSienaTest/R/print07Report.r
pkg/RSienaTest/R/siena01.r
pkg/RSienaTest/R/siena07.r
pkg/RSienaTest/R/siena07gui.r
pkg/RSienaTest/R/siena08.r
pkg/RSienaTest/R/sienaBayes.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaDataCreateFromSession.r
pkg/RSienaTest/R/sienaGOF.r
pkg/RSienaTest/R/sienaTimeTest.r
pkg/RSienaTest/R/sienautils.r
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/doc/RSIENAspec.tex
pkg/RSienaTest/doc/Siena_algorithms.tex
pkg/RSienaTest/inst/doc/RSiena.bib
pkg/RSienaTest/inst/doc/RSiena_Manual.pdf
pkg/RSienaTest/inst/doc/RSiena_Manual.tex
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/siena07.Rd
pkg/RSienaTest/man/siena08.Rd
pkg/RSienaTest/man/sienaAlgorithmCreate.Rd
pkg/RSienaTest/man/sienaDataCreate.Rd
pkg/RSienaTest/man/sienaGOF.Rd
pkg/RSienaTest/man/sienaRI.Rd
pkg/RSienaTest/man/simstats0c.Rd
pkg/RSienaTest/src/model/effects/AllEffects.h
pkg/RSienaTest/src/model/effects/EffectFactory.cpp
pkg/RSienaTest/src/model/effects/generic/CovariateDistance2NetworkFunction.cpp
pkg/RSienaTest/src/model/effects/generic/CovariateDistance2NetworkFunction.h
pkg/RSienaTest/src/model/effects/generic/CovariateDistance2SimilarityNetworkFunction.cpp
pkg/RSienaTest/src/model/effects/generic/NetworkAlterFunction.cpp
pkg/RSienaTest/src/model/effects/generic/NetworkAlterFunction.h
pkg/RSienaTest/src/model/effects/generic/SameCovariateInTiesFunction.cpp
pkg/RSienaTest/src/model/effects/generic/SameCovariateInTiesFunction.h
pkg/RSienaTest/tests/parallel.Rout.save
Log:
Modified: pkg/RSiena/ChangeLog
===================================================================
--- pkg/RSiena/ChangeLog 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/ChangeLog 2015-04-02 14:58:39 UTC (rev 284)
@@ -1,3 +1,40 @@
+2015-04-02 R-Forge Revision 284
+Changes in RSiena and RSienaTest:
+ * New effects: simEgoDist2, simEgoInDist2, simEgoDist2W, simEgoInDist2W,
+ sameXOutAct, diffXInPop, diffXOutAct.
+ * New effectGroups covarABNetNetObjective,
+ covarANetNetObjective, and covarBNetNetObjective (allEffects.csv, effects.r).
+ * Bug corrected that occurred in print01Report for a sienaGroup object
+ where the component objects have constant dyadic covariates
+ (sienaDataCreate.r).
+ * When a statistic is not plotted in plot.sienaGOF() because
+ its variance is 0, a note about this is printed to the screen.
+ * Minimum and maximum of plotted region in plot.sienaGOF()
+ is calculated without taking into account non-plotted statistics.
+ * Bug corrected with includeTimeDummy for timeDummy greater than
+ or equal to 10 (sienaTimeTest.r).
+ * In case of collinear parameter estimates, standard errors
+ are reported as NA (phase3.r, print07Report.r).
+ * At the end of subphases of phase 2, add condition
+ ((!is.na(z$minacor)) & (!is.na(z$maxacor))) to avoid NA errors.
+ * Arguments main and ylab dropped from plot.sienaGOF(); they did
+ not work, and their functionality now is covered by the ...
+ argument (so using main and ylab as arguments now should work).
+ (Thanks to David Kavaler.)
+ * Various changes in DESCRIPTION and NAMESPACE files with respect
+ to Suggests and Depends; for packages in "Depends", require(packageName)
+ was dropped in all R functions; for package "network",
+ suppressPackageStartupMessages() was added to require();
+ for packages in "Suggests", the package name was everywhere
+ added as packageName:: before the function name.
+ * GPL requirement changed to >= 3.
+Changes in RSienaTest:
+ * sienaBayes: correction in initialization of truncation rate parameters
+ based on prior; correction of sampleConstantParameters() (MCversion=0
+ used the wrong MH ratio, now was dropped altogether).
+Changes in RSiena:
+ * reduceg parameter added (sienaAlgorithmCreate, siena07)
+
2014-12-11 R-Forge Revision 282
Changes in RSiena and RSienaTest:
* Effects cl.XWX and cl2.XWX corrected (thanks to Christoph Stadtfeld)
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/DESCRIPTION 2015-04-02 14:58:39 UTC (rev 284)
@@ -1,17 +1,16 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.1-282
-Date: 2014-12-11
+Version: 1.1-284
+Date: 2015-04-02
Author: Ruth Ripley, Krists Boitmanis, Tom A.B. Snijders
-Depends: R (>= 2.15.0)
-Imports: Matrix
-Suggests: tcltk, network, codetools, lattice, MASS, parallel,
- xtable, tools, utils
+Depends: R (>= 2.15.0), utils
+Imports: Matrix, tcltk, lattice, parallel, MASS
+Suggests: xtable, network, tools, codetools
SystemRequirements: GNU make, tcl/tk 8.5, Tktable
Maintainer: Tom A.B. Snijders <tom.snijders at nuffield.ox.ac.uk>
-Description: Fits models to longitudinal network data
-License: GPL-2
+Description: Statistical modelling for longitudinal network data
+License: GPL (>= 3)
LazyLoad: yes
LazyData: yes
NeedsCompilation: yes
Modified: pkg/RSiena/NAMESPACE
===================================================================
--- pkg/RSiena/NAMESPACE 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/NAMESPACE 2015-04-02 14:58:39 UTC (rev 284)
@@ -13,7 +13,7 @@
siena.table, xtable,
Wald.RSiena, Multipar.RSiena)
-import(Matrix)
+import(Matrix, tcltk, lattice, parallel, MASS)
S3method(print, siena)
S3method(print, sienaGroup)
Deleted: pkg/RSiena/R/.Rhistory
===================================================================
--- pkg/RSiena/R/.Rhistory 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/.Rhistory 2015-04-02 14:58:39 UTC (rev 284)
@@ -1 +0,0 @@
-print("Hi Natalie, best wishes from Tom")
Modified: pkg/RSiena/R/RSienaRDocumentation.r
===================================================================
--- pkg/RSiena/R/RSienaRDocumentation.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/RSienaRDocumentation.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -15,7 +15,7 @@
fnlist <- read.csv("RSienafnlist.csv", as.is=TRUE)
mylist <- ls(parent.frame())
## print(mylist)
- library(codetools)
+ ## require(codetools)
## fnlist has a row number at the front: column 3 contains the function names
mylist <- mylist[mylist %in% fnlist[, 3]]
mytt <- lapply(mylist, function(x)
@@ -23,8 +23,8 @@
x <- get(x, envir=parent.frame(3))
if (is.function(x))
{
- tt <- findGlobals(x, merge=FALSE)[[1]]
- tt2 <- findLocals(body(x))
+ tt <- codetools::findGlobals(x, merge=FALSE)[[1]]
+ tt2 <- codetools::findLocals(body(x))
tt <- c(tt, tt2)
tt[tt %in% fnlist[, 3]]
}
@@ -40,8 +40,8 @@
##@getRSienaDocumentation Documentation
getRSienaRDocumentation <- function(Rdir)
{
- library(xtable)
- library(codetools)
+ ## require(xtable)
+ ## require(codetools)
thisdir <- getwd()
## temporarily move directory
@@ -94,8 +94,8 @@
x <- try(getFromNamespace(x, pkgname), silent=TRUE)
if (is.function(x))
{
- tmp1 <- findGlobals(x, merge=FALSE)[[1]]
- tmp2 <- findLocals(body(x))
+ tmp1 <- codetools::findGlobals(x, merge=FALSE)[[1]]
+ tmp2 <- codetools::findLocals(body(x))
tmp <- c(tmp1, tmp2)
}
else
@@ -282,7 +282,7 @@
tmp12 <- tmp12[order(tmp12[, "type"], as.numeric(row.names(tmp12))), ]
tmp12 <- tmp12[, c(3, 2, 5, 6, 4, 1)]
- ff <- xtable(tmp12)
+ ff <- xtable::xtable(tmp12)
## go back to start directory
setwd(thisdir)
print(ff, tabular.environment="longtable",
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/effects.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -36,7 +36,7 @@
createEffects <- function(effectGroup, xName=NULL, yName=NULL, zName = NULL,
name, groupName, group, netType)
{
- effects <- allEffects[allEffects$effectGroup == effectGroup, ]
+ effects <- RSiena::allEffects[RSiena::allEffects$effectGroup == effectGroup, ]
if (nrow(effects) == 0)
{
stop("empty effect group")
@@ -88,6 +88,16 @@
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)
{
@@ -267,9 +277,11 @@
{
objEffects <-
rbind(objEffects,
- covarNetNetEff(otherName, names(xx$cCovars)[k],
- attr(xx$cCovars[[k]],
- 'poszvar'),
+ covarNetNetEff(otherName,
+ covarname=names(xx$cCovars)[k],
+ attr(xx$depvars[[j]], 'nodeSet'),
+ attr(xx$cCovars[[k]], 'nodeSet'),
+ attr(xx$cCovars[[k]], 'poszvar'),
name=varname))
}
}
@@ -279,9 +291,11 @@
{
objEffects <-
rbind(objEffects,
- covarNetNetEff(otherName, names(xx$vCovars)[k],
- attr(xx$vCovars[[k]],
- 'poszvar'),
+ covarNetNetEff(otherName,
+ covarname=names(xx$vCovars)[k],
+ attr(xx$depvars[[j]], 'nodeSet'),
+ attr(xx$vCovars[[k]], 'nodeSet'),
+ attr(xx$vCovars[[k]], 'poszvar'),
name=varname))
}
}
@@ -292,7 +306,10 @@
{
objEffects <-
rbind(objEffects,
- covarNetNetEff(otherName, names(xx$depvars)[k],
+ covarNetNetEff(otherName,
+ covarname=names(xx$depvars)[k],
+ attr(xx$depvars[[j]], 'nodeSet'),
+ attr(xx$depvars[[k]], 'nodeSet'),
poszvar=TRUE,
name=varname))
}
@@ -324,9 +341,9 @@
rateEffects$basicRate[1:observations] <- TRUE
objEffects[objEffects$shortName == "density" &
- objEffects$type == "eval",'randomEffects'] <- TRUE # added dec2013
+ objEffects$type == "eval",'randomEffects'] <- TRUE
objEffects[objEffects$shortName == "linear" &
- objEffects$type == "eval",'randomEffects'] <- TRUE # added dec2013
+ objEffects$type == "eval",'randomEffects'] <- TRUE
objEffects$untrimmedValue <- rep(0, nrow(objEffects))
if (attr(depvar,'symmetric'))
@@ -797,7 +814,7 @@
netType=netType)
}
- if (!poszvar)
+ if (!poszvar) # not (positive variance of z, or any z missing)
{
if (symmetric)
{
@@ -834,13 +851,13 @@
netType=netType)
covObjEffects <-
covObjEffects[covObjEffects$shortName %in%
- c("egoX", "altInDist2", "totInDist2"), ]
+ c("egoX", "altInDist2", "totInDist2", "simEgoInDist2"), ]
covRateEffects <- createEffects("covarBipartiteRate", covarname,
name=varname,
groupName=groupName, group=group,
netType=netType)
}
- else if (poszvar)
+ else if (poszvar) # positive variance of z, or any z missing
{
covObjEffects <- createEffects("covarBipartiteObjective", covarname,
name=varname,
@@ -949,16 +966,56 @@
list(objEff=covObjEffects)
}
##@covarNetNetEff internal getEffects
- covarNetNetEff<- function(othernetname,
- covarname, poszvar, name)
+ covarNetNetEff<- function(othernetname, covarname, nodeSetsj, nodeSetk, poszvar, name)
+ {
+ if (poszvar) # positive variance of z, or any z missing
+ {
+ if (length(nodeSetsj) <= 1) ## second network onemode
+ {
+ processA <- TRUE
+ processB <- TRUE
+ objEffectsOneMode <- createEffects("covarNetNetObjective", othernetname,
+ covarname, name=name,
+ groupName=groupName, group=group,
+ netType=netType)
+ }
+ else ## second network twomode
+ {
+ processA <- (nodeSetsj[[1]] == nodeSetk)
+ processB <- (nodeSetsj[[2]] == nodeSetk)
+ objEffectsOneMode <- NULL
+ }
+ if (processA)
{
- objEffects <- createEffects("covarNetNetObjective", othernetname,
+ objEffectsA <- createEffects("covarANetNetObjective", othernetname,
+ covarname, name=name,
+ groupName=groupName, group=group,
+ netType=netType)
+ }
+ else
+ {
+ objEffectsA <- NULL
+ }
+ if (processB)
+ {
+ objEffectsB <- createEffects("covarBNetNetObjective", othernetname,
covarname, name=name,
groupName=groupName, group=group,
netType=netType)
- if (!poszvar)
+ }
+ else
+ {
+ objEffectsB <- NULL
+ }
+ objEffectsAB <- createEffects("covarABNetNetObjective", othernetname,
+ covarname, name=name,
+ groupName=groupName, group=group,
+ netType=netType)
+ objEffects <- rbind(objEffectsOneMode, objEffectsAB, objEffectsA, objEffectsB)
+ }
+ else
{
- objEffects <- objEffects[objEffects$shortName != "covNetNet", ]
+ objEffects <- NULL
}
objEffects
}
Modified: pkg/RSiena/R/effectsDocumentation.r
===================================================================
--- pkg/RSiena/R/effectsDocumentation.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/effectsDocumentation.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -14,9 +14,10 @@
display=(type=="html"),
filename=ifelse(is.null(effects), "effects", deparse(substitute(effects))))
{
+ ## require(xtable)
if (is.null(effects))
{
- x <- allEffects[, c("effectGroup", "effectName", "shortName",
+ x <- RSiena::allEffects[, c("effectGroup", "effectName", "shortName",
"endowment", "interaction1", "interaction2",
"parm", "interactionType")]
}
@@ -94,7 +95,7 @@
"covarBBehaviorBipartiteObjective",
"unspecifiedBehaviorInteraction")
- mytab <- table(allEffects[,1])
+ mytab <- table(RSiena::allEffects[,1])
addtorowPos <- cumsum(c(0, mytab[myorder]))[1:length(myorder)]
addtorowText <- names(mytab[myorder])
Modified: pkg/RSiena/R/phase2.r
===================================================================
--- pkg/RSiena/R/phase2.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/phase2.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -21,6 +21,7 @@
##@phase2.1 siena07 Start phase 2
phase2.1<- function(z, x, ...)
{
+ ## require(tcltk)
#initialise phase2
if (x$maxlike)
{
@@ -40,6 +41,7 @@
z$sd[z$fixed] <- 0
Report(paste('\nPhase 2 has', x$nsub, 'subphases.\n'), cf)
z$gain <- x$firstg
+ z$reduceg <- x$reduceg
if (x$nsub <= 0)
{
Report('With 0 subphases, there is no phase 2.\n', cf)
@@ -200,7 +202,7 @@
}
else
{
- z$gain <- z$gain * 0.5
+ z$gain <- z$gain * z$reduceg
}
z
} ##end of this subphase
@@ -210,7 +212,8 @@
{
z$nit <- 0
ac <- 0
- z$maxacor <- 1
+ z$maxacor <- -1
+ z$minacor <- 1
xsmall <- NULL
zsmall <- makeZsmall(z)
z$returnDeps <- FALSE
@@ -375,6 +378,8 @@
break
}
## do we stop?
+ if (!(is.na(z$minacor) || is.na(z$maxacor)))
+ {
if ((z$nit >= z$n2min && z$maxacor < 1e-10)||
(z$nit >= z$n2max)||
((z$nit >= 50) && (z$minacor < -0.8) &&
@@ -382,6 +387,7 @@
{
break
}
+ }
}
z
}
Modified: pkg/RSiena/R/phase3.r
===================================================================
--- pkg/RSiena/R/phase3.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/phase3.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -187,7 +187,7 @@
tmax <- max(abs(tstat)[!z$fixed & !z$BasicRateFunction & z$resist > 0.9])
z$tconv <- tstat
error <- (abs(tmax) > 4.0 / sqrt(z$Phase3nits)) && (abs(tmax) > 0.3)
- if (tmax >= 0.4 & !z$error)
+ if (tmax >= 0.4)
{
z$error <- TRUE
}
@@ -264,16 +264,16 @@
dfrac[z$fixed, ] <- 0
dfrac[ ,z$fixed] <- 0
diag(dfrac)[z$fixed] <- 1
- if (inherits(try(cov <- solve(dfrac), silent=TRUE),"try-error"))
+ if (inherits(try(cov.est <- solve(dfrac), silent=TRUE),"try-error"))
{
Report('Noninvertible estimated covariance matrix : \n', outf)
errorMessage.cov <- '***Warning: linear dependencies between statistics ***'
- cov <- NULL
+ cov.est <- NA * dfrac
}
}
else
{
- cov <- z$dinv %*% z$msfc %*% t(z$dinv)
+ cov.est <- z$dinv %*% z$msfc %*% t(z$dinv)
}
error <- FALSE
if (inherits(try(msfinv <- solve(z$msfc), silent=TRUE), "try-error"))
@@ -305,29 +305,24 @@
}
else
{
- Report(c('This may mean that the reported standard errors ',
- 'are invalid.\n'), outf)
+ Report('Do not use any reported standard errors.\n', outf)
errorMessage.cov <- '*** Warning: Noninvertible estimated covariance matrix ***'
}
z$msfinv <- NULL
+ cov.est <- NA * z$msfc
}
else
{
z$msfinv <- msfinv
}
- if (!is.null(cov))
+ if (!is.null(cov.est))
{
- z$diver <- (z$fixed | z$diver | diag(cov) < 1e-9) & (!z$AllUserFixed)
- ## beware: recycling works for one direction but not the other
- diag(cov)[z$diver] <- NA
-# cov[z$diver, ] <- rep(Root(diag(cov)), each=sum(z$diver)) * 33
-# diag(cov)[z$diver] <- 99 * 99
-# cov[, z$diver] <- rep(Root(diag(cov)), sum(z$diver)) * 33
- cov[z$diver, ] <- NA
- cov[, z$diver] <- NA
- diag(cov)[z$diver] <- NA
+ zerovar <- ((diag(cov.est) < 1e-9) | (is.na(diag(cov.est))))
+ z$diver <- (z$fixed | z$diver | zerovar) & (!z$AllUserFixed)
+ cov.est[z$diver, ] <- NA
+ cov.est[, z$diver] <- NA
}
- z$covtheta <- cov
+ z$covtheta <- cov.est
}
z$errorMessage.cov <- errorMessage.cov
## ans<-InstabilityAnalysis(z)
Modified: pkg/RSiena/R/print07Report.r
===================================================================
--- pkg/RSiena/R/print07Report.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/print07Report.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -204,6 +204,14 @@
else
{
Heading(3, outf, "Covariance matrices")
+ if (all(is.na(z$covtheta)))
+ {
+ Report(c('There is a linear dependency between the parameter estimates\n',
+ 'therefore the covariance matrix should not be used.\n\n'),
+ outf)
+ }
+ else
+ {
if (any(z$fixed))
{
Report(c('(Values of the covariance matrix of estimates\n',
@@ -235,6 +243,7 @@
PrtOutMat(format(round(covcor, digits = 3), width = 10), lf)
Report('\n', outf)
Report('\n', lf)
+ }
}
}
Modified: pkg/RSiena/R/robmon.r
===================================================================
--- pkg/RSiena/R/robmon.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/robmon.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -126,7 +126,15 @@
Report('This is not allowed; changed to 0.0001.\n', outf)
z$gain <- 0.0001
}
+ if (x$reduceg <= 0)
+ {
+ Report(c('Reduction factor for the gain parameter is ', x$reduceg,
+ '.\n'), outf)
+ Report('This is not allowed; changed to 0.2.\n', outf)
+ x$reduceg <- 0.2
+ }
Report(c('Initial value for gain parameter = ', format(z$gain),
+ '.\nReduction factor for gain parameter = ', format(x$reduceg),
'.\nStart of the algorithm.\n'), cf, sep='')
Report('Observed function values are \n', cf)
targets <- if (!z$maxlike) z$targets else z$maxlikeTargets
@@ -149,7 +157,7 @@
{
z$AllUserFixed <- TRUE
}
- ##browser()
+
repeat ##this is startagain:
{
z$epsilonProblem <- FALSE
@@ -213,7 +221,6 @@
break
}
z<- phase1.2(z, x, ...)
- ## browser()
if (!z$OK || z$DerivativeProblem ||
UserInterruptFlag() || UserRestartFlag())
{
Modified: pkg/RSiena/R/siena01.r
===================================================================
--- pkg/RSiena/R/siena01.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/siena01.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -28,6 +28,7 @@
siena01Gui <- function(getDocumentation=FALSE)
{
##DONE (FALSE) ## this is so we can exit cleanly, but seems redundant here
+ ## require(tcltk)
maxDegree <- NULL
nMaxDegree <- NULL
resultsFileID <- NULL
@@ -1071,7 +1072,7 @@
return(getInternals())
}
## check we have the right libraries
- library(tcltk)
+ ## require(tcltk)
if (!inherits(tclRequire("Tktable"), "tclObj"))
stop("This function needs the tcl/tk package TkTable: install it, ",
"or use an alternative data entry method: see RSiena help page")
Modified: pkg/RSiena/R/siena07.r
===================================================================
--- pkg/RSiena/R/siena07.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/siena07.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -59,7 +59,7 @@
#}
#else
#{
- require(parallel)
+ ## require(parallel)
#}
if (clusterIter)
{
@@ -196,7 +196,7 @@
revision <- paste(" R-forge revision: ", rforgeRevision, " ", sep="")
}
version <- packageDescription(pkgname, fields = "Version")
- Report(c("\nSiena version ", version, " (",
+ Report(c("\nRSiena version ", version, " (",
format(as.Date(packageDescription(pkgname, fields = "Date")),
"%d %b %y"), ")",
revision, "\n\n"), sep = '', outf )
@@ -228,6 +228,7 @@
##@AnnouncePhase siena07 Progress reporting
AnnouncePhase <- function(z, x, subphase=NULL)
{
+ ## require(tcltk)
if (!is.batch())
{
tkdelete(z$tkvars$phase, 0, "end")
Modified: pkg/RSiena/R/siena07gui.r
===================================================================
--- pkg/RSiena/R/siena07gui.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/siena07gui.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -32,7 +32,7 @@
}
if (is.null(tt))
{
- library(tcltk)
+ ## require(tcltk)
tt <- tktoplevel()
}
tkwm.title(tt,'Siena07')
Modified: pkg/RSiena/R/siena08.r
===================================================================
--- pkg/RSiena/R/siena08.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/siena08.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -371,7 +371,7 @@
##@plot.sienaMeta Methods
plot.sienaMeta <- function(x, ..., layout = c(2,2))
{
- library(lattice)
+ ## library(lattice)
tmp <- xyplot(theta ~ se|effects,
data=x$thetadf[is.na(x$thetadf$scoretests),],
ylab="estimates",
Modified: pkg/RSiena/R/sienaDataCreate.r
===================================================================
--- pkg/RSiena/R/sienaDataCreate.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/sienaDataCreate.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -206,6 +206,7 @@
sienaDataCreate<- function(..., nodeSets=NULL, getDocumentation=FALSE)
{
##@validNodeSet internal sienaDataCreate
+ ## suppressPackageStartupMessages(require(network))
validNodeSet <- function(nodeSetName, n)
{
sub <- match(nodeSetName, nodeSetNames)
@@ -1384,6 +1385,7 @@
##@sienaGroupCreate DataCreate
sienaGroupCreate <- function(objlist, singleOK=FALSE, getDocumentation=FALSE)
{
+ ## suppressPackageStartupMessages(require(network))
##@copyAttributes internal sienaGroupCreate
copyAttributes <- function(x, y)
{
@@ -1706,6 +1708,7 @@
attr(newcovar, "nonMissingCount") <-
attr(const[[j]], "nonMissingCount")
attr(newcovar, "mean") <- attr(const[[j]], "mean")
+ attr(newcovar, "meanp") <- rep(attr(const[[j]], "mean"), dim3)
attr(newcovar, "centered") <- attr(const[[j]], "centered")
attr(newcovar, "range") <- attr(const[[j]], "range")
attr(newcovar, "rangep") <- rep(attr(const[[j]], "range"),
Modified: pkg/RSiena/R/sienaDataCreateFromSession.r
===================================================================
--- pkg/RSiena/R/sienaDataCreateFromSession.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/sienaDataCreateFromSession.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -19,6 +19,7 @@
sessionFromFile <- function(loadfilename, tk=FALSE)
{
## browser()
+ ## require(tcltk)
dots <- max(c(0, gregexpr(".", loadfilename, fixed=TRUE)[[1]]))
if (dots > 1)
{
@@ -78,6 +79,7 @@
##@readInFiles siena01/DataCreate
readInFiles <- function(session, edited, files=NULL)
{
+ ## require(tcltk)
noFiles <- nrow(session)
if (!any(edited))
{
@@ -116,10 +118,10 @@
}
else
{
- require(network)
+ ## suppressPackageStartupMessages(require(network))
oldwarn <- getOption("warn")
options(warn = -1)
- tmp <- read.paj(session$Filename[i])
+ tmp <- network::read.paj(session$Filename[i])
options(warn = oldwarn)
## should be a single net
}
@@ -134,6 +136,7 @@
modelName='Siena', edited=NULL,
files=NULL, getDocumentation=FALSE)
{
+ ## require(tcltk)
##@turnoffwarn internal sienaDataCreateFromSession
turnoffwarn <- function()
{
@@ -163,8 +166,8 @@
}
else if (namesession$Format[1] == "pajek net")
{
- if (any(sapply(namefiles, network.size) !=
- network.size(namefiles[[1]])))
+ if (any(sapply(namefiles, network::network.size) !=
+ network::network.size(namefiles[[1]])))
stop("Dimensions must be the same for one object")
}
}
@@ -197,7 +200,7 @@
ActorSetsSize[k] <<- dim(namefiles[[1]])[i]
}
else if (namesession$Format[1] == "pajek net")
- ActorSetsSize[k] <<- network.size(namefiles[[1]])
+ ActorSetsSize[k] <<- network::network.size(namefiles[[1]])
else
ActorSetsSize[k] <<-
as.numeric(strsplit(namesession$NbrOfActors[1],
@@ -221,7 +224,7 @@
}
else
{
- if (network.size(namefiles[[1]]) != ActorSetsSize[mymatch])
+ if (network::network.size(namefiles[[1]]) != ActorSetsSize[mymatch])
{
stop(paste("Conflicting sizes for actor set",
nodeSets[i]))
@@ -350,16 +353,16 @@
else ## pajek net
{
##require(Matrix)
- nActors <- network.size(namefiles[[1]])
+ nActors <- network::network.size(namefiles[[1]])
mylist <- vector("list", observations)
for (x in 1:nrow(namesession))
{
miss <- miss1[[x]]
myedgelist <-
- as.matrix.network(namefiles[[x]],
+ network::as.matrix.network(namefiles[[x]],
matrix.type="edgelist")
edgenames <-
- list.edge.attributes(namefiles[[x]])
+ network::list.edge.attributes(namefiles[[x]])
edgenames <- edgenames[-match("na", edgenames)]
if (length(edgenames) != 1)
{
@@ -369,7 +372,7 @@
{
myedgelist <-
cbind(myedgelist,
- get.edge.value(namefiles[[x]],
+ network::get.edge.value(namefiles[[x]],
edgenames))
}
myedgelist[myedgelist[, 3] %in% miss, 3] <-
@@ -379,14 +382,14 @@
c(nonzero[[x]], 10, 11)), 3] <- 0
myedgelist[myedgelist[,3] %in%
nonzero[[x]], 3] <- 1
- if (!is.directed(namefiles[[x]]))
+ if (!network::is.directed(namefiles[[x]]))
{
perm <- c(2, 1, 3)
myedgelist <- rbind(myedgelist,
myedgelist[, perm])
}
- if (network.size(namefiles[[x]]) != nActors)
+ if (network::network.size(namefiles[[x]]) != nActors)
stop("number of actors inconsistent")
mylist[[x]] <-
Modified: pkg/RSiena/R/sienaGOF.r
===================================================================
--- pkg/RSiena/R/sienaGOF.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/sienaGOF.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -19,7 +19,7 @@
cluster=NULL, robust=FALSE,
groupName="Data1", varName, ...)
{
- require(MASS)
+ ## require(MASS)
## require(Matrix)
## Check input
if (sienaFitObject$maxlike)
@@ -523,9 +523,9 @@
##@plot.sienaGOF siena07 Plot method for sienaGOF
plot.sienaGOF <- function (x, center=FALSE, scale=FALSE, violin=TRUE,
- key=NULL, perc=.05, period=1, main=main, ylab=ylab, ...)
+ key=NULL, perc=.05, period=1, ...)
{
- require(lattice)
+ ## require(lattice)
args <- list(...)
if (is.null(args$main))
{
@@ -538,7 +538,7 @@
}
else
{
- main=args
+ main=args$main
}
if (attr(x,"joined"))
@@ -556,12 +556,27 @@
## Need to check for useless statistics here:
n.obs <- nrow(obs)
-# Added version 1.1-243 by ts:
+ screen <- sapply(1:ncol(obs),function(i){
+ (sum(is.nan(rbind(sims,obs)[,i])) == 0) }) &
+ (diag(var(rbind(sims,obs)))!=0)
+
+ if (any((diag(var(rbind(sims,obs)))==0)))
+ { cat("Note: some statistics are not plotted because their variance is 0.\n")
+ cat("This holds for the statistic")
+ if (sum(diag(var(rbind(sims,obs)))==0) > 1){cat("s")}
+ cat(": ")
+ cat(paste(attr(x,"key")[which(diag(var(rbind(sims,obs)))==0)], sep=", "))
+ cat(".\n")
+ }
+
+ sims <- sims[,screen, drop=FALSE]
+ obs <- obs[,screen, drop=FALSE]
+ obsLabels <- round(x$Observations[,screen, drop=FALSE],3)
+
sims.min <- apply(sims, 2, min)
sims.max <- apply(sims, 2, max)
sims.min <- pmin(sims.min, obs)
sims.max <- pmax(sims.max, obs)
-# Also further use of ymin, ymax was added.
if (center)
{
@@ -575,8 +590,6 @@
}
if (scale)
{
-# sims.min <- apply(sims, 2, min)
-# sims.max <- apply(sims, 2, max)
sims.range <- sims.max - sims.min + 1e-6
sims <- sapply(1:ncol(sims), function(i) sims[,i]/(sims.range[i]))
obs <- matrix(sapply(1:ncol(sims), function(i) obs[,i]/(sims.range[i]))
@@ -612,13 +625,6 @@
ylabel = args$ylab
}
- screen <- sapply(1:ncol(obs),function(i){
- (sum(is.nan(rbind(sims,obs)[,i])) == 0) }) &
- (diag(var(rbind(sims,obs)))!=0)
- sims <- sims[,screen, drop=FALSE]
- obs <- obs[,screen, drop=FALSE]
- obsLabels <- round(x$Observations[,screen, drop=FALSE],3)
-
if (is.null(args$xlab))
{
xlabel = paste( paste("p:", round(x$p, 3),
@@ -952,7 +958,7 @@
# note that this also is done in RSiena for calculation of target statistics.
# Structural values are treated as in sparseMatrixExtraction.
networkExtraction <- function (i, obsData, sims, period, groupName, varName){
- require(network)
+ ## suppressPackageStartupMessages(require(network))
dimsOfDepVar<- attr(obsData[[groupName]]$depvars[[varName]], "netdims")
isbipartite <- (attr(obsData[[groupName]]$depvars[[varName]], "type")
=="bipartite")
@@ -966,12 +972,12 @@
# Initialize empty networks:
if (isbipartite)
{
- emptyNetwork <- network.initialize(dimsOfDepVar[1]+dimsOfDepVar[2],
+ emptyNetwork <- network::network.initialize(dimsOfDepVar[1]+dimsOfDepVar[2],
bipartite=dimsOfDepVar[1])
}
else
{
- emptyNetwork <- network.initialize(dimsOfDepVar[1], bipartite=NULL)
+ emptyNetwork <- network::network.initialize(dimsOfDepVar[1], bipartite=NULL)
}
# Use what was defined in the function above:
matrixNetwork <- sparseMatrixExtraction(i, obsData, sims,
@@ -991,7 +997,7 @@
}
else
{
- returnValue <- network.edgelist(
+ returnValue <- network::network.edgelist(
cbind(sparseMatrixNetwork at i + 1,
sparseMatrixNetwork at j + bipartiteOffset, 1),
emptyNetwork)
Modified: pkg/RSiena/R/sienaModelCreate.r
===================================================================
--- pkg/RSiena/R/sienaModelCreate.r 2014-12-11 22:09:09 UTC (rev 283)
+++ pkg/RSiena/R/sienaModelCreate.r 2015-04-02 14:58:39 UTC (rev 284)
@@ -23,7 +23,7 @@
n3=1000, nsub=4, dolby=TRUE,
maxlike=FALSE, diagonalize=1.0*!maxlike,
condvarno=0, condname='',
- firstg=0.2, cond=NA, findiff=FALSE, seed=NULL,
+ firstg=0.2, reduceg=0.5, cond=NA, findiff=FALSE, seed=NULL,
pridg=0.05, prcdg=0.05, prper=0.2, pripr=0.3, prdpr=0.3,
prirms=0.05, prdrms=0.05, maximumPermutationLength=40,
minimumPermutationLength=2, initialPermutationLength=20,
@@ -35,6 +35,7 @@
model$checktime <- TRUE
model$n3 <- n3
model$firstg <- firstg
+ model$reduceg <- reduceg
model$maxrat <- 1.0
# model$maxmaxrat <- 10.0
model$maxlike <- maxlike
Modified: pkg/RSiena/R/sienaTimeTest.r
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 284
More information about the Rsiena-commits
mailing list