[Rsiena-commits] r56 - in pkg/RSiena: . R inst/doc man src src/data src/model src/model/effects src/model/effects/generic src/model/variables src/utils
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 11 17:52:14 CET 2010
Author: ripleyrm
Date: 2010-02-11 17:52:13 +0100 (Thu, 11 Feb 2010)
New Revision: 56
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/NAMESPACE
pkg/RSiena/R/phase3.r
pkg/RSiena/R/print01Report.r
pkg/RSiena/R/print07Report.r
pkg/RSiena/R/sienaDataCreate.r
pkg/RSiena/R/sienaprint.r
pkg/RSiena/R/sienautils.r
pkg/RSiena/R/simstatsc.r
pkg/RSiena/changeLog
pkg/RSiena/inst/doc/s_man400.pdf
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/src/data/Data.cpp
pkg/RSiena/src/data/Data.h
pkg/RSiena/src/model/EpochSimulation.cpp
pkg/RSiena/src/model/EpochSimulation.h
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/effects/generic/BetweennessFunction.cpp
pkg/RSiena/src/model/effects/generic/BetweennessFunction.h
pkg/RSiena/src/model/effects/generic/ConstantFunction.cpp
pkg/RSiena/src/model/effects/generic/ConstantFunction.h
pkg/RSiena/src/model/effects/generic/DifferenceFunction.cpp
pkg/RSiena/src/model/effects/generic/DifferenceFunction.h
pkg/RSiena/src/model/effects/generic/EgoInDegreeFunction.cpp
pkg/RSiena/src/model/effects/generic/EgoInDegreeFunction.h
pkg/RSiena/src/model/effects/generic/GenericNetworkEffect.cpp
pkg/RSiena/src/model/effects/generic/GenericNetworkEffect.h
pkg/RSiena/src/model/effects/generic/InTieFunction.cpp
pkg/RSiena/src/model/effects/generic/InTieFunction.h
pkg/RSiena/src/model/effects/generic/IntSqrtFunction.cpp
pkg/RSiena/src/model/effects/generic/IntSqrtFunction.h
pkg/RSiena/src/model/effects/generic/OutDegreeFunction.cpp
pkg/RSiena/src/model/effects/generic/OutDegreeFunction.h
pkg/RSiena/src/model/effects/generic/ProductFunction.cpp
pkg/RSiena/src/model/effects/generic/ProductFunction.h
pkg/RSiena/src/model/effects/generic/ReciprocatedTwoPathFunction.cpp
pkg/RSiena/src/model/effects/generic/ReciprocatedTwoPathFunction.h
pkg/RSiena/src/model/effects/generic/TwoPathFunction.cpp
pkg/RSiena/src/model/effects/generic/TwoPathFunction.h
pkg/RSiena/src/model/variables/BehaviorVariable.cpp
pkg/RSiena/src/model/variables/BehaviorVariable.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/siena07.cpp
pkg/RSiena/src/utils/NamedObject.h
Log:
New version number 1.0.10. Multiple network effects, constraints between networks.
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2010-02-11 15:14:57 UTC (rev 55)
+++ pkg/RSiena/DESCRIPTION 2010-02-11 16:52:13 UTC (rev 56)
@@ -1,10 +1,10 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.9
-Date: 2010-01-18
+Version: 1.0.10
+Date: 2010-02-11
Author: Various
-Depends: R (>= 2.7.0), xtable
+Depends: R (>= 2.9.0), xtable
Imports: Matrix
Suggests: tcltk, rlecuyer, snow, network, codetools
SystemRequirements: GNU make, tcl/tk 8.5, Tktable
Modified: pkg/RSiena/NAMESPACE
===================================================================
--- pkg/RSiena/NAMESPACE 2010-02-11 15:14:57 UTC (rev 55)
+++ pkg/RSiena/NAMESPACE 2010-02-11 16:52:13 UTC (rev 56)
@@ -4,7 +4,7 @@
sienaCompositionChangeFromFile, sienaDataCreate, sienaDataCreateFromSession,
sienaGroupCreate, sienaModelCreate, sienaNet, sienaNodeSet, simstats0c,
varCovar, varDyadCovar, setEffect, includeEffects, includeInteraction,
- effectsDocumentation,
+ effectsDocumentation, sienaDataConstraint,
installGui)#, sienaTimeTest)
import(Matrix)
Modified: pkg/RSiena/R/phase3.r
===================================================================
--- pkg/RSiena/R/phase3.r 2010-02-11 15:14:57 UTC (rev 55)
+++ pkg/RSiena/R/phase3.r 2010-02-11 16:52:13 UTC (rev 56)
@@ -286,149 +286,151 @@
}
##@phase3.2 siena07 Processing at end of phase 3
-phase3.2<- function(z,x,...)
+phase3.2 <- function(z, x, ...)
{
- z$timePhase3<-(proc.time()['elapsed']-z$ctime)/z$Phase3nits
+ z$timePhase3 <- (proc.time()['elapsed'] - z$ctime) / z$Phase3nits
if (x$checktime)
- Report(c('Time per iteration in phase 3 = ',format(z$timePhase3,nsmall=4,
- digits=4),'\n'),lf)
- z<-CalculateDerivative3(z,x)
- #browser()
- z<- PotentialNR(z,x,FALSE)
+ 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)
if (any(z$newfixed))
{
- Report('There was a problem in obtaining convergence)\n',outf)
+ Report('There was a problem in obtaining convergence)\n', outf)
Report(c('Therefore, the program decided tentatively to fix parameter(s)',
- cat(c(1:z$pp)[z$newfixed]),'.\n'),outf)
+ cat(c(1:z$pp)[z$newfixed]), '.\n'), outf)
Report(c('It may be better to start all over again, ',
'with better initial values or a reduced model.\n',
- '(Check that you entered the data properly!)\n'),outf)
+ '(Check that you entered the data properly!)\n'), outf)
}
- Heading(2,outf,c('End of stochastic approximation algorithm, phase ',
- z$Phase,'.'))
- Report(c('Total of', z$n,'iterations.\n'),outf)
- Report(c('Parameter estimates based on', z$n-z$Phase3nits,
+ Heading(2, outf, c('End of stochastic approximation algorithm, phase ',
+ z$Phase, '.'))
+ Report(c('Total of', z$n,'iterations.\n'), outf)
+ Report(c('Parameter estimates based on', z$n - z$Phase3nits,
'iterations,\n'), outf)
if (z$cconditional)
- Report(c('basic rate parameter',c('','s')[as.integer(z$observations>2)+1],
- ' as well as \n'),outf)
+ Report(c('basic rate parameter',
+ c('', 's')[as.integer(z$observations > 2) + 1],
+ ' as well as \n'), outf)
Report(c('convergence diagnostics, covariance and derivative matrices based on ',
- z$Phase3nits,' iterations.\n\n'),sep='',outf)
- Report('Information for convergence diagnosis.\n',outf)
+ z$Phase3nits, ' iterations.\n\n'), sep='', outf)
+ Report('Information for convergence diagnosis.\n', outf)
Report(c('Averages, standard deviations, ',
- 'and t-ratios for deviations from targets:\n'),sep='',outf)
+ 'and t-ratios for deviations from targets:\n'), sep='', outf)
# Report(c(date(),'\n'),bof)
if (z$cconditional)
- Report('\nconditional moment estimation.',bof)
+ Report('\nconditional moment estimation.', bof)
else if (x$maxlike)
- Report('\nMaximum Likelihood estimation.',bof)
+ Report('\nMaximum Likelihood estimation.', bof)
else
- Report('\nunconditional moment estimation.',bof)
- Report('\nInformation for convergence diagnosis.\n',bof)
+ Report('\nunconditional moment estimation.', bof)
+ Report('\nInformation for convergence diagnosis.\n', bof)
Report(c('Averages, standard deviations, ',
- 'and t-ratios for deviations from targets:\n'),bof,sep='')
+ '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
- use2 <- abs(sf)<1e-10*z$scale
- 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
+ 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)
+ 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), '. ',
+ 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), ' ',
format(round(tstat, 4), width=8, nsmall=3), sep='')
- mymess2<- c('',' (fixed parameter)')[as.numeric(z$fixed)+1]
- mymess<- paste(mymess1,mymess2)
- PrtOutMat(as.matrix(mymess),outf)
- PrtOutMat(as.matrix(mymess1),bof)
- ## Report(mymess1,bof,fill=80)
- 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)
- z$error<- TRUE
- Report('Good convergence is indicated by the t-ratios ',outf)
- if (any(z$fixed)) Report('of non-fixed parameters ',outf)
- Report('being close to zero.\n',outf)
- if (z$Phase3nits<100)
- Report(c('(Since the diagnostic checks now are based only on ',z$Phase3nits,
- ' iterations','\nThey are not reliable.)'),sep='',outf)
+ mymess2 <- c('', ' (fixed parameter)')[as.numeric(z$fixed) + 1]
+ mymess <- paste(mymess1, mymess2)
+ PrtOutMat(as.matrix(mymess), outf)
+ PrtOutMat(as.matrix(mymess1), bof)
+ ## Report(mymess1, bof, fill=80)
+ 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)
+ z$error <- TRUE
+ Report('Good convergence is indicated by the t-ratios ', outf)
+ if (any(z$fixed)) Report('of non-fixed parameters ', outf)
+ Report('being close to zero.\n', outf)
+ if (z$Phase3nits < 100)
+ Report(c('(Since the diagnostic checks now are based only on ',
+ z$Phase3nits,
+ ' iterations', '\nThey are not reliable.)'), sep='', outf)
if (error) ## also test subphase here but not relevant to phase 3, I think
{
- Report('One or more of the t-statistics are rather large.\n',outf)
- if (tmax>0.5)
- Report('Convergence of the algorithm is doubtful.\n',outf)
+ Report('One or more of the t-statistics are rather large.\n', outf)
+ if (tmax > 0.5)
+ Report('Convergence of the algorithm is doubtful.\n', outf)
## removed repfortotal loop possibility here as not functioning now
- if (z$Phase3nits<= 50)
+ if (z$Phase3nits <= 50)
Report(c('However, the standard deviations are based on',
'few simulations.\n'), outf)
}
if (x$maxlike)
{
- Report('Autocorrelations during phase 3 : \n',outf)
- Report(paste(format(1:z$pp,width=3),'. ',format(z$sfl,width=8,digits=4),
- '\n'),outf)
- Report ('\n',outf)
+ Report('Autocorrelations during phase 3 : \n', outf)
+ Report(paste(format(1:z$pp,width=3), '. ',
+ format(z$sfl, width=8, digits=4),
+ '\n'), outf)
+ Report ('\n', outf)
}
for (j in 1:z$pp)
if (z$diver[j]) ### don't understand this condition, as AllFixed is true
{
- Report(c('Warning. Extremely large standard error of parameter',j,'.\n'),
- outf)
+ Report(c('Warning. Extremely large standard error of parameter',j,
+ '.\n'), outf)
if (sf[j] < 0.5 * sqrt(dmsf[j]))
- Report('Presumably this parameter must be fixed.\n',outf)
+ Report('Presumably this parameter must be fixed.\n', outf)
else
- Report('Maybe the algorithm diverged.\n',outf)
+ Report('Maybe the algorithm diverged.\n', outf)
}
if (x$maxlike)
{
- Report('Estimated complete data information matrix: \n',cf)
- PrtOutMat(z$dfra,cf)
+ 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
+ '(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"))
+ 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
+ Report('Noninvertible estimated covariance matrix : \n', outf)
+ cov <- NULL
}
}
else
- cov<- z$dinv %*% z$msfc %*% t(z$dinv)
- error<- FALSE
- if (inherits(try(msfinv<- solve(z$msfc)),"try-error"))
+ 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)
+ 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)
+ '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
+ 'are invalid.\n'), outf)
+ z$msfinv <- NULL
}
else
- z$msfinv<- msfinv
+ z$msfinv <- msfinv
if (!is.null(cov))
{
- z$diver<- (z$fixed | z$diver | diag(cov) <1e-9) & (!z$AllUserFixed)
+ z$diver <- (z$fixed | z$diver | diag(cov) <1e-9) & (!z$AllUserFixed)
cov[z$diver,] <- Root(diag(cov))* 33
##not sure this does not use very small vals
cov[,z$diver] <- Root(diag(cov))* 33
diag(cov)[z$diver]<- 999
}
- z$covtheta<- cov
+ z$covtheta <- cov
# ans<-InstabilityAnalysis(z)
z
}
@@ -437,10 +439,10 @@
CalculateDerivative3<- function(z,x)
{
f <- FRANstore()
- z$mnfra<- colMeans(z$sf)
- if (z$FinDiff.method||x$maxlike)
+ z$mnfra <- colMeans(z$sf)
+ if (z$FinDiff.method || x$maxlike)
{
- dfra<- t(apply(z$sdf,c(2,3),mean))
+ dfra <- t(apply(z$sdf, c(2,3), mean))
}
else
{
@@ -451,67 +453,68 @@
dfra[sub,] <- 0
dfra[,sub] <- 0
dfra[sub, sub] <- 1
- Report(c("Warning: diagonal element(s)", sub, " of derivative matrix < 0\n"), cf)
+ Report(c("Warning: diagonal element(s)", sub,
+ " of derivative matrix < 0\n"), cf)
}
}
- z$diver<- rep(FALSE,z$pp)
- if (z$AllUserFixed&any(abs(diag(dfra))<1e-6))
- z$diver[abs(diag(dfra))<1e-6]<- TRUE
- z$msf<- cov(z$sf)
- if (z$Phase3nits>2)
+ z$diver <- rep(FALSE, z$pp)
+ if (z$AllUserFixed & any(abs(diag(dfra)) < 1e-6))
+ z$diver[abs(diag(dfra)) < 1e-6] <- TRUE
+ z$msf <- cov(z$sf)
+ if (z$Phase3nits > 2)
{
- z$sfl<- apply(z$sf,2,function(x)acf(x,plot=FALSE,lag=1)[[1]][[2]])
+ z$sfl <- apply(z$sf, 2, function(x)acf(x, plot=FALSE, lag=1)[[1]][[2]])
}
- z$dfra1<- z$dfra
- z$dfra<- dfra
+ z$dfra1 <- z$dfra
+ z$dfra <- dfra
z
}
##@PotentialNR siena07 Calculates change if NR step done now
-PotentialNR<-function(z,x,MakeStep=FALSE)
+PotentialNR <-function(z,x,MakeStep=FALSE)
{
- z$dfrac<- z$dfra
- z$msfc<- z$msf
+ z$dfrac <- z$dfra
+ z$msfc <- z$msf
if (!z$AllUserFixed)
{
- z$dfrac[z$fixed,]<- 0
- z$dfrac[,z$fixed]<- 0
+ z$dfrac[z$fixed, ] <- 0
+ z$dfrac[, z$fixed] <- 0
diag(z$dfrac)[z$fixed]<- 1
- z$msfc[z$fixed,]<- 0
- z$msfc[,z$fixed]<- 0
- diag(z$msfc)[z$fixed]<- 1
+ z$msfc[z$fixed, ] <- 0
+ z$msfc[, z$fixed] <- 0
+ diag(z$msfc)[z$fixed] <- 1
}
- if (inherits(try(dinv<- solve(z$dfrac)),"try-error"))
+ if (inherits(try(dinv <- solve(z$dfrac)), "try-error"))
{
- Report('Error message from inversion of dfra: \n',cf)
- diag(z$dfrac)<- diag(z$dfrac)+0.1*z$scale
- Report('Intervention 3.4: ridge added after phase 3.\n',cf)
- if (inherits(try(dinv<- solve(z$dfrac)),"try-error"))
+ Report('Error message from inversion of dfra: \n', cf)
+ diag(z$dfrac) <- diag(z$dfrac)+0.1*z$scale
+ Report('Intervention 3.4: ridge added after phase 3.\n', cf)
+ if (inherits(try(dinv <- solve(z$dfrac)), "try-error"))
{
Report(c('Warning. After phase 3, derivative matrix non-invertible',
- 'even with a ridge.\n'),cf)
- fchange<- 0
+ 'even with a ridge.\n'), cf)
+ fchange <- 0
z$dinv <- NULL
}
else
{
- fchange<- dinv%*%colMeans(z$sf)
- z$dinv<- dinv
+ fchange <- dinv %*% colMeans(z$sf)
+ z$dinv <- dinv
}
}
else
{
- fchange<- dinv%*%colMeans(z$sf)
- z$dinv<- dinv
+ fchange <- dinv%*%colMeans(z$sf)
+ z$dinv <- dinv
}
- Report('dfrac :\n',cf)
- PrtOutMat(z$dfrac,cf)
- Report('inverse of dfra :\n',cf)
- PrtOutMat(z$dinv,cf)
+ Report('dfrac :\n', cf)
+ PrtOutMat(z$dfrac, cf)
+ Report('inverse of dfra :\n', cf)
+ PrtOutMat(z$dinv, cf)
Report(c('A full Quasi-Newton-Raphson step after phase 3\n',
'would add the following numbers to the parameters, yielding ',
- 'the following results:\n'),sep='',cf)
- Report(' change new value \n',cf)
+ 'the following results:\n'), sep='', cf)
+ Report(' change new value \n', cf)
Report(c(paste(' ', format(1:z$pp, width=2), '. ',
format(round(-fchange, digits=6), width=12, nsmall=6),
format(round(z$theta-fchange, 6), width=12, nsmall=6),
Modified: pkg/RSiena/R/print01Report.r
===================================================================
--- pkg/RSiena/R/print01Report.r 2010-02-11 15:14:57 UTC (rev 55)
+++ pkg/RSiena/R/print01Report.r 2010-02-11 16:52:13 UTC (rev 56)
@@ -509,16 +509,32 @@
Heading(2, outf, "Reading exogenous changing actor covariates.")
if (!is.null(session))
{
+ if (nData > 1)
+ {
+ covarssession <-
+ session[session$Type == "constant covariate", ]
+ for (i in 1:nrow(covarssession))
+ {
+ names <- strsplit(covarssession$Name[i],
+ " ", fixed=TRUE)[[1]]
+ ncases <- length(x$vCovars[[match(names[1], covars)]])
+ Report(c("Covariate data file",
+ covarssession$Filename[i],
+ "with", length(names), "variables,", ncases,
+ "cases, named:\n"), outf)
+ Report(paste(names, "\n"), outf, sep="")
+ }
+ }
covarssession <- session[session$Type == "changing covariate", ]
- for (i in 1:nrow(covarssession))
+ for (i in seq(along=covarssession[,1]))
{
ncases <- nrow(x$vCovars[[match(covarssession$Name[i],
- covars)]])
+ covars)]])
Report(c("Exogenous changing covariate ",
covarssession$name[i], " read from file ",
covarssession$Filename[i], ".\n"), sep="", outf)
Report(c("Number of cases is ", ncases, ".\n"), sep="",
- outf)
+ outf)
}
}
else
@@ -826,12 +842,12 @@
Report(c("All network changes are upward for the following",
"periods:\n"), outf)
periodsUp <-
- sapply(data, function(x)
+ unlist(lapply(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)
@@ -863,12 +879,12 @@
else
{
periodsDown <-
- sapply(data, function(x)
+ unlist(lapply(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]]
@@ -980,27 +996,69 @@
if (sum(atts$types == 'oneMode') > 0)
{
- balmean <- atts$"balmean"
-
- Report(c("The mean structural dissimilarity value subtracted",
- "in the\n"), outf)
- Report("balance calculations is ", outf)
+ netnames <- atts$netnames[nets]
+ if (nData > 1)
+ {
+ balmean <-
+ lapply(data, function(x)
+ sapply(x$depvars, function(y) attr(y, "balmean")))
+ }
+ else
+ {
+ balmean <- atts$"balmean"
+ }
+ if (nData > 1 || sum(atts$types == "oneMode") > 1)
+ {
+ Report(c("The mean structural dissimilarity values subtracted",
+ "in the\n"), outf)
+ Report("balance calculations are\n", outf)
+ }
+ else
+ {
+ Report(c("The mean structural dissimilarity value subtracted",
+ "in the\n"), outf)
+ Report("balance calculations is ", outf)
+ }
for (i in seq(along=atts$types))
{
if (atts$types[i] == "oneMode")
{
- if (sum(atts$types == "oneMode") > 1)
+ if (nData > 1)
{
- Report(c("Network name:", netnames[i],
- format(round(balmean[i], 4), nsmall=4, width=14),
- '.\n'),
- sep="", outf)
+ thisbalmean <- sapply(balmean, function(x)x[[netnames[i]]])
+ ## if (sum(atts$types == "oneMode") > 1)
+ if (sum(atts$types != "behavior") > 1)
+ {
+ Report(c("for network ", netnames[i],":"), sep="",
+ outf)
+ }
+ Report("\n", outf)
+ mystr <- format(paste("Subproject ", 1:nData, " <",
+ atts$names, "> ", sep=""))
+ for (j in seq(along=thisbalmean))
+ {
+ Report(c(mystr[j], ": ",
+ format(round(thisbalmean[j], 4), nsmall=4,
+ width=14), "\n"), sep="", outf)
+ }
}
else
{
- Report(c(format(round(balmean[i], 4), nsmall=4, width=14),
- '.\n'),
- sep="", outf)
+ ## if (sum(atts$types == "oneMode") > 1)
+ if (sum(atts$types != "behavior") > 1)
+ {
+ Report(c("for network ", format(netnames[i], width=12),
+ format(round(balmean[i], 4),
+ nsmall=4, width=14),
+ '.\n'),
+ sep="", outf)
+ }
+ else
+ {
+ Report(c(format(round(balmean[i], 4), nsmall=4, width=14),
+ '.\n'),
+ sep="", outf)
+ }
}
}
}
@@ -1009,10 +1067,25 @@
(nData ==1 && length(atts$cCovars) > 0) ||
length(atts$vCovars) > 0)
{
+ netnames <- atts$netnames
+ if (nData > 1)
+ {
+ vCovarSim <-
+ lapply(data, function(x)
+ sapply(x$vCovars, function(y) attr(y, "simMean")))
+ behSim <-
+ lapply(data, function(x)
+ sapply(x$depvars, function(y) attr(y, "simMean")))
+ }
+ else
+ {
+ vCovarSim <- atts$"vCovarSim"
+ behSim <- atts$"bSim"
+ }
Report(c("\nFor the similarity variable calculated from each actor",
"covariate,\nthe mean is subtracted.\nThese means are:\n"),
outf)
- if (nData == 1)
+ if (nData == 1) ## ie we may have constant covariates
{
for (i in seq(along=atts$cCovars))
{
@@ -1029,20 +1102,57 @@
{
if (atts$types[i] == "behavior" && atts$bPoszvar[i])
{
- Report(c("Similarity", format(atts$netnames[i], width=12),
- ':', format(round(atts$bSim[i], 4), nsmall=4,
- width=12),
- '\n'), outf)
+ if (nData > 1)
+ {
+ thisSim <- sapply(behSim, function(x)x[[netnames[i]]])
+ Report(c("Similarity ", format(atts$netnames[i], width=12),
+ ":\n"), sep="", outf)
+ mystr <- format(paste(" Subproject ", 1:nData, " <",
+ atts$names, "> ", sep=""))
+ for (j in seq(along=thisSim))
+ {
+ Report(c(mystr[j], format(round(thisSim[j], 4),
+ nsmall=4, width=12), "\n"),
+ sep="", outf)
+ }
+ Report("\n", outf)
+ }
+ else
+ {
+ Report(c("Similarity", format(atts$netnames[i], width=12),
+ ':', format(round(atts$bSim[i], 4), nsmall=4,
+ width=12),
+ '\n'), outf)
+ }
}
}
for (i in seq(along=atts$vCovars))
{
+ covarnames <- atts$vCovars
if (atts$vCovarPoszvar[i])
{
- Report(c("Similarity", format(atts$vCovars[i], width=12),
- ':', format(round(atts$vCovarSim[i], 4), width=12,
- nsmall=4),
- '\n'), outf)
+ if (nData > 1)
+ {
+ thisSim <- sapply(vCovarSim, function(x)x[[covarnames[i]]])
+ Report(c("Similarity ", format(covarnames[i], width=12),
+ ":\n"), sep="", outf)
+ mystr <- format(paste(" Subproject ", 1:nData, " <",
+ atts$names, "> ", sep=""))
+ for (j in seq(along=thisSim))
+ {
+ Report(c(mystr[j], format(round(thisSim[j], 4),
+ nsmall=4, width=12), "\n"),
+ sep="", outf)
+ }
+ Report("\n", outf)
+ }
+ else
+ {
+ Report(c("Similarity", format(atts$vCovars[i], width=12),
+ ':', format(round(atts$vCovarSim[i], 4), width=12,
+ nsmall=4),
+ '\n'), outf)
+ }
}
}
}
Modified: pkg/RSiena/R/print07Report.r
===================================================================
--- pkg/RSiena/R/print07Report.r 2010-02-11 15:14:57 UTC (rev 55)
+++ pkg/RSiena/R/print07Report.r 2010-02-11 16:52:13 UTC (rev 56)
@@ -102,17 +102,16 @@
behNames)],
'> ', behEffects$effectName,
sep='')
- z$requestedEffects$effectName[z$requestedEffects$netType=='behavior'] <-
- behEffects$effectName
+ z$requestedEffects$effectName[z$requestedEffects$netType==
+ 'behavior'] <-
+ behEffects$effectName
}
}
typesp <- ifelse (z$requestedEffects$type== "endow", ": ", ": ")
+ tmp <- paste(z$requestedEffects$type, typesp,
+ z$requestedEffects$effectName, sep = '')
tmp <- paste(sprintf("%2d", 1:length(z$requestedEffects$effectName)),
- '. ', format(paste(z$requestedEffects$type,
- typesp,
- z$requestedEffects$effectName,
- sep = ''),
- width=50),
+ '. ', format(substr(tmp, 1, 50), width=50),
theta, ses, '\n', sep='', collapse = '')
if (nBehavs > 0 && nOneModes > 0)
{
Modified: pkg/RSiena/R/sienaDataCreate.r
===================================================================
--- pkg/RSiena/R/sienaDataCreate.r 2010-02-11 15:14:57 UTC (rev 55)
+++ pkg/RSiena/R/sienaDataCreate.r 2010-02-11 16:52:13 UTC (rev 56)
@@ -516,6 +516,7 @@
## attr(depvars[[i]], 'simCnt') <- rr$simCnt
attr(depvars[[i]], 'simMean') <- rr$simMean
attr(depvars[[i]], 'structural') <- FALSE
+ attr(depvars[[i]], 'balmean') <- NA
}
else
{
@@ -571,6 +572,7 @@
if (type == 'oneMode')
{
attr(depvars[[i]], 'balmean') <- calcBalmean(depvars[[i]])
+ attr(depvars[[i]], 'simMean') <- NA
attr(depvars[[i]], 'symmetric') <- TRUE
attr(depvars[[i]], 'missing') <- FALSE
attr(depvars[[i]], 'structural') <- FALSE
@@ -637,6 +639,8 @@
else #type=='bipartite' not sure what we need here,
#### but include diagonal
{
+ attr(depvars[[i]], 'balmean') <- NA
+ attr(depvars[[i]], 'simMean') <- NA
attr(depvars[[i]], 'symmetric') <- FALSE
attr(depvars[[i]], 'missing') <- FALSE
attr(depvars[[i]], 'structural') <- FALSE
@@ -693,18 +697,124 @@
attr(depvars[[i]], 'name') <- names(depvars)[i]
}
## create the object
- z<- NULL
+ z <- NULL
z$nodeSets <- nodeSets
- z$observations <-observations
+ z$observations <- observations
z$depvars <- depvars
z$cCovars <- cCovars
z$vCovars <- vCovars
z$dycCovars <- dycCovars
z$dyvCovars <- dyvCovars
z$compositionChange <- compositionChange
+ # types <- sapply(z$depvars, function(x)attr(x, "type"))
+ # if (sum(types != "behavior" ) > 1)
+ # {
+ z <- checkConstraints(z)
+ # }
class(z) <- 'siena'
z
}
+##@checkConstraints DataCreate
+checkConstraints <- function(z)
+{
+ types <- sapply(z$depvars, function(x)attr(x, "type"))
+ sparse <- sapply(z$depvars, function(x)attr(x, "sparse"))
+ nodeSets <- sapply(z$depvars, function(x)attr(x, "nodeSet"))
+ nNets <- length(z$depvars)
+ pairsOfNets <- as.matrix(expand.grid(names(z$depvars), names(z$depvars)))
+ ## maybe remove some as don't want pairs with self, but may want all there
+ ##pairsOfNets <- pairsOfNets[pairsOfNets[, 1] != pairsOfNets[, 2], ]
+ pairsNames <- paste(pairsOfNets[, 1], pairsOfNets[,2], sep=",")
+
+ higher <- namedVector(FALSE, pairsNames )
+ atLeastOne <- namedVector(FALSE, pairsNames )
+ disjoint <- namedVector(FALSE, pairsNames )
+
+ ## identify any nets which may relate
+ relates <- data.frame(name=names(z$depvars), type=types,
+ nodeSets=sapply(nodeSets, paste, collapse=","),
+ tn=paste(types, sapply(nodeSets, paste,
+ collapse=",")) , stringsAsFactors=FALSE)
+ use <- relates$tn %in% relates$tn[duplicated(relates$tn)]
+ nets <- namedVector(NA, names(z$depvars), listType=TRUE)
+ for (net in names(z$depvars)[use])
+ {
+ if (types[[net]] != "behavior")
+ {
+ nets[[net]] <- z$depvars[[net]]
+ ## nets[[net]] <- replaceMissingsAndStructurals(z$depvars[[net]])
+ }
+ }
+
+ ## relSplits <- split(relates, relates$tn)
+ ## relSplits <- relSplits[sapply(relSplits, nrow) > 1]
+
+ for (i in 1:nrow(pairsOfNets))
+ {
+ if (pairsOfNets[i, 1] != pairsOfNets[i, 2])
+ {
+ net1 <- pairsOfNets[i, 1]
+ net2 <- pairsOfNets[i, 2]
+
+ type1 <- types[net1]
+ type2 <- types[net2]
+ nodes1 <- relates[net1, "nodeSets"]
+ nodes2 <- relates[net2, "nodeSets"]
+
+ if (type1 == type2 && type1 != "behavior" & nodes1 == nodes2)
+ {
+ higher[i] <- TRUE
+ disjoint[i] <- TRUE
+ atLeastOne[i] <- TRUE
+ depvar1 <- nets[[pairsOfNets[i, 1]]]
+ depvar2 <- nets[[pairsOfNets[i, 2]]]
+ for (obs in 1:z$observations)
+ {
+ if (sparse[net1])
+ {
+ var1 <- depvar1[[obs]]
+ }
+ else
+ {
+ var1 <- depvar1[,, obs]
+ }
+ if (sparse[net2])
+ {
+ var2 <- depvar2[[obs]]
+ }
+ else
+ {
+ var2 <- depvar2[,, obs]
+ }
+ var1[var1 %in% c(10, 11)] <- var1[var1 %in% c(10, 11)] - 10
+ var2[var2 %in% c(10, 11)] <- var2[var2 %in% c(10, 11)] - 10
+ ## higher
+ if (any(var1 - var2 < 0, na.rm=TRUE))
+ {
+ higher[i] <- FALSE
+ }
+ ## disjoint
+ if (sum(var1 * var2, na.rm=TRUE) > 0)
+ {
+ disjoint[i] <- FALSE
+ }
+ ##atleastone
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 56
More information about the Rsiena-commits
mailing list