[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() ;
More information about the Rcpp-commits
mailing list