static void
fisher_sim(int *nrow, int *ncol, int *nrowt, int *ncolt, int *n,
int B, int *observed, double *fact,
int *jwork, double *results)
{
int i, j, ii, iter;
double ans;
/* Calculate log-factorials. fact[i] = lgamma(i+1) */
fact[0] = fact[1] = 0.;
for(i = 2; i <= *n; i++)
fact[i] = fact[i - 1] + log(i);
GetRNGstate();
for(iter = 0; iter < B; ++iter) {
rcont2(nrow, ncol, nrowt, ncolt, n, fact, jwork, observed);
/* Calculate log-prob value from the random table. */
ans = 0.;
for (j = 0; j < *ncol; ++j) {
for (i = 0, ii = j * *nrow; i < *nrow; i++, ii++)
ans -= fact[observed[ii]];
}
results[iter] = ans;
}
PutRNGstate();
return;
}
static void
chisqsim(int *nrow, int *ncol, int *nrowt, int *ncolt, int *n,
int B, double *expected, int *observed, double *fact,
int *jwork, double *results)
{
int i, j, ii, iter;
double chisq, e, o;
/* Calculate log-factorials. fact[i] = lgamma(i+1) */
fact[0] = fact[1] = 0.;
for(i = 2; i <= *n; i++)
fact[i] = fact[i - 1] + log(i);
GetRNGstate();
for(iter = 0; iter < B; ++iter) {
rcont2(nrow, ncol, nrowt, ncolt, n, fact, jwork, observed);
/* Calculate chi-squared value from the random table. */
chisq = 0.;
for (j = 0; j < *ncol; ++j) {
for (i = 0, ii = j * *nrow; i < *nrow; i++, ii++) {
e = expected[ii];
o = observed[ii];
chisq += (o - e) * (o - e) / e;
}
}
results[iter] = chisq;
}
PutRNGstate();
return;
}
/* unconditional Monte Carlo simulation for discrete tests. */
SEXP mcarlo(SEXP x, SEXP y, SEXP lx, SEXP ly, SEXP length, SEXP samples,
SEXP test, SEXP alpha) {
double *fact = NULL, *res = NULL, observed = 0;
int *n = NULL, *ncolt = NULL, *nrowt = NULL, *workspace = NULL;
int *num = INTEGER(length), *nr = INTEGER(lx), *nc = INTEGER(ly);
int *xx = INTEGER(x), *yy = INTEGER(y), *B = INTEGER(samples);
int i = 0, k = 0, npermuts = 0, enough = ceil(NUM(alpha) * (*B)) + 1;
SEXP result;
/* allocate and initialize the result. */
PROTECT(result = allocVector(REALSXP, 3));
res = REAL(result);
res[0] = res[1] = res[2] = 0; // initial test score / p-value / nb permutations
/* allocate and compute the factorials needed by rcont2. */
allocfact(*num);
/* allocate and initialize the workspace for rcont2. */
workspace = alloc1dcont(*nc);
/* initialize the contingency table. */
n = alloc1dcont(*nr * (*nc));
/* initialize the marginal frequencies. */
nrowt = alloc1dcont(*nr);
ncolt = alloc1dcont(*nc);
/* compute the joint frequency of x and y. */
for (k = 0; k < *num; k++)
n[CMC(xx[k] - 1, yy[k] - 1, *nr)]++;
/* compute the marginals. */
for (i = 0; i < *nr; i++)
for (k = 0; k < *nc; k++) {
nrowt[i] += n[CMC(i, k, *nr)];
ncolt[k] += n[CMC(i, k, *nr)];
}/*FOR*/
/* initialize the random number generator. */
GetRNGstate();
/* pick up the observed value of the test statistic, then generate a set of
random contingency tables (given row and column totals) and check how many
tests are greater than the original one.*/
switch(INT(test)) {
case MUTUAL_INFORMATION:
observed = _mi(n, nrowt, ncolt, nr, nc, num);
for (k = 0; k < *B; k++) {
rcont2(nr, nc, nrowt, ncolt, num, fact, workspace, n);
if (_mi(n, nrowt, ncolt, nr, nc, num) > observed) {
sequential_counter_check(res[1]);
}/*THEN*/
npermuts++;
}/*FOR*/
observed = 2 * observed;
break;
case PEARSON_X2:
observed = _x2(n, nrowt, ncolt, nr, nc, num);
for (k = 0; k < *B; k++) {
rcont2(nr, nc, nrowt, ncolt, num, fact, workspace, n);
if (_x2(n, nrowt, ncolt, nr, nc, num) > observed) {
sequential_counter_check(res[1]);
}/*THEN*/
npermuts++;
}/*FOR*/
break;
}/*SWITCH*/
PutRNGstate();
/* save the observed value of the statistic, the corresponding
p-value, and the number of permutations performed. */
res[0] = observed;
res[1] /= (*B);
res[2] = npermuts;
UNPROTECT(1);
return result;
}/*MCARLO*/
/* conditional Monte Carlo simulation for discrete tests. */
SEXP cmcarlo_mean(SEXP x, SEXP y, SEXP z, SEXP lx, SEXP ly, SEXP lz,
SEXP length, SEXP samples, SEXP test) {
double *fact = NULL, *res = NULL, observed = 0;
int **n = NULL, **ncolt = NULL, **nrowt = NULL, *ncond = NULL, *workspace = NULL;
int *num = INTEGER(length), *B = INTEGER(samples);
int *nr = INTEGER(lx), *nc = INTEGER(ly), *nl = INTEGER(lz);
int *xx = INTEGER(x), *yy = INTEGER(y), *zz = INTEGER(z);
int i = 0, j = 0, k = 0, npermuts = 0;
SEXP result;
/* allocate and initialize the result */
PROTECT(result = allocVector(REALSXP, 3));
res = REAL(result);
res[0] = res[1] = res[2] = 0; // initial test score / mean score / nb permutations
/* allocate and compute the factorials needed by rcont2. */
allocfact(*num);
/* allocate and initialize the workspace for rcont2. */
workspace = alloc1dcont(*nc);
/* initialize the contingency table. */
n = alloc2dcont(*nl, (*nr) * (*nc));
/* initialize the marginal frequencies. */
nrowt = alloc2dcont(*nl, *nr);
ncolt = alloc2dcont(*nl, *nc);
ncond = alloc1dcont(*nl);
/* compute the joint frequency of x and y. */
for (k = 0; k < *num; k++)
n[zz[k] - 1][CMC(xx[k] - 1, yy[k] - 1, *nr)]++;
/* compute the marginals. */
for (i = 0; i < *nr; i++)
for (j = 0; j < *nc; j++)
for (k = 0; k < *nl; k++) {
nrowt[k][i] += n[k][CMC(i, j, *nr)];
ncolt[k][j] += n[k][CMC(i, j, *nr)];
ncond[k] += n[k][CMC(i, j, *nr)];
}/*FOR*/
/* initialize the random number generator. */
GetRNGstate();
/* pick up the observed value of the test statistic, then generate a set of
random contingency tables (given row and column totals) and adds their
test scores to compute the mean.*/
switch(INT(test)) {
case MUTUAL_INFORMATION:
observed = 2 * _cmi(n, nrowt, ncolt, ncond, nr, nc, nl);
for (j = 0; j < *B; j++) {
for (k = 0; k < *nl; k++)
rcont2(nr, nc, nrowt[k], ncolt[k], &(ncond[k]), fact, workspace, n[k]);
res[1] += 2 * _cmi(n, nrowt, ncolt, ncond, nr, nc, nl);
npermuts++;
}
break;
case PEARSON_X2:
observed = _cx2(n, nrowt, ncolt, ncond, nr, nc, nl);
for (j = 0; j < *B; j++) {
for (k = 0; k < *nl; k++)
rcont2(nr, nc, nrowt[k], ncolt[k], &(ncond[k]), fact, workspace, n[k]);
res[1] += _cx2(n, nrowt, ncolt, ncond, nr, nc, nl);
npermuts++;
}
break;
}/*SWITCH*/
PutRNGstate();
/* save the observed and mean values of the statistic,
and the number of permutations performed. */
res[0] = observed;
res[1] /= *B; // mean
res[2] = npermuts;
UNPROTECT(1);
return result;
}/*CMCARLO_MEAN*/
SEXP r2dtable(SEXP n, SEXP r, SEXP c)
{
int nr, nc, *row_sums, *col_sums, i, *jwork;
int n_of_samples, n_of_cases;
double *fact;
SEXP ans, tmp;
const void *vmax = vmaxget();
nr = length(r);
nc = length(c);
/* Note that the R code in r2dtable() also checks for missing and
negative values.
Should maybe do the same here ...
*/
if(!isInteger(n) || (length(n) == 0) ||
!isInteger(r) || (nr <= 1) ||
!isInteger(c) || (nc <= 1))
error(_("invalid arguments"));
n_of_samples = INTEGER(n)[0];
row_sums = INTEGER(r);
col_sums = INTEGER(c);
/* Compute total number of cases as the sum of the row sums.
Note that the R code in r2dtable() also checks whether this is
the same as the sum of the col sums.
Should maybe do the same here ...
*/
n_of_cases = 0;
jwork = row_sums;
for(i = 0; i < nr; i++)
n_of_cases += *jwork++;
/* Log-factorials from 0 to n_of_cases.
(I.e., lgamma(1), ..., lgamma(n_of_cases + 1).)
*/
fact = (double *) R_alloc(n_of_cases + 1, sizeof(double));
fact[0] = 0.;
for(i = 1; i <= n_of_cases; i++)
fact[i] = lgammafn((double) (i + 1));
jwork = (int *) R_alloc(nc, sizeof(int));
PROTECT(ans = allocVector(VECSXP, n_of_samples));
GetRNGstate();
for(i = 0; i < n_of_samples; i++) {
PROTECT(tmp = allocMatrix(INTSXP, nr, nc));
rcont2(&nr, &nc, row_sums, col_sums, &n_of_cases, fact,
jwork, INTEGER(tmp));
SET_VECTOR_ELT(ans, i, tmp);
UNPROTECT(1);
}
PutRNGstate();
UNPROTECT(1);
vmaxset(vmax);
return(ans);
}
