src/adapters/a.EMGrank.c

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