.packageName <- "kopls"

###########################################################################

# 

# Classification function that assesses class belonging of 'data'

# based on a threshold 'k'.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsBasicClassify<-function(data,k){



#   k is boundary, data is y_hat

    predClass=matrix(NaN,ncol=ncol(data),nrow=nrow(data));

     for(i in 1:length(data[,1])){        

        tmp<-which(data[i,]>k);

        predClass[i,1:length(tmp)]=tmp;

     }     

	 

	 return(predClass);

}

###########################################################################

#

# Function for performing K-OPLS cross-validation for a set of

# Y-orthogonal components.

#

# K = Kernel matrix (see 'koplsKernel()' for details)

# Y = Y matrix/vector (predictors), rows are observations, columns are

#           features

# A = number predictive components (integer)

# oax = number of Y-orthogonal components (integer)

#

# nrcv= number of cross-validation rounds (integer)

# cvType = 'nfold' for n-fold, 'mccv' for monte-carlo, 'mccvb' for 

#   monte-carlo class-balanced

# preProcK = 'mc' for meancentering, 'no' for no centering

# preProcY = 'mc' for mean-centering, 'uv' for mc + scaling to unit 

#   variance, 'pareto' for mc + Pareto, 'no' for no scaling

# cvFrac = fraction of samples used for modelling (if cvType is 'mc' or 

#   'mb' - otherwise not used

# modelType = 'da' for discriminant analysis, 're' for regression - if 'da'

#   sensitivity and specificity will be calculated.

#

# Reference: 

#

# Authors: Mattias Rantalainen, Imperial College and

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsCV<-function(K,Y,A,oax,nrcv=7,cvType='nfold',preProcK='mc',preProcY='mc',cvFrac=0.75,modelType='re', verbose=TRUE){



release<-'';



#X<-as.data.frame(X);

#Y<-as.data.frame(Y);



N<-nrow(Y);

m<-ncol(Y);

modelMain<-list();



# some minor checks....

if(as.logical((match(modelType,'da',nomatch=0)))){    

	drRule<-'max'; #move to arg... #this is a parameter for DA decision rule

    

	tmp<-unique(as.vector(unlist(Y)));



	#browser()

	

	if(length(tmp)==2){

	  if(all(tmp==0|tmp==1)){

	    if(m==1){

	      Y<-koplsDummy(Y);

	    }

		classVect<-koplsReDummy(Y);

	  }

	}

	else{

	  if(all(Y%%1==0 && m==1)){

	    classVect<-Y;

	    Y<-koplsDummy(Y+1);

	  }

	}

	 

	nclasses<-length(unique(classVect));

 }



if(as.logical(match(cvType,'mccvb',nomatch=0)) && !as.logical(match(modelType,'da',nomatch=0))){

    stop('Class balanced monte-carlo cross validation only applicable to da modelling');;

  }



if(!any(c(as.logical(match(cvType,'mccvb',nomatch=0))) , as.logical(match(cvType,'mccv',nomatch=0)) , as.logical(match(cvType,'nfold',nomatch=0)))){

    stop(paste(cvType, '- unknown Cross-validation type'));

  }



YcenterType<-"no";

YscaleType<-"no";

if (preProcY!="no") {

    YcenterType<-"mc";

    if (preProcY!="mc") {

        YscaleType<-preProcY;

    }

}

  

oay<-0;#tmp fix kopls

Yhat<-NULL;#matrix(NaN,nrow=N,ncol=m);

YhatDaSave<-array(list(),c(oax+1,oay+1));#list(NULL);





pressyVars<-array(list(),c(oax+1,oay+1));#list(NULL):#cell(1,1);

pressyVarsTot<-array(list(),c(oax+1,oay+1));#list(NULL);#cell(1,1);

pressy<-matrix(NaN,oax+1,oay+1);

pressyTot<-matrix(NaN,oax+1,oay+1);

cvTestIndex<-NULL;

cvTrainingIndex<-NULL;



for( icv in 1:nrcv){

  if (verbose)

  {

  	print(paste('Cross validation round: ',icv,'...'));

  }



  #set up cv

  cvSet<-koplsCrossValSet(K,Y,cvType,nrcv,icv,cvFrac);

  cvTestIndex<-c(cvTestIndex,cvSet$testInd);

  cvTrainingIndex<-c(cvTrainingIndex,cvSet$trainInd);

  

  #get kernel matrics

  KtrTr<-cvSet$KTrTr

  KteTe<-cvSet$KTeTe

  KteTr<-cvSet$KTeTr



 

  # center Y and K matrices

  YScaleObj<-koplsScale(cvSet$yTraining,center=YcenterType,scale=YscaleType);

  YScaleObjTest<-koplsScaleApply(YScaleObj,cvSet$yTest);

  if (preProcK=="mc") {

	KteTe<-koplsCenterKTeTe(KteTe,KteTr,KtrTr);

	KteTr<-koplsCenterKTeTr(KteTr,KtrTr);

	KtrTr<-koplsCenterKTrTr(KtrTr);

  }

  



  model<-koplsModel(KtrTr,YScaleObj$x,A,oax,'none','none');



    #ssy<-sum((cvSet$yTest)^2);

    #ssyVars<-colSums((cvSet$yTest)^2);	

    #ssx<-sum(diag(KteTe));

    ssy<-sum((YScaleObjTest$x)^2);

    ssyVars<-colSums((YScaleObjTest$x)^2);	

    ssx<-sum(diag(KteTe));





    if(icv==1){

      ssyTot<-ssy;

      ssyVarsTot<-ssyVars;

      ssxTot<-ssx;



    }

    else{

      ssyTot<-ssyTot+ssy;

      ssyVarsTot<-ssyVarsTot+ssyVars;        

      ssxTot<-ssxTot+ssx;

      }

    

    

  for( ioax in 1:(oax+1)){

    for( ioay in 1:1){#(oay+1)){

       

       #yhat  ====HERE : change inteface on the scaling of cvset?

    

    

      modelPredy<-koplsPredict(KteTr, KteTe,KtrTr, model,ioax-1,rescale=FALSE);	                                   



    

      #pressy[ioax, ioay]<-sum((cvSet$yTest-modelPredy$Yhat)^2);

      #pressyVars[ioax, ioay]<-list(colSums((cvSet$yTest-modelPredy$Yhat)^2));

      pressy[ioax, ioay]<-sum((YScaleObjTest$x-modelPredy$Yhat)^2);

      pressyVars[ioax, ioay]<-list(colSums((YScaleObjTest$x-modelPredy$Yhat)^2));

             

            

            if((icv==1)){

                pressyTot[ioax,ioay]<-pressy[ioax,ioay];

                pressyVarsTot[ioax,ioay]<-pressyVars[ioax,ioay];

            }

            else{

                pressyTot[ioax,ioay]<-pressyTot[ioax,ioay]+pressy[ioax,ioay];

                pressyVarsTot[ioax,ioay]<-list(pressyVarsTot[ioax,ioay][[1]]+pressyVars[ioax,ioay][[1]]);

              }

              

            #browser()

			

			

            #if 'da' save Yhat for all rounds

            if(as.logical(match(modelType,'da',nomatch=0))){

                    #if(icv==1){

                    #    YhatDaSave{ioax,ioay}<-[];                        

                    #}



                    #might not be right...

                    tmp<-koplsRescale(YScaleObj,modelPredy$Yhat);

                    YhatDaSave[ioax,ioay]<-list(rbind(YhatDaSave[ioax,ioay][[1]],tmp));                               

                  }



    

            #if highest number of oscs - save Yhat and Xhat

            if(ioax==oax+1){# && ioay==oay+1){                

                    #if(icv==1){

                    #    Yhat<-[];

                    #    Xhat<-[];

                    #}                    

 

              tmp<-koplsRescale(YScaleObj,modelPredy$Yhat);



                    Yhat<-rbind(Yhat,tmp);

  

            



                  }

            

  }

}

  

}

   #end icv



modelMain$cv$Yhat<-Yhat;





#YScaleObj<-koplsScale(Y,center=YcenterType,scale=YscaleType);

#KtrTr<-K

#if (preProcK=="mc") {

#	KtrTr<-koplsCenterKTrTr(KtrTr);

#}

#modelMain$koplsModel<-koplsModel(KtrTr,YScaleObj$x,A,oax,preProcK,preProcY);



KtrTr<-K

modelMain$koplsModel<-koplsModel(KtrTr,Y,A,oax,preProcK,preProcY);

modelMain$cv$Tcv<-Yhat%*%modelMain$koplsModel$Cp%*%modelMain$koplsModel$Bt[[oax+1]];





    modelMain$cv$Q2Yhat<-NULL;

    modelMain$cv$Q2YhatVars<-array(list(),c(oax+1,oay+1));#cell(1,1);



    for( ioax in 1:(oax+1)){

        for( ioay in 1:(oay+1)){

            modelMain$cv$Q2Yhat[ioax,ioay]<-1-pressyTot[ioax,ioay]/ssyTot;          

            modelMain$cv$Q2YhatVars[ioax,ioay]<-list(1-pressyVarsTot[ioax,ioay][[1]]/ssyVarsTot);



}

}



    modelMain$cv$cvTestIndex<-cvTestIndex;

    modelMain$cv$cvTrainingIndex<-cvTrainingIndex;



if(as.logical(match(modelType,'da',nomatch=0))){





sensSpecRes<-list(1);

da<-list(1);

        #get sens/spec for each y-orth component... eval of model

  for( i in 1:(oax+1)){ #we would have no osc comps for dummy matrix...

    if(as.logical(match(drRule,'max',nomatch=0)) ){

      predClass<-koplsMaxClassify(YhatDaSave[i,1][[1]]);

    }

                else{

                  if(strcmp(drRule,'fixed')){

                    predClass<-koplsBasicClassify(YhatDaSave[i,1][[1]],1/nclasses);

                  }

                  else{

                    stop(paste('Decision rule given: ',drRule,'is not valid/implemented'))

                  }

                }

da$sensSpec[[i]]<-koplsSensSpec(classVect[cvTestIndex], predClass);  



  }





  

           da$confusionMatrix<-koplsConfusionMatrix(classVect[cvTestIndex], predClass);

           da$trueClass<-classVect[cvTestIndex];

            da$nclasses<-nclasses;

        modelMain$da<-da;

        modelMain$da$predClass<-predClass;        

        modelMain$da$decisionRule<-drRule;

                #CHANGE TO ORIGNAL ORDER IF NFOLD CV - for backward

                #compatibility and comparison w/ simca-p etc

        if(as.logical(match(cvType,'nfold',nomatch=0))){

            tmp<-sort(cvTestIndex,index.return=TRUE);

            cvOrder<-tmp$ix;

            modelMain$da$predClass<-modelMain$da$predClass[cvOrder];

            modelMain$da$trueClass<-modelMain$da$trueClass[cvOrder];           

        }

        

}#end if da





    #CHANGE TO ORIGNAL ORDER IF NFOLD CV - for backward

    #compatibility and comparison w/ simca-p etc

    if(as.logical(match(cvType,'nfold',nomatch=0))){

        

        tmp<-sort(cvTestIndex,index.return=TRUE);

        cvOrder<-tmp$ix;

        modelMain$cv$Yhat<-modelMain$cv$Yhat[cvOrder,];

        modelMain$cv$Tcv<-modelMain$cv$Tcv[cvOrder,];



}

    

modelMain$release<-release;

#close(h);        

modelMain$args$oax<-oax;

modelMain$args$A<-A;



class(modelMain)<-"koplscv"



return(modelMain);



}













