[Sciviews-commits] r457 - in pkg: SciViews SciViews/R SciViews/inst/doc svUnit/inst/doc
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 24 08:35:42 CET 2012
Author: phgrosjean
Date: 2012-03-24 08:35:42 +0100 (Sat, 24 Mar 2012)
New Revision: 457
Added:
pkg/SciViews/R/misc.R
pkg/SciViews/inst/doc/introduction.lyx
Removed:
pkg/SciViews/inst/doc/WhySciViews.lyx
Modified:
pkg/SciViews/DESCRIPTION
pkg/SciViews/NAMESPACE
pkg/SciViews/NEWS
pkg/SciViews/R/SciViews-internal.R
pkg/SciViews/R/character.R
pkg/SciViews/R/file.R
pkg/SciViews/R/pcomp.R
pkg/SciViews/TODO
pkg/SciViews/inst/doc/correlation.lyx
pkg/SciViews/inst/doc/pca.lyx
pkg/svUnit/inst/doc/svUnit.Rnw
pkg/svUnit/inst/doc/svUnit.lyx
Log:
Various additions to SciViews package
Modified: pkg/SciViews/DESCRIPTION
===================================================================
--- pkg/SciViews/DESCRIPTION 2012-03-04 22:36:41 UTC (rev 456)
+++ pkg/SciViews/DESCRIPTION 2012-03-24 07:35:42 UTC (rev 457)
@@ -1,12 +1,12 @@
Package: SciViews
Type: Package
Title: SciViews GUI API - Main package
-Imports: ellipse
-Depends: R (>= 2.6.0), stats, grDevices, graphics, MASS
+Imports: ellipse, data.table
+Depends: R (>= 2.6.0), methods, grDevices, graphics, stats, MASS
Enhances: base, stats
Description: Functions to install SciViews additions to R, and more (various) tools
-Version: 0.9-5
-Date: 2011-11-28
+Version: 0.9-6
+Date: 2012-03-21
Author: Philippe Grosjean
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: GPL-2
Modified: pkg/SciViews/NAMESPACE
===================================================================
--- pkg/SciViews/NAMESPACE 2012-03-04 22:36:41 UTC (rev 456)
+++ pkg/SciViews/NAMESPACE 2012-03-24 07:35:42 UTC (rev 457)
@@ -1,6 +1,97 @@
-import(stats, grDevices, graphics, MASS, ellipse)
+import(methods, grDevices, graphics, stats, MASS, ellipse, data.table)
-export(correlation,
+export(cEscape,
+ cExpand,
+ cFind,
+ cFindAll,
+ cFold,
+ cHeight,
+ cLower,
+ cMatch,
+ cSearch,
+ cSplit,
+ cSub,
+ "cSub<-",
+ cRep,
+ cRepAll,
+ cTrans,
+ cTrim,
+ cTrimL,
+ cTrimR,
+ cTrunc,
+ cUpper,
+ cWidth,
+ cWrap,
+ p,
+ p_,
+ ct,
+ cta,
+ ct_,
+ cta_,
+ encodingToNative,
+ encodingToUTF8,
+ encoding,
+ "encoding<-",
+ as.integerBase,
+ rx,
+ rxFind,
+ rxFindAll,
+ rxSearch,
+ rxSplit,
+ rxRep,
+ rxRepAll,
+ path,
+ as.path,
+ is.path,
+ isDir,
+ isFile,
+ fileAccess,
+ fileAppend,
+ fileChmod,
+ fileCopy,
+ fileCreate,
+ fileDelete,
+ fileDir,
+ fileExists,
+ fileExpand,
+ fileFind,
+ fileInfo,
+ fileLink,
+ fileList,
+ fileListGlob,
+ fileName,
+ fileNormalize,
+ filePackage,
+ fileReadLink,
+ fileRemove,
+ fileRename,
+ fileShow,
+ fileSymlink,
+ fileTemp,
+ dirCreate,
+ dirList,
+ dirR,
+ dirTemp,
+ sdir,
+ wdir,
+ valid,
+ ifValid,
+ ifElse,
+ newEnv,
+ names,
+ l,
+ nc,
+ nr,
+ "@",
+ "@<-",
+ "@:=",
+ ":=",
+ "%:%",
+ "%else%",
+ package,
+ enum,
+ timing,
+ correlation,
is.correlation,
as.correlation,
cwm.colors,
@@ -23,6 +114,10 @@
scores,
vectorplot)
+S3method(print, path)
+
+S3method(valid, default)
+
S3method(vectorplot, default)
S3method(vectorplot, loadings)
S3method(vectorplot, correlation)
Modified: pkg/SciViews/NEWS
===================================================================
--- pkg/SciViews/NEWS 2012-03-04 22:36:41 UTC (rev 456)
+++ pkg/SciViews/NEWS 2012-03-24 07:35:42 UTC (rev 457)
@@ -1,5 +1,19 @@
= SciViews News
+== SciViews version 0.9-6
+
+* Added further (misc) functions.
+
+* New syntax using x at attr for attributes, plus := for replacement by reference
+ inspired from data.table package, which Sciviews now imports too.
+
+
+== SciViews version 0.9-5
+
+* Added functions to homogenize function names for strings and files
+ manipulations.
+
+
== SciViews version 0.9-4
* The gamma argument in hsv() function disappears in R 2.14.0. As a consequence,
Modified: pkg/SciViews/R/SciViews-internal.R
===================================================================
--- pkg/SciViews/R/SciViews-internal.R 2012-03-04 22:36:41 UTC (rev 456)
+++ pkg/SciViews/R/SciViews-internal.R 2012-03-24 07:35:42 UTC (rev 457)
@@ -18,3 +18,44 @@
}
.packageName <- "SciViews"
+
+## Rethink this first before making this public
+.subclass <- function (x, class, superclasses = NULL)
+{
+ ## TODO: check this is an S3 object that inherits from the given class(es)
+ if (!is.null(superclasses)) {
+ misClass <- inherits(x, as.character(superclasses), which = TRUE) == 0
+ if (any(misClass))
+ stop("'x' does not inherits from", paste(superclasses[misClass],
+ collapse = ", "))
+ }
+ ## Check if new class in not already defined
+ if (class %in% class(x)) return(x)
+ ## Prepend that class
+ class(x) <- c(class, class(x))
+ return(x)
+}
+
+`.subclass<-` <- function (x, value)
+{
+ if (!value %in% class(x)) class(x) <- c(value, class(x))
+ return(x)
+}
+
+## Code borrowed from svMisc, to avoid a dependency!
+.TempEnv <- function ()
+{
+ pos <- match("TempEnv", search())
+ if (is.na(pos)) { # Must create it
+ TempEnv <- list()
+ attach(TempEnv, pos = length(search()) - 1)
+ rm(TempEnv)
+ pos <- match("TempEnv", search())
+ }
+ return(pos.to.env(pos))
+}
+
+.assignTemp <- function (x, value, replace.existing = TRUE)
+ if (isTRUE(replace.existing) || !exists(x, envir = .TempEnv(), mode = "any",
+ inherits = FALSE))
+ assign(x, value, envir = .TempEnv())
Modified: pkg/SciViews/R/character.R
===================================================================
--- pkg/SciViews/R/character.R 2012-03-04 22:36:41 UTC (rev 456)
+++ pkg/SciViews/R/character.R 2012-03-24 07:35:42 UTC (rev 457)
@@ -1,6 +1,7 @@
## Essentially a series of base R function that manipulate character strings
## and that are renamed/rationalized for facility
## TODO: deal with zero length strings and NAs appropriately in all functions
+## TODO: make.names, make.unique, Sys.setFileTime => fileTime, Sys.umask
## Count the number of characters
## No: make an exception: after n (or nz) do not use uppercase!
@@ -8,17 +9,17 @@
#nzChar <- nzchar
## Format character strings
-strEscape <- encodeString
-strWrap <- strwrap
-# Add strPad => pad a string left/right or both or Padb/Padl/Padr?
+cEscape <- encodeString
+cWrap <- strwrap
+# Add cPad => pad a string left/right or both or Pad/PadL/PadR?
#+sprintf/gettextf?
-## String find/replace using fixed pattern (str*) or regular expressions (reg*)
+## String find/replace using fixed pattern (char*) or regular expressions (rx*)
## TODO: a rx object which prints an example of its work! => fine-tune it
## to make it easy to experiment with the rx object
rx <- glob2rx
-strFind <- function (x, pattern, ignore.case = FALSE,
+cSearch <- function (x, pattern, ignore.case = FALSE,
type = c("logical", "position", "value"), ...) # ... for useBytes
{
type <- pmatch(type)
@@ -33,8 +34,8 @@
return(res)
}
-rxFind <- function (x, pattern, ignore.case = FALSE, max.distance = 0,
-type = c("logical", "position", "value"), ...) # ... for perl & useBytes
+rxSearch <- function (x, pattern, ignore.case = FALSE, max.distance = 0,
+type = c("logical", "position", "value"), ...) # ... for Perl & useBytes
{
type <- pmatch(type)
## If max.distance > 0, use approximate search
@@ -61,53 +62,54 @@
return(res)
}
-strSearch <- function (x, pattern, ignore.case = FALSE, ...) # ... for useBytes
+## Inconsistencies: regexpr(pattern, text, ...) and strsplit(x, xplit, ...)
+cFind <- function (x, pattern, ignore.case = FALSE, ...) # ... for useBytes
return(regexpr(pattern, text = x, ignore.case = ignore.case, fixed = TRUE,
...))
-rxSearch <- function (x, pattern, ignore.case = FALSE, ...) # ... for perl & useBytes
+rxFind <- function (x, pattern, ignore.case = FALSE, ...) # ... for perl & useBytes
return(regexpr(pattern, text = x, ignore.case = ignore.case, fixed = FALSE,
...))
-strSearchAll <- function (x, pattern, ignore.case = FALSE, ...) # ... for useBytes
+cFindAll <- function (x, pattern, ignore.case = FALSE, ...) # ... for useBytes
return(gregexpr(pattern, text = x, ignore.case = ignore.case, fixed = TRUE,
...))
-rxSearchAll <- function (x, pattern, ignore.case = FALSE, ...) # ... for perl & useBytes
+rxFindAll <- function (x, pattern, ignore.case = FALSE, ...) # ... for perl & useBytes
return(gregexpr(pattern, text = x, ignore.case = ignore.case, fixed = FALSE,
...))
-strReplace <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for useBytes
+cRep <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for useBytes
return(sub(pattern, replacement, x, ignore.case = ignore.case, fixed = TRUE,
...))
-rxReplace <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for perl & useBytes
+rxRep <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for Perl & useBytes
return(sub(pattern, replacement, x, ignore.case = ignore.case, fixed = FALSE,
...))
-strReplAll <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for useBytes
+cRepAll <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for useBytes
return(gsub(pattern, replacement, x, ignore.case = ignore.case, fixed = TRUE,
...))
-rxReplAll <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for perl & useBytes
+rxRepAll <- function (x, pattern, replacement, ignore.case = FALSE, ...) # ... for Perl & useBytes
return(gsub(pattern, replacement, x, ignore.case = ignore.case, fixed = FALSE,
...))
## Substrings
-strSplit <- function (x, pattern, ...) # for useBytes
+cSplit <- function (x, pattern, ...) # ... for useBytes
return(strsplit(x, split = pattern, fixed = TRUE, ...))
rxSplit <- function (x, pattern, ...) # for perl & useBytes
return(strsplit(x, split = pattern, fixed = FALSE, ...))
-strSub <- substr
-`strSub<-` <- `substr<-`
-strTrunc <- strtrim ## This indeed truncs strings!!!
+cSub <- substr
+`cSub<-` <- `substr<-`
+cTrunc <- strtrim ## This indeed truncs strings!!!
## paste() is rather long name, in comparison with, e.g., c().
## Also the default argument of sep = " " is irritating and is not consistent
-## with stop() or warning() for instance.
+## with stop() or warning() for instance, that use sep = "".
## Thus, we define:
p <- function (..., sep = "", collapse = NULL)
.Internal(paste(list(...), sep, collapse))
@@ -139,33 +141,33 @@
append = TRUE))
-strTrimb <- function (x, all.spaces = FALSE) # Trim both sides
+cTrim <- function (x, all.spaces = FALSE) # Trim both sides
{
pat <- (if (isTRUE(all.spaces)) "[[:space:]]+" else "[[:blank:]]+")
## Trim left first
- x <- strReplace(p("^", pat), "", x)
+ x <- cRep(p("^", pat), "", x)
## ... then trim right
- return(strReplace(p(pat, "$"), "", x))
+ return(cRep(p(pat, "$"), "", x))
}
-strTriml <- function (x, all.spaces = FALSE) # Trim left-side only
+cTrimL <- function (x, all.spaces = FALSE) # Trim left-side only
{
- pat <- (if (is.TRUE(all.spaces)) "^[[:space:]]+" else "^[[:blank:]]+")
- return(strReplace(pat, "", x))
+ pat <- (if (isTRUE(all.spaces)) "^[[:space:]]+" else "^[[:blank:]]+")
+ return(cRep(pat, "", x))
}
-strTrimr <- function (x, all.spaces = FALSE) # Trim right-side only
+cTrimR <- function (x, all.spaces = FALSE) # Trim right-side only
{
- pat <- (if (is.TRUE(all.space)) "[[:space:]]+$" else "[[:blank:]]+$")
- return(strReplace(pat, "", x))
+ pat <- (if (isTRUE(all.spaces)) "[[:space:]]+$" else "[[:blank:]]+$")
+ return(cRep(pat, "", x))
}
## Change case and translate
-strTr <- chartr
-strCaseFold <- casefold
-strLower <- tolower
-strUpper <- toupper
+cTrans <- chartr
+cFold <- casefold
+cLower <- tolower
+cUpper <- toupper
## Character encoding
encodingToNative <- enc2native
@@ -174,154 +176,28 @@
`encoding<-` <- `Encoding<-`
## Measure size of a string (package graphics)
-strHeight <- strheight
-strWidth <- strwidth
+cHeight <- strheight
+cWidth <- strwidth
## Match and expand character strings to a list of items
-strExpand <- char.expand
-strMatch <- charmatch
+cExpand <- char.expand
+cMatch <- charmatch
# What to do with pmatch()???
-## Conversion to character string
+## Conversion to character string... no change required
#as.character
# To avoid using strtoi(), we prefer as.integerBase (because as.integer cannot
# be converted into a generic function, because it is a primitive!)
-#strToInt <- strtoi # Allows to choose the base used for char representation
+#charToInt <- strtoi # Allows to choose the base used for char representation
as.integerBase <- strtoi
+## Define a function that takes: singular/plural msg and a vector of strings
+## and construct a single string with:
+## singular msg: single item
+## or
+## plural msg: item1, item2, ..., itemN
#+paste = cChar? + my special character string manipulation functions?
-# is.wholenumber(), see ?as.integer => define isWholeInt?
-## This should be nice:
-## Define a valid method to be applied to S3 objects to make sure they are
-## correct
-valid <- function (object, ...)
- UseMethod("valid")
-
-valid.default <- function (object, ...)
- return(object)
+#sAbbreviate <- abbreviate
-ifIs <- function (x, what, yes = valid(x),
-no = stop("need a ", what, " object"))
- return(if (inherits(x, what)) yes else no)
-
-ifElse <- ifelse
-
-## This is useful to get something similar to df$var or obj at slot
-## TODO: how to solve the case ll%a%metadata$OK for metadata being a list?
-`%a%` <- function (x, which)
- return(attr(x, deparse(substitute(which)), exact = FALSE))
-
-`%a%<-` <- function (x, which, value)
- return(`attr<-`(x, deparse(substitute(which)), value))
-
-## To be consistent with the other extraction functions:
-a <- function (x, which, exact = TRUE)
- return(attr(x, which, exact))
-
-## Environments management
-## Usually, to create an object, we use its name, but
-## environment() means something else here!
-## So, OK, we'll stick with
-newEnv <- new.env
-## for the moment...
-## Now, we want to be able to use names() on it too!
-## Note that for environments, we got items by alphabetic order
-## => not exactly the same as for vector, list, or so!
-names <- function (x)
- if (inherits(x, "environment")) ls(x, all = TRUE) else base::names(x)
-## Do we implement `names<-` for environments???
-
-## A more convenient setwd()/getwd() using objects
-wdir <- function (dir = NULL)
-{
- if (is.null(dir)) {
- dir <- getwd()
- class(dir) <- c("filename", "character")
- ## Make sure to use /, even under Windows
- dir <- gsub("\\\\", "/", dir)
- return(dir)
- } else { # Change current working directory
- owdir <- setwd(dir)
- ## Make sure to use /, even under Windows
- owdir <- gsub("\\\\", "/", owdir)
- class(owdir) <- c("filename", "character")
- ## Save old working directory
- .owdir <<- owdir
- return(owdir)
- }
-}
-
-## Get or set session dir
-sdir <- function (dir = NULL)
-{
- if (is.null(dir)) {
- dir <- getOption("R.initdir")
- if (is.null(dir)) return(NULL)
- class(dir) <- c("filename", "character")
- ## Make sure to use /, even under Windows
- dir <- gsub("\\\\", "/", dir)
- return(dir)
- } else { # Change current session directory
- osdir <- getOption("R.initdir")
- ## TODO: make sure to do everything required to cleanly close current
- ## session!
- dir <- gsub("\\\\", "/", dir)
- options(R.initdir = dir)
- ## TODO: make everything we need to open the new session directory
- ## Make sure to use /, even under Windows
- osdir <- gsub("\\\\", "/", osdir)
- class(osdir) <- c("filename", "character")
- ## Save old session directory
- .osdir <<- osdir
- return(osdir)
- }
-}
-
-
-subclass <- function (x, class, superclasses = NULL)
-{
- ## TODO: check this is an S3 object that inherits from the gicven class(es)
- if (!is.null(superclasses)) {
- misClass <- inherits(x, as.character(superclasses), which = TRUE) == 0
- if (any(misClass))
- stop("'x' soes not inherits from", paste(superclasses[misClass],
- collapse = ", "))
- }
- ## Check if new class in not already defined
- if (class %in% class(x)) return(x)
- ## Prepend that class
- class(x) <- c(class, class(x))
- return(x)
-}
-
-`subclass<-` <- function (x, value)
-{
- if (!value %in% class(x)) class(x) <- c(value, class(x))
- return(x)
-}
-
-filename <- function (...)
-{
- ## Create a vector of filename objects inheriting from character
- return(subclass(as.character(c(...)), "filename"))
-}
-
-print.filename <- function (x, ...)
-{
- path <- as.character(x)
- path <- gsub("\\\\", "/", path)
- ## Make sure paths are ended with / to differentiate them from files
- isdir <- file.info(path)$isdir
- ## Non-existent files are these ones
- nofile <- is.na(isdir)
- path[nofile] <- paste(path[nofile], "*", sep = "")
- ## These are directories
- isdir <- (isdir & !grepl("/$", path))
- isdir[is.na(isdir)] <- FALSE
- path[isdir] <- paste(path[isdir], "/", sep = "")
- ## Print it
- print(noquote(paste("<", path, ">", sep = "")))
- return(invisible(x))
-}
Modified: pkg/SciViews/R/file.R
===================================================================
--- pkg/SciViews/R/file.R 2012-03-04 22:36:41 UTC (rev 456)
+++ pkg/SciViews/R/file.R 2012-03-24 07:35:42 UTC (rev 457)
@@ -1,37 +1,19 @@
## Essentially a series of base R function that manipulate files and directories
## and that are renamed/rationalized for facility
-subclass <- function (x, class, superclasses = NULL)
-{
- ## TODO: check this is an S3 object that inherits from the gicven class(es)
- if (!is.null(superclasses)) {
- misClass <- inherits(x, as.character(superclasses), which = TRUE) == 0
- if (any(misClass))
- stop("'x' soes not inherits from", paste(superclasses[misClass],
- collapse = ", "))
- }
- ## Check if new class in not already defined
- if (class %in% class(x)) return(x)
- ## Prepend that class
- class(x) <- c(class, class(x))
- return(x)
-}
-
-`subclass<-` <- function (x, value)
-{
- if (!value %in% class(x)) class(x) <- c(value, class(x))
- return(x)
-}
-
## A replacement for file.path
-filePath <- function (..., fsep = .Platform$file.sep)
+path <- function (..., fsep = .Platform$file.sep)
{
- ## Create a filePath objects inheriting from character
+ ## Create a path objects inheriting from character
return(structure(.Internal(file.path(list(...), fsep)),
- class = c("filePath", "character")))
+ class = c("path", "character")))
}
-print.filePath <- function (x, ...)
+## The print function of filename separates dirs (ending with /) from files
+## and also indicate which file already exists on disk or not
+## EXPRERIMENTAL FEATURE... Should require an option to activate/inactivate
+## test of files on disk!
+print.path <- function (x, ...)
{
path <- as.character(x)
path <- gsub("\\\\", "/", path)
@@ -49,75 +31,111 @@
return(invisible(x))
}
-## Rework file paths
+as.path <- function (x, ...)
+ return(structure(as.character(x), class = c("path", "character")))
+
+is.path <- function (x)
+ return(inherits(x, "path"))
+
+isDir <- function (path)
+ return(file.info(path)$isdir)
+
+isFile <- function (path)
+ return(file.exists(path) & !file.info(path)$isdir)
+
+## Rework paths
## basename
fileName <- function (path)
- return(structure(basename(path), class = c("filePath", "character")))
+ return(structure(basename(path), class = c("path", "character")))
## dirname
fileDir <- function (path)
- return(structure(dirname(path), class = c("filePath", "character")))
+ return(structure(dirname(path), class = c("path", "character")))
## path.expand
fileExpand <- function (path)
- return(structure(path.expand(path), class = c("filePath", "character")))
+ return(structure(path.expand(path), class = c("path", "character")))
## normalizePath
fileNormalize <- function (path, mustWork = FALSE)
return(structure(normalizePath(path, winslash = "/", mustWork = mustWork),
- class = c("filePath", "character")))
+ class = c("path", "character")))
## Get various files or directories
## R.home
dirR <- function (component = "home")
- return(structure(R.home(component), class = c("filePath", "character")))
-
+ return(structure(R.home(component), class = c("path", "character")))
+
+## TODO: find.package() and path.package()
## system.file TODO: case it returns ""! And should we use mustWork?
filePackage <- function (..., package = "base", lib.loc = NULL, mustWork = FALSE)
return(structure(system.file(..., package = package, lib.loc = lib.loc,
- mustWork = mustWork), class = c("filePath", "character")))
+ mustWork = mustWork), class = c("path", "character")))
## tempdir
dirTemp <- function ()
- return(structure(.Internal(tempdir()), class = c("filePath", "character")))
+ return(structure(.Internal(tempdir()), class = c("path", "character")))
## tempfile
fileTemp <- function (pattern = "file", tmpdir = tempdir(), fileext = "")
return(structure(.Internal(tempfile(pattern, tmpdir, fileext)),
- class = c("filePath", "character")))
+ class = c("path", "character")))
-## Sys.which, TODO: keep names and display them in print.filePath objects!
+## Sys.which, TODO: keep names and display them in print.path objects!
fileFind <- function (names)
- return(structure(Sys.which(names), class = c("filePath", "character")))
+ return(structure(Sys.which(names), names = names, class = c("path", "character")))
+## List dirs = dir() = list.dirs()
+dirList <- function (path = ".", full.names = TRUE, recursive = TRUE)
+ return(structure(list.dirs(path = path, full.names = full.names,
+ recursive = recursive), class = c("path", "character")))
-#dirList <- dir
-#dirList <- list.dirs
-#fileList <- list.files
-#dirCreate <- dir.create
-#fileAccess <- file.access
-#fileAppend <- file.append
+## List files = dir() and list.files()
+fileList <- function (path = ".", pattern = NULL, all.files = FALSE,
+full.names = FALSE, recursive = FALSE, ignore.case = FALSE, include.dirs = FALSE)
+ return(structure(dir(path = path, pattern = pattern, all.files = all.files,
+ full.names = full.names, recursive = recursive,
+ ignore.case = ignore.case, include.dirs = include.dirs),
+ class = c("path", "character")))
+
+## List files using wildcard expansion ('globbing')
+fileListGlob <- function (path, dir.mark = FALSE)
+ return(structure(Sys.glob(paths = path, dirmark = dir.mark),
+ class = c("path", "character")))
+
+## Various file manipulation functions that do not return a path object
+## (just homogenize the name...)
+dirCreate <- dir.create
+fileAccess <- file.access
+fileAppend <- file.append
+fileRename <- file.rename
+fileCopy <- file.copy
+fileCreate <- file.create
+fileExists <- file.exists
+fileInfo <- file.info
+fileChmod <- Sys.chmod
+fileRemove <- file.remove
+## This is "stronger" than fileRemove()!
+fileDelete <- function (path, recursive = FALSE, force = FALSE)
+ return(unlink(x = path, recursive = recursive, force = force))
+
+fileLink <- file.link
+fileSymlink <- file.symlink
+fileReadLink <- function (path)
+ return(structure(Sys.readlink(paths = path),
+ class = c("path", "character")))
+
+## This is linked to some GUI element, possibly... anyway...
+fileShow <- file.show
+## TODO: this file choose... but this is really for svDialogs (dlgOpen(), dlgSave())
#fileChoose <- file.choose
-#fileCopy <- file.copy
-#fileCreate <- file.create
-#fileExists <- file.exists
-#fileInfo <- file.info
-#fileLink <- file.link
-#fileRemove <- file.remove
-#fileRename <- file.rename
-#fileShow <- file.show
-#fileSymlink <- file.symlink
-#fileChmod <- Sys.chmod
-#fileGlob <- Sys.glob
-#fileUnlink <- unlink
-# = isDir/isFile
## A more convenient setwd()/getwd() using objects
wdir <- function (dir = NULL)
{
if (is.null(dir)) {
dir <- getwd()
- class(dir) <- c("filename", "character")
+ class(dir) <- c("path", "character")
## Make sure to use /, even under Windows
dir <- gsub("\\\\", "/", dir)
return(dir)
@@ -125,9 +143,9 @@
owdir <- setwd(dir)
## Make sure to use /, even under Windows
owdir <- gsub("\\\\", "/", owdir)
- class(owdir) <- c("filename", "character")
+ class(owdir) <- c("path", "character")
## Save old working directory
- .owdir <<- owdir
+ .assignTemp(".owdir", owdir)
return(owdir)
}
}
@@ -138,7 +156,7 @@
if (is.null(dir)) {
dir <- getOption("R.initdir")
if (is.null(dir)) return(NULL)
- class(dir) <- c("filePath", "character")
+ class(dir) <- c("path", "character")
## Make sure to use /, even under Windows
dir <- gsub("\\\\", "/", dir)
return(dir)
@@ -151,9 +169,9 @@
## TODO: make everything we need to open the new session directory
## Make sure to use /, even under Windows
osdir <- gsub("\\\\", "/", osdir)
- class(osdir) <- c("filePath", "character")
+ class(osdir) <- c("path", "character")
## Save old session directory
- .osdir <<- osdir
+ .assignTemp(".osdir", osdir)
return(osdir)
}
}
Added: pkg/SciViews/R/misc.R
===================================================================
--- pkg/SciViews/R/misc.R (rev 0)
+++ pkg/SciViews/R/misc.R 2012-03-24 07:35:42 UTC (rev 457)
@@ -0,0 +1,310 @@
+## A series of functions defined or redefined for a simpler or better use of R
+
+# is.wholenumber(), see ?as.integer => define isWholeInt?
+
+## This should be nice:
+## Define a valid method to be applied to S3 objects to make sure they are
+## correct
+valid <- function (object, ...)
+ UseMethod("valid")
+
+valid.default <- function (object, ...)
+ return(object)
+
+## A concise construct to make shure we return the right object
+ifValid <- function (x, what, is.not = stop("need a ", what, " object"))
+ return(if (inherits(x, what)) valid(x) else is.not)
+# res <- ifValid(obj, "class")
+## or in a function
+# return(ifValid(obj, "class"))
+
+ifElse <- ifelse
+
+`%else%` <- function (test, expr) if (test) return(invisible()) else expr
+## Useful to write shorter code in something like:
+#test %else% break
+#test %else% stop(msg)
+#test %else% return(res)
+
+## TODO: a tryError(), or some other name making basically
+# res <- try(...., silent = TRUE)
+# if (inherits(res, "try-error")) stop(msg)
+
+enum <- seq_along
+
+## Defines only increasing integer sequences
+`%:%` <- function (lower, upper)
+ if (lower > upper) integer(0) else
+ seq.int(from = as.integer(lower), to = as.integer(upper), by = 1L)
+## Useful in:
+# for (ii in 1%:%l(v)) print(v)
+## Because if (!l(v)) => prints nothing! 1:l(v) would give an error in this case
+# for (ii in enum(v) print(v))
+## is fine too!
+
+## A better require()
+package <- function (package, lib.loc = NULL, silent = TRUE, quietly = silent,
+warn.conflicts = silent,
+error = stop("there is no package called '", package, "'"))
+{
+ res <- suppressWarnings(require(package, lib.loc = lib.loc,
+ quietly = quietly, warn.conflicts = warn.conflicts,
+ character.only = TRUE))
+ if (!res) return(error) else return(invisible(res))
+}
+
+## Environments management
+## Usually, to create an object, we use its name, but
+## environment() means something else here!
+## So, OK, we'll stick with
+newEnv <- new.env
+## for the moment...
+
+## Now, we want to be able to use names() on it too!
+## Note that for environments, we got items by alphabetic order
+## => not exactly the same as for vector, list, or so!
+names <- function (x)
+ if (inherits(x, "environment")) ls(x, all = TRUE) else base::names(x)
+## Do we implement `names<-` for environments???
+
+## Simpler names for often used functions
+l <- length
+nc <- NCOL
+nr <- NROW
+
+## Problem of functional language like R: too much copy!
+## For instance, change a simple attribute using attr(x) <- value
+## leads to a copy of the object.... If the object is large, time
+## needed is significant (+ memory wasted!)
+#n <- 1e7
+#x <- double(n)
+## Trace when x is copied
+#tracemem(x)
+#system.time(attr(x, "a") <- 1)
+## There is a copy of the object => sooo, slow!
+
+## Solution: from data.table...
+## 1) setattr() does the same without copying the object
+## but the syntax is not very nice!
+## 2) for data.table[, ....] authors define the `:=` function to
+## "assign by reference", i.e., changing a part of a table without
+## copying the object
+##
+## One could generalize this... plus take advantage of `@` and `@<-` that is
+## not used for S3 objects and of the same precedence as `$` to simplify
+## manipulation of attributes!
+
+## For non S4 objects, reuse @ for attributes!
+## After all, they are, indeed, attributes!
+## Note that we force exact match, less error-prone that the opposite,
+## and same behaviour as @ used for S4 objects!
+## TODO: also use it for S4 object, in the case a slot is not defined
+## TODO: add check argument for `attr<-` too
+## TODO: attrNames() like slotNames()
+## TODO: slots() as a synonym of getSlots() in parallel with attributes()
+## NO: getSlots() does not recover the content, but only the class for each
+## object in slots =< should reallybe called slotClasses()
+## and we need an attrClasses() too!
+`@` <- function (object, name)
+{
+ arg <- substitute(name)
+ if (is.name(arg)) name <- as.character(arg)
+ if (isS4(object)) slot(object, name) else attr(object, name, exact = TRUE)
+}
+
+## Reuse `@<-` to set attribute from a non S4 object
+## TODO: also use it for S4 object, in the case a slot is not defined
+`@<-` <- function (x, which, value)
+{
+ arg <- substitute(which)
+ if (is.name(arg)) which <- as.character(arg)
+ if (isS4(x)) {
+ `slot<-`(x, which, check = TRUE, value)
+ } else {
+ `attr<-`(x, which, value)
+ }
+}
+
+## Define the "replace by reference" function for attributes, here using
+## setattr() from data.table package
+## TODO: we need also something like that for S4 slots!
+## Since they really are attributes with checking, check first, and then,
+## use setattr(), and it is done!
+`@:=` <- function (x, which, value)
+{
+ arg <- substitute(which)
+ if (is.name(arg)) which <- as.character(arg)
+ if (isS4(x)) {
+ ## TODO: we need an assign by reference function for S4 slots here
+ `slot<-`(x, which, TRUE, value)
+ } else {
+ setattr(x, which, value)
+ }
+}
+
+## TODO: `[:=`, `$:=` and `[[:=`
+## This does not work...
+#`[:=` <- `[<-`
+
+## The`:=` function emulates fun(x) <- value, but with a different mechanism
+## that does not imply a copy of x. This is called "replacement by reference"
+## in comparison to the usual "replacement by value". It calls `fun:=`
+## like fun(x) <- value calls `fun<-`
+## TODO: a validation mechanism for the value passed to the function?
+## TODO: use alist() instead of list()!!!
+`:=` <- function (x, value) {
+ call <- match.call()
+ X <- substitute(x)
+ ## pairlist() because NULL would be lost using list()
+ value <- pairlist(value = value)
+ ## In case single name, do the same as x[] <- value, i.e., keeping size
+ ## and attributes of x ("replacement inside x")
+ if (length(X) == 1) {
+# tryCatch(do.call("[<-", c(list(x = X), value), envir = parent.frame(1)),
+# error = function (e) {
+# ## Construct a call that is closer to the actual syntax!
+# e$call <- paste(deparse(call[[2]]), ":=", deparse(call[[3]]))
+# stop(e)
+# })
+ stop(":= cannot be used directly on an object")
+ }
+ ## If a more complex is provided, try to run `fun:=` instead
+ X <- as.pairlist(substitute(X))
+ ## To emulate `fun<-`, but using `fun:=`
+ fun <- paste(deparse(X[[1]]), ":=", sep = "")
+ X[[1]] <- NULL
+ ## Use tryCatch() to ensure a better error message is issued
+ tryCatch(do.call(fun, c(X, value), envir = parent.frame(1)),
+ error = function (e) {
+ ## Construct a call that is closer to the actual syntax!
+ e$call <- paste(deparse(call[[2]]), ":=", deparse(call[[3]]))
+ stop(e)
+ })
+ ## Like for `fun<-`, value is returned invisibly, probably to allow
+ ## something like x <- y[2] <- value
+ return(invisible(value))
+}
+
+## I don't like much system.time(), first because it returns 3 numbers where
+## we want most of the time only one, and second because it creates a new
+## object proc_time, where a difftime object should be perfectly suitable
+## => new function elapsed()
+timing <- function (expr, gc.first = TRUE)
+{
+ res <- system.time(expr, gcFirst = gc.first)
+ ## Results split into result and details
+ details <- as.difftime(res[c("user.self", "sys.self")], units = "secs")
+ details at names := c("user", "system")
+ res <- as.difftime(res["elapsed"], units = "secs")
+ res at details := details
+ return(res)
+}
+## Test...
+#tst <- timing(Sys.sleep(1.5))
+#tst
+#tst at details
+
+## Sys.sleep() -> sleep()... no, because sleep is a dataset!!!
+#wait <- Sys.sleep
+#traceMemory <- tracemem
+## From stats: xxx.test() => give a 'htest' object => htestXxxx()
+#htestT <- t.test
+#htestAnsari <- ansari.test
+#htestBatlett <- bartlett.test
+#htestChisq <- chisq.test
+#htestFisher <- fisher.test
+#htestFligner <- fligner.test
+#htestFriedman <- friedman.test
+#htestKS <- ks.test
+#htestMantelHaenszel <- mantelhaen.test
+#htestMauchly <- mauchly.test
+#htestMcNemar <- mcnemar.test
+#htestMood <- mood.test
+#htestAnovaPower <- power.anova.test
+#htestPropPower <- power.prop.test
+#htestTPower <- power.t.test
+#htestPhillipsPerron <- PP.test
+#htestProp <- prop.test
+#htestPropTrend <- prop.trend.test
+#htestShapiroWilk <- shapiro.test
+
+
+#contrHelmert <- contr.helmert
+#contrPoly <- contr.poly
+#contrSum <- contr.sum
+#contrTreatment <- contr.treatment
+#contrTreatmentL <- contr.SAS
+
+#equal <- all.equal
+#equalA <- attr.all.equal
+
+#baseEnv <- baseenv
+#emptyEnv <- emptyenv
+#globalEnv <- globalEnv
+#parentEnv <- parent.env
+#`parentEnv<-` <- `parent.env<-`
+##TODO: use tempEnv instead of TempEnv?
+
+#evalParent <- eval.parent
+
+#expandGrid <- expand.grid
+
+#gcTiming <- gc.time + return a difftime object
+#gcInfo <- gcinfo
+#gcTorture <- gctorture
+#??? gcTorture2 <- gctorture2
+
+#inverseRle <- inverse.rle or rleInverse?
+
+#isAtomic <- is.atomic
+#isCall <- is.call??
+#isElement <- is.element
+#?isExpression??
+#isFinite <- is.finite
+#isLanguage <- is.language
+#isLoaded <- is.loaded
+#isNA <- is.na
+#isNaN <- is.nan
+#isNULL <- is.null
+#isR <- is.R
+#isRecursive <- is.recursive
+#isSymbol <- is.symbol
+#isUnsorted <- is.unsorted
+#isVector <- is.vector
+#isTTY <- isatty
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 457
More information about the Sciviews-commits
mailing list