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

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Thu Jan 7 18:28:37 CET 2010


Author: romain
Date: 2010-01-07 18:28:37 +0100 (Thu, 07 Jan 2010)
New Revision: 304

Added:
   pkg/inst/unitTests/runit.S4.R
Modified:
   pkg/inst/ChangeLog
   pkg/src/RObject.cpp
   pkg/src/Rcpp/RObject.h
Log:
added some S4 management stuff

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2010-01-07 16:38:02 UTC (rev 303)
+++ pkg/inst/ChangeLog	2010-01-07 17:28:37 UTC (rev 304)
@@ -1,5 +1,9 @@
 2010-01-07  Romain Francois <francoisromain at free.fr>
 
+	* src/Rcpp/RObject.h: added methods "isS4", "slot" 
+	and "hasSlot" to deal with S4 objects
+	* inst/unitTests/runit.S4.R: unit tests
+
 	* src/Rcpp/ComplexVector.h: new class Rcpp::ComplexVector
 	to manage ... complex vectors (CPLXSXP)
 	* src/ComplexVector.cpp: implementation

Added: pkg/inst/unitTests/runit.S4.R
===================================================================
--- pkg/inst/unitTests/runit.S4.R	                        (rev 0)
+++ pkg/inst/unitTests/runit.S4.R	2010-01-07 17:28:37 UTC (rev 304)
@@ -0,0 +1,42 @@
+#!/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/>.
+
+.setUp <- function(){
+	suppressMessages( require( inline ) )
+}
+
+test.S4 <- function(){
+	funx <- cfunction(signature(x = "ANY" ), '
+	RObject y(x) ;
+	List res(5) ;
+	res[0] = y.isS4() ;
+	res[1] = y.hasSlot("x") ;
+	res[2] = y.hasSlot("z") ;
+	res[3] = y.slot("x") ;
+	res[4] = y.slot("y") ;
+	return res ;
+	', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+	setClass("track",
+           representation(x="numeric", y="numeric"))
+	tr <- new( "track", x = 2, y = 2 )
+	checkEquals( funx(tr),
+		list( TRUE, TRUE, FALSE, 2.0, 2.0 )
+	, msg = "slot management" )
+}
+

Modified: pkg/src/RObject.cpp
===================================================================
--- pkg/src/RObject.cpp	2010-01-07 16:38:02 UTC (rev 303)
+++ pkg/src/RObject.cpp	2010-01-07 17:28:37 UTC (rev 304)
@@ -103,11 +103,25 @@
 	return wrap( Rf_getAttrib( m_sexp, Rf_install( name.c_str() ) ) );
 }
 
+/* S4 */
+
+bool RObject::hasSlot(const std::string& name) const throw(not_s4){
+	if( !Rf_isS4(m_sexp) ) throw not_s4() ;
+	return R_has_slot( m_sexp, Rf_mkString(name.c_str()) ) ;
+}
+
+RObject RObject::slot(const std::string& name) const throw(not_s4){
+	if( !Rf_isS4(m_sexp) ) throw not_s4() ;
+	return R_do_slot( m_sexp, Rf_mkString(name.c_str()) ) ;
+}
+
+
 const char* RObject::not_compatible::what( ) const throw() {
 	return message.c_str() ;
 }
-RObject::not_compatible::~not_compatible() throw() {}
-			
+const char* RObject::not_s4::what( ) const throw() {
+	return "not an S4 object" ;
+}
 
 } // namespace Rcpp
 

Modified: pkg/src/Rcpp/RObject.h
===================================================================
--- pkg/src/Rcpp/RObject.h	2010-01-07 16:38:02 UTC (rev 303)
+++ pkg/src/Rcpp/RObject.h	2010-01-07 17:28:37 UTC (rev 304)
@@ -36,54 +36,61 @@
    	class not_compatible: public std::exception{
    		public:
    			not_compatible(const std::string& message) throw() : message(message){};
-   			
+   			~not_compatible() throw(){} ;
    			const char* what() const throw() ; 
-   			
-   			~not_compatible() throw() ;
    		private:
    			std::string message ;
    	} ;
