R/predict.kernelFactory.R

In kernelFactory: Kernel Factory: An Ensemble of Kernel Machines

#' Predict method for kernelFactory objects
#'
#' Prediction of new data using kernelFactory.
#' 
#' @param object An object of class \code{kernelFactory}, as created by the function \code{kernelFactory}
#' @param newdata A data frame with the same predictors as in the training data.
#' @param predict.all TRUE or FALSE. If TRUE and rp and cp are 1 then the individual predictions of the random forest are returned. If TRUE and any of rp and cp or bigger than 1 then the predictions of all the members are returned.
#' @param ... Not used currently.
#' 
#' @examples
#' #Credit Approval data available at UCI Machine Learning Repository
#' data(Credit)
#' #take subset (for the purpose of a quick example) and train and test
#' Credit <- Credit[1:100,]
#' train.ind <- sample(nrow(Credit),round(0.5*nrow(Credit)))
#' 
#' #Train Kernel Factory on training data
#' kFmodel <- kernelFactory(x=Credit[train.ind,names(Credit)!= "Response"], 
#'           y=Credit[train.ind,"Response"], method=random)
#'  
#' #Deploy Kernel Factory to predict response for test data
#' predictedresponse <- predict(kFmodel, newdata=Credit[-train.ind,names(Credit)!= "Response"])
#' @references Ballings, M. and Van den Poel, D. (2013), Kernel Factory: An Ensemble of Kernel Machines. Expert Systems With Applications, 40(8), 2904-2913.
#' @seealso \code{\link{kernelFactory}}
#' @return A vector containing the response probabilities.
#' @author Authors: Michel Ballings and Dirk Van den Poel, Maintainer: \email{Michel.Ballings@@GMail.com}
#' @method predict kernelFactory
#' @keywords classification
predict.kernelFactory <-
function(object, 
   newdata=NULL, predict.all=FALSE, ...  )
{
  
  newdata <- newdata[,!object$constants]
  
  #ERROR HANDLING
  if (!inherits(object, "kernelFactory")) stop("object not of class kernelFactory")
  
  if (is.null(object)) stop("You must provide the name of the model through object.")
  if (is.null(newdata)) {
  stop("Data cannot be NULL.")
  }else if (any(is.na(newdata))){
  stop("NAs not permitted.")
  }
  if(all(colnames(object$trn[,names(object$trn)!= "Y"]) %in% colnames(newdata))==FALSE ) stop("Column names have to be equal in data and new data.")


 
#STEP1 ### SCALING 

  numericcolumns <- newdata[,object$nmDtrn]
  numericcolumns <- data.frame(base::scale(numericcolumns,center=FALSE,scale=object$rngs))
  
  
  #add factor variables
  facID <- sapply(newdata,is.factor)
  if (sum(facID) >= 1){
    
    newdata <- data.frame(numericcolumns,newdata[,facID])
   
    # in case there is only 1 factor: set colnames
    colnames(newdata) <-  c(colnames(numericcolumns),names(facID)[facID])
  } else {
        
		newdata <- data.frame(numericcolumns)
		
  }
  
  
  rm(numericcolumns)


## ORDER VARIABLES ACCORDING TO TRAINING SET
newdata <- newdata[,colnames(object$trn[,names(object$trn)!= "Y"])]


#STEP3 ### CREATE PARTITIONS 


testlist <- list()
colparts <- object$cpr
rowparts <- object$rpr

startcol <- 1
counter <- 0
#HANDLE UNEVEN NUMBER OF VARIABLES

if (ncol(newdata)%%colparts > 0) {
numbercols <- ncol(newdata)-(ncol(newdata)%%colparts )
} else {
numbercols <-  ncol(newdata)  }



for (i in 1:colparts ){

  
endcol <-(i/colparts )*numbercols 
if (i==colparts ) endcol <- ncol(newdata)

startrow <- 1
for (j in 1:rowparts) {
counter = counter + 1

testlist[[counter]] <- newdata[,c(startcol:endcol)]



}

startcol <- endcol + 1
}

#STEP4 ### SCORING


#STEP 5.1 PREPARING 
predicted <- list()
resultsKIRFScored <- list()
for (i in 1:object$cntr) {                


if (is.null(testlist[[i]][,sapply(testlist[[i]],is.numeric)]) == FALSE) {


#Extract split variables for all trees: these are observation numbers from the trainingdata: split observations
trainobs <- object$trnlst[[i]][,sapply(object$trnlst[[i]],is.numeric)]



           
#compute dot product per split observation from training data with all validation observations: This results in 1 column per split observation
resultsKIRFScored[[i]] <- data.frame(data.frame(kernelMatrix(object$rbfstre[[i]], as.matrix(testlist[[i]][,sapply(testlist[[i]],is.numeric)]),as.matrix(trainobs))),
data.frame(testlist[[i]]))
                 
          
colnames(resultsKIRFScored[[i]]) <- colnames(object$rbfmtrX[[i]])

#STEP 5.2 ACTUAL PREDICTION
    if (predict.all && object$cpr==1 && object$rpr==1 ) { # predict.all
    predicted[[i]]  <- data.frame(sapply(data.frame(predict(object$rsltsKF[[i]], 
                                                        resultsKIRFScored[[i]],type="prob", 
                                                        predict.all=TRUE)$individual,
                                                stringsAsFactors=FALSE),
                                     as.integer,
                                     simplify=FALSE)
                              )
  } else { #combined prediction
    predicted[[i]] <- predict(object$rsltsKF[[i]],resultsKIRFScored[[i]],type="prob")[,2]
  }


} else {
  
  if (predict.all && object$cpr==1 && object$rpr==1 ) { #predict.all
    predicted[[i]]  <- data.frame(sapply(data.frame(predict(object$rsltsKF[[i]], 
                                                        testlist[[i]],type="prob", 
                                                        predict.all=TRUE)$individual,
                                                stringsAsFactors=FALSE),
                                     as.integer,
                                     simplify=FALSE)
                              )
  } else { #combined prediction
    predicted[[i]] <- predict(object$rsltsKF[[i]],testlist[[i]],type="prob")[,2]
  }

}
}

if (predict.all && object$cpr==1 && object$rpr==1  ) {
  return(predicted[[1]])
} else {
  
    #STEP 5.3 COLLECTING PREDICTIONS
    final <- data.frame(matrix(nrow=nrow(newdata),ncol=(object$cntr)))
    for (i in 1:object$cntr) {
    final[,i] <- predicted[[i]]
    }

    
    #STEP 5.4 APPLYING WEIGHTS  
    res <- t(as.numeric(object$wghts) * t(final))

    if (predict.all) {
      return(data.frame(final))
    } else {
      return(rowSums(res))
    }
}
  
}