Merge pull request #87 from snlab-nl/develop

Version 1.4.3

DESCRIPTION

@@ -2,8 +2,8 @@ Encoding: UTF-8
 Package: RSiena
 Type: Package
 Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.4.2
-Date: 2023-12-14
+Version: 1.4.3
+Date: 2024-01-09
 Authors@R: c(person("Tom A.B.", "Snijders", role = c("cre", "aut"), email = "tom.snijders@nuffield.ox.ac.uk", 
                 comment = c(ORCID = "0000-0003-3157-4157")),
               person("Ruth M.", "Ripley", role = "aut"),

NEWS.md

@@ -1,11 +1,29 @@
+# RSiena 1.4.3
+
+2024-01-09
+
+## Changes in RSiena:
+
+### Bug correction:
+  * Correction of error message in `BehaviorVariable::accumulateDerivatives`
+    and in `siena07utilities::Rterminate`. 
+  * Allow `sienaDataCreate` with only one variable defined as 
+    a dependent network given as a list of sparse matrices.
+  * Add some "drop=FALSE" in `initializeFRAN.r` to guard against dimension loss
+    in the construction of sparse matrices. 
+### New functionality:
+  * New parameter `targets` in `siena07`, used to supersede the targets 
+    calculated from the data 
+    (not for regular use, see the help file for `siena07`). 
+
 # RSiena 1.4.2
 
 2023-12-14
 
 ## Changes in RSiena:
 
 ### Effects:
-  * New effect `outXMore`, `outMore3`. 
+  * New effects `outXMore`, `outMore3`. 
   * `Interactiontype` of `altLThresholdX` and `altRThresholdX` is dyadic.
   * `Interactiontype` of `degAbsDiffX`, `degPosDiffX`, and `degNegDiffX` 
     is "" (blank). 

R/initializeFRAN.r

@@ -163,11 +163,11 @@ initializeFRAN <- function(z, x, data, effects, prevAns=NULL, initC,
 		{
 			differentVersions <- (effectsVersion != attr(defaultEffects, "version"))
 		}
-		if ((differentVersions) & 
+		if ((differentVersions) &
 			(any((effects$shortName %in% c("unspInt","behUnspInt"))&effects$include)))
 		{
 			warning("Your effects object contains interaction effects and was made
-			  using a different RSiena version. 
+			  using a different RSiena version.
 			  Make sure the interaction effects are the same.")
 		}
 		if (x$useStdInits)
@@ -798,26 +798,35 @@ initializeFRAN <- function(z, x, data, effects, prevAns=NULL, initC,
 		if (!x$maxlike)
 		{
 			z$targets <- rowSums(ans)
+			attr(z$targets, "fromData") <- TRUE
 			z$targets2 <- ans
-# For the moment, the following is an undocumented and hidden option.
-# This replaces the targets calculated from the data
+# If targets is given in the call of siena07,
+# this replaces the targets calculated from the data
 # by user-defined targets.
 			if ((!is.null(x$targets[1])) & (nGroup == 1) & (groupPeriods[1] == 2))
 			{
 				if (length(z$targets) == length(x$targets))
 				{
 					z$targets <- x$targets
 					z$targets2 <- matrix(x$targets, length(x$targets), 1)
-					message('Note: targets taken from algorithm object.')
+					attr(z$targets, "fromData") <- FALSE
+					message('Note: targets used as given in call of siena07.')
 					cat('\n')
 					print(z$targets)
 					cat('\n')
 				}
+				else
+				{
+					message("length of given targets = ", x$targets, ",")
+					message("but there are ", length(z$targets), " parameters to be estimated.")
+					warning("targets as given in the call of siena07 have incorrect length")
+				}
 			}
 		}
 		else
 		{
-			z$targets <- rep(0, z$pp)
+			z$targets <- rep(0, z$pp)			
+			attr(z$targets, "fromData") <- TRUE
 			z$targets2 <- ans
 			z$targets2[] <- 0
 			z$maxlikeTargets <- rowSums(ans)
@@ -1100,7 +1109,7 @@ unpackOneMode <- function(depvar, observations, compositionChange)
 			## carry forward missing values if any
 			if (i == 1)
 			{
-				netmat <- netmat[!is.na(netmat[,3]), ]
+				netmat <- netmat[!is.na(netmat[,3]), , drop = FALSE]
 				networks[[i]] <- spMatrix(nActors, nActors, netmat[, 1],
 					netmat[, 2], netmat[,3])
 			}
@@ -1129,7 +1138,7 @@ unpackOneMode <- function(depvar, observations, compositionChange)
 			mat3 <- mat1[struct, , drop = FALSE]
 			mat3[, 3] <- 1
 			## now remove the zeros from reset data
-			mat1 <- mat1[!mat1[, 3] == 0, ]
+			mat1 <- mat1[!mat1[, 3] == 0, , drop=FALSE]
 			## do comp change
 			if (compChange)
 			{
@@ -1302,12 +1311,12 @@ unpackOneMode <- function(depvar, observations, compositionChange)
 				}
 			}
 			edgeLists[[i]] <- list(mat1 = t(mat1), mat2 = t(mat2),
-				mat3 = t(mat3))
+				mat3 = t(mat3))				
 		}
 	}
 	else
 	{
-		for (i in 1:observations) ## carry missings forward  if exist
+		for (i in 1:observations) ## carry missings forward if exist
 		{
 			networks[[i]] <- depvar[, , i]
 			if (i == 1)

R/printDataReport.r

@@ -76,7 +76,7 @@ DataReport <- function(z, x, f)
 	Report("Estimation method: ", outf)
 	if (z$cconditional)
 	{
-		Report("conditional moment estimation\n", outf)
+		Report("conditional moment estimation", outf)
 		if (gmm(x))
 		{
 			Report(' by the Generalized Method of Moments.\n', outf)
@@ -136,7 +136,7 @@ DataReport <- function(z, x, f)
 		{
 			Report('.\n', outf)
 		}
-		
+
 		#if (exogenous)
 		#{
 		#    Report("Changing composition: no conditional moment estimation.\n",
@@ -307,7 +307,7 @@ DataReport <- function(z, x, f)
 	{
 	  fixed <- ifelse(z$fixed, '  (fixed) ', '')
 	}
-	else 
+	else
 	{
 	  if (!z$cconditional)
 	  {
@@ -337,7 +337,7 @@ DataReport <- function(z, x, f)
 	}
 	Report(tmp, outf)
 	## targets:
-	Report("\n\nObserved values of target statistics are\n", outf)
+	Report("\n\nValues of target statistics are\n", outf)
 	if (z$maxlike)
 	{
 		targets <- z$maxlikeTargets
@@ -353,6 +353,14 @@ DataReport <- function(z, x, f)
 				targets)),
 		'\n', sep = '', collapse = '')
 	Report(tmp, outf)
+	if (attr(z$targets, "fromData"))
+	{
+		Report("These were calculated from the data.\n", outf)
+	}
+	else
+	{
+		Report("These were given by the user in the call of siena07.\n", outf)
+	}
 	Report(c('\n', nrow(z$requestedEffects)-sum(z$requestedEffects$type=="gmm"), 'parameters,',
 			nrow(z$requestedEffects),
 			'statistics\n'),outf)

R/siena07.r

@@ -15,6 +15,7 @@ siena07 <- function(x, batch = FALSE, verbose = FALSE, silent=FALSE,
 	useCluster = FALSE, nbrNodes = 2,
 	thetaValues = NULL,
     returnThetas = FALSE,
+	targets = NULL,
 	initC=TRUE,
 	clusterString=rep("localhost", nbrNodes), tt=NULL,
 	parallelTesting=FALSE, clusterIter=!x$maxlike,
@@ -32,7 +33,7 @@ siena07 <- function(x, batch = FALSE, verbose = FALSE, silent=FALSE,
 	}
 	on.exit(exitfn())
 
-	# If the user is passing clusters through -cl- then change the 
+	# If the user is passing clusters through -cl- then change the
 	# useCluster to TRUE, and assign the -nbrNodes- to number of nodes
 	if (!useCluster & length(cl))
 	{
@@ -133,14 +134,16 @@ siena07 <- function(x, batch = FALSE, verbose = FALSE, silent=FALSE,
 	}
 	z$randomseed2 <- randomseed2
 
+	x$targets <- targets
+
 	## set the global is.batch
 	batchUse <- batch
 	if (!batch)
 	{
 		if (!requireNamespace("tcltk", quietly = TRUE))
 		{
 				batchUse <- TRUE
-				message("Package tcltk not available, forcing use of batch mode")		
+				message("Package tcltk not available, forcing use of batch mode")
 		}
 		else
 		{

R/sienaDataCreate.r

@@ -240,8 +240,11 @@ sienaDataCreate<- function(..., nodeSets=NULL, getDocumentation=FALSE)
 	if (length(dots) == 1)
 	{
 		ldots <- list(...)
-		dotsIsList <- (is.list(ldots[[1]]))
+		dotsIsList <- ((is.list(ldots[[1]])) & 
+						(! inherits((ldots[[1]]), "sienaDependent")))
 # If dotsIsList, it needs to be a list of variables
+# The second condition is to rule out the case of a single dependent network
+# given as a list of sparse matrices.
 		if (dotsIsList) 
 		{
 			dots <- as.list(substitute(...))[-1]
@@ -2396,8 +2399,9 @@ getGroupNetRanges <- function(data)
 					varmax <- max(varmax, sapply(depvar, function(x)
 											 {
 												 tmp <- x@x
+												 ifelse(length(tmp)==0,0,
 												 max(tmp[!(is.na(tmp) |
-														   tmp %in% c(10, 11))])
+														   tmp %in% c(10, 11))]))
 											 }), na.rm=TRUE)
 				}
 				else

man/RSiena-package.Rd

@@ -14,7 +14,7 @@ The models are stochastic actor-oriented models,
 described in Snijders (2017).
 
 Recent versions of the package are distributed through GitHub,   
-see \url{https://github.com/snlab-nl/rsiena/ }.
+see \url{https://github.com/snlab-nl/rsiena/}.
 }
 \details{
   The main flow of operations of this package is as follows.
@@ -44,8 +44,8 @@ see \url{https://github.com/snlab-nl/rsiena/ }.
   \tabular{ll}{
     Package: \tab RSiena\cr
     Type: \tab Package\cr
-    Version: \tab 1.4.2\cr
-    Date: \tab 2023-12-14\cr
+    Version: \tab 1.4.3\cr
+    Date: \tab 2024-01-09\cr
     Depends: \tab R (>= 3.5.0)\cr
     Imports: \tab Matrix, lattice, parallel, MASS, methods, xtable\cr
     Suggests: \tab network, tools, codetools, tcltk\cr

man/siena07.Rd

@@ -20,6 +20,7 @@ siena07(x, batch=FALSE, verbose=FALSE, silent=FALSE,
         useCluster=FALSE, nbrNodes=2,
         thetaValues = NULL,
         returnThetas = FALSE,
+        targets = NULL,
         initC=TRUE,
         clusterString=rep("localhost", nbrNodes), tt=NULL,
         parallelTesting=FALSE, clusterIter=!x$maxlike,
@@ -44,14 +45,17 @@ siena07(x, batch=FALSE, verbose=FALSE, silent=FALSE,
     dependent variable). Can only be used if \code{x$simOnly=TRUE}.}
   \item{returnThetas}{Boolean: whether to return theta values
    and generated estimation statistics of Phase 2 runs.}
+  \item{targets}{Numeric vector of length equal to the number of estimated
+    parameters, meant to supersede the targets calculated from the data set;
+    see "Details". Not for regular use.}
   \item{initC}{Boolean: set to \code{TRUE} if the simulation will use C
    routines (currently always needed). Only for use if using
    multiple processors, to ensure all copies are initialised
    correctly. Ignored otherwise, so is set to \code{TRUE} by default.}
   \item{clusterString}{Definitions of clusters. Default set up to use
    the local machine only.}
   \item{tt}{A \code{tcltk} toplevel window. Used if called from the
-   model options screen.}
+   model options screen, if \code{tcltk} is available.}
   \item{parallelTesting}{Boolean. If \code{TRUE}, sets up random numbers to
    parallel those in Siena 3.}
   \item{clusterIter}{Boolean. If \code{TRUE}, multiple processes execute
@@ -105,6 +109,14 @@ siena07(x, batch=FALSE, verbose=FALSE, silent=FALSE,
  Unless in batch mode, a tcl/tk screen is displayed to allow interruption
  and to show progress.
 
+ If \code{targets} is specified (which should be done only in special cases),
+ and provided that estimation is by the Method of Moments, the data
+ is not a multi-group data set and has exactly 2 waves,
+ and if the length of the vector \code{targets} is equal to the number
+ of estimated parameters (not counting the rate parameters estimated
+ by conditional estimation), then the vector \code{targets} supersedes the
+ targets calculated from the data set.
+
  It is necessary to check that convergence has been achieved.
  The rule of thumb is that the all t-ratios for convergence should be
  in absolute value less than 0.1 and

src/model/effects/EffectFactory.cpp

@@ -2595,7 +2595,6 @@ Effect * EffectFactory::createEffect(const EffectInfo * pEffectInfo) const
 	else if (effectName == "intercept")
 	{
 		pEffect = new InterceptEffect(pEffectInfo);
-
 	}
 	else if (effectName == "feedback")
 	{

src/model/variables/BehaviorVariable.cpp

@@ -987,11 +987,11 @@ void BehaviorVariable::accumulateDerivatives() const
 
 			if (R_IsNaN(product[effect1]))
 			{
-				Rprintf("effect 1 %d %x \n", effect1, pEffect1);
+				Rprintf("effect 1 %d \n", effect1);
 			}
 			if (R_IsNaN(product[effect2]))
 			{
-				Rprintf("effect2 %d %x \n", effect2, pEffect2);
+				Rprintf("effect2 %d \n", effect2);
 			}
 			this->pSimulation()->derivative(pEffect1->pEffectInfo(),
 				pEffect2->pEffectInfo(),
@@ -1001,7 +1001,6 @@ void BehaviorVariable::accumulateDerivatives() const
 		}
 	}
 	delete[] product;
-
 }
 
 /**