[Sciviews-commits] r488 - in pkg/SciViews: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Dec 7 16:21:47 CET 2012
Author: phgrosjean
Date: 2012-12-07 16:21:47 +0100 (Fri, 07 Dec 2012)
New Revision: 488
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/graphics.R
pkg/SciViews/R/misc.R
Log:
Further work in SciViews functions
Modified: pkg/SciViews/DESCRIPTION
===================================================================
--- pkg/SciViews/DESCRIPTION 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/DESCRIPTION 2012-12-07 15:21:47 UTC (rev 488)
@@ -1,7 +1,7 @@
Package: SciViews
Type: Package
-Version: 0.9-8
-Date: 2012-06-11
+Version: 0.9-9
+Date: 2012-12-06
Title: SciViews GUI API - Main package
Authors at R: c(person("Philippe", "Grosjean", role = c("aut", "cre"),
email = "phgrosjean at sciviews.org"))
Modified: pkg/SciViews/NAMESPACE
===================================================================
--- pkg/SciViews/NAMESPACE 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/NAMESPACE 2012-12-07 15:21:47 UTC (rev 488)
@@ -1,6 +1,8 @@
import(methods, grDevices, graphics, stats, MASS, ellipse, data.table)
-export(cEscape,
+export(.Intern,
+ cAbbreviate,
+ cEscape,
cExpand,
cFind,
cFindAll,
@@ -33,6 +35,7 @@
encodingToUTF8,
encoding,
"encoding<-",
+ setEncoding,
as.integerBase,
rx,
perl,
@@ -76,8 +79,10 @@
wdir,
ifElse,
names,
- n,
- i,
+ num,
+ int,
+ char,
+ logic,
l,
nc,
nr,
@@ -95,14 +100,153 @@
"@<-",
"@:=",
":=",
+ "=",
"%:%",
"%else%",
isEmpty,
+ stopIfNot,
package,
enum,
timing,
+
+
+ sysFunction,
+ sysCall,
+ matchCall,
+ sysParent,
+ sysParents,
+ parentFrame,
+ sysFrame,
+ sysnFrame,
+ sysStatus,
+ onExit,
+ sysOnExit,
+ dumpFrames,
+ debugOnce,
+ isDebugged,
+ baseEnv,
+ baseNamespaceEnv,
+ emptyEnv,
+ globalEnv,
+ autoloadEnv,
+ tempEnv,
+ topEnv,
+ environmentNew,
+ environmentParent,
+ "environmentParent<-",
+ environmentProfile,
+ sysSource,
+ evalQuote,
+ evalParent,
+ evalLocal,
+ autoloaded,
+ isNamespaceEnv,
+
opt,
optDef,
+
+
+ plotOpt,
+ plotOptAll,
+ plotNew,
+ layoutShow,
+ screenSplit,
+ screenSet,
+ screenDelete,
+ screenClose,
+ l__cm,
+ x__in2user,
+ y__in2user,
+ xy__in2user,
+ x__cm2user,
+ y__cm2user,
+ xy__cm2user,
+ xConvert,
+ yConvert,
+ xyConvert,
+ contours,
+ contourplot,
+ filledplot,
+ starplot,
+ stemplot,
+ stripplot,
+ clevelandplot,
+ smoothplot,
+ smoothPanel,
+ coplotIntervals,
+ plotWindowInternal,
+ plotInternal,
+ boxplotInternal,
+ devNew,
+ devCur,
+ devList,
+ devNext,
+ devPrev,
+ devSet,
+ devClose,
+ devCloseAll,
+ devControl,
+ devHold,
+ devHoldFlush,
+ devFlush,
+ devCopy,
+ devCopyNew,
+ devCopyEps,
+ devCopyPdf,
+ devCopyBitmap,
+ devSave,
+ devRecord,
+ devReplay,
+ getSnapshot,
+ playSnapshot,
+ devCapture,
+ devSize,
+ devCapabilities,
+ devInteractive,
+ isDevInteractive,
+ devPdf,
+ devPdfOpt,
+ devPS,
+ devPSOpt,
+ devPdfCairo,
+ devPSCairo,
+ devSvg,
+ devBmp,
+ devJpeg,
+ devPng,
+ devTiff,
+ devBitmap,
+ devXfig,
+ color2rgb,
+ colorAdjust,
+ colorDens,
+ colorBlues9,
+ colorRainbow,
+ colorHeat,
+ colorTerrain,
+ colorTopo,
+ colorCm,
+ colorRwb,
+ colorRyg,
+ colorGray,
+ colorGrey,
+ colorConvertRgb,
+ colorConvert,
+ fontType1,
+ fontCid,
+ fontsPS,
+ fontsPdf,
+ fontsEmbed,
+ optCheck,
+ nclassSturges,
+ nclassScott,
+ nclassFD,
+ rangeExtend,
+ boxplotStats,
+ xyCoords,
+ xyzCoords,
+ in2cm,
+ cm2in,
correlation,
is.correlation,
as.correlation,
@@ -117,6 +261,7 @@
ln1p,
lg,
lg1p,
+ package,
panel.boxplot,
panel.density,
panel.hist,
@@ -132,6 +277,8 @@
S3method(print, path)
+S3method(contours, default)
+
S3method(print, s)
S3method(print, rx)
Modified: pkg/SciViews/NEWS
===================================================================
--- pkg/SciViews/NEWS 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/NEWS 2012-12-07 15:21:47 UTC (rev 488)
@@ -1,5 +1,19 @@
= SciViews News
+== SciViews version 0.9-9
+
+* Improvements to activate warnings regarding possible R traps: if
+ warnPartialMatchArgs, warnPartialMatchAttr, or warnPartialMatchDollar options
+ are not defined yet, they are set to TRUE when the packages loads.
+
+* For a similar purpose, we would like to avoid using = in place of <- for
+ assignation. So, the "=" function is redefined to display a warning when it
+ is used and when warnAssignWithEqualSign option is set to TRUE (by default).
+ The warning message also suggests it may be == erroneously written =.
+
+* Many functions are added with more coherent names for graphics.
+
+
== SciViews version 0.9-8
* Several changes in character.R.
Modified: pkg/SciViews/R/SciViews-internal.R
===================================================================
--- pkg/SciViews/R/SciViews-internal.R 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/R/SciViews-internal.R 2012-12-07 15:21:47 UTC (rev 488)
@@ -1,5 +1,16 @@
.onLoad <- function (lib, pkg)
{
+ ## With SciViews, we try to avoid traps as much as possible!
+ ## So, if corresponding options are not defined yet, specify them to TRUE!
+ if (!length(getOption("warnAssignWithEqualSign")))
+ options(warnAssignWithEqualSign = TRUE)
+ if (!length(getOption("warnPartialMatchArgs")))
+ options(warnPartialMatchArgs = TRUE)
+ if (!length(getOption("warnPartialMatchAttr")))
+ options(warnPartialMatchAttr = TRUE)
+ if (!length(getOption("warnPartialMatchDollar")))
+ options(warnPartialMatchDollar = TRUE)
+
## TODO: check configuration and install everything that we need to use the
## SciViews extensions, including the HTTP or socket server
#serve <- getOption("ko.serve")
@@ -43,23 +54,32 @@
}
## 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) {
+ .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())
+ }
+ pos.to.env(pos)
+ }
+ TempEnv <- .TempEnv()
+ if (isTRUE(replace.existing) || !exists(x, envir = TempEnv, mode = "any",
+ inherits = FALSE))
+ assign(x, value, envir = TempEnv)
}
-.assignTemp <- function (x, value, replace.existing = TRUE)
- if (isTRUE(replace.existing) || !exists(x, envir = .TempEnv(), mode = "any",
- inherits = FALSE))
- assign(x, value, envir = .TempEnv())
-
## This is for convenience: . == .GlobalEnv
#.assignTemp(".", base::.GlobalEnv)
+## To avoid a useless note when checking the package,
+## we replace any .Internal() into .Intern() in renamed R functions
+.Intern <- .Internal
+
+.Recode <- function (f)
+{
+ body(f) <- parse(text = gsub("\\.Internal\\(", ".Intern(", deparse(body(f))))
+ f
+}
Modified: pkg/SciViews/R/character.R
===================================================================
--- pkg/SciViews/R/character.R 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/R/character.R 2012-12-07 15:21:47 UTC (rev 488)
@@ -10,7 +10,7 @@
#nzChar <- nzchar
## Format character strings
-cEscape <- base::encodeString
+cEscape <- .Recode(base::encodeString)
cWrap <- base::strwrap
# Add cPad => pad a string left/right or both or chrPad/chrPadL/chrPadR?
#+sprintf/gettextf?
@@ -140,22 +140,22 @@
strsplit(x, split = pattern, fixed = !is.rx(pattern),
perl = is.perl(pattern), useBytes = useBytes(pattern))
-cSubstr <- base::substr
-`cSubstr<-` <- base::`substr<-`
-cTrunc <- base::strtrim ## This indeed truncs strings!!!
+cSubstr <- .Recode(base::substr)
+`cSubstr<-` <- .Recode(base::`substr<-`)
+cTrunc <- .Recode(base::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, that use sep = "".
## Thus, we define:
if (exists("paste0", envir = baseenv())) { # Starting from R 2.15.0
- p <- base::paste0
+ p <- .Recode(base::paste0)
} else {
p <- function (..., collapse = NULL)
paste(..., sep = "", collapse = collapse)
}
-p_ <- base::paste
+p_ <- .Recode(base::paste)
## The same is true for cat() with sep = " "... and the default behaviour of
## not ending with line feed is more confusing that useful => change this
@@ -201,18 +201,19 @@
## Change case and translate
cTrans <- function (x, old, new) chartr(old = old, new = new, x = x)
cFold <- base::casefold
-cLower <- base::tolower
-cUpper <- base::toupper
+cLower <- .Recode(base::tolower)
+cUpper <- .Recode(base::toupper)
## Character encoding
encodingToNative <- base::enc2native
encodingToUTF8 <- base::enc2utf8
-encoding <- base::Encoding
-`encoding<-` <- base::`Encoding<-`
+encoding <- .Recode(base::Encoding)
+## R CMD check got fooled because it does not find setEncoding... We give it too
+`encoding<-` <- setEncoding <- .Recode(base::`Encoding<-`)
## Measure size of a string (package graphics)
-cHeight <- graphics::strheight
-cWidth <- graphics::strwidth
+cHeight <- .Recode(graphics::strheight)
+cWidth <- .Recode(graphics::strwidth)
## Match, expand or abbreviate character strings to a list of items
cAbbreviate <- function (x, min.length = 4, dot = FALSE, strict = FALSE,
@@ -223,8 +224,8 @@
cExpand <- function (x, target, nomatch = NA_character_)
char.expand(input = x, target = target, nomatch = nomatch)
-cMatch <- base::charmatch
-cPMatch <- base::pmatch
+cMatch <- .Recode(base::charmatch)
+cPMatch <- .Recode(base::pmatch)
## Conversion to character string... no change required
#as.character
@@ -232,7 +233,7 @@
# To avoid using strtoi(), we prefer as.integerBase (because as.integer cannot
# be converted into a generic function, because it is a primitive!)
#charToInt <- strtoi # Allows to choose the base used for char representation
-as.integerBase <- base::strtoi
+as.integerBase <- .Recode(base::strtoi)
## Define a function that takes: singular/plural msg and a vector of strings
## and construct a single string with:
Modified: pkg/SciViews/R/file.R
===================================================================
--- pkg/SciViews/R/file.R 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/R/file.R 2012-12-07 15:21:47 UTC (rev 488)
@@ -106,28 +106,28 @@
## Various file manipulation functions that do not return a path object
## (just homogenize the name...)
-dirCreate <- get("dir.create", envir = baseenv())
-fileAccess <- get("file.access", envir = baseenv())
-fileAppend <- get("file.append", envir = baseenv())
-fileRename <- get("file.rename", envir = baseenv())
-fileCopy <- get("file.copy", envir = baseenv())
-fileCreate <- get("file.create", envir = baseenv())
-fileExists <- get("file.exists", envir = baseenv())
-fileInfo <- get("file.info", envir = baseenv())
-fileChmod <- get("Sys.chmod", envir = baseenv())
-fileRemove <- get("file.remove", envir = baseenv())
+dirCreate <- .Recode(get("dir.create", envir = baseenv()))
+fileAccess <- .Recode(get("file.access", envir = baseenv()))
+fileAppend <- .Recode(get("file.append", envir = baseenv()))
+fileRename <- .Recode(get("file.rename", envir = baseenv()))
+fileCopy <- .Recode(get("file.copy", envir = baseenv()))
+fileCreate <- .Recode(get("file.create", envir = baseenv()))
+fileExists <- .Recode(get("file.exists", envir = baseenv()))
+fileInfo <- .Recode(get("file.info", envir = baseenv()))
+fileChmod <- .Recode(get("Sys.chmod", envir = baseenv()))
+fileRemove <- .Recode(get("file.remove", envir = baseenv()))
## This is "stronger" than fileRemove()!
fileDelete <- function (path, recursive = FALSE, force = FALSE)
return(unlink(x = path, recursive = recursive, force = force))
-fileLink <- get("file.link", envir = baseenv())
-fileSymlink <- get("file.symlink", envir = baseenv())
+fileLink <- .Recode(get("file.link", envir = baseenv()))
+fileSymlink <- .Recode(get("file.symlink", envir = baseenv()))
fileReadLink <- function (path)
return(structure(Sys.readlink(paths = path),
class = c("path", "character")))
## This is linked to some GUI element, possibly... anyway...
-fileShow <- get("file.show", envir = baseenv())
+fileShow <- .Recode(get("file.show", envir = baseenv()))
## TODO: this file choose... but this is really for svDialogs (dlgOpen(), dlgSave())
#fileChoose <- file.choose
Modified: pkg/SciViews/R/graphics.R
===================================================================
--- pkg/SciViews/R/graphics.R 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/R/graphics.R 2012-12-07 15:21:47 UTC (rev 488)
@@ -11,7 +11,7 @@
## The plot.xxx() functions...
## Covered functions: graphics::plot.new(), graphics::frame()
-plotNew <- graphics::plot.new # () and synonym to frame() that is ambiguous => don't use it
+plotNew <- .Recode(graphics::plot.new) # () and synonym to frame() that is ambiguous => don't use it
## The simple dividing of equidistant boxes is done using plotOpt(mfrow) & plotOpt(mfcol)
@@ -124,8 +124,15 @@
## Problem with contour() # generic, add items to a graph when using add = TRUE
## We want the same mechanisms as for plot() vs points()/lines()... So, here,
## we must redefine a generic for that!
-ctrlines <- function (x, ...) UseMethod("ctrlines")
-ctrlines.default <- graphics::contour.default; formals(ctrlines.default)$add <- TRUE
+## We use contours() vs contourplot()
+contours <- function (x, ...) UseMethod("contours")
+contours.default <- function (x = seq(0, 1, length.out = nrow(z)),
+y = seq(0, 1, length.out = ncol(z)), z, labels = NULL, labcex = 0.6,
+drawlabels = TRUE, method = "flattest", col = par("fg"), lty = par("lty"),
+lwd = par("lwd"), add = TRUE, ...)
+ graphics::contour.default(x = x, y = y, z = z, labels = labels,
+ labcex = labcex, drawlabels = drawlabels, method = method, col = col,
+ lty = lty, lwd = lwd, add = add, ...)
## See also the shape package!
## qqlines() from stats
## plot() method of density object in stats + plot() method of hclust objects
@@ -145,10 +152,25 @@
#barplot() # generic
#boxplot() # generic
#contour() # generic, create a graph when using default add = FALSE; contourplot() in lattice!
-ctrplot <- graphics::contour
-filledplot <- graphics::filled.contour
+contourplot <- graphics::contour
+## R CMD check claims he does not find filledcontour => we don't copy the
+## function but call it from filledplot()
+filledplot <- function (x = seq(0, 1, length.out = nrow(z)), y = seq(0, 1,
+length.out = ncol(z)), z, xlim = range(x, finite = TRUE),
+ylim = range(y, finite = TRUE), zlim = range(z, finite = TRUE),
+levels = pretty(zlim, nlevels), nlevels = 20, color.palette = cm.colors,
+col = color.palette(length(levels) - 1), plot.title, plot.axes,
+key.title, key.axes, asp = NA, xaxs = "i", yaxs = "i", las = 1,
+axes = TRUE, frame.plot = axes, ...)
+ graphics::filled.contour(x = x, y = y, z = z, xlim = xlim, ylim = ylim,
+ zlim = zlim, levels = levels, nlevels = nlevels,
+ color.palette = color.palette, col = col, plot.title = plot.title,
+ plot.axes = plot.axes, key.title = key.title, key.axes = key.axes,
+ asp = asp, xaxs = xaxs, yaxs, yaxs, las = las, axes = axes,
+ frame.plot = frame.plot, ...)
starplot <- graphics::stars
-stemplot <- graphics::stem
+stemplot <- function (x, scale = 1, width = 80, atom = 1e-08)
+ graphics::stem(x = x, scale = scale, width = width, atom = atom)
stripplot <- graphics::stripchart
clevelandplot <- graphics::dotchart
smoothplot <- graphics::smoothScatter
@@ -180,8 +202,8 @@
# Not normally called by the end-user
## Covered functions: graphics::plot.window(), graphics::plot.xy(),
## graphics::.filled.contour(), graphics::bxp(),
-plotWindowInternal <- graphics::plot.window
-plotInternal <- graphics::plot.xy
+plotWindowInternal <- .Recode(graphics::plot.window)
+plotInternal <- .Recode(graphics::plot.xy)
boxplotInternal <- graphics::bxp
## Apparently not in R 2.14.0!
#filledplotInternal <- graphics::.filled.contour
@@ -191,56 +213,72 @@
## Devices management
devNew <- grDevices::dev.new
-devCur <- grDevices::dev.cur
+devCur <- .Recode(grDevices::dev.cur)
devList <- grDevices::dev.list
-devNext <- grDevices::dev.next; formals(devNext)$which <- quote(devCur())
-devPrev <- grDevices::dev.prev; formals(devPrev)$which <- quote(devCur())
-devSet <- grDevices::dev.set; formals(devSet)$which <- quote(devNext())
-devClose <- grDevices::dev.off; formals(devClose)$which <- quote(devCur())
+devNext <- .Recode(grDevices::dev.next); formals(devNext)$which <- quote(devCur())
+devPrev <- .Recode(grDevices::dev.prev); formals(devPrev)$which <- quote(devCur())
+devSet <- .Recode(grDevices::dev.set); formals(devSet)$which <- quote(devNext())
+devClose <- .Recode(grDevices::dev.off); formals(devClose)$which <- quote(devCur())
devCloseAll <- grDevices::graphics.off
-devControl <- grDevices::dev.control
-devHold <- grDevices::dev.hold
-devFlush <- grDevices::dev.flush
-devCopy <- grDevices::dev.copy
+devControl <- .Recode(grDevices::dev.control)
+
+## The following two functions call .Internal(devHoldFlush) and here R CMD check
+## got fooled because it does not found a function called devHoldFlush()
+## So, we define also a devHoldFlush() function here to cope with this problem
+devHold <- .Recode(grDevices::dev.hold)
+devFlush <- .Recode(grDevices::dev.flush)
+devHoldFlush <- function (level = 1L)
+{
+ level <- round(level)[1]
+ if (level > 0) {
+ devHold(level)
+ } else if (level < 0) {
+ devFlush(-level)
+ } else return()
+}
+devCopy <- .Recode(grDevices::dev.copy)
devCopyNew <- grDevices::dev.print
devCopyEps <- grDevices::dev.copy2eps
devCopyPdf <- grDevices::dev.copy2pdf
devCopyBitmap <- grDevices::dev2bitmap
-devSave <- grDevices::savePlot
-devRecord <- grDevices::recordPlot
-devReplay <- grDevices::replayPlot
-devCapture <- grDevices::dev.capture
+devSave <- .Recode(grDevices::savePlot)
+## Because these two function call .Internal() that fools R CMD check, we define
+## getSnapshot() and playSnapshot() as synonyms of devRecord() and devReplay()
+devRecord <- getSnapshot <- .Recode(grDevices::recordPlot)
+devReplay <- playSnapshot <- .Recode(grDevices::replayPlot)
+devCapture <- .Recode(grDevices::dev.capture)
#devAskNewPage()
## For devSize, default unit is "cm" instead of "in" for dev.size()
-devSize <- grDevices::dev.size; formals(devSize)$units <- c("cm", "in", "px")
-devCapabilities <- grDevices::dev.capabilities
+devSize <- .Recode(grDevices::dev.size); formals(devSize)$units <- c("cm", "in", "px")
+devCapabilities <- .Recode(grDevices::dev.capabilities)
devInteractive <- grDevices::dev.interactive
isDevInteractive <- grDevices::deviceIsInteractive
+## TODO: a way to define these functions as platform independent!
## Graphic devices
-if (.Platform$OS.type == "unix") {
- devX11 <- grDevices::X11 # + x11()
- devX11Opt <- grDevices::X11.options
-}
-if (grepl("^mac", .Platform$pkgType)) {
- devQuartz <- grDevices::quartz
- devQuartzOpt <- grDevices::quartz.options
- ## There is a quartz.save() function defined somewhere!
-}
-if (.Platform$OS.type == "windows") {
- devWin <- grDevices::windows
- devWinOpt <- grDevices::windows.options
- devWinPrint <- grDevices::win.print
- devWinMetafile <- grDevices::win.metafile
- devToTop <- grDevices::bringToTop # TODO: a similar function for Linux and Mac OS X!
- formals(devToTop)$which <- quote(devCur())
- # this is bringToTop(which = dev.cur(), stay = FALSE) # with -1 is console
- devMsg <- grDevices::msgWindow
- formals(devMsg)$which <- quote(devCur()) # TODO: a similar function for Linux and Mac OS X
- # this is msgWindow(type = c("minimize", "restore", "maximize", "hide", "recordOn", "recordOff"),
- # which = dev.cur()
- #recordGraphics(expr, list, env) # A function intended *only* for experts
-}
+#if (.Platform$OS.type == "unix") {
+# devX11 <- grDevices::X11 # + x11()
+# devX11Opt <- grDevices::X11.options
+#}
+#if (grepl("^mac", .Platform$pkgType)) {
+# devQuartz <- grDevices::quartz
+# devQuartzOpt <- grDevices::quartz.options
+# ## There is a quartz.save() function defined somewhere!
+#}
+#if (.Platform$OS.type == "windows") {
+# devWin <- grDevices::windows
+# devWinOpt <- grDevices::windows.options
+# devWinPrint <- grDevices::win.print
+# devWinMetafile <- grDevices::win.metafile
+# devToTop <- grDevices::bringToTop # TODO: a similar function for Linux and Mac OS X!
+# formals(devToTop)$which <- quote(devCur())
+# # this is bringToTop(which = dev.cur(), stay = FALSE) # with -1 is console
+# devMsg <- grDevices::msgWindow
+# formals(devMsg)$which <- quote(devCur()) # TODO: a similar function for Linux and Mac OS X
+# # this is msgWindow(type = c("minimize", "restore", "maximize", "hide", "recordOn", "recordOff"),
+# # which = dev.cur()
+# #recordGraphics(expr, list, env) # A function intended *only* for experts
+#}
devPdf <- grDevices::pdf
devPdfOpt <- grDevices::pdf.options
devPS <- grDevices::postscript
@@ -250,18 +288,42 @@
devPdfCairo <- grDevices::cairo_pdf
devPSCairo <- grDevices::cairo_ps
devSvg <- grDevices::svg
-devBmp <- grDevices::bmp
-devJpeg <- grDevices::jpeg
-devPng <- grDevices::png
-devTiff <- grDevices::tiff
devBitmap <- grDevices::bitmap
devXfig <- grDevices::xfig
+
+## The following four functions call .Internal(X11) which has more arguments
+## than X11 itself => we don't copy content, but call it instead
+devBmp <- function (filename = "Rplot%03d.bmp", width = 480, height = 480,
+units = "px", pointsize = 12, bg = "white", res = NA, ...,
+type = c("cairo", "Xlib", "quartz"), antialias)
+ grDevices::bmp(filename = filename, width = width, height = height,
+ units = units, pointsize = pointsize, bg = bg, res = res, ...,
+ type = type, antialias = antialias)
+devJpeg <- function (filename = "Rplot%03d.jpeg", width = 480, height = 480,
+units = "px", pointsize = 12, quality = 75, bg = "white",
+res = NA, ..., type = c("cairo", "Xlib", "quartz"), antialias)
+ grDevices::jpeg(filename = filename, width = width, height = height,
+ units = units, pointsize = pointsize, quality = quality, bg = bg,
+ res = res, ..., type = type, antialias = antialias)
+devPng <- function (filename = "Rplot%03d.png", width = 480, height = 480,
+units = "px", pointsize = 12, bg = "white", res = NA, ...,
+type = c("cairo", "cairo-png", "Xlib", "quartz"), antialias)
+ grDevices::png(filename = filename, width = width, height = height,
+ units = units, pointsize = pointsize, bg = bg, res = res, ...,
+ type = type, antialias = antialias)
+devTiff <- function (filename = "Rplot%03d.tiff", width = 480, height = 480,
+units = "px", pointsize = 12, compression = c("none", "rle",
+"lzw", "jpeg", "zip"), bg = "white", res = NA, ..., type = c("cairo",
+"Xlib", "quartz"), antialias)
+ grDevices::tiff(filename = filename, width = width, height = height,
+ units = units, pointsize = pointsize, compression = compression,
+ bg = bg, res = res, ..., type = type, antialias = antialias)
#pictex() # device, historical interest only
## Color management
#palette() # get or set the color palette
#colors() and colours() for a list of color names
-color2rgb <- grDevices::col2rgb # convert colors to rgb
+color2rgb <- .Recode(grDevices::col2rgb) # convert colors to rgb
#rgb()
#rgb2hsv()
#hsv()
@@ -271,28 +333,28 @@
#colorRamp() and colorRampPalette() to create color ramps
colorDens <- grDevices::densCols
## Predefined color sets
-colorBlues9 <- grDevices::blues9
+colorBlues9 <- function () grDevices::blues9
colorRainbow <- grDevices::rainbow
colorHeat <- grDevices::heat.colors
colorTerrain <- grDevices::terrain.colors
colorTopo <- grDevices::topo.colors
-colorCM <- grDevices::cm.colors
-colorCWM <- cwm.colors
-colorRWB <- rwb.colors
-colorRYG <- ryg.colors
+colorCm <- grDevices::cm.colors
+colorCwm <- cwm.colors
+colorRwb <- rwb.colors
+colorRyg <- ryg.colors
colorGray <- grDevices::gray.colors
colorGrey <- grDevices::grey.colors
## colorConverter object
#colorConverter()
-colorConverterRgb <- grDevices::make.rgb
+colorConvertRgb <- grDevices::make.rgb
colorConvert <- grDevices::convertColor
## Fonts
-type1Font <- grDevices::Type1Font
-cidFont <- grDevices::CIDFont
-psFonts <- grDevices::postscriptFonts
-#pdfFonts()
-#embedFonts()
+fontType1 <- grDevices::Type1Font
+fontCid <- grDevices::CIDFont
+fontsPS <- grDevices::postscriptFonts
+fontsPdf <- grDevices::pdfFonts
+fontsEmbed <- grDevices::embedFonts
#if (.Platform$OS.type == "windows") {
# #windowsFont()
# #windowsFonts()
@@ -323,7 +385,7 @@
#as.graphicsAnnot()
## Utility functions
-checkOpt <- grDevices::check.options #utility function to check options consistency!
+optCheck <- grDevices::check.options #utility function to check options consistency!
nclassSturges <- grDevices::nclass.Sturges
nclassScott <- grDevices::nclass.scott
nclassFD <- grDevices::nclass.FD
Modified: pkg/SciViews/R/misc.R
===================================================================
--- pkg/SciViews/R/misc.R 2012-12-04 13:40:43 UTC (rev 487)
+++ pkg/SciViews/R/misc.R 2012-12-07 15:21:47 UTC (rev 488)
@@ -2,7 +2,18 @@
## Note to get a function, but change its default parameters, use:
## fun2 <- fun
## formals(fun2)$arg <- newDefaultValue
+##
+## Note that we should do something about T and F!!!
+## Warn when using = instead of <- for assignation...
+## if option warnAssignWithEqualSign is TRUE
+`=` <- function(x, value)
+{
+ if (isTRUE(getOption("warnAssignWithEqualSign")))
+ warning("Use <- instead of = for assignation, or use == for equalty test")
+ assign(deparse(substitute(x)), value, envir = parent.frame())
+}
+
# is.wholenumber(), see ?as.integer => define isWholeInt?
## A convenient starting object for holding items: . == .GlobalEnv
@@ -14,7 +25,7 @@
## to use if (!length(obj)), but it would be more intuitive to define:
## TODO: isEmpty is a generic function (or even S4?) in filehash that does
## something different => change the name!
-isEmpty <- function (x) return(!length(x))
+isEmpty <- function (x) !length(x)
ifElse <- get("ifelse", envir = baseenv())
@@ -28,7 +39,7 @@
# res <- try(...., silent = TRUE)
# if (inherits(res, "try-error")) stop(msg)
-enum <- function (x) return(seq_along(x))
+enum <- function (x) seq_along(x)
## Defines only increasing integer sequences
`%:%` <- function (lower, upper)
@@ -37,7 +48,7 @@
## 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))
+# for (ii in enum(v)) print(v)
## is fine too!
## A better require()
@@ -48,19 +59,21 @@
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))
+ if (!res) error else invisible(res)
}
-## Now, we want to be able to use names() on it too!
+## Now, we want to be able to use names() on environments 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.names = TRUE) else base::names(x)
-## Do we implement `names<-` for environments???
+## Do we implement `names<-` for environments??? This is a nonsense, may be?
## Simpler names for often used functions
-n <- base::as.numeric # TODO: define a "n" object?
-i <- base::as.integer
+num <- base::as.numeric
+int <- base::as.integer
+char <- base::as.character
+logic <- base::as.logical
## To avoid problems with factors, tell to always use s(f1), or n(f1)/i(f1)
## Since n is already used for a synonym of as.numeric(), I use l() here
@@ -77,7 +90,7 @@
## Instead of apply(x, 2, sum), it gives apply(x, Cols, sum)
## I don't like isTRUE, because if there is an attribute attached to TRUE,
-## it returns FALSE! =>
+## it returns FALSE! => define asTRUE which is more permissive!
asTRUE <- function (x) identical(TRUE, as.logical(x))
isFALSE <- function (x) identical(FALSE, x)
asFALSE <- function (x) identical(FALSE, as.logical(x))
@@ -112,17 +125,16 @@
## Ternary condition statement, like in JavaScript cond ? yes : no
## Not possible to do in R... but the closest is:
-`%?%` <- function (cond, yes.no) { if (cond) yes.no[1] else yes.no[2] }
+#`%?%` <- function (cond, yes.no) { if (cond) yes.no[1] else yes.no[2] }
## ... and its vectorized conterpart:
-`%??%` <- function (cond, yes.no) ifelse(cond, yes = yes.no[1], no = yes.no[2])
+#`%??%` <- function (cond, yes.no) ifelse(cond, yes = yes.no[1], no = yes.no[2])
+#TRUE %?% c(1, 2)
+#FALSE %?% c(yes = 1, no = 2)
+#x <- 1:3
+#res <- any(x > 2) %?% c("yes", "no"); res
+#res <- (x > 2) %??% c("yes", "no"); res # Take care of parentheses!
+#rm(x, res)
-TRUE %?% c(1, 2)
-FALSE %?% c(yes = 1, no = 2)
-x <- 1:3
-res <- any(x > 2) %?% c("yes", "no"); res
-res <- (x > 2) %??% c("yes", "no"); res # Take care of parentheses!
-rm(x, res)
-
## It is common to test if something is zero, or one... Here, the non vectorized
## version asks for all items being zero or one, excluding missing data!
## TODO: good idea (perhaps)... but this does not work well!
@@ -130,7 +142,6 @@
#`%?1%` <- function (x, yes.no) { if (all.(x == 1)) yes.no[1] else yes.no[2] }
#`%??0%` <- function (x, yes.no) ifelse(x == 0, yes = yes.no[1], no = yes.no[2])
#`%??1%` <- function (x, yes.no) ifelse(x == 1, yes = yes.no[1], no = yes.no[2])
-
#x <- 1; x %?0% c(yes = stop("x must be non null"), no = x^2)
#x <- 0; x %?0% c(yes = stop("x must be non null"), no = x^2)
## This helps to construct sentences with single or plural
@@ -384,20 +395,20 @@
## Use of frame as a synonym of environment brings an additional difficulty on
## an already difficult subject! => use env(ironment) everywhere?!
## TODO: all these sys.xxx must remain like this!
-sysFunction <- base::sys.function
-sysCall <- base::sys.call
-sysCalls <- base::sys.calls
-matchCall <- base::match.call
-sysParent <- base::sys.parent
-sysParents <- base::sys.parents
+sysFunction <- .Recode(base::sys.function)
+sysCall <- .Recode(base::sys.call)
+sysCalls <- .Recode(base::sys.calls)
+matchCall <- .Recode(base::match.call)
+sysParent <- .Recode(base::sys.parent)
+sysParents <- .Recode(base::sys.parents)
## TODO: do not use frame => what??? sys.prevEnv()??
-parentFrame <- base::parent.frame
-sysFrame <- base::sys.frame
-sysFrames <- base::sys.frames
-sysnFrame <- base::sys.nframe
+parentFrame <- .Recode(base::parent.frame)
+sysFrame <- .Recode(base::sys.frame)
+sysFrames <- .Recode(base::sys.frames)
+sysnFrame <- .Recode(base::sys.nframe)
sysStatus <- base::sys.status
onExit <- function (expr = NULL, add = FALSE) base::on.exit(expr = expr, add = add)
-sysOnExit <- base::sys.on.exit
+sysOnExit <- .Recode(base::sys.on.exit)
dumpFrames <- utils::dump.frames
#debugger(dump = last.dump) # utils
#browser()
@@ -406,8 +417,8 @@
#browserSetDebug()
#debug()
#undebug()
-debugOnce <- base::debugonce
-isDebugged <- base::isdebugged
+debugOnce <- .Recode(base::debugonce)
+isDebugged <- .Recode(base::isdebugged)
baseEnv <- base::baseenv
.BaseEnv <- base::baseenv()
baseNamespaceEnv <- function () return(.BaseNamespaceEnv)
@@ -423,26 +434,29 @@
tempEnv <- svMisc::TempEnv
.TempEnv <- svMisc::TempEnv()
## TODO: or sys.topEnv()???
-topEnv <- base::topenv
+## RCMD check claims he cannot find isNamespaceEnv() in topEnv() => provide it
+isNamespaceEnv <- function (envir = parentFrame())
+ .Intern(isNamespaceEnv(envir))
+topEnv <- .Recode(base::topenv)
# Usually, to create an object, we use its name, but
## environment() means something else here!
## So, OK, we'll stick with:
-environmentNew <- base::new.env
+environmentNew <- .Recode(base::new.env)
## Should not be used!
-environmentParent <- base::parent.env
-`environmentParent<-` <- base::`parent.env<-`
+environmentParent <- .Recode(base::parent.env)
+`environmentParent<-` <- .Recode(base::`parent.env<-`)
#environmentName()
#environment()
#`environment<-`()
#is.environment()
-environmentProfile <- base::env.profile
+environmentProfile <- .Recode(base::env.profile)
## name attribute to an environment,... see ?environment
#source()
sysSource <- base::sys.source
#.First.sys and .Last.sys cannot be changed!
#eval()
-evalQuote <- base::evalq
+evalQuote <- .Recode(base::evalq)
evalParent <- base::eval.parent
evalLocal <- base::local
More information about the Sciviews-commits
mailing list