[Rcpp-commits] r457 - in pkg: inst src src/Rcpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jan 26 09:23:16 CET 2010
Author: romain
Date: 2010-01-26 09:23:15 +0100 (Tue, 26 Jan 2010)
New Revision: 457
Added:
pkg/src/Rcpp/r_cast.h
pkg/src/r_cast.cpp
Removed:
pkg/src/SEXP_Vector.cpp
Modified:
pkg/inst/ChangeLog
pkg/src/CharacterVector.cpp
pkg/src/Evaluator.cpp
pkg/src/Rcpp.h
pkg/src/Rcpp/CharacterVector.h
pkg/src/Rcpp/SEXP_Vector.h
pkg/src/Rcpp/SimpleVector.h
pkg/src/Rcpp/VectorBase.h
pkg/src/Rcpp/wrap.h
pkg/src/RcppCommon.h
pkg/src/VectorBase.cpp
Log:
introduce r_cast<int>(SEXP) to transform a SEXP to another SEXP type
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/inst/ChangeLog 2010-01-26 08:23:15 UTC (rev 457)
@@ -1,3 +1,8 @@
+2010-01-26 Romain Francois <francoisromain at free.fr>
+
+ * src/Rcpp/r_cast.h: new template function to handle casts
+ from one SEXP to another. This is mostly useful internally
+
2010-01-25 Romain Francois <francoisromain at free.fr>
* src/Rcpp/wrap.h: wrap is back at being a template. The
Modified: pkg/src/CharacterVector.cpp
===================================================================
--- pkg/src/CharacterVector.cpp 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/CharacterVector.cpp 2010-01-26 08:23:15 UTC (rev 457)
@@ -24,23 +24,12 @@
namespace Rcpp{
CharacterVector::CharacterVector(SEXP x) throw(not_compatible) : VectorBase() {
- switch( TYPEOF( x ) ){
- case STRSXP:
- setSEXP( x ) ;
- break ;
- case SYMSXP:
- setSEXP( Rf_ScalarString(PRINTNAME(x)) ) ;
- break ;
- case CHARSXP:
- setSEXP( Rf_ScalarString( x ) ) ;
- default:
- /* TODO: try coercion */
- throw not_compatible( "not compatible with character vector" ) ;
- }
+ SEXP y = r_cast<STRSXP>( x) ;
+ setSEXP( y ) ;
}
- CharacterVector::CharacterVector(int size) : VectorBase() {
- setSEXP( Rf_allocVector(STRSXP, size) ) ;
+ CharacterVector::CharacterVector(const size_t& size) : VectorBase(){
+ setSEXP( Rf_allocVector( STRSXP, size ) ) ;
}
CharacterVector::CharacterVector( const std::string& x) : VectorBase() {
Modified: pkg/src/Evaluator.cpp
===================================================================
--- pkg/src/Evaluator.cpp 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/Evaluator.cpp 2010-01-26 08:23:15 UTC (rev 457)
@@ -30,11 +30,11 @@
SEXP Evaluator::run(SEXP expr, SEXP env) throw(eval_error) {
+ SEXP call = PROTECT( Rf_lang3( Rf_install("rcpp_tryCatch") , expr, env ) ) ;
+
/* already protected */
SEXP RCPP = Environment::Rcpp_namespace();
-
- SEXP call = PROTECT( Rf_lang3( Rf_install("rcpp_tryCatch") , expr, env ) ) ;
-
+
/* call the tryCatch call */
SEXP res = PROTECT( Rf_eval( call, RCPP ) );
@@ -57,4 +57,14 @@
SEXP Evaluator::run( SEXP expr) throw(eval_error){
return run(expr, R_GlobalEnv );
}
+
+
+namespace internal{
+/* this is defined here because we need to be sure that Evaluator is
+ defined */
+ SEXP convert_using_rfunction(SEXP x, const char* const fun){
+ return Evaluator::run( Rf_lcons( Rf_install(fun), Rf_cons(x, R_NilValue) ) ) ;
+ }
+} // namespace internal
+
} // namespace Rcpp
Modified: pkg/src/Rcpp/CharacterVector.h
===================================================================
--- pkg/src/Rcpp/CharacterVector.h 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/Rcpp/CharacterVector.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -25,6 +25,7 @@
#include <RcppCommon.h>
#include <Rcpp/RObject.h>
#include <Rcpp/VectorBase.h>
+#include <Rcpp/r_cast.h>
namespace Rcpp{
@@ -53,7 +54,7 @@
} ;
CharacterVector(SEXP x) throw(not_compatible);
- CharacterVector(int size) ;
+ CharacterVector( const size_t& size) ;
CharacterVector( const std::string& x );
CharacterVector( const std::vector<std::string>& x );
Modified: pkg/src/Rcpp/SEXP_Vector.h
===================================================================
--- pkg/src/Rcpp/SEXP_Vector.h 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/Rcpp/SEXP_Vector.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -27,14 +27,9 @@
#include <Rcpp/Environment.h>
namespace Rcpp{
-
-/* this is only meant for internal use (at least for now) */
-SEXP convert_using_rfunction(SEXP x, const char* fun) ;
-template <int RTYPE> SEXP converter(SEXP x) ;
-template<> SEXP converter<VECSXP>(SEXP x) ;
-template<> SEXP converter<EXPRSXP>(SEXP x) ;
-template <int RTYPE> class SEXP_Vector : public VectorBase{
+template <int RTYPE>
+class SEXP_Vector : public VectorBase {
public:
/* much inspired from item 30 of more effective C++ */
@@ -78,19 +73,12 @@
SEXP_Vector(): VectorBase(){}
SEXP_Vector(SEXP x) : VectorBase() {
- int type = TYPEOF(x) ;
- if( type == RTYPE ){
- setSEXP( x ) ;
- } else {
- SEXP y = converter<RTYPE>(x) ;
- setSEXP( y );
- }
+ SEXP y = r_cast<RTYPE>(x) ;
+ setSEXP( y );
}
- /* FIXME : this should be in VectorBase, which also should
- templated by RTYPE */
SEXP_Vector(const size_t& size) : VectorBase(){
- setSEXP( Rf_allocVector( RTYPE, size) ) ;
+ setSEXP( Rf_allocVector( RTYPE, size ) ) ;
}
#ifdef HAS_INIT_LISTS
Modified: pkg/src/Rcpp/SimpleVector.h
===================================================================
--- pkg/src/Rcpp/SimpleVector.h 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/Rcpp/SimpleVector.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -23,34 +23,24 @@
#define Rcpp_SimpleVector_h
#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
#include <Rcpp/VectorBase.h>
+#include <Rcpp/r_cast.h>
namespace Rcpp{
-
+
template <int RTYPE, typename CTYPE>
class SimpleVector : public VectorBase {
public:
SimpleVector() : VectorBase(), start(0){}
- SimpleVector(SEXP x) throw(not_compatible) : VectorBase(), start(0) {
- int type = TYPEOF(x) ;
- switch( type ){
- case RTYPE:
- setSEXP( x) ;
- break ;
- default:
- if( type == INTSXP || type == LGLSXP || type == CPLXSXP || type == RAWSXP || type == REALSXP ){
- setSEXP( Rf_coerceVector(x, RTYPE ) );
- break ;
- } else{
- /* TODO : include RTYPE in the message */
- throw not_compatible( "cannot convert to simple vector" ) ;
- }
- }
+ SimpleVector(SEXP x) throw(RObject::not_compatible) : VectorBase(), start(0){
+ SEXP y = r_cast<RTYPE>( x ) ;
+ setSEXP( y );
}
-
- SimpleVector( const size_t& size): VectorBase(), start(0){
- setSEXP( Rf_allocVector( RTYPE, size ) ) ;
+
+ SimpleVector( const size_t& size){
+ setSEXP( Rf_allocVector( RTYPE, size) ) ;
}
#ifdef HAS_INIT_LISTS
@@ -63,18 +53,18 @@
inline CTYPE* begin() const{ return start ; }
inline CTYPE* end() const{ return start+Rf_length(m_sexp); }
- CTYPE& operator()( const size_t& i) throw(index_out_of_bounds){
- if( i >= static_cast<size_t>(Rf_length(m_sexp)) ) throw index_out_of_bounds() ;
+ CTYPE& operator()( const size_t& i) throw(RObject::index_out_of_bounds){
+ if( i >= static_cast<size_t>(Rf_length(m_sexp)) ) throw RObject::index_out_of_bounds() ;
return start[i] ;
}
- CTYPE& operator()( const size_t& i, const size_t& j) throw(not_a_matrix,index_out_of_bounds){
+ CTYPE& operator()( const size_t& i, const size_t& j) throw(VectorBase::not_a_matrix,RObject::index_out_of_bounds){
/* TODO: factor this code out into a Offset class otr something */
- if( !Rf_isMatrix(m_sexp) ) throw not_a_matrix() ;
+ if( !Rf_isMatrix(m_sexp) ) throw VectorBase::not_a_matrix() ;
int *dim = INTEGER( Rf_getAttrib( m_sexp, R_DimSymbol ) ) ;
size_t nrow = static_cast<size_t>(dim[0]) ;
size_t ncol = static_cast<size_t>(dim[1]) ;
- if( i >= nrow || j >= ncol ) throw index_out_of_bounds() ;
+ if( i >= nrow || j >= ncol ) throw RObject::index_out_of_bounds() ;
return start[ i + nrow*j ] ;
}
Modified: pkg/src/Rcpp/VectorBase.h
===================================================================
--- pkg/src/Rcpp/VectorBase.h 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/Rcpp/VectorBase.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -37,18 +37,18 @@
} ;
VectorBase() ;
- virtual ~VectorBase() = 0;
-
+ virtual ~VectorBase() ;
+
/**
* the length of the vector, uses Rf_length
*/
inline int length() const { return ::Rf_length( m_sexp ) ; }
-
+
/**
* alias of length
*/
inline int size() const { return ::Rf_length( m_sexp ) ; }
-
+
} ;
template <int sexptype, typename T> T* get_pointer(SEXP x){ throw std::exception( "not implemented" ) ; return static_cast<T*>(0); }
Added: pkg/src/Rcpp/r_cast.h
===================================================================
--- pkg/src/Rcpp/r_cast.h (rev 0)
+++ pkg/src/Rcpp/r_cast.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -0,0 +1,57 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// rcast.h: Rcpp R/C++ interface class library -- cast from one SEXP type to another
+//
+// 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_rcast_h
+#define Rcpp_rcast_h
+
+#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
+
+namespace Rcpp{
+namespace internal {
+
+// /* r_true_cast is only meant to be used when the target SEXP type
+// is different from the SEXP type of x */
+template <int TARGET>
+SEXP r_true_cast( SEXP x){
+ throw RObject::not_compatible( "not compatible" ) ;
+}
+
+template<> SEXP r_true_cast<INTSXP>(SEXP x);
+template<> SEXP r_true_cast<REALSXP>(SEXP x);
+template<> SEXP r_true_cast<RAWSXP>(SEXP x);
+template<> SEXP r_true_cast<CPLXSXP>(SEXP x);
+template<> SEXP r_true_cast<LGLSXP>(SEXP x);
+template<> SEXP r_true_cast<STRSXP>(SEXP x);
+template<> SEXP r_true_cast<VECSXP>(SEXP x);
+template<> SEXP r_true_cast<EXPRSXP>(SEXP x);
+template<> SEXP r_true_cast<LISTSXP>(SEXP x);
+template<> SEXP r_true_cast<LANGSXP>(SEXP x);
+
+} // namespace internal
+
+template <int TARGET> SEXP r_cast( SEXP x){
+ return (TYPEOF(x)== TARGET) ? x : internal::r_true_cast<TARGET>(x) ;
+}
+
+} // namespace Rcpp
+
+#endif
Modified: pkg/src/Rcpp/wrap.h
===================================================================
--- pkg/src/Rcpp/wrap.h 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/Rcpp/wrap.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -31,7 +31,6 @@
#include <Rcpp/NumericVector.h>
#include <Rcpp/LogicalVector.h>
#include <Rcpp/CharacterVector.h>
-// #include <Rcpp/GenericVector.h>
namespace Rcpp{
Modified: pkg/src/Rcpp.h
===================================================================
--- pkg/src/Rcpp.h 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/Rcpp.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -43,6 +43,7 @@
#include <RcppVectorView.h>
/* new api */
+#include <Rcpp/r_cast.h>
#include <Rcpp/grow.h>
#include <Rcpp/wrap.h>
#include <Rcpp/as.h>
Modified: pkg/src/RcppCommon.h
===================================================================
--- pkg/src/RcppCommon.h 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/RcppCommon.h 2010-01-26 08:23:15 UTC (rev 457)
@@ -108,9 +108,17 @@
class Named ;
class Pairlist ;
class Function ;
- class WeakReference;
- class CharacterVector;
-}
+ class WeakReference;
+/* internal namespace for things not intended to be used by the
+ user */
+namespace internal{
+
+ /* defined in Evaluator.cpp */
+ SEXP convert_using_rfunction(SEXP x, const char* const fun) ;
+
+} // namespace internal
+} // namespace Rcpp
+
#endif
Deleted: pkg/src/SEXP_Vector.cpp
===================================================================
--- pkg/src/SEXP_Vector.cpp 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/SEXP_Vector.cpp 2010-01-26 08:23:15 UTC (rev 457)
@@ -1,45 +0,0 @@
-// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
-//
-// SEXP_Vector.cpp: Rcpp R/C++ interface class library -- template for expression and generic vectors
-//
-// 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/>.
-
-#include <Rcpp/SEXP_Vector.h>
-
-namespace Rcpp{
-
-template<> SEXP converter<VECSXP>(SEXP x){
- return convert_using_rfunction( x, "as.list" ) ;
-}
-template<> SEXP converter<EXPRSXP>(SEXP x){
- return convert_using_rfunction( x, "as.expression" ) ;
-}
-
-SEXP convert_using_rfunction(SEXP x, const char* fun){
- SEXP res = R_NilValue ;
- try{
- res = Evaluator::run( Rf_lang2( Rf_install( fun ), x ) );
- } catch( const Evaluator::eval_error& ex){
- throw RObject::not_compatible( "not compatible" ) ;
- }
- return res ;
-}
-
-
-} // namespace Rcpp
-
Modified: pkg/src/VectorBase.cpp
===================================================================
--- pkg/src/VectorBase.cpp 2010-01-26 03:28:26 UTC (rev 456)
+++ pkg/src/VectorBase.cpp 2010-01-26 08:23:15 UTC (rev 457)
@@ -24,9 +24,10 @@
#include <Rcpp/VectorBase.h>
namespace Rcpp{
- VectorBase::VectorBase(): RObject(){} ;
+
+ VectorBase::VectorBase() : RObject() {} ;
VectorBase::~VectorBase(){}
-
+
template<> double* get_pointer<REALSXP,double>(SEXP x){ return REAL(x) ; }
template<> int* get_pointer<INTSXP,int>(SEXP x){ return INTEGER(x) ; }
template<> int* get_pointer<LGLSXP,int>(SEXP x){ return LOGICAL(x) ; }
Added: pkg/src/r_cast.cpp
===================================================================
--- pkg/src/r_cast.cpp (rev 0)
+++ pkg/src/r_cast.cpp 2010-01-26 08:23:15 UTC (rev 457)
@@ -0,0 +1,126 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// rcast.h: Rcpp R/C++ interface class library -- cast from one SEXP type to another
+//
+// 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/>.
+
+#include <Rcpp/r_cast.h>
+
+namespace Rcpp{
+namespace internal{
+
+template<> SEXP r_true_cast<INTSXP>(SEXP x){
+ switch( TYPEOF(x) ){
+ case REALSXP:
+ case RAWSXP:
+ case LGLSXP:
+ case CPLXSXP:
+ return Rf_coerceVector( x, INTSXP) ;
+ default:
+ throw RObject::not_compatible( "not compatible with INTSXP" ) ;
+ }
+ return R_NilValue ; /* -Wall */
+}
+
+template<> SEXP r_true_cast<REALSXP>( SEXP x){
+ switch( TYPEOF( x ) ){
+ case INTSXP:
+ case LGLSXP:
+ case CPLXSXP:
+ case RAWSXP:
+ return Rf_coerceVector( x, REALSXP );
+ default:
+ throw RObject::not_compatible( "not compatible with INTSXP" ) ;
+ }
+ return R_NilValue ; /* -Wall */
+}
+
+template<> SEXP r_true_cast<LGLSXP>( SEXP x){
+ switch( TYPEOF( x ) ){
+ case REALSXP:
+ case INTSXP:
+ case CPLXSXP:
+ case RAWSXP:
+ return Rf_coerceVector( x, LGLSXP );
+ default:
+ throw RObject::not_compatible( "not compatible with LGLSXP" ) ;
+ }
+ return R_NilValue ; /* -Wall */
+}
+
+template<> SEXP r_true_cast<RAWSXP>( SEXP x){
+ switch( TYPEOF( x ) ){
+ case LGLSXP:
+ case REALSXP:
+ case INTSXP:
+ case CPLXSXP:
+ return Rf_coerceVector( x, RAWSXP );
+ default:
+ throw RObject::not_compatible( "not compatible with RAWSXP" ) ;
+ }
+ return R_NilValue ; /* -Wall */
+}
+
+
+template<> SEXP r_true_cast<CPLXSXP>( SEXP x){
+ switch( TYPEOF( x ) ){
+ case RAWSXP:
+ case LGLSXP:
+ case REALSXP:
+ case INTSXP:
+ return Rf_coerceVector( x, CPLXSXP );
+ default:
+ throw RObject::not_compatible( "not compatible with CPLXSXP" ) ;
+ }
+ return R_NilValue ; /* -Wall */
+}
+
+template<> SEXP r_true_cast<STRSXP>( SEXP x){
+ switch( TYPEOF( x ) ){
+ case CPLXSXP:
+ case RAWSXP:
+ case LGLSXP:
+ case REALSXP:
+ case INTSXP:
+ return Rf_coerceVector( x, STRSXP );
+ case CHARSXP:
+ return Rf_ScalarString( x ) ;
+ case SYMSXP:
+ return Rf_ScalarString( PRINTNAME( x ) ) ;
+ default:
+ throw RObject::not_compatible( "not compatible with STRSXP" ) ;
+ }
+ return R_NilValue ; /* -Wall */
+}
+
+template<> SEXP r_true_cast<VECSXP>(SEXP x){
+ return convert_using_rfunction(x, "as.list" ) ;
+}
+
+template<> SEXP r_true_cast<EXPRSXP>(SEXP x){
+ return convert_using_rfunction(x, "as.expression" ) ;
+}
+
+template<> SEXP r_true_cast<LISTSXP>(SEXP x){
+ return convert_using_rfunction(x, "as.pairlist" ) ;
+}
+
+
+} // namespace internal
+} // namespace Rcpp
+
More information about the Rcpp-commits
mailing list