[Rcpp-commits] r1613 - in pkg/Rcpp: . inst/include inst/include/Rcpp/sugar/functions inst/include/Rcpp/traits inst/unitTests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jun 18 22:39:30 CEST 2010
Author: romain
Date: 2010-06-18 22:39:30 +0200 (Fri, 18 Jun 2010)
New Revision: 1613
Added:
pkg/Rcpp/inst/include/Rcpp/sugar/functions/ifelse.h
pkg/Rcpp/inst/include/Rcpp/traits/get_na.h
pkg/Rcpp/inst/unitTests/runit.sugar.ifelse.R
Modified:
pkg/Rcpp/TODO
pkg/Rcpp/inst/include/Rcpp/sugar/functions/functions.h
pkg/Rcpp/inst/include/RcppCommon.h
Log:
implementation of ifelse
Modified: pkg/Rcpp/TODO
===================================================================
--- pkg/Rcpp/TODO 2010-06-18 19:56:23 UTC (rev 1612)
+++ pkg/Rcpp/TODO 2010-06-18 20:39:30 UTC (rev 1613)
@@ -45,7 +45,7 @@
Syntactic sugar
- o duplicated, unique, count, sum, rep, head, tail, pmin, pmax, ifelse
+ o duplicated, unique, count, sum, rep, head, tail, pmin, pmax
o min, max with specialization of the binary operators, so that we can do
things like this lazily:
Modified: pkg/Rcpp/inst/include/Rcpp/sugar/functions/functions.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/sugar/functions/functions.h 2010-06-18 19:56:23 UTC (rev 1612)
+++ pkg/Rcpp/inst/include/Rcpp/sugar/functions/functions.h 2010-06-18 20:39:30 UTC (rev 1613)
@@ -27,5 +27,6 @@
#include <Rcpp/sugar/functions/is_na.h>
#include <Rcpp/sugar/functions/seq_along.h>
#include <Rcpp/sugar/functions/sapply.h>
+#include <Rcpp/sugar/functions/ifelse.h>
#endif
Added: pkg/Rcpp/inst/include/Rcpp/sugar/functions/ifelse.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/sugar/functions/ifelse.h (rev 0)
+++ pkg/Rcpp/inst/include/Rcpp/sugar/functions/ifelse.h 2010-06-18 20:39:30 UTC (rev 1613)
@@ -0,0 +1,92 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// ifelse.h: Rcpp R/C++ interface class library -- ifelse
+//
+// 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__sugar__ifelse_h
+#define Rcpp__sugar__ifelse_h
+
+namespace Rcpp{
+namespace sugar{
+
+template <
+ int RTYPE,
+ bool COND_NA, typename COND_T,
+ bool LHS_NA , typename LHS_T,
+ bool RHS_NA , typename RHS_T
+ >
+class IfElse : public VectorBase<
+ RTYPE,
+ ( COND_NA && LHS_NA && RHS_NA ) ,
+ IfElse<RTYPE,COND_NA,COND_T,LHS_NA,LHS_T,RHS_NA,RHS_T>
+> {
+public:
+ typedef Rcpp::VectorBase<LGLSXP,COND_NA,COND_T> COND_TYPE ;
+ typedef Rcpp::VectorBase<RTYPE ,LHS_NA ,LHS_T> LHS_TYPE ;
+ typedef Rcpp::VectorBase<RTYPE ,RHS_NA ,RHS_T> RHS_TYPE ;
+ typedef typename traits::storage_type<RTYPE>::type STORAGE ;
+
+ IfElse( const COND_TYPE& cond_, const LHS_TYPE& lhs_, const RHS_TYPE& rhs_ ) :
+ cond(cond_), lhs(lhs_), rhs(rhs_) {
+ /* FIXME : cond, lhs and rhs must all have the sale size */
+ }
+
+ inline STORAGE operator[]( int i ) const {
+ return get__impl( i, typename Rcpp::traits::integral_constant<bool,COND_NA>() );
+ }
+
+ inline int size() const { return cond.size() ; }
+
+private:
+
+ inline STORAGE get__impl( int i, Rcpp::traits::true_type ) const {
+ int x = cond[i] ;
+ return Rcpp::traits::is_na<LGLSXP>(x) ? Rcpp::traits::get_na<RTYPE>() : ( x ? lhs[i] : rhs[i] ) ;
+ }
+
+ inline STORAGE get__impl( int i, Rcpp::traits::false_type ) const {
+ return cond[i] ? lhs[i] : rhs[i] ;
+ }
+
+ const COND_TYPE& cond ;
+ const LHS_TYPE& lhs ;
+ const RHS_TYPE& rhs ;
+
+} ;
+
+} // sugar
+
+template <
+ int RTYPE,
+ bool COND_NA, typename COND_T,
+ bool LHS_NA , typename LHS_T,
+ bool RHS_NA , typename RHS_T
+ >
+inline sugar::IfElse< RTYPE,COND_NA,COND_T,LHS_NA,LHS_T,RHS_NA,RHS_T >
+ifelse(
+ const Rcpp::VectorBase<LGLSXP,COND_NA,COND_T>& cond,
+ const Rcpp::VectorBase<RTYPE ,LHS_NA ,LHS_T>& lhs,
+ const Rcpp::VectorBase<RTYPE ,RHS_NA ,RHS_T>& rhs
+ ){
+ return sugar::IfElse<RTYPE,COND_NA,COND_T,LHS_NA,LHS_T,RHS_NA,RHS_T>( cond, lhs, rhs ) ;
+}
+
+} // Rcpp
+
+#endif
Added: pkg/Rcpp/inst/include/Rcpp/traits/get_na.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/traits/get_na.h (rev 0)
+++ pkg/Rcpp/inst/include/Rcpp/traits/get_na.h 2010-06-18 20:39:30 UTC (rev 1613)
@@ -0,0 +1,55 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+/* :tabSize=4:indentSize=4:noTabs=false:folding=explicit:collapseFolds=1: */
+//
+// get_na.h: Rcpp R/C++ interface class library -- NA handling
+//
+// 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__traits__get_na__h
+#define Rcpp__traits__get_na__h
+
+namespace Rcpp{
+namespace traits{
+
+template<int RTYPE>
+typename storage_type<RTYPE>::type get_na() ;
+
+template<>
+inline int get_na<INTSXP>(){ return NA_INTEGER ; }
+
+template<>
+inline int get_na<LGLSXP>(){ return NA_LOGICAL ; }
+
+template<>
+inline double get_na<REALSXP>(){ return NA_REAL ; }
+
+template<>
+inline Rcomplex get_na<CPLXSXP>(){
+ Rcomplex x ;
+ x.r = NA_REAL ;
+ x.i = NA_REAL ;
+ return x ;
+}
+
+template<>
+inline SEXP get_na<STRSXP>(){ return NA_STRING ; }
+
+}
+}
+
+#endif
Modified: pkg/Rcpp/inst/include/RcppCommon.h
===================================================================
--- pkg/Rcpp/inst/include/RcppCommon.h 2010-06-18 19:56:23 UTC (rev 1612)
+++ pkg/Rcpp/inst/include/RcppCommon.h 2010-06-18 20:39:30 UTC (rev 1613)
@@ -225,6 +225,7 @@
#include <Rcpp/traits/r_type_traits.h>
#include <Rcpp/traits/wrap_type_traits.h>
#include <Rcpp/traits/is_na.h>
+#include <Rcpp/traits/get_na.h>
#include <Rcpp/traits/is_trivial.h>
#include <Rcpp/traits/init_type.h>
Added: pkg/Rcpp/inst/unitTests/runit.sugar.ifelse.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.sugar.ifelse.R (rev 0)
+++ pkg/Rcpp/inst/unitTests/runit.sugar.ifelse.R 2010-06-18 20:39:30 UTC (rev 1613)
@@ -0,0 +1,35 @@
+#
+# 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/>.
+
+test.sugar.ifelse <- function( ){
+
+ fx <- cxxfunction( signature( x = "numeric", y = "numeric" ), '
+
+ NumericVector xx(x) ;
+ NumericVector yy(y) ;
+
+ NumericVector res = ifelse( xx < yy, xx*xx, -(yy*yy) ) ;
+ return res ;
+ ', plugin = "Rcpp" )
+
+ x <- 1:10
+ y <- 10:1
+ checkEquals( fx( x, y), ifelse( x<y, x*x, -(y*y) ) )
+
+}
+
More information about the Rcpp-commits
mailing list