double testFreducedmodel(double **predX, double **projectX, double **projectXZ, double **tabres, double **tabXZ, double Fobs, int q, int n, int p, int nperm){
int i,j,k,nrowY,ncolY,NGT=0, ncolX, ncolXZ;
double **Yperm,R2X=0,R2XZ, Fi,**tabpredX,**tabpredXZ, **proviX, **proviXZ, **tabX;
nrowY=predX[0][0];
ncolY=predX[1][0];
ncolXZ=tabXZ[1][0];
ncolX=ncolXZ-1;
taballoc(&Yperm,nrowY,ncolY);
taballoc(&tabpredXZ,nrowY,ncolY);
taballoc(&proviXZ,ncolXZ,ncolY);
if(ncolX>0){
taballoc(&tabpredX,nrowY,ncolY);
taballoc(&proviX,ncolX,ncolY);
taballoc(&tabX,nrowY, ncolX);
for (i=1;i<=nrowY;i++){
for (j=1;j<=ncolX;j++){
tabX[i][j]=tabXZ[i][j];
}
}
}
for (i=1;i<=nperm;i++){
aleapermutmat (tabres);
for (k=1;k<=nrowY;k++){
for (j=1;j<=ncolY;j++){
Yperm[k][j]=predX[k][j]+tabres[k][j];
}
}
prodmatABC(projectXZ,Yperm,proviXZ);
prodmatABC(tabXZ,proviXZ,tabpredXZ);
if(ncolX>0){
prodmatABC(projectX,Yperm,proviX);
prodmatABC(tabX,proviX,tabpredX);
}
if(ncolX>0){
R2X=calcR2(Yperm,tabpredX);
}
R2XZ=calcR2(Yperm,tabpredXZ);
Fi=calcF(R2X,R2XZ,q,n,p);
if (Fi>=Fobs) NGT=NGT+1;
}
freetab(Yperm);
freetab(tabpredXZ);
freetab(proviXZ);
if(ncolX>0){
freetab(tabpredX);
freetab(tabX);
freetab(proviX);
}
return(((double)NGT+1)/((double)nperm+1));
}
/* ============================= */
void projX (double **tabX, double **projsurX){
int nlX,ncX,i,j;
double **provi1, **provi2, **provi3;
nlX=tabX[0][0];
ncX=tabX[1][0];
taballoc(&provi1,ncX,ncX);
prodmatAtAB (tabX, provi1); /* provi1=XtX */
taballoc(&provi2,ncX,ncX);
dinvG(provi1,provi2); /* provi2=(XtX)-1 */
freetab(provi1);
/*taballoc(&provi1,nlX,ncX);
prodmatABC(tabX,provi2,provi1); provi1=X(XtX)-1
*/
taballoc(&provi3,ncX,nlX);
for (i=1; i<=nlX;i++){
for (j=1; j<=ncX;j++){
provi3[j][i]=tabX[i][j]; /* provi3=Xt */
}
}
prodmatABC(provi2,provi3,projsurX); /* projsurX=(XtX)-1Xt */
freetab(provi2);
freetab(provi3);
}
double traceXtdLXq (double **X, double **L, double *d, double *q)
/* Produit matriciel XtDLXQ avec LX comme lag.matrix */
{
/* Declarations de variables C locales */
int j, i, lig, col;
double **auxi, **A, trace;
/* Allocation memoire pour les variables C locales */
lig = X[0][0];
col = X[1][0];
taballoc(&auxi, lig, col);
taballoc(&A, col, col);
/* Calcul de LX */
prodmatABC(L, X, auxi);
/* Calcul de DLX */
for (i=1;i<=lig;i++) {
for (j=1;j<=col;j++) {
auxi[i][j] = auxi[i][j] * d[i];
}
}
/* Calcul de XtDLX */
prodmatAtBC(X,auxi,A);
/* Calcul de trace(XtDLXQ) */
trace=0;
for (i=1;i<=col;i++) {
trace = trace + A[i][i] * q[i];
}
/* Libération des réservations locales */
freetab (auxi);
freetab (A);
return(trace);
}
void forwardsel (double *tabXR, double *tabYR, int *nrowXR, int *ncolXR, int *ncolYR, double *pvalue, int *ordre,
double *Fvalue, int *nperm, double *R2cum, double *adjR2cum, int *K, double *R2seuil, double *adjR2seuil, double *R2more, int *nbcovar, double *alpha, int *verbose){
/* CANOCO 4.5 p. 49 */
/* nouvelle version 01/11/2004 */
/* on ne stocke plus le projecteur au complet (qui est n x n)
ce qui permet d'economiser de la RAM quand n est grand
modifie aussi testFreducedmodel */
int i,j,k,l,nrowX,ncolX, ncolY, *vecrest, *vecsel, R2maxj=0;
double **tabX, **tabY, **tabres, **tabpred1, **tabpred2, **tabXnew, R2max=0, adjR2max=0,R2j, R2X, R2XZ, Fobs,**projectX,**projectXZ, **provi;
nrowX=*nrowXR;
ncolX=*ncolXR;
ncolY=*ncolYR;
taballoc (&tabX, nrowX, ncolX);
taballoc (&tabY, nrowX, ncolY);
taballoc (&tabres, nrowX, ncolY);
taballoc (&tabpred1, nrowX, ncolY);
taballoc (&tabpred2, nrowX, ncolY);
vecintalloc(&vecrest,ncolX);
vecintalloc(&vecsel,ncolX);
taballoc (&projectX, 1,nrowX);
/* Passage des objets R en C */
k = 0;
for (i=1; i<=nrowX; i++) {
for (j=1; j<=ncolX; j++) {
tabX[i][j] = tabXR[k];
k = k + 1;
}
}
k = 0;
for (i=1; i<=nrowX; i++) {
for (j=1; j<=ncolY; j++) {
tabY[i][j] = tabYR[k];
k = k + 1;
tabpred1[i][j]=0;
}
}
for (i=1; i<=ncolX; i++) vecrest[i]=i;
R2X=0;
for (i=1; i<=ncolX; i++){
if ((R2max>*R2seuil) || (i>*K) || (i>(nrowX-1)) || (adjR2max>*adjR2seuil)) {
if ((i>*K) )
Rprintf("Procedure stopped (K criteria)\n");
if ((i>(nrowX-1)))
Rprintf("Procedure stopped: number of variables included equals number of rows minus one. All is explained ! Redo your analysis with other parameters.\n");
break;
}
if(*verbose == 1){
Rprintf("Testing variable %d\n",i);
}
R2max=0;
adjR2max=0;
R2maxj=0;
taballoc(&tabXnew, nrowX, i);
taballoc(&projectXZ, i, nrowX);
taballoc(&provi,i,ncolY);
for (j=1; j<=ncolX; j++){
if (vecrest[j]>0){ /* Selection de la variable j base sur le R2 */
vecsel[i]=j;
constnewX(tabX,tabXnew,vecsel);
projX(tabXnew,projectXZ);
prodmatABC(projectXZ,tabY,provi);
prodmatABC(tabXnew,provi,tabpred2);
R2j=calcR2(tabY,tabpred2);
if (R2j>R2max) {
R2max=R2j;
adjR2max=calcR2adj(R2max,nrowX,i);
R2maxj=j;
}
}
} /* for (j=1; j<=ncolX; j++) */
/* test de la variable j selectionne */
if ((i>1) && (fabs(R2max-R2cum[i-2])<*R2more)){
Rprintf("Procedure stopped (R2more criteria): variable %d explains only %f of the variance.\n",i,(fabs(R2max-R2cum[i-2])));
freetab(tabXnew);
break;
}
if ((R2max>*R2seuil)){
Rprintf("Procedure stopped (R2thresh criteria) R2cum = %f with %d variables (> %f)\n", R2max, i, *R2seuil);
break;
}
if ((adjR2max>*adjR2seuil)){
Rprintf("Procedure stopped (adjR2thresh criteria) adjR2cum = %f with %d variables (> %f)\n", adjR2max, i, *adjR2seuil);
break;
}
vecsel[i]=R2maxj;
R2cum[i-1]=R2max;
adjR2cum[i-1]=adjR2max;
ordre[i-1]=vecsel[i];
vecrest[R2maxj]=0;
constnewX(tabX,tabXnew,vecsel);
projX(tabXnew,projectXZ);
prodmatABC(projectXZ,tabY,provi);
prodmatABC(tabXnew,provi,tabpred2);
for (k=1;k<=nrowX;k++){
for (l=1;l<=ncolY;l++){
tabres[k][l]=tabY[k][l]-tabpred1[k][l];
}
}
R2XZ=R2max;
Fobs=calcF(R2X,R2XZ,1,nrowX,i+(*nbcovar));
Fvalue[i-1]=Fobs;
pvalue[i-1]=testFreducedmodel(tabpred1,projectX,projectXZ,tabres, tabXnew, Fobs,1,nrowX,i+(*nbcovar),*nperm);
for (k=1;k<=nrowX;k++){
for (l=1;l<=ncolY;l++){
tabpred1[k][l]=tabpred2[k][l];/* mettre dans pred1 les predictions du nouvo model */
}
}
freetab(projectX);
taballoc(&projectX, i, nrowX);
for (k=1;k<=i;k++){
for (l=1;l<=nrowX;l++){
projectX[k][l]=projectXZ[k][l];
}
}
R2X=R2XZ;
freetab(tabXnew);
freetab(projectXZ);
freetab(provi);
if ((pvalue[i-1]>*alpha)) {
Rprintf("Procedure stopped (alpha criteria): pvalue for variable %d is %f (> %f)\n",i,pvalue[i-1],*alpha);
ordre[i-1]=0;
break;
}
}/* for (i=1; i<=ncolX; i++) */
freetab(projectX);
freeintvec(vecsel);
freeintvec(vecrest);
freetab(tabX);
freetab(tabY);
freetab(tabres);
freetab(tabpred1);
freetab(tabpred2);
}
