[Sciviews-commits] r297 - in pkg/svMisc: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Sep 7 11:26:10 CEST 2010
Author: phgrosjean
Date: 2010-09-07 11:26:09 +0200 (Tue, 07 Sep 2010)
New Revision: 297
Added:
pkg/svMisc/man/getEnvironment-deprecated.Rd
Removed:
pkg/svMisc/man/getEnvironment.Rd
Modified:
pkg/svMisc/NEWS
pkg/svMisc/R/Args.R
pkg/svMisc/R/CallTip.R
pkg/svMisc/R/Complete.R
pkg/svMisc/R/CompletePlus.R
pkg/svMisc/R/addItems.R
pkg/svMisc/R/def.R
pkg/svMisc/R/descFun.R
pkg/svMisc/R/getEnvironment.R
pkg/svMisc/R/guiCmd.R
pkg/svMisc/R/helpSearchWeb.R
pkg/svMisc/R/listMethods.R
pkg/svMisc/R/listTypes.R
pkg/svMisc/R/objBrowse.R
pkg/svMisc/R/objClear.R
pkg/svMisc/R/objDir.R
pkg/svMisc/R/objInfo.R
pkg/svMisc/R/objList.R
pkg/svMisc/R/objMenu.R
pkg/svMisc/R/objSearch.R
pkg/svMisc/R/progress.R
pkg/svMisc/R/r.R
pkg/svMisc/R/rjson.R
pkg/svMisc/man/Args.Rd
pkg/svMisc/man/Complete.Rd
pkg/svMisc/man/CompletePlus.Rd
pkg/svMisc/man/addItems.Rd
pkg/svMisc/man/def.Rd
pkg/svMisc/man/descFun.Rd
pkg/svMisc/man/guiCmd.Rd
pkg/svMisc/man/helpSearchWeb.Rd
pkg/svMisc/man/listMethods.Rd
pkg/svMisc/man/listTypes.Rd
pkg/svMisc/man/objBrowse.Rd
pkg/svMisc/man/progress.Rd
pkg/svMisc/man/r.Rd
pkg/svMisc/man/rjson.Rd
Log:
Further cleanup of code and man pages in svMisc. Reimplementation of descFun for R >= 2.10.0.
Modified: pkg/svMisc/NEWS
===================================================================
--- pkg/svMisc/NEWS 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/NEWS 2010-09-07 09:26:09 UTC (rev 297)
@@ -15,7 +15,12 @@
* Sys.userdir() did not expanded tilde in recent R versions (corrected).
-*
+* Little change in def() arguments: length.out instead of length to use the same
+ name as correcponding argument in rep(). Coercion to logical is now done using
+ as.logical()... but the result may differ from previous implementations.
+
+* For listTypes(), the convention has changed. Method/type is now separated by
+ an underscore instead as with two dots (like in view_text.default).
== Changes in svMisc 0.9-59
Modified: pkg/svMisc/R/Args.R
===================================================================
--- pkg/svMisc/R/Args.R 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/R/Args.R 2010-09-07 09:26:09 UTC (rev 297)
@@ -1,11 +1,10 @@
-"Args" <-
-function (name, only.args = FALSE)
+Args <- function (name, only.args = FALSE)
{
- #### TODO: handle primitives and S3/S4 methods for generic functions
+ ## TODO: handle primitives and S3/S4 methods for generic functions
ret <- try(res <- eval(parse(text = paste("argsAnywhere(", name, ")",
sep = ""))), silent = TRUE)
if (inherits(ret, "try-error") || is.null(res))
- return("") # Function 'name' not found
+ return("") # Function 'name' not found
res <- deparse(res)
res <- paste(res[-length(res)], collapse = "\n")
if (only.args) {
Modified: pkg/svMisc/R/CallTip.R
===================================================================
--- pkg/svMisc/R/CallTip.R 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/R/CallTip.R 2010-09-07 09:26:09 UTC (rev 297)
@@ -1,25 +1,16 @@
-"CallTip" <-
-function (code, only.args = FALSE, location = FALSE)
+CallTip <- function (code, only.args = FALSE, location = FALSE)
{
- # This is the old treatment!
- # Get a call tip, given a part of the code
- # Extract the last variable name, given it is either at the end,
- # or terminated by '('
- #code <- sub(" *\\($", "", code[1])
- #pos <- regexpr("[a-zA-Z0-9_\\.]+$", code)
- #code <- substring(code, pos)
- # Now, we use a more exhaustive search, using complete
code <- attr(Complete(code, types = NA), "fguess")
if (is.null(code) || !length(code) || code == "")
return("")
- # Get the corresponding Call Tip
- ctip <- "" # Default value, in case the function does not exist
+ ## Get the corresponding calltip
+ ctip <- "" # Default value, in case the function does not exist
if (code != "") ctip <- Args(code, only.args = only.args)
if (is.null(ctip)) return("")
- # Do we need to append an indication of where this function is located?
+ ## Do we need to append an indication of where this function is located?
if (location == TRUE) {
- ### TODO: use getAnywhere() instead
+ ## TODO: use getAnywhere() instead
pkg <- sub("^package:", "", find(code, mode = "function"))
if (length(pkg) > 0 && pkg != ".GlobalEnv")
ctip <- paste(ctip, " [", pkg, "]", sep = "")
Modified: pkg/svMisc/R/Complete.R
===================================================================
--- pkg/svMisc/R/Complete.R 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/R/Complete.R 2010-09-07 09:26:09 UTC (rev 297)
@@ -1,10 +1,9 @@
-"Complete" <-
-function (code, print = FALSE, types = c("default", "scintilla"),
+Complete <- function (code, print = FALSE, types = c("default", "scintilla"),
addition = FALSE, skip.used.args = TRUE, sep = "\n", type.sep = "?") {
ComplEnv <- utils:::.CompletionEnv
finalize <- function (completions) {
- # Sort completion items alphabetically
+ ## Sort completion items alphabetically
completions <- sort(completions)
if (isTRUE(add.types)) {
tl <- numeric(length(completions))
@@ -47,32 +46,32 @@
}
if (is.na(types[1L])) add.types <- FALSE else add.types <- TRUE
- # Default values for completion context
+ ## Default values for completion context
token <- ""
triggerPos <- 0L
fguess <- ""
funargs <- list()
isFirstArg <- FALSE
- # Is there some code provided?
+ ## Is there some code provided?
code <- paste(as.character(code), collapse = "\n")
if (is.null(code) || !length(code) || code == "") {
- # Just return a list of objects in .GlobalEnv
+ ## Just return a list of objects in .GlobalEnv
return(finalize(ls(envir = .GlobalEnv)))
}
- # If code ends with a single [, then nothing to return
+ ## If code ends with a single [, then nothing to return
if (regexpr("[^[][[]$", code) > 0)
return(invisible(""))
- # If code ends with a double [[, then, substitute $ instead and indicate
- # to quote returned arguments (otherwise, [[ is not correctly handled)!
+ ## If code ends with a double [[, then, substitute $ instead and indicate
+ ## to quote returned arguments (otherwise, [[ is not correctly handled)!
if (regexpr("[[][[]$", code) > 0) {
code <- sub("[[][[]$", "$", code)
dblBrackets <- TRUE
} else dblBrackets <- FALSE
- # Save funarg.suffix and use " = " temporarily
+ ## Save funarg.suffix and use " = " temporarily
opts <- ComplEnv$options
funarg.suffix <- opts$funarg.suffix
on.exit({
@@ -94,28 +93,26 @@
triggerPos <- pos - ComplEnv[["start"]]
token <- ComplEnv[["token"]]
- # If token is empty, we complete by using objects in .GlobalEnv by default
+ ## If token is empty, we complete by using objects in .GlobalEnv by default
if (!length(completions) && token == "") {
triggerPos <- nchar(code, type = "chars")
return(finalize(ls(envir = .GlobalEnv)))
}
- # From CompletePlus() for a similar behaviour
- # For tokens like "a[m", the actual token should be "m"
- # completions are modified accordingly
+ ## From CompletePlus() for a similar behaviour
+ ## For tokens like "a[m", the actual token should be "m"
+ ## completions are modified accordingly
rx <- regexpr("[[]+", ComplEnv$token)
if (rx > 0) {
- # then we need to trim out whatever is before the [ in the completion
- # and the token
+ ## Then we need to trim out whatever is before the [ in the completion
+ ## and the token
start <- rx + attr(rx, "match.length")
ComplEnv$token <- substring(ComplEnv$token, start)
completions <- substring(completions, start)
}
if (!length(completions)) return(invisible(""))
- # remove weird object names (useful when the token starts with ".")
- # line below causes error on ubuntu: could not find function "grepl". older R version?
- #completions <- completions[!grepl("^[.]__[[:alpha:]]__", completions)]
+ ## Remove weird object names (useful when the token starts with ".")
i <- grep("^[.]__[[:alpha:]]__", completions)
if (length(i) > 0)
completions <- completions[-i]
@@ -136,7 +133,7 @@
completions <- substring(completions, triggerPos + 1)
if (dblBrackets) {
- # Substitute var$name by var[["name"
+ ## Substitute var$name by var[["name"
completions <- sub("[$](.+)$", '[["\\1"', completions)
token <- sub("[$]$", "[[", token)
triggerPos <- triggerPos + 1
@@ -148,25 +145,18 @@
}
.reserved.words <- c("if", "else", "repeat", "while", "function", "for", "in",
- "next", "break", "TRUE", "FALSE", "NULL", "Inf", "NaN",
- "NA", "NA_integer_", "NA_real_", "NA_complex_",
- "NA_character_")
+ "next", "break", "TRUE", "FALSE", "NULL", "Inf", "NaN", "NA", "NA_integer_",
+ "NA_real_", "NA_complex_", "NA_character_")
-.default.completion.types <- list(fun = "function",
- var = "variable",
- env = "environment",
- args = "arg",
- keyword = "keyword")
+.default.completion.types <- list(fun = "function", var = "variable",
+ env = "environment", args = "arg", keyword = "keyword")
-.scintilla.completion.types <- list(fun = "1",
- var = "3",
- env = "8",
- args = "11",
- keyword = "13")
+.scintilla.completion.types <- list(fun = "1", var = "3",
+ env = "8", args = "11", keyword = "13")
-# modified utils:::inFunction()
-# The only difference is that it also gets current arguments list (if applicable).
-# They are assigned to utils:::.CompletionEnv$funargs
+## Modified utils:::inFunction()
+## The only difference is that it also gets current arguments list (if applicable).
+## They are assigned to utils:::.CompletionEnv$funargs
.inFunctionExt <-
function (line = utils:::.CompletionEnv[["linebuffer"]],
cursor = utils:::.CompletionEnv[["start"]])
@@ -193,22 +183,23 @@
1L), 1000000L), fixed = TRUE)) == 0L)) {
return(character(0L))
} else {
-
- # This is the code added to utils:::inFunction()
+ ## This is the code added to utils:::inFunction()
wp2 <- rev(cumsum(temp$c[-(wp[1L]:nrow(temp))]))
suffix <- sub("^\\s+", "", suffix, perl = TRUE)
- # TODO: simplify this:
+ ## TODO: simplify this:
if (length(wp2)) {
- funargs <- strsplit(suffix, "\\s*[\\(\\)][\\s,]*", perl = TRUE)[[1]]
+ funargs <- strsplit(suffix, "\\s*[\\(\\)][\\s,]*",
+ perl = TRUE)[[1]]
funargs <- paste(funargs[wp2 == 0], collapse = ",")
} else {
funargs <- suffix
}
funargs <- strsplit(funargs, "\\s*,\\s*", perl=TRUE)[[1]]
funargs <- unname(sapply(funargs, sub, pattern = "\\s*=.*$",
- replacement = utils:::.CompletionEnv$options$funarg.suffix, perl=TRUE))
+ replacement = utils:::.CompletionEnv$options$funarg.suffix,
+ perl=TRUE))
assign("funargs", funargs, utils:::.CompletionEnv)
- # ... addition ends here
+ ## ... addition ends here
possible <- suppressWarnings(strsplit(prefix, utils:::breakRE,
perl = TRUE))[[1L]]
@@ -224,8 +215,8 @@
}
}
-# modified utils:::.completeToken()
-# main difference is that calls .inFunctionExt instead of utils:::inFunction.
+## Modified utils:::.completeToken()
+## Main difference is that calls .inFunctionExt instead of utils:::inFunction.
.completeTokenExt <- function () {
ComplEnv <- utils:::.CompletionEnv
text <- ComplEnv$token
@@ -248,10 +239,10 @@
}
} else {
- #Completion does not a good job when there are quoted strings,
- # e.g for linebuffer = "Complete2("anova(", )" would give arguments for anova
- # rather than for Complete2.
- # Code below replaces quoted strings with sequences of "_" of the same length.
+ ## Completion does not a good job when there are quoted strings,
+ ## e.g for linebuffer = "Complete2("anova(", )" would give arguments for
+ ## anova rather than for Complete2.
+ # Replace quoted strings with sequences of "_" of the same length.
# This is a temporary solution though, there should be a better way...
mt <- gregexpr('(?<!\\\\)(["\']).*?((?<!\\\\)\\1|$)', linebuffer,
perl = TRUE)[[1]]
@@ -261,13 +252,13 @@
for (i in seq_along(mt))
substr(linebuffer, mt[i], mt[i] + ml[i]) <- y[i]
}
- # ... additions until here
+ ## ... additions until here
utils:::.setFileComp(FALSE)
utils:::setIsFirstArg(FALSE)
guessedFunction <- ""
if (ComplEnv$settings[["args"]]) {
- # Call of .inFunctionExt() instead of utils:::inFunction()
+ ## Call of .inFunctionExt() instead of utils:::inFunction()
guessedFunction <- .inFunctionExt(linebuffer, st)
} else {
guessedFunction <- ""
Modified: pkg/svMisc/R/CompletePlus.R
===================================================================
--- pkg/svMisc/R/CompletePlus.R 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/R/CompletePlus.R 2010-09-07 09:26:09 UTC (rev 297)
@@ -1,10 +1,7 @@
-"CompletePlus" <-
-function (linebuffer, cursorPosition = nchar(linebuffer), minlength = 2,
- simplify = FALSE, types = c("arguments", "functions", "packages"))
+CompletePlus <- function (linebuffer, cursorPosition = nchar(linebuffer),
+minlength = 2, simplify = FALSE, types = c("arguments", "functions", "packages"))
{
- # PhG: find.multiple() renamed .find.multiple() and moved to svMisc-internal
-
- # call the rcompgen API to get completions
+ ## Call the rcompgen API to get completions
if (nchar(linebuffer, type = "chars") < minlength) return(invisible(NULL))
utils:::.assignLinebuffer(linebuffer)
utils:::.assignEnd(cursorPosition)
@@ -14,23 +11,23 @@
comps <- utils:::.retrieveCompletions()
if (!length(comps)) return(invisible(NULL))
- # For tokens like "a[m", the actual token should be "m"
- # completions are modified accordingly
+ ## For tokens like "a[m", the actual token should be "m"
+ ## completions are modified accordingly
rx <- regexpr("[[]+", token)
if (rx > 0) {
- # then we need to trim out whatever is before the [ in the completion
- # and the token
+ ## Then we need to trim out whatever is before the [ in the completion
+ ## and the token
start <- rx + attr(rx, "match.length")
token <- substring(token, start)
comps <- substring(comps, start)
}
- # remove weird object names (useful when the token starts with ".")
+ ## Remove weird object names (useful when the token starts with ".")
comps <- comps[ !grepl( "^[.]__[[:alpha:]]__", comps ) ]
if (!length(comps))
return(invisible(NULL))
- # restrict the completion for which information is gathered (speed things up)
+ ## Restrict completion for which information is gathered (speed things up)
if (!"arguments" %in% types)
comps <- comps[regexpr("=$", comps) < 0]
if (!length(comps))
@@ -46,16 +43,16 @@
if (!length(comps))
return(invisible(NULL))
- # build the output structure
+ ## Build the output structure
out <- matrix("", nrow = length(comps), ncol = 3)
out[, 1] <- comps
- # deal with packages (completions ending with ::)
+ ## Deal with packages (completions ending with ::)
if (length(test.pack <- grep("::", comps)))
out[test.pack, 3] <- sapply(sub("::", "", comps[test.pack]),
packageDescription, fields = "Description")
- # deal with argument completions (ending with =)
+ ## Deal with argument completions (ending with =)
if (length(test.arg <- grep("=", comps))) {
arg <- sub("=$", "", comps[test.arg])
fguess <- utils:::.CompletionEnv[["fguess"]]
@@ -68,38 +65,38 @@
}
}
- # deal with completions with "$"
+ ## Deal with completions with "$"
if (length(test.dollar <- grep("\\$", comps)) ) {
elements <- comps[test.dollar]
object <- gsub("\\$.*$", "", comps)[1]
after <- gsub("^.*\\$", "", comps)
pack <- .find.multiple(object)
out[test.dollar, 2] <- pack
- out[test.dollar, 3] <- descData(object, after, package = pack)
+ out[test.dollar, 3] <- .descData(object, after, package = pack)
}
- # deal with completions with "@"
+ ## Deal with completions with "@"
if (length(test.slot <- grep("@", comps))) {
elements <- comps[test.dollar]
object <- gsub("@.*$", "", comps)[1]
slots <- gsub("^.*@", "", comps)
pack <- .find.multiple(object)
out[test.dollar, 2] <- pack
- out[test.dollar, 3] <- descSlots(object, slots, package = pack)
+ out[test.dollar, 3] <- .descSlots(object, slots, package = pack)
}
- # deal with completions with "["
+ ## Deal with completions with "["
if (length(test.square <- grep("\\[", comps))) {
elements <- comps[test.square]
out[test.square, 2] <- ""
- out[test.square, 3] <- descSquare(elements, package = pack)
+ out[test.square, 3] <- .descSquare(elements, package = pack)
}
- ### TODO: do not know what to do with these
+ ## TODO: do not know what to do with these?
test.others <- grep(" ", comps)
- ### TODO: are there other kind of completions I miss here
+ ## TODO: are there other kind of completions I miss here?
- # deal with function completions
+ ## Deal with function completions
test.fun <- setdiff(1:length(comps), c(test.arg, test.pack, test.others,
test.dollar, test.slot, test.square))
if (length(test.fun)) {
@@ -118,7 +115,7 @@
out[, 3] <- gsub("\t", " ", out[, 3])
out[, 3] <- gsub("\n", " ", out[, 3])
- # Make sure that arguments are witten 'arg = ', and not 'arg='
+ ## Make sure that arguments are witten 'arg = ', and not 'arg='
out[, 1] <- sub("=$", " = ", out[, 1])
attr( out, "token" ) <- token
Modified: pkg/svMisc/R/addItems.R
===================================================================
--- pkg/svMisc/R/addItems.R 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/R/addItems.R 2010-09-07 09:26:09 UTC (rev 297)
@@ -1,5 +1,4 @@
-"addItems" <-
-function (x, y, use.names = TRUE, replace = TRUE)
+addItems <- function (x, y, use.names = TRUE, replace = TRUE)
{
if (replace) res <- c(y, x) else res <- c(x, y)
if (use.names) {
@@ -10,19 +9,18 @@
return(res)
}
-"addActions" <-
-function (obj = ".svActions", text = NULL, code = NULL, state = NULL,
- options = NULL, replace = TRUE)
+addActions <- function (obj = ".svActions", text = NULL, code = NULL,
+state = NULL, options = NULL, replace = TRUE)
{
dat <- getTemp(obj, default = list())
if (!inherits(dat, "list"))
stop("'obj' should inherit from 'list'")
- # Make sure we return an svActions object
+ ## Make sure we return an svActions object
class(dat) <- unique(c("svActions", class(dat)))
- # Add new actions characteristics to dat; make sure newdata are correct
- "addData" <- function(x, newdata, replace) {
+ ## Add new actions characteristics to dat; make sure newdata are correct
+ addData <- function(x, newdata, replace) {
newnames <- names(newdata)
if (is.null(newnames))
stop("Data you add in actions must be a named character vector")
@@ -36,41 +34,39 @@
if (!is.null(state)) dat$state <- addData(dat$state, state, replace)
if (!is.null(options)) dat$options <- addData(dat$options, options, replace)
- # Reassign the modified values
+ ## Reassign the modified values
assignTemp(obj, dat)
return(invisible(dat))
}
-"addIcons" <-
-function (obj = ".svIcons", icons, replace = TRUE)
+addIcons <- function (obj = ".svIcons", icons, replace = TRUE)
{
- # get the list of icons
+ ## Get the list of icons
icn <- getTemp(obj, default = character())
if (!inherits(icn, "character"))
stop("'obj' should inherit from 'character'")
- # Check that new icons are correctly formatted
+ ## Check that new icons are correctly formatted
nicons <- names(icons)
if (is.null(nicons))
stop("Icons map you add must be a named character vector")
icons <- as.character(icons)
names(icons) <- nicons
- # Add new icons to it
+ ## Add new icons to it
icn <- addItems(icn, icons, replace = replace)
- # Make sure we return an svIcons object
+ ## Make sure we return an svIcons object
class(icn) <- unique(c("svIcons", class(icn)))
- # Reassign the modified values
+ ## Reassign the modified values
assignTemp(obj, icn)
return(invisible(icn))
}
-"addMethods" <-
-function (methods)
+addMethods <- function (methods)
{
- # get the list of methods
+ ## Get the list of methods
met <- getOption("svGUI.methods")
if (!is.null(met)) methods <- addItems(met, methods, use.names = FALSE)
options(svGUI.methods = sort(methods))
Modified: pkg/svMisc/R/def.R
===================================================================
--- pkg/svMisc/R/def.R 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/R/def.R 2010-09-07 09:26:09 UTC (rev 297)
@@ -1,28 +1,30 @@
-"def" <-
-function (value, default = "", mode = "character", length = NULL)
+def <- function (value, default = "", mode = "character", length.out = NULL)
{
- # Ensure we got a value of a given mode, and if not, use default
- # If length is provided, make sure that the returned vector has that length
- # (if needed, cut or recycle 'value')
+ ## Ensure we got a value of a given mode, and if not, use default
+ ## If length.out is provided, make sure that the returned vector has that length
+ ## (if needed, cut or recycle 'value')
- # If either NULL or NA, or something of length == 0 is in 'value', then,
- # return default
- if (is.null(value) || is.na(value) || length(value) < 1) value <- default
+ ## If either NULL or something of length == 0 is in 'value', then,
+ ## return default
+ if (is.null(value) || length(value) == 0) value <- default
- # Coerce to mode... special treatment for logical!
- res <- switch(mode[1],
- logical = (value == TRUE),
+ ## Coerce to mode...
+ res <- switch(as.character(mode[1]),
+ logical = as.logical(value),
character = as.character(value),
numeric = as.numeric(value),
+ double = as.double(value),
+ integer = as.integer(value),
+ single = as.single(value),
factor = as.factor(value),
complex = as.complex(value),
value) # This is for unrecognized modes!
- # If length is provided, make sure the vector has this length
- if (!is.null(length)) {
- if (!is.numeric(length) || length[1] < 1) length <- 1 else
- length <- round(length[1]) # Make sure 'length' argument is correct
- res <- rep(res, length.out = length)
+ ## If length.out is provided, make sure the vector has this length
+ if (!is.null(length.out)) {
+ if (length(length.out) == 0) length.out <- 1 else
+ length.out <- round(as.numeric(length.out[1]))
+ res <- rep(res, length.out = length.out)
}
return(res)
}
Modified: pkg/svMisc/R/descFun.R
===================================================================
--- pkg/svMisc/R/descFun.R 2010-09-06 16:33:25 UTC (rev 296)
+++ pkg/svMisc/R/descFun.R 2010-09-07 09:26:09 UTC (rev 297)
@@ -1,144 +1,95 @@
-# These are all hidden functions for the moment, except descArgs() and descFun()!
-"descFun" <-
-function (fun, package, lib.loc = NULL)
+descFun <- function (fun, package, lib.loc = NULL)
{
- fun <- as.character(fun)
- if (length(fun) == 0) return("")
- # Get the description associated with this Topic
- AllTopics <- eval(parse(text = paste("library(help =", package, ")")))$info[[2]]
+ if (missing(package)) package <- NULL
+
+ ## Use the new help system if this is R >= 2.10.0
+ if (compareRVersion("2.10.0") >= 0)
+ return(.descFunNew(fun = fun, package = package, lib.loc = lib.loc))
+
+ ## Otherwise, use the old version (that depends on text rendered help files)
+ if (is.null(fun) || length(fun) == 0) return("")
+ fun <- as.character(fun[1])
+ ## Get the description associated with this topic
+ AllTopics <- eval(parse(text = paste("library(help =", package,
+ ")")))$info[[2]]
if (length(AllTopics) == 0) return("")
res <- character()
for (i in 1:length(fun)) {
- # index.search() will not be visible any more and will have different
- # arguments in R 2.11... and it is DEPRECATED in R 2.10
- # => need to use a different code here!!!
- # This is a temporary hack for svMisc to pass R CMD check on these versions
- if (!exists("index.search", mode= "function")) {
+ ## index.search() will not be visible any more and will have different
+ ## arguments in R 2.11... and it is DEPRECATED in R 2.10
+ ## => need to use a different code here!!!
+ ## This is a temporary hack for svMisc to pass R CMD check on these versions
+ if (!exists("index.search", mode= "function"))
index.search <- function (...) return("")
- }
paths <- sapply(.find.package(package, lib.loc, verbose = FALSE),
function(p) index.search(fun[i], p, "AnIndex", type = "help"))
- # Topic is the entry that contains the description
+ ## Topic is the entry that contains the description
Topic <- basename(paths[paths != ""])[1]
- # Get the first line of the description
+ ## Get the first line of the description
FirstLine <- (1:length(AllTopics))[regexpr(paste("^", Topic, " ",
sep = ""), AllTopics) > -1]
- # If not found, try with fun[i]
+ ## If not found, try with fun[i]
if (length(FirstLine) == 0) {
Topic <- fun[i]
FirstLine <- (1:length(AllTopics))[regexpr(paste("^", Topic, " ",
sep = ""), AllTopics) > -1]
}
if (length(FirstLine) == 0) {
- res[i] <- "" # Not found (should never happen?)
+ res[i] <- "" # Not found (should never happen?)
} else {
- # Eliminate everything before this line
+ ## Eliminate everything before this line
Topics <- AllTopics[FirstLine[1]:length(AllTopics)]
- # We may have several lines of description: keep them all
+ ## We may have several lines of description: keep them all
isSpace <- (regexpr("^ ", Topics) == -1)
isDesc <- (cumsum(isSpace) == 1)
Topics[1] <- sub(paste("^", Topic, sep = ""), "", Topics[1])
- # Get the description and return it
+ ## Get the description and return it
res[i] <- paste(sub("^ +", "", Topics[isDesc]), collapse = " ")
}
}
- # Add names to this vector and return it
+ ## Add names to this vector and return it
names(res) <- fun
return(res)
}
-"descData" <- function (data, columns, package = NULL, lib.loc = NULL)
- character(length(columns))
-
-# TODO: this might be possible (but hard, so not now)
-"descSlots" <- function (object, slots, package = NULL, lib.loc = NULL)
- character(length(slots))
-
-"descSquare" <-
-function (completions, package = NULL)
- character(length(completions))
-
-#' is this R >= 2.10.0
-".R_2_10_0" <-
-function ()
+.descFunNew <- function (fun, package, lib.loc = NULL)
{
- v <- R.Version()
- major <- as.numeric(v$major)
- minor <- as.numeric(v$minor)
- return(major > 2 || (major == 2 && minor >= 10.0))
-}
-
-# Version of descArgs for R >= 2.10.0 and its new help system
-# Ultimately the original version should be deleted
-".descArgs_R_2_10_0" <-
-function (fun, args = NULL, package = NULL, lib.loc = NULL)
-{
- if (!.R_2_10_0()) stop("cannot use this implementation, needs R >= 2.10.0")
-
- # We cannot just call help normally because otherwise it thinks
- # we are looking for package "package" so we create a call and eval it
+ ## Get the description of fun using the new (R >= 2.10.0) help system
+ if (is.null(fun) || length(fun) == 0) return("")
+ fun <- as.character(fun[1])
+ ## Get location of the help file
+ ## We cannot just call help normally because otherwise it thinks
+ ## we are looking for package "package" so we create a call and eval it
help.call <- call("help", fun, lib.loc = lib.loc, help_type = "text")
if (!is.null(package)) help.call[["package"]] <- package
file <- eval(help.call)
-
- # This is borrowed from utils::print.help_files_with_topic
- path <- dirname(file)
- dirpath <- dirname(path)
- pkgname <- basename(dirpath)
- RdDB <- file.path(path, pkgname)
-
- if (!file.exists(paste(RdDB, "rdx", sep="."))) {
- return(character(length(args)))
- }
-
- rd <- tools:::fetchRdDB(RdDB, basename(file))
-
- # This is not exported from tools
- RdTags <- function (Rd) {
- res <- sapply(Rd, attr, "Rd_tag")
- if (!length(res)) res <- character(0)
- res
- }
- tags <- gsub("\\", "", RdTags(rd), fixed = TRUE)
-
- if (!any(tags == "arguments")) return(character(length(args)))
-
- arguments <- rd[[which(tags == "arguments")[1]]]
- items <- arguments[RdTags(arguments) == "\\item"]
- descriptions <- do.call(rbind, lapply(items, function (item) {
- names <- try(strsplit(item[[1]][[1]], "\\s*,\\s*", perl = TRUE)[[1]],
- silent = TRUE)
- if (inherits(names, "try-error")) {
- # This happens with the "..." argument
- names <- "..."
- }
- content <- paste(rapply(item[-1], as.character), collapse = "")
- cbind(names, rep.int(content, length(names)))
- }))
-
- if (is.null(args)) {
- structure(descriptions[, 2], names = descriptions[, 1])
- } else {
- sapply(args, function (a) {
- if (a %in% descriptions[, 1]) {
- descriptions[which(descriptions[, 1] == a)[1] , 2]
- } else ""
- })
- }
+ file <- as.character(file)
+ if (length(file) == 0) return("")
+ ## Read the Rd file and get the title section out of it
+ Rdoc <- utils:::.getHelpFile(file[1L])
+ ## Look for the \title tag
+ i <- 0
+ for (i in seq_along(Rdoc))
+ if (attr(Rdoc[[i]], "Rd_tag") == "\\title") break
+ if (i == 0) return("") else {
+ desc <- as.character(Rdoc[[i]][[1]])
+ desc <- sub("^[ \t]+", "", desc)
+ desc <- sub("[ \t]+$", "", desc)
+ return(desc)
+ }
}
-"descArgs" <-
-function (fun, args = NULL, package = NULL, lib.loc = NULL)
+descArgs <- function (fun, args = NULL, package = NULL, lib.loc = NULL)
{
- # Use the new help system if this is R >= 2.10.0
- if (.R_2_10_0()) {
- return(.descArgs_R_2_10_0(fun = fun, args = args, package = package,
+ ## Use the new help system if this is R >= 2.10.0
+ if (compareRVersion("2.10.0") >= 0)
+ return(.descArgsNew(fun = fun, args = args, package = package,
lib.loc = lib.loc))
- }
- # Otherwise, use the old version (that depends on text rendered help files)
- # Start from the text version of the online help instead of the .Rd file
- # The next line is to avoid raising warnings in R CMD check in R >= 2.10
+ ## Otherwise, use the old version (that depends on text rendered help files)
+
+ ## Start from the text version of the online help instead of the .Rd file
+ ## The next line is to avoid raising warnings in R CMD check in R >= 2.10
hlp <- function (...) help(...)
if (is.null(package)) {
File <- as.character(hlp(fun,
@@ -149,65 +100,126 @@
}
if (length(File) == 0) return(character(length(args)))
- # doing the same as help to extract the file if it is in a zip
+ ## Doing the same as help to extract the file if it is in a zip
File <- zip.file.extract(File, "Rhelp.zip")
- # if the file could not be extracted, return empties
- if( !file.exists( File ) ){
+ ## If the file could not be extracted, return empties
+ if( !file.exists(File))
return(rep("", length(args)))
- }
- # guess the encoding (from print.help_files_with_topic)
- first <- readLines( File, n = 1)
+ ## Guess the encoding (from print.help_files_with_topic)
+ first <- readLines(File, n = 1)
enc <- if (length(grep("\\(.*\\)$", first)) > 0) {
sub("[^(]*\\((.*)\\)$", "\\1", first)
} else ""
- if (enc == "utf8")
- enc <- "UTF-8"
+ if (enc == "utf8") enc <- "UTF-8"
if (.Platform$OS.type == "windows" && enc == "" &&
l10n_info()$codepage < 1000)
enc <- "CP1252"
File. <- file(File, encoding = enc, open = "r")
- # Read content of the text file
+ ## Read content of the text file
Data <- scan(File., what = character(), sep = "\n", quiet = TRUE)
close(File.)
- # Get the Arguments: section
+ ## Get the Arguments: section
argsStart <- (1:length(Data))[Data == "_\bA_\br_\bg_\bu_\bm_\be_\bn_\bt_\bs:"]
- if (length(argsStart) == 0) # Not found
+ if (length(argsStart) == 0) # Not found
return(rep("", length(args)))
- # Eliminate everything before this section
+ ## Eliminate everything before this section
Data <- Data[(argsStart[1] + 1):length(Data)]
- # Check where next section starts
+ ## Check where next section starts
nextSection <- suppressWarnings((1:length(Data))[regexpr("^_\\b", Data) > -1])
- if (length(nextSection) > 0) # Cut everything after this section
+ if (length(nextSection) > 0) # Cut everything after this section
Data <- Data[1:(nextSection[1] - 1)]
- # Split description by arguments. Looks like: "^ *argument[, argument]: " + desc
+ ## Split description by arguments, like: "^ *argument[, argument]: " + desc
argsFirstLine <- regexpr("^ *[a-zA-Z0-9_., ]+: .*$", Data) > -1
argsNames <- sub("^ *([a-zA-Z0-9_., ]+): .*$", "\\1", Data[argsFirstLine])
- # Try to detect false argsNames, when ":" occurs in description
+ ## Try to detect false argsNames, when ":" occurs in description
isArgs <- (regexpr("[^,] ", argsNames) == -1)
argsFirstLine[argsFirstLine] <- isArgs
argsNames <- argsNames[isArgs]
- # Get the argument description
+ ## Get the argument description
argsDesc <- sub("^ *(.*)$", "\\1", Data)
argsDesc[argsFirstLine] <- sub("^[a-zA-Z0-9_., ]+: (.*)$", "\\1",
argsDesc[argsFirstLine])
- # Create a character vector with the successive argument descriptions
+ ## Create a character vector with the successive argument descriptions
res <- tapply(argsDesc, cumsum(argsFirstLine), paste, collapse = " ")
res <- as.vector(res)
- # Create multiple entries for "arg1, arg2, ..."
+ ## Create multiple entries for "arg1, arg2, ..."
argsNames <- strsplit(argsNames, ", *")
Times <- sapply(argsNames, length)
res <- rep(res, Times)
names(res) <- unlist(argsNames)
- # If args is not NULL, filter according to provided arguments
+ ## If args is not NULL, filter according to provided arguments
if (!is.null(args)) {
res <- res[as.character(args)]
- # If arg names do not exists, return NA -> replace by ""
+ ## If arg names do not exists, return NA -> replace by ""
names(res) <- args
res[is.na(res)] <- ""
}
return(res)
}
+
+## Version of descArgs for R >= 2.10.0 and its new help system
+.descArgsNew <- function (fun, args = NULL, package = NULL, lib.loc = NULL)
+{
+ ## We cannot just call help normally because otherwise it thinks
+ ## we are looking for package "package" so we create a call and eval it
+ help.call <- call("help", fun, lib.loc = lib.loc, help_type = "text")
+ if (!is.null(package)) help.call[["package"]] <- package
+ file <- eval(help.call)
+
+ ## This is borrowed from utils::print.help_files_with_topic
+ path <- dirname(file)
+ dirpath <- dirname(path)
+ pkgname <- basename(dirpath)
+ RdDB <- file.path(path, pkgname)
+
+ if (!file.exists(paste(RdDB, "rdx", sep=".")))
+ return(character(length(args)))
+
+ rd <- tools:::fetchRdDB(RdDB, basename(file))
+
+ ## This is not exported from tools
+ RdTags <- function (Rd) {
+ res <- sapply(Rd, attr, "Rd_tag")
+ if (!length(res)) res <- character(0)
+ return(res)
+ }
+ tags <- gsub("\\", "", RdTags(rd), fixed = TRUE)
+
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 297
More information about the Sciviews-commits
mailing list