From janko.thyson.rstuff at googlemail.com  Wed Aug 24 18:18:08 2011
From: janko.thyson.rstuff at googlemail.com (Janko Thyson)
Date: Wed, 24 Aug 2011 18:18:08 +0200
Subject: [Rd] Implementing a "plugin" paradigm with R methods
In-Reply-To: <4E547FF4.6060605@fhcrc.org>
References: <4E54237D.3090809@googlemail.com> <4E547FF4.6060605@fhcrc.org>
Message-ID: <4E552440.20800@googlemail.com>

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 at r-project.org mailing list
>> https://stat.ethz.ch/mailman/listinfo/r-devel
>
>



[Rd] Implementing a "plugin" paradigm with R methods
Janko Thyson