Develop

DESCRIPTION

@@ -2,8 +2,8 @@ Encoding: UTF-8
 Package: RSiena
 Type: Package
 Title: Siena - Simulation Investigation for Empirical Network Analysis
-Version: 1.6.6
-Date: 2026-04-20
+Version: 1.6.7
+Date: 2026-05-15
 Authors@R: c(person("Tom A.B.", "Snijders", role = c("aut", "ctb"), comment = c(ORCID = "0000-0003-3157-4157")),
               person("Ruth M.", "Ripley", role = "aut"),
               person("Krists", "Boitmanis", role = c( "aut","ctb")),

NEWS.md

@@ -1,3 +1,17 @@
+2026-05-15
+
+# RSiena 1.6.7
+
+## Changes in RSiena:
+### Functionality
+  * Option `onestep` for `test_parameter(..., method="score", ...)`.
+  * Option `onestep` for `update_theta`.
+  * Name `sienaNet` added to `transformScript` as one of the names
+    to be replaced.
+  * Small comment changes in `initializeFRAN.r` and `maxlikec.r`.
+  * `make_effects` also works for `sienadata` objects older than 1.4.10
+    (due to small change in `effects.r`).
+
 2026-04-20
 
 # RSiena 1.6.6

R/Sienatest.r

@@ -42,7 +42,16 @@ test_parameter.sienaFit <- function(x, method=NULL,
 		{
 			tested <- x$test
 		}
-		score.Test(x, tested=tested)
+		if (hasArg("onestep"))
+		{
+			args <- list(...)
+			onest <- args$onestep
+		}
+		else
+		{
+			onest <- FALSE
+		}		
+		score.Test(x, tested=tested, onestep=onest)
 	}
 	else if (method=="same")
 	{
@@ -209,6 +218,7 @@ ScoreTest<- function(pp, dfra, msf, fra, test, redundant, maxlike)
 	{
 		oneStep<- -dinv2 %*% fra
 	}
+# All the following are added to z in terminateFRAN
 	list(testresult=testresult, testresulto=testresulto,
 		testresOverall=testresOverall, covMatrix=covMatrix,
 		oneStep=oneStep, dinv2= dinv2, dfra2=dfra2)
@@ -306,11 +316,12 @@ theEfNames <- function(ans){
 	res
 }
 
-##@scoreTest Calculate score tested
-score.Test <- function(x, tested=x$test)
+##@score.Test Calculate score tested
+score.Test <- function(x, tested=x$test, onestep=FALSE)
 	# use: x must be a sienaFit object;
 	# tested must be a boolean vector with length equal to the number of parameters of x,
-	# or a vector of integer numbers between 1 and x$pp.
+	# or a vector of integer numbers between 1 and x$pp;
+	# a boolean vector with all TRUE
 {
 	if ((is.numeric(tested)) || (is.integer(tested)))
 	{
@@ -319,17 +330,31 @@ score.Test <- function(x, tested=x$test)
 			stop(paste('The maximum requested coordinate is too high:',
 					max(tested)))
 		}
-		tested <- (1:x$pp) %in% tested
+		btested <- (1:x$pp) %in% tested
+	}
+	else # it should be logical
+	{
+		if (all(tested))
+		{
+			tested <- x$test
+		}
+		else if (length(tested) != x$pp)
+		{
+			stop(paste('The length of the boolean vector is ', length(tested),
+				', but it should be ', x$pp, '.', sep=''))		
+		}
+		btested <- tested
+		tested <- which(btested)
 	}
-	if (sum(tested) <= 0) stop(paste('Something should be tested, but the total requested is',
-			sum(tested)))
-	if (length(tested) != x$pp) stop('Dimensions of tested must agree')
-	if (any(tested & (!x$fix))) warning('Warning: some tested parameters were not fixed; do you know what you are doing??? \n')
+	if (sum(btested) <= 0) stop(paste('Something should be tested, but the total requested is',
+			sum(btested)))
+	if (length(btested) != x$pp) stop('Length of boolean vector tested should be', x$pp)	
+	if (any(btested & (!x$fix))) warning('Warning: some tested parameters were not fixed; do you know what you are doing??? \n')
 	fra <- colMeans(x$sf, na.rm=TRUE)
-	redundant <- (x$fix & (!tested))
-	tests <- EvaluateTestStatistic(x$maxlike, tested, redundant, x$dfra, x$msf, fra)
+	redundant <- (x$fix & (!btested))
+	tests <- EvaluateTestStatistic(x$maxlike, btested, redundant, x$dfra, x$msf, fra)
 	teststat <- tests$cvalue
-	df <- sum(tested)
+	df <- sum(btested)
 	if (df == 1)
 	{
 		onesided <- tests$oneSided
@@ -339,8 +364,18 @@ score.Test <- function(x, tested=x$test)
 		onesided <- NULL
 	}
 	pval <- 1 - pchisq(teststat, df)
-	efnames <- theEfNames(x)[tested]
-	t_x <- list(chisquare=teststat, df=df, pvalue=pval, onesided=onesided, efnames=efnames)
+	efnames <- theEfNames(x)[btested]
+	if (onestep)
+	{
+		onestepests <- x$oneStep + x$theta
+	}
+	else
+	{
+		onestepests <- NULL
+	}
+	t_x <- list(chisquare=teststat, df=df, pvalue=pval, onesided=onesided, 
+					efnames=efnames, theEfNames=theEfNames(x),
+					onestepests=onestepests)
 	class(t_x) <- "sienaTest"
 	attr(t_x, "version") <- packageDescription(pkgname, fields = "Version")
 	t_x
@@ -388,6 +423,10 @@ Wald.RSiena <- function(A, x)
 Multipar.RSiena <- function(x, tested)
 {
 	p <- length(x$theta)
+	if (any(x$requestedEffects[tested,"fix"]))
+	{
+		stop("Some parameters to be tested are fixed")
+	}
 	efnames <- theEfNames(x)[tested]
 	k <- length(tested)
 	A <- matrix(0, nrow=k, ncol=p)
@@ -430,7 +469,7 @@ testSame.RSiena <- function(x, e1, e2){
 }
 
 ##@print.sienaTest Methods
-print.sienaTest <- function(x, ...)
+print.sienaTest <- function(x,  ...)
 {
 	if (!inherits(x, "sienaTest"))
 	{
@@ -450,7 +489,7 @@ print.sienaTest <- function(x, ...)
 		', d.f. = ', x$df, '; ', sep=''))
 	if ((x$df == 1) & (!is.null(x$onesided)) & (!is.null(x$sterror)))
 	{
-		cat(paste( 'standard error of linear combination = ',
+		cat(paste( 'standard error = ',
 			format(round(x$sterror, digits=3), nsmall = 2), '; ', sep=''))
 		cat(paste('one-sided Z = ',
 			format(round(x$onesided, digits=2), nsmall = 2), '; ', sep=''))
@@ -465,5 +504,20 @@ print.sienaTest <- function(x, ...)
 		cat(paste(' p = ',
 			format(round(x$pvalue, digits=3), nsmall = 2), '. \n', sep=''))
 	}
+	if (!is.null(x$onestepests)) 
+	{
+	# this implies it comes from score.Test
+		cat('One-step estimates:\n')
+		maxname <- max(nchar(x$efnames))		
+	# pad names with trailing 0s, if necessary:
+		pad <- Vectorize(function(t){
+			while(nchar(t) < maxname){
+				t <- paste(t, " ", sep="")
+			}
+			return(t)})
+		padded <- pad(x$theEfNames)
+		onestepest <- x$onestepests
+		cat(paste(padded, sprintf("%7.3f", onestepest), '\n'), sep="")
+	}
 	invisible(x)
 }

R/TransformScript.R

@@ -70,6 +70,7 @@ transformScript <- function(theoldscript, fileName="newScript.R",
 ################################################################################
 
 namePairs <- list(c("sienaDependent", "as_dependent_rsiena"),
+   c("sienaNet", "as_dependent_rsiena"),
    c("coCovar", "as_covariate_rsiena"),
    c("varDyadCovar", "as_covariate_rsiena"),
    c("sienaCompositionChange", "as_composition_rsiena"),

R/effects.r

@@ -76,10 +76,15 @@ createEffects <- function(effectGroup, xName=NULL, yName=NULL, zName = NULL,
 DoubleAttributesChecked <- function(cova1, cova2)
 {
 	if (is.null(attr(cova1,"lowIntegers")) | is.null(attr(cova2,"lowIntegers")))
+	{	
+		(lowIntegers(cova1, attr(cova1, "centered")) && 
+						lowIntegers(cova2, attr(cova1, "centered")))
+#		stop("Please use function sienaDataCreate for RSiena version at least 1.4.10")
+	}
+	else
 	{
-		stop("Please use function sienaDataCreate for RSiena version at least 1.4.10")
+		(attr(cova1,"lowIntegers") && attr(cova2,"lowIntegers"))
 	}
-	(attr(cova1,"lowIntegers") && attr(cova2,"lowIntegers"))
 }
 
 ##@getEffects DataCreate create effects object

R/initializeFRAN.r

@@ -122,7 +122,7 @@ initializeFRAN <- function(z, x, data, effects, prevAns=NULL, initC,
 	}
 	if (!initC) ## i.e. first time round
 	{
-		if ((!inherits(data,"siena")) && (!inherits(data, 'sienadata')))
+		if ((!inherits(data,"siena")) && (!inherits(data, "sienadata")))
 		{
 			stop("not valid siena data object")
 		}
@@ -2135,11 +2135,31 @@ updateTheta <- function(effects, prevAns, varName=NULL)
 update_theta  <- function(x, ...) UseMethod("update_theta", x)
 
 ##@updateTheta.sienaEffects Copy theta values from previous fit
-update_theta.sienaEffects <- function(x, prevAns, varName=NULL, ...){
-	updateTheta(x, prevAns=prevAns, varName=varName)
+update_theta.sienaEffects <- function(x, prevAns, varName=NULL, onestep=FALSE, freed=0, r=1, ...){
+	eff <- updateTheta(x, prevAns=prevAns, varName=varName)
+	if (onestep)
+	{
+		if (is.null(prevAns$oneStep))
+		{
+			stop("prevAns does not contain any fixed-and-tested effects. Do not use onestep.")
+		}
+		effsF <- prevAns$requestedEffects 
+		requested <- which(names(prevAns$requestedEffects)=="requested")
+		if (min(freed) > 0)
+		{
+			effsF$test[freed] <- FALSE
+			effsF$fix[freed] <- FALSE
+		}
+		effsF$initialValue <- prevAns$theta + r*prevAns$oneStep
+# If this leads to an error, perhaps
+#	effsF$initialValue[!effsF$basicRate[effsF$include]]  <- prevAns$theta + r*prevAns$oneStep
+		eff[eff$effectNumber %in% effsF$effectNumber,] <- subset(effsF ,select = -requested)
+	}
+	eff	
 }
 
-##@ numberIntn siena07 sienaBayes, number of network interaction effects used for getEffects
+
+##@ numberIntn siena07 multi_siena, 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
@@ -2152,7 +2172,7 @@ numberIntn <- function(myeff){
 	ifelse((numnet <= 0), 10, nintn/numnet) # 10 is the default in getEffects
 }
 
-##@ numberIntn siena07 sienaBayes, number of behavior interaction effects used for getEffects
+##@ numberIntn siena07 multi_siena, 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 discrete behaviors

R/maxlikec.r

@@ -119,7 +119,7 @@ maxlikec <- function(z, x, data=NULL, effects=NULL,
 				sims <- 'no simulated dependent variables'
 			}
 		}
-		else ##onlyLoglik is always byGroup (sienaBayes)
+		else ##onlyLoglik is always byGroup (multi_siena)
 		{
 			ans[[1]] <- sum(sapply(anss, '[[', 1))## loglik
 			ans[[2]] <- lapply(anss, "[[", 2)