[Rsiena-commits] r71 - in pkg/RSienaTest: . R data doc man src src/data src/model src/model/effects src/model/ml src/model/variables
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 27 23:11:51 CET 2010
Author: ripleyrm
Date: 2010-03-27 23:11:51 +0100 (Sat, 27 Mar 2010)
New Revision: 71
Added:
pkg/RSienaTest/src/model/ml/Option.cpp
pkg/RSienaTest/src/model/ml/Option.h
Modified:
pkg/RSienaTest/DESCRIPTION
pkg/RSienaTest/NAMESPACE
pkg/RSienaTest/R/maxlike.r
pkg/RSienaTest/R/phase1.r
pkg/RSienaTest/R/phase2.r
pkg/RSienaTest/R/phase3.r
pkg/RSienaTest/R/print01Report.r
pkg/RSienaTest/R/printInitialDescription.r
pkg/RSienaTest/R/siena01.r
pkg/RSienaTest/R/siena07.r
pkg/RSienaTest/R/sienaDataCreate.r
pkg/RSienaTest/R/sienaDataCreateFromSession.r
pkg/RSienaTest/R/simstatsc.r
pkg/RSienaTest/changeLog
pkg/RSienaTest/data/allEffects.csv
pkg/RSienaTest/doc/s_man400.tex
pkg/RSienaTest/man/RSiena-package.Rd
pkg/RSienaTest/src/data/BehaviorLongitudinalData.cpp
pkg/RSienaTest/src/data/BehaviorLongitudinalData.h
pkg/RSienaTest/src/data/Data.cpp
pkg/RSienaTest/src/data/LongitudinalData.cpp
pkg/RSienaTest/src/data/LongitudinalData.h
pkg/RSienaTest/src/data/NetworkLongitudinalData.cpp
pkg/RSienaTest/src/data/NetworkLongitudinalData.h
pkg/RSienaTest/src/data/OneModeNetworkLongitudinalData.cpp
pkg/RSienaTest/src/data/OneModeNetworkLongitudinalData.h
pkg/RSienaTest/src/model/EpochSimulation.h
pkg/RSienaTest/src/model/effects/EffectFactory.cpp
pkg/RSienaTest/src/model/ml/BehaviorChange.cpp
pkg/RSienaTest/src/model/ml/BehaviorChange.h
pkg/RSienaTest/src/model/ml/Chain.cpp
pkg/RSienaTest/src/model/ml/Chain.h
pkg/RSienaTest/src/model/ml/MLSimulation.cpp
pkg/RSienaTest/src/model/ml/MLSimulation.h
pkg/RSienaTest/src/model/ml/MiniStep.cpp
pkg/RSienaTest/src/model/ml/MiniStep.h
pkg/RSienaTest/src/model/ml/NetworkChange.cpp
pkg/RSienaTest/src/model/ml/NetworkChange.h
pkg/RSienaTest/src/model/variables/BehaviorVariable.cpp
pkg/RSienaTest/src/model/variables/BehaviorVariable.h
pkg/RSienaTest/src/model/variables/DependentVariable.cpp
pkg/RSienaTest/src/model/variables/DependentVariable.h
pkg/RSienaTest/src/model/variables/NetworkVariable.cpp
pkg/RSienaTest/src/model/variables/NetworkVariable.h
pkg/RSienaTest/src/siena07.cpp
Log:
Many bug fixes. New version number.
Modified: pkg/RSienaTest/DESCRIPTION
===================================================================
--- pkg/RSienaTest/DESCRIPTION 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/DESCRIPTION 2010-03-27 22:11:51 UTC (rev 71)
@@ -1,8 +1,8 @@
Package: RSienaTest
Type: Package
Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.0.11
-Date: 2010-02-11
+Version: 1.0.12
+Date: 2010-03-27
Author: Various
Depends: R (>= 2.9.0), xtable
Imports: Matrix
Modified: pkg/RSienaTest/NAMESPACE
===================================================================
--- pkg/RSienaTest/NAMESPACE 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/NAMESPACE 2010-03-27 22:11:51 UTC (rev 71)
@@ -30,7 +30,6 @@
S3method(iwlsm, default)
S3method(se.contrast, iwlsm)
S3method(vcov, iwlsm)
-S3method(addAttributes, default)
S3method(addAttributes, coCovar)
S3method(addAttributes, varCovar)
S3method(addAttributes, coDyadCovar)
Modified: pkg/RSienaTest/R/maxlike.r
===================================================================
--- pkg/RSienaTest/R/maxlike.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/maxlike.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -678,7 +678,9 @@
#browser()
list(chain=chain,accept=accept,numm=numm)
}##end of procedure
- ## browser() ##start of mhstep
+ #########################################################################
+ ##start of mhstep
+ #########################################################################
#cat('start', f$numm,'\n')
## print(table(f$chain))
startmat<- f$startmat
Modified: pkg/RSienaTest/R/phase1.r
===================================================================
--- pkg/RSienaTest/R/phase1.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/phase1.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -527,7 +527,8 @@
{
for (ii in 1: min(10 - z$nit + 1, int))
{
- z$npos <- z$npos + ifelse(abs(diag(fras[ii, , ])) > 1e-6, 1, 0)
+ z$npos <- z$npos +
+ ifelse(abs(diag(matrix(fras[ii, , ], nrow=z$pp))) > 1e-6, 1, 0)
}
}
sdf <- fras
Modified: pkg/RSienaTest/R/phase2.r
===================================================================
--- pkg/RSienaTest/R/phase2.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/phase2.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -296,9 +296,7 @@
DisplayThetaAutocor(z)
}
}
- ## limit change. not sure what to do here sd is not set up
- ## unless finite differences are used or ML and
- ## ML is specifically excluded here. Reporting is delayed to
+ ## limit change. Reporting is delayed to
## end of phase.
## browser()
if (x$diag)## !maxlike at present
Modified: pkg/RSienaTest/R/phase3.r
===================================================================
--- pkg/RSienaTest/R/phase3.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/phase3.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -43,6 +43,10 @@
z$sf2 <- array(0, dim = c(z$n3, f$observations - 1, z$pp))
z$ssc <- array(0, dim = c(z$n3, f$observations - 1, z$pp))
z$sdf <- array(0, dim = c(z$n3, z$pp, z$pp))
+ if (z$cconditional)
+ {
+ z$ntim <- matrix(NA, nrow=z$n3, ncol=f$observations - 1)
+ }
z$sims <- vector("list", z$n3)
## revert to original requested method for phase 3 unless symmetric
if (z$FinDiff.method && !x$FinDiff.method &&
Modified: pkg/RSienaTest/R/print01Report.r
===================================================================
--- pkg/RSienaTest/R/print01Report.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/print01Report.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -417,7 +417,7 @@
Report(c(format(netname, width=12),
format(c(missings, sum(missings)),
width=10), " (",
- format(round(sum(missings)/
+ format(round(100 * sum(missings)/
nrow(depvar)/ncol(depvar), 1),
nsmall=1, width=4), ' %)\n'), sep="", outf)
}
@@ -477,7 +477,7 @@
{
Report(c(format(covars[i], width=15),
sum(is.na(x$cCovars[[i]])), " (",
- format(round(sum(is.na(x$cCovars[[i]]))/
+ format(round(100 * sum(is.na(x$cCovars[[i]]))/
length(x$cCovars[[i]]), 1),
width=3, nsmall=1), '%)\n'), outf)
}
@@ -562,7 +562,7 @@
Report(c(format(covars[i], width=10),
format(misscols, width=8),
format(sum(misscols), width=9), " (",
- format(round(sum(misscols)/nrow(thiscovar)/
+ format(round(100 * sum(misscols)/nrow(thiscovar)/
ncol(thiscovar), 1), nsmall=1,
width=3), '%)\n'), outf)
}
@@ -618,7 +618,7 @@
diag(myvar) <- 0
Report(c(format(covars[i], width=15),
sum(is.na(myvar)), " (",
- format(round(sum(is.na(myvar))/
+ format(round(100 * sum(is.na(myvar))/
(length(myvar) - nrow(myvar)), 1),
width=3, nsmall=1), '%)\n'), outf)
}
@@ -669,7 +669,7 @@
Report(c(format(covars[i], width=10),
format(missvals, width=8),
format(sum(missvals), width=9), " (",
- format(round(sum(missvals)/nrow(thiscovar)/
+ format(round(100 * sum(missvals)/nrow(thiscovar)/
ncol(thiscovar), 1), nsmall=1,
width=3), '%)\n'), outf)
}
Modified: pkg/RSienaTest/R/printInitialDescription.r
===================================================================
--- pkg/RSienaTest/R/printInitialDescription.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/printInitialDescription.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -97,34 +97,29 @@
if (startCol > nobs)
break
}
- if (sum(gpatts$types != "bipartite") > 0)
- {
- if (nData > 1)
+ averageOutDegree <- rep(NA, nData)
+ for (group in 1:nData)
{
- averageOutDegree <-
- sapply(data, function(x)
- sapply(x$depvars, function(y)
- attr(y, "averageOutDegree")))
+ j <- match(netnames[net], names(data[[group]]$depvars))
+ if (is.na(j))
+ stop("network names not consistent")
+ depvar <- data[[group]]$depvars[[j]]
+ atts <- attributes(depvar)
+ averageOutDegree[group] <- atts$"averageOutDegree"
}
- else
- {
- averageOutDegree <- gpatts$"averageOutDegree"
- }
Report("\n", outf)
- if (nData > 1 || sum(atts$types != "behavior") > 1)
+ if (nData > 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)
@@ -269,6 +264,7 @@
{
## require(Matrix)
mymat <- depvar[[per]]
+ diag(mymat) <- 0
mymat1 <- mymat at i
mymat2 <- mymat at j
mymat3 <- mymat at x
@@ -293,9 +289,11 @@
missji <- paste(mymat2[is.na(mymat3)],
mymat1[is.na(mymat3)])
mutual <- sum(ij %in% ji) / 2
+ ## nondyads are ones where we have a link and
+ ## its partner is missing
nondyads <- sum(ji %in% missij)
asymm <- length(ij) - nondyads - mutual * 2
- missdyads <- sum(!missij %in% missji) +
+ missdyads <- sum(!(missij %in% missji)) +
sum(missij %in% missji) / 2
nulls <- atts$netdims[1] *
(atts$netdims[2] - 1) / 2 -
Modified: pkg/RSienaTest/R/siena01.r
===================================================================
--- pkg/RSienaTest/R/siena01.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/siena01.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -564,22 +564,28 @@
{
tkmessageBox(message=resp, icon="error")
}
- else ## update the thetas to use next time
+ else ## update the thetas to use next time, if run not interrupted
{
estimAns <<- resp
if (estimAns$cconditional)
{
## z$condvar has the subscripts of included parameters that
## correspond to the conditional variable
- use <- which(myeff$include)
- initValues <- rep(0, length(use))
- initValues[estimAns$condvar] <- estimAns$rate
- initValues[-estimAns$condvar] <- estimAns$theta
- myeff$initialValue[myeff$include] <<- initValues
+ if (!is.null(estimAns$rate))
+ {
+ use <- which(myeff$include)
+ initValues <- rep(0, length(use))
+ initValues[estimAns$condvar] <- estimAns$rate
+ initValues[-estimAns$condvar] <- estimAns$theta
+ myeff$initialValue[myeff$include] <<- initValues
+ }
}
else
{
- myeff$initialValue[myeff$include] <<- estimAns$theta
+ if (!estimAns$termination == "UserInterrupt")
+ {
+ myeff$initialValue[myeff$include] <<- estimAns$theta
+ }
}
wasopen <- FALSE
if (resultsOpen)
Modified: pkg/RSienaTest/R/siena07.r
===================================================================
--- pkg/RSienaTest/R/siena07.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/siena07.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -125,6 +125,8 @@
stopCluster(z$cl)
class(z) <- "sienaFit"
+ z$tkvars <- NULL
+ z$pb <- NULL
z
}
##@InitReports siena07 Print report
Modified: pkg/RSienaTest/R/sienaDataCreate.r
===================================================================
--- pkg/RSienaTest/R/sienaDataCreate.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/sienaDataCreate.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -837,7 +837,6 @@
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
Modified: pkg/RSienaTest/R/sienaDataCreateFromSession.r
===================================================================
--- pkg/RSienaTest/R/sienaDataCreateFromSession.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/sienaDataCreateFromSession.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -254,7 +254,8 @@
gpsession <- session[session$Group == gps[i], ]
ops <- turnoffwarn()
gpsessionperiods <- unlist(strsplit(gpsession$Period, " "))
- observations <- max(as.numeric(gpsessionperiods), na.rm=TRUE)
+ ## observations <- max(as.numeric(gpsessionperiods), na.rm=TRUE)
+ observations <- length(unique(gpsessionperiods))
turnonwarn(ops)
gpfiles <- files[session$Group == gps[i]]
objnames <- unique(gpsession$Name)
@@ -479,6 +480,7 @@
## namesession$MissingValues[1],
## fixed=TRUE)
miss <- namesession$MissingValues
+ miss <- strsplit(miss, " ")[[1]]
if (!is.na(miss) && miss != '')
namefiles[[1]][namefiles[[1]] %in% miss] <- NA
## namefiles[[1]][grep(miss, namefiles[[1]])] <- NA
@@ -493,6 +495,7 @@
## fixed=TRUE)
## namefiles[[1]][grep(miss, namefiles[[1]])] <- NA
miss <- namesession$MissingValues
+ miss <- strsplit(miss, " ")[[1]]
namefiles[[1]][namefiles[[1]] %in% miss] <- NA
varnames <- strsplit(objnames[j], ' ')[[1]]
tmp <- sapply(1: ncol(namefiles[[1]]), function(x){
@@ -508,6 +511,7 @@
## fixed=TRUE)
## namefiles[[1]][grep(miss, namefiles[[1]])] <- NA
miss <- namesession$MissingValues
+ miss <- strsplit(miss, " ")[[1]]
namefiles[[1]][namefiles[[1]] %in% miss] <- NA
assign(objnames[j],
varCovar (namefiles[[1]],
@@ -520,6 +524,7 @@
## fixed=TRUE)
## namefiles[[1]][grep(miss, namefiles[[1]])] <- NA
miss <- namesession$MissingValues
+ miss <- strsplit(miss, " ")[[1]]
namefiles[[1]][namefiles[[1]] %in% miss] <- NA
if (namesession[1, "ActorSet"] == "Actors")
{
@@ -540,9 +545,10 @@
myarray <- array(NA, dim=c(dim(namefiles[[1]]),
observations - 1))
miss <- namesession$MissingValues
+ miss <- strsplit(miss, " ")
for (x in 1:nrow(namesession))
{
- if (miss[x] != '')
+ if (miss[[x]] != '')
{
namefiles[[x]][namefiles[[x]] %in% miss[x]] <- NA
}
Modified: pkg/RSienaTest/R/simstatsc.r
===================================================================
--- pkg/RSienaTest/R/simstatsc.r 2010-03-27 21:47:56 UTC (rev 70)
+++ pkg/RSienaTest/R/simstatsc.r 2010-03-27 22:11:51 UTC (rev 71)
@@ -15,394 +15,9 @@
{
if (INIT || initC) ## initC is to initialise multiple C processes in phase3
{
- if (!initC)
- {
- if (!inherits(data,'siena'))
- stop('not valid siena data object')
- defaultEffects <- getEffects(data)
- if (is.null(effects))
- effects <- defaultEffects
- else
- {
- ## todo check that the effects match the data dependent variables
- userlist <- apply(effects[effects$include,], 1, function(x)
- paste(x[c("name", "effectName",
- "type", "groupName")],
- collapse="|"))
- deflist <- apply(defaultEffects, 1, function(x)
- paste(x[c("name", "effectName",
- "type", "groupName")],
- collapse="|"))
- if (!all(userlist %in% deflist))
- {
- bad <- which(!(userlist %in% deflist))
- print(userlist[bad])
- stop("invalid effect requested: see above ")
- }
- }
- if (!inherits(effects, 'data.frame'))
- stop('effects is not a data.frame')
- if (x$useStdInits)
- {
- if (any(effects$effectName != defaultEffects$effectName))
- {
- stop('Cannot use standard initialisation with a ',
- 'different effect list')
- }
- effects$initialValue <- defaultEffects$initialValue
- }
- ## find any effects not included which are needed for interactions
- interactionNos <- unique(c(effects$effect1, effects$effect2,
- effects$effect3))
- interactionNos <- interactionNos[interactionNos > 0]
- interactionMainEffects <- effects[interactionNos, ]
- effects$requested <- effects$include
- requestedEffects <- effects[effects$include, ]
+ z <- initializeFRAN(z, x, data, effects, prevAns, initC,
+ profileData=profileData, returnDeps=returnDeps)
- effects$include[interactionNos] <- TRUE
- effects <- effects[effects$include,]
-
- ## split and rejoin both versions before continuing
- effects1 <- split(requestedEffects, requestedEffects$name)
- if (inherits(data, "sienaGroup"))
- depvarnames <- names(data[[1]]$depvars)
- else
- depvarnames <- names(data$depvars)
- effects1order <- match(depvarnames, names(effects1))
- requestedEffects <- do.call(rbind, effects1[effects1order])
- row.names(requestedEffects) <- 1:nrow(requestedEffects)
- effects1 <- split(effects, effects$name)
- effects1order <- match(depvarnames, names(effects1))
- effects <- do.call(rbind, effects1[effects1order])
- row.names(effects) <- 1:nrow(effects)
- z$theta <- requestedEffects$initialValue
- z$fixed <- requestedEffects$fix
- z$test <- requestedEffects$test
- z$pp <- length(z$test)
- z$posj <- rep(FALSE,z$pp)
- z$posj[requestedEffects$basicRate] <- TRUE
- z$BasicRateFunction <- z$posj
- effects <- fixUpEffectNames(effects)
-
- ## copy interaction names to the requested effects
- requestedEffects$effectName <- effects[effects$requested,
- "effectName"]
- requestedEffects$functionName <- effects[effects$requested,
- "functionName"]
-
- if (inherits(data, 'sienaGroup'))
- {
- nGroup <- length(data)
- }
- else
- {
- nGroup <- 1
- data <- sienaGroupCreate(list(data), singleOK=TRUE)
- }
- if (is.na(x$cconditional))
- {
- x$cconditional <- length(depvarnames) == 1
- if (x$cconditional)
- {
- x$condvarno <- 1
- }
- }
- z$cconditional <- FALSE
- if (x$cconditional)
- {
- types <- sapply(data[[1]]$depvars, function(x) attr(x, 'type'))
- nets <- sum(types != "behavior")
- if (nets == 1)
- {
- z$cconditional <- TRUE
- ## find the conditioning variable
- observations <- attr(data, 'observations')
- if (x$condname != '')
- {
- z$condvarno <- match(x$condname, attr(data, "netnames"))
- z$condname <- x$condname
- }
- else
- {
- z$condvarno <- x$condvarno
- z$condname <- attr(data, 'netnames')[x$condvarno]
- }
- z$condtype <- attr(data, "types")[z$condvarno]
- if (z$condtype == 'oneMode')
- z$symmetric <- attr(data, "symmetric")[[z$condvarno]]
- else
- z$symmetric <- FALSE
- ## find the positions of basic rate effects for this network
- z$condvar <-
- (1:nrow(requestedEffects))[requestedEffects$name==
- z$condname][1:observations]
- z$theta<- z$theta[-z$condvar]
- z$fixed<- z$fixed[-z$condvar]
- z$test<- z$test[-z$condvar]
- z$pp<- z$pp-length(z$condvar)
- z$scale<- z$scale[-z$condvar]
- z$BasicRateFunction <- z$posj[-z$condvar]
- z$posj <- z$posj[-z$condvar]
- z$theta[z$posj] <-
- z$theta[z$posj] /
- requestedEffects$initialValue[z$condvar]
- z$ntim<- matrix(NA, nrow=x$n3, ncol=observations)
- }
- }
- ## unpack data and put onto f anything we may need next time round.
- f <- lapply(data, function(x) unpackData(x))
- attr(f, "netnames") <- attr(data, "netnames")
- attr(f, "symmetric") <- attr(data, "symmetric")
- attr(f, "allUpOnly") <- attr(data, "allUpOnly")
- attr(f, "allDownOnly") <- attr(data, "allDownOnly")
- attr(f, "allHigher") <- attr(data, "allHigher")
- attr(f, "allDisjoint") <- attr(data, "allDisjoint")
- attr(f, "allAtLeastOne") <- attr(data, "allAtLeastOne")
- attr(f, "anyUpOnly") <- attr(data, "anyUpOnly")
- attr(f, "anyDownOnly") <- attr(data, "anyDownOnly")
- attr(f, "anyHigher") <- attr(data, "anyHigher")
- attr(f, "anyDisjoint") <- attr(data, "anyDisjoint")
- attr(f, "anyAtLeastOne") <- attr(data, "anyAtLeastOne")
- attr(f, "types") <- attr(data, "types")
- attr(f, "observations") <- attr(data, "observations")
- attr(f, "compositionChange") <- attr(data, "compositionChange")
- attr(f, "exooptions") <- attr(data, "exooptions")
- attr(f, "groupPeriods") <- attr(data, "groupPeriods")
- ## if any networks symmetric must use finite differences
- syms <- attr(data,"symmetric")
- z$FinDiffBecauseSymmetric <- FALSE
- if (any(!is.na(syms) & syms))
- {
- z$FinDiff.method <- TRUE
- z$FinDiffBecauseSymmetric <- TRUE
- }
- if (z$cconditional)
- {
- attr(f, "change") <-
- sapply(f, function(xx)attr(xx$depvars[[z$condname]],
- 'distance'))
- attr(f,"condEffects") <- requestedEffects[z$condvar,]
- effcondvar <-
- (1:nrow(effects))[effects$name==
- z$condname][1:observations]
- effects <- effects[-effcondvar, ]
- requestedEffects <- requestedEffects[-z$condvar,]
- }
- ## see if we can use the original dfra
- if (!is.null(prevAns) && inherits(prevAns, "sienaFit"))
- {
- if (all(rownames(prevAns$dfra) == requestedEffects$shortName)
- && !is.null(prevAns$sf))
- {
- z$haveDfra <- TRUE
- z$dfra <- prevAns$dfra
- z$sf <- prevAns$sf
- ## use thetas too, unless use standard values
- if (!x$useStdInits)
- {
- requestedEffects$initialValue <- prevAns$theta
- if (!is.null(prevAns$condvar))
- {
- ## z$condvar has the subscripts of included
- ## parameters
- ## that correspond to the conditional variable
- ## need to scale the other rates again
- requestedEffects$initialValue[z$posj] <-
- requestedEffects$initialValue[z$posj] /
- prevAns$rate
- }
- z$theta <- requestedEffects$initialValue
- }
- }
- }
- z$effects <- effects
- z$requestedEffects <- requestedEffects
- }
- else
- {
- f <- FRANstore()
- ## Would like f to be just the data objects plus the attributes
- ## but need the effects later. Also returnDeps flag
- ff <- f
- f$pData <- NULL
- f$pModel <- NULL
- f$myeffects <- NULL
- f$observations <- NULL
- f$randomseed2 <- NULL
- f$seeds <- NULL
- f$returnDeps <- NULL
- f$depNames <- NULL
- f$groupNames <- NULL
- f$nGroup <- NULL
- f$basicEffects <- NULL
- f$interactionEffects <- NULL
- }
- ##browser()
- #browser()
- pData <- .Call('setupData', PACKAGE=pkgname,
- lapply(f, function(x)(as.integer(x$observations))),
- lapply(f, function(x)(x$nodeSets)))
- ans <- .Call('OneMode', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$nets))
- ans <- .Call('Bipartite', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$bipartites))
- ans <- .Call('Behavior', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$behavs))
- # browser()
- ans <-.Call('ConstantCovariates', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$cCovars))
- ans <-.Call('ChangingCovariates', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$vCovars))
- ans <-.Call('DyadicCovariates', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$dycCovars))
- ans <-.Call('ChangingDyadicCovariates', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$dyvCovars))
- ans <-.Call('ExogEvent', PACKAGE=pkgname,
- pData, lapply(f, function(x)x$exog))
- ## split the names of the constraints
- higher <- attr(f, "allHigher")
- disjoint <- attr(f, "allDisjoint")
- atLeastOne <- attr(f, "allAtLeastOne")
- froms <- sapply(strsplit(names(higher), ","), function(x)x[1])
- tos <- sapply(strsplit(names(higher), ","), function(x)x[2])
- ans <- .Call("Constraints", PACKAGE=pkgname,
- pData, froms[higher], tos[higher],
- froms[disjoint], tos[disjoint],
- froms[atLeastOne], tos[atLeastOne])
- ##store the address
- f$pData <- pData
- ## register a finalizer
- ans <- reg.finalizer(f$pData, clearData, onexit = FALSE)
- if (!initC)
- {
- storage.mode(effects$parm) <- 'integer'
- storage.mode(effects$group) <- 'integer'
- storage.mode(effects$period) <- 'integer'
- effects$effectPtr <- NA
- splitFactor <- factor(effects$name, levels=attr(f, "netnames"))
- myeffects <- split(effects, splitFactor)
- ## remove interaction effects and save till later
- basicEffects <- lapply(myeffects, function(x)
- {
- x[!x$shortName %in% c("unspInt", "behUnspInt"), ]
- }
- )
- interactionEffects <- lapply(myeffects, function(x)
- {
- x[x$shortName %in% c("unspInt", "behUnspInt"), ]
- }
- )
- ## store effects objects as we may need to recreate them
- f$interactionEffects <- interactionEffects
- f$basicEffects <- basicEffects
- }
- else
- {
- myeffects <- ff$myeffects
- basicEffects <- ff$basicEffects
- interactionEffects <- ff$interactionEffects
- returnDeps <- ff$returnDeps
- nGroup <- ff$nGroup
- }
- ans <- .Call('effects', PACKAGE=pkgname,
- pData, basicEffects)
- pModel <- ans[[1]][[1]]
- ## browser()
- for (i in 1:length(ans[[2]])) ## ans[[2]] is a list of lists of
- ## pointers to effects. Each list corresponds to one
- ## dependent variable
- {
- effectPtr <- ans[[2]][[i]]
- basicEffects[[i]]$effectPtr <- effectPtr
-
- interactionEffects[[i]]$effect1 <-
- basicEffects[[i]]$effectPtr[match(interactionEffects[[i]]$effect1,
- basicEffects[[i]]$effectNumber)]
- interactionEffects[[i]]$effect2 <-
- basicEffects[[i]]$effectPtr[match(interactionEffects[[i]]$effect2,
- basicEffects[[i]]$effectNumber)]
- interactionEffects[[i]]$effect3 <-
- basicEffects[[i]]$effectPtr[match(interactionEffects[[i]]$effect3,
- basicEffects[[i]]$effectNumber)]
- }
- ans <- .Call('interactionEffects', PACKAGE=pkgname,
- pData, pModel, interactionEffects)
- ## copy these pointers to the interaction effects and then rejoin
- for (i in 1:length(ans[[1]])) ## ans is a list of lists of
- ## pointers to effects. Each list corresponds to one
- ## dependent variable
- {
- if (nrow(interactionEffects[[i]]) > 0)
- {
- effectPtr <- ans[[1]][[i]]
- interactionEffects[[i]]$effectPtr <- effectPtr
- }
- myeffects[[i]] <- rbind(basicEffects[[i]], interactionEffects[[i]])
- }
- ## remove the effects only created as underlying effects
- ## for interaction effects
- myeffects <- lapply(myeffects, function(x)
- {
- x[x$requested, ]
- }
- )
- if (!initC)
- {
- ans <- .Call('getTargets', PACKAGE=pkgname,
- pData, pModel, myeffects)
- z$targets <- rowSums(ans)
- z$targets2 <- ans
- }
- ##store address of model
- f$pModel <- pModel
- ans <- reg.finalizer(f$pModel, clearModel, onexit = FALSE)
- if (x$MaxDegree == 0 || is.null(x$MaxDegree))
- {
- MAXDEGREE <- NULL
- }
- else
- {
- MAXDEGREE <- x$MaxDegree
- }
- if (z$cconditional)
- {
- CONDVAR <- z$condname
- CONDTARGET <- attr(f, "change")
- ## cat(CONDTARGET, '\n')
- }
- else
- {
- CONDVAR <- NULL
- CONDTARGET <- NULL
- }
- ans <- .Call("setupModelOptions", PACKAGE=pkgname,
- pData, pModel, MAXDEGREE, CONDVAR, CONDTARGET,
- profileData, z$parallelTesting)
- f$myeffects <- myeffects
- if (!initC)
- {
- DataReport(z, x, f)
- f$randomseed2 <- z$randomseed2
- }
- else
- {
- f$randomseed2 <- ff$randomseed2
- }
- f$observations <- attr(f, "observations") + 1
- f$returnDeps <- returnDeps
- f$depNames <- names(f[[1]]$depvars)
- f$groupNames <- names(f)[1:nGroup]
- f$nGroup <- nGroup
- if (!initC)
- {
- z$f <- f
- }
- if (initC || (z$int == 1 && z$int2 == 1))
- {
- f[1:nGroup] <- NULL
- }
-
- FRANstore(f) ## store f in FRANstore
if (initC)
{
return(NULL)
@@ -439,13 +54,13 @@
}
## iteration entry points
f <- FRANstore()
- # browser()
- # cat(f$randomseed2, f$storedseed, '\n')
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rsiena -r 71
More information about the Rsiena-commits
mailing list