Hi Martin,
thanks a lot again for your suggestions! I played around a bit with it
today and this is the solution that I like the most.
The main extensions compared to your code are:
1) Using Reference Classes (I don't know, but I just like them somehow ;-))
1) Basing method dispatch for plugin methods on multiple signature
arguments to ensure transparency/minimize the risk of name clashes for
plugins
2) Hide as much definition details for signature argument classes from
the user as possible (see 'apiClassesEnsure()' and 'pluginObjectCreate()')
One neat thing would be to get around the warnings when defining plugin
methods ('apiClassesEnsure()' which takes care of setting formal classes
for signature arguments is called at 'run time' when calling
'foo()', so the formal classes are not there yet). But I guess I just
have to turn them off temporarily when sourcing in methods from a directory.
It'd be cool if you could tell me what you think of that approach!
Regards,
Janko
#-------------------------------------------------------------------------------
# APPROACH 6 r-devel
#-------------------------------------------------------------------------------
# Set system environments
.HIVE <- new.env()
.HIVE$.protected <- new.env()
.HIVE$.protected$classes <- new.env()
#+++++
# Define plugin class providing all necessary signature arguments for
method
# dispatch of plugin methods
setRefClass("Plugin",
fields=list(
ns="character", # Namespace
link="character", # Name of the function/method for which the
plugin is intended
mount="character", # 'Mounting point' within the link
function. Possibly the linked function can be open for plugins at
different 'sections'
plugin="character", # Name of the plugin method
src="character" # Main input for plugin method
),
methods=list(
# Processes plugins based on fields signature fields above
pluginProcess=function(...){
pluginProcessRef(.self=.self, ...)
}
)
)
#+++++
# Define a function that takes care of 'registering' the classes needed for
# the signature fields above in order to follow a clean method dispatch
# paradigm based on formal classes
apiClassesEnsure <- function(src, do.overwrite=FALSE,...){
out <- sapply(src, function(x.src){
if(!isClass(x.src)){
x.src <- paste("API_", x.src, sep="")
}
if( !exists(x.src, envir=.HIVE$.protected$classes,
inherits=FALSE) |
do.overwrite
){
cat(paste("apiClassesEnsure/assigning class '", x.src,
"' to '.HIVE$.protected$classes'", sep=""), sep="\n")
if(!isClass(x.src)){
expr <- substitute(
setClass(
Class=CLASS,
contains="NULL",
where=ENVIR
),
list(CLASS=x.src, ENVIR=.HIVE$.protected$classes)
)
eval(expr)
eval(substitute(
assign(CLASS, expr, envir=ENVIR),
list(CLASS=x.src, ENVIR=.HIVE$.protected$classes)
))
} else {
eval(substitute(
assign(CLASS, CLASS, envir=ENVIR),
list(CLASS=x.src, ENVIR=.HIVE$.protected$classes)
))
}
}
out <- x.src
return(out)
})
return(out)
}
#+++++
# Define a function that creates plugin objects
pluginObjectCreate <- function(ns=NULL, link=NULL, mount=NULL, plugin=NULL,
src=NULL, do.overwrite=FALSE){
out <- new("Plugin")
out$initFields(
ns=apiClassesEnsure(src=ns, do.overwrite=do.overwrite),
link=apiClassesEnsure(src=link, do.overwrite=do.overwrite),
mount=apiClassesEnsure(src=mount, do.overwrite=do.overwrite),
plugin=apiClassesEnsure(src=plugin, do.overwrite=do.overwrite),
src=src
)
apiClassesEnsure(src=class(src), do.overwrite=do.overwrite)
return(out)
}
pluginObjectCreate()
pluginObjectCreate()$ns
pluginObjectCreate()$link
pluginObjectCreate()$pluginProcess
#+++++
# Set generics
setGeneric(name="pluginProcessRef", signature=c(".self"),
function(.self, ...) standardGeneric("pluginProcessRef")
)
setGeneric(name="pluginExecute",
signature=c("ns", "link", "mount", "plugin", "src"),
function(ns, link, mount, plugin, src, ...)
standardGeneric("pluginExecute")
)
#+++++
# Set method for 'pluginProcessRef'.
# The method has two modi operandi:
# 1) 'do.explicit.clss = FALSE' implies that plugin methods have been
defined
# based on the 'unprocessed' class names for signature arguments, i.e.
# 'signature(ns="mypkg", link="foo", mount="default", plugin="punct",
# src="character")'
# instead of
# 'signature(ns="API_mypkg", link="API_foo", mount="API_default",
# plugin="API_punct", src="character")'
# 2) 'do.explicit.clss = TRUE' implies the use of the 'processed' class
names
setMethod(
f=pluginProcessRef,
signature=c(.self="Plugin"),
function(.self, do.explicit.clss=FALSE, ...){
out <- NULL
if(length(.self$ns)){
if(!do.explicit.clss){
rgx.subst <- "API_"
ns <- gsub(rgx.subst, "", .self$ns)
names(ns) <- NULL
link <- gsub(rgx.subst, "", .self$link)
names(link) <- NULL
mount <- gsub(rgx.subst, "", .self$mount)
names(mount) <- NULL
plugin <- gsub(rgx.subst, "", .self$plugin)
names(plugin) <- NULL
if(!existsMethod(
f="pluginExecute",
signature=c(ns=ns, link=link, mount=mount,
plugin=plugin,
src=class(.self$src))
)){
stop("Invalid plugin")
}
.pluginExecute <- selectMethod(
"pluginExecute",
signature=c(ns=ns, link=link, mount=mount,
plugin=plugin,
src=class(.self$src)),
useInherited=c(ns=FALSE, link=FALSE, mount=FALSE,
plugin=FALSE,
src=TRUE)
)
out <- .pluginExecute(src=.self$src)
} else {
out <- pluginExecute(ns=new(.self$ns),
link=new(.self$link),
mount=new(.self$mount), plugin=new(.self$plugin),
src=.self$src)
}
}
return(out)
}
)
#+++++
# Define the actual plugin methods. For illustration, one using a implicit
# and the other using explicit class names notation for signature arguments.
# Unfortunately I don't know how to avoid warnings at this point; guess
I can't
setMethod(f=pluginExecute, signature=c(ns="mypkg", link="objectModify",
mount="default", plugin="punct",src="character"),
function(ns, link, mount, plugin, src, ...){
out <- gsub("[[:punct:]]", "", src)
}
)
setMethod(f=pluginExecute, signature=c(ns="API_mypkg",
link="API_objectModify",
mount="API_default", plugin="API_digit", src="character"),
function(ns, link, mount, plugin, src, ...){
out <- gsub("[[:digit:]]", "", src)
}
)
showMethods("pluginExecute")
#+++++
# Define the function/method that should be open for plugins
foo <- function(plugin=pluginObjectCreate(), do.explicit.clss=FALSE, ...){
cat("Here: computations before plugin", sep="\n")
cat(paste("Calling plugin '", class(plugin), "'", sep=""), sep="\n")
out <- plugin$pluginProcess(do.explicit.clss=do.explicit.clss)
cat("Here: computations after plugin", sep="\n")
return(out)
}
#+++++
# Apply
foo()
foo( plugin=pluginObjectCreate(ns="mypkg", link="objectModify",
mount="default",
plugin="punct", src="string___123"))
foo(plugin=pluginObjectCreate(ns="mypkg", link="objectModify",
mount="default",
plugin="digit", src="string123"))
# No such plugin method as explicit class names have been used for 'digit
foo(plugin=pluginObjectCreate(ns="mypkg", link="objectModify",
mount="default",
plugin="digit", src="string123"), do.explicit.clss=TRUE)
# /APPROACH 6 r-devel ----------
On 24.08.2011 06:37, Martin Morgan wrote:
On 08/23/2011 03:02 PM, Janko Thyson wrote:
Dear list,
I was wondering how to best implement some sort of a "plugin" paradigm
using R methods and the dispatcher:
Say we have a function/method ('foo') that does something useful, but
that should be open for extension in ONE specific area by OTHERS using
my package. Of course they could go ahead and write a whole new 'foo'
One possibility is to write class / method pairs. The classes extend
'Plugin', and the methods are on generic 'plug', with the infrastructure
## Approach 1: class / method pairs
setClass("Plugin")
setClass("DefaultPlugin", contains="Plugin")
DefaultPlugin <- function() new("DefaultPlugin")
setGeneric("plug",
function(plugin, src) standardGeneric("plug"),
signature="plugin",
valueClass="character")
setMethod(plug, "Plugin", function(plugin, src) {
src
})
foo <- function(src, plugin=DefaultPlugin()) {
plug(plugin, src)
}
This is extended by writing class / method pairs
setClass("Punct", contains="Plugin")
Punct <- function() new("Punct")
setMethod(plug, "Punct", function(plugin, src) {
gsub("[[:punct:]]", "", src)
})
setClass("Digit", contains="Plugin")
Digit <- function() new("Digit")
setMethod(plug, "Digit", function(plugin, src) {
gsub("[[:digit:]]", "", src)
})
The classes could have slots with state, accessible within the method.
An easier-on-the-user approach might have the Plugin class contain or
have slots of class "function". The user would only be obliged to
provide an appropriate function.
## Approach 2:
setClass("Plugin", prototype=prototype(function(src) {
src
}), contains="function")
Plugin <- function() new("Plugin")
setGeneric("foo",
function(src, plugin) standardGeneric("foo"))
setMethod(foo, c("character", "missing"),
function(src, plugin) foo(src, Plugin()))
setMethod(foo, c("character", "Plugin"),
function(src, plugin) plugin(src))
## 'Developer' classes
setClass("Punct", prototype=prototype(function(src) {
gsub("[[:punct:]]", "", src)
}), contains="Plugin")
Punct <- function() new("Punct")
setClass("Digit", prototype=prototype(function(src) {
gsub("[[:digit:]]", "", src)
}), contains="Plugin")
Digit <- function() new("Digit")
## General-purpose 'user' class
setClass("User", contains="Plugin")
User <- function(fun) new("User", fun)
This could have syntax checking in the validity method to catch some
mistakes early. In the S3 world, this is the approach taken by glm for
its 'family' argument, for instance str(gaussian().
Martin
method including the features they'd like to see, but that's not really
necessary. Rather, they should be able to just write a new "plugin"
method for that part of 'foo' that I'd like to open for such plugins.
The way I chose below works, but generates warnings as my method has
signature arguments that don't correspond to formal classes (which is
totally fine). Of course I could go ahead and make sure that such
"dummy" classes exist, but I was wondering if there's a better way.
It'd be great if anyone could let me know how they handle "plugin"
scenarios based on some sort of method dispatch!
Thanks,
Janko
##### CODE EXAMPLE #####
setGeneric(name="foo", signature=c("src"), function(src, ...)
standardGeneric("foo"))
setGeneric(name="plugin", signature=c("src", "link", "plugin"),
function(src, link, plugin, ...) standardGeneric("plugin")
)
setMethod(f="plugin", signature=signature(src="character", link="foo",
plugin="punct"),
function(src, link, plugin, ...){
out <- gsub("[[:punct:]]", "", src)
return(out)
}
)
setMethod(f="plugin", signature=signature(src="character", link="foo",
plugin="digit"),
function(src, link, plugin, ...){
out <- gsub("[[:digit:]]", "", src)
return(out)
}
)
setMethod(f="foo", signature=signature(src="character"),
function(src, plugin=NULL, ...){
if(!is.null(plugin)){
if(!existsMethod(f="plugin",
signature=c(src=class(src), link="foo", plugin=plugin)
)){
stop("Invalid plugin")
}
.plugin <- selectMethod(
"plugin",
signature=c(src=class(src), link="foo", plugin=plugin),
useInherited=c(src=TRUE, plugin=FALSE)
)
out <- .plugin(src=src)
} else {
out <- paste("Hello world: ", src, sep="")
}
return(out)
}
)
foo(src="Teststring:-1234_56/")
foo(src="Teststring:-1234_56/", plugin="punct")
foo(src="Teststring:-1234_56/", plugin="digit")
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
