[Rsiena-commits] r213 - in pkg/RSienaTest: . R data doc inst/doc man src/model/effects
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 18 16:05:50 CEST 2012
Author: tomsnijders
Date: 2012-05-18 16:05:50 +0200 (Fri, 18 May 2012)
New Revision: 213
Modified:
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/initializeFRAN.r
pkg/RSienaTest/R/phase3.r
pkg/RSienaTest/R/print07Report.r
pkg/RSienaTest/R/printInitialDescription.r
pkg/RSienaTest/R/robmon.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaModelCreate.r
pkg/RSienaTest/R/sienaprint.r
pkg/RSienaTest/R/sienautils.r
pkg/RSienaTest/R/terminateFRAN.r
pkg/RSienaTest/changeLog
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/doc/bayes.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/sienaModelCreate.Rd
pkg/RSienaTest/man/sienaNet.Rd
pkg/RSienaTest/src/model/effects/AllEffects.h
pkg/RSienaTest/src/model/effects/EffectFactory.cpp
Log:
Modified: pkg/RSienaTest/DESCRIPTION
===================================================================
--- pkg/RSienaTest/DESCRIPTION 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/DESCRIPTION 2012-05-18 14:05:50 UTC (rev 213)
@@ -1,8 +1,8 @@
Package: RSienaTest
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.1-212
-Date: 2012-03-29
+Version: 1.1-213
+Date: 2012-05-07
Author: Various
Depends: R (>= 2.10.0)
Imports: Matrix
Modified: pkg/RSienaTest/R/effects.r
===================================================================
--- pkg/RSienaTest/R/effects.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/effects.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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
# *
@@ -1244,9 +1244,17 @@
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]))
+#browser()
tmp <- c(matcnt=matcnt, matdiff=matdiff, matchange=matchange)
names(tmp) <- c("matcnt", "matdiff", "matchangeFrom0To0",
"matchangeFrom0To1",
@@ -1357,7 +1365,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)
Modified: pkg/RSienaTest/R/initializeFRAN.r
===================================================================
--- pkg/RSienaTest/R/initializeFRAN.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/initializeFRAN.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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: initializeFRAN.r
# *
@@ -717,6 +717,7 @@
## sort out composition change
## convertToStructuralZeros()?
sparse <- attr(depvar, "sparse")
+ allowOnly <- attr(depvar, "allowOnly")
if (sparse)
{
## require(Matrix)
@@ -932,14 +933,17 @@
mydiff <- mymat2 - mymat1
attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
- if (all(mydiff at x >= 0, na.rm=TRUE))
+ if (allowOnly)
{
- attr(depvar, "uponly")[i] <- TRUE
+ if (all(mydiff at x >= 0, na.rm=TRUE))
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
+ if (all(mydiff at x <= 0, na.rm=TRUE))
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
- if (all(mydiff at x <= 0, na.rm=TRUE))
- {
- attr(depvar, "downonly")[i] <- TRUE
- }
}
edgeLists[[i]] <- list(mat1 = t(mat1), mat2 = t(mat2),
mat3 = t(mat3))
@@ -1049,14 +1053,17 @@
mydiff <- mymat2 - mymat1
attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
- if (all(mydiff >= 0, na.rm=TRUE))
+ if (allowOnly)
{
- attr(depvar, "uponly")[i] <- TRUE
+ if (all(mydiff >= 0, na.rm=TRUE))
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
+ if (all(mydiff <= 0, na.rm=TRUE))
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
- if (all(mydiff <= 0, na.rm=TRUE))
- {
- attr(depvar, "downonly")[i] <- TRUE
- }
}
diag(networks[[i]]) <- 0
edgeLists[[i]] <- createEdgeLists(networks[[i]], depvar[, , i],
@@ -1104,6 +1111,7 @@
action <- matrix(0, nrow=attr(depvar, "netdims")[1], ncol=observations)
}
sparse <- attr(depvar, "sparse")
+ allowOnly <- attr(depvar, "allowOnly")
if (sparse)
{
## require(Matrix)
@@ -1284,14 +1292,17 @@
mydiff <- mymat2 - mymat1
attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
- if (all(mydiff at x >= 0, na.rm=TRUE))
+ if (allowOnly)
{
- attr(depvar, "uponly")[i] <- TRUE
+ if (all(mydiff at x >= 0, na.rm=TRUE))
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
+ if (all(mydiff at x <= 0, na.rm=TRUE))
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
- if (all(mydiff at x <= 0, na.rm=TRUE))
- {
- attr(depvar, "downonly")[i] <- TRUE
- }
}
edgeLists[[i]] <- list(mat1 = t(mat1), mat2 = t(mat2),
mat3 = t(mat3))
@@ -1384,14 +1395,17 @@
mydiff <- mymat2 - mymat1
attr(depvar, "distance")[i] <- sum(mydiff != 0,
na.rm = TRUE)
- if (all(mydiff >= 0, na.rm=TRUE))
+ if (allowOnly)
{
- attr(depvar, "uponly")[i] <- TRUE
+ if (all(mydiff >= 0, na.rm=TRUE))
+ {
+ attr(depvar, "uponly")[i] <- TRUE
+ }
+ if (all(mydiff <= 0, na.rm=TRUE))
+ {
+ attr(depvar, "downonly")[i] <- TRUE
+ }
}
- if (all(mydiff <= 0, na.rm=TRUE))
- {
- attr(depvar, "downonly")[i] <- TRUE
- }
}
edgeLists[[i]] <- createEdgeLists(networks[[i]], depvar[, , i], TRUE)
Modified: pkg/RSienaTest/R/phase3.r
===================================================================
--- pkg/RSienaTest/R/phase3.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/phase3.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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: phase3.r
# *
@@ -88,8 +88,11 @@
Report(c('Time per iteration in phase 3 = ',
format(z$timePhase3, nsmall=4, digits=4), '\n'), lf)
}
- z <- CalculateDerivative3(z, x)
- z <- PotentialNR(z, x, FALSE)
+ z <- CalculateDerivative3(z, x)
+ if (!x$simOnly)
+ {
+ z <- PotentialNR(z, x, FALSE)
+ }
if (any(z$newfixed))
{
Report('There was a problem in obtaining convergence.\n', outf)
@@ -218,61 +221,64 @@
}
}
}
- if (x$maxlike)
- {
- Report('Estimated complete data information matrix: \n', cf)
- PrtOutMat(z$dfra, cf)
- Report(c('Estimated conditional covariance matrix score function ',
- '(unobserved information):\n'), cf)
- PrtOutMat(z$msf, cf)
- Report('\n', cf)
- dfrac <- z$dfra - z$msf
- ## dfrac[z$fixed[row(dfrac)] | z$fixed[col(dfrac)]] <- 0
- ## a clever way to do it
- dfrac[z$fixed, ] <- 0
- dfrac[ ,z$fixed] <- 0
- diag(dfrac)[z$fixed] <- 1
- if (inherits(try(cov <- solve(dfrac)),"try-error"))
- {
- Report('Noninvertible estimated covariance matrix : \n', outf)
- cov <- NULL
- }
- }
- else
+ if (!x$simOnly)
{
- cov <- z$dinv %*% z$msfc %*% t(z$dinv)
- }
- error <- FALSE
- if (inherits(try(msfinv <- solve(z$msfc)), "try-error"))
- {
- Report('Covariance matrix not positive definite: \n', outf)
- if (any(z$fixed || any(z$newfixed)))
+ if (x$maxlike)
{
- Report(c('(This may be unimportant, and related to the fact\n',
- 'that some parameters are fixed.)\n'), outf)
+ Report('Estimated complete data information matrix: \n', cf)
+ PrtOutMat(z$dfra, cf)
+ Report(c('Estimated conditional covariance matrix score function ',
+ '(unobserved information):\n'), cf)
+ PrtOutMat(z$msf, cf)
+ Report('\n', cf)
+ dfrac <- z$dfra - z$msf
+ ## dfrac[z$fixed[row(dfrac)] | z$fixed[col(dfrac)]] <- 0
+ ## a clever way to do it
+ dfrac[z$fixed, ] <- 0
+ dfrac[ ,z$fixed] <- 0
+ diag(dfrac)[z$fixed] <- 1
+ if (inherits(try(cov <- solve(dfrac)),"try-error"))
+ {
+ Report('Noninvertible estimated covariance matrix : \n', outf)
+ cov <- NULL
+ }
}
- else
+ else
{
- Report(c('This may mean that the reported standard errors ',
- 'are invalid.\n'), outf)
+ cov <- z$dinv %*% z$msfc %*% t(z$dinv)
}
- z$msfinv <- NULL
- }
- else
- {
- z$msfinv <- msfinv
- }
- if (!is.null(cov))
- {
- 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] <- 99 * 99
- 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
- diag(cov)[z$diver] <- 99 * 99
- }
- z$covtheta <- cov
+ error <- FALSE
+ if (inherits(try(msfinv <- solve(z$msfc)), "try-error"))
+ {
+ Report('Covariance matrix not positive definite: \n', outf)
+ if (any(z$fixed || any(z$newfixed)))
+ {
+ Report(c('(This may be unimportant, and related to the fact\n',
+ 'that some parameters are fixed.)\n'), outf)
+ }
+ else
+ {
+ Report(c('This may mean that the reported standard errors ',
+ 'are invalid.\n'), outf)
+ }
+ z$msfinv <- NULL
+ }
+ else
+ {
+ z$msfinv <- msfinv
+ }
+ if (!is.null(cov))
+ {
+ 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] <- 99 * 99
+ 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
+ diag(cov)[z$diver] <- 99 * 99
+ }
+ z$covtheta <- cov
+ }
## ans<-InstabilityAnalysis(z)
z
}
Modified: pkg/RSienaTest/R/print07Report.r
===================================================================
--- pkg/RSienaTest/R/print07Report.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/print07Report.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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: print07report.r
# *
@@ -13,8 +13,15 @@
{
types <- attr(z$f, "types")
Report('\n\n', outf)
- Heading(2, outf, "Estimation Results.")
- if (!z$OK)
+ if ((x$nsub == 0)&(!x$simOnly))
+ {
+ Heading(2, outf, "Estimation Results.")
+ }
+ else
+ {
+ Heading(2, outf, "Simulation Results.")
+ }
+ if (!z$OK)
{
Report("Error end of estimation algorithm", outf)
}
@@ -23,7 +30,14 @@
Report("Regular end of estimation algorithm.\n", outf)
Report(c("Total of", z$n, "iteration steps.\n\n"), outf)
Report(c("Total of", z$n, "iteration steps.\n\n"), bof)
- Heading(3, outf, "Estimates and standard errors")
+ if (x$simOnly)
+ {
+ Heading(3, outf, "Parameter values")
+ }
+ else
+ {
+ Heading(3, outf, "Estimates and standard errors")
+ }
Heading(3, bof, "Estimates and standard errors")
if (z$cconditional) ## deal with rate parameter
{
@@ -81,19 +95,26 @@
{
Report("Network Dynamics\n", outf)
}
- ses <- ifelse(diag(z$covtheta) >= 0.0 | z$fixed,
- paste(' (', sprintf("%9.4f",sqrt(diag(z$covtheta))),
+ if (!x$simOnly)
+ {
+ ses <- ifelse(diag(z$covtheta) >= 0.0 | z$fixed,
+ paste(' (', sprintf("%9.4f",sqrt(diag(z$covtheta))),
')', sep=''), ' ---')
- if (!all(z$fixed))
- {
- ses[z$fixed] <- ' ( fixed )'
- }
- theta <- ifelse(diag(z$covtheta) >= 0.0 | z$fixed,
+ if (!all(z$fixed))
+ {
+ ses[z$fixed] <- ' ( fixed )'
+ }
+ theta <- ifelse(diag(z$covtheta) >= 0.0 | z$fixed,
sprintf("%9.4f",z$theta),
' ---')
- if (nBehavs > 0)
- {
- behEffects <-
+ }
+ else
+ {
+ theta <- sprintf("%9.4f",z$theta)
+ }
+ if (nBehavs > 0)
+ {
+ behEffects <-
z$requestedEffects[z$requestedEffects$netType == 'behavior',]
behNames <- unique(behEffects$name)
if (nBehavs > 1)
@@ -108,15 +129,19 @@
behEffects$effectName
}
}
- typesp <- ifelse (z$requestedEffects$type %in% c("eval", "rate"),
+ typesp <- ifelse (z$requestedEffects$type %in% c("eval", "rate"),
": ", ": ")
- typetxt <- ifelse (z$requestedEffects$type == "creation", "creat",
+ typetxt <- ifelse (z$requestedEffects$type == "creation", "creat",
z$requestedEffects$type )
- tmp <- paste(typetxt, typesp, z$requestedEffects$effectName, sep = '')
- tmp <- paste(sprintf("%2d", 1:length(z$requestedEffects$effectName)),
+ tmp <- paste(typetxt, typesp, z$requestedEffects$effectName, sep = '')
+ if (x$simOnly)
+ {
+ ses <- rep(' ', z$pp)
+ }
+ tmp <- paste(sprintf("%2d", 1:length(z$requestedEffects$effectName)),
'. ', format(substr(tmp, 1, 50), width=50),
theta, ses, '\n', sep='', collapse = '')
- if (nBehavs > 0 && nNetworks > 0)
+ if (nBehavs > 0 && nNetworks > 0)
{
nNetworkEff <- nrow(z$requestedEffects) - nrow(behEffects)
tmpstr <- paste(nNetworkEff + 1, '. ', sep='')
@@ -142,38 +167,41 @@
'the standard errors of rate parameters\n',
'not used for conditioning are unreliable.'), outf)
}
- Heading(3, outf, "Covariance matrices")
- if (any(z$fixed))
- {
- Report(c('(Values of the covariance matrix of estimates\n',
- ' are meaningless for the fixed parameters.)\n\n'),
- outf)
- }
-
- Report(c("Covariance matrix of estimates",
+ if (!x$simOnly)
+ {
+ Heading(3, outf, "Covariance matrices")
+ if (any(z$fixed))
+ {
+ Report(c('(Values of the covariance matrix of estimates\n',
+ ' are meaningless for the fixed parameters.)\n\n'),
+ outf)
+ }
+ Report(c("Covariance matrix of estimates",
"(correlations below diagonal):\n"), outf)
- covcor <- z$covtheta
- correl <- z$covtheta/sqrt(diag(z$covtheta))[row(z$covtheta)]/
- sqrt(diag(z$covtheta))[col(z$covtheta)]
- covcor[lower.tri(covcor)] <- correl[lower.tri(correl)]
- PrtOutMat(format(round(covcor, digits = 3), width = 10), outf)
- Report(c('Derivative matrix of expected statistics X by',
- 'parameters and\n'), outf)
- Report(c("covariance/correlation matrix of X can be found using\n",
- "summary(ans) within R,",
- " or by using the 'verbose' option in Siena07.\n "), sep = "", outf)
- Report(c("Derivative matrix of expected statistics X by",
+ covcor <- z$covtheta
+ correl <- z$covtheta/sqrt(diag(z$covtheta))[row(z$covtheta)]/
+ sqrt(diag(z$covtheta))[col(z$covtheta)]
+ covcor[lower.tri(covcor)] <- correl[lower.tri(correl)]
+ PrtOutMat(format(round(covcor, digits = 3), width = 10), outf)
+ Report(c('Derivative matrix of expected statistics X by',
+ 'parameters and\n'), outf)
+ Report(c("covariance/correlation matrix of X can be found using\n",
+ "summary(ans) within R,",
+ " or by using the 'verbose' option in Siena07.\n "),
+ sep = "", outf)
+ Report(c("Derivative matrix of expected statistics X by",
"parameters:\n\n"), lf)
- PrtOutMat(z$dfrac, lf)
- Report('Covariance matrix of X (correlations below the diagonal):\n',
+ PrtOutMat(z$dfrac, lf)
+ Report('Covariance matrix of X (correlations below the diagonal):\n',
lf)
- covcor <- z$msf
- correl <- z$msf/sqrt(diag(z$msf))[row(z$msf)]/
- sqrt(diag(z$msf))[col(z$msf)]
- covcor[lower.tri(covcor)] <- correl[lower.tri(correl)]
- PrtOutMat(format(round(covcor, digits = 3), width = 10), lf)
- Report('\n', outf)
- Report('\n', lf)
- }
+ covcor <- z$msf
+ correl <- z$msf/sqrt(diag(z$msf))[row(z$msf)]/
+ sqrt(diag(z$msf))[col(z$msf)]
+ covcor[lower.tri(covcor)] <- correl[lower.tri(correl)]
+ PrtOutMat(format(round(covcor, digits = 3), width = 10), lf)
+ Report('\n', outf)
+ Report('\n', lf)
+ }
+ }
}
Modified: pkg/RSienaTest/R/printInitialDescription.r
===================================================================
--- pkg/RSienaTest/R/printInitialDescription.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/printInitialDescription.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -1,7 +1,8 @@
#/******************************************************************************
+#/******************************************************************************
# * 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: printInitialDescription.r
# *
@@ -61,7 +62,7 @@
atts <- attributes(depvar)
subs <- 1:data[[group]]$observations + periodFromStart
density[subs] <- atts$density
- if (any(atts$ones >= atts$nval))
+ if (any(atts$ones >= atts$nval, na.rm = TRUE))
{
difficult <- TRUE
}
@@ -109,8 +110,8 @@
Report("\n", outf)
if (nData > 1)
{
- Report("The average degrees are: ", outf)
- Report(paste(names(data), round(averageOutDegree, 3),
+ Report("The average degrees over all waves are: \n ", outf)
+ Report(paste(names(data), round(averageOutDegree, 3), "\n",
sep=': '), outf)
Report("\n", outf)
}
@@ -202,10 +203,11 @@
}
if (valmin == 0 && valmax == 1)
{
- if (matchange[4, per] / (matchange[3, per] +
- matchange[4, per]) <
- matchange[2, per] / (matchange[2, per] +
- matchange[1, per]))
+ if (matchange[4, per]*
+ (matchange[2, per] + matchange[1, per])
+ <
+ matchange[2, per] *
+ (matchange[3, per] + matchange[4, per]) )
{
Report(c("\nThis means that in period ", per,
", proportionately less 1-ties stayed 1,\n",
@@ -306,16 +308,20 @@
mymat[mymat == 10] <- 0
mymat[mymat == 11] <- 1
diag(mymat) <- NA
- dyadTable <- table(mymat, t(mymat))
- diag(dyadTable) <- diag(dyadTable) / 2
- if (valmin == 0 && valmax ==1)
- {
- mutual <- dyadTable[2, 2]
- asymm <- dyadTable[2, 1]
- nulls <- dyadTable[1, 1]
- totDyad <- nulls + asymm + mutual
-
- }
+ # dyadTable <- table(mymat, t(mymat))
+ # Changed to protect against zero rows or columns
+ nulls <- sum((1 - mymat)*(1 - t(mymat)), na.rm=TRUE)
+ asymm <- sum(mymat*(1 - t(mymat)), na.rm=TRUE) +
+ sum((1 - mymat)*t(mymat), na.rm=TRUE)
+ mutual <- sum(mymat*t(mymat), na.rm=TRUE)
+ # diag(dyadTable) <- diag(dyadTable) / 2
+ #if (valmin == 0 && valmax ==1)
+ #{
+ # mutual <- dyadTable[2, 2]
+ # asymm <- dyadTable[2, 1]
+ # nulls <- dyadTable[1, 1]
+ totDyad <- nulls + asymm + mutual
+ #}
}
if (valmin == 0 && valmax == 1)
{
@@ -411,7 +417,6 @@
atts <- attributes(depvar)
for (i in 1: atts$netdims[3])
{
- # browser()
mytab <- table(depvar[, 1, i])
vals[as.numeric(names(mytab)) + 1 - minval,
periodFromStart + i] <- mytab
Modified: pkg/RSienaTest/R/robmon.r
===================================================================
--- pkg/RSienaTest/R/robmon.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/robmon.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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: robmon.r
# *
@@ -324,11 +324,14 @@
z <- terminateFRAN(z, x)
## #####################################################
## call to FRAN changes covariance matrix for conditional estimation
- z$diver<- (z$fixed | z$diver | diag(z$covtheta) < 1e-9) & (!z$AllUserFixed)
- z$covtheta[z$diver, ] <- Root(diag(z$covtheta)) * 33
- ##not sure this does not use very small vals
- z$covtheta[, z$diver] <- Root(diag(z$covtheta)) * 33
- diag(z$covtheta)[z$diver] <- 999
+ if (!x$simOnly)
+ {
+ z$diver<- (z$fixed | z$diver | diag(z$covtheta) < 1e-9) & (!z$AllUserFixed)
+ z$covtheta[z$diver, ] <- Root(diag(z$covtheta)) * 33
+ ##not sure this does not use very small vals
+ z$covtheta[, z$diver] <- Root(diag(z$covtheta)) * 33
+ diag(z$covtheta)[z$diver] <- 999
+ }
z$termination <- 'OK'
z
}
Modified: pkg/RSienaTest/R/sienaDataCreate.r
===================================================================
--- pkg/RSienaTest/R/sienaDataCreate.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/sienaDataCreate.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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: sienaDataCreate.r
# *
@@ -593,10 +593,13 @@
sum(is.na(myvector2) | is.na(myvector1))
attr(depvars[[i]], 'nonMissingEither')[j] <-
sum(!(is.na(myvector2) | is.na(myvector1)))
- if (all(mydiff >= 0, na.rm=TRUE))
- attr(depvars[[i]], 'downonly')[j] <- TRUE
- if (all(mydiff <= 0, na.rm=TRUE))
- attr(depvars[[i]], 'uponly')[j] <- TRUE
+ if (attr(depvars[[i]], 'allowOnly'))
+ {
+ if (all(mydiff >= 0, na.rm=TRUE))
+ attr(depvars[[i]], 'downonly')[j] <- TRUE
+ if (all(mydiff <= 0, na.rm=TRUE))
+ attr(depvars[[i]], 'uponly')[j] <- TRUE
+ }
}
rr <- range(depvars[[i]], na.rm=TRUE)
if (rr[2] == rr[1] && !any(is.na(depvars[[i]])))
@@ -659,10 +662,13 @@
mydiff <- mymat2 - mymat1
attr(depvars[[i]], 'distance')[j] <- sum(mydiff != 0,
na.rm = TRUE)
- if (all(mydiff at x >= 0, na.rm=TRUE))
- attr(depvars[[i]], 'uponly')[j] <- TRUE
- if (all(mydiff at x <= 0, na.rm=TRUE))
- attr(depvars[[i]], 'downonly')[j] <- TRUE
+ if (attr(depvars[[i]], 'allowOnly'))
+ {
+ if (all(mydiff at x >= 0, na.rm=TRUE))
+ attr(depvars[[i]], 'uponly')[j] <- TRUE
+ if (all(mydiff at x <= 0, na.rm=TRUE))
+ attr(depvars[[i]], 'downonly')[j] <- TRUE
+ }
}
else
{
@@ -691,10 +697,13 @@
mydiff <- mymat2 - mymat1
attr(depvars[[i]], 'distance')[j] <- sum(mydiff != 0,
na.rm = TRUE)
- if (all(mydiff >= 0, na.rm=TRUE))
- attr(depvars[[i]], 'uponly')[j] <- TRUE
- if (all(mydiff <= 0, na.rm=TRUE))
- attr(depvars[[i]], 'downonly')[j] <- TRUE
+ if (attr(depvars[[i]], 'allowOnly'))
+ {
+ if (all(mydiff >= 0, na.rm=TRUE))
+ attr(depvars[[i]], 'uponly')[j] <- TRUE
+ if (all(mydiff <= 0, na.rm=TRUE))
+ attr(depvars[[i]], 'downonly')[j] <- TRUE
+ }
}
}
if (type == 'oneMode')
@@ -772,7 +781,12 @@
{
if (is.na(x["11"]))
{
- x["1"]
+ if (is.na(x["1"]))
+ {
+ 0
+ }
+ else
+ x["1"]
}
else
{
Modified: pkg/RSienaTest/R/sienaModelCreate.r
===================================================================
--- pkg/RSienaTest/R/sienaModelCreate.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/sienaModelCreate.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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: sienaModelCreate.r
# *
@@ -26,7 +26,7 @@
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,
- modelType=1, mult=5)
+ modelType=1, mult=5, simOnly=FALSE)
{
model <- NULL
model$projname <- projname
@@ -37,6 +37,7 @@
model$maxrat <- 1.0
model$maxmaxrat <- 10.0
model$maxlike <- maxlike
+ model$simOnly <- simOnly
model$FRANname <- deparse(substitute(fn))
if (maxlike)
{
Modified: pkg/RSienaTest/R/sienaprint.r
===================================================================
--- pkg/RSienaTest/R/sienaprint.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/sienaprint.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -130,7 +130,6 @@
}
cat(tmp1[i], '\n')
}
-
cat("\nTotal of", x$n, "iteration steps.\n\n")
if (x$termination == "UserInterrupt")
cat(" \n*** Warning ***",
@@ -246,7 +245,7 @@
}
cat('\n')
}
- if (x$OK)
+ if ((x$OK)&(!is.null(x$covtheta)))
{
cat("Covariance matrix of estimates (correlations below diagonal)\n\n")
covcor <- x$covtheta
@@ -399,11 +398,16 @@
addtorow$pos[[addsub]] <- nrates + 2
addsub <- addsub + 1
}
-
- ses <- sqrt(diag(x$covtheta))
- ses[x$fixed] <- NA
+ if (!is.null(x$covtheta))
+ {
+ ses <- sqrt(diag(x$covtheta))
+ ses[x$fixed] <- NA
+ }
theta <- x$theta
- theta[diag(x$covtheta) < 0.0] <- NA
+ if (!is.null(x$covtheta))
+ {
+ theta[diag(x$covtheta) < 0.0] <- NA
+ }
if (nBehavs > 0)
{
@@ -425,7 +429,10 @@
"creat", effects$type)
mydf[nrates + (1:x$pp), 'text' ] <- effects$effectName
mydf[nrates + (1:x$pp), 'value' ] <- theta
- mydf[nrates + (1:x$pp), 'se' ] <- ses
+ if (exists("ses"))
+ {
+ mydf[nrates + (1:x$pp), 'se' ] <- ses
+ }
if (!is.null(x$tstat))
{
mydf[1:nrates, "tstat"] <- NA
Modified: pkg/RSienaTest/R/sienautils.r
===================================================================
--- pkg/RSienaTest/R/sienautils.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/sienautils.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -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: sienautils.r
# *
@@ -300,7 +300,7 @@
}
##@sienaNet Create
sienaNet<- function(netarray, type=c("oneMode","bipartite","behavior"),
- nodeSet="Actors", sparse=is.list(netarray))
+ nodeSet="Actors", sparse=is.list(netarray), allowOnly=TRUE)
{
if (!sparse)
{
@@ -436,6 +436,7 @@
attr(obj, "sparse") <- sparse
attr(obj, "nodeSet") <- nodeSet
attr(obj, "netdims") <- netdims
+ attr(obj, "allowOnly") <- allowOnly
obj
}
##@validateSienaNet Miscellaneous not used yet
Modified: pkg/RSienaTest/R/terminateFRAN.r
===================================================================
--- pkg/RSienaTest/R/terminateFRAN.r 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/R/terminateFRAN.r 2012-05-18 14:05:50 UTC (rev 213)
@@ -5,8 +5,11 @@
z$rate<- colMeans(z$ntim, na.rm=TRUE)
z$vrate <- apply(z$ntim, 2, sd, na.rm=TRUE)
z$theta[z$posj] <- z$theta[z$posj] * z$rate
- z$covtheta[z$posj, ] <- z$covtheta[z$posj, ] * z$rate
- z$covtheta[, z$posj] <- z$covtheta[,z$posj ] * z$rate
+ if (!x$simOnly)
+ {
+ z$covtheta[z$posj, ] <- z$covtheta[z$posj, ] * z$rate
+ z$covtheta[, z$posj] <- z$covtheta[,z$posj ] * z$rate
+ }
}
f <- FRANstore()
f$pModel <- NULL
Modified: pkg/RSienaTest/changeLog
===================================================================
--- pkg/RSienaTest/changeLog 2012-03-29 15:32:29 UTC (rev 212)
+++ pkg/RSienaTest/changeLog 2012-05-18 14:05:50 UTC (rev 213)
@@ -1,3 +1,26 @@
+2012-05-18 R-forge revision 213
+ All for RSienaTest only.
+ * R\bayes.r modified - still a test version.
+ * R\effects.r and R\printInitialDescription.r:
+ protect against situations where matrix matchange has zero rows or columns
+ (i.e., minor bug fix)
+ * R\sienaprint.r, R\print07Report.r, R\phase3.r, R\terminateFRAN.r,
+ R\robmon.r, R\sienaModelcreate.r, man\siena07.Rd, man\sienaModelCreate.r:
+ incorporate argument simOnly in sienaModelCreate() to facilitate
+ simulation without estimation.
+ * R\initializeFRAN.r, R\sienaDataCreate.r, R\sienautils.r, man\sienaNet.Rd:
+ incorporate argument allowOnly in sienaNet() to permit
+ ignoring monotonicity in dataand its consequences ofr upOnly and downOnly.
+ * data/allEffects.csv,
+ src/model/effects/allEffects.h, src/model/effects/effectFactory.cpp,
+ src/model/effects/SameCovariateTransitiveTripletsEffect.cpp,
+ src/model/effects/SameCovariateTransitiveTripletsEffect.h,
+ src/model/effects/TransitiveReciprocatedTripletsEffect.h,
+ src/model/effects/TransitiveReciprocatedTripletsEffect.cpp,
+ src/model/effects/SimilarityTransitiveTripletsEffect.h,
+ src/model/effects/SimilarityTransitiveTripletsEffect.cpp:
+ new effects
+
2012-03-29 R-forge revision 212
* update of RSiena_Manual.tex, RSiena.bib (both packages)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 213
More information about the Rsiena-commits
mailing list