[Sciviews-commits] r107 - in pkg/svMisc: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Feb 3 14:28:53 CET 2009
Author: prezez
Date: 2009-02-03 14:28:52 +0100 (Tue, 03 Feb 2009)
New Revision: 107
Modified:
pkg/svMisc/R/objList.R
pkg/svMisc/man/objBrowse.Rd
Log:
added "raw" option to "print.objList" (to produce output for object browser).
man page updated accordingly.
Modified: pkg/svMisc/R/objList.R
===================================================================
--- pkg/svMisc/R/objList.R 2009-01-28 19:46:00 UTC (rev 106)
+++ pkg/svMisc/R/objList.R 2009-02-03 13:28:52 UTC (rev 107)
@@ -1,290 +1,292 @@
-"objList" <-
-function (id = "default", envir = .GlobalEnv, object = NULL, all.names = FALSE,
-pattern = "", group = "", all.info = FALSE, sep = "\t", path = NULL, compare = TRUE, ...)
-{
- # Make sure that id is character
- id <- as.character(id)[1]
- if (id == "") id <- "default"
-
- # Format envir as character (use only first item provided!)
- if (!is.environment(envir)){
- envir <- tryCatch(as.environment(envir), error = function(e) NULL)
- if (is.null(envir) || inherits(envir, "try-error")) {
- envir <- NULL
- ename <- ""
- } else {
- ename <- if (is.null(attr(envir, "name"))) ".GlobalEnv" else attr(envir, "name")
- }
- } else {
- ename <- deparse(substitute(envir))
- }
-
- # Object to return in case of empty data
- Nothing <- data.frame(Envir = character(0), Name = character(0),
- Dims = character(0), Group = character(0), Class = character(0),
- Recursive = logical(0), stringsAsFactors = FALSE)
- if (!all.info) Nothing <- Nothing[, -1]
- attr(Nothing, "all.info") <- all.info
- attr(Nothing, "envir") <- ename
- attr(Nothing, "object") <- object
- attr(Nothing, "class") <- c("objList", "data.frame")
-
- if (is.null(envir))
- return(Nothing)
-
- if (!missing(object) && is.character(object) && object != "") {
- res <- lsObj(envir = envir, objname = object)
- } else {
- # Get the list of objects in this environment
- Items <- ls(envir = envir, all.names = all.names, pattern = pattern)
- if (length(Items) == 0) {
- return(Nothing)
- }
-
- # Get characteristics of all objects
- "describe" <- function (name, all.info = FALSE)
- {
- # get a vector with five items:
- # Name, Dims, Group, Class and Recursive
- obj <- envir[[name]]
- res <- c(
- Name = name,
- Dims = if (is.null(Dim <- dim(obj))) length(obj) else
- paste(Dim, collapse = "x"),
- Group = mode(obj),
- Class = class(obj)[1],
- Recursive = is.recursive(obj) || mode(obj) == "S4"
- )
- return(res)
- }
- res <- data.frame(t(sapply(Items, describe, all.info = all.info)),
- stringsAsFactors = FALSE)
- }
-
- if (NROW(res) == 0)
- return(Nothing)
-
- if (isTRUE(all.info))
- res <- cbind(Envir = ename, res)
-
- vMode <- Groups <- res$Group
- vClass <- res$Class
-
- # Recalculate groups into meaningful ones for the object explorer
- # 1) Correspondance of typeof() and group depicted in the browser
- #{{
- Groups[Groups %in% c("name", "environment", "promise", "language", "char",
- "...", "any", "(", "call", "expression", "bytecode", "weakref",
- "externalptr")] <- "language"
-
- Groups[Groups == "pairlist"] <- "list"
-
- # 2) All Groups not being language, function or S4 whose class is
- # different than typeof are flagged as S3 objects
- Groups[!(Groups %in% c("language", "function", "S4")) & vMode != vClass] <- "S3"
-
- # 3) Integers of class factor become factor in group
- Groups[vClass == "factor"] <- "factor"
-
- # 4) Objects of class 'data.frame' are also group 'data.frame'
- Groups[vClass == "data.frame"] <- "data.frame"
-
- # 5) Objects of class 'Date' or 'POSIXt' are of group 'DateTime'
- Groups[vClass == "Date" | vClass == "POSIXt"] <- "DateTime"
-
- # Reaffect groups
- res$Group <- Groups
-
- # Possibly filter according to group
- if (!is.null(group) && group != "")
- res <- res[Groups == group, ]
- #}}
-
- # Determine if it is required to refresh something
- Changed <- TRUE
- if (compare) {
- allList <- getTemp(".guiObjListCache", default = list())
-
- if (identical(res, allList[[id]])) Changed <- FALSE else {
- # Keep a copy of the last version in TempEnv
- allList[[id]] <- res
- assignTemp(".guiObjListCache", allList)
- }
- }
-
- # Create the 'objList' object
- attr(res, "all.info") <- all.info
- attr(res, "envir") <- ename
- attr(res, "object") <- object
- attr(res, "class") <- c("objList", "data.frame")
-
- if (is.null(path)) { # Return results or "" if not changed
- return(if (Changed) res else Nothing)
- } else if (Changed) { # Write to files in this path
- return(write.objList(res, path = path, sep = sep, ...))
- } else {
- return(Nothing) # Not changed
- }
-}
-
-"write.objList" <-
-function (x, path, sep = "\t", ...)
-{
- id <- attr(x, "id")
- ListF <- file.path(path, sprintf("List_%s.txt", id))
- ParsF <- file.path(path, sprintf("Pars_%s.txt", id))
-
- write.table(as.data.frame(x), row.names = FALSE, col.names = FALSE,
- sep = sep, quote = FALSE, file = ListF)
-
- # Write also in the Pars_<id>.txt file in the same directory
- cat(sprintf("envir=%s\nall.names=%s\npattern=%s\ngroup=%s",
- attr(x, "envir"), attr(x, "all.names"), attr(x, "pattern"),
- attr(x, "group")), file = ParsF, append = FALSE)
-
- return(invisible(ListF))
-}
-
-"print.objList" <-
-function (x, sep = NA, eol = "\n", header = !attr(x, "all.info"), ...)
-{
- if (!inherits(x, "objList"))
- stop("x must be an 'objList' object")
- if (NROW(x) > 0) {
-
-
- cat("Objects list:\n")
- if (header) {
- header.sep <- if (is.na(sep)) " = " else "="
-
- cat("Environment", attr(x, "envir"), sep = header.sep)
- cat("\n")
- cat("Object", if (is.null(attr(x, "object"))) "" else
- attr(x, "object"), sep = header.sep)
- cat("\n")
- }
-
- if (is.na(sep)) {
- print(as.data.frame(x))
- } else if (!is.null(nrow(x)) && nrow(x) > 0) {
- write.table(x, row.names = FALSE, col.names = FALSE, sep = sep,
- eol = eol, quote = FALSE)
- }
- } else {
- cat("An empty objects list\n")
- }
- return(invisible(x))
-}
-
-# called by objList when object is provided
-# TODO: simplify, possibly merge lsObj.S4 into lsObj
-"lsObj" <-
-function (objname, envir, ...)
-{
- obj <- try(eval(parse(text = objname)), silent = TRUE)
- if (inherits(obj, "try-error"))
- return(NULL)
-
- if (mode(obj) == "S4") {
- ret <- lsObj.S4(obj, objname)
- } else if (is.function(obj)) {
- ret <- lsObj.function(obj, objname)
- } else { # S3
-#{{
- if (!(mode(obj) %in% c("list", "pairlist")) || length(obj) == 0)
- return(NULL)
-
- itemnames <- fullnames <- names(obj)
- if (is.null(itemnames)) {
- itemnames <- seq_along(obj)
- fullnames <- paste(objname, "[[", seq_along(obj), "]]", sep = "")
- } else {
- w.names <- itemnames != ""
- .names <- itemnames[w.names]
- nsx <- .names != make.names(.names) # non-syntactic names
- .names[nsx] <- paste("`", .names[nsx], "`", sep = "")
- fullnames[w.names] <- paste (objname, "$", .names, sep = "")
- fullnames[!w.names] <- paste(objname, "[[",
- seq_along(itemnames)[!w.names], "]]", sep = "")
- }
-
- ret <- t(sapply(seq_along(obj), function (i) {
- x <- obj[[i]]
-
- d <- dim(x)
- if (is.null(d)) d <- length(x)
-
- ret <- c(paste(d, collapse = "x"), mode(x), class(x)[1],
- is.function(x) || (is.recursive(x) && !is.language(x) && sum(d) != 0)
- )
- return(ret)
- }))
-
- ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE)
-#}}
- }
- if (!is.null(ret))
- names(ret) <- c("Name", "Full.name", "Dims/default", "Group", "Class",
- "Recursive")
- return (ret)
-}
-
-# called by lsObj
-"lsObj.function" <-
-function (obj, objname = deparse(substitute(obj)))
-{
- # formals(obj) returns NULL if only arg is ..., try: formals(expression)
- obj <- formals(args(obj))
- objname <- paste("formals(args(", objname, "))", sep = "")
-
- if(length(obj) == 0)
- return(NULL)
-
- itemnames <- fullnames <- names(obj)
- nsx <- itemnames != make.names(itemnames) # non-syntactic names
- itemnames[nsx] <- paste("`", itemnames[nsx], "`", sep = "")
- fullnames <- paste(objname, "$", itemnames, sep = "")
-
- ret <- t(sapply (seq_along(obj), function (i) {
- x <- obj[[i]]
- lang <- is.language(obj[[i]])
- o.class <- class(obj[[i]])[1]
- o.mode <- mode(obj[[i]])
-
- d <- deparse(obj[[i]])
- if (lang && o.class == "name") {
- o.class <- ""
- o.mode <- ""
- }
-
- ret <- c(paste(d, collapse = "x"), o.class, o.mode, FALSE)
- return(ret)
- }))
-
- ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE)
- return (ret)
-}
-
-
-# called by lsObj in S4 case
-"lsObj.S4" <-
-function (obj, objname = deparse(substitute(obj)))
-{
- itemnames <- fullnames <- slotNames(obj)
- nsx <- itemnames != make.names(itemnames)
- itemnames[nsx] <- paste("`", itemnames[nsx], "`", sep = "")
- fullnames <- paste(objname, "@", itemnames, sep = "")
-
- ret <- t(sapply(itemnames, function (i) {
- x <- slot(obj, i)
-
- d <- dim(x)
- if (is.null(d)) d <- length(x)
-
- ret <- c(paste(d, collapse = "x"), mode(x), class(x)[1],
- is.function(x) || (is.recursive(x) && !is.language(x) && sum(d) != 0))
- }))
-
- ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE)
- return(ret)
-}
+"objList" <-
+function (id = "default", envir = .GlobalEnv, object = NULL, all.names = FALSE,
+pattern = "", group = "", all.info = FALSE, sep = "\t", path = NULL, compare = TRUE, ...)
+{
+ # Make sure that id is character
+ id <- as.character(id)[1]
+ if (id == "") id <- "default"
+
+ # Format envir as character (use only first item provided!)
+ if (!is.environment(envir)){
+ envir <- tryCatch(as.environment(envir), error = function(e) NULL)
+ if (is.null(envir) || inherits(envir, "try-error")) {
+ envir <- NULL
+ ename <- ""
+ } else {
+ ename <- if (is.null(attr(envir, "name"))) ".GlobalEnv" else attr(envir, "name")
+ }
+ } else {
+ ename <- deparse(substitute(envir))
+ }
+
+ # Object to return in case of empty data
+ Nothing <- data.frame(Envir = character(0), Name = character(0),
+ Dims = character(0), Group = character(0), Class = character(0),
+ Recursive = logical(0), stringsAsFactors = FALSE)
+ if (!all.info) Nothing <- Nothing[, -1]
+ attr(Nothing, "all.info") <- all.info
+ attr(Nothing, "envir") <- ename
+ attr(Nothing, "object") <- object
+ attr(Nothing, "class") <- c("objList", "data.frame")
+
+ if (is.null(envir))
+ return(Nothing)
+
+ if (!missing(object) && is.character(object) && object != "") {
+ res <- lsObj(envir = envir, objname = object)
+ } else {
+ # Get the list of objects in this environment
+ Items <- ls(envir = envir, all.names = all.names, pattern = pattern)
+ if (length(Items) == 0) {
+ return(Nothing)
+ }
+
+ # Get characteristics of all objects
+ "describe" <- function (name, all.info = FALSE)
+ {
+ # get a vector with five items:
+ # Name, Dims, Group, Class and Recursive
+ obj <- envir[[name]]
+ res <- c(
+ Name = name,
+ Dims = if (is.null(Dim <- dim(obj))) length(obj) else
+ paste(Dim, collapse = "x"),
+ Group = mode(obj),
+ Class = class(obj)[1],
+ Recursive = is.recursive(obj) || mode(obj) == "S4"
+ )
+ return(res)
+ }
+ res <- data.frame(t(sapply(Items, describe, all.info = all.info)),
+ stringsAsFactors = FALSE)
+ }
+
+ if (NROW(res) == 0)
+ return(Nothing)
+
+ if (isTRUE(all.info))
+ res <- cbind(Envir = ename, res)
+
+ vMode <- Groups <- res$Group
+ vClass <- res$Class
+
+ # Recalculate groups into meaningful ones for the object explorer
+ # 1) Correspondance of typeof() and group depicted in the browser
+ #{{
+ Groups[Groups %in% c("name", "environment", "promise", "language", "char",
+ "...", "any", "(", "call", "expression", "bytecode", "weakref",
+ "externalptr")] <- "language"
+
+ Groups[Groups == "pairlist"] <- "list"
+
+ # 2) All Groups not being language, function or S4 whose class is
+ # different than typeof are flagged as S3 objects
+ Groups[!(Groups %in% c("language", "function", "S4")) & vMode != vClass] <- "S3"
+
+ # 3) Integers of class factor become factor in group
+ Groups[vClass == "factor"] <- "factor"
+
+ # 4) Objects of class 'data.frame' are also group 'data.frame'
+ Groups[vClass == "data.frame"] <- "data.frame"
+
+ # 5) Objects of class 'Date' or 'POSIXt' are of group 'DateTime'
+ Groups[vClass == "Date" | vClass == "POSIXt"] <- "DateTime"
+
+ # Reaffect groups
+ res$Group <- Groups
+
+ # Possibly filter according to group
+ if (!is.null(group) && group != "")
+ res <- res[Groups == group, ]
+ #}}
+
+ # Determine if it is required to refresh something
+ Changed <- TRUE
+ if (compare) {
+ allList <- getTemp(".guiObjListCache", default = list())
+
+ if (identical(res, allList[[id]])) Changed <- FALSE else {
+ # Keep a copy of the last version in TempEnv
+ allList[[id]] <- res
+ assignTemp(".guiObjListCache", allList)
+ }
+ }
+
+ # Create the 'objList' object
+ attr(res, "all.info") <- all.info
+ attr(res, "envir") <- ename
+ attr(res, "object") <- object
+ attr(res, "class") <- c("objList", "data.frame")
+
+ if (is.null(path)) { # Return results or "" if not changed
+ return(if (Changed) res else Nothing)
+ } else if (Changed) { # Write to files in this path
+ return(write.objList(res, path = path, sep = sep, ...))
+ } else {
+ return(Nothing) # Not changed
+ }
+}
+
+"write.objList" <-
+function (x, path, sep = "\t", ...)
+{
+ id <- attr(x, "id")
+ ListF <- file.path(path, sprintf("List_%s.txt", id))
+ ParsF <- file.path(path, sprintf("Pars_%s.txt", id))
+
+ write.table(as.data.frame(x), row.names = FALSE, col.names = FALSE,
+ sep = sep, quote = FALSE, file = ListF)
+
+ # Write also in the Pars_<id>.txt file in the same directory
+ cat(sprintf("envir=%s\nall.names=%s\npattern=%s\ngroup=%s",
+ attr(x, "envir"), attr(x, "all.names"), attr(x, "pattern"),
+ attr(x, "group")), file = ParsF, append = FALSE)
+
+ return(invisible(ListF))
+}
+
+"print.objList" <-
+function (x, sep = NA, eol = "\n", header = !attr(x, "all.info"), raw.output = !is.na(sep), ...)
+{
+ if (!inherits(x, "objList"))
+ stop("x must be an 'objList' object")
+ if (NROW(x) > 0) {
+
+ if (!raw.output)
+ cat("Objects list:\n")
+ if (header) {
+ header.fmt <- if (raw.output) "Env=%s\nObj=%s\n" else
+ "\tEnvironment: %s\n\tObject: %s\n"
+
+ objname <- if (is.null(attr(x, "object"))) {
+ if (raw.output) "" else "<All>"
+ } else attr(x, "object")
+
+ cat(sprintf(header.fmt, attr(x, "envir"), objname))
+
+ }
+
+ if (is.na(sep)) {
+ print(as.data.frame(x))
+ } else if (!is.null(nrow(x)) && nrow(x) > 0) {
+ write.table(x, row.names = FALSE, col.names = FALSE, sep = sep,
+ eol = eol, quote = FALSE)
+ }
+ } else if (!raw.output) {
+ cat("An empty objects list\n")
+ }
+ return(invisible(x))
+}
+
+# called by objList when object is provided
+# TODO: simplify, possibly merge lsObj.S4 into lsObj
+"lsObj" <-
+function (objname, envir, ...)
+{
+ obj <- try(eval(parse(text = objname)), silent = TRUE)
+ if (inherits(obj, "try-error"))
+ return(NULL)
+
+ if (mode(obj) == "S4") {
+ ret <- lsObj.S4(obj, objname)
+ } else if (is.function(obj)) {
+ ret <- lsObj.function(obj, objname)
+ } else { # S3
+#{{
+ if (!(mode(obj) %in% c("list", "pairlist")) || length(obj) == 0)
+ return(NULL)
+
+ itemnames <- fullnames <- names(obj)
+ if (is.null(itemnames)) {
+ itemnames <- seq_along(obj)
+ fullnames <- paste(objname, "[[", seq_along(obj), "]]", sep = "")
+ } else {
+ w.names <- itemnames != ""
+ .names <- itemnames[w.names]
+ nsx <- .names != make.names(.names) # non-syntactic names
+ .names[nsx] <- paste("`", .names[nsx], "`", sep = "")
+ fullnames[w.names] <- paste (objname, "$", .names, sep = "")
+ fullnames[!w.names] <- paste(objname, "[[",
+ seq_along(itemnames)[!w.names], "]]", sep = "")
+ }
+
+ ret <- t(sapply(seq_along(obj), function (i) {
+ x <- obj[[i]]
+
+ d <- dim(x)
+ if (is.null(d)) d <- length(x)
+
+ ret <- c(paste(d, collapse = "x"), mode(x), class(x)[1],
+ is.function(x) || (is.recursive(x) && !is.language(x) && sum(d) != 0)
+ )
+ return(ret)
+ }))
+
+ ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE)
+#}}
+ }
+ if (!is.null(ret))
+ names(ret) <- c("Name", "Full.name", "Dims/default", "Group", "Class",
+ "Recursive")
+ return (ret)
+}
+
+# called by lsObj
+"lsObj.function" <-
+function (obj, objname = deparse(substitute(obj)))
+{
+ # formals(obj) returns NULL if only arg is ..., try: formals(expression)
+ obj <- formals(args(obj))
+ objname <- paste("formals(args(", objname, "))", sep = "")
+
+ if(length(obj) == 0)
+ return(NULL)
+
+ itemnames <- fullnames <- names(obj)
+ nsx <- itemnames != make.names(itemnames) # non-syntactic names
+ itemnames[nsx] <- paste("`", itemnames[nsx], "`", sep = "")
+ fullnames <- paste(objname, "$", itemnames, sep = "")
+
+ ret <- t(sapply (seq_along(obj), function (i) {
+ x <- obj[[i]]
+ lang <- is.language(obj[[i]])
+ o.class <- class(obj[[i]])[1]
+ o.mode <- mode(obj[[i]])
+
+ d <- deparse(obj[[i]])
+ if (lang && o.class == "name") {
+ o.class <- ""
+ o.mode <- ""
+ }
+
+ ret <- c(paste(d, collapse = "x"), o.class, o.mode, FALSE)
+ return(ret)
+ }))
+
+ ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE)
+ return (ret)
+}
+
+
+# called by lsObj in S4 case
+"lsObj.S4" <-
+function (obj, objname = deparse(substitute(obj)))
+{
+ itemnames <- fullnames <- slotNames(obj)
+ nsx <- itemnames != make.names(itemnames)
+ itemnames[nsx] <- paste("`", itemnames[nsx], "`", sep = "")
+ fullnames <- paste(objname, "@", itemnames, sep = "")
+
+ ret <- t(sapply(itemnames, function (i) {
+ x <- slot(obj, i)
+
+ d <- dim(x)
+ if (is.null(d)) d <- length(x)
+
+ ret <- c(paste(d, collapse = "x"), mode(x), class(x)[1],
+ is.function(x) || (is.recursive(x) && !is.language(x) && sum(d) != 0))
+ }))
+
+ ret <- data.frame(itemnames, fullnames, ret, stringsAsFactors = FALSE)
+ return(ret)
+}
Modified: pkg/svMisc/man/objBrowse.Rd
===================================================================
--- pkg/svMisc/man/objBrowse.Rd 2009-01-28 19:46:00 UTC (rev 106)
+++ pkg/svMisc/man/objBrowse.Rd 2009-02-03 13:28:52 UTC (rev 107)
@@ -30,7 +30,8 @@
path = NULL)
objSearch(sep = "\t", path = NULL, compare = TRUE)
-\method{print}{objList}(x, sep = NA, eol = "\n", header = !attr(x, "all.info"), \dots)
+\method{print}{objList}(x, sep = NA, eol = "\n", header = !attr(x, "all.info"),
+ raw.output = !is.na(sep), \dots)
write.objList(x, path, sep = "\t", \dots)
}
@@ -45,7 +46,7 @@
\item{pattern}{ A pattern to match for selecting variables }
\item{group}{ A group to filter }
\item{path}{ The path where to write a temporary file with the requested
- information. Use \code{path = NULL} (default) if you don't pass this
+ information. Set to NULL (default) if you don't pass this
data to your GUI client by mean of a file }
\item{regenerate}{ Do we force to regenerate the information? }
\item{object}{ name of the object selected in the object browser,
@@ -53,17 +54,18 @@
\item{objects}{ A list with selected items in the object browser }
\item{all.info}{ Do we return all the information (envir as first column or
not (by default) }
- \item{compare}{ If \code{compare == TRUE}, result is compared with last cached
+ \item{compare}{ If TRUE, result is compared with last cached
value and the client is updated only if something changed }
\item{sep}{ Separator to use between items (if path is not NULL) }
\item{x}{ Object returned by \code{objList}}
\item{eol}{ Separator to use between object entries, default is to list each
item in a separate line}
\item{header}{ If TRUE, two-line header is printed, of the form: \cr
- \#Environment=environment name \cr
- \#Object=object name \cr
- Default is not to print header if all.info is true.
+ Environment=environment name \cr
+ Object=object name \cr
+ Default is not to print header if \code{all.info} is true.
}
+ \item{raw.output}{If TRUE, a compact, better suited for parsing output is produced}
\item{\dots}{further arguments, passed to \code{write.table}}
}
@@ -72,7 +74,8 @@
where exchange files are stored, in case you exchange data through files.
You can use a better way to communicate with your GUI (you have to provide
your code) and disable writing to files by using \code{path = NULL}.
- \code{objList()} lists objects in a given environment.
+ \code{objList()} lists objects in a given environment, elements of
+ a recursive objects or function arguments.
\code{objSearch()} lists the search path.
\code{objClear()} clears any reference to a given object browser.
\code{objInfo()} computes a tooltip info for a given object.
More information about the Sciviews-commits
mailing list