Added envir(), envir<-(), and sign<-() generics and implemented their methods for term_list objects, encapsulating their implementation.

Author: krivit

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: statnet.common
-Version: 4.13.0-503
-Date: 2025-10-09
+Version: 4.13.0-504
+Date: 2025-11-28
 Title: Common R Scripts and Utilities Used by the Statnet Project Software
 Authors@R: c(
     person(c("Pavel", "N."), "Krivitsky", role=c("aut","cre"), email="pavel@statnet.org", comment=c(ORCID="0000-0002-9101-3362", affiliation="University of New South Wales")),

NAMESPACE

@@ -4,12 +4,15 @@ S3method("$",control.list)
 S3method("[",term_list)
 S3method("[",wmatrix)
 S3method("[<-",wmatrix)
+S3method("envir<-",default)
+S3method("envir<-",term_list)
 S3method("lrowweights<-",linwmatrix)
 S3method("lrowweights<-",logwmatrix)
 S3method("lrowweights<-",matrix)
 S3method("rowweights<-",linwmatrix)
 S3method("rowweights<-",logwmatrix)
 S3method("rowweights<-",matrix)
+S3method("sign<-",term_list)
 S3method(as.control.list,control.list)
 S3method(as.control.list,list)
 S3method(as.linwmatrix,linwmatrix)
@@ -27,6 +30,8 @@ S3method(compress_rows,logwmatrix)
 S3method(decompress_rows,compressed_rows_df)
 S3method(decompress_rows,wmatrix)
 S3method(diff,control.list)
+S3method(envir,default)
+S3method(envir,term_list)
 S3method(lrowweights,linwmatrix)
 S3method(lrowweights,logwmatrix)
 S3method(order,data.frame)
@@ -40,6 +45,7 @@ S3method(print,term_list)
 S3method(print,wmatrix)
 S3method(rowweights,linwmatrix)
 S3method(rowweights,logwmatrix)
+S3method(sign,term_list)
 S3method(sort,data.frame)
 S3method(split,array)
 S3method(split,matrix)
@@ -48,9 +54,11 @@ S3method(trim_env,environment)
 S3method(update,Welford)
 export("EVL<-")
 export("NVL<-")
+export("envir<-")
 export("lrowweights<-")
 export("replace<-")
 export("rowweights<-")
+export("sign<-")
 export("ult<-")
 export(.Deprecate_method)
 export(.Deprecate_once)
@@ -88,6 +96,7 @@ export(default_options)
 export(despace)
 export(empty_env)
 export(enlist)
+export(envir)
 export(eval_lhs.formula)
 export(filter_rhs.formula)
 export(fixed.pval)

R/formula.utilities.R

@@ -28,10 +28,11 @@ NULL
 #' @param object formula object to be updated or evaluated
 #' @param newterms a [`term_list`] object, or any list of terms (names
 #'   or calls) to append to the formula, or a formula whose RHS terms
-#'   will be used; its `"sign"` attribute vector can give the sign of
-#'   each term (`+1` or `-1`), and its `"env"` attribute
-#'   vector will be used to set its environment, with the first
-#'   available being used and subsequent ones producing a warning.
+#'   will be used; it can have a [sign()] method or a `"sign"`
+#'   attribute vector can give the sign of each term (`+1` or `-1`),
+#'   and its [envir()] method or `"env"` attribute vector will be used
+#'   to set its environment, with the first available being used and
+#'   subsequent ones producing a warning.
 #' @param keep.onesided if the initial formula is one-sided, keep it
 #'   whether to keep it one-sided or whether to make the initial
 #'   formula the new LHS
@@ -83,15 +84,15 @@ append_rhs.formula <- function(object = NULL, newterms, keep.onesided = FALSE, e
 
   for(i in seq_along(newterms)){
     newterm <- newterms[[i]]
-    termsign <- if(NVL(attr(newterms, "sign")[i], +1)>0) "+" else "-"
+    termsign <- if(NVL(ERRVL2(sign(newterms)[i], NULL), attr(newterms, "sign")[i], +1)>0) "+" else "-"
     if(length(object)==0){
       if(termsign == "-") newterm <- call(termsign, newterm)
       object <- as.formula(call("~", newterm))
     }else if(length(object)==3) object[[3L]]<-call(termsign,object[[3L]],newterm)
     else if(keep.onesided) object[[2L]]<-call(termsign,object[[2L]],newterm)
     else object[[3L]]<- if(termsign=="+") newterm else call(termsign,newterm)
 
-    NVL(env) <- termenv <- attr(newterms, "env")[[i]]
+    NVL(env) <- termenv <- NVL(ERRVL2(envir(newterms), NULL), attr(newterms, "env"))[[i]]
     if(!is.null(termenv) && !identical(env, termenv))
       warning(sQuote(paste0("newterms[[",i,"]]")), " has an environment that differs from the specified environment or another term's environment.")
   }
@@ -262,15 +263,16 @@ nonsimp.update.formula<-function (object, new, ..., from.new=FALSE){
 #' A helper class for list of terms in an formula
 #'
 #' Typically generated by [list_rhs.formula()], it contains, in
-#' addition to a list of [call()] or similar objects, attributes
-#' `"sign"` and `"env"`, containing, respectively a vector of
-#' signs that the terms had in the original formula and a list of
-#' environments of the formula from which the term has been
-#' extracted. Indexing and concatenation methods preserve these.
+#' addition to a list of [call()] or similar objects information about
+#' the sign of the term and the environment of the formula from which
+#' the term has been extracted, accessible and modifiable via [sign()]
+#' and [envir()] generics. Indexing and concatenation methods preserve
+#' these.
 #'
-#' @param x a list of terms or a term; a `term_list`
+#' @param x,object a list of terms or a term; a `term_list`
 #' @param sign a vector specifying the signs associated with each term (`-1` and `+1`)
 #' @param env a list specifying the environments, or NULL
+#' @param value RHS; see method documentation
 #' @param i list index
 #' @param ... additional arguments to methods
 #'
@@ -289,23 +291,24 @@ nonsimp.update.formula<-function (object, new, ..., from.new=FALSE){
 #' (l <- c(l1,l2))
 #' \dontshow{
 #' stopifnot(identical(c(unclass(l)), alist(b, c, NULL, 1)))
-#' stopifnot(identical(attr(l, "sign"), c(1,1,-1,1)))
-#' stopifnot(identical(attr(l, "env"), rep(list(e1, globalenv()), each=2)))
+#' stopifnot(identical(sign(l), c(1L,1L,-1L,1L)))
+#' stopifnot(identical(envir(l), rep(list(e1, globalenv()), each=2)))
 #' }
 #'
 #' (l <- c(l2[1], l1[2], l1[1], l1[1], l2[2]))
+#' sign(l)[3] <- -1L
 #' \dontshow{
 #' stopifnot(identical(c(unclass(l)), alist(NULL, c, b, b, 1)))
-#' stopifnot(identical(attr(l, "sign"), c(-1,1,1,1,1)))
-#' stopifnot(identical(attr(l, "env"), list(globalenv(), e1, e1, e1, globalenv())))
+#' stopifnot(identical(sign(l), c(-1L,1L,-1L,1L,1L)))
+#' stopifnot(identical(envir(l), list(globalenv(), e1, e1, e1, globalenv())))
 #' }
 #'
 #' @export
-term_list <- function(x, sign = +1, env = NULL){
+term_list <- function(x, sign = +1L, env = NULL){
   if(!is.list(x)) x <- list(x)
   if(!is.list(env)) env <- list(env)
   structure(x,
-            sign = rep(sign, length.out=length(x)),
+            sign = rep(as.integer(sign), length.out=length(x)),
             env = rep(env, length.out=length(x)),
             class = "term_list")
 }
@@ -320,38 +323,93 @@ as.term_list.term_list <- function(x, ...) x
 
 #' @rdname term_list
 #' @export
-as.term_list.default <- function(x, sign = +1, env = NULL, ...) term_list(x, sign=sign, env=env)
+as.term_list.default <- function(x, sign = +1L, env = NULL, ...) term_list(x, sign=sign, env=env)
 
 #' @rdname term_list
 #' @export
 c.term_list <- function(x, ...){
   xl <- c(list(as.term_list(x)), lapply(list(...), as.term_list))
   structure(
     c(unclass(x), ...),
-    sign = unlist(lapply(xl, attr, "sign"), use.names=FALSE),
-    env = unlist(lapply(xl, attr, "env"), recursive=FALSE, use.names=FALSE),
+    sign = unlist(lapply(xl, sign), use.names = FALSE),
+    env = unlist(lapply(xl, envir), recursive = FALSE, use.names = FALSE),
     class = "term_list"
   )
 }
 
 #' @rdname term_list
 #' @export
 `[.term_list` <- function(x, i, ...){
-  term_list(NextMethod(), sign = attr(x, "sign")[i], env = attr(x, "env")[i])
+  term_list(NextMethod(), sign = sign(x)[i], env = envir(x)[i])
 }
 
 #' @rdname term_list
 #' @export
 print.term_list <- function(x, ...){
-  signstr <- ifelse(attr(x, "sign")>=0, "+", "-")
-  envstr <- sapply(attr(x, "env"), format)
+  signstr <- ifelse(sign(x) >= 0L, "+", "-")
+  envstr <- sapply(envir(x), format)
   termstr <- lapply(lapply(x, format), paste0, collapse="\n")
 
   cat("Term List:\n")
   cat(paste(signstr, termstr, envstr, collapse="\n"))
   cat("\n")
 }
 
+#' @describeIn term_list An [`integer`] vector giving the signs of
+#'   each term in the list.
+#' @export
+sign.term_list <- function(x) attr(x, "sign")
+
+#' A generic for setting the sign of an object
+#'
+#' @param x object whose sign is to be set
+#' @param value a numeric vector specifying the sign
+#' @export
+`sign<-` <- function(x, value) UseMethod("sign<-")
+
+#' @describeIn term_list Update the signs of the terms; `value` is
+#'   recycled to the length of the list.
+#' @export
+`sign<-.term_list` <- function(x, value) structure(x, sign = rep_len(as.integer(sign(value)), length(x)))
+
+#' A generic for querying and setting an object's environment
+#'
+#' [environment()] and [environment<-()] are not generics, so it is
+#' not possible to dispatch based on the class of the object affected.
+#'
+#' When no method is available, these generics fall back to the
+#' [environment()] and [environment<-()] functions.
+#'
+#' @param object object whose environment is to be queried or set
+#' @param value typically an [`environment`], but could be any RHS
+#'   supported by the method
+#'
+#' @export
+`envir` <- function(object) UseMethod("envir")
+
+#' @noRd
+#' @export
+`envir.default` <- function(object) environment(object)
+
+#' @rdname envir
+#' @export
+`envir<-` <- function(object, value) UseMethod("envir<-")
+
+#' @noRd
+#' @export
+`envir<-.default` <- function(object, value) `environment<-`(object, value)
+
+#' @describeIn term_list A [`list`] with an element for each term in
+#'   the list, giving its environment.
+#' @export
+`envir.term_list` <- function(object) attr(object, "env")
+
+#' @describeIn term_list Update the environments of the terms; `value`
+#'   can be an environment or a list of environments, recycled to the
+#'   length of the term list.
+#' @export
+`envir<-.term_list` <- function(object, value) structure(object, env = rep_len(enlist(value), length(object)))
+
 .recurse_summation <- function(x, sign){
   if(length(x)==1)
     term_list(x, sign)
@@ -414,21 +472,21 @@ list_summands.call<-function(object){
 #'
 #' @examples
 #' stopifnot(identical(list_rhs.formula(a~b),
-#'           structure(alist(b), sign=1, env=list(globalenv()), class="term_list")))
+#'           structure(alist(b), sign=1L, env=list(globalenv()), class="term_list")))
 #' stopifnot(identical(list_rhs.formula(~b),
-#'           structure(alist(b), sign=1, env=list(globalenv()), class="term_list")))
+#'           structure(alist(b), sign=1L, env=list(globalenv()), class="term_list")))
 #' stopifnot(identical(list_rhs.formula(~b+NULL),
 #'           structure(alist(b, NULL),
-#'                     sign=c(1,1), env=rep(list(globalenv()), 2), class="term_list")))
+#'                     sign=c(1L,1L), env=rep(list(globalenv()), 2), class="term_list")))
 #' stopifnot(identical(list_rhs.formula(~-b+NULL),
 #'           structure(alist(b, NULL),
-#'                     sign=c(-1,1), env=rep(list(globalenv()), 2), class="term_list")))
+#'                     sign=c(-1L,1L), env=rep(list(globalenv()), 2), class="term_list")))
 #' stopifnot(identical(list_rhs.formula(~+b-NULL),
 #'           structure(alist(b, NULL),
-#'                     sign=c(1,-1), env=rep(list(globalenv()), 2), class="term_list")))
+#'                     sign=c(1L,-1L), env=rep(list(globalenv()), 2), class="term_list")))
 #' stopifnot(identical(list_rhs.formula(~+b-(NULL+c)),
 #'           structure(alist(b, NULL, c),
-#'                     sign=c(1,-1,-1), env=rep(list(globalenv()), 3), class="term_list")))
+#'                     sign=c(1L,-1L,-1L), env=rep(list(globalenv()), 3), class="term_list")))
 #'
 #' @export
 list_rhs.formula<-function(object){