R/misc.utilities.R

In statnet.common: Common R Scripts and Utilities Used by the Statnet Project Software

#  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-2023 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)<replace, x, sign(x)*replace)
}

#' A [split()] method for [`array`] and [`matrix`] types on a margin.
#'
#' These methods split an [`array`] and [`matrix`] into a list of
#' arrays or matrices with the same number of dimensions
#' according to the specified margin.
#'
#' @param x A [`matrix`] or an [`array`].
#' @param f,drop See help for [split()]. Note that `drop` here is
#'   *not* for array dimensions: these are always preserved.
#' @param margin Which margin of the array to split along. `NULL`
#'   splits as [`split.default`], dropping dimensions.
#' @param ... Additional arguments to [split()].
#'
#' @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)))
#'
#' @export
split.array <- function(x, f, drop = FALSE, margin = NULL, ...){
  if(is.null(margin)) return(NextMethod("split"))
  d <- dim(x)
  margin <- as.integer(margin)
  if(margin < 1L || margin > 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))))
}