[Rcpp-commits] r825 - in pkg/RcppArmadillo/inst: . include unitTests

[noreply at r-forge.r-project.org]

Author: romain
Date: 2010-03-03 10:36:43 +0100 (Wed, 03 Mar 2010)
New Revision: 825

Modified:
   pkg/RcppArmadillo/inst/ChangeLog
   pkg/RcppArmadillo/inst/include/RcppArmadillo.h
   pkg/RcppArmadillo/inst/unitTests/runit.RcppArmadillo.R
Log:
avoid an extra copy when possible (eGlue and eOp)

Modified: pkg/RcppArmadillo/inst/ChangeLog
===================================================================
--- pkg/RcppArmadillo/inst/ChangeLog	2010-03-02 23:18:59 UTC (rev 824)
+++ pkg/RcppArmadillo/inst/ChangeLog	2010-03-03 09:36:43 UTC (rev 825)
@@ -1,3 +1,9 @@
+2010-03-03  Romain Francois <romain at r-enthusiasts.com>
+
+	* inst/include/RcppArmadillo.h: avoid an extra memory copy when 
+	possible (i.e. in wrap( eGlue) and wrap( eOp ) when the elem_type
+	is int or double).
+	
 2010-03-02  Dirk Eddelbuettel  <edd at dexter>
 
 	* src/RcppArmadillo.cpp: Added bare-bones 'fastLm' function

Modified: pkg/RcppArmadillo/inst/include/RcppArmadillo.h
===================================================================
--- pkg/RcppArmadillo/inst/include/RcppArmadillo.h	2010-03-02 23:18:59 UTC (rev 824)
+++ pkg/RcppArmadillo/inst/include/RcppArmadillo.h	2010-03-03 09:36:43 UTC (rev 825)
@@ -144,14 +144,52 @@
     
     /* TODO: will do better when I can use 0.9.0 */
     #if ARMA_VERSION_GE_090
+    namespace RcppArmadillo{
+    	
+    	/* we can intercept and directly build the resulting matrix using 
+    	   memory allocated by R */
+    	template <typename T1, typename T2, typename eglue_type>
+    	SEXP wrap_eglue( const arma::eGlue<T1, T2, eglue_type>& X, ::Rcpp::traits::false_type ){
+    		int n_rows = X.P1.n_rows ;
+    		int n_cols = X.P1.n_cols ;
+    		typedef typename ::Rcpp::Vector< ::Rcpp::traits::r_sexptype_traits< typename T1::elem_type>::rtype > VECTOR ;
+    		VECTOR res(::Rcpp::Dimension( n_rows , n_cols )) ;
+    		::arma::Mat<typename T1::elem_type> result( res.begin(), n_rows, n_cols, false ) ;
+    		result = X ;
+    		return res ;
+    	}
+    	
+    	template <typename T1, typename T2, typename eglue_type>
+    	SEXP wrap_eglue( const arma::eGlue<T1, T2, eglue_type>& X, ::Rcpp::traits::true_type ){
+    		return ::Rcpp::wrap( arma::Mat<typename T1::elem_type>(X) ) ;
+    	}
+    	
+    	template <typename T1, typename eop_type>
+    	SEXP wrap_eop( const arma::eOp<T1,eop_type>& X, ::Rcpp::traits::false_type ){
+    		int n_rows = X.P.n_rows ;
+    		int n_cols = X.P.n_cols ;
+    		typedef typename ::Rcpp::Vector< ::Rcpp::traits::r_sexptype_traits< typename T1::elem_type>::rtype > VECTOR ;
+    		VECTOR res(::Rcpp::Dimension( n_rows , n_cols )) ;
+    		::arma::Mat<typename T1::elem_type> result( res.begin(), n_rows, n_cols, false ) ;
+    		result = X ;
+    		return res ;
+    	}
+    	
+    	template <typename T1, typename eop_type>
+    	SEXP wrap_eop( const arma::eOp<T1,eop_type>& X, ::Rcpp::traits::true_type ){
+    		return ::Rcpp::wrap( arma::Mat<typename T1::elem_type>(X) ) ;
+    	}
+    	
+    } // namespace RcppArmadillo
+    
     template <typename T1, typename T2, typename glue_type>
     SEXP wrap(const arma::eGlue<T1, T2, glue_type>& X ){
-    	    return wrap( arma::Mat<typename T1::elem_type>(X) ) ;
+    	return RcppArmadillo::wrap_eglue( X, typename traits::r_sexptype_needscast<typename T1::elem_type>::type() ) ;
     }
 
     template <typename T1, typename op_type>
     SEXP wrap(const arma::eOp<T1, op_type>& X ){
-    	    return wrap( arma::Mat<typename T1::elem_type>(X) ) ;
+    	    return RcppArmadillo::wrap_eop( X, typename traits::r_sexptype_needscast<typename T1::elem_type>::type() ) ;
     }
     #endif
 

Modified: pkg/RcppArmadillo/inst/unitTests/runit.RcppArmadillo.R
===================================================================
--- pkg/RcppArmadillo/inst/unitTests/runit.RcppArmadillo.R	2010-03-02 23:18:59 UTC (rev 824)
+++ pkg/RcppArmadillo/inst/unitTests/runit.RcppArmadillo.R	2010-03-03 09:36:43 UTC (rev 825)
@@ -73,7 +73,7 @@
     data(trees)
     flm <- .Call("fastLm",
                  log(trees$Volume),
-                 cbind(rep(1,31), log(treesGirth)),
+                 cbind(rep(1,31), log(trees$Girth)),
                  PACKAGE="RcppArmadillo")
     fit <- lm(log(Volume) ~ log(Girth), data=trees)