Merge pull request #93 from stocnet/develop

Version 1.4.9

DESCRIPTION

@@ -2,8 +2,8 @@ Encoding: UTF-8
 Package: RSiena
 Type: Package
 Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.4.8
-Date: 2024-02-29
+Version: 1.4.9
+Date: 2024-03-21
 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,3 +1,26 @@
+# RSiena 1.4.9
+
+2024-03-21
+
+
+## Changes in RSiena:
+
+### Effects:
+  * New effects `crossXOutAct`, `outOutDist2ActIntn`, 
+    `outOutDist2AvIntn`, `inPopOutW`.
+  * New effect group `doubleCovarNetObjective`.
+  * New effects `sameXV` and `sameXVInPop` for bipartite networks.
+  * `sameXCycle4` added for one-mode and symmetric networks.
+  * `sharedTo` gets default internal effect parameter `p=3`. 
+### Improved functionality:
+  * Function `updateSpecification` now also updates interaction effects
+    and `initialValues`.
+### Improved coding:
+  * Internal functions `numberIntn`, `numberBehIntn`, `checkVersion` 
+    defined in file `initializeFRAN.r`.
+  * The `Covariate` class and its descendants (all actor covariates)
+    now have functions `min` and `max`. 
+
 # RSiena 1.4.8
 
 2024-02-29

R/effects.r

@@ -186,6 +186,33 @@ getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE, onePeri
 					symmetric, constant=TRUE, name=varname)
 				objEffects <-  rbind(objEffects, tmp$objEff)
 				rateEffects <- rbind(rateEffects, tmp$rateEff)
+
+# I did not do the following, because it would lead to too many
+# unneeded effects. Keep it as an example of how it could be done.
+#				for (jj in seq(along = xx$cCovars))
+#				{
+#					if (jj != j)
+#					{
+#						tmp <- doubleCovarNetEff(names(xx$cCovars)[j],
+#						names(xx$cCovars)[jj], name=varname)
+#						objEffects <-  rbind(objEffects, tmp$objEff)
+#					}
+#				}
+#				for (jj in seq(along = xx$vCovars))
+#				{
+#					tmp <- doubleCovarNetEff(names(xx$cCovars)[j],
+#									names(xx$vCovars)[jj], name=varname)
+#					objEffects <-  rbind(objEffects, tmp$objEff)
+#				}
+#				for (jj in seq(along = xx$depvars))
+#				{
+#					if (types[jj] =='behavior')
+#					{
+#						tmp <- doubleCovarNetEff(names(xx$cCovars)[j],
+#									names(xx$depvars)[jj], name=varname)
+#						objEffects <-  rbind(objEffects, tmp$objEff)
+#					}
+#				}
 			}
 		}
 		for (j in seq(along=xx$depvars))
@@ -202,7 +229,7 @@ getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE, onePeri
 			}
 		}
 		for (j in seq(along=xx$vCovars))
-		{
+		{			
 			if (attr(xx$vCovars[[j]], 'nodeSet') == nodeSet)
 			{
 				tmp <- covarOneModeEff(names(xx$vCovars)[j],
@@ -1018,7 +1045,27 @@ getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE, onePeri
 						'moreThan2'),
 					covNodeset, name=varname)
 				objEffects <- rbind(objEffects, tmp$objEff)
-				rateEffects <- rbind(rateEffects, tmp$rateEff)
+				rateEffects <- rbind(rateEffects, tmp$rateEff)				
+				for (jj in seq(along = xx$cCovars))
+				{
+					if ((jj != j) & (nodeSets[1]==attr(xx$cCovars[[j]], "nodeSet"))
+									& (nodeSets[2]==attr(xx$cCovars[[jj]], "nodeSet")))
+					{
+						tmp <- doubleCovarNetEff(names(xx$cCovars)[j],
+									names(xx$cCovars)[jj], name=varname)
+						objEffects <-  rbind(objEffects, tmp$objEff)
+					}
+				}
+				for (jj in seq(along = xx$vCovars))
+				{
+					if ((nodeSets[1]==attr(xx$cCovars[[j]], "nodeSet"))
+									& (nodeSets[2]==attr(xx$vCovars[[jj]], "nodeSet")))
+					{
+						tmp <- doubleCovarNetEff(names(xx$cCovars)[j],
+									names(xx$vCovars)[jj], name=varname)
+						objEffects <-  rbind(objEffects, tmp$objEff)
+					}
+				}						
 			}
 		}
 		for (j in seq(along=xx$depvars))
