Re: [Rd] Implementing a "plugin" paradigm with R methods

From: Janko Thyson <janko.thyson.rstuff_at_googlemail.com>
Date: Wed, 24 Aug 2011 18:18:08 +0200

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
>
>

______________________________________________
R-devel_at_r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel Received on Wed 24 Aug 2011 - 16:20:54 GMT

This quarter's messages: by month, or sorted: [ by date ] [ by thread ] [ by subject ] [ by author ]

All messages

Archive maintained by Robert King, hosted by the discipline of statistics at the University of Newcastle, Australia.
Archive generated by hypermail 2.2.0, at Thu 25 Aug 2011 - 16:50:23 GMT.

Mailing list information is available at https://stat.ethz.ch/mailman/listinfo/r-devel. Please read the posting guide before posting to the list.

list of date sections of archive