[Rcpp-commits] r1207 - in pkg/RcppGSL: inst inst/include inst/unitTests src

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Wed May 12 13:58:14 CEST 2010


Author: romain
Date: 2010-05-12 13:58:14 +0200 (Wed, 12 May 2010)
New Revision: 1207

Added:
   pkg/RcppGSL/inst/ChangeLog
Modified:
   pkg/RcppGSL/inst/include/RcppGSLForward.h
   pkg/RcppGSL/inst/include/RcppGSL_matrix.h
   pkg/RcppGSL/inst/include/RcppGSL_matrix_view.h
   pkg/RcppGSL/inst/include/RcppGSL_vector.h
   pkg/RcppGSL/inst/include/RcppGSL_vector_view.h
   pkg/RcppGSL/inst/unitTests/runTests.R
   pkg/RcppGSL/inst/unitTests/runit.gsl.R
   pkg/RcppGSL/src/RcppGSL.cpp
Log:
first pass at RcppGSL::vector and RcppGSL::vector_view

Added: pkg/RcppGSL/inst/ChangeLog
===================================================================
--- pkg/RcppGSL/inst/ChangeLog	                        (rev 0)
+++ pkg/RcppGSL/inst/ChangeLog	2010-05-12 11:58:14 UTC (rev 1207)
@@ -0,0 +1,7 @@
+2010-05-12  Romain Francois <romain at r-enthusiasts.com>
+
+	* inst/include/*.h: added classes RcppGSL::vector<T> that act as smart pointers
+	to gsl_vector_* objects. This gives nicer syntax and helps Rcpp implicit 
+	converters wrap and as.
+
+

Modified: pkg/RcppGSL/inst/include/RcppGSLForward.h
===================================================================
--- pkg/RcppGSL/inst/include/RcppGSLForward.h	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/inst/include/RcppGSLForward.h	2010-05-12 11:58:14 UTC (rev 1207)
@@ -24,9 +24,8 @@
 #include <gsl/gsl_vector.h> 
 #include <gsl/gsl_matrix.h>
 
-/* forward declarations */
 namespace Rcpp{
-	
+
 	namespace traits{
 		/* support for gsl_complex */
 		template<> struct r_sexptype_traits<gsl_complex>{ enum{ rtype = CPLXSXP } ; } ;
@@ -58,7 +57,79 @@
 		template<> gsl_complex_long_double caster<Rcomplex,gsl_complex_long_double>( Rcomplex from) ;
 		template<> Rcomplex caster<gsl_complex_long_double,Rcomplex>( gsl_complex_long_double from) ;
     }
-    
+
+}
+
+namespace RcppGSL{
+	template <typename T> class vector ;
+	template <typename T> class vector_view ;
+	
+#undef _RCPPGSL_SPEC
+#define _RCPPGSL_SPEC(__T__,__SUFFIX__,__CAST__)      	                        \
+template <> class vector<__T__>  {           	                                   \
+public:                                      	                                   \
+	typedef __T__ type ;                     	                                   \
+	typedef __T__* pointer ;                 	                                   \
+	typedef gsl_vector##__SUFFIX__ gsltype ; 	                                   \
+	gsltype* data ;                          	                                   \
+	const static int RTYPE = ::Rcpp::traits::r_sexptype_traits<type>::rtype ;    \
+	vector( SEXP x) throw(::Rcpp::not_compatible) : data(0), owner(true) {       \
+		SEXP y = ::Rcpp::r_cast<RTYPE>(x) ;                                      \
+		int size = ::Rf_length( y ) ;                                            \
+		data = gsl_vector##__SUFFIX__##_calloc( size ) ;                         \
+		::Rcpp::internal::export_range<__CAST__*>( y,                            \
+			reinterpret_cast<__CAST__*>( data->data ) ) ;                        \
+	}                                                                            \
+	vector( gsltype* x, bool owner_=true) : data(x), owner(owner_) {}            \
+	vector( int size , bool owner_ = true ) :                                    \
+		data( gsl_vector##__SUFFIX__##_calloc( size ) ), owner(owner_){}         \
+	~vector(){ if(owner) gsl_vector##__SUFFIX__##_free(data) ; }                 \
+	operator gsltype*(){ return data ; }                                         \
+	gsltype* operator->() const { return data; }                                 \
+	gsltype& operator*() const { return *data; }                                 \
+private:                                                                         \
+	bool owner ;                                                                 \
+	vector( const vector& x) ;                                                   \
+	vector& operator=(const vector& other) ;                                     \
+} ;                                                                              \
+template <> class vector_view<__T__>  {           	                            \
+public:                                      	                                   \
+	typedef __T__ type ;                     	                                   \
+	typedef __T__* pointer ;                 	                                   \
+	typedef gsl_vector##__SUFFIX__##_view gsltype ; 	                           \
+	gsltype* data ;                          	                                   \
+	vector_view( gsltype* x) : data(x) {}                                        \
+	~vector_view(){  }                                                           \
+	operator gsltype*(){ return data ; }                                         \
+} ;                                                                             \
+
+// FIXME: the private copy ctors and assignment operator are 
+//        here to prevent copying of the object. maybe we can think of 
+//        a better strategy
+
+_RCPPGSL_SPEC(double                   ,                       , double                  )
+_RCPPGSL_SPEC(float                    , _float                , float                   )
+_RCPPGSL_SPEC(int                      , _int                  , int                     )
+_RCPPGSL_SPEC(long                     , _long                 , long                    )
+_RCPPGSL_SPEC(long double              , _long_double          , long double             )
+_RCPPGSL_SPEC(short                    , _short                , short                   )
+_RCPPGSL_SPEC(unsigned char            , _uchar                , unsigned char           )
+_RCPPGSL_SPEC(unsigned int             , _uint                 , unsigned int            )
+_RCPPGSL_SPEC(unsigned short           , _ushort               , unsigned short          )
+_RCPPGSL_SPEC(unsigned long            , _ulong                , unsigned long           )
+_RCPPGSL_SPEC(char                     , _char                 , unsigned char           )
+_RCPPGSL_SPEC(gsl_complex              , _complex              , gsl_complex             )
+_RCPPGSL_SPEC(gsl_complex_float        , _complex_float        , gsl_complex_float       )
+_RCPPGSL_SPEC(gsl_complex_long_double  , _complex_long_double  , gsl_complex_long_double )
+
+#undef _RCPPGSL_SPEC
+ 
+}
+
+
+/* forward declarations */
+namespace Rcpp{
+
 	template <> SEXP wrap( const gsl_vector& ) ;
 	template <> SEXP wrap( const gsl_vector_int& ) ;
 	template <> SEXP wrap( const gsl_vector_float& ) ;
@@ -150,6 +221,9 @@
 	template <> SEXP wrap( const gsl_matrix_ushort_const_view& ) ;
 	template <> SEXP wrap( const gsl_matrix_ulong_const_view& ) ;
 
+	template <typename T> SEXP wrap( const ::RcppGSL::vector<T>& ) ;
+	template <typename T> SEXP wrap( const ::RcppGSL::vector_view<T>& ) ;
+	 
 }
 
 #endif

Modified: pkg/RcppGSL/inst/include/RcppGSL_matrix.h
===================================================================
--- pkg/RcppGSL/inst/include/RcppGSL_matrix.h	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/inst/include/RcppGSL_matrix.h	2010-05-12 11:58:14 UTC (rev 1207)
@@ -24,8 +24,6 @@
 #include <Rcpp.h>
 #include <RcppGSL_caster.h> 
 
-namespace Rcpp{                                                                                  
-
 namespace RcppGSL {
 	
 	template <typename T> class gslmatrix_importer{
@@ -50,6 +48,8 @@
 	} ;               
 }
 
+namespace Rcpp{                                                                                  
+
 #define RCPPGSL_WRAP(__TYPE__,__DATA__)                                  \
 template <> SEXP wrap( const __TYPE__& x){                               \
 	SEXP res = PROTECT( wrap( RcppGSL::gslmatrix_importer<__DATA__>(     \

Modified: pkg/RcppGSL/inst/include/RcppGSL_matrix_view.h
===================================================================
--- pkg/RcppGSL/inst/include/RcppGSL_matrix_view.h	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/inst/include/RcppGSL_matrix_view.h	2010-05-12 11:58:14 UTC (rev 1207)
@@ -28,26 +28,26 @@
 
 #define RCPPGSL_VIEW(SUFFIX)                                         \
 template <> SEXP wrap( const gsl_matrix##SUFFIX##_view& x){          \
-	return wrap(x.matrix) ;                                         \
-}  ;                                                                 \
+	return wrap(x.matrix) ;                                          \
+}                                                                    \
 template <> SEXP wrap( const gsl_matrix##SUFFIX##_const_view& x ){   \
-   return wrap(x.matrix) ;                                          \
+   return wrap(x.matrix) ;                                           \
 }
 
 RCPPGSL_VIEW()
-RCPPGSL_VIEW(_int) ;
-RCPPGSL_VIEW(_float) ;
-RCPPGSL_VIEW(_long) ;
-RCPPGSL_VIEW(_char) ;
-RCPPGSL_VIEW(_complex) ;
-RCPPGSL_VIEW(_complex_float) ;
-RCPPGSL_VIEW(_complex_long_double) ;
-RCPPGSL_VIEW(_long_double) ;
-RCPPGSL_VIEW(_short) ;
-RCPPGSL_VIEW(_uchar) ;
-RCPPGSL_VIEW(_uint) ;
-RCPPGSL_VIEW(_ushort) ;
-RCPPGSL_VIEW(_ulong) ;
+RCPPGSL_VIEW(_int)
+RCPPGSL_VIEW(_float)
+RCPPGSL_VIEW(_long)
+RCPPGSL_VIEW(_char)
+RCPPGSL_VIEW(_complex)
+RCPPGSL_VIEW(_complex_float)
+RCPPGSL_VIEW(_complex_long_double)
+RCPPGSL_VIEW(_long_double)
+RCPPGSL_VIEW(_short)
+RCPPGSL_VIEW(_uchar)
+RCPPGSL_VIEW(_uint)
+RCPPGSL_VIEW(_ushort)
+RCPPGSL_VIEW(_ulong)
 #undef RCPPGSL_VIEW
 
 } 

Modified: pkg/RcppGSL/inst/include/RcppGSL_vector.h
===================================================================
--- pkg/RcppGSL/inst/include/RcppGSL_vector.h	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/inst/include/RcppGSL_vector.h	2010-05-12 11:58:14 UTC (rev 1207)
@@ -24,8 +24,6 @@
 #include <Rcpp.h>
 #include <RcppGSL_caster.h> 
 
-namespace Rcpp{
-
 namespace RcppGSL{
     
 	template <typename T> class gslvector_importer{
@@ -47,17 +45,19 @@
 	
 }
 
+namespace Rcpp{
+
 #define RCPPGSL_WRAP(__TYPE__,__DATA__)                              \
 template <> SEXP wrap( const __TYPE__& x){                           \
 	return wrap( RcppGSL::gslvector_importer<__DATA__>(              \
 		x.data, x.stride, x.size ) ) ;                               \
-} ;
+} 
 
 #define RCPPGSL_WRAP_CAST(__TYPE__,__DATA__,__CAST__)                \
 template <> SEXP wrap( const __TYPE__& x){                           \
 	return wrap( RcppGSL::gslvector_importer<__DATA__>(              \
 		reinterpret_cast<__CAST__>(x.data), x.stride, x.size ) ) ;   \
-} ;
+} 
 
 RCPPGSL_WRAP(gsl_vector             , double)
 RCPPGSL_WRAP(gsl_vector_float       , float)
@@ -75,6 +75,10 @@
 RCPPGSL_WRAP_CAST(gsl_vector_complex_float      ,gsl_complex_float      ,gsl_complex_float*)
 RCPPGSL_WRAP_CAST(gsl_vector_complex_long_double,gsl_complex_long_double,gsl_complex_long_double*)
 
+template <typename T> SEXP wrap( const ::RcppGSL::vector<T>& x){
+	return wrap( *(x.data) ) ;
+}
+
 #undef RCPPGSL_WRAP_CAST
 #undef RCPPGSL_WRAP
 

Modified: pkg/RcppGSL/inst/include/RcppGSL_vector_view.h
===================================================================
--- pkg/RcppGSL/inst/include/RcppGSL_vector_view.h	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/inst/include/RcppGSL_vector_view.h	2010-05-12 11:58:14 UTC (rev 1207)
@@ -28,26 +28,26 @@
 
 #define RCPPGSL_VIEW(SUFFIX)                                         \
 template <> SEXP wrap( const gsl_vector##SUFFIX##_view& x){          \
-	return wrap(x.vector) ;                                         \
-}  ;                                                                 \
+	return wrap(x.vector) ;                                          \
+}                                                                    \
 template <> SEXP wrap( const gsl_vector##SUFFIX##_const_view& x ){   \
-   return wrap(x.vector) ;                                          \
+   return wrap(x.vector) ;                                           \
 }
 
 RCPPGSL_VIEW()
-RCPPGSL_VIEW(_int) ;
-RCPPGSL_VIEW(_float) ;
-RCPPGSL_VIEW(_long) ;
-RCPPGSL_VIEW(_char) ;
-RCPPGSL_VIEW(_complex) ;
-RCPPGSL_VIEW(_complex_float) ;
-RCPPGSL_VIEW(_complex_long_double) ;
-RCPPGSL_VIEW(_long_double) ;
-RCPPGSL_VIEW(_short) ;
-RCPPGSL_VIEW(_uchar) ;
-RCPPGSL_VIEW(_uint) ;
-RCPPGSL_VIEW(_ushort) ;
-RCPPGSL_VIEW(_ulong) ;
+RCPPGSL_VIEW(_int)
+RCPPGSL_VIEW(_float)
+RCPPGSL_VIEW(_long)
+RCPPGSL_VIEW(_char)
+RCPPGSL_VIEW(_complex)
+RCPPGSL_VIEW(_complex_float)
+RCPPGSL_VIEW(_complex_long_double)
+RCPPGSL_VIEW(_long_double)
+RCPPGSL_VIEW(_short)
+RCPPGSL_VIEW(_uchar)
+RCPPGSL_VIEW(_uint)
+RCPPGSL_VIEW(_ushort)
+RCPPGSL_VIEW(_ulong)
 #undef RCPPGSL_VIEW
 
 } 

Modified: pkg/RcppGSL/inst/unitTests/runTests.R
===================================================================
--- pkg/RcppGSL/inst/unitTests/runTests.R	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/inst/unitTests/runTests.R	2010-05-12 11:58:14 UTC (rev 1207)
@@ -82,7 +82,7 @@
             stop( sprintf( "unit test problems: %d failures, %d errors", err$nFail, err$nErr) )
         } else{
         	success <- err$nTestFunc - err$nFail - err$nErr - err$nDeactivated
-        	cat( sprintf( "%d / %d", success, err$nTestFunc ) )
+        	cat( sprintf( "%d / %d\n", success, err$nTestFunc ) )
         }
     }
 } else {

Modified: pkg/RcppGSL/inst/unitTests/runit.gsl.R
===================================================================
--- pkg/RcppGSL/inst/unitTests/runit.gsl.R	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/inst/unitTests/runit.gsl.R	2010-05-12 11:58:14 UTC (rev 1207)
@@ -17,6 +17,28 @@
 # You should have received a copy of the GNU General Public License
 # along with RcppGSL.  If not, see <http://www.gnu.org/licenses/>.
 
+test.gsl.vector.wrappers <- function(){
+	res <- .Call( "test_gsl_vector_wrapper", PACKAGE = "RcppGSL" )
+	checkEquals( res, 
+		list( 
+			"gsl_vector" = numeric(10), 
+			"gsl_vector_float" = numeric(10), 
+			"gsl_vector_int" = integer(10), 
+			"gsl_vector_long" = numeric(10), 
+			"gsl_vector_char" = raw(10), 
+			"gsl_vector_complex" = complex(10), 
+			"gsl_vector_complex_float" = complex(10), 
+			"gsl_vector_complex_long_double" = complex(10), 
+			"gsl_vector_long_double" = numeric(10), 
+			"gsl_vector_short" = integer(10), 
+			"gsl_vector_uchar" = raw(10), 
+			"gsl_vector_uint" = integer(10), 
+			"gsl_vector_ushort" = integer(10), 
+			"gsl_vector_ulong" = numeric(10)
+		), 
+		msg = "wrap( gsl_vector )" )
+}
+
 test.gsl.vector <- function(){
 	res <- .Call( "test_gsl_vector", PACKAGE = "RcppGSL" )
 	checkEquals( res, 
@@ -81,4 +103,10 @@
 	res <- .Call( "test_gsl_matrix_view", PACKAGE = "RcppGSL" )
 	checkEquals( res$full[3:4, 3:4], res$view, msg = "wrap(gsl.matrix.view)" )
 }
+      
+test.gsl.vector.input.SEXP <- function(){
+	x <- rnorm( 10 )
+	res <- .Call( "test_gsl_vector_input", x, PACKAGE = "RcppGSL" )
+	checkEquals( res, sum(x), msg = "RcppGSL::vector<double>(SEXP)" )
+}
 

Modified: pkg/RcppGSL/src/RcppGSL.cpp
===================================================================
--- pkg/RcppGSL/src/RcppGSL.cpp	2010-05-12 09:04:41 UTC (rev 1206)
+++ pkg/RcppGSL/src/RcppGSL.cpp	2010-05-12 11:58:14 UTC (rev 1207)
@@ -2,6 +2,41 @@
 
 using namespace Rcpp ;
 
+extern "C" SEXP test_gsl_vector_wrapper(){
+	RcppGSL::vector<double> x_double( 10 );
+	RcppGSL::vector<float> x_float( 10 );
+	RcppGSL::vector<int> x_int( 10 ) ; 
+	RcppGSL::vector<long> x_long( 10 ) ; 
+	RcppGSL::vector<char> x_char( 10 ) ; 
+	RcppGSL::vector<long double> x_long_double( 10 ) ;
+	RcppGSL::vector<short> x_short( 10 ) ; 
+	RcppGSL::vector<unsigned char> x_uchar( 10 ) ;
+	RcppGSL::vector<unsigned int> x_uint( 10 ) ; 
+	RcppGSL::vector<unsigned short> x_ushort( 10 ) ;
+	RcppGSL::vector<unsigned long> x_ulong( 10 ) ;
+	RcppGSL::vector<gsl_complex> x_complex( 10 ) ; 
+	RcppGSL::vector<gsl_complex_float> x_complex_float( 10 ) ;
+	RcppGSL::vector<gsl_complex_long_double> x_complex_long_double( 10 ) ;
+	
+	List res = List::create( 
+		_["gsl_vector"] = x_double, 
+		_["gsl_vector_float"] = x_float, 
+		_["gsl_vector_int"] = x_int, 
+		_["gsl_vector_long"] = x_long, 
+		_["gsl_vector_char"] = x_char, 
+		_["gsl_vector_complex"] = x_complex,
+		_["gsl_vector_complex_float"] = x_complex_float, 
+		_["gsl_vector_complex_long_double"] = x_complex_long_double, 
+		_["gsl_vector_long_double"] = x_long_double, 
+		_["gsl_vector_short"] = x_short, 
+		_["gsl_vector_uchar"] = x_uchar, 
+		_["gsl_vector_uint"] = x_uint,                             
+		_["gsl_vector_ushort"] = x_ushort, 
+		_["gsl_vector_ulong"] = x_ulong
+		) ;
+	return res ;
+}
+
 extern "C" SEXP test_gsl_vector(){
 	gsl_vector * x_double = gsl_vector_calloc (10);
 	gsl_vector_float * x_float = gsl_vector_float_calloc(10) ;
@@ -145,3 +180,13 @@
 	return res ;
 }
 
+RCPP_FUNCTION_1( double, test_gsl_vector_input, SEXP x){
+	RcppGSL::vector<double> vec(x) ;
+	int n = vec->size ;
+	double res = 0.0 ;
+	for( int i=0; i<n; i++){
+		res += gsl_vector_get( vec, i ) ;
+	}
+	return res ;
+}
+



More information about the Rcpp-commits mailing list