[Rsiena-commits] r60 - in pkg/RSienaTest: R src src/data
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Feb 16 21:11:51 CET 2010
Author: ripleyrm
Date: 2010-02-16 21:11:51 +0100 (Tue, 16 Feb 2010)
New Revision: 60
Modified:
pkg/RSienaTest/R/maxlike.r
pkg/RSienaTest/R/phase2.r
pkg/RSienaTest/R/print01Report.r
pkg/RSienaTest/R/printInitialDescription.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/simstatsc.r
pkg/RSienaTest/src/data/NetworkLongitudinalData.cpp
pkg/RSienaTest/src/data/NetworkLongitudinalData.h
pkg/RSienaTest/src/siena07.cpp
Log:
Processing of average indegrees and outdegrees from R. Added constraints to report. Fixes for maxlike
Modified: pkg/RSienaTest/R/maxlike.r
===================================================================
--- pkg/RSienaTest/R/maxlike.r 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/R/maxlike.r 2010-02-16 20:11:51 UTC (rev 60)
@@ -5,120 +5,121 @@
{
mlInit<- function(z,x,data,effects)
{
- f<- NULL
- if (!inherits(data,'siena'))
+ f <- NULL
+ if (!inherits(data, 'siena'))
stop('not valid siena data object')
if (is.null(effects))
effects <- getEffects(data)
if (!is.data.frame(effects))
stop('effects is not a data.frame')
- effects<- effects[effects$include,]
- z$theta<- effects$initialValue
- z$fixed<- effects$fix
- z$test<- effects$test
+ effects <- effects[effects$include,]
+ z$theta <- effects$initialValue
+ z$fixed <- effects$fix
+ z$test <- effects$test
z$pp <- length(z$test)
z$posj <- rep(FALSE,z$pp)
z$targets <- rep(0, z$pp)
- # effectsNames<- getEffectNames(effects)
- z$posj[grep('basic',effects$effectName)]<- TRUE
- z$posj[grep('constant',effects$effectName)]<- TRUE
+ ## effectsNames<- getEffectNames(effects)
+ z$posj[grep('basic', effects$effectName)] <- TRUE
+ z$posj[grep('constant', effects$effectName)] <- TRUE
z$BasicRateFunction <- z$posj
- observations<- data$observations
- mats<- vector('list',observations)
- f$mynets<- vector('list',observations)
- types <- sapply(data$depvars,function(x)attr(x,'type'))
- netsubs<- which(types=='oneMode')
+ observations <- data$observations
+ mats <- vector('list', observations)
+ f$mynets <- vector('list', observations)
+ types <- sapply(data$depvars, function(x)attr(x,'type'))
+ netsubs <- which(types=='oneMode')
netsub <- min(netsubs) ### only one for now
actsubs <- which(types=='behavior')
for (i in 1:observations)
{
- mats[[i]] <- data$depvars[[netsub]][,,i]
- f$mynets[[i]]<- mats[[i]]
+ mats[[i]] <- data$depvars[[netsub]][, , i]
+ f$mynets[[i]] <- mats[[i]]
if (i==1)
- f$mynets[[i]][is.na(mats[[i]])]<-0
+ f$mynets[[i]][is.na(mats[[i]])] <-0
else ##carry missing forward!
- f$mynets[[i]][is.na(mats[[i]])]<-
- f$mynets[[i-1]][is.na(mats[[i]])]
+ f$mynets[[i]][is.na(mats[[i]])] <-
+ f$mynets[[i - 1]][is.na(mats[[i]])]
f$mynets[[i]][mats[[i]]==10] <- 0
f$mynets[[i]][mats[[i]]==11] <- 1
}
- f$mystructs<- vector('list',observations)
+ f$mystructs <- vector('list',observations)
for (i in 1:observations)
{
- f$mystructs[[i]]<- mats[[i]]
- f$mystructs[[i]][,]<- 0
- f$mystructs[[i]][mats[[i]]==11]<- 1
- f$mystructs[[i]][mats[[i]]==10]<- 1
+ f$mystructs[[i]] <- mats[[i]]
+ f$mystructs[[i]][, ] <- 0
+ f$mystructs[[i]][mats[[i]]==11] <- 1
+ f$mystructs[[i]][mats[[i]]==10] <- 1
}
- f$mats<- mats
+ f$mats <- mats
for (i in 1:observations)
{
- f$mats[[i]][mats[[i]]==11]<- 1
- f$mats[[i]][mats[[i]]==10]<- 0
+ f$mats[[i]][mats[[i]]==11] <- 1
+ f$mats[[i]][mats[[i]]==10] <- 0
}
if (length(actsubs)>0)
{
- acts<- matrix(data$depvars[[actsubs[1]]],ncol=observations)
- f$acts<- acts
- f$myacts<- acts
- f$myacts[is.na(acts)]<- 0
- f$meanact<- round(mean(acts,na.rm=TRUE))
+ acts <- matrix(data$depvars[[actsubs[1]]],
+ ncol=observations)
+ f$acts <- acts
+ f$myacts <- acts
+ f$myacts[is.na(acts)] <- 0
+ f$meanact <- round(mean(acts,na.rm=TRUE))
}
- f$observations<- observations
+ f$observations <- observations
## browser()
if (any(z$targets!=0))
{
Report(c('Targets should be zero for maximum likelihood:',
'they have been zeroed\n'))
- z$targets<- rep(0,z$pp)
+ z$targets <- rep(0, z$pp)
}
- mat1<- data$depvars[[netsub]][,,1]
- mat2<- data$depvars[[netsub]][,,2]
+ mat1 <- data$depvars[[netsub]][, , 1]
+ mat2 <- data$depvars[[netsub]][, , 2]
# f$mat1<- mat1
# f$mat2<- mat2
- startmat<- mat1
- startmat[is.na(startmat)]<- 0
- endmat<- mat2
- endmat[is.na(endmat)]<- startmat[is.na(endmat)]
- diffmat<- startmat!=endmat
+ startmat <- mat1
+ startmat[is.na(startmat)] <- 0
+ endmat <- mat2
+ endmat[is.na(endmat)] <- startmat[is.na(endmat)]
+ diffmat <- startmat != endmat
if (is.null(x$multfactor))
f$niter <- multfactor * sum(diffmat)
- else
- f$niter<- x$multfactor * sum(diffmat)
+ else
+ f$niter <- x$multfactor * sum(diffmat)
### create initial chain
- chain <- matrix(0,nrow=sum(diffmat),ncol=4)
- chain[,1]<- row(diffmat)[diffmat]
- chain[,2]<- col(diffmat)[diffmat]
- chain<- chain[sample(1:nrow(chain)),]
+ chain <- matrix(0, nrow=sum(diffmat), ncol=4)
+ chain[,1] <- row(diffmat)[diffmat]
+ chain[,2] <- col(diffmat)[diffmat]
+ chain <- chain[sample(1:nrow(chain)),]
chain[, 4] <- 1:nrow(chain)
##chain<- chain ##(here you can put a known chain in (eg from
##delphi!)
- cat(nrow(chain),'\n')
+ cat(nrow(chain), '\n')
### initialise
- pinsdel<- pinsdel/(1-pperm)
- pdiaginsdel<- pdiaginsdel/(1-pperm)
- iter<- 0
+ pinsdel <- pinsdel/(1 - pperm)
+ pdiaginsdel <- pdiaginsdel/(1 - pperm)
+ iter <- 0
##burnin
###construct a max like object to be passed to FRAN
- f$startmat<- startmat
- f$endmat<- endmat
- f$chain<- chain
+ f$startmat <- startmat
+ f$endmat <- endmat
+ f$chain <- chain
f$accepts <- rep(0,4)
- f$rejects<- rep(0,4)
- f$probs<- c(pinsdel,0,pdiaginsdel)#
- f$madechain<- FALSE
- f$numm<- 20
+ f$rejects <- rep(0,4)
+ f$probs <- c(pinsdel, 0, pdiaginsdel)#
+ f$madechain <- FALSE
+ f$numm <- 20
for (i in 1:nstart)
{
- iter<- iter+1
- # cat(iter,'\n')
- f<- mhstep(z$theta,f, promul, prelins)
+ iter <- iter+1
+ ## cat(iter,'\n')
+ f <- mhstep(z$theta, f, promul, prelins)
}
- f$madechain<- TRUE
+ f$madechain <- TRUE
pinsdel <- pinsdel * (1-pperm)
pdiaginsdel <- pdiaginsdel * ( 1-pperm)
- f$probs <- c(pinsdel,pperm,pdiaginsdel)
+ f$probs <- c(pinsdel, pperm, pdiaginsdel)
f$mats <- f$mystructs <- f$mynets <- NULL
FRANstore(f)
z
@@ -131,7 +132,7 @@
## f<- z$f
if (INIT)
{
- z <- mlInit(z,x,data,effects)
+ z <- mlInit(z, x, data, effects)
## f <<-f
return(z)
}
@@ -150,8 +151,8 @@
# int <- x$int
if (z$Phase==2)
{
- f$accepts <- rep(0,4)
- f$rejects <- rep(0,4)
+ f$accepts <- rep(0, 4)
+ f$rejects <- rep(0, 4)
varmat <- FALSE
## browser()
if (z$nit == 1)## beginning of a subphase
@@ -187,7 +188,7 @@
ans <- calcgrad(theta, Z, f$startmat, varmat)
# browser()
f$Z <- Z
- f$chaim <- f$Z[[noSamples]]
+ f$chain <- f$Z[[noSamples]]
}
else
{
@@ -210,7 +211,7 @@
# cat(scores,'\n')
##browser()
list(fra=matrix(scores, nrow=1), sc=NULL, dff=dff, OK=TRUE,
- rejectprop=f$rejects/(f$accepts+f$rejects))
+ rejectprop=f$rejects / (f$accepts + f$rejects))
}
}
mhIntStep <- function(theta, f, promul, prelins, int)
Modified: pkg/RSienaTest/R/phase2.r
===================================================================
--- pkg/RSienaTest/R/phase2.r 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/R/phase2.r 2010-02-16 20:11:51 UTC (rev 60)
@@ -27,7 +27,7 @@
{
#initialise phase2
z$phase2fras <- array(0, dim=c(4, z$pp, 1000))
- z$rejectprops <- matrix(0, nrow=4, ncol=1000)
+ z$rejectprops <- array(0, dim=c(4, 4, 1000))
int <- 1
f <- FRANstore()
z$Phase <- 2
@@ -272,7 +272,7 @@
z$phase2fras[subphase, ,z$nit] <- fra
if (x$maxlike)
{
- z$rejectprops[subphase, z$nit] <- zz$rejectprop
+ z$rejectprops[subphase, , z$nit] <- zz$rejectprop
}
if (z$nit %% 2 == 1)
{
@@ -321,7 +321,7 @@
z$theta <- zsmall$theta
z$thav <- z$thav + zsmall$theta
z$thavn <- z$thavn + 1
- if (x$maxlike && x$moreUpdates > 0)
+ if (x$maxlike && !is.null(x$moreUpdates) && x$moreUpdates > 0)
{
z <- doMoreUpdates(z, x, x$moreUpdates * subphase)
zsmall$theta <- z$theta
Modified: pkg/RSienaTest/R/print01Report.r
===================================================================
--- pkg/RSienaTest/R/print01Report.r 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/R/print01Report.r 2010-02-16 20:11:51 UTC (rev 60)
@@ -261,9 +261,9 @@
}
else if (sum(nnonactive) > 1)
{
- Report(c("Actors ", which(nnonactive),
- " are inactive at this ",
- "observation.\n"), sep='', outf)
+ Report(c("Actors", which(nnonactive),
+ "are inactive at this",
+ "observation.\n"), fill=80, outf)
}
}
}
@@ -1156,6 +1156,48 @@
}
}
}
+ ## report on constraints
+ if (any(atts$anyHigher) || any(atts$anyDisjoint) || any(atts$anyAtLeastOne))
+ {
+ Report("\n", outf)
+ highers <- atts[["anyHigher"]]
+ disjoints <- atts[["anyDisjoint"]]
+ atleastones <- atts[["anyAtLeastOne"]]
+ if (any(highers))
+ {
+ higherSplit <- strsplit(names(highers)[highers], ",")
+ lapply(higherSplit, function(x)
+ {
+ Report(c("Network ", x[1], " is higher than network ", x[2],
+ ".\n"), sep="", outf)
+ Report("This will be respected in the simulations.\n\n",
+ outf)
+ })
+ }
+ if (any(disjoints))
+ {
+ disjointSplit <- strsplit(names(disjoints)[disjoints],',')
+ lapply(disjointSplit, function(x)
+ {
+ Report(c("Network ", x[1], " is disjoint from network ",
+ x[2], ".\n"), sep="", outf)
+ Report("This will be respected in the simulations.\n\n",
+ outf)
+ })
+ }
+ if (any(atleastones))
+ {
+ atLeastOneSplit <- strsplit(names(atleastones)[atleastones],',')
+ lapply(atLeastOneSplit, function(x)
+ {
+ Report(c("A link in at least one of networks ",
+ x[1], " and", x[2],
+ " always exists.\n"), sep="", outf)
+ Report("This will be respected in the simulations.\n\n",
+ outf)
+ })
+ }
+ }
printInitialDescription(data, myeff, modelname)
##close the files
Report(close=TRUE)
Modified: pkg/RSienaTest/R/printInitialDescription.r
===================================================================
--- pkg/RSienaTest/R/printInitialDescription.r 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/R/printInitialDescription.r 2010-02-16 20:11:51 UTC (rev 60)
@@ -60,40 +60,21 @@
depvar <- data[[group]]$depvars[[j]]
atts <- attributes(depvar)
subs <- 1:data[[group]]$observations + periodFromStart
- ones <- sapply(atts$vals, function(x){
- if (is.na(x["11"]))
- {
- x["1"]
- }
- else
- {
- x["1"] + x["11"]
- }
- })
- density[subs] <- ones / atts$nval
- if (any(ones >= atts$nval))
+ density[subs] <- atts$density
+ if (any(atts$ones >= atts$nval))
{
difficult <- TRUE
}
- if (bipartite)
- {
- degree[subs] <- atts$netdims[2] * ones / atts$nval
- missings[subs] <- 1 - atts$nval/ atts$netdims[1] /
- atts$netdims[2]
- }
- else
- {
- degree[subs] <- (atts$netdims[1] - 1) * ones / atts$nval
- missings[subs] <- 1 - atts$nval/ atts$netdims[1] /
- (atts$netdims[1] - 1)
- }
- nties[subs] <- ones
+ degree[subs] <- atts$degree
+ missings[subs] <-atts$missings
+ nties[subs] <- atts$ones
if (gpatts$symmetric[net])
{
nties <- nties / 2
}
periodFromStart <- data[[group]]$observations
}
+ averageDegree <- mean(degree)
## now do the format
tmp <- rbind(format(round(density, 3), nsmall=3, width=7),
format(round(degree, 3), nsmall=3, width=7),
@@ -116,9 +97,38 @@
if (startCol > nobs)
break
}
+ if (sum(gpatts$types == "oneMode") > 0)
+ {
+ netnames <- gpatts$netnames[net]
+ if (nData > 1)
+ {
+ averageOutDegree <-
+ sapply(data, function(x)
+ sapply(x$depvars, function(y)
+ attr(y, "averageOutDegree")))
+ }
+ else
+ {
+ averageOutDegree <- gpatts$"averageOutDegree"
+ }
+ Report("\n", outf)
+ if (nData > 1 || sum(atts$types == "oneMode") > 1)
+ {
+ Report("The average degrees are: ", outf)
+ Report(paste(names(data), round(averageOutDegree, 3),
+ sep=': '), outf)
+ Report("\n", outf)
+
+ }
+ else
+ {
+ Report(c("The average degree is",
+ round(averageOutDegree, 3), "\n"), outf)
+ }
+ }
Report("\n\n", outf)
Report(c(ifelse(gpatts$symmetric[net], "Edge", "Tie"),
- "changes between subsequent observations:\n"), outf)
+ "changes between subsequent observations:\n"), outf)
valmin <- gpatts$netRanges[1, net]
valmax <- gpatts$netRanges[2, net]
tmp <- expand.grid(valmin:valmax, valmin:valmax)
Modified: pkg/RSienaTest/R/sienaDataCreate.r
===================================================================
--- pkg/RSienaTest/R/sienaDataCreate.r 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/R/sienaDataCreate.r 2010-02-16 20:11:51 UTC (rev 60)
@@ -614,12 +614,12 @@
}
else
{
- attr(depvars[[i]], "vals")[[j]] <- table(mymat,
- useNA="always")
+ attr(depvars[[i]], "vals")[[j]] <-
+ table(mymat, useNA="always")
}
attr(depvars[[i]], "nval")[j] <-
sum(!is.na(mymat[row(mymat) != col(mymat)]))
- }
+ }
### need to exclude the structurals here
if (sparse)
{
@@ -635,9 +635,31 @@
attr(depvars[[i]], "range") <-
range(tmp[!(is.na(tmp) | tmp %in% c(10, 11))])
}
+ ## average degree
+ atts <- attributes(depvars[[i]])
+ ones <- sapply(atts$vals, function(x){
+ if (is.na(x["11"]))
+ {
+ ones <- x["1"]
+ }
+ else
+ {
+ ones <- x["1"] + x["11"]
+ }
+ } )
+ density <- ones / atts$nval
+ degree <- (atts$netdims[1] - 1) * ones / atts$nval
+ missings <- 1 - atts$nval/ atts$netdims[1] /
+ (atts$netdims[1] - 1)
+ attr(depvars[[i]], "ones") <- ones
+ attr(depvars[[i]], "density") <- density
+ attr(depvars[[i]], "degree") <- degree
+ attr(depvars[[i]], "averageOutDegree") <- mean(degree)
+ attr(depvars[[i]], "averageInDegree") <- mean(degree)
+ attr(depvars[[i]], "missings") <- missings
}
else #type=='bipartite' not sure what we need here,
- #### but include diagonal
+ ## but include diagonal
{
attr(depvars[[i]], 'balmean') <- NA
attr(depvars[[i]], 'simMean') <- NA
@@ -692,7 +714,28 @@
attr(depvars[[i]], "range") <-
range(tmp[!(is.na(tmp) | tmp %in% c(10, 11))])
}
- }
+ ## average degree
+ atts <- attributes(depvars[[i]])
+ ones <- sapply(atts$vals, function(x){
+ if (is.na(x["11"]))
+ {
+ ones <- x["1"]
+ }
+ else
+ {
+ ones <- x["1"] + x["11"]
+ }
+ } )
+ density <- ones / atts$nval
+ degree <- (atts$netdims[2]) * ones / atts$nval
+ missings <- 1 - atts$nval/ atts$netdims[1] /
+ (atts$netdims[2])
+ attr(depvars[[i]], "ones") <- ones
+ attr(depvars[[i]], "density") <- density
+ attr(depvars[[i]], "degree") <- degree
+ attr(depvars[[i]], "averageOutDegree") <- mean(degree)
+ attr(depvars[[i]], "missings") <- missings
+ }
}
attr(depvars[[i]], 'name') <- names(depvars)[i]
}
@@ -789,6 +832,7 @@
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
+ browser()
if (any(var1 - var2 < 0, na.rm=TRUE))
{
higher[i] <- FALSE
@@ -1230,7 +1274,7 @@
}
if (is.null(nodeSets[[netnamesub]]))
{
- nodeSets[[netnamesub]] <- attribs[['nodeSet']]
+ nodeSets[[netnamesub]] <- attribs[['nodeSet']]
}
else if (any(nodeSets[[netnamesub]] != attribs[['nodeSet']]))
{
@@ -1467,6 +1511,33 @@
balmeans <- calcBalmeanGroup (group)
names(balmeans) <- netnames
attr(group, "balmean") <- balmeans
+ ## calculate overall degree averages
+ atts <- attributes(group)
+ netnames <- atts$netnames
+ types <- atts$types
+ ## cat(types,'\n')
+ degrees <- namedVector(NA, netnames)
+ for (net in seq(along=netnames))
+ {
+ if (types[net] != "behavior")
+ {
+ degree <- 0
+ nDegree <- 0
+ for (i in 1: length(group))
+ {
+ j <- match(netnames[net], names(group[[i]]$depvars))
+ if (is.na(j))
+ stop("network names not consistent")
+ depvar <- group[[i]]$depvars[[j]]
+ degs <- attr(depvar, "degree")
+ degree <- degree + sum(degs)
+ nDegree <- nDegree + length(degs)
+ }
+ degrees[net] <- degree / nDegree
+ }
+ }
+ attr(group, "averageOutDegree") <- degrees
+ attr(group, "averageInDegree") <- degrees
group <- groupRangeAndSimilarityAndMean(group)
bAnyMissing <- attr(group, "bAnyMissing")
attr(group, "anyMissing") <- anyMissing | bAnyMissing
@@ -1477,6 +1548,10 @@
## copy the global attributes down to individual level where appropriate
##group <- copyGroupAttributes(group, "depvars", "balmean", "balmean")
group <- copyGroupAttributes(group, "depvars", "symmetric", "symmetric")
+ ##group <- copyGroupAttributes(group, "depvars", "averageInDegree",
+ ## "averageInDegree")
+ ##group <- copyGroupAttributes(group, "depvars", "averageOutDegree",
+ ## "averageOutDegree")
##group <- copyGroupAttributes(group, "depvars", "bSim", "simMean")
group <- copyGroupAttributes(group, "depvars", "bposzvar", "poszvar")
group <- copyGroupAttributes(group, "depvars", "bRange", "range")
Modified: pkg/RSienaTest/R/simstatsc.r
===================================================================
--- pkg/RSienaTest/R/simstatsc.r 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/R/simstatsc.r 2010-02-16 20:11:51 UTC (rev 60)
@@ -951,6 +951,8 @@
attr(edgeLists, 'symmetric') <- attr(depvar, 'symmetric')
## attr balmean
attr(edgeLists, 'balmean') <- attr(depvar, 'balmean')
+ attr(edgeLists, 'averageInDegree') <- attr(depvar, 'averageInDegree')
+ attr(edgeLists, 'averageOutDegree') <- attr(depvar, 'averageOutDegree')
return(edgeLists = edgeLists)
}
##@unpackBipartite siena07 Reformat data for C++
@@ -1098,6 +1100,7 @@
attr(edgeLists, 'symmetric') <- attr(depvar, 'symmetric')
## attr balmean
attr(edgeLists, 'balmean') <- attr(depvar, 'balmean')
+ attr(edgeLists, 'averageOutDegree') <- attr(depvar, 'averageOutDegree')
return(edgeLists = edgeLists)
}
##@unpackBehavior siena07 Reformat data for C++
Modified: pkg/RSienaTest/src/data/NetworkLongitudinalData.cpp
===================================================================
--- pkg/RSienaTest/src/data/NetworkLongitudinalData.cpp 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/src/data/NetworkLongitudinalData.cpp 2010-02-16 20:11:51 UTC (rev 60)
@@ -284,9 +284,25 @@
{
return this->lmaxDegree;
}
+/**
+ * Stores the average in-degree over all receivers and observations.
+ */
+void NetworkLongitudinalData::averageInDegree(double val)
+{
+ this->laverageInDegree = val;
+}
/**
+ * Store the average out-degree over all senders and observations.
+ */
+void NetworkLongitudinalData::averageOutDegree(double val)
+{
+ this->laverageOutDegree = val;
+}
+
+
+/**
* Returns the average in-degree over all receivers and observations.
*/
double NetworkLongitudinalData::averageInDegree() const
Modified: pkg/RSienaTest/src/data/NetworkLongitudinalData.h
===================================================================
--- pkg/RSienaTest/src/data/NetworkLongitudinalData.h 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/src/data/NetworkLongitudinalData.h 2010-02-16 20:11:51 UTC (rev 60)
@@ -60,6 +60,8 @@
int maxDegree() const;
double averageInDegree() const;
double averageOutDegree() const;
+ void averageInDegree(double val);
+ void averageOutDegree(double val);
private:
// The set of actors receiving the ties of the network
Modified: pkg/RSienaTest/src/siena07.cpp
===================================================================
--- pkg/RSienaTest/src/siena07.cpp 2010-02-12 14:35:28 UTC (rev 59)
+++ pkg/RSienaTest/src/siena07.cpp 2010-02-16 20:11:51 UTC (rev 60)
@@ -773,9 +773,17 @@
SEXP symm;
PROTECT(symm = install("symmetric"));
SEXP symmetric = getAttrib(VECTOR_ELT(ONEMODEGROUP, oneMode), symm);
- SEXP balm;
+ SEXP balm;
PROTECT(balm = install("balmean"));
SEXP balmean = getAttrib(VECTOR_ELT(ONEMODEGROUP, oneMode), balm);
+ SEXP avin;
+ PROTECT(avin = install("averageInDegree"));
+ SEXP averageInDegree = getAttrib(VECTOR_ELT(ONEMODEGROUP, oneMode),
+ avin);
+ SEXP avout;
+ PROTECT(avout = install("averageOutDegree"));
+ SEXP averageOutDegree = getAttrib(VECTOR_ELT(ONEMODEGROUP, oneMode),
+ avout);
SEXP nm;
PROTECT(nm = install("name"));
SEXP name = getAttrib(VECTOR_ELT(ONEMODEGROUP, oneMode), nm);
@@ -786,14 +794,23 @@
myActorSet);
pOneModeNetworkLongitudinalData->symmetric(*(LOGICAL(symmetric)));
pOneModeNetworkLongitudinalData->balanceMean(*(REAL(balmean)));
+ pOneModeNetworkLongitudinalData->
+ averageInDegree(*(REAL(averageInDegree)));
+ pOneModeNetworkLongitudinalData->
+ averageOutDegree(*(REAL(averageOutDegree)));
setupOneModeObservations(VECTOR_ELT(ONEMODEGROUP, oneMode),
pOneModeNetworkLongitudinalData);
+ // Rprintf("%f %f\n", pOneModeNetworkLongitudinalData->
+ // averageInDegree(), pOneModeNetworkLongitudinalData->
+ // averageOutDegree());
// Once all network data has been stored, calculate some
// statistical properties of that data.
-
- pOneModeNetworkLongitudinalData->calculateProperties();
- UNPROTECT(4);
+ //pOneModeNetworkLongitudinalData->calculateProperties();
+ //Rprintf("%f %f\n", pOneModeNetworkLongitudinalData->
+ // averageInDegree(), pOneModeNetworkLongitudinalData->
+ // averageOutDegree());
+ UNPROTECT(6);
}
}
@@ -915,6 +932,10 @@
SEXP nm;
PROTECT(nm = install("name"));
SEXP name = getAttrib(VECTOR_ELT(BIPARTITEGROUP, bipartite), nm);
+ SEXP avout;
+ PROTECT(avout = install("averageOutDegree"));
+ SEXP averageOutDegree = getAttrib(VECTOR_ELT(BIPARTITEGROUP,
+ bipartite), avout);
const ActorSet * pSenders = pData->pActorSet(CHAR(STRING_ELT(
actorSet, 0)));
const ActorSet * pReceivers = pData->pActorSet(CHAR(STRING_ELT(
@@ -922,14 +943,15 @@
NetworkLongitudinalData * pNetworkLongitudinalData =
pData->createNetworkData(CHAR(STRING_ELT(name, 0)),
pSenders, pReceivers);
+ pNetworkLongitudinalData->averageOutDegree(*(REAL(averageOutDegree)));
setupBipartiteObservations(VECTOR_ELT(BIPARTITEGROUP, bipartite),
pNetworkLongitudinalData);
// Once all network data has been stored, calculate some
// statistical properties of that data.
- pNetworkLongitudinalData->calculateProperties();
- UNPROTECT(2);
+ //pNetworkLongitudinalData->calculateProperties();
+ UNPROTECT(3);
}
}
/**
More information about the Rsiena-commits
mailing list