[Rsiena-commits] r109 - in pkg: RSiena RSiena/R RSiena/data RSiena/inst/doc RSiena/man RSiena/src/data RSiena/src/model/effects RSiena/src/model/variables RSienaTest RSienaTest/R RSienaTest/data RSienaTest/doc RSienaTest/inst/doc RSienaTest/man RSienaTest/src/data RSienaTest/src/model/effects RSienaTest/src/model/variables
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jun 25 15:54:37 CEST 2010
Author: ripleyrm
Date: 2010-06-25 15:54:36 +0200 (Fri, 25 Jun 2010)
New Revision: 109
Modified:
pkg/RSiena/DESCRIPTION
pkg/RSiena/R/effects.r
pkg/RSiena/R/print01Report.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/changeLog
pkg/RSiena/data/allEffects.csv
pkg/RSiena/inst/doc/s_man400.pdf
pkg/RSiena/man/RSiena-package.Rd
pkg/RSiena/man/coDyadCovar.Rd
pkg/RSiena/man/varDyadCovar.Rd
pkg/RSiena/src/data/ChangingDyadicCovariate.cpp
pkg/RSiena/src/data/ChangingDyadicCovariate.h
pkg/RSiena/src/model/effects/DyadicCovariateDependentNetworkEffect.cpp
pkg/RSiena/src/model/effects/DyadicCovariateDependentNetworkEffect.h
pkg/RSiena/src/model/effects/DyadicCovariateMainEffect.cpp
pkg/RSiena/src/model/effects/DyadicCovariateReciprocityEffect.cpp
pkg/RSiena/src/model/effects/EffectFactory.cpp
pkg/RSiena/src/model/effects/NetworkEffect.cpp
pkg/RSiena/src/model/variables/NetworkVariable.cpp
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/R/effects.r
pkg/RSienaTest/R/print01Report.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaDataCreateFromSession.r
pkg/RSienaTest/R/sienaModelCreate.r
pkg/RSienaTest/R/sienaprint.r
pkg/RSienaTest/R/sienautils.r
pkg/RSienaTest/R/simstatsc.r
pkg/RSienaTest/changeLog
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/doc/s_man400.tex
pkg/RSienaTest/inst/doc/s_man400.pdf
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/man/coDyadCovar.Rd
pkg/RSienaTest/man/varDyadCovar.Rd
pkg/RSienaTest/src/data/ChangingDyadicCovariate.cpp
pkg/RSienaTest/src/data/ChangingDyadicCovariate.h
pkg/RSienaTest/src/model/effects/DyadicCovariateDependentNetworkEffect.cpp
pkg/RSienaTest/src/model/effects/DyadicCovariateDependentNetworkEffect.h
pkg/RSienaTest/src/model/effects/DyadicCovariateMainEffect.cpp
pkg/RSienaTest/src/model/effects/DyadicCovariateReciprocityEffect.cpp
pkg/RSienaTest/src/model/effects/EffectFactory.cpp
pkg/RSienaTest/src/model/effects/NetworkEffect.cpp
pkg/RSienaTest/src/model/variables/NetworkVariable.cpp
Log:
Missing values and sparse formats for dyadic covariates. Fix for symmetric networks with conditional estimation. Score test results on summary of fit
Modified: pkg/RSiena/DESCRIPTION
===================================================================
--- pkg/RSiena/DESCRIPTION 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/DESCRIPTION 2010-06-25 13:54:36 UTC (rev 109)
@@ -1,8 +1,8 @@
Package: RSiena
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.11.108
-Date: 2010-06-21
+Version: 1.0.11.109
+Date: 2010-06-25
Author: Various
Depends: R (>= 2.9.0), xtable
Imports: Matrix
Modified: pkg/RSiena/R/effects.r
===================================================================
--- pkg/RSiena/R/effects.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/effects.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -446,7 +446,7 @@
if (all(nodeSets == attr(xx$dycCovars[[j]], 'nodeSet')))
{
objEffects <- rbind(objEffects,
- createEffects("dyadObjective",
+ createEffects("dyadBipartiteObjective",
names(xx$dycCovars)[j] ))
}
}
@@ -455,7 +455,7 @@
if (all(nodeSets == attr(xx$dyvCovars[[j]], 'nodeSet')))
{
objEffects <- rbind(objEffects,
- createEffects("dyadObjective",
+ createEffects("dyadBipartiteObjective",
names(xx$dyvCovars)[j]))
}
}
Modified: pkg/RSiena/R/print01Report.r
===================================================================
--- pkg/RSiena/R/print01Report.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/print01Report.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -620,7 +620,14 @@
Report("Number of tie variables with missing data:\n", outf)
for (i in seq(along=covars))
{
- myvar <- x$dycCovars[[i]]
+ if (attr(x$dycCovars[[i]], "sparse"))
+ {
+ myvar <- x$dycCovars[[i]][[1]]
+ }
+ else
+ {
+ myvar <- x$dycCovars[[i]]
+ }
diag(myvar) <- 0
Report(c(format(covars[i], width=15),
sum(is.na(myvar)), " (",
@@ -668,17 +675,26 @@
periodFromStart, width=9),
" overall\n"), sep="", outf)
for (i in seq(along=covars))
- {
+ {
if (use[i])
- {
- thiscovar <- x$dyvCovars[[i]] ## array
- missvals <- colSums(is.na(thiscovar), dims=2)
+ {
+ sparse <- attr(x$dyvCovars[[i]], "sparse")
+ vardims <- attr(x$dyvCovars[[i]], "vardims")
+ thiscovar <- x$dyvCovars[[i]] ## array/list of sparse mats
+ if (!sparse)
+ {
+ missvals <- colSums(is.na(thiscovar), dims=2)
+ }
+ else
+ {
+ missvals <- sapply(thiscovar, function(x)sum(is.na(x)))
+ }
Report(c(format(covars[i], width=10),
format(missvals, width=8),
format(sum(missvals), width=9), " (",
- format(round(100 * sum(missvals)/nrow(thiscovar)/
- ncol(thiscovar), 1), nsmall=1,
- width=3), '%)\n'), outf)
+ format(round(100 * sum(missvals)/vardims[1]/
+ vardims[2]), nsmall=1,
+ width=3), '%)\n'), outf)
}
}
Report("\nMeans of covariates:\n", outf)
Modified: pkg/RSiena/R/sienaDataCreate.r
===================================================================
--- pkg/RSiena/R/sienaDataCreate.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/sienaDataCreate.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -67,48 +67,112 @@
##@addAttributes.coDyadCovar DataCreate
addAttributes.coDyadCovar <- function(x, name, bipartite, ...)
{
+ sparse <- attr(x, "sparse")
if (!bipartite) ## remove diagonal for calculation of mean
{
- diag(x) <- NA
+ if (!sparse)
+ {
+ diag(x) <- NA
+ }
+ else
+ {
+ diag(x[[1]]) <- NA
+ }
}
- varmean <- mean(x, na.rm=TRUE)
+ if (sparse)
+ {
+ nonMissingCount <- sum(!is.na(x[[1]]))
+ varmean <- sum(x[[1]], na.rm=TRUE) / nonMissingCount
+ ## sparse mean is incorrect
+ rr <- range(x[[1]], na.rm=TRUE)
+ }
+ else
+ {
+ varmean <- mean(x, na.rm=TRUE)
+ rr <- range(x, na.rm=TRUE)
+ nonMissingCount <- sum(!is.na(x))
+ }
attr(x,'mean') <- varmean
- rr <- range(x, na.rm=TRUE)
attr(x,'range') <- rr[2] - rr[1]
storage.mode(attr(x, 'range')) <- 'double'
attr(x,'range2') <- rr
attr(x, 'name') <- name
- nonMissingCount <- sum(!is.na(x))
attr(x, "nonMissingCount") <- nonMissingCount
if (!bipartite) #zero the diagonal
{
- diag(x) <- 0
+ if (sparse)
+ {
+ diag(x[[1]]) <- 0
+ }
+ else
+ {
+ diag(x) <- 0
+ }
}
x
}
##@addAttributes.varDyadCovar DataCreate
addAttributes.varDyadCovar <- function(x, name, bipartite, ...)
{
+ sparse <- attr(x, "sparse")
+ vardims <- attr(x, "vardims")
if (!bipartite) ## remove the diagonal before calculating the mean
{
- for (obs in 1:dim(x)[3])
+ for (obs in 1:vardims[3])
{
- diag(x[, , obs]) <- NA
+ if (sparse)
+ {
+ diag(x[[obs]]) <- NA
+ }
+ else
+ {
+ diag(x[, , obs]) <- NA
+ }
}
}
- varmean <- mean(x, na.rm=TRUE)
- attr(x,'mean') <- mean(x, na.rm=TRUE)
- attr(x, "meanp") <- colMeans(x, dims=2, na.rm=TRUE)
- rr <- range(x, na.rm=TRUE)
- attr(x,'range') <- rr[2] - rr[1]
- storage.mode(attr(x, 'range')) <- 'double'
- attr(x, 'name') <- name
- nonMissingCounts <- colSums(!is.na(x), dims=2)
+ if (sparse)
+ {
+ totalValue <- 0
+ totalCount <- 0
+ meanp <- rep(NA, vardims[3])
+ nonMissingCounts <- rep(NA, vardims[3])
+ for (obs in 1:vardims[3])
+ {
+ totalValue <- totalValue + sum(x[[obs]], na.rm=TRUE)
+ nonMissingCounts[obs] <- sum(!is.na(x[[obs]]))
+ totalCount <- totalCount + nonMissingCounts[obs]
+ meanp[obs] <- sum(x[[obs]], na.rm=TRUE) /
+ nonMissingCounts[obs]
+ }
+ varmean <- totalValue / totalCount
+ rr <- range(sapply(x, range, na.rm=TRUE), na.rm=TRUE)
+ attr(x, "meanp") <- meanp
+ }
+ else
+ {
+ varmean <- mean(x, na.rm=TRUE)
+ rr <- range(x, na.rm=TRUE)
+ attr(x, "meanp") <- colMeans(x, dims=2, na.rm=TRUE)
+ nonMissingCounts <- colSums(!is.na(x), dims=2)
+ }
+ attr(x, "mean") <- varmean
+ attr(x, "range") <- rr[2] - rr[1]
+ storage.mode(attr(x, "range")) <- "double"
+ attr(x, "name") <- name
attr(x, "nonMissingCount") <- nonMissingCounts
if (!bipartite) ## put diagonal to zero
{
- for (obs in 1:dim(x)[3])
- diag(x[, , obs]) <- 0
+ for (obs in 1:vardims[3])
+ {
+ if (!sparse)
+ {
+ diag(x[, , obs]) <- 0
+ }
+ else
+ {
+ diag(x[[obs]]) <- 0
+ }
+ }
}
x
}
@@ -315,9 +379,17 @@
{
nattr <- attr(dycCovars[[i]], 'nodeSet')
bipartite <- nattr[1] != nattr[2]
- if (!validNodeSet(nattr[1], nrow(dycCovars[[i]])))
+ if (attr(dycCovars[[i]], "sparse"))
+ {
+ thisdycCovar <- dycCovars[[i]][[1]]
+ }
+ else
+ {
+ thisdycCovar <- dycCovars[[i]]
+ }
+ if (!validNodeSet(nattr[1], nrow(thisdycCovar)))
stop('dyadic covariate incorrect nbr rows', names(dycCovars)[i])
- if (!validNodeSet(nattr[2], ncol(dycCovars[[i]])))
+ if (!validNodeSet(nattr[2], ncol(thisdycCovar)))
stop('dyadic covariate incorrect nbr columns',
names(dycCovars)[i])
dycCovars[[i]] <- addAttributes(dycCovars[[i]], names(dycCovars)[i],
@@ -327,22 +399,37 @@
{
if (observations < 3)
{
- stop("Changing covariates are not possibLe with only two waves")
+ stop("Changing covariates are not possible with only two waves")
}
nattr <- attr(dyvCovars[[i]],'nodeSet')
+ sparse <- attr(dyvCovars[[i]], "sparse")
bipartite <- nattr[1] != nattr[2]
- if (!validNodeSet(nattr[1], dim(dyvCovars[[i]])[1]))
+ vardims <- attr(dyvCovars[[i]], "vardims")
+ if (!validNodeSet(nattr[1], vardims[1]))
+ {
stop('dyadic changing covariate incorrect nbr rows',
names(dyvCovars)[i])
- if (!validNodeSet(nattr[2], dim(dyvCovars[[i]])[2]))
+ }
+ if (!validNodeSet(nattr[2], vardims[2]))
+ {
stop('dyadic changing covariate incorrect nbr columns',
names(dyvCovars)[i])
- if (dim(dyvCovars[[i]])[3] < (observations - 1))
+ }
+ if (vardims[3] < (observations - 1))
+ {
stop('Dyadic changing covariate not enough observations')
- if (dim(dyvCovars[[i]])[3] != (observations - 1))
+ }
+ if (vardims[3] != (observations - 1))
{
tmpatt <- attributes(dyvCovars[[i]])
- dyvCovars[[i]] <- dyvCovars[[i]][, 1:(observations - 1)]
+ if (sparse)
+ {
+ dyvCovars[[i]] <- dyvCovars[[i]][1:(observations - 1)]
+ }
+ else
+ {
+ dyvCovars[[i]] <- dyvCovars[[i]][, 1:(observations - 1)]
+ }
attnames <- names(tmpatt)
for (att in seq(along=attnames))
{
@@ -351,7 +438,7 @@
attr(dyvCovars[[i]], attnames[att]) <- tmpatt[[att]]
}
}
- }
+ }
dyvCovars[[i]] <- addAttributes(dyvCovars[[i]], names(dyvCovars)[i],
bipartite)
}
@@ -1122,11 +1209,27 @@
{
stop("inconsistent covariate names")
}
- vartotal <- vartotal + sum(group[[i]]$dyvCovars[[j]], na.rm=TRUE)
- nonMissingCount <- nonMissingCount +
- sum(!is.na(group[[i]]$dyvCovars[[j]]))
- thisrange[, i] <- range(group[[i]]$dyvCovars[[j]],
- na.rm=TRUE)
+ sparse <- attr(group[[i]]$dyvCovars[[j]], "sparse")
+ vardims <- attr(group[[i]]$dyvCovars[[j]], "vardims")
+ if (attr(group[[i]]$dyvCovars[[j]], "sparse"))
+ {
+ for (obs in 1:vardims[3])
+ {
+ vartotal <- vartotal + sum(group[[i]]$dyvCovars[[j]][[obs]], na.rm=TRUE)
+ nonMissingCount <- nonMissingCount +
+ sum(!is.na(group[[i]]$dyvCovars[[j]][[obs]]))
+ }
+ thisrange[, i] <- range(sapply(group[[i]]$dyvCovars[[j]], range, na.rm=TRUE),
+ na.rm=TRUE)
+ }
+ else
+ {
+ vartotal <- vartotal + sum(group[[i]]$dyvCovars[[j]], na.rm=TRUE)
+ nonMissingCount <- nonMissingCount +
+ sum(!is.na(group[[i]]$dyvCovars[[j]]))
+ thisrange[, i] <- range(group[[i]]$dyvCovars[[j]],
+ na.rm=TRUE)
+ }
}
dyvCovarMean[covar] <- vartotal / nonMissingCount
rr <- range(thisrange, na.rm=TRUE)
Modified: pkg/RSiena/R/sienaDataCreateFromSession.r
===================================================================
--- pkg/RSiena/R/sienaDataCreateFromSession.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/sienaDataCreateFromSession.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -167,17 +167,19 @@
network.size(namefiles[[1]])))
stop("Dimensions must be the same for one object")
}
- else ## siena nets
+ }
+ if (namesession$Format[1] == "Siena net")
+ {
+ nodeSetsSize <-
+ as.matrix(sapply(namesession$NbrOfActors,
+ function(x)
+ as.numeric(strsplit(x, " ")[[1]])))
+ if (any(nodeSetsSize != nodeSetsSize[, 1]))
{
- nodeSetsSize <- as.matrix(sapply(namesession$NbrOfActors,
- function(x)
- as.numeric(strsplit(x, " ")[[1]])))
- if (any(nodeSetsSize != nodeSetsSize[, 1]))
- {
- stop("Dimensions must be the same for one object")
+ stop("Dimensions must be the same for one object")
- }
}
+ nodeSetsSize <- nodeSetsSize[, 1]
}
nodeSets <- unlist(strsplit(namesession$ActorSet[1], ' '))
if (length(nodeSets) > 2)
@@ -197,7 +199,9 @@
else if (namesession$Format[1] == "pajek net")
ActorSetsSize[k] <<- network.size(namefiles[[1]])
else
- ActorSetsSize[k] <<- as.numeric(strsplit(namesession$NbrOfActors[1], " ")[[1]][i])
+ ActorSetsSize[k] <<-
+ as.numeric(strsplit(namesession$NbrOfActors[1],
+ " ")[[1]][i])
}
else if (namesession$Format[1] == "matrix")
{
@@ -209,7 +213,7 @@
}
else if (namesession$Format[1] == "Siena net")
{
- if (nodeSetsSize[i] != ActorSetsSize[mymatch])
+ if (nodeSetsSize[i] != ActorSetsSize[mymatch])
{
stop(paste("Conflicting sizes for actor set",
nodeSets[i]))
@@ -400,9 +404,9 @@
observations))
for (x in 1:observations)
{
- if (miss[x] != '')
- namefiles[[x]][namefiles[[x]] %in%
- miss[x]] <- NA
+ miss <- miss1[[x]]
+ namefiles[[x]][namefiles[[x]] %in%
+ miss] <- NA
namefiles[[x]][!(is.na(namefiles[[x]]))
& !(namefiles[[x]] %in%
c(nonzero[[x]], 10, 11))] <- 0
@@ -455,7 +459,7 @@
c(nonzero[[x]], 10, 11)), 3] <- 0
myedgelist[myedgelist[,3] %in%
nonzero[[x]], 3] <- 1
- if (any(as.numeric(strsplit(namesession$NbrOfActors[1], " ")[[1]]) != nActors))
+ if (any(as.numeric(strsplit(namesession$NbrOfActors[x], " ")[[1]]) != nActors))
stop("number of actors inconsistent")
mylist[[x]] <- myedgelist
}
@@ -468,7 +472,7 @@
} )
tmp <- sienaNet(mylist, nodeSet=nodesets)
- }
+ }
else
{
stop("Two-mode pajek nets not supported")
@@ -519,43 +523,120 @@
.GlobalEnv)
},
'constant dyadic covariate' = {
- ## miss <- gsub(" ", "|",
- ## namesession$MissingValues[1],
- ## fixed=TRUE)
- ## namefiles[[1]][grep(miss, namefiles[[1]])] <- NA
miss <- namesession$MissingValues
- miss <- strsplit(miss, " ")[[1]]
- namefiles[[1]][namefiles[[1]] %in% miss] <- NA
+ miss <- strsplit(miss, " ")[[1]]
if (namesession[1, "ActorSet"] == "Actors")
{
namesession[1, "ActorSet"]<- "Actors Actors"
}
- nodesets <- strsplit(namesession[1, "ActorSet"], ' ')
- assign(objnames[j],
- coDyadCovar (namefiles[[1]],
- nodeSets=nodesets[[1]]),
- .GlobalEnv)
+ nodesets <- strsplit(namesession[1,
+ "ActorSet"], " ")[[1]]
+ if (namesession$Format[1] == "matrix")
+ {
+ namefiles[[1]][namefiles[[1]] %in% miss] <- NA
+ tmp <- coDyadCovar(namefiles[[1]],
+ nodeSets=nodesets)
+ }
+ else
+ {
+ myedgelist <- namefiles[[1]]
+ myedgelist[myedgelist[, 3] %in% miss, 3] <- NA
+ if (ncol(myedgelist) == 4 &&
+ any(myedgelist[, 4] != myedgelist[1, 4]))
+ {
+ stop("Only one wave possible for constant",
+ "dyadic covariates")
+ }
+ nActors <-
+ as.numeric(strsplit(namesession$
+ NbrOfActors[1],
+ " ")[[1]])
+ myval <- spMatrix(nrow = nActors[1],
+ ncol=nActors[2],
+ i=myedgelist[, 1],
+ j=myedgelist[, 2],
+ x=myedgelist[, 3])
+ tmp <- coDyadCovar(myval, nodeSet=nodesets)
+ }
+ assign(objnames[j], tmp, .GlobalEnv)
},
'changing dyadic covariate' = {
if (namesession[1, "ActorSet"] == "Actors")
{
namesession[1, "ActorSet"]<- "Actors Actors"
}
- nodesets <- strsplit(namesession[1, "ActorSet"], ' ')
- myarray <- array(NA, dim=c(dim(namefiles[[1]]),
- observations - 1))
+ nodesets <- strsplit(namesession[1,
+ "ActorSet"], " ")[[1]]
miss <- namesession$MissingValues
miss <- strsplit(miss, " ")
- for (x in 1:nrow(namesession))
+ if (namesession$Format[1] == "matrix")
{
- if (miss[[x]] != '')
+ myarray <- array(NA, dim=c(dim(namefiles[[1]]),
+ observations - 1))
+ for (x in 1:nrow(namesession))
{
- namefiles[[x]][namefiles[[x]] %in% miss[x]] <- NA
+ namefiles[[x]][namefiles[[x]] %in%
+ miss[[x]]] <- NA
+ myarray[ , ,
+ as.numeric(namesession$Period[x])] <-
+ namefiles[[x]]
}
- myarray[ , ,as.numeric(namesession$Period[x])] <-
- namefiles[[x]]
+ tmp <- varDyadCovar(myarray, nodeSets=nodesets)
}
- tmp <- varDyadCovar(myarray, nodeSets=nodesets[[1]])
+ else
+ {
+ if (nrow(namesession) > 1)
+ {
+ if (observations - 1 != nrow(namesession))
+ {
+ stop("observations and periods don't match",
+ "for dyadic covariate")
+ }
+ mylist <- vector("list", observations - 1)
+ nActors <-
+ as.numeric(strsplit(namesession$
+ NbrOfActors[1],
+ " ")[[1]])
+ for (x in 1:nrow(namesession))
+ {
+ myedgelist <- namefiles[[x]][ ,1:3]
+ myedgelist[myedgelist[, 3] %in% miss[[x]],
+ 3] <- NA
+ if (any(as.numeric(strsplit(namesession$
+ NbrOfActors[x],
+ " ")[[1]])
+ != nActors))
+ stop("number of actors inconsistent")
+ mylist[[x]] <- myedgelist
+ }
+ }
+ else
+ {
+ myedgelist <- namefiles[[1]]
+ myedgelist[myedgelist[, 3] %in% miss[[1]],
+ 3] <- NA
+ mylist <- split.data.frame(myedgelist[, 1:3],
+ myedgelist[, 4])
+ if (!is.na(observations) && (observations - 1) !=
+ length(mylist))
+ stop("Differing numbers of observations ",
+ observations, " ", length(mylist))
+ nActors <-
+ as.numeric(strsplit(namesession$
+ NbrOfActors[1],
+ " ")[[1]])
+ }
+ mylist <- lapply(mylist, function(y)
+ {
+ spMatrix(nrow = nActors[1],
+ ncol=nActors[2],
+ i=y[, 1],
+ j=y[, 2],
+ x=y[, 3])
+ }
+ )
+ tmp <- varDyadCovar(mylist, nodeSets=nodesets)
+ }
assign(objnames[j], tmp, .GlobalEnv)
},
'exogenous event' = {
Modified: pkg/RSiena/R/sienaModelCreate.r
===================================================================
--- pkg/RSiena/R/sienaModelCreate.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/sienaModelCreate.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -58,8 +58,16 @@
}
}
model$cconditional <- cond
- model$condvarno <- condvarno
- model$condname <- condname
+ if (!is.na(cond) && cond && condvarno == 0 && condname == "")
+ {
+ model$condvarno <- 1
+ model$condname <- ""
+ }
+ else
+ {
+ model$condvarno <- condvarno
+ model$condname <- condname
+ }
model$FinDiff.method <- findiff
model$nsub <- nsub
model$diag <- diag
Modified: pkg/RSiena/R/sienaprint.r
===================================================================
--- pkg/RSiena/R/sienaprint.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/sienaprint.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -148,6 +148,79 @@
if (!inherits(x, "summary.sienaFit"))
stop("not a legitimate summary of a Siena model fit")
print.sienaFit(x)
+ if (sum(x$test) > 0) ## we have some score tests
+ {
+ testn <- sum(x$test)
+ if (x$maxlike)
+ {
+ cat("Score test <c>\n\n")
+ }
+ else
+ {
+ cat("Generalised score test <c>\n\n")
+ }
+ cat("Testing the goodness-of-fit of the model restricted by\n")
+ j <- 0
+ for (k in 1:x$pp)
+ if (x$test[k])
+ {
+ j <- j+1
+ cat(c(" (",j,") ",
+ format(paste(x$requestedEffects$type[k], ": ",
+ x$requestedEffects$effectName[k],
+ sep=""),
+ width=50), " = ",
+ sprintf("%8.4f", x$theta[k]),"\n"),
+ sep = "")
+ }
+ cat("_________________________________________________\n")
+ cat(" ")
+ cat(" \n")
+ if (testn > 1)
+ cat('Joint test:\n-----------\n')
+ cat(c(' c = ',sprintf("%8.4f", x$testresOverall),
+ ' d.f. = ',j,' p-value '), sep='')
+ pvalue <- 1 - pchisq(x$testresOverall, j)
+ if (pvalue < 0.0001)
+ cat('< 0.0001\n')
+ else
+ cat(c('= ', sprintf("%8.4f\n", pvalue)), sep = '')
+ if (testn==1)
+ cat(c('\n one-sided (normal variate): ',
+ sprintf("%8.4f",x$testresulto[1])), sep = '')
+ if (testn> 1)
+ {
+ cat('\n\n')
+ for (k in 1:j)
+ {
+ cat(c('(',k,') tested separately:\n'),sep='')
+ cat('-----------------------\n')
+ cat(' - two-sided:\n')
+ cat(c(' c = ', sprintf("%8.4f", x$testresult[k]),
+ ' d.f. = 1 p-value '), sep = '')
+ pvalue<- 1-pchisq(x$testresult[k],1)
+ if (pvalue < 0.0001)
+ cat('< 0.0001\n')
+ else
+ cat(c('= ', sprintf("%8.4f", pvalue), '\n'), sep = '')
+ cat(c(' - one-sided (normal variate): ',
+ sprintf("%8.4f", x$testresulto[k])), sep = '')
+ if (k<j)
+ cat('\n\n')
+ }
+ }
+ cat(' \n_________________________________________________\n\n')
+ cat('One-step estimates: \n\n')
+ for (i in 1 : x$pp)
+ {
+ onestepest<- x$oneStep[i]+x$theta[i]
+ cat(c(format(paste(x$requestedEffects$type[i],': ',
+ x$requestedEffects$effectName[i], sep = ''),
+ width=50),
+ sprintf("%8.4f", onestepest), '\n'), sep = "")
+ }
+ cat('\n')
+ }
if (x$OK)
{
cat("Covariance matrix of estimates (correlations below diagonal)\n\n")
Modified: pkg/RSiena/R/sienautils.r
===================================================================
--- pkg/RSiena/R/sienautils.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/sienautils.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -115,42 +115,86 @@
}
##@coDyadCovar Create
-coDyadCovar<- function(val, nodeSets=c('Actors','Actors'))
+coDyadCovar<- function(val, nodeSets=c('Actors','Actors'), sparse=is(val,"dgTMatrix"))
{
- ##matrix, numeric or factor, dims= those of net - must validate later
- if (!is.matrix(val))
- stop('val must be a matrix')
- if (!(is.numeric(val) || is.factor(val)))
- stop('val must be numeric or a factor')
+ ##matrix, numeric or factor, dims= those of net - must validate later or sparse matrix
+ if (!sparse)
+ {
+ if (!is.matrix(val))
+ {
+ stop('val must be a matrix')
+ }
+ if (!(is.numeric(val) || is.factor(val)))
+ {
+ stop('val must be numeric or a factor')
+ }
+ }
+ else
+ {
+ if (!is(val, "dgTMatrix"))
+ {
+ stop('not a sparse triples matrices')
+ }
+ val <- list(val)
+ }
+ vardims <- dim(val)
if (length(nodeSets) > 2)
+ {
stop('nodeSets may only have one or two elements')
- if (!is.character(nodeSets))
+ }
+ if (!is.character(nodeSets))
+ {
stop('nodeSets must be a vector of character strings')
- out<- val
+ }
+ out <- val
class(out) <- 'coDyadCovar'
attr(out, 'nodeSet') <- nodeSets
- attr(out, 'sparse') <- FALSE ### for now!
+ attr(out, 'sparse') <- sparse
+ attr(out, "vardims") <- vardims
out
}
##@varDyadCovar Create
-varDyadCovar<- function(val, nodeSets=c('Actors','Actors'))
+varDyadCovar<- function(val, nodeSets=c('Actors','Actors'), sparse=is.list(val))
{
##array, numeric or factor, dims= those of net by observations-1 -
- ##must validate later
- if (!is.array(val) || !(length(dim(val)) == 3))
- stop('val must be a 3d array')
- if (!(is.numeric(val) || is.factor(val)))
- stop('val must be numeric or a factor')
+ ##must validate later or list of sparse matrices
+ if (!sparse)
+ {
+ if (!is.array(val) || !(length(dim(val)) == 3))
+ stop('val must be a 3d array')
+ if (!(is.numeric(val) || is.factor(val)))
+ stop('val must be numeric or a factor')
+ vardims <- dim(val)
+ }
+ else
+ {
+ if (!is.list(val))
+ stop('values must be an array or a list of sparse matrices')
+ if (!all(sapply(val, function(x) is(x,'dgTMatrix'))))
+ stop('not a list of sparse triples matrices')
+ vardims <- sapply(val, dim) ## dimensions of matrices in columns
+ if (any(vardims != vardims[, 1]))
+ stop('all matrices must have the same dimension')
+ vardims <- vardims[, 1]
+ vardims[3] <- length(val)
+
+ }
if (length(nodeSets) > 2)
stop('nodeSets may only have one or two elements')
if (!is.character(nodeSets))
stop('nodeSets must be a vector of character strings')
if (length(nodeSets) == 1)
nodeSets <- c(nodeSets, nodeSets)
+ observations <- vardims[3]
+ if (observations < 2)
+ {
+ stop('value must have at least two observations')
+ }
out <- val
class(out) <- 'varDyadCovar'
attr(out, 'nodeSet') <- nodeSets
- attr(out, 'sparse') <- FALSE ### for now!
+ attr(out, 'sparse') <- sparse
+ attr(out, 'vardims') <- vardims
out
}
##@sienaNet Create
Modified: pkg/RSiena/R/simstatsc.r
===================================================================
--- pkg/RSiena/R/simstatsc.r 2010-06-21 22:12:12 UTC (rev 108)
+++ pkg/RSiena/R/simstatsc.r 2010-06-25 13:54:36 UTC (rev 109)
@@ -1086,10 +1086,14 @@
nodeSets <- attr(dycCovar, "nodeSet")
if (sparse)
{
- ## have a sparse matrix in triplet format
+ ## have a list containing 1 sparse matrix in triplet format
## with missings embedded
## with 0 based indices!
- varmat <- cbind(dycCovar at i+1, dycCovar at j+1, dycCovar at x)
+ varmat <- cbind(dycCovar[[1]]@i+1, dycCovar[[1]]@j+1, dycCovar[[1]]@x)
+ if (any(duplicated(varmat[, 1:2])))
+ {
+ stop("duplicate entries in sparse matrix dyadic covariate")
+ }
##drop the diagonal, if present - not for bipartite
if (nodeSets[1] == nodeSets[2])
{
@@ -1099,13 +1103,13 @@
mat1[is.na(varmat[, 3]), 3] <- attr(dycCovar, "mean")
mat1 <- mat1[!mat1[, 3] == 0, ]
## add attribute of dim
- attr(mat1,'nActors1') <- nrow(dycCovar)
- attr(mat1,'nActors2') <- ncol(dycCovar)
- mat2 <- varmat[is.na(varmat[, 3]), ]
+ attr(mat1, 'nActors1') <- nrow(dycCovar[[1]])
+ attr(mat1, 'nActors2') <- ncol(dycCovar[[1]])
+ mat2 <- varmat[is.na(varmat[, 3]), , drop=FALSE]
mat2[, 3] <- 1
## add attribute of dim
- attr(mat2,'nActors1') <- nrow(dycCovar)
- attr(mat2,'nActors2') <- ncol(dycCovar)
+ attr(mat2,'nActors1') <- nrow(dycCovar[[1]])
+ attr(mat2,'nActors2') <- ncol(dycCovar[[1]])
edgeLists <- list(t(mat1), t(mat2))
}
else
@@ -1140,10 +1144,10 @@
{
## have a list of sparse matrices in triplet format
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 109
More information about the Rsiena-commits
mailing list