.packageName <- "marginTree"
#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.R"
marginTree=function(x,y, method="complete",   n.threshold=20, predict.trainingset=TRUE){

require(e1071)
y=as.character(y)
n=ncol(x)
ynams=unique(y)

# the input x is n by p; make it p by n for convenience
x=t(x)
xs=transf(x)

cat("Computing pairwise margins",fill=T)
marg.obj=compute.marg.matrix(xs,y)

marg.tree=hclust(as.dist(marg.obj$marg),method=method)

junk=compute.splitters(marg.tree,x,xs,y)


return.list=list(marg.obj=marg.obj,marg.tree=marg.tree,svm.splitters=junk$svm.splitters, plot.heights=junk$plot.heights, nclasses=length(table(y)), nlist=junk$nlist, ynams=ynams)

minrat=getmin.ratio(return.list)
#minrat=max(minrat,0)

threshold=NULL
err=NULL
yhat=NULL
nonzero=NULL
if(predict.trainingset){
cat("Computing thresholded estimates",fill=T)
threshold=seq(1,minrat,length=n.threshold)
err=rep(NA,n.threshold)
nonzero=rep(NA,n.threshold)
yhat=matrix(NA,nrow=length(y),ncol=n.threshold)
nonzero=rep(0,n.threshold)
for(i in 1:n.threshold){
cat(c(i,".- Threshold=",round(threshold[i],4)),fill=T)
 yhat[,i]= marginTree.predict(return.list,t(x),threshold[i])
 err[i]=sum(y!=yhat[,i])

 junk=marginTree.getnonzero(return.list, threshold[i])$feature.scores
 for(ii in 1:length(junk)){
   nonzero[i]=nonzero[i]+nrow(junk[[ii]])/length(junk)
  }
}
}


return.list$threshold=threshold
return.list$err=err
return.list$y=y
return.list$yhat=yhat
return.list$nonzero=nonzero
class(return.list)="marginTree"
return(return.list)

}
#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.confusion.R"
marginTree.confusion <- function(train.obj, threshold, extra = TRUE) {
  temp=abs(train.obj$threshold -threshold)
  ii <- (1:length(train.obj$threshold))[temp==min(temp)]
  ii <- ii[1]
  predicted <- train.obj$yhat[, ii]
  
  true <- train.obj$y
  tt <- table(true, predicted)

  if (extra) {
    tt1 <- tt
    diag(tt1) <- 0
    tt <- cbind(tt, apply(tt1, 1, sum)/apply(tt, 1, sum))
    dimnames(tt)[[2]][ncol(tt)] <- "Class Error rate"
    print(tt)
    cat(c("Overall error rate=", round(sum(tt1)/sum(tt), 3)),
        fill= TRUE)
  }
  if (!extra) {
    return(tt)
  }
}