###########################################################################

#

# Centering function for the KteTe=Xte*Xte' kernel. Requires

# additional (un-centered) kernels.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsCenterKTeTe<-function(KteTe,KteTr,KtrTr){



nte<-nrow(KteTr);

ntr<-ncol(KteTr);



Itrain<-diag(rep(1,ntr));

InTrain<-matrix(rep(1,ntr),ncol=1);

nTrain<-ntr;



I<-diag(rep(1,nte));

In<-matrix(rep(1,nte),ncol=1);

n<-nte;



Dte <- (1/nTrain)*In%*%t(InTrain);

KteTe <- KteTe -Dte%*%t(KteTr) - KteTr%*%t(Dte) + Dte%*%KtrTr%*%t(Dte);

return(KteTe);

}

###########################################################################

#

# Centering function for the KteTr=Xte*Xtr' kernel. Requires

# additional (un-centered) training kernel.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsCenterKTeTr<-function(KteTr,Ktrain){

  K<-KteTr; #Xtest*Xtrain';

  Kold<-K;



#Ktrain<-model.Kold;



#Mean Centering of K

#I_n <- vectors of length n containing only ones

#I <- identity matrix of same dimensionality as K

Itrain<-diag(rep(1,nrow(Ktrain)));#eye(length(Ktrain(:,1)));

InTrain<-matrix(rep(1,nrow(Ktrain)),ncol=1);#ones(length(Ktrain(:,1)),1);

nTrain<-nrow(Ktrain);#length(Ktrain(:,1));



I<-diag(rep(1,nrow(K)));#eye(length(K(:,1)));

In<-matrix(rep(1,nrow(K)),ncol=1);#ones(length(K(:,1)),1);

n<-nrow(K);#length(K(:,1));     



#this is the mean center step in feature space..

#K <- (I- (1/n).* I_n*I_n') * K*(I-(1/n).*I_n*I_n');

