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

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Fri Mar 19 10:55:50 CET 2010


Author: romain
Date: 2010-03-19 10:55:50 +0100 (Fri, 19 Mar 2010)
New Revision: 915

Added:
   pkg/Rcpp/inst/unitTests/runit.Vector.create.R
Modified:
   pkg/Rcpp/src/Rcpp.h
   pkg/Rcpp/src/Rcpp/Named.h
   pkg/Rcpp/src/Rcpp/Vector.h
Log:
initial (pre code bloat) Vector<>::create

Added: pkg/Rcpp/inst/unitTests/runit.Vector.create.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.Vector.create.R	                        (rev 0)
+++ pkg/Rcpp/inst/unitTests/runit.Vector.create.R	2010-03-19 09:55:50 UTC (rev 915)
@@ -0,0 +1,63 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2010	Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
+
+.setUp <- function(){
+	suppressMessages( require( inline ) )
+}
+
+test.IntegerVector.create <- function(){
+	fx <- cfunction(signature(), '
+	List output(2); 
+	output[0] = IntegerVector::create( 10 ) ;
+	output[1] = IntegerVector::create( _["foo"] = 20 ) ;
+	return output ;
+	', 
+	Rcpp = TRUE, includes = "using namespace Rcpp;" )
+	
+	checkEquals( fx(), list( 10L, c(foo = 20L ) ), 
+		msg = "IntegerVector::create" )
+}
+
+test.List.create <- function(){
+	fx <- cfunction(signature(), '
+	List output(2); 
+	output[0] = List::create( 10 ) ;
+	output[1] = List::create( _["foo"] = "bar" ) ;
+	return output ;
+	', 
+	Rcpp = TRUE, includes = "using namespace Rcpp;" )
+	
+	checkEquals( fx(), list( list( 10L ), list(foo = "bar" ) ), 
+		msg = "List::create" )
+}
+
+test.CharacterVector.create <- function(){
+	fx <- cfunction(signature(), '
+	List output(2); 
+	output[0] = CharacterVector::create( "foo" ) ;
+	output[1] = CharacterVector::create( _["foo"] = "bar" ) ;
+	return output ;
+	', 
+	Rcpp = TRUE, includes = "using namespace Rcpp;" )
+	                          
+	checkEquals( fx(), list( "foo", c(foo = "bar" ) ), 
+		msg = "CharacterVector::create" )
+	
+}
+

Modified: pkg/Rcpp/src/Rcpp/Named.h
===================================================================
--- pkg/Rcpp/src/Rcpp/Named.h	2010-03-18 14:51:56 UTC (rev 914)
+++ pkg/Rcpp/src/Rcpp/Named.h	2010-03-19 09:55:50 UTC (rev 915)
@@ -72,14 +72,39 @@
 	std::string tag ;
 } ;
 
