[Rcpp-commits] r899 - in pkg/Rcpp: inst inst/unitTests src src/Rcpp

[noreply at r-forge.r-project.org]

Author: romain
Date: 2010-03-14 19:49:42 +0100 (Sun, 14 Mar 2010)
New Revision: 899

Modified:
   pkg/Rcpp/inst/ChangeLog
   pkg/Rcpp/inst/unitTests/runit.S4.R
   pkg/Rcpp/src/Rcpp/S4.h
   pkg/Rcpp/src/Rcpp/exceptions.h
   pkg/Rcpp/src/S4.cpp
Log:
Rcpp::S4 gains a constructor taking a string reference

Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog	2010-03-14 12:38:22 UTC (rev 898)
+++ pkg/Rcpp/inst/ChangeLog	2010-03-14 18:49:42 UTC (rev 899)
@@ -1,3 +1,10 @@
+2010-03-14  Romain Francois <romain at r-enthusiasts.com>
+
+	* src/Rcpp/S4.h : Rcpp::S4 gains a new constructor taking a string 
+	reference and building a new S4 object of that type. This throws an 
+	exception if the object is not successfully created (e.g the class
+	is not a known S4 class)
+
 2010-03-13  Romain Francois <romain at r-enthusiasts.com>
 
 	* src/Rcpp/S4.h : new class Rcpp::S4

Modified: pkg/Rcpp/inst/unitTests/runit.S4.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.S4.R	2010-03-14 12:38:22 UTC (rev 898)
+++ pkg/Rcpp/inst/unitTests/runit.S4.R	2010-03-14 18:49:42 UTC (rev 899)
@@ -75,8 +75,19 @@
 		Rcpp = TRUE, includes = "using namespace Rcpp;" )
 	checkEquals( fx( tr ), 2, msg = "S4( SEXP )" )
 	
-	checkExecption( fx( list( x = 2, y = 3 ) ), msg = "not S4" )
+	checkException( fx( list( x = 2, y = 3 ) ), msg = "not S4" )
 	checkException( fx( structure( list( x = 2, y = 3 ), class = "track" ) ), msg = "S3 is not S4" )
+
+	fx <- cfunction( signature( clazz = "character" ), 
+		'
+		std::string cl = as<std::string>( clazz );
+		return S4( cl ); 
+		', includes = "using namespace Rcpp" )
+	tr <- fx( "track" )
+	checkTrue( inherits( tr, "track" ) )
+	checkEquals( tr at x, 0.0 )
+	checkEquals( tr at y, 0.0 )
+	checkException( fx( "someclassthatdoesnotexist" ) )
 	
 }
 

Modified: pkg/Rcpp/src/Rcpp/S4.h
===================================================================
--- pkg/Rcpp/src/Rcpp/S4.h	2010-03-14 12:38:22 UTC (rev 898)
+++ pkg/Rcpp/src/Rcpp/S4.h	2010-03-14 18:49:42 UTC (rev 899)
@@ -34,8 +34,7 @@
 	S4(const S4& other) ;
 	S4& operator=( const S4& other);
 	
-	// TODO : 
-	// S4( const& std::string klass ) ; ...
+	S4( const std::string& klass ) ;
 	
 } ;
 

Modified: pkg/Rcpp/src/Rcpp/exceptions.h
===================================================================
--- pkg/Rcpp/src/Rcpp/exceptions.h	2010-03-14 12:38:22 UTC (rev 898)
+++ pkg/Rcpp/src/Rcpp/exceptions.h	2010-03-14 18:49:42 UTC (rev 899)
@@ -44,7 +44,18 @@
 		virtual ~parse_error() throw(){};
 		virtual const char* what() const throw(){ return "parse error" ; } ;
 	} ;
-		
+
+class S4_creation_error : public std::exception{
+	public:
+		S4_creation_error(const std::string& klass) throw() : message("error creating object of S4 class : ") {
+			message += klass ;
+		} ;
+		virtual ~S4_creation_error() throw(){};
+		virtual const char* what() const throw(){ return "" ; } ;
+	private:
+		std::string message ;
+} ;
+	
 } // namesapce Rcpp
 
 #endif

Modified: pkg/Rcpp/src/S4.cpp
===================================================================
--- pkg/Rcpp/src/S4.cpp	2010-03-14 12:38:22 UTC (rev 898)
+++ pkg/Rcpp/src/S4.cpp	2010-03-14 18:49:42 UTC (rev 899)
@@ -20,6 +20,7 @@
 // along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
 #include <Rcpp/S4.h>
+#include <Rcpp/exceptions.h>
 
 namespace Rcpp {
 
@@ -42,4 +43,14 @@
 		return *this ;
 	}
 	
+	S4::S4( const std::string& klass ) {
+		SEXP oo = PROTECT( R_do_new_object(R_do_MAKE_CLASS(klass.c_str())) ) ;
+  		if (!Rf_inherits(oo, klass.c_str())) {
+  			UNPROTECT( 1) ;
+  			throw S4_creation_error( klass ) ;
+  		}
+  		setSEXP( oo ) ;
+  		UNPROTECT( 1) ; /* oo */
+	}
+	
 } // namespace Rcpp