| # File src/library/utils/R/indices.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2017 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| packageDescription <- |
| function(pkg, lib.loc = NULL, fields = NULL, drop = TRUE, encoding = "") |
| { |
| retval <- list() |
| if(!is.null(fields)){ |
| fields <- as.character(fields) |
| retval[fields] <- NA |
| } |
| |
| ## If the NULL default for lib.loc is used, |
| ## the loaded packages/namespaces are searched before the libraries. |
| pkgpath <- |
| if(is.null(lib.loc)) { |
| if(pkg == "base") |
| file.path(.Library, "base") |
| else if(isNamespaceLoaded(pkg)) |
| getNamespaceInfo(pkg, "path") |
| else if((envname <- paste0("package:", pkg)) %in% search()) { |
| attr(as.environment(envname), "path") |
| ## could be NULL if a perverse user has been naming |
| ## environments to look like packages. |
| } |
| } |
| if(is.null(pkgpath)) pkgpath <- "" |
| |
| if(pkgpath == "") { |
| libs <- if(is.null(lib.loc)) .libPaths() else lib.loc |
| for(lib in libs) |
| if(file.access(file.path(lib, pkg), 5) == 0L) { |
| pkgpath <- file.path(lib, pkg) |
| break |
| } |
| } |
| |
| if(pkgpath == "") { |
| warning(gettextf("no package '%s' was found", pkg), domain = NA) |
| return(NA) |
| } |
| |
| ## New in 2.7.0: look for installed metadata first. |
| ## We always need to be able to drop back to the file as this |
| ## is used during package installation. |
| |
| if(file.exists(file <- file.path(pkgpath, "Meta", "package.rds"))) { |
| desc <- readRDS(file)$DESCRIPTION |
| if(length(desc) < 1) |
| stop(gettextf("metadata of package '%s' is corrupt", pkg), |
| domain = NA) |
| desc <- as.list(desc) |
| } else if(file.exists(file <- file.path(pkgpath,"DESCRIPTION"))) { |
| dcf <- read.dcf(file=file) |
| if(NROW(dcf) < 1L) |
| stop(gettextf("DESCRIPTION file of package '%s' is corrupt", pkg), |
| domain = NA) |
| desc <- as.list(dcf[1,]) |
| } else file <- "" |
| |
| if(nzchar(file)) { |
| ## read the Encoding field if any |
| enc <- desc[["Encoding"]] |
| if(!is.null(enc) && !is.na(encoding)) { |
| ## Determine encoding and re-encode if necessary and possible. |
| if (missing(encoding) && Sys.getlocale("LC_CTYPE") == "C") |
| encoding <- "ASCII//TRANSLIT" |
| if(encoding != enc) { # try to translate from 'enc' to 'encoding' -------- |
| ## might have an invalid encoding ... |
| newdesc <- try(lapply(desc, iconv, from = enc, to = encoding)) |
| dOk <- function(nd) !inherits(nd, "error") && !anyNA(nd) |
| ok <- dOk(newdesc) |
| if(!ok) # try again |
| ok <- dOk(newdesc <- try(lapply(desc, iconv, from = enc, |
| to = paste0(encoding,"//TRANSLIT")))) |
| if(!ok) # try again |
| ok <- dOk(newdesc <- try(lapply(desc, iconv, from = enc, |
| to = "ASCII//TRANSLIT", sub = "?"))) |
| if(ok) |
| desc <- newdesc |
| else |
| warning("'DESCRIPTION' file has an 'Encoding' field and re-encoding is not possible", call. = FALSE) |
| } |
| } |
| if(!is.null(fields)){ |
| ok <- names(desc) %in% fields |
| retval[names(desc)[ok]] <- desc[ok] |
| } |
| else |
| retval[names(desc)] <- desc |
| } |
| |
| if((file == "") || (length(retval) == 0)){ |
| warning(gettextf("DESCRIPTION file of package '%s' is missing or broken", pkg), domain = NA) |
| return(NA) |
| } |
| |
| if(drop & length(fields) == 1L) |
| return(retval[[1L]]) |
| |
| class(retval) <- "packageDescription" |
| if(!is.null(fields)) attr(retval, "fields") <- fields |
| attr(retval, "file") <- file |
| retval |
| } |
| |
| |
| print.packageDescription <- |
| function(x, abbrCollate = 0.8 * getOption("width"), ...) |
| { |
| xx <- x |
| xx[] <- lapply(xx, function(x) if(is.na(x)) "NA" else x) |
| if(abbrCollate > 0 && any(names(xx) == "Collate")) { |
| ## trim a long "Collate" field -- respecting word boundaries |
| wrds <- strsplit(xx$Collate,"[ \n]")[[1L]] |
| k <- which.max(cumsum(nchar(wrds)) > abbrCollate) - 1L |
| xx$Collate <- paste(c(wrds[seq_len(k)], "....."), collapse=" ") |
| } |
| write.dcf(as.data.frame.list(xx, optional = TRUE)) |
| cat("\n-- File:", attr(x, "file"), "\n") |
| if(!is.null(attr(x, "fields"))){ |
| cat("-- Fields read: ") |
| cat(attr(x, "fields"), sep = ", ") |
| cat("\n") |
| } |
| invisible(x) |
| } |
| |
| # Simple convenience functions |
| |
| maintainer <- function(pkg) |
| { |
| force(pkg) |
| desc <- packageDescription(pkg) |
| if(is.list(desc)) gsub("\n", " ", desc$Maintainer, fixed = TRUE) |
| else NA_character_ |
| } |
| |
| packageVersion <- function(pkg, lib.loc = NULL) |
| { |
| res <- suppressWarnings(packageDescription(pkg, lib.loc=lib.loc, |
| fields = "Version")) |
| if (!is.na(res)) package_version(res) else |
| stop(packageNotFoundError(pkg, lib.loc, sys.call())) |
| } |
| |
| ##' Auxiliary: generalize extraction from "Built" |
| asDateBuilt <- function(built) { |
| as.Date(strsplit(built, split="; ", fixed=TRUE)[[1L]][[3L]], |
| format = "%Y-%m-%d") |
| } |
| |
| packageDate <- function(pkg, lib.loc = NULL, |
| date.fields = c("Date", "Packaged", "Date/Publication", "Built"), |
| tryFormats = c("%Y-%m-%d", "%Y/%m/%d", "%D", "%m/%d/%y"), |
| desc = packageDescription(pkg, lib.loc=lib.loc, fields=date.fields)) |
| { |
| useDesc <- is.list(desc) && length(names(desc)) >= 1 |
| for (fld in date.fields) { |
| res <- if(useDesc) { |
| r <- desc[[fld]] |
| if(is.null(r)) NA_character_ else r |
| } else |
| packageDescription(pkg, lib.loc=lib.loc, fields = fld) |
| res <- if(fld == "Built" && !is.na(res)) |
| tryCatch(asDateBuilt(res), |
| error = function(e) { |
| warning("Invalid \"Built\": ", conditionMessage(e)) |
| NA_character_ |
| }) |
| else as.Date(res, tryFormats=tryFormats, |
| optional = TRUE)# NA instead of errror |
| if (!is.na(res)) |
| break |
| } |
| if(is.na(res)) res else structure(res, field = fld) # NA or 'Date' object |
| } |
| |
| |
| ## used with firstOnly = TRUE for example() |
| ## used with firstOnly = FALSE in help() |
| index.search <- function(topic, paths, firstOnly = FALSE) |
| { |
| res <- character() |
| for (p in paths) { |
| if(file.exists(f <- file.path(p, "help", "aliases.rds"))) |
| al <- readRDS(f) |
| else if(file.exists(f <- file.path(p, "help", "AnIndex"))) { |
| ## aliases.rds was introduced before 2.10.0, as can phase this out |
| foo <- scan(f, what = list(a="", b=""), sep = "\t", quote = "", |
| na.strings = "", quiet = TRUE) |
| al <- structure(foo$b, names = foo$a) |
| } else next |
| f <- al[topic] |
| if(is.na(f)) next |
| res <- c(res, file.path(p, "help", f)) |
| if(firstOnly) break |
| } |
| res |
| } |
| |
| print.packageIQR <- function(x, ...) |
| { |
| db <- x$results |
| ## Split according to Package. |
| out <- if(nrow(db) > 0L) |
| lapply(split(seq_len(nrow(db)), db[, "Package"]), |
| function(ind) db[ind, c("Item", "Title"), drop = FALSE]) |
| outFile <- tempfile("RpackageIQR") |
| outConn <- file(outFile, open = "w") |
| first <- TRUE |
| for(pkg in names(out)) { |
| writeLines(paste0(ifelse(first, "", "\n"), x$title, |
| " in package ", sQuote(pkg), ":\n"), |
| outConn) |
| writeLines(formatDL(out[[pkg]][, "Item"], |
| out[[pkg]][, "Title"]), |
| outConn) |
| first <- FALSE |
| } |
| if(first) { |
| close(outConn) |
| unlink(outFile) |
| writeLines(paste("no", tolower(x$title), "found")) |
| if(!is.null(x$footer)) |
| writeLines(c("", x$footer)) |
| } |
| else { |
| if(!is.null(x$footer)) |
| writeLines(c("\n", x$footer), outConn) |
| close(outConn) |
| file.show(outFile, delete.file = TRUE, |
| title = paste("R", tolower(x$title))) |
| } |
| invisible(x) |
| } |
