[Rcpp-commits] r1168 - in pkg/Rcpp: 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 5 11:56:35 CEST 2010
Author: romain
Date: 2010-05-05 11:56:35 +0200 (Wed, 05 May 2010)
New Revision: 1168
Modified:
pkg/Rcpp/inst/ChangeLog
pkg/Rcpp/inst/include/Rcpp/S4.h
pkg/Rcpp/inst/include/Rcpp/exceptions.h
pkg/Rcpp/inst/include/RcppCommon.h
pkg/Rcpp/inst/unitTests/runit.S4.R
pkg/Rcpp/src/Evaluator.cpp
pkg/Rcpp/src/S4.cpp
Log:
+ S4::is method, following advice from Doug (lme4a)
Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog 2010-05-05 01:57:37 UTC (rev 1167)
+++ pkg/Rcpp/inst/ChangeLog 2010-05-05 09:56:35 UTC (rev 1168)
@@ -1,3 +1,10 @@
+2010-05-06 Romain Francois <romain at r-enthusiasts.com>
+
+ * inst/include/Rcpp/S4.h: S4 gains a "is" method to identify if an object
+ is of a given S4 class, following Doug's advice in lme4a
+
+ * inst/include/RcppCommon.h: new STL-like algorithm Rcpp::any
+
2010-05-04 Romain Francois <romain at r-enthusiasts.com>
* inst/include/Rcpp/preprocessor_generated.h: new macros to hide most of
Modified: pkg/Rcpp/inst/include/Rcpp/S4.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/S4.h 2010-05-05 01:57:37 UTC (rev 1167)
+++ pkg/Rcpp/inst/include/Rcpp/S4.h 2010-05-05 09:56:35 UTC (rev 1168)
@@ -61,6 +61,11 @@
*/
S4( const std::string& klass ) throw(S4_creation_error) ;
+ /**
+ * Indicates if this object is an instance of the given S4 class
+ */
+ bool is( const std::string& clazz) ;
+
} ;
} // namespace Rcpp
Modified: pkg/Rcpp/inst/include/Rcpp/exceptions.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/exceptions.h 2010-05-05 01:57:37 UTC (rev 1167)
+++ pkg/Rcpp/inst/include/Rcpp/exceptions.h 2010-05-05 09:56:35 UTC (rev 1168)
@@ -78,7 +78,6 @@
RCPP_SIMPLE_EXCEPTION_CLASS(no_such_function, "no such function")
RCPP_SIMPLE_EXCEPTION_CLASS(unevaluated_promise, "promise not yet evaluated")
-
RCPP_EXCEPTION_CLASS(not_compatible, message )
RCPP_EXCEPTION_CLASS(S4_creation_error, std::string("error creating object of S4 class : ") + message )
RCPP_EXCEPTION_CLASS(no_such_binding, std::string("no such binding : '") + message + "'" )
@@ -87,7 +86,6 @@
RCPP_EXCEPTION_CLASS(no_such_namespace, std::string("no such namespace: '") + message + "'" )
RCPP_EXCEPTION_CLASS(eval_error, message )
-
#undef RCPP_EXCEPTION_CLASS
#undef RCPP_SIMPLE_EXCEPTION_CLASS
Modified: pkg/Rcpp/inst/include/RcppCommon.h
===================================================================
--- pkg/Rcpp/inst/include/RcppCommon.h 2010-05-05 01:57:37 UTC (rev 1167)
+++ pkg/Rcpp/inst/include/RcppCommon.h 2010-05-05 09:56:35 UTC (rev 1168)
@@ -156,8 +156,8 @@
/* defined in Evaluator.cpp */
SEXP convert_using_rfunction(SEXP x, const char* const fun) throw(::Rcpp::not_compatible) ;
- SEXP try_catch( SEXP expr, SEXP env ) ;
- SEXP try_catch( SEXP expr ) ;
+ SEXP try_catch( SEXP expr, SEXP env ) throw(::Rcpp::eval_error) ;
+ SEXP try_catch( SEXP expr ) throw(::Rcpp::eval_error) ;
} // namespace internal
@@ -223,5 +223,19 @@
RcppExport SEXP RcppXPtrExample_get_external_pointer(SEXP );
#include <Rcpp/preprocessor.h>
+
+namespace Rcpp{
+
+/**
+ * stl like algorithm to identify if any of the objects in the range
+ * is equal to the value
+ */
+template<class InputIterator, class T>
+bool any( InputIterator first, InputIterator last, const T& value ){
+ for ( ;first!=last; first++) if ( *first==value ) return true;
+ return false;
+} ;
+}
+
#endif
Modified: pkg/Rcpp/inst/unitTests/runit.S4.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.S4.R 2010-05-05 01:57:37 UTC (rev 1167)
+++ pkg/Rcpp/inst/unitTests/runit.S4.R 2010-05-05 09:56:35 UTC (rev 1168)
@@ -86,3 +86,26 @@
}
+
+test.S4.is <- function(){
+ setClass("track", representation(x="numeric", y="numeric"))
+ setClass("trackCurve", representation(smooth = "numeric"), contains = "track")
+
+ tr1 <- new( "track", x = 2, y = 3 )
+ tr2 <- new( "trackCurve", x = 2, y = 3, smooth = 5 )
+
+ fx <- cppfunction( signature(tr="ANY"), '
+ S4 o(tr) ;
+ return wrap( o.is( "track" ) ) ;
+ ' )
+ checkTrue( fx( tr1 ), msg = 'track is track' )
+ checkTrue( fx( tr2 ), msg = 'trackCurve is track' )
+
+ fx <- cppfunction( signature(tr="ANY"), '
+ S4 o(tr) ;
+ return wrap( o.is( "trackCurve" ) ) ;
+ ' )
+ checkTrue( !fx( tr1 ), msg = 'track is not trackCurve' )
+ checkTrue( fx( tr2 ), msg = 'trackCurve is trackCurve' )
+
+}
Modified: pkg/Rcpp/src/Evaluator.cpp
===================================================================
--- pkg/Rcpp/src/Evaluator.cpp 2010-05-05 01:57:37 UTC (rev 1167)
+++ pkg/Rcpp/src/Evaluator.cpp 2010-05-05 09:56:35 UTC (rev 1168)
@@ -64,10 +64,10 @@
return res;
}
- SEXP try_catch( SEXP expr, SEXP env ){
+ SEXP try_catch( SEXP expr, SEXP env ) throw(::Rcpp::eval_error) {
return Evaluator::run(expr, env) ;
}
- SEXP try_catch( SEXP expr ){
+ SEXP try_catch( SEXP expr ) throw(::Rcpp::eval_error) {
return Evaluator::run(expr) ;
}
Modified: pkg/Rcpp/src/S4.cpp
===================================================================
--- pkg/Rcpp/src/S4.cpp 2010-05-05 01:57:37 UTC (rev 1167)
+++ pkg/Rcpp/src/S4.cpp 2010-05-05 09:56:35 UTC (rev 1168)
@@ -21,6 +21,7 @@
#include <Rcpp/S4.h>
#include <Rcpp/exceptions.h>
+#include <Rcpp/Vector.h>
namespace Rcpp {
@@ -53,4 +54,34 @@
UNPROTECT( 1) ; /* oo */
}
+ bool S4::is( const std::string& clazz ) {
+ CharacterVector cl = attr("class");
+
+ // simple test for exact match
+ if( ! clazz.compare( cl[0] ) ) return true ;
+
+ try{
+ //
+ // mimic the R call:
+ // names( slot( getClassDef( cl ), "contains" ) )
+ //
+ CharacterVector res = internal::try_catch(
+ Rf_lang2(
+ Rf_install( "names" ),
+ Rf_lang3(
+ Rf_install( "slot" ),
+ Rf_lang2( Rf_install( "getClassDef"), cl ),
+ Rf_mkString( "contains" )
+ )
+ )
+ ) ;
+ return any( res.begin(), res.end(), clazz.c_str() ) ;
+ } catch( ... ){
+ // we catch eval_error and also not_compatible when
+ // contains is NULL
+ }
+ return false ;
+
+ }
+
} // namespace Rcpp
More information about the Rcpp-commits
mailing list