weighted k-means has now a Rcpp interface and we added an empty routi…

…ne registration file to silence R CMD check.

R/RcppExports.R

@@ -0,0 +1,7 @@
+# Generated by using Rcpp::compileAttributes() -> do not edit by hand
+# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+kmnsw <- function(a_R, c_R, wh_R, k, iter) {
+    .Call('stream_kmnsw', PACKAGE = 'stream', a_R, c_R, wh_R, k, iter)
+}
+

R/kmeansW.R

@@ -53,22 +53,24 @@ kmeansW <- function(x, centers, weight = rep(1,nrow(x)),
         stop("'iter.max' must be positive")
     if (ncol(x) != ncol(centers))
         stop("must have same number of columns in 'x' and 'centers'")
-    Z <- .C("kmnsw", as.double(x), as.integer(m),
-            as.integer(ncol(x)),
-            centers = as.double(centers), as.double(weight),
-            as.integer(k), c1 = integer(m), nc = integer(k), 
-            as.integer(iter.max), wss = double(k),
-            ifault = as.integer(0), PACKAGE="stream")
+    #Z <- .Call("kmnsw", as.double(x), as.integer(m),
+    #        as.integer(ncol(x)),
+    #        centers = as.double(centers), as.double(weight),
+    #        as.integer(k), c1 = integer(m), nc = integer(k),
+    #        as.integer(iter.max), wss = double(k),
+    #       ifault = as.integer(0))
+    Z <- kmnsw(x, centers, weight, k, as.integer(iter.max))
     if (nstart >= 2 && !is.null(cn)) {
         best <- sum(Z$wss)
         for (i in 2:nstart) {
             centers <- cn[sample(1:mm, k), , drop = FALSE]
-            ZZ <-  .C("kmnsw", as.double(x), as.integer(m),
-                      as.integer(ncol(x)),
-                      centers = as.double(centers), as.double(weight),
-                      as.integer(k), c1 = integer(m), nc = integer(k), 
-                      as.integer(iter.max), wss = double(k),
-                      ifault = as.integer(0L), PACKAGE="stream")
+            #ZZ <-  .Call("kmnsw", as.double(x), as.integer(m),
+            #          as.integer(ncol(x)),
+            #          centers = as.double(centers), as.double(weight),
+            #          as.integer(k), c1 = integer(m), nc = integer(k),
+            #          as.integer(iter.max), wss = double(k),
+            #          ifault = as.integer(0L))
+            ZZ <- kmnsw(x, centers, weight, k, as.integer(iter.max))
             if ((z <- sum(ZZ$wss)) < best) {
                 Z <- ZZ
                 best <- z

src/RcppExports.cpp

@@ -0,0 +1,22 @@
+// Generated by using Rcpp::compileAttributes() -> do not edit by hand
+// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+#include <Rcpp.h>
+
+using namespace Rcpp;
+
+// kmnsw
+Rcpp::List kmnsw(Rcpp::NumericMatrix a_R, Rcpp::NumericMatrix c_R, Rcpp::NumericVector wh_R, int k, int iter);
+RcppExport SEXP stream_kmnsw(SEXP a_RSEXP, SEXP c_RSEXP, SEXP wh_RSEXP, SEXP kSEXP, SEXP iterSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type a_R(a_RSEXP);
+    Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type c_R(c_RSEXP);
+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type wh_R(wh_RSEXP);
+    Rcpp::traits::input_parameter< int >::type k(kSEXP);
+    Rcpp::traits::input_parameter< int >::type iter(iterSEXP);
+    rcpp_result_gen = Rcpp::wrap(kmnsw(a_R, c_R, wh_R, k, iter));
+    return rcpp_result_gen;
+END_RCPP
+}

src/init.c

@@ -0,0 +1,10 @@
+// RegisteringDynamic Symbols
+
+#include <R.h>
+#include <Rinternals.h>
+#include <R_ext/Rdynload.h>
+
+void R_init_markovchain(DllInfo* info) {
+    R_registerRoutines(info, NULL, NULL, NULL, NULL);
+    R_useDynamicSymbols(info, TRUE);
+}

src/kmeansw.cc

@@ -16,23 +16,25 @@
 
 //
 
+#include <Rcpp.h>
+
 #include <cstdlib>
 #include <iomanip>
 #include <cmath>
 #include <ctime>
 #include "kmeansw.h"
 
+
 using namespace std;
 
 # define epsilon 1.0E-30 //NEW
 
 
-extern "C"  {
+//extern "C"  {
 //****************************************************************************80
 //MODIF function name: kmnsw
 //NEW   weight of each point variable: wh
-void kmnsw ( double *a, int *m_p, int *n_p, double *c, double *wh, int *k_p,
-                 int *ic1, int *nc, int *iter_p, double *wss, int *ifault )
+
 //****************************************************************************80
 //
 //     Purpose:
@@ -97,7 +99,39 @@ void kmnsw ( double *a, int *m_p, int *n_p, double *c, double *wh, int *k_p,
 //
 //NEW    Output, double WHC(K), the weight of each cluster.
 //
+
+// [[Rcpp::export]]
+Rcpp::List kmnsw (Rcpp::NumericMatrix a_R,
+            Rcpp::NumericMatrix c_R, Rcpp::NumericVector wh_R, int k,
+            int iter)
 {
+            //int *ic1, int *nc, int iter, double *wss, int *ifault )
+
+
+  Rcpp::List ret;
+
+  int ifault_;
+  int *ifault = &ifault_;
+  int m = a_R.nrow();
+  int n = a_R.ncol();
+  std::vector<double> a_ = Rcpp::as<std::vector<double> >(a_R);
+  double *a = &a_[0];
+
+  std::vector<double> c_ = Rcpp::as<std::vector<double> >(c_R);
+  double *c = &c_[0];
+
+  std::vector<double> wh_ = Rcpp::as<std::vector<double> >(wh_R);
+  double *wh = &wh_[0];
+
+  std::vector<int> ic1_(m);
+  int *ic1 = &ic1_[0];
+
+  std::vector<int> nc_(k);
+  int *nc = &nc_[0];
+
+  std::vector<double> wss_(k);
+  double *wss = &wss_[0];
+
   //DEL  double aa;
   double da;
   double db;
@@ -117,14 +151,14 @@ void kmnsw ( double *a, int *m_p, int *n_p, double *c, double *wh, int *k_p,
   int *live;
   int *ncp;
   double *whc; //NEW
-  int m=*m_p, n=*n_p, k=*k_p, iter=*iter_p; //NEW
 
   *ifault = 0;
 
   if ( k <= 1 || m <= k )
   {
     *ifault = 3;
-    return;
+    ret["ifault"] = *ifault;
+    return ret;
   }
   d = new double[m];
   ic2 = new int[m];
@@ -218,7 +252,8 @@ void kmnsw ( double *a, int *m_p, int *n_p, double *c, double *wh, int *k_p,
   {
     if ( whc[l-1] < epsilon ) //MODIF
     {
-      return;
+      ret["ifault"] = *ifault;
+      return ret;
     }
   }
 
@@ -341,18 +376,23 @@ void kmnsw ( double *a, int *m_p, int *n_p, double *c, double *wh, int *k_p,
       wss[ii-1] = wss[ii-1] + da * da * wh[i-1]; //MODIF
     }
   }
-  
+
   delete [] d;
   delete [] ic2;
   delete [] itran;
   delete [] live;
   delete [] ncp;
   delete [] whc; //NEW
 
-  return;
+  ret["c1"] = Rcpp::wrap(ic1_);
+  ret["centers"] = Rcpp::wrap(c_);
+  ret["nc"] = Rcpp::wrap(nc_);
+  ret["wss"] = Rcpp::wrap(wss_);
+  ret["ifault"] = *ifault;
+  return ret;
 }
 
-} // extern "C"
+//} // extern "C"
 
 //****************************************************************************80
 //DEL   variables: an1, an2

src/kmeansw.h

@@ -19,10 +19,10 @@
 #ifndef KMEANSW_H
 #define KMEANSW_H
 
-extern "C" {
+//extern "C" {
 void kmnsw ( double *a, int *mR, int *nR, double *c, double *wh, int *kR, int *ic1, int *nc,
              int *iterR, double *wss, int *ifault );
-}
+//}
 
 void optra ( double a[], int m, int n, double c[], double wh[], double whc[], int k, int ic1[],
              int ic2[], int nc[], int ncp[], double d[],