Pass R CMD check --as-cran
[valse.git] / pkg / src / 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 }