[Rcpp-commits] r1281 - in pkg/Rcpp: . R inst inst/include inst/include/Rcpp inst/unitTests src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed May 19 12:08:25 CEST 2010
Author: romain
Date: 2010-05-19 12:08:24 +0200 (Wed, 19 May 2010)
New Revision: 1281
Added:
pkg/Rcpp/R/Module.R
pkg/Rcpp/R/getDLL.R
pkg/Rcpp/inst/include/Rcpp/Module.h
pkg/Rcpp/inst/unitTests/runit.Module.R
pkg/Rcpp/src/Module.cpp
Modified:
pkg/Rcpp/DESCRIPTION
pkg/Rcpp/NAMESPACE
pkg/Rcpp/inst/ChangeLog
pkg/Rcpp/inst/include/Rcpp.h
Log:
initial pass at Rcpp modules (inspired from boost.python)
Modified: pkg/Rcpp/DESCRIPTION
===================================================================
--- pkg/Rcpp/DESCRIPTION 2010-05-19 07:27:56 UTC (rev 1280)
+++ pkg/Rcpp/DESCRIPTION 2010-05-19 10:08:24 UTC (rev 1281)
@@ -1,6 +1,6 @@
Package: Rcpp
Title: Rcpp R/C++ interface package
-Version: 0.8.0
+Version: 0.8.0.1
Date: $Date$
Author: Dirk Eddelbuettel and Romain Francois, with contributions
by Simon Urbanek, David Reiss and Douglas Bates; based on code written during
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2010-05-19 07:27:56 UTC (rev 1280)
+++ pkg/Rcpp/NAMESPACE 2010-05-19 10:08:24 UTC (rev 1281)
@@ -6,4 +6,7 @@
importFrom( utils, capture.output )
importFrom( inline, cfunction )
+exportMethods( getDLL )
+exportClasses( Module )
+export( Module )
Added: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R (rev 0)
+++ pkg/Rcpp/R/Module.R 2010-05-19 10:08:24 UTC (rev 1281)
@@ -0,0 +1,44 @@
+# Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+setClass( "Module", representation( pointer = "externalptr" ) )
+
+Module <- function( module, PACKAGE ){
+ name <- sprintf( "_rcpp_module_boot_%s", module )
+ symbol <- getNativeSymbolInfo( name, PACKAGE )
+ xp <- .Call( symbol )
+ new( "Module", pointer = xp )
+}
+
+setMethod( "$", "Module", function(x, name){
+ function( ... ) {
+ res <- .External( "Module__invoke" , x at pointer, name, ..., PACKAGE = "Rcpp" )
+ if( isTRUE( res$void ) ) invisible(NULL) else res$result
+ }
+} )
+
+setMethod( "show", "Module", function( object ){
+ info <- .Call( "Module__funtions_arity", object at pointer, PACKAGE = "Rcpp" )
+ name <- .Call( "Module__name", object at pointer )
+ txt <- sprintf( "Rcpp module '%s' \n\t%d functions: ", name, length(info) )
+ writeLines( txt )
+ txt <- sprintf( "%15s : %d arguments", names(info), info )
+ writeLines( txt )
+} )
+
+#TODO: maybe attach( Module ), with( Module )
+
Added: pkg/Rcpp/R/getDLL.R
===================================================================
--- pkg/Rcpp/R/getDLL.R (rev 0)
+++ pkg/Rcpp/R/getDLL.R 2010-05-19 10:08:24 UTC (rev 1281)
@@ -0,0 +1,44 @@
+# Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+# TODO: this probably should be in inline rather than in Rcpp
+
+setGeneric("getDLL", function(x, ...) standardGeneric("getDLL") )
+
+setMethod( "getDLL", signature( x = "character" ),
+function( x ){
+ dlls <- getLoadedDLLs()
+ if( x %in% names( dlls ) ){
+ dlls[[ x ]]
+ } else {
+ stop( sprintf( "dll %s not loaded" ) )
+ }
+} )
+
+setMethod( "getDLL", signature( x = "CFunc" ),
+function( x ){
+ env <- environment( x at .Data )
+ f <- get( "f", env )
+ dlls <- getLoadedDLLs()
+ dll <- if( ! f %in% names(dlls) ){
+ dyn.load( get( "libLFile", env ) )
+ } else{
+ dlls[[ f ]]
+ }
+ dll
+} )
+
Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog 2010-05-19 07:27:56 UTC (rev 1280)
+++ pkg/Rcpp/inst/ChangeLog 2010-05-19 10:08:24 UTC (rev 1281)
@@ -1,3 +1,14 @@
+
+2010-05-19 Romain Francois <romain at r-enthusiasts.com>
+
+ * inst/include/Rcpp/Module.h : adding the concept of Rcpp modules, inspired
+ from boost.python
+
+ * R/Module.R: R side support for modules
+
+ * R/getDLL.R: generic (s4) function to get the DLL based on either its name
+ e.g. getDLL( "Rcpp" ) or an object of class CFunc (from the inline package)
+
2010-05-17 Dirk Eddelbuettel <edd at debian.org>
* DESCRIPTION: Release 0.8.0
Added: pkg/Rcpp/inst/include/Rcpp/Module.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/Module.h (rev 0)
+++ pkg/Rcpp/inst/include/Rcpp/Module.h 2010-05-19 10:08:24 UTC (rev 1281)
@@ -0,0 +1,250 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Module.h: Rcpp R/C++ interface class library -- Rcpp modules
+//
+// Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
+//
+// This file is part of Rcpp.
+//
+// Rcpp is free software: you can redistribute it and/or modify it
+// under the terms of the GNU General Public License as published by
+// the Free Software Foundation, either version 2 of the License, or
+// (at your option) any later version.
+//
+// Rcpp is distributed in the hope that it will be useful, but
+// WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+//
+// You should have received a copy of the GNU General Public License
+// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+#ifndef Rcpp_Module_h
+#define Rcpp_Module_h
+
+namespace Rcpp{
+
+class CppFunction {
+ public:
+ CppFunction() {}
+ virtual SEXP operator()(SEXP* args) { return R_NilValue ; } ;
+ virtual ~CppFunction(){} ;
+ virtual int nargs(){ return 0 ; }
+ virtual bool is_void(){ return false ; }
+};
+
+template <typename OUT>
+class CppFunction0 : public CppFunction {
+ public:
+ CppFunction0(OUT (*fun)(void) ) : CppFunction(), ptr_fun(fun){}
+ SEXP operator()(SEXP* args){
+ SEXP res = R_NilValue ;
+ try{
+ res = Rcpp::wrap( ptr_fun() ) ;
+ } catch( std::exception& __ex__ ){
+ forward_exception_to_r( __ex__ ) ;
+ }
+ return res ;
+ }
+
+ inline int nargs(){ return 0; }
+
+ private:
+ OUT (*ptr_fun)(void) ;
+} ;
+
+template <>
+class CppFunction0<void> : public CppFunction {
+ public:
+ CppFunction0(void (*fun)(void) ) ;
+
+ SEXP operator()(SEXP* args) ;
+
+ inline int nargs(){ return 0; }
+ inline bool is_void(){ return true; }
+
+ private:
+ void (*ptr_fun)(void) ;
+} ;
+
+
+template <typename OUT, typename U0>
+class CppFunction1 : public CppFunction {
+ public:
+ CppFunction1(OUT (*fun)(U0 u0) ) : CppFunction(), ptr_fun(fun){}
+ SEXP operator()(SEXP* args){
+ SEXP res = R_NilValue ;
+ try{
+ res = Rcpp::wrap( ptr_fun( Rcpp::as<U0>( args[0] ) ) ) ;
+ } catch( std::exception& __ex__ ){
+ forward_exception_to_r( __ex__ ) ;
+ }
+ return res ;
+ }
+
+ inline int nargs(){ return 1; }
+
+ private:
+ OUT (*ptr_fun)(U0 u0) ;
+} ;
+
+template <typename U0>
+class CppFunction1<void,U0> : public CppFunction {
+ public:
+ CppFunction1(void (*fun)(U0 u0) ) : CppFunction(), ptr_fun(fun){}
+ SEXP operator()(SEXP* args){
+ try{
+ ptr_fun( Rcpp::as<U0>( args[0] ) ) ;
+ } catch( std::exception& __ex__ ){
+ forward_exception_to_r( __ex__ ) ;
+ }
+ return R_NilValue ;
+ }
+
+ inline int nargs(){ return 1; }
+ inline bool is_void(){ return true; }
+
+ private:
+ void (*ptr_fun)(U0 u0) ;
+} ;
+
+
+
+template <typename OUT, typename U0, typename U1>
+class CppFunction2 : public CppFunction {
+ public:
+ CppFunction2(OUT (*fun)(U0 u0, U1 u1) ) : CppFunction(), ptr_fun(fun){}
+ SEXP operator()(SEXP* args){
+ SEXP res = R_NilValue ;
+ try{
+ res = Rcpp::wrap( ptr_fun(
+ Rcpp::as<U0>( args[0] ),
+ Rcpp::as<U1>( args[1] )
+ ) ) ;
+ } catch( std::exception& __ex__ ){
+ forward_exception_to_r( __ex__ ) ;
+ }
+ return res ;
+ }
+ inline int nargs(){ return 2; }
+
+
+ private:
+ OUT (*ptr_fun)(U0 u0, U1 u1) ;
+} ;
+
+template <typename U0, typename U1>
+class CppFunction2<void,U0,U1> : public CppFunction {
+ public:
+ CppFunction2(void (*fun)(U0 u0, U1 u1) ) : CppFunction(), ptr_fun(fun){}
+ SEXP operator()(SEXP* args){
+ try{
+ ptr_fun(
+ Rcpp::as<U0>( args[0] ),
+ Rcpp::as<U1>( args[1] )
+ );
+ } catch( std::exception& __ex__ ){
+ forward_exception_to_r( __ex__ ) ;
+ }
+ return R_NilValue ;
+ }
+ inline int nargs(){ return 2; }
+ inline bool is_void(){ return true; }
+
+
+ private:
+ void (*ptr_fun)(U0 u0, U1 u1) ;
+} ;
+
+template <typename OUT>
+CppFunction* make_function( OUT (*fun)(void) ){
+ return new CppFunction0<OUT>( fun ) ;
+}
+
+template <typename OUT, typename U0>
+CppFunction* make_function( OUT (*fun)(U0 u0) ){
+ return new CppFunction1<OUT,U0>( fun ) ;
+}
+
+template <typename OUT, typename U0, typename U1>
+CppFunction* make_function( OUT (*fun)(U0 u0, U1 u1) ){
+ return new CppFunction2<OUT,U0,U1>( fun ) ;
+}
+
+class Module {
+ public:
+ typedef std::map<std::string,CppFunction*> MAP ;
+
+ Module() : name(), functions() {}
+ Module(const char* name_) : name(name_), functions() {}
+
+ SEXP invoke( const std::string& name, SEXP* args, int nargs){
+ MAP::iterator it = functions.find( name );
+ if( it == functions.end() ){
+ ::Rf_error( "no such function" ) ;
+ }
+ CppFunction* fun = it->second ;
+ if( fun->nargs() > nargs ){
+ ::Rf_error( "expecting %d arguments", fun->nargs() ) ;
+ }
+ return Rcpp::List::create(
+ Rcpp::Named("result") = fun->operator()( args ),
+ Rcpp::Named("void") = fun->is_void()
+ ) ;
+ }
+
+ Rcpp::IntegerVector functions_arity() ;
+
+ inline void Add( const char* name, CppFunction* ptr){
+ functions.insert( std::pair<std::string,CppFunction*>( name, ptr ) ) ;
+ }
+
+ std::string name ;
+
+ private:
+ std::map<std::string,CppFunction*> functions ;
+
+};
+
+extern Rcpp::Module* current_scope ;
+
+template <typename OUT>
+void function( const char* name, OUT (*fun)(void)){
+ if( Rcpp::current_scope ){
+ Rcpp::current_scope->Add( name, new CppFunction0<OUT>( fun ) ) ;
+ }
+}
+
+template <typename OUT, typename U0>
+void function( const char* name, OUT (*fun)(U0 u0)){
+ if( Rcpp::current_scope ){
+ Rcpp::current_scope->Add( name, new CppFunction1<OUT,U0>( fun ) ) ;
+ }
+}
+
+template <typename OUT, typename U0, typename U1>
+void function( const char* name, OUT (*fun)(U0 u0, U1 u1)){
+ if( Rcpp::current_scope ){
+ Rcpp::current_scope->Add( name, new CppFunction2<OUT,U0,U1>( fun ) ) ;
+ }
+}
+
+
+}
+
+
+#define RCPP_MODULE(name) \
+void _rcpp_module_##name##_init() ; \
+static Rcpp::Module _rcpp_module_##name( # name ) ; \
+extern "C" SEXP _rcpp_module_boot_##name(){ \
+ ::Rcpp::current_scope = & _rcpp_module_##name ; \
+ _rcpp_module_##name##_init( ) ; \
+ Rcpp::XPtr<Rcpp::Module> mod_xp( & _rcpp_module_##name , false ) ; \
+ ::Rcpp::current_scope = 0 ; \
+ return mod_xp ; \
+} \
+void _rcpp_module_##name##_init()
+
+
+#endif
+
Modified: pkg/Rcpp/inst/include/Rcpp.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp.h 2010-05-19 07:27:56 UTC (rev 1280)
+++ pkg/Rcpp/inst/include/Rcpp.h 2010-05-19 10:08:24 UTC (rev 1281)
@@ -69,4 +69,6 @@
#include <Rcpp/Formula.h>
#include <Rcpp/DataFrame.h>
+#include <Rcpp/Module.h>
+
#endif
Added: pkg/Rcpp/inst/unitTests/runit.Module.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.Module.R (rev 0)
+++ pkg/Rcpp/inst/unitTests/runit.Module.R 2010-05-19 10:08:24 UTC (rev 1281)
@@ -0,0 +1,72 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+test.Argument <- function(){
+
+ inc <- '
+
+ std::string hello(){
+ return "hello" ;
+ }
+
+ int bar( int x){
+ return x*2 ;
+ }
+
+ double foo( int x, double y){
+ return x * y ;
+ }
+
+ void bla( ){
+ Rprintf( "hello\\n" ) ;
+ }
+
+ void bla1( int x){
+ Rprintf( "hello (x = %d)\\n", x ) ;
+ }
+
+ void bla2( int x, double y){
+ Rprintf( "hello (x = %d, y = %5.2f)\\n", x, y ) ;
+ }
+
+
+ RCPP_MODULE(yada){
+ using namespace Rcpp ;
+
+ function( "hello" , &hello ) ;
+ function( "bar" , &bar ) ;
+ function( "foo" , &foo ) ;
+ function( "bla" , &bla ) ;
+ function( "bla1" , &bla1 ) ;
+ function( "bla2" , &bla2 ) ;
+
+ }
+
+ '
+ fx <- cppfunction( signature(), "" , include = inc )
+
+ mod <- Module( "yada", getDLL(fx) )
+ checkEquals( mod$bar( 2L ), 4L )
+ checkEquals( mod$foo( 2L, 10.0 ), 20.0 )
+ checkEquals( mod$hello(), "hello" )
+ checkEquals( capture.output( mod$bla() ), "hello" )
+ checkEquals( capture.output( mod$bla1(2L) ), "hello (x = 2)" )
+ checkEquals( capture.output( mod$bla2(2L, 5.0) ), "hello (x = 2, y = 5.00)" )
+
+}
Added: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp (rev 0)
+++ pkg/Rcpp/src/Module.cpp 2010-05-19 10:08:24 UTC (rev 1281)
@@ -0,0 +1,84 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Module.cpp: Rcpp R/C++ interface class library -- Rcpp modules
+//
+// Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
+//
+// This file is part of Rcpp.
+//
+// Rcpp is free software: you can redistribute it and/or modify it
+// under the terms of the GNU General Public License as published by
+// the Free Software Foundation, either version 2 of the License, or
+// (at your option) any later version.
+//
+// Rcpp is distributed in the hope that it will be useful, but
+// WITHOUT ANY WARRANTY; without even the implied warranty of
+// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+// GNU General Public License for more details.
+//
+// You should have received a copy of the GNU General Public License
+// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+#include <Rcpp.h>
+
+#define MAX_ARGS 65
+
+extern "C" SEXP Module__invoke( SEXP args){
+ SEXP p = CDR(args) ;
+ Rcpp::XPtr<Rcpp::Module> module( CAR(p) ) ; p = CDR(p) ;
+ std::string fun = Rcpp::as<std::string>( CAR(p) ) ; p = CDR(p) ;
+
+ SEXP cargs[MAX_ARGS] ;
+ int nargs = 0 ;
+ for(; nargs<MAX_ARGS; nargs++){
+ if( p == R_NilValue ) break ;
+ cargs[nargs] = CAR(p) ;
+ p = CDR(p) ;
+ }
+ return module->invoke( fun, cargs, nargs ) ;
+}
+
+extern "C" SEXP Module__funtions_arity( SEXP mod_xp ){
+ Rcpp::XPtr<Rcpp::Module> module(mod_xp) ;
+ return module-> functions_arity() ;
+}
+
+extern "C" SEXP Module__name( SEXP mod_xp ){
+ Rcpp::XPtr<Rcpp::Module> module(mod_xp) ;
+ return Rcpp::wrap( module->name );
+}
+
+namespace Rcpp{
+ Rcpp::Module* current_scope = 0 ;
+
+ Rcpp::IntegerVector Module::functions_arity(){
+ int n = functions.size() ;
+ Rcpp::IntegerVector x( n ) ;
+ Rcpp::CharacterVector names( n );
+ MAP::iterator it = functions.begin() ;
+ for( int i=0; i<n; i++, ++it){
+ x[i] = (it->second)->nargs() ;
+ names[i] = it->first ;
+ }
+ x.names() = names ;
+ return x ;
+ }
+
+
+
+ CppFunction0<void>::CppFunction0( void (*fun)(void) ) :
+ CppFunction(), ptr_fun(fun){}
+
+ SEXP CppFunction0<void>::operator()(SEXP* args){
+ try{
+ ptr_fun() ;
+ } catch( std::exception& __ex__ ){
+ forward_exception_to_r( __ex__ ) ;
+ }
+ return R_NilValue ;
+ }
+
+
+
+}
+
More information about the Rcpp-commits
mailing list