Sugar cumprod, cummin, cummax with unit tests

Author: nathan-russell

inst/include/Rcpp/sugar/functions/cummax.h

@@ -0,0 +1,71 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// cumsum.h: Rcpp R/C++ interface class library -- cumsum
+//
+// Copyright (C) 2010 - 2011 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__cummax_h
+#define Rcpp__sugar__cummax_h
+
+namespace Rcpp{
+namespace sugar{
+
+template <int RTYPE, bool NA, typename T>
+class Cummax : public Lazy< Rcpp::Vector<RTYPE>, Cummax<RTYPE, NA, T> > {
+public:
+    typedef typename Rcpp::VectorBase<RTYPE, NA, T> VEC_TYPE;
+    typedef typename Rcpp::traits::storage_type<RTYPE>::type STORAGE;
+    typedef Rcpp::Vector<RTYPE> VECTOR;
+    
+    Cummax(const VEC_TYPE& object_) : object(object_) {}
+    
+    VECTOR get() const {
+        R_xlen_t n = object.size();
+        VECTOR result(n, Rcpp::traits::get_na<RTYPE>());
+        STORAGE current = object[0];
+        
+        if (Rcpp::traits::is_na<RTYPE>(current)) return result;
+        result[0] = current;
+        for (R_xlen_t i = 1; i < n; i++) {
+            current = object[i];
+            if (Rcpp::traits::is_na<RTYPE>(current)) return result;
+            result[i] = result[i-1] > current ? result[i-1] : current;
+        }
+        return result ;
+    }
+private:
+    const VEC_TYPE& object;    
+};
+
+} // sugar
+
+
+template <bool NA, typename T>
+inline sugar::Cummax<INTSXP, NA, T> cummax(const VectorBase<INTSXP, NA, T>& t) {
+    return sugar::Cummax<INTSXP, NA, T>(t);
+}
+
+template <bool NA, typename T>
+inline sugar::Cummax<REALSXP, NA, T> cummax(const VectorBase<REALSXP, NA, T>& t) {
+    return sugar::Cummax<REALSXP, NA, T>(t);
+}
+
+
+} // Rcpp
+#endif // Rcpp__sugar__cummax_h 
+

inst/include/Rcpp/sugar/functions/cummin.h

@@ -0,0 +1,71 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// cumsum.h: Rcpp R/C++ interface class library -- cumsum
+//
+// Copyright (C) 2010 - 2011 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__cummin_h
+#define Rcpp__sugar__cummin_h
+
+namespace Rcpp{
+namespace sugar{
+
+template <int RTYPE, bool NA, typename T>
+class Cummin : public Lazy< Rcpp::Vector<RTYPE>, Cummin<RTYPE, NA, T> > {
+public:
+    typedef typename Rcpp::VectorBase<RTYPE, NA, T> VEC_TYPE;
+    typedef typename Rcpp::traits::storage_type<RTYPE>::type STORAGE;
+    typedef Rcpp::Vector<RTYPE> VECTOR;
+    
+    Cummin(const VEC_TYPE& object_) : object(object_) {}
+    
+    VECTOR get() const {
+        R_xlen_t n = object.size();
+        VECTOR result(n, Rcpp::traits::get_na<RTYPE>());
+        STORAGE current = object[0];
+        
+        if (Rcpp::traits::is_na<RTYPE>(current)) return result;
+        result[0] = current;
+        for (R_xlen_t i = 1; i < n; i++) {
+            current = object[i];
+            if (Rcpp::traits::is_na<RTYPE>(current)) return result;
+            result[i] = result[i-1] < current ? result[i-1] : current;
+        }
+        return result ;
+    }
+private:
+    const VEC_TYPE& object;    
+};
+
+} // sugar
+
+
+template <bool NA, typename T>
+inline sugar::Cummin<INTSXP, NA, T> cummin(const VectorBase<INTSXP, NA, T>& t) {
+    return sugar::Cummin<INTSXP, NA, T>(t);
+}
+
+template <bool NA, typename T>
+inline sugar::Cummin<REALSXP, NA, T> cummin(const VectorBase<REALSXP, NA, T>& t) {
+    return sugar::Cummin<REALSXP, NA, T>(t);
+}
+
+
+} // Rcpp
+#endif // Rcpp__sugar__cummin_h 
+

inst/include/Rcpp/sugar/functions/cumprod.h

@@ -0,0 +1,76 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// cumsum.h: Rcpp R/C++ interface class library -- cumsum
+//
+// Copyright (C) 2010 - 2011 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__cumprod_h
+#define Rcpp__sugar__cumprod_h
+
+namespace Rcpp{
+namespace sugar{
+
+template <int RTYPE, bool NA, typename T>
+class Cumprod : public Lazy< Rcpp::Vector<RTYPE>, Cumprod<RTYPE, NA, T> > {
+public:
+    typedef typename Rcpp::VectorBase<RTYPE, NA, T> VEC_TYPE;
+    typedef typename Rcpp::traits::storage_type<RTYPE>::type STORAGE;
+    typedef Rcpp::Vector<RTYPE> VECTOR;
+
+    Cumprod(const VEC_TYPE& object_) : object(object_) {}
+    
+    VECTOR get() const {
+        R_xlen_t n = object.size();
+        VECTOR result(n, Rcpp::traits::get_na<RTYPE>());
+        STORAGE current = object[0];
+        
+        if (Rcpp::traits::is_na<RTYPE>(current)) return result;
+        result[0] = current;
+        for (R_xlen_t i = 1; i < n; i++) {
+            current = object[i];
+            if (Rcpp::traits::is_na<RTYPE>(current)) return result;
+            result[i] = result[i-1] * current;
+        }
+        return result ;
+    }
+private:
+    const VEC_TYPE& object;    
+};
+
+} // sugar
+
+
+template <bool NA, typename T>
+inline sugar::Cumprod<INTSXP, NA, T> cumprod(const VectorBase<INTSXP, NA, T>& t) {
+    return sugar::Cumprod<INTSXP, NA, T>(t);
+}
+
+template <bool NA, typename T>
+inline sugar::Cumprod<REALSXP, NA, T> cumprod(const VectorBase<REALSXP, NA, T>& t) {
+    return sugar::Cumprod<REALSXP, NA, T>(t);
+}
+
+template <bool NA, typename T>
+inline sugar::Cumprod<CPLXSXP, NA, T> cumprod(const VectorBase<CPLXSXP, NA, T>& t) {
+    return sugar::Cumprod<CPLXSXP, NA, T>(t);
+}
+
+
+} // Rcpp
+#endif // Rcpp__sugar__cumprod_h 
+

