#include "../../include/rcore.h"
#include "../../core/allocations.h"
#include "../../core/data.table.h"
#include "../../include/globals.h"
#include "../../minimal/common.h"
#include "../../minimal/data.frame.h"
#include "../../minimal/strings.h"
#include "../patterns.h"
#include "../tests.h"

/* user-provided test function; kept at the R/C boundary because it builds the
 * response and conditioning-set SEXPs and calls back into R for each node. */
static void rrd_custom(SEXP x, SEXP z, SEXP fixed, SEXP data, SEXP custom_fn,
    SEXP custom_args, double *pvalue, double alpha, bool debugging) {

int i = 0, j = 0, k = 0, l = 0, valid = length(z) - 1;
int *fixed_nodes = NULL;
bool *dropped_nodes = NULL;
SEXP yi, sxi, ff;

  PROTECT(yi = allocVector(STRSXP, 1));
  PROTECT(ff = match(fixed, z, 0));
  fixed_nodes = INTEGER(ff);
  dropped_nodes = Calloc1D(length(z), sizeof(bool));

  /* note that, unlike other round-robin patterns above, nodes are not removed
   * from consideration when they are found to be non-significant. */

  for (i = 0, l = 0; i < length(z); i++) {

    /* nothing to do once no candidate is left to test. */
    if (valid < 0)
      break;
    /* fixed nodes are not tested. */
    if (fixed_nodes[i] > 0)
      continue;

    /* iterate over the nodes, one at a time... */
    SET_STRING_ELT(yi, 0 , STRING_ELT(z, i));
    /* ... use all other nodes as the conditioning set... */
    PROTECT(sxi = allocVector(STRSXP, valid));
    for (j = 0, k = 0; j < length(z); j++)
      if ((j != i) && !dropped_nodes[j])
        SET_STRING_ELT(sxi, k++ , STRING_ELT(z, j));
    /* ... compute the test statistic, and fill the p-value array. */
    custom_test_function(x, yi, sxi, data, custom_fn, custom_args,
        pvalue + l);

    if (debugging) {

      int nsx = length(sxi);
      const char **cond = Calloc1D(nsx, sizeof(char *));

      for (j = 0; j < nsx; j++)
        cond[j] = CHAR(STRING_ELT(sxi, j));
      debug_test_outcome(CHAR(STRING_ELT(x, 0)), CHAR(STRING_ELT(yi, 0)), cond,
        nsx, pvalue[l], alpha);

      Free1D(cond);

    }/*THEN*/

    /* if the p-value is not significant... */
    if (pvalue[l] > alpha) {

      /* .. remove the node from consideration... */
      dropped_nodes[i] = TRUE;
      /* ...and adjust the size of the next conditioning set. */
      valid--;

    }/*THEN*/

    /* move on to the next p-value. */
    l++;

    UNPROTECT(1);

  }/*FOR*/


  Free1D(dropped_nodes);
  UNPROTECT(2);

}/*RRD_CUSTOM*/

