########################################################### # Sources of the package PLSS for the R version 1.9.1 under WINDOWS # release 10.30, 22/06/2006 # REFERENCES # Durand, J.F., Roman, S. et Vivien M. (1998), "Guide de la régression PLS linéaire sous S-Plus". # Rapport de Recherche 98-06, Groupe de Biostatistique et d'Analyses des Systèmes, # ENSA.M-INRA-UM II. # Durand, J.F., (2000), "La régression Partial Least Squares Spline - PLSS - Guide d'utilisation # sous S-Plus". Rapport de Recherche 00-06, Groupe de Biostatistique et d'Analyses # des Systèmes, ENSA.M-INRA-UM II. # Durand, J.F., (2001), "Local Polynomial Additive Regression through PLS and Splines: PLSS", # Chemometrics and Intelligent Laboratory Systems, vol. 58, issue 2, 235-246. # Durand, J.F., (2002), "Elements de calcul matriciel et d'Analyse Factorielle de Données", cours # polycopié, Université Montpellier II. # Durand, J.F. and Lombardo, R., (2003), "Interactions terms in nonlinear PLS via additive spline # transformations", Between Data Science and Applied Data Analysis, Studies # in Classification, Data Analysis, and Knowledge Organization. Eds M.Schader, # W. Gaul and M. Vichi, Springer, 22-29. ########################################################### objetspls<-c("PLSL","plscalibration","bivarplot","pls" ,"plscv" ,"plscv.plot" ,"Dcenter" ,"Dcentred", "invgene" ,"Dproj", "Dcp" ,"Dvar" ,"WDop" ,"VQop" ,"lss", "plss" ,"plss.plot", "plsscv" , "Gnorm" ,"traceAtB", "tucker", "grad", "Projtuc" ,"Gscal" ,"traceAB" ,"Projn", "Codisjc", "affecte" ,"codisj","Bsplinen","noeuds","selectvar","Mahalanobis", "MAPLSS","plssinter","plss.plotinter","surfaceinter","MVcut","f","mygraphics","simulMAPLSS", "plss2","OneInterActAnalysis","TryAnalysis","Bspline") ########################################################### PLSL<-function(X,Y,Xtest,Ytest,standX=T,standY=T,D=1,A=1,eps=1e-08,smooth="lowess",lambda=0.6, impres=T,graph=T,titlepar=T,prop=0.1,typedata=T,cexpar=0.7,pchpar=1,askpar=T,ptypar="m", colpar=1,matcol=1,matrow=1,bgpar="wheat",qual,names.qual) { # bgpar, chacter string of the background color. default is "wheat",try "transparent" "peachpuff", "lightblue", "gray", # "lightpink", "thistle", "tan"....;use colors() to choose. mapalette=c("black","red","green3","blue","cyan","magenta","chocolate3","gray","pink3","peru","orange","salmon","deepskyblue","yellow") palette(mapalette) # pie(rep(1,length(mapalette)),col=mapalette,radius=0.9) oldpar<-par(no.readonly = TRUE) par(ask=F,bg=bgpar,mfrow=c(1,1),bty="n",xaxt="n",yaxt="n") plot(0,0,type="n",bg=par("bg"),xlab="",ylab="",xlim=c(-4,4),ylim=c(-4,4)) text(0,2,"Linear Partial Least-Squares",cex=1.7,col="red") text(0,0,"Regression",cex=1.7,col="red") text(0,-2,"J.F. Durand, Montpellier 2 University",cex=1,col="blue") text(0,-3,"www.jf-durand-pls.com",cex=0.9,col="blue") par(oldpar) par(ask=askpar,bg=bgpar,xaxt="s",yaxt="s") X0<-as.matrix(X) if(!missing(Xtest))Xtest0<-as.matrix(Xtest) Y<-as.matrix(Y) Xvariables<-rep(T,ncol(X0)) repeat{ X<-X0[,Xvariables,drop=F] if(!missing(Xtest))Xtest<-Xtest0[,Xvariables] p<-ncol(X) q<-ncol(Y) cat("==========================================================\n") reponse<-menu(c("Bivariate Analysis","Cross Validation", "Generalized Cross Validation","Conversational PLS","Selection of the predictors (Remove/Add)"),title="'Linear PLS' (0 to exit)") cat("==========================================================\n") if(reponse==1) { if(q==1) menuvec<-c("Inside the X variables","Between X and Y") else menuvec<-c("Inside the X variables","Between X and Y","Inside the Y variables") cat("==========================================================\n") reponseb<-menu(menuvec,title=" What kind of relationship ?") cat("==========================================================\n") switch(reponseb, {Ybiv<-X;Xbiv<-X},{Ybiv<-Y;Xbiv<-X},{Ybiv<-Y;Xbiv<-Y}) if(reponseb!=0) { cat("Graphs or matrix of Correlations (g/c)?\n") plctY<-scan(quiet=T,"",character(),1) if((length(plctY)==0)|(plctY=="c")) { if(reponseb==1) print(round(Dvar(X,D=D,cor=T)$V,2)) if(reponseb==2) print(round(Dvar(cbind(X,Y),D=D,cor=T)$V,2)) if(reponseb==3) print(round(Dvar(Y,D=D,cor=T)$V,2)) } else bivarplot(X=Xbiv,Y=Ybiv,matrow=matrow,matcol=matcol,smooth=smooth,lambda=lambda,degree=1,knots=0, titlepar=titlepar,typedata=typedata,cexpar=cexpar,pchpar=pchpar,ptypar=ptypar, colpar=colpar,askpar=askpar,bgpar=bgpar) par(mfrow=c(1,1),pty="m") def.par <- par(no.readonly = TRUE) layout(matrix(c(3,4,5,6,1,2),2,3,byrow=TRUE), heights=c(2,10),widths= c(3,10,1), TRUE) switch(reponseb, {par(mar=c(4,4,0,3)); image(1:p,1:p,Dvar(X,D=D,cor=T)$V,xlab="predictors",ylab="predictors",col=topo.colors(64),cex=cexpar); box(); par(mar=c(4,0,0,1)); image(1,seq(min(Dvar(X,D=D,cor=T)$V),1,length=64),t(matrix(1:64,64,1)),xaxt="n",yaxt="s",col=topo.colors(64),xlab="",ylab="",cex=cexpar); box(); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"Var.",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"names",cex=cexpar+0.2,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(0,0,"Image of Correlations",cex=cexpar+0.5,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"r",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"level",cex=cexpar+0.2,col="red"); plot(rep(0,5),-2:2,type="n",xlab="",ylab="",axes=F); text(rep(-0.3,p),seq(-1.5,2,length=p),paste(format(1:p),dimnames(X)[[2]]),cex=cexpar); }, {par(mar=c(4,4,0,3)); image(1:(p+q),1:(p+q),Dvar(cbind(X,Y),D=D,cor=T)$V,xlab="predictors + responses",ylab="predictors + responses",col=topo.colors(64),cex=cexpar); box(); par(mar=c(4,0,0,1)); image(1,seq(min(Dvar(cbind(X,Y),D=D,cor=T)$V),1,length=64),t(matrix(1:64,64,1)),xaxt="n",yaxt="s",col=topo.colors(64),xlab="",ylab="",cex=cexpar); box(); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"Var.",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"names",cex=cexpar+0.2,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(0,0,"Image of Correlations",cex=cexpar+0.5,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"r",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"level",cex=cexpar+0.2,col="red"); plot(rep(0,5),-2:2,type="n",xlab="",ylab="",axes=F); text(rep(-0.8,p+q),seq(-1.5,2,length=p+q),paste(format(1:(p+q)),c(dimnames(X)[[2]],dimnames(Y)[[2]])), col=c(rep("blue",p),rep("magenta",q)),pos=4,cex=cexpar) }, {par(mar=c(4,4,0,3)); image(1:q,1:q,Dvar(Y,D=D,cor=T)$V,xlab="responses",ylab="responses",col=topo.colors(64),cex=cexpar); box(); par(mar=c(4,0,0,1)); image(1,seq(min(Dvar(Y,D=D,cor=T)$V),1,length=64),t(matrix(1:64,64,1)),xaxt="n",yaxt="s",col=topo.colors(64),xlab="",ylab="",cex=cexpar); box(); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"Var.",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"names",cex=cexpar+0.2,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(0,0,"Image of Correlations",cex=cexpar+0.5,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"r",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"level",cex=cexpar+0.2,col="red"); plot(rep(0,5),-2:2,type="n",xlab="",ylab="",axes=F); text(rep(-0.3,q),seq(-1.5,2,length=q),paste(format(1:q),dimnames(Y)[[2]]),cex=cexpar)} ) } par(def.par) }#endreponse1 #--------------------------------------------------------- if(reponse==4) { if(missing(Xtest)) plsresult<-pls(X,Y,standX=standX,standY=standY,A=A,eps=eps,splflag=F,impres=impres,graph=graph, askpar=askpar,cexpar=cexpar,,pchpar=pchpar,colpar=colpar,pty=ptypar,qual=qual,names.qual=names.qual) else { if(missing(Ytest)) plsresult<-pls(X,Y,Xtest=Xtest,standX=standX,standY=standY,A=A,eps=eps,splflag=F,impres=impres, graph=graph,askpar=askpar,cexpar=cexpar,pchpar=pchpar,colpar=colpar,pty=ptypar,qual=qual,names.qual=names.qual) else plsresult<-pls(X,Y,Xtest=Xtest,Ytest=Ytest,standX=standX,standY=standY,A=A,eps=eps,splflag=F, impres=impres,graph=graph,askpar=askpar,cexpar=cexpar,pchpar=pchpar,colpar=colpar,pty=ptypar,qual=qual,names.qual=names.qual) } A<-plsresult$A } #--------------------------------------------------------- if((reponse==2)|(reponse==3)) { cat("Enter the maximum number of components (dimensions) to explore \n") Aexplore<-scan(quiet=T,"",numeric(),1) if(reponse==2) i<-1 else i<-0 campaign<-matrix(0,1,Aexplore+2) if(reponse==2) dimnames(campaign)<-list(format(i),c("prop","Dim",format(1:Aexplore))) else dimnames(campaign)<-list(format(i),c("alpha","Dim",format(1:Aexplore))) if(reponse==2) { repeat{ plscvresul<-plscv(X,Y,standX=standX,standY=standY,A=Aexplore,prop=prop,GCV=0) plscvresul<-plscv.plot(plscvresul,colpar=colpar,cexpar=cexpar,titlepar=titlepar,bgpar=bgpar) #browser() campaign[i,]<-c(prop,plscvresul$A,round(plscvresul[[1]],5)) cat("Another proportion of left-predicted observations,(y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if((repo!="y")&(repo!="Y"))break cat("Enter prop (< 0.5):") prop<-scan(quiet=T,"",numeric(),1) i<-i+1 campaign<-rbind(campaign,rep(0,Aexplore+2)) dimnames(campaign)[[1]][i]<-format(i) }#endrepeat matrice<-campaign[,3:(Aexplore + 2),drop=F] campaignmean<-apply(matrice,2,"mean") campaignstdv<-sqrt(apply(matrice,2,"var")) campaign<-rbind(campaign,c(NA,NA,campaignmean)) campaign[nrow(campaign),2]<-round(campaign[nrow(campaign),2]) dimnames(campaign)[[1]][nrow(campaign)]<-"mean" campaign<-rbind(campaign,c(prop,plscvresul$A,campaignmean + 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean+2sdv" campaign<-rbind(campaign,c(prop,plscvresul$A,campaignmean - 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean-2sdv" campaign[(nrow(campaign)-1):nrow(campaign),2]<-NA if(nrow(campaign)>4){ par(mfrow=c(1,1)) ts.plot(ts(t(campaign[,3:(Aexplore+2)])),gpars=list(xlab="Model Dim.",ylab="PRESS",type="n", main="CV experiments' summary",cex=cexpar)) for(i in 1:(nrow(campaign)-2)){ points(1:Aexplore,campaign[i,3:(Aexplore+2)],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[i,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) } points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],pch=i+1,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],pch=i+2,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],type="l",lty=i,col=colpar+i) cat("Click to locate the top left corner of the legend\n") legend(locator(1),c(campaign[1:(nrow(campaign)-3),1],"mean","mean+2sdv","mean-2sdv"),pch=1:nrow(campaign),bty="o",col=c(colpar+(1:(nrow(campaign)-2)), colpar+rep((nrow(campaign)-2),2)),cex=cexpar,ncol=max(nrow(campaign)%/%5,1), text.col=c(colpar+(1:(nrow(campaign)-2)),colpar+rep((nrow(campaign)-2),2))) print(campaign[1:(nrow(campaign)-2),]) cat("Choose the best experiment row number ( 1<= # <=",nrow(campaign)-3,")") exp0<-scan(quiet=T,"",numeric(),1) plscvresul[[2]]<-campaign[exp0,3:(Aexplore+2)] plscvresul$A<-campaign[exp0,2] #prop<-eval(parse("",text=dimnames(campaign)[[1]][exp0])) prop<-campaign[exp0,1] cat("Retained experiment values\n") cat("PRESS(",prop,",",plscvresul$A,")=",plscvresul[[2]][plscvresul$A],"\n",sep="") } } else { repeat {# repeat{ cat("GCV(k,alpha)= ASR/(1-alpha*k/n)^2\n") cat("where ASR=Average Squared Residuals, k=dimension\n") cat("Enter alpha (>0) the tuning parameter :\n") GCV<-scan(quiet=T,"",numeric(),1) if(GCV*Aexplore/nrow(X)>=1) cat("Try a smaller value!\n") else break } i<-i+1 plscvresul<-plscv(X,Y,standX=standX,standY=standY,A=Aexplore,prop=prop,GCV=GCV) plscvresul<-plscv.plot(plscvresul,colpar=colpar,cexpar=cexpar,titlepar=titlepar,bgpar=bgpar) campaign<-rbind(campaign,matrix(c(GCV,plscvresul$A,round(plscvresul[[1]],5)),1,Aexplore+2)) if(i==1)campaign<-campaign[-1,,drop=F] dimnames(campaign)[[1]][i]<-format(i) #campaign[i,]<-c(GCV,plscvresul$A,round(plscvresul[[2]],5)) cat("Another GCV try,(y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break }#endrepeat if(reponse==3) {## matrice<-campaign[,3:(Aexplore + 2),drop=F] campaignmean<-apply(matrice,2,"mean") campaignstdv<-sqrt(apply(matrice,2,"var")) campaign<-rbind(campaign,c(NA,NA,campaignmean)) campaign[nrow(campaign),2]<-round(campaign[nrow(campaign),2]) dimnames(campaign)[[1]][nrow(campaign)]<-"mean" campaign<-rbind(campaign,c(GCV,plscvresul$A,campaignmean + 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean+2sdv" campaign<-rbind(campaign,c(GCV,plscvresul$A,campaignmean - 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean-2sdv" campaign[(nrow(campaign)-1):nrow(campaign),2]<-NA if(nrow(campaign)>4){ par(mfrow=c(1,1)) ts.plot(ts(t(campaign[,3:(Aexplore+2)])),gpars=list(xlab="Model Dim.",ylab="GCV",type="n", main="CV experiments' summary",cex=cexpar)) for(i in 1:(nrow(campaign)-2)){ points(1:Aexplore,campaign[i,3:(Aexplore+2)],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[i,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) } points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],pch=i+1,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],pch=i+2,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],type="l",lty=i,col=colpar+i) cat("Click to locate the top left corner of the legend\n") legend(locator(1),c(campaign[1:(nrow(campaign)-3),1],"mean","mean+2sdv","mean-2sdv"),pch=1:nrow(campaign),bty="o",col=c(colpar+(1:(nrow(campaign)-2)), colpar+rep((nrow(campaign)-2),2)),cex=cexpar,ncol=max(nrow(campaign)%/%5,1), text.col=c(colpar+(1:(nrow(campaign)-2)),colpar+rep((nrow(campaign)-2),2))) print(campaign[1:(nrow(campaign)-2),]) cat("Choose the best experiment row number ( 1<= # <=",nrow(campaign)-3,")") exp0<-scan(quiet=T,"",numeric(),1) plscvresul[[2]]<-campaign[exp0,3:(Aexplore+2)] plscvresul$A<-campaign[exp0,2] #prop<-eval(parse("",text=dimnames(campaign)[[1]][exp0])) GCV<-campaign[exp0,1] cat("Retained experiment values\n") cat("PRESS(",GCV,",",plscvresul$A,")=",plscvresul[[2]][plscvresul$A],"\n",sep="") } }## } A<-plscvresul$A } #--------------------------------------------------------- if(reponse==5) { Xvariables<-selectvar(X0,Xvariables=Xvariables) } #--------------------------------------------------------- if(reponse==0)break }#finrepeat invisible(Xvariables) } ########################################################### PLSS<-function(X,Y,Xtest,Ytest,standX=T,standY=T,D=1,A=2,degree=1,knots=0,equiknots=F,eps=1e-8, listknots=listknots,smooth="reg.spline",lambda=0.6,interaction=NULL,listinteraction,qual,names.qual, ptypar="s",typedata=T,titlepar=T,pchpar=1,cexpar=0.7,nbpoints=100,colpar=0,askpar=T, matrow=1,matcol=1,prop=0.1,impres=T,bgpar="lavenderblush2") { # Bibliography : # J. F. Durand. "Local Polynomial Additive Regression through PLS and Splines: PLSS", # Chemometrics and Intelligent Laboratory Systems 58, 235-246, 2001. # mapalette=c("black","red","green3","blue","cyan","magenta","gray","chocolate3","pink3","peru","orange","salmon","deepskyblue","yellow") palette(mapalette) # pie(rep(1,length(mapalette)),col=mapalette,radius=0.9) oldpar<-par(no.readonly = TRUE) par(ask=F,bg=bgpar,mfrow=c(1,1),bty="n",xaxt="n",yaxt="n") plot(0,0,type="n",bg=par("bg"),xlab="",ylab="",xlim=c(-4,4),ylim=c(-4,4)) text(0,2.5,"Partial Least-Squares",cex=2,col="red") text(0,0,"Splines : PLSS",cex=2,col="red") text(0,-2,"J.F. Durand, Montpellier 2 University",cex=1,col="blue") text(0,-3,"www.jf-durand-pls.com",cex=0.9,col="blue") par(oldpar) par(ask=askpar,bg=bgpar,xaxt="s",yaxt="s",mai=rep(0.75,4)) X0<-as.matrix(X) degree0<-degree if(length(degree0)==1)degree0<-rep(degree,ncol(X0)) knots0<-knots if(length(knots0)==1)knots0<-rep(knots,ncol(X0)) equiknots0<-equiknots if(length(equiknots0)==1)equiknots0<-rep(equiknots,ncol(X0)) if(!missing(listknots)) listknots0<-listknots else { listknots0<-list(NULL) for(i in 1:(ncol(X0)-1)) listknots0<-c(listknots0,list(NULL)) } if(!missing(Xtest)) { if(is.null(dimnames(Xtest))){ if(length(Xtest)==dim(X)[2])Xtest0<-matrix(Xtest,1,length(Xtest)) dimnames(Xtest0)<-list(paste("x",1:(length(Xtest)/length(X)),sep=""),dimnames(X)[[2]]) } else Xtest0<-as.matrix(Xtest) } Y<-as.matrix(Y) Xvariables<-rep(T,ncol(X0)) repeat{ flag<-sum(Xvariables)==ncol(X0) X<-as.matrix(X0[,Xvariables,drop=F]) p<-ncol(X) q<-ncol(Y) if(length(degree0)>1)degree<-degree0[Xvariables] if(length(knots0)>1)knots<-knots0[Xvariables] if(length(equiknots0)>1)equiknots<-equiknots0[Xvariables] #if(!missing(listknots)) listknots<-listknots0[Xvariables] listknots<-listknots0[Xvariables] aa<-NULL for(i in 1:length(listknots))aa<-c(aa,listknots[[i]]) listknotsnullflag<-is.null(aa) if(!missing(Xtest))Xtest<-Xtest0[,Xvariables,drop=F] cat("==========================================================\n") if((smooth=="reg.spline")&(matrow+matcol==2)) menu1<-"Bivariate Analysis for Spline Inputs" else menu1<-"Bivariate Analysis" if(A>1) menu41<-"exploration and modeling" else menu41<-"modeling" if(missing(Xtest)) menu4<-paste("A look at graphics for ",menu41,sep="") else menu4<-paste("Prediction and a look at graphics for ",menu41,sep="") reponse<-menu(c(menu1,"Cross Validation", "Generalized Cross Validation",menu4,"Selection of the predictors (Remove/Add)"),title="'PLS Spline' (0 to exit)") cat("===========================================================\n") if((reponse==1)&flag) { if(q==1) menuvec<-c("Inside the X variables","Between X and Y") else menuvec<-c("Inside the X variables","Between X and Y","Inside the Y variables") cat("============================================================\n") reponseb<-menu(menuvec,title=" What kind of relationship?") cat("============================================================\n") switch(reponseb, {Ybiv<-X;Xbiv<-X},{Ybiv<-Y;Xbiv<-X},{Ybiv<-Y;Xbiv<-Y}) if(reponseb!=0) { cat("Graphs or matrix of Correlations (g/c)?\n") plctY<-scan(quiet=T,"",character(),1) if((length(plctY)==0)|(plctY=="c")) { if(reponseb==1) print(round(Dvar(X,D=D,cor=T)$V,2)) if(reponseb==2) print(round(Dvar(cbind(X,Y),D=D,cor=T)$V,2)) if(reponseb==3) print(round(Dvar(Y,D=D,cor=T)$V,2)) } else if(smooth=="reg.spline") { if(missing(listknots)|listknotsnullflag) resu<-bivarplot(X=Xbiv,Y=Ybiv,matrow=matrow,matcol=matcol,smooth=smooth,degree=degree,knots=knots, equiknots=equiknots,lambda=lambda,titlepar=titlepar,qual=qual,names.qual=names.qual, typedata=typedata,cexpar=cexpar,pchpar=pchpar,ptypar=ptypar,colpar=colpar,askpar=askpar,bgpar=bgpar,nbpoints=nbpoints) else resu<-bivarplot(X=Xbiv,Y=Ybiv,matrow=matrow,matcol=matcol,smooth=smooth,degree=degree,knots=knots, equiknots=equiknots,listknots=listknots,lambda=lambda,titlepar=titlepar,qual=qual,names.qual=names.qual, typedata=typedata,cexpar=cexpar,pchpar=pchpar,ptypar=ptypar,colpar=colpar,askpar=askpar,bgpar=bgpar,nbpoints=nbpoints) listknots0<-resu$listknots degree0<-resu$degree for(i in 1:ncol(X0))knots0[i]<-length(listknots0[[i]]) names(degree0)<-dimnames(X0)[[2]] names(listknots0)<-dimnames(X0)[[2]] names(knots0)<-dimnames(X0)[[2]] #browser() } else bivarplot(X=Xbiv,Y=Ybiv,matrow=matrow,matcol=matcol,smooth=smooth,lambda=lambda,titlepar=titlepar, typedata=typedata,cexpar=cexpar,pchpar=pchpar,ptypar=ptypar,colpar=colpar,askpar=askpar,bgpar=bgpar) par(mfrow=c(1,1),pty="m") #cat("Click on the plot to locate the legend !\n") def.par <- par(no.readonly = TRUE) layout(matrix(c(3,4,5,6,1,2),2,3,byrow=TRUE), heights=c(2,10),widths= c(3,10,1), TRUE) switch(reponseb, {par(mar=c(4,4,0,3)); image(1:p,1:p,Dvar(X,D=D,cor=T)$V,xlab="predictors",ylab="predictors",col=topo.colors(64),cex=cexpar); box(); par(mar=c(4,0,0,1)); image(1,seq(min(Dvar(X,D=D,cor=T)$V),1,length=64),t(matrix(1:64,64,1)),xaxt="n",yaxt="s",col=topo.colors(64),xlab="",ylab="",cex=cexpar); box(); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"Var.",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"names",cex=cexpar+0.2,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(0,0,"Image of Correlations",cex=cexpar+0.5,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"r",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"level",cex=cexpar+0.2,col="red"); plot(rep(0,5),-2:2,type="n",xlab="",ylab="",axes=F); text(rep(-0.3,p),seq(-1.5,2,length=p),paste(format(1:p),dimnames(X)[[2]]),cex=cexpar); }, {par(mar=c(4,4,0,3)); image(1:(p+q),1:(p+q),Dvar(cbind(X,Y),D=D,cor=T)$V,xlab="predictors + responses",ylab="predictors + responses",col=topo.colors(64),cex=cexpar); box(); par(mar=c(4,0,0,1)); image(1,seq(min(Dvar(cbind(X,Y),D=D,cor=T)$V),1,length=64),t(matrix(1:64,64,1)),xaxt="n",yaxt="s",col=topo.colors(64),xlab="",ylab="",cex=cexpar); box(); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"Var.",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"names",cex=cexpar+0.2,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(0,0,"Image of Correlations",cex=cexpar+0.5,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"r",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"level",cex=cexpar+0.2,col="red"); plot(rep(0,5),-2:2,type="n",xlab="",ylab="",axes=F); text(rep(-0.8,p+q),seq(-1.5,2,length=p+q),paste(format(1:(p+q)),c(dimnames(X)[[2]],dimnames(Y)[[2]])), col=c(rep("blue",p),rep("magenta",q)),cex=cexpar,pos=4)}, {par(mar=c(4,4,0,3)); image(1:q,1:q,Dvar(Y,D=D,cor=T)$V,xlab="responses",ylab="responses",col=topo.colors(64),cex=cexpar); box(); par(mar=c(4,0,0,1)); image(1,seq(min(Dvar(Y,D=D,cor=T)$V),1,length=64),t(matrix(1:64,64,1)),xaxt="n",yaxt="s",col=topo.colors(64),xlab="",ylab="",cex=cexpar); box(); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"Var.",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"names",cex=cexpar+0.2,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(0,0,"Image of Correlations",cex=cexpar+0.5,col="red"); par(mar=c(0,0,0,0)); plot(0,0,type="n",xlab="",ylab="",axes=F); text(-0.2,0,"r",cex=cexpar+0.2,col="red"); text(-0.2,-0.5,"level",cex=cexpar+0.2,col="red"); plot(rep(0,5),-2:2,type="n",xlab="",ylab="",axes=F); text(rep(-0.3,q),seq(-1.5,2,length=q),paste(format(1:q),dimnames(Y)[[2]]),cex=cexpar)} ) } par(def.par) }#endreponse1 #--------------------------------------------------------- if(reponse==4) { if(missing(listknots)|listknotsnullflag) { if(missing(Xtest)) { resulpls<-plss(X=X,Y=Y,standX=standX,standY=standY,D=D,A=A,degree=degree,knots=knots,equiknots=equiknots,eps=eps,impres=F, interaction=interaction,listinteraction=listinteraction,colpar=colpar,cexpar=cexpar,titlepar=titlepar) cat("NUMERICAL AND GRAPHICAL ISSUES :\n") cat("\n") plss.plot(resulpls,ptypar=ptypar,typedata=typedata,titlepar=titlepar,pchpar=pchpar,cexpar=cexpar, nbpoints=nbpoints,colpar=colpar,askpar=askpar,qual=qual,names.qual=names.qual) } else { if(missing(Ytest)) resulpls<-plss(X=X,Y=Y,Xtest=Xtest,standX=standX,standY=standY,D=D,A=A,degree=degree,knots=knots, equiknots=equiknots,eps=eps,impres=T,interaction=interaction,listinteraction=listinteraction, colpar=colpar,cexpar=cexpar,titlepar=titlepar) else resulpls<-plss(X=X,Y=Y,Xtest=Xtest,Ytest=Ytest,standX=standX,standY=standY,D=D,A=A,degree=degree, knots=knots,equiknots=equiknots,eps=eps,impres=T,interaction=interaction,listinteraction=listinteraction,colpar=colpar,cexpar=cexpar,titlepar=titlepar) cat("NUMERICAL AND GRAPHICAL ISSUES :\n") cat("\n") plss.plot(resulpls,Xtest,ptypar=ptypar,typedata=typedata,titlepar=titlepar,pchpar=pchpar,cexpar=cexpar, nbpoints=nbpoints,colpar=colpar,askpar=askpar,qual=qual,names.qual=names.qual) }#endmissingXtest } else { if(missing(Xtest)) { resulpls<-plss(X=X,Y=Y,standX=standX,standY=standY,D=D,A=A,degree=degree,listknots=listknots, eps=eps,impres=F,interaction=interaction,listinteraction=listinteraction,colpar=colpar,cexpar=cexpar, titlepar=titlepar) if(resulpls$nomfichX=="NON4")return() cat("NUMERICAL AND GRAPHICAL ISSUES :\n") cat("\n") plss.plot(resulpls,ptypar=ptypar,typedata=typedata,titlepar=titlepar,pchpar=pchpar, cexpar=cexpar,nbpoints=nbpoints,colpar=colpar,askpar=askpar,qual=qual,names.qual=names.qual) } else { if(missing(Ytest)) resulpls<-plss(X=X,Y=Y,Xtest=Xtest,standX=standX,standY=standY,D=D,A=A,degree=degree,listknots= listknots,eps=eps,impres=T,interaction=interaction,listinteraction=listinteraction,colpar=colpar,cexpar=cexpar,titlepar=titlepar) else resulpls<-plss(X=X,Y=Y,Xtest=Xtest,Ytest=Ytest,standX=standX,standY=standY,D=D,A=A,degree=degree, listknots=listknots,eps=eps,impres=T,interaction=interaction,listinteraction=listinteraction,colpar=colpar,cexpar=cexpar,titlepar=titlepar) cat("NUMERICAL AND GRAPHICAL ISSUES :\n") cat("\n") plss.plot(resulpls,Xtest,ptypar=ptypar,typedata=typedata,titlepar=titlepar,pchpar=pchpar,cexpar=cexpar, nbpoints=nbpoints,colpar=colpar,askpar=askpar,qual=qual,names.qual=names.qual) }#endmissingXtest }#endifelsemissinglistknots A<-resulpls$axes } #--------------------------------------------------------- if((reponse==2)|(reponse==3)) { cat("Enter the maximum number of components (dimensions) to explore \n") Aexplore<-scan(quiet=T,"",numeric(),1) if(reponse==2) i<-1 else i<-0 campaign<-matrix(0,1,Aexplore+2) if(reponse==2) dimnames(campaign)<-list(format(i),c("prop","Dim",format(1:Aexplore))) else dimnames(campaign)<-list(format(i),c("alpha","Dim",format(1:Aexplore))) if(reponse==2) { repeat{ if(missing(listknots)|listknotsnullflag) plscvresul<-plsscv(X,Y,standX=standX,standY=standY,interaction=interaction,D=D,A=Aexplore, degree=degree,knots=knots,equiknots=equiknots,prop=prop,GCV=0) else plscvresul<-plsscv(X,Y,standX=standX,standY=standY,interaction=NULL,D=D,A=Aexplore, degree=degree,knots=knots,equiknots=equiknots,listknots=listknots,prop=prop,GCV=0) plscvresul<-plscv.plot(plscvresul,colpar=colpar,cexpar=cexpar,titlepar=titlepar,bg=par("bg")) campaign[i,]<-c(prop,plscvresul$A,round(plscvresul[[1]],5)) cat("Another proportion of left-predicted observations,(y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if((repo!="y")&(repo!="Y"))break cat("Enter prop (< 0.5):") prop<-scan(quiet=T,"",numeric(),1) i<-i+1 campaign<-rbind(campaign,rep(0,Aexplore+2)) dimnames(campaign)[[1]][i]<-format(i) }#endrepeat matrice<-campaign[,3:(Aexplore + 2),drop=F] campaignmean<-apply(matrice,2,"mean") campaignstdv<-sqrt(apply(matrice,2,"var")) campaign<-rbind(campaign,c(NA,NA,campaignmean)) campaign[nrow(campaign),2]<-round(campaign[nrow(campaign),2]) dimnames(campaign)[[1]][nrow(campaign)]<-"mean" campaign<-rbind(campaign,c(prop,plscvresul$A,campaignmean + 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean+2sdv" campaign<-rbind(campaign,c(prop,plscvresul$A,campaignmean - 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean-2sdv" campaign[(nrow(campaign)-1):nrow(campaign),2]<-NA if(nrow(campaign)>4){ par(mfrow=c(1,1)) ts.plot(ts(t(campaign[,3:(Aexplore+2)])),gpars=list(xlab="Model Dim.",ylab="PRESS",type="n", main="CV experiments' summary",cex=cexpar,bg=par("bg"))) for(i in 1:(nrow(campaign)-2)){ points(1:Aexplore,campaign[i,3:(Aexplore+2)],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[i,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) } points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],pch=i+1,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],pch=i+2,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],type="l",lty=i,col=colpar+i) cat("Click to locate the top left corner of the legend\n") legend(locator(1),c(campaign[1:(nrow(campaign)-3),1],"mean","mean+2sdv","mean-2sdv"),pch=1:nrow(campaign),bty="o",col=c(colpar+(1:(nrow(campaign)-2)), colpar+rep((nrow(campaign)-2),2)),cex=cexpar,ncol=max(nrow(campaign)%/%5,1), text.col=c(colpar+(1:(nrow(campaign)-2)),colpar+rep((nrow(campaign)-2),2))) print(campaign[1:(nrow(campaign)-2),]) cat("Choose the best experiment row number ( 1<= # <=",nrow(campaign)-3,")") exp0<-scan(quiet=T,"",numeric(),1) plscvresul[[2]]<-campaign[exp0,3:(Aexplore+2)] plscvresul$A<-campaign[exp0,2] #prop<-eval(parse("",text=dimnames(campaign)[[1]][exp0])) prop<-campaign[exp0,1] cat("Retained experiment values\n") cat("PRESS(",prop,",",plscvresul$A,")=",plscvresul[[2]][plscvresul$A],"\n",sep="") } }#endreponse==2 else { repeat {# repeat{ cat("GCV(k,alpha)= ASR/(1-alpha*k/n)^2\n") cat("where ASR=Average Squared Residuals, k=dimension\n") cat("Enter alpha (>0) the tuning parameter :\n") GCV<-scan(quiet=T,"",numeric(),1) if(GCV*Aexplore/nrow(X)>=1) cat("Try a smaller value!\n") else break } i<-i+1 if(missing(listknots)|listknotsnullflag) plscvresul<-plsscv(X,Y,standX=standX,standY=standY,interaction=interaction,D=D,A=Aexplore, degree=degree,knots=knots,equiknots=equiknots,prop=prop,GCV=GCV) else plscvresul<-plsscv(X,Y,standX=standX,standY=standY,interaction=NULL,D=1,A=Aexplore, degree=degree,knots=knots,equiknots=equiknots,listknots=listknots,prop=prop,GCV=GCV) plscvresul<-plscv.plot(plscvresul,colpar=colpar,cexpar=cexpar,titlepar=titlepar,bg=par("bg")) campaign<-rbind(campaign,matrix(c(GCV,plscvresul$A,round(plscvresul[[1]],5)),1,Aexplore+2)) if(i==1)campaign<-campaign[-1,,drop=F] dimnames(campaign)[[1]][i]<-format(i) #campaign[i,]<-c(GCV,plscvresul$A,round(plscvresul[[2]],5)) cat("Another GCV try,(y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break }#endrepeat if(reponse==3) {## matrice<-campaign[,3:(Aexplore + 2),drop=F] campaignmean<-apply(matrice,2,"mean") campaignstdv<-sqrt(apply(matrice,2,"var")) campaign<-rbind(campaign,c(NA,NA,campaignmean)) campaign[nrow(campaign),2]<-round(campaign[nrow(campaign),2]) dimnames(campaign)[[1]][nrow(campaign)]<-"mean" campaign<-rbind(campaign,c(GCV,plscvresul$A,campaignmean + 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean+2sdv" campaign<-rbind(campaign,c(GCV,plscvresul$A,campaignmean - 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean-2sdv" campaign[(nrow(campaign)-1):nrow(campaign),2]<-NA if(nrow(campaign)>4){ par(mfrow=c(1,1)) ts.plot(ts(t(campaign[,3:(Aexplore+2)])),gpars=list(xlab="Model Dim.",ylab="GCV",type="n", main="CV experiments' summary",cex=cexpar)) for(i in 1:(nrow(campaign)-2)){ points(1:Aexplore,campaign[i,3:(Aexplore+2)],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[i,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) } points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],pch=i+1,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],pch=i+2,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],type="l",lty=i,col=colpar+i) cat("Click to locate the top left corner of the legend\n") legend(locator(1),c(campaign[1:(nrow(campaign)-3),1],"mean","mean+2sdv","mean-2sdv"),pch=1:nrow(campaign),bty="o",col=c(colpar+(1:(nrow(campaign)-2)), colpar+rep((nrow(campaign)-2),2)),cex=cexpar,ncol=max(nrow(campaign)%/%5,1), text.col=c(colpar+(1:(nrow(campaign)-2)),colpar+rep((nrow(campaign)-2),2))) print(campaign[1:(nrow(campaign)-2),]) cat("Choose the best experiment row number ( 1<= # <=",nrow(campaign)-3,")") exp0<-scan(quiet=T,"",numeric(),1) plscvresul[[2]]<-campaign[exp0,3:(Aexplore+2)] plscvresul$A<-campaign[exp0,2] #prop<-eval(parse("",text=dimnames(campaign)[[1]][exp0])) GCV<-campaign[exp0,1] cat("Retained experiment values\n") cat("GCV(",GCV,",",plscvresul$A,")=",plscvresul[[2]][plscvresul$A],"\n",sep="") } }## }#end else <==> endreponse==3 A<-plscvresul$A } #--------------------------------------------------------- if(reponse==5) { Xvariables<-selectvar(X0,Xvariables=Xvariables) } #--------------------------------------------------------- if(reponse==0) { break} }#finrepeat invisible(list(Xvariables=Xvariables,degree=degree0,knots=knots0,equiknots=equiknots0,listknots=listknots0)) } ########################################################### plscalibration<-function(X,Y,spect=1:nrow(X),Xtest,Ytest,spectest,byscale=1,standY=T,A=2, prop=0.1,thetapar=-60,phipar=30,rpar=10,steps=F,steporder=T,cexpar=0.7,askpar=F,ptypar="m",colpar=1, titlestring="Training Sample",matcol=3,matrow=1,titlepar=T,bgpar="peachpuff") { par(ask=askpar) oldpar<-par(no.readonly = TRUE) par(ask=F,bg=bgpar,mfrow=c(1,1),bty="n",xaxt="n",yaxt="n") plot(0,0,type="n",bg=par("bg"),xlab="",ylab="",xlim=c(-4,4),ylim=c(-4,4)) text(0,3.5,"Linear Partial Least-Squares",cex=1.7,col="red") text(0,1.5,"for Calibration in",cex=1.7,col="red") text(0,-0.5,"Near Infrared Spectroscopy",cex=1.7,col="red") text(0,-2,"J.F. Durand, Montpellier 2 University",cex=1,col="blue") text(0,-3,"www.jf-durand-pls.com",cex=0.9,col="blue") par(oldpar) par(ask=askpar,bg=bgpar,xaxt="s",yaxt="s") Xini<-as.matrix(X) Yini<-as.matrix(Y) X<-Xini[spect,,drop=F] Y<-Yini[spect,,drop=F] n<-nrow(X)# nombre de spectres effectivement traites pini<-ncol(X)# nombre de "temps" initiaux (peut etre trop nombreux) q<-ncol(Y) echini<-dimnames(X)[[2]] mode(echini)<-"numeric"# echini est le vecteur des "temps" initialement pris en compte #ech<-seq(min(echini),max(echini),by=byscale)# ech est le sous-vecteur de echini avec un "pas" egal a byscale nbcol<-seq(1,ncol(Xini),by=byscale) X<-X[,nbcol]# matrice des absorbances effectivement prise en compte ech<-dimnames(X)[[2]] mode(ech)<-"numeric"# ech est le vecteur des "temps" pris en compte p<-ncol(X)# nombre de "temps" effectivement traités #calcul du spectre moyen et des ecarts types moyen<-apply(X,2,mean) sigma<-sqrt(apply(X,2,var)) if(missing(Xtest)){ Xtest<-Xini if(missing(spectest)) spectest<-spect Xtest<-Xtest[spectest,nbcol,drop=F] } else { if(missing(spectest)) spectest<-1:nrow(Xtest) Xtest<-Xtest[spectest,nbcol,drop=F] } repeat { if(p>=1000)cat("Too many wavelegths (>1000). Use byscale = 2 ou 3...\n") cat("==========================================================\n") reponse<-menu(c("Looking at the spectra","Cross Validation","Generalized Cross Validation", "Conversational PLS"),title="PLS for 'Near Infrared Spectroscopy' (0 to exit)") cat("==========================================================\n") if(reponse==1) { par(mfrow=c(1,1),pty=ptypar) if(steporder){debut<-1 fin<-n pas<-1} else {debut<-n fin<-1 pas<--1} plot(ech,X[debut,],xlab="wavelengths",ylab="Absorbance",xlim=range(echini),ylim=range(X),col=1,type="l",main=titlestring,cex=cexpar) for(i in (debut+pas):fin) { if(steps){ cat(paste("spectrum",dimnames(X)[[1]][i-pas],"\n")) cat("ENTER for the next") plctY<-scan(quiet=T,"",character(),n=1) } points(ech,X[i,],type="l",col=i) } if(steps){ cat(paste("spectrum",dimnames(X)[[1]][fin],"\n")) cat("ENTER to end") scan(quiet=T,"",character(),n=1) } #plot du spectre moyen et de la dispersion par(mfrow=c(matrow,matcol),pty=ptypar) moyen.rts<- moyen moyen.df2 <- diff(moyen.rts, 1,2) moyen.df1<- diff(moyen.rts, 1,1) ylimite<-range(cbind(moyen,moyen+2*sigma,moyen-2*sigma)) plot(ech,moyen,xlab="wavelengths",ylab="Mean (+ -) 2*Stand. Dev.",xlim=range(echini), ylim=ylimite,type="n",cex=cexpar,bg=par("bg")) points(ech,moyen,type="l",col=colpar) points(ech,moyen+2*sigma,col=colpar+2,type="l") points(ech,moyen-2*sigma,col=colpar+2,type="l") plot(supsmu(ech[-1],moyen.df1/(byscale/diff(range(echini)))),type="n",cex=cexpar,xlab="wavelengths",ylab="First Derivative") lines(supsmu(ech[-1],moyen.df1/(byscale/diff(range(echini)))),col=colpar+1) abline(h=0) plot(supsmu(ech[-(1:2)],moyen.df2/(byscale/diff(range(echini)))^2),type="n",cex=cexpar,xlab="wavelengths",ylab="Second Derivative") lines(supsmu(ech[-(1:2)],moyen.df2/(byscale/diff(range(echini)))^2),col=colpar+1) abline(h=0) if((matrow!=1)|(matcol!=1))mtext(side=3,line=-2,cex=cexpar+0.5,outer=TRUE,titlestring) #plot du graphique matriciel (surface) par(mfrow=c(1,1),pty=ptypar) # persp.setup(lty=c(1,1,1), col=c(colpar+1,colpar+1,colpar+1), lwd=c(1,0,1)) persp(1:n,ech,X,xlab="samples",ylab="wavelengths",zlab="absorbance",theta=thetapar,phi=phipar,r=rpar,ticktype="detailed",cex=cexpar,col=colpar+1) title(main = titlestring,col=colpar+1) def.par <- par(no.readonly = TRUE) layout(matrix(c(3,4,1,2),2,2,byrow=TRUE), c(10,1), c(1,10), TRUE) #layout(matrix(c(1,2),1,2,byrow=T),widths=c(85,15)) par(mar=c(4,4,0,3)) image(ech,1:n,t(X),ylab="samples",xlab="wavelengths",col=topo.colors(64)) box() par(mar=c(4,0,0,1)) image(1,seq(min(X),max(X),length=64),t(matrix(1:64,64,1)),xaxt="n",yaxt="s",col=topo.colors(64), xlab="",ylab="",cex=cexpar) box() par(mar=c(0,0,0,0)) plot(0,0,type="n",xlab="",ylab="",axes=F) text(0,0,titlestring,cex=cexpar+0.5,col="red") par(mar=c(0,0,0,0)) plot(0,0,type="n",xlab="",ylab="",axes=F) text(-0.2,0,"Abso.",cex=cexpar+0.2,col="red") text(-0.2,-0.5,"Level",cex=cexpar+0.2,col="red") par(def.par) } #--------------------------------------------------------- if(reponse==4) {if(!missing(Ytest)) plsresult<-pls(X,Y,Xtest=Xtest,Ytest=Ytest[spectest,,drop=F],standX=F,standY=standY,A=A,askpar=askpar, calibration=T,cexpar=cexpar,colpar=colpar,pty=ptypar) else plsresult<-pls(X,Y,Xtest=Xtest,standX=F,standY=standY,A=A,askpar=askpar,calibration=T, cexpar=cexpar,colpar=colpar,pty=ptypar) A<-plsresult$A } #--------------------------------------------------------- if((reponse==2)|(reponse==3)) { cat("Enter the maximum number of components (dimensions) to explore \n") Aexplore<-scan(quiet=T,"",numeric(),1) if(reponse==2) i<-1 else i<-0 campaign<-matrix(0,1,Aexplore+2) if(reponse==2) dimnames(campaign)<-list(format(i),c("prop","Dim",format(1:Aexplore))) else dimnames(campaign)<-list(format(i),c("alpha","Dim",format(1:Aexplore))) if(reponse==2) { repeat{ plscvresul<-plscv(X,Y,standX=F,standY=standY,A=Aexplore,prop=prop,GCV=0) plscvresul<-plscv.plot(plscvresul,colpar=colpar,cexpar=cexpar,titlepar=titlepar,bg=par("bg")) campaign[i,]<-c(prop,plscvresul$A,round(plscvresul[[1]],5)) cat("Another proportion of left-predicted observations,(y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break cat("Enter prop (< 0.5):") prop<-scan(quiet=T,"",numeric(),1) i<-i+1 campaign<-rbind(campaign,rep(0,Aexplore+2)) dimnames(campaign)[[1]][i]<-format(i) }#endrepeat matrice<-campaign[,3:(Aexplore + 2),drop=F] campaignmean<-apply(matrice,2,"mean") campaignstdv<-sqrt(apply(matrice,2,"var")) campaign<-rbind(campaign,c(NA,NA,campaignmean)) campaign[nrow(campaign),2]<-round(campaign[nrow(campaign),2]) dimnames(campaign)[[1]][nrow(campaign)]<-"mean" campaign<-rbind(campaign,c(prop,plscvresul$A,campaignmean + 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean+2sdv" campaign<-rbind(campaign,c(prop,plscvresul$A,campaignmean - 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean-2sdv" campaign[(nrow(campaign)-1):nrow(campaign),2]<-NA if(nrow(campaign)>4){ par(mfrow=c(1,1)) ts.plot(ts(t(campaign[,3:(Aexplore+2)])),gpars=list(xlab="Model Dim.",ylab="PRESS",type="n", main="CV experiments' summary",cex=cexpar)) for(i in 1:(nrow(campaign)-2)){ points(1:Aexplore,campaign[i,3:(Aexplore+2)],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[i,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) } points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],pch=i+1,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],pch=i+2,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],type="l",lty=i,col=colpar+i) cat("Click to locate the top left corner of the legend\n") legend(locator(1),c(campaign[1:(nrow(campaign)-3),1],"mean","mean+2sdv","mean-2sdv"),pch=1:nrow(campaign),bty="o",col=c(colpar+(1:(nrow(campaign)-2)), colpar+rep((nrow(campaign)-2),2)),cex=cexpar,ncol=max(nrow(campaign)%/%5,1), text.col=c(colpar+(1:(nrow(campaign)-2)),colpar+rep((nrow(campaign)-2),2))) print(campaign[1:(nrow(campaign)-2),]) cat("Choose the best experiment row number ( 1<= # <=",nrow(campaign)-3,")") exp0<-scan(quiet=T,"",numeric(),1) plscvresul[[2]]<-campaign[exp0,3:(Aexplore+2)] plscvresul$A<-campaign[exp0,2] prop<-campaign[exp0,1] cat("Retained experiment values\n") cat("PRESS(",prop,",",plscvresul$A,")=",plscvresul[[2]][plscvresul$A],"\n",sep="") } } else { repeat {# repeat{ cat("GCV(k,alpha)= ASR/(1-alpha*k/n)^2\n") cat("where ASR=Average Squared Residuals, k=dimension\n") cat("Enter alpha (>0) the tuning parameter:") GCV<-scan(quiet=T,"",numeric(),1) if(GCV*Aexplore/nrow(X)>=1) cat("Try a smaller value!\n") else break } i<-i+1 plscvresul<-plscv(X,Y,standX=F,standY=standY,A=Aexplore,prop=prop,GCV=GCV) plscvresul<-plscv.plot(plscvresul,colpar=colpar,cexpar=cexpar,titlepar=titlepar,bg=par("bg")) campaign<-rbind(campaign,matrix(c(GCV,plscvresul$A,round(plscvresul[[1]],5)),1,Aexplore+2)) if(i==1)campaign<-campaign[-1,,drop=F] dimnames(campaign)[[1]][i]<-format(i) cat("Another GCV try,(y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break }#endrepeat if(reponse==3) {## matrice<-campaign[,3:(Aexplore + 2),drop=F] campaignmean<-apply(matrice,2,"mean") campaignstdv<-sqrt(apply(matrice,2,"var")) campaign<-rbind(campaign,c(NA,NA,campaignmean)) campaign[nrow(campaign),2]<-round(campaign[nrow(campaign),2]) dimnames(campaign)[[1]][nrow(campaign)]<-"mean" campaign<-rbind(campaign,c(GCV,plscvresul$A,campaignmean + 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean+2sdv" campaign<-rbind(campaign,c(GCV,plscvresul$A,campaignmean - 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean-2sdv" campaign[(nrow(campaign)-1):nrow(campaign),2]<-NA if(nrow(campaign)>4){ par(mfrow=c(1,1)) ts.plot(ts(t(campaign[,3:(Aexplore+2)])),gpars=list(xlab="Model Dim.",ylab="GCV",type="n", main="CV experiments' summary",cex=cexpar)) for(i in 1:(nrow(campaign)-2)){ points(1:Aexplore,campaign[i,3:(Aexplore+2)],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[i,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) } points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],pch=i+1,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],pch=i+2,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],type="l",lty=i,col=colpar+i) cat("Click to locate the top left corner of the legend\n") legend(locator(1),c(campaign[1:(nrow(campaign)-3),1],"mean","mean+2sdv","mean-2sdv"),pch=1:nrow(campaign),bty="o",col=c(colpar+(1:(nrow(campaign)-2)), colpar+rep((nrow(campaign)-2),2)),cex=cexpar,ncol=max(nrow(campaign)%/%5,1), text.col=c(colpar+(1:(nrow(campaign)-2)),colpar+rep((nrow(campaign)-2),2))) print(campaign[1:(nrow(campaign)-2),]) cat("Choose the best experiment row number ( 1<= # <=",nrow(campaign)-3,")") exp0<-scan(quiet=T,"",numeric(),1) plscvresul[[2]]<-campaign[exp0,3:(Aexplore+2)] plscvresul$A<-campaign[exp0,2] GCV<-campaign[exp0,1] cat("Retained experiment values\n") cat("GCV(",GCV,",",plscvresul$A,")=",plscvresul[[2]][plscvresul$A],"\n",sep="") } }## } A<-plscvresul$A } #--------------------------------------------------------- if(reponse==0)break }#endrepeat } ########################################################### bivarplot<-function(X,Y=X,matrow=1,matcol=1,smooth="reg.spline",degree=1,knots=0, equiknots=F,listknots,lambda=0.6,titlepar=T,typedata=T,qual,names.qual, cexpar=0.7,pchpar=1,ptypar="s",colpar=1,askpar=T,bgpar="gray",nbpoints=100) { X<-as.matrix(X) Y<-as.matrix(Y) p<-ncol(X) q<-ncol(Y) n<-nrow(X) nods<-knots if(is.null(dimnames(X)))dimnames(X)<-list(format(1:n),paste("X",1:p,sep="")) if(is.null(dimnames(Y)))dimnames(Y)<-list(format(1:n),paste("Y",1:q,sep="")) if(length(dimnames(X)[[1]])==0) dimnames(X)[[1]]<- format(1:n) if(length(dimnames(Y)[[1]])==0) dimnames(Y)[[1]]<- format(1:n) if(length(dimnames(X)[[2]])==0) dimnames(X)[[2]]<- paste("X",1:p,sep="") if(length(dimnames(Y)[[2]])==0) {cat("Affect name(s) to the response(s)\n") prov<-as.vector(format(1:q)) for(i in 1:q) {cat(paste("response ",format(i),"\n")) prov[i]<-scan(quiet=T,what="", 1) } dimnames(Y)[[2]]<-prov } if(q>1){ cat("The number of the response? (<=",q,")") j <- scan(quiet=T,"", numeric(),1) } else j<-1 par(mfrow=c(matrow,matcol),pty=ptypar) par(ask=askpar) par(bg=bgpar) devtype<-sum(c(matrow,matcol)) if(smooth=="reg.spline"){ if(devtype==2)cat("Choose now the degrees and the knots :\n") knots<-list(NULL) for(i in 1:(ncol(X)-1))knots<-c(knots,c(list(NULL))) names(knots)<-dimnames(X)[[2]] knots2<-knots degree<-degree if(length(degree)==1)degree<-rep(degree,ncol(X)) if(length(nods)==1)nods<-rep(nods,ncol(X)) if(!missing(listknots))knots1<-listknots else knots1<-knots if((devtype>2)&!missing(names.qual)) { oldpar<-par(no.readonly = TRUE) par(bty="n",xaxt="n",yaxt="n") plot(c(-1,1),c(-1,1),xlab="",ylab="",type="n") legend(0,0,names.qual,x.intersp=cexpar,y.intersp=cexpar,bty="n", text.col=colpar+(min(qual):max(qual))+1,cex=1,fill=colpar+(min(qual):max(qual))+1,xjust=0.5,yjust=0.5) par(bty="o",xaxt="s",yaxt="s") #par(oldpar) } } for(i in 1:p) {# Z<-sum((Y[,j]-X[,i])^2) if(Z>1e-16) { if(smooth!="reg.spline"){ if((matrow==1)&(matcol==1))plot(X[,i],Y[,j],type="n",xlab=dimnames(X)[[2]][i],ylab=dimnames(Y)[[2]][j], cex=cexpar,main=paste("R² = ",format(round(cor(X[,i],Y[,j])^2,4)),sep=""),bg=par("bg")) else plot(X[,i],Y[,j],type="n",xlab=dimnames(X)[[2]][i],ylab="",cex=cexpar,bg=par("bg")) if(!typedata)points(X[, i],Y[,j],pch=pchpar,cex=cexpar,col=colpar+3) else text(X[,i],Y[,j],dimnames(X)[[1]],cex=cexpar,col=colpar+3) } if(smooth=="reg.spline") {## if(!missing(listknots)) resu<-lss(X[,i,drop=F],Y[,j,drop=F],listknots=list(c(knots1[[i]])),degree=degree[i],knots=nods[i], equiknots=equiknots[i],fonct=T,askpar=F,cexpar=cexpar,colpar=colpar,ptypar=ptypar,nbpoints=nbpoints,qual=qual) else resu<-lss(X[,i,drop=F],Y[,j,drop=F],degree=degree[i],knots=nods[i], equiknots=equiknots[i],fonct=T,askpar=F,cexpar=cexpar,colpar=colpar,ptypar=ptypar,nbpoints=nbpoints,qual=qual) par(ask=askpar) title(main=paste("R² = ",format(round(resu$R2,4)),sep=""),cex.main=cexpar+0.3) if(!missing(names.qual)) { long<-length(names.qual) if(sum(c(matrow,matcol))==2) legend(max(X[,i])-diff(range(X[,i]))/7,max(Y[,j]),names.qual,x.intersp=cexpar,y.intersp=cexpar,bty="o", text.col=colpar+(min(qual):max(qual))+1,cex=cexpar,fill=colpar+(min(qual):max(qual))+1) } if(devtype==2) {#11 repeat {### if(resu$knots!=0)knots[[i]]<-resu$intknots[[1]] repeat{ cat("The degree and the knots for",dimnames(X)[[2]][i],"(y,Y/n,N)?") repo<-scan(quiet=T,what=character(),n=1) if(length(repo)==0) {repo<-"n" break } if((repo=="y")|(repo=="Y"))break if((repo=="n")|(repo=="N"))break } if((repo=="y")|(repo=="Y")) {#y repeat{ cat("the degree :") toto<-scan(quiet=T,"", character(),n=1) cat("OK (y,Y/n,N) for ",toto," ") repon<-scan(quiet=T,what=character(),n=1) if(length(repon)==0)repon<-"y" if((repon=="y")|(repon=="Y")) if((length(toto)!=0)&&!is.na(as.numeric(toto)))break } degree[i]<-as.numeric(toto) repeat{ cat("the knots' locations, NULL if no knots :\n") toto<-scan(quiet=T,what=character()) if(length(toto)==0)cat("OK (y,Y/n,N) for ",format(knots[[i]])," ") else cat("OK (y,Y/n,N) for ",toto," ") repin<-scan(quiet=T,what=character(),n=1) if(length(repin)==0)repin<-"y" if((repin=="y")|(repin=="Y"))break } if((length(toto)==1)&&(toto!="NULL"))knots[[i]]<-eval(parse("",text=toto)) if((length(toto)==1)&&(toto=="NULL")) { knotsinter<-knots knots<-knots2 if(i>1) for(k in 1:(i-1))if(!is.null(knotsinter[[k]]))knots[[k]]<-knotsinter[[k]] } if(length(toto)>1) {#* titi<-rep(0,length(toto)) for(k in 1:length(toto)) titi[k]<-eval(parse("",text=toto[k])) knots[[i]]<-titi }#* resu<-lss(X[,i,drop=F],Y[,j,drop=F],listknots=list(c(knots[[i]])),degree=degree[i],fonct=T,askpar=F, cexpar=cexpar,colpar=colpar,ptypar=ptypar,nbpoints=nbpoints,qual=qual) par(ask=askpar) title(main=paste("R² = ",format(round(resu$R2,4)),sep=""),cex.main=cexpar+0.3) if(!missing(names.qual)) { long<-length(names.qual) legend(max(X[,i])-diff(range(X[,i]))/7,max(Y[,j]),names.qual,x.intersp=cexpar,y.intersp=cexpar,bty="o", text.col=colpar+(min(qual):max(qual))+1,cex=cexpar,fill=colpar+(min(qual):max(qual))+1) } cat("Another try? ") }#y else break }### }#11 }## else{ switch(smooth,lowess=,lines(lowess(X[,i],Y[,j],f=lambda),col=colpar+1), supsmu=,lines(supsmu(X[,i],Y[,j],span=lambda),col=colpar+1), ksmooth=,lines(ksmooth(X[,i],Y[,j],bandwith=lambda,kernel="normal"),col=colpar+1), smooth.spline=,lines(smooth.spline(X[,i],Y[,j],spar=lambda),col=colpar+1), ) } } }# if(titlepar) if((matrow!=1)|(matcol!=1)){ if(smooth!="reg.spline") mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("(",dimnames(Y)[[2]][j]," , predictor) scatterplots smoothed by '", smooth,"(",lambda,")'",sep="")) } if(smooth=="reg.spline") return(smooth,degree=degree,listknots=knots) else invisible(smooth) } ########################################################### pls<-function(X,Y,Xtest,Ytest,standX=T,standY=T,D=1,A=1,eps=1e-08,splflag=F,impres=T,graph=T, titlepar=T,ptypar="s",cexpar=0.8,pchpar=1,typedata=T,colpar=0.7,askpar=T,calibration=F,qual,names.qual) { # # Regression PLS lineaire # lecture des donnees if(impres==F)graph<-F nomfichX<-deparse(substitute(X)) nomfichY<-deparse(substitute(Y)) X<-as.matrix(X) Y<-as.matrix(Y) Yinitial<-Y n<-nrow(X) p<-ncol(X) q<-ncol(Y) if(is.null(dimnames(X)))dimnames(X)<-list(format(1:n),paste("X",1:p,sep="")) if(is.null(dimnames(Y)))dimnames(Y)<-list(format(1:n),paste("Y",1:q,sep="")) if(length(dimnames(X)[[1]])==0) dimnames(X)[[1]]<- format(1:n) if(length(dimnames(Y)[[1]])==0) dimnames(Y)[[1]]<- format(1:n) if(length(dimnames(X)[[2]])==0) dimnames(X)[[2]]<- paste("X",1:p,sep="") if(length(dimnames(Y)[[2]])==0) dimnames(Y)[[2]]<- paste("Y",1:q,sep="") # calcul de la metrique si D=1 # if(length(D)==1) D<-rep(1/n,n) else D<-as.vector(D) # centrage et reduction centX<-Dcentred(X,D=D) centY<-Dcentred(Y,D=D) if(standX) X<-centX$Xcr else X<-centX$Xc if(standY) Y<-centY$Xcr else Y<-centY$Xc if(!missing(Xtest)) { if(is.null(dimnames(Xtest)))dimnames(Xtest)<-list(format(1:nrow(Xtest)),dimnames(X)[[2]]) Xinitest<-sweep(Xtest, 2,centX$moy) if(standX) Xinitest<- sweep(Xinitest,2,sqrt(centX$var),FUN="/") dimnames(Xinitest)<-dimnames(Xtest) } if(!missing(Ytest)) { if(is.null(dimnames(Ytest)))dimnames(Ytest)<-list(format(1:nrow(Ytest)),dimnames(Y)[[2]]) Yinitest<-sweep(Ytest, 2,centY$moy) if(standY) Yinitest<-sweep(Yinitest,2,sqrt(centY$var),FUN="/") dimnames(Yinitest)<-dimnames(Ytest) } Xini<-as.matrix(X) Yini<-as.matrix(Y) varX<-centX$var varY<-centY$var SYX<-NULL # matrice de covariance entre Y et X inertotY<-sum(diag(VQop(Y,D=D))) inertotX<-sum(diag(VQop(X,D=D))) if(!splflag) VARX<-"VAR X" else VARX<-"VAR B" if(impres) { cat("__________________________________________________________________\n") cat(" - Linear PLS -\n") cat(paste("Total Variance of Y =",format(inertotY),"\n")) if(splflag) cat(paste("Total Variance of B =",format(inertotX),"\n")) else cat(paste("Total Variance of X =",format(inertotX),"\n")) } # initialisation w<-NULL # facteur de X cc<-NULL # facteur de Y tt<-NULL # composante de X u<-NULL # composante de Y RtX<-NULL # correlations entre t et X RtY<-NULL # correlations entre t et Y YH<-list(NULL) # modele de Y YR<-list(NULL) # residu de Y alpha <- matrix(0,nrow=p,ncol=1)# poids de X pour t alph <- list(NULL) # liste des alpha COMP<-matrix(0,nrow=p,ncol=p) # compteur pour le calcul des alpha BETA<-matrix(0,nrow=p,ncol=q) # coefficients du modele Y explique par X apres A etapes dimnames(BETA)<-list(dimnames(X)[[2]],dimnames(Y)[[2]]) BETALCR<-list(NULL) # liste des coeff du modele CR suivant le nb d'axes BETAL<-list(NULL) # liste des coeff du modele suivant le nb d'axes cov<-as.numeric(0) # covariance optimale covXY<-NULL # vecteur des covariances optimales VY<-NULL # vecteur des variances des composantes de Y VX<-NULL # vecteur des variances des composantes de X IEY<-NULL # vecteur des inerties de Y expliquees IEX<-NULL # vecteur des inerties de X expliquees R2<-rep(0,q) # vecteur des R2 R2c<-matrix(0,q,1) WX<-matrix(0,p,A) # matrice des facteurs de X CY<-matrix(0,q,A) # matrice des facteurs de Y TX<-NULL # matrice des composantes de X UY<-NULL # matrice des composantes de Y RU<-NULL # matrice de correlations entre les composantes de Y normc<-as.numeric(0) normw<-as.numeric(0) k<-0 inerexpY<-as.numeric(0) inerexpX<-as.numeric(0) varty<-NULL # debut boucle axe repeat { k<-k+1 if(impres) { cat("__________________________________________________________________\n") cat(paste("Dimension",format(k),"\n")) cat("\n") } XtDY<-Dcp(X,Y,D=D) if(p<=q) { vpvp<-eigen(XtDY%*%t(XtDY),symmetric=T) cov<-sqrt(vpvp$values[1]) if(p==1){tt<-X w<-matrix(1,1,1) } else{ w<-as.matrix(vpvp$vectors[,1]) tt<-X%*%w } cc<-t(XtDY)%*%w normc<-sqrt(sum(cc^2)) cc<-cc/normc u<-Y%*%cc } else { vpvp<-eigen(t(XtDY)%*%XtDY,symmetric=T) cov<-sqrt(vpvp$values[1]) if(q==1){u<-Y cc<-matrix(1,1,1) } else {cc<-as.matrix(vpvp$vectors[,1]) u<-Y%*%cc } w<-XtDY%*%cc normw<-sqrt(sum(w^2)) w<-w/normw tt<-X%*%w } #browser() vx<-as.numeric(Dcp(tt,D=D)) vy<-as.numeric(Dcp(u,D=D)) rtX<-as.matrix(Dcp(X,tt,D=D))/sqrt(vx) rtY<-as.matrix(Dcp(Y,tt,D=D))/sqrt(vx) if(!standX)rtX<-rtX/as.matrix(sqrt(varX)) if(!standY)rtY<-rtY/as.matrix(sqrt(varY)) r<-rtY/sqrt(vx) if(k>1)ruUY<-Dcp(Dvar(UY,D=D,cor=T)$U,Dvar(u,D=D,cor=T)$U,D=D) # stockage des differents objets covXY<-c(covXY,cov) VX<-c(VX,vx) VY<-c(VY,vy) TX<-cbind(TX,tt) UY<-cbind(UY,u) WX[,k]<-w CY[,k]<-cc RtX<-cbind(RtX,rtX) RtY<-cbind(RtY,rtY) if(k>1)RU<-c(RU,ruUY) # calcul des coefficients beta du modele ajuste if(k==1){alpha<-w alph[[1]]<-w } else { alpha<-w-COMP%*%Dcp(Xini,D=D)%*%w alph[[k]]<-alpha } COMP<-COMP + alpha%*%t(alpha)/vx BETA<-BETA+alpha%*%t(alpha)%*%Dcp(Xini,Y,D=D)/vx BETALCR[[k]]<-BETA BETAL[[k]]<-BETA for(j in 1:p) for(i in 1:q) { if((standX) & (standY)) BETAL[[k]][j,i]<-BETA[j,i]*sqrt(varY[i]/varX[j]) if((standX) & (! standY))BETAL[[k]][j,i]<-BETA[j,i]/sqrt(varX[j]) if((! standX) & (standY)) BETAL[[k]][j,i]<-BETA[j,i]*sqrt(varY[i]) if((! standX) & (! standY)) BETAL[[k]][j,i]<-BETA[j,i] } if(p==1)bidon<-t(as.matrix(centY$moy))-t(matrix(1,1,p)%*%centX$moy%*%BETAL[[k]]) else bidon<-t(as.matrix(centY$moy))-t(matrix(1,1,p)%*%diag(as.vector(centX$moy))%*%BETAL[[k]]) dimnames(bidon)<-list(dimnames(Y)[[2]],c("Const")) BETAL[[k]]<-cbind(bidon,t(BETAL[[k]])) BETALCR[[k]]<-t(BETALCR[[k]]) # calcul des nouveaux X et Y #browser() ProjX<-Dproj(tt,X,D=D,eps=1e-08) ProjY<-Dproj(tt,Y,D=D,eps=1e-08) inerexpY<-sum(diag(VQop(ProjY$Yhat,D=D))) inerexpX<-sum(diag(VQop(ProjX$Yhat,D=D))) R2<-R2+diag(VQop(ProjY$Yhat,D=D))/diag(VQop(Yini,D=D)) if(k==1)R2c[,1]<-R2 else R2c<-cbind(R2c,R2) IEX<-c(IEX,inerexpX) IEY<-c(IEY,inerexpY) X<-ProjX$Yres Y<-ProjY$Yres YH[[k]]<-ProjY$Yhat YR[[k]]<-Y sinerexpY<-sum(IEY) sinerexpX<-sum(IEX) if(impres) { cat(" cov(t,u)=",format(cov)," r(t,u)=",format(round(cov/sqrt(vx*vy),3))) cat(" stdev(t)=",format(sqrt(vx))," stdev(u)=",format(sqrt(vy)),"\n") cat("\n") affich<-matrix(round(diag(VQop(ProjY$Yhat,D=D))/diag(VQop(Yini,D=D)),3),1,q) affich<-cbind(affich,round(inerexpY/inertotY*100,3)) if(k==1){dimnames(affich)<-list(c("R2 part."),c(dimnames(Y)[[2]]," % VAR Y")) print(affich) varty<-c(varty,affich[1,q+1]) } else{affich1<-matrix(round(R2,3),1,q) affich1<-cbind(affich1,round(sinerexpY/inertotY*100,3)) affich<-rbind(affich,affich1) dimnames(affich)<-list(c("partial R2","cum. R2"),c(dimnames(Y)[[2]]," % VAR Y") ) print(affich) varty<-c(varty,affich[2,q+1]) } cat("\n") cat(paste("% ",VARX," accounted for by the comp. ="),inerexpX/inertotX*100,"\n") if(k>1)cat(paste("% explained ",VARX," ="),sinerexpX/inertotX*100,"\n") } # test d'arret de la boucle axes if(k==A) { if(impres)cat("_______________________________________________________________\n") if((impres)&((sinerexpX/inertotX*100!=100)&(A !=p))){cat("number of supplementary components ?") repeat{ Asup<-scan(quiet=T,"",numeric(),1) if((A+Asup <=p)&(A+Asup <=n))break else cat("a bit too large!!\n") } } else Asup<-0 if(Asup==0)break else {A<-A+Asup CYY<-matrix(0,q,Asup) CY<-cbind(CY,CYY) WXX<-matrix(0,p,Asup) WX<-cbind(WX,WXX) } } # fin boucle axes } # dimnames des fichiers dimnames(TX)<-list(paste((1:n),sep=""),paste("t",(1:A),sep="")) dimnames(UY)<-list(paste((1:n),sep=""),paste("u",(1:A),sep="")) dimnames(RtX)<-list(dimnames(X)[[2]],paste("t",(1:A),sep="")) dimnames(RtY)<-list(dimnames(Y)[[2]],paste("t",(1:A),sep="")) names(BETALCR)<-paste("Beta(",format(1:A),")",sep="") names(BETAL)<-paste("Beta(",format(1:A),")",sep="") if(impres){ if ((!splflag)&(!calibration)){ cat("_______________________________________________________________\n") if(standX & standY)choixx<-"On standardized variables" else choixx<-"On centered variables (standardized)" choix<-c(choixx,"On initial variables") reponse<-menu(choix,title="PLS models according to the dimension (0 to exit)") switch(reponse,print(BETALCR),print(BETAL),stop("Bad choice!")) } cat("_______________________________________________________________\n") if (!splflag){ if(!missing(Xtest)) { Tsup<-matrix(0,nrow(Xtest),A) for(i in 1:A)Tsup[,i]<-Tsup[,i]+as.matrix(Xinitest)%*%alph[[i]] repeat{ cat("\n") if(!missing(Ytest)) cat("Validation and prediction on the test sample ? (y/n)\n") else cat("prediction on the test sample ? (y/n)\n") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break else { if(!missing(Ytest)) { cat("VALIDATION :\n") cat("Mean of the absolute error means of reponses according to the dimension\n") affich1<-matrix(0,1,A) dimnames(affich1)<-list("MAE",format(1:A)) for(i in 1:A) affich1[1,i]<-round(mean(apply(abs(Yinitest-as.matrix(Xinitest)%*%t(BETALCR[[i]])),2,mean)),2) print(affich1) par(mfrow=c(1,1)) plot(ts(affich1[1,]),type="b",pch=pchpar,xlab="MODEL DIMENSION",ylab="",cex=cexpar) if(titlepar)title(main=paste("Opt.Dim. for the test sample =",order(affich1[1,])[1])) cat("Choose the model dimension (<=",A,")\n") dimopt<-scan(quiet=T,"",numeric(),1) if(p==1)bidon<-t(as.matrix(centY$moy))-t(matrix(1,1,p)%*%centX$moy%*%t(BETAL[[dimopt]][,-1,drop=F])) else bidon<-t(as.matrix(centY$moy))-t(matrix(1,1,p)%*%diag(as.vector(centX$moy))%*%t(BETAL[[dimopt]][,-1,drop=F])) dimnames(bidon)<-list(dimnames(Y)[[2]],c("Const")) BETAP<-cbind(bidon,BETAL[[dimopt]][,-1,drop=F]) Yest<-as.matrix(cbind(matrix(1,nrow(Xtest),1),Xtest))%*%t(BETAP) dimnames(Yest)<-list(dimnames(Xtest)[[1]],paste("est.",dimnames(Y)[[2]],sep="")) Yerr<-Ytest-Yest dimnames(Yerr)<-list(dimnames(Ytest)[[1]],paste("err.",dimnames(Ytest)[[2]],sep="")) Yaff<-NULL for(i in 1:ncol(Ytest))Yaff<-cbind(Yaff,as.matrix(cbind(Yest[,i,drop=F],Yerr[,i,drop=F]))) cat("Prediction error Yerr = Ytest - Yest \n") print(Yaff) cat("Absolute relative error in % of Ytest: |Yerr|/|Ytest|*100\n") erreur100<-abs(Yerr)/abs(Ytest)*100 erreur100<-rbind(erreur100,apply(erreur100,2,mean),sqrt(apply(erreur100,2,var))) dimnames(erreur100)<-list(c(dimnames(Ytest)[[1]],"Mean","Stdv"),dimnames(Ytest)[[2]]) print(round(erreur100,2)) par(ask=askpar) cat("plot of estimated Ytest versus observed Ytest\n") if(q>1){ cat("How many plots per row (<=",q,")?\n") colplots<-scan(quiet=T,"",numeric(),1) cat("How many rows?\n") rowplots<-scan(quiet=T,"",numeric(),1) par(mfrow=c(rowplots,colplots)) } else par(mfrow=c(1,1)) par(pty="s") for(i in 1:q) { if(abs(sum(Yini^2)-sum(Yinitest^2))1) {#points(RtY[,axespar]) text(RtY[,axespar],dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } else { text(t(as.matrix(RtY[,axespar])),dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } }#cercle corr else {#else corr par(mfrow=c(1,1),pty="m") plot(rbind(Xcoord,Ycoord)[,axespar],xlab=paste("t",axespar[1]," (",round(Inertexpx[axespar[1]],2),"%VX) (",round(Inertexpy[axespar[1]],2),"%VY)"),ylab=paste("t",axespar[2]," (",round(Inertexpx[axespar[2]],2), "%VX) (",round(Inertexpy[axespar[2]],2),"%VY)"),type="n",cex=cexpar) abline(h=0) abline(v=0) #points(Xcoord[,axespar]) text(Xcoord[,axespar],dimnames(RtX)[[1]],col=colpar+3,cex=cexpar) if(q>1) {#points(Ycoord[,axespar]) text(Ycoord[,axespar],dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } else { text(t(Ycoord[,axespar]),dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } }#else corr }#fin else break }#finrepeat cat("_______________________________________________________________\n") repeat { cat("Representation of the observations (y/n) ?\n") plctY<-scan(quiet=T,"",character(),1) if( (length(plctY)!=0)&&((plctY=="Y")|(plctY=="y"))) { if(standX)Xcoord<-RtX else Xcoord<-diag(sqrt(varX))%*%RtX if(standY) { if(q!=1)Ycoord<-RtY else Ycoord<-as.matrix(RtY) } else { if(q!=1)Ycoord<-diag(sqrt(varY))%*%RtY else Ycoord<-as.matrix(RtY*sqrt(varY)) } cat("Horizontal axis number (<=",A,") ?\n") plctYh<-scan(quiet=T,"",numeric(),1) cat("Vertical axis number (<=",A,") ?\n") plctYv<-scan(quiet=T,"",numeric(),1) axespar<-c(plctYh,plctYv) cat("_______________________\n") repeat {#repeatmenu if(A!=1) resmenu<-menu(c("Pseudo-projection based representation (t)", "Projection based representation (t*)","Regression of t* onto t","All the preceding ones", "Projection based representation and Correlation circle"), title="Maps of the observations (0 to exit)") else resmenu<-menu(c("Pseudo-projection based representation (t)", "Projection based representation (t*)","Regression of t* onto t","All the preceding ones", "Projection based representation of observations and variables"), title="Maps of the observations (0 to exit)") ########### if(resmenu==1){ par(mfrow=c(1,1),pty="m") if(!missing(Xtest)) plot(rbind(TX[,axespar],Tsup[,axespar,drop=F]),xlab=paste("t",axespar[1],sep=""),ylab=paste("t",axespar[2],sep=""),type="n",cex=cexpar) else plot(TX[,axespar],xlab=paste("t",axespar[1],sep=""),ylab=paste("t",axespar[2],sep=""),type="n",cex=cexpar) abline(h=0) abline(v=0) text(TX[,axespar],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) if(!missing(Xtest))text(Tsup[,axespar,drop=F],dimnames(Xinitest)[[1]],col=colpar+5,cex=cexpar) } ########### if(resmenu==2){ par(mfrow=c(1,1),pty="m") if(!missing(Xtest)) plot(rbind(Tstar[,axespar],Tstarsup[,axespar,drop=F]),xlab=paste("t *",axespar[1]," (",round(vartstar[axespar[1]]/IPLS*100,2)," %) (r",axespar[1],"=",round(TXTstarcor[axespar[1]],3),")",sep=""),ylab=paste("t *",axespar[2]," (",round(vartstar[axespar[2]]/IPLS*100,2)," %) (r",axespar[2],"=",round(TXTstarcor[axespar[2]],3),")",sep=""),type="n",cex=cexpar) else plot(Tstar[,axespar],xlab=paste("t *",axespar[1]," (",round(vartstar[axespar[1]]/IPLS*100,2)," %) (r",axespar[1],"=",round(TXTstarcor[axespar[1]],3),")",sep=""),ylab=paste("t *",axespar[2]," (",round(vartstar[axespar[2]]/IPLS*100,2)," %) (r",axespar[2],"=",round(TXTstarcor[axespar[2]],3),")",sep=""),type="n",cex=cexpar) text(Tstar[,axespar],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) if(!missing(Xtest))text(Tstarsup[,axespar,drop=F],dimnames(Xinitest)[[1]],col=colpar+5,cex=cexpar) abline(h=0) abline(v=0) cat("a coloured map of training samples according to the levels of a categorical variable? (y/n)\n") plto <- scan(quiet=T,"", character(), 1) if( (length(plto)!=0)&&((plto=="Y")|(plto=="y"))) { repeat{ cat("enter the name of the vector-variable or that of the matrix containing the column-variable\n") nom <- scan(quiet=T,"", character(), 1) matricenom<-as.matrix(get(nom,pos=1)) if(nrow(matricenom)==nrow(Xini))break else cat("misfit of the nb of rows\n") } if(is.vector(get(nom,pos=1))) {dimnames(matricenom)<-list(dimnames(Xini)[[1]],c(nom)) numer<-1 variab<-get(nom,pos=1) } if((is.matrix(get(nom,pos=1)))|(is.data.frame(get(nom,pos=1)))) { cat(paste(dimnames(matricenom)[[2]],"(",1:ncol(matricenom),"),",sep=""),"\n") cat("enter the nunber of the column of integer values\n") numer <- scan(quiet=T,"",numeric(), 1) variab<-matricenom[,numer] cat("name of the variable : ",dimnames(matricenom)[[2]][numer],"\n") } cat("click to locate the top left corner of the legend\n") for(i in min(variab):max(variab)) text(Tstar[variab==i,axespar],dimnames(Xini)[[1]][variab==i],col=i+1,cex=cexpar) legend(locator(1),paste(dimnames(matricenom)[[2]][numer],min(variab):max(variab),sep=""),fill=(min(variab):max(variab))+1,cex=cexpar) } } ########### if(resmenu==3){ par(mfrow=c(1,2),pty="s") plot(TX[,axespar[1]],Tstar[,axespar[1]],xlab=paste("t",axespar[1],sep=""),ylab=paste("t*",axespar[1],sep=""),main=paste("r",axespar[1]," = ",format(round(TXTstarcor[axespar[1]],3)),sep=""),type="n",cex=cexpar) text(TX[,axespar[1]],Tstar[,axespar[1]],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) abline(h=0) abline(v=0) abline(a=0,b=TXTstarcor[axespar[1]]*sqrt(diag(Dcp(Tstar,D=D)))[axespar[1]]/sqrt(diag(Dcp(TX,D=D)))[axespar[1]]) plot(TX[,axespar[2]],Tstar[,axespar[2]],xlab=paste("t",axespar[2],sep=""),ylab=paste("t*",axespar[2],sep=""),main=paste("r",axespar[2]," = ",format(round(TXTstarcor[axespar[2]],3)),sep=""),type="n",cex=cexpar) text(TX[,axespar[2]],Tstar[,axespar[2]],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) abline(h=0) abline(v=0) abline(a=0,b=TXTstarcor[axespar[2]]*sqrt(diag(Dcp(Tstar,D=D)))[axespar[2]]/sqrt(diag(Dcp(TX,D=D)))[axespar[2]]) } ########### if(resmenu==4){ par(mfrow=c(2,2),pty="m") if(!missing(Xtest)) plot(rbind(TX[,axespar],Tsup[,axespar,drop=F]),xlab=paste("t",axespar[1],sep=""),ylab=paste("t",axespar[2],sep=""),type="n",cex=cexpar) else plot(TX[,axespar],xlab=paste("t",axespar[1],sep=""),ylab=paste("t",axespar[2],sep=""),type="n",cex=cexpar) abline(h=0) abline(v=0) text(TX[,axespar],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) if(!missing(Xtest))text(Tsup[,axespar,drop=F],dimnames(Xinitest)[[1]],col=colpar+5,cex=cexpar) if(!missing(Xtest)) plot(rbind(Tstar[,axespar],Tstarsup[,axespar,drop=F]),xlab=paste("t *",axespar[1]," (",round(vartstar[axespar[1]]/IPLS*100,2)," %)",sep=""),ylab=paste("t *",axespar[2]," (",round(vartstar[axespar[2]]/IPLS*100,2)," %)",sep=""),type="n",cex=cexpar) else plot(Tstar[,axespar],xlab=paste("t*",axespar[1]," (",round(vartstar[axespar[1]]/IPLS*100,2)," %)",sep=""),ylab=paste("t*",axespar[2]," (",round(vartstar[axespar[2]]/IPLS*100,2)," %)",sep=""),type="n",cex=cexpar) text(Tstar[,axespar],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) if(!missing(Xtest))text(Tstarsup[,axespar,drop=F],dimnames(Xinitest)[[1]],col=colpar+5,cex=cexpar) abline(h=0) abline(v=0) plot(TX[,axespar[1]],Tstar[,axespar[1]],xlab=paste("t",axespar[1],sep=""),ylab=paste("t*",axespar[1],sep=""),main=paste("r",axespar[1]," = ",format(round(TXTstarcor[axespar[1]],3)),sep=""),type="n",cex=cexpar) text(TX[,axespar[1]],Tstar[,axespar[1]],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) abline(h=0) abline(v=0) abline(a=0,b=TXTstarcor[axespar[1]]*sqrt(diag(Dcp(Tstar,D=D)))[axespar[1]]/sqrt(diag(Dcp(TX,D=D)))[axespar[1]]) plot(TX[,axespar[2]],Tstar[,axespar[2]],xlab=paste("t",axespar[2],sep=""),ylab=paste("t*",axespar[2],sep=""),main=paste("r",axespar[2]," = ",format(round(TXTstarcor[axespar[2]],3)),sep=""),type="n",cex=cexpar) text(TX[,axespar[2]],Tstar[,axespar[2]],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) abline(h=0) abline(v=0) abline(a=0,b=TXTstarcor[axespar[2]]*sqrt(diag(Dcp(Tstar,D=D)))[axespar[2]]/sqrt(diag(Dcp(TX,D=D)))[axespar[2]]) } ########### if(resmenu==5){ par(mfrow=c(1,1),pty="s") if(!missing(Xtest)) plot(rbind(Tstar[,axespar],Tstarsup[,axespar,drop=F]),xlab=paste("t *",axespar[1]," (",round(vartstar[axespar[1]]/IPLS*100,2)," %) (r",axespar[1],"=",round(TXTstarcor[axespar[1]],3),")",sep=""),ylab=paste("t *",axespar[2]," (",round(vartstar[axespar[2]]/IPLS*100,2)," %) (r",axespar[2],"=",round(TXTstarcor[axespar[2]],3),")",sep=""),type="n",cex=cexpar) else plot(Tstar[,axespar],xlab=paste("t *",axespar[1]," (",round(vartstar[axespar[1]]/IPLS*100,2)," %) (r",axespar[1],"=",round(TXTstarcor[axespar[1]],3),")",sep=""),ylab=paste("t *",axespar[2]," (",round(vartstar[axespar[2]]/IPLS*100,2)," %) (r",axespar[2],"=",round(TXTstarcor[axespar[2]],3),")",sep=""),type="n",cex=cexpar) text(Tstar[,axespar],dimnames(Xini)[[1]],col=colpar+3,cex=cexpar) if(!missing(Xtest))text(Tstarsup[,axespar,drop=F],dimnames(Xinitest)[[1]],col=colpar+5,cex=cexpar) abline(h=0) abline(v=0) if(!missing(qual)) { variab<-qual if(missing(names.qual)){ repeat{ cat("Enter the levels' names\n") names.qual<-scan(quiet=T,what=character()) if(length(names.qual)==max(qual)-min(qual)+1)break else cat("not the right nb of levels' names,should be",max(qual)-min(qual)+1,"!\n") } } cat("click to locate the top left corner of the legend\n") for(i in min(variab):max(variab)) text(Tstar[variab==i,axespar],dimnames(Xini)[[1]][variab==i],col=i+1,cex=cexpar) legend(locator(1),names.qual,x.intersp=cexpar,y.intersp=cexpar,bty="o", text.col=min(variab):max(variab)+1,cex=cexpar,fill=(min(qual):max(qual))+1) } if(A!=1) { theta<-seq(0,20,.05) x<-cos(theta) y<-sin(theta) plot(x,y,type="l",xlab=paste("t",axespar[1]," (",round(Inertexpx[axespar[1]],2),"%IX) (", round(Inertexpy[axespar[1]],2),"%IY)"),ylab=paste("t",axespar[2]," (",round(Inertexpx[axespar[2]],2), "%IX) (",round(Inertexpy[axespar[2]],2),"%IY)"),cex=cexpar) abline(h=0) abline(v=0) text(RtX[,axespar],dimnames(RtX)[[1]],col=colpar+3,cex=cexpar) if(q>1) {#points(RtY[,axespar]) text(RtY[,axespar],dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } else { #points(t(as.matrix(RtY[,axespar]))) text(t(as.matrix(RtY[,axespar])),dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } }#endifA!=1 else { plot(rbind(Xcoord,Ycoord)[,axespar],xlab=paste("t",axespar[1]," (",round(Inertexpx[axespar[1]],2),"%VX) (",round(Inertexpy[axespar[1]],2),"%VY)"),ylab=paste("t",axespar[2]," (",round(Inertexpx[axespar[2]],2), "%VX) (",round(Inertexpy[axespar[2]],2),"%VY)"),type="n",cex=cexpar) abline(h=0) abline(v=0) #points(Xcoord[,axespar]) text(Xcoord[,axespar],dimnames(RtX)[[1]],col=colpar+3,cex=cexpar) if(q>1) {#points(Ycoord[,axespar]) text(Ycoord[,axespar],dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } else { #points(t(Ycoord[,axespar])) text(t(Ycoord[,axespar]),dimnames(RtY)[[1]],col=colpar+1,cex=cexpar) } } ########### } cat("_______________________\n") if(resmenu ==0)break }#endrepeatmenu }#fin else break }#finrepeat cat("_______________________________________________________________\n") repeat { cat("regression of Y onto t (y/n) ?\n") plcYt<-scan(quiet=T,"",character(),1) if( (length(plcYt)!=0)&&((plcYt=="Y")|(plcYt=="y"))) { cat("t number (<=",A,") ?\n") plcYtn<-scan(quiet=T,"",numeric(),1) for(j in 1:q) { par(mfrow=c(1,1),pty="s") axespar<-c(plcYtn) if(missing(Ytest)) plot(TX[,axespar],Yini[,j],xlab=paste("t",axespar[1]),ylab=dimnames(Y)[[2]][j],type="n") else plot(c(TX[,axespar],Tsup[,axespar]),c(Yini[,j],Yinitest[,j]),xlab=paste("t",axespar[1]),ylab=dimnames(Y)[[2]][j],type="n") text(TX[,axespar],Yini[,j],dimnames(X)[[1]],col=colpar+4,cex=cexpar) if(!missing(Ytest)) text(Tsup[,axespar,drop=F],Yinitest[,j],dimnames(Xtest)[[1]],col=colpar+5,cex=cexpar) abline(lm(Yini[,j]~TX[,axespar]),col=colpar+1) } } else break } repeat { if(!calibration)break cat("_______________________________________________________________\n") cat("plot of the BETA's according to the dimension (y/n) ?\n") pltctY<-scan(quiet=T,"",character(),1) if( (length(pltctY)!=0)&&((pltctY=="Y")|(pltctY=="y"))) { if(q>1) { cat("Number of Y-plots per row ? (<=",q,")\n") colo<-scan(quiet=T,"",numeric(),1) cat("Number of rows ?\n") lign<-scan(quiet=T,"",numeric(),1) par(mfrow=c(lign,colo),pty="m") } else par(mfrow=c(1,1),pty="m") echini<-dimnames(Xini)[[2]] mode(echini)<-"numeric"# echini est le vecteur des "temps" initialement pris en compte cat("dimension du modele (<=",A,") ?\n") dimmod<-scan(quiet=T,"",numeric(),1) for(j in 1:q){ plot(echini,BETALCR[[dimmod]][j,],type="n",ylab=paste("BETA , dimension ",dimmod,sep=""),xlab="wavelengths",main=dimnames(Yini)[[2]][j],cex=cexpar) points(echini,BETALCR[[dimmod]][j,],type="l",col=colpar+j) abline(h=0) } } else break } cat("_______________________________________________________________\n") repeat { if(standX==F)break cat("evolution of the BETA's according to the dimension (y/n) ?\n") plcYt<-scan(quiet=T,"",character(),1) if(length(plcYt)==0) plcYt<-"n" if(plcYt=="n")break else { if(q>1){ cat("one Individual plot per response or one plot for All the responses (I/A)\n") pltu<- scan(quiet=T,"", character(), 1) if((pltu=="I")|(pltu=="i")) par(mfrow=c(1,1),pty="s") else{ if(p<=20) cat("Nunber of plots per row ? (<=",q+1,", count 1 more plot for the legend)\n") else cat("Nunber of plots per row ? (<=",q,")\n") colo<-scan(quiet=T,"",numeric(),1) cat("Nunber of rows ?\n") lign<-scan(quiet=T,"",numeric(),1) par(mfrow=c(lign,colo),pty="s") } } else {par(mfrow=c(1,1)) pltu<-"I"} yco<-matrix(ncol=A,nrow=p,NA) for(j in 1:q) { if(p<=20){ if((pltu=="I")|(pltu=="i"))cat("Click on the plot to locate the legend !\n") else if(j==q)cat("Click on the plot to locate the legend !\n") } for(k in 1:A)yco[,k]<-BETALCR[[k]][j,] ts.plot(ts(t(yco)),gpars=list(xlab="MODEL DIM.",ylab=dimnames(Y)[[2]][j],type="n",cex=cexpar)) for(i in 1:p) { points(yco[i,],pch=i,cex=cexpar+0.4,col=i) points(yco[i,],type="l",lty=i,col=i) } if((pltu=="I")|(pltu=="i")){ if(p<=20){ if(p>5)legend(locator(1),dimnames(X)[[2]],pch=1:p,bty="n",cex=cexpar,col=1:p,ncol=2) else legend(locator(1),dimnames(X)[[2]],pch=1:p,bty="n",cex=cexpar,col=1:p) } } else { if((j==q)&(p<=20)) {plot(0,0,type="n",xlab="",main="LEGEND FOR PREDICTORS",ylab="",axes=F) if(p>5)legend(locator(1),dimnames(X)[[2]],pch=1:p,bty="n",cex=cexpar,col=1:p,ncol=2) else legend(locator(1),dimnames(X)[[2]],pch=1:p,bty="n",cex=cexpar,col=1:p) } } } } } cat("_______________________________________________________________\n") repeat { if(calibration)break cat("representation of the most influential predictors on a response (y/n) ?\n") plctY<- scan(quiet=T,"", character(), 1) if( (length(plctY)!=0)&&((plctY=="Y")|(plctY=="y"))) {if(q!=1){ cat("response number (<=",q,") ?\n") numres<-scan(quiet=T,"",numeric(),1) } else numres<-1 cat("model dimension (<=",A,") ?\n") dimmod<-scan(quiet=T,"",numeric(),1) #browser() invtx<-rev(order(rank((abs(BETALCR[[dimmod]][numres,]))))) ZZ<-BETALCR[[dimmod]] dimnames(ZZ)[[2]]<-paste(dimnames(ZZ)[[2]],"(",1:ncol(ZZ),")",sep="") print(round(abs(ZZ[numres,invtx]),3)) if(titlepar==F)par(mfrow=c(1,2),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,2),pty=ptypar) if(p<=10){ barplot(BETALCR[[dimmod]][numres,invtx],ylab="regression coeff.",names=dimnames(X)[[2]][invtx], xlab="predictors",density=20,space=1.4,col=1:p,cex.axis=cexpar,cex.names=cexpar) barplot(abs(BETALCR[[dimmod]][numres,invtx]),ylab="absolute values",names=dimnames(X)[[2]][invtx],xlab="predictors",density=20,space=1.4, col=1:p,cex.axis=cexpar,cex.names=cexpar) } else{ barplot(BETALCR[[dimmod]][numres,invtx],ylab="regression coeff.",names=format(invtx),xlab="predictors",density=20,space=1.4, col=1:p,cex.axis=cexpar,cex.names=cexpar) barplot(abs(BETALCR[[dimmod]][numres,invtx]),ylab="absolute values",names=format(invtx),xlab="predictors", density=20,space=1.4,col=1:p,legend=paste(invtx,dimnames(X)[[2]][invtx]),cex.axis=cexpar,cex.names=cexpar) } if(titlepar==T)mtext(side=3,line=-4,cex=cexpar+1,outer=TRUE,paste("PLS model for ",dimnames(Yini)[[2]][numres]," (dim ",dimmod,")",sep="")) cat("Number of retained predictors ?,(<=",p,") \n") nb<- scan(quiet=T,"", numeric(), 1) cat("How many plots per row ?,(<=",nb,") \n") pc<- scan(quiet=T,"", numeric(), 1) cat("How many rows ? \n") pl<-scan(quiet=T,"", numeric(), 1) par(oma=c(0,0,4,0),mfrow=c(pl,pc),pty="s") if(missing(Xtest)){ rangemin<-min(Xini*BETALCR[[dimmod]][numres,invtx[1]]) rangemax<-max(Xini*BETALCR[[dimmod]][numres,invtx[1]]) } else{ rangemin<-min(rbind(Xini,Xinitest)*BETALCR[[dimmod]][numres,invtx[1]]) rangemax<-max(rbind(Xini,Xinitest)*BETALCR[[dimmod]][numres,invtx[1]]) } for(i in invtx[1:nb]) { if(missing(Xtest)) plot(Xini[,i],Xini[,i]*BETALCR[[dimmod]][numres,i],ylim=c(rangemin,rangemax),xlab="",ylab="",type="n", main=paste(round(BETALCR[[dimmod]][numres,i],3),dimnames(Xini)[[2]][i]),cex=cexpar) else plot(c(Xini[,i],Xinitest[,i]),c(Xini[,i],Xinitest[,i])*BETALCR[[dimmod]][numres,i],ylim=c(rangemin,rangemax),xlab="",ylab="",type="n", main=paste(round(BETALCR[[dimmod]][numres,i],3),dimnames(Xini)[[2]][i]),cex=cexpar) text(Xini[,i],Xini[,i]*BETALCR[[dimmod]][numres,i],dimnames(Xini)[[1]],col=colpar+2,cex=cexpar) if(!missing(Xtest)) text(Xinitest[,i],Xinitest[,i]*BETALCR[[dimmod]][numres,i],dimnames(Xinitest)[[1]],col=colpar+2,cex=cexpar) abline(0,BETALCR[[dimmod]][numres,i],col=colpar+1) if(titlepar) mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("Predictors' influence on ",dimnames(Yini)[[2]][numres], " (dim ",dimmod,")",sep="")) } } else break } cat("\n") cat("__________________________________________________________________\n") cat("plot of Yhat versus Y (y/n)?\n") plt3 <- scan(quiet=T,,what="", 1) if((length(plt3)!=0)&&(plt3=="y")){ par(mfrow=c(1,1)) repeat{ cat("Enter the dimension ?,(<=",A,") \n") pa<- scan(quiet=T,"", numeric(), 1) YHAT<-matrix(0,n,q) for(k in 1:pa){ YHAT<-YHAT+YH[[k]] } if(q>1){ cat("How many plots per row (<=",q,")?\n") colplots<-scan(quiet=T,"",numeric(),1) cat("How many rows?\n") rowplots<-scan(quiet=T,"",numeric(),1) par(mfrow=c(rowplots,colplots)) } else par(mfrow=c(1,1)) for(i in 1:q) { yy<-YHAT[,i]*sqrt(varY[i])+centY$moy[i] if(sum(Yinitial[,i]==0)==0) { titrepl<-"nean relative err (%) = " relativeerreur<-Dvar(abs(Yinitial[,i]-yy)/abs(Yinitial[,i])*100,D=D)$mean } else { relativeerreur<-sqrt(Dvar(Yinitial[,i]-yy,D=D)$var) titrepl<-" stdv err = " } if(titlepar) plot(Yinitial[,i],yy,xlab=dimnames(Yini)[[2]][i], ylab=paste("modeled ",dimnames(Yini)[[2]][i],",",pa," Dim.",sep=""), type="n",xlim=range(c(Yinitial[,i],yy)),ylim=range(c(Yinitial[,i],yy)), main=paste(titrepl,round(relativeerreur,2))) else plot(Yinitial[,i],yy,xlab=dimnames(Yini)[[2]][i], ylab=paste("modeled ",dimnames(Yini)[[2]][i],",",pa," Dim.",sep=""), type="n",xlim=range(c(Yinitial[,i],yy)),ylim=range(c(Yinitial[,i],yy))) if(!typedata)points(Yinitial[,i],yy,pch=pchpar,cex=cexpar) else text(Yinitial[,i],yy,dimnames(Yini)[[1]],col=colpar+3) abline(a=0,b=1,col=colpar+1) } cat("A different dimension ? (y/n)\n") plcYt<-scan(quiet=T,"",character(),1) if(length(plcYt)==0) plcYt<-"n" if(plcYt=="n")break }#repeat } cat("__________________________________________________________________\n") cat("\n") cat("Residual plots according to the dimensions? (y/n)\n") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) { repeat{ cat("Enter the dimension ?,(<=",A,") \n") pa<- scan(quiet=T,"", numeric(), 1) if(q==1){cat("How many plots per row ? (<=",pa,")\n") repoc<-scan(quiet=T,"",numeric(),1) if(pa-repoc==0)repol<-1 else repol<-ceiling(pa/repoc) } else { cat("How many plots per row ? (<=",q,")\n") repoc<-scan(quiet=T,"",numeric(),1) cat("How many rows ? (<=",pa,")\n") repol<-scan(quiet=T,"",numeric(),1) } if(titlepar==F)par(mfrow=c(repol,repoc),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(repol,repoc),pty=ptypar) YHAT<-matrix(0,n,q) for(k in 1:pa){ #YHAT<-Xini%*%BETALCR[[k]] YHAT<-YHAT+YH[[k]] if(!missing(Ytest))YHtest<-as.matrix(Xinitest)%*%t(BETALCR[[k]]) for(i in 1:q) { if(missing(Ytest)){ if(k==1) variat<-range(Yini-YHAT) variat<-range(variat,range(Yini-YHAT)) plot(YHAT[,i],Yini[,i]-YHAT[,i],ylim=variat,xlab=paste(dimnames(Yini)[[2]][i]," , ",k,sep=""),ylab="",type="n",cex=cexpar) } else{ if(k==1) variat<-range(rbind(Yini,Yinitest)-rbind(YHAT,YHtest)) variat<-range(variat,range(rbind(Yini,Yinitest)-rbind(YHAT,YHtest))) plot(c(YHAT[,i],YHtest[,i]),c(Yini[,i]-YHAT[,i],Yinitest[,i]-YHtest[,i]),ylim=variat,xlab=paste(dimnames(Yini)[[2]][i]," , ",k,sep=""),ylab="",type="n",cex=cexpar) } if(!typedata)text(YHAT[,i],Yini[,i]-YHAT[,i],cex=cexpar,col=colpar+4) else text(YHAT[,i],Yini[,i]-YHAT[,i],dimnames(Yini)[[1]],cex=cexpar,col=colpar+4) if(!missing(Ytest)) { if(!typedata)text(YHtest[,i],Yinitest[,i]-YHtest[,i],cex=cexpar,col=colpar+2) else text(YHtest[,i],Yinitest[,i]-YHtest[,i],dimnames(Yinitest)[[1]],cex=cexpar,col=colpar+2) } } } if(titlepar==T)mtext(side=3,line=-1,cex=2,outer=TRUE,"Residuals with PLS dimensions") cat("A different dimension? (y/n)\n") plcYt<-scan(quiet=T,"",character(),1) if(length(plcYt)==0) plcYt<-"n" if(plcYt=="n")break } } cat("\n") cat("__________________________________________________________________\n") if(q==2){ cat(paste("Bidimensional plot (", dimnames(Yini)[[2]][1],",",dimnames(Yini)[[2]][2], ") of the fitted responses (y/n)? \n",sep="")) plt3 <- scan(quiet=T,,what="", 1) if((length(plt3)!=0)&&(plt3=="y")){ if(titlepar==F)par(mfrow=c(1,2),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,2),pty=ptypar) repeat{ cat("Enter the dimension ?,(<=",A,") \n") pa<- scan(quiet=T,"", numeric(), 1) YYY<-matrix(0,n,2) for(i in 1:pa)YYY<-YYY+YH[[i]] range1<-range(c(YYY[, 1],Yini[, 1])) range2<-range(c(YYY[, 2],Yini[, 2])) plot(YYY[, 1],YYY[,2],xlim=range1,ylim=range2,xlab=paste("fitted",dimnames(Yini)[[2]][1]),ylab=paste("fitted",dimnames(Yini)[[2]][2]),type="n",pch=pchpar,main="Reconstituted shape") if(!typedata)points(YYY[, 1],YYY[, 2],pch=pchpar,cex=cexpar) else text(YYY[, 1],YYY[, 2],dimnames(Yini)[[1]],col=colpar+3) plot(Yini[, 1],Yini[, 2],xlim=range1,ylim=range2,xlab=dimnames(Yini)[[2]][1],ylab=dimnames(Yini)[[2]][2],type="n",pch=pchpar,main="Original shape") if(!typedata)points(Yini[, 1],Yini[, 2],pch=pchpar,cex=cexpar) else text(Yini[, 1],Yini[, 2],dimnames(Yini)[[1]],col=colpar+3) if(titlepar==T)mtext(side=3,line=0,cex=2,outer=TRUE,paste("PLS (",pa," dim.)",sep="")) cat("A different dimension? (y/n)\n") repo<-scan(quiet=T,"",character(),1) if((length(repo)==0)|(repo!="y"))break } } } # fin des graphiques } invisible(return(nomfichX,Xini,nomfichY,Yini,covXY,A,VX,VY,TX,UY,WX,CY,IEY,IEX,YH,YR,RtX,RtY,BETALCR,BETAL,alph,R2c)) #return(nomfichX,Xini,nomfichY,Yini,covXY,A,VX,VY,TX,UY,WX,CY,IEY,IEX,YH,YR,RtX,RtY,BETALCR,BETAL,#alph,R2c,xlocator) } ######################################################## plscv<-function(X,Y,standX=T,standY=T,A=2,D=1,prop=0.1,GCV=2,impres=T) { # cross-validation sur PLS Xinitial<-as.matrix(X) Yinitial<-as.matrix(Y) n<-nrow(Xinitial) p<-ncol(Xinitial) q<-ncol(Yinitial) if(is.null(dimnames(Xinitial)))dimnames(Xinitial)<-list(format(1:n),paste("X",1:p,sep="")) if(is.null(dimnames(Yinitial)))dimnames(Yinitial)<-list(format(1:n),paste("Y",1:q,sep="")) if(length(dimnames(Xinitial)[[1]])==0) dimnames(Xinitial)[[1]]<- format(1:n) if(length(dimnames(Yinitial)[[1]])==0) dimnames(Yinitial)[[1]]<- format(1:n) if(length(dimnames(Xinitial)[[2]])==0) dimnames(Xinitial)[[2]]<- paste("X",1:p,sep="") if(length(dimnames(Yinitial)[[2]])==0) {cat("Enter the name of the response(s)\n") prov<-as.vector(format(1:q)) for(i in 1:q) {cat(paste("response ",format(i),"\n")) prov[i]<-scan(quiet=T,,what="", 1) } dimnames(Yinitial)[[2]]<-prov } # calcul de la metrique si D=1 if(length(D)==1) D<-rep(1/n,n) else D<-as.vector(D) # centrage et reduction centX<-Dcentred(Xinitial,D=D) centY<-Dcentred(Yinitial,D=D) if(standX) Xini<-as.matrix(centX$Xcr) else Xini<-as.matrix(centX$Xc) if(standY) Yini<-as.matrix(centY$Xcr) else Yini<-as.matrix(centY$Xc) if(GCV==0) {#GCV==0 pp<-round(n*prop) if(pp==0)repeat{ cat("choose an another proportion of samples >",prop," !!\n") prop<- scan(quiet=T,"", numeric(), 1) pp<-round(n*prop) if(pp !=0)break } if(impres)cat(pp,"objects out\n") ppc<-floor(n/pp) PRESS<-array(0,c(ppc,q,A)) predict<-array(0,c(n,q,A)) for(i in 0:(ppc-1)) { ii<-(1:pp)+pp*i if(impres)cat(ii,"*") plsresul<-pls(Xinitial[-ii,],Yinitial[-ii,],A=A,standX=standX,standY=standY,impres=F,graph=F, cexpar=cexpar,colpar=colpar,titlepar=titlepar) for(k in 1:A){ PRESS[i+1,,k]<-PRESS[i+1,,k]+apply((Yini[ii,,drop=F]-Xini[ii,,drop=F]%*%t(plsresul$BETALCR[[k]]))^2,2,sum) predict[ii,,k]<-Xini[ii,,drop=F]%*%t(plsresul$BETALCR[[k]]) } } if(n%%pp!=0){ ii<-(1:(n%%pp))+pp*ppc if(impres)cat(ii,"*") plsresul<-pls(Xinitial[-ii,],Yinitial[-ii,],A=A,standX=standX,standY=standY,impres=F,graph=F,cexpar=cexpar,colpar=colpar,titlepar=titlepar) for(k in 1:A){ PRESS[ppc, ,k]<-PRESS[ppc, ,k]+apply((Yini[ii,,drop=F]-Xini[ii,,drop=F]%*%t(plsresul$BETALCR[[k]]))^2,2,sum) predict[ii,,k]<-Xini[ii,,drop=F]%*%t(plsresul$BETALCR[[k]]) } } if(impres)cat("\n") dimnames(PRESS)<-list(format(1:ppc),dimnames(Yinitial)[[2]],paste("Dim",1:A,sep="")) dimnames(predict)<-list(dimnames(Yinitial)[[1]],dimnames(Yinitial)[[2]],paste("Dim",1:A,sep="")) PRESStot<-apply(PRESS,3,sum)/n PRESSpar<-apply(PRESS,c(2,3),sum)/n invisible(return(Xinitial,Yinitial,Yini,A,PRESS,PRESStot,PRESSpar,predict,prop,GCV)) }#finGCV==0 else {#GCV!=0 plsresul<-pls(Xinitial,Yinitial,A=A,standX=standX,standY=standY,impres=F,graph=F) GCrit<-matrix(0,q,A) for(i in 1:q) { YHAT<-matrix(0,n,1) for(k in 1:A){ YHAT<-YHAT+plsresul$YH[[k]][,i] Yres<-Yini[,i]-YHAT #Average squared residual ASR<-sum(diag(as.matrix(VQop(Yres,D=D)))) GCrit[i,k]<-ASR/(1-k*GCV/n)^2 } dimnames(GCrit)<-list(dimnames(Yinitial)[[2]],paste("Dim",1:A,sep="")) } GCritot<-apply(GCrit,2,sum) #browser() invisible(return(Xinitial,Yinitial,Yini,A,predict,GCV,GCrit,GCritot)) }#finGCV!=0 } ######################################################## plscv.plot<-function(plscvresul,D=1,cexpar=0.7,ptypar="s",colpar=1,titlepar=T,askpar=T,bgpar="gray") { # plots de la validation croisee n<-nrow(plscvresul$Yinitial) q<-ncol(plscvresul$Yinitial) par(ask=askpar) par(bg=bgpar) if(plscvresul$GCV==0) { if(q>1){ par(mfrow=c(1,2),pty=ptypar) if(titlepar) plot(plscvresul$PRESStot,type="n",xlab="Model Dim.",ylab="PRESS",main=paste("opt. Dim.",order(plscvresul$PRESStot)[1]," , ","PRESS =",round(min(plscvresul$PRESStot),2),"(",round(n*plscvresul$prop),"out )"), cex=cexpar,bg=par("bg")) else plot(plscvresul$PRESStot,type="n",xlab="Model Dim.",ylab="PRESS",cex=cexpar,bg=par("bg")) points(plscvresul$PRESStot,pch=10,cex=cexpar+0.7) points(plscvresul$PRESStot,type="l") if(titlepar) ts.plot(ts(t(plscvresul$PRESSpar)),gpars=list(xlab="Model Dim.",ylab="Partial PRESS", type="n",main=paste("PRESS/Responses","(",round(n*plscvresul$prop),"out )"),cex=cexpar)) else ts.plot(ts(t(plscvresul$PRESSpar)),gpars=list(xlab="Model Dim.",ylab="Partial PRESS",type="n",cex=cexpar,bg=par("bg"))) for(i in 1:q){ points(1:plscvresul$A,plscvresul$PRESSpar[i,],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:plscvresul$A,plscvresul$PRESSpar[i,],type="l",lty=i,col=colpar+i) } cat("Click to locate the top left corner of the legend\n") #legend(2,14,dimnames(plscvresul$Yinitial)[[2]],marks=1:q,cex=cexpar,ncol=ncolpar,bty="n",col= #colpar+(1:q)) legend(locator(1),dimnames(plscvresul$Yinitial)[[2]],pch=1:q,cex=cexpar, bty="n",x.intersp=.5,y.intersp=.5,col=colpar+(1:q)) } else{ par(mfrow=c(1,1),pty=ptypar) if(titlepar) plot(plscvresul$PRESStot,type="n",xlab="Model Dim." ,ylab="PRESS",main=paste("opt. Dim.",order(plscvresul$PRESStot)[1]," , ",dimnames(plscvresul$Yinitial)[[2]],"PRESS =",round(min(plscvresul$PRESStot),2),"(",round(n*plscvresul$prop),"out )"), cex=cexpar,bg=par("bg")) else plot(plscvresul$PRESStot,type="n",xlab="Model Dim." ,ylab="PRESS",cex=cexpar,bg=par("bg")) points(plscvresul$PRESStot,pch=10,cex=cexpar+0.7) points(plscvresul$PRESStot,type="l") } A<-1 cat("Observed Y-samples against CV predicted Y-samples along with the dimension\n") repeat{ cat("Choose the model dimension or 0 to exit (<=",plscvresul$A,")") dimension<-scan(quiet=T,"",numeric(),1) if(length(dimension)==0)break if(dimension!=0) {A<-dimension print(paste("PRESS(",plscvresul$prop,",",A,")=",round(plscvresul$PRESStot[A],4),sep="")) } else A<-A if(dimension==0)break #browser() if(q>1){ cat("How many plots per row (<=",q,")?") colplots<-scan(quiet=T,"",numeric(),1) cat("How many rows?") rowplots<-scan(quiet=T,"",numeric(),1) par(mfrow=c(rowplots,colplots)) } else par(mfrow=c(1,1)) varmeany<-Dvar(plscvresul$Yinitial,D=D) for(j in 1:q){ yy<-plscvresul$predict[,j,dimension]*sqrt(varmeany$var[j])+varmeany$mean[j] if(sum(plscvresul$Yinitial[,j]==0)>0) { titreplot<-paste(dimnames(plscvresul$Yinitial)[[2]][j]," stdv err = ") sigmapredict<-round(sqrt(Dvar(plscvresul$Yinitial[,j]-yy,D=D)$var),2) } else { titreplot<-paste(dimnames(plscvresul$Yinitial)[[2]][j],"mean relative err in % = ") sigmapredict<-round(Dvar(abs((plscvresul$Yinitial[,j]-yy)/plscvresul$Yinitial[,j])*100,D=D)$mean,2) } if(titlepar) plot(plscvresul$Yinitial[,j],yy,xlab=paste("obs. ",dimnames(plscvresul$Yinitial)[[2]][j]), ylab=paste("est. ",dimnames(plscvresul$Yinitial)[[2]][j],", Dim. ",dimension), xlim=range(c(plscvresul$Yinitial[,j],yy)),ylim=range(c(plscvresul$Yinitial[,j],yy)), main=paste(titreplot,format(sigmapredict),sep=""),type="n",cex=cexpar,bg=par("bg")) else plot(plscvresul$Yinitial[,j],yy,xlab=paste("obs. ",dimnames(plscvresul$Yinitial)[[2]][j]), xlim=range(c(plscvresul$Yinitial[,j],yy)),ylim=range(c(plscvresul$Yinitial[,j],yy)), ylab=paste("est. ",dimnames(plscvresul$Yinitial)[[2]][j],", Dim. ",dimension),type="n",cex=cexpar,bg=par("bg")) abline(a=0,b=1,col=colpar+1) text(plscvresul$Yinitial[,j],yy,dimnames(plscvresul$Yinitial)[[1]],col=colpar+3,cex=cexpar) cat(titreplot,sigmapredict,"\n") }#endforj=1:q }#endrepeat #browser() invisible(return(plscvresul$PRESStot,plscvresul$PRESSpar,A)) }#finGCV==0 else { if(q>1){ par(mfrow=c(1,2),pty=ptypar) if(titlepar) plot(plscvresul$GCritot,type="n",xlab="Model Dim.",ylab="GCV", main=paste("opt. Dim.",order(plscvresul$GCritot)[1],",","GCV=",round(min(plscvresul$GCritot),3), "(alpha=",plscvresul$GCV,")"),cex=cexpar,bg=par("bg")) else plot(plscvresul$GCritot,type="n",xlab="Model Dim.",ylab="GCV",cex=cexpar,bg=par("bg")) points(plscvresul$GCritot,pch=10,cex=cexpar+0.7) points(plscvresul$GCritot,type="l") if(titlepar) ts.plot(ts(t(plscvresul$GCrit)), gpars=list(xlab="Model Dim.",ylab="Partial GCV", type="n",main=paste("GCV/Responses"),cex=cexpar,bg=par("bg"))) else ts.plot(ts(t(plscvresul$GCrit)),gpars=list(xlab="Model Dim.",ylab="Partial GCV",type="n",cex=cexpar,bg=par("bg"))) for(i in 1:q){ points(1:plscvresul$A,plscvresul$GCrit[i,],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:plscvresul$A,plscvresul$GCrit[i,],type="l",lty=i,col=colpar+i) } cat("Click to locate the top left corner of the legend\n") legend(locator(1),dimnames(plscvresul$Yinitial)[[2]],pch=1:q,cex=cexpar, bty="n",x.intersp=.5,y.intersp=.5,col=colpar+(1:q)) } else { par(mfrow=c(1,1),pty=ptypar) if(titlepar) plot(plscvresul$GCritot,type="n",xlab="Model Dim.",ylab="GCV", main=paste("opt. Dim.",order(plscvresul$GCritot)[1],",",dimnames(plscvresul$Yinitial)[[2]], "GCV=",round(min(plscvresul$GCritot),3), "(alpha=",plscvresul$GCV,")"),cex=cexpar,bg=par("bg")) else plot(1:plscvresul$A,plscvresul$GCrit,xlab="Dim",ylab="GCV",type="n",cex=cexpar,bg=par("bg")) points(plscvresul$GCritot,pch=10,cex=cexpar+0.7) points(plscvresul$GCritot,type="l") } cat(paste("Dimension retained (<=",plscvresul$A,")")) A<-scan(quiet=T,"",numeric(),1) #browser() print(paste("GCV(",plscvresul$GCV,",",A,")=",round(plscvresul$GCritot[A],4),sep="")) invisible(return(plscvresul$GCritot,plscvresul$GCrit,A)) } } ############################################## Dcenter<-function(X,D=1) #D-centrage de la matrice X { X<-as.matrix(X) if(all(!is.na(X))){ if(length(D)==1) mx<-apply(X,2,"mean") else {idx<-D*X mx<-apply(idx,2,"sum") } X<-sweep(X,2,mx) } else { mx<-rep(0,ncol(X)) if(length(D)==1){for(i in 1:ncol(X)) mx[i]<-mean(X[,i][!is.na(X[,i])])} else {idx<-D*X mx<-apply(idx,2,"sum") } X<-sweep(X,2,mx) } return(X,mx) } ########################################################### Dcentred<-function(X,D=1) { # D-centrage de la matrice X # # Entree # X matrice des variables # D metrique des poids # Sorties # Xc matrice deduite de X, D-centree # Xcr matrice deduite de X, D-centree et reduite # moy vecteur des D-moyennes # var vecteur des D-variances X<-as.matrix(X) n<-nrow(X) p<-ncol(X) n2<-n*n n1<-matrix(1,nrow=n,ncol=1) if(length(D)==1)D<-diag(rep(1/n,n),nrow=n) if(length(D)==n)D<-diag(D,nrow=n) if(length(D)==n2)D<-as.matrix(D) moy<-t(n1)%*%D%*%X Xc<-sweep(X,2,moy) var<-diag(t(Xc)%*%D%*%Xc) ect<-sqrt(var) Xcr<-sweep(Xc,2,ect,FUN="/") return(Xc,Xcr,moy,var) } ############################################################## invgene<-function(A,eps=1e-06) # inverse generalisee de A { A<-as.matrix(A) # decomposition valeurs singulieres de A et calcul de son inverse dans RR valsin<-svd(A) diago<-valsin$d[valsin$d>eps] # browser() if(length(diago) == 0){RR<-matrix(0,ncol(A),nrow(A)) return(RR)} if(length(diago)==1) RR <- as.matrix(valsin$v[, 1:length(diago)])%*%t(as.matrix(valsin$u[, 1:length(diago)]))/diago else RR<-valsin$v[,1:length(diago)]%*%diag(1/diago)%*%t(valsin$u[,1:length(diago)]) return(RR) } ############################################################## Dproj<-function(X,Y,D=1,eps=1e-08,inv=F) # D-proj de Y sur X # sortie du residu Yres=Y-P Y de Yhat=P Y et des coef. beta # X X { X<-as.matrix(X) Y<-as.matrix(Y) if(inv) R<-solve(Dcp(X,D=D)) else R<-invgene(Dcp(X,D=D),eps=eps) H<-WDop(X,Q=R,D=D) Yhat<-H%*%Y Yres<-Y-Yhat beta<-R%*%Dcp(X,Y,D=D) return(H,Yhat,Yres,R,beta) } ################################################################ Dcp<-function(X,Y=X,D=1) { # signification de Dcp : Diagonalcrossproduct, i.e., X'DY # D est un vecteur des poids, par defaut 1/nrow(X) Y<-as.matrix(Y) X<-as.matrix(X) if(length(D)==1) DD<-rep(1/nrow(X),nrow(X)) else DD<-as.vector(D) for(i in 1:nrow(X)) X[i,]<-DD[i]*X[i,] V<-crossprod(X,Y) dimnames(V)<-NULL return(V) } ################################################################ Dvar<-function(X,D=1,cor=F) # VALUE: # V: matrice des D-variances de X si cor=F, sinon matrice des D-correlations # U: matrice D-centree de X si cor=F, sinon matrice D-centree reduite # mean: vecteur des D-moyennes # var: vecteur des D-variances { mat<-FALSE if(is.matrix(X)) mat<-TRUE X<-as.matrix(X) centrage<-Dcenter(X,D=D) Y<-centrage$X mean<-centrage$mx V<-VQop(Y,D=D) var<-diag(V) if(cor==F){ U<-Y } else { ect<-sqrt(var) U<-sweep(Y,2,ect,FUN="/") V<-VQop(U,D=D) } if(mat){ dimnames(V)<-list(dimnames(X)[[2]],dimnames(X)[[2]]) dimnames(U)<-dimnames(X) } return(V,U,mean,var) } ################################################################# WDop<-function(X,Y=X,Q=1,D=1) { # X,Y vecteurs ou matrices n x p, par defaut Y=X; # operateur des produits scalaires entre individus de X et Y, XQY'D; # Q est la metrique de l'espace des individus (par defaut Q=Ipp);Q matrice # D est la metrique de l'espace des variables de Y:(par defaut 1/n Inn), # D vecteur X<-as.matrix(X) Y<-as.matrix(Y) if(length(D)==1) DD<-rep(1/nrow(Y),nrow(Y)) else DD<-as.vector(D) if(!is.matrix(Q)) W<-X%*%t(Y) else W<-X%*%Q%*%t(Y) for(i in 1:ncol(W)) W[,i]<-DD[i]*W[,i] return(W) } ################################################################## VQop<-function(X,Y=X,Q=1,D=1) { # operateur crossproduct generalise, i.e., X'DYQ; # Q matrice ou vecteur est une metrique sur l'espace des variables de Y, # par defaut Q=1 donne l'identite # si Q=k alors Q=kI # si Q=vecteur alors Q=diag(vecteur); # D est un vecteur, par defaut D=1 donne le vecteur 1/nrow(X); Y<-as.matrix(Y) X<-as.matrix(X) if(length(D)==1) DD<-rep(1/nrow(X),nrow(X)) else DD<-as.vector(D) for(i in 1:nrow(X)) X[i,]<-DD[i]*X[i,] if(! is.matrix(Q)) { QQ<-as.vector(Q) if(length(QQ)==1 & QQ[1]==1){ V<-crossprod(X,Y) return(V) } if(length(QQ)==1 & QQ[1]!=1) QQ<-rep(QQ,ncol(Y)) for(i in 1:ncol(Y)) Y[,i]<-Y[,i]*QQ[i] V<-crossprod(X,Y) return(V) } V<-crossprod(X,Y)%*%Q return(V) } ################################################################### lss<-function(X,Y,listknots,centerX=F,centerY=F,standX=F,standY=F,D=1,degree=1,knots=0,equiknots=F, invpar=T,fonct=F,impres=T,nbpoints=50,titlepar=F,qual,ptypar="s",pchpar=1,cexpar=0.7,typedata=T, colpar=0,ncolpar=2,askpar=T) { # version 9.6 programee par J.F. Durand # Regression sur codage spline des predicteurs # # Entrees # invpar boolean, when T the inverse of the B'B is computed, if F the Moore-Penrose inverse is used. # impres impression des resultats si T, si F rien # graph trace des graphiques si T, si F pas de trace # nomfichX<-deparse(substitute(X)) nomfichY<-deparse(substitute(Y)) Xinitial<-as.matrix(X) Yinitial<-as.matrix(Y) if(standX)centerX<-TRUE if(standY)centerY<-TRUE if(!centerX)standX<-FALSE if(!centerY)standY<-FALSE centrageX <- Dvar(Xinitial, D = D, cor = F) meanX <- centrageX$mean varX <- centrageX$var centrageY <- Dvar(Yinitial, D = D, cor = F) meanY <- centrageY$mean varY <- centrageY$var n<-nrow(Xinitial) p<-ncol(Xinitial) q<-ncol(Yinitial) if(!missing(listknots)) { if(length(listknots)!=p){cat("nb incorrect de vecteurs de noeuds\n") return()} knots<-vector("numeric",p) for(i in 1:p)knots[i]<-length(listknots[[i]]) } if(is.null(dimnames(Xinitial)))dimnames(Xinitial)<-list(format(1:n),paste("X",1:p,sep="")) if(is.null(dimnames(Yinitial)))dimnames(Yinitial)<-list(format(1:n),paste("Y",1:q,sep="")) # calcul de la metrique si D=1 if(length(D)==1) DD<-rep(1/n,n) else DD<-as.vector(D) # centrage et reduction centX<-Dcentred(Xinitial,D=DD) centY<-Dcentred(Yinitial,D=DD) Xini<-Xinitial Yini<-Yinitial if(centerX)Xini<-as.matrix(centX$Xc) if(centerY)Yini<-as.matrix(centY$Xc) if(standX) Xini<-as.matrix(centX$Xcr) if(standY) Yini<-as.matrix(centY$Xcr) dimnames(Xini)<-dimnames(Xinitial) dimnames(Yini)<-dimnames(Yinitial) # calcul de la matrice de codage spline de Xini listknotsn<-list(NULL)#list of centered (possibly scaled) interior knots if(missing(listknots)){ listknotsn<-list(NULL) if(p>1) for(i in 1:(p-1))listknotsn<-c(listknotsn,list(NULL))} else { for(i in 1:p){ listknotsn[[i]]<-listknots[[i]] if(centerX)listknotsn[[i]]<-listknots[[i]]-meanX[i] if(standX)listknotsn[[i]]<-(listknotsn[[i]]-meanX[i])/sqrt(varX[i]) } } BsplineX <- Bsplinen(Xini,ordre=degree+1,nbni=knots,noeudequi=equiknots, center=centerX,D=D,tt=listknotsn) itX <- BsplineX$v dimension<-BsplineX$ordre+BsplineX$nbni Bcod<-NULL for(i in 1:p)Bcod<-cbind(Bcod,itX[[i]][[1]]) ######## resullsspl<-Dproj(Bcod,Yini,D=DD,inv=invpar) ######## Yhat<-resullsspl$Yhat beta<-resullsspl$beta Yres<-resullsspl$Yres R2<-Dvar(Yhat,D=DD)$var/Dvar(Yini,D=DD)$var if(length(D)==1) { fit<-sum(Yres^2) diaginvBtB<-diag(resullsspl$R)/n sigma2<-fit/(n-sum(diag(resullsspl$H))) intervconfbeta<-2*sqrt(diaginvBtB*sigma2) fit<-fit/n #browser() } else fit<-sum(diag(Dcp(Yres,D=DD))) if(impres){# if(fonct==F){ par(ask=askpar) cat("\n") cat("R2 \n") print(R2) cat("\n") cat("\n") cat("Least-squares fit \n") print(fit) cat("\n") } pX<-p pY<-q AA<-list(NULL) ranget<-list(NULL) Transf<-list(NULL) for(j in 1:pY) { Transf[[j]]<-matrix(0,n,pX) dd<-1 AA[[j]]<-list(NULL) for(i in 1:pX) { AA[[j]][[i]]<-as.matrix(beta[dd:(dd+dimension[i]-1),j]) dd<-dd+dimension[i] #browser() Transf[[j]][,i]<-BsplineX$v[[i]][[1]]%*%AA[[j]][[i]] ranget[[j]][i]<-diff(range(Transf[[j]][,i])) } } if(fonct==F){ cat("\n") cat("The B-spline transformations of the",pX,"predictor(s) are now being computed \n") } xx<-list(NULL) spl<-list(NULL) tt<-list(NULL) ttint<-list(NULL) for(i in 1:pX){ if(fonct==F){ cat(i," ") } minXini<-min(Xini[, i]) maxXini<-max(Xini[, i]) xx[[i]]<-seq(minXini,maxXini,length=nbpoints) if(BsplineX$nbni[i]!=0){ tt[[i]]<-BsplineX$v[[i]][[2]] ttint[[i]]<-tt[[i]][(BsplineX$ordre[i]+1):(BsplineX$ordre[i]+BsplineX$nbni[i])] if(centerX) spl[[i]]<-sweep(Bsplinen(xx[[i]],ordre=BsplineX$ordre[i],nbni=BsplineX$nbni[i],D=D,tt=list(ttint[[i]]))$v[[1]][[1]],2,BsplineX$meansc[[i]]) else spl[[i]]<-Bsplinen(xx[[i]],ordre=BsplineX$ordre[i],nbni=BsplineX$nbni[i],D=D,tt=list(ttint[[i]]))$v[[1]][[1]] } else { if(centerX) spl[[i]]<-sweep(Bsplinen(xx[[i]],ordre=BsplineX$ordre[i],nbni=0,D=D)$v[[1]][[1]],2,BsplineX$meansc[[i]]) else spl[[i]]<-Bsplinen(xx[[i]],ordre=BsplineX$ordre[i],nbni=0,D=D)$v[[1]][[1]] } } if(fonct==F){#### cat("\n") cat("__________________________________________________________________\n") }#### yy<-list(NULL) noeudint<-list(NULL) if(p==1){#### for(j in 1:q){#* if((titlepar==F)|missing(qual))par(pty=ptypar) else par(oma=c(0,0,4,0),pty=ptypar) yy[[1]]<-spl[[1]]%*%AA[[j]][[1]] if(titlepar==T) plot(Xini[,1],Yini[,j],ylim=range(c(Yini[,j],yy[[1]])),xlab=paste(dimnames(Xini)[[2]][j],sep=""), ylab="",cex=cexpar,main=paste("L-S splines for ",dimnames(Yini)[[2]][j],sep=""),type="n") else plot(Xini[,1],Yini[,j],ylim=range(c(Yini[,j],yy[[1]])),xlab=paste(dimnames(Xini)[[2]][j],sep=""), ylab=dimnames(Yini)[[2]][j],cex=cexpar,type="n") points(xx[[1]],yy[[1]],type="l",col=colpar+2) rug(Xini[,1],ticksize=0.02,lwd=1.5,col="red") if(typedata) { if(missing(qual)) text(Xini[,1],Yini[,j],dimnames(Xini)[[j]],cex=cexpar,col=colpar+1) else for(i in (min(qual):max(qual)))text(Xini[qual==i,1],Yini[qual==i,j],dimnames(Xini)[[1]][qual==i],cex=cexpar,col=colpar+i+1) } else points(Xini[,1],Yini[,j],pch=pchpar,cex=cexpar) if(BsplineX$nbni[1]!=0){ noeudint[[1]]<-BsplineX$v[[1]][[2]][(BsplineX$v[[1]][[2]]!=min(BsplineX$v[[1]][[2]]))&(BsplineX$v[[1]][[2]]!=max(BsplineX$v[[1]][[2]]))] abline(v=noeudint[[1]],lty=2) } }#* }#### else{#### cat("\n") cat("additive influence of the predictors on a response? (y/n)") plt <- scan("", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) { noeudint<-list(NULL) repeat {# if(pY==1)j<-1 else{ cat("The number of the response variable?,(<=",pY,")") j<- scan("", numeric(), 1) } if(titlepar==F)par(mfrow=c(1,1),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,1),pty=ptypar) if(pX<21) { xxf<-Transf[[j]][,1] catf<-rep(1,n) if(pX>1)for(i in 2:pX){xxf<-c(xxf,Transf[[j]][,i]) catf<-c(catf,rep(i,n)) } tecno24<-split(xxf,catf) boxplot(tecno24,sub="predictors",ylab="transf. dat.",cex=0.7) cat("Click to indicate the legend location\n") legend(locator(1),paste(1:p,dimnames(Xini)[[2]]),cex=cexpar,ncol=ncolpar,bty="n") if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,dimnames(Yini)[[2]][j]) } cat("\n") cat("Influence of the predictors on :",dimnames(Yini)[[2]][j]," \n") class<-NULL class<-matrix(0,1,pX) class[1,]<-round(rev(sort(ranget[[j]])),5) ordreinv<-rev(order(rank((ranget[[j]])),1:pX)) dimnames(class)<-list("",paste(dimnames(Xini)[[2]][ordreinv],"(",format(ordreinv),")",sep="")) cat("\n") cat("Range of the transformed predictors in descending order:\n") cat("\n") print(class) cat("\n") if(pX>50) barplot(class[1,],ylab="range of the transf. predictors",names=NULL,xlab="predictors",density=20,space=1.4) else {if(pX>10){ barplot(class[1,],ylab="range of the transf. predictors",names=format(ordreinv),xlab="predictors",density=20,space=1.4,col=colpar+(1:pX)) cat("Click to indicate the legend location\n") legend(locator(1),paste(ordreinv,dimnames(Xini)[[2]][ordreinv]),cex=cexpar,ncol=ncolpar,fill=colpar+(1:pX),bty="n") } else barplot(class[1,],ylab="range of the transf. predictors",names=dimnames(Xini)[[2]][ordreinv],xlab="predictors",density=20,space=1.4) } if((titlepar==T)) mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("influence of the predictors on",dimnames(Yini)[[2]][j])) cat("Coordinate function plots of the main influence predictors? (y/n)") plt <- scan("", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) {### cat("How many predictors?,(<=",pX,")") nb<- scan("", numeric(), 1) cat("How many plots on a row ?,(<=",nb,")") pc<- scan("", numeric(), 1) cat("How many row(s) ?") pl<-scan("", numeric(), 1) if(titlepar==F)par(mfrow=c(pl,pc),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(pl,pc),pty=ptypar) cat("Do you need curves, data or both? (c,d,b)") repeat{ plt<-scan("",character(),1) if(length(plt)==0){plt<-"d" break} if((plt=="c")|(plt=="d")|(plt=="b"))break } mintransf<-1e+18 maxtransf<-(-1e+18) yy<-list(NULL) for(i in ordreinv[1:nb]) { if(!(plt=="d")){ yy[[i]]<-spl[[i]]%*%AA[[j]][[i]] mintransf<-min(mintransf,min(yy[[i]])) maxtransf<-max(maxtransf,max(yy[[i]])) } else{mintransf<-min(mintransf,min(Transf[[j]][,i])) maxtransf<-max(maxtransf,max(Transf[[j]][,i])) } } for(i in ordreinv[1:nb]) { if(!(plt=="d")) { plot(xx[[i]],yy[[i]],ylim=c(mintransf,maxtransf),xlab=paste(dimnames(Xini)[[2]][i],sep=""),ylab="",type="n",cex=cexpar) points(xx[[i]],yy[[i]],type="l",col=colpar+3) } else plot(Xini[,i],Transf[[j]][,i],ylim=c(mintransf,maxtransf),xlab=paste(dimnames(Xini)[[2]][i],sep=""),ylab="",type="n") if(!(plt=="c")) { if(!typedata)points(Xini[, i],Transf[[j]][,i],pch=pchpar,cex=cexpar,col=colpar+7) else text(Xini[, i],Transf[[j]][,i],dimnames(Xini)[[1]],cex=cexpar,col=colpar+7) } noeudint[[i]]<-BsplineX$v[[i]][[2]][(BsplineX$v[[i]][[2]]!=min(BsplineX$v[[i]][[2]]))&(BsplineX$v[[i]][[2]]!=max(BsplineX$v[[i]][[2]]))] abline(v=noeudint[[i]],lty=2) } if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("L-S splines for ",dimnames(Yini)[[2]][j],sep="")) #dev.off() }### cat("Another reponse ? (y/n)") repo<-scan("",character(),1) if((length(repo)==0)|(repo!="y"))break }#fin du repeat } }#### if(fonct==F){#### cat("\n") cat("__________________________________________________________________\n") cat("\n") cat("Plots of the response residuals ? (y/n)") plt <- scan("", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) { if(titlepar==F)par(mfrow=c(1,pY),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,pY),pty=ptypar) variat<-range(Yini-Yhat) for(i in 1:pY) { sigmai<-sqrt(Dvar(Yini[,i]-Yhat[,i],D=D)$var) plot(Yhat[,i],Yini[,i]-Yhat[,i],ylim=c(min(variat[1],-2*sigmai),max(variat[2],2*sigmai)),xlab=paste("Fitted ",dimnames(Yinitial)[[2]][i],sep="") ,ylab="residuals",type="n",cex=cexpar) if(!typedata)points(Yhat[,i],Yini[,i]-Yhat[,i],pch=pchpar,cex=cexpar) else text(Yhat[,i],Yini[,i]-Yhat[,i],dimnames(Yinitial)[[1]],cex=cexpar,col=colpar+1) abline(h=0) abline(h=2*sigmai,lty=2) abline(h=-2*sigmai,lty=2) } if(titlepar==T)mtext(side=3,line=-1,cex=cexpar+0.7,outer=TRUE,"Residuals in Least-Squares splines") } cat("__________________________________________________________________\n") cat("plot of Yhat against Y (y/n)?") plt3 <- scan(,what="", 1) if((length(plt3)!=0)&&(plt3=="y")){ par(mfrow=c(1,1)) for(i in 1:pY) { plot(Yini[,i],Yhat[,i],xlab=dimnames(Yini)[[2]][i],ylab=paste("modeled ",dimnames(Yini)[[2]][i],sep=""),type="n",cex=cexpar) if(!typedata)points(Yini[,i],Yhat[,i],pch=pchpar,cex=cexpar) else text(Yini[,i],Yhat[,i],dimnames(Yini)[[1]],col=colpar+2) abline(a=0,b=1,col=colpar+3) } } cat("\n") cat("__________________________________________________________________\n") cat("\n") if(pY==2){ cat("Plot of the reconstituted responses (y/n)?") plt3 <- scan(,what="", 1) if((length(plt3)!=0)&&(plt3=="y")){ if(titlepar==F)par(mfrow=c(1,2),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,2),pty=ptypar) range1<-range(c(Yhat[, 1],Yini[, 1])) range2<-range(c(Yhat[, 2],Yini[, 2])) plot(Yhat[, 1],Yhat[,2],xlim=range1,ylim=range2,xlab=paste("fitted",dimnames(Yinitial)[[2]][1]),ylab=paste("fitted",dimnames(Yinitial)[[2]][2]),type="n",pch=pchpar,main="Reconstituted shape") if(!typedata)points(Yhat[, 1],Yhat[, 2],pch=pchpar,cex=cexpar) else text(Yhat[, 1],Yhat[, 2],dimnames(Yinitial)[[1]],col=colpar+(1:n)) plot(Yini[, 1],Yini[, 2],xlim=range1,ylim=range2,xlab=dimnames(Yinitial)[[2]][1],ylab=dimnames(Yini)[[2]][2],type="n",pch=pchpar,main="Original shape") if(!typedata)points(Yini[, 1],Yini[, 2],pch=pchpar,cex=cexpar) else text(Yini[, 1],Yini[, 2],dimnames(Yinitial)[[1]],col=colpar+(1:n)) if(titlepar==T)mtext(side=3,line=0,cex=2,outer=TRUE,"Least-Squares Splines") } } }#### }# #browser() if(impres&fonct)invisible(return(R2,fit,beta,Bcod,xx,spl,intknots=BsplineX$intknots,knots=BsplineX$nbni)) invisible( return(R2,fit,beta,Bcod)) } ####################################################### interactionij<-function(Bsplineresult,i,j) { Xij<-NULL for(k in 1:ncol(Bsplineresult$v[[i]][[1]])) Xij<-cbind(Xij,Bsplineresult$v[[i]][[1]][,k]*Bsplineresult$v[[j]][[1]]) return(Xij) } ####################################################### plss<-function(X,Y,Xtest,Ytest,standX=T,standY=T,D=1,A=2,degree=1,knots=0,equiknots=F,eps=1e-8,listknots, impres=T,interaction=NULL,listinteraction,cexpar=0.7,colpar=1,titlepar=T) { # version 9.6 programmee par JF Durand # Regression PLS sur codage spline des predicteurs # order<-degree +1 nomfichX<-deparse(substitute(X)) nomfichY<-deparse(substitute(Y)) Xinitial<-as.matrix(X) Yinitial<-as.matrix(Y) centrageX <- Dvar(Xinitial, D = D, cor = F) meanX <- centrageX$mean varX <- centrageX$var centrageY <- Dvar(Yinitial, D = D, cor = F) meanY <- centrageY$mean varY <- centrageY$var if(!missing(Xtest)){ centrageXtest <- Dvar(Xtest, D = D, cor = F) meanXtest <- centrageXtest$mean varXtest <- centrageXtest$var } n<-nrow(Xinitial) p<-ncol(Xinitial) q<-ncol(Yinitial) if(!missing(listknots)) { { if(length(listknots)!=p){cat("nb incorrect de vecteurs de noeuds\n") return()} knots<-vector("numeric",p) for(i in 1:p) { knots[i]<-length(listknots[[i]]) if(knots[i]!=0){ rangeknots<-range(listknots[[i]]) rangevar<-range(Xinitial[,i]) if((rangeknots[1]<=rangevar[1])|(rangeknots[2]>=rangevar[2])) { cat("range of interior knots out of range of variable ",dimnames(Xinitial)[[2]][i],"!!!\n") return(list(nomfichX="NON4")) }} } } } if(is.null(dimnames(Xinitial)))dimnames(Xinitial)<-list(format(1:n),paste("X",1:p,sep="")) if(is.null(dimnames(Yinitial)))dimnames(Yinitial)<-list(format(1:n),paste("Y",1:q,sep="")) if(length(dimnames(Xinitial)[[1]])==0) dimnames(Xinitial)[[1]]<- format(1:n) if(length(dimnames(Yinitial)[[1]])==0) dimnames(Yinitial)[[1]]<- format(1:n) if(length(dimnames(Xinitial)[[2]])==0) dimnames(Xinitial)[[2]]<- paste("X",1:p,sep="") if(length(dimnames(Yinitial)[[2]])==0) {cat("Affect name(s) to response(s)\n") prov<-as.vector(format(1:q)) for(i in 1:q) {cat(paste("response ",format(i),"\n")) prov[i]<-scan(quiet=T,,what="", 1) } dimnames(Yinitial)[[2]]<-prov } # centrage et reduction centX<-Dcentred(Xinitial,D=D) centY<-Dcentred(Yinitial,D=D) if(!missing(Xtest)) { Xinitest<-sweep(Xtest, 2,centX$moy) if(standX) Xinitest<- sweep(Xinitest,2,sqrt(centX$var),FUN="/") dimnames(Xinitest)<-dimnames(Xtest) } if(!missing(Ytest)) { Yinitest<-sweep(Ytest, 2,centY$moy) if(standY) Yinitest<-sweep(Yinitest,2,sqrt(centY$var),FUN="/") dimnames(Yinitest)<-dimnames(Ytest) } if(standX) Xini<-as.matrix(centX$Xcr) else Xini<-as.matrix(centX$Xc) if(standY) Yini<-as.matrix(centY$Xcr) else Yini<-as.matrix(centY$Xc) dimnames(Xini)<-dimnames(Xinitial) dimnames(Yini)<-dimnames(Yinitial) # calcul de la matrice de codage spline de Xini listknotsn<-list(NULL)#list of centered (possibly scaled) interior knots if(missing(listknots)){ listknotsn<-list(NULL) if(p>1) for(i in 1:(p-1))listknotsn<-c(listknotsn,list(NULL)) listknots<-listknotsn } else {if(p>1) for(i in 1:(p-1))listknotsn<-c(listknotsn,list(NULL)) for(i in 1:p){ if(!is.null(listknots[[i]])){ #if(centerX)listknotsn[[i]]<-listknots[[i]]-meanX[i] if(standX)listknotsn[[i]]<-(listknots[[i]]-meanX[i])/sqrt(varX[i]) else listknotsn[[i]]<-listknots[[i]]-meanX[i] } } } BsplineX <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=T,D=D,tt=listknotsn) itX <- BsplineX$v dimension<-BsplineX$ordre+BsplineX$nbni Bcod<-NULL for(i in 1:p)Bcod<-cbind(Bcod,itX[[i]][[1]]) Bcodintcum<-NULL if((missing(listinteraction))&(length(interaction)!=0)) { BsplineXint <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=F,D=D,tt=listknotsn) rint<-length(interaction) Bcodint<-list(NULL) Bcodintmean<-list(NULL) dimensionint<-matrix(0,rint,rint) namesint<-matrix("",rint,rint) namesint1<-NULL for(i in 1:(rint-1)) { Bcodint[[i]]<-list(NULL) for(j in (i+1):rint) { Bcodint[[i]][[j]]<-Dcenter(interactionij(BsplineXint,interaction[i],interaction[j]),D=D)$X Bcodintmean[[i]][[j]]<-Dcenter(interactionij(BsplineXint,interaction[i],interaction[j]),D=D)$mx Bcodintcum<-cbind(Bcodintcum,Bcodint[[i]][[j]]) namesint[i,j]<-paste(dimnames(Xini)[[2]][interaction[i]],"*",dimnames(Xini)[[2]][interaction[j]],sep="") namesint1<-c(namesint1,namesint[i,j]) dimensionint[i,j]<-dimension[interaction[i]]*dimension[interaction[j]] } }} if(!missing(listinteraction)) { namesint1<-NULL dimensionint<-rep(0,length(listinteraction)) BsplineXint <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=F,D=D,tt=listknotsn) Bcodint<-list(NULL) Bcodintmean<-list(NULL) for(i in 1:length(listinteraction)) { Bcodint[[i]]<-Dcenter(interactionij(BsplineXint,listinteraction[[i]][1],listinteraction[[i]][2]),D=D)$X dimensionint[i]<-ncol(Bcodint[[i]]) Bcodintcum<-cbind(Bcodintcum,Bcodint[[i]]) namesint1<-c(namesint1,paste(dimnames(Xini)[[2]][listinteraction[[i]][1]],"*",dimnames(Xini)[[2]][listinteraction[[i]][2]],sep="")) Bcodintmean[[i]]<-Dcenter(interactionij(BsplineXint,listinteraction[[i]][1],listinteraction[[i]][2]),D=D)$mx } } #browser() #cat(svd(Bcod)$d) if(!missing(Xtest)){ BsplineXtest <- Bsplinen(rbind(Xinitest,apply(Xini,2,min),apply(Xini,2,max)),ordre=order, nbni=knots,center=F,D=D,tt=BsplineX$intknots) itXtest <- BsplineXtest$v Bcodtest<-NULL for(i in 1:p)Bcodtest<-cbind(Bcodtest,sweep(itXtest[[i]][[1]][1:nrow(Xtest),,drop=F],2,BsplineX$meansc[[i]])) #add interactions if any!!!! } if(impres){ cat("\n") if(length(interaction)==0) cat("PLSS : LINEAR PLS ON SPLINE CODED PREDICTORS\n") else cat("PLSS : LINEAR PLS ON SPLINE CODED PREDICTORS + INTERACTIONS\n") cat("\n") } ######################### if(missing(Xtest))resulpls<-pls(X=cbind(Bcod,Bcodintcum),Y=Yini,standX=F,standY=F,A=A,D=D, splflag=T,impres=impres,graph=F,eps=eps,cexpar=cexpar,colpar=colpar,titlepar=titlepar) else {if(missing(Ytest)) resulpls<-pls(X=Bcod,Y=Yini,Xtest=Bcodtest,standX=F,standY=F,A=A,D=D,splflag=T,impres=impres, graph=F,eps=eps,cexpar=cexpar,colpar=colpar,titlepar=titlepar) else resulpls<-pls(X=Bcod,Y=Yini,Xtest=Bcodtest,Ytest=Yinitest,standX=F,standY=F,A=A,D=D,splflag=T, impres=impres,graph=F,eps=eps,cexpar=cexpar,colpar=colpar,titlepar=titlepar) } ######################### cat("\n") alph<-resulpls$alph R2<-resulpls$R2c pX<-p pY<-q noeudint<-list(NULL) axes<-resulpls$A corX<-standX corY<-standY covXY<-resulpls$covXY alphaX<-NULL compX<-resulpls$TX compY<-resulpls$UY cX<-resulpls$WX cY<-resulpls$CY BETALCR<-resulpls$BETALCR YH<-resulpls$YH Yhat<-matrix(0,n,pY) dimnames(Yhat)<-dimnames(Yini) VY<-NULL for(i in 1:axes){ Yhat<-Yhat+YH[[i]] VY<-c(VY,sum(Dvar(YH[[i]],D=D)$var)) } AA<-list(NULL) ranget<-list(NULL) Transf<-list(NULL) if(length(interaction)!=0) { rangetint<-list(NULL) Transfint<-list(NULL) AAint<-list(NULL) } for(j in 1:pY) { Transf[[j]]<-matrix(0,n,pX) ranget[[j]]<-rep(0,pX) if(length(interaction)!=0){ Transfint[[j]]<-array(0,c(n,rint,rint)) AAint[[j]]<-list(NULL) rangetint[[j]]<-matrix(0,rint,rint) } dd<-1 AA[[j]]<-list(NULL) for(i in 1:pX) { AA[[j]][[i]]<-as.matrix(BETALCR[[axes]][j,dd:(dd+dimension[i]-1)]) dd<-dd+dimension[i] Transf[[j]][,i]<-BsplineX$v[[i]][[1]]%*%AA[[j]][[i]] ranget[[j]][i]<-diff(range(Transf[[j]][,i])) } names(ranget[[j]])<-dimnames(Xini)[[2]] #browser() if(length(interaction)!=0) { for(i in 1:(rint-1)) { AAint[[j]][[i]]<-list(NULL) for(k in (i+1):rint){ AAint[[j]][[i]][[k]]<-as.matrix(BETALCR[[axes]][j,dd:(dd+dimensionint[i,k]-1)]) dd<-dd+dimensionint[i,k] Transfint[[j]][,i,k]<-Bcodint[[i]][[k]]%*%AAint[[j]][[i]][[k]] rangetint[[j]][i,k]<-diff(range(Transfint[[j]][,i,k])) dimnames(rangetint[[j]])<-list(dimnames(Xini)[[2]][interaction],dimnames(Xini)[[2]][interaction]) } } }#endifinteraction }#endjloop if(length(interaction)==0) { corYtrans<-matrix(0,q,pX) dimnames(corYtrans)<-list(dimnames(Yini)[[2]],dimnames(Xini)[[2]]) } else { corYtrans<-matrix(0,q,pX+rint*(rint-1)/2) dimnames(corYtrans)<-list(dimnames(Yini)[[2]],c(dimnames(Xini)[[2]],namesint1)) } for(j in 1:q) corYtrans[j,1:pX]<-cor(cbind(Yini[,j],Transf[[j]]))[2:(1+pX),1] if(length(interaction)!=0) { for(j in 1:q) {compt<-1 for(i in 1:(rint-1)) for(k in (i+1):rint) { corYtrans[j,pX+compt]<-cor(Yini[,j],Transfint[[j]][,i,k]) compt<-compt+1 }} } corYtrans<-round(corYtrans,2) #browser() if(impres){ if((!missing(Xtest))&(missing(Ytest))){ repeat{ cat("\n") cat("Prediction of the test sample according to the dimension ? (y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break { cat("Choose the dimension (<=",axes,")") dimopt<-scan(quiet=T,"",numeric(),1) AAt<-list(NULL) Transftest<-list(NULL) for(j in 1:pY) { Transftest[[j]]<-matrix(0,nrow(Xtest),pX) dd<-1 AAt[[j]]<-list(NULL) for(i in 1:pX) { AAt[[j]][[i]]<-as.matrix(BETALCR[[dimopt]][j,dd:(dd+dimension[i]-1)]) dd<-dd+dimension[i] Transftest[[j]][,i]<-sweep(BsplineXtest$v[[i]][[1]][1:nrow(Xtest),,drop=F],2,BsplineX$meansc[[i]],FUN="-")%*%AAt[[j]][[i]] } } Yaju<-matrix(0,nrow(Xtest),q) dimnames(Yaju)<-list(dimnames(Xtest)[[1]],paste("est.",dimnames(Yini)[[2]],sep="")) for(j in 1:pY) for(i in 1:pX) Yaju[,j]<-Yaju[,j]+Transftest[[j]][,i] for(i in 1:pY){ if(standY)Yaju[,i]<-Yaju[,i]*sqrt(centY$var[i])+centY$moy[i] else Yaju[,i]<-Yaju[,i]+centY$moy[i] } print(Yaju) #browser() } #else break }##fin du repeat }#fin du if missing Xtest if((!missing(Xtest))&(!missing(Ytest))) { repeat{#2 cat("\n") cat("Validation of the model with the test sample according to the dimension ? (y/n)") repospe<-scan(quiet=T,"",character(),1) if((length(repospe)!=0)&&((repospe=="y")|(repospe=="Y"))) { Yerr<-as.list(1:axes) Yajust<-as.list(1:axes) ERRMOY<-vector("numeric",axes) for(dimopt in 1:axes) { Yerr[[dimopt]]<-matrix(0,nrow(Ytest),ncol(Ytest)) AAt<-list(NULL) Transftest<-list(NULL) for(j in 1:pY) { Transftest[[j]]<-matrix(0,nrow(Xtest),pX) dd<-1 AAt[[j]]<-list(NULL) for(i in 1:pX) { AAt[[j]][[i]]<-as.matrix(BETALCR[[dimopt]][j,dd:(dd+dimension[i]-1)]) dd<-dd+dimension[i] Transftest[[j]][,i]<-sweep(BsplineXtest$v[[i]][[1]][1:nrow(Xtest),,drop=F],2,BsplineX$meansc[[i]],FUN="-")%*%AAt[[j]][[i]] } } Yaju<-matrix(0,nrow(Ytest),q) dimnames(Yaju)<-list(dimnames(Ytest)[[1]],paste("est.",dimnames(Ytest)[[2]],sep="")) for(j in 1:pY) for(i in 1:pX) Yaju[,j]<-Yaju[,j]+Transftest[[j]][,i] for(i in 1:pY){ if(standY)Yaju[,i]<-Yaju[,i]*sqrt(centY$var[i])+centY$moy[i] else Yaju[,i]<-Yaju[,i]+centY$moy[i] } Yajust[[dimopt]]<-Yaju Yerr[[dimopt]]<- Ytest-Yaju ERRMOY[dimopt]<-mean(apply(abs(Yerr[[dimopt]]),2,mean)) }#fin du for sur dimopt cat("Mean Absolute Error of the response(s) according to the dimension\n") errmoy<-matrix(ERRMOY,1,axes) dimnames(errmoy)<-list("MeanAbsErr",1:axes) print(round(errmoy,3)) cat("Choose the dimension (<=",axes,")") dimoptopt<-scan(quiet=T,"",numeric(),1) cat("Estimated Responses (Yest) as well as Errors (Yerr = Ytest - Yest) \n") dimnames(Yerr[[dimoptopt]])[[2]]<-paste("err.",dimnames(Ytest)[[2]],sep="") Yaff<-NULL for(i in 1:ncol(Ytest))Yaff<-cbind(Yaff,as.matrix(cbind(Yajust[[dimoptopt]][,i,drop=F],Yerr[[dimoptopt]][,i,drop=F]))) print(round(Yaff,4)) if(sum(Ytest==0)==0){ cat("Relative Errors in %: |Yerr|/|Ytest|*100\n") erreur100<-abs(Yerr[[dimoptopt]])/abs(Ytest)*100 erreur100<-rbind(erreur100,apply(erreur100,2,mean),sqrt(apply(erreur100,2,var))) dimnames(erreur100)<-list(c(dimnames(Ytest)[[1]],"Mean","Stdv"),dimnames(Ytest)[[2]]) print(round(erreur100,2)) } cat("plot of estimated versus observed Ytest\n") if(q>1){ cat("How many plots per row (<=",q,")?\n") colplots<-scan(quiet=T,"",numeric(),1) cat("How many rows?\n") rowplots<-scan(quiet=T,"",numeric(),1) par(mfrow=c(rowplots,colplots)) } else par(mfrow=c(1,1)) par(pty="s") for(i in 1:q) { if(titlepar) { if(sum(Ytest==0)==0){ if(abs(sum(Yini^2)-sum(Yinitest^2))1, des NA sinon . # center, boolleen indiquant le centrage # ordre . # nbni . # noeudequi . # intknots liste des vecteurs des noeuds interieurs # si center=T, sortie des vecteurs D-moyennes des colonnes de X (mx) # et de v[[.]][[1]] #________________________________________________________________________________ X <- as.matrix(X) #cat("Spline transformations of columns are now being computed...\n") #-------------------------------------------------------------------------------- #centrage eventuel de X if(center == T) { trans <- Dcenter(X, D = D) X <- trans$X mx <- trans$mx } #--------------------------------------------------------------------------------- ordre <- as.vector(ordre) if(length(ordre) == 1) ordre <- rep(ordre, ncol(X)) nbni <- as.vector(nbni) if(length(nbni) == 1) nbni <- rep(nbni, ncol(X)) noeudequi <- as.vector(noeudequi) if(length(noeudequi) == 1) noeudequi <- rep(noeudequi, ncol(X)) v <- list(NULL) if(missing(tt)) {tt <- list(NULL) if(ncol(X)>1)for(i in 1:(ncol(X)-1))tt<-c(tt,list(NULL)) } meansc <- list(NULL) intknots<-list(NULL) for(i in 1:ncol(X)) {## #cat("* ") if(diff(range(X[,i]))==0) { if(!is.null(dimnames(X)[[2]])) stop(paste("The variable '",dimnames(X)[[2]][i],"' is constant, remove it!!\n",sep="")) else stop(paste("The variable number ",i," is constant, remove it!!\n",sep="")) } nod<-noeuds(X[,i],nbn=nbni[i],ord=ordre[i],equi=noeudequi[i],tt=tt[[i]]) a<-vector("numeric",ordre[i]+nbni[i]) if((ordre[i]>1)&(!is.null(nod)))for(j in 1:(ordre[i]+nbni[i]))a[j]<-mean(nod[(j+1):(j+ordre[i]-1)]) else a<-rep(NA,ordre[i]+nbni[i]) intknots[[i]]<-nod[(ordre[i]+1):(ordre[i]+nbni[i])] if(ordre[i]!=1) { if(is.null(nod))v[i]<-list(list(bs(X[,i],knots=NULL,intercept=T,degree=ordre[i]-1),nod,a)) else v[i]<-list(list(bs(X[,i],knots=nod[(ordre[i]+1):(ordre[i]+nbni[i])],intercept=T,degree=ordre[i]-1),nod,a)) } else { if(is.null(nod))v[i]<-list(list(matrix(1,nrow(X),1),nod,a)) else v[i]<-list(list(MVcut(X[,i,drop=F],breaks=list(nod[(ordre[i]+1):(ordre[i]+nbni[i])]))$U,nod,a)) } # D-centrage eventuel de la matrice des transformees splines if(center == T) { transit <- Dcenter(v[[i]][[1]], D = D) v[[i]][[1]] <- transit$X meansc[[i]] <- transit$mx } }## #cat("\n") if(center) invisible(return(X, v, center, ordre, nbni, noeudequi, mx, meansc,intknots)) invisible(return(X, v, center, ordre, nbni, noeudequi,intknots)) } ############################################### noeuds<-function(x,nbn,ord,equi=T,tt) # x vecteur # nbn entier nombre de noeuds interieurs # ord entier ordre des splines= degre+1 # equi booleen, si TRUE noeuds interieurs equidistants, si FALSE nbn quantiles # sauf si tt est fourni # tt vecteur des noeuds interieurs # sortie: t vecteur des noeuds de 2*ord+nbn elements {#browser() x<-as.vector(x) n<-ord*2+nbn mi<-min(x) ma<-max(x) noeuds<-vector("numeric",n) noeuds[1:ord]<-mi noeuds[(ord+nbn+1):n]<-ma if(nbn!=0){ if(length(tt)==0) { tt<-vector("numeric",nbn) if(equi){h<-(ma-mi)/(nbn+1) for(i in 1:nbn) tt[i]<-mi+i*h } else tt<- quantile(x,seq(0,1,1/(nbn+1)))[2:(nbn+1)] } if(length(tt)!=nbn)cat("misfit dans le nb de noeuds interieurs !!!\n") noeuds[(ord+1):(ord+nbn)]<-tt } else noeuds<-NULL return(noeuds) } ################################################### plss.plotinter<-function(resulpls,Xtest,ptypar="s",typedata=T,titlepar=T,pchpar=1, cexpar=0.7,nbpoints=50,colpar=0,askpar=T,thetapar=-60,phipar=30,rpar=10) # # DESCRIPTION # give usual plots for interpreting the results of the PLSS method. # # ARGUMENTS # # resulpls S-PLUS object returned from the plss function. #VALUE # # no object except when Xtest is not missing. When Xtest is present, a list # containing the folllowing component: # Ypred Y predicted matrix. The number of columns is the same of the number of # columns of the response matrix for the plss function. The number of rows is # the same as in Xtest. { colorpar<-colpar Xini<-resulpls$Xini Yini<-resulpls$Yini pX<-ncol(Xini) pY<-ncol(Yini) n<-nrow(Xini) A<-list(NULL) noeudint<-list(NULL) axes<-resulpls$axes corX<-resulpls$corX corY<-resulpls$corY covXY<-resulpls$covXY compX<-resulpls$compX compY<-resulpls$compY cX<-resulpls$cX cY<-resulpls$cY Yhat<-resulpls$Yhat BsplineX<-resulpls$BsplineX itX <- BsplineX$v dimension<-resulpls$dimension interaction<-resulpls$interaction if(!is.null(resulpls$listinteraction))listinteraction<-resulpls$listinteraction if((!is.null(resulpls$listinteraction))|(length(interaction)!=0)) { dimensionint<-resulpls$dimensionint if(length(interaction)!=0) { rint<-length(interaction) interactnumber<-rint*(rint-1)/2 } else interactnumber<-length(listinteraction) rangetint<-resulpls$rangetint namesint1<-resulpls$namesint1 } #browser() yy<-list(NULL) nom<-deparse(substitute(resulpls)) par(ask=askpar) varX<-resulpls$varX varX<-as.matrix(varX) varX1<-round(cbind(resulpls$meanX,sqrt(varX)),2) dimnames(varX1)<-list(dimnames(resulpls$Xini)[[2]],c(" mean","st.dv.")) varY<-resulpls$varY varY<-as.matrix(varY) varY1<-round(cbind(resulpls$meanY,sqrt(varY)),2) dimnames(varY1)<-list(dimnames(resulpls$Yini)[[2]],c(" mean","st.dv.")) cat(" General information on the data? (y/n)") general<- scan(quiet=T,"", character(), 1) if(length(general)==0)general<-"n" cat("\n") cat("__________________________________________________________________\n") cat("\n") if((general=="y")|(general=="Y")) { cat("\n") cat("__________________________________________________________________\n") cat("\n") cat(paste(" File of the PLSS results: ",nom,"\n")) cat("__________________________________________________________________\n") cat("\n") cat(paste(" 'X' data file:",resulpls$nomfichX,"\n")) cat(paste(format(n)," objects, ",format(pX)," variables","\n")) if(resulpls$corX)cat("The data are scaled\n") else cat("The data are centered\n") cat("------------------------------------------------------------------\n") cat(paste("'Y' data file:",resulpls$nomfichY,"\n")) cat(paste(format(n)," objects, ",format(pY)," variables","\n")) if(resulpls$corY)cat("The data are scaled\n") else cat("The data are centered\n") cat("------------------------------------------------------------------\n") cat("mean and stand. dev. of the X variables: \n") cat("\n") print(t(varX1)) cat("------------------------------------------------------------------\n") cat("mean and stand. dev. of the Y variables : \n") cat("\n") print(t(varY1)) cat("------------------------------------------------------------------\n") cat("Nature of the B-splines :\n") cat("\n") for(i in 1:pX){ if(resulpls$knots[[i]]!=0){ if(length(resulpls$listknots[[i]])==0) { if(resulpls$BsplineX$noeudequi[i])noeudqual<-",equidistributed\n" else noeudqual<-",quantiles\n" } else{ noeudqual<-", imposed\n" nombrenoeuds<-length(resulpls$listknots[[i]]) } } else{ nombrenoeuds<-0 noeudqual<-", Polynomial\n" } cat(dimnames(resulpls$Xini)[[2]][i],":"," degree ",resulpls$BsplineX$ordre[i]-1,", knots ",resulpls$knots[i],noeudqual) } cat("------------------------------------------------------------------\n") cat(paste("number of components : ",resulpls$axes,"\n")) cat("------------------------------------------------------------------\n") cat(paste("Optimal covariances of the (t,u): ")) cat(round(resulpls$covXY,3)) cat("\n") cat("______________________________________________________________________\n") } if((!is.null(resulpls$listinteraction))|(length(interaction)!=0)) { cat("Bivariate interactions accounted for :\n") cat(namesint1) cat("\n") } cat("______________________________________________________________________\n") cat("The B-spline transformations of the",pX,"predictors are now being computed \n") xx<-list(NULL) spl<-list(NULL) splnc<-list(NULL) tt<-rep(list(NULL),pX) ttint<-rep(list(NULL),pX) for(i in 1:pX)if(resulpls$knots[i]!=0)tt[[i]]<-BsplineX$v[[i]][[2]] for(i in 1:pX) if(length(tt[[i]])!=0)ttint[[i]]<-tt[[i]][(BsplineX$ordre[i]+1):(BsplineX$ordre[i]+BsplineX$nbni[i])] for(i in 1:pX){ cat(i," ") minXini<-min(Xini[, i]) maxXini<-max(Xini[, i]) xx[[i]]<-seq(minXini,maxXini,length=nbpoints) splnc[[i]]<-Bsplinen(xx[[i]],ordre=BsplineX$ordre[i],nbni=BsplineX$nbni[i],D=D,tt=list(ttint[[i]]))$v[[1]][[1]] spl[[i]]<-sweep(splnc[[i]],2,BsplineX$meansc[[i]]) varX<-Dvar(resulpls$compX,cor=T,D=resulpls$D) varY<-Dvar(resulpls$compY,cor=T,D=resulpls$D) varx<-Dvar(resulpls$compX,D=resulpls$D)$V vary<-Dvar(resulpls$compY,D=resulpls$D)$V CompXN<-varX$U CompYN<-varY$U } cat("\n") cat("------------------------------------------------------------------\n") cat("\n") inertreconst<-round(sum(diag(Dvar(resulpls$Yhat,D=resulpls$D)$V)),4) varYini<-Dvar(resulpls$Yini,D=resulpls$D)$V suminer<-round(sum(diag(varYini)),4) cat(paste("Y variance =",suminer,", reconstituted variance =",inertreconst," according to components\n")) cat("\n") valtab<-matrix(0,resulpls$axes,3) dimnames(valtab)<-list(format(1:resulpls$axes),c(" Y var."," % "," cumul. %")) valtab[,1]<-round(resulpls$VY,digits=4) valtab[,2]<-round(resulpls$VY/suminer*100,digits=2) for(i in 1:resulpls$axes)valtab[i,3]<-sum(valtab[1:i,2]) print(valtab) cat("\n") cat("______________________________________________________________________\n") cat("\n") cat("R2 of the reponses on the t subspaces according to the dimension\n") cat("\n") R2tab<-matrix(0,resulpls$axes,pY) dimnames(R2tab)<-list(paste(format(1:resulpls$axes)," "),dimnames(resulpls$Yini)[[2]]) for(k in 1:resulpls$axes) for(j in 1:pY) R2tab[k,j]<-round(as.numeric(Dcp(resulpls$YH[[k]][,j],D=resulpls$D))/varYini[j,j],3) if(resulpls$axes > 1)for(j in 2:resulpls$axes)R2tab[j,]<-R2tab[j,]+R2tab[j-1,] print(R2tab) cat("______________________________________________________________________\n") cat("additive influence of the predictors on a response? (y/n)") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) { noeudint<-list(NULL) repeat {# if(pY==1)j<-1 else{ cat("The number of the reponse variable?,(<=",pY,")") j<- scan(quiet=T,"", numeric(), 1) } if(titlepar==F)par(mfrow=c(1,1),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,1),pty=ptypar) if((length(interaction)==0)& is.null(resulpls$listinteraction)) { if(pX>1){ if(pX<31) { xxf<-resulpls$Transf[[j]][,1] catf<-rep(1,n) if(pX>1)for(i in 2:pX){xxf<-c(xxf,resulpls$Transf[[j]][,i]) catf<-c(catf,rep(i,n)) } tecno24<-split(xxf,catf) if(pX>30) boxplot(tecno24,sub="predictors",ylab="transf. data",cex=cexpar) else boxplot(tecno24,sub="",ylab="transf. data",cex=cexpar,names=dimnames(resulpls$Xini)[[2]]) if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,dimnames(resulpls$Yini)[[2]][j]) } cat("\n") cat("Influence of the predictors on the response:",dimnames(resulpls$Yini)[[2]][j]," \n") class<-NULL class<-matrix(0,1,pX) class[1,]<-round(rev(sort(resulpls$ranget[[j]])),5) ordreinv<-rev(order(rank((resulpls$ranget[[j]])),1:pX)) dimnames(class)<-list("",paste(dimnames(resulpls$Xini)[[2]][ordreinv],"(",format(ordreinv),")",sep="")) cat("\n") cat("Range of the transformed predictors in descending order:\n") #cat("\n") print(class) cat("A look at coordinate functions? (y/n)") plt1 <- scan(quiet=T,"", character(), 1) if( (length(plt1)!=0)&&((plt1=="y")|(plt1=="Y"))) plotflag<-T else plotflag<-F #cat("\n") if(pX>1){ if(pX<=30){ barplot(class[1,],xlab="range of the transf. predictors",names=dimnames(resulpls$Xini)[[2]][], ylab="",density=20,space=1.4,horiz=T,col=1:pX,cex.names=cexpar,cex.axis=cexpar) } if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("Predictors' Influence on",dimnames(resulpls$Yini)[[2]][j],",",format(axes),"Dim.")) } if(plotflag){ cat("Ordered predictors? (y/n)") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) ordrepredict<-ordreinv else ordrepredict<-1:pX #{### cat("How many predictors?,(<=",pX,")") nb<- scan(quiet=T,"", numeric(), 1) cat("How many plots on a row ?,(<=",nb,")") pc<- scan(quiet=T,"", numeric(), 1) cat("How many row(s) ?") pl<-scan(quiet=T,"", numeric(), 1) }#endplotflag } else {pl<-1 pc<-1 nb<-1 ordrepredict<-1} if(plotflag){### if(titlepar==F)par(mfrow=c(pl,pc),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(pl,pc),pty=ptypar) cat("Do you need curves, data or both? (c,d,b)") repeat{ plt<-scan(quiet=T,"",character(),1) if(length(plt)==0){plt<-"d" break} if((plt=="c")|(plt=="d")|(plt=="b"))break } mintransf<-1e+18 maxtransf<-(-1e+18) for(i in ordrepredict[1:nb]) { if(!(plt=="d")){ A[[i]]<-resulpls$AA[[j]][[i]] yy[[i]]<-spl[[i]]%*%A[[i]] mintransf<-min(mintransf,min(yy[[i]])) maxtransf<-max(maxtransf,max(yy[[i]])) } else{mintransf<-min(mintransf,min(resulpls$Transf[[j]][,i])) maxtransf<-max(maxtransf,max(resulpls$Transf[[j]][,i])) } } for(i in ordrepredict[1:nb]) { if(pX==1){ if(pX!=1) plot(resulpls$Xini[,i],resulpls$Yini[,j],xlab=paste(dimnames(Xini)[[2]][i],sep=""),ylab="",type="n",cex=cexpar) text(resulpls$Xini[,i],resulpls$Yini[,j],dimnames(Xini)[[1]],cex=cexpar,col=colpar+5) } if(!(plt=="d")){ if(pX!=1) plot(xx[[i]],yy[[i]],ylim=c(mintransf,maxtransf),xlab=paste(dimnames(Xini)[[2]][i],sep=""),ylab="",type="n",cex=cexpar) points(xx[[i]],yy[[i]],type="l",col=colorpar+3) } else plot(Xini[,i],resulpls$Transf[[j]][,i],ylim=c(mintransf,maxtransf),xlab=dimnames(Xini)[[2]][i],ylab="",type="n") if(!(plt=="c")) { if(!typedata)points(Xini[, i],resulpls$Transf[[j]][,i],pch=pchpar,cex=cexpar,col=colorpar+8) else text(Xini[, i],resulpls$Transf[[j]][,i],dimnames(Xini)[[1]],cex=cexpar,col=colorpar+8) } if(resulpls$BsplineX$nbni[i]!=0){ noeudint[[i]]<-BsplineX$v[[i]][[2]][(BsplineX$v[[i]][[2]]!=min(BsplineX$v[[i]][[2]]))&(BsplineX$v[[i]][[2]]!=max(BsplineX$v[[i]][[2]]))] abline(v=noeudint[[i]],lty=2)} } if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("Predictors' influence on ",dimnames(Yini)[[2]][j]," (",axes," dim.)",sep="")) }### }#endofinternull else { cat("\n") cat("Influence of the predictors on the response:",dimnames(resulpls$Yini)[[2]][j]," \n") class<-NULL rangetint1<-NULL if(length(interaction)!=0) { for(i in 1:(rint-1)) for(k in (i+1):rint) rangetint1<-c(rangetint1,rangetint[[j]][i,k]) names(rangetint1)<-namesint1 } else rangetint1<-rangetint[[j]] class<-matrix(0,1,sum(resulpls$Xvariables)+interactnumber) class[1,]<-round(rev(sort(c(resulpls$ranget[[j]],rangetint1))),5) ordreinv<-rev(order(rank(c(resulpls$ranget[[j]][resulpls$Xvariables],rangetint1)),1:(sum(resulpls$Xvariables)+interactnumber))) dimnames(class)<-list("",paste(c(dimnames(resulpls$Xini)[[2]][resulpls$Xvariables],namesint1)[ordreinv]," ")) cat("\n") cat("Range of the transformed predictors in descending order:\n") cat("\n") print(class) cat("A look at coordinate functions? (y/n)") plt1 <- scan(quiet=T,"", character(), 1) if( (length(plt1)!=0)&&((plt1=="y")|(plt1=="Y"))) plotflag<-T else plotflag<-F #cat("\n") if(sum(resulpls$Xvariables)+interactnumber<=30){ barplot(class[1,],xlab="range of the transf. predictors",names=dimnames(class)[[2]],ylab="", density=20,space=1.4,horiz=T,col=1:pX,cex.names=cexpar,cex.axis=cexpar) if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("Predictors' Influence on",dimnames(resulpls$Yini)[[2]][j],",",format(axes),"Dim.")) } if(plotflag){ cat("Coordinate function plots of the decreasing influential effects\n") ordrepredict<-ordreinv cat("How many predictors?,(<=",sum(resulpls$Xvariables)+interactnumber,")") nb<- scan(quiet=T,"", numeric(), 1) cat("How many plots on a row ?,(<=",nb,")") pc<- scan(quiet=T,"", numeric(), 1) cat("How many row(s) ?") pl<-scan(quiet=T,"", numeric(), 1) if(titlepar==F)par(mfrow=c(pl,pc),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(pl,pc),pty=ptypar) mintransf<-1e+18 maxtransf<-(-1e+18) grille<-matrix(0,nbpoints,nbpoints) for(i in ordrepredict[1:nb]) { if(i<=sum(resulpls$Xvariables)) { A[[((1:pX)[resulpls$Xvariables])[i]]]<-resulpls$AA[[j]][[((1:pX)[resulpls$Xvariables])[i]]] yy[[((1:pX)[resulpls$Xvariables])[i]]]<-spl[[((1:pX)[resulpls$Xvariables])[i]]]%*%A[[((1:pX)[resulpls$Xvariables])[i]]] mintransf<-min(mintransf,min(yy[[((1:pX)[resulpls$Xvariables])[i]]])) maxtransf<-max(maxtransf,max(yy[[((1:pX)[resulpls$Xvariables])[i]]])) }#endif i else {ii<-i-sum(resulpls$Xvariables) grille<-surfaceinter(splnc[[listinteraction[[ii]][1]]],splnc[[listinteraction[[ii]][2]]],resulpls$Bcodintmean[[ii]],resulpls$AAint[[j]][[ii]]) mintransf<-min(mintransf,min(grille)) maxtransf<-max(maxtransf,max(grille)) #browser() } }#endfor for(i in ordrepredict[1:nb]) { if(i<=sum(resulpls$Xvariables)) { plot(xx[[((1:pX)[resulpls$Xvariables])[i]]],yy[[((1:pX)[resulpls$Xvariables])[i]]],ylim=c(mintransf,maxtransf),xlab=paste(dimnames(Xini)[[2]][((1:pX)[resulpls$Xvariables])[i]],sep=""),ylab="",type="n",cex=cexpar) points(xx[[((1:pX)[resulpls$Xvariables])[i]]],yy[[((1:pX)[resulpls$Xvariables])[i]]],type="l",col=colorpar+15) text(Xini[, ((1:pX)[resulpls$Xvariables])[i]],resulpls$Transf[[j]][,((1:pX)[resulpls$Xvariables])[i]],dimnames(Xini)[[1]],cex=cexpar,col=colorpar+6) if(resulpls$BsplineX$nbni[((1:pX)[resulpls$Xvariables])[i]]!=0){ noeudint[[((1:pX)[resulpls$Xvariables])[i]]]<-BsplineX$v[[((1:pX)[resulpls$Xvariables])[i]]][[2]][(BsplineX$v[[((1:pX)[resulpls$Xvariables])[i]]][[2]]!=min(BsplineX$v[[((1:pX)[resulpls$Xvariables])[i]]][[2]]))&(BsplineX$v[[((1:pX)[resulpls$Xvariables])[i]]][[2]]!=max(BsplineX$v[[((1:pX)[resulpls$Xvariables])[i]]][[2]]))] abline(v=noeudint[[((1:pX)[resulpls$Xvariables])[i]]],lty=2)} }#endif i else {ii<-i-sum(resulpls$Xvariables) plot(1:10,type="n",xlab=paste(namesint1[ii],"interaction"),ylab="",axes=F,cex=cexpar) par(new=T) grille<-surfaceinter(splnc[[listinteraction[[ii]][1]]], splnc[[listinteraction[[ii]][2]]],resulpls$Bcodintmean[[ii]],resulpls$AAint[[j]][[ii]]) zout<-persp(x=xx[[listinteraction[[ii]][1]]],y=xx[[listinteraction[[ii]][2]]],z=grille, xlab=dimnames(Xini)[[2]][listinteraction[[ii]][1]],ylab=dimnames(Xini)[[2]][listinteraction[[ii]][2]], zlab="",zlim=c(mintransf,maxtransf),theta=thetapar,phi=phipar,r=rpar,cex=cexpar-0.1,col=colpar+4, ticktype="detailed") par(new=F) } }#endfor if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("Main Effects and Interactions on ",dimnames(Yini)[[2]][j]," (",axes," Dim.)",sep="")) #browser() } }#endofinter if(ncol(Yini)>1){ cat("Another reponse ? (y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break } else break }#fin du repeat } } ################################################ plss.plot<-function(resulpls,Xtest,ptypar="s",typedata=T,titlepar=T,pchpar=1,cexpar=0.7, nbpoints=50,colpar=1,askpar=T,qual,names.qual) # # DESCRIPTION # give usual plots for interpreting the results of the PLSS method. # # ARGUMENTS # # resulpls S-PLUS object returned from the plss function. # Xtest test sample matrix, missing data are not allowed. The number of columns should # be the same as the number of columns of the predictor matrix for the plss # function. If Xtest is not missing, the Y-predicted matrix is Ypred. #VALUE # # no object except when Xtest is not missing. When Xtest is present, a list # containing the folllowing component: # Ypred Y predicted matrix. The number of columns is the same of the number of # columns of the response matrix for the plss function. The number of rows is # the same as in Xtest. { colorpar<-colpar Xini<-resulpls$Xini Yini<-resulpls$Yini pX<-ncol(Xini) pY<-ncol(Yini) n<-nrow(Xini) A<-list(NULL) noeudint<-list(NULL) axes<-resulpls$axes corX<-resulpls$corX corY<-resulpls$corY covXY<-resulpls$covXY compX<-resulpls$compX compY<-resulpls$compY cX<-resulpls$cX cY<-resulpls$cY Yhat<-resulpls$Yhat BsplineX<-resulpls$BsplineX itX <- BsplineX$v if(!missing(Xtest)){ Xinitest<-sweep(Xtest, 2,resulpls$meanX) if( sum(Dvar(resulpls$Xini,cor=F)$var)==ncol(Xtest)) Xinitest<- sweep(Xinitest,2,sqrt(resulpls$varX),FUN="/") dimnames(Xinitest)<-dimnames(Xtest) BsplineXtest <- Bsplinen(rbind(Xinitest,apply(resulpls$Xini,2,min),apply(resulpls$Xini,2,max)), ordre=resulpls$BsplineX$ordre,nbni=resulpls$BsplineX$nbni,center=F,D=D,tt=resulpls$BsplineX$intknots) itXtest <- BsplineXtest$v Bcodtest<-NULL for(i in 1:ncol(Xtest))Bcodtest<-cbind(Bcodtest,sweep(itXtest[[i]][[1]][1:nrow(Xtest),,drop=F],2,resulpls$BsplineX$meansc[[i]])) } dimension<-resulpls$dimension interaction<-resulpls$interaction if(length(interaction)!=0) { dimensionint<-resulpls$dimensionint rint<-length(interaction) rangetint<-resulpls$rangetint namesint1<-resulpls$namesint1 corYtrans<-resulpls$corYtrans } #browser() yy<-list(NULL) nom<-deparse(substitute(resulpls)) par(ask=askpar) varX<-resulpls$varX varX<-as.matrix(varX) varX1<-round(cbind(resulpls$meanX,sqrt(varX)),2) dimnames(varX1)<-list(dimnames(resulpls$Xini)[[2]],c(" mean","st.dv.")) varY<-resulpls$varY varY<-as.matrix(varY) varY1<-round(cbind(resulpls$meanY,sqrt(varY)),2) dimnames(varY1)<-list(dimnames(resulpls$Yini)[[2]],c(" mean","st.dv.")) cat(" General information on the data? (y/n)") general<- scan(quiet=T,"", character(), 1) if(length(general)==0)general<-"n" cat("\n") cat("__________________________________________________________________\n") cat("\n") if((general=="y")|(general=="Y")) { cat("\n") cat("__________________________________________________________________\n") cat("\n") cat(paste(" File of the PLSS results: ",nom,"\n")) cat("__________________________________________________________________\n") cat("\n") cat(paste(" 'X' data file:",resulpls$nomfichX,"\n")) cat(paste(format(n)," objects, ",format(pX)," variables","\n")) if(resulpls$corX)cat("The data are scaled\n") else cat("The data are centered\n") cat("------------------------------------------------------------------\n") cat(paste("'Y' data file:",resulpls$nomfichY,"\n")) cat(paste(format(n)," objects, ",format(pY)," variables","\n")) if(resulpls$corY)cat("The data are scaled\n") else cat("The data are centered\n") cat("------------------------------------------------------------------\n") cat("mean and stand. dev. of the X variables: \n") cat("\n") print(t(varX1)) cat("------------------------------------------------------------------\n") cat("mean and stand. dev. of the Y variables : \n") cat("\n") print(t(varY1)) cat("------------------------------------------------------------------\n") cat("Nature of the B-splines :\n") cat("\n") for(i in 1:pX){ if(resulpls$knots[[i]]!=0){ if(length(resulpls$listknots[[i]])==0) { if(resulpls$BsplineX$noeudequi[i])noeudqual<-",equidistributed\n" else noeudqual<-",quantiles\n" } else{ noeudqual<-", imposed\n" nombrenoeuds<-length(resulpls$listknots[[i]]) } } else{ nombrenoeuds<-0 noeudqual<-", Polynomial\n" } cat(dimnames(resulpls$Xini)[[2]][i],":"," degree ",resulpls$BsplineX$ordre[i]-1,", knots ",resulpls$knots[i],noeudqual) } cat("------------------------------------------------------------------\n") cat(paste("number of components : ",resulpls$axes,"\n")) cat("------------------------------------------------------------------\n") cat(paste("Optimal covariances of the (t,u): ")) cat(round(resulpls$covXY,3)) cat("\n") cat("______________________________________________________________________\n") } xx<-list(NULL) spl<-list(NULL) tt<-rep(list(NULL),pX) ttint<-rep(list(NULL),pX) for(i in 1:pX)if(resulpls$knots[i]!=0)tt[[i]]<-BsplineX$v[[i]][[2]] for(i in 1:pX)if(length(tt[[i]])!=0)ttint[[i]]<-tt[[i]][(BsplineX$ordre[i]+1):(BsplineX$ordre[i]+BsplineX$nbni[i])] for(i in 1:pX){ #cat(i," ") minXini<-min(Xini[, i]) maxXini<-max(Xini[, i]) xx[[i]]<-seq(minXini,maxXini,length=nbpoints) spl[[i]]<-sweep(Bsplinen(xx[[i]],ordre=BsplineX$ordre[i],nbni=BsplineX$nbni[i],D=D,tt=list(ttint[[i]]))$v[[1]][[1]],2,BsplineX$meansc[[i]]) varX<-Dvar(resulpls$compX,cor=T,D=resulpls$D) varY<-Dvar(resulpls$compY,cor=T,D=resulpls$D) varx<-Dvar(resulpls$compX,D=resulpls$D)$V vary<-Dvar(resulpls$compY,D=resulpls$D)$V CompXN<-varX$U CompYN<-varY$U } #cat("\n") inertreconst<-round(sum(diag(Dvar(resulpls$Yhat,D=resulpls$D)$V)),4) varYini<-Dvar(resulpls$Yini,D=resulpls$D)$V suminer<-round(sum(diag(varYini)),4) cat(paste("Y variance =",suminer,", reconstituted variance =",inertreconst,"\n")) valtab<-matrix(0,resulpls$axes,3) dimnames(valtab)<-list(format(1:resulpls$axes),c(" Y var."," % "," cumul. %")) valtab[,1]<-round(resulpls$VY,digits=4) valtab[,2]<-round(resulpls$VY/suminer*100,digits=2) for(i in 1:resulpls$axes)valtab[i,3]<-sum(valtab[1:i,2]) print(valtab) cat("______________________________________________________________________\n") cat("\n") cat("R2 of the responses on the t subspace dimensions\n") R2tab<-matrix(0,resulpls$axes,pY) dimnames(R2tab)<-list(paste(format(1:resulpls$axes)," "),dimnames(resulpls$Yini)[[2]]) for(k in 1:resulpls$axes) for(j in 1:pY) R2tab[k,j]<-round(as.numeric(Dcp(resulpls$YH[[k]][,j],D=resulpls$D))/varYini[j,j],3) if(resulpls$axes > 1)for(j in 2:resulpls$axes)R2tab[j,]<-R2tab[j,]+R2tab[j-1,] print(R2tab) if(sum(apply(resulpls$Yinitial,1,sum))==nrow(resulpls$Xini)) { cat("______________________________________________________________________\n") indicator=rep(0,nrow(resulpls$Xini)) for(i in 1:nrow(resulpls$Xini)) for(j in 1:ncol(resulpls$Yinitial)) if(resulpls$Yinitial[i,j]==1)indicator[i]=j affectresul=affecte(resulpls$compX,indicator) cat("\n") cat("table of real and predicted training groups :\n") print(affectresul$tableau) dimnames(resulpls$Xini)[[1]]=indicator cat("Percentage of missclassified individuals :",round(100*(nrow(resulpls$Xini)-sum(diag(affectresul$tableau)))/nrow(resulpls$Xini),2),"%\n") } cat("______________________________________________________________________\n") cat("additive influence of the predictors on a component? (y/n)") plt <- scan(quiet=T,"", character(), 1) cat("\n") if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) {#1 repeat { cat("The number of the t component ?,(<=",axes,")") j<- scan(quiet=T,"", numeric(), 1) #cat("\n") if(titlepar==F)par(mfrow=c(1,1),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,1),pty=ptypar) tttj<-list(NULL) # liste des transformes des predicteurs expliquant additivement tj rangetttj<-rep(0,pX) dd<-1 for(i in 1:pX) { tttj[[i]]<-itX[[i]][[1]]%*%resulpls$alph[[j]][dd:(dd+dimension[i]-1),1] dd<-dd+dimension[i] rangetttj[i]<-max(tttj[[i]])-min(tttj[[i]]) } orderinv<-rev(order(rangetttj)) cat("\n") classwTX<-matrix(0,1,pX) classwTX[1,]<-round(rev(sort(rangetttj)),4) dimnames(classwTX)<-list("",paste(dimnames(Xini)[[2]][orderinv],"(",format(orderinv),")",sep="")) cat("\n") cat("Range of the transformed predictors in descending order:\n") cat("\n") print(classwTX) cat("\n") if(pX>1){ if(pX<=30){ barplot(classwTX[1,],xlab="range of the transf. predictors",horiz=T,names=dimnames(Xini)[[2]][orderinv], density=20,space=1.4,col=1:pX,cex.names=cexpar,cex.axis=cexpar) #legend(locator(1),paste(format(orderinv)," ",dimnames(resulpls$Xini)[[2]][orderinv]),col=1:pX,ncol=2,bty="n",cex=cexpar) if(titlepar==T)mtext(side=3,line=0,cex=2,outer=TRUE,paste("Contributions of the predictors to t",j,sep="")) }} if(pX>1){ cat("Coordinate function plots of the ordered or nonordered influential predictors? (y/n)") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) ordrepredict<-orderinv else ordrepredict<-1:pX #{### cat("How many predictors?,(<=",pX,")") nb<- scan(quiet=T,"", numeric(), 1) cat("How many plots on a row ?,(<=",nb,")") pc<- scan(quiet=T,"", numeric(), 1) cat("How many row(s) ?") pl<-scan(quiet=T,"", numeric(), 1) } else { pl<-1 pc<-1 nb<-1 ordrepredict<-1} if(titlepar==F)par(mfrow=c(pl,pc),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(pl,pc),pty=ptypar) cat("Do you need curves, data or both? (c,d,b)") repeat{ plt<-scan(quiet=T,"",character(),1) if(length(plt)==0){plt<-"d" break} if((plt=="c")|(plt=="d")|(plt=="b"))break } minTX<-1e+18 maxTX<-(-1e+18) for(i in ordrepredict[1:nb]){ if(!(plt=="d")){ if(i>1) { dd<-0 for(ii in 1:(i-1)) dd<-dd+dimension[ii] dd<-dd+1 } else {dd<-1} A[[i]]<-resulpls$alph[[j]][dd:(dd+dimension[i]-1),1,drop=F] yy[[i]]<-spl[[i]]%*%A[[i]] minTX<-min(minTX,min(yy[[i]])) maxTX<-max(maxTX,max(yy[[i]])) } else {minTX<-min(minTX,min(tttj[[i]])) maxTX<-max(maxTX,max(tttj[[i]])) } } for(i in ordrepredict[1:nb]) { if(!(plt=="d")) { plot(xx[[i]],yy[[i]],ylim=c(minTX,maxTX),xlab=dimnames(Xini)[[2]][i],ylab="", cex=cexpar,type="n") points(xx[[i]],yy[[i]],type="l",col=colorpar+1) } else plot(Xini[, i],tttj[[i]],ylim=c(minTX,maxTX), xlab=dimnames(Xini)[[2]][i],ylab="",type="n",cex=cexpar) if(!(plt=="c")) { if(!typedata)points(Xini[, i],tttj[[i]],pch=pchpar,cex=cexpar,col=colorpar+3) else text(Xini[, i],tttj[[i]],dimnames(Xini)[[1]],cex=cexpar,col=colorpar+3) } if(resulpls$BsplineX$nbni[i]!=0){ noeudint[[i]]<-BsplineX$v[[i]][[2]][(BsplineX$v[[i]][[2]]!=min(BsplineX$v[[i]][[2]]))&(BsplineX$v[[i]][[2]]!=max(BsplineX$v[[i]][[2]]))] abline(v=noeudint[[i]],lty=2)} } if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("Predictors' influence on t",j,sep="")) #}### cat("Another t component ? (y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break }#fin du repeat }#1 cat("\n") cat("__________________________________________________________________\n") cat("\n") if(axes>1){ cat("scatterplot of observations and correlations' circle? (y/n)") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="Y")|(plt=="y"))) { ah<-as.numeric(1) av<-as.numeric(2) repeat { corYtah<-Dvar(cbind(resulpls$Yini,resulpls$compX[,ah]),cor=T,D=resulpls$D)$V[,pY+1] corYtav<-Dvar(cbind(resulpls$Yini,resulpls$compX[,av]),cor=T,D=resulpls$D)$V[,pY+1] par(mfrow=c(1,1),pty=ptypar,mar=c(5,5,4,2)) if(!missing(Xtest)) { auxtest<-matrix(0,ncol(Bcodtest),length(resulpls$alph)) for(i in 1:length(resulpls$alph))auxtest[,i]<-resulpls$alph[[i]] compos<-rbind(resulpls$compX,Bcodtest%*%auxtest) } else compos<-resulpls$compX plot(compos[,ah],compos[,av],type="n",xlab=paste("t",format(ah),sep=""),ylab=paste("t",format(av),sep=""),cex=cexpar) abline(h=0) abline(v=0) if(length(dimnames(resulpls$Xini)[[1]])==0)text(resulpls$compX[,ah],resulpls$compX[,av],cex=cexpar,col=colorpar+3) else text(resulpls$compX[,ah],resulpls$compX[,av],cex=cexpar,dimnames(resulpls$Xini)[[1]],col=colorpar+3) if(sum(apply(resulpls$Yinitial,1,sum))==nrow(resulpls$Xini)) { cat("mark the badly affected training samples y/n") repo= scan(quiet=T,"", character(), 1) if( (length(repo)!=0)&&((repo=="Y")|(repo=="y"))) points(resulpls$compX[aversaY3[,1]!=affectresul$groupe,c(ah,av)],pch=pchpar,cex=cexpar+1.3) } if(!missing(Xtest)) text(compos[-(1:nrow(resulpls$Xini)),ah,drop=F],compos[-(1:nrow(resulpls$Xini)),av,drop=F],cex=cexpar,dimnames(Xtest)[[1]],col=colorpar+6) if(!missing(qual)) { variab<-qual if(missing(names.qual)){ repeat{ cat("Enter the levels' names\n") names.qual<-scan(quiet=T,what=character()) if(length(names.qual)==(max(qual)-min(qual)+1))break else cat("not the right nb of levels' names,should be",max(qual)-min(qual)+1,"!\n") } } cat("click to locate the top left corner of the legend\n") for(i in min(variab):max(variab)) text(resulpls$compX[variab==i,ah],resulpls$compX[variab==i,av],dimnames(resulpls$Xini)[[1]][variab==i],col=i+1,cex=cexpar) legend(locator(1),names.qual,x.intersp=cexpar,y.intersp=cexpar,bty="o", text.col=min(variab):max(variab)+1,cex=cexpar,fill=(min(qual):max(qual))+1) } plot(cos(seq(0,2*pi,length=100)),sin(seq(0,2*pi,length=100)),type="l",xlab=paste("t",ah,sep=""),ylab=paste("t",av,sep=""),cex=cexpar) abline(h=0) abline(v=0) text(corYtah[1:pY],corYtav[1:pY],dimnames(resulpls$Yini)[[2]],cex=cexpar,col=colorpar+1) arrows(rep(0,pY),rep(0,pY),corYtah[1:pY]*0.9,corYtav[1:pY]*0.9,col=colorpar+1,angle=15,length=0.15) cat("\n") cat("Different components (y/n) ?") plt5 <- scan(quiet=T,"", character(), 1) if(length(plt5)==0)plt5<-"n" if(plt5!="y")break cat("first axis (horizontal) ?") ah <- scan(quiet=T,"", numeric(),1) cat("second axis (vertical) ?") av <- scan(quiet=T,"", numeric(),1) } } cat("\n") cat("______________________________________________________________________\n") cat("\n") }#fin scatterplot cat("additive influence of the predictors on a response? (y/n)") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) { noeudint<-list(NULL) repeat {# if(pY==1)j<-1 else{ cat("The number of the reponse variable?,(<=",pY,")") j<- scan(quiet=T,"", numeric(), 1) } if(titlepar==F)par(mfrow=c(1,1),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,1),pty=ptypar) if(length(interaction)==0) { if(pX>1){ if(pX<31) { xxf<-resulpls$Transf[[j]][,1] catf<-rep(1,n) if(pX>1)for(i in 2:pX){xxf<-c(xxf,resulpls$Transf[[j]][,i]) catf<-c(catf,rep(i,n)) } tecno24<-split(xxf,catf) if(pX>30) boxplot(tecno24,sub="predictors",ylab="transf. data",cex=cexpar) else boxplot(tecno24,sub="",ylab="transf. data",cex=cexpar,names=dimnames(resulpls$Xini)[[2]]) if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,dimnames(resulpls$Yini)[[2]][j]) } cat("\n") cat("Influence of the predictors on the response:",dimnames(resulpls$Yini)[[2]][j]," \n") class<-NULL class<-matrix(0,1,pX) class[1,]<-round(rev(sort(resulpls$ranget[[j]])),5) ordreinv<-rev(order(rank((resulpls$ranget[[j]])),1:pX)) dimnames(class)<-list("",paste(dimnames(resulpls$Xini)[[2]][ordreinv],"(",format(ordreinv),")",sep="")) cat("\n") cat("Range of the transformed predictors in descending order:\n") cat("\n") print(class) cat("A look at coordinate functions? (y/n)") plt1 <- scan(quiet=T,"", character(), 1) if( (length(plt1)!=0)&&((plt1=="y")|(plt1=="Y"))) plotflag<-T else plotflag<-F #cat("\n") if(pX>1){ if(pX<=30){ barplot(class[1,],xlab="range of the transf. predictors", names=dimnames(resulpls$Xini)[[2]][ordreinv],ylab="", density=20,space=1.4,horiz=T,col=1:pX,cex.names=cexpar,cex.axis=cexpar) } if((titlepar==T)&(plotflag)) mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("influence of the predictors on",dimnames(resulpls$Yini)[[2]][j])) } if(plotflag){ cat("Ordered predictors? (y/n)") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) ordrepredict<-ordreinv else ordrepredict<-1:pX cat("How many predictors?,(<=",pX,")") nb<- scan(quiet=T,"", numeric(), 1) cat("How many plots on a row ?,(<=",nb,")") pc<- scan(quiet=T,"", numeric(), 1) cat("How many row(s) ?") pl<-scan(quiet=T,"", numeric(), 1) }#endplotflag } else {pl<-1 pc<-1 nb<-1 ordrepredict<-1} if(plotflag){### if(titlepar==F)par(mfrow=c(pl,pc),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(pl,pc),pty=ptypar) cat("Do you need curves, data or both? (c,d,b)") repeat{ plt<-scan(quiet=T,"",character(),1) if(length(plt)==0){plt<-"d" break} if((plt=="c")|(plt=="d")|(plt=="b"))break } mintransf<-1e+18 maxtransf<-(-1e+18) for(i in ordrepredict[1:nb]) { if(!(plt=="d")){ A[[i]]<-resulpls$AA[[j]][[i]] yy[[i]]<-spl[[i]]%*%A[[i]] mintransf<-min(mintransf,min(yy[[i]])) maxtransf<-max(maxtransf,max(yy[[i]])) } else{mintransf<-min(mintransf,min(resulpls$Transf[[j]][,i])) maxtransf<-max(maxtransf,max(resulpls$Transf[[j]][,i])) } } for(i in ordrepredict[1:nb]) { if(pX==1){ if(pX!=1) plot(resulpls$Xini[,i],resulpls$Yini[,j],xlab=paste(dimnames(Xini)[[2]][i],sep=""),ylab="",type="n",cex=cexpar) text(resulpls$Xini[,i],resulpls$Yini[,j],dimnames(Xini)[[1]],cex=cexpar,col=colpar+5) } if(!(plt=="d")){ if(pX!=1) plot(xx[[i]],yy[[i]],ylim=c(mintransf,maxtransf),xlab=paste(dimnames(Xini)[[2]][i],sep=""),ylab="",type="n",cex=cexpar) points(xx[[i]],yy[[i]],type="l",col=colorpar+1) } else plot(Xini[,i],resulpls$Transf[[j]][,i],ylim=c(mintransf,maxtransf),xlab=dimnames(Xini)[[2]][i],ylab="",type="n") if(!(plt=="c")) { if(!typedata)points(Xini[, i],resulpls$Transf[[j]][,i],pch=pchpar,cex=cexpar,col=colorpar+3) else text(Xini[, i],resulpls$Transf[[j]][,i],dimnames(Xini)[[1]],cex=cexpar,col=colorpar+3) } if(resulpls$BsplineX$nbni[i]!=0){ noeudint[[i]]<-BsplineX$v[[i]][[2]][(BsplineX$v[[i]][[2]]!=min(BsplineX$v[[i]][[2]]))&(BsplineX$v[[i]][[2]]!=max(BsplineX$v[[i]][[2]]))] abline(v=noeudint[[i]],lty=2)} } if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("Predictors' influence on ",dimnames(Yini)[[2]][j]," (",axes," dim.)",sep="")) #dev.off() }### }#endofinternull else { cat("\n") cat("Influence of the predictors on the response:",dimnames(resulpls$Yini)[[2]][j]," \n") cat("Correlation coefficients between",dimnames(resulpls$Yini)[[2]][j]," and the transformed predictors : \n") auxmatrix<-corYtrans[j,][rev(order(rank(abs(corYtrans[j,])),1:(pX+rint*(rint-1)/2)))] names(auxmatrix)<-dimnames(corYtrans)[[2]][rev(order(rank(corYtrans[j,,drop=F]),1:(pX+rint*(rint-1)/2)))] print(auxmatrix) class<-NULL rangetint1<-NULL for(i in 1:(rint-1)) for(k in (i+1):rint) rangetint1<-c(rangetint1,rangetint[[j]][i,k]) names(rangetint1)<-namesint1 class<-matrix(0,1,sum(Xvariables)+rint*(rint-1)/2) class[1,]<-round(rev(sort(c(resulpls$ranget[[j]],rangetint1))),5) ordreinv<-rev(order(rank(c(resulpls$ranget[[j]],rangetint1)),1:(pX+rint*(rint-1)/2))) dimnames(class)<-list("",paste(c(dimnames(resulpls$Xini)[[2]],namesint1)[],"(",format(),")",sep="")) cat("\n") cat("Range of the transformed predictors in descending order:\n") cat("\n") print(class) cat("\n") if(pX>1){ if(pX+rint*(rint-1)/2<=30){ barplot(class[1,],xlab="range of the transf. predictors",names=dimnames(class)[[2]],ylab="", density=20,space=1.4,horiz=T,cex=cexpar,col=1:pX,cex.names=cexpar,cex.axis=cexpar) } if(titlepar==T)mtext(side=3,line=0,cex=cexpar+0.7,outer=TRUE,paste("influence of the predictors on",dimnames(resulpls$Yini)[[2]][j])) } }#endofinter if(ncol(Yini)>1){ cat("Another reponse ? (y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break } else break }#fin du repeat } #cat("\n") cat("__________________________________________________________________\n") cat("plot of Yhat against Y (y/n)?") plt3 <- scan(quiet=T,,what="", 1) if((length(plt3)!=0)&&(plt3=="y")){ par(mfrow=c(1,1),pty=ptypar) repeat{ cat("How many dimensions ?,(<=",axes,")") pa<- scan(quiet=T,"", numeric(), 1) YHAT<-matrix(0,n,pY) for(k in 1:pa){ YHAT<-YHAT+resulpls$YH[[k]] } if(pY>1){ cat("How many plots per row (<=",pY,")?\n") colplots<-scan(quiet=T,"",numeric(),1) cat("How many rows?\n") rowplots<-scan(quiet=T,"",numeric(),1) par(mfrow=c(rowplots,colplots)) } else par(mfrow=c(1,1)) for(i in 1:pY) { yy<-YHAT[,i]*sqrt(resulpls$varY[i])+resulpls$meanY[i] if(sum(resulpls$Yinitial[,i]==0)==0) { titrepl<-"nean relative err (%) = " relativeerreur<-Dvar(abs(resulpls$Yinitial[,i]-yy)/abs(resulpls$Yinitial[,i])*100,D=D)$mean } else { relativeerreur<-sqrt(Dvar(resulpls$Yinitial[,i]-yy,D=resulpls$D)$var) titrepl<-"stdv err = " } plot(resulpls$Yinitial[,i],yy,xlab=dimnames(Yini)[[2]][i], ylab=paste("modeled ",dimnames(Yini)[[2]][i],",",pa," Dim.",sep=""), type="n",xlim=range(c(resulpls$Yinitial[,i],yy)),ylim=range(c(resulpls$Yinitial[,i],yy)), main=paste(titrepl,round(relativeerreur,2))) if(!typedata)points(resulpls$Yinitial[,i],yy,pch=pchpar,cex=cexpar) else text(resulpls$Yinitial[,i],yy,dimnames(Yini)[[1]],col=colorpar+3) abline(a=0,b=1,col=colorpar+1) } cat("Another axis number? (y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break }#repeat } cat("\n") cat("__________________________________________________________________\n") cat("\n") cat("Plots of the reponse residuals according to the number of components? (y/n)") plt <- scan(quiet=T,"", character(), 1) if( (length(plt)!=0)&&((plt=="y")|(plt=="Y"))) { repeat{ cat("How many axes ?,(<=",axes,")") pa<- scan(quiet=T,"", numeric(), 1) if(pY>1) { if(titlepar==F)par(mfrow=c(pa,pY),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(pa,pY),pty=ptypar) } else par(mfrow=c(pY,pa),pty=ptypar) YHAT<-matrix(0,n,pY) for(k in 1:pa){ YHAT<-YHAT+resulpls$YH[[k]] for(i in 1:pY) { if(k==1) variat<-range(Yini-YHAT) variat<-range(variat,range(Yini-YHAT)) plot(YHAT[,i],Yini[,i]-YHAT[,i],ylim=variat,xlab=paste("est. ",dimnames(Yini)[[2]][i],", ",k," dim",sep="") ,ylab="",type="n",cex=cexpar) if(!typedata)points(YHAT[,i],Yini[,i]-YHAT[,i],pch=pchpar,cex=cexpar) else text(YHAT[,i],Yini[,i]-YHAT[,i],dimnames(Yini)[[1]],cex=cexpar,col=colorpar+3) } } if(titlepar==T)mtext(side=3,line=-1,cex=cexpar+0.7,outer=TRUE,"Residuals according to PLSS dimensions") cat("Another axis number? (y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break } } cat("\n") cat("__________________________________________________________________\n") if(pY==2){ cat(paste("Plot of the reconstructed responses (", dimnames(Yini)[[2]][1],",",dimnames(Yini)[[2]][2],") (y/n)?",sep="")) plt3 <- scan(quiet=T,,what="", 1) if((length(plt3)!=0)&&(plt3=="y")){ if(titlepar==F)par(mfrow=c(1,2),pty=ptypar) else par(oma=c(0,0,4,0),mfrow=c(1,2),pty=ptypar) repeat{ cat("How many components ?,(<=",axes,")") pa<- scan(quiet=T,"", numeric(), 1) YYY<-matrix(0,n,2) for(i in 1:pa)YYY<-YYY+resulpls$YH[[i]] range1<-range(c(YYY[, 1],Yini[, 1])) range2<-range(c(YYY[, 2],Yini[, 2])) plot(YYY[, 1],YYY[,2],xlim=range1,ylim=range2,xlab=paste("fitted",dimnames(Yini)[[2]][1]),ylab=paste("fitted",dimnames(Yini)[[2]][2]),type="n",pch=pchpar,main="Reconstituted shape") if(!typedata)points(YYY[, 1],YYY[, 2],pch=pchpar,cex=cexpar) else text(YYY[, 1],YYY[, 2],dimnames(Yini)[[1]],col=colorpar+3,cex=cexpar) plot(Yini[, 1],Yini[, 2],xlim=range1,ylim=range2,xlab=dimnames(Yini)[[2]][1],ylab=dimnames(Yini)[[2]][2],type="n",pch=pchpar,main="Original shape") if(!typedata)points(Yini[, 1],Yini[, 2],pch=pchpar,cex=cexpar) else text(Yini[, 1],Yini[, 2],dimnames(Yini)[[1]],col=colorpar+3) if(titlepar==T)mtext(side=3,line=0,cex=2,outer=TRUE,paste("PLSS (",pa," dim.)",sep="")) cat("More components? (y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break } } } } ################################################ plsscv<-function(X,Y,standX=T,standY=T,interaction=NULL,D=1,A=2, degree=1,knots=0,equiknots=F,listknots,prop=0.1,GCV=2,impres=T) { # version 9.9.9 programmee par JF Durand # Regression PLS sur codage spline des predicteurs # order<-degree+1 nomfichX<-deparse(substitute(X)) nomfichY<-deparse(substitute(Y)) Xinitial<-as.matrix(X) Yinitial<-as.matrix(Y) centrageX <- Dvar(Xinitial, D = D, cor = F) meanX <- centrageX$mean varX <- centrageX$var centrageY <- Dvar(Yinitial, D = D, cor = F) meanY <- centrageY$mean varY <- centrageY$var n<-nrow(Xinitial) p<-ncol(Xinitial) q<-ncol(Yinitial) if(!missing(listknots)) { if(length(listknots)!=p){cat("incorrect number of knot vectors\n") return()} knots<-vector("numeric",p) for(i in 1:p)knots[i]<-length(listknots[[i]]) } if(is.null(dimnames(Xinitial)))dimnames(Xinitial)<-list(format(1:n),paste("X",1:p,sep="")) if(is.null(dimnames(Yinitial)))dimnames(Yinitial)<-list(format(1:n),paste("Y",1:q,sep="")) if(length(dimnames(Xinitial)[[1]])==0) dimnames(Xinitial)[[1]]<- format(1:n) if(length(dimnames(Yinitial)[[1]])==0) dimnames(Yinitial)[[1]]<- format(1:n) if(length(dimnames(Xinitial)[[2]])==0) dimnames(Xinitial)[[2]]<- paste("X",1:p,sep="") if(length(dimnames(Yinitial)[[2]])==0) {cat("Enter the name of the response(s)\n") prov<-as.vector(format(1:q)) for(i in 1:q) {cat(paste("response ",format(i),"\n")) prov[i]<-scan(quiet=T,,what="", 1) } dimnames(Yinitial)[[2]]<-prov } # calcul de la metrique si D=1 if(length(D)==1) D<-rep(1/n,n) else D<-as.vector(D) # centrage et reduction centX<-Dcentred(Xinitial,D=D) centY<-Dcentred(Yinitial,D=D) if(standX) Xini<-as.matrix(centX$Xcr) else Xini<-as.matrix(centX$Xc) if(standY) Yini<-as.matrix(centY$Xcr) else Yini<-as.matrix(centY$Xc) dimnames(Xini)<-dimnames(Xinitial) dimnames(Yini)<-dimnames(Yinitial) listknotsn<-list(NULL)#list of centered (possibly scaled) interior knots if(missing(listknots)){ listknotsn<-list(NULL) if(p>1) for(i in 1:(p-1))listknotsn<-c(listknotsn,list(NULL)) listknots<-listknotsn } else {if(p>1) for(i in 1:(p-1))listknotsn<-c(listknotsn,list(NULL)) for(i in 1:p){ if(!is.null(listknots[[i]])){ listknotsn[[i]]<-listknots[[i]] #if(centerX)listknotsn[[i]]<-listknots[[i]]-meanX[i] if(standX)listknotsn[[i]]<-(listknotsn[[i]]-meanX[i])/sqrt(varX[i]) else listknotsn[[i]]<-listknots[[i]]-meanX[i] } } } BsplineX <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=T,D=D,tt=listknotsn) itX <- BsplineX$v Bcod<-NULL for(i in 1:p)Bcod<-cbind(Bcod,itX[[i]][[1]]) if(impres)cat("\n") Bcodintcum<-NULL if(length(interaction)!=0) { BsplineXint <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=F,D=D,tt=listknotsn) rint<-length(interaction) Bcodint<-list(NULL) for(i in 1:(rint-1)) { Bcodint[[i]]<-list(NULL) for(j in (i+1):rint) { Bcodint[[i]][[j]]<-Dcenter(interactionij(BsplineXint,interaction[i],interaction[j]),D=D)$X Bcodintcum<-cbind(Bcodintcum,Bcodint[[i]][[j]]) } }} plscvresul<-plscv(cbind(Bcod,Bcodintcum),Yinitial,standX=F,standY=standY,A=A,D=D,prop=prop,GCV=GCV,impres=impres) if(GCV==0) { PRESS<-plscvresul$PRESS PRESStot<-plscvresul$PRESStot PRESSpar<-plscvresul$PRESSpar predict<-plscvresul$predict Yini<-plscvresul$Yini invisible(return(Xinitial,Yinitial,Yini,A,PRESS,PRESStot,PRESSpar,predict,prop,GCV)) } else { GCrit<-plscvresul$GCrit GCritot<-plscvresul$GCritot invisible(return(Xinitial,Yinitial,Yini,A,GCrit,GCritot,GCV)) } } ################################################# Gnorm<-function(G,X) # Generalized norm = sqrt(trace(X'GX)) # Sortie: U=GX et norm la norme de X au sens de G { X<-as.matrix(X) U<-matrix(0,nrow(X),ncol(X)) if(length(G)==1) U<-X/nrow(X) if(length(G)==nrow(X)) for(i in 1:ncol(X)) U[,i]<-X[,i]*G if(length(G)==nrow(X)*nrow(X)) U<-G%*%X n<-traceAtB(U,X) norm<-as.numeric(0) norm<-sqrt(n) return(norm,U) } ################################################## traceAtB<-function(A,B=A) { # A,B matrices, par defaut B=A; # sortie : tt = trace(A %*% t(B)) # A<-as.matrix(A) # B<-as.matrix(B) # u<-as.numeric(0) # for(i in 1:nrow(A)) # for(j in 1:ncol(A)) # u<-u+A[i,j]*B[i,j] # t<-as.numeric(u) tt<-sum(A*B) return(tt) } ################################################## tucker<-function(X,Y,D=1,QX=1,QY=1) # Analyse de Tucker inter-battery # Fournit les combinaisons lineaires X QX x # et Y QY y maximisant la covariance # X et Y matrices ayant le meme nb de lignes # si QX=1 QX est l'identite # si QY=1 QY est l'identite # si D=1 metrique des poids equi-repartis 1/nrow(X) # sorties: # x vecteur des combinaisons de X # y vecteur des combinaisons de Y # mu2 val propre la + grande # Y'DX { X<-as.matrix(X) Y<-as.matrix(Y) if((! is.matrix(QX))&(length(QX)!=1)) QX<-diag(QX) if((! is.matrix(QY))&(length(QY)!=1)) QY<-diag(QY) if(ncol(X)<=ncol(Y)){ bx<-TRUE A<-X B<-Y QA<-QX QB<-QY } else { bx<-FALSE A<-Y B<-X QA<-QY QB<-QX } U<-Dcp(B,A,D=D) # U=B'DA if(!is.matrix(QB)) W<-t(U)%*%U else W<-t(U)%*%QB%*%U if(is.matrix(QA)){L<-chol(QA) W<-t(L)%*%W%*%L } #browser() propre<-eigen(W) mu2<-propre$values[1] if(!is.matrix(propre$vectors))propre$vectors<-as.matrix(propre$vectors) a<-propre$vectors[,1] if(is.matrix(QA)) a<- solve(t(L))%*%a if(!is.matrix(QA)) b<-U%*%a else b<-U%*%QA%*%a mu2<-sqrt(mu2) b<-b/mu2 if(bx) { if(length(QA)==1)compX<-A%*%a else compX<-A%*%QA%*%a if(length(QB)==1)compY<-B%*%b else compY<-B%*%QB%*%b } else { if(length(QA)==1)compY<-A%*%a else compY<-A%*%QA%*%a if(length(QB)==1)compX<-B%*%b else compX<-B%*%QB%*%b } if(bx)sortie<-list(a,b,mu2,compX,compY) else sortie<-list(b,a,mu2,compX,compY) names(sortie[1])<-"x" names(sortie[2])<-"y" names(sortie[3])<-"cov(XY)" names(sortie[4])<-"compX" names(sortie[5])<-"compY" return(sortie) } ############################################### grad<-function(x,y,Y,itX,D=1,QX=1,QY=1) # gradient par rapport a PARX { x<-as.matrix(x) y<-as.matrix(y) z<-list(NULL) for(i in 1:length(x)) z[[i]]<-VQop(itX[[i]][[1]],Y,Q=QY,D=D) #w<-VQop(t(y),t(x),Q=QX,D=rep(1,length(x))) w<-y%*%t(x) if(is.matrix(QX))w<-w%*%QX g<-list(NULL) for(i in 1:length(x)) g[[i]]<-z[[i]]%*%w[,i] #browser() return(g) } ############################################### Projtuc<-function(c,Y,D=1) # D-proj de Y sur c # sortie du residu Y-PcY et de PcY { c<-as.matrix(c) R<-as.numeric(Dcp(c,D=D)) TT<-c%*%Dcp(c,Y,D=D)/R Z<-Y-TT return(Z,TT) } ############################################### Gscal<-function(G,X,Y=X) # Generalized scal = trace(X'GY) # Sortie: U=GY et le prod scal de X et Y au sens de G { X<-as.matrix(X) Y<-as.matrix(Y) U<-matrix(0,nrow(X),ncol(Y)) if(length(G)==1) U<-Y/nrow(Y) if(length(G)==nrow(Y)) for(i in 1:ncol(Y)) U[,i]<-Y[,i]*G if(length(G)==nrow(X)*nrow(Y)) U<-G%*%Y scal<-traceAB(t(X),U) return(scal,U) } ############################################## traceAB<-function(A,B=A) { # A,B matrices, par defaut B=A; # sortie : u = trace(A %*% B) A<-as.matrix(A) B<-as.matrix(B) tt<-as.numeric(0) for(i in 1:nrow(A)) for(j in 1:ncol(A)) tt<-tt+A[i,j]*B[j,i] u<-as.numeric(tt) return(u) } ################################################ Projn<-function(c,Y) # D-proj de Y sur c # sortie du residu Y-PcY et de PcY { R<-invgene(crossprod(c)) Yhat<-c%*%R%*%t(c)%*%Y Yres<-Y-Yhat return(Yres,Yhat) } ################################################ Codisjc<-function(X) { # codage disjonctif complet de la matrice X # # Entree # X matrice (numerique) des modalites des variables qualitatives # Sorties # nbmodal vecteur des nombres de modalites de chaque variable # nbmodaltot nombre total de modalites # U matrice du codage # B matrice de Burt associee a U # X<-as.matrix(X) n<-nrow(X) p<-ncol(X) U<-NULL nbmodal<-NULL nommod<-NULL ylab<-NULL nbmodaltot<-as.numeric(0) for(j in 1:p) { nbmodal[j]<-max(X[,j]) nommod<-paste(dimnames(X)[[2]][j],(1:nbmodal[j]),sep="") nbmodaltot<-nbmodaltot+nbmodal[j] V<-matrix(0,n,nbmodal[j]) for(i in 1:n) V[i,X[i,j]]<-1 U<-cbind(U,V) ylab<-cbind(ylab,nommod) } B<-t(U)%*%U dimnames(U)<-list(dimnames(X)[[1]],ylab) dimnames(B)<-list(ylab,ylab) return(nbmodal,nbmodaltot,U,B) } #################################################### affecte<-function(X,g,Y,imin=1,imax=nrow(Y),D=1) { # entrees: # X matrice dont les lignes sont les coordonnees de points # g vecteur des modalites des groupes # Y matrice des vecteurs lignes des coordonnees des points a affecter; # si Y manque, alors Y=X. # imin et imax indices des individus de Y a affecter. # D vecteur des poids des individus. # objectif: a quel groupe (a quelle modalite de g) affecter les lignes de Y ? # sortie : liste de composantes: # La matrice des centres de gravite des groupes, A. # La metrique de Mahalanobis de X, V. # Le vecteur des numero des groupes d'affectation des individus de Y, # groupe. # Si Y=X, (Y manquant) alors: # Le tableau croisant les groupes reels avec les groupes affectes, tableau. #-------------------------------------------------------------------- if(missing(Y)){ Y<-as.matrix(X) indicmiss=T } # A matrice des coordonnees des centres de gravites # A est max(g) x ncol(X) ng<-max(g) codg<-codisj(g) G<-Mahalanobis(codg,D) if(length(D)==1) A<-G%*%t(codg)%*%X/nrow(X) else { XC<-D*X A<-G%*%t(codg)%*%XC } V<-Mahalanobis(X,D) groupe<-rep(0,nrow(Y)) for(j in imin:imax) { x<-Y[j,] U<-NULL for(i in 1:ng) U<-rbind(U,x) U<-(U-A) UU<-U%*%V aa<-NULL for(i in 1:ng) aa[i]<-sum(UU[i,]*U[i,]) distmin<-min(aa) i<-0 repeat {i<-i+1 if(aa[i]==distmin) break } groupe[j]<-i } tableau<-matrix(0,ng,ng) if(indicmiss) { for(i in 1:nrow(X)) tableau[groupe[i],g[i]]<-tableau[groupe[i],g[i]]+1 dimnames(tableau)<-list(paste("predicted",format(1:ng)),paste("real",format(1:ng))) return(A,V,groupe,tableau) } else return(A,V,groupe) } #################################################### codisj<-function(x) { x<-as.vector(x) nbmodal<-max(x) X<-matrix(0,length(x),nbmodal) for(i in 1:length(x)) X[i,x[i]]<-1 return(X) } ####################################################### surfaceinter<-function(Bspline1,Bspline2,moyenne,beta) { beta<-as.matrix(beta) Z<-matrix(0,nrow(Bspline1),nrow(Bspline2)) B1B2kro<-kronecker(Bspline1,Bspline2) compteur<-0 for(k in 1:nrow(Bspline1)) { Z[k,]<-sweep(B1B2kro[(compteur+1):(compteur+nrow(Bspline2)),],2,moyenne)%*%beta compteur<-compteur+nrow(Bspline2) } return(Z) } ####################################################### MAPLSS<-function(X,Y,standX=T,standY=T,D=1,A=2,degree=1,knots=0,equiknots=F,eps=1e-8,listknots, interaction=1:ncol(X),GCV=2,prop=0.1,colpar=1,typedata=T,titlepar=T,pchpar=1,cexpar=0.7, nbpoints=50,ptypar="s",askpar=T,PRESSprop=0.2,thetapar=-60,phipar=30,rpar=10,impres=T,bgpar="lightblue") { # Bibliography : # # J. F. Durand. "Local Polynomial Additive Regression through PLS and Splines: PLSS", # Chemometrics and Intelligent Laboratory Systems 58, 235-246, 2001. # # J. F. Durand and R. Lombardo. "Interactions terms in nonlinear PLS via additive spline # transformations". «Between Data Science and Applied Data Analysis», Studies in Classification, # Data Analysis, and Knowledge Organization. Eds M.Schader, W. Gaul and M. Vichi, Springer, 22-29, 2003 # oldpar<-par(no.readonly = TRUE) par(ask=F,bg=bgpar,mfrow=c(1,1),bty="n",xaxt="n",yaxt="n") plot(0,0,type="n",bg=par("bg"),xlab="",ylab="",xlim=c(-4,4),ylim=c(-4,4)) text(0,1.5,"Partial Least-Squares",cex=2,col="red") text(0,3.5,"Multivariate Additive",cex=2,col="red") text(0,-0.5,"Splines : MAPLSS",cex=2,col="red") text(0,-2,"J.F. Durand, Montpellier 2 University",cex=1,col="blue") text(0,-3,"www.jf-durand-pls.com",cex=0.9,col="blue") par(oldpar) par(ask=askpar,bg=bgpar,xaxt="s",yaxt="s",mai=rep(0.75,4)) par(bg=bgpar) interflag<-F p<-ncol(X) q<-ncol(Y) n<-nrow(X) ordre<-degree +1 resulini<-NULL if(GCV==0) texto<-paste("PRESS(",prop,", . )",sep="") else texto<-paste("GCV(",GCV,", . )",sep="") X0<-as.matrix(X) Y<-as.matrix(Y) Xvariables<-rep(T,ncol(X)) interaction01<-rep(F,p) interaction01[interaction]<-T if(!missing(listknots)) { if(length(listknots)!=p){cat("incorrect number of knot vectors\n") return()} knots<-vector("numeric",p) for(i in 1:p)knots[i]<-length(listknots[[i]]) } repeat { cat("==========================================================\n") reponse<-menu(c(paste(texto,"for pure main effects models (mandatory)"), "Automatic selection of interactions", "Validation of the dimension and a look at the model", "Pruning main effects and interactions"), title="Multivariate Additive Partial Least-Squares Splines (0 to exit)") cat("==========================================================\n") if(reponse==0)break if((reponse==1)&(!interflag)) { cat("*************************************************\n") cat("1:",texto," for main effects models (mandatory)\n") cat("*************************************************\n") if(length(degree)>1)degree0<-degree[Xvariables] else degree0<-degree if(length(knots)>1)knots0<-knots[Xvariables] else knots0<-knots if(length(equiknots)>1)equiknots0<-equiknots[Xvariables] else equiknots0<-equiknots if(!missing(listknots)) listknots0<-listknots[Xvariables] ordre0<-degree0+1 cat("Number of dimensions to explore?\n") Aexplore<-scan(quiet=T,"",numeric(),1) i<-1 exp0=1 crossvalmem=NULL if(GCV==0)Count=prop else Count=GCV repeat { if(missing(listknots)) { resul<-plsscv(X[,Xvariables],Y,standX=standX,standY=standY,D=D,A=Aexplore,degree=degree0,knots=knots0 ,equiknots=equiknots0,interaction=NULL,GCV=GCV,prop=prop) } else { resul<-plsscv(X[,Xvariables],Y,standX=standX,standY=standY,D=D,A=Aexplore,degree=degree0,knots=knots0 ,equiknots=equiknots0,listknots=listknots0,interaction=NULL,GCV=GCV,prop=prop) } crossval<-plscv.plot(resul,askpar=askpar,bgpar=bgpar) crossvalmem[[i]]=crossval if(GCV!=0) cat("Another tuning-parameter alpha,(y/n)") else cat("Another proportion of left-predicted observations,(y/n)") repo<-scan(quiet=T,"",character(),1) if(length(repo)==0)repo<-"n" if(repo!="y")break if(GCV!=0)cat("Enter alpha :") else cat("Enter prop (< 0.5):") titi<-scan(quiet=T,"",numeric(),1) if(GCV!=0) GCV<-titi else prop<-titi i<-i+1 Count=c(Count,titi) }#endrepeat campaign<-matrix(0,i,Aexplore+2) if(GCV==0) { dimnames(campaign)<-list(format(1:i),c("prop","Dim",format(1:Aexplore))) ylabel="PRESS" } else { dimnames(campaign)<-list(format(1:i),c("alpha","Dim",format(1:Aexplore))) ylabel="GCV" } for(j in 1:i) { campaign[j,1]=Count[j] campaign[j,2]=crossvalmem[[j]]$A campaign[j,3:(Aexplore+2)]=crossvalmem[[j]][[1]] } matrice<-campaign[,3:(Aexplore + 2),drop=F] campaignmean<-apply(matrice,2,"mean") campaignstdv<-sqrt(apply(matrice,2,"var")) campaign<-rbind(campaign,c(NA,NA,campaignmean)) #campaign[nrow(campaign),2]<-round(campaign[nrow(campaign),2]) dimnames(campaign)[[1]][nrow(campaign)]<-"mean" campaign<-rbind(campaign,c(NA,NA,campaignmean + 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean+2sdv" campaign<-rbind(campaign,c(NA,NA,campaignmean - 2*campaignstdv)) dimnames(campaign)[[1]][nrow(campaign)]<-"mean-2sdv" if(nrow(campaign)>4){ par(mfrow=c(1,1)) ts.plot(ts(t(campaign[,3:(Aexplore+2)])),gpars=list(xlab="Model Dim.",ylab=ylabel,type="n", main=paste(ylabel," experiments' summary",sep=""),cex=cexpar)) for(i in 1:(nrow(campaign)-2)){ points(1:Aexplore,campaign[i,3:(Aexplore+2)],pch=i,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[i,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) } points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],pch=i+1,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign)-1,3:(Aexplore+2)],type="l",lty=i,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],pch=i+2,cex=cexpar+0.7,col=colpar+i) points(1:Aexplore,campaign[nrow(campaign),3:(Aexplore+2)],type="l",lty=i,col=colpar+i) cat("Click to locate the top left corner of the legend\n") legend(locator(1),c(campaign[1:(nrow(campaign)-3),1],"mean","mean+2sdv","mean-2sdv"),pch=1:nrow(campaign),bty="o",col=c(colpar+(1:(nrow(campaign)-2)), colpar+rep((nrow(campaign)-2),2)),cex=cexpar,ncol=max(nrow(campaign)%/%5,1), text.col=c(colpar+(1:(nrow(campaign)-2)),colpar+rep((nrow(campaign)-2),2))) print(campaign[1:(nrow(campaign)-2),]) cat("Choose the best experiment row number ( 1<= # <=",nrow(campaign)-3,")") exp0<-scan(quiet=T,"",numeric(),1) crossval<-crossvalmem[[exp0]] #prop<-eval(parse("",text=dimnames(campaign)[[1]][exp0])) if(GCV==0)prop<-campaign[exp0,1] else GCV=campaign[exp0,1] cat("Retained experiment values\n") cat(ylabel,"(",campaign[exp0,1],",",crossval$A,")=",crossval[[1]][crossval$A],"\n",sep="") } if(GCV==0) texto<-paste("PRESS(",campaign[exp0,1],", . )",sep="") else texto<-paste("GCV(",campaign[exp0,1],", . )",sep="") cat(texto," values according to Dimensions\n") PRESSmat<-rbind(crossval[[2]],crossval[[1]]) if(GCV==0)dimnames(PRESSmat)[[1]][q+1]<-"TOTAL PRESS" else { dimnames(PRESSmat)[[1]][q+1]<-"TOTAL GCV" } print(round(PRESSmat,4)) A<-crossval$A PRESScounter<-crossval[[1]][A] if(missing(listknots)) { resulini<-plss(X[,Xvariables],Y,standX=standX,standY=standY,D=D,A=A,degree=degree0,knots=knots0, equiknots=equiknots0,eps=eps,interaction=NULL,impres=F) } else { resulini<-plss(X[,Xvariables],Y,standX=standX,standY=standY,D=D,A=A,degree=degree0,knots=knots0, equiknots=equiknots0,eps=eps,listknots=listknots0,interaction=NULL,impres=F) } R2mat<-resulini$R2 R2mat<-rbind(R2mat,cumsum(resulini$VY/sum(Dvar(resulini$Yini)$var)*100)) dimnames(R2mat)<-list(c(dimnames(Y)[[2]],"% TOTAL Y-VAR"),paste("Dim",1:resulini$axes,sep="")) cat("R2 coefficients according to Dimensions\n") print(round(R2mat,4)) Bcod<-resulini$Bcod BsplineXint <- Bsplinen(resulini$Xini,ordre=ordre0,nbni=knots0,noeudequi=equiknots0, center=F,D=D,tt=resulini$listknotsn) }#endreponse=1 if((reponse==2)&(!interflag)) { rint<-sum(interaction01) cat("*************************************************\n") cat("2.1: Evaluating Separately the",rint*(rint-1)/2,"Possible Interactions : \n") cat("*************************************************\n") cat("Number of Dimensions to explore?\n") Aexplore<-scan(quiet=T,"",numeric(),1) Bcodintcum<-NULL crittot<-0 namescrittot<-NULL PRESScritcum<-NULL if(rint==1) {cat("No possible interactions, ncol(X)=1 !!") break } intermatrix<-matrix(0,rint*(rint-1)/2,8) cat("All", rint*(rint-1)/2, "possible bivariate interactions are tested. Please WAIT....\n") count<-1 for(i in 1:(rint-1)) { for(j in (i+1):rint) { cat(count,",") Bcodint<-Dcenter(interactionij(BsplineXint,interaction[i],interaction[j]),D=D)$X Bcodintcum<-cbind(Bcod,Bcodint) resulpls<-pls(X=cbind(Bcod,Bcodintcum),Y=resulini$Yini,standX=F,standY=F,A=Aexplore,D=D,splflag=T,impres=F,graph=F,eps=eps) #crit<-round((resulpls$R2c[A]-resulini$R2[A])/resulini$R2[A],7) #intermatrix[count,1:3]<-c(interaction[i],interaction[j],crit) crossval<-plscv(X=cbind(Bcod,Bcodintcum),Y,standX=F,standY=standY,prop=prop,A=Aexplore,GCV=GCV,impres=F) if(GCV==0){ PRESSmin<-min(crossval$PRESStot) Ami<-order(crossval$PRESStot)[1] } else { PRESSmin<-min(crossval$GCritot) Ami<-order(crossval$GCritot)[1] } PRESScrit<-(PRESScounter-PRESSmin)/PRESScounter PRESScritcum<-c(PRESScritcum,PRESScrit) crit<-round((resulpls$R2c[Ami]-resulini$R2[A])/resulini$R2[A],7) intermatrix[count,1:3]<-c(interaction[i],interaction[j],crit) crittot<-c(crittot,crit+PRESScrit) namescrittot<-c(namescrittot,paste(dimnames(resulini$Xini)[[2]][interaction[i]],"*",dimnames(resulini$Xini)[[2]] [interaction[j]],sep="")) intermatrix[count,4:6]<-c(PRESScrit,crit+PRESScrit,Ami) count<-count+1 #browser() } } cat("\n") crittot<-crittot[-1] names(crittot)<-namescrittot if(GCV==0) dimnames(intermatrix)<-list(namescrittot,c("i","j",paste("R2CRIT(",format(A),")",sep=""), "PRESSCRIT","TOTCRIT","A","PRESS","%rel.PRESSgain")) else dimnames(intermatrix)<-list(namescrittot,c("i","j",paste("R2CRIT(",format(A),")",sep=""), "PRESSCRIT","TOTCRIT","A","GCV","%rel.GCVgain")) revorder<-rev(order(crittot)) orderinteract<-rev(sort(crittot)) selectintermatrix<-intermatrix[revorder[1:nrow(intermatrix)],,drop=F] print(selectintermatrix[,1:6]) par(mfrow=c(1,1)) barplot(orderinteract,ylab=paste("TOTCRIT = R2CRIT +",texto,"CRIT"), xlab="candidate interactions",col=2:nrow(intermatrix),histo=T,cex.names=cexpar,cex.axis=cexpar) abline(v=sum(selectintermatrix[,5]>0)*1.225,col=colpar+1) i<-1 listinteraction<-list(NULL) Bcodintcum<-Bcod currentintermatrix<-matrix(0,nrow=1,ncol=8) CVseq<-NULL cat("*************************************************\n") cat("2.2: Incorporating interactions step by step : \n") cat("*************************************************\n") if(GCV==0) cat(paste("Reference : Main effects PRESS(",prop,",",A,") = ",round(PRESScounter,7),sep=""),"\n") else cat(paste("Reference : Main effects GCV(",GCV,",",A,") = ",round(PRESScounter,7),sep=""),"\n") cat("-------------------------------------------------\n") PRESScounter0<-PRESScounter repeat { cat("candidate ",i," : ",dimnames(selectintermatrix)[[1]][i]) if(selectintermatrix[i,5]<0){ i<-i-1 cat(" REFUSED.\n") break} listinteraction[[i]]<-selectintermatrix[i,1:2] Bcodintcum<-cbind(Bcodintcum, Dcenter(interactionij(BsplineXint,selectintermatrix[i,1],selectintermatrix[i,2]),D=D)$X) crossval<-plscv(X=Bcodintcum,Y,standX=F,standY=standY,GCV=GCV,prop=prop,A=Aexplore,impres=F) if(GCV==0)PRESSmin<-min(crossval$PRESStot) else PRESSmin<-min(crossval$GCritot) gain<-(PRESScounter-PRESSmin)/PRESScounter if(gain1)degree<-degree0[Xvariables] if(length(knots)>1)knots<-knots0[Xvariables] if(length(equiknots)>1)equiknots<-equiknots0[Xvariables] if(!missing(listknots)) {knots0<-NULL for(i in 1:ncol(X))knots0[i]<-length(listknots0[[i]]) } BsplineX <- Bsplinen(resulini$Xini[,Xvariables],ordre=degree0+1,nbni=knots0,noeudequi=equiknots0, center=T,D=D,tt=resulini$listknotsn[Xvariables]) itX <- BsplineX$v for(i in 1:ncol(X[,Xvariables]))Bcod<-cbind(Bcod,itX[[i]][[1]]) } Bcodintcum<-NULL if(interflag){ if(sum(intervariables)!=0) { if(!missing(listknots)) {knots0<-NULL for(i in 1:ncol(X))knots0[i]<-length(listknots0[[i]]) } BsplineXint <- Bsplinen(resulini$Xini,ordre=degree0+1,nbni=knots0,noeudequi=equiknots0,center=F,D=D, tt=resulini$listknotsn) rint1<-length(intervariables) Bcodint<-list(NULL) AAA<-selectintermatrix[(1:rint1)[intervariables],1:2,drop=F] for(i in 1:nrow(AAA)) { Bcodint[[i]]<-Dcenter(interactionij(BsplineXint,AAA[i,1],AAA[i,2]),D=D)$X Bcodintcum<-cbind(Bcodintcum,Bcodint[[i]]) } } } cat("Number of dimensions to explore?\n") Aexplore<-scan(quiet=T,"",numeric(),1) plscvresul<-plscv(cbind(Bcod,Bcodintcum),Y,standX=F,standY=standY,A=Aexplore,D=D,prop=prop,GCV=GCV,impres=impres) plscvresul<-plscv.plot(plscvresul,bgpar=bgpar) A<-plscvresul$A } #****************************************finreponse2 }#endrepeat }#endelse }#endreponse=3 #--------------------------------------------------------- if(reponse==4) { cat("*************************************************\n") cat("4: Selection of the main effects and interactions\n") cat("*************************************************\n") repeat{ cat("---------------------------------------\n") reponse<-menu(c("'R'emove or 'A'dd main effects","'R'emove or 'A'dd interactions"), title="Selection of main effects and interactions, 0 to exit") cat("---------------------------------------\n") if(reponse==0) { if(sum(intervariables)!=0)listinteraction<-listinteraction[intervariables] else interflag<-F break } #**************************************** if(reponse==1) { Xvariables<-selectvar1(X0,Xvariables=Xvariables) } #****************************************finreponse1 if(reponse==2) { cat("'R'emove or 'A'dd interactions? (R/A)\n") signe<-scan(quiet=T,what=character(),n=1) if((signe=="R")|(signe=="r")) { cat("remaining interactions:\n") cat(paste(dimnames(selectintermatrix)[[1]][1:length(listinteraction)],"(",(1:length(listinteraction)),")",sep="")) cat("\n") cat("number of the interactions to be removed\n") num<-scan(quiet=T,) intervariables[num]<-F #listinteraction<-listinteraction[intervariables] if(sum(intervariables)==0)interflag<-F } else { if(sum(intervariables)==length(intervariables)) { cat("Impossible to add more!\n") } else { cat("interactions already removed:\n") cat(paste(dimnames(selectintermatrix)[[1]][1:sum(intervariables)] [intervariables==F],"(",(1:length(listinteraction))[intervariables==F],")",sep="")) cat("\n") cat("number of the interactions to be reintroduced\n") num<-scan(quiet=T,) intervariables[num]<-T interflag<-T } } } }#endrepeat4 } #--------------------------------------------------------- }#endrepeat if(interflag)invisible(list(listinteraction,currentintermatrix,resulini)) else invisible(resulini) } #################################################### selectvar<-function(X,Xvariables=rep(T,ncol(X))) { # Suppression/Addition de variables explicatives pour les modèles PLSL et PLSS #Entrées # X, matrice des variables initiales (toutes les variables de départ avec dimnames) # Xvariables, vecteur booléen de longueur ncol(X), indic. des variables retenues précédemment, par défaut T #Sorties # Xvariables, vecteur booléen, indicatrice des variables retenues finalement cat("'R'emove or 'A'dd? (R/A)\n") signe<-scan(quiet=T,what=character(),n=1) if(length(signe)==0)return(Xvariables) if(is.na(as.numeric(signe))) { if((signe=="R")|(signe=="r")){ Y<-X[,Xvariables] initY<-rep(T,ncol(Y)) cat("remaining variables:\n") cat(paste(dimnames(Y)[[2]],"(",(1:ncol(Y)),")",sep="")) cat("\n") cat("number of the main effects to be removed\n") num<-scan(quiet=T,) initY[num]<-F numeroplusY<-(1:ncol(Y))[-num] numeromoinsY<-(1:ncol(Y))[num] nplusX<-((1:ncol(X))[Xvariables==T])[-num] nmoinsX<-(1:ncol(X))[-nplusX] Xvariables[nplusX]<-T Xvariables[nmoinsX]<-F } if((signe=="A")|(signe=="a")) { if(sum(Xvariables==F)==0)return(Xvariables) cat("main effects already removed:\n") cat(paste(dimnames(X)[[2]][Xvariables==F],"(",(1:ncol(X))[Xvariables==F],")",sep="")) cat("\n") cat("number of the main effects to be reintroduced\n") num<-scan(quiet=T,) Xvariables[num]<-T } }#is.na else cat("try again!!\n") return(Xvariables) } #################################################### selectvar1<-function(X,Xvariables=rep(T,ncol(X))) { # Suppression/Addition des effets principaux pour les modèles MAPLSS #Entrées # X, matrice des variables initiales (toutes les variables de départ avec dimnames) # Xvariables, vecteur booléen de longueur ncol(X), indic. des variables retenues précédemment, par défaut T #Sorties # Xvariables, vecteur booléen, indicatrice des variables retenues finalement cat("'R'emove or 'A'dd? (R/A)\n") signe<-scan(quiet=T,what=character(),n=1) if((signe=="R")|(signe=="r")){ #Y<-X[,Xvariables] #initY<-rep(T,ncol(Y)) cat("remaining variables:\n") cat(paste(dimnames(X)[[2]][Xvariables],"(",(1:ncol(X))[Xvariables],")",sep="")) cat("\n") cat("number of the main effects to be removed\n") num<-scan(quiet=T,) Xvariables[num]<-F } else { if(sum(Xvariables==F)==0)return(Xvariables) cat("main effects already removed:\n") cat(paste(dimnames(X)[[2]][Xvariables==F],"(",(1:ncol(X))[Xvariables==F],")",sep="")) cat("\n") cat("number of the main effects to be reintroduced\n") num<-scan(quiet=T,) Xvariables[num]<-T } return(Xvariables) } #################################################### mygraphics<-function(file,width=6,height=6,horizontal=F,devicepar=X11) { # création d'un fichier postscript d'une image R # #file chaine de caracteres, nom du fichier postscript, ou pdf ou jpeg #devicepar chaine de caractères, nom du device de l'image source, windows ou X11 #horizontal, logical, uniquement en postscript, T donne paysage, F portrait # # Pour visualiser et/ou imprimer le fichier postscript utiliser ghostview # création de J.F. Durand, le 30/09/2004 # cat("Dimensions : width =",width,", height =",height,"\n") reponse<-menu(c(" postscript (dimensions in inches, 1 inch ~ 2.54 cm)", " pdf (dimensions in inches, 1 inch ~ 2.54 cm)", " jpeg (dimensions in pixels)"),title=paste("Choose the format of the file '",file,"' ( 0 to exit ):",sep="")) if(reponse==0)invisible(return()) if(reponse==1) { dev.copy(device=devicepar) dev.print(device=postscript,file=paste(file,".ps",sep=""),width=width,height=height, horizontal=horizontal,bg=par("bg")) } if(reponse==2) { dev.copy(device=devicepar) dev.print(device=pdf,file=paste(file,".pdf",sep=""),width=width,height=height,bg=par("bg")) } if(reponse==3) { dev.copy(device=devicepar) dev.print(device=jpeg,file=paste(file,".jpeg",sep=""),width=width,height=height,bg=par("bg")) } dev.off(dev.cur()) } #################################################### Mahalanobis<-function(X,D=1) { # sortie: M metrique de Mahalanobis R= inv(X'DX) X<-as.matrix(X) tXDX<-Dcp(X,D=D) #browser() #_______________________________________________________________________________ # decomposition valeurs singulieres de X'DX et calcul de son inverse dans R valsin<-svd(tXDX,nv=0) diago<-valsin$d[valsin$d>1e-06] if(length(diago)==1)R<-matrix(1/diago,1,1) else R<-valsin$u[,1:length(diago)]%*%diag(1/diago)%*%t(valsin$u[,1:length(diago)]) #_______________________________________________________________________________ return(R) } #################################################### plssinter<-function(X,Y,Xtest,Ytest,standX=T,standY=T,D=1,A=2,degree=1,knots=0,equiknots=F, eps=1e-8,listknots,impres=T,interaction=NULL,listinteraction,Xvariables=1:ncol(X)) { # version 9.6 programmee par JF Durand # Regression PLS sur codage spline des predicteurs # order<-degree +1 nomfichX<-deparse(substitute(X)) nomfichY<-deparse(substitute(Y)) Xinitial<-as.matrix(X) Yinitial<-as.matrix(Y) centrageX <- Dvar(Xinitial, D = D, cor = F) meanX <- centrageX$mean varX <- centrageX$var centrageY <- Dvar(Yinitial, D = D, cor = F) meanY <- centrageY$mean varY <- centrageY$var if(!missing(Xtest)){ centrageXtest <- Dvar(Xtest, D = D, cor = F) meanXtest <- centrageXtest$mean varXtest <- centrageXtest$var } n<-nrow(Xinitial) p<-ncol(Xinitial) q<-ncol(Yinitial) if(!missing(listknots)) { if(length(listknots)!=p){cat("nb incorrect de vecteurs de noeuds\n") return()} knots<-vector("numeric",p) for(i in 1:p)knots[i]<-length(listknots[[i]]) } if(is.null(dimnames(Xinitial)))dimnames(Xinitial)<-list(format(1:n),paste("X",1:p,sep="")) if(is.null(dimnames(Yinitial)))dimnames(Yinitial)<-list(format(1:n),paste("Y",1:q,sep="")) if(length(dimnames(Xinitial)[[1]])==0) dimnames(Xinitial)[[1]]<- format(1:n) if(length(dimnames(Yinitial)[[1]])==0) dimnames(Yinitial)[[1]]<- format(1:n) if(length(dimnames(Xinitial)[[2]])==0) dimnames(Xinitial)[[2]]<- paste("X",1:p,sep="") if(length(dimnames(Yinitial)[[2]])==0) {cat("Affect name(s) to response(s)\n") prov<-as.vector(format(1:q)) for(i in 1:q) {cat(paste("response ",format(i),"\n")) prov[i]<-scan(quiet=T,,what="", 1) } dimnames(Yinitial)[[2]]<-prov } # centrage et reduction centX<-Dcentred(Xinitial,D=D) centY<-Dcentred(Yinitial,D=D) if(!missing(Xtest)) { Xinitest<-sweep(Xtest, 2,centX$moy) if(standX) Xinitest<- sweep(Xinitest,2,sqrt(centX$var),FUN="/") dimnames(Xinitest)<-dimnames(Xtest) } if(!missing(Ytest)) { Yinitest<-sweep(Ytest, 2,centY$moy) if(standY) Yinitest<-sweep(Yinitest,2,sqrt(centY$var),FUN="/") dimnames(Yinitest)<-dimnames(Ytest) } if(standX) Xini<-as.matrix(centX$Xcr) else Xini<-as.matrix(centX$Xc) if(standY) Yini<-as.matrix(centY$Xcr) else Yini<-as.matrix(centY$Xc) dimnames(Xini)<-dimnames(Xinitial) dimnames(Yini)<-dimnames(Yinitial) # calcul de la matrice de codage spline de Xini listknotsn<-list(NULL)#list of centered (possibly scaled) interior knots if(missing(listknots)){ listknotsn<-list(NULL) if(p>1) for(i in 1:(p-1))listknotsn<-c(listknotsn,list(NULL)) listknots<-listknotsn } else {if(p>1) for(i in 1:(p-1))listknotsn<-c(listknotsn,list(NULL)) for(i in 1:p){ if(!is.null(listknots[[i]])){ #if(centerX)listknotsn[[i]]<-listknots[[i]]-meanX[i] if(standX)listknotsn[[i]]<-(listknots[[i]]-meanX[i])/sqrt(varX[i]) else listknotsn[[i]]<-listknots[[i]]-meanX[i] } } } BsplineX <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=T,D=D,tt=listknotsn) itX <- BsplineX$v dimension<-BsplineX$ordre+BsplineX$nbni Bcod<-NULL if(sum(Xvariables)!=0) for(i in (1:p)[Xvariables])Bcod<-cbind(Bcod,itX[[i]][[1]]) Bcodintcum<-NULL if((missing(listinteraction))&(length(interaction)!=0)) { BsplineXint <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=F,D=D,tt=listknotsn) rint<-length(interaction) Bcodint<-list(NULL) Bcodintmean<-list(NULL) dimensionint<-matrix(0,rint,rint) namesint<-matrix("",rint,rint) namesint1<-NULL for(i in 1:(rint-1)) { Bcodint[[i]]<-list(NULL) for(j in (i+1):rint) { Bcodint[[i]][[j]]<-Dcenter(interactionij(BsplineXint,interaction[i],interaction[j]),D=D)$X Bcodintmean[[i]][[j]]<-Dcenter(interactionij(BsplineXint,interaction[i],interaction[j]),D=D)$mx Bcodintcum<-cbind(Bcodintcum,Bcodint[[i]][[j]]) namesint[i,j]<-paste(dimnames(Xini)[[2]][interaction[i]],"*",dimnames(Xini)[[2]][interaction[j]],sep="") namesint1<-c(namesint1,namesint[i,j]) dimensionint[i,j]<-dimension[interaction[i]]*dimension[interaction[j]] } }} if((!missing(listinteraction))&(length(listinteraction)!=0)) { namesint1<-NULL dimensionint<-rep(0,length(listinteraction)) BsplineXint <- Bsplinen(Xini,ordre=order,nbni=knots,noeudequi=equiknots, center=F,D=D,tt=listknotsn) Bcodint<-list(NULL) Bcodintmean<-list(NULL) for(i in 1:length(listinteraction)) { Bcodint[[i]]<-Dcenter(interactionij(BsplineXint,listinteraction[[i]][1],listinteraction[[i]][2]),D=D)$X dimensionint[i]<-ncol(Bcodint[[i]]) Bcodintcum<-cbind(Bcodintcum,Bcodint[[i]]) namesint1<-c(namesint1,paste(dimnames(Xini)[[2]][listinteraction[[i]][1]],"*",dimnames(Xini)[[2]][listinteraction[[i]][2]],sep="")) Bcodintmean[[i]]<-Dcenter(interactionij(BsplineXint,listinteraction[[i]][1],listinteraction[[i]][2]),D=D)$mx } } if(!missing(Xtest)){ BsplineXtest <- Bsplinen(rbind(Xinitest,apply(Xini,2,min),apply(Xini,2,max)),ordre=order,nbni=knots,center=F,D=D,tt=BsplineX$intknots) itXtest <- BsplineXtest$v Bcodtest<-NULL for(i in (1:p)[Xvariables])Bcodtest<-cbind(Bcodtest,sweep(itXtest[[i]][[1]][1:nrow(Xtest),,drop=F],2,BsplineX$meansc[[i]])) #add interactions if any!!!! } if(impres){ cat("\n") if((length(interaction)==0)& (missing(listinteraction))) cat("PLSS : PLS LINEAIRE SUR LE CODAGE SPLINE DES PREDICTEURS\n") else cat("PLSS : PLS LINEAIRE SUR LE CODAGE SPLINE DES PREDICTEURS + INTERACTIONS\n") cat("\n") } ######################### if(missing(Xtest)) resulpls<-pls(X=cbind(Bcod,Bcodintcum),Y=Yini,standX=F,standY=F,A=A,D=D,splflag=T,impres=impres,graph=F,eps=eps) else {if(missing(Ytest)) resulpls<-pls(X=Bcod,Y=Yini,Xtest=Bcodtest,standX=F,standY=F,A=A,D=D,splflag=T,impres=impres,graph=F,eps=eps) else resulpls<-pls(X=Bcod,Y=Yini,Xtest=Bcodtest,Ytest=Yinitest,standX=F,standY=F,A=A,D=D,splflag=T,impres=impres,graph=F,eps=eps) } ######################### cat("\n") alph<-resulpls$alph R2<-resulpls$R2c pX<-p pY<-q noeudint<-list(NULL) axes<-resulpls$A corX<-standX corY<-standY covXY<-resulpls$covXY alphaX<-NULL compX<-resulpls$TX compY<-resulpls$UY cX<-resulpls$WX cY<-resulpls$CY BETALCR<-resulpls$BETALCR YH<-resulpls$YH Yhat<-matrix(0,n,pY) dimnames(Yhat)<-dimnames(Yini) VY<-NULL for(i in 1:axes){ Yhat<-Yhat+YH[[i]] VY<-c(VY,sum(Dvar(YH[[i]],D=D)$var)) } AA<-list(NULL) ranget<-list(NULL) Transf<-list(NULL) if((length(interaction)!=0)| !missing(listinteraction)) { rangetint<-list(NULL) Transfint<-list(NULL) AAint<-list(NULL) } for(j in 1:pY) { Transf[[j]]<-matrix(0,n,pX) if((length(interaction)!=0)& missing(listinteraction)){ Transfint[[j]]<-array(0,c(n,rint,rint)) AAint[[j]]<-list(NULL) rangetint[[j]]<-matrix(0,rint,rint) } if(!missing(listinteraction)){ Transfint[[j]]<-matrix(0,n,length(listinteraction)) AAint[[j]]<-list(NULL) rangetint[[j]]<-rep(0,length(listinteraction)) } dd<-1 AA[[j]]<-list(NULL) for(i in (1:pX)[Xvariables]) { AA[[j]][[i]]<-as.matrix(BETALCR[[axes]][j,dd:(dd+dimension[i]-1)]) dd<-dd+dimension[i] Transf[[j]][,i]<-BsplineX$v[[i]][[1]]%*%AA[[j]][[i]] ranget[[j]][i]<-diff(range(Transf[[j]][,i])) } if(sum(Xvariables)!=0)names(ranget[[j]])<-dimnames(Xini)[[2]][Xvariables] if((length(interaction)!=0)& missing(listinteraction)) { for(i in 1:(rint-1)) { AAint[[j]][[i]]<-list(NULL) for(k in (i+1):rint){ AAint[[j]][[i]][[k]]<-as.matrix(BETALCR[[axes]][j,dd:(dd+dimensionint[i,k]-1)]) dd<-dd+dimensionint[i,k] Transfint[[j]][,i,k]<-Bcodint[[i]][[k]]%*%AAint[[j]][[i]][[k]] rangetint[[j]][i,k]<-diff(range(Transfint[[j]][,i,k])) dimnames(rangetint[[j]])<-list(dimnames(Xini)[[2]][interaction],dimnames(Xini)[[2]][interaction]) }} #browser() }#endif if(!missing(listinteraction)) { for(i in 1:length(listinteraction)) { AAint[[j]][[i]]<-as.matrix(BETALCR[[axes]][j,dd:(dd+dimensionint[i]-1)]) dd<-dd+dimensionint[i] Transfint[[j]][,i]<-Bcodint[[i]]%*%AAint[[j]][[i]] rangetint[[j]][i]<-diff(range(Transfint[[j]][,i])) }#endfor names(rangetint[[j]])<-namesint1 #browser() }#endif }#endjloop #browser() if(impres){ if((!missing(Xtest))&(missing(Ytest))){ repeat{ cat("\n") cat("Prediction pour l'echantillon test par le modele spline additif suivant la dimension ? (o/n)") repo<-scan(quiet=T,"",character(),1) if((length(repo)==0)|(repo!="o"))break else { cat("Choisissez la dimension du modele (<=",axes,")") dimopt<-scan(quiet=T,"",numeric(),1) AAt<-list(NULL) Transftest<-list(NULL) for(j in 1:pY) { Transftest[[j]]<-matrix(0,nrow(Xtest),pX) dd<-1 AAt[[j]]<-list(NULL) for(i in 1:pX) { AAt[[j]][[i]]<-as.matrix(BETALCR[[dimopt]][j,dd:(dd+dimension[i]-1)]) dd<-dd+dimension[i] Transftest[[j]][,i]<-BsplineXtest$v[[i]][[1]][1:nrow(Xtest),,drop=F]%*%AAt[[j]][[i]] } } Yaju<-matrix(0,nrow(Ytest),q) dimnames(Yaju)<-list(dimnames(Ytest)[[1]],paste("est.",dimnames(Ytest)[[2]],sep="")) for(j in 1:pY) for(i in 1:pX) Yaju[,j]<-Yaju[,j]+Transftest[[j]][,i] for(i in 1:pY){ if(standY)Yaju[,i]<-Yaju[,i]*sqrt(centY$var[i])+centY$moy[i] else Yaju[,i]<-Yaju[,i]+centY$moy[i] } print(Yaju) #browser() } }##fin du repeat }#fin du if missing Xtest if((!missing(Xtest))&(!missing(Ytest))) { repeat{#2 cat("\n") cat("Validation par l'echantillon test suivant la dimension ? (o/n)") repo<-scan(quiet=T,"",character(),1) if((length(repo)==0)|(repo!="o"))break else { Yerr<-as.list(1:axes) Yajust<-as.list(1:axes) ERRMOY<-vector("numeric",axes) for(dimopt in 1:axes) { Yerr[[dimopt]]<-matrix(0,nrow(Ytest),ncol(Ytest)) AAt<-list(NULL) Transftest<-list(NULL) for(j in 1:pY) { Transftest[[j]]<-matrix(0,nrow(Xtest),pX) dd<-1 AAt[[j]]<-list(NULL) for(i in 1:pX) { AAt[[j]][[i]]<-as.matrix(BETALCR[[dimopt]][j,dd:(dd+dimension[i]-1)]) dd<-dd+dimension[i] Transftest[[j]][,i]<-BsplineXtest$v[[i]][[1]][1:nrow(Xtest),,drop=F]%*%AAt[[j]][[i]] } } Yaju<-matrix(0,nrow(Ytest),q) dimnames(Yaju)<-list(dimnames(Ytest)[[1]],paste("est.",dimnames(Ytest)[[2]],sep="")) for(j in 1:pY) for(i in 1:pX) Yaju[,j]<-Yaju[,j]+Transftest[[j]][,i] for(i in 1:pY){ if(standY)Yaju[,i]<-Yaju[,i]*sqrt(centY$var[i])+centY$moy[i] else Yaju[,i]<-Yaju[,i]+centY$moy[i] } Yajust[[dimopt]]<-Yaju Yerr[[dimopt]]<- Ytest-Yaju ERRMOY[dimopt]<-mean(sqrt(apply(Yerr[[dimopt]]^2,2,mean))) }#fin du for if(ncol(Ytest)==1)cat("Erreur moyenne de la reponse suivant la dimension\n") else cat("Moyenne des erreurs suivant la dimension\n") errmoy<-matrix(ERRMOY,1,axes) dimnames(errmoy)<-list("MSE",1:axes) print(round(errmoy,3)) cat("Choisissez la dimension du modele (<=",axes,")") dimoptopt<-scan(quiet=T,"",numeric(),1) cat("Reponses estimees et erreurs de prediction Yerr = Ytest - Yest \n") dimnames(Yerr[[dimoptopt]])[[2]]<-paste("err.",dimnames(Ytest)[[2]],sep="") Yaff<-NULL for(i in 1:ncol(Ytest))Yaff<-cbind(Yaff,cbind(Yajust[[dimoptopt]][,i,drop=F],Yerr[[dimoptopt]][,i,drop=F])) print(round(Yaff,4)) } }#fin du repeat2 }#fin du if((!missing(Xtest))&(!missing(Ytest))) }#fin de impres if(length(knots)==1)knots<-rep(knots,pX) if((!missing(Xtest))&(!missing(Ytest))) invisible(return(nomfichX, axes, Xinitial, meanX, varX, corX, Xini, covXY, cX, compX,BsplineX,Bcod,Transf,AA,ranget,D, nomfichY, Yinitial, dimension,alph, meanY, varY,VY, corY, Yini, cY, compY, Yhat,BETALCR,YH,listknots,listknotsn,R2,knots,Yerr)) else { if((length(interaction)==0)& missing(listinteraction)) invisible(return(nomfichX, axes, Xinitial, meanX, varX, corX, Xini, covXY, cX, compX,BsplineX,Bcod,Transf,AA,ranget,D, nomfichY, Yinitial, dimension,alph, meanY, varY,VY, corY, Yini, cY, compY, Yhat,BETALCR,YH,listknots,listknotsn,R2,knots,interaction)) else { if(missing(listinteraction)) invisible(return(nomfichX, axes, Xinitial,Xvariables, meanX, varX, corX, Xini, covXY,cX, compX, BsplineX,Bcod,Transf,AA,ranget,D, nomfichY, Yinitial, dimension,alph,meanY, varY,VY, corY, Yini, cY, compY,Yhat,BETALCR,YH,listknots,listknotsn,R2,knots,interaction,Bcodint,dimensionint,namesint, namesint1,Transfint,rangetint,AAint,Bcodintmean)) else invisible(return(nomfichX, axes, Xinitial,Xvariables, meanX, varX, corX, Xini, covXY,cX, compX, BsplineX,Bcod,Transf,AA,ranget,D, nomfichY, Yinitial, dimension,alph,meanY, varY,VY, corY, Yini, cY, compY,Yhat,BETALCR,YH,listknots,listknotsn,R2,knots,listinteraction,Bcodint,dimensionint,namesint1, Transfint,rangetint,AAint,Bcodintmean)) } } } ####################################################### MVcut<-function(X,qual,nbmod=3,equibreaks=F,breaks,labelsquant,labelsqual) { # découpage MultiVariables de variables quantitatives # codage disjonctif complet de variables quantitatives et qualitatives placées en dernier #ENTREES # X matrice de variables quantitatives + d'éventuelles variables qualitatives (booleennes ou entières) #qual, entier numero de la première colonne qualitative (les autres suivent) #nbmod vecteur entiers, nombre de modalités de chaque variable quantitative #equibreaks vecteur booleen, si T séparateurs internes equidistants si F aux nbmod quantiles #breaks liste, liste des vecteurs de separateurs interieurs a chaque variable quantitative #labelsquant liste des noms des modalités des variables quantitatives #labelsqual liste des noms des modalités des variables qualitatives #SORTIES #X dataframe, tableau d'entiers des modalites #U matrice du codage disjonctif complet #B tableau de Burt #nbmod vecteur du nb de modalités #breaks liste des vecteurs des séparateurs intérieurs + le max de la variable quantitavive #labels liste des noms des modalités des variables #EXEMPLE # # stateafcm<-MVcut(cbind(state.x77,Region=codes(state.region)),qual=ncol(state.x77)+1,labelsqual=sort(levels(state.region))) # ou bien # stateafcm<-MVcut(cbind(state.x77,Region=as.numeric(state.region)),qual=ncol(state.x77)+1,labelsqual=levels(state.region)) # afc(stateafcm,AFCM=T) # pour l'afcm du tableau des var quantitatives + la var qualitative des 4 modalités région # # X<-as.matrix(X) n<-nrow(X) pX<-ncol(X) if(!missing(qual)){ if(qual>1){ Xquant<-X[,1:(qual-1),drop=F] } else { Xquant<-NULL U<-NULL } Xqual<-X[,qual:pX,drop=F] } else { Xquant<-X Xqual<-NULL } if(is.matrix(Xquant)) {# p<-ncol(Xquant) if(length(nbmod)==1) nbmod<-rep(nbmod,p) if(length(equibreaks)==1)equibreaks<-rep(equibreaks,p) if(missing(breaks)) { breaks<-rep(list(NULL),p) for(i in 1:p) {if(equibreaks[i]) {etend<-range(Xquant[,i]) hh<-diff(etend)/nbmod[i] for(j in 1:(nbmod[i])) breaks[[i]][j]<-etend[1]+j*hh } else { breaks[[i]]<-quantile(Xquant[,i],probs=(1:nbmod[i])/nbmod[i]) } } } else {nbmod<-rep(0,p) for(i in 1:p) {breaks[[i]]<-c(breaks[[i]],max(Xquant[,i])) nbmod[i]<-length(breaks[[i]]) } } if(missing(labelsquant)){ labelsquant<-rep(list(NULL),p) for(i in 1:p) labelsquant[[i]]<-paste(dimnames(Xquant)[[2]][i],format(1:nbmod[i]),sep="") } mat<-Xquant for(i in 1:p) mat[,i]<-cut(Xquant[,i],breaks=c(min(Xquant[,i])-1,breaks[[i]]),labels=F) codage<-Codisjc(mat) X<-mat U<-codage$U }# if(is.matrix(Xqual)) {## cat("variables Entières ou Codage disjonctif complet?(E ou C)\n") pltc <- scan(quiet=T,"", character(), 1) if((pltc=="E")|(pltc=="e")) {codage1<-Codisjc(Xqual) V<-codage1$U if(missing(labelsqual)) labelsqual<-codage1$labels else dimnames(V)[[2]]<-labelsqual U<-cbind(U,V) nbmodqual<-codage1$nbmod } else { pqual<-sum(Xqual[1,]) if(pqual==1)cat("rentrez le nombre de modalités de cette variable\n") else cat("Rentrez le nombre de modalités pour chacune des",pqual,"variables\n") nbmodqual<-scan(quiet=T,"",numeric(),pqual) U<-cbind(U,Xqual) if(missing(labelsqual)) labelsqual<-dimnames(Xqual)[[2]] } }## B<-t(U)%*%U if((is.matrix(Xquant))&(is.matrix(Xqual))) { if((pltc=="E")|(pltc=="e")) X<-cbind(mat,Xqual) labels<-c(labelsquant,labelsqual) nbmod<-c(nbmod,nbmodqual) } if((!is.matrix(Xquant))&(is.matrix(Xqual))) { labels<-labelsqual nbmod<-nbmodqual } if((is.matrix(Xquant))&(!is.matrix(Xqual))) labels<-labelsquant X<-as.data.frame(X) if(is.matrix(Xquant)) return(X,U,B,nbmod,labels,breaks) else return(U,B,nbmod,labels) } #################################################### f<-function(signal="",n=100,p=1,stdv=1,seedpar=20) { # FUNCTION of X to generate (X,Y) training data bases for multivariate responses # INPUTS: # signal, vector of character strings of the signal as a function of X # examples : signal="10*sin(pi*X[,1]*X[,2])+20*(X[,3]-0.5)^2+10*X[,4]+5*X[,5]" # signal=c("10*sin(pi*X[,1]*X[,2])","15*exp(-(X[,4]+2*X[,5]))") # n, number of observations # p, number of predictors # stdv, vector of standard deviations of the normal errors from the signal # seedpar, positive integer, the seed of the random numbers # OUTPUTS # X, matrix nxp of the sample predictors (uniform on [0,1]) # Y, matrix nxlength(signal) of the responses Y_i = f_i(X) +eps_i #example : # f1<-"10*sin(pi*X[,1]*X[,2])+20*(X[,3]-0.5)^2+10*X[,4]+5*X[,5]" # MAPLSS(f(f1,100,5)$X,f(f1,100,5)$Y,degree=c(1,1,2,1,1,1),listknots=list(0.5,0.5,0.5,NULL,NULL),GCV=0,interaction=1:2) set.seed(seedpar) X<-matrix(runif(p*n,0,1),n,p) Y<-matrix(0,n,length(signal)) dimnames(X)<-list(1:n,paste("X",1:p,sep="")) if(length(signal)!=length(stdv))stdv=rep(stdv[1],length(signal)) for(i in 1:length(signal)) { eps<-rnorm(n,sd=stdv[i]) Y[,i]<-eval(parse("",text=signal[i])) if(is.null(Y[,i]))Y[,i]<-0 Y[,i]<-Y[,i]+eps } dimnames(Y)<-list(1:n,paste("Y",1:length(signal),sep="")) return(X,Y) } #################################################### plss2<-function(X,Y,standX=T,standY=T,GCV=0,D=1,A=2,degree=1,knots=0,equiknots=F,eps=1e-8, listknots,interaction=1:ncol(X),prop=0.1,colpar=1,typedata=T,titlepar=T, pchpar=1,cexpar=0.7,nbpoints=50,ptypar="s",askpar=T,PRESSprop=0.1,eyepar=c(8,-8,0.6),impres=F) { # non-conversational version of PLSS interflag=F ordre<-degree +1 n<-nrow(X) p<-ncol(X) q<-ncol(Y) if(!missing(listknots)) { if(length(listknots)!=p){cat("incorrect number of knot vectors\n") return()} knots<-vector("numeric",p) for(i in 1:p)knots[i]<-length(listknots[[i]]) } Aexplore<-A if(missing(listknots)) { crossval<-plsscv(X,Y,standX=standX,standY=standY,GCV=GCV,D=D,A=Aexplore,degree=degree,knots=knots,equiknots=equiknots,interaction=NULL,impres=impres) } else { crossval<-plsscv(X,Y,standX=standX,standY=standY,GCV=GCV,D=D,A=Aexplore,degree=degree,knots=knots,equiknots=equiknots,listknots=listknots,interaction=NULL,prop=prop,impres=impres) } if(GCV==0) { PRESSmat<-rbind(crossval[[7]],crossval[[6]]) dimnames(PRESSmat)[[1]][q+1]<-"TOTAL PRESS" A<-order(crossval[[6]])[1] PRESScounter<-crossval[[6]][A] } else { PRESSmat<-rbind(crossval[[5]],crossval[[6]]) dimnames(PRESSmat)[[1]][q+1]<-"TOTAL PRESS" A<-order(crossval[[6]])[1] PRESScounter<-crossval[[6]][A] } #################################### if(missing(listknots)) { resulini<-plss(X,Y,standX=standX,standY=standY,D=D,A=A,degree=degree,knots=knots,equiknots=equiknots,eps=eps,interaction=NULL,impres=impres) } else { resulini<-plss(X,Y,standX=standX,standY=standY,D=D,A=A,degree=degree,knots=knots,equiknots=equiknots,eps=eps,listknots=listknots,interaction=NULL,impres=impres) } R2mat<-resulini$R2 R2mat<-rbind(R2mat,cumsum(resulini$VY/sum(Dvar(resulini$Yini)$var)*100)) dimnames(R2mat)<-list(c(dimnames(Y)[[2]],"% TOTAL Y-VAR"),paste("Dim",1:resulini$axes,sep="")) Bcod<-resulini$Bcod BsplineXint <- Bsplinen(resulini$Xini,ordre=ordre,nbni=knots,noeudequi=equiknots, center=F,D=D,tt=resulini$listknotsn) ######################################### Aexplore<-A Bcodintcum<-NULL rint<-length(interaction) crittot<-0 namescrittot<-NULL PRESScritcum<-NULL if(rint==1) {cat("No possible interactions, ncol(X)=1 !!") break } intermatrix<-matrix(0,rint*(rint-1)/2,6) count<-1 for(i in 1:(rint-1)) { for(j in (i+1):rint) { Bcodint<-Dcenter(interactionij(BsplineXint,interaction[i],interaction[j]),D=D)$X Bcodintcum<-cbind(Bcod,Bcodint) #browser() resulpls<-pls(X=cbind(Bcod,Bcodintcum),Y=resulini$Yini,standX=F,standY=F,A=A,D=D,splflag=T,impres=F,graph=F,eps=eps) #crit<-round((resulpls$R2c[A]-resulini$R2[A])/resulini$R2[A],7) #intermatrix[count,1:3]<-c(interaction[i],interaction[j],crit) crossval<-plscv(X=cbind(Bcod,Bcodintcum),Y,standX=F,standY=standY,GCV=GCV,prop=prop,A=Aexplore,impres=F) if(GCV==0){ PRESSmin<-min(crossval$PRESStot) Ami<-order(crossval$PRESStot)[1] } else { PRESSmin<-min(crossval$GCritot) Ami<-order(crossval$GCritot)[1] } PRESScrit=(PRESScounter-PRESSmin)/PRESScounter PRESScritcum=c(PRESScritcum,PRESScrit) crit<-round((resulpls$R2c[Ami]-resulini$R2[A])/resulini$R2[A],7) intermatrix[count,1:3]<-c(interaction[i],interaction[j],crit) crittot<-c(crittot,crit+PRESScrit) namescrittot<-c(namescrittot,paste(dimnames(resulini$Xini)[[2]][interaction[i]],"*",dimnames(resulini$Xini)[[2]] [interaction[j]],sep="")) intermatrix[count,4:6]<-c(PRESScrit,crit+PRESScrit,Ami) count<-count+1 #browser() } } crittot<-crittot[-1] names(crittot)<-namescrittot dimnames(intermatrix)<-list(namescrittot,c("i","j",paste("R2CRIT(",format(A),")",sep=""), "PRESSCRIT","TOTCRIT","A")) #cat(summary(crittot)) revorder<-rev(order(crittot)) orderinteract<-rev(sort(crittot)) selectintermatrix<-cbind(intermatrix[revorder[1:nrow(intermatrix)],,drop=F],matrix(0,nrow(intermatrix),2)) if(GCV==0) dimnames(selectintermatrix)[[2]]=c(dimnames(intermatrix)[[2]],"PRESS","rel.gain %") else dimnames(selectintermatrix)[[2]]=c(dimnames(intermatrix)[[2]],"GCV","rel.gain %") ############################################## i<-1 listinteraction<-list(NULL) Bcodintcum<-Bcod currentintermatrix<-matrix(0,nrow=1,ncol=8) PRESScounter0<-PRESScounter repeat { #cat("candidate ",i," : ",dimnames(selectintermatrix)[[1]][i]) #cat("How many interactions to incorporate?\n") #ninteract<-scan("",numeric(),1) #if(ninteract==0) break if(selectintermatrix[i,5]<0){ i<-i-1 #cat("REFUSED.\n") break} #for(i in 1:nrow(selectintermatrix)) listinteraction[[i]]<-selectintermatrix[i,1:2] #for(i in 1:ninteract) Bcodintcum<-cbind(Bcodintcum,Dcenter(interactionij(BsplineXint,selectintermatrix[i,1],selectintermatrix[i,2]),D=D)$X) #crossval<-plscv.plot(plscv(X=Bcodintcum,Y,standX=F,standY=standY,GCV=GCV,prop=prop,A=resulini$axes)) crossval<-plscv(X=Bcodintcum,Y,standX=F,standY=standY,GCV=GCV,prop=prop,A=Aexplore,impres=F) #cat("PRESS values according to Dimensions\n") #PRESSmat<-rbind(crossval$PRESSpar,crossval$PRESStot) #dimnames(PRESSmat)[[1]][q+1]<-"TOTAL PRESS" #print(round(PRESSmat,4)) if(GCV==0) PRESSmin<-min(crossval$PRESStot) else PRESSmin<-min(crossval$GCritot) gain<-(PRESScounter-PRESSmin)/PRESScounter if(gain1){ #cat("How many interactions to incorporate (<=",length(listinteraction),")?\n") #numberinteract<-scan("",numeric(),1) #} #else #numberinteract<-1 #if(missing(listknots)) #resulini<-plss(X,Y,standX=standX,standY=standY,D=D,A=A,degree=degree,knots=knots,equiknots=equiknots,listinteraction=listinteraction[1:numberinteract]) #else #resulini<-plss(X,Y,standX=standX,standY=standY,D=D,A=A,degree=degree,listknots=listknots,listinteraction=listinteraction[1:numberinteract]) #} #}#endreponse=5 ################################### #if(reponse==6) #{ #cat("*************************************************\n") #cat("6: Displaying the numerical and graphical results : \n") #cat("*************************************************\n") #plss.plot(resulini,colpar=colpar,typedata=typedata,titlepar=titlepar,pchpar=pchpar,cexpar=cexpar,nbpoints=nbpoints,ptypar=ptypar,askpar=askpar,eyepar=eyepar) #}#endreponse=6 if(interflag){return(listinteraction,PRESScounter0,selectintermatrix[1:length(listinteraction),,drop=F]) } else return(listinteraction,PRESScounter0) } ################################################################### simulMAPLSS<-function(p,N,signal,sigmaN=1,nbiter=1,GCV=0,A=2,PRESSprop=0.1,standX=T,standY=T,D=1, degree=1,knots=0,equiknots=F,eps=1e-8,listknots,interaction=1:p, prop=0.1) #colpar=1,typedata=T,titlepar=T,pchpar=1,cexpar=0.7,nbpoints=50,ptypar="s", #askpar=T,eyepar=c(8,-8,0.6)) { # function that tests MAPLSS on different simulated datasets created by the function f() # p, nb of predictors # N, nb of samples # signal, character string, text of the signal as a function of X[,1],.....,X[,p] # sigmaN, real positive, default 1, the stdev of the additive normal error # nbiter, integer, the number of simulations, default 1 # PRESSprop, real positive in [0,1], default 0.1, the PRESS/GCV threshold for rejecting # an interaction candidate # GCV, real positive, the tuning GCV parameter in [0,4[, if 0, natural CV is processed. # A, integer, default 2, the max number of dimensions to explore # degree, knots, equiknots, listknots, the spline parameters of the PLSS function Time=c("debut","fin") Time[1]=date() step<-list(NULL) resul<-list(NULL) nb<-0 for(i in 1:nbiter) { #set.seed(i) datasets=f(signal=signal,n=N,p=p,stdv=sigmaN,seedpar=i) matX=datasets$X y=datasets$Y if(missing(listknots)) { step[[i]]<-plss2(matX,y,standX=standX,standY=standY,GCV=GCV,D=D,A=A, degree=degree,knots=knots,equiknots=equiknots,eps=eps,interaction=interaction, prop=prop,colpar=colpar,typedata=typedata, titlepar=titlepar,pchpar=pchpar,cexpar=cexpar,nbpoints=nbpoints,ptypar=ptypar, askpar=askpar,PRESSprop=PRESSprop,eyepar=eyepar) } else {step[[i]]<-plss2(matX,y,standX=standX,standY=standY,GCV=GCV,D=D,A=A, degree=degree,knots=knots,equiknots=equiknots,listknots=listknots,eps=eps,interaction=interaction, prop=prop,colpar=colpar,typedata=typedata, titlepar=titlepar,pchpar=pchpar,cexpar=cexpar,nbpoints=nbpoints,ptypar=ptypar, askpar=askpar,PRESSprop=PRESSprop,eyepar=eyepar) } if(length(step[[i]]$listinteraction)!=0) { nb<-nb+1 if(GCV==0) resul[[i]]<-list(main.eff.PRESS=step[[i]][[2]],summary=step[[i]][[3]]) else resul[[i]]<-list(main.eff.GCV=step[[i]][[2]],summary=step[[i]][[3]]) } else { if(GCV==0) resul[[i]]<-list(main.eff.PRESS=step[[i]][[2]]) else resul[[i]]<-list(main.eff.GCV=step[[i]][[2]]) } } Time[2]=date() names(Time)=c("start","stop") return(list(simul=resul,detect=nb,Aexplore=A,samples=N,NBsimul=nbiter,threshold=PRESSprop*100,GCV=GCV,duration=Time)) } ################################################################### OneInterActAnalysis=function(resul,interact) { # summary of a simulation according on the threshold or the GCV tuning parameter # resul is the value of the function simulMAPLSS # interact, couple of variable numbers expected to be detected, interact=c(1,2) TABLE=matrix(0,1,7) TABLE[1,1]=resul$threshold/100 col1="Thresh." TABLE[1,2]=resul$GCV col2="GCV" dimnames(TABLE)=list(paste("samples=",format(resul$samples),sep=""),c(col1,col2,"MainEff.","Exact", "Parasit","First","MaxInter")) TABLE[1,3]=resul$NBsimul-resul$detect counterEXACT=0 counterNOTEXACT=0 counterMAXINTER=0 for(i in 1:resul$NBsimul) { if(length(resul$simul[[i]])>1) { if(nrow(resul$simul[[i]][[2]])>counterMAXINTER)counterMAXINTER=nrow(resul$simul[[i]][[2]]) for(j in 1:nrow(resul$simul[[i]][[2]])) { if((dim(resul$simul[[i]][[2]])[1]==1)) { if((all((resul$simul[[i]][[2]][j,1:2]-interact)==0))|(all((resul$simul[[i]][[2]][j,1:2]-rev(interact))==0)))counterEXACT=counterEXACT+1 } else {#plus d'une détectée if(j==1) if((all((resul$simul[[i]][[2]][1,1:2]-interact)==0))|(all((resul$simul[[i]][[2]][1,1:2]-rev(interact))==0))) counterNOTEXACT=counterNOTEXACT+1 } }#endforj }#endiflength }#endfori TABLE[1,4]=counterEXACT TABLE[1,6]=counterNOTEXACT TABLE[1,5]=resul$detect-counterEXACT TABLE[1,7]=counterMAXINTER return(TABLE) } ################################################################## TryAnalysis=function(resul,interaction=NULL) { # statistics of a simulation according to the threshold or the GCV tuning parameter # resul is the value of the function simulMAPLSS # interaction, default NULL, is a list of couples, example, interaction=list(c(1,2),c(2,4)) Time1=resul$duration[1] Time2=resul$duration[2] T1H=substr(Time1,12,13) T2H=substr(Time2,12,13) mode(T2H)="real" mode(T1H)="real" T1H=T1H*3600 T2H=T2H*3600 T1M=substr(Time1,15,16) T2M=substr(Time2,15,16) mode(T2M)="real" mode(T1M)="real" T1H=T1H+T1M*60 T2H=T2H+T2M*60 T1S=substr(Time1,18,19) T2S=substr(Time2,18,19) mode(T2S)="real" mode(T1S)="real" T1H=T1H+T1S T2H=T2H+T2S Lasting=T2H-T1H LastingH=Lasting%/%3600 LastingM=(Lasting-LastingH*3600)%/%60 LastingS=Lasting%%60 if(length(interaction)==0) cat("Detection of main effects additive models\n") if(length(interaction)==1) cat("Detection of interaction ",interaction[[1]],"\n") if(length(interaction)>1) { cat("Detection of interactions ") for(i in 1:length(interaction)) if(i1) { if(nrow(resul$simul[[i]][[2]])>counterMAXINTER)counterMAXINTER=nrow(resul$simul[[i]][[2]]) }#endiflength }#endfori TABLE[1,4]=resul$detect TABLE[1,5]=counterMAXINTER return(TABLE) }#endif(length(interaction)==0) if(length(interaction)>1) { TABLE=matrix(0,1,5) TABLE[1,1]=resul$threshold/100 col1="Thresh." TABLE[1,2]=resul$GCV col2="GCV" dimnames(TABLE)=list(paste("samples=",format(resul$samples),sep=""),c(col1,col2,"MainEff.","Exact","MaxInter")) TABLE[1,3]=resul$NBsimul-resul$detect counterEXACT=0 counterNOTEXACT=0 counterMAXINTER=0 for(i in 1:resul$NBsimul) { if(length(resul$simul[[i]])>1) { if(nrow(resul$simul[[i]][[2]])>counterMAXINTER)counterMAXINTER=nrow(resul$simul[[i]][[2]]) if(nrow(resul$simul[[i]][[2]])==length(interaction)) { flag=rep(T,nrow(resul$simul[[i]][[2]])) for(j in 1:nrow(resul$simul[[i]][[2]])) {flag[j]=F for(k in 1:length(interaction)) if((all((resul$simul[[i]][[2]][j,1:2]-interaction[[k]])==0))|(all((resul$simul[[i]][[2]][j,1:2]-rev(interaction[[k]]))==0))) flag[j]=T }#endforj if(sum(flag)==nrow(resul$simul[[i]][[2]]))counterEXACT=counterEXACT+1 } }#endiflength }#endfori TABLE[1,3]=resul$NBsimul-resul$detect TABLE[1,4]=counterEXACT TABLE[1,5]=counterMAXINTER print(TABLE) }#endif(length(interaction)>1) } ################################################################## Bspline<-function(X,degree=1,knots=0,equiknots=T,listknots,center=F,D=1,graph=F,matrow=1,matcol=1, nbpoints=100,cexpar=0.7,bgpar="lightblue",askpar=T) # gives the coding matrix B and the list of knots locations for a vector or a matrix X # if graph=T the graphs of the B-spline basis functions are displayed for the selected predictor { X=as.matrix(X) columnlist2=NULL if(is.null(dimnames(X))) dimnames(X)=list(format(1:nrow(X)),paste("X",1:ncol(X),sep="")) BB=Bsplinen(X,ordre=degree+1,nbni=knots,noeudequi=equiknots,center=center,D=D,tt=listknots) B=BB$v[[1]][[1]] if(degree[1]!=0) dimnames(B)=list(dimnames(X)[[1]],paste("B1*",format(1:ncol(BB$v[[1]][[1]])),sep="")) else dimnames(B)=list(dimnames(X)[[1]],paste(dimnames(X)[[2]][1],format(1:ncol(BB$v[[1]][[1]])),sep="")) if(ncol(X)>1) { for(i in 2:ncol(X)) { if(BB$ordre[i]!=1) dimnames(BB$v[[i]][[1]])[[2]]=paste("B",i,"*",1:ncol(BB$v[[i]][[1]]),sep="") else dimnames(BB$v[[i]][[1]])[[2]]=paste(dimnames(X)[[2]][i],1:ncol(BB$v[[i]][[1]]),sep="") B=cbind(B,BB$v[[i]][[1]]) }} if(graph) { par(ask=askpar) if(ncol(X)>1) {cat("The variable column number") column=scan(quiet=T,"", numeric(), 1) } else column=1 BX=Bsplinen(X[,column,drop=F],ordre=degree+1,nbni=knots,noeudequi=equiknots,center=center,D=D,tt=listknots)$v[[1]][[1]] par(mfrow=c(matrow,matcol),bg=bgpar) for(i in 1:dim(BX)[2]) { x=seq(min(X[,column]),max(X[,column]),length=nbpoints) bbx=Bsplinen(x,ordre=degree+1,nbni=knots,noeudequi=equiknots,center=center,D=D,tt=listknots) bx=bbx$v[[1]][[1]] plot(x,bx[,i],xlab="",ylab="",ylim=c(0,1),main=paste("B",i,sep=""),type="l") rug(X[,column],ticksize=0.02,lwd=1.5,col="red") text(X[,column],BX[,i],dimnames(B)[[1]],col="red",cex=cexpar) if(bbx$nbni!=0)abline(v=bbx$intknots[[1]],lty=2) } }#endifplots return(B) } ##################################################################