[Rcpp-commits] r655 - in pkg: inst inst/unitTests src/Rcpp

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

Author: romain
Date: 2010-02-10 11:36:52 +0100 (Wed, 10 Feb 2010)
New Revision: 655

Modified:
   pkg/inst/ChangeLog
   pkg/inst/unitTests/runit.GenericVector.R
   pkg/src/Rcpp/SEXP_Vector.h
Log:
+ SEXP_Vector.push_{back,front}

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2010-02-10 09:03:46 UTC (rev 654)
+++ pkg/inst/ChangeLog	2010-02-10 10:36:52 UTC (rev 655)
@@ -1,5 +1,12 @@
 2010-02-10  Romain Francois <romain at r-enthusiasts.com>
 
+	* src/Rcpp/SEXP_Vector.h: SEXP_Vector (and therefore 
+	ExpressionVector and GenericVector, a.k.a List) gain 
+	methods push_front and push_back that are templated and 
+	use the implicit wrap idiom to add an element to the front
+	or to the back of the list, pushing other elements. Internally
+	the SEXP is actually copied.
+
 	* src/Rcpp/VectorBase.h: VectorBase gains a version of 
 	offset to support retrieving the offset of a given name of a
 	vector: offset( const std::string& name)

Modified: pkg/inst/unitTests/runit.GenericVector.R
===================================================================
--- pkg/inst/unitTests/runit.GenericVector.R	2010-02-10 09:03:46 UTC (rev 654)
+++ pkg/inst/unitTests/runit.GenericVector.R	2010-02-10 10:36:52 UTC (rev 655)
@@ -153,3 +153,36 @@
 	checkEquals( funx( d ), sum(1:10), msg = "List names based indexing" )
 }
 
+test.List.push.back <- function(){
+	
+	funx <- cfunction( signature(x = "list"), 
+	'
+	List list(x) ;
+	list.push_back( 10 ) ;
+	list.push_back( Named( "foo", "bar" ) ) ;
+	return list ;
+	', Rcpp = TRUE, includes = "using namespace Rcpp;" )
+	d <- list( x = 1:10, y = letters[1:10] )
+	res <- funx( d )
+	checkEquals( res,
+		list( x = 1:10, y = letters[1:10], 10L, foo = "bar" ), 
+		msg = "List.push_back" )
+}
+
+test.List.push.front <- function(){
+	
+	funx <- cfunction( signature(x = "list"), 
+	'
+	List list(x) ;
+	list.push_front( 10 ) ;
+	list.push_front( Named( "foo", "bar" ) ) ;
+	return list ;
+	', Rcpp = TRUE, includes = "using namespace Rcpp;" )
+	d <- list( x = 1:10, y = letters[1:10] )
+	res <- funx( d )
+	checkEquals( res,
+		list( foo = "bar", 10L, x = 1:10, y = letters[1:10] ), 
+		msg = "List.push_front" )
+}
+
+

Modified: pkg/src/Rcpp/SEXP_Vector.h
===================================================================
--- pkg/src/Rcpp/SEXP_Vector.h	2010-02-10 09:03:46 UTC (rev 654)
+++ pkg/src/Rcpp/SEXP_Vector.h	2010-02-10 10:36:52 UTC (rev 655)
@@ -168,8 +168,92 @@
 	void assign( InputIterator first, InputIterator last){
 		setSEXP( r_cast<RTYPE>( wrap( first, last) ) ) ;
 	}
+	
+	template <typename WRAPPABLE>
+	void push_back( const WRAPPABLE& t){
+		push_back_sexp( wrap(t), "" ) ;
+	}
+	void push_back( const Named& t){
+		push_back_sexp( t.getSEXP() , t.getTag() ) ;
+	}
 
+	template <typename WRAPPABLE>
+	void push_front( const WRAPPABLE& t){
+		push_front_sexp( wrap(t), false, "" ) ;
+	}
+	void push_front( const Named& t){
+		push_front_sexp( t.getSEXP() , true, t.getTag() ) ;
+	}
+
+private:
 	
+	void push_back_sexp( SEXP t, bool named, const std::string& name ){
+		if( isNULL() ){ 
+			set_single( t, named, name );
+		} else {
+			/* not sure we can avoid the copy. R does the same
+			   with lengthgets at builtin.c */
+			R_len_t n = size() ;
+			SEXP x = PROTECT( Rf_allocVector( RTYPE, n+1 ) ) ;
+			R_len_t i=0 ;
+			for( ; i<n; i++){
+				SET_VECTOR_ELT( x, i, VECTOR_ELT(m_sexp, i ) ) ;
+			}
+			SET_VECTOR_ELT( x, i, t ) ;
+			SEXP names = RCPP_GET_NAMES( m_sexp ) ;
+			if( names != R_NilValue ){
+				SEXP x_names = PROTECT( Rf_allocVector( STRSXP, n+1) );
+				for( i=0; i<n; i++){
+					SET_STRING_ELT( x_names, i, STRING_ELT(names, i ) ) ;
+				}
+				SET_STRING_ELT(x_names, i, Rf_mkChar(name.c_str()) ) ;
+				Rf_setAttrib( x, Rf_install("names"), x_names );
+				UNPROTECT(1) ; /* x_names */
+			}
+			setSEXP( x ); 
+			UNPROTECT(1) ; /* x */
+		}
+	}
+	
+	void push_front_sexp( SEXP t, bool named, const std::string& name ){
+		if( isNULL() ){ 
+			set_single( t, named, name );
+		} else {
+			/* not sure we can avoid the copy. R does the same
+			   with lengthgets at builtin.c */
+			R_len_t n = size() ;
+			SEXP x = PROTECT( Rf_allocVector( RTYPE, n+1 ) ) ;
+			R_len_t i=0 ;
+			SET_VECTOR_ELT( x, 0, t ) ;
+			for(i=0 ; i<n; i++){
+				SET_VECTOR_ELT( x, i+1, VECTOR_ELT(m_sexp, i ) ) ;
+			}
+			SEXP names = RCPP_GET_NAMES( m_sexp ) ;
+			if( names != R_NilValue ){
+				SEXP x_names = PROTECT( Rf_allocVector( STRSXP, n+1) );
+				for( i=0; i<n; i++){
+					SET_STRING_ELT( x_names, i+1, STRING_ELT(names, i ) ) ;
+				}
+				SET_STRING_ELT(x_names, 0, Rf_mkChar(name.c_str()) ) ;
+				Rf_setAttrib( x, Rf_install("names"), x_names );
+				UNPROTECT(1) ; /* x_names */
+			}
+			setSEXP( x ); 
+			UNPROTECT(1) ; /* x */
+		}
+	}
+
+	void set_single( SEXP t, bool named, const std::string& name ){
+		SEXP x = PROTECT( Rf_allocVector( RTYPE, 1) );
+		SET_VECTOR_ELT( x, 0, t ) ;
+		if( named ){
+			SEXP names = PROTECT( Rf_mkString( name.c_str() ) ) ;
+			Rf_setAttrib( x, Rf_install("names"), names) ;
+			UNPROTECT(1) ; /* names */
+		}
+		setSEXP( x ) ;
+		UNPROTECT(1) ;
+	}
 }   ;
 
 typedef SEXP_Vector<VECSXP> GenericVector ;