/* function to test svdfirst & eigenfirst from R */
SEXP test_ev(SEXP x, SEXP svd)
{
int KIND = asInteger(svd);
int nr = nrows(x), nc = ncols(x);
SEXP ans = PROTECT(allocVector(REALSXP, 1));
if (KIND)
REAL(ans)[0] = svdfirst(REAL(x), nr, nc);
else
REAL(ans)[0] = eigenfirst(REAL(x), nr);
UNPROTECT(1);
return ans;
}
SEXP do_getF(SEXP perms, SEXP E, SEXP QR, SEXP QZ, SEXP effects,
SEXP first, SEXP isPartial, SEXP isDB)
{
int i, j, k, ki, p, nterms = length(effects),
nperm = nrows(perms), nr = nrows(E), nc = ncols(E),
FIRST = asInteger(first), PARTIAL = asInteger(isPartial),
DISTBASED = asInteger(isDB);
/* check that we got terms */
if (nterms == 0)
error("model has no terms to test");
/* check that permutations matrix has correct number of
* observations */
if (ncols(perms) != nr)
error("\'permutations\' matrix should have %d columns, but it has %d",
nr, ncols(perms));
double ev1, ev0, ev;
SEXP ans = PROTECT(allocMatrix(REALSXP, nperm, nterms + 1));
double *rans = REAL(ans);
memset(rans, 0, nperm * (nterms + 1) * sizeof(double));
SEXP Y = PROTECT(duplicate(E));
double *rY = REAL(Y);
if (TYPEOF(effects) != INTSXP)
effects = coerceVector(effects, INTSXP);
PROTECT(effects);
int *term = INTEGER(effects);
/* pointers and new objects to the QR decomposition */
double *qr = REAL(VECTOR_ELT(QR, 0));
int qrank = asInteger(VECTOR_ELT(QR, 1));
double *qraux = REAL(VECTOR_ELT(QR, 2));
double *Zqr, *Zqraux;
int Zqrank;
if (PARTIAL) {
Zqr = REAL(VECTOR_ELT(QZ, 0));
Zqrank = asInteger(VECTOR_ELT(QZ, 1));
Zqraux = REAL(VECTOR_ELT(QZ, 2));
}
double *fitted = (double *) R_alloc(nr * nc, sizeof(double));
/* separate resid needed only in some cases */
double *resid;
if (PARTIAL || FIRST)
resid = (double *) R_alloc(nr * nc, sizeof(double));
/* work array and variables for QR decomposition */
double *qty = (double *) R_alloc(nr, sizeof(double));
double dummy;
int info, qrkind;
/* distance-based methods need to transpose data */
double *transY;
if (DISTBASED)
transY = (double *) R_alloc(nr * nr, sizeof(double));
/* permutation matrix must be duplicated */
if (TYPEOF(perms) != INTSXP)
perms = coerceVector(perms, INTSXP);
SEXP dperms = PROTECT(duplicate(perms));
int *iperm = INTEGER(dperms);
/* permutations to zero base */
for(i = 0; i < nperm * nr; i++)
iperm[i]--;
/* loop over rows of permutation matrix */
for (k = 0; k < nperm; k++) {
/* Y will be permuted data */
for (i = 0; i < nr; i++) {
ki = iperm[k + nperm * i];
for(j = 0; j < nc; j++) {
if (DISTBASED) /* shuffle rows & cols symmetrically */
rY[i + nr*j] = REAL(E)[ki + nr * iperm[k + nperm*j]];
else /* shuffle rows */
rY[i + nr*j] = REAL(E)[ki + nr*j];
}
}
/* Partial model: qr.resid(QZ, Y) with LINPACK */
if (PARTIAL) {
qrkind = RESID;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(Zqr, &nr, &nr, &Zqrank, Zqraux, rY + i*nr,
&dummy, qty, &dummy, rY + i*nr, &dummy,
&qrkind, &info);
/* distances need symmetric residuals */
if (DISTBASED) {
transpose(rY, transY, nr, nr);
qrkind = RESID;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(Zqr, &nr, &nr, &Zqrank, Zqraux,
transY + i*nr, &dummy, qty, &dummy,
rY + i*nr, &dummy, &qrkind, &info);
}
}
/* CONSTRAINED COMPONENT */
/* qr.fitted(QR, Y) + qr.resid(QR, Y) with LINPACK */
/* If there are effects, we go for all but the full rank first */
ev0 = 0; /* must be set for later use outside the loop */
if (nterms > 1) {
qrkind = FIT;
for (p = 0; p < (nterms - 1); p++) {
for (i = 0; i < nc; i++)
F77_CALL(dqrsl)(qr, &nr, &nr, term + p, qraux, rY + i*nr,
&dummy, qty, &dummy, &dummy, fitted + i*nr,
&qrkind, &info);
ev = getEV(fitted, nr, nc, DISTBASED);
rans[k + p*nperm] = ev - ev0;
ev0 = ev;
}
}
/* Evaluate full-rank model */
if (PARTIAL || FIRST)
qrkind = FIT + RESID;
else
qrkind = FIT;
for (i = 0; i < nc; i++)
F77_CALL(dqrsl)(qr, &nr, &nr, &qrank, qraux, rY + i*nr, &dummy,
qty, &dummy, resid + i*nr, fitted + i*nr,
&qrkind, &info);
/* Eigenvalues: either sum of all or the first If the sum of
* all eigenvalues does not change, we have only ev of CCA
* component in the first column, and the second column is
* rubbish that should be filled in the calling R function
* with the correct value. */
if (FIRST) {
if (DISTBASED) { /* needs symmetric matrix */
transpose(fitted, transY, nr, nr);
qrkind = FIT;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(qr, &nr, &nr, &qrank, qraux,
transY + i*nr, &dummy, qty, &dummy,
&dummy, fitted + i*nr, &qrkind, &info);
ev1 = eigenfirst(fitted, nr);
} else {
ev1 = svdfirst(fitted, nr, nc);
ev1 = ev1 * ev1;
}
rans[k] = ev1;
} else {
rans[k + (nterms - 1) * nperm] =
getEV(fitted, nr, nc, DISTBASED) - ev0;
}
if (PARTIAL || FIRST)
rans[k + nterms * nperm] = getEV(resid, nr, nc, DISTBASED);
} /* end permutation loop */
UNPROTECT(4);
return ans;
}
SEXP do_getF(SEXP perms, SEXP E, SEXP QR, SEXP QZ, SEXP first,
SEXP isPartial, SEXP isDB)
{
int i, j, k, ki,
nperm = nrows(perms), nr = nrows(E), nc = ncols(E),
FIRST = asInteger(first), PARTIAL = asInteger(isPartial),
DISTBASED = asInteger(isDB);
double ev1;
SEXP ans = PROTECT(allocMatrix(REALSXP, nperm, 2));
double *rans = REAL(ans);
SEXP Y = PROTECT(duplicate(E));
double *rY = REAL(Y);
/* pointers and new objects to the QR decomposition */
double *qr = REAL(VECTOR_ELT(QR, 0));
int qrank = asInteger(VECTOR_ELT(QR, 1));
double *qraux = REAL(VECTOR_ELT(QR, 2));
double *Zqr, *Zqraux;
int Zqrank;
if (PARTIAL) {
Zqr = REAL(VECTOR_ELT(QZ, 0));
Zqrank = asInteger(VECTOR_ELT(QZ, 1));
Zqraux = REAL(VECTOR_ELT(QZ, 2));
}
double *fitted = (double *) R_alloc(nr * nc, sizeof(double));
/* separate resid needed only in some cases */
double *resid;
if (PARTIAL || FIRST)
resid = (double *) R_alloc(nr * nc, sizeof(double));
/* work array and variables for QR decomposition */
double *qty = (double *) R_alloc(nr, sizeof(double));
double dummy;
int info, qrkind;
/* distance-based methods need to transpose data */
double *transY;
if (DISTBASED)
transY = (double *) R_alloc(nr * nr, sizeof(double));
/* permutation matrix must be duplicated */
SEXP dperms = PROTECT(duplicate(perms));
int *iperm = INTEGER(dperms);
/* permutations to zero base */
for(i = 0; i < nperm * nr; i++)
iperm[i]--;
/* loop over rows of permutation matrix */
for (k = 0; k < nperm; k++) {
/* Y will be permuted data */
for (i = 0; i < nr; i++) {
ki = iperm[k + nperm * i];
for(j = 0; j < nc; j++) {
if (DISTBASED) /* shuffle rows & cols symmetrically */
rY[i + nr*j] = REAL(E)[ki + nr * iperm[k + nperm*j]];
else /* shuffle rows */
rY[i + nr*j] = REAL(E)[ki + nr*j];
}
}
/* Partial model: qr.resid(QZ, Y) with LINPACK */
if (PARTIAL) {
qrkind = RESID;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(Zqr, &nr, &nr, &Zqrank, Zqraux, rY + i*nr,
&dummy, qty, &dummy, rY + i*nr, &dummy,
&qrkind, &info);
/* distances need symmetric residuals */
if (DISTBASED) {
transpose(rY, transY, nr, nr);
qrkind = RESID;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(Zqr, &nr, &nr, &Zqrank, Zqraux,
transY + i*nr, &dummy, qty, &dummy,
rY + i*nr, &dummy, &qrkind, &info);
}
}
/* CONSTRAINED COMPONENT */
/* qr.fitted(QR, Y) + qr.resid(QR, Y) with LINPACK */
if (PARTIAL || FIRST)
qrkind = FIT + RESID;
else
qrkind = FIT;
for (i = 0; i < nc; i++)
F77_CALL(dqrsl)(qr, &nr, &nr, &qrank, qraux, rY + i*nr, &dummy,
qty, &dummy, resid + i*nr, fitted + i*nr,
&qrkind, &info);
/* Eigenvalues: either sum of all or the first If the sum of
* all eigenvalues does not change, we have only ev of CCA
* component in the first column, and the second column is
* rubbish that should be filled in the calling R function
* with the correct value. */
if (FIRST) {
if (DISTBASED) { /* needs symmetric matrix */
transpose(fitted, transY, nr, nr);
qrkind = FIT;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(qr, &nr, &nr, &qrank, qraux,
transY + i*nr, &dummy, qty, &dummy,
&dummy, fitted + i*nr, &qrkind, &info);
ev1 = eigenfirst(fitted, nr);
} else {
ev1 = svdfirst(fitted, nr, nc);
ev1 = ev1 * ev1;
}
rans[k] = ev1;
} else {
rans[k] = getEV(fitted, nr, nc, DISTBASED);
}
if (PARTIAL || FIRST)
rans[k + nperm] = getEV(resid, nr, nc, DISTBASED);
} /* end permutation loop */
UNPROTECT(3);
return ans;
}
