72 lines
2.1 KiB
C
72 lines
2.1 KiB
C
#include "cve.h"
|
|
|
|
// SEXP rStiefel_c(SEXP pin, SEXP qin) {
|
|
// int p = asInteger(pin);
|
|
// int q = asInteger(qin);
|
|
|
|
// SEXP Vout = PROTECT(allocMatrix(REALSXP, p, q));
|
|
|
|
// int workLen = 2 * (p + 1) * q;
|
|
// double *workMem = (double*)R_alloc(workLen, sizeof(double));
|
|
|
|
// rStiefel(p, q, REAL(Vout), workMem, workLen);
|
|
|
|
// UNPROTECT(1);
|
|
// return Vout;
|
|
// }
|
|
|
|
SEXP cve(SEXP X, SEXP Y, SEXP k, SEXP h,
|
|
SEXP method,
|
|
SEXP V, // initial
|
|
SEXP momentum, SEXP tau, SEXP tol,
|
|
SEXP slack, SEXP gamma,
|
|
SEXP epochs, SEXP attempts,
|
|
SEXP logger, SEXP loggerEnv) {
|
|
/* Handle logger parameter, set to NULL pointer if not a function. */
|
|
if (!(isFunction(logger) && isEnvironment(loggerEnv))) {
|
|
logger = (void*)0;
|
|
}
|
|
|
|
/* Get dimensions. */
|
|
int n = nrows(X);
|
|
int p = ncols(X);
|
|
int q = p - asInteger(k);
|
|
|
|
/* Convert types if needed. */
|
|
// TODO: implement! (or leave in calling R code?)
|
|
|
|
/* Create output list. */
|
|
SEXP Vout = PROTECT(allocMatrix(REALSXP, p, q));
|
|
SEXP Lout = PROTECT(allocVector(REALSXP, n));
|
|
|
|
/* Check `attempts`, if not positive use passed values of `V` as
|
|
* optimization start value without further attempts.
|
|
* Therefor, copy from `V` to `Vout`. */
|
|
if (asInteger(attempts) < 1L) {
|
|
// TODO: Check for
|
|
memcpy(REAL(Vout), REAL(V), p * q * sizeof(double));
|
|
}
|
|
|
|
/* Call CVE simple subroutine. */
|
|
cve_sub(n, p, q,
|
|
REAL(X), REAL(Y), asReal(h),
|
|
asInteger(method),
|
|
asReal(momentum), asReal(tau), asReal(tol),
|
|
asReal(slack), asReal(gamma),
|
|
asInteger(epochs), asInteger(attempts),
|
|
REAL(Vout), REAL(Lout),
|
|
logger, loggerEnv);
|
|
|
|
/* Build output list object with names "V", "L" */
|
|
SEXP out = PROTECT(allocVector(VECSXP, 2));
|
|
SET_VECTOR_ELT(out, 0, Vout);
|
|
SET_VECTOR_ELT(out, 1, Lout);
|
|
SEXP names = PROTECT(allocVector(STRSXP, 2));
|
|
SET_STRING_ELT(names, 0, mkChar("V"));
|
|
SET_STRING_ELT(names, 1, mkChar("L"));
|
|
setAttrib(out, R_NamesSymbol, names);
|
|
|
|
UNPROTECT(4);
|
|
return out;
|
|
}
|