[rkward-cvs] SF.net SVN: rkward:[3413] trunk/rkward/rkward/rbackend/rpackages/rkward
tfry at users.sourceforge.net
tfry at users.sourceforge.net
Thu Feb 3 15:15:14 UTC 2011
Revision: 3413
http://rkward.svn.sourceforge.net/rkward/?rev=3413&view=rev
Author: tfry
Date: 2011-02-03 15:15:13 +0000 (Thu, 03 Feb 2011)
Log Message:
-----------
Function replacements need to be generated at runtime, not at package installation time.
Introduce utility function rk.replace.function to make this a bit easier.
Modified Paths:
--------------
trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R
trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R
Added Paths:
-----------
trunk/rkward/rkward/rbackend/rpackages/rkward/man/rk.replace.function.Rd
Modified: trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R 2011-02-02 13:08:17 UTC (rev 3412)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R 2011-02-03 15:15:13 UTC (rev 3413)
@@ -392,22 +392,6 @@
}
}
-## History manipulation function (overloads for functions by the same name in package utils)
-"loadhistory" <- function (file = ".Rhistory") {
- invisible (.rk.do.call ("commandHistory", c ("set", readLines (file))))
-}
-
-"savehistory" <- function (file = ".Rhistory") {
- invisible (writeLines (.rk.do.call ("commandHistory", "get"), file))
-}
-
-"timestamp" <- function (stamp = date(), prefix = "##------ ", suffix = " ------##", quiet = FALSE) {
- stamp <- paste(prefix, stamp, suffix, sep = "")
- .rk.do.call (.rk.do.call ("commandHistory", c ("append", stamp)))
- if (!quiet) cat(stamp, sep = "\n")
- invisible(stamp)
-}
-
# retrieve the (expected) "base" url of help files. Most importantly this will be a local port for R 2.10.0 and above, but a local directory for 2.9.x and below. As a side effect, in R 2.10.0 and above, the dynamic help server is started.
".rk.getHelpBaseUrl" <- function () {
port <- NA
@@ -443,82 +427,111 @@
invisible (TRUE)
}
-"select.list" <- function () {
- # the "list" parameter was renamed to "choices" in R 2.11.0
- if (!exists ("list", inherits=FALSE)) list <- choices
- # the "graphics" parameter was introduced in R 2.11.0, so we cannot rely on its existance
- if (!exists ("graphics", inherits=FALSE)) graphics <- TRUE
- if (graphics) {
- return (rk.select.list (list, preselect, multiple, title))
- }
+# Tries to replace a function inside its environemnt/namespace.
+# Function formals are copied from the original.
+# A backup of the original is stored as rkward::.rk.FUNCTIONNAME.default
+"rk.replace.function" <- function (functionname, environment, replacement, copy.formals=TRUE) {
+ original <- get (functionname, envir=environment, inherits=FALSE)
- # for text list, use the default implementation
- eval (body (.rk.select.list.default))
-}
-formals (select.list) <- formals (utils::select.list)
-.rk.select.list.default <- utils::select.list
+ # create a backup
+ backupname <- paste (".rk.", functionname, ".default", sep="")
+ assign (backupname, original, envir=as.environment ("package:rkward"))
-"menu" <- function () {
- if (graphics) {
- res <- rk.select.list (choices, multiple=FALSE, title=title)
- return (match(res, choices, nomatch = 0L))
- }
+ if (copy.formals) formals (replacement) <- formals (original)
+ assign (functionname, replacement, envir=as.environment ("package:rkward"))
+ try (
+ if (bindingIsLocked (functionname, environment)) {
+ unlockBinding (functionname, environment)
+ on.exit (lockBinding (functionname, environment))
+ }
+ )
+ try (
+ if (isNamespace (environment)) {
+ assignInNamespace (functionname, replacement, ns=environment)
+ } else {
+ assignInNamespace (functionname, replacement, envir=environment)
+ }
+ )
+ try (
+ assign (functionname, replacement, envir=environment)
+ )
- # for text menus, use the default implementation
- eval (body (.rk.menu.default))
+ invisible (NULL)
}
-formals (menu) <- formals (utils::menu)
-.rk.menu.default <- utils::menu
-# Add output synchronisation across system(), and system2() calls.
-"system" <- function () {
- if (!exists ("ignore.stdout", inherits=FALSE)) ignore.stdout <- FALSE # ignore.stdout was introduced in R 2.12.0
+# where masking is not enough, we need to assign in the original environment / namespace. This can only be done after package loading,
+# so we have a separate function for that.
+".rk.fix.assignments" <- function () {
+ ## History manipulation function (overloads for functions by the same name in package utils)
+ rk.replace.function ("loadhistory", as.environment ("package:utils"),
+ function (file = ".Rhistory") {
+ invisible (.rk.do.call ("commandHistory", c ("set", readLines (file))))
+ }, copy.formals = FALSE)
- if (!(intern || (ignore.stdout && ignore.stderr))) {
- .Call ("rk.sync.output", 0)
- on.exit (.Call ("rk.sync.output", 1), TRUE)
- }
+ rk.replace.function ("savehistory", as.environment ("package:utils"),
+ function (file = ".Rhistory") {
+ invisible (writeLines (.rk.do.call ("commandHistory", "get"), file))
+ }, copy.formals = FALSE)
- eval (body (.rk.system.default))
-}
-formals (system) <- formals (base::system)
-.rk.system.default <- base::system
+ rk.replace.function ("timestamp", as.environment ("package:utils"),
+ function (stamp = date(), prefix = "##------ ", suffix = " ------##", quiet = FALSE) {
+ stamp <- paste(prefix, stamp, suffix, sep = "")
+ .rk.do.call (.rk.do.call ("commandHistory", c ("append", stamp)))
+ if (!quiet) cat(stamp, sep = "\n")
+ invisible(stamp)
+ }, copy.formals = FALSE)
-# NOTE: system2 was not introduced before R 2.12.0 (or was it 2.11.0?)
-if (exists ("system2", base::.BaseNamespaceEnv)) {
- "system2" <- function () {
- if (stdout != "" || stderr != "") {
- .Call ("rk.sync.output", 0)
- on.exit (.Call ("rk.sync.output", 1), TRUE)
- }
- eval (body (.rk.system2.default))
+ ## Interactive menus
+ rk.replace.function ("select.list", as.environment ("package:utils"),
+ function () {
+ # the "list" parameter was renamed to "choices" in R 2.11.0
+ if (!exists ("list", inherits=FALSE)) list <- choices
+ # the "graphics" parameter was introduced in R 2.11.0, so we cannot rely on its existance
+ if (!exists ("graphics", inherits=FALSE)) graphics <- TRUE
+ if (graphics) {
+ return (rk.select.list (list, preselect, multiple, title))
+ }
+
+ # for text list, use the default implementation
+ eval (body (rkward::.rk.select.list.default))
+ })
+
+ rk.replace.function ("menu", as.environment ("package:utils"),
+ function () {
+ if (graphics) {
+ res <- rk.select.list (choices, multiple=FALSE, title=title)
+ return (match(res, choices, nomatch = 0L))
+ }
+
+ # for text menus, use the default implementation
+ eval (body (.rk.menu.default))
+ })
+
+ ## Add output synchronisation across system(), and system2() calls.
+ rk.replace.function ("system", base::.BaseNamespaceEnv,
+ function () {
+ if (!exists ("ignore.stdout", inherits=FALSE)) ignore.stdout <- FALSE # ignore.stdout was introduced in R 2.12.0
+
+ if (!(intern || (ignore.stdout && ignore.stderr))) {
+ .Call ("rk.sync.output", 0)
+ on.exit (.Call ("rk.sync.output", 1), TRUE)
+ }
+
+ eval (body (.rk.system.default))
+ })
+
+ # NOTE: system2 was not introduced before R 2.12.0 (or was it 2.11.0?)
+ if (exists ("system2", base::.BaseNamespaceEnv)) {
+ rk.replace.function ("system2", base::.BaseNamespaceEnv,
+ function () {
+ if (stdout != "" || stderr != "") {
+ .Call ("rk.sync.output", 0)
+ on.exit (.Call ("rk.sync.output", 1), TRUE)
+ }
+ eval (body (.rk.system2.default))
+ })
}
- formals (system2) <- formals (base::system2)
- .rk.system2.default <- base::system2
-}
-# 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.
-#NOTE: TODO: By now we are replacing so many functions, that it would make sense to create a generic framework for doing such replacements.
-".rk.fix.assignments" <- function () {
- assignInNamespace ("loadhistory", loadhistory, envir=as.environment ("package:utils"))
- assignInNamespace ("savehistory", savehistory, envir=as.environment ("package:utils"))
- assignInNamespace ("timestamp", timestamp, envir=as.environment ("package:utils"))
- assignInNamespace ("menu", menu, envir=as.environment ("package:utils"))
- assignInNamespace ("select.list", select.list, envir=as.environment ("package:utils"))
- try ({
- unlockBinding ("makeActiveBinding", base::.BaseNamespaceEnv)
- assign ("makeActiveBinding", rkward::makeActiveBinding, envir=base::.BaseNamespaceEnv)
- })
- try ({
- unlockBinding ("system", base::.BaseNamespaceEnv)
- assign ("system", rkward::system, envir=base::.BaseNamespaceEnv)
- })
- try ({
- unlockBinding ("system2", base::.BaseNamespaceEnv)
- assign ("system2", rkward::system2, envir=base::.BaseNamespaceEnv)
- })
-
# call separate assignments functions:
if (exists (".rk.fix.assignments.graphics")) eval (body (.rk.fix.assignments.graphics)) # internal_graphics.R
}
Modified: trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R 2011-02-02 13:08:17 UTC (rev 3412)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal_graphics.R 2011-02-03 15:15:13 UTC (rev 3413)
@@ -71,51 +71,41 @@
}
}
-"plot.new" <- function ()
+# see .rk.fix.assignmetns () in internal.R
+".rk.fix.assignments.graphics" <- function ()
{
- if (dev.cur() == 1) rk.screen.device ()
- if (getOption ("rk.enable.graphics.history")) {
- .callstr <- sys.call (-sys.parents()[sys.nframe ()])
- rk.record.plot$record (nextplot.pkg = "graphics", nextplot.call = .callstr)
- }
- eval (body (.rk.plot.new.default))
-}
-formals (plot.new) <- formals (graphics::plot.new)
-.rk.plot.new.default <- graphics::plot.new
+ rk.replace.function ("plot.new", as.environment ("package:graphics"),
+ function () {
+ if (dev.cur() == 1) rk.screen.device ()
+ if (getOption ("rk.enable.graphics.history")) {
+ .callstr <- sys.call (-sys.parents()[sys.nframe ()])
+ rk.record.plot$record (nextplot.pkg = "graphics", nextplot.call = .callstr)
+ }
+ eval (body (.rk.plot.new.default))
+ })
-"dev.off" <- function (which = dev.cur ())
-{
- if (getOption ("rk.enable.graphics.history"))
- rk.record.plot$onDelDevice (devId = which)
-
- # see http://thread.gmane.org/gmane.comp.statistics.rkward.devel/802
- .rk.do.call ("killDevice", as.character (which))
-
- ret <- eval (body (.rk.dev.off.default))
- return (ret)
-}
-formals (dev.off) <- formals (grDevices::dev.off)
-.rk.dev.off.default <- grDevices::dev.off
+ rk.replace.function ("dev.off", as.environment ("package:grDevices"),
+ function (which = dev.cur ()) {
+ if (getOption ("rk.enable.graphics.history"))
+ rk.record.plot$onDelDevice (devId = which)
+
+ # see http://thread.gmane.org/gmane.comp.statistics.rkward.devel/802
+ .rk.do.call ("killDevice", as.character (which))
+
+ ret <- eval (body (.rk.dev.off.default))
+ return (ret)
+ })
-"dev.set" <- function ()
-{
- ret <- eval (body (.rk.dev.set.default))
-
- if (getOption ("rk.enable.graphics.history") && rk.record.plot$.is.device.managed (which))
- rk.record.plot$.set.trellis.last.object (which)
-
- ret
-}
-formals (dev.set) <- formals (grDevices::dev.set)
-.rk.dev.set.default <- grDevices::dev.set
+ rk.replace.function ("dev.set", as.environment ("package:grDevices"),
+ function () {
+ ret <- eval (body (.rk.dev.set.default))
+
+ if (getOption ("rk.enable.graphics.history") && rk.record.plot$.is.device.managed (which))
+ rk.record.plot$.set.trellis.last.object (which)
+
+ ret
+ })
-# see .rk.fix.assignmetns () in internal.R
-".rk.fix.assignments.graphics" <- function ()
-{
- assignInNamespace ("plot.new", plot.new, envir=as.environment ("package:graphics"))
- assignInNamespace ("dev.off", dev.off, envir=as.environment ("package:grDevices"))
- assignInNamespace ("dev.set", dev.set, envir=as.environment ("package:grDevices"))
-
## set a hook defining "print.function" for lattice:
setHook (packageEvent ("lattice", "onLoad"),
function (...)
Added: trunk/rkward/rkward/rbackend/rpackages/rkward/man/rk.replace.function.Rd
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/man/rk.replace.function.Rd (rev 0)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/man/rk.replace.function.Rd 2011-02-03 15:15:13 UTC (rev 3413)
@@ -0,0 +1,48 @@
+\name{rk.replace.function}
+\alias{rk.replace.function}
+
+\title{Replace a function inside its package environment / namespace}
+
+\usage{
+rk.replace.function(functionname, environment, replacement, copy.formals=TRUE)
+}
+
+\arguments{
+ \item{functionname}{name of the function to be replaced (character).}
+ \item{environment}{package environment or namespace, where replacment should be done.}
+ \item{replacement}{the replacement. This should be a function.}
+ \item{copy.formals}{logical; whether to copy the \code{\link{formals}} from the original function.}
+}
+
+\details{
+ \code{rk.replace.function} can be used to replace a function inside a different package / namespace. It is mainly intended for internal usage inside rkward, e.g. to replace \code{menu} and \code{select.list} with appropriate GUI implementations.
+
+ The original function is assigned to the environment of the rkward package, as ".rk.FUNCTIONAME.default", and can be referred to from the replacement. WARNING: This mechansim does not support several subsequent replacments of the same function.
+
+ WARNING: This function can be used to alter - and disrupt - internal functions in arbitrary ways. You better know what you are doing.
+
+ WARNING: Does not work well on generics!
+}
+
+\value{
+ Returns \code{NULL}, invisibly, unconditionally.
+}
+
+\author{Thomas Friedrichsmeier \email{rkward-devel at lists.sourceforge.net}}
+
+\seealso{
+ \code{\link{assignInNamespace}}, \code{\link{debug}}
+}
+
+\examples{
+## Not run
+rk.replace.function ("history", as.environment ("package:utils"),
+ function () {
+ cat ("This is what you typed:\n")
+ eval (body (.rk.history.default))
+ })
+## End not run
+}
+
+\keyword{utilities}
+\keyword{IO}
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