#true#



K <- (K- (1/nTrain)*(In%*%t(InTrain) %*% Ktrain)) %*% (Itrain-(1/nTrain)*InTrain%*%t(InTrain));

  return(K);

}

###########################################################################

#

# Centering function for the training kernel. 

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsCenterKTrTr<-function(K){

  I<-diag(rep(1,nrow(K)));

  In<-matrix(rep(1,nrow(K)),ncol=1);

  n<-nrow(K);

  K <- (I-(1/n) * In%*%t(In)) %*% K %*% (I-(1/n)*In%*%t(In));

  return(K);

}

###########################################################################

#

# Calculates a confusion matrix from two vectors:

# true = True class belonging

# pred = Predicted class belonging

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsConfusionMatrix<-function(true,pred){

uniqueClass=unique(true);

nclasses<-length(uniqueClass);

A<-matrix(rep(0,nclasses^2),ncol=nclasses);

for(i in 1:nclasses){

  indTrue=which(true==uniqueClass[i]);

  for(j in 1:length(indTrue)){

    #pred(indTrue(j))

    #[find(uniqueClass==pred(indTrue(j)))\

    A[i,which(uniqueClass==pred[indTrue[j]])]<-A[i,which(uniqueClass==pred[indTrue[j]])]+1;

  }

  A[i,]=A[i,]/length(indTrue);

}

return(A);

}

###########################################################################

#

# Fetches a set of training/test observations for cross-validation.

# K = Kernel matrix

# Y = response matrix

# type = type of cross-validation:

# 	'nfold' for n-fold, 'mccv' for monte-carlo, 'mccvb' for 

#   	monte-carlo class-balanced

# nfold =  number of total nfold rounds (if type='nfold')

# i =  Current nfold rounds (if type='nfold')

# trainFrac = fraction of observations in training set.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



"koplsCrossValSet" <-

function(K,Y,type='nfold',nfold,i,trainFrac=(2/3)){

	#nobs is the total number of observations

	#Y is the response matrix vector

	#type is type of Cross validation; nfold,mc or mccb

	#i is the order, if nfold...set i to N for Leave one out Cross validation

	#trainFrac is the fraction of the data that is used for training set if mc or mccb

	   

		

		

	if(type=='nfold'){

		testInd<-seq(i,nrow(K),nfold);

		trainInd<-setdiff(1:nrow(K),testInd);

	}



	if(type=='mccv'){

		randomSeq<-rnorm(nrow(K));

		ind<-sort(randomSeq,index.return = TRUE)$ix;

		trainSize<-floor(nrow(K)*trainFrac);

		trainInd<-ind[1:trainSize];

		testInd<-ind[(trainSize+1):nrow(K)];

	}



	if(type=='mccvb'){

		#assume that we have a dummy matrix as input

		trainInd<-NULL;

		testInd<-NULL;



		class<-koplsReDummy(Y);

		uniqueClass<-unique(class);

		for(i in 1:length(uniqueClass)){

		      ind<-which(class==uniqueClass[i]);

		      ind<-ind[sort(rnorm(length(ind)),index.return=TRUE)$ix];

		      trainSize<-floor(length(ind)*trainFrac);

		      trainInd<-c(trainInd,ind[1:trainSize]);

		      testInd<-c(testInd,ind[(trainSize+1):length(ind)]);

		}#end for each class

	

		

	}#end 'mccb'

	

	## Construct Kernel/Y matrices for training/test

	KTrTr<-K[trainInd,trainInd,drop=FALSE];

	KTeTr<-K[testInd,trainInd,drop=FALSE];

	KTeTe<-K[testInd,testInd,drop=FALSE];

	yTrain<-Y[trainInd,,drop=FALSE];

	yTest<-Y[testInd,,drop=FALSE];

	

	return(list(KTrTr=KTrTr, KTeTr=KTeTr, KTeTe=KTeTe, yTraining=yTrain, yTest=yTest, trainInd=trainInd, testInd=testInd, class='crossValSet'));

}



###########################################################################

# 

# Converts integer vector to binary matrix (dummy matrix)

# class = vector with class belongings (int)

#

# Output: dummy = matrix (for K-OPLS-DA), class labels(columns) in ascending

#	order i.e. smallest class label will be as column one in dummy, etc.

#	labels_sorted=the class labels that are found in class in

#	sorted order.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



"koplsDummy" <-

function(class, numClasses=NA){

	#create a dummy matrix based on the vector Class that indicate

	#class

	rowNames<-rownames(class);

	if(is.data.frame(class)|is.matrix(class)){

		class<-as.vector(as.matrix(class));

	}



	if (is.na(numClasses))

	{

		uniqueClass<-unique(class);

		uniqueClass<-sort(uniqueClass);

	} else

	{

		uniqueClass<-1:numClasses

	}

	dummy<-matrix(0,nrow=length(class),ncol=length(uniqueClass));

	for(i in 1:length(uniqueClass)){

	      ind<-which(class==uniqueClass[i]);

	      dummy[ind,i]<-1;	      

	}

	rownames(dummy)<-rowNames;

	colnames(dummy)<-uniqueClass;

	return(dummy);

}#end createDummy

###########################################################################

#

# Kernel construction method. 

#

# *Input:

# X1 = the first X matrix (non-centered).

# X2 = the second X matrix (non-centered).

#  If X2 = NULL (empty set), then only X1 will be used for

#  the calculations. This way, only (n^2 - n)/2 instead of n^2

#  calculations have to be performed, which is typically much

#  faster. Only applicable for training kernels.

# Ktype = the type of kernel used. Supported entries are:

# - 'g': Gaussian kernel.

# - 'p': Polynomial kernel.

# param = A vector with parameter for the kernel function.

#   (Currently, all supported kernel functions use a scalar value

#    so the vector property of the parameters is for future

#    compability).

#

# *Output:

# K = The kernel.

#

# Authors: Mattias Rantalainen, Imperial College and

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################





