add allow_overwrite incl test case

Author: mschubert

R/RcppExports.R

@@ -1,7 +1,7 @@
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
-cpp_stack <- function(array_list, along, fill) {
-    .Call('_narray_cpp_stack', PACKAGE = 'narray', array_list, along, fill)
+cpp_stack <- function(array_list, along, fill, ovr) {
+    .Call('_narray_cpp_stack', PACKAGE = 'narray', array_list, along, fill, ovr)
 }
 

R/stack.r

@@ -33,6 +33,6 @@ stack = function(..., along=length(dim(arrayList[[1]]))+1, fill=NA, drop=FALSE,
     }
 
     arrayList = vectors_to_row_or_col(arrayList, along=along)
-    result = cpp_stack(arrayList, along, fill)
+    result = cpp_stack(arrayList, along, fill, allow_overwrite)
     drop_if(result, drop)
 }

src/RcppExports.cpp

@@ -11,21 +11,22 @@ Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
 #endif
 
 // cpp_stack
-SEXP cpp_stack(List array_list, int along, SEXP fill);
-RcppExport SEXP _narray_cpp_stack(SEXP array_listSEXP, SEXP alongSEXP, SEXP fillSEXP) {
+SEXP cpp_stack(List array_list, int along, SEXP fill, bool ovr);
+RcppExport SEXP _narray_cpp_stack(SEXP array_listSEXP, SEXP alongSEXP, SEXP fillSEXP, SEXP ovrSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
     Rcpp::traits::input_parameter< List >::type array_list(array_listSEXP);
     Rcpp::traits::input_parameter< int >::type along(alongSEXP);
     Rcpp::traits::input_parameter< SEXP >::type fill(fillSEXP);
-    rcpp_result_gen = Rcpp::wrap(cpp_stack(array_list, along, fill));
+    Rcpp::traits::input_parameter< bool >::type ovr(ovrSEXP);
+    rcpp_result_gen = Rcpp::wrap(cpp_stack(array_list, along, fill, ovr));
     return rcpp_result_gen;
 END_RCPP
 }
 
 static const R_CallMethodDef CallEntries[] = {
-    {"_narray_cpp_stack", (DL_FUNC) &_narray_cpp_stack, 3},
+    {"_narray_cpp_stack", (DL_FUNC) &_narray_cpp_stack, 4},
     {NULL, NULL, 0}
 };
 

src/stack.cpp

@@ -4,7 +4,7 @@
 using namespace Rcpp;
 using namespace std;
 
-template<int RTYPE> Vector<RTYPE> cpp_stack_impl(List array_list, int along, Vector<RTYPE> fill) {
+template<int RTYPE> Vector<RTYPE> cpp_stack_impl(List array_list, int along, Vector<RTYPE> fill, bool ovr) {
     auto dimnames = vector<CharacterVector>(along); // dim: names along
     auto axmap = vector<unordered_map<string, int>>(along); // dim: element name->index
     auto ax_unnamed = vector<int>(along); // counter for unnamed dimension elements
@@ -105,7 +105,13 @@ template<int RTYPE> Vector<RTYPE> cpp_stack_impl(List array_list, int along, Vec
             }
 
 //            Rprintf("result[%i] = a[%i][%i]\n", *it[0] + dim_offset, ai, aidx);
-            result[*it[0] + dim_offset] = a[aidx];
+            int ri = *it[0] + dim_offset;
+            auto newval = a[aidx];
+            if (!ovr) {
+                if (! (result[ri] == fill[0] || result[ri] == newval))
+                    stop("Different values on same position and allow_overwrite=FALSE");
+            }
+            result[ri] = newval;
 
             it[0]++;
             for (int d=0; d<maxdim; d++) { // check if we're jumping dimensions
@@ -123,7 +129,7 @@ template<int RTYPE> Vector<RTYPE> cpp_stack_impl(List array_list, int along, Vec
 }
 
 // [[Rcpp::export]]
-SEXP cpp_stack(List array_list, int along, SEXP fill) {
+SEXP cpp_stack(List array_list, int along, SEXP fill, bool ovr) {
     auto max_type = NILSXP;
     for (int ai=0; ai<array_list.size(); ai++) {
         int cur_type = TYPEOF(array_list[ai]);
@@ -134,11 +140,11 @@ SEXP cpp_stack(List array_list, int along, SEXP fill) {
     }
 
     switch(max_type) {
-        case LGLSXP: return cpp_stack_impl<LGLSXP>(array_list, along, as<LogicalVector>(fill));
-        case INTSXP: return cpp_stack_impl<INTSXP>(array_list, along, as<IntegerVector>(fill));
-        case REALSXP: return cpp_stack_impl<REALSXP>(array_list, along, as<NumericVector>(fill));
-        case CPLXSXP: return cpp_stack_impl<CPLXSXP>(array_list, along, as<ComplexVector>(fill));
-        case STRSXP: return cpp_stack_impl<STRSXP>(array_list, along, as<CharacterVector>(fill));
+        case LGLSXP: return cpp_stack_impl<LGLSXP>(array_list, along, as<LogicalVector>(fill), ovr);
+        case INTSXP: return cpp_stack_impl<INTSXP>(array_list, along, as<IntegerVector>(fill), ovr);
+        case REALSXP: return cpp_stack_impl<REALSXP>(array_list, along, as<NumericVector>(fill), ovr);
+        case CPLXSXP: return cpp_stack_impl<CPLXSXP>(array_list, along, as<ComplexVector>(fill), ovr);
+        case STRSXP: return cpp_stack_impl<STRSXP>(array_list, along, as<CharacterVector>(fill), ovr);
         default: return R_NilValue; // this should not happen
     }
 }

tests/testthat/test-stack.r

@@ -91,6 +91,15 @@ test_that("keep_empty arg when stacking zero-length vectors", {
     expect_equal(re2, t(re3))
 })
 
+test_that("allow overwrite", {
+    ov = A
+    ov[1,1] = 10
+    expect_error(stack(ov, A, along=2))
+    expect_error(stack(A, ov, along=2))
+    expect_equal(stack(ov, A, along=2, allow_overwrite=TRUE), A)
+    expect_equal(stack(A, ov, along=2, allow_overwrite=TRUE), ov)
+})
+
 test_that("performance", {
     skip_on_cran()