R/predict.credpart.R

In evclust: Evidential Clustering

#' Computation of a credal partition for new data
#'
#' \code{predict.credpart} is the \code{predict} method for \code{"credpart"} 
#' objects generated by \code{nnevclus} or \code{ecm}.
#'
#' This function computes a credal partial of newdata based on learnt information stored 
#' in a \code{"credpart"} objects created by \code{\link{ecm}} or \code{\link{nnevclus}}.
#'
#' @param object An object of class \code{"credpart"}, encoding a credal partition.
#' @param newdata A matrix of size ntest*p containing the new data.
#' @param fhat An optional vector of one-class SVM outputs (for method nn-evclus only)
#' @param ... Additional arguments (not used).
#'
#' @return A credal partition of the new data.
#'
#' @export
#' @method predict credpart
#'
#' @seealso \code{\link{ecm}}, \code{\link{cecm}}, \code{\link{nnevclus}}.
#'
#' @references
#' T. Denoeux and O. Kanjanatarakul. Beyond Fuzzy, Possibilistic and Rough: An
#' Investigation of Belief Functions in Clustering. 8th International conference on soft
#' methods in probability and statistics, Rome, 12-14 September, 2016.
#'
#' M.-H. Masson and T. Denoeux. ECM: An evidential version of the fuzzy c-means algorithm.
#' Pattern Recognition, Vol. 41, Issue 4, pages 1384--1397, 2008.
#'
#'T. Denoeux, S. Sriboonchitta and O. Kanjanatarakul. Evidential clustering of large
#'dissimilarity data. Knowledge-Based Systems, vol. 106, pages 179-195, 2016.
#'
#' @examples
#' \dontrun{
#' data(fourclass)
#' train<-sample(400,200)
#' x<-fourclass[train,1:2]
#' x.test<-x[-train,1:2]
#' clus<-ecm(x,c=4,type='pairs',delta=sqrt(10),epsi=1e-3,disp=TRUE)
#' clus.test<-predict(clus,x.test)
#' plot(clus.test,x.test,mfrow=c(2,2))
#' }
predict.credpart<-function(object,newdata,fhat=NULL,...){
  clus<-object
  x<-as.matrix(newdata)
  n<-nrow(x)
  d <- ncol(x)
  c<-ncol(clus$F)
  f<-nrow(clus$F)
  
  if(clus$method=="nn-evclus"){
    X<-cbind(rep(1,n),x)
    if(is.null(clus$param$U)){ # Only one hidden layer
      n_H<-nrow(clus$param$V)
      Zeros<-matrix(0,n,n_H)
      # Propagation
      A<-X%*%t(clus$param$V)
      Z<-cbind(rep(1,n),pmax(Zeros,A))
      alpha<-Z%*%t(clus$param$W)
#      mass<-exp(alpha)
      mass<-exp(alpha-apply(alpha,1,max))
      mass<-mass/rowSums(mass)
      if(is.null(fhat)) gam<-rep(0,n) else{
        eta<-log(1+exp(clus$param$beta[1]+clus$param$beta[2]*fhat))
        gam<-eta/(1+eta)
        mass<-cbind(gam+(1-gam)*mass[,1],matrix(1-gam,n,f-1)*mass[,2:f])
      }
    } else{  # Two hidden layers
      n_H=c(nrow(clus$param$U),nrow(clus$param$V))
      Zeros1<-matrix(0,n,n_H[1])
      A1<-X%*%t(clus$param$U)
      Z1<-cbind(rep(1,n),pmax(Zeros1,A1)) # size(n,n_H[1]+1)
      Zeros2<-matrix(0,n,n_H[2])
      A2<-Z1%*%t(clus$param$V)
      Z2<-cbind(rep(1,n),pmax(Zeros2,A2)) # size(n,n_H[2]+1)
      alpha<-Z2%*%t(clus$param$W)
      mass<-exp(alpha-apply(alpha,1,max))
      mass<-mass/rowSums(mass)
      if(is.null(fhat)) gam<-rep(0,n) else{
        betafhat<-clus$param$beta[1]+clus$param$beta[2]*fhat
        eta<-log(1+exp(betafhat))
        gam<-eta/(1+eta)
        mass<-cbind(gam+(1-gam)*mass[,1],matrix(1-gam,n,f-1)*mass[,2:f])
      }
    }
    clus.test<-extractMass(mass=mass,F=clus$F,method="predict_nn-evlus",
                           crit=clus$crit,param=clus$param)
  } else if (clus$method=="ecm"){
    card<- rowSums(clus$F[2:f,])
    gplus<-matrix(0,f-1,d)
    for(i in 2:f){
      fi <- clus$F[i,]
      truc <- matrix(fi,c,d)
      gplus[i-1,] <- colSums(clus$g*truc)/sum(fi)
    } #end for i
    # calculation of distances to centers
    D<-matrix(0,n,f-1)
    for(j in 1:(f-1)) D[,j]<- rowSums((x-matrix(gplus[j,],n,d,byrow = TRUE))^2)
    alpha<-clus$param$alpha
    beta<-clus$param$beta
    delta<-clus$param$delta
    delta2<-delta^2
    # Calculation of masses
    m <- matrix(0,n,f-1)
    for(i in 1:n){
      vect0 <- D[i,]
      for(j in 1:(f-1)){
        vect1 <- (rep(D[i,j],f-1)/vect0) ^(1/(beta-1))
        vect2 <-  rep(card[j]^(alpha/(beta-1)),f-1) /(card^(alpha/(beta-1)))
        vect3 <- vect1 * vect2
        m[i,j]<- 1/(  sum(vect3) + (card[j]^alpha * D[i,j]/delta2)^(1/(beta-1))  )
      }
    }
    mvide <- 1-rowSums(m)
    m<-cbind(mvide,m)
    clus.test<-extractMass(mass=m,F=clus$F,g=clus$g,param=list(alpha=clus$alpha,beta=clus$beta,
                       delta=clus$delta),method="predict_ecm",crit=clus$crit)
  } else {
    print("Error: no prediction for this type of credal partition")
    clus.test<-NULL
    }
  return(clus.test)
}