blob: 8dfa486e16b9d4e3a44d4d64bb52ce89ac6829bc [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
#=============================================================================#
## 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")
}