/* 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; }