73 lines
3.1 KiB
C
73 lines
3.1 KiB
C
#include "cve.h"
|
|
|
|
/**
|
|
* Calles a R function passed to the algoritm and supplied intermidiate
|
|
* optimization values for logging the optimization progress.
|
|
* The supplied parameters to the logger functions are as follows:
|
|
* - attempt: Attempts counter.
|
|
* - iter: Current iter staring with 0 as initial iter.
|
|
* - L: Per X_i to X_j pair loss.
|
|
* - V: Current estimated SDR null space basis.
|
|
* - tau: Step-size.
|
|
* - err: Error \eqn{|| V V^T - V_{tau} V_{tau}^T ||}.
|
|
*
|
|
* @param logger Pointer to a SEXP R object representing an R function.
|
|
* @param env Pointer to a SEXP R object representing an R environment.
|
|
* @param L Pointer to a SEXP R object representing an R environment.
|
|
* @param V Pointer memory area of size `nrowV * ncolV` storing `V`.
|
|
* @param nrowV Nr. of rows of `V`.
|
|
* @param ncolV Nr. of columns of `V`.
|
|
* @param G Pointer memory area of size `nrowG * ncolG` storing `G`.
|
|
* @param nrowG Nr. of rows of `G`.
|
|
* @param ncolG Nr. of columns of `G`.
|
|
* @param loss Current loss L(V).
|
|
* @param err Errof for break condition (0.0 befor first iteration).
|
|
* @param tau Current step-size.
|
|
*/
|
|
void callLogger(SEXP logger, SEXP env,
|
|
const int attempt, const int iter,
|
|
const double* L, const int lenL,
|
|
const double* V, const int nrowV, const int ncolV,
|
|
const double* G, const int nrowG, const int ncolG,
|
|
const double loss, const double err, const double tau) {
|
|
/* Create R objects to be passed to R logger function. */
|
|
// Attempt is converted from 0-indexed to 1-indexed as R index.
|
|
SEXP r_attempt = PROTECT(ScalarInteger(attempt + 1));
|
|
SEXP r_iter = PROTECT(ScalarInteger(iter + 1));
|
|
|
|
/* Create R representations of L, V and G */
|
|
SEXP r_L = PROTECT(allocVector(REALSXP, lenL));
|
|
SEXP r_V = PROTECT(allocMatrix(REALSXP, nrowV, ncolV));
|
|
SEXP r_G = PROTECT(allocMatrix(REALSXP, nrowG, ncolG));
|
|
/* Copy data to R objects */
|
|
memcpy(REAL(r_L), L, lenL * sizeof(double));
|
|
memcpy(REAL(r_V), V, nrowV * ncolV * sizeof(double));
|
|
memcpy(REAL(r_G), G, nrowG * ncolG * sizeof(double));
|
|
|
|
/* Build data list passed to logger */
|
|
SEXP data = PROTECT(allocVector(VECSXP, 6));
|
|
SET_VECTOR_ELT(data, 0, r_L);
|
|
SET_VECTOR_ELT(data, 1, r_V);
|
|
SET_VECTOR_ELT(data, 2, r_G);
|
|
SET_VECTOR_ELT(data, 3, PROTECT(ScalarReal(loss)));
|
|
SET_VECTOR_ELT(data, 4, PROTECT(ScalarReal(err < 0.0 ? NA_REAL : err)));
|
|
SET_VECTOR_ELT(data, 5, PROTECT(ScalarReal(tau)));
|
|
SEXP names = PROTECT(allocVector(STRSXP, 6));
|
|
SET_STRING_ELT(names, 0, mkChar("L"));
|
|
SET_STRING_ELT(names, 1, mkChar("V"));
|
|
SET_STRING_ELT(names, 2, mkChar("G"));
|
|
SET_STRING_ELT(names, 3, mkChar("loss"));
|
|
SET_STRING_ELT(names, 4, mkChar("err"));
|
|
SET_STRING_ELT(names, 5, mkChar("tau"));
|
|
setAttrib(data, R_NamesSymbol, names);
|
|
|
|
/* Create logger function call as R language expression. */
|
|
SEXP loggerCall = PROTECT(lang4(logger, r_attempt, r_iter, data));
|
|
|
|
/* Evaluate the logger function call expression. */
|
|
eval(loggerCall, env);
|
|
|
|
/* Unprotect created R objects. */
|
|
UNPROTECT(11);
|
|
}
|