[Rsiena-commits] r25 - in pkg/RSiena: . R data inst inst/doc man src/model src/model/variables tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Nov 24 18:56:30 CET 2009
Author: ripleyrm
Date: 2009-11-24 18:56:29 +0100 (Tue, 24 Nov 2009)
New Revision: 25
Added:
pkg/RSiena/changeLog
pkg/RSiena/man/sienaFit.Rd
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/NAMESPACE
pkg/RSiena/R/Sienatest.r
pkg/RSiena/R/effects.r
pkg/RSiena/R/phase3.r
pkg/RSiena/R/print01Report.r
pkg/RSiena/R/printInitialDescription.r
pkg/RSiena/R/siena01.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienaDataCreateFromSession.r
pkg/RSiena/R/sienaModelCreate.r
pkg/RSiena/R/sienaprint.r
pkg/RSiena/R/sienautils.r
pkg/RSiena/R/simstatsc.r
pkg/RSiena/data/allEffects.csv
pkg/RSiena/inst/doc/s_man400.pdf
pkg/RSiena/inst/sienascript
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/siena07.Rd
pkg/RSiena/man/sienaModelCreate.Rd
pkg/RSiena/src/model/EpochSimulation.h
pkg/RSiena/src/model/variables/BehaviorVariable.cpp
pkg/RSiena/src/model/variables/NetworkVariable.h
pkg/RSiena/tests/parallel.R
Log:
New version 1.0.8. Bug fixes. Uponly and downonly for behavior variables. Conditional simulation now the default if only one dependent variable.
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2009-11-08 17:24:42 UTC (rev 24)
+++ pkg/RSiena/DESCRIPTION 2009-11-24 17:56:29 UTC (rev 25)
@@ -1,14 +1,14 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.7
-Date: 2009-11-05
+Version: 1.0.8
+Date: 2009-11-22
Author: Various
-Depends: R (>= 2.7.0)
-Imports: Matrix, xtable
+Depends: R (>= 2.7.0), xtable
+Imports: Matrix
Suggests: tcltk, snow, rlecuyer, network, codetools
SystemRequirements: GNU make, tcl/tk 8.5, Tktable
-Maintainer: <ruth at stats.ox.ac.uk>
+Maintainer: Ruth Ripley <ruth at stats.ox.ac.uk>
Description: Fits models to longitudinal networks
License: GPL (>=2)
LazyLoad: yes
Modified: pkg/RSiena/NAMESPACE
===================================================================
--- pkg/RSiena/NAMESPACE 2009-11-08 17:24:42 UTC (rev 24)
+++ pkg/RSiena/NAMESPACE 2009-11-24 17:56:29 UTC (rev 25)
@@ -1,9 +1,9 @@
-useDynLib("RSiena")
+useDynLib(RSiena)
export(coCovar, coDyadCovar, getEffects, model.create, print01Report,
siena01Gui, siena07, sienaCompositionChange,
sienaCompositionChangeFromFile, sienaDataCreate, sienaDataCreateFromSession,
sienaGroupCreate, sienaModelCreate, sienaNet, sienaNodeSet, simstats0c, varCovar, varDyadCovar,
- installGui)
+ installGui)#, sienaTimeTest)
import(Matrix)
import(xtable)
@@ -15,3 +15,8 @@
S3method(print, sienaModel)
S3method(summary, sienaFit)
S3method(xtable, sienaFit)
+S3method(print, xtable.sienaFit)
+#S3method(print, sienaTimeTest)
+#S3method(summary, sienaTimeTest)
+#S3method(print, summary.sienaTimeTest)
+#S3method(plot, sienaTimeTest)
Modified: pkg/RSiena/R/Sienatest.r
===================================================================
--- pkg/RSiena/R/Sienatest.r 2009-11-08 17:24:42 UTC (rev 24)
+++ pkg/RSiena/R/Sienatest.r 2009-11-24 17:56:29 UTC (rev 25)
@@ -224,7 +224,7 @@
oneSided <- ov * sqrt(vav)
else
oneSided <- 0
- if (maxlike) oneSided<- - oneSided
+ if (!maxlike) oneSided<- - oneSided
## change the sign for intuition for users
}
else
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2009-11-08 17:24:42 UTC (rev 24)
+++ pkg/RSiena/R/effects.r 2009-11-24 17:56:29 UTC (rev 25)
@@ -19,7 +19,7 @@
{
xx <- x
xx[, c("effectName", "functionName", "period")] <-
- sub("nnnnnn", i, xx[, c("effectName", "functionName",
+ sub("nnnnnn", periodNos[i], xx[, c("effectName", "functionName",
"period")])
tmp <- rbind(tmp, xx)
}
@@ -120,7 +120,7 @@
}
for (j in seq(along = xx$dyvCovars))
{
- if (attr(xx$dvvCovars[[j]], 'nodeSet')[1] == nodeSet)
+ if (attr(xx$dyvCovars[[j]], 'nodeSet')[1] == nodeSet)
{
objEffects <- rbind(objEffects,
createEffects("dyadObjective",
@@ -197,8 +197,7 @@
}
}
if (types[j] == 'bipartite' &&
- any(attr(xx$depvars[[j]], 'nodeSet') == nodeSet))
- ## not sure what this test should be
+ (attr(xx$depvars[[j]], 'nodeSet')[1] == nodeSet))
{
objEffects <-
rbind(objEffects,
@@ -244,9 +243,6 @@
}
if ((nOneModes + nBipartites) > 1) ## add the network name
{
- # rateEffects$functionName <- paste(varname, ': ',
- # rateEffects$functionName,
- # sep = '')
objEffects$functionName <- paste(varname, ': ',
objEffects$functionName, sep = '')
objEffects$effectName <- paste(varname, ': ',
@@ -281,19 +277,20 @@
}
else
{
- if (!(attr(depvar,'anyUpOnly') || attr(depvar, 'anyDownOnly')))
+ if (!(attr(depvar,'allUpOnly') || attr(depvar, 'allDownOnly')))
{
objEffects[objEffects$effectName =='outdegree (density)'&
objEffects$type == 'eval',
c('include', "initialValue", "untrimmedValue")] <-
list(TRUE, starts$degree, starts$untrimmed)
}
+ else
+ {
+ objEffects <-
+ objEffects[!objEffects$shortName == "density", ]
+ }
objEffects[objEffects$effectName == 'reciprocity'&
objEffects$type == 'eval','include'] <- TRUE
- ##if (attr(xx$depvars[[i]],'uponly') ||attr(xx$depvars[[i]],
- ##'downonly'))
- ##effects[['outdegree (density)']]$eval$fix <- TRUE
- ## maybe when you run it in siena07!
}
rateEffects$basicRate[1:observations] <- TRUE
list(effects=rbind(rateEffects = rateEffects, objEffects = objEffects),
@@ -333,7 +330,7 @@
varname, names(xx$depvars)[j]))
}
if (types[j] == 'bipartite' &&
- (attr(xx$depvars[[j]], 'nodeSet')[[1]] == nodeSet))
+ (attr(xx$depvars[[j]], 'nodeSet')[1] == nodeSet))
{
objEffects <- rbind(objEffects,
createEffects("behaviorBipartiteObjective",
@@ -385,7 +382,7 @@
varname, names(xx$depvars)[j]))
}
if (types[j] == 'bipartite' &&
- any(attr(xx$depvars[[j]], 'nodeSet') == nodeSet))
+ attr(xx$depvars[[j]], 'nodeSet')[1] == nodeSet)
{
objEffects <- rbind(objEffects,
createEffects("behaviorBipartiteObjective2",
@@ -403,17 +400,25 @@
## get starting values
starts <- getBehaviorStartingVals(depvar)
## set defaults
- if (!(attr(depvar,'anyUpOnly') || attr(depvar, 'anyDownOnly')))
+ if (!(attr(depvar,'allUpOnly') || attr(depvar, 'allDownOnly')))
{
objEffects[grepl("linear shape", objEffects$effectName) &
objEffects$type == 'eval',
c('include', 'initialValue','untrimmedValue')] <-
list(TRUE, starts$tendency, starts$untrimmed)
+ }
+ else
+ {
+ objEffects <- objEffects[objEffects$shortName != "linear", ]
+ }
+ if (attr(depvar, "range") > 2)
+ {
objEffects[grepl("quadratic shape", objEffects$effectName) &
objEffects$type == 'eval','include'] <- TRUE
- ## no starting value yet for quadratic effect
+ ## no starting value for quadratic effect
}
+
rateEffects[1:observations, 'include'] <- TRUE
rateEffects[1:noPeriods, 'initialValue'] <- starts$startRate
rateEffects$basicRate[1:observations] <- TRUE
@@ -518,8 +523,7 @@
{
otherName <- names(xx$depvars)[j]
if (types[j] == 'oneMode' &&
- attr(xx$depvars[[j]], 'nodeSet') %in% nodeSets )
- ## not sure what this test should be
+ attr(xx$depvars[[j]], 'nodeSet') == nodeSets[1] )
{
if (attr(xx$depvars[[j]], "symmetric"))
{
@@ -537,8 +541,7 @@
}
}
if (types[j] == 'bipartite' &&
- all(attr(xx$depvars[[j]], 'nodeSet') %in% nodeSets) &&
- ## or any?
+ (attr(xx$depvars[[j]], 'nodeSet')[1] == nodeSets[1]) &&
varname != otherName)
{
objEffects <-
@@ -549,9 +552,6 @@
}
if ((nOneModes + nBipartites) > 1) ## add the network name
{
- # rateEffects$functionName <- paste(varname, ': ',
- # rateEffects$functionName,
- # sep = '')
objEffects$functionName <- paste(varname, ': ',
objEffects$functionName, sep = '')
objEffects$effectName <- paste(varname, ': ',
@@ -572,17 +572,24 @@
rateEffects[1:noPeriods, 'initialValue'] <- starts$startRate
rateEffects$basicRate[1:observations] <- TRUE
- if (!(attr(depvar,'anyUpOnly') || attr(depvar, 'anyDownOnly')))
+ if (!(attr(depvar,'allUpOnly') || attr(depvar, 'allDownOnly')))
{
objEffects[objEffects$effectName =='outdegree (density)' &
objEffects$type == 'eval',
c('include', 'initialValue', 'untrimmedValue')] <-
- list(TRUE, starts$degree, starts$untrimmed)
+ list(TRUE, starts$degree, starts$untrimmed)
}
- ##if (attr(xx$depvars[[i]],'uponly') ||attr(xx$depvars[[i]],
- ##'downonly'))
- ##effects[['outdegree (density)']]$eval$fix <- TRUE
- ## maybe when you run it in siena07!
+ else
+ {
+ objEffects <-
+ objEffects[!objEffects$shortName == "density", ]
+ }
+ if (attr(xx$depvars[[i]],'uponly') || attr(xx$depvars[[i]],
+ 'downonly'))
+ {
+ objEffects <-
+ objEffects[!objEffects$shortName == "density", ]
+ }
rateEffects$basicRate[1:observations] <- TRUE
@@ -630,6 +637,7 @@
{
covObjEffects <-
createEffects("covarBipartiteObjective", covarname)[3, ]
+ covRateEffects <- createEffects("covarBipartiteRate", covarname)
}
else if (poszvar)
{
@@ -645,7 +653,6 @@
covObjEffects <- NULL
}
- covRateEffects <- createEffects("covarBipartiteRate", covarname)
list(objEff=covObjEffects, rateEff=covRateEffects)
}
@@ -1057,7 +1064,7 @@
list(startRate=startRate, tendency=tendency, untrimmed = untrimmed, dif=dif)
}
##@getNetworkStartingVals DataCreate
-getNetworkStartingVals <- function(depvar, structValid=TRUE)
+getNetworkStartingVals <- function(depvar)
{
noPeriods <- attr(depvar, "netdims")[3] - 1
##rate
@@ -1065,15 +1072,8 @@
if (!attr(depvar,'sparse'))
{
nactors <- nrow(depvar)
- if (structValid)
- {
- use <- !is.na(depvar) & (depvar == 10 | depvar == 11)
- depvar[use] <- depvar[use] - 10 ## remove structural values
- }
- else
- {
- depvar[depvar==10 | depvar==11] <- NA ## remove structural values
- }
+ use <- !is.na(depvar) & (depvar == 10 | depvar == 11)
+ depvar[use] <- depvar[use] - 10 ## remove structural values
tmp <- sapply(1:noPeriods, function(x, z){
diag(z[ , , x]) <- NA
diag(z[, , x + 1]) <- NA
@@ -1081,7 +1081,11 @@
matchange <- table(z[, , x + 1], z[, , x])
matcnt <- nactors * nactors -
sum(is.na(z[, , x + 1]) | is.na(z[, , x]))
- c(matcnt=matcnt, matdiff=matdiff, matchange=matchange)
+ tmp <- c(matcnt=matcnt, matdiff=matdiff, matchange=matchange)
+ names(tmp) <- c("matcnt", "matdiff", "matchangeFrom0To0",
+ "matchangeFrom0To1",
+ "matchangeFrom1To0", "matchangeFrom1To1")
+ tmp
}, z=depvar)
}
else
@@ -1094,22 +1098,12 @@
{
mymat1 <- depvar[[i]]
mymat2 <- depvar[[i+1]]
- if (structValid)
- {
- use <- mymat1 at x %in% c(10, 11)
- mymat1 at x[use] <- mymat1 at x[use] - 10
- use <- mymat2 at x %in% c(10, 11)
- mymat2 at x[use] <- mymat2 at x[use] - 10
- mymat1 <- drop0(mymat1)
- mymat2 <- drop0(mymat2)
- }
- else
- {
- mymat1 at x[mymat1 at x==10] <- NA
- mymat1 at x[mymat1 at x==11] <- NA
- mymat2 at x[mymat2 at x==10] <- NA
- mymat2 at x[mymat2 at x==11] <- NA
- }
+ use <- mymat1 at x %in% c(10, 11)
+ mymat1 at x[use] <- mymat1 at x[use] - 10
+ use <- mymat2 at x %in% c(10, 11)
+ mymat2 at x[use] <- mymat2 at x[use] - 10
+ mymat1 <- drop0(mymat1)
+ mymat2 <- drop0(mymat2)
diag(mymat1) <- NA
diag(mymat2) <- NA
mydif <- mymat2 - mymat1
@@ -1117,18 +1111,21 @@
tmp <- table(mydif at x)
tmp00 <- nactors * nactors - length(mydif at x)
tmp <- c(tmp00, tmp[c(3, 1, 2)])
- matchange[,i] <- tmp
+ matchange[, i] <- tmp
matcnt[i] <- sum(tmp)
}
matchange <- data.frame(matchange)
- tmp <-as.matrix(rbind(matcnt=matcnt, matdiff=matdiff,
+ tmp <- as.matrix(rbind(matcnt=matcnt, matdiff=matdiff,
matchange=matchange))
+ row.names(tmp) <- c("matcnt", "matdiff", "matchangeFrom0To0",
+ "matchangeFrom0To1",
+ "matchangeFrom1To0", "matchangeFrom1To1")
}
distance <- attr(depvar, "distance" )
if (attr(depvar,'symmetric'))
- startRate<- nactors * (0.2 + distance)/(tmp['matcnt',] %/% 2 +1)
+ startRate <- nactors * (0.2 + distance)/(tmp['matcnt',] %/% 2 +1)
else
- startRate<- nactors * (0.2 + 2 * distance)/(tmp['matcnt',]+1)
+ startRate <- nactors * (0.2 + 2 * distance)/(tmp['matcnt',] + 1)
startRate <- pmax(0.1, startRate)
startRate <- pmin(100, startRate)
##degree
@@ -1136,41 +1133,48 @@
if (attr(depvar,'symmetric'))
{
matchange <- matchange %/% 2
- ## matcnt <- matcnt %/% 2
}
- p01 <- ifelse (matchange[1,] + matchange[2,] >=1,
- matchange[2,]/(matchange[1,]+matchange[2,]),0.5)
- p10 <- ifelse (matchange[3,] + matchange[4,] >=1,
- matchange[3,]/(matchange[3,]+matchange[4,]),0.5)
- p01 <- pmax(0.02,p01)
- p10 <- pmax(0.02,p10)
- p01 <- pmin(0.98,p01)
- p10 <- pmin(0.98,p10)
- alpha <- 0.5 * log(p01/p10)
- ## if (observations == 2) ##more observations may come later!
- ## alphaf1 <- alpha
- ## else
- ## {
- p00 <- ifelse (matchange[1,] + matchange[2,] >=1,
- matchange[1,]/(matchange[1,]+matchange[2,]),0.0)
- p11 <- ifelse (matchange[3,] + matchange[4,] >=1,
- matchange[4,]/(matchange[3,]+matchange[4,]),0.0)
- p00 <- pmax(0.02,p00)
- p11 <- pmax(0.02,p11)
- p00 <- pmin(0.98,p00)
- p11 <- pmin(0.98,p11)
- prec <- ifelse(matchange[2,] * matchange[3,] >=1,
- 4 /((p00/matchange[2,]) +
- (p11/matchange[3,])),1e-6)
- alphaf1 <- sum(alpha*prec/sum(prec))
- ## }
+ p01 <- ifelse (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ] >=1,
+ matchange["matchangeFrom0To1", ] /
+ (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ]), 0.5)
+ p10 <- ifelse (matchange["matchangeFrom1To0", ]
+ + matchange["matchangeFrom1To1", ] >=1,
+ matchange["matchangeFrom1To0", ] /
+ (matchange["matchangeFrom1To0", ] +
+ matchange["matchangeFrom1To1", ]), 0.5)
+ p01 <- pmax(0.02, p01)
+ p10 <- pmax(0.02, p10)
+ p01 <- pmin(0.98, p01)
+ p10 <- pmin(0.98, p10)
+ alpha <- 0.5 * log(p01 / p10)
+ p00 <- ifelse (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ] >=1,
+ matchange["matchangeFrom0To0", ] /
+ (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ]), 0.0)
+ p11 <- ifelse (matchange["matchangeFrom1To0", ]
+ + matchange["matchangeFrom1To1", ] >=1,
+ matchange["matchangeFrom1To1", ] /
+ (matchange["matchangeFrom1To0", ] +
+ matchange["matchangeFrom1To1", ]), 0.0)
+ p00 <- pmax(0.02, p00)
+ p11 <- pmax(0.02, p11)
+ p00 <- pmin(0.98, p00)
+ p11 <- pmin(0.98, p11)
+ prec <- ifelse(matchange["matchangeFrom0To1", ] *
+ matchange["matchangeFrom1To0", ] >= 1,
+ 4 / ((p00 / matchange["matchangeFrom0To1", ]) +
+ (p11 / matchange["matchangeFrom1To0", ])), 1e-6)
+ alphaf1 <- sum(alpha * prec / sum(prec))
untrimmed <- alphaf1
alphaf1 <- ifelse(alphaf1 < -3, -3, ifelse(alphaf1 > 3, 3, alphaf1))
list(startRate=startRate, degree=alphaf1, alpha=alpha, prec=prec, tmp=tmp,
untrimmed = untrimmed)
}
##@getBipartiteStartingVals DataCreate
-getBipartiteStartingVals <- function(depvar, structValid=TRUE)
+getBipartiteStartingVals <- function(depvar)
{
noPeriods <- attr(depvar, "netdims")[3] - 1
##rate
@@ -1179,21 +1183,18 @@
{
nsenders<- nrow(depvar)
nreceivers <- ncol(depvar)
- if (structValid)
- {
use <- !is.na(depvar) & (depvar == 10 | depvar == 11)
depvar[use] <- depvar[use] - 10 ## remove structural values
- }
- else
- {
- depvar[depvar==10 | depvar==11] <- NA ## 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])
matcnt <- nsenders * nreceivers -
sum(is.na(z[, , x + 1]) | is.na(z[, , x]))
- c(matcnt=matcnt, matdiff=matdiff, matchange=matchange)
+ tmp <- c(matcnt=matcnt, matdiff=matdiff, matchange=matchange)
+ names(tmp) <- c("matcnt", "matdiff", "matchangeFrom0To0",
+ "matchangeFrom0To1",
+ "matchangeFrom1To0", "matchangeFrom1To1")
+ tmp
}, z=depvar)
}
else
@@ -1207,22 +1208,12 @@
{
mymat1 <- depvar[[i]]
mymat2 <- depvar[[i+1]]
- if (structValid)
- {
- use <- mymat1 at x %in% c(10, 11)
- mymat1 at x[use] <- mymat1 at x[use] - 10
- use <- mymat2 at x %in% c(10, 11)
- mymat2 at x[use] <- mymat2 at x[use] - 10
- mymat1 <- drop0(mymat1)
- mymat2 <- drop0(mymat2)
- }
- else
- {
- mymat1 at x[mymat1 at x==10] <- NA
- mymat1 at x[mymat1 at x==11] <- NA
- mymat2 at x[mymat2 at x==10] <- NA
- mymat2 at x[mymat2 at x==11] <- NA
- }
+ use <- mymat1 at x %in% c(10, 11)
+ mymat1 at x[use] <- mymat1 at x[use] - 10
+ use <- mymat2 at x %in% c(10, 11)
+ mymat2 at x[use] <- mymat2 at x[use] - 10
+ mymat1 <- drop0(mymat1)
+ mymat2 <- drop0(mymat2)
mydif <- mymat2 - mymat1
matdiff[i] <- sum(abs(mydif), na.rm=TRUE)
tmp <- table(mydif at x)
@@ -1234,42 +1225,49 @@
matchange <- data.frame(matchange)
tmp <-as.matrix(rbind(matcnt=matcnt, matdiff=matdiff,
matchange=matchange))
+ row.names(tmp) <- c("matcnt", "matdiff", "matchangeFrom0To0",
+ "matchangeFrom0To1",
+ "matchangeFrom1To0", "matchangeFrom1To1")
}
distance <- attr(depvar, "distance" )
- startRate<- nsenders * (0.2 + 2 * distance)/(tmp['matcnt',]+1)
+ startRate <- nsenders * (0.2 + 2 * distance)/(tmp['matcnt',] + 1)
startRate <- pmax(0.1, startRate)
startRate <- pmin(100, startRate)
##degree
matchange<- as.matrix(tmp[grep("matchange", rownames(tmp)),,drop=FALSE])
- if (attr(depvar,'symmetric'))
- {
- matchange <- matchange %/% 2
- ## matcnt <- matcnt %/% 2
- }
- p01 <- ifelse (matchange[1,] + matchange[2,] >=1,
- matchange[2,]/(matchange[1,]+matchange[2,]),0.5)
- p10 <- ifelse (matchange[3,] + matchange[4,] >=1,
- matchange[3,]/(matchange[3,]+matchange[4,]),0.5)
+ p01 <- ifelse (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ] >=1,
+ matchange["matchangeFrom0To1", ] /
+ (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ]), 0.5)
+ p10 <- ifelse (matchange["matchangeFrom1To0", ]
+ + matchange["matchangeFrom1To1", ] >=1,
+ matchange["matchangeFrom1To0", ] /
+ (matchange["matchangeFrom1To0", ] +
+ matchange["matchangeFrom1To1", ]), 0.5)
p01 <- pmax(0.02,p01)
p10 <- pmax(0.02,p10)
p01 <- pmin(0.98,p01)
p10 <- pmin(0.98,p10)
alpha <- 0.5 * log(p01/p10)
- ## if (observations == 2) ##more observations may come later!
- ## alphaf1 <- alpha
- ## else
- ## {
- p00 <- ifelse (matchange[1,] + matchange[2,] >=1,
- matchange[1,]/(matchange[1,]+matchange[2,]),0.0)
- p11 <- ifelse (matchange[3,] + matchange[4,] >=1,
- matchange[4,]/(matchange[3,]+matchange[4,]),0.0)
+ p00 <- ifelse (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ] >=1,
+ matchange["matchangeFrom0To0", ] /
+ (matchange["matchangeFrom0To0", ] +
+ matchange["matchangeFrom0To1", ]), 0.0)
+ p11 <- ifelse (matchange["matchangeFrom1To0", ]
+ + matchange["matchangeFrom1To1", ] >=1,
+ matchange["matchangeFrom1To1", ] /
+ (matchange["matchangeFrom1To0", ] +
+ matchange["matchangeFrom1To1", ]), 0.0)
p00 <- pmax(0.02,p00)
p11 <- pmax(0.02,p11)
p00 <- pmin(0.98,p00)
p11 <- pmin(0.98,p11)
- prec <- ifelse(matchange[2,] * matchange[3,] >=1,
- 4 /((p00/matchange[2,]) +
- (p11/matchange[3,])),1e-6)
+ prec <- ifelse(matchange["matchangeFrom0To1", ] *
+ matchange["matchangeFrom1To0", ] >= 1,
+ 4 / ((p00 / matchange["matchangeFrom0To1", ]) +
+ (p11 / matchange["matchangeFrom1To0", ])), 1e-6)
alphaf1 <- sum(alpha*prec/sum(prec))
## }
untrimmed <- alphaf1
Modified: pkg/RSiena/R/phase3.r
===================================================================
--- pkg/RSiena/R/phase3.r 2009-11-08 17:24:42 UTC (rev 24)
+++ pkg/RSiena/R/phase3.r 2009-11-24 17:56:29 UTC (rev 25)
@@ -328,15 +328,16 @@
Report(c('Averages, standard deviations, ',
'and t-ratios for deviations from targets:\n'),bof,sep='')
##calculate t-ratios
- dmsf<- diag(z$msf)
- sf<- colMeans(z$sf)
- use<- dmsf< 1e-20*z$scale*z$scale
+ dmsf <- diag(z$msf)
+ sf <- colMeans(z$sf)
+ use <- dmsf < 1e-20*z$scale*z$scale
use2 <- abs(sf)<1e-10*z$scale
- dmsf[use]<- 1e-20*z$scale[use]*z$scale[use]
- tstat<- rep(NA,z$pp)
+ dmsf[use] <- 1e-20*z$scale[use]*z$scale[use]
+ tstat <- rep(NA,z$pp)
tstat[!use]<- sf[!use]/sqrt(dmsf[!use])
tstat[use&use2]<- 0
tstat[use&!use2]<- 999
+ z$tstat <- tstat
mymess1<- paste(format(1:z$pp,width=3), '. ',
format(round(sf, 4), width=8, nsmall=4), ' ',
format(round(sqrt(dmsf), 4) ,width=8, nsmall=4), ' ',
Modified: pkg/RSiena/R/print01Report.r
===================================================================
--- pkg/RSiena/R/print01Report.r 2009-11-08 17:24:42 UTC (rev 24)
+++ pkg/RSiena/R/print01Report.r 2009-11-24 17:56:29 UTC (rev 25)
@@ -387,6 +387,16 @@
format(atts$modes, width=4)), outf)
Report("\n", outf)
}
+ depvar2 <- depvar
+ depvar2[is.na(depvar2)] <- 0
+ if (!isTRUE(all.equal(as.vector(depvar2) -
+ round(as.vector(depvar2)),
+ rep(0, length(depvar2)))))
+ {
+ Report(c("Non-integer values noted in this behavior",
+ "variable: they will be truncated.\n")
+ , outf)
+ }
Report('\n', outf)
}
}
@@ -426,7 +436,7 @@
Report(c(format(netname, width=14),
format(round(means, 3), nsmall=3,
width=10), format(round(mean(means),
- 3), width=10), '\n\n'), sep="", outf)
+ 3), width=10), '\n'), sep="", outf)
}
}
}
@@ -794,23 +804,182 @@
periodFromStart <- periodFromStart + data[[i]]$observations
}
Report("\n", outf)
- }
- if (sum(nets) > 0)
+ }
+ periodNos <- attr(data, "periodNos")
+ if (any(atts$anyUpOnly[nets]))
{
- if (any(atts$anyMissing[nets]))
+ netnames <- atts$netnames[nets]
+ upOnly <- atts$anyUpOnly[nets]
+ for (i in seq(along=netnames[upOnly]))
{
- netnames <- atts$netnames[nets]
- missings <- atts$anyMissing[nets]
- for (i in seq(along=netnames[missings]))
+ if (sum(nets) > 1)
{
- Report(c("There are missing data for network variable ",
- netnames[i], ".\n"), sep = "", outf)
+ Report(c("Network ", netnames[i], ":\n"), sep = "", outf)
}
+ if (atts$observations == 1)
+ {
+ Report("All network changes are upward.\n", outf)
+ Report("This will be respected in the simulations.\n", outf)
+ }
+ else
+ {
+ Report(c("All network changes are upward for the following",
+ "periods:\n"), outf)
+ periodsUp <-
+ sapply(data, function(x)
+ {
+ attr(x$depvars[[match(netnames[i],
+ names(x$depvars))]],
+ "uponly")
+ })
+ periods <- periodNos[c(1:length(periodsUp))[periodsUp]]
+ Report(paste(periods, " => ", periods + 1, ";",
+ sep=""), fill=80, outf)
+ Report("This will be respected in the simulations.\n", outf)
+ if (atts$allUpOnly[i])
+ {
+ Report(c("All changes are only up:",
+ "no outdegree parameter.\n"), outf)
+ }
+ }
+ Report("\n", outf)
}
- Report("\n", outf)
}
- if (sum(atts$types == 'oneMode') > 0)
+ if (any(atts$anyDownOnly[nets]))
{
+ netnames <- atts$netnames[nets]
+ downOnly <- atts$anyDownOnly[nets]
+ for (i in seq(along=netnames[downOnly]))
+ {
+ if (sum(nets) > 1)
+ {
+ Report(c("Network ", netnames[i], "\n"), sep = "", outf)
+ }
+ if (atts$observations == 1)
+ {
+ Report("All network changes are downward.\n", outf)
+ Report("This will be respected in the simulations.\n\n", outf)
+ }
+ else
+ {
+ periodsDown <-
+ sapply(data, function(x)
+ {
+ attr(x$depvars[[match(netnames[i],
+ names(x$depvars))]],
+ "downonly")
+ })
+ Report(c("All network changes are downward for the",
+ "following periods:\n"), outf)
+ periods <- periodNos[c(1:length(periodsDown))[periodsDown]]
+ Report(paste(periods, " => ", periods + 1, ";",
+ sep=""), fill=80, outf)
+ Report("This will be respected in the simulations.\n", outf)
+ if (atts$allDownOnly[i])
+ {
+ Report(c("All changes are only down:",
+ "no outdegree parameter.\n"), outf)
+ }
+ }
+ Report("\n", outf)
+ }
+ }
+ if (any(atts$anyUpOnly[!nets]))
+ {
+ netnames <- atts$netnames[!nets]
+ upOnly <- atts$anyUpOnly[!nets]
+ for (i in seq(along=netnames[upOnly]))
+ {
+ Report(c("\nBehavior variable ", netnames[i], ":\n"), sep = "", outf)
+ if (atts$observations == 1)
+ {
+ Report("All behavior changes are upward.\n", outf)
+ Report("This will be respected in the simulations.\n", outf)
+ }
+ else
+ {
+ Report(c("All behavior changes are upward for the following",
+ "periods:\n"), outf)
+ periodsUp <-
+ sapply(data, function(x)
+ {
+ attr(x$depvars[[match(netnames[i],
+ names(x$depvars))]],
+ "uponly")
+ })
+ periods <- periodNos[c(1:length(periodsUp))[periodsUp]]
+ Report(paste(periods, " => ", periods + 1, ";",
+ sep=""), fill=80, outf)
+ Report("This will be respected in the simulations.\n", outf)
+ if (atts$allUpOnly[i])
+ {
+ Report(c("All changes are only up:",
+ "no linear shape parameter.\n\n"), outf)
+ }
+ }
+ Report("\n", outf)
+ }
+ }
+ if (any(atts$anyDownOnly[!nets]))
+ {
+ netnames <- atts$netnames[!nets]
+ downOnly <- atts$anyDownOnly[!nets]
+ for (i in seq(along=netnames[downOnly]))
+ {
+ Report(c("\nBehavior ", netnames[i], ":\n"), sep = "", outf)
+ if (atts$observations == 1)
+ {
+ Report("All behavior changes are downward.\n", outf)
+ Report("This will be respected in the simulations.\n", outf)
+ }
+ else
+ {
+ periodsDown <-
+ sapply(data, function(x)
+ {
+ attr(x$depvars[[match(netnames[i],
+ names(x$depvars))]],
+ "downonly")
+ })
+ Report(c("All behavior changes are downward for the",
+ "following periods:\n"), outf)
+ periods <- periodNos[c(1:length(periodsDown))[periodsDown]]
+ Report(paste(periods, " => ", periods + 1, ";",
+ sep=""), fill=80, outf)
+ Report("This will be respected in the simulations.\n", outf)
+ if (atts$allDownOnly[i])
+ {
+ Report(c("All changes are only down:",
+ "no linear shape parameter.\n"), outf)
+ }
+ }
+ Report("\n", outf)
+ }
+ }
+ if (any(atts$anyMissing[nets]))
+ {
+ netnames <- atts$netnames[nets]
+ missings <- atts$anyMissing[nets]
+ for (i in seq(along=netnames[missings]))
+ {
+ Report(c("There are missing data for network variable ",
+ netnames[i], ".\n"), sep = "", outf)
+ }
+ }
+ if (any(atts$anyMissing[!nets]))
+ {
+ netnames <- atts$netnames[!nets]
+ missings <- atts$anyMissing[!nets]
+ for (i in seq(along=netnames[missings]))
+ {
+ Report(c("There are missing data for behavior variable ",
+ netnames[i], ".\n"), sep = "", outf)
+ }
+ }
+ Report("\n", outf)
+
+ if (sum(atts$types == 'oneMode') > 0)
+ {
balmean <- atts$"balmean"
Report(c("The mean structural dissimilarity value subtracted",
Modified: pkg/RSiena/R/printInitialDescription.r
===================================================================
--- pkg/RSiena/R/printInitialDescription.r 2009-11-08 17:24:42 UTC (rev 24)
+++ pkg/RSiena/R/printInitialDescription.r 2009-11-24 17:56:29 UTC (rev 25)
@@ -138,11 +138,11 @@
depvar <- data[[group]]$depvars[[j]]
if (bipartite)
{
- tmp <- getBipartiteStartingVals(depvar, structValid=TRUE)
+ tmp <- getBipartiteStartingVals(depvar)
}
else
{
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 25
More information about the Rsiena-commits
mailing list