THIS IS A TEST INSTANCE ONLY! REPOSITORIES CAN BE DELETED AT ANY TIME!

Browse Source

PERFORMANCE: Using barebone stop_if_not() rather than base::stopifnot() - the latter has some overhead and more so in R (>= 3.5.0)

feature/c
hb 3 years ago
parent
commit
251138d457
  1. 2
      R/get_variable.R
  2. 6
      R/listenv.R
  3. 18
      R/parse_env_subset.R
  4. 16
      R/utils.R

2
R/get_variable.R

@ -37,7 +37,7 @@ get_variable.listenv <- function(x, name, mustExist = FALSE,
## Map multi-dimensional index to scalar index
if (length(name) > 1L) {
stopifnot(is.numeric(name))
stop_if_not(is.numeric(name))
idxs <- name
if (anyNA(idxs)) stop("Unknown index detected")

6
R/listenv.R

@ -183,7 +183,7 @@ mapping <- function(x, ...) {
map <- mapping
`mapping<-` <- function(x, value) {
stopifnot(is.character(value))
stop_if_not(is.character(value))
assign(".listenv.map", value, envir = parent.env(x), inherits = FALSE)
invisible(x)
}
@ -536,7 +536,7 @@ to_index <- function(x, idxs) {
} else if (is.numeric(i)) {
## Exclude elements with negative indices?
if (any(i < 0)) {
stopifnot(is.null(dim(i)))
stop_if_not(is.null(dim(i)))
if (any(i > 0)) {
stop("only 0's may be mixed with negative subscripts")
}
@ -873,7 +873,7 @@ remove_by_index <- function(x, i) {
} else {
idxs_dd <- unique(idxs_dd)
}
stopifnot(is.numeric(idxs_dd))
stop_if_not(is.numeric(idxs_dd))
dim[dd] <- dim[dd] - length(idxs_dd)
dimnames[[dd]] <- dimnames[[dd]][-idxs_dd]
}

18
R/parse_env_subset.R

@ -48,7 +48,7 @@ parse_env_subset <- function(expr, envir = parent.frame(), substitute = TRUE) {
res$subset <- list(expr)
} else {
n <- length(expr)
stopifnot(n >= 2L)
stop_if_not(n >= 2L)
if (n >= 3L) {
## Assignment to environment via $ and [[
@ -146,7 +146,7 @@ parse_env_subset <- function(expr, envir = parent.frame(), substitute = TRUE) {
## Special: listenv:s
envir <- res$envir
stopifnot(is.environment(envir))
stop_if_not(is.environment(envir))
if (inherits(envir, "listenv")) {
names <- names(envir)
@ -182,7 +182,7 @@ parse_env_subset <- function(expr, envir = parent.frame(), substitute = TRUE) {
idx <- 1
for (kk in seq_along(subset)) {
i <- subset[[kk]]
stopifnot(is.numeric(i))
stop_if_not(is.numeric(i))
d <- dim[kk]
if (any(i < 0)) {
if (op == "[[") {
@ -273,12 +273,12 @@ parse_env_subset <- function(expr, envir = parent.frame(), substitute = TRUE) {
}
## Sanity check
stopifnot(is.environment(res$envir))
stopifnot(is.character(res$name))
stopifnot(is.null(res$subset) || is.list(res$subset))
stopifnot(is.null(res$idx) || all(is.numeric(res$idx)))
stopifnot(is.logical(res$exists), !anyNA(res$exists))
stopifnot(length(res$exists) == length(res$idx))
stop_if_not(is.environment(res$envir))
stop_if_not(is.character(res$name))
stop_if_not(is.null(res$subset) || is.list(res$subset))
stop_if_not(is.null(res$idx) || all(is.numeric(res$idx)))
stop_if_not(is.logical(res$exists), !anyNA(res$exists))
stop_if_not(length(res$exists) == length(res$idx))
res
}

16
R/utils.R

@ -43,3 +43,19 @@ stopf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint
warnf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint
warning(sprintf(fmt, ...), call. = call., domain = domain)
}
stop_if_not <- function(...) {
res <- list(...)
n <- length(res)
if (n == 0L) return()
for (ii in 1L:n) {
res_ii <- .subset2(res, ii)
if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) {
mc <- match.call()
call <- deparse(mc[[ii + 1]], width.cutoff = 60L)
if (length(call) > 1L) call <- paste(call[1L], "...")
stop(sQuote(call), " is not TRUE", call. = FALSE, domain = NA)
}
}
}
Loading…
Cancel
Save