statnet.common/0000755000176200001440000000000014737434742013242 5ustar liggesusersstatnet.common/MD50000644000176200001440000000754414737434742013564 0ustar liggesusers4ec2d1b77cb2c22603d9c56daa50449b *DESCRIPTION 4cb31c4454a2aba2c3b38fbe8f368d26 *LICENSE 49dd3aa54c1b21ace799547613757728 *NAMESPACE 05250e8dcb1e02208fe5c889445dec2a *NEWS ba483beed6d59ddd0454a425aed6d473 *NEWS.md fc0042229ce8b07655e914ce43cfa022 *R/Welford.R bf56aea0d7bb6aecc5aa3fa0925a7916 *R/cite.utilities.R 3c4776fb3aa93d10fccf6da5fa35b7ba *R/control.utilities.R 90c24510b618b34ff6dea00d3f7c491f *R/deprecation_utils.R 718b35e0404f974f03bccc106f8118aa *R/formula.utilities.R c725df8dcf86637ce2507676cc28f3bd *R/locator.R b30710c0d8b67a7cbdc560a300ccbed1 *R/logspace.utils.R 932693af8bc78bea27a88f90b450d6ea *R/matrix.utils.R 17dbb6e028d8e5dbf6ae366adee8fc75 *R/mcmc-utils.R 22e893e6bdde460c29b89c7fdee99642 *R/misc.utilities.R 9592a2158b79fe835e528af12c094799 *R/startup.utilities.R 6890d1c6043744a0e206f7881663d088 *R/string.utilities.R acc5747137664810c22a5f843fcf6500 *R/wmatrix.R bcaa64a33f71411c9e1a90411bb16618 *R/zzz.R 6636db6035b0a2d1bb0fbd347add7f94 *build/stage23.rdb 9e7c70db805aff935ad52ef3c5725e08 *inst/CITATION 9baa07f8000d80691116328192ecb53d *inst/templates/snctrl.R 7f2a94a498a5dc05b0503c5a31ab87b5 *man/ERRVL.Rd 3ff13be4f722b95759d48982ef49331a *man/NVL.Rd 34de3ab4201a3cc30d57218b24164e0b *man/Welford.Rd b8da6a5b1e1749ebb1e2bd91fee52ae4 *man/all_identical.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 c7885722ddb46ab915a286cae1f096e4 *man/fixed.pval.Rd c9a722d71b353491bb1c93fdc0b228fe *man/forkTimeout.Rd d2bbaea746e24c2d6b9a225c494af84a *man/formula.utilities.Rd c4c4fd04ad2eb3987c562ee6725f7863 *man/handle.controls.Rd fb6b61e978b717e1ff51be23ad2229a6 *man/is.SPD.Rd 7ac45e4ba0e24a75670c19060379d76f *man/locate_function.Rd 106679def3d41374466723b60cd011df *man/logspace.utils.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 d12dde635ec286bc0a93b352aceb544f *man/set.control.class.Rd 740f941781269918f51d2162fddb38f1 *man/simplify_simple.Rd 9e3c3a3de6d2bbf3965184810705bb7f *man/snctrl-API.Rd 3d8dbbbec4df017419dd5c970a98b582 *man/snctrl.Rd a8de5de83cb42976a7fe04718debec89 *man/sort.data.frame.Rd 23afa368f513c4b3b06fad2aa62d4ef5 *man/split.array.Rd 7ac26fc4152b98b6cc9133dbf3e0e3c7 *man/ssolve.Rd 9bbf055f43b721dac1b7c1077ae89537 *man/statnet.cite.Rd 893ba4da7f56b1f754582e0eebe430e1 *man/statnetStartupMessage.Rd e39f236ad480f70fa99a9619806380bd *man/sweep_cols.matrix.Rd 8185268c388657b21290d1eb38b37536 *man/term_list.Rd 06fa194617821642f5530efebcc3eaec *man/trim_env.Rd 32710045b53e1d71ddf2812bb93e4a83 *man/ult.Rd 76a21eabe2d29ac33723ebd37714cc78 *man/unused_dots_warning.Rd c3e0ca540da380a53d3d6d2f871f6932 *man/unwhich.Rd acf1f0b58218004dc025eb1a475d4ea1 *man/vector.namesmatch.Rd 3039ecb65762e63a9a0522855a1bd0be *man/wmatrix.Rd 127255b6fa25823caad8378cb7865bdd *man/wmatrix_weights.Rd 299aa872038561fe81375e88c4c0d10d *man/xTAx.Rd 13fc2ba2114d30878c31dcb919738d49 *src/init.c 1f49976f676d3d723ca74d4ea0d8edba *src/logspace_utils.c statnet.common/R/0000755000176200001440000000000014734147767013450 5ustar liggesusersstatnet.common/R/matrix.utils.R0000644000176200001440000002015614734147767016242 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-2024 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 <- drop(crossprod(x, e$vectors[, keep, drop=FALSE])) structure(sum(h*h/e$values[keep]), rank = sum(keep), nullity = sum(!keep)) } .inv_diag <- function(X){ d <- diag(as.matrix(X)) ifelse(d==0, 0, 1/d) } .sqrt_inv_diag <- function(X){ Xname <- deparse1(substitute(X)) d <- .inv_diag(X) d <- suppressWarnings(sqrt(d)) if(anyNA(d)) stop("Matrix ", sQuote(Xname), " assumed symmetric and non-negative-definite has negative elements on the diagonal.") d } #' Wrappers around matrix algebra functions that pre-*s*cale their #' arguments #' #' Covariance matrices of variables with very different orders of #' magnitude can have very large ratios between their greatest and #' their least eigenvalues, causing them to appear to the algorithms #' to be near-singular when they are actually very much SPD. These #' functions first scale the matrix's rows and/or columns by its #' diagonal elements and then undo the scaling on the result. #' #' `ginv_eigen()` reimplements [MASS::ginv()] but using #' eigendecomposition rather than SVD; this means that it is only #' suitable for symmetric matrices, but that detection of negative #' eigenvalues is more robust. #' #' `ssolve()`, `sginv()`, `sginv_eigen()`, and `snearPD()` wrap #' [solve()], [MASS::ginv()], `ginv_eigen()`, and [Matrix::nearPD()], #' respectively. `srcond()` returns the reciprocal condition number of #' [rcond()] net of the above scaling. `xTAx_ssolve()`, #' `xTAx_qrssolve()`, `xTAx_seigen()`, and `sandwich_ssolve()` wrap #' the corresponding \pkg{statnet.common} functions. #' #' @param snnd assume that the matrix is symmetric non-negative #' definite (SNND). This typically entails scaling that converts #' covariance to correlation and use of eigendecomposition rather #' than singular-value decomposition. If it's "obvious" that the matrix is #' not SSND (e.g., negative diagonal elements), an error is raised. #' #' @param x,a,b,X,A,B,tol,... corresponding arguments of the wrapped functions. #' #' @export ssolve <- function(a, b, ..., snnd = TRUE) { if(missing(b)) { b <- diag(1, nrow(a)) colnames(b) <- rownames(a) } if(snnd) { d <- .sqrt_inv_diag(a) a <- a * d * rep(d, each = length(d)) solve(a, b*d, ...) * d } else { d <- .inv_diag(a) ## NB: In R, vector * matrix and matrix * vector always scales ## corresponding rows. solve(a*d, b*d, ...) } } #' @rdname ssolve #' #' @export sginv <- function(X, ..., snnd = TRUE){ if(snnd) { d <- .sqrt_inv_diag(X) dd <- rep(d, each = length(d)) * d ginv_eigen(X * dd, ...) * dd } else { d <- .inv_diag(X) dd <- rep(d, each = length(d)) MASS::ginv(X * dd, ...) * t(dd) } } #' @rdname ssolve #' @export ginv_eigen <- function(X, tol = sqrt(.Machine$double.eps), ...){ e <- eigen(X, symmetric=TRUE) keep <- e$values > 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(all.equal( #' xTAx_qrssolve(x,A), #' structure(drop(x%*%sginv(A)%*%x), rank = 2L, nullity = 1L) #' )) #' #' 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 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") } } #' @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{ if(nrow(x)<2) return(matrix(onerow, ncol(x), ncol(x))) .Call("logspace_wmean2_wrapper", sweep_cols.matrix(x, E), logw, PACKAGE="statnet.common") } } #' @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) else if(!is.null(xdim)) rbind(o) else o }else{ if(nrow(x)<2) matrix(onerow, ncol(x), ncol(y)) else .Call("logspace_wxmean_wrapper", x, y, logw, PACKAGE="statnet.common") } } #' @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.R0000644000176200001440000001232514734147767015241 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-2024 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.R0000644000176200001440000007771714734147767016563 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-2024 Statnet Commons ################################################################################ #' reorder vector v into order determined by matching the names of its elements #' to a vector of names #' #' A helper function to reorder vector \code{v} (if named) into order specified #' by matching its names to the argument \code{names} #' #' does some checking of appropriateness of arguments, and reorders v by #' matching its names to character vector \code{names} #' #' @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 advertiased #' @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 "', 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 "', errname,'". Specify by position.') } v } #' "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 } #' Return the first argument passed (out of any number) that is not a #' \code{try-error} (result of \code{\link[base]{try}} encountering an error. #' #' This function is inspired by \code{\link{NVL}}, and simply returns the first #' argument that is not a \code{try-error}, raising an error if all arguments #' are \code{try-error}s. #' #' #' @param \dots Expressions to be tested; usually outputs of #' \code{\link[base]{try}}. #' @return The first argument that is not a \code{try-error}. Stops #' with an error if all are. #' @note This function uses lazy evaluation, so, for example `ERRVL(1, #' stop("Error!"))` will never evaluate the [`stop`] call and will #' not produce an error, whereas `ERRVL(try(solve(0)), #' stop("Error!"))` would. #' #' In addition, all expressions after the first may contain a `.`, #' which is substituted with the `try-error` object returned by the #' previous expression. #' #' @seealso \code{\link[base]{try}}, \code{\link[base]{inherits}} #' @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!"))) #' #' # Error with an elaborate message: #' print(ERRVL(try(solve(0), silent=TRUE), #' stop("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("No non-error expressions passed.") } #' 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 #' #' @return `TRUE` if all elements of `x` are identical to each other. #' #' @seealso [`identical`] #' #' @examples #' #' stopifnot(!all_identical(1:3)) #' #' stopifnot(all_identical(list("a", "a", "a"))) #' @export all_identical <- function(x){ if(length(x)==0) return(TRUE) v0 <- x[[1L]] for(v in x[-1]) if(!identical(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. } statnet.common/R/formula.utilities.R0000644000176200001440000004623214734147767017261 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-2024 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; its `"sign"` attribute vector can give the sign of #' each term (`+1` or `-1`), and its `"env"` attribute #' vector will be used to set its environment, with the first #' available being used and subsequent ones producing a warning. #' @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(attr(newterms, "sign")[i], +1)>0) "+" else "-" if(length(object)==0){ if(termsign == "-") newterm <- call(termsign, newterm) object <- as.formula(call("~", newterm)) }else if(length(object)==3) object[[3L]]<-call(termsign,object[[3L]],newterm) else if(keep.onesided) object[[2L]]<-call(termsign,object[[2L]],newterm) else object[[3L]]<- if(termsign=="+") newterm else call(termsign,newterm) NVL(env) <- termenv <- attr(newterms, "env")[[i]] 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, attributes #' `"sign"` and `"env"`, containing, respectively a vector of #' signs that the terms had in the original formula and a list of #' environments of the formula from which the term has been #' extracted. Indexing and concatenation methods preserve these. #' #' @param x 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 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(attr(l, "sign"), c(1,1,-1,1))) #' stopifnot(identical(attr(l, "env"), rep(list(e1, globalenv()), each=2))) #' } #' #' (l <- c(l2[1], l1[2], l1[1], l1[1], l2[2])) #' \dontshow{ #' stopifnot(identical(c(unclass(l)), alist(NULL, c, b, b, 1))) #' stopifnot(identical(attr(l, "sign"), c(-1,1,1,1,1))) #' stopifnot(identical(attr(l, "env"), list(globalenv(), e1, e1, e1, globalenv()))) #' } #' #' @export term_list <- function(x, sign = +1, env = NULL){ if(!is.list(x)) x <- list(x) if(!is.list(env)) env <- list(env) structure(x, sign = rep(sign, length.out=length(x)), 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 = +1, env = NULL, ...) term_list(x, sign=sign, env=env) #' @rdname term_list #' @export c.term_list <- function(x, ...){ xl <- c(list(as.term_list(x)), lapply(list(...), as.term_list)) structure( c(unclass(x), ...), sign = unlist(lapply(xl, attr, "sign"), use.names=FALSE), env = unlist(lapply(xl, attr, "env"), recursive=FALSE, use.names=FALSE), class = "term_list" ) } #' @rdname term_list #' @export `[.term_list` <- function(x, i, ...){ term_list(NextMethod(), sign = attr(x, "sign")[i], env = attr(x, "env")[i]) } #' @rdname term_list #' @export print.term_list <- function(x, ...){ signstr <- ifelse(attr(x, "sign")>=0, "+", "-") envstr <- sapply(attr(x, "env"), format) termstr <- lapply(lapply(x, format), paste0, collapse="\n") cat("Term List:\n") cat(paste(signstr, termstr, envstr, collapse="\n")) cat("\n") } .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=1, env=list(globalenv()), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~b), #' structure(alist(b), sign=1, env=list(globalenv()), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~b+NULL), #' structure(alist(b, NULL), #' sign=c(1,1), env=rep(list(globalenv()), 2), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~-b+NULL), #' structure(alist(b, NULL), #' sign=c(-1,1), env=rep(list(globalenv()), 2), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~+b-NULL), #' structure(alist(b, NULL), #' sign=c(1,-1), env=rep(list(globalenv()), 2), class="term_list"))) #' stopifnot(identical(list_rhs.formula(~+b-(NULL+c)), #' structure(alist(b, NULL, c), #' sign=c(1,-1,-1), env=rep(list(globalenv()), 3), class="term_list"))) #' #' @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.R0000644000176200001440000000744614734147767015210 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-2024 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.R0000644000176200001440000000771414734147767015661 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-2024 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.R0000644000176200001440000000100214734147767014421 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-2024 Statnet Commons ################################################################################ .onUnload <- function(libpath){ library.dynam.unload("statnet.common",libpath) } statnet.common/R/string.utilities.R0000644000176200001440000000773314734147767017125 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-2024 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.R0000644000176200001440000002251114734147767015267 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-2024 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.R0000644000176200001440000005311114734147767017266 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-2024 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/cite.utilities.R0000644000176200001440000001020114734147767016523 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-2024 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.R0000644000176200001440000000553614734147767017321 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-2024 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/NEWS0000644000176200001440000002701514734077726013750 0ustar liggesusersstatnet.common 4.11.0 ===================== - 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. - 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 ===================== - `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. - 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. - `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. - A new function `var.mcmc.list()` "method" to evaluate the covariance matrix for an `mcmc.list` without constructing a large matrix. - `colMeans.mcmc.list()` "method" no longer constructs a large matrix when calculating. 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/0000755000176200001440000000000014734150561014020 5ustar liggesusersstatnet.common/src/init.c0000644000176200001440000000275414734147767015155 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-2024 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.c0000644000176200001440000001565614734147767017234 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-2024 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/NAMESPACE0000644000176200001440000000743614734077726014475 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",control.list) S3method("[",term_list) S3method("[",wmatrix) S3method("[<-",wmatrix) S3method("lrowweights<-",linwmatrix) S3method("lrowweights<-",logwmatrix) S3method("lrowweights<-",matrix) S3method("rowweights<-",linwmatrix) S3method("rowweights<-",logwmatrix) S3method("rowweights<-",matrix) 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(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(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("lrowweights<-") export("rowweights<-") export("ult<-") export(.Deprecate_method) export(.Deprecate_once) export(COLLATE_ALL_MY_CONTROLS_EXPR) export(ERRVL) 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(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(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(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(rowweights) export(sandwich_solve) export(sandwich_ssolve) export(set.control.class) export(sginv) export(simplify_simple) export(snctrl) export(snctrl_names) export(snearPD) 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(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,var) importFrom(utils,capture.output) importFrom(utils,getAnywhere) importFrom(utils,modifyList) useDynLib(statnet.common) statnet.common/LICENSE0000644000176200001440000000311314676752012014240 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-2024 statnet.common/NEWS.md0000644000176200001440000002452314734077726014350 0ustar liggesusers# statnet.common 4.11.0 * 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. * 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 * `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. * 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. * `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. * A new function `var.mcmc.list()` "method" to evaluate the covariance matrix for an `mcmc.list` without constructing a large matrix. * `colMeans.mcmc.list()` "method" no longer constructs a large matrix when calculating. # 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/0000755000176200001440000000000014734077726014221 5ustar liggesusersstatnet.common/inst/CITATION0000644000176200001440000000342214734147444015352 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("2024-12-29", 1, 4), note = paste("R package version ", "4.11.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/0000755000176200001440000000000014734147767016222 5ustar liggesusersstatnet.common/inst/templates/snctrl.R0000644000176200001440000000326014734147767017653 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-2024 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/0000755000176200001440000000000014734150561014330 5ustar liggesusersstatnet.common/build/stage23.rdb0000644000176200001440000000613514734150561016276 0ustar liggesusers‹Í\{WÛÈÆ/Þ ÙÍcÓM´Ð’8!Ù†$Ȇ6$ÔО4U7G–ƶ‚¬Q%p9ôSíßýíWè_=ù›ÎHWf$ z„,çˆ{Gss_sg4âí° 9!_ ¿){‰ü„AJ¯ÏÜÏyaˆÐ¹[âÈ@–ì U¬uD vÈX\U,Ø‘ª9ô‹¦l¨‚Ï1÷«ê{GnŽí±´öfkkãõn¸±m)ªcô“©{ÍÐÀ]%rW]Óaó‚÷ó1ÔdpÃPB Ú}1¿jWF†‚UÍh„4Àm\0ä²CÝ–7º=¿„nr4rƒ#·L‚hœ~±úïŸ?¾þyñ_áž]¶ýžsþ0·ßìl¾U_WîG‡#¦L•A±… ­Vœ–Y©’_Úâ;mñe¥Zkkººø=Z|øhQ]\ª×î)‚Ï1³ àV •–lTlCq,}¡¶mî@ ‰¸Ÿ@„7CŸÂ®rbݨ&]·ñ; Øn`Ø»m |[~wã-x`îSÈçæ m7HÚå?%‚ñà–¸­#ÙF^´¨Xi·A4¡aCÔ ±ZQ°áXX_h;š®9²ªȃáŸà”>þAjð±uHÅÏP¸À€Ä” ¶r=2 ÓŸ7ªÏ9˜hž+~4 &®Ô‚ä…WìÐ1àÇÎß"Tü8Cáú¢¡éº t øDªáJ-J²®Év„Ü ãÀ'ÓE*“Pñ …+#“LìxiV\óòJLp°¥—¿œ¡mÍÑyáR{Pzø+ço*þ*CáJh›ÜYáªkoÖ78xŠ`ŸÂ•R-£^ØÎ.,,ÜŽ ©Ö<êòÙåÓ¢Ô¶åÏCü9º,êÃóö²g×.…+¡‡ ¦…3VðéhRkø+ð’Ê ñ”˜À†ÁE†\É£ñ ¼Hz¸ÛD¢)[dîu%êšíˆš-¶MÕ]­¨2+kЬëQ¶ICe8•W¹Ã PJW_Mír?Èu,«(Y9‰mÃû° ’Ai–¨´-‹”ˆÝA5´}dˆ5¤ãƒ¸F8¡ôàȰöÑԊЛ/ö1ðÏ?T©ø†Â•Ñè‡%Ùj¸Å<¯Öº™ñKf«QjŸ¦ËVgžÏ¢àP:ÎÐäÕ(ûí“UÑ[)Dg¾²d#%bý&ÜÿÛ4º¥-F?õ¢I§? )ÇÐä 1Œ[0&Ÿ&ö>n«\•Wæú?¿yBVV ¸R±%+¦‡0ýC¥aúQ8)IŽ3æ%G®Hç´’T2»8Èv˜†å0ÿ S·E‘ÛÕÉáÕnÃ|¨Q™ÈSv;& ¶áSIªk¶Å6ý*ÔdPR¬àãsŸaÕØ>.†ù¥GO¨‘Šþn‘ð3€d·k݈î6¿tÒœs‹èYT÷ôr÷–+}n)IØ Iå¢nzç7ú:ØgtÿÓZÝP·Nõè–z 6ôNÐsúö[à(­Ã·Q ëjo#Ž´:Òm¶¿Ë=(wš©‰Ùþ.Eög“B+à¿Ñ¢y½š “xh·ÜSëL« œÎÊ)ñd²1]‡2}v̆a¡'P÷e½ÍŠ›èÉ È=‰:/™{œñ¥L#CÕXߘîée_¶NéÅß“ûNH36B²nãSÂsL"esD…ì&·‰Ý,!ZÓ݃_¬š¹NP”t;¬Ax)–™à»íJ=†ºGb$ÊÓNqæ€6}Ãf Nþ'ÖdÍɳI€=C GÚý¨H éƒLKm=à Q8ÚÂ:5g î>G8r{%1‘¢ÉzpÌ=²ªâì&>8Eq%©ª¾1ø‡û`ËKjµüg%ËÁ¶Ñ[x£.²!M<áˆáÅjIRÿØÆgr¸îÁÚS§÷²D £Ó:Ex‘ÌE=SQÛÒ£`Ú?89—Óvu°¥žmNªöqþ‚d»oÕðÜ/\lx/Æô«¤È<ÔGݼ:ɵuï(B¢½CrÝF“|Ñîs‹3h¤ ɵ'ËG4ÞG[ŒòÊ•a*¤™Ì}< %Ô’5/</þ£Ï¾Ú•tÍØÛyà¿ù·Ó`ŒÓÙdw lÚZ¨faš¬‡8]y;©‘óu(ÂlžAyi¯Ö/Œ´ŽÈ,ª ÓTERcT)Ü÷¢IþÛx—$ØYg翜/âZIJ0X:‰ä ÍÐ`"eoZ÷ÿW ÙmݱW,uÎvˆè÷]±¿9ëöòòrU} Þ3³òìÔô½©ÛÇœuá ¬KëÀ×OÖ…ìºþ­Ð³ʼäW )x/S´ÊXýÏÑÖï¿-6Ïú¶ÞpXÀf¥‰[¨bÊûH¯¬ÃÛav¥Šl$[J³²ƒëÎl¡JužN?{»é~R+ÞBµbwl’_ºoé„üJÞÍãDØv5‘«)á&wz+àLô»÷ÛÕÙé{\÷ñ`PÊ9«¬žý^~%Ì@¯&è-Xxédqsx|Dk¯£#OÂñññ‘ÇpÆxÆE)gÏ2åËRM«y%YæÌMßã a`Sz økI†š1L 7tÙ}ó7ì\ ‘û¡cצïQ#‘ßœá=„!= 5™…z­ã-[>Ÿu˜ÀÉÐ:9iós‚~@)eΦ]–Öª«¯Ýå|к{IGMÇ1íåJ…ö½P'^KÏT,`«QÉr…8ÖÝFpýŒ3ÜI"¥[Àoeâb¤zµ ”M–û†Cÿ$‘#òFÅ~º+tÓ\òÔÆÙä ïz+¬,¬ú$~-ä®ï¢« ÿð¥ï€—VgÚ´œðõ³i¨š[Æf¡¡gñ5¤yò£uc\úð?e6 žÔÒ;kÕÍíÝÍ7¯³ÑE‚Ê™Á­Ð¥œÊ9a÷õ° [~Y¨ài|x;ŽÑ£ÿFL©¼”I>ÌK*Ö²÷üj[",z”ó02JŸÿ,µ'}oÉšAÖùÊÈÎkñíÜêBˆÖ‚ÿ$—Rx5óìZiŸ÷\xTUX¢±ãÉüÁ”M ™dAJ•ꮟþOðR)¬Ô!¦3á—ÿkék “Hstatnet.common/man/0000755000176200001440000000000014734077726014017 5ustar liggesusersstatnet.common/man/empty_env.Rd0000644000176200001440000000144014014030772016270 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.utilities.R \name{empty_env} \alias{empty_env} \alias{base_env} \title{Replace an object's environment with a simple, static environment.} \usage{ empty_env(object) base_env(object) } \arguments{ \item{object}{An object with the \verb{environment()<-} method.} } \value{ An object of the same type as \code{object}, with updated environment. } \description{ Replace an object's environment with a simple, static environment. } \examples{ f <- y~x environment(f) # GlobalEnv environment(empty_env(f)) # EmptyEnv \dontshow{ stopifnot(identical(environment(empty_env(f)), emptyenv())) } environment(base_env(f)) # base package environment \dontshow{ stopifnot(identical(environment(base_env(f)), baseenv())) } } statnet.common/man/mcmc-utilities.Rd0000644000176200001440000000577714677005327017250 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mcmc-utils.R \name{mcmc-utilities} \alias{mcmc-utilities} \alias{colMeans.mcmc.list} \alias{var.mcmc.list} \alias{sweep.mcmc.list} \alias{lapply.mcmc.list} \title{Utility operations for \code{\link[coda:mcmc.list]{mcmc.list}} objects} \usage{ colMeans.mcmc.list(x, ...) var.mcmc.list(x, ...) sweep.mcmc.list(x, STATS, FUN = "-", check.margin = TRUE, ...) lapply.mcmc.list(X, FUN, ...) } \arguments{ \item{x}{a \code{\link[coda:mcmc.list]{mcmc.list}} object.} \item{\dots}{additional arguments to the functions evaluated on each chain.} \item{STATS, FUN, check.margin}{See help for \code{\link[=sweep]{sweep()}}.} \item{X}{An \code{\link[coda:mcmc.list]{mcmc.list}} object.} } \value{ \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. \code{sweep.mcmc.list} returns an appropriately modified version of \code{x} \code{lapply.mcmc.list} returns an \code{\link[coda:mcmc.list]{mcmc.list}} each of whose chains had been passed through \code{FUN}. } \description{ \code{colMeans.mcmc.list} is a "method" for (non-generic) \code{\link[=colMeans]{colMeans()}} applicable to \code{\link[coda:mcmc.list]{mcmc.list}} objects. \code{var.mcmc.list} is a "method" for (non-generic) \code{\link[=var]{var()}} applicable to \code{\link[coda:mcmc.list]{mcmc.list}} objects. Since MCMC chains are assumed to all be sampling from the same underlying distribution, their pooled mean is used. \code{sweep.mcmc.list} is a "method" for (non-generic) \code{\link[=sweep]{sweep()}} applicable to \code{\link[coda:mcmc.list]{mcmc.list}} objects. \code{lapply.mcmc.list} is a "method" for (non-generic) \code{\link[=lapply]{lapply()}} applicable to \code{\link[coda:mcmc.list]{mcmc.list}} objects. } \details{ These implementations should be equivalent (within numerical error) to the same function being called on \code{as.matrix(x)}, while avoiding construction of the large matrix. } \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)))) } 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))))) } 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))) } 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)))))) } } \seealso{ \code{\link[coda:mcmc.list]{mcmc.list}} \code{\link[=colMeans]{colMeans()}} \code{\link[=var]{var()}} \code{\link[=sweep]{sweep()}} \code{\link[=lapply]{lapply()}} } statnet.common/man/ERRVL.Rd0000644000176200001440000000271613701734650015173 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{ERRVL} \alias{ERRVL} \title{Return the first argument passed (out of any number) that is not a \code{try-error} (result of \code{\link[base]{try}} encountering an error.} \usage{ ERRVL(...) } \arguments{ \item{\dots}{Expressions to be tested; usually outputs of \code{\link[base]{try}}.} } \value{ The first argument that is not a \code{try-error}. Stops with an error if all are. } \description{ This function is inspired by \code{\link{NVL}}, and simply returns the first argument that is not a \code{try-error}, raising an error if all arguments are \code{try-error}s. } \note{ This function uses lazy evaluation, so, for example \code{ERRVL(1, stop("Error!"))} will never evaluate the \code{\link{stop}} call and will not produce an error, whereas \code{ERRVL(try(solve(0)), stop("Error!"))} would. In addition, all expressions after the first may contain a \code{.}, which is substituted with the \code{try-error} object returned by the previous expression. } \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!"))) # Error with an elaborate message: print(ERRVL(try(solve(0), silent=TRUE), stop("Stopped with an error: ", .))) } } \seealso{ \code{\link[base]{try}}, \code{\link[base]{inherits}} } \keyword{utilities} statnet.common/man/ssolve.Rd0000644000176200001440000000531614537773317015626 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/matrix.utils.R \name{ssolve} \alias{ssolve} \alias{sginv} \alias{ginv_eigen} \alias{xTAx_seigen} \alias{srcond} \alias{snearPD} \alias{xTAx_ssolve} \alias{xTAx_qrssolve} \alias{sandwich_ssolve} \title{Wrappers around matrix algebra functions that pre-\emph{s}cale their arguments} \usage{ ssolve(a, b, ..., snnd = TRUE) sginv(X, ..., snnd = TRUE) ginv_eigen(X, tol = sqrt(.Machine$double.eps), ...) xTAx_seigen(x, A, tol = sqrt(.Machine$double.eps), ...) srcond(x, ..., snnd = TRUE) snearPD(x, ...) xTAx_ssolve(x, A, ...) xTAx_qrssolve(x, A, tol = 1e-07, ...) sandwich_ssolve(A, B, ...) } \arguments{ \item{snnd}{assume that the matrix is symmetric non-negative definite (SNND). This typically entails scaling that converts covariance to correlation and use of eigendecomposition rather than singular-value decomposition. If it's "obvious" that the matrix is not SSND (e.g., negative diagonal elements), an error is raised.} \item{x, a, b, X, A, B, tol, ...}{corresponding arguments of the wrapped functions.} } \description{ Covariance matrices of variables with very different orders of magnitude can have very large ratios between their greatest and their least eigenvalues, causing them to appear to the algorithms to be near-singular when they are actually very much SPD. These functions first scale the matrix's rows and/or columns by its diagonal elements and then undo the scaling on the result. } \details{ \code{ginv_eigen()} reimplements \code{\link[MASS:ginv]{MASS::ginv()}} but using eigendecomposition rather than SVD; this means that it is only suitable for symmetric matrices, but that detection of negative eigenvalues is more robust. \code{ssolve()}, \code{sginv()}, \code{sginv_eigen()}, and \code{snearPD()} wrap \code{\link[=solve]{solve()}}, \code{\link[MASS:ginv]{MASS::ginv()}}, \code{ginv_eigen()}, and \code{\link[Matrix:nearPD]{Matrix::nearPD()}}, respectively. \code{srcond()} returns the reciprocal condition number of \code{\link[=rcond]{rcond()}} net of the above scaling. \code{xTAx_ssolve()}, \code{xTAx_qrssolve()}, \code{xTAx_seigen()}, and \code{sandwich_ssolve()} wrap the corresponding \pkg{statnet.common} functions. } \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(all.equal( xTAx_qrssolve(x,A), structure(drop(x\%*\%sginv(A)\%*\%x), rank = 2L, nullity = 1L) )) 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") } statnet.common/man/message_print.Rd0000644000176200001440000000140613701734650017134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/string.utilities.R \name{message_print} \alias{message_print} \title{\code{\link{print}} objects to the \code{\link{message}} output.} \usage{ message_print(..., messageArgs = NULL) } \arguments{ \item{...}{arguments to \code{\link{print}}.} \item{messageArgs}{a list of arguments to be passed directly to \code{\link{message}}.} } \description{ A thin wrapper around \code{\link{print}} that captures its output and prints it as a \code{\link{message}}, usually to STDERR. } \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 } statnet.common/man/snctrl-API.Rd0000644000176200001440000000562314306106145016207 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/control.utilities.R \docType{data} \name{snctrl_names} \alias{snctrl_names} \alias{snctrl-API} \alias{update_snctrl} \alias{collate_controls} \alias{UPDATE_MY_SCTRL_EXPR} \alias{COLLATE_ALL_MY_CONTROLS_EXPR} \title{Helper functions used by packages to facilitate \code{\link{snctrl}} updating.} \format{ \code{UPDATE_MY_SCTRL_EXPR} is a quoted expression meant to be passed directly to \code{\link[=eval]{eval()}}. \code{COLLATE_ALL_MY_CONTROLS_EXPR} is a quoted expression meant to be passed directly to \code{\link[=eval]{eval()}}. } \usage{ snctrl_names() update_snctrl(myname, arglists = NULL, callback = NULL) collate_controls(x = NULL, ...) UPDATE_MY_SCTRL_EXPR COLLATE_ALL_MY_CONTROLS_EXPR } \arguments{ \item{myname}{Name of the package defining the arguments.} \item{arglists}{A named list of argument name-default pairs. If the list is not named, it is first passed through \code{\link[=collate_controls]{collate_controls()}}.} \item{callback}{A function with no arguments that updates the packages own copy of \code{\link[=snctrl]{snctrl()}}.} \item{x}{Either a function, a list of functions, or an environment. If \code{x} is an environment, all functions starting with dQuote(\code{control.}) are obtained.} \item{...}{Additional functions or lists of functions.} } \value{ \code{update_snctrl()} has no return value and is used for its side-effects. \code{collate_controls()} returns the combined list of name-default pairs of each function. } \description{ Helper functions used by packages to facilitate \code{\link{snctrl}} updating. } \section{Functions}{ \itemize{ \item \code{snctrl_names()}: Typeset the currently defined list of argument names by package and control function. \item \code{update_snctrl()}: Typically called from \code{\link[=.onLoad]{.onLoad()}}, Update the argument list of \code{\link[=snctrl]{snctrl()}} to include additional argument names associated with the package, and set a callback for the package to update its own copy. \item \code{collate_controls()}: Obtain and concatenate the argument lists of specified functions or all functions starting with dQuote(\code{control.}) in the environment. \item \code{UPDATE_MY_SCTRL_EXPR}: A stored expression that, if evaluated, will create a callback function \code{update_my_snctrl()} that will update the client package's copy of \code{\link[=snctrl]{snctrl()}}. \item \code{COLLATE_ALL_MY_CONTROLS_EXPR}: A stored expression that, if evaluated on loading, will add arguments of the package's \verb{control.*()} functions to \code{\link[=snctrl]{snctrl()}} and set the callback. }} \examples{ \dontrun{ # In the client package (outside any function): eval(UPDATE_MY_SCTRL_EXPR) } \dontrun{ # In the client package: .onLoad <- function(libame, pkgname){ # ... other code ... eval(statnet.common::COLLATE_ALL_MY_CONTROLS_EXPR) # ... other code ... } } } \keyword{datasets} statnet.common/man/is.SPD.Rd0000644000176200001440000000070014426711612015326 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/matrix.utils.R \name{is.SPD} \alias{is.SPD} \title{Test if the object is a matrix that is symmetric and positive definite} \usage{ is.SPD(x, tol = .Machine$double.eps) } \arguments{ \item{x}{the object to be tested.} \item{tol}{the tolerance for the reciprocal condition number.} } \description{ Test if the object is a matrix that is symmetric and positive definite } statnet.common/man/trim_env.Rd0000644000176200001440000000271214734077726016133 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formula.utilities.R \name{trim_env} \alias{trim_env} \alias{trim_env.environment} \alias{trim_env.default} \title{Make a copy of an environment with just the selected objects.} \usage{ trim_env(object, keep = NULL, ...) \method{trim_env}{environment}(object, keep = NULL, ...) \method{trim_env}{default}(object, keep = NULL, ...) } \arguments{ \item{object}{An \code{\link{environment}} or an object with \code{\link[=environment]{environment()}} and \verb{environment()<-} methods.} \item{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.} \item{...}{Additional arguments, passed on to lower-level methods.} } \value{ An object of the same type as \code{object}, with updated environment. If \code{keep} is empty, the environment is \code{\link[=baseenv]{baseenv()}}; if not empty, it's a new environment with \code{\link[=baseenv]{baseenv()}} as parent. } \description{ Make a copy of an environment with just the selected objects. } \section{Methods (by class)}{ \itemize{ \item \code{trim_env(environment)}: A method for environment objects. \item \code{trim_env(default)}: Default method, for objects such as \code{\link{formula}} and \code{\link{function}} that have \code{\link[=environment]{environment()}} and \verb{environment()<-} methods. }} statnet.common/man/ult.Rd0000644000176200001440000000211713701734650015100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{ult} \alias{ult} \alias{ult<-} \title{Extract or replace the \emph{ult}imate (last) element of a vector or a list, or an element counting from the end.} \usage{ ult(x, i = 1L) ult(x, i = 1L) <- value } \arguments{ \item{x}{a vector or a list.} \item{i}{index from the end of the list to extract or replace (where 1 is the last element, 2 is the penultimate element, etc.).} \item{value}{Replacement value for the \code{i}th element from the end.} } \value{ An element of \code{x}. } \description{ Extract or replace the \emph{ult}imate (last) element of a vector or a list, or an element counting from the end. } \note{ Due to the way in which assigning to a function is implemented in R, \code{ult(x) <- e} may be less efficient than \code{x[[length(x)]] <- e}. } \examples{ x <- 1:5 (last <- ult(x)) (penultimate <- ult(x, 2)) # 2nd last. \dontshow{ stopifnot(last==5) stopifnot(penultimate==4) } (ult(x) <- 6) (ult(x, 2) <- 7) # 2nd last. x \dontshow{ stopifnot(all(x == c(1:3, 7L, 6L))) } } statnet.common/man/simplify_simple.Rd0000644000176200001440000000410414004655074017476 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{simplify_simple} \alias{simplify_simple} \title{Convert a list to an atomic vector if it consists solely of atomic elements of length 1.} \usage{ simplify_simple( x, toNA = c("null", "empty", "keep"), empty = c("keep", "unlist"), ... ) } \arguments{ \item{x}{an R \code{\link{list}} to be simplified.} \item{toNA}{a character string indicating whether \code{NULL} entries (if \code{"null"}) or 0-length entries including \code{NULL} (if \code{"empty"}) should be replaced with \code{NA}s before attempting conversion; specifying \code{keep} or \code{FALSE} leaves them alone (typically preventing conversion).} \item{empty}{a character string indicating how empty lists should be handled: either \code{"keep"}, in which case they are unchanged or \code{"unlist"}, in which cases they are unlisted (typically to \code{NULL}).} \item{...}{additional arguments passed to \code{\link[=unlist]{unlist()}}.} } \value{ an atomic vector or a list of the same length as \code{x}. } \description{ This behaviour is not dissimilar to that of \code{\link[=simplify2array]{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 \code{\link{data.frame}}. } \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. } statnet.common/man/statnetStartupMessage.Rd0000644000176200001440000000272514056620171020647 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/startup.utilities.R \name{statnetStartupMessage} \alias{statnetStartupMessage} \title{Construct a "standard" startup message to be printed when the package is loaded.} \usage{ statnetStartupMessage(pkgname, friends = c(), nofriends = c()) } \arguments{ \item{pkgname}{Name of the package whose information is used.} \item{friends, nofriends}{No longer used.} } \value{ A string containing the startup message, to be passed to the \code{\link[=packageStartupMessage]{packageStartupMessage()}} call or \code{NULL}, if policy prescribes printing default startup message. (Thus, if \code{\link[=statnetStartupMessage]{statnetStartupMessage()}} returns \code{NULL}, the calling package should not call \code{\link[=packageStartupMessage]{packageStartupMessage()}} at all.) } \description{ This function uses information returned by \code{\link[=packageDescription]{packageDescription()}} to construct a standard package startup message according to the policy of the Statnet Project. } \note{ Earlier versions of this function printed a more expansive message. This may change again as the Statnet Project policy evolves. } \examples{ \dontrun{ .onAttach <- function(lib, pkg){ sm <- statnetStartupMessage("ergm") if(!is.null(sm)) packageStartupMessage(sm) } } } \seealso{ \code{\link[=packageDescription]{packageDescription()}}, \code{\link[=packageStartupMessage]{packageStartupMessage()}} } \keyword{utilities} statnet.common/man/split.array.Rd0000644000176200001440000000243513701734650016547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{split.array} \alias{split.array} \alias{split.matrix} \title{A \code{\link[=split]{split()}} method for \code{\link{array}} and \code{\link{matrix}} types on a margin.} \usage{ \method{split}{array}(x, f, drop = FALSE, margin = NULL, ...) \method{split}{matrix}(x, f, drop = FALSE, margin = NULL, ...) } \arguments{ \item{x}{A \code{\link{matrix}} or an \code{\link{array}}.} \item{f, drop}{See help for \code{\link[=split]{split()}}. Note that \code{drop} here is \emph{not} for array dimensions: these are always preserved.} \item{margin}{Which margin of the array to split along. \code{NULL} splits as \code{\link{split.default}}, dropping dimensions.} \item{...}{Additional arguments to \code{\link[=split]{split()}}.} } \description{ These methods split an \code{\link{array}} and \code{\link{matrix}} into a list of arrays or matrices with the same number of dimensions according to the specified margin. } \examples{ x <- diag(5) f <- rep(1:2, c(2,3)) split(x, f, margin=1) # Split rows. split(x, f, margin=2) # Split columns. # This is similar to how data frames are split: stopifnot(identical(split(x, f, margin=1), lapply(lapply(split(as.data.frame(x), f), as.matrix), unname))) } statnet.common/man/vector.namesmatch.Rd0000644000176200001440000000212613701734650017715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/misc.utilities.R \name{vector.namesmatch} \alias{vector.namesmatch} \title{reorder vector v into order determined by matching the names of its elements to a vector of names} \usage{ vector.namesmatch(v, names, errname = NULL) } \arguments{ \item{v}{a vector (or list) with named elements, to be reorderd} \item{names}{a character vector of element names, corresponding to names of \code{v}, specificying desired orering of \code{v}} \item{errname}{optional, name to be reported in any error messages. default to \code{deparse(substitute(v))}} } \value{ returns \code{v}, with elements reordered } \description{ A helper function to reorder vector \code{v} (if named) into order specified by matching its names to the argument \code{names} } \details{ does some checking of appropriateness of arguments, and reorders v by matching its names to character vector \code{names} } \note{ earlier versions of this function did not order as advertiased } \examples{ test<-list(c=1,b=2,a=3) vector.namesmatch(test,names=c('a','c','b')) } statnet.common/man/paste.and.Rd0000644000176200001440000000167713701734650016163 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/string.utilities.R \name{paste.and} \alias{paste.and} \title{Concatenates the elements of a vector (optionaly enclosing them in quotation marks or parentheses) adding appropriate punctuation and conjunctions.} \usage{ paste.and(x, oq = "", cq = "", con = "and") } \arguments{ \item{x}{A vector.} \item{oq}{Opening quotation symbol. (Defaults to none.)} \item{cq}{Closing quotation symbol. (Defaults to none.)} \item{con}{Conjunction to be used if \code{length(x)>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/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/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.Rd0000644000176200001440000000401514265230012016262 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} \title{A helper class for list of terms in an formula} \usage{ term_list(x, sign = +1, env = NULL) as.term_list(x, ...) \method{as.term_list}{term_list}(x, ...) \method{as.term_list}{default}(x, sign = +1, env = NULL, ...) \method{c}{term_list}(x, ...) \method{[}{term_list}(x, i, ...) \method{print}{term_list}(x, ...) } \arguments{ \item{x}{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} } \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, attributes \code{"sign"} and \code{"env"}, containing, respectively a vector of signs that the terms had in the original formula and a list of environments of the formula from which the term has been extracted. Indexing and concatenation methods preserve these. } \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(attr(l, "sign"), c(1,1,-1,1))) stopifnot(identical(attr(l, "env"), rep(list(e1, globalenv()), each=2))) } (l <- c(l2[1], l1[2], l1[1], l1[1], l2[2])) \dontshow{ stopifnot(identical(c(unclass(l)), alist(NULL, c, b, b, 1))) stopifnot(identical(attr(l, "sign"), c(-1,1,1,1,1))) stopifnot(identical(attr(l, "env"), list(globalenv(), e1, e1, e1, globalenv()))) } } \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/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.Rd0000644000176200001440000000402214537773317015170 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} \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), ...) } \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; 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/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.Rd0000644000176200001440000000104513701734650017057 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) } \arguments{ \item{x}{a vector or a list} } \value{ \code{TRUE} if all elements of \code{x} are identical to each other. } \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"))) } \seealso{ \code{\link{identical}} } statnet.common/man/formula.utilities.Rd0000644000176200001440000001714714306351011017750 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; its \code{"sign"} attribute vector can give the sign of each term (\code{+1} or \code{-1}), and its \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=1, env=list(globalenv()), class="term_list"))) stopifnot(identical(list_rhs.formula(~b), structure(alist(b), sign=1, env=list(globalenv()), class="term_list"))) stopifnot(identical(list_rhs.formula(~b+NULL), structure(alist(b, NULL), sign=c(1,1), env=rep(list(globalenv()), 2), class="term_list"))) stopifnot(identical(list_rhs.formula(~-b+NULL), structure(alist(b, NULL), sign=c(-1,1), env=rep(list(globalenv()), 2), class="term_list"))) stopifnot(identical(list_rhs.formula(~+b-NULL), structure(alist(b, NULL), sign=c(1,-1), env=rep(list(globalenv()), 2), class="term_list"))) stopifnot(identical(list_rhs.formula(~+b-(NULL+c)), structure(alist(b, NULL, c), sign=c(1,-1,-1), env=rep(list(globalenv()), 3), class="term_list"))) ## 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/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/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/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/DESCRIPTION0000644000176200001440000000241214737434742014747 0ustar liggesusersPackage: statnet.common Version: 4.11.0 Date: 2024-12-29 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"))) Description: Non-statistical utilities used by the software developed by the Statnet Project. They may also be of use to others. Depends: R (>= 3.5) 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, rlang (>= 1.1.1), MASS NeedsCompilation: yes Packaged: 2024-12-29 04:34:57 UTC; pavel Author: Pavel N. Krivitsky [aut, cre] (, University of New South Wales), Skye Bender-deMoll [ctb], Chad Klumb [ctb] (University of Washington) Maintainer: Pavel N. Krivitsky Repository: CRAN Date/Publication: 2025-01-08 08:40:02 UTC