koplsKernel<-function(X1,X2=NULL,Ktype,param){



fast.calc<-(is.null(X2));



if (fast.calc) {

	K<-matrix(NA,ncol=nrow(X1),nrow=nrow(X1));

} else {

	K<-matrix(NA,ncol=nrow(X2),nrow=nrow(X1));

}



if(Ktype=='g'){ #gaussian

  #print('gaussian');

  sigma<-param[1]; #small value = overfit, larger = more general



	if (fast.calc) {

		for(i in 1:nrow(X1)){

				for( j in i:nrow(X1)){

		                  

					K[i,j]<-exp( -(vectNorm(X1[i,]- X1[j,])^2) / (2* sigma^2) );

					K[j,i]<-K[i,j]; #Due to symmetry

		        }

		}

		

	} else {

		for(i in 1:nrow(X1)){

				for( j in 1:nrow(X2)){

		                  

					K[i,j]<-exp( -(vectNorm(X1[i,]- X2[j,])^2) / (2* sigma^2) );

		        }



		}

		

	}

}







if(Ktype=='p'){ #polynomial, order=param

  #print('polynomial');

  #sigma=0.0005; %small value = overfit, larger = more general

  porder<-param[1];

  

  if (fast.calc) {

	for(i in 1:nrow(X1)){

	    for( j in i:nrow(X1)){



	      K[i,j]<-(t(X1[i,]) %*% ((X1[j,])+1))^porder; #polynomial/homogenous

	      K[j,i]<-K[i,j]

	    }

	  }

  } else {

  

	  for(i in 1:nrow(X1)){

	    for( j in 1:nrow(X2)){





	      K[i,j]<-(t(X1[i,]) %*% ((X2[j,])+1))^porder; #polynomial/homogenous

	      ###K[i,j]<-(X1[i,] %*% (t(X2[j,])+1))^porder; #polynomial/homogenous

	      #K[i,j]<-(X1[i,] %*% t(X2[j,])-1)^porder; #polynomial non-homogenous

	    }

	  }

	}

}



return(K);

}





vectNorm<-function(a){ 

	return(c(sqrt(t(a) %*% a)));

}#end vectNorm

###########################################################################

#

# Classification function that assesses class belonging of 'data'

# based on the maximum value.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsMaxClassify<-function(data){

  predClass<-matrix(apply(data,1,which.max),ncol=1);

}

###########################################################################

#

# Function for training a K-OPLS model.

# K = Kernel matrix

# Y = response matrix

# A = number of predictive components

# nox = number of Y-orthogonal components

# preProcK = pre-processing parameter for the K matrix.

#	'mc' for meancentering, 'no' for no centering.

# preProcY = pre-processing parameter for the Y matrix.

#	'mc' for mean-centering, 'uv' for mc + scaling to unit

#	variance, 'pa' for mc + Pareto, 'no' for no scaling.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsModel<-function(K,Y,A,nox,preProcK='mc',preProcY='mc'){



n=ncol(K);

#K<-centerK(K);

I<-diag(rep(1,n));





#[nn,kk]=size(K);

#I=eye(nn);



if (preProcK=='mc') {

	Kmc<-koplsCenterKTrTr(K);

} else {

	Kmc<-K;

}



K<-matrix(list(),ncol=nox+1,nrow=nox+1);

K[1,1]<-list(Kmc);



#%mean centering ---------------------

#% I=eye(length(K(:,1)));

#% I_n=ones(length(K(:,1)),1);

#% n=length(K(:,1));

#% 

#% %this is the mean center step in feature space..

#% Kmc = (I- (1/n).* I_n*I_n') * K*(I-(1/n).*I_n*I_n');

#% %Kold_mc=K;





## Pre-process Y

Y.old<-Y

scale.params<-list()

if (preProcY=='mc' | preProcY=='uv' | preProcY=='pareto') {

	scale.params<-koplsScale(Y, center='mc', scale=ifelse(preProcY=='mc','none',preProcY)  )

	Y<-scale.params$x

}





# initiate Yorth related vars

to<-list();

co<-list();

so<-list();

toNorm<-list();

Tp<-list();

Cp<-list();

Bt<-list();







# KOPLS model estimation -------------



#step 1

tmp<-svd(t(Y)%*%K[1,1][[1]]%*%Y,nu=A,nv=A)

#[Cp,Sp]=eigs(K,A);

Cp<-tmp$u;



if( A > 1){

  Sp<-diag(tmp$d[1:A]);

  Sps<-diag(tmp$d[1:A]^(-1/2)) #scaled version

}

else{

  Sp<-tmp$d[1];

  Sps<-tmp$d[1]^(-1/2) #scaled version

}

  

#step2

Up<-Y%*%Cp;



if (nox > 0) {

	for(i in 1:nox){ #Step3



	    #step4

	    Tp[[i]]<-t(K[1,i][[1]])%*%Up%*%Sps;    

	    Bt[[i]]<-solve(t(Tp[[i]])%*%Tp[[i]])%*%t(Tp[[i]])%*%Up;  

	    

	    #step5

	    #[CoTmp,SoTmp,Vo]

		#browser()

	    tmp<- svd( t(Tp[[i]])%*% (K[i,i][[1]]-Tp[[i]]%*%t(Tp[[i]]) )%*% Tp[[i]],nu=1,nv=1 );

	    



	    

	    co[[i]]<-tmp$u;

	    so[[i]]<-tmp$d[1];

	    

	    #step6

	    to[[i]]<-(K[i,i][[1]]-Tp[[i]]%*%t(Tp[[i]])) %*% Tp[[i]]%*%co[[i]]%*%so[[i]]^(-1/2);

	    

	    #step7

	    toNorm[[i]]<-c(sqrt(t(to[[i]])%*%to[[i]]));

	    

	    #step8

	    to[[i]]<-to[[i]]/toNorm[[i]];

	    

	    #step9

	    K[1,i+1][[1]]<-K[1,i][[1]]%*%(I - to[[i]]%*%t(to[[i]]));

	    

	    #step10

	    K[i+1,i+1][[1]]<-(I - to[[i]]%*%t(to[[i]])) %*% K[i,i][[1]]%*% (I - to[[i]]%*%t(to[[i]]));

	    

	    

	     

	} #step 11

}



#step12

Tp[[nox+1]]=t(K[1,nox+1][[1]])%*%Up%*%Sps;



#Step13

Bt[[nox+1]]=solve(t(Tp[[nox+1]]) %*% Tp[[nox+1]]) %*% t(Tp[[nox+1]])%*%Up;    



#---------- extra stuff -----------------

EEprime<-K[nox+1,nox+1][[1]]-Tp[[nox+1]]%*%t(Tp[[nox+1]]);

sstotK <- sum(diag(K[1,1][[1]]));

R2X <- NULL;

R2XO <- NULL;

R2XC <- NULL;



for (i in 1:(nox+1)){

    rss <- sum(diag( K[i,i][[1]]-Tp[[i]]%*%t(Tp[[i]]) ));    

    R2X <- c(R2X, 1 - rss/sstotK);

    

    rssc <- sum(diag( K[1,1][[1]]-Tp[[i]]%*%t(Tp[[i]]) ));    

    R2XC <- c(R2XC, 1 - rssc/sstotK );

    

    rsso <- sum(diag( K[i,i][[1]] ));    

    R2XO <- c(R2XO, 1 - rsso/sstotK );

  }



# should work but not fully tested (MB 2007-02-19)

sstotY <- sum(sum(Y*Y));

F<-Y-Up%*%t(Cp);

R2Y <- 1 - sum(sum( F*F))/sstotY;

