[Sciviews-commits] r89 - in pkg/svMisc: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jan 12 14:57:36 CET 2009
Author: prezez
Date: 2009-01-12 14:57:36 +0100 (Mon, 12 Jan 2009)
New Revision: 89
Added:
pkg/svMisc/R/lsObj.R
pkg/svMisc/man/lsObj.Rd
Modified:
pkg/svMisc/NAMESPACE
pkg/svMisc/R/captureAll.R
pkg/svMisc/R/objList.R
pkg/svMisc/man/objBrowse.Rd
Log:
Added function `lsObj` listing object contents and function arguments (for use with R-Objects) - should be combined with objList later.
Typo corrected in captureAll. Slightly modified `objList` and `print.objList`, nothing is printed if there are no objects.
Updated documentation (`objList`, `print.objList` and `lsObj`)
Package passes R-Check now.
Modified: pkg/svMisc/NAMESPACE
===================================================================
--- pkg/svMisc/NAMESPACE 2009-01-12 09:49:58 UTC (rev 88)
+++ pkg/svMisc/NAMESPACE 2009-01-12 13:57:36 UTC (rev 89)
@@ -38,6 +38,7 @@
isWin,
listMethods,
listTypes,
+ lsObj,
objBrowse,
objClear,
objDir,
@@ -46,6 +47,7 @@
objMenu,
objSearch,
Parse,
+ print.objList,
progress,
r,
rmTemp,
Modified: pkg/svMisc/R/captureAll.R
===================================================================
--- pkg/svMisc/R/captureAll.R 2009-01-12 09:49:58 UTC (rev 88)
+++ pkg/svMisc/R/captureAll.R 2009-01-12 13:57:36 UTC (rev 89)
@@ -87,7 +87,7 @@
return()
} else if (Warn > 1) { # Generate an error!
- msg <- .gettextf("(converted from warning) %s", Mes)
+ msg <- .gettextf("(converted from warning) %s", msg)
stop(simpleError(msg, call = call))
} else {
# warn = 1
Added: pkg/svMisc/R/lsObj.R
===================================================================
--- pkg/svMisc/R/lsObj.R (rev 0)
+++ pkg/svMisc/R/lsObj.R 2009-01-12 13:57:36 UTC (rev 89)
@@ -0,0 +1,133 @@
+lsObj <- function(objname, envir = .GlobalEnv, sep = ",") {
+
+
+ if (!is.environment(envir)){
+ envir <- envir[1]
+ if( is.numeric(envir) ){
+ ename <- search()[envir]
+ envir <- as.environment( envir )
+ } else if( is.character( envir ) ){
+ envir <- as.environment( match( ename <- envir, search() ) )
+ } else {
+ return("")
+ }
+ } else{
+ ename <- deparse( substitute( envir ) )
+ }
+
+ obj <- try(eval(parse(text = objname)), silent = TRUE)
+ if (inherits(obj, "try-error")) {
+ return ("");
+ }
+
+ if (mode(obj) == "S4") {
+ return (lsSlots(obj, objname, ename, sep = sep));
+ }
+
+ if (is.function(obj)) {
+ obj <- formals(obj)
+ objname <- paste("formals(", objname, ")")
+ fun <- TRUE
+ } else {
+ fun <- FALSE
+ if (!(mode(obj) %in% c("list", "pairlist")))
+ return("");
+ }
+
+ if(length(obj) == 0)
+ return("");
+
+ itemnames <- fullnames <- names(obj)
+ if (is.null(itemnames)) {
+ 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 <- c()
+ for (i in seq_along(obj)) {
+ x <- obj[[i]]
+ lang <- is.language(obj[[i]])
+ o.class <- class(obj[[i]])[1]
+ o.mode <- mode(obj[[i]])
+
+ if (fun) {
+ if (o.class == "logical") {
+ d <- if(isTRUE(obj[[i]])) "TRUE" else "FALSE";
+ } else {
+ d <- deparse(obj[[i]]);
+ if (lang) {
+
+ if (o.class == "name") {
+ o.class <- ""
+ o.mode <- ""
+ }
+ }
+ }
+
+ } else {
+ d <- dim(x)
+ if (is.null(d)) d <- length(x)
+ pos.length <- sum(d) != 0
+ }
+
+ ret <- rbind(ret,
+ list(paste(d, collapse="x"),
+ o.class,
+ o.mode,
+ is.function(obj[[i]]) || (is.recursive(obj[[i]]) && !lang && pos.length))
+ )
+ }
+ if (is.na(sep)) {
+ ret <- data.frame(ename, itemnames, fullnames, ret)
+ names(ret) <- c("Environment", "Name", "Full name", "Dims/default value", "Class", "Mode", "Recursive")
+ } else {
+ ret <- apply(ret, 1, paste, collapse = sep)
+ ret <- paste(ename, itemnames, fullnames, ret, sep = sep)
+ }
+
+ return (ret)
+}
+
+
+# called by lsObj in S4 case
+lsSlots <- function(obj, objname = deparse(substitute(obj)), ename, sep = ",") {
+ itemnames <- fullnames <- slotNames(obj);
+ nsx <- itemnames != make.names(itemnames)
+ itemnames[nsx] <- paste("`", itemnames[nsx], "`", sep = "")
+ fullnames <- paste (objname, "@", itemnames, sep = "")
+ ret <- c()
+
+ for (i in itemnames) {
+ x <- slot(obj, i)
+ lang <- is.language(x)
+ o.class <- class(x)[1]
+ o.mode <- mode(x)
+
+ d <- dim(x)
+ if (is.null(d)) d <- length(x)
+ pos.length <- sum(d) != 0
+
+ ret <- append(ret,
+ paste(paste(d, collapse="x"),
+ o.class,
+ o.mode,
+ is.function(x) || (is.recursive(x) && !lang && pos.length),
+ sep = sep)
+ )
+ }
+
+ if (is.na(sep)) {
+ ret <- data.frame(ename, itemnames, fullnames, ret)
+ names(ret) <- c("Environment", "Name", "Full name", "Dims/default value", "Class", "Mode", "Recursive")
+ } else {
+ ret <- apply(ret, 1, paste, collapse = sep)
+ ret <- paste(ename, itemnames, fullnames, ret, sep = sep)
+ }
+ return(ret)
+}
Modified: pkg/svMisc/R/objList.R
===================================================================
--- pkg/svMisc/R/objList.R 2009-01-12 09:49:58 UTC (rev 88)
+++ pkg/svMisc/R/objList.R 2009-01-12 13:57:36 UTC (rev 89)
@@ -1,42 +1,36 @@
+`objList` <- function(id = "default", envir = .GlobalEnv, object = "", all.names = FALSE,
+pattern = "", group = "", all.info = FALSE, sep = "\t", path = NULL, compare = TRUE) {
-NOTHING <- data.frame( Envir=character(), Name=character(), Dims=character(),
- Group=character(), Class = character(), Recursive = logical(),
- stringsAsFactors=FALSE)
-class( NOTHING ) <- c( "objList", "data.frame" )
+ # Empty result. Change back to data frame?
+ Nothing <- structure(NULL, class = c("objList", "NULL"))
-"objList" <- function(id = "default", envir = .GlobalEnv, object = "", all.names = FALSE,
-pattern = "", group = "", all.info = FALSE, path = NULL, compare = TRUE) {
+ # Make sure that id is character
+ id <- as.character(id)[1]
+ if (id == "") id <- "default"
- # 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 <- envir[1]
if( is.numeric(envir) ){
- ename <- search( envir[1] )
- envir <- as.environment( envir[1] )
+ ename <- search( )[envir]
+ envir <- as.environment( envir )
} else if( is.character( envir ) ){
- envir <- as.environment( match( ename <- envir[1], search() ) )
+ envir <- as.environment( match( ename <- envir, search() ) )
} else {
- return( NOTHING )
+ return(Nothing)
}
} else{
ename <- deparse( substitute( envir ) )
}
-
+
# Get the list of objects in this environment
Items <- ls(envir=envir, all.names = all.names, pattern = pattern)
if (length(Items) == 0) {
- if (all.info) {
- return(NOTHING)
- } else {
- return(NOTHING[,-1])
- }
+ return(Nothing)
}
-
+
# Get characteristics of all objects
- "describe" <- function(name, envir=.GlobalEnv, all.info = FALSE) {
+ `describe` <- function(name, all.info = FALSE) {
# get a vector with five items:
# Name, Dims, Group, Class and Recursive
obj <- envir[[ name ]]
@@ -46,12 +40,11 @@
Group = typeof(obj),
Class = class(obj)[1],
Recursive = !inherits(obj, "function") && is.recursive(obj))
- if (all.info) res <- c(Envir = as.character(envir), res)
+ if (all.info) res <- c(Envir = ename, res)
return(res)
}
- res <- data.frame(t(sapply(Items, describe, envir = envir,
- all.info = all.info)), stringsAsFactors = FALSE)
-
+ res <- data.frame(t(sapply(Items, describe, all.info = all.info)), stringsAsFactors = FALSE)
+
# Recalculate groups into meaningful ones for the object explorer
# 1) Correspondance of typeof() and group depicted in the browser
GrpTable <- c(
@@ -66,34 +59,34 @@
"logical", "integer", "double", "complex", "character",
"...", "any", "expression", "list", "bytecode",
"S4", "weakref", "raw", "externalptr")
- Groups <- GrpTable[res$Group]
-
+ Groups <- GrpTable[res$Group]
+
# 2) All Groups not being language, function or S4 whose class is
# different than typeof are flagged as S3 objects
Filter <- !(Groups %in% c("language", "function", "S4"))
Groups[Filter][res$Group[Filter] != res$Class[Filter]] <- "S3"
-
+
# 3) Special case for typeof = double and class = numeric
Groups[res$Group == "double"] <- "numeric"
-
+
# 4) integers of class factor become factor in group
Groups[res$Class == "factor"] <- "factor"
-
+
# 5) Objects of class 'data.frame' are also group 'data.frame'
Groups[res$Class == "data.frame"] <- "data.frame"
-
+
# 6) Objects of class 'Date' or 'POSIXt' are of group 'DateTime'
Groups[res$Class == "Date"] <- "DateTime"
Groups[res$Class == "POSIXt"] <- "DateTime"
-
+
# Reaffect groups
res$Group <- Groups
-
+
# Possibly filter according to group
if (!is.null(group) && group != "") res <- res[Groups == group, ]
-
+
class( res ) <- c( "objList", "data.frame" )
-
+
# Determine if it is required to refresh something
Changed <- TRUE
if (compare) {
@@ -104,9 +97,12 @@
assignTemp(".guiObjListCache", allList)
}
}
-
+
if (is.null(path)) { # Return results or "" if not changed
- if (Changed) return(invisible(res)) else return(invisible(NOTHING))
+ if (Changed)
+ return(res)
+ else
+ return(Nothing)
} else if (Changed) { # Write to files in this path
# Create file names
ListF <- file.path(path, paste("List_", id, ".txt", sep = ""))
@@ -118,19 +114,22 @@
cat("pattern=", pattern, "\n", sep = "", file = ParsF, append = TRUE)
cat("group=", group, "\n", sep = "", file = ParsF, append = TRUE)
return(invisible(ListF))
- } else return(invisible(FALSE)) # Not changed
+ } else
+ return(Nothing) # Not changed
}
-print.objList <- function( x, sep="\t", ...){
- if( is.null(sep) ){
- NextMethod( "print" )
- } else {
- if( !is.null(nrow(x)) && nrow(x) > 0 ){
- out <- apply( x, 1, paste, collapse = sep )
- out
- } else{
- ""
+
+
+`print.objList` <- function(x, sep = "\t", sep2 = "\n", ...){
+ if (!is.null(x)) {
+ if( is.null(sep) ) {
+ NextMethod( "print" )
+ } else if( !is.null(nrow(x)) && nrow(x) > 0 ){
+ out <- apply(x, 1, paste, collapse=sep)
+ cat(out, sep = sep2)
}
+ } else {
+ cat()
}
}
Added: pkg/svMisc/man/lsObj.Rd
===================================================================
--- pkg/svMisc/man/lsObj.Rd (rev 0)
+++ pkg/svMisc/man/lsObj.Rd 2009-01-12 13:57:36 UTC (rev 89)
@@ -0,0 +1,31 @@
+\name{lsObj}
+\alias{lsObj}
+\encoding{utf-8}
+
+
+\title{ R object component browser helper functions }
+\description{
+ This function is not intended to be used at the command line (except for
+ debugging purposes). It executes a command string to a (compatible) GUI client.
+}
+\usage{
+lsObj (objname, envir = .GlobalEnv, sep = ",")
+}
+
+\arguments{
+ \item{objname}{ name of the object as character string }
+ \item{envir} {an environment, or the name of the environment, or the position in the search() path}
+ \item{sep}{ a character string to separate the items. If set to NA, a data frame is returned}
+}
+
+\value{
+ For each element in object \dQuote{objname} (or argument, if object was function), following values are returned: an environment, name, full name (of type i.e. \code{object$name}, \code{object$name} for S4 objects slots or\code{formals(object)$name} for function arguments), dimensions or default value (arguments), class, mode, logical - is component recursive?.\cr
+ If \code{sep} is NA, a data frame is returned, otherwise a character vector with values separated with \code{sep}.
+}
+
+
+\author{Kamil Bartoń (\email{kbarton at zbs.bialowieza.pl})}
+
+\seealso{ \code{\link{objList}} }
+
+\keyword{misc}
Modified: pkg/svMisc/man/objBrowse.Rd
===================================================================
--- pkg/svMisc/man/objBrowse.Rd 2009-01-12 09:49:58 UTC (rev 88)
+++ pkg/svMisc/man/objBrowse.Rd 2009-01-12 13:57:36 UTC (rev 89)
@@ -6,6 +6,7 @@
\alias{objList}
\alias{objMenu}
\alias{objSearch}
+\alias{print.objList}
\title{ Functions to implement an object browser }
\description{
@@ -21,10 +22,15 @@
objInfo(id = "default", envir = .GlobalEnv, object = "", path = NULL)
objList(id = "default", envir = .GlobalEnv, object = "", all.names = FALSE,
pattern = "", group = "", all.info = FALSE, sep = "\t", path = NULL,
- compare = TRUE)
+ compare = TRUE)
+
+
objMenu(id = "default", envir = .GlobalEnv, objects = "", sep = "\t",
path = NULL)
objSearch(sep = "\t", path = NULL, compare = TRUE)
+
+print.objList(x, sep="\t", sep2 = "\n", ...)
+
}
\arguments{
@@ -36,7 +42,6 @@
with '.')? }
\item{pattern}{ A pattern to match for selecting variables }
\item{group}{ A group to filter }
- \item{sep}{ Separator to use between items in the file (if path is not NULL) }
\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
data to your GUI client by mean of a file }
@@ -47,7 +52,12 @@
not (by default) }
\item{compare}{ If \code{compare == 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{sep2} {Separator to use between object entries}
+ \item{\dots} {further arguments, not used.}
}
+
\details{
\code{objBrowse()} does the horsework. \code{objDir()} gets the temporary directory
where exchange files are stored, in case you exchange data through files.
@@ -59,6 +69,7 @@
\code{objInfo()} computes a tooltip info for a given object.
\code{objMenu()} computes a context menu for selected object(s) in the object
explorer managed by the GUI client.
+ \code{print.objList()} print method for \code{objList} objects.
}
\value{
Depending on the function, a list, a string, a reference to an external,
More information about the Sciviews-commits
mailing list