[Rcpp-commits] r1413 - in pkg/Rcpp: R inst inst/include/Rcpp inst/include/Rcpp/module inst/unitTests man src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jun 4 11:13:32 CEST 2010
Author: romain
Date: 2010-06-04 11:13:30 +0200 (Fri, 04 Jun 2010)
New Revision: 1413
Added:
pkg/Rcpp/inst/include/Rcpp/module/Module_Add_Property.h
pkg/Rcpp/inst/include/Rcpp/module/Module_Property.h
Modified:
pkg/Rcpp/R/Module.R
pkg/Rcpp/inst/ChangeLog
pkg/Rcpp/inst/include/Rcpp/Module.h
pkg/Rcpp/inst/unitTests/runit.Module.R
pkg/Rcpp/man/CppObject-class.Rd
pkg/Rcpp/src/Module.cpp
Log:
support for properties
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-06-04 00:41:01 UTC (rev 1412)
+++ pkg/Rcpp/R/Module.R 2010-06-04 09:13:30 UTC (rev 1413)
@@ -82,18 +82,30 @@
res <- .External( "Class__invoke_method", x at cppclass, name, x at pointer, ... , PACKAGE = "Rcpp" )
if( isTRUE( res$void ) ) invisible(NULL) else res$result
}
+
}
dollar_cppobject <- function(x, name){
if( .Call( "Class__has_method", x at cppclass, name, PACKAGE = "Rcpp" ) ){
MethodInvoker( x, name )
- } else{
- stop( "no such method" )
+ } else if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ) {
+ .Call( "CppClass__get", x at cppclass, x at pointer, name, PACKAGE = "Rcpp" )
+ } else {
+ stop( "no such method or property" )
}
}
setMethod( "$", "C++Object", dollar_cppobject )
+dollargets_cppobject <- function(x, name, value){
+ if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ){
+ .Call( "CppClass__set", x at cppclass, x at pointer, name, value, PACKAGE = "Rcpp" )
+ }
+ x
+}
+
+setReplaceMethod( "$", "C++Object", dollargets_cppobject )
+
Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()) ){
name <- sprintf( "_rcpp_module_boot_%s", module )
symbol <- getNativeSymbolInfo( name, PACKAGE )
@@ -134,7 +146,6 @@
new( "Module", pointer = xp )
}
-
setGeneric( "complete", function(x) standardGeneric("complete") )
setMethod( "complete", "C++Object", function(x){
xp <- x at cppclass
@@ -150,7 +161,6 @@
.Call( "Module__funtions_arity", object at pointer, PACKAGE = "Rcpp" )
} )
-
setGeneric( "prompt" )
setMethod( "prompt", "Module", function(object, filename = NULL, name = NULL, ...){
lines <- readLines( system.file( "prompt", "module.Rd", package = "Rcpp" ) )
Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog 2010-06-04 00:41:01 UTC (rev 1412)
+++ pkg/Rcpp/inst/ChangeLog 2010-06-04 09:13:30 UTC (rev 1413)
@@ -1,3 +1,8 @@
+2010-06-04 Romain Francois <romain at r-enthusiasts.com>
+
+ * inst/include/Rcpp/Module.h:
+ * R/Module.R: support for properties of C++ objects
+
2010-06-03 Romain Francois <romain at r-enthusiasts.com>
* src/RcppCommn.cpp: added show method for C++Object and C++Class
Modified: pkg/Rcpp/inst/include/Rcpp/Module.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/Module.h 2010-06-04 00:41:01 UTC (rev 1412)
+++ pkg/Rcpp/inst/include/Rcpp/Module.h 2010-06-04 09:13:30 UTC (rev 1413)
@@ -56,6 +56,9 @@
virtual bool has_method( const std::string& ){
return false ;
}
+ virtual bool has_property( const std::string& ) {
+ return false ;
+ }
virtual SEXP newInstance(SEXP *, int){
return R_NilValue;
}
@@ -66,6 +69,13 @@
virtual Rcpp::CharacterVector complete(){ return Rcpp::CharacterVector(0) ; }
virtual ~class_Base(){}
+ virtual SEXP getProperty( const std::string&, SEXP ) throw(std::range_error) {
+ throw std::range_error( "cannot retrieve property" ) ;
+ }
+ virtual void setProperty( const std::string&, SEXP, SEXP) throw(std::range_error){
+ throw std::range_error( "cannot set property" ) ;
+ }
+
std::string name ;
} ;
@@ -129,22 +139,37 @@
virtual ~CppMethod(){}
virtual int nargs(){ return 0 ; }
virtual bool is_void(){ return false ; }
-
} ;
#include <Rcpp/module/Module_generated_CppMethod.h>
#include <Rcpp/module/Module_generated_Pointer_CppMethod.h>
template <typename Class>
+class CppProperty {
+ public:
+ typedef Rcpp::XPtr<Class> XP ;
+
+ CppProperty(){} ;
+ virtual SEXP get(Class* ) throw(std::range_error){ throw std::range_error("cannot retrieve property"); }
+ virtual void set(Class*, SEXP) throw(std::range_error){ throw std::range_error("cannot set property"); }
+} ;
+
+#include <Rcpp/module/Module_Property.h>
+
+template <typename Class>
class class_ : public class_Base {
public:
typedef class_<Class> self ;
typedef CppMethod<Class> method_class ;
typedef std::map<std::string,method_class*> METHOD_MAP ;
typedef std::pair<const std::string,method_class*> PAIR ;
- typedef Rcpp::XPtr<Class> XP ;
+ typedef Rcpp::XPtr<Class> XP ;
- class_( const char* name_ ) : class_Base(name_), methods(), specials(0) {
+ typedef CppProperty<Class> prop_class ;
+ typedef std::map<std::string,prop_class*> PROPERTY_MAP ;
+ typedef std::pair<const std::string,prop_class*> PROP_PAIR ;
+
+ class_( const char* name_ ) : class_Base(name_), methods(), properties(), specials(0) {
if( !singleton ){
singleton = new self ;
singleton->name = name_ ;
@@ -179,6 +204,11 @@
if( *name == '[' ) singleton->specials++ ;
return *this ;
}
+
+ self& AddProperty( const char* name, prop_class* p){
+ singleton->properties.insert( PROP_PAIR( name, p ) ) ;
+ return *this ;
+ }
#include <Rcpp/module/Module_generated_method.h>
#include <Rcpp/module/Module_generated_Pointer_method.h>
@@ -186,6 +216,9 @@
bool has_method( const std::string& m){
return methods.find(m) != methods.end() ;
}
+ bool has_property( const std::string& m){
+ return properties.find(m) != properties.end() ;
+ }
Rcpp::CharacterVector method_names(){
int n = methods.size() ;
@@ -199,10 +232,12 @@
Rcpp::CharacterVector complete(){
int n = methods.size() - specials ;
- Rcpp::CharacterVector out(n) ;
+ int ntotal = n + properties.size() ;
+ Rcpp::CharacterVector out(ntotal) ;
typename METHOD_MAP::iterator it = methods.begin( ) ;
std::string buffer ;
- for( int i=0; i<n; ++it){
+ int i=0 ;
+ for( ; i<n; ++it){
buffer = it->first ;
if( buffer[0] == '[' ) continue ;
if( (it->second)->nargs() == 0){
@@ -212,16 +247,41 @@
}
out[i] = buffer ;
i++ ;
- }
+ }
+ typename PROPERTY_MAP::iterator prop_it = properties.begin();
+ for( ; i<ntotal; i++, ++prop_it){
+ out[i] = prop_it->first ;
+ }
return out ;
}
+ SEXP getProperty( const std::string& name, SEXP object) throw(std::range_error) {
+ typename PROPERTY_MAP::iterator it = properties.find( name ) ;
+ if( it == properties.end() ){
+ throw std::range_error( "no such property" ) ;
+ }
+ prop_class* prop = it->second ;
+ return prop->get( XP(object) );
+ }
+ void setProperty( const std::string& name, SEXP object, SEXP value) throw(std::range_error){
+ typename PROPERTY_MAP::iterator it = properties.find( name ) ;
+ if( it == properties.end() ){
+ throw std::range_error( "no such property" ) ;
+ }
+ prop_class* prop = it->second ;
+ return prop->set( XP(object), value );
+ }
+
+#include <Rcpp/module/Module_Add_Property.h>
+
+
private:
METHOD_MAP methods ;
+ PROPERTY_MAP properties ;
static self* singleton ;
int specials ;
- class_( ) : class_Base(), methods(), specials(0) {};
+ class_( ) : class_Base(), methods(), properties(), specials(0) {};
} ;
Added: pkg/Rcpp/inst/include/Rcpp/module/Module_Add_Property.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/module/Module_Add_Property.h (rev 0)
+++ pkg/Rcpp/inst/include/Rcpp/module/Module_Add_Property.h 2010-06-04 09:13:30 UTC (rev 1413)
@@ -0,0 +1,74 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Module_Add_Property.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_Add_Property_h
+#define Rcpp_Module_Add_Property_h
+
+ template <typename PROP>
+ self& property( const char* name, PROP (Class::*GetMethod)(void) ){
+ AddProperty( name, new CppProperty_GetMethod<Class,PROP>(GetMethod) ) ;
+ return *this ;
+ }
+
+ template <typename PROP>
+ self& property( const char* name, PROP (*GetMethod)(Class*) ){
+ AddProperty( name, new CppProperty_GetPointerMethod<Class,PROP>(GetMethod) ) ;
+ return *this ;
+ }
+
+
+ template <typename PROP>
+ self& property( const char* name, PROP (Class::*GetMethod)(void), void (Class::*SetMethod)(PROP) ){
+ AddProperty(
+ name,
+ new CppProperty_GetMethod_SetMethod<Class,PROP>(GetMethod, SetMethod)
+ ) ;
+ return *this ;
+ }
+
+ template <typename PROP>
+ self& property( const char* name, PROP (Class::*GetMethod)(void), void (*SetMethod)(Class*,PROP) ){
+ AddProperty(
+ name,
+ new CppProperty_GetMethod_SetPointer<Class,PROP>(GetMethod, SetMethod)
+ ) ;
+ return *this ;
+ }
+
+ template <typename PROP>
+ self& property( const char* name, PROP (*GetMethod)(Class*), void (Class::*SetMethod)(PROP) ){
+ AddProperty(
+ name,
+ new CppProperty_GetPointer_SetMethod<Class,PROP>(GetMethod, SetMethod)
+ ) ;
+ }
+
+ template <typename PROP>
+ self& property( const char* name, PROP (*GetMethod)(Class*), void (*SetMethod)(Class*,PROP) ){
+ AddProperty(
+ name,
+ new CppProperty_GetPointer_SetPointer<Class,PROP>(GetMethod, SetMethod)
+ ) ;
+ return *this ;
+ }
+
+
+#endif
Added: pkg/Rcpp/inst/include/Rcpp/module/Module_Property.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/module/Module_Property.h (rev 0)
+++ pkg/Rcpp/inst/include/Rcpp/module/Module_Property.h 2010-06-04 09:13:30 UTC (rev 1413)
@@ -0,0 +1,162 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Module_Property.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_Property_h
+#define Rcpp_Module_Property_h
+
+// getter through a member function
+template <typename Class, typename PROP>
+class CppProperty_GetMethod : public CppProperty<Class> {
+ public:
+ typedef PROP (Class::*GetMethod)(void) ;
+ typedef CppProperty<Class> prop_class ;
+
+ CppProperty_GetMethod( GetMethod getter_ ) : getter(getter_){}
+
+ SEXP get(Class* object) throw(std::range_error){ return Rcpp::wrap( (object->*getter)() ) ; }
+ void set(Class*, SEXP) throw(std::range_error){ throw std::range_error("property is read only") ; }
+
+ private:
+ GetMethod getter ;
+
+} ;
+
+// getter through a free function taking a pointer to Class
+template <typename Class, typename PROP>
+class CppProperty_GetPointerMethod : public CppProperty<Class> {
+ public:
+ typedef PROP (*GetMethod)(Class*) ;
+ typedef CppProperty<Class> prop_class ;
+
+ CppProperty_GetPointerMethod( GetMethod getter_ ) : getter(getter_){}
+
+ SEXP get(Class* object) throw(std::range_error){ return Rcpp::wrap( getter(object) ) ; }
+ void set(Class*, SEXP) throw(std::range_error){ throw std::range_error("property is read only") ; }
+
+ private:
+ GetMethod getter ;
+
+} ;
+
+
+// getter and setter through member functions
+template <typename Class, typename PROP>
+class CppProperty_GetMethod_SetMethod : public CppProperty<Class> {
+ public:
+ typedef PROP (Class::*GetMethod)(void) ;
+ typedef void (Class::*SetMethod)(PROP) ;
+ typedef CppProperty<Class> prop_class ;
+
+ CppProperty_GetMethod_SetMethod( GetMethod getter_, SetMethod setter_) : getter(getter_), setter(setter_){}
+
+ SEXP get(Class* object) throw(std::range_error){
+ return Rcpp::wrap( (object->*getter)() ) ;
+ }
+ void set(Class* object, SEXP value) throw(std::range_error){
+ (object->*setter)(
+ Rcpp::as< typename Rcpp::traits::remove_const_and_reference< PROP >::type >( value )
+ ) ;
+ }
+
+ private:
+ GetMethod getter ;
+ SetMethod setter ;
+
+} ;
+
+// getter though a member function, setter through a pointer function
+template <typename Class, typename PROP>
+class CppProperty_GetMethod_SetPointer : public CppProperty<Class> {
+ public:
+ typedef PROP (Class::*GetMethod)(void) ;
+ typedef void (*SetMethod)(Class*,PROP) ;
+ typedef CppProperty<Class> prop_class ;
+
+ CppProperty_GetMethod_SetPointer( GetMethod getter_, SetMethod setter_) : getter(getter_), setter(setter_){}
+
+ SEXP get(Class* object) throw(std::range_error){
+ return Rcpp::wrap( (object->*getter)() ) ;
+ }
+ void set(Class* object, SEXP value) throw(std::range_error){
+ setter( object,
+ Rcpp::as< typename Rcpp::traits::remove_const_and_reference< PROP >::type >( value )
+ ) ;
+ }
+
+ private:
+ GetMethod getter ;
+ SetMethod setter ;
+
+} ;
+
+// getter through pointer function, setter through member function
+template <typename Class, typename PROP>
+class CppProperty_GetPointer_SetMethod : public CppProperty<Class> {
+ public:
+ typedef PROP (*GetMethod)(Class*) ;
+ typedef void (Class::*SetMethod)(PROP) ;
+ typedef CppProperty<Class> prop_class ;
+
+ CppProperty_GetPointer_SetMethod( GetMethod getter_, SetMethod setter_) : getter(getter_), setter(setter_){}
+
+ SEXP get(Class* object) throw(std::range_error){
+ return Rcpp::wrap( getter(object) ) ;
+ }
+ void set(Class* object, SEXP value) throw(std::range_error){
+ (object->*setter)(
+ Rcpp::as< typename Rcpp::traits::remove_const_and_reference< PROP >::type >( value )
+ ) ;
+ }
+
+ private:
+ GetMethod getter ;
+ SetMethod setter ;
+
+} ;
+
+// getter and setter through pointer functions
+// getter through pointer function, setter through member function
+template <typename Class, typename PROP>
+class CppProperty_GetPointer_SetPointer : public CppProperty<Class> {
+ public:
+ typedef PROP (*GetMethod)(Class*) ;
+ typedef void (*SetMethod)(Class*,PROP) ;
+ typedef CppProperty<Class> prop_class ;
+
+ CppProperty_GetPointer_SetPointer( GetMethod getter_, SetMethod setter_) : getter(getter_), setter(setter_){}
+
+ SEXP get(Class* object) throw(std::range_error){
+ return Rcpp::wrap( getter(object) ) ;
+ }
+ void set(Class* object, SEXP value) throw(std::range_error){
+ setter( object,
+ Rcpp::as< typename Rcpp::traits::remove_const_and_reference< PROP >::type >( value )
+ ) ;
+ }
+
+ private:
+ GetMethod getter ;
+ SetMethod setter ;
+
+} ;
+
+
+#endif
Modified: pkg/Rcpp/inst/unitTests/runit.Module.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.Module.R 2010-06-04 00:41:01 UTC (rev 1412)
+++ pkg/Rcpp/inst/unitTests/runit.Module.R 2010-06-04 09:13:30 UTC (rev 1413)
@@ -163,5 +163,38 @@
}
+test.Module.property <- function(){
+ inc <- '
+
+ class World {
+ public:
+ World() : msg("hello"){}
+ void set(std::string msg) { this->msg = msg; }
+ std::string greet() { return msg; }
+
+ private:
+ std::string msg;
+ };
+
+ RCPP_MODULE(yada){
+ using namespace Rcpp ;
+
+ class_<World>( "World" )
+ .property( "msg", &World::greet, &World::set )
+ ;
+
+ }
+
+ '
+ fx <- cxxfunction( signature(), "" , include = inc, plugin = "Rcpp" )
+
+ mod <- Module( "yada", getDynLib(fx) )
+ World <- mod$World
+ w <- new( World )
+ checkEquals( w$msg, "hello" )
+ w$msg <- "hello world"
+ checkEquals( w$msg, "hello world" )
}
+
+}
Modified: pkg/Rcpp/man/CppObject-class.Rd
===================================================================
--- pkg/Rcpp/man/CppObject-class.Rd 2010-06-04 00:41:01 UTC (rev 1412)
+++ pkg/Rcpp/man/CppObject-class.Rd 2010-06-04 09:13:30 UTC (rev 1413)
@@ -3,6 +3,7 @@
\docType{class}
\alias{C++Object-class}
\alias{$,C++Object-method}
+\alias{$<-,C++Object-method}
\alias{show,C++Object-method}
\title{c++ internal objects}
@@ -27,7 +28,8 @@
}
\section{Methods}{
\describe{
- \item{$}{\code{signature(x = "C++Object")}: invokes a method on the object }
+ \item{$}{\code{signature(x = "C++Object")}: invokes a method on the object, or retrieves the value of a property }
+ \item{$<-}{\code{signature(x = "C++Object")}: set the value of a property }
\item{show}{\code{signature(object = "C++Object")}: print the object }
}
}
Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp 2010-06-04 00:41:01 UTC (rev 1412)
+++ pkg/Rcpp/src/Module.cpp 2010-06-04 09:13:30 UTC (rev 1413)
@@ -31,6 +31,9 @@
RCPP_FUNCTION_2( bool, Class__has_method, XP_Class cl, std::string m){
return cl->has_method(m) ;
}
+RCPP_FUNCTION_2( bool, Class__has_property, XP_Class cl, std::string m){
+ return cl->has_property(m) ;
+}
RCPP_FUNCTION_1( std::string, Class__name, XP_Class cl){
return cl->name ;
}
@@ -65,7 +68,20 @@
XP_Class cl(xp) ;
return cl->complete();
}
+RCPP_FUNCTION_3(SEXP, CppClass__get, XP_Class cl, SEXP obj, std::string name){
+ BEGIN_RCPP
+ return cl->getProperty( name, obj ) ;
+ END_RCPP
+}
+RCPP_FUNCTION_4(SEXP, CppClass__set, XP_Class cl, SEXP obj, std::string name, SEXP value){
+ BEGIN_RCPP
+ cl->setProperty( name, obj, value ) ;
+ END_RCPP
+}
+
+
+
// .External functions
extern "C" SEXP Module__invoke( SEXP args){
SEXP p = CDR(args) ;
More information about the Rcpp-commits
mailing list