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

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

Author: romain
Date: 2010-01-08 16:34:21 +0100 (Fri, 08 Jan 2010)
New Revision: 317

Modified:
   pkg/inst/ChangeLog
   pkg/inst/unitTests/runit.Pairlist.R
   pkg/src/RObject.cpp
   pkg/src/Rcpp/Language.h
   pkg/src/Rcpp/Pairlist.h
   pkg/src/Rcpp/RObject.h
   pkg/src/exceptions.cpp
Log:
{Language,Pairlist}::insert

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2010-01-08 13:32:56 UTC (rev 316)
+++ pkg/inst/ChangeLog	2010-01-08 15:34:21 UTC (rev 317)
@@ -1,6 +1,7 @@
 2010-01-08  Romain Francois <francoisromain at free.fr>
 
-	* src/Rcpp/Pairlist.h: Pairlist gains a push_back method
+	* src/Rcpp/Pairlist.h: Pairlist gains a push_back 
+	and insert methods
 
 	* src/Rcpp/Language.h: idem for Language
 

Modified: pkg/inst/unitTests/runit.Pairlist.R
===================================================================
--- pkg/inst/unitTests/runit.Pairlist.R	2010-01-08 13:32:56 UTC (rev 316)
+++ pkg/inst/unitTests/runit.Pairlist.R	2010-01-08 15:34:21 UTC (rev 317)
@@ -80,3 +80,28 @@
 		msg = "Pairlist::push_back" )
 }
 
+test.Pairlist.insert <- function(){
+	funx <- cfunction(signature(), '
+	Pairlist p ;
+	p.push_back( 1 ) ;
+	p.push_back( 10.0 ) ;
+	p.push_back( 20.0 ) ;
+	
+	/* insert in 2nd position */
+	p.insert( 1, Named( "bla", "bla" ) ) ;
+	
+	/* insert in front */
+	p.insert( 0, 30.0 ) ;
+	
+	/* insert in back */
+	p.insert( 5, "foobar" ) ;
+	
+	return p ;
+	', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+	checkEquals( funx(), 
+		pairlist( 30.0, 1L, bla = "bla", 10.0, 20.0, "foobar" ), 
+		msg = "Pairlist::replace" )
+}
+
+
+

Modified: pkg/src/RObject.cpp
===================================================================
--- pkg/src/RObject.cpp	2010-01-08 13:32:56 UTC (rev 316)
+++ pkg/src/RObject.cpp	2010-01-08 15:34:21 UTC (rev 317)
@@ -122,6 +122,10 @@
 const char* RObject::not_s4::what( ) const throw() {
 	return "not an S4 object" ;
 }
+const char* RObject::index_out_of_bounds::what( ) const throw() {
+	return "array or list out of bounds" ;
+}
 
+
 } // namespace Rcpp
 

Modified: pkg/src/Rcpp/Language.h
===================================================================
--- pkg/src/Rcpp/Language.h	2010-01-08 13:32:56 UTC (rev 316)
+++ pkg/src/Rcpp/Language.h	2010-01-08 15:34:21 UTC (rev 317)
@@ -115,6 +115,43 @@
 	}
 
 	/**
+	 * wraps an object and add it in front of the pairlist
+	 *
+	 * @param object anything that can be wrapped by one 
+	 * of the wrap functions, or an object of class Named
+	 */
+	template <typename T>
+	void push_front( const T& object){
+		setSEXP( grow(object, m_sexp) ) ;
+		SET_TAG(m_sexp, R_NilValue);
+		SET_TYPEOF(m_sexp, LANGSXP);
+	}
+
+
+	template <typename T>
+	void insert( const int& index, const T& object) throw(index_out_of_bounds) {
+		if( index == 0 ) {
+			push_front( object ) ;
+		} else{
+			if( index <  0 ) throw index_out_of_bounds() ;
+			if( isNULL( ) ) throw index_out_of_bounds() ;
+			
+			if( index < 0 || index > Rf_length(m_sexp) ) throw index_out_of_bounds() ;
+			
+			int i=1;
+			SEXP x = m_sexp ;
+			while( i < index ){
+				x = CDR(x) ;
+				i++; 
+			}
+			SEXP tail = PROTECT( grow( object, CDR(x) ) ) ; 
+			SETCDR( x, tail ) ;
+			UNPROTECT(1) ;
+		}
+	}
+	
+	
+	/**
 	 * sets the symbol of the call
 	 */
 	void setSymbol( const std::string& symbol);

Modified: pkg/src/Rcpp/Pairlist.h
===================================================================
--- pkg/src/Rcpp/Pairlist.h	2010-01-08 13:32:56 UTC (rev 316)
+++ pkg/src/Rcpp/Pairlist.h	2010-01-08 15:34:21 UTC (rev 317)
@@ -98,6 +98,29 @@
 			UNPROTECT(1) ;
 		}
 	}
+	
+	template <typename T>
+	void insert( const int& index, const T& object) throw(index_out_of_bounds) {
+		if( index == 0 ) {
+			push_front( object ) ;
+		} else{
+			if( index <  0 ) throw index_out_of_bounds() ;
+			if( isNULL( ) ) throw index_out_of_bounds() ;
+			
+			if( index < 0 || index > Rf_length(m_sexp) ) throw index_out_of_bounds() ;
+			
+			int i=1;
+			SEXP x = m_sexp ;
+			while( i < index ){
+				x = CDR(x) ;
+				i++; 
+			}
+			SEXP tail = PROTECT( grow( object, CDR(x) ) ) ; 
+			SETCDR( x, tail ) ;
+			UNPROTECT(1) ;
+		}
+	}
+	
 
 };
 

Modified: pkg/src/Rcpp/RObject.h
===================================================================
--- pkg/src/Rcpp/RObject.h	2010-01-08 13:32:56 UTC (rev 316)
+++ pkg/src/Rcpp/RObject.h	2010-01-08 15:34:21 UTC (rev 317)
@@ -51,7 +51,14 @@
    			~not_s4() throw(){} ;
    			const char* what() const throw() ; 
    	} ;
-
+   	
+   	class index_out_of_bounds: public std::exception{
+   	public:
+   		index_out_of_bounds() throw(){};
+   		~index_out_of_bounds() throw(){};
+   		const char* what() const throw() ;
+   	} ;
+   	
    /**
      * default constructor. uses R_NilValue
      */ 

Modified: pkg/src/exceptions.cpp
===================================================================
--- pkg/src/exceptions.cpp	2010-01-08 13:32:56 UTC (rev 316)
+++ pkg/src/exceptions.cpp	2010-01-08 15:34:21 UTC (rev 317)
@@ -2,7 +2,7 @@
 //
 // exceptions.cpp: R/C++ interface class library -- exception handling
 //
-// Copyright (C) 2009 - 2010 Romain Francois
+// Copyright (C) 2009 - 2010 Dirk Eddelbuettel and Romain Francois
 //
 // This file is part of Rcpp.
 //

_______________________________________________
Rcpp-commits mailing list
Rcpp-commits at lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-commits