#----------------------------------------





model<-list();

model$Cp<-Cp;

model$Sp<-Sp;

model$Sps<-Sps;

model$Up<-Up;

model$Tp<-Tp;

model$T<-as.matrix(Tp[[nox+1]]);

model$co<-co;

model$so<-so;

model$to<-to;

if (nox > 0) {

	model$To<-matrix(nrow=nrow(model$T), ncol=nox, data=unlist(to), byrow=FALSE)

} else {

	model$To<-NULL

}

model$toNorm<-toNorm;

model$Bt<-Bt;

model$A<-A;

model$nox<-nox;

model$K<-K;



#extra stuff

model$EEprime<-EEprime;

model$sstot_K<-sstotK;

model$R2X<-R2X;

model$R2XO<-R2XO;

model$R2XC<-R2XC;

model$sstot_Y<-sstotY;

model$R2Y<-R2Y;



##Pre-processing

model$preProc<-list()

model$preProc$K<-preProcK

model$preProc$Y<-preProcY

model$preProc$paramsY<-scale.params





class(model)<-"kopls"



return(model);

}

###########################################################################


#


# Plots diagnostic parameters from K-OPLS cross-validation.


# (R2X, R2Xcorr, R2Xortho, Q2Y).


#


# Authors: Mattias Rantalainen, Imperial College and 


#   Max Bylesj, Ume University


# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj


#


###########################################################################


#


# This file is part of the K-OPLS package.


#


# The K-OPLS package is free software; you can redistribute it and/or


# modify it under the terms of the GNU General Public License version 2


# as published by the Free Software Foundation.


#


# The K-OPLS package is distributed in the hope that it will be useful,


# but WITHOUT ANY WARRANTY; without even the implied warranty of


# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the


# GNU General Public License for more details.


#


###########################################################################





koplsPlotCVDiagnostics<-function(model.full, plot.values=FALSE, ...) {





	if (class(model.full) != "koplscv") {


		stop(paste("Unknown model type: '", class(model.full), "' (must be of type 'koplscv'). Aborting.", sep=""))


	}


	


	model<-model.full$koplsModel


	model$Q2<-model.full$cv$Q2Yhat


	


	koplsPlotModelDiagnostics(model, plot.values, ...)


}








###########################################################################


#


# Plots diagnostic parameters for a K-OPLS model.


# (R2X, R2Xcorr, R2Xortho, and optionally Q2Y).


#


# Authors: Mattias Rantalainen, Imperial College and 


#   Max Bylesj, Ume University


# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj


#


###########################################################################


#


# This file is part of the K-OPLS package.


#


# The K-OPLS package is free software; you can redistribute it and/or


# modify it under the terms of the GNU General Public License version 2


# as published by the Free Software Foundation.


#


# The K-OPLS package is distributed in the hope that it will be useful,


# but WITHOUT ANY WARRANTY; without even the implied warranty of


# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the


# GNU General Public License for more details.


#


###########################################################################





koplsPlotModelDiagnostics<-function(model, plot.values=FALSE, ...) {





	if (class(model) != "kopls") {


		stop(paste("Unknown model type: '", class(model), "' (must be of type 'kopls'). Aborting.", sep=""))


	}


	


	


	


	## Define labels


	labels<-paste("tp", 1:model$A, sep=",")


	if (model$nox > 0)


			labels<-c(labels, paste("to", 1:model$nox, sep=","))	


	


	## Plot


	layout.mat<-matrix(nrow=2, ncol=2, data=1:4, byrow=T)


	layout(layout.mat)


	b<-barplot(model$R2X, names.arg=labels, ylab="R2X (cumulative)", col="Green", xpd=FALSE)


	if (plot.values) {


		for (i in 1:length(b)) {


			par(new=T)


			text(x=b[i],y=(model$R2X[i]-0.05*sign(model$R2X[i])*max(model$R2X)),labels=paste( round(100*model$R2X[i],2), "%", sep=""), ...)


		}


	}


	


	b<-barplot(model$R2XO[2:length(model$R2XO)], names.arg=labels[2:length(model$R2XO)], ylab="R2Xortho (cumulative)", col="Blue")


	if (plot.values) {


		for (i in 1:length(b)) {


			par(new=T)


			text(x=b[i],y=(model$R2XO[i+1]-0.05*sign(model$R2XO[i+1])*max(model$R2XO)),labels=paste( round(100*model$R2XO[i+1],2), "%", sep=""), col="White", ...)


		}


	}





	b<-barplot(model$R2XC, names.arg=labels, ylab="R2Xcorr", col="Red")


	if (plot.values) {


		for (i in 1:length(b)) {


			par(new=T)


			text(x=b[i],y=(model$R2XC[i]-0.05*sign(model$R2XC[i])*max(model$R2XC)),labels=paste( round(100*model$R2XC[i],2), "%", sep=""), col="White", ...)


		}


	}





	if (!is.null(model$Q2))	{


		#browser()


		q2<-as.numeric(model$Q2)


		b<-barplot(q2, names.arg=labels, ylab="Q2Y", col="Yellow")


		if (plot.values) {


			for (i in 1:length(b)) {


				par(new=T)


				text(x=b[i],y=(q2[i]-0.05*sign(q2[i])*max(q2)),labels=paste( round(100*q2[i],2), "%", sep=""), ...)


			}


		}


		


	} else {


		plot.new()


		plot.window(c(0,1),c(0,1))


		text(0.5, 0.5, "Q2Y undefined (cross-validation not performed)", ...)


	}


	layout(1)





}








###########################################################################


#


# Plots scores for a K-OPLS model.


#


# If only the model is specified, all possible combinations of


# score vectors will be displayed as a scatter plot matrix.


#


# Otherwise, a scatter plot is displayed with the following settings:


# x = the vector number for the x axis


# xsub = the vector identifier {'p', 'o'} for the x axis


# y = the vector number for the y axis


# ysub = the vector identifier {'p', 'o'} for the y axis


#


# Authors: Mattias Rantalainen, Imperial College and 


#   Max Bylesj, Ume University


# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj


#


###########################################################################


#


# This file is part of the K-OPLS package.


#


# The K-OPLS package is free software; you can redistribute it and/or


# modify it under the terms of the GNU General Public License version 2


# as published by the Free Software Foundation.


#


# The K-OPLS package is distributed in the hope that it will be useful,


# but WITHOUT ANY WARRANTY; without even the implied warranty of


# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the


# GNU General Public License for more details.


#


###########################################################################





