| #=============================================================================# |
| # 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 |
| #=============================================================================# |
| |
| |
| ## Internal utilities for R IDE |
| |
| #' Estimates a value for the parameter max.level of \code{str} |
| #' for the given R element. |
| #' |
| #' @param x the R element to show |
| #' @param max.elements maximum elements to show |
| #' @param max.levels maximum levels to show |
| #' @returnType integer |
| #' @return a value for max.level |
| #' @export |
| estimateStrDepth <- function(x, max.elements= 2000L, max.levels= 10L) { |
| deeplength <- function(x, level= 0L) { |
| if (isS4(x)) { |
| xslots <- slotNames(class(x)) |
| xlen <- length(xslots) |
| if (level == 0L || xlen == 0L) { |
| return (xlen) |
| } |
| else { |
| s <- 0L |
| for (xslot in xslots) { |
| s <- s + deeplength(slot(x, xslot), level= level-1L) |
| } |
| return (s) |
| } |
| } |
| if (is.list(x)) { |
| xlen <- length(x) |
| if (level == 0L || xlen == 0L || is.data.frame(x)) { |
| return (xlen) |
| } |
| else { |
| return (sum(sapply(x, deeplength, level= level-1L, USE.NAMES= FALSE))) |
| } |
| } |
| return (0L) |
| } |
| |
| level <- -1L |
| s <- 0L |
| while (level < max.levels && s < max.elements) { |
| level <- level + 1L |
| s.level <- deeplength(x, level) |
| if (s.level == 0L) { |
| return (NA) |
| } |
| s <- s + s.level |
| } |
| return (level) |
| } |
| |
| #' Captures output of \code{str} for the given R element. |
| #' The output is limited to the specified number of R elements. |
| #' |
| #' @param x the R element to show |
| #' @param limit maximum elements to show |
| #' @returnType character |
| #' @return output of \code{str} |
| #' @export |
| .statet.captureStr <- function(x, limit= 2000L) { |
| savedOptions <- options(width= 10000L) |
| on.exit(options(savedOptions)) |
| levels <- estimateStrDepth(x, max.elements= limit) |
| if (!is.na(levels) && levels <= 1L && getRversion() >= "2.11.0") { |
| output <- capture.output(str(x, max.level= 1L, list.len= limit - 1L)) |
| } |
| else { |
| output <- capture.output(str(x, max.level= levels)) |
| } |
| return (output) |
| } |
| |
| |
| .statet.prepareSrcfile <- function(filename, path) { |
| map <- .rj.tmp$statet.SrcfileMap |
| if (is.null(map)) { |
| map <- list() |
| } |
| map[[filename]] <- NULL |
| map[[filename]] <- path |
| if (length(map) > 20) { |
| map[[1]] <- NULL |
| } |
| .rj.tmp$statet.SrcfileMap <- map |
| return (invisible(NULL)) |
| } |
| |
| .statet.extSrcfile <- function(srcfile) { |
| map <- .rj.tmp$statet.SrcfileMap |
| path <- NULL |
| if (is.null(map) || is.null(srcfile$filename)) { |
| return (srcfile) |
| } |
| idx <- which(names(map) == srcfile$filename) |
| if (length(idx) != 1) { |
| return (srcfile) |
| } |
| path <- map[[idx]] |
| |
| if (idx <= 10) { |
| map[[idx]] <- NULL |
| map[[srcfile$filename]] <- path |
| .rj.tmp$statet.SrcfileMap <- map |
| } |
| |
| srcfile$statet.Path <- path |
| return (srcfile) |
| } |
| |
| .addElementIds <- function(expr, elementIds) { |
| names <- names(elementIds) |
| for (i in seq_along(names)) { |
| if (!is.na(names[i])) { |
| path <- elementIds[[i]] |
| tryCatch(attr(expr[[path]], "statet.ElementId") <- names[i], |
| error= .rj.errorHandler ) |
| } |
| } |
| return (expr) |
| } |
| |
| .statet.prepareCommand <- function(lines, filename= "<text>", |
| srcfileAttributes, elementIds) { |
| # create srcfile object |
| srcfile <- srcfilecopy(filename, lines) |
| if (!missing(srcfileAttributes)) { |
| names <- names(srcfileAttributes) |
| for (i in seq_along(names)) { |
| if (!is.na(names[i])) { |
| assign(names[i], srcfileAttributes[[i]], envir= srcfile) |
| } |
| } |
| } |
| |
| # parse command |
| expr <- parse(text= lines, srcfile= srcfile, encoding= "UTF-8") |
| |
| # attach element ids |
| if (!missing(elementIds)) { |
| expr <- .addElementIds(expr, elementIds) |
| } |
| |
| # finish |
| .rj.tmp$statet.CommandExpr <- expr |
| invisible(expr) |
| } |
| |
| .statet.evalCommand <- function() { |
| expr <- .rj.tmp$statet.CommandExpr |
| if (is.null(expr)) { |
| stop("Commands not available.") |
| } |
| srcrefs <- attr(expr, "srcref", exact= TRUE) |
| exi <- call("{", expr[[1]]) |
| if (1 <= length(srcrefs)) { |
| attr(exi, "srcref") <- list(NULL, srcrefs[[1]]) |
| } |
| eval(exi, parent.frame()) |
| } |
| |
| .statet.prepareSource <- function(info) { |
| assign("statet.NextSourceInfo", info, envir= .rj.tmp) |
| } |
| |
| .statet.extSource <- function(expr) { |
| info <- .rj.tmp$statet.NextSourceInfo |
| if (is.null(info)) { |
| return (expr) |
| } |
| on.exit(rm("statet.NextSourceInfo", envir= .rj.tmp)) |
| if (is.null(expr)) { |
| return (expr) |
| } |
| srcfile <- attr(expr, "srcfile", exact= TRUE) |
| if (is.null(srcfile) |
| || is.null(srcfile$statet.Path) || is.null(srcfile$timestamp) |
| || srcfile$statet.Path != info$path |
| || !equalsTimestamp(unclass(srcfile$timestamp), info$timestamp / 1000) |
| || length(expr) != info$exprsLength ) { |
| return (expr) |
| } |
| expr <- .addElementIds(expr, info$elementIds) |
| return (expr) |
| } |
| |
| |
| .searchExpr <- function(expr, cond, max.depth= 5, depth= 1) { |
| if (expr[[1]] == "{") { |
| for (i in seq_along(expr)) { |
| if (cond(expr[[i]])) { |
| return (i); |
| } |
| } |
| } |
| for (i in seq_along(expr)) { |
| if (depth < max.depth && length(expr[[i]]) > 1) { |
| idx <- .searchExpr(expr= expr[[i]], cond= cond, |
| max.depth= max.depth, depth= depth + 1) |
| if (!is.null(idx)) { |
| return (c(i, idx)) |
| } |
| } |
| } |
| return (NULL) |
| } |
| |
| |
| #### R env / R lib path (R pkg manager) |
| |
| renv.checkLibs <- function() { |
| libs <- .libPaths() |
| result <- file.info(libs)$mtime |
| names(result) <- libs |
| |
| result |
| } |
| |
| renv.getBioCVersion <- function() { |
| v <- tools:::.BioC_version_associated_with_R_version |
| if (is.function(v)) { |
| v <- v() |
| } |
| return (v) |
| } |
| |
| renv.getAvailPkgs <- function(repo) { |
| fields= c('Package', 'Version', 'Priority', 'License', |
| 'Depends', 'Imports', 'LinkingTo', 'Suggests', 'Enhances') |
| result <- available.packages(contriburl= contrib.url(repo), fields= fields, |
| filter= c('R_version', 'OS_type', 'subarch') ) |
| result[, fields, drop= FALSE] |
| } |
| |
| renv.getInstPkgs <- function(lib) { |
| names <- list.files(lib) |
| fields <- c('Package', 'Version', 'Title', 'Built') |
| result <- matrix(NA_character_, nrow= length(names), ncol= length(fields)) |
| num <- 0L |
| for (name in names) { |
| pkgpath <- file.path(lib, name) |
| if (file.access(pkgpath, 5L)) { |
| next |
| } |
| if (file.exists(file <- file.path(pkgpath, 'Meta', 'package.rds'))) { |
| md <- try(readRDS(file)) |
| if (inherits(md, 'try-error')) { |
| next |
| } |
| descr <- md$DESCRIPTION[fields] |
| if (is.null(descr)) { |
| next |
| } |
| enc <- md$DESCRIPTION['Encoding'] |
| if (!is.na(enc)) { |
| txt <- try(iconv(descr[3L], from= enc, to= "UTF-8")) |
| if (!inherits(txt, "try-error")) { |
| descr[3L] <- txt |
| } |
| } |
| descr[1L] <- name |
| result[num <- num + 1, ] <- descr |
| } |
| } |
| result[seq.int(from= 1L, length.out= num), , drop= FALSE] |
| } |
| |
| renv.getInstPkgDetail <- function(lib, name) { |
| fields <- c('Priority', 'License', |
| 'Depends', 'Imports', 'LinkingTo', 'Suggests', 'Enhances' ) |
| file <- file.path(lib, name, 'Meta', 'package.rds') |
| md <- readRDS(file) |
| md$DESCRIPTION[fields] |
| } |
| |
| renv.isValidLibLocation <- function(path) { |
| # path <- normalizePath(path, winslash= "/") |
| current <- path |
| repeat { |
| if (file.access(current, 0L) == 0L) { # exists |
| result <- file.access(current, 3L) # writable |
| names(result) <- path |
| return (result) |
| } |
| parent <- dirname(current) |
| if (nchar(parent) <= 1L || parent == current) { |
| return (-1L) |
| } |
| current <- parent |
| } |
| } |
| |
| |
| #### R help |
| |
| #' Returns the package description for the specified package |
| #' |
| #' @param lib the library location |
| #' @param name the package name |
| rhelp.loadPkgDescr <- function(lib, name) { |
| fields <- c('Version', 'Title', 'Description', 'Author', 'Maintainer', 'URL', 'Built') |
| file <- file.path(lib, name, 'Meta', 'package.rds') |
| md <- readRDS(file) |
| descr <- md$DESCRIPTION[fields] |
| if (is.null(descr)) { |
| return (NULL) |
| } |
| enc <- md$DESCRIPTION['Encoding'] |
| if (!is.na(enc)) { |
| txt <- try(iconv(descr[2L:5L], from= enc, to= "UTF-8")) |
| if (!inherits(txt, "try-error")) { |
| descr[2L:5L] <- txt |
| } |
| } |
| return (descr) |
| } |
| |
| #' Returns the help files for the specified package |
| #' |
| #' @param lib the library location |
| #' @param name the package name |
| rhelp.loadPkgRd <- function(lib, name) { |
| error("Operation not supported") |
| } |
| |