+namespace traits {
+
+template <typename T> class named_object {
+	public:
+		named_object( const std::string& name_, const T& o_) : 
+			name(name_), object(o_){} 
+		const std::string& name ;
+		const T& object ;
+		operator ::Rcpp::Named(){
+			return ::Rcpp::Named(name, object) ;	
+		}
+} ;
+
+template <typename T>
+named_object<T> named( const std::string& name, const T& o){
+	return named_object<T>( name, o );	
+} ;
+
+template <typename T> struct is_named : public false_type{} ;
+template <typename T> struct is_named< named_object<T> >   : public true_type {} ;
+
+
+} // namespace traits
+
+
 class Argument {
 public:
 	Argument() : name(){} ;
 	Argument( const std::string& name_) : name(name_){} 
 	
 	template<typename T>
-	Named operator=( const T& t){
-		return Named( name, t ) ;	
+	traits::named_object<T> operator=( const T& t){
+		return traits::named_object<T>( name, t ) ;	
 	}
 	
 private:
@@ -88,16 +113,16 @@
 
 
 namespace internal{
-	
+
 class NamedPlaceHolder {
 public:
 	NamedPlaceHolder(){}
 	~NamedPlaceHolder(){}
-	Named operator[]( const std::string& arg) const {
-		return Named( arg ) ;
+	Argument operator[]( const std::string& arg) const {
+		return Argument( arg ) ;
 	}
-	Named operator()(const std::string& arg) const {
-		return Named( arg ) ;
+	Argument operator()(const std::string& arg) const {
+		return Argument( arg ) ;
 	}
 	operator SEXP() const { return R_MissingArg ; }
 } ;

Modified: pkg/Rcpp/src/Rcpp/Vector.h
===================================================================
--- pkg/Rcpp/src/Rcpp/Vector.h	2010-03-18 14:51:56 UTC (rev 914)
+++ pkg/Rcpp/src/Rcpp/Vector.h	2010-03-19 09:55:50 UTC (rev 915)
@@ -216,7 +216,8 @@
 	template <int RTYPE>
 	class string_element_converter {
 	public:
-		// typedef typename ::Rcpp::traits::storage_typ
+		typedef SEXP target ;
+		
 		string_element_converter(){};
 		
 		template <typename T>
@@ -228,11 +229,16 @@
 		SEXP get(const std::string& input){
 			return Rf_mkChar( input.c_str() ) ;
 		}
+		
+		SEXP get(const char& input){
+			return Rf_mkChar( &input ) ;
+		}
 	} ;
 	
 	template <int RTYPE>
 	class generic_element_converter {
 	public:
+		typedef SEXP target ;
 		generic_element_converter(){};
 		
 		template <typename T>
@@ -681,8 +687,60 @@
 		cache.update(*this) ;
 	}
 	
+	template <typename T1>
+	static SEXP create( const T1& t1){
+		return create__dispatch( typename traits::integral_constant< bool, traits::is_named<T1>::value >::type(), t1 ) ;  		
+	}
+	
 private:
 	
+	template <typename T1>
+	static SEXP create__dispatch( traits::false_type, const T1& t1 ){
+		Vector res(1) ;
+		iterator it( res.begin() );
+		
+		////
+		*it = converter.get(t1) ; ++it ;
+		//// 
+		
+		return res ;
+	}
+	
+	template <typename T1>
+	static SEXP create__dispatch( traits::true_type, const T1& t1){
+		Vector res(1) ;                                                                      
+		SEXP names = PROTECT( ::Rf_allocVector( STRSXP, 1 ) ) ;
+		int index = 0 ;
+		iterator it( res.begin() );
+		
+		////
+		replace_element( it, names, index, t1 ) ; ++it; ++index ;
+		////
+		
+		res.attr("names") = names ;
+		UNPROTECT(1); // names
+		return res ;
+	}
+	
+	template <typename U>
+	static void replace_element( iterator it, SEXP names, int index, const U& u){
+		replace_element__dispatch( typename traits::is_named<U>::type(), 
+			it, names, index, u ) ;
+	}
+	
+	template <typename U>
+	static void replace_element__dispatch( traits::false_type, iterator it, SEXP names, int index, const U& u){
+		typedef typename converter_type::target target_type ;
+		target_type value = converter.get(u); *it = value ;
+	}
+	
+	template <typename U>
+	static void replace_element__dispatch( traits::true_type, iterator it, SEXP names, int index, const U& u){
+		*it = converter.get(u.object ) ;
+		SET_STRING_ELT( names, index, ::Rf_mkChar( u.name.c_str() ) ) ;
+	}
+	
+	
 	void set_sexp(SEXP x){
 		Base::setSEXP( x) ;
 		update_vector() ;
@@ -1203,6 +1261,17 @@
 			return *this ;
 		}
 		
+		string_proxy& operator=(const char& rhs){
+			set( Rf_mkChar( &rhs ) ) ;
+			return *this ;	
+		}
+		
+		string_proxy& operator=(SEXP rhs){
+			// TODO: check this is a CHARSXP
+			set( rhs ) ;
+			return *this ;
+		}
+		
 		/**
 		 * lhs use. Adds the content of the rhs proxy to the 
 		 * element this proxy refers to.

Modified: pkg/Rcpp/src/Rcpp.h
===================================================================
--- pkg/Rcpp/src/Rcpp.h	2010-03-18 14:51:56 UTC (rev 914)
+++ pkg/Rcpp/src/Rcpp.h	2010-03-19 09:55:50 UTC (rev 915)
@@ -48,6 +48,7 @@
 /* new api */
 
 #include <Rcpp/RObject.h>
+#include <Rcpp/Named.h>
 
 #include <Rcpp/S4.h>
 #include <Rcpp/exceptions.h>
@@ -60,7 +61,6 @@
 #include <Rcpp/XPtr.h>
 #include <Rcpp/Symbol.h>
 #include <Rcpp/Language.h>
-#include <Rcpp/Named.h>
 #include <Rcpp/make_list.h>
 #include <Rcpp/DottedPair.h>
 #include <Rcpp/Pairlist.h>



More information about the Rcpp-commits mailing list