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

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Thu Dec 31 17:57:08 CET 2009


Author: romain
Date: 2009-12-31 17:57:08 +0100 (Thu, 31 Dec 2009)
New Revision: 249

Added:
   pkg/inst/unitTests/runit.evaluator.R
   pkg/src/Evaluator.cpp
   pkg/src/Rcpp/Evaluator.h
Modified:
   pkg/R/exceptions.R
   pkg/inst/ChangeLog
   pkg/src/Rcpp.h
   pkg/src/Rcpp/RObject.h
   pkg/src/RcppCommon.h
Log:
added Rcpp::Evaluator class

Modified: pkg/R/exceptions.R
===================================================================
--- pkg/R/exceptions.R	2009-12-31 15:25:43 UTC (rev 248)
+++ pkg/R/exceptions.R	2009-12-31 16:57:08 UTC (rev 249)
@@ -26,3 +26,24 @@
 	stop( condition )
 }
 
+# used by Rcpp::Evaluator
+exceptions <- new.env()
+setCurrentError <- function( condition = NULL) exceptions[["current"]] <- condition
+resetCurrentError <- function() {
+	setCurrentError(NULL)
+	setErrorOccured(FALSE)
+}
+getCurrentError <- function() exceptions[["current"]]
+errorOccured <- function() isTRUE( exceptions[["error_occured"]] )
+setErrorOccured <- function(error_occured = TRUE) exceptions[["error_occured"]] <- error_occured
+resetCurrentError()
+protectedEval <- function(expr, env ){
+	resetCurrentError()
+	tryCatch( eval( expr, envir = env), error = function(e){
+		setErrorOccured( TRUE )
+		setCurrentError( e )
+		invisible( NULL )
+	} )
+}
+setErrorOccured(FALSE)
+

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-12-31 15:25:43 UTC (rev 248)
+++ pkg/inst/ChangeLog	2009-12-31 16:57:08 UTC (rev 249)
@@ -1,3 +1,17 @@
+2009-12-31  Romain Francois <francoisromain at free.fr>
+
+	* src/Rcpp/Evaluator.h : new class Rcpp::Evaluator that eases
+	evaluation of R expression with error capture. so that we can for example
+	throw C++ exceptions
+	
+	* src/Evaluator.cpp : implementation of Rcpp::Evaluator
+	
+	* inst/unitTests/runit.evaluator: unit tests of Rcpp::Evaluator
+	
+	* inst/Rcpp/RObject.h: RObject::RObject(SEXP) now initializes isProtected
+	
+	* inst/src/Environment.cpp: use of exceptions
+
 2009-12-30  Romain Francois <francoisromain at free.fr>
 
 	* src/Rcpp/Environment.h : added support for environment through the

