outliertree 0.2.1 → 0.3.0

data/vendor/outliertree/src/Rwrapper.cpp

@@ -1,5 +1,9 @@
+#ifdef _FOR_R
+
 #include <Rcpp.h>
+#include <Rcpp/unwindProtect.h>
 // [[Rcpp::plugins(cpp11)]]
+// [[Rcpp::plugins(unwindProtect)]]
 
 /* This is to serialize the model objects */
 // [[Rcpp::depends(Rcereal)]]
@@ -7,14 +11,22 @@
 #include <cereal/types/vector.hpp>
 #include <sstream>
 #include <string>
+#include <limits>
 
 /* This is the package's header */
 #include "outlier_tree.hpp"
 
+SEXP alloc_RawVec(void *data)
+{
+    size_t vec_size = *(size_t*)data;
+    if (vec_size > (size_t)std::numeric_limits<R_xlen_t>::max())
+        Rcpp::stop("Resulting model is too large for R to handle.");
+    return Rcpp::RawVector((R_xlen_t)vec_size);
+}
+
 /* for model serialization and re-usage in R */
 /* https://stackoverflow.com/questions/18474292/how-to-handle-c-internal-data-structure-in-r-in-order-to-allow-save-load */
 /* this extra comment below the link is a workaround for Rcpp issue 675 in GitHub, do not remove it */
-#include <Rinternals.h>
 Rcpp::RawVector serialize_OutlierTree(ModelOutputs *model_outputs)
 {
     std::stringstream ss;
@@ -23,27 +35,60 @@ Rcpp::RawVector serialize_OutlierTree(ModelOutputs *model_outputs)
         oarchive(*model_outputs);
     }
     ss.seekg(0, ss.end);
-    Rcpp::RawVector retval(ss.tellg());
+    std::stringstream::pos_type vec_size = ss.tellg();
+    if (vec_size <= 0) {
+        Rcpp::Rcerr << "Error: model is too big to serialize, resulting object will not be usable.\n" << std::endl;
+        return Rcpp::RawVector();
+    }
+    size_t vec_size_ = (size_t)vec_size;
+    Rcpp::RawVector retval = Rcpp::unwindProtect(alloc_RawVec, (void*)&vec_size_);
+    if (!retval.size())
+        return retval;
     ss.seekg(0, ss.beg);
-    ss.read(reinterpret_cast<char*>(&retval[0]), retval.size());
+    ss.read(reinterpret_cast<char*>(RAW(retval)), retval.size());
     return retval;
 }
 
-// [[Rcpp::export]]
-SEXP deserialize_OutlierTree(Rcpp::RawVector src)
+SEXP safe_XPtr(void *model_ptr)
+{
+    return Rcpp::XPtr<ModelOutputs>((ModelOutputs*)model_ptr, true);
+}
+
+void R_delete_model(SEXP R_ptr)
+{
+    ModelOutputs *model = static_cast<ModelOutputs*>(R_ExternalPtrAddr(R_ptr));
+    delete model;
+    R_ClearExternalPtr(R_ptr);
+}
+
+// [[Rcpp::export(rng = false)]]
+SEXP deserialize_OutlierTree(Rcpp::RawVector src, SEXP ptr_obj)
 {
     std::stringstream ss;
-    ss.write(reinterpret_cast<char*>(&src[0]), src.size());
+    ss.write(reinterpret_cast<char*>(RAW(src)), src.size());
     ss.seekg(0, ss.beg);
     std::unique_ptr<ModelOutputs> model_outputs = std::unique_ptr<ModelOutputs>(new ModelOutputs());
     {
         cereal::BinaryInputArchive iarchive(ss);
         iarchive(*model_outputs);
     }
-    return Rcpp::XPtr<ModelOutputs>(model_outputs.release(), true);
+    R_SetExternalPtrAddr(ptr_obj, model_outputs.get());
+    R_RegisterCFinalizerEx(ptr_obj, R_delete_model, TRUE);
+    model_outputs.release();
+    return R_NilValue;
 }
 
