[Rcpp-devel] [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
_______________________________________________
Rcpp-commits mailing list
Rcpp-commits at lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-commits
More information about the Rcpp-devel
mailing list