[rkward-cvs] SF.net SVN: rkward:[2892] trunk/rkward/rkward/rbackend/rpackages/rkward/R
kapatp at users.sourceforge.net
kapatp at users.sourceforge.net
Wed Jun 23 05:34:48 UTC 2010
Revision: 2892
http://rkward.svn.sourceforge.net/rkward/?rev=2892&view=rev
Author: kapatp
Date: 2010-06-23 05:34:48 +0000 (Wed, 23 Jun 2010)
Log Message:
-----------
Collect graphics related functions into separate files.
Modified Paths:
--------------
trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R
trunk/rkward/rkward/rbackend/rpackages/rkward/R/public.R
Added Paths:
-----------
trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R
trunk/rkward/rkward/rbackend/rpackages/rkward/R/public_graphics.R
Modified: trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R 2010-06-22 11:53:35 UTC (rev 2891)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R 2010-06-23 05:34:48 UTC (rev 2892)
@@ -141,41 +141,6 @@
# .Internal (.addCondHands (c ("message", "warning", "error"), list (function (m) { .Call ("rk.do.condition", c ("m", conditionMessage (m))) }, function (w) { .Call ("rk.do.condition", c ("w", conditionMessage (w))) }, function (e) { .Call ("rk.do.condition", c ("e", conditionMessage (e))) }), globalenv (), NULL, TRUE))
#}
-# overriding x11 to get informed, when a new x11 window is opened
-"rk.screen.device" <- function (...) {
- .rk.do.call ("startOpenX11", as.character (dev.cur ()));
-
- if (!exists (".rk.default.device")) {
- if (base::.Platform$OS.type == "unix") {
- device <- grDevices::x11
- } else {
- device <- grDevices::windows
- }
- } else {
- device <- .rk.default.device
- if (is.character (.rk.default.device)) {
- device <- get (.rk.default.device)
- }
- }
- x <- device (...)
-
- .rk.do.call ("endOpenX11", as.character (dev.cur ()));
-
- invisible (x)
-}
-
-"x11" <- rk.screen.device
-
-"X11" <- x11
-
-if (base::.Platform$OS.type == "windows") {
- "windows" = rk.screen.device
- "win.graph" = rk.screen.device
-}
-
-# set from rkward the application:
-# options(device="rk.screen.device")
-
# these functions can be used to track assignments to R objects. The main interfaces are .rk.watch.symbol (k) and .rk.unwatch.symbol (k). This works by copying the symbol to a backup environment, removing it, and replacing it by an active binding to the backup location
".rk.watched.symbols" <- new.env ()
@@ -333,31 +298,6 @@
".rk.set.reply" <- function (x) .rk.rkreply <<- x
-".rk.preview.devices" <- list ();
-
-".rk.startPreviewDevice" <- function (x) {
- a <- .rk.preview.devices[[x]]
- if (is.null (a)) {
- a <- dev.cur ()
- x11 ()
- if (a != dev.cur ()) {
- .rk.preview.devices[[x]] <<- dev.cur ()
- }
- } else {
- dev.set (a)
- }
-}
-
-".rk.killPreviewDevice" <- function (x) {
- a <- .rk.preview.devices[[x]]
- if (!is.null (a)) {
- .rk.preview.devices[[x]] <<- NULL
- if (a %in% dev.list ()) {
- dev.off (a)
- }
- }
-}
-
"Sys.setlocale" <- function (category = "LC_ALL", locale = "", ...) {
if (category == "LC_ALL" || category == "LC_CTYPE" || category == "LANG") {
.rk.do.call ("preLocaleChange", NULL);
@@ -473,18 +413,12 @@
formals (menu) <- formals (utils::menu)
.rk.menu.default <- utils::menu
-"plot.new" <- function ()
-{
- rk.record.plot$record ()
- eval (body (.rk.plot.new.default))
-}
-formals (plot.new) <- formals (graphics::plot.new)
-.rk.plot.new.default <- graphics::plot.new
-
# where masking is not enough, we need to assign in the namespace. This can only be done after package loading,
# so we have a separate function for that.
".rk.fix.assignments" <- function () {
assignInNamespace ("menu", menu, envir=as.environment ("package:utils"))
assignInNamespace ("select.list", select.list, envir=as.environment ("package:utils"))
- assignInNamespace ("plot.new", plot.new, envir=as.environment ("package:graphics"))
+
+ # call separate assignments functions:
+ eval (body (.rk.fix.assignments.graphics)) # internal_graphics.R
}
Added: trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R (rev 0)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R 2010-06-23 05:34:48 UTC (rev 2892)
@@ -0,0 +1,75 @@
+## Internal functions manipulating graphics should be stored here.
+## These functions are _not_ supposed to be called by the end user.
+
+# overriding x11 to get informed, when a new x11 window is opened
+"rk.screen.device" <- function (...) {
+ .rk.do.call ("startOpenX11", as.character (dev.cur ()));
+
+ if (!exists (".rk.default.device")) {
+ if (base::.Platform$OS.type == "unix") {
+ device <- grDevices::x11
+ } else {
+ device <- grDevices::windows
+ }
+ } else {
+ device <- .rk.default.device
+ if (is.character (.rk.default.device)) {
+ device <- get (.rk.default.device)
+ }
+ }
+ x <- device (...)
+
+ .rk.do.call ("endOpenX11", as.character (dev.cur ()));
+
+ invisible (x)
+}
+
+"x11" <- rk.screen.device
+
+"X11" <- x11
+
+if (base::.Platform$OS.type == "windows") {
+ "windows" = rk.screen.device
+ "win.graph" = rk.screen.device
+}
+
+# set from rkward the application:
+# options(device="rk.screen.device")
+
+".rk.preview.devices" <- list ();
+
+".rk.startPreviewDevice" <- function (x) {
+ a <- .rk.preview.devices[[x]]
+ if (is.null (a)) {
+ a <- dev.cur ()
+ x11 ()
+ if (a != dev.cur ()) {
+ .rk.preview.devices[[x]] <<- dev.cur ()
+ }
+ } else {
+ dev.set (a)
+ }
+}
+
+".rk.killPreviewDevice" <- function (x) {
+ a <- .rk.preview.devices[[x]]
+ if (!is.null (a)) {
+ .rk.preview.devices[[x]] <<- NULL
+ if (a %in% dev.list ()) {
+ dev.off (a)
+ }
+ }
+}
+
+"plot.new" <- function ()
+{
+ rk.record.plot$record ()
+ eval (body (.rk.plot.new.default))
+}
+formals (plot.new) <- formals (graphics::plot.new)
+.rk.plot.new.default <- graphics::plot.new
+
+# see .rk.fix.assignmetns () in internal.R
+".rk.fix.assignments.graphics" <- function () {
+ assignInNamespace ("plot.new", plot.new, envir=as.environment ("package:graphics"))
+}
Modified: trunk/rkward/rkward/rbackend/rpackages/rkward/R/public.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/R/public.R 2010-06-22 11:53:35 UTC (rev 2891)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/R/public.R 2010-06-23 05:34:48 UTC (rev 2892)
@@ -144,52 +144,6 @@
error ("Could not find column with given name")
}
-# Requests a graph to be written.
-rk.graph.on <- function (device.type=getOption ("rk.graphics.type"), width=getOption ("rk.graphics.width"), height=getOption ("rk.graphics.height"), quality, ...)
-{
- if (!is.numeric (width)) width <- 480
- if (!is.numeric (height)) height <- 480
- if (is.null (device.type)) device.type <- "PNG" # default behavior is PNG for now
-
- ret <- NULL
- if (device.type == "PNG") {
- filename <- rk.get.tempfile.name(prefix = "graph", extension = ".png")
- ret <- png(filename = file.path(filename), width = width, height = height, ...)
- .rk.cat.output(paste("<img src=\"", filename, "\" width=\"", width,
- "\" height=\"", height, "\"><br>", sep = ""))
- } else if (device.type == "JPG") {
- if (missing (quality)) {
- quality = getOption ("rk.graphics.jpg.quality") # COMPAT: getOption (x, *default*) not yet available in R 2.9
- if (is.null (quality)) quality = 75
- }
- filename <- rk.get.tempfile.name(prefix = "graph", extension = ".jpg")
- ret <- jpeg(filename = file.path(filename), width = width, height = height, "quality"=quality, ...)
- .rk.cat.output(paste("<img src=\"", filename, "\" width=\"", width,
- "\" height=\"", height, "\"><br>", sep = ""))
- } else if (device.type == "SVG") {
- if (!capabilities ("cairo")) { # cairo support is not always compiled in
- require (cairoDevice)
- svg <- Cairo_svg
- }
- filename <- rk.get.tempfile.name(prefix = "graph", extension = ".svg")
- ret <- svg(filename = file.path(filename), ...)
- .rk.cat.output(paste("<object data=\"", filename, "\" type=\"image/svg+xml\" width=\"", width,
- "\" height=\"", height, "\">\n", sep = ""))
- .rk.cat.output(paste("<param name=\"src\" value=\"", filename, "\">\n", sep = ""))
- .rk.cat.output(paste("This browser appears incapable of displaying SVG object. The SVG source is at:", filename))
- .rk.cat.output("</object>")
- } else {
- stop (paste ("Device type \"", device.type, "\" is unknown to RKWard", sep=""))
- }
-
- invisible (ret)
-}
-
-"rk.graph.off" <- function(){
- .rk.cat.output ("\n") # so the output will be auto-refreshed
- dev.off()
-}
-
"rk.print" <- function(x,...) {
htmlfile <- rk.get.output.html.file()
if(require("R2HTML")==TRUE) {
@@ -462,112 +416,3 @@
.rk.do.call ("select.list", params)
}
-
-# create a (global) history of various graphics calls - a rudimentary attempt
-# can do: record, showPrevious, showNext, replay
-"rk.record.plot" <- function ()
-{
- # TODO:
- # - record / show from which device? - Partially implemented
- # - Create separate history for each device?
- # - Destroy the history when a device is closed?
- # - .... ?
-
- env <- environment()
- recorded <- list()
- current <- numeric (length(dev.list()) + 2); # 1 is always null device
- newPlotExists <- FALSE
-
- onAddDevice <- function (deviceId)
- {
- recordUnsaved (deviceId)
- current <<- c(current, current[deviceId])
- }
- onDelDevice <- function (deviceId = dev.cur())
- {
- recordUnsaved (deviceId)
- current <<- current[-deviceId]
- }
- record <- function(newplotflag = TRUE, force = FALSE)
- {
- if (newPlotExists) {
- if (class (try (unsavedPlot <- recordPlot(), silent=TRUE)) != 'try-error')
- {
- current[dev.cur()] <<- length(recorded) + 1L
- recorded[[current[dev.cur()]]] <<- unsavedPlot
- }
- }
- if (force) {
- if (class (try (unsavedPlot <- recordPlot(), silent=TRUE)) != 'try-error')
- {
- recorded[[current[dev.cur()]]] <<- unsavedPlot
- }
- }
- newPlotExists <<- newplotflag
- }
- recordUnsaved <- function (deviceId)
- {
- if ((current[deviceId] == length (recorded)) && newPlotExists) {
- record (newplotflag = FALSE)
- }
- }
- replay <- function(n = current[dev.cur()] - 1L, deviceId = dev.cur ())
- {
- if (n > 0 && n <= length(recorded)) {
- current[deviceId] <<- n
- replayPlot(recorded[[n]])
- }
- #else message("'n' not in valid range: ", n)
- }
- restore <- function() replay(n = length(recorded))
- showPrevious <- function(deviceId)
- {
- recordUnsaved (deviceId)
- replay(n = current[deviceId] - 1L, deviceId = deviceId)
- }
- showNext <- function(deviceId)
- {
- recordUnsaved (deviceId)
- replay(n = current[deviceId] + 1L, deviceId = deviceId)
- }
- resetHistory <- function ()
- {
- recorded <<- list()
- current <<- numeric (length(dev.list()) + 2)
- newPlotExists <<- FALSE
-
- }
- env
-}
-rk.record.plot <- rk.record.plot ()
-
-# quick wrappers around rk.record.plot$show{Previous,Next} :
-# 1 is always the null device
-"rk.next.plot" <- function (deviceId = 2)
-{
- # TODO - utilze the device number when rk.record.plot matures
- cur.deviceId <- dev.cur ()
- dev.set (which = deviceId)
- rk.record.plot$showNext (deviceId)
- dev.set (which = cur.deviceId)
- invisible ()
-}
-"rk.current.plot" <- function (deviceId = 2)
-{
- # TODO - utilze the device number when rk.record.plot matures
- cur.deviceId <- dev.cur ()
- dev.set (which = deviceId)
- rk.record.plot$record (newplotflag=FALSE, force=TRUE)
- dev.set (which = cur.deviceId)
- invisible ()
-}
-"rk.previous.plot" <- function (deviceId = 2)
-{
- # TODO - utilze the device number when rk.record.plot matures
- cur.deviceId <- dev.cur ()
- dev.set (which = deviceId)
- rk.record.plot$showPrevious (deviceId)
- dev.set (which = cur.deviceId)
- invisible ()
-}
-
Added: trunk/rkward/rkward/rbackend/rpackages/rkward/R/public_graphics.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/R/public_graphics.R (rev 0)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/R/public_graphics.R 2010-06-23 05:34:48 UTC (rev 2892)
@@ -0,0 +1,157 @@
+## Public functions manipulating "graphics" should be stored here.
+## These functions are accessible to the user.
+
+# Requests a graph to be written.
+rk.graph.on <- function (device.type=getOption ("rk.graphics.type"), width=getOption ("rk.graphics.width"), height=getOption ("rk.graphics.height"), quality, ...)
+{
+ if (!is.numeric (width)) width <- 480
+ if (!is.numeric (height)) height <- 480
+ if (is.null (device.type)) device.type <- "PNG" # default behavior is PNG for now
+
+ ret <- NULL
+ if (device.type == "PNG") {
+ filename <- rk.get.tempfile.name(prefix = "graph", extension = ".png")
+ ret <- png(filename = file.path(filename), width = width, height = height, ...)
+ .rk.cat.output(paste("<img src=\"", filename, "\" width=\"", width,
+ "\" height=\"", height, "\"><br>", sep = ""))
+ } else if (device.type == "JPG") {
+ if (missing (quality)) {
+ quality = getOption ("rk.graphics.jpg.quality") # COMPAT: getOption (x, *default*) not yet available in R 2.9
+ if (is.null (quality)) quality = 75
+ }
+ filename <- rk.get.tempfile.name(prefix = "graph", extension = ".jpg")
+ ret <- jpeg(filename = file.path(filename), width = width, height = height, "quality"=quality, ...)
+ .rk.cat.output(paste("<img src=\"", filename, "\" width=\"", width,
+ "\" height=\"", height, "\"><br>", sep = ""))
+ } else if (device.type == "SVG") {
+ if (!capabilities ("cairo")) { # cairo support is not always compiled in
+ require (cairoDevice)
+ svg <- Cairo_svg
+ }
+ filename <- rk.get.tempfile.name(prefix = "graph", extension = ".svg")
+ ret <- svg(filename = file.path(filename), ...)
+ .rk.cat.output(paste("<object data=\"", filename, "\" type=\"image/svg+xml\" width=\"", width,
+ "\" height=\"", height, "\">\n", sep = ""))
+ .rk.cat.output(paste("<param name=\"src\" value=\"", filename, "\">\n", sep = ""))
+ .rk.cat.output(paste("This browser appears incapable of displaying SVG object. The SVG source is at:", filename))
+ .rk.cat.output("</object>")
+ } else {
+ stop (paste ("Device type \"", device.type, "\" is unknown to RKWard", sep=""))
+ }
+
+ invisible (ret)
+}
+
+"rk.graph.off" <- function(){
+ .rk.cat.output ("\n") # so the output will be auto-refreshed
+ dev.off()
+}
+
+# create a (global) history of various graphics calls - a rudimentary attempt
+# can do: record, showPrevious, showNext, replay
+"rk.record.plot" <- function ()
+{
+ # TODO:
+ # - record / show from which device? - Partially implemented
+ # - Create separate history for each device?
+ # - Destroy the history when a device is closed?
+ # - .... ?
+
+ env <- environment()
+ recorded <- list()
+ current <- numeric (length(dev.list()) + 2); # 1 is always null device
+ newPlotExists <- FALSE
+
+ onAddDevice <- function (deviceId)
+ {
+ recordUnsaved (deviceId)
+ current <<- c(current, current[deviceId])
+ }
+ onDelDevice <- function (deviceId = dev.cur())
+ {
+ recordUnsaved (deviceId)
+ current <<- current[-deviceId]
+ }
+ record <- function(newplotflag = TRUE, force = FALSE)
+ {
+ if (newPlotExists) {
+ if (class (try (unsavedPlot <- recordPlot(), silent=TRUE)) != 'try-error')
+ {
+ current[dev.cur()] <<- length(recorded) + 1L
+ recorded[[current[dev.cur()]]] <<- unsavedPlot
+ }
+ }
+ if (force) {
+ if (class (try (unsavedPlot <- recordPlot(), silent=TRUE)) != 'try-error')
+ {
+ recorded[[current[dev.cur()]]] <<- unsavedPlot
+ }
+ }
+ newPlotExists <<- newplotflag
+ }
+ recordUnsaved <- function (deviceId)
+ {
+ if ((current[deviceId] == length (recorded)) && newPlotExists) {
+ record (newplotflag = FALSE)
+ }
+ }
+ replay <- function(n = current[dev.cur()] - 1L, deviceId = dev.cur ())
+ {
+ if (n > 0 && n <= length(recorded)) {
+ current[deviceId] <<- n
+ replayPlot(recorded[[n]])
+ }
+ #else message("'n' not in valid range: ", n)
+ }
+ restore <- function() replay(n = length(recorded))
+ showPrevious <- function(deviceId)
+ {
+ recordUnsaved (deviceId)
+ replay(n = current[deviceId] - 1L, deviceId = deviceId)
+ }
+ showNext <- function(deviceId)
+ {
+ recordUnsaved (deviceId)
+ replay(n = current[deviceId] + 1L, deviceId = deviceId)
+ }
+ resetHistory <- function ()
+ {
+ recorded <<- list()
+ current <<- numeric (length(dev.list()) + 2)
+ newPlotExists <<- FALSE
+
+ }
+ env
+}
+rk.record.plot <- rk.record.plot ()
+
+# quick wrappers around rk.record.plot$show{Previous,Next} :
+# 1 is always the null device
+"rk.next.plot" <- function (deviceId = 2)
+{
+ # TODO - utilze the device number when rk.record.plot matures
+ cur.deviceId <- dev.cur ()
+ dev.set (which = deviceId)
+ rk.record.plot$showNext (deviceId)
+ dev.set (which = cur.deviceId)
+ invisible ()
+}
+"rk.current.plot" <- function (deviceId = 2)
+{
+ # TODO - utilze the device number when rk.record.plot matures
+ cur.deviceId <- dev.cur ()
+ dev.set (which = deviceId)
+ rk.record.plot$record (newplotflag=FALSE, force=TRUE)
+ dev.set (which = cur.deviceId)
+ invisible ()
+}
+"rk.previous.plot" <- function (deviceId = 2)
+{
+ # TODO - utilze the device number when rk.record.plot matures
+ cur.deviceId <- dev.cur ()
+ dev.set (which = deviceId)
+ rk.record.plot$showPrevious (deviceId)
+ dev.set (which = cur.deviceId)
+ invisible ()
+}
+
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
More information about the rkward-tracker
mailing list