-// [[Rcpp::export]]
+SEXP safe_int(void *x)
+{
+    return Rcpp::wrap(*(int*)x);
+}
+
+SEXP safe_bool(void *x)
+{
+    return Rcpp::wrap(*(bool*)x);
+}
+
+// [[Rcpp::export(rng = false)]]
 Rcpp::LogicalVector check_null_ptr_model(SEXP ptr_model)
 {
     return Rcpp::LogicalVector(R_ExternalPtrAddr(ptr_model) == NULL);
@@ -59,12 +104,22 @@ double* set_R_nan_as_C_nan(double *restrict x_R, std::vector<double> &x_C, size_
     return x_C.data();
 }
 
+double* set_R_nan_as_C_nan(double *restrict x_R, Rcpp::NumericVector &x_C, size_t n, int nthreads)
+{
+    x_C = Rcpp::NumericVector(x_R, x_R + n);
+    #pragma omp parallel for schedule(static) num_threads(nthreads) shared(x_R, x_C, n)
+    for (size_t_for i = 0; i < n; i++)
+        if (isnan(x_R[i]) || Rcpp::NumericVector::is_na(x_R[i]) || Rcpp::traits::is_nan<REALSXP>(x_R[i]))
+            x_C[i] = NAN;
+    return REAL(x_C);
+}
+
 
 /* for predicting outliers */
 Rcpp::List describe_outliers(ModelOutputs &model_outputs,
-                             double *arr_num,
-                             int    *arr_cat,
-                             int    *arr_ord,
+                             double *restrict arr_num,
+                             int    *restrict arr_cat,
+                             int    *restrict arr_ord,
                              Rcpp::ListOf<Rcpp::StringVector> cat_levels,
                              Rcpp::ListOf<Rcpp::StringVector> ord_levels,
                              Rcpp::StringVector colnames_num,
@@ -345,6 +400,12 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                         }
                         break;
                     }
+
+                    default:
+                    {
+                        assert(0);
+                        break;
+                    }
                 }
                 
                 /* add the comparison point */
@@ -377,6 +438,11 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                 cond_clust["value_comp"] = Rcpp::as<Rcpp::CharacterVector>(NA_STRING);
                                 break;
                             }
+
+                            default:
+                            {
+                                unexpected_error();
+                            }
                         }
                         break;
                     }
@@ -492,6 +558,12 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                         }
                         break;
                     }
+
+                    default:
+                    {
+                        assert(0);
+                        break;
+                    }
                     
                 }
                 lst_cond[row] = Rcpp::List::create(Rcpp::clone(cond_clust));
@@ -528,6 +600,12 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                 cond_clust["column"] = Rcpp::as<Rcpp::CharacterVector>(colnames_ord[model_outputs.all_trees[outl_col][curr_tree].col_num]);
                                 break;
                             }
+
+                            default:
+                            {
+                                assert(0);
+                                break;
+                            }
                         }
 
                         /* add conditions from tree */
@@ -599,6 +677,7 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                         break;
                                     }
 
+                                    default: {}
                                 }
                                 break;
                             }
@@ -696,6 +775,7 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                         break;
                                     }
 
+                                    default: {}
                                 }
                                 break;
                             }
@@ -758,10 +838,16 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                         break;
                                     }
 
+                                    default: {}
                                 }
                                 break;
                             }
 
+                            default:
+                            {
+                                assert(0);
+                                break;
+                            }
                         }
                     }
 
@@ -796,6 +882,12 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                 cond_clust["column"] = Rcpp::as<Rcpp::CharacterVector>(colnames_ord[model_outputs.all_trees[outl_col][parent_tree].col_num]);
                                 break;
                             }
+
+                            default:
+                            {
+                                assert(0);
+                                break;
+                            }
                         }
 
 
