pkg/src/adapters/a.EMGrank.c

   1 #include <R.h>
   2 #include <Rdefines.h>
   3 #include "EMGrank.h"
   4
   5 // See comments in src/sources/EMGrank.c and R/EMGrank.R (wrapper)
   6 SEXP EMGrank(
   7     SEXP Pi_,
   8     SEXP Rho_,
   9     SEXP mini_,
  10     SEXP maxi_,
  11     SEXP X_,
  12     SEXP Y_,
  13     SEXP eps_,
  14     SEXP rank_
  15 ) {
  16     // Get matrices dimensions
  17     SEXP dimX = getAttrib(X_, R_DimSymbol);
  18     int n = INTEGER(dimX)[0];
  19     int p = INTEGER(dimX)[1];
  20     SEXP dimRho = getAttrib(Rho_, R_DimSymbol);
  21     int m = INTEGER(dimRho)[0];
  22     int k = INTEGER(dimRho)[2];
  23
  24     ////////////
  25     // INPUTS //
  26     ////////////
  27
  28     // get scalar parameters
  29     int mini = INTEGER_VALUE(mini_);
  30     int maxi = INTEGER_VALUE(maxi_);
  31     double eps = NUMERIC_VALUE(eps_);
  32
  33     // Get pointers from SEXP arrays ; WARNING: by columns !
  34     double* Pi = REAL(Pi_);
  35     double* Rho = REAL(Rho_);
  36     double* X = REAL(X_);
  37     double* Y = REAL(Y_);
  38     int* rank = INTEGER(rank_);
  39
  40     /////////////
  41     // OUTPUTS //
  42     /////////////
  43
  44     SEXP phi, LLF, dimPhi;
  45     PROTECT(dimPhi = allocVector(INTSXP, 3));
  46     int* pDimPhi = INTEGER(dimPhi);
  47     pDimPhi[0] = p; pDimPhi[1] = m; pDimPhi[2] = k;
  48     PROTECT(phi = allocArray(REALSXP, dimPhi));
  49     PROTECT(LLF = allocVector(REALSXP, 1));
  50     double *pPhi=REAL(phi), *pLLF=REAL(LLF);
  51
  52     /////////////////////
  53     // Call to EMGrank //
  54     /////////////////////
  55
  56     EMGrank_core(Pi, Rho, mini, maxi, X, Y, eps, rank,
  57         pPhi,pLLF,
  58         n,p,m,k);
  59
  60     // Build list from OUT params and return it
  61     SEXP listParams, listNames;
  62     PROTECT(listParams = allocVector(VECSXP, 2));
  63     char* lnames[2] = {"phi", "LLF"}; //lists labels
  64     PROTECT(listNames = allocVector(STRSXP,2));
  65     for (int i=0; i<2; i++)
  66         SET_STRING_ELT(listNames,i,mkChar(lnames[i]));
  67     setAttrib(listParams, R_NamesSymbol, listNames);
  68     SET_VECTOR_ELT(listParams, 0, phi);
  69     SET_VECTOR_ELT(listParams, 1, LLF);
  70
  71     UNPROTECT(5);
  72     return listParams;
  73 }