koplsPlotScores<-function(model, x=NA, xsub="p", y=NA, ysub="o", ...) {





	if (class(model) != "kopls") {


		stop(paste("Unknown model type: '", class(model), "' (must be of type 'kopls'). Aborting.", sep=""))


	}


	





	## The default visualization is a scatter plot matrix


	## of small multiples.


	## Diagonal depicts the density of a variable.


	if (is.na(x) | is.na(y)) {





		Tall<-model$T


		labels<-paste("tp", 1:model$A, sep=",")


			


		if (model$nox > 0) {


			Tall<-cbind(Tall, model$To)


			labels<-c(labels, paste("to", 1:model$nox, sep=","))


		} else {


			tos<-NULL


		}





		





		layout.mat<-matrix(nrow=ncol(Tall), ncol=ncol(Tall), data=1:(ncol(Tall)^2), byrow=T)


		#curr.margin<-par("mai")


		#par(mai=c(0.6, 0.5, 0.1, 0.1))


		layout(layout.mat)


		for (i in 1:ncol(Tall)) {


			for (j in 1:ncol(Tall)) {


			


				## Multiple arguments not supported here


				if (i == j) {


					plot(density(Tall[, i]), main="", ylab="Density", xlab=labels[i])


				} else {	


					plot(x=Tall[, i], y=Tall[, j], xlab=labels[i], ylab=labels[j], ...)


				}


			


			}


		}


		layout(1) #reset


		


	} else


	{


		if ( (xsub=="p" & x > model$A) | (xsub=="o" & x > model$nox) )


			stop("X variable outside range of model. Aborting.")


		


		if ( (ysub=="p" & y > model$A) | (ysub=="o" & y > model$nox) )


			stop("Y variable outside range of model. Aborting.")


		


		


		if (xsub=="p") {


			xvec<-model$T[,x]


		} else if (xsub=="o") {


			xvec<-model$To[,x]


		} else 	{


			stop(paste("Unknown model component specification for x : ", xsub, "; should be {o, p}. Aborting.", sep=""))


		}


		


		if (ysub=="p") {


			yvec<-model$T[,y]


		} else if (ysub=="o") {


			yvec<-model$To[,y]


		} else 	{


			stop(paste("Unknown model component specification for y : ", ysub, "; should be {o, p}. Aborting.", sep=""))


		}


		


		#browser()


		


		plot(x=xvec, y=yvec, xlab=paste("t", xsub, ",", x), ylab=paste("t", ysub, ",", y), ...)


	}





}








###########################################################################


# Plots sensitivity and specificity values from K-OPLS cross-validation.


# v = row vector of true class assignments (template)


# m = matrix (or row vector) of class assignments to be compared.


#


# Authors: Mattias Rantalainen, Imperial College and 


#   Max Bylesj, Ume University


# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj


#


###########################################################################


#


# This file is part of the K-OPLS package.


#


# The K-OPLS package is free software; you can redistribute it and/or


# modify it under the terms of the GNU General Public License version 2


# as published by the Free Software Foundation.


#


# The K-OPLS package is distributed in the hope that it will be useful,


# but WITHOUT ANY WARRANTY; without even the implied warranty of


# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the


# GNU General Public License for more details.


#


###########################################################################





koplsPlotSensSpec<-function(modelFull) {





	


	


	# Plots sensitivity (true positive rate) and specificity (true negative rate)


	# v = row vector of true class assignments (template)


	# m = matrix (or row vector) of class assignments to be compared.


	#


	# Max Bylesj


	# Research Group for Chemometrics


	# Department of Organic Chemistry


	# Ume University


	# Sweden





	if (class(modelFull) != 'koplscv')


	    stop("Unknown model type (must be of type 'koplscv'). Aborting.");


	end





	if (is.null(modelFull$da)) {


		stop("The cross-validation results are not for discriminant analysis. Aborting");


	}


	


	


	#res<-koplsSensSpec(modelFull$da$trueClass, modelFull$da$predClass);








	


	plot.mat<-matrix(ncol=2, nrow=length(modelFull$da$sensSpec), data=0)


	colnames(plot.mat)<-c("Sens", "Spec")


	rownames(plot.mat)<-paste("to", 0:modelFull$args$oax, sep=",")


	for (i in 1:nrow(plot.mat))


	{


		plot.mat[i, "Sens"]<-modelFull$da$sensSpec[[i]]$totalResults$sensTot;


		plot.mat[i, "Spec"]<-modelFull$da$sensSpec[[i]]$totalResults$specTot;


	}


	#browser()


	


	## Construct a matrix for plotting


	#num.classes<-length(res$classResults)


	#sens.vec<-rep(0, num.classes)


	#spec.vec<-rep(0, num.classes)


	#tot.vec<-rep(0, max(num.classes,2))


	#for (i in 1:num.classes) {


	#	sens.vec[i]<-res$classResults[[i]]$sens


	#	spec.vec[i]<-res$classResults[[i]]$spec


	#}


	#tot.vec[1]<-res$totalResults$sensTot


	#tot.vec[2]<-res$totalResults$specTot


	


	#plot.mat<-cbind(sens.vec, spec.vec, tot.vec)


	#rownames(plot.mat)<-paste("Class", 1:nrow(plot.mat), sep="")


	


	b<-barplot(t(plot.mat), beside=TRUE, legend=c("Sens.", "Spec."), ylab="Sens. and spec.(%)" );





	modelFull$da$sensSpec





}


###########################################################################

#

# Predictions of Y for a test kernel matrix based on a training model.

#

# * Input:

# KteTr = Xte*Xtr' kernel matrix

# Ktest = Xte*Xte' kernel matrix

# Ktrain = Xtr*Xtr' kernel matrix (same as used in model training)

# model = K-OPLS model object

# nox = number of Y-orthogonal components. If not specified, the number

#	used during model training will be employed.

# rescaleY = Boolean parameter. If true, Yhat is rescaled according to

#	the pre-processing settings of the model. If false, Yhat is not

#	rescaled (default).

#

# * Output:

# Tp = predicted predictive score matrix

# To = predicted Y-orthogonal score matrix

# EEprime = The deflated KteTe matrix, useful e.g for residual stats.

# Yhat = The predicted value of Y

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