inst/include/Rcpp/sugar/functions/functions.h

@@ -76,4 +76,9 @@
 
 #include <Rcpp/sugar/functions/strings/strings.h>
 
+#include <Rcpp/sugar/functions/cumprod.h>
+#include <Rcpp/sugar/functions/cummin.h>
+#include <Rcpp/sugar/functions/cummax.h>
+
 #endif
+

inst/unitTests/cpp/sugar.cpp

@@ -670,3 +670,49 @@ double meanLogical(Rcpp::LogicalVector x) { return(Rcpp::mean(x)); }
 // [[Rcpp::export]]
 Rcomplex meanComplex(Rcpp::ComplexVector x) { return(Rcpp::mean(x)); }
 
+
+// 30 Oct 2015: cumprod, cummin, cummax
+
+// [[Rcpp::export]]
+NumericVector runit_cumprod_nv(NumericVector xx){
+    NumericVector res = cumprod(xx) ;
+    return res ;
+}
+
+// [[Rcpp::export]]
+IntegerVector runit_cumprod_iv(IntegerVector xx){
+    IntegerVector res = cumprod(xx) ;
+    return res ;
+}
+
+// [[Rcpp::export]]
+ComplexVector runit_cumprod_cv(ComplexVector xx){
+    ComplexVector res = cumprod(xx) ;
+    return res ;
+}
+
+// [[Rcpp::export]]
+NumericVector runit_cummin_nv(NumericVector xx){
+    NumericVector res = cummin(xx) ;
+    return res ;
+}
+
+// [[Rcpp::export]]
+IntegerVector runit_cummin_iv(IntegerVector xx){
+    IntegerVector res = cummin(xx) ;
+    return res ;
+}
+
+// [[Rcpp::export]]
+NumericVector runit_cummax_nv(NumericVector xx){
+    NumericVector res = cummax(xx) ;
+    return res ;
+}
+
+// [[Rcpp::export]]
+IntegerVector runit_cummax_iv(IntegerVector xx){
+    IntegerVector res = cummax(xx) ;
+    return res ;
+}
+
+

inst/unitTests/runit.sugar.R

@@ -714,5 +714,67 @@ if (.runThisTest) {
         checkEquals(mean(v1), meanLogical(v1), "mean of logical vector")
         checkEquals(mean(v2), meanLogical(v2), "mean of logical vector with NA")
     }
+    
+    
+    ## 30 Oct 2015: cumprod, cummin, cummax
+    # base::cumprod defined for numeric, integer, and complex vectors
+    test.sugar.cumprod_nv <- function() {
+        fx <- runit_cumprod_nv
+        x <- rnorm(10)
+        checkEquals(fx(x), cumprod(x))
+        x[4] <- NA
+        checkEquals(fx(x), cumprod(x))
+    }
+    
+    test.sugar.cumprod_iv <- function() {
+        fx <- runit_cumprod_iv
+        x <- as.integer(rpois(10, 5))
+        checkEquals(fx(x), cumprod(x))
+        x[4] <- NA
+        checkEquals(fx(x), cumprod(x))
+    }
+    
+    test.sugar.cumprod_cv <- function() {
+        fx <- runit_cumprod_cv
+        x <- rnorm(10) + 2i
+        checkEquals(fx(x), cumprod(x))
+        x[4] <- NA
+        checkEquals(fx(x), cumprod(x))
+    }
+    
+    # base::cummin defined for numeric and integer vectors
+    test.sugar.cummin_nv <- function() {
+        fx <- runit_cummin_nv
+        x <- rnorm(10)
+        checkEquals(fx(x), cummin(x))
+        x[4] <- NA
+        checkEquals(fx(x), cummin(x))
+    }
+    
+    test.sugar.cummin_iv <- function() {
+        fx <- runit_cummin_iv
+        x <- as.integer(rpois(10, 5))
+        checkEquals(fx(x), cummin(x))
+        x[4] <- NA
+        checkEquals(fx(x), cummin(x))
+    }
+    
+    # base::cummax defined for numeric and integer vectors
+    test.sugar.cummax_nv <- function() {
+        fx <- runit_cummax_nv
+        x <- rnorm(10)
+        checkEquals(fx(x), cummax(x))
+        x[4] <- NA
+        checkEquals(fx(x), cummax(x))
+    }
+    
+    test.sugar.cummax_iv <- function() {
+        fx <- runit_cummax_iv
+        x <- as.integer(rpois(10, 5))
+        checkEquals(fx(x), cummax(x))
+        x[4] <- NA
+        checkEquals(fx(x), cummax(x))
+    }
 
 }
+