[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