[Rcpp-commits] r659 - in pkg: inst inst/unitTests src/Rcpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Feb 10 13:00:26 CET 2010
Author: romain
Date: 2010-02-10 13:00:26 +0100 (Wed, 10 Feb 2010)
New Revision: 659
Modified:
pkg/inst/ChangeLog
pkg/inst/unitTests/runit.GenericVector.R
pkg/src/Rcpp/SEXP_Vector.h
Log:
+ SEXP_Vector::erase modelled after std::vector<>::erase
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2010-02-10 11:35:48 UTC (rev 658)
+++ pkg/inst/ChangeLog 2010-02-10 12:00:26 UTC (rev 659)
@@ -3,10 +3,17 @@
* src/Rcpp/SEXP_Vector.h: SEXP_Vector (and therefore
ExpressionVector and GenericVector, a.k.a List) gain
methods push_front, push_back and insert that are templated and
- use the implicit wrap idiom to add an element to the front
+ use the 'implicit wrap idiom' to add an element to the front
or, the back or an arbitrary (valid) position of the list,
pushing other elements. Internally the SEXP is actually copied.
+ * src/Rcpp/SEXP_Vector.h: SEXP_Vector gains an erase method
+ modelled after std::vector<>::erase to remove elements from
+ a list. erase has a single iterator (or int) form that removes
+ one element, and a range based version
+ erase(iterator first, iterator last) that erases all elements
+ between first and last.
+
* 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 11:35:48 UTC (rev 658)
+++ pkg/inst/unitTests/runit.GenericVector.R 2010-02-10 12:00:26 UTC (rev 659)
@@ -201,3 +201,36 @@
msg = "List.insert" )
}
+test.List.erase <- function(){
+
+ funx <- cfunction( signature(x = "list"),
+ '
+ List list(x) ;
+ list.erase( list.begin() ) ;
+ return list ;
+ ', Rcpp = TRUE, includes = "using namespace Rcpp;" )
+ d <- list( x = 1:10, y = letters[1:10] )
+ res <- funx( d )
+ checkEquals( res,
+ list( y = letters[1:10] ),
+ msg = "List.erase" )
+}
+
+test.List.erase.range <- function(){
+
+ funx <- cfunction( signature(x = "list"),
+ '
+ List list(x) ;
+ list.erase( 0, 1 ) ;
+ return list ;
+ ', Rcpp = TRUE, includes = "using namespace Rcpp;" )
+ d <- list( x = 1:10, y = letters[1:10], z = 1:10 )
+ res <- funx( d )
+ checkEquals( res,
+ list( z = 1:10 ),
+ msg = "List.erase (range version)" )
+}
+
+
+
+
Modified: pkg/src/Rcpp/SEXP_Vector.h
===================================================================
--- pkg/src/Rcpp/SEXP_Vector.h 2010-02-10 11:35:48 UTC (rev 658)
+++ pkg/src/Rcpp/SEXP_Vector.h 2010-02-10 12:00:26 UTC (rev 659)
@@ -207,6 +207,25 @@
return insert_sexp( iterator(*this,index), object.getSEXP() , true, object.getTag() ) ;
}
+ iterator erase( iterator position ){
+ erase_single( position.index() ) ;
+ return position ;
+ }
+ iterator erase( int index ){
+ erase_single(index) ;
+ return iterator(*this,index) ;
+ }
+
+ iterator erase( iterator first, iterator last){
+ erase_range(first.index(), last.index() ) ;
+ return first ;
+ }
+
+ iterator erase( int first, int last){
+ erase_range(first, last ) ;
+ return iterator( *this, first ) ;
+ }
+
private:
/*
@@ -233,7 +252,68 @@
push_middle_sexp( 0, t, named, name ) ;
}
}
+
+ void erase_single( int index ){
+ if( index >= size() || index < 0 ) throw RObject::index_out_of_bounds() ;
+
+ R_len_t n = size() ;
+ SEXP x = PROTECT( Rf_allocVector( RTYPE, n-1 ) ) ;
+ R_len_t i=0 ;
+ for( ; i<index; i++){
+ SET_VECTOR_ELT( x, i, VECTOR_ELT(m_sexp, i ) ) ;
+ }
+ i++; /* skip the one we don't want */
+ for( ; 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<index; i++){
+ SET_STRING_ELT( x_names, i, STRING_ELT(names, i ) ) ;
+ }
+ i++ ; /* skip */
+ for( ; i<n; i++){
+ SET_STRING_ELT( x_names, i-1, STRING_ELT(names, i ) ) ;
+ }
+ Rf_setAttrib( x, Rf_install("names"), x_names );
+ UNPROTECT(1) ; /* x_names */
+ }
+ setSEXP( x );
+ UNPROTECT(1) ; /* x */
+ }
+
+ void erase_range( int first, int last ){
+ if( first > last ) throw std::range_error("invalid range") ;
+ if( last >= size() || first < 0 ) throw RObject::index_out_of_bounds() ;
+
+ int range_size = last - first + 1 ;
+ R_len_t n = size() ;
+ SEXP x = PROTECT( Rf_allocVector( RTYPE, n - range_size ) ) ;
+ R_len_t i=0 ;
+ for( ; i<first; i++){
+ SET_VECTOR_ELT( x, i, VECTOR_ELT(m_sexp, i ) ) ;
+ }
+ for( i=last+1; i<n; i++){
+ SET_VECTOR_ELT( x, i-range_size, VECTOR_ELT(m_sexp, i ) ) ;
+ }
+ SEXP names = RCPP_GET_NAMES( m_sexp ) ;
+ if( names != R_NilValue ){
+ SEXP x_names = PROTECT( Rf_allocVector( STRSXP, n-range_size) );
+ for( i=0; i<first; i++){
+ SET_STRING_ELT( x_names, i, STRING_ELT(names, i ) ) ;
+ }
+ for( i=last+1; i<n; i++){
+ SET_STRING_ELT( x_names, i-range_size, STRING_ELT(names, i ) ) ;
+ }
+ Rf_setAttrib( x, Rf_install("names"), x_names );
+ UNPROTECT(1) ; /* x_names */
+ }
+ setSEXP( x );
+ UNPROTECT(1) ; /* x */
+ }
+
void push_middle_sexp( int index, SEXP t, bool named, const std::string& name ){
if( index > size() || index < 0 ) throw RObject::index_out_of_bounds() ;
PROTECT(t) ; /* just in case */
More information about the Rcpp-commits
mailing list