@@ -835,6 +927,11 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                         cond_clust["value_comp"] = Rcpp::as<Rcpp::CharacterVector>(NA_STRING);
                                         break;
                                     }
+
+                                    default:
+                                    {
+                                        unexpected_error();
+                                    }
                                 }
                                 break;
                             }
@@ -1011,6 +1108,11 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
                                 break;
                             }
 
+                            default:
+                            {
+                                assert(0);
+                                break;
+                            }
                         }
 
                         
@@ -1038,6 +1140,37 @@ Rcpp::List describe_outliers(ModelOutputs &model_outputs,
     return outp;
 }
 
+struct args_describe_outliers {
+    ModelOutputs *model_outputs;
+    double *arr_num;
+    int    *arr_cat;
+    int    *arr_ord;
+    Rcpp::ListOf<Rcpp::StringVector> *cat_levels;
+    Rcpp::ListOf<Rcpp::StringVector> *ord_levels;
+    Rcpp::StringVector *colnames_num;
+    Rcpp::StringVector *colnames_cat;
+    Rcpp::StringVector *colnames_ord;
+    Rcpp::NumericVector *min_date;
+    Rcpp::NumericVector *min_ts;
+};
+
+SEXP describe_outliers_wrapper(void *args_)
+{
+    args_describe_outliers *args = (args_describe_outliers*)args_;
+    return describe_outliers(*(args->model_outputs),
+                             args->arr_num,
+                             args->arr_cat,
+                             args->arr_ord,
+                             *(args->cat_levels),
+                             *(args->ord_levels),
+                             *(args->colnames_num),
+                             *(args->colnames_cat),
+                             *(args->colnames_ord),
+                             *(args->min_date),
+                             *(args->min_ts));
+}
+
+
 /* for extracting info about flaggable outliers */
 Rcpp::List extract_outl_bounds(ModelOutputs &model_outputs,
                                Rcpp::ListOf<Rcpp::StringVector> cat_levels,
@@ -1102,9 +1235,27 @@ Rcpp::List extract_outl_bounds(ModelOutputs &model_outputs,
     return outp;
 }
 
+struct args_extract_outl_bounds {
+    ModelOutputs *model_outputs;
+    Rcpp::ListOf<Rcpp::StringVector> *cat_levels;
+    Rcpp::ListOf<Rcpp::StringVector> *ord_levels;
+    Rcpp::NumericVector *min_date;
+    Rcpp::NumericVector *min_ts;
+};
+
+SEXP extract_outl_bounds_wrapper(void *args_)
+{
+    args_extract_outl_bounds *args = (args_extract_outl_bounds*)args_;
+    return extract_outl_bounds(*(args->model_outputs),
+                               *(args->cat_levels),
+                               *(args->ord_levels),
+                               *(args->min_date),
+                               *(args->min_ts));
+}
+
 
 /* external functions for fitting the model and predicting outliers */
-// [[Rcpp::export]]
+// [[Rcpp::export(rng = false)]]
 Rcpp::List fit_OutlierTree(Rcpp::NumericVector arr_num, size_t ncols_numeric,
                            Rcpp::IntegerVector arr_cat, size_t ncols_categ,   Rcpp::IntegerVector ncat,
                            Rcpp::IntegerVector arr_ord, size_t ncols_ord,     Rcpp::IntegerVector ncat_ord,
@@ -1121,8 +1272,17 @@ Rcpp::List fit_OutlierTree(Rcpp::NumericVector arr_num, size_t ncols_numeric,
                            Rcpp::NumericVector min_date,
                            Rcpp::NumericVector min_ts)
 {
+    Rcpp::List outp = Rcpp::List::create(
+        Rcpp::_["ptr_model"] = R_NilValue,
+        Rcpp::_["serialized_obj"] = R_NilValue,
+        Rcpp::_["bounds"] = R_NilValue,
+        Rcpp::_["outliers_info"] = R_NilValue,
+        Rcpp::_["ntrees"] = R_NilValue,
+        Rcpp::_["nclust"] = R_NilValue,
+        Rcpp::_["found_outliers"] = R_NilValue
+    );
+
     bool found_outliers;
-    Rcpp::List outp;
     size_t tot_cols = ncols_numeric + ncols_categ + ncols_ord;
     std::vector<char> cols_ignore;
     char *cols_ignore_ptr = NULL;
@@ -1132,54 +1292,70 @@ Rcpp::List fit_OutlierTree(Rcpp::NumericVector arr_num, size_t ncols_numeric,
         cols_ignore_ptr = &cols_ignore[0];
     }
     std::vector<double> Xcpp;
-    double *arr_num_C = set_R_nan_as_C_nan(&arr_num[0], Xcpp, arr_num.size(), nthreads);
+    double *arr_num_C = set_R_nan_as_C_nan(REAL(arr_num), Xcpp, arr_num.size(), nthreads);
 
     std::unique_ptr<ModelOutputs> model_outputs = std::unique_ptr<ModelOutputs>(new ModelOutputs());
+    try {
     found_outliers = fit_outliers_models(*model_outputs,
                                          arr_num_C, ncols_numeric,
-                                         &arr_cat[0], ncols_categ, &ncat[0],
-                                         &arr_ord[0], ncols_ord,   &ncat_ord[0],
+                                         INTEGER(arr_cat), ncols_categ, INTEGER(ncat),
+                                         INTEGER(arr_ord), ncols_ord,   INTEGER(ncat_ord),
                                          nrows, cols_ignore_ptr, nthreads,
                                          categ_as_bin, ord_as_bin, cat_bruteforce_subset, categ_from_maj, take_mid,
                                          max_depth, max_perc_outliers, min_size_numeric, min_size_categ,
                                          min_gain, gain_as_pct, follow_all, z_norm, z_outlier);
 
-    outp["bounds"] = extract_outl_bounds(*model_outputs,
-                                         cat_levels,
-                                         ord_levels,
-                                         min_date,
-                                         min_ts);
-
+    args_extract_outl_bounds temp = {
+        model_outputs.get(),
+        &cat_levels,
+        &ord_levels,
+        &min_date,
+        &min_ts
+    };
+    outp["bounds"] = Rcpp::unwindProtect(extract_outl_bounds_wrapper, (void*)&temp);
     outp["serialized_obj"] = serialize_OutlierTree(model_outputs.get());
+    } catch(std::bad_alloc &e) {
+        Rcpp::stop("Insufficient memory.\n");
+    }
+
+    if (!Rf_xlength(outp["serialized_obj"]))
+        return outp;
     if (return_outliers) {
-        outp["outliers_info"] = describe_outliers(*model_outputs,
-                                                  arr_num_C,
-                                                  &arr_cat[0],
-                                                  &arr_ord[0],
-                                                  cat_levels,
-                                                  ord_levels,
-                                                  colnames_num,
-                                                  colnames_cat,
-                                                  colnames_ord,
-                                                  min_date,
-                                                  min_ts);
+        args_describe_outliers temp = {
+            model_outputs.get(),
+            arr_num_C,
+            INTEGER(arr_cat),
+            INTEGER(arr_ord),
+            &cat_levels,
+            &ord_levels,
+            &colnames_num,
+            &colnames_cat,
+            &colnames_ord,
+            &min_date,
+            &min_ts
+        };
+        outp["outliers_info"] = Rcpp::unwindProtect(describe_outliers_wrapper, (void*)&temp);
     }
+    forget_row_outputs(*model_outputs);
+
     /* add number of trees and clusters */
     size_t ntrees = 0, nclust = 0;
     for (size_t col = 0; col < model_outputs->all_trees.size(); col++) {
     	ntrees += model_outputs->all_trees[col].size();
     	nclust += model_outputs->all_clusters[col].size();
     }
-    outp["ntrees"] = Rcpp::wrap((int) ntrees);
-    outp["nclust"] = Rcpp::wrap((int) nclust);
-    outp["found_outliers"] = Rcpp::wrap(found_outliers);
+    int ntrees_int = (int)ntrees;
+    int nclust_int = (int)nclust;
+    outp["ntrees"] = Rcpp::unwindProtect(safe_int, (void*)&ntrees_int);
+    outp["nclust"] = Rcpp::unwindProtect(safe_int, (void*)&nclust_int);
+    outp["found_outliers"] = Rcpp::unwindProtect(safe_bool, (void*)&found_outliers);
     
-    forget_row_outputs(*model_outputs);
-    outp["ptr_model"] = Rcpp::XPtr<ModelOutputs>(model_outputs.release(), true);
+    outp["ptr_model"] = Rcpp::unwindProtect(safe_XPtr, model_outputs.get());
+    model_outputs.release();
     return outp;
 }
 
-// [[Rcpp::export]]
+// [[Rcpp::export(rng = false)]]
 Rcpp::List predict_OutlierTree(SEXP ptr_model, size_t nrows, int nthreads,
                                Rcpp::NumericVector arr_num, Rcpp::IntegerVector arr_cat, Rcpp::IntegerVector arr_ord,
                                Rcpp::ListOf<Rcpp::StringVector> cat_levels,
@@ -1190,36 +1366,59 @@ Rcpp::List predict_OutlierTree(SEXP ptr_model, size_t nrows, int nthreads,
                                Rcpp::NumericVector min_date,
                                Rcpp::NumericVector min_ts)
 {
-    std::vector<double> Xcpp;
-    double *arr_num_C = set_R_nan_as_C_nan(&arr_num[0], Xcpp, arr_num.size(), nthreads);
+    Rcpp::NumericVector Xcpp;
+    double *arr_num_C = set_R_nan_as_C_nan(REAL(arr_num), Xcpp, arr_num.size(), nthreads);
 
     ModelOutputs *model_outputs = static_cast<ModelOutputs*>(R_ExternalPtrAddr(ptr_model));
-    bool found_outliers = find_new_outliers(&arr_num[0], &arr_cat[0], &arr_ord[0],
+    bool found_outliers = find_new_outliers(arr_num_C, INTEGER(arr_cat), INTEGER(arr_ord),
                                             nrows, nthreads, *model_outputs);
-    Rcpp::List outp = describe_outliers(*model_outputs,
-                                        arr_num_C,
-                                        &arr_cat[0],
-                                        &arr_ord[0],
-                                        cat_levels,
-                                        ord_levels,
-                                        colnames_num,
-                                        colnames_cat,
-                                        colnames_ord,
-                                        min_date,
-                                        min_ts);
-    outp["found_outliers"] = Rcpp::LogicalVector(found_outliers);
+    args_describe_outliers temp = {
+        model_outputs,
+        arr_num_C,
+        INTEGER(arr_cat),
+        INTEGER(arr_ord),
+        &cat_levels,
+        &ord_levels,
+        &colnames_num,
+        &colnames_cat,
+        &colnames_ord,
+        &min_date,
+        &min_ts
+    };
+
+    Rcpp::List outp;
+    try {
+        outp = Rcpp::unwindProtect(describe_outliers_wrapper, (void*)&temp);
+    } catch(...) {
+        forget_row_outputs(*model_outputs);
+        throw;
+    }
     forget_row_outputs(*model_outputs);
+    outp["found_outliers"] = Rcpp::LogicalVector(found_outliers);
     return outp;
 }
 
-// [[Rcpp::export]]
+// [[Rcpp::export(rng = false)]]
 Rcpp::LogicalVector check_few_values(Rcpp::NumericVector arr_num, size_t nrows, size_t ncols, int nthreads)
 {
-    std::vector<char> too_few_vals(ncols, 0);
-    check_more_two_values(&arr_num[0], nrows, ncols, nthreads, too_few_vals.data());
     Rcpp::LogicalVector outp(ncols);
+    std::vector<char> too_few_vals(ncols, 0);
+    check_more_two_values(REAL(arr_num), nrows, ncols, nthreads, too_few_vals.data());
     for (size_t col = 0; col < ncols; col++) {
         outp[col] = (bool) too_few_vals[col];
     }
     return outp;
 }
+
+
+// [[Rcpp::export(rng = false)]]
+bool R_has_openmp()
+{
+    #ifdef _OPENMP
+    return true;
+    #else
+    return false;
+    #endif
+}
+
+#endif /* _FOR_R */

data/vendor/outliertree/src/cat_outlier.cpp

@@ -74,7 +74,7 @@
 */
 void find_outlier_categories(size_t categ_counts[], size_t ncateg, size_t tot, double max_perc_outliers,
                              long double perc_threshold[], size_t buffer_ix[], long double buffer_perc[],
-                             double z_norm, char is_outlier[], bool *found_outliers, bool *new_is_outlier,
+                             double z_norm, signed char is_outlier[], bool *found_outliers, bool *new_is_outlier,
                              double *next_most_comm)
 {
     //TODO: must also establish bounds for new, unseen categories
@@ -90,7 +90,7 @@ void find_outlier_categories(size_t categ_counts[], size_t ncateg, size_t tot, d
     size_t size_tail = 0;
 
     /* reset the temporary arrays and fill them */
-    memset(is_outlier, 0, ncateg * sizeof(char));
+    memset(is_outlier, 0, ncateg * sizeof(signed char));
     for (size_t cat = 0; cat < ncateg; cat++) {
         buffer_ix[cat] = cat;
         buffer_perc[cat] = (categ_counts[cat] > 0)? ((long double)categ_counts[cat] / tot_dbl) : 0;
@@ -225,13 +225,13 @@ void find_outlier_categories(size_t categ_counts[], size_t ncateg, size_t tot, d
 *        Category to which the majority of the observations belong.
 */
 void find_outlier_categories_by_maj(size_t categ_counts[], size_t ncateg, size_t tot, double max_perc_outliers,
-                                    long double prior_prob[], double z_outlier, char is_outlier[],
+                                    long double prior_prob[], double z_outlier, signed char is_outlier[],
                                     bool *found_outliers, bool *new_is_outlier, int *categ_maj)
 {
     /* initialize parameters as needed */
     *found_outliers = false;
     *new_is_outlier = false;
-    memset(is_outlier, 0, ncateg * sizeof(char));
+    memset(is_outlier, 0, ncateg * sizeof(signed char));
     size_t max_outliers = (size_t) calculate_max_outliers((long double)tot, max_perc_outliers);
     long double tot_dbl = (long double) (tot + 1);
     size_t n_non_maj;
@@ -283,7 +283,7 @@ void find_outlier_categories_by_maj(size_t categ_counts[], size_t ncateg, size_t
 *        Proportion of the least common non-outlier category.
 */
 bool find_outlier_categories_no_cond(size_t categ_counts[], size_t ncateg, size_t tot,
-                                     char is_outlier[], double *next_most_comm)
+                                     signed char is_outlier[], double *next_most_comm)
 {
     /* if sample is too small, don't flag any as outliers */
     if (tot < 1000) return false;
@@ -296,7 +296,7 @@ bool find_outlier_categories_no_cond(size_t categ_counts[], size_t ncateg, size_
 
     /* look if there's any category meeting the first condition and none meeting the second one */
     bool has_outlier_cat = false;
-    memset(is_outlier, 0, sizeof(char) * ncateg);
+    memset(is_outlier, 0, sizeof(signed char) * ncateg);
     for (size_t cat = 0; cat < ncateg; cat++) {
         if (categ_counts[cat] > max_outliers && categ_counts[cat] < max_next_most_comm) {
             has_outlier_cat = false;