[Sciviews-commits] r103 - in pkg/svMisc: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jan 23 12:57:05 CET 2009
Author: phgrosjean
Date: 2009-01-23 12:57:05 +0100 (Fri, 23 Jan 2009)
New Revision: 103
Modified:
pkg/svMisc/DESCRIPTION
pkg/svMisc/NEWS
pkg/svMisc/R/objList.R
pkg/svMisc/man/objBrowse.Rd
Log:
objList() reworked
Modified: pkg/svMisc/DESCRIPTION
===================================================================
--- pkg/svMisc/DESCRIPTION 2009-01-23 09:23:04 UTC (rev 102)
+++ pkg/svMisc/DESCRIPTION 2009-01-23 11:57:05 UTC (rev 103)
@@ -3,8 +3,8 @@
Imports: utils, methods
Depends: R (>= 2.6.0)
Description: Supporting functions for the GUI API (various utilitary functions)
-Version: 0.9-46
-Date: 2009-01-22
+Version: 0.9-47
+Date: 2009-01-23
Author: Philippe Grosjean, Romain Francois & Kamil Barton
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: GPL (>= 2)
Modified: pkg/svMisc/NEWS
===================================================================
--- pkg/svMisc/NEWS 2009-01-23 09:23:04 UTC (rev 102)
+++ pkg/svMisc/NEWS 2009-01-23 11:57:05 UTC (rev 103)
@@ -1,5 +1,10 @@
= svMisc News
+== Changes in svMisc 0.9-47
+
+* objList(), print.objectList() and write.objList() reworked (PhG)
+
+
== Changes in svMisc 0.9-46
* Added objList(), print() method for 'objList' objects and write.objList() (KB)
Modified: pkg/svMisc/R/objList.R
===================================================================
--- pkg/svMisc/R/objList.R 2009-01-23 09:23:04 UTC (rev 102)
+++ pkg/svMisc/R/objList.R 2009-01-23 11:57:05 UTC (rev 103)
@@ -1,36 +1,37 @@
-`objList` <- function(id = "default", envir = .GlobalEnv, object = NULL, all.names = FALSE,
-pattern = "", group = "", all.info = FALSE, path = NULL, compare = TRUE, ...) {
-
- #Nothing <- structure(list(character(0), character(0), character(0), character(0), character(0), logical(0)), .Names = c("Envir", "Name", "Dims", "Group", "Class", "Recursive"), class = c("objList", "NULL","data.frame"))
- #
- #if (!all.info)
- # Nothing <- Nothing[,-1]
-
-
+"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[1])){
- envir <- tryCatch(as.environment(envir[1]), error = function(e) NULL)
-
- if(is.null(envir) ){
- return(Nothing)
+ 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 ) )
+ 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")
- #cat("ename:", ename, "\n")
+ if (is.null(envir))
+ return(Nothing)
- # Empty result. Change back to data frame?
- Nothing <- structure(NULL, class = c("objList", "NULL"),
- all.info = all.info, envir = ename, object = object)
-
if (!missing(object) && is.character(object) && object != "") {
res <- lsObj(envir = envir, objname = object)
} else {
@@ -41,29 +42,30 @@
}
# Get characteristics of all objects
- `describe` <- function(name, all.info = FALSE) {
+ "describe" <- function (name, all.info = FALSE)
+ {
# get a vector with five items:
# Name, Dims, Group, Class and Recursive
- obj <- envir[[ name ]]
+ obj <- envir[[name]]
res <- c(
Name = name,
- Dims = if (is.null(Dim <- dim(obj))) length(obj) else paste(Dim, collapse = "x"),
+ 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)
-
+ res <- data.frame(t(sapply(Items, describe, all.info = all.info)),
+ stringsAsFactors = FALSE)
}
- if (is.null(res))
+ if (NROW(res) == 0)
return(Nothing)
if (isTRUE(all.info))
- res <- cbind(Environment = ename, res)
+ res <- cbind(Envir = ename, res)
vMode <- Groups <- res$Group
vClass <- res$Class
@@ -71,23 +73,23 @@
# 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 %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"
- # 4) integers of class factor become factor in group
+ # 3) Integers of class factor become factor in group
Groups[vClass == "factor"] <- "factor"
- # 5) Objects of class 'data.frame' are also group 'data.frame'
+ # 4) Objects of class 'data.frame' are also group 'data.frame'
Groups[vClass == "data.frame"] <- "data.frame"
- # 6) Objects of class 'Date' or 'POSIXt' are of group 'DateTime'
+ # 5) Objects of class 'Date' or 'POSIXt' are of group 'DateTime'
Groups[vClass == "Date" | vClass == "POSIXt"] <- "DateTime"
# Reaffect groups
@@ -96,94 +98,96 @@
# 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")
- res <- structure(
- .Data = res,
- class = c( "objList", "data.frame" ), id = id, envir = ename,
- all.names = all.names, all.info = all.info, pattern = pattern,
- group = group, object = if (!is.null(object)) object else NULL
- )
-
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
- write.objList(res, path, ...)
- } else
+ return(write.objList(res, path = path, sep = sep, ...))
+ } else {
return(Nothing) # Not changed
+ }
}
-
-
-`write.objList` <- function(x, path, sep = "\t", ...) {
-
+"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(x, row.names = FALSE, col.names = FALSE, sep =",", quote = FALSE, file = ListF)
+ 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
- )
+ attr(x, "group")), file = ParsF, append = FALSE)
return(invisible(ListF))
-
}
-
-`print.objList` <- function(x, sep = "\t", eol = "\n", header = !attr(x, "all.info"), ...){
- if (!is.null(x)) {
+"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) {
- cat("#Environment=",attr(x, "envir"), "\n", sep = "")
- cat("#Object=", if (is.null(attr(x, "object"))) "" else attr(x, "object"), "\n", sep = "")
+ cat("\tEnvironment = ", attr(x, "envir"), "\n", sep = "")
+ cat("\tObject = ", if (is.null(attr(x, "object"))) "" else
+ attr(x, "object"), "\n", sep = "")
}
- if(is.na(sep) ) {
- print.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)
- return(invisible(x))
+ if (is.na(sep)) {
+ cat("\n")
+ 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()
+ cat("An empty objects list\n")
}
+ return(invisible(x))
}
# called by objList when object is provided
-#TODO: simplify, possilby merge lsObj.S4 into lsObj
-`lsObj` <- function(objname, envir, ...) {
-
+# 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 (inherits(obj, "try-error"))
+ return(NULL)
if (mode(obj) == "S4") {
ret <- lsObj.S4(obj, objname)
- } else if (is.function(obj)){
+ } else if (is.function(obj)) {
ret <- lsObj.function(obj, objname)
- } else { #S3:
-
+ } else { # S3
#{{
if (!(mode(obj) %in% c("list", "pairlist")) || length(obj) == 0)
- return(NULL);
+ return(NULL)
itemnames <- fullnames <- names(obj)
if (is.null(itemnames)) {
@@ -195,95 +199,85 @@
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 = "")
+ fullnames[!w.names] <- paste(objname, "[[",
+ seq_along(itemnames)[!w.names], "]]", sep = "")
}
-
- ret <- t(sapply (seq_along(obj), function(i) {
+ 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)
+ 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)
+ 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")
-
-
-
-
+ 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)
+"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);
+ 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 = "")
+ fullnames <- paste(objname, "$", itemnames, sep = "")
- ret <- t(sapply (seq_along(obj), function(i) {
+ 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]]);
+ 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 <- 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);
+"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 = "")
+ fullnames <- paste(objname, "@", itemnames, sep = "")
-
- ret <- t(sapply (itemnames, function(i) {
+ 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 <- 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)
Modified: pkg/svMisc/man/objBrowse.Rd
===================================================================
--- pkg/svMisc/man/objBrowse.Rd 2009-01-23 09:23:04 UTC (rev 102)
+++ pkg/svMisc/man/objBrowse.Rd 2009-01-23 11:57:05 UTC (rev 103)
@@ -23,14 +23,14 @@
objDir()
objInfo(id = "default", envir = .GlobalEnv, object = "", path = NULL)
objList(id = "default", envir = .GlobalEnv, object = NULL, all.names = FALSE,
- pattern = "", group = "", all.info = FALSE, path = NULL, compare = TRUE,
- \dots)
+ pattern = "", group = "", all.info = FALSE, sep = "\t", path = NULL,
+ compare = TRUE, \dots)
objMenu(id = "default", envir = .GlobalEnv, objects = "", sep = "\t",
path = NULL)
objSearch(sep = "\t", path = NULL, compare = TRUE)
-\method{print}{objList}(x, sep = "\t", eol = "\n", header = !attr(x, "all.info"), \dots)
+\method{print}{objList}(x, sep = NA, eol = "\n", header = !attr(x, "all.info"), \dots)
write.objList(x, path, sep = "\t", \dots)
}
More information about the Sciviews-commits
mailing list