X-Git-Url: https://git.auder.net/?a=blobdiff_plain;f=pkg%2Fsrc%2Fa.EMGrank.c;fp=pkg%2Fsrc%2Fa.EMGrank.c;h=8da760d99a2f062e425b23d1ad1e4c5fb7f86451;hb=1196a43d961a95abc18d3c8e777e9a4e8233e562;hp=0000000000000000000000000000000000000000;hpb=859c30ec72871f923da0498c14a94e67b0219875;p=valse.git

diff --git a/pkg/src/a.EMGrank.c b/pkg/src/a.EMGrank.c
new file mode 100644
index 0000000..8da760d
--- /dev/null
+++ b/pkg/src/a.EMGrank.c
@@ -0,0 +1,73 @@
+#include <R.h>
+#include <Rdefines.h>
+#include "EMGrank.h"
+
+// See comments in src/sources/EMGrank.c and R/EMGrank.R (wrapper)
+SEXP EMGrank(
+	SEXP Pi_,
+	SEXP Rho_,
+	SEXP mini_,
+	SEXP maxi_,
+	SEXP X_,
+	SEXP Y_,
+	SEXP eps_,
+	SEXP rank_
+) {
+	// Get matrices dimensions
+	SEXP dimX = getAttrib(X_, R_DimSymbol);
+	int n = INTEGER(dimX)[0];
+	int p = INTEGER(dimX)[1];
+	SEXP dimRho = getAttrib(Rho_, R_DimSymbol);
+	int m = INTEGER(dimRho)[0];
+	int k = INTEGER(dimRho)[2];
+
+	////////////
+	// INPUTS //
+	////////////
+
+	// get scalar parameters
+	int mini = INTEGER_VALUE(mini_);
+	int maxi = INTEGER_VALUE(maxi_);
+	double eps = NUMERIC_VALUE(eps_);
+
+	// Get pointers from SEXP arrays ; WARNING: by columns !
+	double* Pi = REAL(Pi_);
+	double* Rho = REAL(Rho_);
+	double* X = REAL(X_);
+	double* Y = REAL(Y_);
+	int* rank = INTEGER(rank_);
+
+	/////////////
+	// OUTPUTS //
+	/////////////
+
+	SEXP phi, LLF, dimPhi;
+	PROTECT(dimPhi = allocVector(INTSXP, 3));
+	int* pDimPhi = INTEGER(dimPhi);
+	pDimPhi[0] = p; pDimPhi[1] = m; pDimPhi[2] = k;
+	PROTECT(phi = allocArray(REALSXP, dimPhi));
+	PROTECT(LLF = allocVector(REALSXP, 1));
+	double *pPhi=REAL(phi), *pLLF=REAL(LLF);
+
+	/////////////////////
+	// Call to EMGrank //
+	/////////////////////
+
+	EMGrank_core(Pi, Rho, mini, maxi, X, Y, eps, rank,
+		pPhi,pLLF,
+		n,p,m,k);
+
+	// Build list from OUT params and return it
+	SEXP listParams, listNames;
+	PROTECT(listParams = allocVector(VECSXP, 2));
+	char* lnames[2] = {"phi", "LLF"}; //lists labels
+	PROTECT(listNames = allocVector(STRSXP,2));
+	for (int i=0; i<2; i++)
+		SET_STRING_ELT(listNames,i,mkChar(lnames[i]));
+	setAttrib(listParams, R_NamesSymbol, listNames);
+	SET_VECTOR_ELT(listParams, 0, phi);
+	SET_VECTOR_ELT(listParams, 1, LLF);
+
+	UNPROTECT(5);
+	return listParams;
+}