statnet.common/0000755000176200001440000000000015120320202013206 5ustar liggesusersstatnet.common/MD50000644000176200001440000001063615120320202013524 0ustar liggesusersb39da809551ce3d231dde7bfe35b8012 *DESCRIPTION 1c6b8591f19ee8b6f90fe14517f9cc94 *LICENSE 33e0e5fab7819f8245e44036f60a098f *NAMESPACE 5c82e24f8d078c813ccebf5359b47958 *NEWS 5a3a46fc89238db5d0da2a0c6966a688 *NEWS.md 02ff331b6664bcac00c427cf59b95b8e *R/Welford.R 64ca6fb2c6de07dad558840ce9cbd11e *R/cite.utilities.R a1b8f608b0712c2021ba55623bce5f70 *R/control.utilities.R 0a4750fd8bcf0544641949720f95e40d *R/deprecation_utils.R 21ca7c9c6fd5bea022246afb1e798965 *R/formula.utilities.R 5f756f626768146e06cb64905855bc0c *R/locator.R 0b0c64a194bb5bf3e8e1f9dad97f2790 *R/logspace.utils.R 2b43efebb7e48847fc27424167aeba7d *R/matrix.utils.R 943b337c58a6980b48ed1bcc0c417395 *R/mcmc-utils.R a3a63dc11bebbc4998f666bbe123c105 *R/misc.utilities.R a8506f18606289a2b45dab193ae1da08 *R/startup.utilities.R 34e9853ea51f134fca43c3eb30a44a10 *R/string.utilities.R a61dfe6084dd4d04322e68b1467f012b *R/test.utilities.R 42c8fe1d998bad437843324c52f970f3 *R/wmatrix.R 3da167167b8d1f0506951d1c11789701 *R/zzz.R a9fa015fc07009a777df25f3889096b9 *build/stage23.rdb f8e4ae485bd0e45eacbc749399ea90eb *inst/CITATION eac2f0dc76351d96bcb6567a0b2216cf *inst/templates/snctrl.R 2e15ec8e7110b4648322e9a57858aa3a *man/ERRVL.Rd 3ff13be4f722b95759d48982ef49331a *man/NVL.Rd 34de3ab4201a3cc30d57218b24164e0b *man/Welford.Rd e6c82b4ba125668093097694093c608b *man/all_identical.Rd 29c38803fcdc870baeac01edb9a270fc *man/arr_from_coo.Rd bd39d31ab0f9e15408974ab420daf507 *man/as.control.list.Rd 3ba4d22fcc4e1337155a6718b5b96629 *man/attr.Rd 0a20ec0d0489a2fefd8888af5b0325fe *man/check.control.class.Rd 3d6c6870ce2f5e58298725cd06a2fe31 *man/compress_rows.Rd 9db58d7b6e6813c0ff3c304a6ea6814b *man/compress_rows.data.frame.Rd 69e165465cfe137f151e88da25d2c547 *man/control.list.accessor.Rd 3fdf8a833fede8838180c050d6cebf86 *man/control.remap.Rd c3be3a9476df5c0d8918f01dec3ccf18 *man/deInf.Rd 4fc9c8b806ec2ba21e3817d25a3e8250 *man/default_options.Rd fa99d54928bf41d5f6406879f140fc51 *man/deprecation-utilities.Rd 9855a7006964b42b31a34bc9419328d1 *man/despace.Rd 5bcee973fe48b49b4fe18d7140ad15c1 *man/diff.control.list.Rd cca9ecb70068bacf3dba0ebd3fabf32c *man/empty_env.Rd bdf70211a0e526663f101fc58d0d70c1 *man/enlist.Rd b181bebe900f7e6c937120e00309de48 *man/envir.Rd c7885722ddb46ab915a286cae1f096e4 *man/fixed.pval.Rd c9a722d71b353491bb1c93fdc0b228fe *man/forkTimeout.Rd 5c6534a0fb8977785af483b2f8ddda1e *man/formula.utilities.Rd c4c4fd04ad2eb3987c562ee6725f7863 *man/handle.controls.Rd fb6b61e978b717e1ff51be23ad2229a6 *man/is.SPD.Rd 7ac45e4ba0e24a75670c19060379d76f *man/locate_function.Rd 106679def3d41374466723b60cd011df *man/logspace.utils.Rd e792dea716208a75b83c17fcd1ed4ae1 *man/match_names.Rd f5e91678ac7ab1b66510d0872466c1c5 *man/mcmc-utilities.Rd c4e645b96228c6f88533cf55dde327c6 *man/message_print.Rd 09be6d891bb8ce7326295bcbdce4a133 *man/modify_in_place.Rd 9a2a60603a701952ab439e01e0ab7316 *man/once.Rd b3f30472590e0c88122bae0f2fa585a7 *man/opttest.Rd 7f1cd031b808ff7070fcdba16ee1f164 *man/paste.and.Rd e99354e1d54c6d52f4991b071e15e5de *man/persistEval.Rd 55282e11ef7613fc90d2ddd222c9920c *man/print.control.list.Rd f7fd7856146524a73cabb7555f7139a2 *man/replace.Rd d12dde635ec286bc0a93b352aceb544f *man/set.control.class.Rd efe208bbd5ed5f842043bc5449c78713 *man/set_diag.Rd 065892e6d772b9cb1461df2b1532f45d *man/sign-set.Rd 740f941781269918f51d2162fddb38f1 *man/simplify_simple.Rd 23ffded04df7ba1b9d3ad5691a599368 *man/skip_if_not_checking.Rd 9e3c3a3de6d2bbf3965184810705bb7f *man/snctrl-API.Rd 3d8dbbbec4df017419dd5c970a98b582 *man/snctrl.Rd a8de5de83cb42976a7fe04718debec89 *man/sort.data.frame.Rd 23afa368f513c4b3b06fad2aa62d4ef5 *man/split.array.Rd 231b89b8e5fe9c6c7d2b3fc6a3a7c171 *man/split_len.Rd 6683e8a0e036a6c473cac5d9080acff9 *man/ssolve.Rd 9bbf055f43b721dac1b7c1077ae89537 *man/statnet.cite.Rd 893ba4da7f56b1f754582e0eebe430e1 *man/statnetStartupMessage.Rd e39f236ad480f70fa99a9619806380bd *man/sweep_cols.matrix.Rd 0f74817c83cecdcbe0cf151d10500a8d *man/term_list.Rd 06fa194617821642f5530efebcc3eaec *man/trim_env.Rd 32710045b53e1d71ddf2812bb93e4a83 *man/ult.Rd 76a21eabe2d29ac33723ebd37714cc78 *man/unused_dots_warning.Rd c3e0ca540da380a53d3d6d2f871f6932 *man/unwhich.Rd c938b8c3cb914c69179aacba6119a148 *man/vector.namesmatch.Rd 1800b201b0a82e344157fd6783f1a6b6 *man/which_top_n.Rd 3039ecb65762e63a9a0522855a1bd0be *man/wmatrix.Rd 127255b6fa25823caad8378cb7865bdd *man/wmatrix_weights.Rd ca97ae9fa36ebcb129d8b3865521dbc2 *man/xTAx.Rd b77da637750865f8daad3a1c94eddff7 *src/init.c 854fd5ba41f261259e9d48e299fc0788 *src/logspace_utils.c statnet.common/R/0000755000176200001440000000000015120242451013420 5ustar liggesusersstatnet.common/R/matrix.utils.R0000644000176200001440000003162015120241142016204 0ustar liggesusers# File R/matrix.utils.R in package statnet.common, part of the Statnet suite # of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' Test if the object is a matrix that is symmetric and positive definite #' #' @param x the object to be tested. #' @param tol the tolerance for the reciprocal condition number. #' #' @export is.SPD <- function(x, tol = .Machine$double.eps) { is.matrix(x) && nrow(x) == ncol(x) && all(x == t(x)) && rcond(x) >= tol && all(eigen(x, symmetric=TRUE, only.values=TRUE)$values > 0) } #' Common quadratic forms #' #' @name xTAx #' #' @details These are somewhat inspired by emulator::quad.form.inv() #' and others. NULL #' @describeIn xTAx Evaluate \eqn{x'Ax} for vector \eqn{x} and square #' matrix \eqn{A}. #' #' @param x a vector #' @param A a square matrix #' #' @export xTAx <- function(x, A) { drop(crossprod(crossprod(A, x), x)) } #' @describeIn xTAx Evaluate \eqn{xAx'} for vector \eqn{x} and square #' matrix \eqn{A}. #' #' @export xAxT <- function(x, A) { drop(x %*% tcrossprod(A, x)) } #' @describeIn xTAx Evaluate \eqn{x'A^{-1}x} for vector \eqn{x} and #' invertible matrix \eqn{A} using [solve()]. #' #' @export xTAx_solve <- function(x, A, ...) { drop(crossprod(x, solve(A, x, ...))) } #' @describeIn xTAx Evaluate \eqn{x'A^{-1}x} for vector \eqn{x} and #' matrix \eqn{A} using QR decomposition and confirming that \eqn{x} #' is in the span of \eqn{A} if \eqn{A} is singular; returns `rank` #' and `nullity` as attributes just in case subsequent calculations #' (e.g., hypothesis test degrees of freedom) are affected. #' #' @param tol tolerance argument passed to the relevant subroutine #' #' @export xTAx_qrsolve <- function(x, A, tol = 1e-07, ...) { Aqr <- qr(A, tol=tol, ...) nullity <- NCOL(A) - Aqr$rank if(nullity && !all(abs(crossprod(qr.Q(Aqr)[,-seq_len(Aqr$rank), drop=FALSE], x)) max(tol * e$values[1L], 0) h <- crossprod(e$vectors, x) if(!all(keep) && !all(abs(h[!keep,]) max(tol * e$values[1L], 0) tcrossprod(e$vectors[, keep, drop=FALSE] / rep(e$values[keep],each=ncol(X)), e$vectors[, keep, drop=FALSE]) } #' @rdname ssolve #' #' @export xTAx_seigen <- function(x, A, tol=sqrt(.Machine$double.eps), ...) { d <- .sqrt_inv_diag(A) dd <- rep(d, each = length(d)) * d A <- A * dd x <- x * d xTAx_eigen(x, A, tol=tol, ...) } #' @rdname ssolve #' #' @export srcond <- function(x, ..., snnd = TRUE) { if(snnd) { d <- .sqrt_inv_diag(x) dd <- rep(d, each = length(d)) * d rcond(x*dd) } else { d <- .inv_diag(x) rcond(x*d, ...) } } #' @rdname ssolve #' #' @export snearPD <- function(x, ...) { d <- abs(diag(as.matrix(x))) d[d==0] <- 1 d <- suppressWarnings(sqrt(d)) if(anyNA(d)) stop("Matrix ", sQuote("x"), " has negative elements on the diagonal.") dd <- rep(d, each = length(d)) * d x <- Matrix::nearPD(x / dd, ...) x$mat <- x$mat * dd x } #' @rdname ssolve #' #' @export xTAx_ssolve <- function(x, A, ...) { drop(crossprod(x, ssolve(A, x, ...))) } #' @rdname ssolve #' #' @examples #' x <- rnorm(2, sd=c(1,1e12)) #' x <- c(x, sum(x)) #' A <- matrix(c(1, 0, 1, #' 0, 1e24, 1e24, #' 1, 1e24, 1e24), 3, 3) #' stopifnot(isTRUE(all.equal( #' xTAx_qrssolve(x,A), #' structure(drop(x%*%sginv(A)%*%x), rank = 2L, nullity = 1L) #' ))) #' #' stopifnot(isTRUE(all.equal(c(A %*% qrssolve(A, x)), x))) #' #' x <- rnorm(2, sd=c(1,1e12)) #' x <- c(x, rnorm(1, sd=1e12)) #' A <- matrix(c(1, 0, 1, #' 0, 1e24, 1e24, #' 1, 1e24, 1e24), 3, 3) #' #' stopifnot(try(xTAx_qrssolve(x,A), silent=TRUE) == #' "Error in xTAx_qrssolve(x, A) : x is not in the span of A\n") #' #' @export xTAx_qrssolve <- function(x, A, tol = 1e-07, ...) { d <- .sqrt_inv_diag(A) dd <- rep(d, each = length(d)) * d Aqr <- qr(A*dd, tol=tol, ...) nullity <- NCOL(A) - Aqr$rank if(nullity && !all(abs(crossprod(qr.Q(Aqr)[,-seq_len(Aqr$rank), drop=FALSE], x*d))2){ stop("Arrays of 3 or more dimensions are not supported at this time.") }else{ # Matrix setNames( if(d[1L]==0) rep(NaN, d[2L]) else if(d[1L]!=length(logw)) stop("logw must have the same length as the number of rows in x") else .Call("logspace_wmeans_wrapper", x, logw, PACKAGE="statnet.common"), colnames(x) ) } } #' @describeIn logspace.utils weighted variance of `x`: `crossprod(x-lweighted.mean(x,logw)*exp(logw/2))/sum(exp(logw))` #' @export lweighted.var <- function(x, logw, onerow = NA){ E <- lweighted.mean(x, logw) if(is.null(dim(x))){ if(length(x)<2) return(onerow) x <- x - E lweighted.mean(x*x, logw) }else{ structure( if(nrow(x)<2) matrix(onerow, ncol(x), ncol(x)) else .Call("logspace_wmean2_wrapper", sweep_cols.matrix(x, E), logw, PACKAGE="statnet.common"), dimnames = list(dimnames(x)[[2]], dimnames(x)[[2]]) ) } } #' @describeIn logspace.utils weighted covariance between `x` and `y`: `crossprod(x-lweighted.mean(x,logw)*exp(logw/2), y-lweighted.mean(y,logw)*exp(logw/2))/sum(exp(logw))` #' @export lweighted.cov <- function(x, y, logw, onerow = NA){ xdim <- dim(x) E <- lweighted.mean(x, logw) x <- if(is.null(xdim)) x - E else sweep_cols.matrix(x, E) ydim <- dim(y) E <- lweighted.mean(y, logw) y <- if(is.null(ydim)) y - E else sweep_cols.matrix(y, E) if(is.null(xdim) || is.null(ydim)){ if(length(x)<2) return(onerow) o <- lweighted.mean(x*y, logw) if(!is.null(xdim)) cbind(o, deparse.level = 0) else if(!is.null(ydim)) rbind(o, deparse.level = 0) else o }else{ structure( if(nrow(x)<2) matrix(onerow, ncol(x), ncol(y)) else .Call("logspace_wxmean_wrapper", x, y, logw, PACKAGE="statnet.common"), dimnames = list(dimnames(x)[[2]], dimnames(y)[[2]]) ) } } #' @describeIn logspace.utils `log(1-exp(-x))` for `x >= 0` (a wrapper for the eponymous C macro provided by R) #' @examples #' #' x <- rexp(1000) #' stopifnot(isTRUE(all.equal(log1mexp(x), log(1-exp(-x))))) #' #' @export log1mexp <- function(x) .Call("log1mexp_wrapper", x) #' Suptract a elements of a vector from respective columns of a matrix #' #' An optimized function equivalent to \code{sweep(x, 2, STATS)} for a matrix #' \code{x}. #' #' #' @param x a numeric matrix; #' @param STATS a numeric vector whose length equals to the number of columns #' of \code{x}. #' @param disable_checks if \code{TRUE}, do not check that \code{x} is a #' numeric matrix and its number of columns matches the length of \code{STATS}; #' set in production code for a significant speed-up. #' @return A matrix of the same attributes as \code{x}. #' @examples #' #' x <- matrix(runif(1000), ncol=4) #' s <- 1:4 #' #' stopifnot(all.equal(sweep_cols.matrix(x, s), sweep(x, 2, s))) #' #' @export sweep_cols.matrix <- function(x, STATS, disable_checks=FALSE){ if(!disable_checks) if(!is.matrix(x) || mode(x)!="numeric" || ncol(x)!=length(STATS)) stop("Argument ",sQuote("x")," must be a numeric matrix variable (not an expression that evaluates to a numeric matrix).") o <- .Call("sweep2m", x, STATS, PACKAGE="statnet.common") attributes(o) <- attributes(x) o } statnet.common/R/locator.R0000644000176200001440000001232515120241142015205 0ustar liggesusers# File R/locator.R in package statnet.common, part of the Statnet suite of # packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' A simple dictionary to cache recent InitFunction lookups. #' #' @param name function name. #' @param env the environment name for the function; if `NULL`, look #' up in cache, otherwise insert or overwrite. #' #' @return A character string giving the name of the environment #' containing the function, or `NULL` if not in cache. #' @noRd locate_function_cache <- local({ cache <- list() watchlist <- character(0) # Packages being watched for unloading. pkglist <- character(0) # Current list of packages. # Reset the cache and update the list of watched packages. reset <- function(...){ pkglist <<- .packages() new <- setdiff(pkglist, watchlist) for(pkg in new){ setHook(packageEvent(pkg, "detach"), reset) setHook(packageEvent(pkg, "onUnload"), reset) } watchlist <<- c(watchlist, new) cache <<- list() } # Check if new namespaces have been added. checknew <- function(){ if(!setequal(.packages(), pkglist)) reset() } function(name, env=NULL){ checknew() if(is.null(env)){ cache[[name]] }else{ cache[[name]] <<- env } } }) #' Locate a function with a given name and return it and its environment. #' #' These functions first search the given environment, then search all #' loaded environments, including those where the function is not #' exported. If found, they return an unambiguous reference to the #' function. #' #' @name locate_function NULL #' @describeIn locate_function a low-level function returning the #' reference to the function named `name`, or `NULL` if not found. #' #' @param name a character string giving the function's name. #' @param env an [`environment`] where it should search first. #' @param ... additional arguments to the warning and error warning messages. See Details. #' #' @return If the function is found, an unevaluated call of the form #' `ENVNAME:::FUNNAME`, which can then be used to call the function #' even if it is unexported. If the environment does not have a #' name, or is `GlobalEnv`, only `FUNNAME` is returned. Otherwise, #' `NULL` is returned. #' #' @details If the initial search fails, a search using #' [getAnywhere()] is attempted, with exported ("visible") functions #' with the specified name preferred over those that are not. When #' multiple equally qualified functions are available, a warning is #' printed and an arbitrary one is returned. #' #' Because [getAnywhere()] can be slow, past searches are cached. #' #' @examples #' #' # Locate a random function in base. #' locate_function(".row_names_info") #' #' @export locate_function <- function(name, env = globalenv(), ...){ if(is.call(name)) name <- name[[1]] name <- as.character(name) # Try the given environment... if(!is.null(obj<-get0(name, mode='function', envir=env))){ env <- environment(obj) envname <- environmentName(env) # Check that environment name is not blank or globalenv(), and # that the detected environment actually contains the object. if(! NVL(envname,"") %in% c("", "R_GlobalEnv") && exists(name, mode='function', envir=env, inherits=FALSE)) return(call(":::",as.name(envname),as.name(name))) else return(as.name(name)) } # Try the cache... envname <- locate_function_cache(name) if(!is.null(envname)) return(call(":::",as.name(envname),as.name(name))) # Use getAnywhere()... #' @importFrom utils getAnywhere m <- getAnywhere(name) if(length(m$objs)){ ## Prioritise visible over not: if(any(m$visible)){ m <- lapply(unclass(m)[-1], "[", m$visible) } if(length(m$objs)>1) warning("Name ",name," matched by multiple objects; using the first one on the list.", ...) envname <- environmentName(environment(m$objs[[1]])) locate_function_cache(name, envname) return(call(":::",as.name(envname),as.name(name))) } NULL } #' @describeIn locate_function a helper function that searches for a #' function of the form `prefix.name` and produces an informative #' error message if not found. #' #' @param prefix a character string giving the prefix, so the #' searched-for function is `prefix.name`. #' @param errname a character string; if given, if the function is not #' found an error is raised, with `errname` prepended to the error #' message. #' @param call. a logical, whether the call #' (`locate_prefixed_function`) should be a part of the error #' message; defaults to `FALSE` (which is different from [stop()]'s #' default). #' #' @export locate_prefixed_function <- function(name, prefix, errname, env = globalenv(), ..., call.=FALSE){ if(is.call(name)) name <- name[[1]] name <- as.character(name) fname <- paste(prefix,name,sep=".") f <- locate_function(fname, env, ...) if(is.null(f) && !is.null(errname)) stop(errname,' ', sQuote(name), " function ", sQuote(fname), " not found.", ..., call.=call.) else f } statnet.common/R/misc.utilities.R0000644000176200001440000013373115120241142016514 0ustar liggesusers# File R/misc.utilities.R in package statnet.common, part of the Statnet suite # of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' reorder vector v into order determined by matching the names of its elements #' to a vector of names #' #' This function is deprecated in favor of [match_names()] and will be #' removed in a future release. #' #' @param v a vector (or list) with named elements, to be reorderd #' @param names a character vector of element names, corresponding to names of #' \code{v}, specificying desired orering of \code{v} #' @param errname optional, name to be reported in any error messages. default #' to \code{deparse(substitute(v))} #' @return returns \code{v}, with elements reordered #' @note earlier versions of this function did not order as advertised #' @examples #' #' test<-list(c=1,b=2,a=3) #' vector.namesmatch(test,names=c('a','c','b')) #' @export vector.namesmatch<-function(v,names,errname=NULL){ if(is.null(errname)) errname <- deparse(substitute(v)) if(is.null(names(v))){ if(length(v) == length(names)){ names(v) <- names }else stop('Length of ', sQuote(errname), ' is ', length(v), " but should be ", length(names),".") }else{ if(length(v) == length(names) && length(unique(names(v)))==length(v) && length(unique(names))==length(names) && all(sort(names(v)) == sort(names))){ namesmatch <- match(names, names(v)) v <- v[namesmatch] }else stop('Name mismatch in ', sQuote(errname),'. Specify by position.') } v } #' Construct a named vector with semantics useful for parameter vectors #' #' This is a helper function that constructs a named vector with names #' in `names` with values taken from `v` and optionally `default`, #' performing various checks. It supersedes [vector.namesmatch()]. #' #' If `v` is not named, it is required to be the same length as #' `names` and is simply given the corresponding names. If it is #' named, nonempty names are matched to the corresponding elements of #' `names`, with partial matching supported. #' #' Default values can be specified by the caller in `default` or by #' the end-user by adding an element with an empty (`""`) name in #' addition to the others. If given, the latter overrides the former. #' #' Duplicated names in `v` or `names` are resolved sequentially, #' though note the example below for caveat about partial matching. #' #' Zero-length `v` is handled as follows: #' #' * If length of `names` is empty, return `v` unchanged. #' #' * If it is not and `default` is not `NULL`, return the `default` vector. #' #' * Otherwise, raise an error. #' #' An informative error is raised under any of the following conditions: #' #' * `v` is not named but has length that differs from that of `names`. #' #' * More than one element of `v` has an empty name. #' #' * Not all elements of `names` are matched by an element of `v`, and #' no default is specified. #' #' * Not all elements of `v` are used up for elements of `names`. #' #' * There is ambiguity that [pmatch()] cannot resolve. #' #' @note At this time, passing `partial=FALSE` will use a crude #' sentinel to prevent partial matching, which in some, extremely #' improbable, circumstances might not work. #' #' @param v a vector #' @param names a character vector of element names #' @param default value to be used for elements of `names` not found in `v` #' @param partial whether partial matching is allowed #' @param errname optional, name to be reported in any error messages; #' defaults to `deparse1(substitute(v))` #' @return A named vector with names `names` (in that order). See #' Details. #' @examples #' #' # Unnamed: #' test <- as.numeric(1:3) #' stopifnot(identical( #' match_names(test, c('a', 'c', 'b')), #' c(a = 1, c = 2, b = 3) #' )) #' #' # Named, reordered: #' test <- c(c = 1, b = 2, a = 3) #' stopifnot(identical( #' match_names(test, c('a', 'c', 'b')), #' c(a = 3, c = 1, b = 2) #' )) #' #' # Default value specified by default= assigned to a #' test <- c(c = 1, b = 2) #' stopifnot(identical( #' match_names(test, c('a', 'c', 'b'), NA), #' c(a = NA, c = 1, b = 2) #' )) #' #' # Default value specified in v assigned to a and b: #' test <- c(c = 1, 2) #' stopifnot(identical( #' match_names(test, c('a', 'c', 'b')), #' c(a = 2, c = 1, b = 2) #' )) #' #' # Partial matching #' test <- c(c = 1, 2) #' stopifnot(identical( #' match_names(test, c('a', 'cab', 'b')), #' c(a = 2, cab = 1, b = 2) #' )) #' #' # Multiple matching #' test <- c(c = 1, 2, c = 3) #' stopifnot(identical( #' match_names(test, c('a', 'c', 'c')), #' c(a = 2, c = 1, c = 3) #' )) #' #' # Partial + multiple matching caveat: exact match will match first. #' test <- c(c = 1, a = 2, ca = 3) #' stopifnot(identical( #' match_names(test, c('a', 'ca', 'ca')), #' c(a = 2, ca = 3, ca = 1) #' )) #' #' @importFrom stats na.omit setNames #' @export match_names <- function(v, names, default = NULL, partial = TRUE, errname = NULL) { if(is.null(errname)) errname <- deparse1(substitute(v)) if(length(v) == 0) { if(length(names) == 0) v else if(!is.null(default)) setNames(rep_len(default, length(names)), names) else stop(sQuote(errname), ' is ', sQuote(deparse1(v)), " but should have ", length(names)," element(s):\n", paste(strwrap(paste(sQuote(names), collapse = ", "), indent = 2, exdent = 2), collapse = "\n"), call. = FALSE) }else if(is.null(names(v))){ if(length(v) == length(names)){ setNames(v, names) }else stop('Length of ', sQuote(errname), ' is ', length(v), " but should be ", length(names),":\n", paste(strwrap(paste(sQuote(names), collapse = ", "), indent = 2, exdent = 2), collapse = "\n"), call. = FALSE) }else{ blanks <- names(v) == "" if(any(blanks)){ if(sum(blanks) > 1L) stop("Named vector ", sQuote(errname), " may have at most one unnamed element.", call. = FALSE) default <- unname(v[blanks]) v <- v[!blanks] } # partial == FALSE -> add a sentinel string at the end of all strings to prevent partial matching. namesmatch <- if(partial) pmatch(names(v), names) else pmatch(paste(names(v), "\n\xf5\xdc\n"), paste(names, "\n\xf5\xdc\n")) used <- !is.na(namesmatch) found <- unwhich(na.omit(namesmatch), length(names)) if(is.null(default) && !all(found)) stop("Named vector ", sQuote(errname), " is missing values for the following elements: ", paste.and(sQuote(names[!found])), ".", call. = FALSE) if(!all(used)) stop("In named vector ", sQuote(errname), " unused or not uniquely matched elements: ", substr(s <- deparse1(v[!used]), 3, nchar(s)-1L), call. = FALSE) numeric(length(names)) |> replace(na.omit(namesmatch), v[used]) |> replace(!found, default) |> setNames(names) } } #' "Compress" a data frame. #' #' \code{compress_rows.data.frame} "compresses" a data frame, returning unique rows #' and a tally of the number of times each row is repeated, as well as a #' permutation vector that can reconstruct the original data frame. #' \code{decompress_rows.compressed_rows_df} reconstructs the original data frame. #' #' #' @param x For \code{compress_rows.data.frame} a \code{\link{data.frame}} to be #' compressed. For \code{decompress_rows.compress_rows_df} a \code{\link{list}} as #' returned by \code{compress_rows.data.frame}. #' @param ... Additional arguments, currently unused. #' @return For \code{compress_rows.data.frame}, a \code{\link{list}} with three #' elements: \item{rows }{Unique rows of \code{x}} \item{frequencies }{A vector #' of the same length as the number or rows, giving the number of times the #' corresponding row is repeated } \item{ordering}{A vector such that if #' \code{c} is the compressed data frame, \code{c$rows[c$ordering,,drop=FALSE]} #' equals the original data frame, except for row names} \item{rownames}{Row #' names of \code{x}} #' #' For \code{decompress_rows.compressed_rows_df}, the original data frame. #' @seealso \code{\link{data.frame}} #' @keywords manip #' @examples #' #' (x <- data.frame(V1=sample.int(3,30,replace=TRUE), #' V2=sample.int(2,30,replace=TRUE), #' V3=sample.int(4,30,replace=TRUE))) #' #' (c <- compress_rows(x)) #' #' stopifnot(all(decompress_rows(c)==x)) #' #' @export compress_rows.data.frame<-function(x, ...){ r <- rownames(x) o <- order.data.frame(x) x <- x[o, , drop=FALSE] firsts<-which(!duplicated(x)) freqs<-diff(c(firsts,nrow(x)+1)) x<-x[firsts, , drop=FALSE] structure(x, frequencies=freqs, ordering=order(o), rownames=r, class=c("compressed_rows_df", class(x))) # Note that x[order(x)][order(order(x))]==x. } #' @rdname compress_rows.data.frame #' @export decompress_rows.compressed_rows_df<-function(x, ...){ r <- x rn <- attr(x, "rownames") f <- attr(x, "frequencies") o <- attr(x, "ordering") out <- r[rep.int(seq_along(f), f),, drop=FALSE][o,, drop=FALSE] rownames(out) <- rn out } #' @rdname sort.data.frame #' @export order <- function(..., na.last = TRUE, decreasing = FALSE) UseMethod("order") #' @rdname sort.data.frame #' @export order.default <- function(..., na.last = TRUE, decreasing = FALSE) base::order(..., na.last=na.last, decreasing=decreasing) #' @rdname sort.data.frame #' @export order.data.frame<-function(..., na.last = TRUE, decreasing=FALSE){ x <- list(...)[[1L]] do.call(base::order,c(unname(x), na.last=na.last, decreasing=decreasing)) } #' @rdname sort.data.frame #' @export order.matrix<-function(..., na.last = TRUE, decreasing=FALSE){ x <- list(...)[[1L]] do.call(base::order,c(lapply(seq_len(ncol(x)), function(i) x[,i]), na.last=na.last, decreasing=decreasing)) } #' Implement the \code{\link{sort}} and \code{\link{order}} methods for #' \code{\link{data.frame}} and \code{\link{matrix}}, sorting it in #' lexicographic order. #' #' These function return a data frame sorted in lexcographic order or a #' permutation that will rearrange it into lexicographic order: first by the #' first column, ties broken by the second, remaining ties by the third, etc.. #' #' #' @param x A \code{\link{data.frame}} to sort. #' @param \dots Ignored for \code{sort}. For \code{order}, first argument is #' the data frame to be ordered. (This is needed for compatibility with #' \code{\link[base]{order}}.) #' @param decreasing Whether to sort in decreasing order. #' @param na.last See \code{\link[base]{order}} documentation. #' @return For \code{sort}, a data frame, sorted lexicographically. For #' \code{order}, a permutation \code{I} (of a vector \code{1:nrow(x)}) such #' that \code{x[I,,drop=FALSE]} equals \code{x} ordered lexicographically. #' @seealso \code{\link{data.frame}}, \code{\link{sort}}, \code{\link{order}}, #' \code{\link{matrix}} #' @keywords manip #' @examples #' #' data(iris) #' #' head(iris) #' #' head(order(iris)) #' #' head(sort(iris)) #' #' stopifnot(identical(sort(iris),iris[order(iris),])) #' @export sort.data.frame<-function(x, decreasing=FALSE, ...){ x[order(x,decreasing=decreasing),,drop=FALSE] } #' Convenience functions for handling [`NULL`] objects. #' #' #' @param \dots,test expressions to be tested. #' #' @name NVL #' #' @note Whenever possible, these functions use lazy evaluation, so, #' for example `NVL(1, stop("Error!"))` will never evaluate the #' [`stop`] call and will not produce an error, whereas `NVL(NULL, stop("Error!"))` would. #' #' @seealso [`NULL`], \code{\link[base]{is.null}}, \code{\link[base]{if}} #' @keywords utilities #' NULL #' @describeIn NVL #' #' Inspired by SQL function \code{NVL}, returns the first argument #' that is not \code{NULL}, or \code{NULL} if all arguments are #' `NULL`. #' #' @examples #' a <- NULL #' #' a # NULL #' NVL(a,0) # 0 #' #' b <- 1 #' #' b # 1 #' NVL(b,0) # 1 #' #' # Here, object x does not exist, but since b is not NULL, x is #' # never evaluated, so the statement finishes. #' NVL(b,x) # 1 #' #' # Also, #' NVL(NULL,1,0) # 1 #' NVL(NULL,0,1) # 0 #' NVL(NULL,NULL,0) # 0 #' NVL(NULL,NULL,NULL) # NULL #' @export NVL <- function(...){ for(e in eval(substitute(alist(...)))){ # Lazy evaluate. (See http://adv-r.had.co.nz/Computing-on-the-language.html .) x <- eval(e, parent.frame()) if(!is.null(x)) break } x } #' @describeIn NVL #' #' Inspired by Oracle SQL function `NVL2`, returns the second argument #' if the first argument is not `NULL` and the third argument if the #' first argument is `NULL`. The third argument defaults to `NULL`, so #' `NVL2(a, b)` can serve as shorthand for `(if(!is.null(a)) b)`. #' #' @param notnull expression to be returned if `test` is not `NULL`. #' @param null expression to be returned if `test` is `NULL`. #' #' @examples #' #' NVL2(a, "not null!", "null!") # "null!" #' NVL2(b, "not null!", "null!") # "not null!" #' @export NVL2 <- function(test, notnull, null = NULL){ if(is.null(test)) null else notnull } #' @describeIn NVL #' #' Inspired by Oracle SQL `NVL2` function and `magittr` \code{\%>\%} #' operator, behaves as `NVL2` but `.`s in the second argument are #' substituted with the first argument. #' #' @examples #' #' NVL3(a, "not null!", "null!") # "null!" #' NVL3(b, .+1, "null!") # 2 #' @export NVL3 <- function(test, notnull, null = NULL){ if(is.null(test)) null else{ e <- substitute(notnull) eval(do.call(substitute, list(e, list(.=test))), parent.frame()) } } #' @describeIn NVL #' #' As `NVL`, but for any objects of length 0 (*E*mpty) rather than just `NULL`. Note that if no non-zero-length arguments are given, `NULL` is returned. #' #' @examples #' #' NVL(NULL*2, 1) # numeric(0) is not NULL #' EVL(NULL*2, 1) # 1 #' #' @export EVL <- function(...){ o <- NULL for(e in eval(substitute(alist(...)))){ # Lazy evaluate. (See http://adv-r.had.co.nz/Computing-on-the-language.html .) x <- eval(e, parent.frame()) if(length(x)){ o <- x; break } } o } #' @describeIn NVL #' #' As `NVL2`, but for any objects of length 0 (*E*mpty) rather than just `NULL`. #' #' @export EVL2 <- function(test, notnull, null = NULL){ if(length(test)) notnull else null } #' @describeIn NVL #' #' As `NVL3`, but for any objects of length 0 (*E*mpty) rather than just `NULL`. #' #' @export EVL3 <- function(test, notnull, null = NULL){ if(length(test)==0) null else{ e <- substitute(notnull) eval(do.call(substitute, list(e, list(.=test))), parent.frame()) } } #' @describeIn NVL #' #' Assigning to `NVL` overwrites its first argument if that argument #' is [`NULL`]. Note that it will *always* return the right-hand-side #' of the assignment (`value`), regardless of what `x` is. #' #' @param x an object to be overwritten if [`NULL`]. #' @param value new value for `x`. #' #' @examples #' #' NVL(a) <- 2 #' a # 2 #' NVL(b) <- 2 #' b # still 1 #' @export `NVL<-` <- function(x, value){ if(is.null(x)) value else x } #' @describeIn NVL #' #' As assignment to `NVL`, but for any objects of length 0 (*E*mpty) rather than just `NULL`. #' #' @export `EVL<-` <- function(x, value){ if(length(x)) x else value } #' Attempt a series of statements and return the first one that is not an error. #' #' `ERRVL()` expects the potentially erring statements to be wrapped #' in [try()]. In addition, all expressions after the first may #' contain a `.`, which is substituted with the `try-error` object #' returned by the previous expression. #' #' @note This family of functions behave similarly to the [NVL()] and the [EVL()] families. #' #' @param \dots Expressions to be attempted; for `ERRVL()`, should be #' wrapped in [try()]. #' @return The first argument that is not an error. Stops with an #' error if all are. #' @note These functions use lazy evaluation, so, for example #' `ERRVL(1, stop("Error!"))` will never evaluate the [stop()] call #' and will not produce an error, whereas `ERRVL2(solve(0), #' stop("Error!"))` would. #' #' @seealso [try()], [inherits()], [tryCatch()] #' @keywords utilities #' @examples #' #' print(ERRVL(1,2,3)) # 1 #' print(ERRVL(try(solve(0)),2,3)) # 2 #' print(ERRVL(1, stop("Error!"))) # No error #' #' \dontrun{ #' # Error: #' print(ERRVL(try(solve(0), silent=TRUE), #' stop("Error!"))) #' } #' #' # Capture and print the try-error object: #' ERRVL(try(solve(0), silent=TRUE), #' print(paste0("Stopped with an error: ", .))) #' @export ERRVL <- function(...){ x <- NULL for(e in eval(substitute(alist(...)))){ # Lazy evaluate. (See http://adv-r.had.co.nz/Computing-on-the-language.html .) x <- eval(if(inherits(x, "try-error")) do.call(substitute, list(e, list(.=x))) else e, parent.frame()) if(!inherits(x, "try-error")) return(x) } stop(attr(x, "condition")) } #' @rdname ERRVL #' @description `ERRVL2()` does *not* require the potentially erring #' statements to be wrapped in [try()] and will, in fact, treat them #' as non-erring; it does not perform dot substitution. #' #' @examples #' #' print(ERRVL2(1,2,3)) # 1 #' print(ERRVL2(solve(0),2,3)) # 2 #' print(ERRVL2(1, stop("Error!"))) # No error #' #' @export ERRVL2 <- function(...){ for(e in eval(substitute(alist(...)))) # Lazy evaluate. (See http://adv-r.had.co.nz/Computing-on-the-language.html .) err <- tryCatch(return(eval.parent(e)), error = function(err) err) stop(err) } #' @rdname ERRVL #' @description `ERRVL3()` behaves as `ERRVL2()`, but it does perform #' dot-substitution with the [`condition`] object. #' #' @examples #' #' \dontrun{ #' # Error: #' ERRVL3(solve(0), stop("Error!")) #' } #' #' # Capture and print the error object: #' ERRVL3(solve(0), print(paste0("Stopped with an error: ", .))) #' #' # Shorthand for tryCatch(expr, error = function(e) e): #' ERRVL3(solve(0), .) #' #' @export ERRVL3 <- function(...){ err <- NULL for(e in eval(substitute(alist(...)))) # Lazy evaluate. (See http://adv-r.had.co.nz/Computing-on-the-language.html .) err <- tryCatch( return(eval.parent(if (!is.null(err)) do.call(substitute, list(e, list(. = err))) else e)), error = function(err) err) stop(err) } #' Optionally test code depending on environment variable. #' #' A convenience wrapper to run code based on whether an environment variable #' is defined. #' #' #' @param expr An expression to be evaluated only if \code{testvar} is set to a #' non-empty value. #' @param testname Optional name of the test. If given, and the test is #' skipped, will print a message to that end, including the name of the test, #' and instructions on how to enable it. #' @param testvar Environment variable name. If set to one of the #' \code{yesvals}, \code{expr} is run. Otherwise, an optional message is #' printed. #' @param yesvals A character vector of strings considered affirmative values #' for \code{testvar}. #' @param lowercase Whether to convert the value of \code{testvar} to lower #' case before comparing it to \code{yesvals}. #' @keywords utilities environment debugging #' @export opttest <- function(expr, testname=NULL, testvar="ENABLE_statnet_TESTS", yesvals=c("y","yes","t","true","1"), lowercase=TRUE){ testval <- Sys.getenv(testvar) if(lowercase) testval <- tolower(testval) if(testval %in% yesvals) eval.parent(expr) else if(!is.null(testname)) message(testname," test(s) skipped. Set ",testvar," environment variable to run.") } #' Test if all items in a vector or a list are identical. #' #' @param x a vector or a list #' @param .p a predicate function of two arguments returning a logical. #' Defaults to [identical()]. #' @param .ref integer; index of element of `x` to which all the remaining #' ones will be compared. Defaults to 1. #' @param ... additional arguments passed to `.p()` #' #' @return By default `TRUE` if all elements of `x` are identical to each #' other, `FALSE` otherwise. In the general case, `all_identical()` #' returns `TRUE` if and only if `.p()` returns `TRUE` for all the pairs #' involving the first element and the remaining elements. #' #' @seealso [identical()], [all.equal()] #' #' @examples #' #' stopifnot(!all_identical(1:3)) #' #' stopifnot(all_identical(list("a", "a", "a"))) #' #' # Using with `all.equal()` has its quirks #' # because of numerical tolerance: #' x <- seq( #' .Machine$double.eps, #' .Machine$double.eps + 1.1 * sqrt(.Machine$double.eps), #' length = 3 #' ) #' # Results with `all.equal()` are affected by ordering #' all_identical(x, all.equal) # FALSE #' all_identical(x[c(2,3,1)], all.equal) # TRUE #' # ... because `all.equal()` is intransitive #' all_identical(x[-3], all.equal) # is TRUE and #' all_identical(x[-1], all.equal) # is TRUE, but #' all_identical(x[-2], all.equal) # is FALSE #' #' @export all_identical <- function(x, .p = identical, .ref = 1L, ...){ if(length(x) == 0) return(TRUE) stopifnot(is.function(.p)) stopifnot(length(.ref) == 1) v0 <- x[[.ref]] for(v in x[- .ref]) if(!isTRUE(.p(v0, v, ...))) return(FALSE) return(TRUE) } #' Construct a logical vector with `TRUE` in specified positions. #' #' This function is basically an inverse of [`which`]. #' #' @param which a numeric vector of indices to set to `TRUE`. #' @param n total length of the output vector. #' #' @return A logical vector of length `n` whose elements listed in #' `which` are set to `TRUE`, and whose other elements are set to #' `FALSE`. #' #' @examples #' #' x <- as.logical(rbinom(10,1,0.5)) #' stopifnot(all(x == unwhich(which(x), 10))) #' @export unwhich <- function(which, n){ o <- logical(n) if(length(which)) o[which] <- TRUE o } #' Evaluate an \R expression with a hard time limit by forking a process #' #' This function uses #' #ifndef windows #' [parallel::mcparallel()], #' #endif #' #ifdef windows #' `parallel::mcparallel()`, #' #endif #' so the time limit is not #' enforced on Windows. However, unlike functions using [setTimeLimit()], the time #' limit is enforced even on native code. #' #' @param expr expression to be evaluated. #' @param timeout number of seconds to wait for the expression to #' evaluate. #' @param unsupported a character vector of length 1 specifying how to #' handle a platform that does not support #' #ifndef windows #' [parallel::mcparallel()], #' #endif #' #ifdef windows #' `parallel::mcparallel()`, #' #endif #' \describe{ #' #' \item{`"warning"` or `"message"`}{Issue a warning or a message, #' respectively, then evaluate the expression without the time limit #' enforced.} #' #' \item{`"error"`}{Stop with an error.} #' #' \item{`"silent"`}{Evaluate the expression without the time limit #' enforced, without any notice.} #' #' } Partial matching is used. #' @param onTimeout Value to be returned on time-out. #' #' @return Result of evaluating `expr` if completed, `onTimeout` #' otherwise. #' #' @note `onTimeout` can itself be an expression, so it is, for #' example, possible to stop with an error by passing #' `onTimeout=stop()`. #' #' @note Note that this function is not completely transparent: #' side-effects may behave in unexpected ways. In particular, RNG #' state will not be updated. #' #' @examples #' #' forkTimeout({Sys.sleep(1); TRUE}, 2) # TRUE #' forkTimeout({Sys.sleep(1); TRUE}, 0.5) # NULL (except on Windows) #' @export forkTimeout <- function(expr, timeout, unsupported = c("warning","error","message","silent"), onTimeout = NULL){ loadNamespace("parallel") loadNamespace("tools") env <- parent.frame() if(!exists("mcparallel", where=asNamespace("parallel"), mode="function")){ # fork() is not available on the system. unsupported <- match.arg(unsupported) warnmsg <- "Your platform (probably Windows) does not have fork() capabilities. Time limit will not be enforced." errmsg <- "Your platform (probably Windows) does not have fork() capabilities." switch(unsupported, message = message(warnmsg), warning = warning(warnmsg), error = stop(errmsg)) out <- eval(expr, env) }else{ # fork() is available on the system. child <- parallel::mcparallel(eval(expr, env), mc.interactive=NA) out <- parallel::mccollect(child, wait=FALSE, timeout=timeout) if(is.null(out)){ # Timed out with no result: kill. tools::pskill(child$pid) out <- onTimeout suppressWarnings(parallel::mccollect(child)) # Clean up. }else{ out <- out[[1L]] } } out } #' Extract or replace the *ult*imate (last) element of a vector or a list, or an element counting from the end. #' #' @param x a vector or a list. #' @param i index from the end of the list to extract or replace (where 1 is the last element, 2 is the penultimate element, etc.). #' #' @return An element of `x`. #' #' @examples #' x <- 1:5 #' (last <- ult(x)) #' (penultimate <- ult(x, 2)) # 2nd last. #' #' \dontshow{ #' stopifnot(last==5) #' stopifnot(penultimate==4) #' } #' #' @export ult <- function(x, i=1L){ x[[length(x)-i+1L]] } #' @rdname ult #' #' @param value Replacement value for the `i`th element from the end. #' #' @note Due to the way in which assigning to a function is #' implemented in R, `ult(x) <- e` may be less efficient than #' `x[[length(x)]] <- e`. #' #' @examples #' (ult(x) <- 6) #' (ult(x, 2) <- 7) # 2nd last. #' x #' #' \dontshow{ #' stopifnot(all(x == c(1:3, 7L, 6L))) #' } #' #' @export `ult<-` <- function(x, i=1L, value){ x[[length(x)-i+1L]] <- value x } #' Evaluate a function once for a given input. #' #' This is a `purrr`-style adverb that checks if a given function has #' already been called with a given configuration of arguments and #' skips it if it has. #' #' @param f A function to modify. #' @param expire_after The number of seconds since it was added to the #' database before a particular configuration is "forgotten". This #' can be used to periodically remind the user without overwhelming #' them. #' @param max_entries The number of distinct configurations to #' remember. If not `Inf`, *earliest-inserted* configurations will #' be removed from the database when capacity is exceeded. (This #' exact behavior may change in the future.) #' #' @details Each modified function instance returned by `once()` #' maintains a database of previous argument configurations. They #' are not in any way compressed, so this database may grow over #' time. Thus, this wrapper should be used with caution if arguments #' are large objects. This may be replaced with hashing in the #' future. In the meantime, you may want to set the `max_entries` #' argument to be safe. #' #' Different instances of a modified function do not share #' databases, even if the function is the same. This means that if #' you, say, modify a function within another function, the modified #' function will call once per call to the outer function. Modified #' functions defined at package level count as the same "instance", #' however. See example. #' #' @note Because the function needs to test whether a particular #' configuration of arguments have already been used, do not rely on #' lazy evaluation behaviour. #' #' @examples #' msg <- once(message) #' msg("abc") # Prints. #' msg("abc") # Silent. #' #' msg <- once(message) # Starts over. #' msg("abc") # Prints. #' #' f <- function(){ #' innermsg <- once(message) #' innermsg("efg") # Prints once per call to f(). #' innermsg("efg") # Silent. #' msg("abcd") # Prints only the first time f() is called. #' msg("abcd") # Silent. #' } #' f() # Prints "efg" and "abcd". #' f() # Prints only "efg". #' #' msg3 <- once(message, max_entries=3) #' msg3("a") # 1 remembered. #' msg3("a") # Silent. #' msg3("b") # 2 remembered. #' msg3("a") # Silent. #' msg3("c") # 3 remembered. #' msg3("a") # Silent. #' msg3("d") # "a" forgotten. #' msg3("a") # Printed. #' #' msg2s <- once(message, expire_after=2) #' msg2s("abc") # Prints. #' msg2s("abc") # Silent. #' Sys.sleep(1) #' msg2s("abc") # Silent after 1 sec. #' Sys.sleep(1.1) #' msg2s("abc") # Prints after 2.1 sec. #' #' @export once <- function(f, expire_after=Inf, max_entries=Inf){ local({ prev <- list() prev.time <- c() function(...){ # If using expire_after, expire old entries. if(is.finite(expire_after)){ expired <- Sys.time() - prev.time > expire_after prev <<- prev[!expired] prev.time <<- prev.time[!expired] } sig <- list(...) if(! list(sig)%in%prev){ prev <<- c(prev, list(sig)) prev.time <<- c(prev.time, Sys.time()) if(length(prev) > max_entries){ prev <<- prev[-1] prev.time <<- prev.time[-1] } f(...) } } }) } #' Evaluate an expression, restarting on error #' #' A pair of functions paralleling [eval()] and [evalq()] that make #' multiple attempts at evaluating an expression, retrying on error up #' to a specified number of attempts, and optionally evaluating #' another expression before restarting. #' #' @param expr an expression to be retried; note the difference #' between [eval()] and [evalq()]. #' @param retries number of retries to make; defaults to #' `"eval.retries"` option, or 5. #' @param beforeRetry if given, an expression that will be evaluated #' before each retry if the initial attempt fails; it is evaluated #' in the same environment and with the same quoting semantics as #' `expr`, but its errors are not handled. #' @param envir,enclos see [eval()]. #' @param verbose Whether to output retries. #' #' @note If `expr` returns a `"try-error"` object (returned by #' [try()]), it will be treated as an error. This behavior may #' change in the future. #' #' @return Results of evaluating `expr`, including side-effects such #' as variable assignments, if successful in `retries` retries. #' #' @examples #' x <- 0 #' persistEvalQ({if((x<-x+1)<3) stop("x < 3") else x}, #' beforeRetry = {cat("Will try incrementing...\n")}) #' #' x <- 0 #' e <- quote(if((x<-x+1)<3) stop("x < 3") else x) #' persistEval(e, #' beforeRetry = quote(cat("Will try incrementing...\n"))) #' @export persistEval <- function(expr, retries=NVL(getOption("eval.retries"), 5), beforeRetry, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), verbose=FALSE){ for(attempt in seq_len(retries)){ out <- try(eval(expr, envir=envir, enclos=enclos), silent=TRUE) #' @importFrom methods is if(!is(out, "try-error")) return(out) else{ if(!missing(beforeRetry)) eval(beforeRetry, envir=envir, enclos=enclos) if(verbose) message("Retrying: retry ", attempt, ".") } } out <- eval(expr, envir=envir, enclos=enclos) } #' @rdname persistEval #' @export persistEvalQ <- function(expr, retries=NVL(getOption("eval.retries"), 5), beforeRetry, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), verbose=FALSE){ expr <- substitute(expr) beforeRetry <- substitute(beforeRetry) envir <- force(envir) enclos <- force(enclos) persistEval(expr=expr, retries=retries, beforeRetry=beforeRetry, envir=envir, enclos=enclos, verbose=verbose) } #' Truncate values of high magnitude in a vector. #' #' @param x a numeric or integer vector. #' @param replace a number or a string `"maxint"` or `"intmax"`. #' #' @return Returns `x` with elements whose magnitudes exceed `replace` #' replaced replaced by `replace` (or its negation). If `replace` is #' `"maxint"` or `"intmax"`, `.Machine$integer.max` is used instead. #' #' `NA` and `NAN` values are preserved. #' #' @export deInf <- function(x, replace=1/.Machine$double.eps){ NVL(x) <- integer(0) if(tolower(replace) %in% c("maxint","intmax")) replace <- .Machine$integer.max ifelse(is.nan(x) | abs(x) length(d)) stop(sQuote("margin"), " must be between 1 and the dimensionality of ", sQuote("x"), ".") args <- c(list(x), rep(TRUE, length(d)), list(drop=FALSE)) ind_call <- function(ind){ args[[margin+1L]] <- ind do.call(`[`, args) } lapply(split(x = seq_len(dim(x)[margin]), f = f, drop = drop, ...), ind_call) } #' @rdname split.array #' @export split.matrix <- split.array #' Convert a list to an atomic vector if it consists solely of atomic elements of length 1. #' #' This behaviour is not dissimilar to that of [simplify2array()], but #' it offers more robust handling of empty or NULL elements and never #' promotes to a matrix or an array, making it suitable to be a column #' of a [`data.frame`]. #' #' @param x an R [`list`] to be simplified. #' @param toNA a character string indicating whether `NULL` entries #' (if `"null"`) or 0-length entries including `NULL` (if `"empty"`) #' should be replaced with `NA`s before attempting conversion; #' specifying `keep` or `FALSE` leaves them alone (typically #' preventing conversion). #' @param empty a character string indicating how empty lists should #' be handled: either `"keep"`, in which case they are unchanged or #' `"unlist"`, in which cases they are unlisted (typically to #' `NULL`). #' @param ... additional arguments passed to [unlist()]. #' #' @return an atomic vector or a list of the same length as `x`. #' @examples #' #' (x <- as.list(1:5)) #' stopifnot(identical(simplify_simple(x), 1:5)) #' #' x[3] <- list(NULL) # Put a NULL in place of 3. #' x #' stopifnot(identical(simplify_simple(x, FALSE), x)) # Can't be simplified without replacing the NULL. #' #' stopifnot(identical(simplify_simple(x), c(1L,2L,NA,4L,5L))) # NULL replaced by NA and simplified. #' #' x[[3]] <- integer(0) #' x #' stopifnot(identical(simplify_simple(x), x)) # A 0-length vector is not replaced by default, #' stopifnot(identical(simplify_simple(x, "empty"), c(1L,2L,NA,4L,5L))) # but can be. #' #' (x <- lapply(1:5, function(i) c(i,i+1L))) # Elements are vectors of equal length. #' simplify2array(x) # simplify2array() creates a matrix, #' stopifnot(identical(simplify_simple(x), x)) # but simplify_simple() returns a list. #' #' @export simplify_simple <- function(x, toNA = c("null","empty","keep"), empty = c("keep", "unlist"), ...){ if(isFALSE(toNA)) toNA <- "keep" toNA <- match.arg(toNA) empty <- match.arg(empty) if(is.atomic(x)) return(x) x <- switch(toNA, keep = x, null = lapply(x, NVL, NA), empty = lapply(x, EVL, NA)) if(length(x)==0) switch(empty, keep=x, unlist=unlist(x, recursive=FALSE, ...)) else if(all(lengths(x)==1L) && all(vapply(x, is.atomic, logical(1)))) unlist(x, recursive=FALSE, ...) else x } #' A wrapper for base::attr which defaults to exact matching. #' #' @param x,which,exact as in \code{base::attr}, but with \code{exact} #' defaulting to \code{TRUE} in this implementation #' #' @return as in \code{base::attr} #' @examples #' #' x <- list() #' attr(x, "name") <- 10 #' #' base::attr(x, "n") #' #' stopifnot(is.null(attr(x, "n"))) #' #' base::attr(x, "n", exact = TRUE) #' @export attr <- function(x, which, exact = TRUE) { base::attr(x, which, exact) } #' An error handler for [rlang::check_dots_used()] that issues a #' warning that only lists argument names. #' #' This handler parses the error message produced by #' [rlang::check_dots_used()], extracting the names of the unused #' arguments, and formats them into a more gentle warning message. It #' relies on \CRANpkg{rlang} maintaining its current format. #' #' @param e a [condition][condition] object, typically not passed by #' the end-user; see example below. #' #' @examples #' #' \dontshow{ #' o <- options(warn=1, useFancyQuotes=FALSE) #' } #' #' g <- function(b=NULL, ...){ #' invisible(force(b)) #' } #' #' f <- function(...){ #' rlang::check_dots_used(error = unused_dots_warning) #' g(...) #' } #' #' f() # OK #' f(b=2) # OK #' f(a=1, b=2, c=3) # Warning about a and c but not about b #' #' \dontshow{ #' # Test: #' stopifnot(grepl("Argument(s) 'a' and 'c' were not recognized or used. Did you mistype an argument name?", tryCatch(f(a=1, b=2, c=3), warning = function(e) e$message), fixed=TRUE)) #' options(o) #' } #' @export unused_dots_warning <- function(e){ v <- lapply(parse(text = e$body[names(e$body)=="*"]), `[[`, 2) rlang::warn(sprintf("Argument(s) %s were not recognized or used. Did you mistype an argument name?", paste.and(sQuote(v)))) } #' Modify the argument in the calling environment of the calling function #' #' This is a helper function that enables a function to modify its argument in place, emulating behavior of \CRANpkg{R6} classes and methods in the \CRANpkg{network}. It should typically be the last line of the calling function. #' #' This function determines whether the argument can be assigned to by actually attempting to do so. If this results in an error, for example, because the argument is anonymous, the error is silently ignored. #' #' It can be called multiple times by the same function to modify multiple arguments. It uses the [on.exit()] mechanism, adding to the list. Thus, if some other function calls `on.exit(..., add = FALSE)` (the default) afterwards, `modify_in_place()` will fail silently. #' #' @param x the argument (not its name!) to be modified #' @param value the value to assign (defaulting to the current value of `x`) #' #' @return `value`, invisibly, while attempting to modify `x` in place #' #' @examples #' ## A function that increments its argument in place: #' inc <- function(x){ #' modify_in_place(x, x+1) #' } #' #' y <- 1 #' z <- 1 #' #' stopifnot(inc(z) == 2) #' stopifnot(z == 2) #' stopifnot(inc(y) == 2) #' stopifnot(y == 2) #' stopifnot(inc(z) == 3) #' stopifnot(z == 3) #' #' stopifnot(inc(identity(z)) == 4) #' stopifnot(z == 3) # Not updated! #' #' ## Modify an argument that's been updated in place: #' inc2 <- function(y){ #' y <- y + 1 #' modify_in_place(y) #' } #' #' z #' stopifnot(inc2(z) == 4) #' stopifnot(z == 4) #' #' ## Decrement the first argument, increment the second: #' incdec <- function(x,y){ #' modify_in_place(x, x-1) #' modify_in_place(y, y+1) #' } #' #' c(y,z) #' incdec(y,z) #' stopifnot(all(c(y,z) == c(1,5))) #' @export modify_in_place <- function(x, value = x){ xn <- substitute(x) # Grab the name of the argument to be updated. xnn <- match.call(sys.function(-1), sys.call(-1))[[xn]] # Grab the expression that was passed into its argument. eval.parent(on.exit( # As the calling function exits... tryCatch( # try to... eval.parent(call("<-", xnn, value), n = 2), # Assign `value` to whatever `xnn` stands for in the caller's calling environment. error = identity # and do nothing if it fails. ), add = TRUE)) invisible(value) # Return invisibly. } #' Replace values in a vector according to functions #' #' This is a thin wrapper around [base::replace()] that allows `list` #' and/or `values` to be functions that are evaluated on `x` to obtain #' the replacement indices and values. The assignment version replaces #' `x`. #' #' `list` function is passed the whole vector `x` at once (not #' elementwise) and any additional arguments to `replace()`, and must #' return an indexing vector (numeric, logical, character, #' etc.). `values`/`value` function is passed `x` after subsetting it by the #' result of calling `list()`. #' #' If passing named arguments, `x`, `list`, and `values` may cause a #' conflict. #' #' @param x a vector. #' @param list either an index vector or a function (*not* a function #' name). #' @param values,value either a vector of replacement values or a function #' (*not* a function name). #' @param ... additional arguments to `list` if it is a function; #' otherwise ignored. #' #' @return A vector with the values replaced. #' #' @seealso [purrr::modify()] family of functions. #' #' @examples #' #' (x <- rnorm(10)) #' #' ### Replace elements of x that are < 1/4 with 0. #' #' # Note that this code is pipeable. #' x |> replace(`<`, 0, 1/4) #' # More readable, using lambda notation. #' x |> replace(\(.x) .x < 1/4, 0) #' # base equivalent. #' stopifnot(identical(replace(x, `<`, 0, 1/4), #' base::replace(x, x < 1/4, 0))) #' #' ### Multiply negative elements of x by 1i. #' #' x |> replace(\(.x) .x < 0, \(.x) .x * 1i) #' stopifnot(identical(replace(x, \(.x) .x < 0, \(.x) .x * 1i), #' base::replace(x, x < 0, x[x < 0] * 1i))) #' #' ### Modify the list in place. #' #' y <- x #' replace(x, `<`, 1/4) <- 0 #' x #' stopifnot(identical(x, replace(y, `<`, 0, 1/4))) #' #' @export replace <- function(x, list, values, ...) { if (is.function(list)) list <- list(x, ...) if (is.function(values)) values <- values(x[list], ...) base::replace(x, list, values) } #' @rdname replace #' @export `replace<-` <- function(x, list, ..., value) replace(x, list, value, ...) #' Wrap an object into a singleton list if not already a list #' #' This function tests whether its first argument is a list according #' to the specified criterion; if not, puts it into a list of length 1. #' #' @param x an object to be wrapped. #' #' @param test how a string or a function to decide whether an object #' counts as a list; see Details. #' #' @details `test` can be one of the following \describe{ #' #' \item{`"inherits"`}{use [`inherits`]`(x, "list")`. This will #' require the object to have class `list` and is generally the #' strictest (i.e., will wrap the most objects).} #' #' \item{`"list"`}{use [`is.list`]`(x)`. This will treat S3 objects #' based on lists as lists.} #' #' \item{`"vector"`}{use [`is.vector`]`(x)`. This will treat atomic #' vectors and [`expression`]s as lists.} #' #' \item{a function with 1 argument}{call `as.logical(test(x))`; if #' `TRUE`, the object is treated as a list; otherwise not.} #' #' } #' #' @examples #' #' data(mtcars) #' stopifnot( #' # Atomic vectors don't inherit from lists. #' identical(enlist(1:3), list(1:3)), #' # Atomic vectors are not lists internally. #' identical(enlist(1:3, "list"), list(1:3)), #' # Atomic vectors are a type of R vector. #' identical(enlist(1:3, "vector"), 1:3), #' # Data frames don't inherit from lists. #' identical(enlist(mtcars), list(mtcars)), #' # Data frames are lists internally. #' identical(enlist(mtcars, "list"), mtcars), #' # Data frames are not considered R vectors. #' identical(enlist(mtcars, "vector"), list(mtcars)) #' ) #' #' # We treat something as a "list" if its first element is odd. #' is.odd <- function(x) as.logical(x[1] %% 2) #' stopifnot( #' # 1 is a list. #' identical(enlist(1, is.odd), 1), #' # 2 is not. #' identical(enlist(2, is.odd), list(2)) #' ) #' #' @export enlist <- function(x, test = c("inherits", "vector", "list")) { if (is.character(test)) test <- switch(match.arg(test), vector = is.vector, list = is.list, inherits = function(x) inherits(x, "list")) else if (!as.logical(is.function(test))) stop(sQuote("test"), " is neither a function nor one of ", paste.and(dQuote(formals(enlist)$test), "or")) if (test(x)) x else list(x) } #' Top or bottom `n` elements of a vector #' #' Return the indices of the top or bottom `abs(n)` elements of a #' vector, with several methods for resolving ties. #' #' @param x a vector on which [rank()] can be evaluated. #' #' @param n the number of elements to attempt to select; if positive #' top `n` are selected, and if negative bottom `-n`. #' #' @param tied a string to specify how to handle multiple elements #' tied for `n`'th place: `all` or `none` to include all or none of #' the tied elements, returning a longer or shorter vector than `n`, #' respectively; `given` (the default) to use the order in which the #' elements are found in `x`. #' #' @return An integer vector of indices on `x`, with an attribute #' `attr(, "tied")` with the indicies of the tied elements (possibly #' empty). #' #' @examples #' #' (x <- rep(1:4, 1:4)) #' #' stopifnot(identical(which_top_n(x, 5, "all"), structure(4:10, tied = 4:6))) #' stopifnot(identical(which_top_n(x, 5, "none"), structure(7:10, tied = 4:6))) #' stopifnot(identical(which_top_n(x, 5), structure(6:10, tied = 4:6))) #' #' stopifnot(identical(which_top_n(x, -5, "all"), structure(1:6, tied = 4:6))) #' stopifnot(identical(which_top_n(x, -5, "none"), structure(1:3, tied = 4:6))) #' stopifnot(identical(which_top_n(x, -5), structure(1:5, tied = 4:6))) #' #' @export which_top_n <- function(x, n, tied = c("given", "all", "none")) { tied <- match.arg(tied) ordcut <- if (n > 0) function(r) (length(x) + 1 - r) <= n else function(r) r <= -n s1 <- ordcut(rank(x, ties.method = "min")) s2 <- ordcut(rank(x, ties.method = "max")) structure( which(switch(tied, given = ordcut(rank(x, ties.method = "first")), all = s1 | s2, none = s1 & s2)), tied = which(s1 != s2) ) } #' Split a list or some other `split()`-able object by lengths #' #' `split_len()` splits an object, such as a list or a data frame, #' into subsets with specified lengths. #' #' @param x an object with a [split()] method. #' @param l a vector of lengths of the subsets. #' #' @return A list with elements of the same type as `x`. #' #' @examples #' x <- 1:10 #' l <- 1:4 #' #' o <- split_len(x, l) #' #' stopifnot(identical(lengths(o), l)) #' stopifnot(identical(unlist(o), x)) #' #' @export split_len <- function(x, l) { unname(split(x, factor(rep.int(seq_along(l), l), levels = seq_along(l)))) } statnet.common/R/formula.utilities.R0000644000176200001440000005217515120241142017230 0ustar liggesusers# File R/formula.utilities.R in package statnet.common, part of the Statnet # suite of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ ################################################################### ## This file has utilities whose primary purpose is examining or ## ## manipulating ERGM formulas. ## ################################################################### #' @title Functions for Querying, Validating and Extracting from Formulas #' #' @description A suite of utilities for handling model formulas of the style used in Statnet packages. #' #' @name formula.utilities NULL #' @describeIn formula.utilities #' #' \code{append_rhs.formula} appends a list of terms to the RHS of a #' formula. If the formula is one-sided, the RHS becomes the LHS, if #' \code{keep.onesided==FALSE} (the default). #' #' @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; 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 #' @param env an environment for the new formula, if `object` is #' `NULL` #' @param \dots Additional arguments. Currently unused. #' @return \code{append_rhs.formula} each return an updated formula #' object; if `object` is `NULL` (the default), a one-sided formula #' containing only the terms in `newterms` will be returned. #' @examples #' #' ## append_rhs.formula #' #' (f1 <- append_rhs.formula(y~x,list(as.name("z1"),as.name("z2")))) #' (f2 <- append_rhs.formula(~y,list(as.name("z")))) #' (f3 <- append_rhs.formula(~y+x,structure(list(as.name("z")),sign=-1))) #' (f4 <- append_rhs.formula(~y,list(as.name("z")),TRUE)) #' (f5 <- append_rhs.formula(y~x,~z1-z2)) #' (f6 <- append_rhs.formula(NULL,list(as.name("z")))) #' (f7 <- append_rhs.formula(NULL,structure(list(as.name("z")),sign=-1))) #' #' fe <- ~z2+z3 #' environment(fe) <- new.env() #' (f8 <- append_rhs.formula(NULL, fe)) # OK #' (f9 <- append_rhs.formula(y~x, fe)) # Warning #' (f10 <- append_rhs.formula(y~x, fe, env=NULL)) # No warning, environment from fe. #' (f11 <- append_rhs.formula(fe, ~z1)) # Warning, environment from fe #' #' \dontshow{ #' stopifnot(f1 == (y~x+z1+z2)) #' stopifnot(f2 == (y~z)) #' stopifnot(f3 == (y+x~-z)) #' stopifnot(f4 == (~y+z)) #' stopifnot(f5 == (y~x+z1-z2)) #' stopifnot(f6 == (~z)) #' stopifnot(f7 == (~-z)) #' stopifnot(f8 == (~z2+z3), identical(environment(f8), environment(fe))) #' stopifnot(f9 == (y~x+z2+z3), identical(environment(f9), globalenv())) #' stopifnot(f10 == (y~x+z2+z3), identical(environment(f10), environment(fe))) #' stopifnot(f11 == (z2+z3~z1), identical(environment(f11), environment(fe))) #' } #' #' @export append_rhs.formula <- function(object = NULL, newterms, keep.onesided = FALSE, env = if(is.null(object)) NULL else environment(object)){ force(env) if(is.null(object)) keep.onesided <- TRUE if(inherits(newterms,"formula")) newterms <- list_rhs.formula(newterms) for(i in seq_along(newterms)){ newterm <- newterms[[i]] 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 <- 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.") } environment(object) <- env object } #' @describeIn formula.utilities #' #' \code{append.rhs.formula} has been renamed to \code{append_rhs.formula}. #' @export append.rhs.formula<-function(object,newterms,keep.onesided=FALSE){ .Deprecate_once("append_rhs.formula") append_rhs.formula(object,newterms,keep.onesided) } #' @describeIn formula.utilities #' #' \code{filter_rhs.formula} filters through the terms in the RHS of a #' formula, returning a formula without the terms for which function #' `f(term, ...)` is `FALSE`. Terms inside another term (e.g., #' parentheses or an operator other than + or -) will be unaffected. #' #' #' @examples #' ## filter_rhs.formula #' (f1 <- filter_rhs.formula(~a-b+c, `!=`, "a")) #' (f2 <- filter_rhs.formula(~-a+b-c, `!=`, "a")) #' (f3 <- filter_rhs.formula(~a-b+c, `!=`, "b")) #' (f4 <- filter_rhs.formula(~-a+b-c, `!=`, "b")) #' (f5 <- filter_rhs.formula(~a-b+c, `!=`, "c")) #' (f6 <- filter_rhs.formula(~-a+b-c, `!=`, "c")) #' (f7 <- filter_rhs.formula(~c-a+b-c(a), #' function(x) (if(is.call(x)) x[[1]] else x)!="c")) #' #' #' \dontshow{ #' stopifnot(f1 == ~-b+c) #' stopifnot(f2 == ~b-c) #' stopifnot(f3 == ~a+c) #' stopifnot(f4 == ~-a-c) #' stopifnot(f5 == ~a-b) #' stopifnot(f6 == ~-a+b) #' stopifnot(f7 == ~-a+b) #' } #' #' @param f a function whose first argument is the term and whose #' additional arguments are forwarded from `...` that returns either #' `TRUE` or `FALSE`, for whether that term should be kept. #' @export filter_rhs.formula <- function(object, f, ...){ rhs <- ult(object) SnD <- function(x){ if(!f(x, ...)) return(NULL) if(is(x, "call")){ op <- x[[1L]] if(! as.character(op)%in%c("+","-")) return(x) else if(length(x)==2){ arg <- SnD(x[[2L]]) if(is.null(arg)) return(NULL) else return(call(as.character(op), arg)) }else if(length(x)==3){ arg1 <- SnD(x[[2L]]) arg2 <- SnD(x[[3L]]) if(is.null(arg2)) return(arg1) else if(is.null(arg1)){ if(as.character(op)=="+") return(arg2) else return(call(as.character(op), arg2)) } else return(call(as.character(op), arg1, arg2)) }else stop("Unsupported type of formula passed.") }else return(x) } rhs <- SnD(rhs) ult(object) <- rhs object } #' @describeIn formula.utilities #' #' \code{nonsimp_update.formula} is a reimplementation of #' \code{\link{update.formula}} that does not simplify. Note that the #' resulting formula's environment is set as follows. If #' \code{from.new==FALSE}, it is set to that of object. Otherwise, a new #' sub-environment of object, containing, in addition, variables in new listed #' in from.new (if a character vector) or all of new (if TRUE). #' #' @param new new formula to be used in updating #' @param from.new logical or character vector of variable names. controls how #' environment of formula gets updated. #' @return #' \code{nonsimp_update.formula} each return an #' updated formula object #' @importFrom stats as.formula #' @export nonsimp_update.formula<-function (object, new, ..., from.new=FALSE){ old.lhs <- if(length(object)==2) NULL else object[[2L]] old.rhs <- if(length(object)==2) object[[2L]] else object[[3L]] new.lhs <- if(length(new)==2) NULL else new[[2L]] new.rhs <- if(length(new)==2) new[[2L]] else new[[3L]] sub.dot <- function(c, dot){ if(is.name(c) && c==".") dot # If it's a dot, return substitute. else if(is.call(c)) as.call(c(list(c[[1L]]), lapply(c[-1], sub.dot, dot))) # If it's a call, construct a call consisting of the call and each of the arguments with the substitution performed, recursively. else c # If it's anything else, just return it. } deparen<- function(c, ops = c("+","*")){ if(is.call(c)){ if(as.character(c[[1L]]) %in% ops){ op <- as.character(c[[1L]]) if(length(c)==2 && is.call(c[[2L]]) && c[[2L]][[1L]]==op) return(deparen(c[[2L]], ops)) else if(length(c)==3 && is.call(c[[3L]]) && c[[3L]][[1L]]==op){ if(length(c[[3L]])==3) return(call(op, call(op, deparen(c[[2L]],ops), deparen(c[[3L]][[2L]],ops)), deparen(c[[3L]][[3L]],ops))) else return(call(op, deparen(c[[2L]],ops), deparen(c[[3L]][[2L]],ops))) } } return(as.call(c(list(c[[1L]]), lapply(c[-1], deparen, ops)))) # If it's a non-reducible call, construct a call consisting of the call and each of the arguments with the substitution performed, recursively. }else return(c) } # This is using some argument alchemy to handle the situation in # which object is one-sided but new is two sided with a dot in the # LHS. quote(expr=) creates a missing argument object that gets # substituted in place of a dot. The next statement then checks if # the resulting LHS *is* a missing object (as it is when the # arguments are ~a and .~.) removes the LHS if it is. out <- if(length(new)==2) call("~", deparen(sub.dot(new.rhs, old.rhs))) else if(length(object)==2) call("~", deparen(sub.dot(new.lhs, quote(expr=))), deparen(sub.dot(new.rhs, old.rhs))) else call("~", deparen(sub.dot(new.lhs, old.lhs)), deparen(sub.dot(new.rhs, old.rhs))) if(identical(out[[2]], quote(expr=))) out <- out[-2] # a new sub-environment for the formula, containing both # the variables from the old formula and the new. if(identical(from.new,FALSE)){ # The new formula will use the environment of the original formula (the default). e <- environment(object) }else{ # Create a sub-environment also containing variables from environment of new. e <- new.env(parent=environment(object)) if(identical(from.new,TRUE)) from.new <- setdiff(ls(pos=environment(new), all.names=TRUE), "...") # If TRUE, copy all of them but the dots (dangerous!). for(name in from.new) assign(name, get(name, pos=environment(new)), pos=e) } as.formula(out, env = e) } #' @describeIn formula.utilities #' #' \code{nonsimp.update.formula} has been renamed to \code{nonsimp_update.formula}. #' @export nonsimp.update.formula<-function (object, new, ..., from.new=FALSE){ .Deprecate_once("nonsimp_update.formula") nonsimp_update.formula(object, new, ..., from.new=from.new) } #' 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 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,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 #' #' @seealso [list_rhs.formula()], [list_summands.call()] #' #' @examples #' #' e1 <- new.env() #' f1 <- a~b+c #' environment(f1) <- e1 #' f2 <- ~-NULL+1 #' #' (l1 <- list_rhs.formula(f1)) #' (l2 <- list_rhs.formula(f2)) #' #' (l <- c(l1,l2)) #' \dontshow{ #' stopifnot(identical(c(unclass(l)), alist(b, c, NULL, 1))) #' 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(sign(l), c(-1L,1L,-1L,1L,1L))) #' stopifnot(identical(envir(l), list(globalenv(), e1, e1, e1, globalenv()))) #' } #' #' @export 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(as.integer(sign), length.out=length(x)), env = rep(env, length.out=length(x)), class = "term_list") } #' @rdname term_list #' @export as.term_list <- function(x, ...) UseMethod("as.term_list") #' @rdname term_list #' @export as.term_list.term_list <- function(x, ...) x #' @rdname term_list #' @export 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, 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 = sign(x)[i], env = envir(x)[i]) } #' @rdname term_list #' @export print.term_list <- function(x, ...){ 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) else if(length(x)==2 && x[[1L]]=="+") .recurse_summation(x[[2L]],sign) else if(length(x)==2 && x[[1L]]=="-") .recurse_summation(x[[2L]],-sign) else if(length(x)==3 && x[[1L]]=="+") c(.recurse_summation(x[[2L]],sign), .recurse_summation(x[[3L]],sign)) else if(length(x)==3 && x[[1L]]=="-") c(.recurse_summation(x[[2L]],sign), .recurse_summation(x[[3L]],-sign)) else if(length(x[[1]]) && x[[1L]]=="(") .recurse_summation(x[[2L]], sign) else term_list(x, sign) } #' @describeIn formula.utilities #' #' \code{term.list.formula} is an older version of \code{list_rhs.formula} that required the RHS call, rather than the formula itself. #' #' @param rhs,sign Arguments to the deprecated `term.list.formula`. #' #' @export term.list.formula<-function(rhs, sign=+1){ .Deprecate_once("list_rhs.formula") .recurse_summation(rhs, sign) } #' @describeIn formula.utilities #' #' \code{list_summands.call}, given an unevaluated call or expression #' containing the sum of one or more terms, returns an object of class [`term_list`] with the #' terms being summed, handling \code{+} and \code{-} operators and #' parentheses, and keeping track of whether a term has a plus or a #' minus sign. #' #' @return \code{list_summands.call} returns an object of type #' [`term_list`]; its `"env"` attribute is set to a list of #' `NULL`s, however. #' #' @export list_summands.call<-function(object){ .recurse_summation(object, sign=+1) } #' @describeIn formula.utilities #' #' \code{list_rhs.formula} returns an object of type [`term_list`], #' containing terms in a given formula, handling \code{+} and \code{-} #' operators and parentheses, and keeping track of whether a term has #' a plus or a minus sign. #' #' @return #' \code{list_rhs.formula} returns an object of type [`term_list`]. #' #' @examples #' stopifnot(identical(list_rhs.formula(a~b), #' structure(alist(b), sign=1L, env=list(globalenv()), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~b), #' structure(alist(b), sign=1L, env=list(globalenv()), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~b+NULL), #' structure(alist(b, NULL), #' 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(-1L,1L), env=rep(list(globalenv()), 2), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~+b-NULL), #' structure(alist(b, NULL), #' 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(1L,-1L,-1L), env=rep(list(globalenv()), 3), class="term_list"))) #' #' @export list_rhs.formula<-function(object){ if (!is(object, "formula")) stop("Invalid formula of class ",sQuote(class(object)),".") o <- .recurse_summation(ult(object), sign=+1) structure(o, env = rep(list(environment(object)), length(o))) } #' @describeIn formula.utilities #' #' \code{eval_lhs.formula} extracts the LHS of a formula, evaluates it in the formula's environment, and returns the result. #' #' @return #' \code{eval_lhs.formula} an object of whatever type the LHS evaluates to. #' @examples #' ## eval_lhs.formula #' #' (result <- eval_lhs.formula((2+2)~1)) #' #' stopifnot(identical(result,4)) #' @export eval_lhs.formula <- function(object){ if (!is(object, "formula")) stop("Invalid formula of class ",sQuote(class(object)),".") if(length(object)<3) stop("Formula given is one-sided.") eval(object[[2L]],envir=environment(object)) } #' Make a copy of an environment with just the selected objects. #' #' @param object An [`environment`] or an object with #' [`environment()`] and `environment()<-` methods. #' @param ... Additional arguments, passed on to lower-level methods. #' #' @param keep A character vector giving names of variables in the #' environment (including its ancestors) to copy over, defaulting to #' dropping all. Variables that cannot be resolved are silently #' ignored. #' #' @return An object of the same type as `object`, with updated #' environment. If `keep` is empty, the environment is [baseenv()]; #' if not empty, it's a new environment with [baseenv()] as parent. #' @export trim_env <- function(object, keep=NULL, ...){ UseMethod("trim_env") } #' @describeIn trim_env A method for environment objects. #' @export trim_env.environment <- function(object, keep=NULL, ...){ # NB: The parent should be baseenv(), not emptyenv(), because :: and # ::: are defined in baseenv(), so PKG:::NAME calls won't work. e <- if(length(keep)) new.env(parent=baseenv()) else baseenv() for(vn in keep){ try(assign(vn, get(vn, envir=object), envir=e), silent=TRUE) } e } #' @describeIn trim_env Default method, for objects such as [`formula`] and [`function`] that have [`environment()`] and `environment()<-` methods. #' @export trim_env.default <- function(object, keep=NULL, ...){ environment(object) <- trim_env(environment(object), keep, ...) object } #' Replace an object's environment with a simple, static environment. #' #' @param object An object with the `environment()<-` method. #' #' @return An object of the same type as `object`, with updated environment. #' #' @examples #' f <- y~x #' environment(f) # GlobalEnv #' #' environment(empty_env(f)) # EmptyEnv #' #' \dontshow{ #' stopifnot(identical(environment(empty_env(f)), emptyenv())) #' } #' @export empty_env <- function(object){ environment(object) <- emptyenv() object } #' @rdname empty_env #' @examples #' #' environment(base_env(f)) # base package environment #' #' \dontshow{ #' stopifnot(identical(environment(base_env(f)), baseenv())) #' } #' @export base_env <- function(object){ environment(object) <- baseenv() object } statnet.common/R/Welford.R0000644000176200001440000000744615120241142015154 0ustar liggesusers# File R/Welford.R in package statnet.common, part of the Statnet suite of # packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' A Welford accumulator for sample mean and variance #' #' A simple class for keeping track of the running mean and the sum of squared deviations from the mean for a vector. #' #' @param dn,means,vars initialization of the Welford object: if `means` #' and `vars` are given, they are treated as the running means and #' variances, and `dn` is their associated sample size, and if not, #' `dn` is the dimension of the vector (with sample size 0). #' #' @return an object of type `Welford`: a list with four elements: #' #' 1. `n`: Running number of observations #' 2. `means`: Running mean for each variable #' 3. `SSDs`: Running sum of squared deviations from the mean for each variable #' 4. `vars`: Running variance of each variable #' #' @examples #' #' X <- matrix(rnorm(200), 20, 10) #' w0 <- Welford(10) #' #' w <- update(w0, X) #' stopifnot(isTRUE(all.equal(w$means, colMeans(X)))) #' stopifnot(isTRUE(all.equal(w$vars, apply(X,2,var)))) #' #' w <- update(w0, X[1:12,]) #' w <- update(w, X[13:20,]) #' stopifnot(isTRUE(all.equal(w$means, colMeans(X)))) #' stopifnot(isTRUE(all.equal(w$vars, apply(X,2,var)))) #' #' w <- Welford(12, colMeans(X[1:12,]), apply(X[1:12,], 2, var)) #' w <- update(w, X[13:20,]) #' stopifnot(isTRUE(all.equal(w$means, colMeans(X)))) #' stopifnot(isTRUE(all.equal(w$vars, apply(X,2,var)))) #' #' @export Welford <- function(dn, means, vars){ switch(1 + missing(means) + missing(vars), structure(list(n = dn, means = means, SSDs = vars*(dn-1), vars = vars), class = "Welford"), # Both means and vars -> dn is sample size. stop("Either both ", sQuote("mean"), " and ", sQuote("var"), " should be passed or neither."), # One of the two -> error. structure(list(n = 0L, means = numeric(dn), SSDs = numeric(dn), vars = numeric(dn)), class = "Welford") # Neither means nor vars -> dn is dimension. ) } #' @describeIn Welford Update a `Welford` object with new #' data. #' #' @param object a `Welford` object. #' @param newdata either a numeric vector of length `d`, a numeric #' matrix with `d` columns for a group update, or another `Welford` #' object with the same `d`. #' @param ... additional arguments to methods. #' #' @export update.Welford <- function(object, newdata, ...){ l <- object x <- newdata if(is(x, "Welford")){ # Multielement update: newdata is a Welford object. if(length(l[[2]]) != length(x[[2]])) stop(sQuote("newdata"), " must have the same dimension as ", sQuote("object")) l.n <- l[[1]]; x.n <- x[[1]]; l[[1]] <- n.new <- l.n + x.n l.m <- l[[2]]; x.m <- x[[2]] d <- x.m - l.m # In our application, n for x and n for l are going to be similar, so we use weighted average. l[[2]] <- (l.n*l.m + x.n*x.m)/n.new l[[3]] <- l[[3]] + x[[3]] + d*d*l.n*x.n/n.new }else if(is.numeric(x)){ # Either a vector or a matrix with statistics in rows. xm <- rbind(x) if(length(l[[2]]) != ncol(xm)) stop(sQuote("newdata"), " must have the same dimension as ", sQuote("object")) for(r in seq_len(nrow(xm))){ x <- xm[r,] n.prev <- l[[1]] l[[1]] <- n.new <- n.prev + 1 m.prev <- l[[2]] l[[2]] <- m.new <- m.prev + (x-m.prev)/n.new l[[3]] <- l[[3]] + (x-m.prev)*(x-m.new) } }else stop(sQuote("newdata"), " must be either another Welford object, a scalar of correct length, or a matrix with statistics in rows.") l[[4]] <- l[[3]]/(l[[1]]-1) l } statnet.common/R/mcmc-utils.R0000644000176200001440000000771415120241142015625 0ustar liggesusers# File R/mcmc-utils.R in package statnet.common, part of the Statnet suite of # packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' @name mcmc-utilities #' @title Utility operations for [`mcmc.list`][coda::mcmc.list] objects #' #' @description \code{colMeans.mcmc.list} is a "method" for (non-generic) [colMeans()] applicable to [`mcmc.list`][coda::mcmc.list] objects. #' #' @param x a [`mcmc.list`][coda::mcmc.list] object. #' @param \dots additional arguments to the functions evaluated on each chain. #' @return \code{colMeans.mcmc} returns a vector with length equal to #' the number of mcmc chains in \code{x} with the mean value for #' each chain. #' #' @details These implementations should be equivalent (within #' numerical error) to the same function being called on #' `as.matrix(x)`, while avoiding construction of the large matrix. #' #' @seealso [`mcmc.list`][coda::mcmc.list] #' #' [colMeans()] #' @examples #' data(line, package="coda") #' colMeans(as.matrix(line)) # also coda #' colMeans.mcmc.list(line) # "Method" #' \dontshow{ #' stopifnot(isTRUE(all.equal(colMeans(as.matrix(line)),colMeans.mcmc.list(line)))) #' } #' @export colMeans.mcmc.list colMeans.mcmc.list <- function(x,...){ nchain <- length(x) Reduce(`+`, lapply(x, colMeans, ...)) / nchain } #' @rdname mcmc-utilities #' #' @description \code{var.mcmc.list} is a "method" for (non-generic) #' [var()] applicable to [`mcmc.list`][coda::mcmc.list] objects. Since MCMC chains #' are assumed to all be sampling from the same underlying #' distribution, their pooled mean is used. #' #' @seealso [var()] #' @examples #' data(line, package="coda") #' var(as.matrix(line)) # coda #' var.mcmc.list(line) # "Method" #' \dontshow{ #' stopifnot(isTRUE(all.equal(var.mcmc.list(line), var(as.matrix(line))))) #' } #' @importFrom stats var #' @export var.mcmc.list var.mcmc.list <- function(x, ...){ nchain <- length(x) niter <- NROW(x[[1]]) SSW <- Reduce(`+`, lapply(x, var, ...)) * (niter-1) SSB <- if(nchain > 1) var(t(sapply(x, colMeans, ...))) * niter else 0 (SSW+SSB) / (niter*nchain-1) } #' @rdname mcmc-utilities #' #' @description \code{sweep.mcmc.list} is a "method" for (non-generic) #' [sweep()] applicable to [`mcmc.list`][coda::mcmc.list] objects. #' #' @param STATS,FUN,check.margin See help for [sweep()]. #' @return \code{sweep.mcmc.list} returns an appropriately modified #' version of \code{x} #' @seealso [sweep()] #' @examples #' data(line, package="coda") #' colMeans.mcmc.list(line)-1:3 #' colMeans.mcmc.list(sweep.mcmc.list(line, 1:3)) #' \dontshow{ #' stopifnot(isTRUE(all.equal(colMeans.mcmc.list(sweep.mcmc.list(line, 1:3)), colMeans.mcmc.list(line)-1:3))) #' } #' @export sweep.mcmc.list sweep.mcmc.list<-function(x, STATS, FUN="-", check.margin=TRUE, ...){ for(chain in seq_along(x)){ x[[chain]] <- sweep(x[[chain]], 2, STATS, FUN, check.margin, ...) } x } #' @rdname mcmc-utilities #' #' @description \code{lapply.mcmc.list} is a "method" for (non-generic) #' [lapply()] applicable to [`mcmc.list`][coda::mcmc.list] objects. #' #' @param X An [`mcmc.list`][coda::mcmc.list] object. #' @return `lapply.mcmc.list` returns an [`mcmc.list`][coda::mcmc.list] each of #' whose chains had been passed through `FUN`. #' @seealso [lapply()] #' @examples #' data(line, package="coda") #' colMeans.mcmc.list(line)[c(2,3,1)] #' colMeans.mcmc.list(lapply.mcmc.list(line, `[`,,c(2,3,1))) #' \dontshow{ #' stopifnot(isTRUE(all.equal(colMeans.mcmc.list(line)[c(2,3,1)],colMeans.mcmc.list(lapply.mcmc.list(line, `[`,,c(2,3,1)))))) #' } #' @importFrom coda as.mcmc.list as.mcmc #' @export lapply.mcmc.list lapply.mcmc.list<-function(X, FUN, ...){ as.mcmc.list(lapply(lapply(X, FUN, ...), as.mcmc)) } statnet.common/R/zzz.R0000644000176200001440000000100215120241142014365 0ustar liggesusers# File R/zzz.R in package statnet.common, part of the Statnet suite of # packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ .onUnload <- function(libpath){ library.dynam.unload("statnet.common",libpath) } statnet.common/R/string.utilities.R0000644000176200001440000000773315120241142017071 0ustar liggesusers# File R/string.utilities.R in package statnet.common, part of the Statnet # suite of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' Concatenates the elements of a vector (optionaly enclosing them in quotation #' marks or parentheses) adding appropriate punctuation and conjunctions. #' #' A vector \code{x} becomes "\code{x[1]}", "\code{x[1]} and \code{x[2]}", or #' "\code{x[1]}, \code{x[2]}, and \code{x[3]}", depending on the langth of #' \code{x}. #' #' #' @param x A vector. #' @param oq Opening quotation symbol. (Defaults to none.) #' @param cq Closing quotation symbol. (Defaults to none.) #' @param con Conjunction to be used if `length(x)>1`. (Defaults to "and".) #' @return A string with the output. #' @seealso paste, cat #' @keywords utilities #' @examples #' #' print(paste.and(c())) #' #' print(paste.and(1)) #' #' print(paste.and(1:2)) #' #' print(paste.and(1:3)) #' #' print(paste.and(1:4,con='or')) #' @export paste.and <- function(x, oq='', cq='', con='and'){ x <- paste(oq, x, cq, sep='') if(length(x)==0) return('') if(length(x)==1) return(x) if(length(x)==2) return(paste(x[1L],con,x[2L])) if(length(x)>=3) return(paste0(paste(x[-length(x)], collapse=", "),', ',con,' ',ult(x))) } #' [`print`] objects to the [`message`] output. #' #' A thin wrapper around [`print`] that captures its output and prints #' it as a [`message`], usually to STDERR. #' #' @param ... arguments to [`print`]. #' @param messageArgs a list of arguments to be passed directly to [`message`]. #' #' @examples #' cat(1:5) #' #' print(1:5) #' message_print(1:5) # Looks the same (though may be in a different color on some frontends). #' #' suppressMessages(print(1:5)) # Still prints #' suppressMessages(message_print(1:5)) # Silenced #' @export message_print <- function(..., messageArgs=NULL){ #' @importFrom utils capture.output do.call(message, c(list(paste(capture.output(print(...)),collapse="\n")), messageArgs)) } #' A one-line function to strip whitespace from its argument. #' @param s a character vector. #' @examples #' stopifnot(despace("\n \t ")=="") #' @export despace <- function(s) gsub("[[:space:]]", "", s) #' Format a p-value in fixed notation. #' #' This is a thin wrapper around [format.pval()] that guarantees fixed #' (not scientific) notation, links (by default) the `eps` argument to #' the `digits` argument and vice versa, and sets `nsmall` to equal #' `digits`. #' #' @param pv,digits,eps,na.form,... see [format.pval()]. #' #' @return A character vector. #' #' @examples #' pvs <- 10^((0:-12)/2) #' #' # Jointly: #' fpf <- fixed.pval(pvs, digits = 3) #' fpf #' format.pval(pvs, digits = 3) # compare #' \dontshow{ #' stopifnot(all(fpf == c("1.000", "0.316", "0.100", "0.032", "0.010", "0.003", "0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001"))) #' } #' # Individually: #' fpf <- sapply(pvs, fixed.pval, digits = 3) #' fpf #' sapply(pvs, format.pval, digits = 3) # compare #' \dontshow{ #' stopifnot(all(fpf == c("1.000", "0.316", "0.100", "0.032", "0.010", "0.003", "0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001"))) #' } #' # Control eps: #' fpf <- sapply(pvs, fixed.pval, eps = 1e-3) #' fpf #' \dontshow{ #' stopifnot(all(fpf == c("1.000", "0.316", "0.100", "0.032", "0.010", "0.003", "0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001"))) #' } #' @export fixed.pval <- function(pv, digits = max(1, getOption("digits") - 2), eps = 10^-digits, na.form = "NA", ...) { if (missing(digits) && !missing(eps)) { digits <- ceiling(-log10(eps)) } o <- options(scipen = 200) on.exit(options(o)) format.pval(round(pv, digits), digits, eps = eps, na.form = na.form, nsmall = digits, ...) } statnet.common/R/wmatrix.R0000644000176200001440000002251115120241142015233 0ustar liggesusers# File R/wmatrix.R in package statnet.common, part of the Statnet suite of # packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' A data matrix with row weights #' #' A representation of a numeric matrix with row weights, represented #' on either linear (`linwmatrix`) or logarithmic (`logwmatrix`) #' scale. #' #' @param x an object to be coerced or tested. #' @param data,nrow,ncol,byrow,dimnames passed to [`matrix`]. #' @param w row weights on the appropriate scale. #' @param target.nrows see [`decompress_rows`]. #' @param i,j,value rows and columns and values for extraction or #' replacement; as [`matrix`]. #' @param drop Used for consistency with the generic. Ignored, and #' always treated as `FALSE`. #' @param ... extra arguments, currently unused. #' #' @note Note that `wmatrix` itself is an "abstract" class: you cannot #' instantiate it. #' #' @note Note that at this time, `wmatrix` is designed as, first and #' foremost, as class for storing compressed data matrices, so most #' methods that operate on matrices may not handle the weights #' correctly and may even cause them to be lost. #' #' @return An object of class `linwmatrix`/`logwmatrix` and `wmatrix`, #' which is a [`matrix`] but also has an attribute `w` containing #' row weights on the linear or the natural-log-transformed scale. #' #' @seealso [`rowweights`], [`lrowweights`], [`compress_rows`] #' #' @name wmatrix #' #' @examples #' (m <- matrix(1:3, 2, 3, byrow=TRUE)) #' (m <- rbind(m, 3*m, 2*m, m)) #' (mlog <- as.logwmatrix(m)) #' (mlin <- as.linwmatrix(m)) #' (cmlog <- compress_rows(mlog)) #' (cmlin <- compress_rows(mlin)) #' #' stopifnot(all.equal(as.linwmatrix(cmlog),cmlin)) #' #' cmlog[2,] <- 1:3 #' (cmlog <- compress_rows(cmlog)) #' stopifnot(sum(rowweights(cmlog))==nrow(m)) #' #' (m3 <- matrix(c(1:3,(1:3)*2,(1:3)*3), 3, 3, byrow=TRUE)) #' (rowweights(m3) <- c(4, 2, 2)) #' #' stopifnot(all.equal(compress_rows(as.logwmatrix(m)), as.logwmatrix(m3),check.attributes=FALSE)) #' stopifnot(all.equal(rowweights(compress_rows(as.logwmatrix(m))), #' rowweights(as.logwmatrix(m3)),check.attributes=FALSE)) NULL #' @rdname wmatrix #' @export logwmatrix <- function(data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL, w = NULL){ x <- matrix(data, nrow, ncol, byrow, dimnames) as.logwmatrix(x, w) } #' @rdname wmatrix #' @export linwmatrix <- function(data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL, w = NULL){ x <- matrix(data, nrow, ncol, byrow, dimnames) as.linwmatrix(x, w) } #' @rdname wmatrix #' @export is.wmatrix <- function(x) inherits(x, "wmatrix") #' @rdname wmatrix #' @export is.logwmatrix <- function(x) inherits(x, "logwmatrix") #' @rdname wmatrix #' @export is.linwmatrix <- function(x) inherits(x, "linwmatrix") #' @rdname wmatrix #' @export as.linwmatrix <- function(x, ...) UseMethod("as.linwmatrix") #' @rdname wmatrix #' @export as.logwmatrix <- function(x, ...) UseMethod("as.logwmatrix") #' @rdname wmatrix #' @export as.linwmatrix.linwmatrix <- function(x, ...) x #' @rdname wmatrix #' @export as.linwmatrix.logwmatrix <- function(x, ...){ attr(x, "w") <- exp(attr(x, "w")) class(x)[class(x)=="logwmatrix"] <- "linwmatrix" x } #' @rdname wmatrix #' @export as.logwmatrix.logwmatrix <- function(x, ...) x #' @rdname wmatrix #' @export as.logwmatrix.linwmatrix <- function(x, ...){ attr(x, "w") <- log(attr(x, "w")) class(x)[class(x)=="linwmatrix"] <- "logwmatrix" x } #' @rdname wmatrix #' @export as.linwmatrix.matrix <- function(x, w=NULL, ...){ attr(x, "w") <- NVL(w, rep(1, nrow(x))) class(x) <- c("linwmatrix", "wmatrix", class(x)) x } #' @rdname wmatrix #' @export as.logwmatrix.matrix <- function(x, w=NULL, ...){ attr(x, "w") <- NVL(w, rep(0, nrow(x))) class(x) <- c("logwmatrix", "wmatrix", class(x)) x } #' @rdname wmatrix #' @export print.wmatrix <- function(x, ...){ x <- cbind(unclass(x), Weight = attr(x, "w")) print(x, ...) } #' @rdname wmatrix #' @export print.logwmatrix <- function(x, ...){ cat("A row-weighted matrix with natural-log-scaled weights:\n") NextMethod("print") } #' @rdname wmatrix #' @export print.linwmatrix <- function(x, ...){ cat("A row-weighted matrix with linear-scaled weights:\n") NextMethod("print") } #' Set or extract weighted matrix row weights #' #' @param x a [`linwmatrix`], a [`logwmatrix`], or a [`matrix`]; a #' [`matrix`] is coerced to a weighted matrix of an appropriate #' type. #' @param value weights to set, on the appropriate scale. #' @param update if `TRUE` (the default), the old weights are updated #' with the new weights (i.e., corresponding weights are multiplied #' on linear scale or added on on log scale); otherwise, they are #' overwritten. #' @param ... extra arguments for methods. #' #' @return For the accessor functions, the row weights or the row #' log-weights; otherwise, a weighted matrix with modified #' weights. The type of weight (linear or logarithmic) is converted #' to the required type and the type of weighting of the matrix is #' preserved. #' #' @name wmatrix_weights NULL #' @rdname wmatrix_weights #' @export rowweights <- function(x, ...) UseMethod("rowweights") #' @rdname wmatrix_weights #' @export rowweights.linwmatrix <- function(x, ...) attr(x, "w") #' @rdname wmatrix_weights #' @export rowweights.logwmatrix <- function(x, ...) exp(attr(x, "w")) #' @rdname wmatrix_weights #' @export lrowweights <- function(x, ...) UseMethod("lrowweights") #' @rdname wmatrix_weights #' @export lrowweights.logwmatrix <- function(x, ...) attr(x, "w") #' @rdname wmatrix_weights #' @export lrowweights.linwmatrix <- function(x, ...) log(attr(x, "w")) #' @rdname wmatrix_weights #' @export `rowweights<-` <- function(x, ..., value) UseMethod("rowweights<-") #' @rdname wmatrix_weights #' @export `rowweights<-.linwmatrix` <- function(x, update=TRUE, ..., value){ attr(x, "w") <- value * if(update) attr(x, "w") else 1 x } #' @rdname wmatrix_weights #' @export `rowweights<-.logwmatrix` <- function(x, update=TRUE,..., value){ attr(x, "w") <- log(value) + if(update) log(attr(x, "w")) else 0 x } #' @rdname wmatrix_weights #' @export `lrowweights<-` <- function(x, ..., value) UseMethod("lrowweights<-") #' @rdname wmatrix_weights #' @export `lrowweights<-.linwmatrix` <- function(x, update=TRUE, ..., value){ attr(x, "w") <- exp(value + if(update) log(attr(x, "w")) else 0) x } #' @rdname wmatrix_weights #' @export `lrowweights<-.logwmatrix` <- function(x, update=TRUE,..., value){ attr(x, "w") <- value + if(update) attr(x, "w") else 0 x } #' @rdname wmatrix_weights #' @export `rowweights<-.matrix` <- function(x, ..., value){ attr(x, "w") <- value class(x) <- c("linwmatrix", "wmatrix", class(x)) x } #' @rdname wmatrix_weights #' @export `lrowweights<-.matrix` <- function(x, ..., value){ attr(x, "w") <- value class(x) <- c("logwmatrix", "wmatrix", class(x)) x } #' A generic function to compress a row-weighted table #' #' Compress a matrix or a data frame with duplicated rows, updating row weights #' to reflect frequencies, or reverse the process, reconstructing a matrix like #' the one compressed (subject to permutation of rows and weights not adding up #' to an integer). #' #' @param x a weighted matrix or data frame. #' @param ... extra arguments for methods. #' @return For \code{compress_rows} A weighted matrix or data frame of the same #' type with duplicated rows removed and weights updated appropriately. #' @export compress_rows <- function(x, ...) UseMethod("compress_rows") #' @rdname wmatrix #' @export compress_rows.logwmatrix <- function(x, ...){ o <- order.matrix(x) x <- x[o, , drop=FALSE] firsts <- !duplicated(x) groups <- cumsum(firsts) cx <- x[firsts, , drop=FALSE] attr(cx, "w") <- c(tapply(attr(x, "w"), list(groups), log_sum_exp), use.names=FALSE) cx } #' @rdname wmatrix #' @export compress_rows.linwmatrix <- function(x, ...){ o <- order.matrix(x) x <- x[o, , drop=FALSE] firsts <- !duplicated(x) groups <- cumsum(firsts) cx<-x[firsts, , drop=FALSE] attr(cx, "w") <- c(tapply(attr(x, "w"), list(groups), sum), use.names=FALSE) cx } #' @rdname compress_rows #' @export decompress_rows <- function(x, ...) UseMethod("decompress_rows") #' @rdname wmatrix #' @param target.nrows the approximate number of rows the uncompressed matrix #' should have; if not achievable exactly while respecting proportionality, a #' matrix with a slightly different number of rows will be constructed. #' @export decompress_rows.wmatrix <- function(x, target.nrows=NULL, ...){ w <- rowweights(x) if(is.null(target.nrows)) target.nrows <- sum(w) n <- round(w/sum(w)*target.nrows) # Number of replications of each row rowweights(x) <- 1/n x[rep(seq_along(n), n),] } #' @rdname wmatrix #' @export `[.wmatrix` <- function(x, i, j, ..., drop=FALSE){ if(drop) warning("Row-weighted matrices cannot drop dimensions.") o <- unclass(x)[i,j,...,drop=FALSE] attr(o, "w") <- attr(x, "w")[i] class(o) <- class(x) o } #' @rdname wmatrix #' @export `[<-.wmatrix` <- function(x, i, j, ..., value){ o <- unclass(x) o[i,j,...] <- value attr(o, "w") <- attr(x, "w") class(o) <- class(x) o } statnet.common/R/control.utilities.R0000644000176200001440000005311115120241142017232 0ustar liggesusers# File R/control.utilities.R in package statnet.common, part of the Statnet # suite of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ .autodetect_dep_warn <- local({ warned <- c() function(caller = as.character(ult(sys.calls(),3)[[1L]])){ if(!caller %in% warned) warning("In ",sQuote(caller),": Autodetection of acceptable control parameter generators and of the calling function name has been deprecated and will be removed in a future version. They must be set explicitly.", call.=FALSE) warned <<- c(warned, caller) } }) #' Ensure that the class of the control list is one of those that can #' be used by the calling function #' #' This function converts an ordinary `list` into a control list (if #' needed) and checks that the control list passed is appropriate for #' the function to be controlled. #' #' @param OKnames List of control function names which are acceptable. #' @param myname Name of the calling function (used in the error #' message). #' @param control The control list or a list to be converted to a #' control list using `control.myname()`. Defaults to the #' \code{control} variable in the calling function. See Details for #' detailed behavior. #' #' @note In earlier versions, `OKnames` and `myname` were #' autodetected. This capability has been deprecated and results in #' a warning issued once per session. They now need to be set #' explicitly. #' #' @details `check.control.class()` performs the check by looking up #' the class of the `control` argument (defaulting to the `control` #' variable in the calling function) and checking if it matches a #' list of acceptable given by `OKnames`. #' #' Before performing any checks, the `control` argument (including #' the default) will be converted to a control list by calling #' [as.control.list()] on it with the first element of `OKnames` to #' construct the control function. #' #' If `control` is missing, it will be assumed that the user wants #' to modify it in place, and a variable with that name in the #' parent environment will be overwritten. #' #' @return A valid control list for the function in which it is to be #' used. If `control` argument is missing, it will also overwrite #' the variable `control` in the calling environment with it. #' #' @seealso [set.control.class()], [print.control.list()], [as.control.list()] #' @keywords utilities #' @export check.control.class <- function(OKnames=as.character(ult(sys.calls(),2)[[1L]]), myname=as.character(ult(sys.calls(),2)[[1L]]), control=get("control",pos=parent.frame())){ overwrite_control <- missing(control) control <- as.control.list(control, OKnames[1]) if(missing(OKnames) || missing(myname)) .autodetect_dep_warn() funs <- paste("control", OKnames, sep=".") # Control missing: overwrite default name in parent. if(overwrite_control) assign("control", control, pos=parent.frame()) if(inherits(control, funs[1L])) return(control) for(fun in funs[-1]) # If there is only one, that's a null vector, so it just terminates. if(inherits(control, fun)){ warning("Using ", fun,"(...) as the control parameter of ",myname,"(...) is suboptimal and may overwrite some settings that should be preserved. Use ",funs[1L],"(...) instead.") return(control) } stop("Invalid control parameters for ",myname,"(...): ",class(control)[1L],"(...). Use ",funs[1L],"(...) to construct them instead.", call.=FALSE) } #' Set the class of the control list #' #' This function sets the class of the control list, with the default being the #' name of the calling function. #' #' #' @param myname Name of the class to set. #' @param control Control list. Defaults to the \code{control} variable in the #' calling function. #' @return The control list with class set. #' @note In earlier versions, `OKnames` and `myname` were autodetected. This capability has been deprecated and results in a warning issued once per session. They now need to be set explicitly. #' @seealso [check.control.class()], [print.control.list()] #' @keywords utilities #' @export set.control.class <- function(myname=as.character(ult(sys.calls(),2)[[1L]]), control=get("control",pos=parent.frame())){ if(missing(myname)) .autodetect_dep_warn() class(control) <- c(myname, "control.list", "list") control } #' Handle standard `control.*()` function semantics. #' #' This function takes the arguments of its caller (whose name should #' be passed explicitly), plus any `...` arguments and produces a #' control list based on the standard semantics of `control.*()` #' functions, including handling deprecated arguments, identifying #' undefined arguments, and handling arguments that should be passed #' through [match.arg()]. #' #' @param myname the name of the calling function. #' @param ... the `...` argument of the control function, if present. #' #' @details The function behaves based on the information it acquires from the calling function. Specifically, #' #' * The values of formal arguments (except `...`, if present) are #' taken from the environment of the calling function and stored in #' the list. #' #' * If the calling function has a `...` argument *and* defines an #' `old.controls` variable in its environment, then it remaps the #' names in `...` to their new names based on `old.controls`. In #' addition, if the value is a list with two elements, `action` and #' `message`, the standard deprecation message will have `message` #' appended to it and then be called with `action()`. #' #' * If the calling function has a `match.arg.pars` in its #' environment, the arguments in that list are processed through #' [match.arg()]. #' #' @return a list with formal arguments of the calling function. #' @export handle.controls <- function(myname, ...){ formal.args <- formals(sys.function(-1)) if(has.dots <- "..." %in% names(formal.args)) formal.args[["..."]] <- NULL control <- list() for(arg in names(formal.args)) control[arg] <- list(get(arg, parent.frame())) if(has.dots){ old.controls <- if(exists("old.controls", parent.frame())) get("old.controls", parent.frame()) else list() for(arg in names(list(...))){ if(is.null(newarg <- old.controls[[arg]])){ stop("Unrecognized control parameter for ", sQuote(paste0(myname, "()")), ": ", sQuote(arg), ".", call.=FALSE) }else if(is.list(newarg)){ newarg$action("Control parameter ",sQuote(paste0(arg,"=..."))," to ", sQuote(paste0(myname, "()")), " is no longer used.", newarg$message, call.=FALSE) }else{ warning("Passing ",sQuote(paste0(arg,"=..."))," to ", sQuote(paste0(myname, "()")), " is deprecated and may be removed in a future version. Specify it as ", sQuote(paste0(myname, "(", old.controls[[arg]], "=...)")), " instead.", call.=FALSE) control[old.controls[[arg]]]<-list(list(...)[[arg]]) } } } if(exists("match.arg.pars", parent.frame())) for(arg in get("match.arg.pars", parent.frame())) control[arg] <- list(match.arg(control[[arg]][1], eval(formal.args[[arg]], parent.frame()))) control } #' Pretty print the control list #' #' This function prints the control list, including what it can control and the #' elements. #' #' #' @param x A list generated by a \code{control.*} function. #' @param \dots Additional argument to print methods for individual settings. #' @param indent an argument for recursive calls, to facilitate indentation of nested lists. #' @seealso \code{\link{check.control.class}}, \code{\link{set.control.class}} #' @keywords utilities #' @export print.control.list <- function(x, ..., indent=""){ cat("Control parameter list generated by", sQuote(class(x)[1L]), "or equivalent. Non-empty parameters:\n") for(name in names(x)){ if(length(x[[name]])){ cat(indent, name,": ",sep="") if(is.list(x[[name]])) {print(x[[name]], ..., indent=paste0(indent," "))} else cat(paste(deparse(x[[name]]), collapse=" "),"\n", sep="") } } } #' Named element accessor for ergm control lists #' #' Utility method that overrides the standard `$' list accessor to disable #' partial matching for ergm \code{control.list} objects #' #' Executes \code{\link[base]{getElement}} instead of \code{\link[base]{$}} so #' that element names must match exactly to be returned and partially matching #' names will not return the wrong object. #' #' @param object list-coearceable object with elements to be searched #' @param name literal character name of list element to search for and return #' @return Returns the named list element exactly matching \code{name}, or #' \code{NULL} if no matching elements found #' @author Pavel N. Krivitsky #' @seealso see \code{\link{getElement}} #' @name control.list.accessor #' @export `$.control.list` <- function(object, name) object[[name, exact = TRUE]] #' Overwrite control parameters of one configuration with another. #' #' Given a \code{control.list}, and two prefixes, \code{from} and \code{to}, #' overwrite the elements starting with \code{to} with the corresponding #' elements starting with \code{from}. #' #' #' @param control An object of class \code{control.list}. #' @param from Prefix of the source of control parameters. #' @param to Prefix of the destination of control parameters. #' @return An \code{control.list} object. #' @author Pavel N. Krivitsky #' @seealso \code{\link{print.control.list}} #' @keywords utilities #' @examples #' #' (l <- set.control.class("test", list(a.x=1, a.y=2))) #' control.remap(l, "a", "b") #' #' @export control.remap <- function(control, from, to){ from <- paste0("^",from,"\\.") to <- paste0(to,"\\.") nfrom <- grep(from, names(control), value=TRUE) nto <- sub(from, to, nfrom) for(i in seq_along(nfrom)) control[[nto[i]]] <- control[[nfrom[i]]] control } #' Identify and the differences between two control lists. #' @param x a `control.list` #' @param y a reference `control.list`; defaults to the default #' settings for `x`. #' @param ignore.environment whether environment for #' environment-bearing parameters (such as formulas and functions) #' should be considered when comparing. #' @param ... Additional arguments to methods. #' #' @return An object of class `diff.control.list`: a named list with #' an element for each non-identical setting. The element is either #' itself a `diff.control.list` (if the setting is a control list) #' or a named list with elements `x` and `y`, containing `x`'s and #' `y`'s values of the parameter for that setting. #' @export diff.control.list <- function(x, y=eval(call(class(x)[[1L]])), ignore.environment=TRUE, ...){ d <- list() for(name in union(names(x),names(y))){ d[[name]] <- if(is(x[[name]], "control.list") && is(y[[name]], "control.list")) EVL(diff(x[[name]], y[[name]])) else if(!identical(x[[name]],y[[name]],ignore.environment=ignore.environment)) list(x=x[[name]], y=y[[name]]) } structure(d, class=c("diff.control.list", "list"), xclass=c(class(x)[1L])) } #' @describeIn diff.control.list A print method. #' @param indent an argument for recursive calls, to facilitate #' indentation of nested lists. #' @export print.diff.control.list <- function(x, ..., indent = ""){ if(length(x)==0) cat("No difference between parameter lists generated by", sQuote(attr(x,"xclass")), "or equivalent.\n") else{ cat("Difference between parameter lists generated by", sQuote(attr(x,"xclass")), "or equivalent. Differences:\n") for(name in names(x)){ if(length(x[[name]])){ cat(indent, name,": ",sep="") if(is(x[[name]],"diff.control.list")) print(x[[name]], ..., indent=paste0(indent," ")) else if(is.list(x[[name]]$x)){ print(x[[name]]$x, ..., indent=paste0(indent," ")) cat("versus") print(x[[name]]$y, ..., indent=paste0(indent," ")) }else{ cat(paste(deparse(x[[name]]$x), collapse=" "), " versus ", paste(deparse(x[[name]]$y), collapse=" "), "\n", sep="") } } } } } #' Convert to a control list. #' #' @param x An object, usually a [`list`], to be converted to a #' control list. #' @param ... Additional arguments to methods. #' @return a `control.list` object. #' #' @examples #' myfun <- function(..., control=control.myfun()){ #' as.control.list(control) #' } #' control.myfun <- function(a=1, b=a+1){ #' list(a=a,b=b) #' } #' #' myfun() #' myfun(control = list(a=2)) #' @export as.control.list <- function(x, ...) UseMethod("as.control.list") #' @describeIn as.control.list Idempotent method for control lists. #' @export as.control.list.control.list <- function(x, ...) x #' @describeIn as.control.list The method for plain lists, which runs #' them through `FUN`. #' @param FUN Either a `control.*()` function or its name or suffix #' (to which `"control."` will be prepended); defaults to taking the #' nearest (in the call traceback) function that does not begin with #' `"as.control.list"`, and prepending `"control."` to it. (This is #' typically the function that called `as.control.list()` in the #' first place.) #' @param unflat Logical, indicating whether an attempt should be made #' to detect whether some of the arguments are appropriate for a #' lower-level control function and pass them down. #' @examples #' myfun2 <- function(..., control=control.myfun2()){ #' as.control.list(control) #' } #' control.myfun2 <- function(c=3, d=c+2, myfun=control.myfun()){ #' list(c=c,d=d,myfun=myfun) #' } #' #' myfun2() #' # Argument to control.myfun() (i.e., a) gets passed to it, and a #' # warning is issued for unused argument e. #' myfun2(control = list(c=3, a=2, e=3)) #' @export as.control.list.list <- function(x, FUN=NULL, unflat=TRUE, ...){ if(is.null(FUN)){ FUN <- ult( Filter(function(x) !startsWith(x, "as.control.list"), vapply( lapply(sys.calls(), # Obtain the traceback. `[[`, 1L), # Extract the function names as names. as.character, character(1)) # Convert to character vectors. ) # Drop those that begin with "as.control.list". ) # Take the last one. } if(is.character(FUN) && !startsWith(FUN, "control.")) FUN <- paste0("control.", FUN) FUN <- match.fun(FUN) if(unflat){ xnames_unused <- names(x) unflat <- function(f){ args <- formals(f) anames <- setdiff(names(args), "...") l <- list() for(aname in names(args)) if(aname %in% names(x)){ # Present in the input list: copy. l[aname] <- list(x[[aname]]) xnames_unused <<- setdiff(xnames_unused, aname) }else if(is.call(aval <- args[[aname]]) && startsWith(as.character(aval[[1]]), "control.")){ # A control list not supplied directly: process recursively. subargs <- unflat(get(as.character(aval[[1]]), pos=environment(f), mode="function")) if(length(subargs)) l[aname] <- list(subargs) } # Otherwise, leave blank. l } x <- unflat(FUN) if(length(xnames_unused)) warning("Control arguments ", paste.and(sQuote(xnames_unused)), " not used in any of the control functions.", call.=FALSE, immediate.=TRUE) } do.call(FUN, x, envir=parent.frame()) } #' Statnet Control #' #' A utility to facilitate argument completion of control lists. #' #' In and of itself, `snctrl` copies its named arguments into a #' list. However, its argument list is updated dynamically as packages #' are loaded, as are those of its reexports from other packages. This #' is done using an API provided by helper functions. (See `API?snctrl`.) #' #' @param ... The parameter list is updated dynamically as packages #' are loaded and unloaded. Their current list is given below. #' #' @section Currently recognised control parameters: #' This list is updated as packages are loaded and unloaded. #' #' \Sexpr[results=rd,stage=render]{statnet.common::snctrl_names()} #' #' @note You may see messages along the lines of #' ``` #' The following object is masked from 'package:PKG': #' snctrl #' ``` #' when loading packages. They are benign. #' #' @export snctrl <- function(...){ control <- list(...) # NB: The results of snctrl() will eventually get passed to # as.control.list.list(), which will check for misspelled names, so # we don't need to do that here. if(any(names(control)=="")) stop("All arguments to ",sQuote("snctrl")," must be named.", call.=FALSE) formal.args<-formals(sys.function()) formal.args[["..."]] <- NULL for(arg in names(formal.args)){ if(arg=="") stop("All arguments to ",sQuote("snctrl")," must be named.", call.=FALSE) if(!do.call(missing, list(arg))) control[arg] <- list(get(arg)) } control } #' @describeIn snctrl-API Typeset the currently defined list of #' argument names by package and control function. #' #' @export snctrl_names <- function(){ a <- argnames() pkgs <- sapply(names(a), function(pkg){ funs <- lapply(names(a[[pkg]]), function(ctrl){ ctrll <- nchar(ctrl) args <- names(a[[pkg]][[ctrl]]) paste0("\\item{\\code{\\link[",pkg,":",ctrl,"]{",ctrl,"}}}{\\code{", paste0(strwrap(paste0(args,collapse=", "),simplify=TRUE,exdent=ctrll+1),collapse="\n"), "}}") }) paste0("\\subsection{Package \\pkg{",pkg,"}}{\\describe{", paste0(funs,collapse="\n"),"}}") }) paste0(pkgs,collapse="\n") } argnames <- local({ cache <- list() delpkg <- function(pkgname,pkgpath){ cache[[pkgname]] <<- NULL update_snctrl() } function(pkg, arglists){ if(missing(pkg)) cache else{ cache[[pkg]] <<- arglists setHook(packageEvent(pkg, "onUnload"), delpkg) } } }) callbacks <- local({ cache <- list() delpkg <- function(pkgname,pkgpath){ cache[[pkgname]] <<- NULL } function(pkg, callback){ if(missing(pkg)) cache else{ cache[[pkg]] <<- callback setHook(packageEvent(pkg, "onUnload"), delpkg) } } }) #' @name snctrl-API #' @title Helper functions used by packages to facilitate [`snctrl`] updating. #' NULL #' @describeIn snctrl-API Typically called from [.onLoad()], Update the #' argument list of [snctrl()] to include additional argument names #' associated with the package, and set a callback for the package #' to update its own copy. #' #' @param myname Name of the package defining the arguments. #' @param arglists A named list of argument name-default pairs. If the #' list is not named, it is first passed through #' [collate_controls()]. #' @param callback A function with no arguments that updates the #' packages own copy of [snctrl()]. #' #' @return `update_snctrl()` has no return value and is used for its side-effects. #' @export update_snctrl <- function(myname, arglists=NULL, callback=NULL){ if(length(arglists) && all(names(arglists)=="")) arglists <- do.call(collate_controls, arglists) # Make a copy and replace the arglist. tmp <- snctrl if(!missing(myname)){ argnames(myname, arglists) if(!is.null(callback)) callbacks(myname, callback) } arglists <- c(argnames(),list(list(formals(tmp)[1]))) arglist <- unlist(unlist(lapply(unname(arglists), unname), recursive=FALSE), recursive=FALSE) argnames <- sort(unique(names(arglist))) arglist <- structure(rep(list(substitute()), length(argnames)), # For now, leave all default arguments blank. names = argnames) formals(tmp) <- arglist # Replace the original function with the copy. unlockBinding("snctrl", environment(snctrl)) snctrl <<- tmp lockBinding("snctrl", environment(snctrl)) for(callback in callbacks()) callback() invisible() } #' @describeIn snctrl-API Obtain and concatenate the argument lists of #' specified functions or all functions starting with dQuote(`control.`) in #' the environment. #' #' @param x Either a function, a list of functions, or an #' environment. If `x` is an environment, all functions starting #' with dQuote(`control.`) are obtained. #' @param ... Additional functions or lists of functions. #' #' @return `collate_controls()` returns the combined list of name-default pairs of each function. #' @export collate_controls <- function(x=NULL, ...){ l <- if(is.environment(x)) lapply(grep("^control\\.*", ls(pos=x), value=TRUE), mget, x, mode="function", ifnotfound=list(NULL)) else list(x) l <- unlist(c(list(...), l)) arglists <- lapply(l, formals) } #' @describeIn snctrl-API A stored expression that, if evaluated, will #' create a callback function `update_my_snctrl()` that will update #' the client package's copy of [snctrl()]. #' @format `UPDATE_MY_SCTRL_EXPR` is a quoted expression meant to be passed directly to [eval()]. #' @examples #' \dontrun{ #' # In the client package (outside any function): #' eval(UPDATE_MY_SCTRL_EXPR) #' } #' @export UPDATE_MY_SCTRL_EXPR <- quote( update_my_snctrl <- function(){ unlockBinding("snctrl", environment(update_my_snctrl)) snctrl <<- statnet.common::snctrl lockBinding("snctrl", environment(update_my_snctrl)) } ) #' @describeIn snctrl-API A stored expression that, if evaluated on #' loading, will add arguments of the package's `control.*()` #' functions to [snctrl()] and set the callback. #' @format `COLLATE_ALL_MY_CONTROLS_EXPR` is a quoted expression meant to be passed directly to [eval()]. #' @examples #' \dontrun{ #' # In the client package: #' .onLoad <- function(libame, pkgname){ #' # ... other code ... #' eval(statnet.common::COLLATE_ALL_MY_CONTROLS_EXPR) #' # ... other code ... #' } #' } #' @export COLLATE_ALL_MY_CONTROLS_EXPR <- quote( statnet.common::update_snctrl(pkgname, list(environment(.onLoad)), update_my_snctrl) ) statnet.common/R/test.utilities.R0000644000176200001440000000131715120241142016532 0ustar liggesusers# File R/test.utilities.R in package statnet.common, part of the Statnet suite # of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' Skip a test if not called via `R CMD` [`check`] #' #' A \CRANpkg{testthat} predicate to skip tests if not run as a part #' of a package [check]. #' #' @export skip_if_not_checking <- function() { testthat::skip_if_not(testthat::is_checking(), "not inside R CMD check") } statnet.common/R/cite.utilities.R0000644000176200001440000001020115120241142016467 0ustar liggesusers# File R/cite.utilities.R in package statnet.common, part of the Statnet suite # of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ # ---- BEGIN STATNET CITATION FUNCTIONS ---- #' \code{CITATION} file utilities for Statnet packages (DEPRECATED) #' #' These functions automate citation generation for Statnet Project #' packages. They no longer appear to work with CRAN and are thus #' deprecated. #' #' #' @param pkg Name of the package whose citation is being generated. #' @return For \code{statnet.cite.head} and \code{statnet.cite.foot}, an object #' of type \code{citationHeader} and \code{citationFooter}, respectively, #' understood by the \code{\link{citation}} function, with package name #' substituted into the template. #' #' For \code{statnet.cite.pkg}, an object of class \code{\link{bibentry}} #' containing a 'software manual' citation for the package constructed from the #' current version and author information in the \code{DESCRIPTION} and a #' template. #' @seealso citation, citHeader, citFooter, bibentry #' @keywords utilities #' @name statnet.cite #' @examples #' #' \dontrun{ #' statnet.cite.head("statnet.common") #' #' statnet.cite.pkg("statnet.common") #' #' statnet.cite.foot("statnet.common") #' } NULL # A header function for ensuring that all the statnet packages provide consistent messaging #' @rdname statnet.cite #' @export statnet.cite.head <- function(pkg){ .Deprecated("No longer usable.") utils::citHeader( paste("`",pkg,"` is part of the Statnet suite of packages. ", "If you are using the `",pkg,"` package for research that will be published, ", "we request that you acknowledge this by citing the following.\n", 'For BibTeX format, use toBibtex(citation("',pkg,'")).', sep="") ) } # A footer function for ensuring that all the statnet packages provide consistent messaging #' @rdname statnet.cite #' @export statnet.cite.foot <- function(pkg){ .Deprecated("No longer usable.") # the 'meta' variable should be provided by R's CITATION processing script # instead of using packageDescription(). But if this code is called in another context # use packageDescription() to assign meta if(!exists("meta") || is.null(meta)){ meta <- utils::packageDescription(pkg) } utils::citFooter("We have invested a lot of time and effort in creating the", "Statnet suite of packages for use by other researchers.", "Please cite it in all papers where it is used. The package",pkg," is made distributed under the terms of the license:",meta$License ) } # generates a consistent bibentry citation for the software manual of the package #' @rdname statnet.cite #' @export statnet.cite.pkg <- function(pkg){ .Deprecated("No longer usable.") # the 'meta' variable should be provided by R's CITATION processing script # instead of using packageDescription(). But if this code is called in another context # use packageDescription() to assign meta if(!exists("meta") || is.null(meta)){ meta <- utils::packageDescription(pkg) } projhomepage <- "http://www.statnet.org" # compute the list of authors auts <- eval(parse(text=meta$`Authors@R`)) auts <- auts[sapply(auts, function(aut) "aut" %in% aut$role)] # create a citation entry for a "software manual" for this version of the software # it will be appended with any specific articles defineded inthe package citation file utils::bibentry("Manual", author = auts, title = paste(meta$Package,": ", meta$Title, sep=""), organization = paste("The Statnet Project (\\url{", projhomepage, "})",sep=""), year = substr(meta$Date,1,4), note = paste("R package version ", meta$Version, sep=""), url = paste("CRAN.R-project.org/package=",meta$Package,sep="") ) } # ---- END STATNET CITATION FUNCTIONS ---- statnet.common/R/deprecation_utils.R0000644000176200001440000000553615120241142017265 0ustar liggesusers# File R/deprecation_utils.R in package statnet.common, part of the Statnet # suite of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ #' @name deprecation-utilities #' @rdname deprecation-utilities #' @title Utilities to help with deprecating functions. #' NULL #' @rdname deprecation-utilities #' #' @description `.Deprecate_once` calls [.Deprecated()], passing all its arguments #' through, but only the first time it's called. #' #' @param ... arguments passed to [.Deprecated()]. #' #' @examples #' \dontrun{ #' options(warn=1) # Print warning immediately after the call. #' f <- function(){ #' .Deprecate_once("new_f") #' } #' f() # Deprecation warning #' f() # No deprecation warning #' } #' @importFrom utils modifyList #' @export .Deprecate_once <- local({ warned <- c() function(...){ me <- sys.call(-1) myname <- format(me[[1L]]) if(! myname%in%warned){ do.call(".Deprecated", modifyList(list(old=myname),list(...))) warned <<- c(warned, myname) } } }) #' @rdname deprecation-utilities #' @description `.Deprecate_method` calls #' [.Deprecated()], but only if a method has been called by name, #' i.e., \code{\var{METHOD}.\var{CLASS}}. Like `.Deprecate_once` it #' only issues a warning the first time. #' #' @param generic,class strings giving the generic function name and #' class name of the function to be deprecated. #' #' @examples #' \dontrun{ #' options(warn=1) # Print warning immediately after the call. #' summary.packageDescription <- function(object, ...){ #' .Deprecate_method("summary", "packageDescription") #' invisible(object) #' } #' #' summary(packageDescription("statnet.common")) # No warning. #' summary.packageDescription(packageDescription("statnet.common")) # Warning. #' summary.packageDescription(packageDescription("statnet.common")) # No warning. #' } #' @export .Deprecate_method <- local({ warned <- c() function(generic, class){ fullname <- paste(generic,class,sep=".") if(! fullname%in%warned){ me <- sys.call(-1)[[1L]] if(length(me)>1 && me[[1L]]=="::") me <- me[[3L]] parent <- sys.call(-2)[[1L]] if(length(parent)>1 && parent[[1L]]=="::") parent <- parent[[3L]] if(me==fullname && NVL(parent,"")!=generic){ do.call(".Deprecated", list(msg=paste0("You appear to be calling ", fullname,"() directly. ", fullname,"() is a method, and will not be exported in a future version of ", sQuote("ergm"),". Use ", generic, "() instead, or getS3method() if absolutely necessary."), old=fullname)) warned <<- c(warned, fullname) } } } }) statnet.common/NEWS0000644000176200001440000003505315120240112013714 0ustar liggesusersstatnet.common 4.13.0 ===================== New utilities ------------- - New `testthat` predicate, `skip_if_not_checking()`, that skips the test if it's not part of an `R CMD check`, e.g., if run by `testthat::test_local()`. - New function, `enlist()` to wrap an object into a singleton list if it's not already a list, for various definitions of "list". - New function, `which_top_n()`, to return the indices of top or bottom `n` elements of a vector, with several methods for resolving ties. - New function, `split_len()` to split a split()-able object by lengths. Enhancements to existing utilities ---------------------------------- - `term_list` objects now have `envir()`, `envir<-()`, `sign()`, and `sign<-()` methods to better encapsulate their environment and sign information. - `ERRVL*()` functions if not given any non-erroring expressions now throw the last error rather than a generic message. statnet.common 4.12.0 ===================== New utilities ------------- - New matrix functions: `qrssolve()` to solve linear systems via QR decomposition after scaling, and `qrsolve()` to do the same without scaling, along with `sandwich_qrsolve()`, `sandwich_qrssolve()`, `sandwich_ginv()`, and `sandwich_sginv()`. - New function, `match_names()` to replace `vector.namesmatch()` with more flexible behavior and error checking. - New functions, `ERRVL2()` and `ERRVL3()` that, unlike `ERRVL()`, do not require the expressions to be wrapped in `try()`. - New function, `replace()`, a more pipe-friendly drop-in replacement for `base::replace()` for which replacement indices and values can be specified as functions evaluated on the input vector. `replace()<-` is also implemented, allowing the list to be modified in place. - New pair of functions, `arr_to_coo()` and `arr_from_coo()`, to translate between an array and its list of non-default values. - New function, `set_diag()` to set a diagonal of a matrix to specified values and return (as opposed to modifying it in place). Enhancements to existing utilities ---------------------------------- - `statnetStartupMessage()` now prints `Remote:` information if the package was installed from a remote. - Matrices returned by the `lweighted.*()` family of functions now inherit dimensional names. - `xTAx_eigen()` (and therefore `xTAx_seigen()`) now handle matrix-valued x correctly and check that `x` is in the span of `A`. - Scaling version of matrix operations now use `.Machine$double.xmax/(1 + .Machine$double.eps)` as the inverse of the zero diagonal. - `all_identical()` can now use a custom comparison predicate (e.g., `all.equal()`), and the use any of the elements in the list as the reference. (Thanks to Michał Bojanowski @mbojan.) statnet.common 4.11.0 ===================== New utilities ------------- - New function, `modify_in_place()`, that attempts to modify the argument of its caller in place. A function can call it to modify its own arguments in place. - New function, `log1mexp(x)` to compute `log(1-exp(-x))` minimizing the loss of precision. R provides a C macro `log1mexp(x)` but not the corresponding R wrapper. Enhancements to existing utilities ---------------------------------- - The behavior of `trim_env()` has changed: if no variables are to be copied in, the environment is set directly to `baseenv()`. statnet.common 4.10.0 ===================== New utilities ------------- - New linear algebra utilities: `ginv_eigen()`, which performs generalised inverse via eigendecomposition rather than SVD, to be used by `sginv()` if `snnd=TRUE`; and `xTAx_eigen()` and `xTAx_seigen()` to evaluate the inverse quadratic form using eigendecomposition. - A new function `var.mcmc.list()` "method" to evaluate the covariance matrix for an `mcmc.list` without constructing a large matrix. Enhancements to existing utilities ---------------------------------- - `colMeans.mcmc.list()` "method" no longer constructs a large matrix when calculating. - `lweighted.var()` and `lweighted.cov()` now take an additional argument `onerow=` to specify what they should return (`NA`, 0, or something else) if the input matrix has one row. Bug fixes --------- - `as.cntrol.list.list()` and hence `snctrl()` no longer clobbers nested controls, e.g., `control.ergm(SAN=control.san(...),...)`. - To facilitate support for earlier versions of R, avoid using the built-in pipe (`|>`) for now. statnet.common 4.9.0 ==================== New utilities ------------- - A new function,`lweighted.cov()`, to compute weighted covariance between two matrices or vectors. - New linear algebra utilities, `is.SPD()`, `sandwich_solve()`, `sandwich_ssolve()`, `sginv()`, `snearPD()`, `srcond()`, `ssolve()`, `xAxT()`, `xTAx()`, `xTAx_qrsolve()`, `xTAx_qrssolve()`, `xTAx_solve()`, and `xTAx_ssolve()` moved from `ergm` and documented. Bug fixes --------- - In `handle.controls()`, arguments that are `match.arg()`-ed are now evaluated in the correct frame. statnet.common 4.8.0 ==================== New utilities ------------- - A helper function `unused_dots_warning()` is exported that works with `rlang::check_dots_used()` to print an informative message. statnet.common 4.7.0 ==================== New utilities ------------- - An S3 class `term_list` for storing terms extracted from a formula, by `list_rhs.formula()` and others, containing information about each term's sign and environment. Concatenation, indexing, and print methods are implemented. Bug fixes --------- - `list_rhs.formula()` can now handle `NULL` terms on the RHS. statnet.common 4.6.0 ==================== New utilities ------------- - An implementation of Welford's online algorithm for calculating sample mean and variance has been added as a class `Welford` that implements method `update()` and maintains elements `$n`, `$means`, `$SSDs`, and `$vars`. Bug fixes --------- - `snctrl()` was issuing a warning twice when called with a misspelled argument. - `deInf()` now handles `NULL` input. - in `locate_function()` a subtle bug has been fixed in handling of visible as opposed to invisible objects. statnet.common 4.5.0 ==================== New utilities ------------- - `ergm`'s term locator functions (`locate_function()` and `locate_prefixed_function()`) have been moved from `ergm`. - A new function, `default_options()`, a wrapper around `options()` that drops options already set. - A new function, `as.control.list()` generic and methods which take an R list and call an appropriate `control.*()` function on it. - `check.control.class()` now first runs the control argument through `as.control.list()` and overwrites, so `control=` arguments to many functions can be plain lists. - A new function, `simplify_simple()`, which takes a list and returns an atomic vector if the elements of the list are atomic and of length 1, with particular handling for `NULL` and empty (0-length) elements. - A new function, `snctrl()` (StatNet ConTRoL), designed so that argument completion will complete all available control functions. Looking up its help (`?snctrl`) produces a dynamic list of all control parameters and their packages and control functions that is updated as packages are loaded and unloaded. - A new function, `handle.controls()`, that performs the most normal functions in a `control.*()` function. - Two trivial helper functions, `base_env()` and `empty_env()`, to replace an object's environment with `baseenv()` and `emptyenv()`, respectively. - A new function, `fixed.pval()` that wraps `base::format.pval()` with better default arguments. - A reimplementation of `attr()` is exported, which disables partial matching by default. Enhancements to existing utilities ---------------------------------- - `statnetStartupMessage()` now first looks for a `comment=(affil=...)` for the contributor's affiliation, before using e-mail. - Improved output formatting for `.Deprecate_once()`. - `append_rhs.formula()` now accepts NULL as the first argument, in which case it creates a new formula, and takes an additonal argument `env=`, which is used as this new formula's environment. Miscellaneous changes --------------------- - `rle` utilities are no longer reexported. - `statnet.common` no longer depends on `purrr`. - `statnetStartupMessage()` has been simplified. statnet.common 4.4.0 ==================== `rle` utilities have been moved to a separate package, `rle` ------------------------------------------------------------ - Major methods are reexported, for now. New utilities ------------- - `split()` methods for matrices and arrays, to split them along a margin. - `trim_env()`, a generic that will replace an environment (possibly attached to another object) with a sub-environment containing only objects whose names are specified. - A `diff()` method for control lists and a `print()` method for the resulting differences. - `deInf()`, to replace `.deinf()` in package `ergm`. - A `compress()` generic, a `compress()` method for RLEs, and a `doNotCompress` argument to `rep.rle()`. Both `compact.rle()` and the `doNotCompact` argument to `rep.rle()` are now deprecated. Enhancements to existing utilities ---------------------------------- - Various optimizations have been made to RLEs. - `nonsimp_update.formula()` now handles both one and two sided formulas; it also now copies all names except `...` when `from.new = TRUE`. Bug fixes --------- - `str.rle()` now works despite the overridden `length()` method. statnet.common 4.3.0 ==================== New utilities ------------- - `EVL()`, a family of functions like `NVL()`, that treat any object of length 0 as `NULL`. - `once()`, a `purrr`-style adverb that wraps a function to only evaluate the first time it's called with a given configuration of arguments. - `persistEval()` and `persistEvalQ()` to retry evaluating a given expression a specified number of times. Bug fixes --------- - In `forkTimeout()`, don't collect a process twice. Thanks to Tomas Kalibera for suggesting the fix. statnet.common 4.2.0 ==================== New utilities ------------- - `.Deprecate_once()` calls `.Deprecated()`, passing all its arguments through, but only the first time it's called. - `.Deprecate_method()` calls `.Deprecated()`, but only if a method has been called by name, i.e., `METHOD.CLASS`. - `forkTimeout()` evaluates an R expression with a hard time limit (except on Windows) by forking a process. Unlike `setTimeLimit()`, it enforces the limit even on native code. - `ult()` is a convenience function that extracts or replaces elements of a list indexed from the end. Miscellaneous ------------- - `statnet.common` now depends on R \>= 3.5 due to what appears to be a method dispatching bug in earlier versions. - The package no longer Enhances `coda`. statnet.common 4.1.4 ==================== New utilities ------------- - `despace()` removes whitespace from a string. - Pseudo-methods `colMeans.mcmc.list()`, `sweep.mcmc.list()`, and `lapply.mcmc.list()` (migrated from the `ergm` package). - `filter_rhs.formula()` selectively deletes terms in on the RHS of a formula. - `eval_lhs.formula()` extracts the LHS of the formula and evaluates it in the specified environment. - `NVL2()` and `NVL3()` for flexible substitution of null values. - `message_print()` formats its arguments as if for `print()` or `show()` methods, but then prints to stderr like `message()`. Enhancements to existing utilities ---------------------------------- - `paste.and()` now takes an additional `con=` argument, allowing a conjunction other than "and" to be used. - `ERRVL()` now uses lazy evaluation and lets the user dot-substitute the previous argument's try-error into the next argument. Bug fixes --------- - Printing for control lists now works for function arguments. - A number of improvements to `rle` methods. Miscellaneous ------------- - A number of functions have been renamed for consistency: - `term.list.formula()` → `list_rhs.formula()` - `append.rhs.formula()` → `append_rhs.formula()` - `nonsimp.update.formula()` → `nonsimp_update.formula()` - Citation utilities have been deprecated, since CRAN's structure makes them unusable. statnet.common 4.0.0 ==================== - The package now uses `Roxygen` for documentation. - `term.list.formula()` output format has been changed, since support of attributes on symbols is being deprecated. - A library of methods has been added for the base `rle` class, implementing concatenation, compaction, and a number of binary operations. - `all_same()` has been moved from ergm and renamed to `all_identical()`. - A new assignment method `NVL()<-` overwrites a variable if its value is NULL. - A set of classes and functions for manipulating and efficiently performing calculations on dense matrices or vectors with weighted rows or elements (possibly on the log scale) has been added. - New control parameter helper function, control.remap() has been added. Autodetection of function names by `set.control.class()` and `check.control.class()` has been deprecated and now results in a warning. - Improvements to the compressed data frame code, including an order() generic. - Miscellaneous robustifications added. - Native routine registration has been added. statnet.common 3.3.0 ==================== - `append.rhs.formula()`, `vectors.namesmatch()`, `term.list.formula()`, and `ergm.update.formula()` (renamed to `nosimp.update.formula()`) moved from `ergm`. - Skye Bender-deMoll has been added as a contributor. statnet.common 3.2.3 ==================== - `ERRVL()` moved from `ergm`. - Some `NAMESPACE` and other fixes to pass CRAN checks. statnet.common 3.2.2 ==================== - control class improvements and bug fixes. statnet.common 3.1.1 ==================== - Updated e-mail address - Some improvements to opttest. statnet.common 3.1.0 ==================== - Initial release, incorporating the control class framework (`set.control.class()`, `check.control.class()`, `print.control.list()`); startup message framework; `NVL()`; `sort.data.frame()`; `compress.data.frame()`; `paste.and()`; citation utilities framework; and `opttest()` framework. statnet.common/src/0000755000176200001440000000000015120242451014006 5ustar liggesusersstatnet.common/src/init.c0000644000176200001440000000275415120241143015122 0ustar liggesusers/* File src/init.c in package statnet.common, part of the Statnet suite of * packages for network analysis, https://statnet.org . * * This software is distributed under the GPL-3 license. It is free, open * source, and has the attribution requirements (GPL Section 7) at * https://statnet.org/attribution . * * Copyright 2007-2025 Statnet Commons */ #include #include #include // for NULL #include /* .Call calls */ extern SEXP log_sum_exp_wrapper(SEXP, SEXP); extern SEXP log1mexp_wrapper(SEXP); extern SEXP logspace_wmean_wrapper(SEXP, SEXP); extern SEXP logspace_wmean2_wrapper(SEXP, SEXP); extern SEXP logspace_wmeans_wrapper(SEXP, SEXP); extern SEXP logspace_wxmean_wrapper(SEXP, SEXP, SEXP); extern SEXP sweep2m(SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"log_sum_exp_wrapper", (DL_FUNC) &log_sum_exp_wrapper, 2}, {"log1mexp_wrapper", (DL_FUNC) &log1mexp_wrapper, 1}, {"logspace_wmean_wrapper", (DL_FUNC) &logspace_wmean_wrapper, 2}, {"logspace_wmean2_wrapper", (DL_FUNC) &logspace_wmean2_wrapper, 2}, {"logspace_wmeans_wrapper", (DL_FUNC) &logspace_wmeans_wrapper, 2}, {"logspace_wxmean_wrapper", (DL_FUNC) &logspace_wxmean_wrapper, 3}, {"sweep2m", (DL_FUNC) &sweep2m, 2}, {NULL, NULL, 0} }; void R_init_statnet_common(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } statnet.common/src/logspace_utils.c0000644000176200001440000001565615120241143017201 0ustar liggesusers/* File src/logspace_utils.c in package statnet.common, part of the Statnet * suite of packages for network analysis, https://statnet.org . * * This software is distributed under the GPL-3 license. It is free, open * source, and has the attribution requirements (GPL Section 7) at * https://statnet.org/attribution . * * Copyright 2007-2025 Statnet Commons */ #include #include #include /* * Compute log sum x given log(x) values logx * * log (sum_i exp (logx[i]) ) = * log (e^M * sum_i e^(logx[i] - M) ) = * M + log( sum_i e^(logx[i] - M) * * without causing overflows or throwing much accuracy. * * Based on logspace_sum in pgamma.c in R; unlike that implementation, * it does not use the long double type, sacrificing precision for a * speed gain. */ double log_sum_exp(const double *logx, int n){ if(n == 1) return logx[0]; if(n == 2) return logspace_add(logx[0], logx[1]); // else (n >= 3) : int i; // Mx := max_i log(x_i) double Mx = logx[0]; for(i = 1; i < n; i++) if(Mx < logx[i]) Mx = logx[i]; double s = 0.; for(i = 0; i < n; i++) s += exp(logx[i] - Mx); return Mx + log(s); } SEXP log_sum_exp_wrapper(SEXP logx, SEXP long_double){ long_double = PROTECT(coerceVector(long_double, LGLSXP)); logx = PROTECT(coerceVector(logx, REALSXP)); int n = length(logx); SEXP out = PROTECT(allocVector(REALSXP, 1)); if(LOGICAL(long_double)[0]) REAL(out)[0] = logspace_sum(REAL(logx), n); else REAL(out)[0] = log_sum_exp(REAL(logx), n); UNPROTECT(3); return(out); } /* * Compute a weighted mean of x given log-weights lw * * log (sum_i exp (logx[i]) ) = * log (e^M * sum_i e^(logx[i] - M) ) = * M + log( sum_i e^(logx[i] - M) * * without causing overflows or throwing much accuracy. * Based on logspace_sum in pgamma.c in R. */ double logspace_wmean (const double *x, const double* logw, int n){ if(n == 1) return x[0]; // else (n >= 2) : int i; // Mw := max_i log(w_i) double Mw = logw[0]; for(i = 1; i < n; i++) if(Mw < logw[i]) Mw = logw[i]; double sw = 0., sxw = 0.; for(i = 0; i < n; i++){ double w = exp(logw[i] - Mw); sw += w; sxw += w*x[i]; } return (double) sxw/sw; } SEXP logspace_wmean_wrapper(SEXP x, SEXP logw){ x = PROTECT(coerceVector(x, REALSXP)); logw = PROTECT(coerceVector(logw, REALSXP)); int n = length(x); if(n != length(logw)) error("Lengths of value and log-weight vectors differ."); SEXP out = PROTECT(allocVector(REALSXP, 1)); REAL(out)[0] = logspace_wmean(REAL(x), REAL(logw), n); UNPROTECT(3); return(out); } /* Matrix version of logspace_wmean */ void logspace_wmeans (const double *xm, const double* logw, int n, int p, double *out){ if(n == 1){ memcpy(out, xm, p*sizeof(double)); return; } // else (n >= 2) : int i; // Mw := max_i log(w_i) double Mw = logw[0]; for(i = 1; i < n; i++) if(Mw < logw[i]) Mw = logw[i]; memset(out, 0, p*sizeof(double)); double sw = 0.; for(i = 0; i < n; i++){ double w = exp(logw[i] - Mw); sw += w; for(unsigned int j = 0; j < p; j++) out[j] += w*xm[i + j*n]; } for(unsigned int j = 0; j < p; j++) out[j] /= sw; } SEXP logspace_wmeans_wrapper(SEXP xm, SEXP logw){ int *xdim = INTEGER(PROTECT(getAttrib(xm, R_DimSymbol))); int n = xdim[0], p = xdim[1]; xm = PROTECT(coerceVector(xm, REALSXP)); logw = PROTECT(coerceVector(logw, REALSXP)); if(n != length(logw)) error("Number of rows in the value matrix differs from the length of the log-weights vector."); SEXP out = PROTECT(allocVector(REALSXP, p)); logspace_wmeans(REAL(xm), REAL(logw), n, p, REAL(out)); UNPROTECT(4); return(out); } SEXP sweep2m(SEXP xm, SEXP stats){ int *xdim = INTEGER(PROTECT(getAttrib(xm, R_DimSymbol))); int n = xdim[0], p = xdim[1]; SEXP out = PROTECT(allocMatrix(REALSXP, n, p)); xm = PROTECT(coerceVector(xm, REALSXP)); stats = PROTECT(coerceVector(stats, REALSXP)); /* if(p != length(stats)) error("Number of columns in the value matrix differs from the length of the STATS vector."); */ unsigned int pos = 0; for(unsigned int i=0; i= 2) : int i; // Mw := max_i log(w_i) double Mw = logw[0]; for(i = 1; i < n; i++) if(Mw < logw[i]) Mw = logw[i]; memset(out, 0, p*p*sizeof(double)); double sw = 0.; for(i = 0; i < n; i++){ double w = exp(logw[i] - Mw); sw += w; for(unsigned int j = 0; j < p; j++) for(unsigned int k = 0; k <= j; k++) out[j + k*p] += w*xm[i + j*n]*xm[i + k*n]; } for(unsigned int j = 0; j < p; j++) for(unsigned int k = 0; k <= j; k++){ out[j + k*p] /= sw; out[k + j*p] = out[j + k*p]; } } SEXP logspace_wmean2_wrapper(SEXP xm, SEXP logw){ int *xdim = INTEGER(PROTECT(getAttrib(xm, R_DimSymbol))); int n = xdim[0], p = xdim[1]; xm = PROTECT(coerceVector(xm, REALSXP)); logw = PROTECT(coerceVector(logw, REALSXP)); if(n != length(logw)) error("Number of rows in the value matrix differs from the length of the log-weights vector."); SEXP out = PROTECT(allocMatrix(REALSXP, p, p)); logspace_wmean2(REAL(xm), REAL(logw), n, p, REAL(out)); UNPROTECT(4); return(out); } void logspace_wxmean (const double *xm, const double *ym, const double* logw, int n, int p, int q, double *out) { // else (n >= 2) : int i; // Mw := max_i log(w_i) double Mw = logw[0]; for(i = 1; i < n; i++) if(Mw < logw[i]) Mw = logw[i]; memset(out, 0, p*q*sizeof(double)); double sw = 0.; for(i = 0; i < n; i++){ double w = exp(logw[i] - Mw); sw += w; for(unsigned int j = 0; j < p; j++) for(unsigned int k = 0; k < q; k++) out[j + k*p] += w*xm[i + j*n]*ym[i + k*n]; } for(unsigned int j = 0; j < p; j++) for(unsigned int k = 0; k < q; k++) out[j + k*p] /= sw; } SEXP logspace_wxmean_wrapper(SEXP xm, SEXP ym, SEXP logw){ int *xdim = INTEGER(PROTECT(getAttrib(xm, R_DimSymbol))); int n = xdim[0], p = xdim[1]; int *ydim = INTEGER(PROTECT(getAttrib(ym, R_DimSymbol))); if(n != ydim[0]) error("Numbers of rows in the value matrices differ."); int q = ydim[1]; xm = PROTECT(coerceVector(xm, REALSXP)); ym = PROTECT(coerceVector(ym, REALSXP)); logw = PROTECT(coerceVector(logw, REALSXP)); if(n != length(logw)) error("Number of rows in the value matrices differs from the length of the log-weights vector."); SEXP out = PROTECT(allocMatrix(REALSXP, p, q)); logspace_wxmean(REAL(xm), REAL(ym), REAL(logw), n, p, q, REAL(out)); UNPROTECT(6); return(out); } SEXP log1mexp_wrapper(SEXP xR){ xR = PROTECT(coerceVector(xR, REALSXP)); unsigned int n = length(xR); SEXP outR = PROTECT(allocVector(REALSXP, n)); double *x = REAL(xR), *out = REAL(outR); for(unsigned int i = 0; i < n; i++) *(out++) = log1mexp(*(x++)); UNPROTECT(2); return outR; } statnet.common/NAMESPACE0000644000176200001440000001061015120237037014440 0ustar liggesusers# Generated by roxygen2: do not edit by hand 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) S3method(as.linwmatrix,logwmatrix) S3method(as.linwmatrix,matrix) S3method(as.logwmatrix,linwmatrix) S3method(as.logwmatrix,logwmatrix) S3method(as.logwmatrix,matrix) S3method(as.term_list,default) S3method(as.term_list,term_list) S3method(c,term_list) S3method(compress_rows,data.frame) S3method(compress_rows,linwmatrix) 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) S3method(order,default) S3method(order,matrix) S3method(print,control.list) S3method(print,diff.control.list) S3method(print,linwmatrix) S3method(print,logwmatrix) 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) S3method(trim_env,default) 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) export(COLLATE_ALL_MY_CONTROLS_EXPR) export(ERRVL) export(ERRVL2) export(ERRVL3) export(EVL) export(EVL2) export(EVL3) export(NVL) export(NVL2) export(NVL3) export(UPDATE_MY_SCTRL_EXPR) export(Welford) export(all_identical) export(append.rhs.formula) export(append_rhs.formula) export(arr_from_coo) export(arr_to_coo) export(as.control.list) export(as.linwmatrix) export(as.logwmatrix) export(as.term_list) export(attr) export(base_env) export(check.control.class) export(colMeans.mcmc.list) export(collate_controls) export(compress_rows) export(control.remap) export(deInf) export(decompress_rows) export(default_options) export(despace) export(empty_env) export(enlist) export(envir) export(eval_lhs.formula) export(filter_rhs.formula) export(fixed.pval) export(forkTimeout) export(ginv_eigen) export(handle.controls) export(is.SPD) export(is.linwmatrix) export(is.logwmatrix) export(is.wmatrix) export(lapply.mcmc.list) export(linwmatrix) export(list_rhs.formula) export(list_summands.call) export(locate_function) export(locate_prefixed_function) export(log1mexp) export(log_mean_exp) export(log_sum_exp) export(logwmatrix) export(lrowweights) export(lweighted.cov) export(lweighted.mean) export(lweighted.var) export(match_names) export(message_print) export(modify_in_place) export(nonsimp.update.formula) export(nonsimp_update.formula) export(once) export(opttest) export(order) export(paste.and) export(persistEval) export(persistEvalQ) export(qrsolve) export(qrssolve) export(replace) export(rowweights) export(sandwich_ginv) export(sandwich_qrsolve) export(sandwich_qrssolve) export(sandwich_sginv) export(sandwich_solve) export(sandwich_ssolve) export(set.control.class) export(set_diag) export(sginv) export(simplify_simple) export(skip_if_not_checking) export(snctrl) export(snctrl_names) export(snearPD) export(split_len) export(srcond) export(ssolve) export(statnet.cite.foot) export(statnet.cite.head) export(statnet.cite.pkg) export(statnetStartupMessage) export(sweep.mcmc.list) export(sweep_cols.matrix) export(term.list.formula) export(term_list) export(trim_env) export(ult) export(unused_dots_warning) export(unwhich) export(update_snctrl) export(var.mcmc.list) export(vector.namesmatch) export(which_top_n) export(xAxT) export(xTAx) export(xTAx_eigen) export(xTAx_qrsolve) export(xTAx_qrssolve) export(xTAx_seigen) export(xTAx_solve) export(xTAx_ssolve) importFrom(coda,as.mcmc) importFrom(coda,as.mcmc.list) importFrom(methods,is) importFrom(stats,as.formula) importFrom(stats,na.omit) importFrom(stats,setNames) importFrom(stats,var) importFrom(utils,capture.output) importFrom(utils,getAnywhere) importFrom(utils,modifyList) useDynLib(statnet.common) statnet.common/LICENSE0000644000176200001440000000311315015614465014235 0ustar liggesusers-------------------------------------------------- License for the 'statnet' component package 'statnet.common' -------------------------------------------------- This software is distributed under the GPL-3 license. It is free, open source, and has the following attribution requirements (GPL Section 7): (a) you agree to retain in 'statnet.common' and any modifications to 'statnet.common' the copyright, author attribution and URL information as provided at http://statnet.org/attribution (b) you agree that 'statnet.common' and any modifications to 'statnet.common' will, when used, display the attribution: Based on 'statnet' project software (http://statnet.org). For license and citation information see http://statnet.org/attribution -------------------------------------------------- What does this mean? ==================== If you are modifying 'statnet.common' or adopting any source code from 'statnet.common' for use in another application, you must ensure that the copyright and attributions mentioned in the license above appear in the code of your modified version or application. These attributions must also appear when the package is loaded (e.g., via 'library' or 'require'). Enjoy! Mark S. Handcock, University of California - Los Angeles David R. Hunter, Penn State University Carter T. Butts, University of California - Irvine Steven M. Goodreau, University of Washington Pavel N. Krivitsky, University of New South Wales Michał Bojanowski, Kozminski University Martina Morris, University of Washington The 'statnet' development team Copyright 2007-2025 statnet.common/NEWS.md0000644000176200001440000003200715120240057014317 0ustar liggesusers# statnet.common 4.13.0 ## New utilities * New `testthat` predicate, `skip_if_not_checking()`, that skips the test if it's not part of an `R CMD check`, e.g., if run by `testthat::test_local()`. * New function, `enlist()` to wrap an object into a singleton list if it's not already a list, for various definitions of "list". * New function, `which_top_n()`, to return the indices of top or bottom `n` elements of a vector, with several methods for resolving ties. * New function, `split_len()` to split a split()-able object by lengths. ## Enhancements to existing utilities * `term_list` objects now have `envir()`, `envir<-()`, `sign()`, and `sign<-()` methods to better encapsulate their environment and sign information. * `ERRVL*()` functions if not given any non-erroring expressions now throw the last error rather than a generic message. # statnet.common 4.12.0 ## New utilities * New matrix functions: `qrssolve()` to solve linear systems via QR decomposition after scaling, and `qrsolve()` to do the same without scaling, along with `sandwich_qrsolve()`, `sandwich_qrssolve()`, `sandwich_ginv()`, and `sandwich_sginv()`. * New function, `match_names()` to replace `vector.namesmatch()` with more flexible behavior and error checking. * New functions, `ERRVL2()` and `ERRVL3()` that, unlike `ERRVL()`, do not require the expressions to be wrapped in `try()`. * New function, `replace()`, a more pipe-friendly drop-in replacement for `base::replace()` for which replacement indices and values can be specified as functions evaluated on the input vector. `replace()<-` is also implemented, allowing the list to be modified in place. * New pair of functions, `arr_to_coo()` and `arr_from_coo()`, to translate between an array and its list of non-default values. * New function, `set_diag()` to set a diagonal of a matrix to specified values and return (as opposed to modifying it in place). ## Enhancements to existing utilities * `statnetStartupMessage()` now prints `Remote:` information if the package was installed from a remote. * Matrices returned by the `lweighted.*()` family of functions now inherit dimensional names. * `xTAx_eigen()` (and therefore `xTAx_seigen()`) now handle matrix-valued x correctly and check that `x` is in the span of `A`. * Scaling version of matrix operations now use `.Machine$double.xmax/(1 + .Machine$double.eps)` as the inverse of the zero diagonal. * `all_identical()` can now use a custom comparison predicate (e.g., `all.equal()`), and the use any of the elements in the list as the reference. (Thanks to Michał Bojanowski @mbojan.) # statnet.common 4.11.0 ## New utilities * New function, `modify_in_place()`, that attempts to modify the argument of its caller in place. A function can call it to modify its own arguments in place. * New function, `log1mexp(x)` to compute `log(1-exp(-x))` minimizing the loss of precision. R provides a C macro `log1mexp(x)` but not the corresponding R wrapper. ## Enhancements to existing utilities * The behavior of `trim_env()` has changed: if no variables are to be copied in, the environment is set directly to `baseenv()`. # statnet.common 4.10.0 ## New utilities * New linear algebra utilities: `ginv_eigen()`, which performs generalised inverse via eigendecomposition rather than SVD, to be used by `sginv()` if `snnd=TRUE`; and `xTAx_eigen()` and `xTAx_seigen()` to evaluate the inverse quadratic form using eigendecomposition. * A new function `var.mcmc.list()` "method" to evaluate the covariance matrix for an `mcmc.list` without constructing a large matrix. ## Enhancements to existing utilities * `colMeans.mcmc.list()` "method" no longer constructs a large matrix when calculating. * `lweighted.var()` and `lweighted.cov()` now take an additional argument `onerow=` to specify what they should return (`NA`, 0, or something else) if the input matrix has one row. ## Bug fixes * `as.cntrol.list.list()` and hence `snctrl()` no longer clobbers nested controls, e.g., `control.ergm(SAN=control.san(...),...)`. * To facilitate support for earlier versions of R, avoid using the built-in pipe (`|>`) for now. # statnet.common 4.9.0 ## New utilities * A new function,`lweighted.cov()`, to compute weighted covariance between two matrices or vectors. * New linear algebra utilities, `is.SPD()`, `sandwich_solve()`, `sandwich_ssolve()`, `sginv()`, `snearPD()`, `srcond()`, `ssolve()`, `xAxT()`, `xTAx()`, `xTAx_qrsolve()`, `xTAx_qrssolve()`, `xTAx_solve()`, and `xTAx_ssolve()` moved from `ergm` and documented. ## Bug fixes * In `handle.controls()`, arguments that are `match.arg()`-ed are now evaluated in the correct frame. # statnet.common 4.8.0 ## New utilities * A helper function `unused_dots_warning()` is exported that works with `rlang::check_dots_used()` to print an informative message. # statnet.common 4.7.0 ## New utilities * An S3 class `term_list` for storing terms extracted from a formula, by `list_rhs.formula()` and others, containing information about each term's sign and environment. Concatenation, indexing, and print methods are implemented. ## Bug fixes * `list_rhs.formula()` can now handle `NULL` terms on the RHS. # statnet.common 4.6.0 ## New utilities * An implementation of Welford's online algorithm for calculating sample mean and variance has been added as a class `Welford` that implements method `update()` and maintains elements `$n`, `$means`, `$SSDs`, and `$vars`. ## Bug fixes * `snctrl()` was issuing a warning twice when called with a misspelled argument. * `deInf()` now handles `NULL` input. * in `locate_function()` a subtle bug has been fixed in handling of visible as opposed to invisible objects. # statnet.common 4.5.0 ## New utilities * `ergm`'s term locator functions (`locate_function()` and `locate_prefixed_function()`) have been moved from `ergm`. * A new function, `default_options()`, a wrapper around `options()` that drops options already set. * A new function, `as.control.list()` generic and methods which take an R list and call an appropriate `control.*()` function on it. * `check.control.class()` now first runs the control argument through `as.control.list()` and overwrites, so `control=` arguments to many functions can be plain lists. * A new function, `simplify_simple()`, which takes a list and returns an atomic vector if the elements of the list are atomic and of length 1, with particular handling for `NULL` and empty (0-length) elements. * A new function, `snctrl()` (StatNet ConTRoL), designed so that argument completion will complete all available control functions. Looking up its help (`?snctrl`) produces a dynamic list of all control parameters and their packages and control functions that is updated as packages are loaded and unloaded. * A new function, `handle.controls()`, that performs the most normal functions in a `control.*()` function. * Two trivial helper functions, `base_env()` and `empty_env()`, to replace an object's environment with `baseenv()` and `emptyenv()`, respectively. * A new function, `fixed.pval()` that wraps `base::format.pval()` with better default arguments. * A reimplementation of `attr()` is exported, which disables partial matching by default. ## Enhancements to existing utilities * `statnetStartupMessage()` now first looks for a `comment=(affil=...)` for the contributor's affiliation, before using e-mail. * Improved output formatting for `.Deprecate_once()`. * `append_rhs.formula()` now accepts NULL as the first argument, in which case it creates a new formula, and takes an additonal argument `env=`, which is used as this new formula's environment. ## Miscellaneous changes * `rle` utilities are no longer reexported. * `statnet.common` no longer depends on `purrr`. * `statnetStartupMessage()` has been simplified. # statnet.common 4.4.0 ## `rle` utilities have been moved to a separate package, `rle` * Major methods are reexported, for now. ## New utilities * `split()` methods for matrices and arrays, to split them along a margin. * `trim_env()`, a generic that will replace an environment (possibly attached to another object) with a sub-environment containing only objects whose names are specified. * A `diff()` method for control lists and a `print()` method for the resulting differences. * `deInf()`, to replace `.deinf()` in package `ergm`. * A `compress()` generic, a `compress()` method for RLEs, and a `doNotCompress` argument to `rep.rle()`. Both `compact.rle()` and the `doNotCompact` argument to `rep.rle()` are now deprecated. ## Enhancements to existing utilities * Various optimizations have been made to RLEs. * `nonsimp_update.formula()` now handles both one and two sided formulas; it also now copies all names except `...` when `from.new = TRUE`. ## Bug fixes * `str.rle()` now works despite the overridden `length()` method. # statnet.common 4.3.0 ## New utilities * `EVL()`, a family of functions like `NVL()`, that treat any object of length 0 as `NULL`. * `once()`, a `purrr`-style adverb that wraps a function to only evaluate the first time it's called with a given configuration of arguments. * `persistEval()` and `persistEvalQ()` to retry evaluating a given expression a specified number of times. ## Bug fixes * In `forkTimeout()`, don't collect a process twice. Thanks to Tomas Kalibera for suggesting the fix. # statnet.common 4.2.0 ## New utilities * `.Deprecate_once()` calls `.Deprecated()`, passing all its arguments through, but only the first time it's called. * `.Deprecate_method()` calls `.Deprecated()`, but only if a method has been called by name, i.e., `METHOD.CLASS`. * `forkTimeout()` evaluates an R expression with a hard time limit (except on Windows) by forking a process. Unlike `setTimeLimit()`, it enforces the limit even on native code. * `ult()` is a convenience function that extracts or replaces elements of a list indexed from the end. ## Miscellaneous * `statnet.common` now depends on R >= 3.5 due to what appears to be a method dispatching bug in earlier versions. * The package no longer Enhances `coda`. # statnet.common 4.1.4 ## New utilities * `despace()` removes whitespace from a string. * Pseudo-methods `colMeans.mcmc.list()`, `sweep.mcmc.list()`, and `lapply.mcmc.list()` (migrated from the `ergm` package). * `filter_rhs.formula()` selectively deletes terms in on the RHS of a formula. * `eval_lhs.formula()` extracts the LHS of the formula and evaluates it in the specified environment. * `NVL2()` and `NVL3()` for flexible substitution of null values. * `message_print()` formats its arguments as if for `print()` or `show()` methods, but then prints to stderr like `message()`. ## Enhancements to existing utilities * `paste.and()` now takes an additional `con=` argument, allowing a conjunction other than "and" to be used. * `ERRVL()` now uses lazy evaluation and lets the user dot-substitute the previous argument's try-error into the next argument. ## Bug fixes * Printing for control lists now works for function arguments. * A number of improvements to `rle` methods. ## Miscellaneous * A number of functions have been renamed for consistency: * `term.list.formula()` → `list_rhs.formula()` * `append.rhs.formula()` → `append_rhs.formula()` * `nonsimp.update.formula()` → `nonsimp_update.formula()` * Citation utilities have been deprecated, since CRAN's structure makes them unusable. # statnet.common 4.0.0 * The package now uses `Roxygen` for documentation. * `term.list.formula()` output format has been changed, since support of attributes on symbols is being deprecated. * A library of methods has been added for the base `rle` class, implementing concatenation, compaction, and a number of binary operations. * `all_same()` has been moved from ergm and renamed to `all_identical()`. * A new assignment method `NVL()<-` overwrites a variable if its value is NULL. * A set of classes and functions for manipulating and efficiently performing calculations on dense matrices or vectors with weighted rows or elements (possibly on the log scale) has been added. * New control parameter helper function, control.remap() has been added. Autodetection of function names by `set.control.class()` and `check.control.class()` has been deprecated and now results in a warning. * Improvements to the compressed data frame code, including an order() generic. * Miscellaneous robustifications added. * Native routine registration has been added. # statnet.common 3.3.0 * `append.rhs.formula()`, `vectors.namesmatch()`, `term.list.formula()`, and `ergm.update.formula()` (renamed to `nosimp.update.formula()`) moved from `ergm`. * Skye Bender-deMoll has been added as a contributor. # statnet.common 3.2.3 * `ERRVL()` moved from `ergm`. * Some `NAMESPACE` and other fixes to pass CRAN checks. # statnet.common 3.2.2 * control class improvements and bug fixes. # statnet.common 3.1.1 * Updated e-mail address * Some improvements to opttest. # statnet.common 3.1.0 * Initial release, incorporating the control class framework (`set.control.class()`, `check.control.class()`, `print.control.list()`); startup message framework; `NVL()`; `sort.data.frame()`; `compress.data.frame()`; `paste.and()`; citation utilities framework; and `opttest()` framework. statnet.common/inst/0000755000176200001440000000000015016302635014201 5ustar liggesusersstatnet.common/inst/CITATION0000644000176200001440000000342215120241337015334 0ustar liggesusers#' statnet: statnet.cite.head("statnet.common") # ---- BEGIN AUTOGENERATED STATNET CITATION ---- citHeader(paste0(sQuote("statnet.common"), " is part of the Statnet suite of packages. ", "If you are using the ", sQuote("statnet.common"), " package for research that will be published, ", "we request that you acknowledge this by citing the following.\n", "For BibTeX format, use toBibtex(citation(\"", "statnet.common", "\")).")) # ---- END AUTOGENERATED STATNET CITATION ---- #' statnet: statnet.cite.pkg("statnet.common") # ---- BEGIN AUTOGENERATED STATNET CITATION ---- bibentry("Manual", author = structure(list(list(given = c("Pavel", "N."), family = "Krivitsky", role = c("aut", "cre"), email = "pavel@statnet.org", comment = c(ORCID = "0000-0002-9101-3362", affiliation = "University of New South Wales" ))), class = "person"), title = paste("statnet.common", ": ", gsub("\n", " ", "Common R Scripts and Utilities Used by the Statnet Project Software", fixed = TRUE), sep = ""), organization = paste0("The Statnet Project (\\url{", "https://statnet.org", "})"), year = substr("2025-12-16", 1, 4), note = paste("R package version ", "4.13.0", sep = ""), url = paste0("https://CRAN.R-project.org/package=", "statnet.common")) # ---- END AUTOGENERATED STATNET CITATION ---- #' statnet: statnet.cite.foot("statnet.common") # ---- BEGIN AUTOGENERATED STATNET CITATION ---- citFooter(paste0("We have invested a lot of time and effort in creating the ", "Statnet suite of packages for use by other researchers. ", "Please cite it in all papers where it is used. The package ", sQuote("statnet.common"), " is distributed under the terms of the license ", "GPL-3 + file LICENSE", ".")) # ---- END AUTOGENERATED STATNET CITATION ---- statnet.common/inst/templates/0000755000176200001440000000000015120241142016166 5ustar liggesusersstatnet.common/inst/templates/snctrl.R0000644000176200001440000000326015120241142017617 0ustar liggesusers# File inst/templates/snctrl.R in package statnet.common, part of the Statnet # suite of packages for network analysis, https://statnet.org . # # This software is distributed under the GPL-3 license. It is free, open # source, and has the attribution requirements (GPL Section 7) at # https://statnet.org/attribution . # # Copyright 2007-2025 Statnet Commons ################################################################################ # This document provides a template for exporting a package's # control.* functions to be visible to snctrl() and providing a # sensible help document. Currently, the packages have to be updated # manually when the template changes. ## Usage: # 1. Add the following line: # "eval(statnet.common::COLLATE_ALL_MY_CONTROLS_EXPR)" to the # .onLoad() function. It is important that the function's arguments # have their standard names ("libname" and "pkgname"). # # 2. Add the following text block to provide help. Note that the NULL is important, because otherwise, Roxygen will create an unsightly usage statement. # # 3. Run roxygen. # TODO: Figure out some automatic way to keep this in sync with statnet.common. ## BEGIN text block #' @name snctrl #' #' @title Statnet Control #' #' @description A utility `snctrl(...)`, to facilitate argument completion of control lists, reexported from `statnet.common`. #' #' @section Currently recognised control parameters: #' This list is updated as packages are loaded and unloaded. #' #' \Sexpr[results=rd,stage=render]{statnet.common::snctrl_names()} #' #' @seealso [statnet.common::snctrl()] #' @docType import NULL #' @export snctrl <- statnet.common::snctrl eval(UPDATE_MY_SCTRL_EXPR) # END text block statnet.common/build/0000755000176200001440000000000015120242451014316 5ustar liggesusersstatnet.common/build/stage23.rdb0000644000176200001440000000633615120242451016267 0ustar liggesuserskWUx'd7n@SHДA iӍ94 FdI~==HWb$ 9GjΝ(oA "'^"Ϲ3,AXkEƽ%QŢChȆ*sow]#^|j'Jl[D)f`鈠y9Bҿa( ov.FP p DvdF0sG#78r$V;:˶?rWs[m~u8lThiV^yZki:/<)QșSpJS6*8>W6wFXhy7$w6BDbnpQ~Bғ -6EJ b fՊ \tѐ=W<>!s 8 /> )3Ā” S'_6O92:W8 p/2q$/l>rGיz2{2 kQuMc7[r e?@2rضWf5$"39:/]  /~}C_f \=&wRq յy•,^NN,R uųEe˻O;Bʞ_WҟV{HI( W`r^&=i є-2:uvD[V65E(ۄP#Ae'5 UWSܷD*Ė}R%*-"-bԮ t| C'~ >1v>*e@2~P]BPϲZ CR0]:|' e]YS[tX: ɒԑuV\nsIu`:Ga̢jXRXI 8vq5tq5VJ3@RZe|p 4 ͱ^uf\y /L 뀯ѯNEhb`u 7E4H@-&.NEbrHlٚKr]\M k@IHLF(i $p qo s򥀲{p_vsEf\ȚA|-}^>=mN3f", MŞvx]~jly-KAkLI-}(|*bpˉ:p𞂈˵_1Lv 9>ݜc]tZŵHqۛly !XwSK1W?!uꕼY40W2pD2 CZ[!5`}G5H_|T! iSxv:ⲝrx s$kV /C 5Uubćt^ d"Zj+2]#n7 !zCgjľti\iZvbB 54R.aN( ۈ.w{֖T ]*B40Z (։%7Af _:}3NkfcFŞ$[9 ~g{#+_Y~mR/Ҥ) b*1nN>9T* Yy%JŦXFg%U8vġoC3 dvq0(Aj@ ?em0 7JR]mY,W~IFsa1G#*OHE0’+djAF9耞EuO/\rKIf0Wp>1ǟuö4jÑu܂GiD5D+hux;^ =S]&V(~YF |h5S 9`ex 2&ɮ2}v̦a#QeŲ ='t^28L"Cؘe_ߓN26BncsD"msLE&,!/ (J!L])fCX4G9EưUS7Ywjʚg15c!(͔`{5vEzp3;_! 쐗jJA̢ :T4Ƶ]/Z俉uSMiFL9k1kp R(4Cٓių;!sVu{ii?'&'fĉ{۟8UOL2]ѿ:~:-ӧO.E!g6n:,ܹ|P&eO@c wEkZxWw3P\]?%J.IltMsRkL闲V]}"d!w 8Tб窳(v+POw,"/Hl)P6U*/EOiŞ+e[ x ,|tE?sB1T &Ïo<~L_՘iC}Bmk|S}wcPwK]BiLO_ UZuskg3[E02c l@aUDVaK= 1}. (Defaults to "and".)} } \value{ A string with the output. } \description{ A vector \code{x} becomes "\code{x[1]}", "\code{x[1]} and \code{x[2]}", or "\code{x[1]}, \code{x[2]}, and \code{x[3]}", depending on the langth of \code{x}. } \examples{ print(paste.and(c())) print(paste.and(1)) print(paste.and(1:2)) print(paste.and(1:3)) print(paste.and(1:4,con='or')) } \seealso{ paste, cat } \keyword{utilities} statnet.common/man/fixed.pval.Rd0000644000176200001440000000270614045135346016337 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/string.utilities.R \name{fixed.pval} \alias{fixed.pval} \title{Format a p-value in fixed notation.} \usage{ fixed.pval( pv, digits = max(1, getOption("digits") - 2), eps = 10^-digits, na.form = "NA", ... ) } \arguments{ \item{pv, digits, eps, na.form, ...}{see \code{\link[=format.pval]{format.pval()}}.} } \value{ A character vector. } \description{ This is a thin wrapper around \code{\link[=format.pval]{format.pval()}} that guarantees fixed (not scientific) notation, links (by default) the \code{eps} argument to the \code{digits} argument and vice versa, and sets \code{nsmall} to equal \code{digits}. } \examples{ pvs <- 10^((0:-12)/2) # Jointly: fpf <- fixed.pval(pvs, digits = 3) fpf format.pval(pvs, digits = 3) # compare \dontshow{ stopifnot(all(fpf == c("1.000", "0.316", "0.100", "0.032", "0.010", "0.003", "0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001"))) } # Individually: fpf <- sapply(pvs, fixed.pval, digits = 3) fpf sapply(pvs, format.pval, digits = 3) # compare \dontshow{ stopifnot(all(fpf == c("1.000", "0.316", "0.100", "0.032", "0.010", "0.003", "0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001"))) } # Control eps: fpf <- sapply(pvs, fixed.pval, eps = 1e-3) fpf \dontshow{ stopifnot(all(fpf == c("1.000", "0.316", "0.100", "0.032", "0.010", "0.003", "0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001", "<0.001"))) } } statnet.common/man/wmatrix_weights.Rd0000644000176200001440000000375313701734650017530 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/wmatrix.R \name{wmatrix_weights} \alias{wmatrix_weights} \alias{rowweights} \alias{rowweights.linwmatrix} \alias{rowweights.logwmatrix} \alias{lrowweights} \alias{lrowweights.logwmatrix} \alias{lrowweights.linwmatrix} \alias{rowweights<-} \alias{rowweights<-.linwmatrix} \alias{rowweights<-.logwmatrix} \alias{lrowweights<-} \alias{lrowweights<-.linwmatrix} \alias{lrowweights<-.logwmatrix} \alias{rowweights<-.matrix} \alias{lrowweights<-.matrix} \title{Set or extract weighted matrix row weights} \usage{ rowweights(x, ...) \method{rowweights}{linwmatrix}(x, ...) \method{rowweights}{logwmatrix}(x, ...) lrowweights(x, ...) \method{lrowweights}{logwmatrix}(x, ...) \method{lrowweights}{linwmatrix}(x, ...) rowweights(x, ...) <- value \method{rowweights}{linwmatrix}(x, update = TRUE, ...) <- value \method{rowweights}{logwmatrix}(x, update = TRUE, ...) <- value lrowweights(x, ...) <- value \method{lrowweights}{linwmatrix}(x, update = TRUE, ...) <- value \method{lrowweights}{logwmatrix}(x, update = TRUE, ...) <- value \method{rowweights}{matrix}(x, ...) <- value \method{lrowweights}{matrix}(x, ...) <- value } \arguments{ \item{x}{a \code{\link{linwmatrix}}, a \code{\link{logwmatrix}}, or a \code{\link{matrix}}; a \code{\link{matrix}} is coerced to a weighted matrix of an appropriate type.} \item{...}{extra arguments for methods.} \item{value}{weights to set, on the appropriate scale.} \item{update}{if \code{TRUE} (the default), the old weights are updated with the new weights (i.e., corresponding weights are multiplied on linear scale or added on on log scale); otherwise, they are overwritten.} } \value{ For the accessor functions, the row weights or the row log-weights; otherwise, a weighted matrix with modified weights. The type of weight (linear or logarithmic) is converted to the required type and the type of weighting of the matrix is preserved. } \description{ Set or extract weighted matrix row weights } statnet.common/man/despace.Rd0000644000176200001440000000057613701734650015707 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/string.utilities.R \name{despace} \alias{despace} \title{A one-line function to strip whitespace from its argument.} \usage{ despace(s) } \arguments{ \item{s}{a character vector.} } \description{ A one-line function to strip whitespace from its argument. } \examples{ stopifnot(despace("\n \t ")=="") } statnet.common/man/control.list.accessor.Rd0000644000176200001440000000172013701734650020526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{control.list.accessor} \alias{control.list.accessor} \alias{$.control.list} \title{Named element accessor for ergm control lists} \usage{ \method{$}{control.list}(object, name) } \arguments{ \item{object}{list-coearceable object with elements to be searched} \item{name}{literal character name of list element to search for and return} } \value{ Returns the named list element exactly matching \code{name}, or \code{NULL} if no matching elements found } \description{ Utility method that overrides the standard `$' list accessor to disable partial matching for ergm \code{control.list} objects } \details{ Executes \code{\link[base]{getElement}} instead of \code{\link[base]{$}} so that element names must match exactly to be returned and partially matching names will not return the wrong object. } \seealso{ see \code{\link{getElement}} } \author{ Pavel N. Krivitsky } statnet.common/man/set.control.class.Rd0000644000176200001440000000173713701734650017661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{set.control.class} \alias{set.control.class} \title{Set the class of the control list} \usage{ set.control.class( myname = as.character(ult(sys.calls(), 2)[[1L]]), control = get("control", pos = parent.frame()) ) } \arguments{ \item{myname}{Name of the class to set.} \item{control}{Control list. Defaults to the \code{control} variable in the calling function.} } \value{ The control list with class set. } \description{ This function sets the class of the control list, with the default being the name of the calling function. } \note{ In earlier versions, \code{OKnames} and \code{myname} were autodetected. This capability has been deprecated and results in a warning issued once per session. They now need to be set explicitly. } \seealso{ \code{\link[=check.control.class]{check.control.class()}}, \code{\link[=print.control.list]{print.control.list()}} } \keyword{utilities} statnet.common/man/statnet.cite.Rd0000644000176200001440000000241313701734650016700 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cite.utilities.R \name{statnet.cite} \alias{statnet.cite} \alias{statnet.cite.head} \alias{statnet.cite.foot} \alias{statnet.cite.pkg} \title{\code{CITATION} file utilities for Statnet packages (DEPRECATED)} \usage{ statnet.cite.head(pkg) statnet.cite.foot(pkg) statnet.cite.pkg(pkg) } \arguments{ \item{pkg}{Name of the package whose citation is being generated.} } \value{ For \code{statnet.cite.head} and \code{statnet.cite.foot}, an object of type \code{citationHeader} and \code{citationFooter}, respectively, understood by the \code{\link{citation}} function, with package name substituted into the template. For \code{statnet.cite.pkg}, an object of class \code{\link{bibentry}} containing a 'software manual' citation for the package constructed from the current version and author information in the \code{DESCRIPTION} and a template. } \description{ These functions automate citation generation for Statnet Project packages. They no longer appear to work with CRAN and are thus deprecated. } \examples{ \dontrun{ statnet.cite.head("statnet.common") statnet.cite.pkg("statnet.common") statnet.cite.foot("statnet.common") } } \seealso{ citation, citHeader, citFooter, bibentry } \keyword{utilities} statnet.common/man/skip_if_not_checking.Rd0000644000176200001440000000055515054302502020425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/test.utilities.R \name{skip_if_not_checking} \alias{skip_if_not_checking} \title{Skip a test if not called via \verb{R CMD} \code{\link{check}}} \usage{ skip_if_not_checking() } \description{ A \CRANpkg{testthat} predicate to skip tests if not run as a part of a package \link{check}. } statnet.common/man/wmatrix.Rd0000644000176200001440000000726113711220501015756 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/wmatrix.R \name{wmatrix} \alias{wmatrix} \alias{logwmatrix} \alias{linwmatrix} \alias{is.wmatrix} \alias{is.logwmatrix} \alias{is.linwmatrix} \alias{as.linwmatrix} \alias{as.logwmatrix} \alias{as.linwmatrix.linwmatrix} \alias{as.linwmatrix.logwmatrix} \alias{as.logwmatrix.logwmatrix} \alias{as.logwmatrix.linwmatrix} \alias{as.linwmatrix.matrix} \alias{as.logwmatrix.matrix} \alias{print.wmatrix} \alias{print.logwmatrix} \alias{print.linwmatrix} \alias{compress_rows.logwmatrix} \alias{compress_rows.linwmatrix} \alias{decompress_rows.wmatrix} \alias{[.wmatrix} \alias{[<-.wmatrix} \title{A data matrix with row weights} \usage{ logwmatrix( data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL, w = NULL ) linwmatrix( data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL, w = NULL ) is.wmatrix(x) is.logwmatrix(x) is.linwmatrix(x) as.linwmatrix(x, ...) as.logwmatrix(x, ...) \method{as.linwmatrix}{linwmatrix}(x, ...) \method{as.linwmatrix}{logwmatrix}(x, ...) \method{as.logwmatrix}{logwmatrix}(x, ...) \method{as.logwmatrix}{linwmatrix}(x, ...) \method{as.linwmatrix}{matrix}(x, w = NULL, ...) \method{as.logwmatrix}{matrix}(x, w = NULL, ...) \method{print}{wmatrix}(x, ...) \method{print}{logwmatrix}(x, ...) \method{print}{linwmatrix}(x, ...) \method{compress_rows}{logwmatrix}(x, ...) \method{compress_rows}{linwmatrix}(x, ...) \method{decompress_rows}{wmatrix}(x, target.nrows = NULL, ...) \method{[}{wmatrix}(x, i, j, ..., drop = FALSE) \method{[}{wmatrix}(x, i, j, ...) <- value } \arguments{ \item{data, nrow, ncol, byrow, dimnames}{passed to \code{\link{matrix}}.} \item{w}{row weights on the appropriate scale.} \item{x}{an object to be coerced or tested.} \item{...}{extra arguments, currently unused.} \item{target.nrows}{the approximate number of rows the uncompressed matrix should have; if not achievable exactly while respecting proportionality, a matrix with a slightly different number of rows will be constructed.} \item{i, j, value}{rows and columns and values for extraction or replacement; as \code{\link{matrix}}.} \item{drop}{Used for consistency with the generic. Ignored, and always treated as \code{FALSE}.} } \value{ An object of class \code{linwmatrix}/\code{logwmatrix} and \code{wmatrix}, which is a \code{\link{matrix}} but also has an attribute \code{w} containing row weights on the linear or the natural-log-transformed scale. } \description{ A representation of a numeric matrix with row weights, represented on either linear (\code{linwmatrix}) or logarithmic (\code{logwmatrix}) scale. } \note{ Note that \code{wmatrix} itself is an "abstract" class: you cannot instantiate it. Note that at this time, \code{wmatrix} is designed as, first and foremost, as class for storing compressed data matrices, so most methods that operate on matrices may not handle the weights correctly and may even cause them to be lost. } \examples{ (m <- matrix(1:3, 2, 3, byrow=TRUE)) (m <- rbind(m, 3*m, 2*m, m)) (mlog <- as.logwmatrix(m)) (mlin <- as.linwmatrix(m)) (cmlog <- compress_rows(mlog)) (cmlin <- compress_rows(mlin)) stopifnot(all.equal(as.linwmatrix(cmlog),cmlin)) cmlog[2,] <- 1:3 (cmlog <- compress_rows(cmlog)) stopifnot(sum(rowweights(cmlog))==nrow(m)) (m3 <- matrix(c(1:3,(1:3)*2,(1:3)*3), 3, 3, byrow=TRUE)) (rowweights(m3) <- c(4, 2, 2)) stopifnot(all.equal(compress_rows(as.logwmatrix(m)), as.logwmatrix(m3),check.attributes=FALSE)) stopifnot(all.equal(rowweights(compress_rows(as.logwmatrix(m))), rowweights(as.logwmatrix(m3)),check.attributes=FALSE)) } \seealso{ \code{\link{rowweights}}, \code{\link{lrowweights}}, \code{\link{compress_rows}} } statnet.common/man/arr_from_coo.Rd0000644000176200001440000000360215016066617016745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/matrix.utils.R \name{arr_from_coo} \alias{arr_from_coo} \alias{arr_to_coo} \title{Conveniently covert between coordinate-value and array representations} \usage{ arr_from_coo(x, coord, dim = lengths(dimnames), x0 = NA, dimnames = NULL) arr_to_coo(X, x0, na.rm = FALSE) } \arguments{ \item{x}{values of elements differing from the default.} \item{coord}{an integer matrix of their indices.} \item{dim}{dimension vector; recycled to \code{ncol(coord)}; if not given, inferred from \code{dimnames}.} \item{x0}{the default value.} \item{dimnames}{dimension name list.} \item{X}{an array.} \item{na.rm}{whether the \code{NA} elements of the array should be omitted from the list.} } \value{ \code{coo_to_arr()} returns a matrix or an array. \code{arr_to_coo()} returns a list with the following elements: \item{\code{x}}{the values distinct from \code{x0}} \item{\code{coord}}{a matrix with a column for each dimension containing indexes of values distinct from \code{x0}} \item{\code{dim}}{the dimension vector of the matrix} \item{\code{dimnames}}{the dimension name list of the matrix} } \description{ These function similarly to \CRANpkg{Matrix}'s utilities but is simpler and allows arbitrary baseline and handling of missing values. (It is also almost certainly much slower.) Also, since it is likely that operations will be performed on the elements of the array, their argument is first for easier piping. } \details{ If \code{x0} is \code{NA}, non-\code{NA} elements are returned; if \code{x0} is \code{NULL}, all elements are. } \examples{ m <- matrix(rpois(25, 1), 5, 5) arr_to_coo(m, 0L) stopifnot(identical(do.call(arr_from_coo, arr_to_coo(m, 0L)), m)) stopifnot(length(arr_to_coo(m, NULL)$x) == 25) # No baseline m[sample.int(25L, 2L)] <- NA m arr_to_coo(m, 0L) # Return NAs arr_to_coo(m, 0L, na.rm = TRUE) # Drop NAs } statnet.common/man/default_options.Rd0000644000176200001440000000177013744456436017511 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/startup.utilities.R \name{default_options} \alias{default_options} \title{Set \code{\link[=options]{options()}} according to a named list, skipping those already set.} \usage{ default_options(...) } \arguments{ \item{...}{see \code{\link[=options]{options()}}: either a list of \code{name=value} pairs or a single unnamed argument giving a named list of options to set.} } \value{ The return value is same as that of \code{\link[=options]{options()}} (omitting options already set). } \description{ This function can be useful for setting default options, which do not override options set elsewhere. } \examples{ options(onesetting=1) default_options(onesetting=2, anothersetting=3) stopifnot(getOption("onesetting")==1) # Still 1. stopifnot(getOption("anothersetting")==3) default_options(list(yetanothersetting=5, anothersetting=4)) stopifnot(getOption("anothersetting")==3) # Still 3. stopifnot(getOption("yetanothersetting")==5) } statnet.common/man/control.remap.Rd0000644000176200001440000000155013701734650017057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{control.remap} \alias{control.remap} \title{Overwrite control parameters of one configuration with another.} \usage{ control.remap(control, from, to) } \arguments{ \item{control}{An object of class \code{control.list}.} \item{from}{Prefix of the source of control parameters.} \item{to}{Prefix of the destination of control parameters.} } \value{ An \code{control.list} object. } \description{ Given a \code{control.list}, and two prefixes, \code{from} and \code{to}, overwrite the elements starting with \code{to} with the corresponding elements starting with \code{from}. } \examples{ (l <- set.control.class("test", list(a.x=1, a.y=2))) control.remap(l, "a", "b") } \seealso{ \code{\link{print.control.list}} } \author{ Pavel N. Krivitsky } \keyword{utilities} statnet.common/man/check.control.class.Rd0000644000176200001440000000435513770731134020142 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{check.control.class} \alias{check.control.class} \title{Ensure that the class of the control list is one of those that can be used by the calling function} \usage{ check.control.class( OKnames = as.character(ult(sys.calls(), 2)[[1L]]), myname = as.character(ult(sys.calls(), 2)[[1L]]), control = get("control", pos = parent.frame()) ) } \arguments{ \item{OKnames}{List of control function names which are acceptable.} \item{myname}{Name of the calling function (used in the error message).} \item{control}{The control list or a list to be converted to a control list using \code{control.myname()}. Defaults to the \code{control} variable in the calling function. See Details for detailed behavior.} } \value{ A valid control list for the function in which it is to be used. If \code{control} argument is missing, it will also overwrite the variable \code{control} in the calling environment with it. } \description{ This function converts an ordinary \code{list} into a control list (if needed) and checks that the control list passed is appropriate for the function to be controlled. } \details{ \code{check.control.class()} performs the check by looking up the class of the \code{control} argument (defaulting to the \code{control} variable in the calling function) and checking if it matches a list of acceptable given by \code{OKnames}. Before performing any checks, the \code{control} argument (including the default) will be converted to a control list by calling \code{\link[=as.control.list]{as.control.list()}} on it with the first element of \code{OKnames} to construct the control function. If \code{control} is missing, it will be assumed that the user wants to modify it in place, and a variable with that name in the parent environment will be overwritten. } \note{ In earlier versions, \code{OKnames} and \code{myname} were autodetected. This capability has been deprecated and results in a warning issued once per session. They now need to be set explicitly. } \seealso{ \code{\link[=set.control.class]{set.control.class()}}, \code{\link[=print.control.list]{print.control.list()}}, \code{\link[=as.control.list]{as.control.list()}} } \keyword{utilities} statnet.common/man/term_list.Rd0000644000176200001440000000557415112517167016310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.utilities.R \name{term_list} \alias{term_list} \alias{as.term_list} \alias{as.term_list.term_list} \alias{as.term_list.default} \alias{c.term_list} \alias{[.term_list} \alias{print.term_list} \alias{sign.term_list} \alias{sign<-.term_list} \alias{envir.term_list} \alias{envir<-.term_list} \title{A helper class for list of terms in an formula} \usage{ term_list(x, sign = +1L, env = NULL) as.term_list(x, ...) \method{as.term_list}{term_list}(x, ...) \method{as.term_list}{default}(x, sign = +1L, env = NULL, ...) \method{c}{term_list}(x, ...) \method{[}{term_list}(x, i, ...) \method{print}{term_list}(x, ...) \method{sign}{term_list}(x) \method{sign}{term_list}(x) <- value \method{envir}{term_list}(object) \method{envir}{term_list}(object) <- value } \arguments{ \item{x, object}{a list of terms or a term; a \code{term_list}} \item{sign}{a vector specifying the signs associated with each term (\code{-1} and \code{+1})} \item{env}{a list specifying the environments, or NULL} \item{...}{additional arguments to methods} \item{i}{list index} \item{value}{RHS; see method documentation} } \description{ Typically generated by \code{\link[=list_rhs.formula]{list_rhs.formula()}}, it contains, in addition to a list of \code{\link[=call]{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 \code{\link[=sign]{sign()}} and \code{\link[=envir]{envir()}} generics. Indexing and concatenation methods preserve these. } \section{Methods (by generic)}{ \itemize{ \item \code{sign(term_list)}: An \code{\link{integer}} vector giving the signs of each term in the list. \item \code{sign(term_list) <- value}: Update the signs of the terms; \code{value} is recycled to the length of the list. \item \code{envir(term_list)}: A \code{\link{list}} with an element for each term in the list, giving its environment. \item \code{envir(term_list) <- value}: Update the environments of the terms; \code{value} can be an environment or a list of environments, recycled to the length of the term list. }} \examples{ e1 <- new.env() f1 <- a~b+c environment(f1) <- e1 f2 <- ~-NULL+1 (l1 <- list_rhs.formula(f1)) (l2 <- list_rhs.formula(f2)) (l <- c(l1,l2)) \dontshow{ stopifnot(identical(c(unclass(l)), alist(b, c, NULL, 1))) 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(sign(l), c(-1L,1L,-1L,1L,1L))) stopifnot(identical(envir(l), list(globalenv(), e1, e1, e1, globalenv()))) } } \seealso{ \code{\link[=list_rhs.formula]{list_rhs.formula()}}, \code{\link[=list_summands.call]{list_summands.call()}} } statnet.common/man/unwhich.Rd0000644000176200001440000000125213701734650015740 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{unwhich} \alias{unwhich} \title{Construct a logical vector with \code{TRUE} in specified positions.} \usage{ unwhich(which, n) } \arguments{ \item{which}{a numeric vector of indices to set to \code{TRUE}.} \item{n}{total length of the output vector.} } \value{ A logical vector of length \code{n} whose elements listed in \code{which} are set to \code{TRUE}, and whose other elements are set to \code{FALSE}. } \description{ This function is basically an inverse of \code{\link{which}}. } \examples{ x <- as.logical(rbinom(10,1,0.5)) stopifnot(all(x == unwhich(which(x), 10))) } statnet.common/man/which_top_n.Rd0000644000176200001440000000301515120230065016557 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{which_top_n} \alias{which_top_n} \title{Top or bottom \code{n} elements of a vector} \usage{ which_top_n(x, n, tied = c("given", "all", "none")) } \arguments{ \item{x}{a vector on which \code{\link[=rank]{rank()}} can be evaluated.} \item{n}{the number of elements to attempt to select; if positive top \code{n} are selected, and if negative bottom \code{-n}.} \item{tied}{a string to specify how to handle multiple elements tied for \code{n}'th place: \code{all} or \code{none} to include all or none of the tied elements, returning a longer or shorter vector than \code{n}, respectively; \code{given} (the default) to use the order in which the elements are found in \code{x}.} } \value{ An integer vector of indices on \code{x}, with an attribute \code{attr(, "tied")} with the indicies of the tied elements (possibly empty). } \description{ Return the indices of the top or bottom \code{abs(n)} elements of a vector, with several methods for resolving ties. } \examples{ (x <- rep(1:4, 1:4)) stopifnot(identical(which_top_n(x, 5, "all"), structure(4:10, tied = 4:6))) stopifnot(identical(which_top_n(x, 5, "none"), structure(7:10, tied = 4:6))) stopifnot(identical(which_top_n(x, 5), structure(6:10, tied = 4:6))) stopifnot(identical(which_top_n(x, -5, "all"), structure(1:6, tied = 4:6))) stopifnot(identical(which_top_n(x, -5, "none"), structure(1:3, tied = 4:6))) stopifnot(identical(which_top_n(x, -5), structure(1:5, tied = 4:6))) } statnet.common/man/opttest.Rd0000644000176200001440000000220413701734650015773 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{opttest} \alias{opttest} \title{Optionally test code depending on environment variable.} \usage{ opttest( expr, testname = NULL, testvar = "ENABLE_statnet_TESTS", yesvals = c("y", "yes", "t", "true", "1"), lowercase = TRUE ) } \arguments{ \item{expr}{An expression to be evaluated only if \code{testvar} is set to a non-empty value.} \item{testname}{Optional name of the test. If given, and the test is skipped, will print a message to that end, including the name of the test, and instructions on how to enable it.} \item{testvar}{Environment variable name. If set to one of the \code{yesvals}, \code{expr} is run. Otherwise, an optional message is printed.} \item{yesvals}{A character vector of strings considered affirmative values for \code{testvar}.} \item{lowercase}{Whether to convert the value of \code{testvar} to lower case before comparing it to \code{yesvals}.} } \description{ A convenience wrapper to run code based on whether an environment variable is defined. } \keyword{debugging} \keyword{environment} \keyword{utilities} statnet.common/man/xTAx.Rd0000644000176200001440000000430115000431635015144 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/matrix.utils.R \name{xTAx} \alias{xTAx} \alias{xAxT} \alias{xTAx_solve} \alias{xTAx_qrsolve} \alias{sandwich_solve} \alias{xTAx_eigen} \alias{sandwich_sginv} \alias{sandwich_ginv} \title{Common quadratic forms} \usage{ xTAx(x, A) xAxT(x, A) xTAx_solve(x, A, ...) xTAx_qrsolve(x, A, tol = 1e-07, ...) sandwich_solve(A, B, ...) xTAx_eigen(x, A, tol = sqrt(.Machine$double.eps), ...) sandwich_sginv(A, B, ...) sandwich_ginv(A, B, ...) } \arguments{ \item{x}{a vector} \item{A}{a square matrix} \item{...}{additional arguments to subroutines} \item{tol}{tolerance argument passed to the relevant subroutine} \item{B}{a square matrix} } \description{ Common quadratic forms } \details{ These are somewhat inspired by emulator::quad.form.inv() and others. } \section{Functions}{ \itemize{ \item \code{xTAx()}: Evaluate \eqn{x'Ax} for vector \eqn{x} and square matrix \eqn{A}. \item \code{xAxT()}: Evaluate \eqn{xAx'} for vector \eqn{x} and square matrix \eqn{A}. \item \code{xTAx_solve()}: Evaluate \eqn{x'A^{-1}x} for vector \eqn{x} and invertible matrix \eqn{A} using \code{\link[=solve]{solve()}}. \item \code{xTAx_qrsolve()}: Evaluate \eqn{x'A^{-1}x} for vector \eqn{x} and matrix \eqn{A} using QR decomposition and confirming that \eqn{x} is in the span of \eqn{A} if \eqn{A} is singular; returns \code{rank} and \code{nullity} as attributes just in case subsequent calculations (e.g., hypothesis test degrees of freedom) are affected. \item \code{sandwich_solve()}: Evaluate \eqn{A^{-1}B(A')^{-1}} for \eqn{B} a square matrix and \eqn{A} invertible. \item \code{xTAx_eigen()}: Evaluate \eqn{x' A^{-1} x} for vector \eqn{x} and matrix \eqn{A} (symmetric, nonnegative-definite) via eigendecomposition and confirming that \eqn{x} is in the span of \eqn{A} if \eqn{A} is singular; returns \code{rank} and \code{nullity} as attributes just in case subsequent calculations (e.g., hypothesis test degrees of freedom) are affected. Decompose \eqn{A = P L P'} for \eqn{L} diagonal matrix of eigenvalues and \eqn{P} orthogonal. Then \eqn{A^{-1} = P L^{-1} P'}. Substituting, \deqn{x' A^{-1} x = x' P L^{-1} P' x = h' L^{-1} h} for \eqn{h = P' x}. }} statnet.common/man/envir.Rd0000644000176200001440000000145515112517167015423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.utilities.R \name{envir} \alias{envir} \alias{envir<-} \title{A generic for querying and setting an object's environment} \usage{ envir(object) envir(object) <- value } \arguments{ \item{object}{object whose environment is to be queried or set} \item{value}{typically an \code{\link{environment}}, but could be any RHS supported by the method} } \description{ \code{\link[=environment]{environment()}} and \code{\link[=environment<-]{environment<-()}} are not generics, so it is not possible to dispatch based on the class of the object affected. } \details{ When no method is available, these generics fall back to the \code{\link[=environment]{environment()}} and \code{\link[=environment<-]{environment<-()}} functions. } statnet.common/man/deprecation-utilities.Rd0000644000176200001440000000276414056633145020613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecation_utils.R \name{deprecation-utilities} \alias{deprecation-utilities} \alias{.Deprecate_once} \alias{.Deprecate_method} \title{Utilities to help with deprecating functions.} \usage{ .Deprecate_once(...) .Deprecate_method(generic, class) } \arguments{ \item{...}{arguments passed to \code{\link[=.Deprecated]{.Deprecated()}}.} \item{generic, class}{strings giving the generic function name and class name of the function to be deprecated.} } \description{ \code{.Deprecate_once} calls \code{\link[=.Deprecated]{.Deprecated()}}, passing all its arguments through, but only the first time it's called. \code{.Deprecate_method} calls \code{\link[=.Deprecated]{.Deprecated()}}, but only if a method has been called by name, i.e., \code{\var{METHOD}.\var{CLASS}}. Like \code{.Deprecate_once} it only issues a warning the first time. } \examples{ \dontrun{ options(warn=1) # Print warning immediately after the call. f <- function(){ .Deprecate_once("new_f") } f() # Deprecation warning f() # No deprecation warning } \dontrun{ options(warn=1) # Print warning immediately after the call. summary.packageDescription <- function(object, ...){ .Deprecate_method("summary", "packageDescription") invisible(object) } summary(packageDescription("statnet.common")) # No warning. summary.packageDescription(packageDescription("statnet.common")) # Warning. summary.packageDescription(packageDescription("statnet.common")) # No warning. } } statnet.common/man/logspace.utils.Rd0000644000176200001440000000745614734077726017256 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/logspace.utils.R \name{logspace.utils} \alias{logspace.utils} \alias{log_sum_exp} \alias{log_mean_exp} \alias{lweighted.mean} \alias{lweighted.var} \alias{lweighted.cov} \alias{log1mexp} \title{Utilities for performing calculations on logarithmic scale.} \usage{ log_sum_exp(logx, use_ldouble = FALSE) log_mean_exp(logx, use_ldouble = FALSE) lweighted.mean(x, logw) lweighted.var(x, logw, onerow = NA) lweighted.cov(x, y, logw, onerow = NA) log1mexp(x) } \arguments{ \item{logx}{Numeric vector of \eqn{\log(x)}, the natural logarithms of the values to be summed or averaged.} \item{use_ldouble}{Whether to use \code{long double} precision in the calculation. If \code{TRUE}, 's C built-in \code{logspace_sum()} is used. If \code{FALSE}, the package's own implementation based on it is used, using \code{double} precision, which is (on most systems) several times faster, at the cost of precision.} \item{x, y}{Numeric vectors or matrices of \eqn{x} and \eqn{y}, the (raw) values to be summed, averaged, or whose variances and covariances are to be calculated.} \item{logw}{Numeric vector of \eqn{\log(w)}, the natural logarithms of the weights.} \item{onerow}{If given a matrix or matrices with only one row (i.e., sample size 1), \code{\link[=var]{var()}} and \code{\link[=cov]{cov()}} will return \code{NA}. But, since weighted matrices are often a product of compression, the same could be interpreted as a variance of variables that do not vary, i.e., 0. This argument controls what value should be returned.} } \value{ The functions return the equivalents of the R expressions given below, but faster and with less loss of precision. } \description{ A small suite of functions to compute sums, means, and weighted means on logarithmic scale, minimizing loss of precision. } \section{Functions}{ \itemize{ \item \code{log_sum_exp()}: \code{log(sum(exp(logx)))} \item \code{log_mean_exp()}: \code{log(mean(exp(logx)))} \item \code{lweighted.mean()}: weighted mean of \code{x}: \code{sum(x*exp(logw))/sum(exp(logw))} for \code{x} scalar and \code{colSums(x*exp(logw))/sum(exp(logw))} for \code{x} matrix \item \code{lweighted.var()}: weighted variance of \code{x}: \code{crossprod(x-lweighted.mean(x,logw)*exp(logw/2))/sum(exp(logw))} \item \code{lweighted.cov()}: weighted covariance between \code{x} and \code{y}: \code{crossprod(x-lweighted.mean(x,logw)*exp(logw/2), y-lweighted.mean(y,logw)*exp(logw/2))/sum(exp(logw))} \item \code{log1mexp()}: \code{log(1-exp(-x))} for \code{x >= 0} (a wrapper for the eponymous C macro provided by R) }} \examples{ x <- rnorm(1000) stopifnot(all.equal(log_sum_exp(x), log(sum(exp(x))), check.attributes=FALSE)) stopifnot(all.equal(log_mean_exp(x), log(mean(exp(x))), check.attributes=FALSE)) logw <- rnorm(1000) stopifnot(all.equal(m <- sum(x*exp(logw))/sum(exp(logw)),lweighted.mean(x, logw))) stopifnot(all.equal(sum((x-m)^2*exp(logw))/sum(exp(logw)), lweighted.var(x, logw), check.attributes=FALSE)) x <- cbind(x, rnorm(1000)) stopifnot(all.equal(mx <- colSums(x*exp(logw))/sum(exp(logw)), lweighted.mean(x, logw), check.attributes=FALSE)) stopifnot(all.equal(crossprod(t(t(x)-mx)*exp(logw/2))/sum(exp(logw)), lweighted.var(x, logw), check.attributes=FALSE)) y <- cbind(x, rnorm(1000)) my <- colSums(y*exp(logw))/sum(exp(logw)) stopifnot(all.equal(crossprod(t(t(x)-mx)*exp(logw/2), t(t(y)-my)*exp(logw/2))/sum(exp(logw)), lweighted.cov(x, y, logw), check.attributes=FALSE)) stopifnot(all.equal(crossprod(t(t(y)-my)*exp(logw/2), t(t(x)-mx)*exp(logw/2))/sum(exp(logw)), lweighted.cov(y, x, logw), check.attributes=FALSE)) x <- rexp(1000) stopifnot(isTRUE(all.equal(log1mexp(x), log(1-exp(-x))))) } \author{ Pavel N. Krivitsky } \keyword{arith} statnet.common/man/all_identical.Rd0000644000176200001440000000316215012573507017060 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{all_identical} \alias{all_identical} \title{Test if all items in a vector or a list are identical.} \usage{ all_identical(x, .p = identical, .ref = 1L, ...) } \arguments{ \item{x}{a vector or a list} \item{.p}{a predicate function of two arguments returning a logical. Defaults to \code{\link[=identical]{identical()}}.} \item{.ref}{integer; index of element of \code{x} to which all the remaining ones will be compared. Defaults to 1.} \item{...}{additional arguments passed to \code{.p()}} } \value{ By default \code{TRUE} if all elements of \code{x} are identical to each other, \code{FALSE} otherwise. In the general case, \code{all_identical()} returns \code{TRUE} if and only if \code{.p()} returns \code{TRUE} for all the pairs involving the first element and the remaining elements. } \description{ Test if all items in a vector or a list are identical. } \examples{ stopifnot(!all_identical(1:3)) stopifnot(all_identical(list("a", "a", "a"))) # Using with `all.equal()` has its quirks # because of numerical tolerance: x <- seq( .Machine$double.eps, .Machine$double.eps + 1.1 * sqrt(.Machine$double.eps), length = 3 ) # Results with `all.equal()` are affected by ordering all_identical(x, all.equal) # FALSE all_identical(x[c(2,3,1)], all.equal) # TRUE # ... because `all.equal()` is intransitive all_identical(x[-3], all.equal) # is TRUE and all_identical(x[-1], all.equal) # is TRUE, but all_identical(x[-2], all.equal) # is FALSE } \seealso{ \code{\link[=identical]{identical()}}, \code{\link[=all.equal]{all.equal()}} } statnet.common/man/formula.utilities.Rd0000644000176200001440000001731415112517167017760 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.utilities.R \name{formula.utilities} \alias{formula.utilities} \alias{append_rhs.formula} \alias{append.rhs.formula} \alias{filter_rhs.formula} \alias{nonsimp_update.formula} \alias{nonsimp.update.formula} \alias{term.list.formula} \alias{list_summands.call} \alias{list_rhs.formula} \alias{eval_lhs.formula} \title{Functions for Querying, Validating and Extracting from Formulas} \usage{ append_rhs.formula( object = NULL, newterms, keep.onesided = FALSE, env = if (is.null(object)) NULL else environment(object) ) append.rhs.formula(object, newterms, keep.onesided = FALSE) filter_rhs.formula(object, f, ...) nonsimp_update.formula(object, new, ..., from.new = FALSE) nonsimp.update.formula(object, new, ..., from.new = FALSE) term.list.formula(rhs, sign = +1) list_summands.call(object) list_rhs.formula(object) eval_lhs.formula(object) } \arguments{ \item{object}{formula object to be updated or evaluated} \item{newterms}{a \code{\link{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; it can have a \code{\link[=sign]{sign()}} method or a \code{"sign"} attribute vector can give the sign of each term (\code{+1} or \code{-1}), and its \code{\link[=envir]{envir()}} method or \code{"env"} attribute vector will be used to set its environment, with the first available being used and subsequent ones producing a warning.} \item{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} \item{env}{an environment for the new formula, if \code{object} is \code{NULL}} \item{f}{a function whose first argument is the term and whose additional arguments are forwarded from \code{...} that returns either \code{TRUE} or \code{FALSE}, for whether that term should be kept.} \item{\dots}{Additional arguments. Currently unused.} \item{new}{new formula to be used in updating} \item{from.new}{logical or character vector of variable names. controls how environment of formula gets updated.} \item{rhs, sign}{Arguments to the deprecated \code{term.list.formula}.} } \value{ \code{append_rhs.formula} each return an updated formula object; if \code{object} is \code{NULL} (the default), a one-sided formula containing only the terms in \code{newterms} will be returned. \code{nonsimp_update.formula} each return an updated formula object \code{list_summands.call} returns an object of type \code{\link{term_list}}; its \code{"env"} attribute is set to a list of \code{NULL}s, however. \code{list_rhs.formula} returns an object of type \code{\link{term_list}}. \code{eval_lhs.formula} an object of whatever type the LHS evaluates to. } \description{ A suite of utilities for handling model formulas of the style used in Statnet packages. } \section{Functions}{ \itemize{ \item \code{append_rhs.formula()}: \code{append_rhs.formula} appends a list of terms to the RHS of a formula. If the formula is one-sided, the RHS becomes the LHS, if \code{keep.onesided==FALSE} (the default). \item \code{append.rhs.formula()}: \code{append.rhs.formula} has been renamed to \code{append_rhs.formula}. \item \code{filter_rhs.formula()}: \code{filter_rhs.formula} filters through the terms in the RHS of a formula, returning a formula without the terms for which function \code{f(term, ...)} is \code{FALSE}. Terms inside another term (e.g., parentheses or an operator other than + or -) will be unaffected. \item \code{nonsimp_update.formula()}: \code{nonsimp_update.formula} is a reimplementation of \code{\link{update.formula}} that does not simplify. Note that the resulting formula's environment is set as follows. If \code{from.new==FALSE}, it is set to that of object. Otherwise, a new sub-environment of object, containing, in addition, variables in new listed in from.new (if a character vector) or all of new (if TRUE). \item \code{nonsimp.update.formula()}: \code{nonsimp.update.formula} has been renamed to \code{nonsimp_update.formula}. \item \code{term.list.formula()}: \code{term.list.formula} is an older version of \code{list_rhs.formula} that required the RHS call, rather than the formula itself. \item \code{list_summands.call()}: \code{list_summands.call}, given an unevaluated call or expression containing the sum of one or more terms, returns an object of class \code{\link{term_list}} with the terms being summed, handling \code{+} and \code{-} operators and parentheses, and keeping track of whether a term has a plus or a minus sign. \item \code{list_rhs.formula()}: \code{list_rhs.formula} returns an object of type \code{\link{term_list}}, containing terms in a given formula, handling \code{+} and \code{-} operators and parentheses, and keeping track of whether a term has a plus or a minus sign. \item \code{eval_lhs.formula()}: \code{eval_lhs.formula} extracts the LHS of a formula, evaluates it in the formula's environment, and returns the result. }} \examples{ ## append_rhs.formula (f1 <- append_rhs.formula(y~x,list(as.name("z1"),as.name("z2")))) (f2 <- append_rhs.formula(~y,list(as.name("z")))) (f3 <- append_rhs.formula(~y+x,structure(list(as.name("z")),sign=-1))) (f4 <- append_rhs.formula(~y,list(as.name("z")),TRUE)) (f5 <- append_rhs.formula(y~x,~z1-z2)) (f6 <- append_rhs.formula(NULL,list(as.name("z")))) (f7 <- append_rhs.formula(NULL,structure(list(as.name("z")),sign=-1))) fe <- ~z2+z3 environment(fe) <- new.env() (f8 <- append_rhs.formula(NULL, fe)) # OK (f9 <- append_rhs.formula(y~x, fe)) # Warning (f10 <- append_rhs.formula(y~x, fe, env=NULL)) # No warning, environment from fe. (f11 <- append_rhs.formula(fe, ~z1)) # Warning, environment from fe \dontshow{ stopifnot(f1 == (y~x+z1+z2)) stopifnot(f2 == (y~z)) stopifnot(f3 == (y+x~-z)) stopifnot(f4 == (~y+z)) stopifnot(f5 == (y~x+z1-z2)) stopifnot(f6 == (~z)) stopifnot(f7 == (~-z)) stopifnot(f8 == (~z2+z3), identical(environment(f8), environment(fe))) stopifnot(f9 == (y~x+z2+z3), identical(environment(f9), globalenv())) stopifnot(f10 == (y~x+z2+z3), identical(environment(f10), environment(fe))) stopifnot(f11 == (z2+z3~z1), identical(environment(f11), environment(fe))) } ## filter_rhs.formula (f1 <- filter_rhs.formula(~a-b+c, `!=`, "a")) (f2 <- filter_rhs.formula(~-a+b-c, `!=`, "a")) (f3 <- filter_rhs.formula(~a-b+c, `!=`, "b")) (f4 <- filter_rhs.formula(~-a+b-c, `!=`, "b")) (f5 <- filter_rhs.formula(~a-b+c, `!=`, "c")) (f6 <- filter_rhs.formula(~-a+b-c, `!=`, "c")) (f7 <- filter_rhs.formula(~c-a+b-c(a), function(x) (if(is.call(x)) x[[1]] else x)!="c")) \dontshow{ stopifnot(f1 == ~-b+c) stopifnot(f2 == ~b-c) stopifnot(f3 == ~a+c) stopifnot(f4 == ~-a-c) stopifnot(f5 == ~a-b) stopifnot(f6 == ~-a+b) stopifnot(f7 == ~-a+b) } stopifnot(identical(list_rhs.formula(a~b), structure(alist(b), sign=1L, env=list(globalenv()), class="term_list"))) stopifnot(identical(list_rhs.formula(~b), structure(alist(b), sign=1L, env=list(globalenv()), class="term_list"))) stopifnot(identical(list_rhs.formula(~b+NULL), structure(alist(b, NULL), 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(-1L,1L), env=rep(list(globalenv()), 2), class="term_list"))) stopifnot(identical(list_rhs.formula(~+b-NULL), structure(alist(b, NULL), 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(1L,-1L,-1L), env=rep(list(globalenv()), 3), class="term_list"))) ## eval_lhs.formula (result <- eval_lhs.formula((2+2)~1)) stopifnot(identical(result,4)) } statnet.common/man/locate_function.Rd0000644000176200001440000000464314306106145017450 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/locator.R \name{locate_function} \alias{locate_function} \alias{locate_prefixed_function} \title{Locate a function with a given name and return it and its environment.} \usage{ locate_function(name, env = globalenv(), ...) locate_prefixed_function( name, prefix, errname, env = globalenv(), ..., call. = FALSE ) } \arguments{ \item{name}{a character string giving the function's name.} \item{env}{an \code{\link{environment}} where it should search first.} \item{...}{additional arguments to the warning and error warning messages. See Details.} \item{prefix}{a character string giving the prefix, so the searched-for function is \code{prefix.name}.} \item{errname}{a character string; if given, if the function is not found an error is raised, with \code{errname} prepended to the error message.} \item{call.}{a logical, whether the call (\code{locate_prefixed_function}) should be a part of the error message; defaults to \code{FALSE} (which is different from \code{\link[=stop]{stop()}}'s default).} } \value{ If the function is found, an unevaluated call of the form \code{ENVNAME:::FUNNAME}, which can then be used to call the function even if it is unexported. If the environment does not have a name, or is \code{GlobalEnv}, only \code{FUNNAME} is returned. Otherwise, \code{NULL} is returned. } \description{ These functions first search the given environment, then search all loaded environments, including those where the function is not exported. If found, they return an unambiguous reference to the function. } \details{ If the initial search fails, a search using \code{\link[=getAnywhere]{getAnywhere()}} is attempted, with exported ("visible") functions with the specified name preferred over those that are not. When multiple equally qualified functions are available, a warning is printed and an arbitrary one is returned. Because \code{\link[=getAnywhere]{getAnywhere()}} can be slow, past searches are cached. } \section{Functions}{ \itemize{ \item \code{locate_function()}: a low-level function returning the reference to the function named \code{name}, or \code{NULL} if not found. \item \code{locate_prefixed_function()}: a helper function that searches for a function of the form \code{prefix.name} and produces an informative error message if not found. }} \examples{ # Locate a random function in base. locate_function(".row_names_info") } statnet.common/man/sign-set.Rd0000644000176200001440000000056515112517167016032 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.utilities.R \name{sign<-} \alias{sign<-} \title{A generic for setting the sign of an object} \usage{ sign(x) <- value } \arguments{ \item{x}{object whose sign is to be set} \item{value}{a numeric vector specifying the sign} } \description{ A generic for setting the sign of an object } statnet.common/man/set_diag.Rd0000644000176200001440000000066315016066617016061 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/matrix.utils.R \name{set_diag} \alias{set_diag} \title{Return the matrix with diagonal set to a specified value} \usage{ set_diag(x, value) } \arguments{ \item{x}{a square matrix.} \item{value}{a value or a vector (recycled to the required length).} } \description{ This function simply assigns \code{value} to diagonal of \code{x} and returns \code{x}. } statnet.common/man/compress_rows.Rd0000644000176200001440000000141613711220501017164 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/wmatrix.R \name{compress_rows} \alias{compress_rows} \alias{decompress_rows} \title{A generic function to compress a row-weighted table} \usage{ compress_rows(x, ...) decompress_rows(x, ...) } \arguments{ \item{x}{a weighted matrix or data frame.} \item{...}{extra arguments for methods.} } \value{ For \code{compress_rows} A weighted matrix or data frame of the same type with duplicated rows removed and weights updated appropriately. } \description{ Compress a matrix or a data frame with duplicated rows, updating row weights to reflect frequencies, or reverse the process, reconstructing a matrix like the one compressed (subject to permutation of rows and weights not adding up to an integer). } statnet.common/man/split_len.Rd0000644000176200001440000000123115120237037016253 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{split_len} \alias{split_len} \title{Split a list or some other \code{split()}-able object by lengths} \usage{ split_len(x, l) } \arguments{ \item{x}{an object with a \code{\link[=split]{split()}} method.} \item{l}{a vector of lengths of the subsets.} } \value{ A list with elements of the same type as \code{x}. } \description{ \code{split_len()} splits an object, such as a list or a data frame, into subsets with specified lengths. } \examples{ x <- 1:10 l <- 1:4 o <- split_len(x, l) stopifnot(identical(lengths(o), l)) stopifnot(identical(unlist(o), x)) } statnet.common/man/snctrl.Rd0000644000176200001440000000210014264744472015601 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{snctrl} \alias{snctrl} \title{Statnet Control} \usage{ snctrl(...) } \arguments{ \item{...}{The parameter list is updated dynamically as packages are loaded and unloaded. Their current list is given below.} } \description{ A utility to facilitate argument completion of control lists. } \details{ In and of itself, \code{snctrl} copies its named arguments into a list. However, its argument list is updated dynamically as packages are loaded, as are those of its reexports from other packages. This is done using an API provided by helper functions. (See \code{API?snctrl}.) } \note{ You may see messages along the lines of \if{html}{\out{
}}\preformatted{The following object is masked from 'package:PKG': snctrl }\if{html}{\out{
}} when loading packages. They are benign. } \section{Currently recognised control parameters}{ This list is updated as packages are loaded and unloaded. \Sexpr[results=rd,stage=render]{statnet.common::snctrl_names()} } statnet.common/man/persistEval.Rd0000644000176200001440000000406213701734650016576 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{persistEval} \alias{persistEval} \alias{persistEvalQ} \title{Evaluate an expression, restarting on error} \usage{ persistEval( expr, retries = NVL(getOption("eval.retries"), 5), beforeRetry, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), verbose = FALSE ) persistEvalQ( expr, retries = NVL(getOption("eval.retries"), 5), beforeRetry, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), verbose = FALSE ) } \arguments{ \item{expr}{an expression to be retried; note the difference between \code{\link[=eval]{eval()}} and \code{\link[=evalq]{evalq()}}.} \item{retries}{number of retries to make; defaults to \code{"eval.retries"} option, or 5.} \item{beforeRetry}{if given, an expression that will be evaluated before each retry if the initial attempt fails; it is evaluated in the same environment and with the same quoting semantics as \code{expr}, but its errors are not handled.} \item{envir, enclos}{see \code{\link[=eval]{eval()}}.} \item{verbose}{Whether to output retries.} } \value{ Results of evaluating \code{expr}, including side-effects such as variable assignments, if successful in \code{retries} retries. } \description{ A pair of functions paralleling \code{\link[=eval]{eval()}} and \code{\link[=evalq]{evalq()}} that make multiple attempts at evaluating an expression, retrying on error up to a specified number of attempts, and optionally evaluating another expression before restarting. } \note{ If \code{expr} returns a \code{"try-error"} object (returned by \code{\link[=try]{try()}}), it will be treated as an error. This behavior may change in the future. } \examples{ x <- 0 persistEvalQ({if((x<-x+1)<3) stop("x < 3") else x}, beforeRetry = {cat("Will try incrementing...\n")}) x <- 0 e <- quote(if((x<-x+1)<3) stop("x < 3") else x) persistEval(e, beforeRetry = quote(cat("Will try incrementing...\n"))) } statnet.common/man/forkTimeout.Rd0000644000176200001440000000362613701734650016612 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{forkTimeout} \alias{forkTimeout} \title{Evaluate an \R expression with a hard time limit by forking a process} \usage{ forkTimeout( expr, timeout, unsupported = c("warning", "error", "message", "silent"), onTimeout = NULL ) } \arguments{ \item{expr}{expression to be evaluated.} \item{timeout}{number of seconds to wait for the expression to evaluate.} \item{unsupported}{a character vector of length 1 specifying how to handle a platform that does not support #ifndef windows \code{\link[parallel:mcparallel]{parallel::mcparallel()}}, #endif #ifdef windows \code{parallel::mcparallel()}, #endif \describe{ \item{\code{"warning"} or \code{"message"}}{Issue a warning or a message, respectively, then evaluate the expression without the time limit enforced.} \item{\code{"error"}}{Stop with an error.} \item{\code{"silent"}}{Evaluate the expression without the time limit enforced, without any notice.} } Partial matching is used.} \item{onTimeout}{Value to be returned on time-out.} } \value{ Result of evaluating \code{expr} if completed, \code{onTimeout} otherwise. } \description{ This function uses #ifndef windows \code{\link[parallel:mcparallel]{parallel::mcparallel()}}, #endif #ifdef windows \code{parallel::mcparallel()}, #endif so the time limit is not enforced on Windows. However, unlike functions using \code{\link[=setTimeLimit]{setTimeLimit()}}, the time limit is enforced even on native code. } \note{ \code{onTimeout} can itself be an expression, so it is, for example, possible to stop with an error by passing \code{onTimeout=stop()}. Note that this function is not completely transparent: side-effects may behave in unexpected ways. In particular, RNG state will not be updated. } \examples{ forkTimeout({Sys.sleep(1); TRUE}, 2) # TRUE forkTimeout({Sys.sleep(1); TRUE}, 0.5) # NULL (except on Windows) } statnet.common/man/compress_rows.data.frame.Rd0000644000176200001440000000333213711220501021164 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{compress_rows.data.frame} \alias{compress_rows.data.frame} \alias{decompress_rows.compressed_rows_df} \title{"Compress" a data frame.} \usage{ \method{compress_rows}{data.frame}(x, ...) \method{decompress_rows}{compressed_rows_df}(x, ...) } \arguments{ \item{x}{For \code{compress_rows.data.frame} a \code{\link{data.frame}} to be compressed. For \code{decompress_rows.compress_rows_df} a \code{\link{list}} as returned by \code{compress_rows.data.frame}.} \item{...}{Additional arguments, currently unused.} } \value{ For \code{compress_rows.data.frame}, a \code{\link{list}} with three elements: \item{rows }{Unique rows of \code{x}} \item{frequencies }{A vector of the same length as the number or rows, giving the number of times the corresponding row is repeated } \item{ordering}{A vector such that if \code{c} is the compressed data frame, \code{c$rows[c$ordering,,drop=FALSE]} equals the original data frame, except for row names} \item{rownames}{Row names of \code{x}} For \code{decompress_rows.compressed_rows_df}, the original data frame. } \description{ \code{compress_rows.data.frame} "compresses" a data frame, returning unique rows and a tally of the number of times each row is repeated, as well as a permutation vector that can reconstruct the original data frame. \code{decompress_rows.compressed_rows_df} reconstructs the original data frame. } \examples{ (x <- data.frame(V1=sample.int(3,30,replace=TRUE), V2=sample.int(2,30,replace=TRUE), V3=sample.int(4,30,replace=TRUE))) (c <- compress_rows(x)) stopifnot(all(decompress_rows(c)==x)) } \seealso{ \code{\link{data.frame}} } \keyword{manip} statnet.common/man/as.control.list.Rd0000644000176200001440000000356514306106145017332 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{as.control.list} \alias{as.control.list} \alias{as.control.list.control.list} \alias{as.control.list.list} \title{Convert to a control list.} \usage{ as.control.list(x, ...) \method{as.control.list}{control.list}(x, ...) \method{as.control.list}{list}(x, FUN = NULL, unflat = TRUE, ...) } \arguments{ \item{x}{An object, usually a \code{\link{list}}, to be converted to a control list.} \item{...}{Additional arguments to methods.} \item{FUN}{Either a \verb{control.*()} function or its name or suffix (to which \code{"control."} will be prepended); defaults to taking the nearest (in the call traceback) function that does not begin with \code{"as.control.list"}, and prepending \code{"control."} to it. (This is typically the function that called \code{as.control.list()} in the first place.)} \item{unflat}{Logical, indicating whether an attempt should be made to detect whether some of the arguments are appropriate for a lower-level control function and pass them down.} } \value{ a \code{control.list} object. } \description{ Convert to a control list. } \section{Methods (by class)}{ \itemize{ \item \code{as.control.list(control.list)}: Idempotent method for control lists. \item \code{as.control.list(list)}: The method for plain lists, which runs them through \code{FUN}. }} \examples{ myfun <- function(..., control=control.myfun()){ as.control.list(control) } control.myfun <- function(a=1, b=a+1){ list(a=a,b=b) } myfun() myfun(control = list(a=2)) myfun2 <- function(..., control=control.myfun2()){ as.control.list(control) } control.myfun2 <- function(c=3, d=c+2, myfun=control.myfun()){ list(c=c,d=d,myfun=myfun) } myfun2() # Argument to control.myfun() (i.e., a) gets passed to it, and a # warning is issued for unused argument e. myfun2(control = list(c=3, a=2, e=3)) } statnet.common/man/sweep_cols.matrix.Rd0000644000176200001440000000157413701734650017750 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/logspace.utils.R \name{sweep_cols.matrix} \alias{sweep_cols.matrix} \title{Suptract a elements of a vector from respective columns of a matrix} \usage{ sweep_cols.matrix(x, STATS, disable_checks = FALSE) } \arguments{ \item{x}{a numeric matrix;} \item{STATS}{a numeric vector whose length equals to the number of columns of \code{x}.} \item{disable_checks}{if \code{TRUE}, do not check that \code{x} is a numeric matrix and its number of columns matches the length of \code{STATS}; set in production code for a significant speed-up.} } \value{ A matrix of the same attributes as \code{x}. } \description{ An optimized function equivalent to \code{sweep(x, 2, STATS)} for a matrix \code{x}. } \examples{ x <- matrix(runif(1000), ncol=4) s <- 1:4 stopifnot(all.equal(sweep_cols.matrix(x, s), sweep(x, 2, s))) } statnet.common/man/print.control.list.Rd0000644000176200001440000000126513701734650020064 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{print.control.list} \alias{print.control.list} \title{Pretty print the control list} \usage{ \method{print}{control.list}(x, ..., indent = "") } \arguments{ \item{x}{A list generated by a \code{control.*} function.} \item{\dots}{Additional argument to print methods for individual settings.} \item{indent}{an argument for recursive calls, to facilitate indentation of nested lists.} } \description{ This function prints the control list, including what it can control and the elements. } \seealso{ \code{\link{check.control.class}}, \code{\link{set.control.class}} } \keyword{utilities} statnet.common/man/Welford.Rd0000644000176200001440000000364314306106145015675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Welford.R \name{Welford} \alias{Welford} \alias{update.Welford} \title{A Welford accumulator for sample mean and variance} \usage{ Welford(dn, means, vars) \method{update}{Welford}(object, newdata, ...) } \arguments{ \item{dn, means, vars}{initialization of the Welford object: if \code{means} and \code{vars} are given, they are treated as the running means and variances, and \code{dn} is their associated sample size, and if not, \code{dn} is the dimension of the vector (with sample size 0).} \item{object}{a \code{Welford} object.} \item{newdata}{either a numeric vector of length \code{d}, a numeric matrix with \code{d} columns for a group update, or another \code{Welford} object with the same \code{d}.} \item{...}{additional arguments to methods.} } \value{ an object of type \code{Welford}: a list with four elements: \enumerate{ \item \code{n}: Running number of observations \item \code{means}: Running mean for each variable \item \code{SSDs}: Running sum of squared deviations from the mean for each variable \item \code{vars}: Running variance of each variable } } \description{ A simple class for keeping track of the running mean and the sum of squared deviations from the mean for a vector. } \section{Methods (by generic)}{ \itemize{ \item \code{update(Welford)}: Update a \code{Welford} object with new data. }} \examples{ X <- matrix(rnorm(200), 20, 10) w0 <- Welford(10) w <- update(w0, X) stopifnot(isTRUE(all.equal(w$means, colMeans(X)))) stopifnot(isTRUE(all.equal(w$vars, apply(X,2,var)))) w <- update(w0, X[1:12,]) w <- update(w, X[13:20,]) stopifnot(isTRUE(all.equal(w$means, colMeans(X)))) stopifnot(isTRUE(all.equal(w$vars, apply(X,2,var)))) w <- Welford(12, colMeans(X[1:12,]), apply(X[1:12,], 2, var)) w <- update(w, X[13:20,]) stopifnot(isTRUE(all.equal(w$means, colMeans(X)))) stopifnot(isTRUE(all.equal(w$vars, apply(X,2,var)))) } statnet.common/man/modify_in_place.Rd0000644000176200001440000000357114734077726017435 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{modify_in_place} \alias{modify_in_place} \title{Modify the argument in the calling environment of the calling function} \usage{ modify_in_place(x, value = x) } \arguments{ \item{x}{the argument (not its name!) to be modified} \item{value}{the value to assign (defaulting to the current value of \code{x})} } \value{ \code{value}, invisibly, while attempting to modify \code{x} in place } \description{ This is a helper function that enables a function to modify its argument in place, emulating behavior of \CRANpkg{R6} classes and methods in the \CRANpkg{network}. It should typically be the last line of the calling function. } \details{ This function determines whether the argument can be assigned to by actually attempting to do so. If this results in an error, for example, because the argument is anonymous, the error is silently ignored. It can be called multiple times by the same function to modify multiple arguments. It uses the \code{\link[=on.exit]{on.exit()}} mechanism, adding to the list. Thus, if some other function calls \code{on.exit(..., add = FALSE)} (the default) afterwards, \code{modify_in_place()} will fail silently. } \examples{ ## A function that increments its argument in place: inc <- function(x){ modify_in_place(x, x+1) } y <- 1 z <- 1 stopifnot(inc(z) == 2) stopifnot(z == 2) stopifnot(inc(y) == 2) stopifnot(y == 2) stopifnot(inc(z) == 3) stopifnot(z == 3) stopifnot(inc(identity(z)) == 4) stopifnot(z == 3) # Not updated! ## Modify an argument that's been updated in place: inc2 <- function(y){ y <- y + 1 modify_in_place(y) } z stopifnot(inc2(z) == 4) stopifnot(z == 4) ## Decrement the first argument, increment the second: incdec <- function(x,y){ modify_in_place(x, x-1) modify_in_place(y, y+1) } c(y,z) incdec(y,z) stopifnot(all(c(y,z) == c(1,5))) } statnet.common/man/unused_dots_warning.Rd0000644000176200001440000000231214363654400020351 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{unused_dots_warning} \alias{unused_dots_warning} \title{An error handler for \code{\link[rlang:check_dots_used]{rlang::check_dots_used()}} that issues a warning that only lists argument names.} \usage{ unused_dots_warning(e) } \arguments{ \item{e}{a \link{condition} object, typically not passed by the end-user; see example below.} } \description{ This handler parses the error message produced by \code{\link[rlang:check_dots_used]{rlang::check_dots_used()}}, extracting the names of the unused arguments, and formats them into a more gentle warning message. It relies on \CRANpkg{rlang} maintaining its current format. } \examples{ \dontshow{ o <- options(warn=1, useFancyQuotes=FALSE) } g <- function(b=NULL, ...){ invisible(force(b)) } f <- function(...){ rlang::check_dots_used(error = unused_dots_warning) g(...) } f() # OK f(b=2) # OK f(a=1, b=2, c=3) # Warning about a and c but not about b \dontshow{ # Test: stopifnot(grepl("Argument(s) 'a' and 'c' were not recognized or used. Did you mistype an argument name?", tryCatch(f(a=1, b=2, c=3), warning = function(e) e$message), fixed=TRUE)) options(o) } } statnet.common/man/once.Rd0000644000176200001440000000506013701734650015220 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{once} \alias{once} \title{Evaluate a function once for a given input.} \usage{ once(f, expire_after = Inf, max_entries = Inf) } \arguments{ \item{f}{A function to modify.} \item{expire_after}{The number of seconds since it was added to the database before a particular configuration is "forgotten". This can be used to periodically remind the user without overwhelming them.} \item{max_entries}{The number of distinct configurations to remember. If not \code{Inf}, \emph{earliest-inserted} configurations will be removed from the database when capacity is exceeded. (This exact behavior may change in the future.)} } \description{ This is a \code{purrr}-style adverb that checks if a given function has already been called with a given configuration of arguments and skips it if it has. } \details{ Each modified function instance returned by \code{once()} maintains a database of previous argument configurations. They are not in any way compressed, so this database may grow over time. Thus, this wrapper should be used with caution if arguments are large objects. This may be replaced with hashing in the future. In the meantime, you may want to set the \code{max_entries} argument to be safe. Different instances of a modified function do not share databases, even if the function is the same. This means that if you, say, modify a function within another function, the modified function will call once per call to the outer function. Modified functions defined at package level count as the same "instance", however. See example. } \note{ Because the function needs to test whether a particular configuration of arguments have already been used, do not rely on lazy evaluation behaviour. } \examples{ msg <- once(message) msg("abc") # Prints. msg("abc") # Silent. msg <- once(message) # Starts over. msg("abc") # Prints. f <- function(){ innermsg <- once(message) innermsg("efg") # Prints once per call to f(). innermsg("efg") # Silent. msg("abcd") # Prints only the first time f() is called. msg("abcd") # Silent. } f() # Prints "efg" and "abcd". f() # Prints only "efg". msg3 <- once(message, max_entries=3) msg3("a") # 1 remembered. msg3("a") # Silent. msg3("b") # 2 remembered. msg3("a") # Silent. msg3("c") # 3 remembered. msg3("a") # Silent. msg3("d") # "a" forgotten. msg3("a") # Printed. msg2s <- once(message, expire_after=2) msg2s("abc") # Prints. msg2s("abc") # Silent. Sys.sleep(1) msg2s("abc") # Silent after 1 sec. Sys.sleep(1.1) msg2s("abc") # Prints after 2.1 sec. } statnet.common/man/handle.controls.Rd0000644000176200001440000000324214047641642017373 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{handle.controls} \alias{handle.controls} \title{Handle standard \verb{control.*()} function semantics.} \usage{ handle.controls(myname, ...) } \arguments{ \item{myname}{the name of the calling function.} \item{...}{the \code{...} argument of the control function, if present.} } \value{ a list with formal arguments of the calling function. } \description{ This function takes the arguments of its caller (whose name should be passed explicitly), plus any \code{...} arguments and produces a control list based on the standard semantics of \verb{control.*()} functions, including handling deprecated arguments, identifying undefined arguments, and handling arguments that should be passed through \code{\link[=match.arg]{match.arg()}}. } \details{ The function behaves based on the information it acquires from the calling function. Specifically, \itemize{ \item The values of formal arguments (except \code{...}, if present) are taken from the environment of the calling function and stored in the list. \item If the calling function has a \code{...} argument \emph{and} defines an \code{old.controls} variable in its environment, then it remaps the names in \code{...} to their new names based on \code{old.controls}. In addition, if the value is a list with two elements, \code{action} and \code{message}, the standard deprecation message will have \code{message} appended to it and then be called with \code{action()}. \item If the calling function has a \code{match.arg.pars} in its environment, the arguments in that list are processed through \code{\link[=match.arg]{match.arg()}}. } } statnet.common/man/diff.control.list.Rd0000644000176200001440000000250214306106145017625 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \name{diff.control.list} \alias{diff.control.list} \alias{print.diff.control.list} \title{Identify and the differences between two control lists.} \usage{ \method{diff}{control.list}(x, y = eval(call(class(x)[[1L]])), ignore.environment = TRUE, ...) \method{print}{diff.control.list}(x, ..., indent = "") } \arguments{ \item{x}{a \code{control.list}} \item{y}{a reference \code{control.list}; defaults to the default settings for \code{x}.} \item{ignore.environment}{whether environment for environment-bearing parameters (such as formulas and functions) should be considered when comparing.} \item{...}{Additional arguments to methods.} \item{indent}{an argument for recursive calls, to facilitate indentation of nested lists.} } \value{ An object of class \code{diff.control.list}: a named list with an element for each non-identical setting. The element is either itself a \code{diff.control.list} (if the setting is a control list) or a named list with elements \code{x} and \code{y}, containing \code{x}'s and \code{y}'s values of the parameter for that setting. } \description{ Identify and the differences between two control lists. } \section{Methods (by generic)}{ \itemize{ \item \code{print(diff.control.list)}: A print method. }} statnet.common/man/replace.Rd0000644000176200001440000000400715016036034015677 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{replace} \alias{replace} \alias{replace<-} \title{Replace values in a vector according to functions} \usage{ replace(x, list, values, ...) replace(x, list, ...) <- value } \arguments{ \item{x}{a vector.} \item{list}{either an index vector or a function (\emph{not} a function name).} \item{values, value}{either a vector of replacement values or a function (\emph{not} a function name).} \item{...}{additional arguments to \code{list} if it is a function; otherwise ignored.} } \value{ A vector with the values replaced. } \description{ This is a thin wrapper around \code{\link[base:replace]{base::replace()}} that allows \code{list} and/or \code{values} to be functions that are evaluated on \code{x} to obtain the replacement indices and values. The assignment version replaces \code{x}. } \details{ \code{list} function is passed the whole vector \code{x} at once (not elementwise) and any additional arguments to \code{replace()}, and must return an indexing vector (numeric, logical, character, etc.). \code{values}/\code{value} function is passed \code{x} after subsetting it by the result of calling \code{list()}. If passing named arguments, \code{x}, \code{list}, and \code{values} may cause a conflict. } \examples{ (x <- rnorm(10)) ### Replace elements of x that are < 1/4 with 0. # Note that this code is pipeable. x |> replace(`<`, 0, 1/4) # More readable, using lambda notation. x |> replace(\(.x) .x < 1/4, 0) # base equivalent. stopifnot(identical(replace(x, `<`, 0, 1/4), base::replace(x, x < 1/4, 0))) ### Multiply negative elements of x by 1i. x |> replace(\(.x) .x < 0, \(.x) .x * 1i) stopifnot(identical(replace(x, \(.x) .x < 0, \(.x) .x * 1i), base::replace(x, x < 0, x[x < 0] * 1i))) ### Modify the list in place. y <- x replace(x, `<`, 1/4) <- 0 x stopifnot(identical(x, replace(y, `<`, 0, 1/4))) } \seealso{ \code{\link[purrr:modify]{purrr::modify()}} family of functions. } statnet.common/man/sort.data.frame.Rd0000644000176200001440000000330713701734650017266 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{order} \alias{order} \alias{order.default} \alias{order.data.frame} \alias{order.matrix} \alias{sort.data.frame} \title{Implement the \code{\link{sort}} and \code{\link{order}} methods for \code{\link{data.frame}} and \code{\link{matrix}}, sorting it in lexicographic order.} \usage{ order(..., na.last = TRUE, decreasing = FALSE) \method{order}{default}(..., na.last = TRUE, decreasing = FALSE) \method{order}{data.frame}(..., na.last = TRUE, decreasing = FALSE) \method{order}{matrix}(..., na.last = TRUE, decreasing = FALSE) \method{sort}{data.frame}(x, decreasing = FALSE, ...) } \arguments{ \item{\dots}{Ignored for \code{sort}. For \code{order}, first argument is the data frame to be ordered. (This is needed for compatibility with \code{\link[base]{order}}.)} \item{na.last}{See \code{\link[base]{order}} documentation.} \item{decreasing}{Whether to sort in decreasing order.} \item{x}{A \code{\link{data.frame}} to sort.} } \value{ For \code{sort}, a data frame, sorted lexicographically. For \code{order}, a permutation \code{I} (of a vector \code{1:nrow(x)}) such that \code{x[I,,drop=FALSE]} equals \code{x} ordered lexicographically. } \description{ These function return a data frame sorted in lexcographic order or a permutation that will rearrange it into lexicographic order: first by the first column, ties broken by the second, remaining ties by the third, etc.. } \examples{ data(iris) head(iris) head(order(iris)) head(sort(iris)) stopifnot(identical(sort(iris),iris[order(iris),])) } \seealso{ \code{\link{data.frame}}, \code{\link{sort}}, \code{\link{order}}, \code{\link{matrix}} } \keyword{manip} statnet.common/man/deInf.Rd0000644000176200001440000000130013701734650015312 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{deInf} \alias{deInf} \title{Truncate values of high magnitude in a vector.} \usage{ deInf(x, replace = 1/.Machine$double.eps) } \arguments{ \item{x}{a numeric or integer vector.} \item{replace}{a number or a string \code{"maxint"} or \code{"intmax"}.} } \value{ Returns \code{x} with elements whose magnitudes exceed \code{replace} replaced replaced by \code{replace} (or its negation). If \code{replace} is \code{"maxint"} or \code{"intmax"}, \code{.Machine$integer.max} is used instead. \code{NA} and \code{NAN} values are preserved. } \description{ Truncate values of high magnitude in a vector. } statnet.common/man/NVL.Rd0000644000176200001440000000632414306106145014731 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{NVL} \alias{NVL} \alias{NVL2} \alias{NVL3} \alias{EVL} \alias{EVL2} \alias{EVL3} \alias{NVL<-} \alias{EVL<-} \title{Convenience functions for handling \code{\link{NULL}} objects.} \usage{ NVL(...) NVL2(test, notnull, null = NULL) NVL3(test, notnull, null = NULL) EVL(...) EVL2(test, notnull, null = NULL) EVL3(test, notnull, null = NULL) NVL(x) <- value EVL(x) <- value } \arguments{ \item{\dots, test}{expressions to be tested.} \item{notnull}{expression to be returned if \code{test} is not \code{NULL}.} \item{null}{expression to be returned if \code{test} is \code{NULL}.} \item{x}{an object to be overwritten if \code{\link{NULL}}.} \item{value}{new value for \code{x}.} } \description{ Convenience functions for handling \code{\link{NULL}} objects. } \section{Functions}{ \itemize{ \item \code{NVL()}: Inspired by SQL function \code{NVL}, returns the first argument that is not \code{NULL}, or \code{NULL} if all arguments are \code{NULL}. \item \code{NVL2()}: Inspired by Oracle SQL function \code{NVL2}, returns the second argument if the first argument is not \code{NULL} and the third argument if the first argument is \code{NULL}. The third argument defaults to \code{NULL}, so \code{NVL2(a, b)} can serve as shorthand for \code{(if(!is.null(a)) b)}. \item \code{NVL3()}: Inspired by Oracle SQL \code{NVL2} function and \code{magittr} \code{\%>\%} operator, behaves as \code{NVL2} but \code{.}s in the second argument are substituted with the first argument. \item \code{EVL()}: As \code{NVL}, but for any objects of length 0 (\emph{E}mpty) rather than just \code{NULL}. Note that if no non-zero-length arguments are given, \code{NULL} is returned. \item \code{EVL2()}: As \code{NVL2}, but for any objects of length 0 (\emph{E}mpty) rather than just \code{NULL}. \item \code{EVL3()}: As \code{NVL3}, but for any objects of length 0 (\emph{E}mpty) rather than just \code{NULL}. \item \code{NVL(x) <- value}: Assigning to \code{NVL} overwrites its first argument if that argument is \code{\link{NULL}}. Note that it will \emph{always} return the right-hand-side of the assignment (\code{value}), regardless of what \code{x} is. \item \code{EVL(x) <- value}: As assignment to \code{NVL}, but for any objects of length 0 (\emph{E}mpty) rather than just \code{NULL}. }} \note{ Whenever possible, these functions use lazy evaluation, so, for example \code{NVL(1, stop("Error!"))} will never evaluate the \code{\link{stop}} call and will not produce an error, whereas \code{NVL(NULL, stop("Error!"))} would. } \examples{ a <- NULL a # NULL NVL(a,0) # 0 b <- 1 b # 1 NVL(b,0) # 1 # Here, object x does not exist, but since b is not NULL, x is # never evaluated, so the statement finishes. NVL(b,x) # 1 # Also, NVL(NULL,1,0) # 1 NVL(NULL,0,1) # 0 NVL(NULL,NULL,0) # 0 NVL(NULL,NULL,NULL) # NULL NVL2(a, "not null!", "null!") # "null!" NVL2(b, "not null!", "null!") # "not null!" NVL3(a, "not null!", "null!") # "null!" NVL3(b, .+1, "null!") # 2 NVL(NULL*2, 1) # numeric(0) is not NULL EVL(NULL*2, 1) # 1 NVL(a) <- 2 a # 2 NVL(b) <- 2 b # still 1 } \seealso{ \code{\link{NULL}}, \code{\link[base]{is.null}}, \code{\link[base]{if}} } \keyword{utilities} statnet.common/man/attr.Rd0000644000176200001440000000113514053620112015231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{attr} \alias{attr} \title{A wrapper for base::attr which defaults to exact matching.} \usage{ attr(x, which, exact = TRUE) } \arguments{ \item{x, which, exact}{as in \code{base::attr}, but with \code{exact} defaulting to \code{TRUE} in this implementation} } \value{ as in \code{base::attr} } \description{ A wrapper for base::attr which defaults to exact matching. } \examples{ x <- list() attr(x, "name") <- 10 base::attr(x, "n") stopifnot(is.null(attr(x, "n"))) base::attr(x, "n", exact = TRUE) } statnet.common/DESCRIPTION0000644000176200001440000000302515120320202014714 0ustar liggesusersPackage: statnet.common Version: 4.13.0 Date: 2025-12-16 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")), person("Skye", "Bender-deMoll", role=c("ctb"), email="skyebend@uw.edu"), person("Chad", "Klumb", role=c("ctb"), email="cklumb@gmail.com", comment=c(affiliation="University of Washington")), person("Michał", "Bojanowski", role=c("ctb"), email="michal2992@gmail.com", comment=c(ORCID="0000-0001-7503-852X"))) Description: Non-statistical utilities used by the software developed by the Statnet Project. They may also be of use to others. Depends: R (>= 4.1) Imports: utils, methods, coda, parallel, tools, Matrix BugReports: https://github.com/statnet/statnet.common/issues License: GPL-3 + file LICENSE URL: https://statnet.org RoxygenNote: 7.3.2.9000 Encoding: UTF-8 Suggests: covr, roxygen2, rlang (>= 1.1.1), purrr, testthat, MASS NeedsCompilation: yes Packaged: 2025-12-16 11:40:25 UTC; pavel Author: Pavel N. Krivitsky [aut, cre] (ORCID: , affiliation: University of New South Wales), Skye Bender-deMoll [ctb], Chad Klumb [ctb] (affiliation: University of Washington), Michał Bojanowski [ctb] (ORCID: ) Maintainer: Pavel N. Krivitsky Repository: CRAN Date/Publication: 2025-12-16 18:10:10 UTC