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

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Mon Jan 4 23:51:54 CET 2010


Author: romain
Date: 2010-01-04 23:51:53 +0100 (Mon, 04 Jan 2010)
New Revision: 275

Added:
   pkg/inst/unitTests/runit.Function.R
   pkg/src/Function.cpp
   pkg/src/Rcpp/Function.h
Modified:
   pkg/inst/ChangeLog
   pkg/inst/unitTests/runit.Pairlist.R
   pkg/src/Pairlist.cpp
   pkg/src/Rcpp.h
Log:
new class Rcpp::Function

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2010-01-04 22:05:43 UTC (rev 274)
+++ pkg/inst/ChangeLog	2010-01-04 22:51:53 UTC (rev 275)
@@ -1,5 +1,15 @@
 2010-01-04  Romain Francois <francoisromain at free.fr>
 
+	* src/Rcpp/Function.h: new class Rcpp::Function to manage functions
+	(closures, primitives and builtins) all share the Function class
+	(at least for now). This is implemented as a functor taking 
+	variable number of arguments, so it looks pretty similar to the 
+	R function
+	
+	* src/Function.cpp: implementation
+	
+	* inst/unitTests/runit.Function.R: unit tests
+
 	* src/Rcpp/Pairlist.h: new class Rcpp::Pairlist to manage dotted
 	pair lists (LISTSXP). unsurprisingly this shares a lot of
 	similarities with Language class