Added: pkg/inst/unitTests/runit.evaluator.R
===================================================================
--- pkg/inst/unitTests/runit.evaluator.R	                        (rev 0)
+++ pkg/inst/unitTests/runit.evaluator.R	2009-12-31 16:57:08 UTC (rev 249)
@@ -0,0 +1,45 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2009 - 2010	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.evaluator.error <- function(){
+	funx <- cfunction(signature(x = "expression"),  '
+	Rcpp::Evaluator evaluator( x ) ;
+	evaluator.run( Rcpp::Environment::global_env() ) ;
+	return evaluator.getError() ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	err <- funx( expression(stop("error")) ) 
+	checkTrue( all( "simpleError" %in% class(err ) ), msg = "error capture" )
+}
+
+test.evaluator.ok <- function(){
+	funx <- cfunction(signature(x = "expression"),  '
+	Rcpp::Evaluator evaluator( x ) ;
+	evaluator.run( Rcpp::Environment::global_env() ) ;
+	return evaluator.getResult() ;
+	', Rcpp=TRUE, verbose=FALSE)
+	
+	x <- funx( expression( sample(1:10) ) ) 
+	checkEquals( sort(x), 1:10, msg = "Evaluator running fine" )
+}
+

Added: pkg/src/Evaluator.cpp
===================================================================
--- pkg/src/Evaluator.cpp	                        (rev 0)
+++ pkg/src/Evaluator.cpp	2009-12-31 16:57:08 UTC (rev 249)
@@ -0,0 +1,47 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Evaluator.cpp: Rcpp R/C++ interface class library -- evaluator
+//
+// Copyright (C) 2009 - 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/Evaluator.h>
+#include <Rcpp/Environment.h>
+
+namespace Rcpp {
+	
+	Evaluator::Evaluator( SEXP expression = R_NilValue) : 
+		expression(expression), 
+		result(R_NilValue),
+		error(R_NilValue),
+		error_occured(false){}
+	
+	Evaluator::~Evaluator(){} 
+	
+	void Evaluator::run(SEXP env ){
+		Environment rcpp = Environment::namespace_env("Rcpp") ;
+		SEXP call = Rf_lang3( Rf_install("protectedEval"), expression, env ) ;
+		result = RObject( Rf_eval( call, rcpp ) ); 
+		result.protect() ;
+		error_occured = LOGICAL( Rf_eval( Rf_lang1( Rf_install("errorOccured")) , rcpp) )[0] ;
+		if( error_occured ){
+			error = RObject( Rf_eval( Rf_lang1(Rf_install("getCurrentError")) , rcpp) );
+			error.protect() ;
+		}
+	}
+	
+} // namespace Rcpp

Added: pkg/src/Rcpp/Evaluator.h
===================================================================
--- pkg/src/Rcpp/Evaluator.h	                        (rev 0)
+++ pkg/src/Rcpp/Evaluator.h	2009-12-31 16:57:08 UTC (rev 249)
@@ -0,0 +1,48 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Evaluator.h: Rcpp R/C++ interface class library -- protected evaluation
+//
+// Copyright (C) 2009 - 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_Evaluator_h
+#define Rcpp_Evaluator_h
+
+#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
+#include <Rcpp/Environment.h>
+
+namespace Rcpp{ 
+
+class Evaluator{
+public:
+	Evaluator(SEXP expression ) ;
+	~Evaluator() ;
+	void run(SEXP env) ;
+	inline RObject getResult() const { return result ; }
+	inline RObject getError() const { return error ; }
+	
+private:		
+	SEXP expression ;
+	bool error_occured ;
+	RObject result ;
+	RObject error ;
+};
+
+} // namespace Rcpp
+
+#endif

Modified: pkg/src/Rcpp/RObject.h
===================================================================
--- pkg/src/Rcpp/RObject.h	2009-12-31 15:25:43 UTC (rev 248)
+++ pkg/src/Rcpp/RObject.h	2009-12-31 16:57:08 UTC (rev 249)
@@ -38,7 +38,7 @@
      * the SEXP from garbage collection, and release to 
      * remove the protection
      */
-    RObject(SEXP m_sexp = R_NilValue) : m_sexp(m_sexp) {};
+    RObject(SEXP m_sexp = R_NilValue) : m_sexp(m_sexp), isProtected(false){};
     
     /**
      * if this object is protected rom R's GC, then it is released

Modified: pkg/src/Rcpp.h
===================================================================
--- pkg/src/Rcpp.h	2009-12-31 15:25:43 UTC (rev 248)
+++ pkg/src/Rcpp.h	2009-12-31 16:57:08 UTC (rev 249)
@@ -43,7 +43,8 @@
 
 /* new api */
 #include <Rcpp/RObject.h>
-#include <Rcpp/XPtr.h> 
-#include <Rcpp/Environment.h> 
+#include <Rcpp/XPtr.h>
+#include <Rcpp/Environment.h>
+#include <Rcpp/Evaluator.h> 
 
 #endif

Modified: pkg/src/RcppCommon.h
===================================================================
--- pkg/src/RcppCommon.h	2009-12-31 15:25:43 UTC (rev 248)
+++ pkg/src/RcppCommon.h	2009-12-31 16:57:08 UTC (rev 249)
@@ -39,6 +39,7 @@
 #include <R.h>
 #include <Rinternals.h>
 #include <R_ext/Callbacks.h>
+#include <Rversion.h>
 
 // #ifdef BUILDING_DLL
 // #define RcppExport extern "C" __declspec(dllexport)
@@ -54,6 +55,7 @@
 //#define logTxt(x) logTxtFunction(__FILE__, __LINE__, x);
 #define logTxt(x) 
 
+/* in exceptions.cpp */
 void forward_uncaught_exceptions_to_r() ;
 RcppExport SEXP initUncaughtExceptionHandler() ; 
 

_______________________________________________
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