which.is.max <- function(x)
{
        y <- seq(length(x))[x == max(x)]
        if(length(y) > 1)
                y <- sample(y, 1)
        y
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.cv.R"
marginTree.cv <- function(x, y, train.obj, nfold = min(table(y)), folds = NULL, threshold = NULL, n.threshold=20)

{
require(e1071)

y=as.character(y)

# the input x is n by p; make it p by n for convenience

        this.call <- match.call()
        n <- length(y)

if(is.null(nfold)) {nfold <- min(table(y))}

        if(is.null(folds)) {
                folds <- balanced.folds(y)
        }
         
nfold<- length(folds)

if(missing(threshold)) {
                if(missing(train.obj))
               stop("Must either supply threshold argument, or an marginTree train.obj")
        }

       
minrat=getmin.ratio(train.obj)
#minrat=max(minrat,0)

threshold=seq(1,minrat,length=n.threshold)

        n.threshold <- length(threshold)        ### Set up the data structures
        yhat <- matrix(NA,nrow=n,ncol= n.threshold)
        dimnames(yhat)[[2]] <- paste(seq(n.threshold))
        n.class <- table(y)
        size <- double(n.threshold)

        for(ii in 1:nfold) {
                cat("Fold", ii, ":")
b2=marginTree(x[-folds[[ii]],],y[-folds[[ii]]],method="complete", predict.trainingset=F)


          for(j in 1:n.threshold){
        yhat[folds[[ii]],j]=marginTree.predict(b2,x[folds[[ii]],,drop=F],threshold=threshold[j])
        }}

        error <- rep(NA, n.threshold)
        
        for(i in 1:n.threshold) {
               error[i] <- sum(yhat[, i] != y)/n
                }
# find # genes used at each tree split

size.indiv=matrix(NA,nrow=length(train.obj$svm.splitters),ncol=n.threshold)
for(j in 1:n.threshold){
for( i in 1:length(train.obj$svm.splitters)){
  a=train.obj$svm.splitters[[i]]
 rat=a$margshrink[,2]/max(a$margshrink[,2])
rat[1]=1
 o=(1:length(rat))[rat>=threshold[j]]
         o=o[length(o)]
         o[is.na(o)]=length(rat)
         size.indiv[i,j]=a$margshrink[o,1]
}}
size=apply(size.indiv,2,mean)




obj<- list(threshold=threshold, error=error,  size=size, size.indiv=size.indiv, yhat=yhat,y=y,folds=folds, 
                call = this.call)
        class(obj) <- "marginTreecv"
        obj
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.getnonzero.R"
marginTree.getnonzero=function(train.obj,threshold){
nn=nrow(train.obj$marg.tree$merge)
feature.scores=vector("list",nn)
left.classes=vector("list",nn)
right.classes=vector("list",nn)

ynams=train.obj$ynams

for(i in 1:nn){
 a=train.obj$svm.splitters[[i]]
        bb=a$beta
        rat = a$margshrink[, 2]/max(a$margshrink[, 2])
        o = (1:length(rat))[rat >= threshold]
        o = o[length(o)]
        o[is.na(o)] = length(rat)
        temp = a$margshrink[o, 1]
        r = rank(-abs(bb))
        bb[r > temp] = 0 
        bb = bb/sqrt(sum(bb^2))
        ord=order(-abs(bb[bb!=0]))
feature.scores[[i]]=cbind((1:length(bb))[bb!=0], bb[bb!=0])[ord,]
dimnames(feature.scores[[i]])=list(NULL,c("Feature#", "Weight"))

left.classes[[i]]=ynams[my.descendants(train.obj$marg.tree$merge,i,1)]
right.classes[[i]]=ynams[my.descendants(train.obj$marg.tree$merge,i,2)]
    }

return.list=list(feature.scores=feature.scores,left.classes=left.classes,
right.classes=right.classes)
class(return.list)="marginTreegetnonzero"
return(return.list)
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.morefuns.R"
mypredict=function(a,x,threshold){
# prediction with thresholded betas
# takes object "a" from compute.splitters
beta=a$beta

vars=1:ncol(x)
meanx=rep(0,ncol(x))
mu=0
cutp=a$cutp
dir=a$dir

if(threshold<1){
 rat=a$margshrink[,2]/max(a$margshrink[,2])
         o=(1:length(rat))[rat>=threshold]
         o=o[length(o)]
         o[is.na(o)]=length(rat)
         temp=a$margshrink[o,1]
         r=rank(-abs(beta))
         beta[r>temp]=0
         beta=beta/sqrt(sum(beta^2))
         cutp=a$cutp.shrink[o]
         dir=a$dir.shrink[o]
}


nbetas<<-c(nbetas,sum(beta!=0))
yhat=scale(x[,vars,drop=F],meanx,FALSE)%*%beta +mu
if(dir==1){ yhatt=-1+2*(yhat>cutp)}
if(dir== -1){yhatt=1-2*(yhat>cutp)}
return(yhatt)
}
margfunc=function(x,y,a=NULL){
if(is.null(a)){
#  a=mysvm(t(x),y,K=10e99, cxx=cxx)
  a=svm(t(x),as.factor(y),cost=10e99, scale=F,  kernel="linear")
}
#beta=a$beta
beta = x[, a$index] %*% a$coefs
margin=2/sqrt(sum(beta^2))
return(list(margin=margin, svmfit=a))
}


getmin.ratio=function(a){
nn=length(a$svm.splitters)
rat=NULL
for(i in 1:nn){
val=a$svm.splitters[[i]]$margshrink[,2]
rat=c(rat,min(val)/max(val))
}
return(min(rat))
}


compute.splitters=function(marg.tree,x,xs,y, compute.ngenes=TRUE ){
cat("Computing splitters",fill=T)
n=length(y)
nams=unique(y)
nsplits=nrow(marg.tree$merge)
nlist=NULL
svm.splitters=vector("list",nsplits)
for(i in 1:nsplits){
cat(c("Split=",i),fill=T)
   o1=my.descendants(marg.tree$merge,i,1)
   o2=my.descendants(marg.tree$merge,i,2)
   oo1=NULL;oo2=NULL
   for(ii  in 1:length(o1)){
     oo1=c(oo1,(1:n)[y==nams[o1[ii]]])
   }
   for(ii in 1:length(o2)){
     oo2=c(oo2,(1:n)[y==nams[o2[ii]]])
   }

   xxs=xs[,c(oo1,oo2)]
   xx=x[,c(oo1,oo2)]
   yy=c(rep(-1,length(oo1)),rep(1,length(oo2)))
#   svm.splitters[[i]]=mysvm(t(xx),yy,K=10e99,cxx=cxxtemp)
svm.splitters[[i]]=svm(t(xxs),as.factor(yy),cost=10e99, scale=F,  kernel="linear")

marg=margfunc(xxs,as.factor(yy),svm.splitters[[i]])$marg
a=svm.splitters[[i]]
beta=xx[,a$index]%*%a$coefs
#beta=a$beta

svm.splitters[[i]]$left.classes=o1
svm.splitters[[i]]$right.classes=o2
svm.splitters[[i]]$left.ind=oo1
svm.splitters[[i]]$right.ind=oo2

if(compute.ngenes){

 r=rank(-abs(beta))
nlist=trunc(exp(seq(log(nrow(x)),log(2),length=50)))
nlist=nlist[nlist>10]

margshrink=matrix(NA,nrow=length(nlist),ncol=2)

ii=0
dir.shrink=NULL
cutp.shrink=NULL
for(ngenes in nlist){
temp=beta
oo=r<=ngenes
temp=temp[oo]
temp=temp/sqrt(sum(temp^2))
yhat=t(xx[oo,])%*%temp
ii=ii+1
if(mean(yhat[yy==1]) > mean(yhat[yy==-1])) {
   gap=min(yhat[yy==1])-max(yhat[yy==-1])
   cutp.shrink=c(cutp.shrink,max(yhat[yy==-1])+gap/2)
   dir.shrink=c(dir.shrink,1)
}
else{
   gap=min(yhat[yy==-1])-max(yhat[yy==1])
   cutp.shrink=c(cutp.shrink,max(yhat[yy==1])+gap/2)
   dir.shrink=c(dir.shrink,-1)
}
margshrink[ii,]=c(ngenes,gap)


}
svm.splitters[[i]]$margshrink=margshrink
svm.splitters[[i]]$cutp.shrink=cutp.shrink
svm.splitters[[i]]$dir.shrink=dir.shrink
}


yhat0=t(xx)%*%beta

if(mean(yhat0[yy==1]) > mean(yhat0[yy==-1])) {
   gap=min(yhat0[yy==1])-max(yhat0[yy==-1])
   cutp=max(yhat0[yy==-1])+gap/2
   dir=+1
}
else{
   gap=min(yhat0[yy==-1])-max(yhat0[yy==1])
   cutp=max(yhat0[yy==1])+gap/2
   dir=-1
 }
 svm.splitters[[i]]$marg=marg
 svm.splitters[[i]]$cutp=cutp
 svm.splitters[[i]]$dir=dir
svm.splitters[[i]]$beta=beta
}

# compute heights for plotting tree
marg=NULL
for(i in 1:length(svm.splitters)){
marg=c(marg,svm.splitters[[i]]$marg)
}

plot.heights=rep(0,length(marg))
for(i  in length(marg):1){
  o1=marg.tree$merge[i,1]
  o2=marg.tree$merge[i,2]
if(o1>0){plot.heights[o1]=plot.heights[i]-marg[i]}
if(o2>0){plot.heights[o2]=plot.heights[i]-marg[i]}

}

plot.heights=plot.heights-min(plot.heights)

return(list(marg.tree=marg.tree,svm.splitters=svm.splitters, plot.heights=plot.heights, nclasses=length(table(y)), nlist=nlist))
}



 descendants <- function(m,k){
  # the done object indicates what rows of m were used
    done <- k
    if (m[k,1]<0) left <- -m[k,1]
    else {
      junk <- descendants(m,m[k,1])
      left <- junk[[1]]
      done <- c(done,junk[[2]])
    }
    if (m[k,2]<0) right <- -m[k,2]
    else {
      junk <- descendants(m,m[k,2])
      right <- junk[[1]]
      done <- c(done,junk[[2]])
    }
    return(list(c(left,right),done))
  }
my.descendants<- function(m,j,k){
  #returns descendants of merge element m[j,k]
  #uses a kluge in order to make us of "descendants" function

  if(k==1){m[j,2]<- -99999}
  if(k==2){m[j,1]<- -99999}
junk<- sort(descendants(m,j)[[1]])
return(junk[-length(junk)])
}


compute.marg.matrix=function(xs,y){
k=length(table(y))

n=ncol(xs)

svmfit=vector("list",k*(k-1)/2)
marg=matrix(NA,nrow=k,ncol=k)
nams=unique(y)
ii=0
for(i in 1:(k-1)){
for(j in (i+1):k){
cat(c(i,j),fill=T)
o=y==nams[i] | y==nams[j]
xx=xs[,o]
yy= 1-2*(y[o]==nams[i])
junk=margfunc(xx,yy)
marg[i,j]=junk$margin
ii=ii+1
svmfit[[ii]]=junk
dimnames(marg)=list(nams,nams)
}}
marg[is.na(marg)]=0
marg=marg+t(marg)
return(list(marg=marg,svmfit=svmfit))
}

balanced.folds <- function(y, nfolds = min(min(table(y)), 10)) {
   totals <- table(y)
   fmax <- max(totals)
   nfolds <- min(nfolds, fmax)
   nfolds= max(nfolds, 2)
         # makes no sense to have more folds than the max class size
   folds <- as.list(seq(nfolds))
   yids <- split(seq(y), y)
         # nice we to get the ids in a list, split by class
###Make a big matrix, with enough rows to get in all the folds per class
   bigmat <-matrix(NA, ceiling(fmax/nfolds) * nfolds, length(totals))
   for(i in seq(totals)) {
     if(length(yids[[i]])>1){bigmat[seq(totals[i]), i] <- sample(yids[[i]])}
     if(length(yids[[i]])==1){bigmat[seq(totals[i]), i] <- yids[[i]]}

   }
   smallmat <-matrix(bigmat, nrow = nfolds)# reshape the matrix
### Now do a clever sort to mix up the NAs
   smallmat <- permute.rows(t(smallmat))   ### Now a clever unlisting
         # the "clever" unlist doesn't work when there are no NAs
         #       apply(smallmat, 2, function(object)
         #        object[!is.na(object)])
   res <-vector("list", nfolds)
   for(j in 1:nfolds) {
     jj <- !is.na(smallmat[, j])
     res[[j]] <- smallmat[jj, j]
   }
   return(res)
 }


permute.rows <-function(x)
{
        dd <- dim(x)
        n <- dd[1]
        p <- dd[2]
        mm <- runif(length(x)) + rep(seq(n) * 10, rep(p, n))
        matrix(t(x)[order(mm)], n, p, byrow = TRUE)
}

print.marginTree <- function(x, ...) {
  cat("Call:\n")
  dput(x$call)
  mat <- rbind(threshold = format(round(x$threshold, 3)), number_of_features = 
               format(trunc(x$nonzero)), errors = x$err)
  dimnames(mat) <- list(dimnames(mat)[[1]], paste(1:ncol(mat)))
  print(t(mat), quote = FALSE)
  invisible()
}


 print.marginTreecv <-function(x, ...) {
   cat("Call:\n")
   dput(x$call)
  
   mat <- rbind(threshold = format(round(x$threshold, 3)), number_of_features = 
                format(trunc(x$size)), errors = trunc(x$err * nrow(
                                              x$yhat)))
   dimnames(mat) <- list(dimnames(mat)[[1]], paste(1:ncol(mat)))
 
 cat("\n")
   print(t(mat), quote = FALSE)
   invisible()
}

print.marginTreegetnonzero <-function(x, ...) {
   cat("Call:\n")

   m=length(x$feature.scores)
for( i in m:1){
    s1=NULL
    for(ii in 1:length(x$left.classes[[i]])){
         s1=paste(s1,x$left.classes[[i]][ii])
    }
    s2=NULL
    for(ii in 1:length(x$right.classes[[i]])){
         s2=paste(s2,x$right.classes[[i]][ii])
    }

   titl=paste("Split: ", as.character(i), ", classes ", s1," vs " , s2,sep="")
   
cat("\n")
cat("\n")
print(titl,quote=FALSE)
cat("\n")
print(x$feature.scores[[i]],quote=FALSE)
}
   invisible()
}

summary.marginTreegetnonzero <-function(object, ...) {
   cat("Call:\n")

   m=length(object$feature.scores)
for( i in m:1){
    s1=NULL
    for(ii in 1:length(object$left.classes[[i]])){
         s1=paste(s1,object$left.classes[[i]][ii])
    }
    s2=NULL
    for(ii in 1:length(object$right.classes[[i]])){
         s2=paste(s2,object$right.classes[[i]][ii])
    }

   titl=paste("Split: ", as.character(i), ", classes ", s1," vs " , s2,sep="")

cat("\n")
cat("\n")
print(titl,quote=FALSE)
cat("Top features\n")
nn=min(5,nrow(object$feature.scores[[i]]))
print(object$feature.scores[[i]][1:nn,],quote=FALSE)
}
   invisible()
}



transf=function(x,xx=NULL){
svd.tr=svd(t(x))
svalue <- svd.tr$d
  svaluePos <- seq(svalue)[svalue > 0]
 svalue <- svalue[svaluePos]
if(is.null(xx)){xs=t(scale(svd.tr$u[,svaluePos],center=F,scale=1/svalue))
    result=xs
}
 
if(!is.null(xx)){xxs=t(t(xx)%*%svd.tr$v)
          result=xxs
}
return(result)
}
     
mysvd<-function(x,  n.components=NULL){
# finds PCs of matrix x
  p<-nrow(x)
  n<-ncol(x)

# center the observations (rows)

 feature.means<-rowMeans(x)
x<- t(scale(t(x),center=feature.means,scale=F))


  if(is.null(n.components)){n.components=min(n,p)}
  if(p>n){
    a<-eigen(t(x)%*%x)
    v<-a$vec[,1:n.components,drop=FALSE]
    d<-sqrt(a$val[1: n.components,drop=FALSE])
    
      u<-scale(x%*%v,center=FALSE,scale=d)
 
    
    return(list(u=u,d=d,v=v,  feature.means=feature.means))
  }
  else{

      junk<-svd(x,LINPACK=TRUE)
      nc=min(ncol(junk$u), n.components)
      return(list(u=junk$u[,1:nc],d=junk$d[1:nc],
                  v=junk$v[,1:nc], feature.means=feature.means))
}
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.plclust.R"
marginTree.plclust=function(train.obj, ...){
if(train.obj$nclasses==2){
stop("No cluster tree is  available since there are only 2 classes in the data")
}
else{
marg.tree=train.obj$marg.tree
marg.tree$height=train.obj$plot.heights

plclust(marg.tree,sub="",xlab="",frame.plot=T)
}

}

#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.plotcv.R"
marginTree.plotcv <- function(cv.obj) {
  par(mar = c(5, 5, 5, 1))
  par(mfrow = c(2, 1))
  n <- nrow(cv.obj$yhat)
  y <- cv.obj$y
  nc <- length(table(y))
  nfolds <- length(cv.obj$folds)
  err <- matrix(NA, ncol = ncol(cv.obj$yhat), nrow = nfolds)
  temp <- matrix(y, ncol = ncol(cv.obj$yhat), nrow = n)
  ni <- rep(NA, nfolds)
  for(i in 1:nfolds) {
    ii <- cv.obj$folds[[i]]
    ni[i] <- length(cv.obj$folds[[i]])
    err[i,  ] <- apply(temp[ii,  ] != cv.obj$yhat[ii,  ], 2, sum)/ni[i]
  }
  se <- sqrt(apply(err, 2, var)/nfolds)
  plot(cv.obj$threshold, cv.obj$error, ylim = c(-0.1, 0.8), xlab = 
       "Value of threshold  ", ylab = "Misclassification Error", type
       = "n", yaxt = "n")
  axis(3, at = cv.obj$threshold, lab = paste(cv.obj$size), srt = 90, adj = 0)
  mtext("Number of features", 3, 4, cex = 1.2)
  axis(2, at = c(0, 0.2, 0.4, 0.6, 0.8))
  lines(cv.obj$threshold, cv.obj$error, col = 2)
  o <- cv.obj$err == min(cv.obj$err)
  points(cv.obj$threshold[o], cv.obj$error[o], pch = "x")
  error.bars(cv.obj$threshold, cv.obj$err - se, cv.obj$err + se)
  err2 <- matrix(NA, nrow = length(unique(y)), ncol = length(cv.obj$threshold
                                                 ))
  for(i in 1:(length(cv.obj$threshold) )) {
    s <- marginTree.confusion(cv.obj, cv.obj$threshold[i], extra = FALSE)
    diag(s) <- 0
    err2[, i] <- apply(s, 1, sum)/table(y)
  }
  plot(cv.obj$threshold, err2[1,  ],xlim=c(min(cv.obj$threshold),1.3), ylim = c(-0.1, 1.1), xlab = 
       "Value of threshold ", ylab = "Misclassification Error", type
       = "n", yaxt = "n")
  axis(3, at = cv.obj$threshold, lab = paste(cv.obj$size), srt = 90, adj = 0)     
  axis(2, at = c(0, 0.2, 0.4, 0.6, 0.8))
  for(i in 1:nrow(err2)) {
    lines(cv.obj$threshold, err2[i,  ], col = i + 1)
  }
  legend(1.1, 1.1, dimnames(table(y))[[1]], col = (2:(nc + 1)), lty = 1,cex=.6)
  par(mfrow = c(1, 1))
}

error.bars <-function(x, upper, lower, width = 0.02, ...) {
  xlim <- range(x)
  barw <- diff(xlim) * width
  segments(x, upper, x, lower, ...)
  segments(x - barw, upper, x + barw, upper, ...)
  segments(x - barw, lower, x + barw, lower, ...)
  range(upper, lower)
}

#line 1 "d:/RCompile/CRANpkg/local/2.13/marginTree/R/marginTree.predict.R"
marginTree.predict=function(train.obj,x,threshold=1){

require(e1071)
nbetas<<-NULL
# x is n by p; make it p by n for convenience
x=t(x)

nsplits=nrow(train.obj$marg.tree$merge)

predfunc=function(a,x1, ii){
  aa=1.5+.5*mypredict(train.obj$svm.splitters[[ii]],t(x1),threshold);
  
   if(train.obj$marg.tree$merge[ii,aa]<0){ pred= -train.obj$marg.tree$merge[ii,aa]}
   else{pred=predfunc(train.obj,x1,train.obj$marg.tree$merge[ii,aa])}
return(pred)
}


n=ncol(x)

yhat=rep(NA,n)
for(i in 1:n){
  yhat[i]=train.obj$ynams[predfunc(a,x[,i,drop=F],nsplits)]
}

return(yhat)
}
