#include "../include/rcore.h"
#include "../math/sparse.amat.h"
#include "../minimal/common.h"

/* evaluate a user-provided, custom decomposable score function. */
double custom_score_function(SEXP target, sparse_amat sam, SEXP data,
    SEXP custom_fn, SEXP custom_args, bool debugging) {

int i = 0, it = 0, npar = 0;
SEXP parents, call, args_iterator, result;

  /* gather the parent labels from the sparse adjacency matrix. */
  it = sparse_amat_node(sam, (char *)CHAR(STRING_ELT(target, 0)));
  npar = sam.rowptr[it + 1] - sam.rowptr[it];
  PROTECT(parents = allocVector(STRSXP, npar));
  for (i = 0; i < npar; i++)
    SET_STRING_ELT(parents, i, mkChar(sam.labels[sam.colidx[sam.rowptr[it] + i]]));

  /* allocate and populate the pairlist to be valuated. */
  PROTECT(args_iterator = call = allocLang(5));
  /* first slot, the function name. */
  SETCAR(args_iterator, custom_fn);
  args_iterator = CDR(args_iterator);
  /* second slot, the label of the target node. */
  SETCAR(args_iterator, target);
  args_iterator = CDR(args_iterator);
  /* third slot, the labels of the parents. */
  SETCAR(args_iterator, parents);
  args_iterator = CDR(args_iterator);
  /* fourth slot, the data. */
  SETCAR(args_iterator, data);
  args_iterator = CDR(args_iterator);
  /* fifth slot, the optional arguments passed as a list. */
  SETCAR(args_iterator, custom_args);
  /* evaluate the custom score function. */
  PROTECT(result = eval(call, R_GlobalEnv));

  /* the return value must be a scalar, real number. */
  if ((TYPEOF(result) != REALSXP) || (length(result) != 1))
    error("the score for node %s must be a scalar, real value.",
      CHAR(STRING_ELT(target, 0)));

  UNPROTECT(3);

  return NUM(result);

}/*CUSTOM_SCORE_FUNCTION*/