koplsPredict<-function(KteTr,Ktest,Ktrain, model,nox=NA,rescaleY=FALSE){



if (class(model) != "kopls") {

	stop(paste("Unknown model type: '", class(model), "' (must be of type 'kopls'). Aborting.", sep=""))

}



## centering (order of these arg is important...)



KteTeMc<-Ktest;

if (model$preProc$K=='mc') {

	KteTeMc<-koplsCenterKTeTe(Ktest,KteTr,Ktrain);

}

KteTe<-matrix(list(),ncol=model$nox+1,nrow=model$nox+1);

#KteTe<-cell(model.nox+1,model.nox+1);

KteTe[1,1][[1]]<-KteTeMc;



KteTrMc<-KteTr;

if (model$preProc$K=='mc') {

	KteTrMc<-koplsCenterKTeTr(KteTr,Ktrain);

}

KteTrTmp<-matrix(list(),ncol=model$nox+1,nrow=model$nox+1);

KteTrTmp[1,1][[1]]<-KteTrMc;

KteTr<-KteTrTmp;





## init of Y-orth scores

to<-list();

Tp<-list();



## check if last arg is number of components to use in prediction:



if(!is.na(nox)){

  #nox already assigned

    if(nox>model$nox){

        warning('Number of Y-orthogonal components to use is higher than in model - setting number of Yorth to max in model');

        nox<-model$nox;

  }

} else {

    nox<-model$nox;

}



## KOPLS prediction



if(nox>0){

for(i in 1:nox){ #step1

    

    #step2



 

    Tp[[i]]<-KteTr[i,1][[1]]%*%model$Up%*%model$Sps;

  



    #Yhat[[i]]<-Tp[[i]]%*%model$Bt[[i]]%*%model$Cp';



    #step3

    to[[i]]<-(KteTr[i,i][[1]]-Tp[[i]]%*%t(model$Tp[[i]]))%*%model$Tp[[i]]%*%model$co[[i]]%*%model$so[[i]]^(-1/2);

    

    #step4

    to[[i]]<-to[[i]]/model$toNorm[[i]];



    # step 4$5 deflate KteTe. (this is an EXTRA feature - not in alg. in

    # paper )

    KteTe[i+1,i+1][[1]] <- KteTe[i,i][[1]] - KteTr[i,i][[1]]%*%model$to[[i]]%*%t(to[[i]]) - to[[i]]%*%t(model$to[[i]])%*% t(KteTr[i,i][[1]]) + to[[i]]%*%t(model$to[[i]])%*%model$K[i,i][[1]]%*%model$to[[i]]%*%t(to[[i]]);

    

    #step5

    KteTr[i+1,1][[1]]<-KteTr[i,1][[1]] -to[[i]]%*% t(model$to[[i]]) %*% t(model$K[1,i][[1]]);

    

    #step6

    KteTr[i+1,i+1][[1]]<-KteTr[i,i][[1]]-KteTr[i,i][[1]]%*% model$to[[i]]%*% t(model$to[[i]])-to[[i]]%*%t(model$to[[i]])%*%model$K[i,i][[1]]+to[[i]]%*%t(model$to[[i]])%*%model$K[i,i][[1]]%*%model$to[[i]]%*%t(model$to[[i]]);



}  #end for   #step7

}#end if nox



 if(nox==0){

     i<-0;

   }





Tp[[i+1]]<-KteTr[i+1,1][[1]]%*%model$Up%*%model$Sps;

#Yhat[[i+1]]<-Tp[[i+1]]%*%model$Bt[[i+1]]%*%t(model$Cp);

Yhat<-Tp[[i+1]]%*%model$Bt[[i+1]]%*%t(model$Cp);



if (rescaleY) {

	if (model$preProc$Y!='no' & model$preProc$Y!='none' ) {

		Yhat<-koplsRescale(model$preProc$paramsY, Yhat)

	} else {

		warning("Attempted re-scale of Yhat although no pre-processing parameters have been set.")

	}

}





#---- Extra stuff ----------------------------------

#this appears to be correct - but does not match previous code...

EEprime<-(KteTe[i+1,i+1][[1]]-Tp[[i+1]]%*%t(Tp[[i+1]])); 

#--------------------------------------------------

modelp<-list();

modelp$Tp<-Tp;

modelp$T<-Tp[[nox+1]];

modelp$to<-to;

#modelp$KteTr<-KteTr;

modelp$EEprime<-EEprime;

modelp$Yhat<-Yhat;

return(modelp);

 }

###########################################################################

#

# Reconstructs a (integer) class vector from a binary (dummy) matrix.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



"koplsReDummy" <-

function(dummy){

	

	#revert the dummy to original vector of class labels

	class<-matrix(NA,ncol=1,nrow=nrow(dummy));

	for(i in 1:ncol(dummy)){

		#if(any(!is.na(as.numeric(colnames(dummy))))){

		if (all(is.numeric(colnames(dummy)))) {

			class[dummy[,i]>0,1]<-as.numeric(colnames(dummy))[i];

		}

		else{

			#class[dummy[,i]>0,1]<-i;#assign class numbers(int)

			class[dummy[,i]>0,1]<-(colnames(dummy))[i];#assign class as strings based on labels in original class vector

		}

	}

return(class);

}

###########################################################################

#

# Scales a matrix based on pre-defined parameters from a scaling object.

#

# model = An object containing scaling parameters (see 'koplsScale()')

# x = If defined, this matrix will be scaled and returned.

#	Otherwise the original data set in the scaleS object will be scaled

#	and returned.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################



"koplsRescale" <-

function(model,x=NA){

	#model is scaled object

	#rescales the matrix according to object info

	center=model$center;

	scale=model$scale;

	sdevx=model$sdVector;

	meanVector=model$meanVector;

	if(!all(is.na(x))){

          #print('mjrRescale():using x from arg');

		x<-x;

	}

	else{

		x<-model$x;

	}

	if (!is.null(scale)) {

	

		if(scale=='uv'){

			x<-scale(x,center=FALSE,scale=1/sdevx);#x<-((x)%*%diag(sdevx));

		}

		if(scale=='pareto'){#scale to unit variance

			x<-scale(x,center=FALSE,scale=1/sqrt(sdevx));#x<-((x)%*%diag(sqrt(sdevx)));

		}

	}

	if (!is.null(center)) {

		if(as.logical(match(center,'mc',nomatch=0))){

			x<-x+ matrix(rep(meanVector,nrow(x)),nrow=nrow(x),byrow=TRUE);

		}	

	}

	return(x);

}#end rescaleMe



###########################################################################

#

# Scales a matrix.

# 

# * Input:

# X = X matrix (to be scaled)

# center = 'mc' for mean-centering, 'no' for no centering.

# scale = 'uv' for unit variance scaling, 'pa' for Pareto scaling,

#	'no' for no scaling.

# 

# *Output:

# An object with the following properties:

# - center

# - scale

# - meanVector = vector with mean values for columns in X

# - stdvx = vector with standard deviations for columns in X

# - x = scaled X

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################





"koplsScale" <-

function(x,center='mc',scale='none'){

	#x is matrix

	#center=TRUE or FALSE  -mean centering

	#scale= 'uv', 'pareto or 'none'



	meanVector<-apply(x,2,'mean');

	sdevx<-NULL;



	if(as.logical(match(center,'mc',nomatch=0))){



		x<-x-matrix(rep(meanVector,nrow(x)),nrow=nrow(x),byrow=TRUE);

	}

	if(scale=='uv'){#scale to unit variance

		sdevx<-sd(x);	

		      

		x<-scale(x,center=FALSE,scale=sdevx);#((x)%*%diag(1/sdevx));

	}

	if(scale=='pareto'){#scale to unit variance

		sdevx<-sd(x);	       

		x<-scale(x,center=FALSE,scale=sqrt(sdevx));#(x) %*% diag(1/sqrt(sdevx));

	}



	return(list(x=x,meanVector=meanVector,sdVector=(sdevx),scale=scale,center=center));

}