SEXP roundrobin_test(SEXP x, SEXP z, SEXP fixed, SEXP data, SEXP test,
    SEXP alpha, SEXP extra_args, SEXP debug) {

double *pvalue = NULL, a = NUM(alpha);
bool debugging = isTRUE(debug);
const char *t = CHAR(STRING_ELT(test, 0));
test_e test_type = test_to_enum(t);
SEXP xx, zz, which_fixed, result;

  /* extract the variables from the data. */
  PROTECT(xx = c_dataframe_column(data, x, FALSE, TRUE));
  PROTECT(zz = c_dataframe_column(data, z, FALSE, TRUE));
  /* match fixed variables. */
  PROTECT(which_fixed = match(fixed, z, 0));
  /* allocate the return value. */
  PROTECT(result = allocVector(REALSXP, length(z) - length(fixed)));
  setAttrib(result, R_NamesSymbol, string_setdiff(z, fixed));
  pvalue = REAL(result);
  /* set all elements to zero. */
  memset(pvalue, '\0', length(result) * sizeof(double));

  if (IS_DISCRETE_ASYMPTOTIC_TEST(test_type)) {

    /* parametric tests for discrete variables. */
    tabular dtx = tabular_from_SEXP(xx, 0, 0, R_NilValue);
    tabular dtz = tabular_from_SEXP(zz, 0, 0, which_fixed);

    rrd_discrete(dtx, dtz, test_type, pvalue, a, debugging);

    FreeTAB(dtx);
    FreeTAB(dtz);

  }/*THEN*/
  else if ((test_type == COR) || (test_type == ZF) || (test_type == MI_G) ||
           (test_type == MI_G_SH)) {

    /* parametric tests for Gaussian variables; x and the round-robin set are
     * extracted together so x leads, and the fixed mask shifts by one to skip
     * it. */
    SEXP xz, wf;
    PROTECT(xz = c_dataframe_column_set(data, x, R_NilValue, z));
    PROTECT(wf = allocVector(INTSXP, length(which_fixed) + 1));
    INTEGER(wf)[0] = 0;
    for (int j = 0; j < length(which_fixed); j++)
      INTEGER(wf)[j + 1] = INTEGER(which_fixed)[j];
    tabular dt = tabular_from_SEXP(xz, 0, 0, wf);

    rrd_gaustests(dt, test_type, pvalue, a, debugging);

    FreeTAB(dt);
    UNPROTECT(2);

  }/*THEN*/
  else if (test_type == MI_CG) {

    /* conditional linear Gaussian test. */
    tabular dtx = tabular_from_SEXP(xx, 0, 0, R_NilValue);
    tabular dtz = tabular_from_SEXP(zz, 1, 1, which_fixed);

    rrd_micg(dtx, dtz, test_type, pvalue, a, debugging);

    FreeTAB(dtx);
    FreeTAB(dtz);

  }/*THEN*/
  else if (IS_DISCRETE_PERMUTATION_TEST(test_type)) {

    /* discrete permutation tests. */
    tabular dtx = tabular_from_SEXP(xx, 0, 0, R_NilValue);
    tabular dtz = tabular_from_SEXP(zz, 0, 0, which_fixed);
    int B = INT(getListElement(extra_args, "B"));

    rrd_dperm(dtx, dtz, test_type, pvalue, a, B, IS_SMC(test_type) ? a : 1,
      debugging);

    FreeTAB(dtx);
    FreeTAB(dtz);

  }/*THEN*/
  else if (IS_CONTINUOUS_PERMUTATION_TEST(test_type)) {

    /* continuous permutation tests; x leads the extracted set, fixed mask
     * shifts by one. */
    SEXP xz, wf;
    PROTECT(xz = c_dataframe_column_set(data, x, R_NilValue, z));
    PROTECT(wf = allocVector(INTSXP, length(which_fixed) + 1));
    INTEGER(wf)[0] = 0;
    for (int j = 0; j < length(which_fixed); j++)
      INTEGER(wf)[j + 1] = INTEGER(which_fixed)[j];
    tabular dt = tabular_from_SEXP(xz, 0, 0, wf);
    int B = INT(getListElement(extra_args, "B"));

    rrd_gperm(dt, test_type, pvalue, a, B, IS_SMC(test_type) ? a : 1,
      tabular_is_complete(dt), debugging);

    FreeTAB(dt);
    UNPROTECT(2);

  }/*THEN*/
  else if (test_type == CUSTOM_T) {

    /* user-provided test function. */
    SEXP custom_fn = getListElement(extra_args, "fun");
    SEXP custom_args = getListElement(extra_args, "args");

    rrd_custom(x, z, fixed, data, custom_fn, custom_args, pvalue, a, debugging);

  }/*THEN*/

  UNPROTECT(4);

  /* catch-all for unknown tests (after deallocating memory.) */
  if (test_type == ENOTEST)
    error("unknown test statistic '%s'.", t);

  /* increment the test counter. */
  test_counter += length(zz) - length(fixed);

  return result;

}/*ROUNDROBIN_TEST*/
