void build_tau(double **data, double *tau, int *ncols, int *nrows,
int *imaginary, double *phi) {
int i = 0, j = 0, res_ncols = *ncols + 1;
double temp = 0;
double *mean = NULL, *mat = NULL;
/* allocate mean vector and covariance matrix. */
mean = alloc1dreal(*ncols);
mat = alloc1dreal((*ncols) * (*ncols));
/* compute the mean values. */
for (i = 0; i < *ncols; i++) {
for (j = 0 ; j < *nrows; j++)
mean[i] += data[i][j];
mean[i] /= (*nrows);
}/*FOR*/
/* compute the covariance matrix... */
c_covmat(data, mean, ncols, nrows, mat);
/* ... multiply it by the phi coefficient... */
for (i = 0; i < *ncols; i++)
for (j = 0; j < *ncols; j++)
mat[CMC(i, j, *ncols)] *= (*phi);
/* ... compute the pseudoinverse... */
c_ginv(mat, ncols, mat);
/* ... and store it in the bottom-right corner of the tau matrix. */
for (i = 1; i < res_ncols; i++)
for (j = 1; j < res_ncols; j++)
tau[CMC(i, j, res_ncols)] = mat[CMC(i - 1, j - 1, *ncols)];
/* fill the top-right and bottom-left corners. */
for (i = 1; i < *ncols + 1; i++) {
temp = 0;
for (j = 0; j < *ncols; j++)
temp += mean[j] * mat[CMC(j, i - 1, *ncols)];
tau[CMC(i, 0, res_ncols)] = tau[CMC(0, i, res_ncols)] = -temp;
}/*FOR*/
/* fill the top-left corner. */
for (i = 1; i < res_ncols; i++)
tau[CMC(0, 0, res_ncols)] += - mean[i - 1] * tau[CMC(i, 0, res_ncols)];
tau[CMC(0, 0, res_ncols)] += 1/((double) *imaginary);
/* perform the final (pseudo)inversion. */
c_ginv(tau, &res_ncols, tau);
}/*BUILD_TAU*/
/* conditional Monte Carlo simulation for correlation-based tests. */
SEXP gauss_cmcarlo(SEXP data, SEXP length, SEXP samples, SEXP test, SEXP alpha) {
int j = 0, k = 0, ncols = LENGTH(data), errcode = 0, *work = NULL, *perm = NULL;
int error_counter = 0, *B = INTEGER(samples), *num = INTEGER(length);
double observed = 0, permuted = 0, *yperm = NULL, *yorig = NULL, *res = NULL;
double enough = ceil(NUM(alpha) * (*B)) + 1;
double **column = NULL, *mean = NULL, *covariance = NULL, *covariance_backup = NULL;
double *u = NULL, *d = NULL, *vt = NULL;
SEXP result;
/* allocate the matrices needed for the SVD decomposition. */
u = alloc1dreal(ncols * ncols);
d = alloc1dreal(ncols);
vt = alloc1dreal(ncols * ncols);
/* allocate and initialize the result. */
PROTECT(result = allocVector(REALSXP, 1));
res = REAL(result);
*res = 0;
/* allocate and initialize an array of pointers for the variables. */
column = (double **) alloc1dpointer(ncols);
for (j = 0; j < ncols; j++)
column[j] = REAL(VECTOR_ELT(data, j));
/* cache the means of the variables (they are invariant under permutation). */
mean = alloc1dreal(ncols);
/* compute the mean values */
for (j = 0; j < ncols; j++) {
for (k = 0 ; k < *num; k++)
mean[j] += column[j][k];
mean[j] /= (*num);
}/*FOR*/
/* allocate and initialize the covariance matrix. */
covariance = alloc1dreal(ncols * ncols);
covariance_backup = alloc1dreal(ncols * ncols);
c_covmat(column, mean, &ncols, num, covariance);
memcpy(covariance_backup, covariance, ncols * ncols * sizeof(double));
/* substitute the original data with the fake column that will be permuted. */
yperm = alloc1dreal(*num);
yorig = column[1];
memcpy(yperm, yorig, *num * sizeof(double));
column[1] = yperm;
/* allocate the arrays needed by RandomPermutation. */
perm = alloc1dcont(*num);
work = alloc1dcont(*num);
/* initialize the random number generator. */
GetRNGstate();
/* pick up the observed value of the test statistic, then generate a set of
random permutations (all variable but the second are fixed) and check how
many tests are greater (in absolute value) than the original one.*/
switch(INT(test)) {
case GAUSSIAN_MUTUAL_INFORMATION:
case LINEAR_CORRELATION:
case FISHER_Z:
observed = c_fast_pcor(covariance, &ncols, u, d, vt, &errcode);
if (errcode)
error("an error (%d) occurred in the call to dgesvd().\n", errcode);
for (j = 0; j < (*B); j++) {
/* reset the error flag of the SVD Fortran routine. */
errcode = 0;
RandomPermutation(*num, perm, work);
for (k = 0; k < *num; k++)
yperm[k] = yorig[perm[k]];
/* restore the covariance matrix from the good copy. */
memcpy(covariance, covariance_backup, ncols * ncols * sizeof(double));
/* update the relevant covariances. */
c_update_covmat(column, mean, 1, &ncols, num, covariance);
permuted = c_fast_pcor(covariance, &ncols, u, d, vt, &errcode);
if (errcode != 0)
error_counter++;
if (fabs(permuted) > fabs(observed)) {
sequential_counter_check(*res);
}/*THEN*/
}/*FOR*/
if (error_counter > 0)
warning("unable to compute %d permutations due to errors in dgesvd().\n",
error_counter);
break;
}/*SWITCH*/
PutRNGstate();
/* save the observed p-value. */
*res /= *B;
UNPROTECT(1);
return result;
}/*GAUSS_CMCARLO*/
/* parametric tests for Gaussian variables. */
static double ct_gaustests(SEXP xx, SEXP yy, SEXP zz, int nobs, int ntests,
double *pvalue, double *df, test_e test) {
int i = 0, nsx = length(zz), ncols = nsx + 2;
double transform = 0, **column = NULL, *mean = NULL, statistic = 0, lambda = 0;
double *u = NULL, *d = NULL, *vt = NULL, *cov = NULL, *basecov = 0;
/* compute the degrees of freedom for correlation and mutual information. */
if (test == COR)
*df = nobs - ncols;
else if ((test == MI_G) || (test == MI_G_SH))
*df = 1;
if (((test == COR) && (*df < 1)) || ((test == ZF) && (nobs - ncols < 2))) {
/* if there are not enough degrees of freedom, return independence. */
warning("trying to do a conditional independence test with zero degrees of freedom.");
*df = 0;
statistic = 0;
for (i = 0; i < ntests; i++)
pvalue[i] = 1;
return statistic;
}/*THEN*/
GAUSSIAN_CACHE();
if (ntests > 1) {
/* allocate and compute mean values and the covariance matrix. */
mean = Calloc1D(ncols, sizeof(double));
c_meanvec(column, mean, nobs, ncols, 1);
c_covmat(column, mean, ncols, nobs, cov, 1);
memcpy(basecov, cov, ncols * ncols * sizeof(double));
for (i = 0; i < ntests; i++) {
GAUSSIAN_PCOR_CACHE();
if (test == COR) {
COMPUTE_PCOR();
transform = cor_t_trans(statistic, *df);
pvalue[i] = 2 * pt(fabs(transform), *df, FALSE, FALSE);
}/*THEN*/
else if (test == MI_G) {
COMPUTE_PCOR();
statistic = 2 * nobs * cor_mi_trans(statistic);
pvalue[i] = pchisq(statistic, *df, FALSE, FALSE);
}/*THEN*/
else if (test == MI_G_SH) {
lambda = covmat_lambda(column, mean, cov, nobs, ncols);
covmat_shrink(cov, ncols, lambda);
COMPUTE_PCOR();
statistic = 2 * nobs * cor_mi_trans(statistic);
pvalue[i] = pchisq(statistic, *df, FALSE, FALSE);
}/*THEN*/
else if (test == ZF) {
COMPUTE_PCOR();
statistic = cor_zf_trans(statistic, (double)nobs - ncols);
pvalue[i] = 2 * pnorm(fabs(statistic), 0, 1, FALSE, FALSE);
}/*THEN*/
}/*FOR*/
}/*THEN*/
else {
GAUSSIAN_PCOR_NOCACHE();
if (test == COR) {
COMPUTE_PCOR();
transform = cor_t_trans(statistic, *df);
pvalue[0] = 2 * pt(fabs(transform), *df, FALSE, FALSE);
}/*THEN*/
else if (test == MI_G) {
COMPUTE_PCOR();
statistic = 2 * nobs * cor_mi_trans(statistic);
pvalue[0] = pchisq(statistic, *df, FALSE, FALSE);
}/*THEN*/
else if (test == MI_G_SH) {
lambda = covmat_lambda(column, mean, cov, nobs, ncols);
covmat_shrink(cov, ncols, lambda);
COMPUTE_PCOR();
statistic = 2 * nobs * cor_mi_trans(statistic);
pvalue[0] = pchisq(statistic, *df, FALSE, FALSE);
}/*THEN*/
else if (test == ZF) {
COMPUTE_PCOR();
statistic = cor_zf_trans(statistic, (double)nobs - ncols);
pvalue[0] = 2 * pnorm(fabs(statistic), 0, 1, FALSE, FALSE);
}/*THEN*/
}/*ELSE*/
GAUSSIAN_FREE();
Free1D(mean);
Free1D(column);
return statistic;
}/*CT_GAUSTESTS*/