###########################################################################

#

# Applies scaling from external scaling objects ('see koplsScale()')

# on a matrix X.

# 

# * Input:

# model = An object containing scaling parameters (see 'koplsScale()')

# x = X matrix (to be scaled)

# 

# *Output:

# An object with e.g. the following properties:

# - x = scaled X

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################





"koplsScaleApply" <-

function(model,x){

	#model is the scaled data set

	#x is the new matrix to apply scaling to

	center=model$center;

	scale=model$scale;

	sdevx=model$sdVector;

	meanVector=model$meanVector;



	if(as.logical(match(center,'mc',nomatch=0))){

		x<-x-matrix(rep(meanVector,nrow(x)),nrow=nrow(x),byrow=TRUE);

	}

	if(scale=='uv'){#scale to unit variance

				x<-scale(x,center=FALSE,scale=sdevx);#x<-((x)%*%diag(1/sdevx));

			}

	if(scale=='pareto'){#scale to pareto variance

				x<-scale(x,center=FALSE,scale=sqrt(sdevx));#x<-((x)%*%diag(sqrt(1/sdevx)));

	}

	

	return(list(x=x,meanVector=meanVector,sdVector=sdevx,scale=scale,center=center));

	

}



###########################################################################

#

# Calculates sensitivity and specificity in a class-wise fashion.

# * Input:

# trueClass = row vector of true class assignments (template)

# predClass = matrix (or row vector) of class assignments to be compared.

#

# *Output:

# Object with the class-specific and total sensitivity and specificity.

#

# Authors: Mattias Rantalainen, Imperial College and 

#   Max Bylesj, Ume University

# Copyright (c) 2007 Mattias Rantalainen and Max Bylesj

#

###########################################################################

#

# This file is part of the K-OPLS package.

#

# The K-OPLS package is free software; you can redistribute it and/or

# modify it under the terms of the GNU General Public License version 2

# as published by the Free Software Foundation.

#

# The K-OPLS package is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

# GNU General Public License for more details.

#

###########################################################################





koplsSensSpec<-function(trueClass,predClass){







if(!is.data.frame(trueClass) || !is.matrix(trueClass)){

  trueClass<-as.matrix(trueClass);

}



if(!is.data.frame(predClass) || !is.matrix(predClass)){

  predClass<-as.matrix(predClass);

}



#if(dim(trueClass)!=NULL && dim(predClass)!=NULL && all(dim(trueClass)

  

 

#if class vectors, recreate 'dummy'....

  tmp1<-unique(as.vector(trueClass));

  tmp2<-unique(as.vector(predClass));

  

  if(ncol(trueClass)==1){

    trueClassDummy<-koplsDummy(trueClass);

    ## To make sure dummy is correct dimension for prediction data set

    predClassDummy<-koplsDummy(predClass, numClasses=ncol(trueClassDummy));

  }

  

#if(length(tmp1)==2 && length(tmp2)==2){

#  if(all(tmp1==c(0,1)) && all(tmp2==c(0,1))){

if(length(tmp1)==2){

  if(all(tmp1==c(0,1))){

    trueClassDummy<-(trueClass);

    predClassDummy<-(predClass);

  }

}

  else{

    #waRNING here... or further tests

	#browser()

	warning("Unexpected dimensionality of true class index")

  }

  





nclasses<-length(trueClassDummy[1,]);

results<-list(NULL);

if(length(predClassDummy[,1])!=length(trueClassDummy[,1]))

    error('Different number of observations in predClass and trueClass');

    return;

end





resultsTot<-list(NULL);

resultsTot$TPtot<-0;

resultsTot$FPtot<-0;

resultsTot$TNtot<-0;

resultsTot$FNtot<-0;

resultsTot$Ntot<-0;

tmpSens<-NULL;

tmpSpec<-NULL;





    for(i in 1:nclasses){

        ind<-which(trueClassDummy[,i]==1); #true ind

        indPred<-which(predClassDummy[,i]==1); #pred ind

        indN<-which(trueClassDummy[,i]==0); #true ind

        indPredN<-which(predClassDummy[,i]==0); #pred

        

        results[[i]]<-list(NULL);

        results[[i]]$TP<-length(intersect(ind,indPred));

        results[[i]]$TN<-length(intersect(indN,indPredN));



        results[[i]]$N<-length(trueClassDummy[,i]);



        results[[i]]$FP<-length(setdiff(indPred,ind));

        results[[i]]$FN<-length(setdiff(indPredN,indN));

 

        results[[i]]$sens<-results[[i]]$TP/(results[[i]]$TP+results[[i]]$FN);

		if (!is.finite(results[[i]]$sens)) {

			results[[i]]$sens<-0;

		}

        results[[i]]$spec<-results[[i]]$TN/(results[[i]]$TN+results[[i]]$FP);

		if (!is.finite(results[[i]]$spec)) {

			results[[i]]$spec<-0;

		}

		

		tmpSens<-c(tmpSens,results[[i]]$sens);

		tmpSens[ which(!is.finite(tmpSens)) ]<-0;

		tmpSpec<-c(tmpSpec,results[[i]]$spec);

		tmpSpec[ which(!is.finite(tmpSpec)) ]<-0;

		

        results[[i]]$class<-i;

        

        #total

        resultsTot$TPtot<-resultsTot$TPtot+results[[i]]$TP;      

        resultsTot$FPtot<-resultsTot$FPtot+results[[i]]$FP;

        resultsTot$Ntot<-resultsTot$Ntot+results[[i]]$N;

        resultsTot$TNtot<-resultsTot$TNtot+results[[i]]$TN;

        resultsTot$FNtot<-resultsTot$FNtot+results[[i]]$FN;



        if(i==nclasses){#last class is done..

            resultsTot$sensTot<-resultsTot$TPtot/(resultsTot$TPtot+resultsTot$FNtot);

			if (!is.finite(resultsTot$sensTot)) { ## May actually happen

				resultsTot$sensTot<-0

			}

            resultsTot$specTot<-resultsTot$TNtot/(resultsTot$TNtot+resultsTot$FPtot);

			if (!is.finite(resultsTot$specTot)) {

				resultsTot$specTot<-0

			}

			

			resultsTot$meanSens<-mean(tmpSens);

			resultsTot$meanSpec<-mean(tmpSpec);

			

          }

      

      }



return(list(classResults=results,totalResults=resultsTot));

}

