[Sciviews-commits] r288 - in pkg/svMisc: . R inst inst/unitTests man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Sep 6 18:28:53 CEST 2010
Author: phgrosjean
Date: 2010-09-06 18:28:53 +0200 (Mon, 06 Sep 2010)
New Revision: 288
Added:
pkg/svMisc/R/parseText.R
pkg/svMisc/R/rjson.R
pkg/svMisc/R/sourceClipboard.R
pkg/svMisc/inst/unitTests/
pkg/svMisc/inst/unitTests/.DS_Store
pkg/svMisc/inst/unitTests/runitsvMisc.R
pkg/svMisc/man/Parse-deprecated.Rd
pkg/svMisc/man/clipsource-deprecated.Rd
pkg/svMisc/man/parseText.Rd
pkg/svMisc/man/rjson.Rd
pkg/svMisc/man/sourceClipboard.Rd
pkg/svMisc/man/svMisc-package.Rd
pkg/svMisc/man/unitTests.svMisc.Rd
Removed:
pkg/svMisc/R/Parse.R
pkg/svMisc/R/clipsource.R
pkg/svMisc/man/Parse.Rd
pkg/svMisc/man/clipsource.Rd
Modified:
pkg/svMisc/DESCRIPTION
pkg/svMisc/NAMESPACE
pkg/svMisc/NEWS
pkg/svMisc/R/Sys.tempdir.R
pkg/svMisc/R/Sys.userdir.R
pkg/svMisc/R/TempEnv.R
pkg/svMisc/R/addTemp.R
pkg/svMisc/R/assignTemp.R
pkg/svMisc/R/captureAll.R
pkg/svMisc/R/changeTemp.R
pkg/svMisc/R/compareRVersion.R
pkg/svMisc/R/existsTemp.R
pkg/svMisc/R/getTemp.R
pkg/svMisc/R/isAqua.R
pkg/svMisc/R/isMac.R
pkg/svMisc/R/isRgui.R
pkg/svMisc/R/isSDI.R
pkg/svMisc/R/isWin.R
pkg/svMisc/R/rmTemp.R
pkg/svMisc/R/svMisc-internal.R
pkg/svMisc/R/tempvar.R
pkg/svMisc/TODO
pkg/svMisc/inst/CITATION
pkg/svMisc/man/Sys.tempdir.Rd
pkg/svMisc/man/Sys.userdir.Rd
pkg/svMisc/man/TempEnv.Rd
pkg/svMisc/man/addTemp.Rd
pkg/svMisc/man/assignTemp.Rd
pkg/svMisc/man/captureAll.Rd
pkg/svMisc/man/changeTemp.Rd
pkg/svMisc/man/compareRVersion.Rd
pkg/svMisc/man/existsTemp.Rd
pkg/svMisc/man/getTemp.Rd
pkg/svMisc/man/isAqua.Rd
pkg/svMisc/man/isHelp.Rd
pkg/svMisc/man/isMac.Rd
pkg/svMisc/man/isRgui.Rd
pkg/svMisc/man/isSDI.Rd
pkg/svMisc/man/isWin.Rd
pkg/svMisc/man/rmTemp.Rd
pkg/svMisc/man/tempvar.Rd
Log:
Refactoring of svMisc. Addition of Rjson support.
Modified: pkg/svMisc/DESCRIPTION
===================================================================
--- pkg/svMisc/DESCRIPTION 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/DESCRIPTION 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,11 +1,12 @@
Package: svMisc
Type: Package
Title: SciViews GUI API - Miscellaneous functions
-Imports: utils, methods
-Depends: R (>= 2.6.0), tools
+Imports: utils, methods, tools
+Depends: R (>= 2.6.0)
+Suggests: svUnit
Description: Supporting functions for the GUI API (various utilitary functions)
-Version: 0.9-57
-Date: 2010-03-28
+Version: 0.9-60
+Date: 2010-09-05
Author: Philippe Grosjean, Romain Francois & Kamil Barton
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: GPL-2
Modified: pkg/svMisc/NAMESPACE
===================================================================
--- pkg/svMisc/NAMESPACE 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/NAMESPACE 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,5 +1,5 @@
-import(utils)
-importFrom(methods, getMethods, isGeneric, showMethods)
+import(utils, tools)
+importFrom(methods, new, getMethods, isGeneric, showMethods, slot, slotNames)
export( addActions,
addIcons,
@@ -18,6 +18,7 @@
def,
descArgs,
descFun,
+ evalRjson,
existsTemp,
getEnvironment,
getTemp,
@@ -46,14 +47,16 @@
objMenu,
objSearch,
Parse,
- print.objList,
+ parseText,
progress,
r,
rmTemp,
+ sourceClipboard,
Sys.tempdir,
Sys.userdir,
TempEnv,
tempvar,
+ toRjson,
write.objList)
S3method(print, objList)
Modified: pkg/svMisc/NEWS
===================================================================
--- pkg/svMisc/NEWS 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/NEWS 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,5 +1,41 @@
= svMisc News
+== Changes in svMisc 0.9-60
+
+* A couple of functions are renamed: Parse() -> parseText(), clipsource() ->
+ sourceClipboard(). These functions are declared deprecated, and will become
+ defunct in final version 1.0-0 of the package.
+
+* captureAll() now returns NA in case of incomplete line of code parsed by
+ parseText(). It also detects if expr is a valid language expression or is
+ NA.
+
+* isMac() was not working correctly on Mac OS X Leopard and Snow Leopard
+ (bug corrected).
+
+* Sys.userdir() did not expanded tilde in recent R versions (corrected).
+
+*
+
+
+== Changes in svMisc 0.9-59
+
+* RJSON objects now use a customized list() function to build lists, but also
+ structures and new S4 objects.
+
+* captureAll() has now a 'split' argument that allows to output to the R
+ console, while capturing output.
+
+* Bug correction in captureAll(): call[[1L]] is not subsettable.
+
+
+== Changes in svMisc 0.9-58
+
+* Additions of functions toRjson() and evalRjson() and specification of the
+ RJSON (R-JavaScript Object Notation), an object exchange format not unlike
+ JSON, but richer and more adapted to represent most R objects.
+
+
== Changes in svMisc 0.9-57
* Small changes to objList() (now look at objects in their correct environment).
Deleted: pkg/svMisc/R/Parse.R
===================================================================
--- pkg/svMisc/R/Parse.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/Parse.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,39 +0,0 @@
-"Parse" <-
-function (text)
-{
- # Parse R instructions provided as a string and return the expression if it
- # is correct, or try-error if it is an incorrect code, or NA if the (last)
- # instruction is incomplete
- text <- paste(text, collapse = "\n")
- msgcon <- textConnection(text)
- expr <- try(parse(msgcon), silent = TRUE)
- close(msgcon)
-
- # Determine if this code is correctly parsed
- if (inherits(expr, "try-error")) {
- # Determine if it is incorrect code, or incomplete line!
- # Code is different before and after R 2.9.0
- if (compareRVersion("2.9.0") < 0) {
- toSearch <- paste("\n", length(strsplit(text, "\n")[[1]]) +
- 1, ":", sep = "")
- } else {
- toSearch <- paste(": ", length(strsplit(text, "\n")[[1]]) +
- 1, ":0:", sep = "")
- }
- if (length(grep(toSearch, expr)) == 1) return(NA) else return(expr)
- }
- # There is still a case of incomplete code not catch: incomplete strings
- dp <- deparse(expr)
- # Is it an incomplete string (like "my string)?
- if (regexpr("\\n\")$", dp) > 0 &&
- regexpr("\n[\"'][ \t\r\n\v\f]*($|#.*$)", text) < 0)
- return(NA)
-
- # Is it an incomplete variable name (like `name)?
- if (regexpr("\n`)$", dp) > 0 &&
- regexpr("\n`[ \t\r\n\v\f]*($|#.*$)", text) < 0)
- return(NA)
-
- # Everything is fine, just return parsed expression
- return(expr)
-}
Modified: pkg/svMisc/R/Sys.tempdir.R
===================================================================
--- pkg/svMisc/R/Sys.tempdir.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/Sys.tempdir.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,8 +1,8 @@
-"Sys.tempdir" <-
-function ()
+Sys.tempdir <- function ()
{
- # On the contrary to tempdir(), this function returns the temporary
- # directory used by the system. It is assumed to be
- # the parent directory of tempdir()
+ ## On the contrary to tempdir(), this function returns the temporary
+ ## directory used by the system. It is assumed to be
+ ## the parent directory of tempdir()
+ ## TODO: shouldn't we return /tmp on Mac OS X???
return(dirname(tempdir()))
}
Modified: pkg/svMisc/R/Sys.userdir.R
===================================================================
--- pkg/svMisc/R/Sys.userdir.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/Sys.userdir.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,14 +1,2 @@
-"Sys.userdir" <-
-function ()
-{
- if (isWin()) {
- # Return the user directory ("My Documents" under Windows)
- udir <- Sys.getenv("R_User")
- udir <- normalizePath(udir)
- } else { # Just expand ~
- udir <- normalizePath("~")
- # For reasons I ignore /~ is appended at the end of the path (on MacOS)
- udir <- sub("/~$", "", udir)
- }
- return(udir)
-}
+Sys.userdir <- function ()
+ return(tools::file_path_as_absolute("~"))
Modified: pkg/svMisc/R/TempEnv.R
===================================================================
--- pkg/svMisc/R/TempEnv.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/TempEnv.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,5 +1,4 @@
-"TempEnv" <-
-function ()
+TempEnv <- function ()
{
pos <- match("TempEnv", search())
if (is.na(pos)) { # Must create it
Modified: pkg/svMisc/R/addTemp.R
===================================================================
--- pkg/svMisc/R/addTemp.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/addTemp.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,12 +1,11 @@
-"addTemp" <-
-function (x, item, value, use.names = TRUE, replace = TRUE)
+addTemp <- function (x, item, value, use.names = TRUE, replace = TRUE)
{
x <- as.character(x)[1]
item <- as.character(item)[1]
if (existsTemp(x)) dat <- getTemp(x) else dat <- list()
- # The object must be a list!
+ ## The object must be a list!
if (!inherits(dat, "list")) stop(x, " must be a list!")
- # Does 'item' already exists?
+ ## Does 'item' already exist?
if (item %in% names(dat))
value <- addItems(dat[[item]], value,
use.names = use.names, replace = replace)
Modified: pkg/svMisc/R/assignTemp.R
===================================================================
--- pkg/svMisc/R/assignTemp.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/assignTemp.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,5 +1,4 @@
-"assignTemp" <-
-function (x, value, replace.existing = TRUE)
+assignTemp <- function (x, value, replace.existing = TRUE)
if (replace.existing || !exists(x, envir = TempEnv(), mode = "any",
inherits = FALSE))
assign(x, value, envir = TempEnv())
Modified: pkg/svMisc/R/captureAll.R
===================================================================
--- pkg/svMisc/R/captureAll.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/captureAll.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,16 +1,21 @@
-"captureAll" <-
-function (expr)
+captureAll <- function (expr, split = FALSE)
{
- # capture.all() is inspired from capture.output(), but it captures
- # both the output and the message streams
+ ## If expr is NA, just return it
+ if (!is.language(expr))
+ if (identical(expr, NA))
+ return(NA) else stop("'expr' must be an expression or NA")
+ ## Ensure split is always a boolean
+ split <- isTRUE(split)
+
+ ## captureAll() is inspired from capture.output(), but it captures
+ ## both the output and the message streams
rval <- NULL # Just to avoid a note during code analysis
file <- textConnection("rval", "w", local = TRUE)
- sink(file, type = "output")
- #sink(file, type = "message") # not necessarry anymore since there is custom error handler
+ sink(file, type = "output", split = split)
- # This is a hack to display warning(..., immediate.) correctly
- # (except from base objects) because there is no way to detect it
- # in our handler with the current warning() function
+ ## This is a hack to display warning(..., immediate.) correctly
+ ## (except from base objects) because there is no way to detect it
+ ## in our handler with the current warning() function
assign("warning", function(..., call. = TRUE, immediate. = FALSE,
domain = NULL) {
args <- list(...)
@@ -18,7 +23,7 @@
base::warning(..., call. = call., immediate. = immediate.,
domain = domain)
} else {
- # Deal with immediate warnings
+ ## Deal with immediate warnings
oldwarn <- getOption("warn")
if (immediate. && oldwarn < 1) {
options(warn = 1)
@@ -30,50 +35,43 @@
}, envir = TempEnv())
on.exit({
sink(type = "output")
- #sink(type = "message")
close(file)
if (exists("warning", envir = TempEnv()))
rm("warning", envir = TempEnv())
})
- "evalVis" <- function (Expr)
+ evalVis <- function (Expr)
{
- # We need to install our own warning handling
- # and also, we use a customized interrupt handler
+ ## We need to install our own warning handling
+ ## and also, we use a customized interrupt handler
owarns <- getOption("warning.expression")
- # Inactivate current warning handler
+ ## Inactivate current warning handler
options(warning.expression = expression())
- # ... and make sure it is restored at the end
+ ## ... and make sure it is restored at the end
on.exit({
- # Check that the warning.expression was not changed
+ ## Check that the warning.expression was not changed
nwarns <- getOption("warning.expression")
if (!is.null(nwarns) && length(as.character(nwarns)) == 0)
options(warning.expression = owarns)
})
- # Evaluate instruction(s) in the user workspace (.GlobalEnv)
- #myEvalEnv.. <- .GlobalEnv # << is this necessary?
-
- res <- try(withCallingHandlers(.Internal(eval.with.vis(Expr,
- .GlobalEnv, baseenv())),
+ ## Evaluate instruction(s) in the user workspace (.GlobalEnv)
+ res <- try(withCallingHandlers(withVisible(eval(Expr, .GlobalEnv)),
warning = function (e) {
- # changed some variable names to match corresponding ones in the error handler below
-
msg <- conditionMessage(e)
call <- conditionCall(e)
- # Possibly truncate it
+ ## Possibly truncate it
wl <- getOption("warning.length")
if (is.null(wl)) wl <- 1000 # Default value
if (nchar(msg) > wl)
- msg <- paste(substr(msg, 1, wl),
- .gettext("[... truncated]")) # [... truncated] not in it?
+ msg <- paste(substr(msg, 1, wl), .gettext("[... truncated]"))
- # Result depends upon 'warn'
+ ## Result depends upon 'warn'
Warn <- getOption("warn")
- # If warning generated in eval environment, make it NULL
- if (!is.null(call) && identical(call[[1]], quote(eval.with.vis)))
- e$call <- NULL
+ ## If warning generated in eval environment, make it NULL
+ try(if (!is.null(call) && identical(call[[1L]], quote(eval)))
+ e$call <- NULL, silent = TRUE)
if (Warn < 0) { # Do nothing!
return()
@@ -81,10 +79,10 @@
if (exists("warns", envir = TempEnv())) {
lwarn <- get("warns", envir = TempEnv())
} else lwarn <- list()
- # Do not add more than 50 warnings
+ ## Do not add more than 50 warnings
if (length(lwarn) >= 50) return()
- # Add the warning to this list and save in TempEnv()
+ ## Add the warning to this list and save in TempEnv()
assign("warns", append(lwarn, list(e)), envir = TempEnv())
return()
@@ -92,26 +90,29 @@
msg <- .gettextf("(converted from warning) %s", msg)
stop(simpleError(msg, call = call))
} else {
- # warn = 1
- # Print the warning message immediately
- # Format the warning message
+ ## warn = 1
+ ## Print the warning message immediately
+ ## Format the warning message
- # this is modified code from base::try
+ ## This is modified code from base::try
if (!is.null(call)) {
- dcall <- deparse(call)[1]
+ dcall <- deparse(call)[1L]
prefix <- paste(.gettext("Warning in"), dcall, ": ")
- sm <- strsplit(msg, "\n")[[1]]
- if (nchar(dcall, type="w") + nchar(sm[1], type="w") > 58) # to match value in errors.c
+ LONG <- 75L
+ sm <- strsplit(msg, "\n")[[1L]]
+ w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w")
+ if (is.na(w))
+ w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b")
+ if (w > LONG)
prefix <- paste(prefix, "\n ", sep = "")
} else prefix <- .gettext("Warning : ")
msg <- paste(prefix, msg, "\n", sep="")
cat(msg)
-
}
}
, interrupt = function (i) cat(.gettext("<INTERRUPTED!>\n"))
- # this is modified code from base::try
+ ## This is modified code from base::try
, error = function(e) {
call <- conditionCall(e)
msg <- conditionMessage(e)
@@ -120,34 +121,37 @@
## try(stop(...)). This will need adjusting if the
## implementation of tryCatch changes.
## Use identical() since call[[1]] can be non-atomic.
- if (!is.null(call) && identical(call[[1]], quote(eval.with.vis)))
- call <- NULL
+ try(if (!is.null(call) && identical(call[[1L]], quote(eval)))
+ call <- NULL, silent = TRUE)
if (!is.null(call)) {
- dcall <- deparse(call)[1]
+ dcall <- deparse(call)[1L]
prefix <- paste(.gettext("Error in "), dcall, ": ")
- sm <- strsplit(msg, "\n")[[1]]
- if (nchar(dcall, type="w") + nchar(sm[1], type="w") > 61) # to match value in errors.c
+ LONG <- 75L
+ sm <- strsplit(msg, "\n")[[1L]]
+ w <- 14L + nchar(dcall, type = "w") + nchar(sm[1L], type = "w")
+ if (is.na(w))
+ w <- 14L + nchar(dcall, type = "b") + nchar(sm[1L], type = "b")
+ if (w > LONG)
prefix <- paste(prefix, "\n ", sep = "")
- } else prefix <- .gettext("Error: ")
+ } else prefix <- .gettext("Error : ")
- msg <- paste(prefix, msg, "\n", sep="")
+ msg <- paste(prefix, msg, "\n", sep = "")
## Store the error message for legacy uses of try() with
## geterrmessage().
- .Internal(seterrmessage(msg[1]))
- if (identical(getOption("show.error.messages"), TRUE)) {
+ .Internal(seterrmessage(msg[1L]))
+ if (identical(getOption("show.error.messages"), TRUE))
cat(msg)
- }
}
, message = function(e) {
signalCondition(e)
cat(conditionMessage(e))
}
), silent = TRUE)
- # Possibly add 'last.warning' as attribute to res
+ ## Possibly add 'last.warning' as attribute to res
if (exists("warns", envir = TempEnv())) {
warns <- get("warns", envir = TempEnv())
- # reshape the warning list
+ ## Reshape the warning list
last.warning <- lapply(warns, "[[", "call")
names(last.warning) <- sapply(warns, "[[", "message")
@@ -157,14 +161,14 @@
return(res)
}
- # This is my function to display delayed warnings
+ ## This is my own function to display delayed warnings
WarningMessage <- function (last.warning)
{
assign("last.warning", last.warning, envir = baseenv())
n.warn <- length(last.warning)
if (n.warn < 11) { # If less than 11 warnings, print them
- # For reasons I don't know, R append a white space to the warning
- # messages... we replicate this behaviour here
+ ## For reasons I don't know, R append a white space to the warning
+ ## messages... we replicate this behaviour here.
print.warnings(warnings(" ", sep = ""))
} else if (n.warn >= 50) {
cat(.gettext("There were 50 or more warnings (use warnings() to see the first 50)\n"))
@@ -180,10 +184,10 @@
if (inherits(tmp, "try-error")) {
last.warning <- attr(tmp, "last.warning")
if (!is.null(last.warning)) {
- cat(.gettext("In addition: "))
+ cat(.gettext("In addition : "))
WarningMessage(last.warning)
}
- break
+ break
} else { # No error
if (tmp$visible) print(tmp$value)
last.warning <- attr(tmp, "last.warning")
@@ -192,6 +196,6 @@
}
}
cat("\n") # In case last line does not end with \n, I add it!
-
return(rval)
}
+
Modified: pkg/svMisc/R/changeTemp.R
===================================================================
--- pkg/svMisc/R/changeTemp.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/changeTemp.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,12 +1,11 @@
-"changeTemp" <-
-function (x, item, value, replace.existing = TRUE)
+changeTemp <- function (x, item, value, replace.existing = TRUE)
{
x <- as.character(x)[1]
item <- as.character(item)[1]
if (existsTemp(x)) dat <- getTemp(x) else dat <- list()
- # The object must be a list!
+ ## The object must be a list!
if (!inherits(dat, "list")) stop(x, " must be a list!")
- # Does 'item' already exists
+ ## Does 'item' already exist?
if (replace.existing || !item %in% names(dat)){
dat[[item]] <- value
assignTemp(x, dat)
Deleted: pkg/svMisc/R/clipsource.R
===================================================================
--- pkg/svMisc/R/clipsource.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/clipsource.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,21 +0,0 @@
-"clipsource" <-
-function (primary = TRUE, ...)
-{
- # Source data from the clipboard, manage clipboard correctly depending
- # on the OS
- if (isWin()) { # Windows OS
- data <- file("clipboard")
- } else if (isMac()) { # Mac OS
- data <- pipe("pbpaste")
- } else { # Must be Linux/Unix
- if (primary) {
- data <- file("X11_clipboard")
- } else {
- data <- file("X11_secondary")
- }
- }
- on.exit(close(data))
- # Invoke source() with the data from the clipboard
- res <- source(data, ...)
- return(invisible(res))
-}
Modified: pkg/svMisc/R/compareRVersion.R
===================================================================
--- pkg/svMisc/R/compareRVersion.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/compareRVersion.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,7 +1,6 @@
-"compareRVersion" <-
-function (version)
+compareRVersion <- function (version)
{
- # This is similar to compareVersion, but works for R version comparison
- compareVersion(paste(R.Version()$major, R.Version()$minor, sep = "."),
+ ## This is similar to compareVersion, but works for R version comparison
+ compareVersion(paste(R.version$major, R.version$minor, sep = "."),
version)
}
Modified: pkg/svMisc/R/existsTemp.R
===================================================================
--- pkg/svMisc/R/existsTemp.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/existsTemp.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,3 +1,2 @@
-"existsTemp" <-
-function (x, mode = "any")
+existsTemp <- function (x, mode = "any")
exists(x, envir = TempEnv(), mode = mode, inherits = FALSE)
Modified: pkg/svMisc/R/getTemp.R
===================================================================
--- pkg/svMisc/R/getTemp.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/getTemp.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,5 +1,4 @@
-"getTemp" <-
-function (x, default = NULL, mode = "any", item = NULL)
+getTemp <- function (x, default = NULL, mode = "any", item = NULL)
{
if (is.null(item)) Mode <- mode else Mode <- "any"
if (exists(x, envir = TempEnv(), mode = Mode, inherits = FALSE)) {
Modified: pkg/svMisc/R/isAqua.R
===================================================================
--- pkg/svMisc/R/isAqua.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/isAqua.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,3 +1,2 @@
-"isAqua" <-
-function ()
+isAqua <- function ()
(.Platform$GUI[1] == "AQUA")
\ No newline at end of file
Modified: pkg/svMisc/R/isMac.R
===================================================================
--- pkg/svMisc/R/isMac.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/isMac.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,3 +1,2 @@
-"isMac" <-
-function ()
- (.Platform$pkgType == "mac.binary")
+isMac <- function ()
+ (grepl("^mac", .Platform$pkgType))
Modified: pkg/svMisc/R/isRgui.R
===================================================================
--- pkg/svMisc/R/isRgui.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/isRgui.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,3 +1,2 @@
-"isRgui" <-
-function ()
+isRgui <- function ()
(.Platform$GUI[1] == "Rgui")
Modified: pkg/svMisc/R/isSDI.R
===================================================================
--- pkg/svMisc/R/isSDI.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/isSDI.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,52 +1,11 @@
-"isSDI" <-
-function ()
+isSDI <- function ()
{
# This function is specific to Windows, but it is defined everywhere
# so that we don't have to test the platform before use!
# Check if Rgui was started in SDI mode (needed by some GUI clients)
- # 1) First is it Rgui?
- if (!.Platform$GUI[1] == "Rgui")
- return(FALSE) # This is not Rgui
-
- # The code is much simpler, starting form R 2.0.0
- if (compareRVersion("2.0") == 1) { # R >= 2.0.0
- # RGui SDI mode: returns "R Console", in MDI mode: returns "RGui"
- if (getIdentification() == "R Console") return(TRUE) else return(FALSE)
- }
-
- # Rem: this code will never run, because svMisc is compiled for R >= 2.0.0
- # It is left there in case one would like to make it backward compatible!
- # 2) Check parameters
- if (any(commandArgs() == "--sdi"))
- return(TRUE)
-
- # 3) Look for Rconsole file
- UserDir <- Sys.getenv("R_USER")
- if (UserDir == "") UserDir <- Sys.getenv("HOME")
- if (UserDir == "") UserDir <- paste(Sys.getenv("HOMEDRIVE"),
- Sys.getenv("HOMEPATH"), sep = "")
- if (UserDir == "") ConfFile <- "" else
- ConfFile <- file.path(UserDir, "Rconsole")
- # Does it exists
- if (!file.exists(ConfFile)) { # Look for a possible system-wide config file
- ConfFile <- file.path(Sys.getenv("R_HOME"), "etc", "Rconsole")
- if (!file.exists(ConfFile))
- return(FALSE) # No config file found => default behavious: MDI
- }
-
- # 4) Read the Rconsole file
- Conf <- read.table(ConfFile, sep = "------", header = FALSE)
- # Look for a line starting with 'MDI'
- MDIpos <- grep("^MDI", as.vector(Conf[, 1]))
- if (length(MDIpos) == 0)
- return(FALSE) # Argument not found => default value (MDI)?
- MDIarg <- as.character(Conf[MDIpos[1], 1])
- MDIvalue <- strsplit(MDIarg, "=")[[1]][2]
- MDIvalue <- gsub(" ", "", tolower(MDIvalue))
- # If contains "yes" or "1", it is MDI mode, otherwise SDI mode (?)
- if (MDIvalue == "yes") return(FALSE)
- if (MDIvalue == "1") return(FALSE)
- # Should be SDI mode?
- return(TRUE)
+ # First, is it Rgui?
+ if (!isRgui()) return(FALSE)
+ # RGui SDI mode: returns "R Console", in MDI mode: returns "RGui"
+ if (getIdentification() == "R Console") return(TRUE) else return(FALSE)
}
Modified: pkg/svMisc/R/isWin.R
===================================================================
--- pkg/svMisc/R/isWin.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/isWin.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,3 +1,2 @@
-"isWin" <-
-function ()
+isWin <- function ()
(.Platform$OS.type == "windows")
Added: pkg/svMisc/R/parseText.R
===================================================================
--- pkg/svMisc/R/parseText.R (rev 0)
+++ pkg/svMisc/R/parseText.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -0,0 +1,45 @@
+Parse <- function (text)
+{
+ ## Deprecated, in favor of parseText
+ .Deprecated("parseText")
+ return(parseText(text))
+}
+
+parseText <- function (text)
+{
+ ## Parse R instructions provided as a string and return the expression if it
+ ## is correct, or a 'try-error' object if it is an incorrect code, or NA if
+ ## the (last) instruction is incomplete
+ text <- paste(text, collapse = "\n")
+ code <- textConnection(text)
+ expr <- try(parse(code), silent = TRUE)
+ close(code)
+
+ ## Determine if this code is correctly parsed
+ if (inherits(expr, "try-error")) {
+ ## Determine if it is incorrect code, or incomplete line!
+ ## Code is different before and after R 2.9.0
+ if (compareRVersion("2.9.0") < 0) {
+ toSearch <- paste("\n", length(strsplit(text, "\n")[[1]]) +
+ 1, ":", sep = "")
+ } else {
+ toSearch <- paste(": ", length(strsplit(text, "\n")[[1]]) +
+ 1, ":0:", sep = "")
+ }
+ if (length(grep(toSearch, expr)) == 1) return(NA) else return(expr)
+ }
+ ## There is still a case of incomplete code not catch: incomplete strings
+ dp <- deparse(expr)
+ ## Is it an incomplete string (like "my string or 'my string)?
+ if (regexpr("\\n\")$", dp) > 0 &&
+ regexpr("\n[\"'][ \t\r\n\v\f]*($|#.*$)", text) < 0)
+ return(NA)
+
+ ## Is it an incomplete variable name (like `name)?
+ if (regexpr("\n`)$", dp) > 0 &&
+ regexpr("\n`[ \t\r\n\v\f]*($|#.*$)", text) < 0)
+ return(NA)
+
+ ## Everything is fine, just return parsed expression
+ return(expr)
+}
Added: pkg/svMisc/R/rjson.R
===================================================================
--- pkg/svMisc/R/rjson.R (rev 0)
+++ pkg/svMisc/R/rjson.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -0,0 +1,143 @@
+# TODO: complex => character + how to restore complex numbers with attributes = TRUE?
+# TODO: check dates, and manage other dates than Date!
+# TODO: convert functions, expressions into string, and how to include JS code? or R code?
+# TODO: allow for special characters \b, \n, \r, \f, \t, \" in names!
+# TODO: environment and proto
+"toRjson" <- function (x, attributes = FALSE)
+{
+ # This is derived from dput()
+ file <- file()
+ on.exit(close(file))
+ if (isTRUE(attributes)) {
+ opts <- .deparseOpts(c("showAttributes", "S_compatible"))
+ } else {
+ opts <- .deparseOpts("S_compatible")
+ }
+
+ # Non-named list items are not allowed => make sure we give names to these
+ # Also if attributes == FALSE, we use the string representation of factors
+ "rework" <- function (x, attributes = FALSE) {
+ if (is.list(x) && length(x)) {
+ # Make sure all items have names, and use [[x]] for unnamed items
+ i <- paste("[[", 1:length(x), "]]", sep = "")
+ n <- names(x)
+ if (is.null(n)) {
+ n <- i
+ } else {
+ nonames <- n == ""
+ n[nonames] <- i[nonames]
+ }
+ # Flag names with leading and trailing sequence (unlikely elsewhere)
+ n <- paste("@&#&&", n, "&&#&@", sep = "")
+ # Change names of x
+ names(x) <- n
+ # If we don't use attributes, convert factors and Dates to characters
+ if (!isTRUE(attributes))
+ x <- rapply(x, as.character, classes = c("factor", "Date"),
+ how = "replace")
+ # Do this recursively
+ for (item in names(x))
+ x[[item]] <- rework(x[[item]], attributes)
+ } else if (!isTRUE(attributes) && inherits(x, c("factor", "Date")))
+ x <- as.character(x)
+ # Process also all attributes
+ if (isTRUE(attributes)) {
+ a <- attributes(x)
+ if (!is.null(a)) {
+ n <- names(x)
+ a$.Names <- NULL
+ a$names <- NULL
+ na <- names(a)
+ if (length(na)) {
+ for (item in na)
+ a[[item]] <- rework(a[[item]], attributes)
+ # Tag attributes names and translate a few special ones
+ specials <- c(".Dim", ".Dimnames", ".Tsp", ".Label")
+ replace <- c("dim", "dimnames", "tsp", "levels")
+ m <- match(na, specials)
+ ok <- (!is.na(m) & m)
+ na[ok] <- replace[m[ok]]
+ names(a) <- paste("@&#&&", na, "&&#&@", sep = "")
+ }
+ attributes(x) <- a
+ names(x) <- n
+ }
+ }
+ return(x)
+ }
+
+ # Is this an S4 object => process each slot separately
+ if (isS4(x)) {
+ cat('list("Class_" := "', class(x), '"\n', file = file, sep = "")
+ for (n in slotNames(x)) {
+ cat(' , "', n, '" := ', file = file)
+ dput(rework(slot(x, n), attributes), file = file, control = opts)
+ }
+ cat(")\n", file = file)
+ invisible()
+ }
+ else .Internal(dput(rework(x, attributes), file, opts))
+
+ # Now read content from the file
+ res <- readLines(file)
+
+ # dput() indicates sequences of integers with x:y that JavaScript cannot
+ # process... replace these by the equivalent code seq(x, y)
+ res <- gsub("(-?[0-9]+):(-?[0-9]+)", "seq(\\1, \\2)", res)
+
+ # Convert '.Names = ' into '"names" := '
+ res <- gsub(".Names = ", '"names" := ', res, fixed = TRUE)
+ # We need to replace special characters
+ # TODO: do so only inside `@&#&&...&&#&@`
+# TODO: all this does not work!!!
+# res <- gsub('(`@&#&&.*)\b(.*&&#&@`)', '\\1\\\\b\\2', res)
+# res <- gsub('(`@&#&&.*)\t(.*&&#&@`)', '\\1\\\\t\\2', res)
+# res <- gsub('(`@&#&&.*)\n(.*&&#&@`)', '\\1\\\\n\\2', res)
+# res <- gsub('(`@&#&&.*)\f(.*&&#&@`)', '\\1\\\\f\\2', res)
+# res <- gsub('(`@&#&&.*)\r(.*&&#&@`)', '\\1\\\\r\\2', res)
+# res <- gsub('(`@&#&&.*)\"(.*&&#&@`)', '\\1\\\\"\\2', res)
+ #res <- gsub('\t', '\\t', res, fixed = TRUE)
+ #res <- gsub('\n', '\\n', res, fixed = TRUE)
+ #res <- gsub('\f', '\\f', res, fixed = TRUE)
+ #res <- gsub('\r', '\\r', res, fixed = TRUE)
+ #res <- gsub('\"', '\\"', res, fixed = TRUE)
+ # Convert `@&#&& into ", and &&#&@` = into " :=
+ res <- gsub('"?`@&#&&', '"', res)
+ res <- gsub('&&#&@`\"? =', '" :=', res)
+ # Convert "@&#&&[[d]]&&#&@" to "" (non-named items)
+ res <- gsub('"@&#&&\\[\\[[1-9][0-9]*]]&&#&@"', '""', res)
+ # Convert "@&#&& into " and &&#&@" into "
+ res <- gsub('"@&#&&', '"', res, fixed = TRUE)
+ res <- gsub('&&#&@"', '"', res, fixed = TRUE)
+ # No unnamed items, so, convert 'structure(' into 'list("Data_" := '
+ res <- gsub("([^a-zA-Z0-9._])structure\\(", '\\1list("Data_" := ', res)
+ res <- sub("^structure\\(", 'list("Data_" := ', res)
+ # Old code!
+ ## Convert 'list(' into 'hash('
+ #res <- gsub("([^a-zA-Z0-9._])list\\(", "\\1hash(", res)
+ #res <- sub("^list\\(", "hash(", res)
+
+ # Return the no quoted results
+ return(noquote(res))
+}
+
+"evalRjson" <- function (rjson) {
+ # Our custom list() manages to create list() but also new() or structure() items
+ "list" <- function (Class_, Data_, ...) {
+ # If there is a "Class_" argument, create new S4 object
+ # Note that "Data_" is ignored in this case!
+ if (!missing(Class_)) return(new(Class_, ...))
+ # If there is a "_Data_" argument, create a structure
+ if (!missing(Data_)) return(structure(Data_, ...))
+ # otherwise, create a list
+ return(base::list(...))
+ }
+
+ # To convert RJSON data into a R object, simply evaluate it
+ # Note: RJSONp objects will be evaluated correctly too
+ # providing the <callback>() exists and can manage a single
+ # argument (being the RJSOn object converted to R)
+
+ # We need first to convert all ':=' into '='
+ return(eval(parse(text = gsub(":=", "=", rjson, fixed = TRUE))))
+}
Modified: pkg/svMisc/R/rmTemp.R
===================================================================
--- pkg/svMisc/R/rmTemp.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/rmTemp.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,5 +1,4 @@
-"rmTemp" <-
-function (x)
+rmTemp <- function (x)
{
if (!is.character(x))
stop("'x' must be character string(s)!")
Added: pkg/svMisc/R/sourceClipboard.R
===================================================================
--- pkg/svMisc/R/sourceClipboard.R (rev 0)
+++ pkg/svMisc/R/sourceClipboard.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -0,0 +1,27 @@
+clipsource <- function (primary = TRUE, ...)
+{
+ ## Deprecated, in favor of sourceClipboard
+ .Deprecated("sourceClipboard")
+ return(sourceClipboard(primary = primary, ...))
+}
+
+sourceClipboard <- function (primary = TRUE, ...)
+{
+ ## Source data from the clipboard, manage clipboard correctly depending
+ ## on the OS
+ if (isWin()) { # Windows OS
+ data <- file("clipboard")
+ } else if (isMac()) { # Mac OS
+ data <- pipe("pbpaste")
+ } else { # Must be Linux/Unix
+ if (primary) {
+ data <- file("X11_clipboard")
+ } else {
+ data <- file("X11_secondary")
+ }
+ }
+ on.exit(close(data))
+ ## Invoke source() with the data from the clipboard
+ res <- source(data, ...)
+ return(invisible(res))
+}
Modified: pkg/svMisc/R/svMisc-internal.R
===================================================================
--- pkg/svMisc/R/svMisc-internal.R 2010-09-05 16:10:46 UTC (rev 287)
+++ pkg/svMisc/R/svMisc-internal.R 2010-09-06 16:28:53 UTC (rev 288)
@@ -1,18 +1,14 @@
-".onLoad" <-
-function (lib, pkg)
-{
+.onLoad <- function (lib, pkg)
.initialize()
-}
-".initialize" <-
-function (replace = TRUE)
+.initialize <- function (replace = TRUE)
{
- # Create .svActions if it does not exists yet
+ ## Create .svActions if it does not exists yet
.svActions <- list()
class(.svActions) <- unique(c("svActions", class(.svActions)))
assignTemp(".svActions", .svActions, replace.existing = FALSE)
- # Define actions we need for the object browser menus
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 288
More information about the Sciviews-commits
mailing list