[Rcpp-devel] [Rcpp-commits] r264 - in pkg: inst inst/unitTests src src/Rcpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 3 18:10:51 CET 2010
Author: romain
Date: 2010-01-03 18:10:51 +0100 (Sun, 03 Jan 2010)
New Revision: 264
Added:
pkg/inst/unitTests/runit.as.R
pkg/src/Rcpp/as.h
pkg/src/as.cpp
Modified:
pkg/inst/ChangeLog
pkg/inst/unitTests/runit.Language.R
pkg/src/Rcpp.h
Log:
generic as converter: as<int>, as<double>, ...
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2010-01-03 16:17:32 UTC (rev 263)
+++ pkg/inst/ChangeLog 2010-01-03 17:10:51 UTC (rev 264)
@@ -1,5 +1,13 @@
2010-01-03 Romain Francois <francoisromain at free.fr>
+ * src/Rcpp/as.h: template as<> to convert SEXP to classic
+ C++ types, fcactored out of RObject
+
+ * src/as.cpp: specific implementations. as<int>, as<bool>
+ as<string>, ...
+
+ * inst/unitTests/runit.as.R: unit tests
+
* src/Rcpp/wrap.h : factored out from RObject. there is now a
template wrap in addition to the specific implementations. The
template generates a warning and return NULL
Modified: pkg/inst/unitTests/runit.Language.R
===================================================================
--- pkg/inst/unitTests/runit.Language.R 2010-01-03 16:17:32 UTC (rev 263)
+++ pkg/inst/unitTests/runit.Language.R 2010-01-03 17:10:51 UTC (rev 264)
@@ -46,7 +46,7 @@
return Language( "rnorm", 10, Named("mean",0.0), 2.0 ) ;
', Rcpp=TRUE, verbose=TRUE, includes = "using namespace Rcpp;" )
checkEquals( funx(), call("rnorm", 10L, mean = 0.0, 2.0 ),
- msg = "variadic templates" )
+ msg = "variadic templates (with names)" )
}
}
Added: pkg/inst/unitTests/runit.as.R
===================================================================
--- pkg/inst/unitTests/runit.as.R (rev 0)
+++ pkg/inst/unitTests/runit.as.R 2010-01-03 17:10:51 UTC (rev 264)
@@ -0,0 +1,135 @@
+#!/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.as.int <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ int y = as<int>(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;")
+ checkEquals( funx(10), 10L, msg = "as<int>( REALSXP ) " )
+ checkEquals( funx(10L), 10L, msg = "as<int>( INTSXP ) " )
+ checkEquals( funx(as.raw(10L)), 10L, msg = "as<int>( RAWSXP ) " )
+ checkEquals( funx(TRUE), 1L, msg = "as<int>( LGLSXP ) " )
+}
+
+test.as.double <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ double y = as<double>(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;")
+ checkEquals( funx(10), 10.0, msg = "as<double>( REALSXP ) " )
+ checkEquals( funx(10L), 10.0, msg = "as<double>( INTSXP ) " )
+ checkEquals( funx(as.raw(10L)), 10.0, msg = "as<double>( RAWSXP ) " )
+ checkEquals( funx(TRUE), 1.0, msg = "as<double>( LGLSXP ) " )
+}
+
+test.as.raw <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ Rbyte y = as<Rbyte>(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;")
+ checkEquals( funx(10), as.raw(10), msg = "as<Rbyte>( REALSXP ) " )
+ checkEquals( funx(10L), as.raw(10), msg = "as<Rbyte>( INTSXP ) " )
+ checkEquals( funx(as.raw(10L)), as.raw(10), msg = "as<Rbyte>( RAWSXP ) " )
+ checkEquals( funx(TRUE), as.raw(1), msg = "as<Rbyte>( LGLSXP ) " )
+}
+
+test.as.bool <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ bool y = as<bool>(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;")
+ checkEquals( funx(10), as.logical(10), msg = "as<bool>( REALSXP ) " )
+ checkEquals( funx(10L), as.logical(10), msg = "as<bool>( INTSXP ) " )
+ checkEquals( funx(as.raw(10L)), as.logical(10), msg = "as<bool>( RAWSXP ) " )
+ checkEquals( funx(TRUE), as.logical(1), msg = "as<bool>( LGLSXP ) " )
+}
+
+test.as.string <- function(){
+ funx <- cfunction(signature(x="character"), '
+ string y = as<string>(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE,
+ includes =c( "using namespace Rcpp;", "using namespace std;" ) )
+ checkEquals( funx("foo"), "foo", msg = "as<string>( STRSXP ) " )
+}
+
+test.as.vector.int <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ vector<int> y = as< vector<int> >(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE,
+ includes =c( "using namespace Rcpp;", "using namespace std;" ) )
+ checkEquals( funx(1:10), 1:10 , msg = "as<vector<int>>( INTSXP ) " )
+ checkEquals( funx(as.numeric(1:10)), 1:10 , msg = "as<vector<int>>( REALSXP ) " )
+ checkEquals( funx(as.raw(1:10)), 1:10 , msg = "as<vector<int>>( RAWSXP ) " )
+ checkEquals( funx(c(TRUE,FALSE)), 1:0 , msg = "as<vector<int>>( LGLSXP ) " )
+}
+
+test.as.vector.double <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ vector<double> y = as< vector<double> >(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE,
+ includes =c( "using namespace Rcpp;", "using namespace std;" ) )
+ checkEquals( funx(1:10), as.numeric(1:10) , msg = "as<vector<double>>( INTSXP ) " )
+ checkEquals( funx(as.numeric(1:10)), as.numeric(1:10) , msg = "as<vector<double>>( REALSXP ) " )
+ checkEquals( funx(as.raw(1:10)), as.numeric(1:10), msg = "as<vector<double>>( RAWSXP ) " )
+ checkEquals( funx(c(TRUE,FALSE)), c(1.0, 0.0) , msg = "as<vector<double>>( LGLSXP ) " )
+}
+
+test.as.vector.raw <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ vector<Rbyte> y = as< vector<Rbyte> >(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE,
+ includes =c( "using namespace Rcpp;", "using namespace std;" ) )
+ checkEquals( funx(1:10), as.raw(1:10) , msg = "as<vector<Rbyte>>( INTSXP ) " )
+ checkEquals( funx(as.numeric(1:10)), as.raw(1:10) , msg = "as<vector<Rbyte>>( REALSXP ) " )
+ checkEquals( funx(as.raw(1:10)), as.raw(1:10) , msg = "as<vector<Rbyte>>( RAWSXP ) " )
+ checkEquals( funx(c(TRUE,FALSE)), as.raw(1:0) , msg = "as<vector<Rbyte>>( LGLSXP ) " )
+}
+
+test.as.vector.bool <- function(){
+ funx <- cfunction(signature(x="numeric"), '
+ vector<bool> y = as< vector<bool> >(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE,
+ includes =c( "using namespace Rcpp;", "using namespace std;" ) )
+ checkEquals( funx(0:10), as.logical(0:10) , msg = "as<vector<bool>>( INTSXP ) " )
+ checkEquals( funx(as.numeric(0:10)), as.logical(0:10) , msg = "as<vector<bool>>( REALSXP ) " )
+ checkEquals( funx(as.raw(0:10)), as.logical(0:10) , msg = "as<vector<bool>>( RAWSXP ) " )
+ checkEquals( funx(c(TRUE,FALSE)), as.logical(1:0) , msg = "as<vector<bool>>( LGLSXP ) " )
+}
+
+
+test.as.vector.bool <- function(){
+ funx <- cfunction(signature(x="character"), '
+ vector<string> y = as< vector<string> >(x) ;
+ return wrap(y) ;
+ ', Rcpp=TRUE, verbose=FALSE,
+ includes =c( "using namespace Rcpp;", "using namespace std;" ) )
+ checkEquals( funx(letters), letters , msg = "as<vector<string>>( STRSXP ) " )
+
+}
+
Added: pkg/src/Rcpp/as.h
===================================================================
--- pkg/src/Rcpp/as.h (rev 0)
+++ pkg/src/Rcpp/as.h 2010-01-03 17:10:51 UTC (rev 264)
@@ -0,0 +1,49 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// as.h: Rcpp R/C++ interface class library -- generic converters from SEXP
+//
+// 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_as_h
+#define Rcpp_as_h
+
+#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
+
+namespace Rcpp{
+
+/**
+ * Generic converted from SEXP to the typename
+ */
+template <typename T> T as( SEXP m_sexp) {
+ throw std::runtime_error("not implemented") ;
+}
+template<> bool as<bool>(SEXP m_sexp) ;
+template<> double as<double>(SEXP m_sexp) ;
+template<> int as<int>(SEXP m_sexp) ;
+template<> Rbyte as<Rbyte>(SEXP m_sexp) ;
+template<> std::string as<std::string>(SEXP m_sexp) ;
+template<> std::vector<int> as< std::vector<int>>(SEXP m_sexp) ;
+template<> std::vector<double> as< std::vector<double> >(SEXP m_sexp) ;
+template<> std::vector<std::string> as< std::vector<std::string> >(SEXP m_sexp) ;
+template<> std::vector<Rbyte> as< std::vector<Rbyte> >(SEXP m_sexp) ;
+template<> std::vector<bool> as< std::vector<bool> >(SEXP m_sexp) ;
+
+} // namespace Rcpp
+
+#endif
Modified: pkg/src/Rcpp.h
===================================================================
--- pkg/src/Rcpp.h 2010-01-03 16:17:32 UTC (rev 263)
+++ pkg/src/Rcpp.h 2010-01-03 17:10:51 UTC (rev 264)
@@ -4,6 +4,7 @@
//
// Copyright (C) 2005 - 2006 Dominick Samperi
// Copyright (C) 2008 - 2009 Dirk Eddelbuettel
+// Copyright (C) 2009 - 2010 Dirk Eddelbuettel and Romain Francois
//
// This file is part of Rcpp.
//
@@ -45,6 +46,7 @@
#include <Rcpp/pairlist.h>
#include <Rcpp/grow.h>
#include <Rcpp/wrap.h>
+#include <Rcpp/as.h>
#include <Rcpp/RObject.h>
#include <Rcpp/XPtr.h>
#include <Rcpp/Environment.h>
Added: pkg/src/as.cpp
===================================================================
--- pkg/src/as.cpp (rev 0)
+++ pkg/src/as.cpp 2010-01-03 17:10:51 UTC (rev 264)
@@ -0,0 +1,215 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// as.cpp: Rcpp R/C++ interface class library -- generic converters from SEXP
+//
+// 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/as.h>
+
+namespace Rcpp{
+
+template<> double as<double>(SEXP m_sexp) {
+ if (Rf_length(m_sexp) != 1) {
+ throw std::range_error("as<double> expects single value");
+ }
+ switch( TYPEOF(m_sexp) ){
+ case LGLSXP:
+ return LOGICAL(m_sexp)[0] ? 1.0 : 0.0 ;
+ case REALSXP:
+ return REAL(m_sexp)[0] ;
+ case INTSXP:
+ return (double)INTEGER(m_sexp)[0];
+ case RAWSXP:
+ return (double)RAW(m_sexp)[0];
+ default:
+ throw std::range_error("as<double> invalid type");
+ }
+ return 0.0 ; // never reached
+}
+
+template<> int as<int>(SEXP m_sexp) {
+ if (Rf_length(m_sexp) != 1) {
+ throw std::range_error("as<int> expects single value");
+ }
+ switch( TYPEOF(m_sexp)){
+ case LGLSXP:
+ return LOGICAL(m_sexp)[0] ? 1 : 0 ;
+ case REALSXP:
+ return (int)REAL(m_sexp)[0] ; // some of this might be lost
+ case INTSXP:
+ return INTEGER(m_sexp)[0];
+ case RAWSXP:
+ return (int)RAW(m_sexp)[0];
+ default:
+ throw std::range_error("as<int>");
+ }
+ return 0; // never reached
+}
+
+template<> Rbyte as<Rbyte>(SEXP m_sexp) {
+ if (Rf_length(m_sexp) != 1) {
+ throw std::range_error("as<Rbyte> expects single value");
+ }
+ switch( TYPEOF(m_sexp) ){
+ case LGLSXP:
+ return LOGICAL(m_sexp)[0] ? (Rbyte)1 : (Rbyte)0 ;
+ case REALSXP:
+ return (Rbyte)REAL(m_sexp)[0] ;
+ case INTSXP:
+ return (Rbyte)INTEGER(m_sexp)[0] ;
+ case RAWSXP:
+ return RAW(m_sexp)[0] ;
+ default:
+ throw std::range_error("as<Rbyte> expects raw, double or int");
+ }
+ return (Rbyte)0; // never reached
+}
+
+template<> bool as<bool>(SEXP m_sexp) {
+ if (Rf_length(m_sexp) != 1) {
+ throw std::range_error("as<bool> expects single value");
+ }
+ switch( TYPEOF(m_sexp) ){
+ case LGLSXP:
+ return LOGICAL(m_sexp)[0] ? true : false ;
+ case REALSXP:
+ return (bool)REAL(m_sexp)[0] ;
+ case INTSXP:
+ return (bool)INTEGER(m_sexp)[0] ;
+ case RAWSXP:
+ return (bool)RAW(m_sexp)[0] ;
+ default:
+ throw std::range_error("as<bool> expects raw, double or int");
+ }
+ return false; // never reached
+}
+
+template<> std::string as<std::string>(SEXP m_sexp) {
+ if (Rf_length(m_sexp) != 1) {
+ throw std::range_error("as<std::string> expects single value");
+ }
+ if (!Rf_isString(m_sexp)) {
+ throw std::range_error("as<std::string> expects string");
+ }
+ return std::string(CHAR(STRING_ELT(m_sexp,0)));
+}
+
+template<> std::vector<bool> as< std::vector<bool> >(SEXP m_sexp) {
+ int n = Rf_length(m_sexp);
+ std::vector<bool> v(n);
+ switch( TYPEOF(m_sexp) ){
+ case LGLSXP:
+ v.assign( LOGICAL(m_sexp), LOGICAL(m_sexp)+n ) ;
+ break ;
+ case INTSXP:
+ v.assign( INTEGER(m_sexp), INTEGER(m_sexp)+n ) ;
+ break;
+ case REALSXP:
+ v.assign( REAL(m_sexp), REAL(m_sexp)+n ) ;
+ break;
+ case RAWSXP:
+ v.assign( RAW(m_sexp), RAW(m_sexp)+n ) ;
+ break;
+ default:
+ throw std::range_error( "as< vector<bool> >: invalid R type" ) ;
+ }
+ return v;
+}
+
+
+template<> std::vector<int> as< std::vector<int> >(SEXP m_sexp){
+ int n = Rf_length(m_sexp);
+ std::vector<int> v(n);
+ switch( TYPEOF(m_sexp) ){
+ case LGLSXP:
+ v.assign( LOGICAL(m_sexp), LOGICAL(m_sexp)+n ) ;
+ break;
+ case INTSXP:
+ v.assign( INTEGER(m_sexp), INTEGER(m_sexp)+n ) ;
+ break;
+ case REALSXP:
+ v.assign( REAL(m_sexp), REAL(m_sexp)+n ) ;
+ break;
+ case RAWSXP:
+ v.assign( RAW(m_sexp), RAW(m_sexp)+n ) ;
+ break;
+ default:
+ throw std::range_error( "as< vector<int> >: invalid R type" ) ;
+ }
+ return v;
+}
+
+template<> std::vector<Rbyte> as< std::vector<Rbyte> >(SEXP m_sexp) {
+ int n = Rf_length(m_sexp);
+ std::vector<Rbyte> v(n);
+ switch( TYPEOF(m_sexp) ){
+ case LGLSXP:
+ v.assign( LOGICAL(m_sexp), LOGICAL(m_sexp)+n ) ;
+ break ;
+ case RAWSXP:
+ v.assign( RAW(m_sexp), RAW(m_sexp)+n ) ;
+ break ;
+ case REALSXP:
+ v.assign( REAL(m_sexp), REAL(m_sexp)+n) ;
+ break;
+ case INTSXP:
+ v.assign( INTEGER(m_sexp), INTEGER(m_sexp)+n) ;
+ break;
+ default:
+ throw std::range_error("as< vector<Rbyte> > expects raw, double or int");
+ }
+ return v;
+}
+
+template<> std::vector<double> as< std::vector<double> >(SEXP m_sexp){
+ int n = Rf_length(m_sexp);
+ std::vector<double> v(n);
+ switch( TYPEOF(m_sexp) ){
+ case LGLSXP:
+ v.assign( LOGICAL(m_sexp), LOGICAL(m_sexp)+n ) ;
+ break ;
+ case RAWSXP:
+ v.assign( RAW(m_sexp), RAW(m_sexp)+n ) ;
+ break ;
+ case REALSXP:
+ v.assign( REAL(m_sexp), REAL(m_sexp)+n) ;
+ break;
+ case INTSXP:
+ v.assign( INTEGER(m_sexp), INTEGER(m_sexp)+n) ;
+ break;
+ default:
+ throw std::range_error("as< vector<double> >: expects raw, double or int");
+ }
+ return v;
+}
+
+
+template<> std::vector<std::string> as< std::vector<std::string> >(SEXP m_sexp){
+ int n = Rf_length(m_sexp);
+ std::vector<std::string> v(n);
+ if (!Rf_isString(m_sexp)) {
+ throw std::range_error("as< vector<string> >: expects string");
+ }
+ for (int i = 0; i < n; i++) {
+ v[i] = std::string(CHAR(STRING_ELT(m_sexp,i)));
+ }
+ return v;
+}
+
+} // namespace Rcpp
+
_______________________________________________
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