[Rcpp-devel] [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
_______________________________________________
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
More information about the Rcpp-devel
mailing list