Added: pkg/inst/unitTests/runit.Function.R
===================================================================
--- pkg/inst/unitTests/runit.Function.R	                        (rev 0)
+++ pkg/inst/unitTests/runit.Function.R	2010-01-04 22:51:53 UTC (rev 275)
@@ -0,0 +1,49 @@
+#!/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 ) )
+	suppressMessages( require( stats ) )
+}
+
+test.Function <- function(){
+	funx <- cfunction(signature(x="ANY"), 'return Function(x) ;', 
+		Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+	checkEquals( funx( rnorm ), rnorm, msg = "Function( CLOSXP )" )
+	checkEquals( funx( is.function ), is.function, msg = "Pairlist( BUILTINSXP )" )
+	
+	checkException( funx(1:10), msg = "Function( INTSXP) " )
+	checkException( funx(TRUE), msg = "Function( LGLSXP )" )
+	checkException( funx(1.3), msg = "Function( REALSXP) " )
+	checkException( funx(as.raw(1) ), msg = "Function( RAWSXP)" )
+	checkException( funx(new.env()), msg = "Function not compatible with environment" )
+	
+}
+
+test.Function.variadic <- function(){
+	if( Rcpp:::canUseCXX0X() ){
+		funx <- cfunction(signature(x="function", y = "numeric"), '
+		Function sort(x) ;
+		return sort( y, Named("decreasing", true) ) ;
+		', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+		checkEquals( funx( sort, sample(1:20) ), 
+			20:1, msg = "calling function" )
+	}
+}
+

Modified: pkg/inst/unitTests/runit.Pairlist.R
===================================================================
--- pkg/inst/unitTests/runit.Pairlist.R	2010-01-04 22:05:43 UTC (rev 274)
+++ pkg/inst/unitTests/runit.Pairlist.R	2010-01-04 22:51:53 UTC (rev 275)
@@ -25,7 +25,7 @@
 	funx <- cfunction(signature(x="ANY"), 'return Pairlist(x) ;', 
 		Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
 	checkEquals( funx( pairlist("rnorm") ), pairlist("rnorm" ), msg = "Pairlist( LISTSXP )" )
-	checkEquals( funx( call("rnorm") ), pairlist("rnorm" ), msg = "Pairlist( LANGSXP )" )
+	checkEquals( funx( call("rnorm") ), call("rnorm" ), msg = "Pairlist( LANGSXP )" )
 	checkEquals( funx(1:10), as.pairlist(1:10) , msg = "Pairlist( INTSXP) " )
 	checkEquals( funx(TRUE), as.pairlist( TRUE) , msg = "Pairlist( LGLSXP )" )
 	checkEquals( funx(1.3), as.pairlist(1.3), msg = "Pairlist( REALSXP) " )

Added: pkg/src/Function.cpp
===================================================================
--- pkg/src/Function.cpp	                        (rev 0)
+++ pkg/src/Function.cpp	2010-01-04 22:51:53 UTC (rev 275)
@@ -0,0 +1,52 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Function.cpp: Rcpp R/C++ interface class library -- functions
+//
+// 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/>.
+
+#include <Rcpp/Function.h>
+#include <Rcpp/RObject.h>
+#include <Rcpp/Language.h>
+#include <Rcpp/pairlist.h>
+#include <RcppCommon.h>
+
+namespace Rcpp {
+	
+	Function::Function( SEXP x = R_NilValue ) throw(not_compatible) : RObject::RObject( ){
+		switch( TYPEOF(x) ){
+		case CLOSXP:
+		case SPECIALSXP:
+		case BUILTINSXP:
+			setSEXP(x); 
+			break; 
+		default:
+			throw not_compatible() ;
+		}
+	};
+	
+	Function::~Function(){}
+	
+	Function::not_compatible::not_compatible() throw() {}
+    	const char* Function::not_compatible::what() const throw(){
+    		return "not a function" ;
+    	}
+    	Function::not_compatible::~not_compatible() throw() {}
+    
+	
+	
+} // namespace Rcpp

Modified: pkg/src/Pairlist.cpp
===================================================================
--- pkg/src/Pairlist.cpp	2010-01-04 22:05:43 UTC (rev 274)
+++ pkg/src/Pairlist.cpp	2010-01-04 22:51:53 UTC (rev 275)
@@ -28,27 +28,25 @@
 namespace Rcpp {
 	
 	Pairlist::Pairlist( SEXP x = R_NilValue ) throw(not_compatible) : RObject::RObject( ){
-		
 		if( x != R_NilValue ){
-			if( TYPEOF( x ) == LISTSXP ){
-				// bingo 
-				setSEXP( x ) ;
-			} else if( TYPEOF( x) == LANGSXP ){
-				// almost
-				SET_TYPEOF(x, LISTSXP);
-				setSEXP( x) ;
-			} else {
-				Evaluator evaluator( Language("as.pairlist", x ) ) ;
-				evaluator.run() ;
-				if( evaluator.successfull() ){
-    					setSEXP( evaluator.getResult().asSexp() ) ;
-    				} else{
-    					throw not_compatible( ) ; 
-    				}
+			switch( TYPEOF(x) ){
+				case LANGSXP:
+				case LISTSXP:
+					setSEXP( x) ; 
+					break ;
+				default:
+					{
+						Evaluator evaluator( Language("as.pairlist", x ) ) ;
+						evaluator.run() ;
+						if( evaluator.successfull() ){
+    							setSEXP( evaluator.getResult().asSexp() ) ;
+    						} else{
+    							throw not_compatible( ) ; 
+    						}
+					}
 			}
-		}
+		}          
 		
-		
 	};
 	
 	Pairlist::~Pairlist(){}

Added: pkg/src/Rcpp/Function.h
===================================================================
--- pkg/src/Rcpp/Function.h	                        (rev 0)
+++ pkg/src/Rcpp/Function.h	2010-01-04 22:51:53 UTC (rev 275)
@@ -0,0 +1,91 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Function.h: Rcpp R/C++ interface class library -- functions (also primitives and builtins)
+//
+// 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/>.
+
+#ifndef Rcpp_Function_h
+#define Rcpp_Function_h
+
+#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
+#include <Rcpp/pairlist.h>
+#include <Rcpp/Evaluator.h>
+
+namespace Rcpp{ 
+
+/** 
+ * functions
+ */
+class Function : public RObject{
+public:
+	/**
+	 * Exception thrown when attempting build a Function from a SEXP 
+	 * that is not appropriate
+	 */
+	class not_compatible: public std::exception{
+		public:
+			not_compatible() throw() ;
+			
+			/**
+			 * The message: not a function 
+			 */
+			const char* what() const throw() ;
+			
+			~not_compatible() throw() ;
+		
+	} ;
+  	
+	/**
+	 * Attempts to convert the SEXP to a pair list
+	 *
+	 * @throw not_compatible if the SEXP could not be converted
+	 * to a pair list using as.pairlist
+	 */
+	Function(SEXP lang) throw(not_compatible) ;
+	
+	
+	/**
+	 * calls the function with the specified arguments
+	 *
+	 * @param ...Args variable length argument list. The type of each 
+	 *        argument must be wrappable, meaning there need to be 
+	 *        a wrap function that takes this type as its parameter
+	 *
+	 */
+#ifdef CXX0X
+template<typename... Args> 
+	SEXP operator()( const Args&... args) {
+		Evaluator evaluator( Rf_lcons( m_sexp, pairlist(args...) ) ) ; 
+		evaluator.run() ;
+		if( evaluator.successfull() ){
+			return evaluator.getResult() ;
+		} else{
+			/* FIXME: need some strategy about error handling */
+			/* throw an exception ? */
+			return evaluator.getError() ;
+		}
+	}
+#endif	
+	
+	~Function() ;
+};
+
+} // namespace Rcpp
+
+#endif

Modified: pkg/src/Rcpp.h
===================================================================
--- pkg/src/Rcpp.h	2010-01-04 22:05:43 UTC (rev 274)
+++ pkg/src/Rcpp.h	2010-01-04 22:51:53 UTC (rev 275)
@@ -55,5 +55,6 @@
 #include <Rcpp/Language.h>
 #include <Rcpp/Named.h>
 #include <Rcpp/Pairlist.h>
+#include <Rcpp/Function.h>
 
 #endif



More information about the Rcpp-commits mailing list