| #=============================================================================# |
| # Copyright (c) 2009, 2018 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 |
| #=============================================================================# |
| |
| |
| ## RJ init |
| |
| .rj.config <- new.env() |
| .rj.config$isDebug <- FALSE |
| |
| #' Initializes the package |
| .onLoad <- function(libname, pkgname) { |
| utilsEnv <- getNamespace("utils") |
| assign("help", envir = .rj.originals, value = get("help", envir = utilsEnv)) |
| assign("help.start", envir = .rj.originals, value = get("help.start", envir = utilsEnv)) |
| |
| return (invisible(TRUE)) |
| } |
| |
| .rj.originals <- new.env() |
| |
| |
| ## Tmp |
| |
| #' 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.createId <- function(prefix, envir = .rj.tmp) { |
| i <- 1L; |
| repeat { |
| name <- paste(prefix, i, sep= "") |
| if (!exists(name, envir = envir, inherits = FALSE)) { |
| assign(name, NULL, envir= envir) |
| return(name); |
| } |
| i <- i + 1L; |
| } |
| } |
| |
| 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.removeAll <- 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.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) |
| toRemove <- toRemove[toRemove != "help"] # TODO Remove in RJ-1.2 |
| rm(list= toRemove, envir= envir) |
| } |
| |
| |
| ## Internal utils |
| |
| .rj.errorHandler <- function(e) { |
| if (.rj.config$isDebug) { |
| print(e) |
| } |
| } |
| |
| patchPackage <- function(name, value, envir, ns = TRUE) { |
| if (exists(name, envir)) { |
| unlockBinding(name, envir) |
| on.exit(lockBinding(name, envir), add= TRUE) |
| assign(name, value, envir) |
| } |
| if (ns && getRversion() < "2.15.0") { |
| envName <- environmentName(envir) |
| if (envName == "base") { |
| ns <- "base" |
| } |
| else if (!is.null(envName) && substring(envName, 1L, 8L) == "package:") { |
| ns <- asNamespace(substring(envName, 9L)) |
| } |
| else { |
| ns <- NULL |
| } |
| if (!is.null(ns)) { |
| assignInNamespace(name, value, ns= ns) |
| } |
| } |
| return (invisible(TRUE)) |
| } |
| |
| resolveVisible <- function(result) { |
| if (result$visible) { |
| return (result$value) |
| } |
| else { |
| return (invisible(result$value)) |
| } |
| } |