blob: c7b3a5a8d2150dbb7103c3e568da6344da9956e5 [file] [log] [blame]
#=============================================================================#
# Copyright (c) 2009, 2021 Stephan Wahlbrink and others.
#
# This program and the accompanying materials are made available under the
# terms of the Eclipse Public License 2.0 which is available at
# https://www.eclipse.org/legal/epl-2.0, or the Apache License, Version 2.0
# which is available at https://www.apache.org/licenses/LICENSE-2.0.
#
# SPDX-License-Identifier: EPL-2.0 OR Apache-2.0
#
# Contributors:
# Stephan Wahlbrink <sw@wahlbrink.eu> - initial API and implementation
#=============================================================================#
## Client Utils
#' Environment for temporary R objects
.rj.tmp <- new.env()
#' Returns the next available id (a element name with the specified prefix)
#'
#' @param prefix prefix of the element name, usually a key for a element type
#' @param envir optional environment, default is \code{.rj.tmp}
#' @return the id
#' @returnType char
tmp.createItem <- function(prefix, envir= .rj.tmp) {
i <- 1L;
repeat {
name <- paste0(prefix, i, ".");
if (!exists(name, envir= envir, inherits= FALSE)) {
assign(name, NULL, envir= envir);
return(name);
}
i <- i + 1L;
}
}
tmp.removeItem <- function(id, envir= .rj.tmp) {
names <- ls(envir= envir, pattern= paste0("^\\Q", id, "\\E"));
if (length(names)) {
rm(list= names, envir= envir, inherits= FALSE);
}
return (invisible());
}
tmp.set <- function(name, value, envir= .rj.tmp) {
assign(name, value, envir= envir);
return (invisible());
}
tmp.remove <- function(name, envir= .rj.tmp) {
if (exists(name, envir= envir, inherits= FALSE)) {
rm(list= name, envir= envir, inherits= FALSE);
}
return (invisible());
}
tmp.setReverseIndex <- function(name, index, len= NA, envir= .rj.tmp) {
index= get(index, envir= envir, inherits= FALSE);
if (is.na(len)) {
len <- length(index);
}
index.r <- rep.int(NA_integer_, len);
index.r[index] <- 1L:length(index);
assign(name, index.r, envir= envir);
return (invisible());
}
tmp.setWhichIndex <- function(name, filter, envir= .rj.tmp) {
filter <- get(filter, envir= envir, inherits= FALSE);
filter <- which(filter);
assign(name, filter, envir= envir);
return (invisible());
}
tmp.setFilteredIndex <- function(name, filter, index, envir= .rj.tmp) {
filter <- get(filter, envir= envir, inherits= FALSE);
index <- get(index, envir= envir, inherits= FALSE);
if (length(dim(index)) > 1L) {
idx <- index[,1L];
index <- index[filter[idx],];
}
else {
index <- index[filter[index]];
}
assign(name, index, envir= envir);
return (invisible());
}
tmp.getFilteredCount <- function(index, filter, envir= .rj.tmp) {
filter <- get(filter, envir= envir, inherits= FALSE);
if (missing(index)) {
return (sum(filter));
}
index <- get(index, envir= envir, inherits= FALSE);
if (length(dim(index)) > 1L) {
index <- index[,1L];
}
return (sum(filter[index]));
}
tmp.clear <- function(envir= .rj.tmp) {
toRemove <- ls(envir= envir, all.names= TRUE);
rm(list= toRemove, envir= envir, inherits= FALSE);
}