@@ -1213,7 +1260,7 @@ getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE, onePeri
 				groupName=groupName, group=group,
 				netType=netType)
 		}
-
+				
 		if (constant)
 		{
 			covObjEffects <-
@@ -1245,6 +1292,18 @@ getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE, onePeri
 
 		list(objEff=covObjEffects, rateEff=covRateEffects)
 	}
+
+	##@doubleCovarNetEff internal getEffects
+	doubleCovarNetEff<- function(covarname1, covarname2, name)
+	{
+		covObjEffects <- createEffects("doubleCovarNetObjective", 
+				covarname1,covarname2,
+				name=name,
+				groupName=groupName, group=group,
+				netType=netType)
+		list(objEff=covObjEffects, rateEff=NULL)
+	}
+
 	##@covarBipartiteEff internal getEffects
 	covarBipartiteEff<- function(covarname, poszvar, moreThan2, nodesetNbr,
 		name)
@@ -1257,10 +1316,10 @@ getEffects<- function(x, nintn = 10, behNintn=4, getDocumentation=FALSE, onePeri
 					name=varname,
 					groupName=groupName, group=group,
 					netType=netType)
-			# restrict to covariates on first node set
+			# restrict to covariates on first node set, but also include sameX
 			covObjEffects <-
 				covObjEffects[covObjEffects$shortName %in%
-				c("egoX", "egoSqX", "egoLThresholdX", "egoRThresholdX",
+				c("egoX", "egoSqX", "sameX", "egoLThresholdX", "egoRThresholdX",
 					"degAbsDiffX", "degPosDiffX", "degNegDiffX",
 					"altInDist2", "totInDist2", "simEgoInDist2", 
 					"sameEgoInDist2", "sameXInPop", "diffXInPop",

R/effectsDocumentation.r

@@ -87,6 +87,7 @@ effectsDocumentation <- function(effects= NULL, type="html",
 				"dyadBipartiteObjective",
 				"dyadSecondBipartiteObjective",
 				"covarBipartiteObjective",
+				"doubleCovarNetObjective", 
 				"unspecifiedNetInteraction",
 				"bipartiteNonSymmetricObjective",
 				"bipartiteSymmetricObjective",

R/effectsMethods.r

@@ -235,15 +235,16 @@ edit.sienaEffects <- function(name, ...)
 }
 
 ##@updateSpecification Methods add specified effects from other effects object
-updateSpecification <- function(effects.to, effects.from, name.to=NULL, name.from=NULL)
+updateSpecification <- function(effects.to, effects.from,
+									effects.extra=NULL, name.to=NULL, name.from=NULL)
 {
-    if (!inherits(effects.to, "data.frame"))
+    if (!inherits(effects.to, "sienaEffects"))
     {
-        stop("effects.to is not a data.frame")
+        stop("effects.to is not an effects object")
     }
-    if (!inherits(effects.from, "data.frame"))
+    if (!inherits(effects.from, "sienaEffects"))
     {
-        stop("effects.from is not a data.frame")
+        stop("effects.from is not an effects object")
     }
     if (is.null(name.from))
     {
@@ -308,5 +309,109 @@ updateSpecification <- function(effects.to, effects.from, name.to=NULL, name.fro
     effects.to$test[use] <- prevEffects$test[correspondence][use]
     effects.to$parm[use] <- prevEffects$parm[correspondence][use]
     effects.to$randomEffects[use] <- prevEffects$randomEffects[correspondence][use]
+    effects.to$initialValue[use] <- prevEffects$initialValue[correspondence][use]
+# the above does not transfer interaction effects.
+# A lot of work is needed to get the information about the interacting effects.
+    inter <- which(prevEffects$include &
+						(prevEffects$shortName %in% c("unspInt","behUnspInt")))
+    if (length(inter) >= 1)
+	{
+	# look up the interacting main effects, and try to get information
+	# about which are the interacting effects.
+		efn1 <- prevEffects$effect1[inter]
+		efn2 <- prevEffects$effect2[inter]
+		efn3 <- prevEffects$effect3[inter]
+	# Note that some of efn3 may be 0,
+	# and effects.from$effectNumber starts counting from 1.
+	# First try to find the corresponding main effects in effects.from
+		three <- (efn3 > 0)
+		mefn1 <- match(efn1, effects.from$effectNumber)
+		mefn2 <- match(efn2, effects.from$effectNumber)
+		mefn3 <- ifelse(three, match(efn3, effects.from$effectNumber), 0)
+		effects.fr <- effects.from
+		if (any(is.na(c(mefn1,mefn2,mefn3))))
+		{
+			if (is.null(effects.extra))
+			{
+				stop("Effects object ", deparse(substitute(effects.from)),
+					" contains some interactions \n",
+					"  without information for the corresponding main effects,\n",
+					"  and there is no effects.extra.")
+			}
+			else
+			{
+				if (!inherits(effects.extra, "sienaEffects"))
+				{
+					stop("effects.extra is needed, and is not an effects object")
+				}
+	# Now try to find the corresponding main effects in effects.extra
+				version1 <- attr(effects.from, "version")
+				version2 <- attr(effects.extra, "version")
+				sameversion <- FALSE
+				if ((!is.null(version1)) & (!is.null(version2)))
+				{
+					sameversion <- (version1==version2)
+				}
+				if (!sameversion)
+				{
+					warning("RSiena versions of effects.from and effects.extra",
+						" are different;\n",
+						"  check that the effects object",
+						" generated by updateSpecification is correct.")
+				}
+				mefn1 <- match(efn1, effects.extra$effectNumber)
+				mefn2 <- match(efn2, effects.extra$effectNumber)
+				mefn3 <- ifelse(three, match(efn3, effects.extra$effectNumber), 0)
+				if (any(is.na(c(mefn1,mefn2,mefn3))))
+				{
+					stop("Effects object ", deparse(substitute(effects.from)),
+					" contains some interactions \n",
+					"  and neither this nor ", deparse(substitute(effects.extra)),
+					"\n contains information for the corresponding main effects.")
+				}
+				effects.fr <- effects.extra
+			}
+		}
+        shn1  <- effects.fr[mefn1,"shortName"]
+        shn2  <- effects.fr[mefn2,"shortName"]
+		shn3  <- rep('', length(three))
+        shn3[three]  <- effects.fr[mefn3[three],"shortName"]
+        int11  <- effects.fr[mefn1,"interaction1"]
+        int12  <- effects.fr[mefn2,"interaction1"]
+		int13  <- rep('', length(three))
+        int13[three]  <- effects.fr[mefn3[three],"interaction1"]
+        int21  <- effects.fr[mefn1,"interaction2"]
+        int22  <- effects.fr[mefn2,"interaction2"]
+		int23  <- rep('', length(three))
+        int23[three]  <- effects.fr[mefn3[three],"interaction2"]
+        nam  <- prevEffects[inter,"name"]
+        typ   <- prevEffects[inter,"type"]
+        fixx  <- prevEffects[inter,"fix"]
+        tests <- prevEffects[inter,"test"]
+        rand  <- prevEffects[inter,"randomEffects"]
+		initv <- prevEffects[inter,"initialValue"]
+        for (k in seq_along(inter)){
+			if (three[k])
+			{
+				effects.to <- includeInteraction(effects.to, shn1[k], shn2[k], shn3[k],
+					name=nam[k],
+					interaction1=c(int11[k],int12[k],int13[k]),
+					interaction2=c(int21[k],int22[k],int23[k]),
+					initialValue=initv[k],
+					type=typ[k], fix=fixx[k], test=tests[k], random=rand[k],
+					verbose=FALSE, character=TRUE)
+			}
+			else
+			{
+				effects.to <- includeInteraction(effects.to, shn1[k], shn2[k],
+					name=nam[k],
+					interaction1=c(int11[k],int21[k]),
+					interaction2=c(int12[k],int22[k]),
+					initialValue=initv[k],
+					type=typ[k], fix=fixx[k], test=tests[k], random=rand[k],
+					verbose=FALSE, character=TRUE)
+			}
+        }
+    }
     effects.to
 }

R/initializeFRAN.r

@@ -114,15 +114,7 @@ initializeFRAN <- function(z, x, data, effects, prevAns=NULL, initC,
 			stop("not valid siena data object")
 		}
 		## check the effects object
-		if (!is.null(attr(effects, "onePeriodSde")))
-		{
-			oPS <- attr(effects, "onePeriodSde")
-		}
-		else
-		{
-			oPS <- FALSE
-		}
-		defaultEffects <- getEffects(data, onePeriodSde=oPS)
+		defaultEffects <- checkVersion(data, effects)
 		if (is.null(effects))
 		{
 			cat("You specified no effects. The default effects are used.\n")
@@ -154,22 +146,6 @@ initializeFRAN <- function(z, x, data, effects, prevAns=NULL, initC,
 		{
 			stop("effects is not a data.frame")
 		}
-		effectsVersion <- attr(effects, "version")
-		if (is.null(effectsVersion))
-		{
-			differentVersions <- TRUE
-		}
-		else
-		{
-			differentVersions <- (effectsVersion != attr(defaultEffects, "version"))
-		}
-		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.
-			  Make sure the interaction effects are the same.")
-		}
 		if (x$useStdInits)
 		{
 		# The restriction to effects with shortname not unspInt or behUnspInt
@@ -2452,6 +2428,65 @@ updateTheta <- function(effects, prevAns, varName=NULL)
 	effects
 }
 
+
+##@ numberIntn siena07 sienaBayes, number of network interaction effects used for getEffects
+numberIntn <- function(myeff){
+	if (!is.null(myeff)){	
+		numnet <- length(unique(myeff$name[myeff$shortName=="density"])) # number of dependent networks
+		nintn <- sum(myeff$shortName == 'unspInt')/3 # 3 for eval - creation - endow
+	}
+	else
+	{
+		numnet <- 0
+	}	
+	ifelse((numnet <= 0), 10, nintn/numnet) # 10 is the default in getEffects
+}
+
+##@ numberIntn siena07 sienaBayes, number of behavior interaction effects used for getEffects
+numberBehIntn <- function(myeff){
+	if (!is.null(myeff)){	
+		numbeh <- length(unique(myeff$name[myeff$shortName=="linear"]))# number of dependent behaviors
+		nbehIntn <- sum(myeff$shortName == 'behUnspInt')/3 # 3 for eval - creation - endow
+	}
+	else
+	{
+		numbeh <- 0
+	}		
+	ifelse((numbeh <= 0), 4, nbehIntn/numbeh) # 4 is the default in getEffects
+}
+
+
+##@checkVersion siena07 Create default effects object and check RSiena version.
+checkVersion <- function(dat, effs){
+	if (!is.null(attr(effs, "onePeriodSde")))
+	{
+		oPS <- attr(effs, "onePeriodSde")
+	}
+	else
+	{
+		oPS <- FALSE
+	}
+	defaultEffects <- getEffects(dat, nintn=numberIntn(effs), 
+						behNintn=numberBehIntn(effs),onePeriodSde=oPS)
+	effectsVersion <- attr(effs, "version")
+	if (is.null(effectsVersion))
+	{
+		differentVersions <- TRUE
+	}
+	else
+	{
+		differentVersions <- (effectsVersion != attr(defaultEffects, "version"))
+	}
+	if ((differentVersions) & 
+		(any((effs$shortName %in% c("unspInt","behUnspInt"))&effs$include)))
+		{
+		warning("Your effects object contains interaction effects and was made
+		  using a different RSiena version. 
+		  Make sure the interaction effects are the same.")
+	}
+	defaultEffects 
+}
+
 ##@addSettingseffects siena07 add extra rate effects for settings model
 # addSettingsEffects <- function(effects, x)
 # {