core/org.eclipse.statet.rj.server.rpkg/pkg/R/utils.R

 #=============================================================================#
 # 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);
}