-	
-	
-    /**
+
+	/**
+   	 * Exception thrown when attempting to convert a SEXP
+   	 */
+   	class not_s4: public std::exception{
+   		public:
+   			not_s4() throw(){};
+   			~not_s4() throw(){} ;
+   			const char* what() const throw() ; 
+   	} ;
+
+   /**
      * default constructor. uses R_NilValue
      */ 
     RObject() : m_sexp(R_NilValue) {} ;	
-	
+
     /**
      * wraps a SEXP. The SEXP is automatically protected from garbage 
      * collection by this object and the protection vanishes when this 
      * object is destroyed
      */
     RObject(SEXP x) : m_sexp(R_NilValue) { setSEXP(x) ; };
-    
+
     /**
      * Copy constructor. set this SEXP to the SEXP of the copied object
      */
     RObject( const RObject& other ) ;
-    
+
     /**
      * Assignment operator. set this SEXP to the SEXP of the copied object
      */
     RObject& operator=( const RObject& other ) ;
-    
+
     /** 
      * Assignement operator. Set this SEXP to the given SEXP
      */ 
     RObject& operator=( SEXP other ) ;
-    
+
     /**
      * if this object is protected rom R's GC, then it is released
      * and become subject to garbage collection. See preserve 
      * and release member functions.
      */
     virtual ~RObject() ;
-   
+
     /**
      * implicit conversion to SEXP
      */
     inline operator SEXP() const { return m_sexp ; }
-    
+
     /* we don't provide implicit converters because 
        of Item 5 in More Effective C++ */
     bool                     asBool() const;
@@ -96,43 +103,69 @@
     std::vector<std::string> asStdVectorString() const;
     std::vector<Rbyte>       asStdVectorRaw() const;
     std::vector<bool>        asStdVectorBool() const;
-    
+
     inline bool isPreserved() { DEFUNCT("isPreserved") ; return m_sexp != R_NilValue ; }
     inline void forgetPreserve() { DEFUNCT("forgetPreserve") ; }
-    
+
     /* attributes */
-	
+
     /**
      * extracts the names of the attributes of the wrapped SEXP
      */
     std::vector<std::string> attributeNames() const ;
-    
+
     /**
      * Identifies if the SEXP has the given attribute
      */
     bool hasAttribute( const std::string& attr) const ; 
-    
+
     /**
      * extract the given attribute
      */
+    /* TODO: implement a proxy pattern for attributes */
     RObject attr( const std::string& name) const  ;
-    
+
     /**
      * is this object NULL
      */
     inline bool isNULL() const{ return Rf_isNull(m_sexp) ; }
-    
+
     /**
      * The SEXP typeof, calls TYPEOF on the underlying SEXP
      */
     inline int sexp_type() const { return TYPEOF(m_sexp) ; }
-    
+
     /** 
      * explicit conversion to SEXP
      */
     inline SEXP asSexp() const { return m_sexp ; }
-    
-    
+
+    /**
+     * Tests if the SEXP has the object bit set
+     */
+    inline bool isObject() const { return Rf_isObject(m_sexp) ;}
+
+    /**
+     * Tests if the SEXP is an S4 object
+     */
+    inline bool isS4() const { return Rf_isS4(m_sexp) ; }
+
+    /**
+     * Indicates if this S4 object has the given slot
+     *
+     * @throw not_s4 if the object is not an S4 object
+     */
+    bool hasSlot(const std::string& name) const throw(not_s4) ;
+
+    /**
+     * Retrieves the given slot
+     *
+     * @throw not_s4 if this is not an S4 object
+     */
+    RObject slot(const std::string& name) const throw(not_s4) ;
+    /* TODO : implement the proxy pattern here so that we can get and 
+              set the slot the same way */
+
 protected:
 
     /**
@@ -141,20 +174,20 @@
      * @param x new SEXP to attach to this object
      */
     void setSEXP(SEXP x) ;
-   
+
     inline void DEFUNCT(const std::string& method ){ Rf_warning("method %s is defunct", method.c_str() )  ; }
-    
+
     /**
      * The SEXP this is wrapping. This has to be considered read only.
      * to change it, use setSEXP
      */
     SEXP m_sexp ;
-    
+
 private:
-    
+
     void preserve(){ if( m_sexp != R_NilValue ) R_PreserveObject(m_sexp) ; } 
     void release() { if( m_sexp != R_NilValue ) R_ReleaseObject(m_sexp) ; } 
-    
+
 };
 
 } // namespace Rcpp



More information about the Rcpp-commits mailing list