Nothing
#'
#' utilarg.R
#'
#' Utilities for checking/handling arguments
#'
#' $Revision: 1.11 $ $Date: 2023/03/03 02:02:49 $
#'
"%orifnull%" <- function(a, b) {
if(!is.null(a)) return(a)
# b is evaluated only now
return(b)
}
check.anyvector <- function(v, npoints=NULL, fatal=TRUE, things="data points",
naok=FALSE, warn=FALSE, vname, oneok=FALSE) {
# vector or factor of values for each point/thing
if(missing(vname))
vname <- sQuote(short.deparse(substitute(v)))
whinge <- NULL
nv <- length(v)
if(!is.atomic(v) || !is.null(dim(v))) # vector with attributes
whinge <- paste(vname, "is not a vector or factor")
else if(!(is.null(npoints) || (nv == npoints)) &&
!(oneok && nv == 1))
whinge <- paste("The length of", vname,
paren(paste0("=", nv)),
"should equal the number of", things,
paren(paste0("=", npoints)))
else if(!naok && anyNA(v))
whinge <- paste("Some values of", vname, "are NA or NaN")
#
if(!is.null(whinge)) {
if(fatal) stop(whinge)
if(warn) warning(whinge)
ans <- FALSE
attr(ans, "whinge") <- whinge
return(ans)
}
return(TRUE)
}
check.nvector <- function(v, npoints=NULL, fatal=TRUE, things="data points",
naok=FALSE, warn=FALSE, vname, oneok=FALSE) {
# vector of numeric values for each point/thing
if(missing(vname))
vname <- sQuote(short.deparse(substitute(v)))
whinge <- NULL
nv <- length(v)
if(!is.numeric(v))
whinge <- paste(vname, "is not numeric")
else if(!is.atomic(v) || !is.null(dim(v))) # vector with attributes
whinge <- paste(vname, "is not a vector")
else if(!(is.null(npoints) || (nv == npoints)) &&
!(oneok && nv == 1))
whinge <- paste("The length of", vname,
paren(paste0("=", nv)),
"should equal the number of", things,
paren(paste0("=", npoints)))
else if(!naok && anyNA(v))
whinge <- paste("Some values of", vname, "are NA or NaN")
#
if(!is.null(whinge)) {
if(fatal) stop(whinge)
if(warn) warning(whinge)
ans <- FALSE
attr(ans, "whinge") <- whinge
return(ans)
}
return(TRUE)
}
check.nmatrix <- function(m, npoints=NULL, fatal=TRUE, things="data points",
naok=FALSE, squarematrix=TRUE, matchto="nrow",
warn=FALSE, mname) {
## matrix of values for each thing or each pair of things
if(missing(mname)) mname <- sQuote(short.deparse(substitute(m)))
whinge <- NULL
if(!is.matrix(m))
whinge <- paste(mname, "should be a matrix")
else if(squarematrix && (nrow(m) != ncol(m)))
whinge <- paste(mname, "should be a square matrix")
else if(!naok && anyNA(m))
whinge <- paste("Some values of", mname, "are NA or NaN")
else if(!is.null(npoints)) {
if(matchto=="nrow" && nrow(m) != npoints)
whinge <- paste("Number of rows in", mname,
paren(paste0("=", nrow(m))),
"does not match number of", things,
paren(paste0("=", npoints)))
else if(matchto=="ncol" && ncol(m) != npoints)
whinge <- paste("Number of columns in", mname,
paren(paste0("=", ncol(m))),
"does not match number of", things,
paren(paste0("=", npoints)))
}
##
if(!is.null(whinge)) {
if(fatal) stop(whinge)
if(warn) warning(whinge)
return(FALSE)
}
return(TRUE)
}
check.named.vector <- function(x, nam, context="", namopt=character(0),
onError=c("fatal", "null"), xtitle=NULL) {
onError <- match.arg(onError)
fatal <- (onError == "fatal")
if(is.null(xtitle) && fatal)
xtitle <- short.deparse(substitute(x))
problem <- check.named.thing(x, nam, namopt, sQuote(xtitle),
is.numeric(x), "vector", context,
fatal=fatal)
if(length(problem) > 0)
return(NULL)
opt <- namopt %in% names(x)
return(x[c(nam, namopt[opt])])
}
check.named.list <- function(x, nam, context="", namopt=character(0),
onError=c("fatal", "null"), xtitle=NULL) {
onError <- match.arg(onError)
fatal <- (onError == "fatal")
if(is.null(xtitle) && fatal)
xtitle <- short.deparse(substitute(x))
problem <- check.named.thing(x, nam, namopt, sQuote(xtitle),
is.list(x), "list", context, fatal=fatal)
if(length(problem) > 0)
return(NULL)
opt <- namopt %in% names(x)
return(x[c(nam, namopt[opt])])
}
check.named.thing <- function(x, nam, namopt=character(0), xtitle=NULL,
valid=TRUE, type="object", context="",
fatal=TRUE) {
## Check whether names(x) contains all obligatory names 'nam'
## and possibly some of the optional names 'namopt'.
## Return a character string, length 0 if OK, otherwise contains message
namesx <- names(x)
omitted <- !(nam %in% namesx)
foreign <- !(namesx %in% c(nam, namopt))
if(valid && !any(omitted) && !any(foreign))
return(character(0))
## Some condition violated
## give details
if(is.null(xtitle))
xtitle <- sQuote(short.deparse(substitute(x)))
if(nzchar(context))
xtitle <- paste(context, xtitle)
whinge <- paste(xtitle,
"must be a named", paste(type, ",", sep=""),
"with components", commasep(nam))
if(length(namopt) > 0)
whinge <- paste(whinge, paren(paste("and optionally", commasep(namopt))))
if(any(omitted)) {
grizzle <- paste(ngettext(sum(omitted), "parameter", "parameters"),
commasep(nam[omitted]),
"omitted")
whinge <- paste(whinge, grizzle, sep="; ")
}
if(any(foreign)) {
grizzle <- paste(ngettext(sum(foreign), "component", "components"),
commasep(namesx[foreign]),
"not recognised")
whinge <- paste(whinge, grizzle, sep="; ")
}
if(fatal)
stop(whinge, call.=FALSE)
return(whinge)
}
validposint <- function(n, caller, fatal=TRUE) {
if(length(n) != 1 || n != round(n) || n <=0) {
if(!fatal)
return(FALSE)
prefix <- if(!missing(caller)) paste("In ", caller, ", ", sep="") else NULL
nname <- short.deparse(substitute(n))
stop(paste0(prefix, nname, "should be a single positive integer"),
call.=FALSE)
}
return(TRUE)
}
# errors and checks
forbidNA <- function(x, context="", xname, fatal=TRUE, usergiven=TRUE, warn=TRUE) {
if(!anyNA(x)) return(TRUE)
if(fatal || warn) {
if(missing(xname)) xname <- sQuote(short.deparse(substitute(x)))
if(usergiven) {
## argument came from user
offence <- ngettext(length(x), "be NA", "contain NA values")
whinge <- paste(context, xname, "must not", offence)
} else {
## argument was computed internally
violates <- ngettext(length(x), "is NA", "contains NA values")
whinge <- paste(context, xname, violates)
}
if(fatal) stop(whinge, call.=FALSE) else warning(whinge, call.=FALSE)
}
return(FALSE)
}
check.finite <- function(x, context="", xname, fatal=TRUE, usergiven=TRUE, warn=TRUE) {
offence <- if(anyNA(x)) "na" else if(any(!is.finite(x))) "NaNInf" else NULL
if(is.null(offence)) return(TRUE)
if(fatal || warn) {
if(missing(xname)) xname <- sQuote(short.deparse(substitute(x)))
if(usergiven) {
## argument came from user
violates <- switch(offence,
na = ngettext(length(x),
"must not be NA",
"must not contain NA values"),
NaNInf = ngettext(length(x),
"must be a finite value",
"must contain finite values"))
} else {
## argument was computed internally
violates <- switch(offence,
na = ngettext(length(x),
"is NA",
"contains NA values"),
NaNInf = ngettext(length(x),
"is not finite",
"contains non-finite values"))
}
whinge <- paste(context, xname, violates)
if(fatal) stop(whinge, call.=FALSE) else warning(whinge, call.=FALSE)
}
return(FALSE)
}
check.satisfies <- function(cond, xname, should, context="",
fatal=TRUE, warn=TRUE) {
if(cond) return(TRUE)
if(fatal || warn) {
whinge <- paste(sQuote(xname), should)
if(nzchar(context)) whinge <- paste(context, whinge)
if(fatal) stop(whinge, call.=FALSE) else warning(whinge, call.=FALSE)
}
return(FALSE)
}
check.1.real <- function(x, context="", fatal=TRUE, warn=TRUE) {
if(is.numeric(x) && length(x) == 1)
return(TRUE)
if(fatal || warn) {
xname <- short.deparse(substitute(x))
whinge <- paste(sQuote(xname), "should be a single number")
if(nzchar(context)) whinge <- paste(context, whinge)
if(fatal) stop(whinge, call.=FALSE) else warning(whinge, call.=FALSE)
}
return(FALSE)
}
check.1.integer <- function(x, context="", fatal=TRUE, warn=TRUE) {
if(is.numeric(x) && length(x) == 1 && is.finite(x) && x %% 1 == 0)
return(TRUE)
if(fatal || warn) {
xname <- short.deparse(substitute(x))
whinge <- paste(sQuote(xname), "should be a single finite integer")
if(nzchar(context)) whinge <- paste(context, whinge)
if(fatal) stop(whinge, call.=FALSE) else warning(whinge, call.=FALSE)
}
return(FALSE)
}
check.1.string <- function(x, context="", fatal=TRUE, warn=TRUE) {
if(is.character(x) && length(x) == 1)
return(TRUE)
if(fatal || warn) {
xname <- short.deparse(substitute(x))
whinge <- paste(sQuote(xname), "should be a single character string")
if(nzchar(context)) whinge <- paste(context, whinge)
if(fatal) stop(whinge, call.=FALSE) else warning(whinge, call.=FALSE)
}
return(FALSE)
}
complaining <- function(whinge, fatal=FALSE, value=NULL) {
if(fatal) stop(whinge, call.=FALSE)
warning(whinge, call.=FALSE)
return(value)
}
explain.ifnot <- function(expr, context="") {
ans <- expr
if(!(is.logical(ans) && length(ans) == 1 && ans)) {
ex <- deparse(substitute(expr))
stop(paste(context, "it must be TRUE that", sQuote(ex)), call.=FALSE)
}
}
warn.ignored.args <- function(..., context=NULL) {
if((narg <- length(list(...))) > 0) {
whinge <- paste(narg, "unrecognised",
ngettext(narg, "argument was", "arguments were"),
"ignored")
if(!is.null(context)) whinge <- paste(context, whinge)
warning(context)
}
}
trap.extra.arguments <- function(..., .Context="", .Fatal=FALSE) {
z <- list(...)
if((narg <- length(z)) == 0) return(FALSE)
nama <- names(z)
named <- nzchar(nama)
whinge <- paste(.Context, ":", sep="")
if(any(named)) {
# some arguments are named: ensure all are named
nama <- sQuote(nama)
if(!all(named))
nama[!named] <- paste("[Arg", 1:length(nama), ,"]", sep="")[!named]
whinge <- paste(whinge,
"unrecognised",
ngettext(narg, "argument", "arguments"),
commasep(nama),
ngettext(narg, "was", "were"), "ignored")
} else {
# all arguments unnamed
whinge <- paste(whinge,
narg, "unrecognised",
ngettext(narg, "argument was", "arguments were"),
"ignored")
}
if(.Fatal) stop(whinge, call.=FALSE) else warning(whinge, call.=FALSE)
return(TRUE)
}
## replace recognised keywords by other keywords
mapstrings <- function(x, map=NULL) {
if(is.null(map)) return(x)
x <- as.character(x)
from <- names(map)
map <- as.character(map)
if(sum(nzchar(from)) != length(map))
stop("input names are missing in map", call.=FALSE)
if(any(duplicated(from)))
stop("input names are duplicated in map", call.=FALSE)
i <- match(x, from)
hit <- !is.na(i)
x[hit] <- map[i[hit]]
return(x)
}
there.is.no.try <- function(...) {
#' do, or do not
y <- try(..., silent=TRUE)
if(inherits(y, "try-error")) return(NULL)
return(y)
}
dont.complain.about <- function(...) {
#' prevents code checkers complaining about 'unused variables'
#' Typically needed where the variables in question
#' are referenced in an expression that will be evaluated elsewhere.
return(invisible(NULL))
}
matchNameOrPosition <- function(expected, avail) {
if(length(avail) < length(expected))
stop("Not enough arguments to match", call.=FALSE)
j <- match(expected, avail)
if(!anyNA(j)) return(j)
everything <- seq_along(avail)
for(k in seq_along(expected)) {
if(is.na(j[k]))
j[k] <- min(setdiff(everything, j[-k]))
}
return(j)
}
badprobability <- function(x, NAvalue=NA) {
ifelse(is.na(x), NAvalue, !is.finite(x) | x < 0 | x > 1)
}
# test for equivalence of two functions
samefunction <- function(f, g) {
identical(deparse(f), deparse(g))
}
#' .................. calls and expressions ..................
fakecallstring <- function(fname, parlist) {
cl <- do.call(call, append(list(name = fname), parlist))
return(format(cl))
}
dotexpr.to.call <- function(expr, dot="funX", evaluator="eval.fv") {
# convert an expression into a function call
# replacing "." by the specified variable
stopifnot(is.expression(expr))
aa <- substitute(substitute(ee, list(.=as.name(d))),
list(ee=expr, d=dot))
bb <- eval(parse(text=deparse(aa)))
cc <- as.call(bb)
cc[[1]] <- as.name(evaluator)
return(cc)
}
inject.expr <- function(base, expr) {
## insert an expression inside a call and parse it
txt <- sub(".", as.character(expr), as.character(base), fixed=TRUE)
parse(text=txt)
}
## Match variable names to objects in 'data' list or environment
getdataobjects <- function(nama, envir, datalist=NULL, fatal=FALSE) {
if(is.null(nama)) return(NULL)
stopifnot(is.character(nama))
n <- length(nama)
y <- vector(mode="list", length=n)
names(y) <- nama
if(!is.null(datalist)) {
hit <- nama %in% names(datalist)
if(any(hit))
y[hit] <- as.list(datalist)[nama[hit]]
external <- unlist(lapply(y, is.null))
} else external <- rep(TRUE, n)
y[external] <- mget(nama[external], envir=envir,
ifnotfound=list(NULL), inherits=TRUE)
if(fatal && any(bad <- unlist(lapply(y, is.null)))) {
nbad <- sum(bad)
stop(paste(ngettext(nbad, "Covariate", "Covariates"),
commasep(sQuote(nama[bad])),
ngettext(nbad, "was not found", "were not found")),
call.=FALSE)
}
names(y) <- nama
attr(y, "external") <- external
return(y)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.