.packageName <- "TreeRank"
#line 1 "d:/Rcompile/CRANpkg/local/2.12/TreeRank/R/LeafRank.R"
#################################################################################
#
# LeafRank functions : implementation of LeafRank classifiers:
#                         LRCart : a modified Cart classifier.
# 			    LRsvm : a svm classifier
#                          LRforest : cart-forest classifier
#################################################################################

#################################################################################
#  Guideline for a LeafRank implementation 
#   2 functions are needed :
#   LRMyClassifier(formula, data,bestresponse, wpos=0.5, weights = NULL) : return the model learned from data,  who fit the formula (R format), with the label bestresponse
#   as the wanted label; wpos denotes the weight of the positive label (bestresponse label) in data; weights is unused. Usually, the return type is "LRMyClassifier". 
#   predict.LRMyClassifier(object, newdata, ...) : predict the response of object, the model learned, on the data frame newdata. The return value is <0 for the best instances and >0 for the worstest.
#   Optionnaly, the function varImportance.LRMyClassifier(obj,norm=TRUE) can be implemented, which return a vector of the variables appearing in the induced model obj and their importance value (norm denotes when a normalisation has to be done or  not).
#
#
#################################################################################


#################################################################################
# LRCart functions
#
#################################################################################


#################################################################################
#
# predict.TR_LRCart(object, newdata, type) :
#                           object : LRCart object
#                           newdata : data to be predicted
#                           type : "node" to predict terminal nodes
#                                  otherwise -1 for best label, +1 for worst
#
#################################################################################


predict.TR_LRCart <- function(object, newdata,...)
{
  if (!inherits(object,"TR_LRCart"))
    stop("object not of class TR_LRCart");
  #tmp <- predict.party(object,newdata,type = "node")
  #if(!(is.null(type)))
   # if (type == "node")
   #   return(tmp);
  #pred <- array(sapply(tmp, function(x) {if (x %in% object$info$Lnode) -1 else 1}))
  #pred
  return(predict(object$fustree,newdata));
}


#################################################################################
#
#
# LRCartFusion(tree, pcInit,ncInit)
#    Reorder leafs for concavification purpose and merge leafs in two subsets
#
#    return : 2 lists, LeftNode set and RightNode set
#
#################################################################################


LRCartFusion <- function(tree,pcInit,ncInit){


  # Retrieve  informations on true postive and true negative
 
  listLeafs <- (1:tree$nbNode)[tree$isleaf];
  if (length(listLeafs) <2)
    {return(list(Lnode = tree$root, Rnode = 0))}
  betaList <- tree$pcount[listLeafs]
  alphaList <- tree$ncount[listLeafs]
   
  betaList <- betaList/pcInit;
  alphaList <- alphaList/ncInit;

  #Ratio list of  true positive and  false negative for each leaf
  crVec <- betaList/alphaList;

  #Reorder leafs
  listIndex <- order(-crVec)

  #Compute the cumulate vector of ratio TP and FN for each leaf
  alphaListOrd <- cumsum(alphaList[listIndex])
  betaListOrd <- cumsum(betaList[listIndex])
  
  #Compute entropy, find the best and divide leafs between right and left subset
  entropy <- betaListOrd-alphaListOrd
  Lnode <- listLeafs[listIndex[1:which.max(entropy)]]
  Rnode <- listLeafs[listIndex[as.integer(which.max(entropy)+1):length(listIndex)]]
  list(Lnode = Lnode, Rnode = Rnode)
}


#################################################################################
#
# LRCart(formula, data, bestresponse, weights, growing, pruning) : Main Cart function
#
#        formula, data, weights :
#        bestresponse: value of the label considered as best
#       wpos: positive examples weight
#        weights : unused
#
#       Return : a LeafRank Cart classifier, type TR_LRCart
#################################################################################
LRCart <- function(formula, data,bestresponse, wpos=0.5, weights = NULL,maxdepth=10,minsplit=50,mincrit=0,nfcv=0){
  
  evaluation <- function(y, wt, parms){
    idx <- y== bestresponse;
    pc <- sum(wt[idx])*(1-parms$pInit);
    nc <- sum(wt[!idx])*parms$pInit;
    label <- bestresponse;
    miss <- nc;
    if (nc>pc){
      label <-parms$neglab;
      miss <- pc;
    }
    return(list(label=label,deviance=miss))
  }

  split <- function(y,wt,x,parms,continuous,...){
    n <- length(y)
    
    pInit<-parms$pInit;
    pvec <- y==bestresponse;
    nvec <- !pvec;
    pcount <- sum(pvec*wt)
    ncount <- sum(nvec*wt)

    if (continuous){
    leftpos <- cumsum(pvec*wt)[-n];
    leftneg <- cumsum(nvec*wt)[-n];
    WERMLess <- 2-(2*pInit*leftneg/(pcount+ncount)+2*(1-pInit)*(pcount-leftpos)/(pcount+ncount));
    WERMGreat <- 2-(2*pInit*(ncount-leftneg)/(pcount+ncount)+2*(1-pInit)*(leftpos)/(pcount+ncount));
    ret <- list(goodness= WERMLess,direction=rep(-1,(n-1)))
    if (max(WERMLess)<max(WERMGreat)){
      ret <-list(goodness=WERMGreat,direction=rep(-1,(n-1)))
    }
    }
    else{
	ux <- sort(unique(x));
	wtsumP <- tapply(wt*pvec,x,sum);
	wtsumN <- tapply(wt*nvec,x,sum);
	werm <- 2- (2*pInit*wtsumN/(pcount+ncount) + 2*(1-pInit)*(pcount-wtsumP)/(pcount+ncount));
	ord <- order(werm);
	no <- length(ord);
        ret <- list(goodness = werm[ord][-no],direction = ux[ord]);

	}	
    return(ret);
  }

  init <- function(y,offset,parms,wt){
    pcInit=sum((y==bestresponse)*wt);
    ncInit = sum((y!=bestresponse)*wt);
    ntot = pcInit+ncInit;
    pInit = pcInit/ntot;
    neglab<-y[which(y!=bestresponse)][[1]]
    list(y=y, parms=list(pInit=pInit,ntot=ntot,poslab=bestresponse,
                neglab=neglab), numresp=1, numy=1,
	      summary= function(yval, dev, wt, ylevel, digits ) {
		  paste("  mean=", format(signif(yval, digits)),
			", MSE=" , format(signif(dev/wt, digits)),
			sep='')})
  }

  #initiallisation
  if (missing(data))
    data <- environment(formula)
 
  mf <- call <-  match.call(expand.dots = FALSE)
  m <- match(c("formula", "data"),
             names(mf), 0)
  mf <- mf[c(1, m)]
  mf$drop.unused.levels <- FALSE
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  y <-model.response(mf)
                                        #  if (is.null(weights)) weights <- rep.int(1, length(y))
  pcInit <- y == bestresponse;
  ncInit <- sum(!pcInit);
  pcInit <- sum(pcInit);
  pInit <- pcInit/(pcInit+ncInit);
    if ((pInit == 1) || (pInit == 0))
    {
      return(NULL);
   }
  alist <- list(eval=evaluation,split=split,init=init);
  rtree <- rpart(formula,mf,method=alist,control=rpart.control(cp=0,maxdepth=maxdepth,minsplit=minsplit,maxsurrogate=0,maxcompete=0,minbucket=1),model=TRUE,y=TRUE,xval=0);
  tree <- rpart2TR(rtree,bestresponse);
  class(tree) <- "TR_LRCart";
  tree$terms <- rtree$terms;
  tree$rpart <- rtree;
  tree$formula <- formula;
  tree$call <- call;
  tree$bestresponse <- bestresponse;
  if (nfcv>0){
    oldtree <- tree;
    rtree <- .pruneRpart(rtree,bestresponse,pInit,nfcv)
    tree <- rpart2TR(rtree,bestresponse);
    class(tree) <- "TR_LRCart"
    tree$unpruned  <- oldtree;
    tree$rpart <-rtree;
    tree$formula <- formula;
    tree$call <- call;
    tree$terms <- rtree$terms;
    tree$bestresponse <- bestresponse;
  }
  splitNode <- LRCartFusion(tree,pcInit,ncInit);
  tree$Lnode <-splitNode$Lnode;
  tree$Rnode <- splitNode$Rnode;
  fustree <- tree$rpart;
  for (i in splitNode$Lnode){
    fustree$frame[i,"yval"]<- -1;
  }
  for (i in splitNode$Rnode){
    fustree$frame[i,"yval"]<-1;
  }
  tree$fustree <- fustree;
  return(tree);
}

.pruneRpart <- function(tree,bestresponse,pInit,nfcv){
  if (nrow(tree$frame)<4)
    return(tree)
  
    cvinfo <- xpred.rpart(tree,xval = nfcv)
    cverr <- apply(cvinfo,2,function(x) {
      idx <- which(tree$y != x);
      err <- (pInit)*sum(tree$y[idx]!=bestresponse);
      err <- err+ (1-pInit)*sum(tree$y[idx]==bestresponse);
      return(err)
    })
    copt <- which.min(cverr[-1])+1
  
    rtree <- prune.rpart(tree,cp = tree$cptable[[copt]]);
   return(rtree)
  }
  



print.TR_LRCart<- function(x,...){
object <- x;
  if(!inherits(object,"TR_LRCart"))
    stop("object not of class TR_LRCart");

  id <- object$root;
  nodestack<-id;
  cat("TreeRank tree\n   id) var <|>= threshold #pos:#neg dauc \n\n");

  while(length(nodestack)>0){
    id <- nodestack[[1]];
    nodestack <-nodestack[-1];
    s <- "";
    sp <-"root";
    if (id != object$root){
       parent <- object$parentslist[id];
	if (object$split[[parent]]["type"]==0){
    	   if (object$kidslist[[parent]][[1]] == id)
    	      sp <- paste(object$split[[parent]]["name"],"<",format(object$split[[parent]]["breaks"],digits=3))
    	    else sp <- paste(object$split[[parent]]["name"],">=",format(object$split[[parent]]["breaks"],digits=3));
     	}
	else 
	{
	if (object$kidslist[[parent]][[1]] == id)
	sp <- paste(object$split[[parent]]["name"],"!=", object$split[[parent]]["breaks"])
	else sp <- paste(object$split[[parent]]["name"],"==", object$split[[parent]]["breaks"])
   	 }
	}

    s <- paste(cat(rep(' ',2*object$depth[id])),id,"| ", sp,"  ",
               object$pcount[id],":",
               object$ncount[id]," ",format(object$ldauc[id],digits=3),sep="")
    
    if (!(object$isleaf[id])){
      nodestack <- c(object$kidslist[[id]][[1]],object$kidslist[[id]][[2]],nodestack);
    }else{s<- paste(s,"*");}
    cat(paste(s,"\n"));
  }
}
    
    

varImportance.TR_LRCart <- function(obj,norm=TRUE){
  nr <- attributes(obj$terms)$term.labels
  res <- array(0,length(nr))
  names(res)<- nr;
  listvar <- array(unlist(lapply(obj$inner,function(x){obj$split[[x]]["name"]})));
  for (i in 1:length(obj$inner))
     res[listvar[i]] <- res[listvar[i]]+obj$ldauc[obj$inner[i]]^2;
  if (norm) ret <- res/max(res)
  else ret <- res;
  ret
}



#################################################################################
#
# LRsvm (formula, data, bestresponse,wpos, weights = NULL,...) 
#
#       Return : a LeafRank svm classifier, type TR_LRsvm
#################################################################################


LRsvm <- function(formula,data,bestresponse,wpos=0.5, weights=NULL,...){
  if (missing(data))
    data <- environment(formula)
  mf <- match.call(expand.dots = FALSE)
  m <- match(c("formula", "data"),names(mf), 0)
  mf <- mf[c(1, m)]
  mf$drop.unused.levels <- FALSE
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  y <-model.response(mf)
  if (is.null(weights)) weights <- rep.int(1, length(y))
  rn <- names(mf)[1] ### model.response(mf)

  x <- mf[,colnames(mf)!="(weights)"]

  pc <- sum(weights[y == bestresponse]);
  nc <- sum(weights[y!=bestresponse]);
  classw <- c(nc/(pc+nc),pc/(pc+nc));
  nclass <- unique(mf[,rn]);

  mf[,rn] <- as.factor(mf[,rn]);

  if (bestresponse !=nclass[[1]])
    {names(classw) <- nclass[c(2,1)];}
  else
    {names(classw) <- nclass;}
  
  if (classw[[1]]*classw[[2]] == 0)
    return(NULL);
  
#  m <- ksvm(formula,data,type="C-svc",class.weights=classw,prob.model=TRUE);
  m <- ksvm(formula,mf,class.weights=classw,type="C-svc",...);
  
  ret <- list(svm=m,bestresponse= bestresponse);
  class(ret)<-"TR_LRsvm";
  ret;
}





predict.TR_LRsvm <- function(object,newdata=NULL,...){
  p <- predict(object$svm,newdata);
  ret <- rep(1,nrow(newdata));
  ret[p==object$bestresponse] <- -1;
  ret;
}
  




#################################################################################
#
# LRforest(formula,data,bestresponse,wpos,mtry=(ncol(data)-1),...)
# see randomForest package for forest options
#
#################################################################################



LRforest <- function(formula,data,bestresponse,wpos=0.5,mtry=(ncol(data)-1),prcsize=1,...){
  if (missing(data))
    data <- environment(formula)
  mf <- match.call(expand.dots = FALSE)
  m <- match(c("formula", "data"), names(mf), 0)
  mf <- mf[c(1, m)]
  mf$drop.unused.levels <- FALSE
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  y <-model.response(mf)
  rn <- names(mf)[1] ### model.response(mf)
  x <- mf[,colnames(mf)!="(weights)"]
  pc <- sum(y == bestresponse);
  nc <- sum(y!=bestresponse);
  classw <- c(nc/(pc+nc),pc/(pc+nc));
  nclass <- unique(mf[,rn]);
  mf[,rn] <- as.factor(mf[,rn]);
  if (bestresponse !=nclass[[1]])
    {names(classw) <- nclass[c(2,1)];}
  else
    {names(classw) <- nclass;}
  
  if (classw[[1]]*classw[[2]] == 0)
    return(NULL);

 forest <- randomForest(formula=formula,data=mf,classwt=classw,mtry=mtry,sampsize=floor(prcsize*nrow(data)),...);
  
  ret <- list(forest=forest,bestresponse= bestresponse);
  class(ret)<-"TR_LRforest";
  ret;
}

predict.TR_LRforest <- function(object,newdata=NULL,...){
  p <- predict(object$forest,newdata);
  ret <- rep(1,nrow(newdata));
  ret[p==object$bestresponse] <- -1;
  ret;
}
  

varImportance.TR_LRforest <- function(obj,norm=TRUE){
	vi <- importance(obj$forest);
	res <- array(vi);
	names(res) <- row.names(vi);
  if (norm) ret <- res/max(res)
  else ret <- res;
  ret
}

r2weka <- function(data,dest,lab){
  dest<-file(dest,open="w");
  writeLines("@relation 'cpu'",dest);
  for (i in names(data)){
    if (i !=lab)
    {writeLines(paste("@attribute",i,"real"),dest)}
    else{
      cat("@attribute",i,"{",file=dest);
      cat(paste(unlist(unique(data[,lab])),",",sep=""),file=dest);
      writeLines("}",dest);
    }
    
  }
  writeLines("@DATA",dest);
  for (i in 1:nrow(data)){
    cat(paste(unlist(data[i,]),",",sep=""),sep="",file=dest);
    cat("\n",file=dest);
  }
  close(dest)
}
    


#line 1 "d:/Rcompile/CRANpkg/local/2.12/TreeRank/R/TRGUI.R"
#########################################################
#
# GUI functions, largely inspired by igraph tkiplot function
#
#
#########################################################




#########################################################
# trg : Environment var, fields:
# tree, coords, treeCanvas,minNodeSize,maxNodeSize,minNodePad

if (!exists(".TRgui.env")){
  .TRgui.env <- new.env();
  assign(".next",1,.TRgui.env);
}


#########################################################
# LeafRank functions definition
#########################################################

cartOpt <- list(
                list(name="Minimum Split",default=50,type="entry",optName="minsplit"),

                list(name="Min. Crit.",default=0,type="entry",optName="mincrit"),
                list(name="Maximum Depth",default=10,type="entry",optName="maxdepth"),
                list(name="n-fold",default=0,type="entry",optName="nfcv")
                );
LRCartopt2cmd <-function(obj){
  return(paste("maxdepth=",obj$maxdepth,
               ",minsplit=",obj$minsplit,",mincrit=",obj$mincrit,
               ",nfcv=",obj$nfcv,sep=""));
}
LRsvmopt2cmd <- function(obj){
  tmp <- "";
  if (!(obj$auto)){
    if (obj$kernel == "polydot"){
      tmp <-  paste(",kpar=list(","scale=",obj$scale,",offset=",obj$offset,
    ",degre=",obj$sigma,")",sep="");
    }
    if(obj$kernel == "tanhdot"){
      tmp <-  paste(",kpar=list(","scale=",obj$scale,",offset=",obj$offset,
                    ")",sep="");
    }
    if (obj$kernel == "rbfdot"){
      tmp <-  paste(",kpar=list(sigma=",obj$sigma,")",sep="");
    }
  }
  
  return(paste("C=",obj$C,
               ",kernel=\"",obj$kernel,
               "\",prcSplitVar=",(obj$varsplit/100),
               ",prcSplitData=",(obj$datasplit/100),tmp,sep=""));
}

LRCart.def <- list(name="Cart",fun="LRCart",
                   opt=cartOpt,opt2cmd=LRCartopt2cmd);


LRsvm.def <- list(name="svm",fun="LRsvm",
                     opt=list(
                       list(name="C",default=1,type="entry",optName="C"),
                       list(name="Degre/Sigma",default=1,type="entry",optName="sigma"),
                       list(name="scale",default=1,type="entry",optName="scale"),
                       list(name="offset",default=1,type="entry",optName="offset"),
                       list(name="Kernel",default=0,type="listbox",optName="kernel",choiceName=c("RBF","Poly.","TanHyp"),choice=c("rbfdot","polydot","tanhdot")),
                       list(name="Auto. Parameters",default=TRUE,type="check",optName="auto")),
                  opt2cmd=LRsvmopt2cmd);


forestOpt<- list(list(name="#Tree",default=50,type="entry",optName="ntree"),
			 list(name="#Var",default="0",type="entry",optName="mtry"),
			 list(name="%Data", default ="100",type="entry",optName="prcsize"),
			 list(name="replace",default=TRUE,type="check",optName="replace"),
			 list(name="node size",default=1,type="entry",optName="nodesize"),
			 list(name="Max Leaves",default=0,type="entry",optName="maxnodes"));

LRforest2cmd <- function(obj){
tmp <- paste("ntree=",obj$ntree,",nodesize=",obj$nodesize,",replace=",obj$replace,sep="");
if (obj$mtry!=0) tmp <- paste(tmp,",mtry=",obj$mtry,sep="");
if (obj$prcsize !=100)tmp<- paste(tmp,",prcsize=",obj$prcsize/100,sep="");
if (obj$maxnodes !=0) tmp <- paste(tmp,",maxnodes=",obj$maxnodes,sep="");
tmp
}

			 
LRforest.def <- list(name="randomForest",fun="LRforest",opt=forestOpt,opt2cmd=LRforest2cmd);


#########################################################
#
# Main launching Frame:
#  composed by 3 frames  : infoFrame (dataset definition)
#                          LR frame (for LeafRank)
#                          TR frame (for TreeRank)
#
#########################################################


TRGui <- function(){

  top <- tktoplevel(height="200",width="100")
  mainGuiEnv <- new.env();
  tktitle(top) <- "TreeRank GUI"
  mainFrame <- tkframe(top,height="200",width="100",borderwidth=2);

  infoFrame <- tkframe(mainFrame,borderwidth=5,width=100);
  LRFrame <- tkframe(mainFrame,borderwidth=5,width=100,relief="groove");
  TRFrame <-tkframe(mainFrame,borderwidth=5,width=100,relief="groove");
  
  optTRFrame <- tkframe(TRFrame,borderwidth=2,width=100);
  optLRFrame <- tkframe(LRFrame,borderwidth=2,width=100);
  

  ## info Frame definition
  dataset <- tclVar("");
  resname<-tclVar("class");
  bestresponse <-tclVar("1");

  entry.dataset <- tkentry(infoFrame,width="20",textvariable=dataset);
  entry.resname <- tkentry(infoFrame,width="20",textvariable=resname);
  entry.bestresponse <- tkentry(infoFrame,width="5",textvariable=bestresponse);
  tkgrid(tklabel(infoFrame,text="Data set: "),entry.dataset);
  tkgrid(tklabel(infoFrame,text="Label name: "),entry.resname);
  tkgrid(tklabel(infoFrame,text="Best Label: "),entry.bestresponse);
  
  
  #TreeRank options frame
  dftOpt <- growing_ctrl();
  minOptTR <- tclVar(dftOpt$minsplit);
  maxOptTR <- tclVar(dftOpt$maxdepth);
  mincritOptTR <- tclVar(dftOpt$mincrit);
  forestOptTR<-tclVar(0);
  varSplitTR <- tclVar(100);
  dataSplitTR <- tclVar(100);
  nfcvOptTR <-tclVar("0");
  replOptTR <- tclVar("1");
  entry.minOptTR <-tkentry(optTRFrame,width="5",textvariable=minOptTR);
  entry.mincritOptTR <-tkentry(optTRFrame,width="5",textvariable=mincritOptTR);
  entry.maxOptTR <-tkentry(optTRFrame,width="5",textvariable=maxOptTR);
  entry.forestOptTR <- tkentry(optTRFrame,width=5,textvariable=forestOptTR);
  entry.varSplitTR <- tkentry(optTRFrame,width="5",textvariable=varSplitTR);
  entry.dataSplitTR <- tkentry(optTRFrame,width="5",textvariable= dataSplitTR);
  entry.nfcvOptTR <- tkentry(optTRFrame,width=5,textvariable=nfcvOptTR);
  entry.replOptTR <- tkcheckbutton(optTRFrame,variable = replOptTR);

  tkgrid(tklabel(optTRFrame,text="Minimum Split"),entry.minOptTR,
         tklabel(optTRFrame,text="Forest"),entry.forestOptTR);
  tkgrid(tklabel(optTRFrame,text="Maximum Depth"),entry.maxOptTR,
         tklabel(optTRFrame,text="%Data. split"),entry.dataSplitTR);
  tkgrid(tklabel(optTRFrame,text="Min. Criteria"),entry.mincritOptTR,
         tklabel(optTRFrame,text="Replace"),entry.replOptTR);
  tkgrid(tklabel(optTRFrame,text="n-fold Cross Validation "),entry.nfcvOptTR,
	    tklabel(optTRFrame,text="%Var. split"),entry.varSplitTR);
   
  tkgrid(tklabel(TRFrame,text="TreeRank Options"));
  tkgrid(optTRFrame);

  
  
  
  #LeafRank
  ## Scan the environment for new LeafRank functions definition
  LRlist <- ls(pattern="LR.*.def",name=globalenv());
  nameLR <- list(LRCart.def$name,LRsvm.def$name,LRforest.def$name);
  funNameLR <- list(LRCart.def$fun,LRsvm.def$fun ,LRforest.def$fun);
  optionLR <- list(LRCart.def$opt,LRsvm.def$opt,LRforest.def$opt);
  opt2cmdLR <- list(LRCart.def$opt2cmd,LRsvm.def$opt2cmd,LRforest.def$opt2cmd);
  lbLR <- tklistbox(LRFrame,height=3,width=10,selectmode="single");
  tkinsert(lbLR,"end",LRCart.def$name);
  tkinsert(lbLR,"end",LRsvm.def$name);
  tkinsert(lbLR,"end",LRforest.def$name);
  for (x in LRlist){
    obj <- eval(parse(text=x),globalenv())
    nameLR <- c(nameLR,obj$name);
    funNameLR <- c(funNameLR,obj$fun);
    optionLR <- c(optionLR,list(obj$opt));
    opt2cmdLR <- c(opt2cmdLR,list(obj$opt2cmd));
    tkinsert(lbLR,"end",obj$name)
  }

  tkselection.set(lbLR,0);
  assign("curLeafRank",1,mainGuiEnv);
  tkgrid(tklabel(LRFrame,text="LeafRank: "),lbLR);

  assign("listVarLR",list(),mainGuiEnv);
  assign("listWidgetLR",list(),mainGuiEnv);

  ## LR Frame building  
  buildLRopt <- function(){
    listVarLR <- list()
    id <- as.numeric(tkcurselection(lbLR))+1;
    if (length(id)<1)
      id <- 1;
    listOptLR <- optionLR[[id]];
    listSlaves <- tclvalue(tkgrid.slaves(optLRFrame));
    if (listSlaves[[1]] !=""){
      sapply(unlist(strsplit(listSlaves,split=" ")),tkgrid.remove)
    }
    listWidgetLR <- list()
    listGrid <- list();
    for (i in 1:length(listOptLR)){
      if (listOptLR[[i]]$type=="entry"){
        tmp <- tclVar(listOptLR[[i]]$default)
        listVarLR <- c(listVarLR,list(tmp))
        listWidgetLR<-c(listWidgetLR,list(tkentry(optLRFrame,width="5",textvariable=tmp)))
      }
      if (listOptLR[[i]]$type=="check"){
        tmp <- tclVar(listOptLR[[i]]$default);
        listVarLR <- c(listVarLR,list(tmp))
        listWidgetLR<-c(listWidgetLR,list(tkcheckbutton(optLRFrame,variable=tmp)))
      }
      if (listOptLR[[i]]$type=="listbox"){
        tmplb <- tklistbox(optLRFrame,height=3,width=6,selectmode="single");
        for (na in listOptLR[[i]]$choiceName){
          tkinsert(tmplb,"end",na);
        }
        tkselection.set(tmplb,listOptLR[[i]]$default);
        listVarLR <- c(listVarLR,list(tmplb));
        listWidgetLR<-c(listWidgetLR,list(tmplb))

      }
      tmpW <- listWidgetLR[[length(listWidgetLR)]]
    }
    for (i in (1:(length(listWidgetLR)/2))){
      tkgrid(tklabel(optLRFrame,text=listOptLR[[(i*2-1)]]$name),
             listWidgetLR[[(i*2-1)]],
             tklabel(optLRFrame,text=listOptLR[[(i*2)]]$name),
             listWidgetLR[[(i*2)]]);
    }
    if (length(listWidgetLR) %% 2 >0)
      tkgrid(tklabel(optLRFrame,text=listOptLR[[length(listOptLR)]]$name),
             listWidgetLR[[length(listOptLR)]]);
    assign("listWidgetLR",listWidgetLR,mainGuiEnv)
    assign("listVarLR",listVarLR,mainGuiEnv)
    assign("curLeafRank",id,mainGuiEnv)
    
  }
  
  buildLRopt();
  tkgrid(optLRFrame)
  tkbind(lbLR,"<<ListboxSelect>>",buildLRopt);

  ##Command Line building
  
  cmdLine <- function(){
    datasetV <-  tclvalue(dataset);
    resnameV <- tclvalue(resname);
    bestresponseV <- tclvalue(bestresponse);
    idLR <- get("curLeafRank",mainGuiEnv);
    #LeafRank options
    listOptLR <- optionLR[[idLR]]
    optPar <- list();
    listVarLR <- get("listVarLR",mainGuiEnv)
    for(i in 1:length(listVarLR)){
      
      if (listOptLR[[i]]$type=="listbox"){
        id <- as.numeric(tkcurselection(listVarLR[[i]]))+1;
        tmp<- paste("c(optPar,",listOptLR[[i]]["optName"],"=\"",
                    listOptLR[[i]]$choice[id],"\")",sep="");
      }else{
        tmp <- paste("c(optPar,",listOptLR[[i]]["optName"],"=",tclvalue(listVarLR[[i]]),")",sep="");
      }
      optPar <- eval(parse(text=tmp));
      
    }
    optLR <- opt2cmdLR[[idLR]](optPar);
                                        #TreeRank options
    minOptTRV <- as.double(tclvalue(minOptTR));
    maxOptTRV <- as.double(tclvalue(maxOptTR));
    mincritOptTRV <-as.double(tclvalue(mincritOptTR));
    nfcvOptTRV <- as.integer(tclvalue(nfcvOptTR));
    varSplitTRV <- as.numeric(tclvalue(varSplitTR));
    dataSplitTRV <- as.numeric(tclvalue(dataSplitTR));
    forestTRV <- as.numeric(tclvalue(forestOptTR));

   replTRV <- as.logical(as.numeric(tclvalue(replOptTR)));
    if (is.null(datasetV)||is.null(resnameV)||is.null(bestresponseV)
        ||is.null(minOptTRV)||is.null(maxOptTRV)||is.null(mincritOptTRV)
        ||is.null(nfcvOptTRV)
        ||is.null(varSplitTRV))
      {
        errorGui("undefined value");
        return
      }

    grTRctrl <- paste("growing_ctrl(maxdepth=",maxOptTRV,",mincrit=",mincritOptTRV,",minsplit=",minOptTRV,")",sep="");
                                        #    prTRctrl <- paste("pruning_ctrl(prune=",pruneOptTRV,",strat=",stratOptTRV,",nfcv=",nfcvOptTRV,")",sep="");
 #   prTRctrl <- paste("pruning_ctrl(prune=TRUE,strat=FALSE,nfcv=",nfcvOptTRV,")",sep="");
                                        #cb <-function(id,depth,pc,nc,pck,nck){
                                        # if (length(listx)==0){
                                        #  pcinit <- pc;
                                        #  ncinit <- nc;
                                        #}
    
                                        #}
    
                                        # print(paste(id,depth,pc,nc,pck,nck,sep=" "));
                                        #}
    if  (forestTRV>1){
    cmd <-  paste("TreeRankForest(formula=",resnameV,"~., data=",datasetV,",bestresponse=\"",bestresponseV,"\"",",ntree=",forestTRV,",replace=",replTRV,",sampsize=",(dataSplitTRV/100),",varsplit=", (varSplitTRV/100),",growing=",grTRctrl,",nfcv=",nfcvOptTRV,",LeafRank= function(...){",funNameLR[[idLR]],"(",optLR,",...)})",sep="");
  }
    else     cmd <-  paste("TreeRank(formula=",resnameV,"~., data=",datasetV,",bestresponse=\"",bestresponseV,"\",growing=",grTRctrl,",nfcv=",nfcvOptTRV,",LeafRank= function(...){",funNameLR[[idLR]],"(",optLR,",...)})",sep="");
print(cmd);
    return(cmd);   
  }
  
  runGui <- function(){

    tree <- eval(parse(text=cmdLine()),.GlobalEnv);
    assign("tree",tree,.GlobalEnv);
    TRplot(tree);
    print("Computation done");
  }
  
  exportCmd <- function(){
    cmd <- cmdLine();
    tt <- tktoplevel()
    name <- tclVar("funName");
    entry.Name <- tkentry(tt,width="20",textvariable=name)
    tkgrid(tklabel(tt,text="Fun name"));
    OnOk <- function()
      {
        NameVal <- tclvalue(name);
        tkdestroy(tt)
        assign(NameVal,cmd,.GlobalEnv);
      }
    OK.but <- tkbutton(tt,text=" set ",command=OnOk);
    tkbind(entry.Name,"<Return>",OnOk)
    tkgrid(entry.Name)
    tkgrid(OK.but)
    tkfocus(tt);
  }

  but.run <-tkbutton(mainFrame,text="run",command =runGui);
  #but.exp <- tkbutton(mainFrame,text="export cmd",command=exportCmd);
  tkgrid(infoFrame);
  
  tkgrid(LRFrame);
  tkgrid(TRFrame);
  tkgrid(but.run);
  tkbind(mainFrame,"<<Return>>",runGui);
                                        #tkgrid(but.exp);
  tkgrid(mainFrame);
  tkfocus(top);
  
}












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

TRplot <- function(tree,top= NULL){
  if (is.null(top))
    top <- tktoplevel(width="600",height="600");
  treeType <- -1;
  tktitle(top)<- "TreeRank GUI"
  if (inherits(tree,"TR_LRCart")){
    treeType <- 1;
    
    popup.menu<-
      list(list(label="View Unpruned",func=.TRgui.viewUnpruned),
           list(label="Save Tree",func = .TRgui.saveTree),
           list(label="Export Tree",func = .TRgui.exportTree));
    node.popup.menu <-
      list(list(label="View Unpruned",func=.TRgui.viewUnpruned),
           list(label="Save Tree",func = .TRgui.saveTree),
           list(label="Export Tree",func = .TRgui.exportTree));
  }
  if ((inherits(tree,"TR_TreeRank"))||(inherits(tree,"TR_forest"))){
    treeType <- 0;
    if (inherits(tree,"TR_forest"))
      treeType<-2;
    popup.menu<-
      list(list(label="View Subtree", func = .TRgui.viewSubTree),
           list(label="View Unpruned",func=.TRgui.viewUnpruned),
           list(label="Plot Subtree ROC", func = .TRgui.plotROCSubTree),
           list(label="Plot Unpruned ROC",func=.TRgui.plotROCUnpruned),
           list(label="Add test set", func = .TRgui.submitTestSet),
          list(label="Add ROC",func=.TRgui.addExtROC),
           list(label="Save Tree",func = .TRgui.saveTree),
           list(label="Export ROC",func = .TRgui.exportROC),
           list(label="Export Tree",func = .TRgui.exportTree));

    node.popup.menu <-
      list(list(label = "View LeafRank", func = .TRgui.viewLeafRank),
           list(label="View Subtree", func = .TRgui.viewSubTree),
           list(label="View Unpruned",func=.TRgui.viewUnpruned),
           list(label="Plot Subtree ROC", func = .TRgui.plotROCSubTree),
           list(label="Plot Unpruned ROC",func=.TRgui.plotROCUnpruned),
           list(label="Add test set", func = .TRgui.submitTestSet),
           list(label="Add ROC",func=.TRgui.addExtROC),
           list(label="Save Tree",func = .TRgui.saveTree),
            list(label="Export ROC",func = .TRgui.exportROC),
           list(label="Export Tree",func = .TRgui.exportTree));
  }
  if (treeType == -1){
    print("Bad class for tree");
    stop();
  }
  trg.id <- .TRgui.new(list(top=top,nodeSize = 10,panX=50,panY=50,maxNodeSize=30,minNodeSize=5,tree=tree,treeType = treeType));
    if (treeType==2){
      .TRgui.set(trg.id,"forest",tree);
      .TRgui.set(trg.id,"ntree",tree$ntree);
      .TRgui.set(trg.id,"tree",tree$forest[[1]]);
      .TRgui.set(trg.id,"forestCur",1);
    }

  
  treeFrame <- .TRgui.treeFrame(trg.id,popup.menu,node.popup.menu);
  infoFrame <- .TRgui.infoFrame(trg.id);
  if(treeType != 1){
    rightFrame <- .TRgui.rightFrame(trg.id);
  }
  tkgrid(infoFrame,row=0,column=0,sticky="nesw");
  tkgrid(treeFrame,row=0,column=1,sticky="nesw");
  if(treeType!=1){
    tkgrid(rightFrame,row=0,column=2,sticky="nesw");
  }
  tkgrid.columnconfigure(top,1);

  if (as.numeric(tclvalue(tkwinfo("viewable",top))!=1))
    tkwait.visibility(top);
  .TRgui.computeCoords(trg.id);
  .TRgui.scale(trg.id);
  .TRgui.create.nodes(trg.id);
  .TRgui.create.edges(trg.id);
  .TRgui.update.nodes(trg.id);
  .TRgui.refresh(trg.id);
  tkbind(top, "<Destroy>", function() TRgui.close(trg.id, FALSE))

  main.menu <- tkmenu(top)
  tkadd(main.menu, "command", label="Close", command=function() {
    TRgui.close(trg.id, TRUE)})
  sapply(node.popup.menu,function(x){tkadd(main.menu,"command",label=x$label,command=function(){x$f(trg.id)})})
  tkconfigure(top, "-menu", main.menu)
  
  trg.id;
 }


.TRgui.info2str <- function(trg.id,i = NULL){
  trg <- .TRgui.get(trg.id);
  tree <- .TRgui.get(trg.id,"tree")
  if (is.null(i)){
    ret <- "                                \nNode: \nDauc:\n#Pos:\n#Neg.: \n\n";
    return(ret);
  }
  else{
    ret <- paste("                                \nNode: ",i,
                 "\nDauc: ",format(tree$ldauc[[i]],digits=3),
                 "\n#Pos: ",tree$pcount[[i]],
                 "\n#Neg: ",tree$ncount[[i]],
		 "\nratio: ",format(tree$pcount[[i]]/(tree$pcount[[i]]+tree$ncount[[i]]),digits=3),"\n",sep="");
    
  }
  if (trg$treeType != 1){
   if (tree$isleaf[i]){
  ret <- paste(ret,"Score: ",format(tree$score[[i]],digits=3),"\n",sep="");
   }else ret <- paste(ret,"\n");
   }
  ret;
}

.TRgui.infoFrame <- function(trg.id){
  top <- .TRgui.get(trg.id,"top");
  trg <- .TRgui.get(trg.id);
  tree <- .TRgui.get(trg.id,"tree");
  frame <- tkframe(top,borderwidth=2,width=120,relief="groove");
  .TRgui.set(trg.id,"infoFrame",frame);
  txt <- .TRgui.info2str(trg.id);
  infoLabel <-tklabel(frame,text= txt );
  tkgrid(infoLabel,sticky="w");
  .TRgui.set(trg.id,"infoLabel",infoLabel);
  lbVI <-  tklistbox(frame,height=10,yscrollcommand=function(...)tkset(scr,...));
  scr <-tkscrollbar(frame,command=function(...)tkyview(lbVI,...))
  if (.TRgui.get(trg.id,"treeType")==2){
    vi <- varImportance(.TRgui.get(trg.id,"forest"))
  }else{
  vi <- varImportance(tree);}
  if (!(is.null(vi))){
    tkgrid(tklabel(frame,text="Var. importance:"));
    for (i in 1:length(vi))
      tkinsert(lbVI,"end",paste(names(vi)[[i]],": ",format(vi[[i]],digits=4),sep=""));
    tkgrid(lbVI,scr);
    tkgrid.configure(scr,sticky="nsw")
  }
    .TRgui.set(trg.id,"lbVI",lbVI);
  if (trg$treeType !=1){
    frameListROC <- tkframe(frame,borderwidth=2,width=200,height=200,relief="groove")
        if (trg$treeType==2){
          
          foresttl<-tklistbox(frameListROC,height=5,selectmode="single",yscrollcommand=function(...)tkset(forestscr,...))
          forestscr <- tkscrollbar(frameListROC,
                                   command=function(...)tkyview(foresttl,...))
          tkgrid(tklabel(frameListROC,text="Forest"));
          for (i in (1:.TRgui.get(trg.id,"ntree")))
            {
              tkinsert(foresttl,"end",i)
            }
          tkselection.set(foresttl,0);
          .TRgui.set(trg.id,"foresttl",foresttl);
        changeTree <- function(){
          tl <- .TRgui.get(trg.id,"foresttl");
          id <-as.numeric(tkcurselection(tl))+1;
          forest <- .TRgui.get(trg.id,"forest");
          .TRgui.set(trg.id,"tree",forest$forest[[id]]);
          .TRgui.set(trg.id,"forestCur",id);
          .TRgui.clean(trg.id);
          .TRgui.computeCoords(trg.id);
          .TRgui.scale(trg.id);
          .TRgui.create.nodes(trg.id);
          .TRgui.create.edges(trg.id);
          .TRgui.update.nodes(trg.id);
          .TRgui.refresh(trg.id);
          .TRgui.addROC(trg.id,getCurves(forest$forest[[id]]),paste("Learn. ",id));
          .TRgui.updateROC(trg.id);
          .TRgui.viFrameReplot(trg.id);
          
        }
          tkgrid(foresttl,forestscr)
          tkgrid.configure(forestscr,sticky="nsw")
          tkbind(foresttl,"<<ListboxSelect>>",changeTree);
        }

  vbROC <- tclVar("1");
  vbPrec <- tclVar("0");
    .TRgui.set(trg.id,"vbROC",vbROC);
   .TRgui.set(trg.id,"vbPrec",vbPrec);
    cbROC <- tkcheckbutton(frameListROC);
    cbPrec <- tkcheckbutton(frameListROC);
    tkconfigure(cbROC,variable=vbROC,command=function(...){.TRgui.updateROC(trg.id)});
    tkconfigure(cbPrec,variable=vbPrec,command=function(...){.TRgui.updateROC(trg.id)});
    tkgrid(tklabel(frameListROC,text="ROC"),cbROC,tklabel(frameListROC,text="Prec/Recall"),cbPrec);
    tkgrid(tklabel(frameListROC,text="ROC List"),tklabel(frameListROC,text="auc"));
    tkgrid(frameListROC,sticky="nsew")
    .TRgui.set(trg.id,"frameListROC",frameListROC);

    
    }
             #txt <- paste(txt,names(vi)[[i]],": ",vi[[i]],"\n",sep="");
  #tkgrid(tklabel(frame,text=txt),sticky="w");
  return(frame);
}

.TRgui.rightFrame <- function(trg.id){
  top <- .TRgui.get(trg.id,"top");
  frame <-tkframe(top,borderwidth=2,relief="groove");
  .TRgui.set(trg.id,"rightFrame",frame);
  frameROC <- .TRgui.frameROC(trg.id);
  viFrame <-.TRgui.viFrame(trg.id);
  frame;
}



.TRgui.viFrame <- function(trg.id){
  top<- .TRgui.get(trg.id,"rightFrame");
  vi <- varImportance(.TRgui.get(trg.id,"tree"));
  if (is.null(vi))return(tkframe(top));
  viFrame <- tkrplot(top,function() barplot(vi,col=heat_hcl(length(vi))[rank(-vi)]),vscale=0.7);
  tkgrid(viFrame,sticky="nesw");
  .TRgui.set(trg.id,"viFrame",viFrame);
  viFrame;
}

.TRgui.viFrameReplot <- function(trg.id){
  vi <- varImportance(.TRgui.get(trg.id,"tree"));
  viFrame <- .TRgui.get(trg.id,"viFrame");
  if (is.null(vi))return(tkframe(viFrame));
  tkrreplot(viFrame,function() barplot(vi,col=heat_hcl(length(vi))[rank(-vi)]),vscale=0.7);
  
}


.TRgui.treeFrame <- function(trg.id,popup.menu,node.popup.menu){
  top <- .TRgui.get(trg.id,"top");
  frame <- tkframe(top,relief="groove",borderwidth=2);
  canvas <- tkcanvas(frame,width=500,height=700);
  .TRgui.set(trg.id,"treeCanvas",canvas);
  .TRgui.set(trg.id,"treeFrame",frame);
  tmp<-tkframe(frame)
  yscr <- tkscrollbar(frame,repeatinterval=5, command = function(...) tkyview(canvas,...));
  tkconfigure(canvas, yscrollcommand= function(...) tkset(yscr,...));
  xscr <- tkscrollbar(frame, repeatinterval=5,orient = "horizontal",command = function(...) tkxview(canvas,...));
  tkconfigure(canvas, xscrollcommand= function(...) tkset(xscr,...));
  but.zoom <- tkbutton(tmp,text="+",command=function(...).TRgui.zoom(trg.id,1.2,...));
  but.dezoom <- tkbutton(tmp,text="-",command=function(...) .TRgui.zoom(trg.id,1/1.2,...));
  tkgrid(canvas,yscr,stick="ns");
  tkgrid(xscr,sticky="ew");
  tkgrid(but.dezoom,but.zoom)
  tkgrid(tmp);

  #zoom
  tkbind(canvas,"<4>",function().TRgui.zoom(trg.id,1.2,TRUE));
  tkbind(canvas,"<5>",function().TRgui.zoom(trg.id,1/1.2,TRUE));
  tkbind(canvas,"<Configure>",function() .TRgui.reinitGUI(trg.id));
  #node (de/)selection
  tkitembind(canvas,"node||nodelabel","<1>",function(x,y){
    trg <- .TRgui.get(trg.id);
    .TRgui.deselect.all(trg.id)
    .TRgui.select.current(trg.id)
    
  })
  
  tkitembind(canvas,"node||nodelabel","<Control-1>",function(x,y){
    treeCanvas <-.TRgui.get(trg.id,"treeCanvas");
    curtags <- as.character(tkgettags(canvas,"current"));
    seltags <- as.character(tkgettags(canvas,"selected"));
    .TRgui.select.current(trg.id);
  });


  pm <- tkmenu(canvas);
  node.pm <- tkmenu(canvas);
  sapply(popup.menu,function(x){tkadd(pm,"command",label = x$label, command = function(){x$f(trg.id)})})
  sapply(node.popup.menu,function(x){tkadd(node.pm,"command",label = x$label, command = function(){x$f(trg.id)})})
  
  tkbind(canvas,"<3>",function(x,y){
    treeCanvas <- .TRgui.get(trg.id,"treeCanvas");
    tags <- as.character(tkgettags(treeCanvas,"current"));
    if (!("selected" %in% tags)){
      .TRgui.deselect.all(trg.id)
      .TRgui.select.current(trg.id);
    }
    tags <- as.character(tkgettags(treeCanvas,"selected"));
    if ("node" %in% tags){
      menu <- node.pm;
    }else{menu <- pm};
        
    
    x <- as.integer(x) + as.integer(tkwinfo("rootx", canvas))
    y <- as.integer(y) + as.integer(tkwinfo("rooty", canvas))
    .Tcl(paste("tk_popup", .Tcl.args(menu, x, y)))

  })
  return(frame);
}


.TRgui.zoom<- function(trg.id,zoom,m=FALSE){
  trg <- .TRgui.get(trg.id);
  x <-0;
  y<-0;
  if (m){
    x <- as.numeric(tclvalue(tkwinfo("pointerx",trg$treeCanvas)))-as.numeric(tclvalue(tkwinfo("rootx",trg$treeCanvas)));
    y <- as.numeric(tclvalue(tkwinfo("pointery",trg$treeCanvas)))-as.numeric(tclvalue(tkwinfo("rooty",trg$treeCanvas)));
  }
   
  tcl(trg$treeCanvas,"scale","all",x,y,zoom,zoom);
.TRgui.refresh(trg.id);
  
}
    
.TRgui.frameROC<- function(trg.id){

  top <- .TRgui.get(trg.id,"rightFrame");
  tree <- .TRgui.get(trg.id,"tree");
  frameROC <-tkrplot(top,function() 0);
    tabc = rainbow(10);
  .TRgui.set(trg.id,"frameROC",frameROC);
  .TRgui.set(trg.id,"rocList",list());
  .TRgui.set(trg.id,"precList",list());
  .TRgui.set(trg.id,"aucList",list());
  .TRgui.set(trg.id,"rocListColor",tabc);
  .TRgui.set(trg.id,"rocColor",list());
  .TRgui.set(trg.id,"indexColorROC",1);
  .TRgui.set(trg.id,"listVB",list());
  .TRgui.set(trg.id,"listCB",list());
  if (.TRgui.get(trg.id,"treeType")==2){
    .TRgui.addROC(trg.id,getCurves(.TRgui.get(trg.id,"forest")),"Learn. forest");
   # .TRgui.addROC(trg.id,getROC(tree),"Learn. 1")
  }
  .TRgui.addROC(trg.id,getCurves(tree),"Learn. 1")
  tkgrid(frameROC,sticky="nsew");
  .TRgui.updateROC(trg.id);
  frameROC;
}



.TRgui.addROC <- function(trg.id,curves,txt)
{

  roc <- curves[[1]];
  prec <- curves[[2]];
  trg <- .TRgui.get(trg.id)
  .TRgui.set(trg.id,"rocList",c(trg$rocList,list(roc)));
  .TRgui.set(trg.id,"precList",c(trg$precList,list(prec)));
  .TRgui.set(trg.id,"aucList",c(trg$aucList,auc(roc)));
  .TRgui.set(trg.id,"rocColor",c(trg$rocColor,trg$rocListColor[[trg$indexColorROC]]));
  .TRgui.set(trg.id,"indexColorROC",(((trg$indexColorROC) %% length(trg$rocListColor))+1));
  frameListROC <- .TRgui.get(trg.id,"frameListROC");
  vb <- tclVar("1");
  cb <- tkcheckbutton(frameListROC);
  tkconfigure(cb,variable=vb,command=function(...){.TRgui.updateROC(trg.id)});
  .TRgui.set(trg.id,"listVB",c(trg$listVB,list(vb)));
  .TRgui.set(trg.id,"listCB",c(trg$listCB,list(cb)));
  tkgrid(tklabel(frameListROC,text=txt),tklabel(frameListROC,text=format(auc(roc),digits=3)),cb);
  
  .TRgui.updateROC(trg.id);
}


.TRgui.updateROC <- function(trg.id){

  frame <- .TRgui.get(trg.id,"frameROC");
  rocList <- .TRgui.get(trg.id,"rocList")
  precList <- .TRgui.get(trg.id,"precList");
  rocColor <- .TRgui.get(trg.id,"rocColor")
  #rocStyle <- .TRgui.get(trg.id,"rocStyle")
  listVB <- as.numeric(sapply(.TRgui.get(trg.id,"listVB"),function(x) tclvalue(x)));
  tree <- .TRgui.get(trg.id,"tree")
  vids <- .TRgui.get.selected.nodes(trg.id)
  points <- list();
  for (i in vids)
    {
      if (tree$isleaf[i]){
        points <- c(points,list(c(tree$lalpha[i],tree$lbeta[i])))
      }
      else{points <- c(points,list(c(tree$lalpha[tree$kidslist[[i]][2]],
                                     tree$lbeta[tree$kidslist[[i]][[2]]])));
         }
    }


	vr <- as.logical(as.numeric(tclvalue(.TRgui.get(trg.id,"vbROC"))));
	vp <- as.logical(as.numeric(tclvalue(.TRgui.get(trg.id,"vbPrec"))));
    curlist <- list();
    corlist <- list(); 

    if (vr) {curlist <- c(curlist,rocList[listVB==1]); corlist <- c(corlist,rocColor[listVB==1]);}
    if (vp) {curlist <- c(curlist,precList[listVB==1]); corlist <- c(corlist,rocColor[listVB==1]);}
if (vr)  tkrreplot(frame,fun=function()plotROC(curlist,corlist,points)) 
else tkrreplot(frame,fun=function()plotROC(curlist,corlist));
 
 top <- .TRgui.get(trg.id,"top");
tkfocus(top); 
}

  


.TRgui.viewLeafRank <- function(id){
  tree <- .TRgui.get(id,"tree")
  vids <- .TRgui.get.selected.nodes(id)
  for (i in vids)
    TRplot(getClassifier(tree,i));
 }


.TRgui.viewSubTree <- function(id){
  tree <- .TRgui.get(id,"tree")
  vids <- .TRgui.get.selected.nodes(id)
  if (length(vids)==0) return(FALSE)
  TRplot(subTreeRank(tree,vids))
 }


.TRgui.viewUnpruned <- function(id){
  tree <- .TRgui.get(id,"tree")
  if (is.null(tree$unpruned)){
    tkmessageBox(title= "TreeRank",message="Not pruned tree",type="ok")
  
  }else
  {TRplot(tree$unpruned)}
 }

.TRgui.plotROCUnpruned <- function(id){
  tree <- .TRgui.get(id,"tree");
 
  if (is.null(tree$unpruned)){
    tkmessageBox(title="TreeRank",message="Not pruned tree",type="ok")
  }else{
  .TRgui.addROC(id,getCurves(tree$unpruned),"Unpruned Tree");
  .TRgui.updateROC(id);}
 }


.TRgui.plotROCSubTree <- function(id){
  trg <- .TRgui.get(id);
  vids <- .TRgui.get.selected.nodes(id)
  if (length(vids)==0) return(FALSE)
  newtree <-subTreeRank(trg$tree,vids)
  .TRgui.addROC(id,getCurves(newtree),"Subtree");
  .TRgui.updateROC(id);
 } 

.TRgui.submitTestSet <- function(id){
  tree <- .TRgui.get(id,"tree")	
  tt<-tktoplevel()
  Name <- tclVar("testset")
  entry.Name <-tkentry(tt,width="20",textvariable=Name)
  tkgrid(tklabel(tt,text="Test Set"))
  tkgrid(entry.Name)
  OnOK <- function()
    {
      NameVal <- tclvalue(Name)
      tkdestroy(tt)
      if ((.TRgui.get(id,"treeType")==2)){
  #      if (as.numeric(tclvalue(vb))!=0){
        forest <- .TRgui.get(id,"forest");
        roc <- eval(parse(text=paste("getCurves(forest,",NameVal,")",sep="")));
        .TRgui.addROC(id,roc,paste(NameVal,"forest"));
      }
      roc <- eval(parse(text=paste("getCurves(tree,",NameVal,")",sep="")))
      if ((.TRgui.get(id,"treeType")==2))
        .TRgui.addROC(id,roc,paste(NameVal,.TRgui.get(id,"forestCur")))
      else      .TRgui.addROC(id,roc,NameVal);
      .TRgui.updateROC(id);

    }
  OK.but <-tkbutton(tt,text="  set  ",command=OnOK)
  tkbind(entry.Name, "<Return>",OnOK)
  tkgrid(OK.but)
  tkfocus(tt)
  }

.TRgui.addExtROC <- function(id){
  tt <- tktoplevel()
  Name <-tclVar("roc")
  entry.Name <- tkentry(tt,width="20",textvariable=Name)
  tkgrid(tklabel(tt,text="ROC var. name"))
  tkgrid(entry.Name)
  OnOK <- function()
    {
      NameVal <- tclvalue(Name)
      tkdestroy(tt)
      roc <- eval(parse(text=NameVal));
      trg <- .TRgui.get(id);
      .TRgui.addROC(id,c(list(as.matrix(roc)),list(c(0,0))),NameVal)
      .TRgui.updateROC(id);
    }
  OK.but <- tkbutton(tt,text="  set  ",command=OnOK)
  tkbind(entry.Name,"<Return>",OnOK)
  tkgrid(OK.but)
  tkfocus(tt)
  }


.TRgui.exportTree <- function(trg.id){
  tt <- tktoplevel()
  frame <- .TRgui.get(trg.id,"treeCanvas");
  name <- tclVar("file.eps")
  entry.Name <- tkentry(tt,width="20",textvariable=name)
  tkgrid(tklabel(tt,text="File Name"))
  tkgrid(entry.Name);
  OnOk <- function(){
    NameVal <- tclvalue(name);
    tkdestroy(tt);
    tkpostscript(frame,file=NameVal);
    tkmessageBox(title= "Info",message="Tree saved",type="ok")
  }
  OK.but <- tkbutton(tt,text=" save ",command=OnOk);
  tkbind(entry.Name,"<Return>",OnOk);
  tkgrid(OK.but);
  tkfocus(tt)
}


 .TRgui.exportROC <- function(trg.id){
  tt <- tktoplevel()
  rocList <- .TRgui.get(trg.id,"rocList")
  precList <- .TRgui.get(trg.id,"precList");
  rocColor <- .TRgui.get(trg.id,"rocColor");
  listVB <-  as.numeric(sapply(.TRgui.get(trg.id,"listVB"),function(x) tclvalue(x)));
  name <- tclVar("file.eps")
  entry.Name <- tkentry(tt,width="20",textvariable=name)
  tkgrid(tklabel(tt,text="File Name"))
  tkgrid(entry.Name);
  OnOk <- function(){
    NameVal <- tclvalue(name);
    tkdestroy(tt);
    postscript(NameVal)
   
	vr <- as.logical(as.numeric(tclvalue(.TRgui.get(trg.id,"vbROC"))));
	vp <- as.logical(as.numeric(tclvalue(.TRgui.get(trg.id,"vbPrec"))));
    curlist <- list();
    corlist <- list();
    if (vr) {curlist <- c(curlist,rocList[listVB==1]); corlist <- c(corlist,rocColor[listVB==1]);}
    if (vp) {curlist <- c(curlist,precList[listVB==1]); corlist <- c(corlist,rocColor[listVB==1]);}
    plotROC(curlist,corlist)
    dev.off()
    tkmessageBox(title= "Info",message="ROC saved",type="ok")

  }
  OK.but <- tkbutton(tt,text=" save ",command=OnOk);
  tkbind(entry.Name,"<Return>",OnOk);
  tkgrid(OK.but);
  tkfocus(tt)
 }
.TRgui.saveTree <- function(id){
  tr <- .TRgui.get(id,"tree")
  tt <- tktoplevel()
  name <- tclVar("varname")
  entry.Name <- tkentry(tt,width="20",textvariable=name)
  tkgrid(tklabel(tt,text="Var name"))
  tkgrid(entry.Name);
  OnOk <- function()
    {
      NameVal <- tclvalue(name)
      tkdestroy(tt)
      assign(NameVal,tr,.GlobalEnv)
    }
  OK.but <- tkbutton(tt,text=" set ",command=OnOk)
  tkbind(entry.Name,"<Return>",OnOk)
  tkgrid(OK.but)
  tkfocus(tt)
 }
  
.TRgui.refresh <-function(trg.id){
  trg <- .TRgui.get(trg.id);
  bbox <- tclvalue(tcl(trg$treeCanvas,"bbox","all"));
  bbox <- as.numeric(unlist(strsplit(bbox,split=" ")));
  if(length(bbox>1)){
  tkconfigure(trg$treeCanvas, scrollregion =c(bbox[[1]],bbox[[2]],bbox[[3]],bbox[[4]]));
  .TRgui.set(trg.id,"treeScrollRegion",bbox);}
}


.TRgui.create.node <- function(trg.id, id, label=NULL, x=0, y=0) {
  trg <- .TRgui.get(trg.id)
  node.size <-trg$sizeNodeList[[id]];
  node.color <- trg$colorNode[[id]];
  node.out.color <- trg$outColorNode[[id]];
  item <- tkcreate(trg$treeCanvas, "oval", x-node.size, y-node.size,
                   x+node.size, y+node.size, width=1,
                   outline=node.out.color,  fill=node.color)
  tkaddtag(trg$treeCanvas, "node", "withtag", item)
  tkaddtag(trg$treeCanvas, paste("n-", id, sep=""), "withtag", item)
  if (!(is.null(label))){
    litem <- tkcreate(trg$treeCanvas, "text", x,y,text=label)
    tkaddtag(trg$treeCanvas, "nodelabel", "withtag", litem)
    tkaddtag(trg$treeCanvas, paste("nlabel-", id, sep=""), "withtag", litem)
  }
    item;
}


.TRgui.create.edge <- function(trg.id, from, to, id,label=NULL) {
  trg <- .TRgui.get(trg.id);
  from.c <- trg$treeCoords[from,]
  to.c   <- trg$treeCoords[to,]
  edge.color <- "black";
  edge.width <-"2";
  phi <- atan2(to.c[2]-from.c[2], to.c[1]-from.c[1])
  r <- sqrt( (to.c[1]-from.c[1])^2 + (to.c[2]-from.c[2])^2 )
  to.c[1] <- from.c[1] + (r-trg$sizeNodeList[[to]])*cos(phi)
    to.c[2] <- from.c[2] + (r-trg$sizeNodeList[[to]])*sin(phi)
  from.c[1] <- from.c[1] +trg$sizeNodeList[[from]]*cos(phi)
  from.c[2] <- from.c[2] + trg$sizeNodeList[[from]]*sin(phi)

  coords <- c(from.c[1], from.c[2], to.c[1], to.c[2])
  args <- c(list(trg$treeCanvas, "line"),
            coords, 
            list(fill=edge.color, activefill="red", 
                   tags=c("edge", paste(sep="", "edge-", id),
                     paste(sep="", "from-", from),
                     paste(sep="", "to-", to))))
  do.call(tkcreate, args)
  if (!(is.null(label))){
    label.x <- (to.c[1]+from.c[1])/2
    label.y <- (to.c[2]+from.c[2])/2
    litem <- tkcreate(trg$treeCanvas,"text",label.x,label.y,
                      text=as.character(label));
    tkaddtag(trg$treeCanvas,"label","withtag",litem);
    tkaddtag(trg$treeCanvas,paste(sep="","elabel-",id),"withtag",litem)
  }
  
}

.TRgui.create.nodes <- function(trg.id) {
  trg <- .TRgui.get(trg.id);
  tree <- trg$tree;
  treeType <- .TRgui.get(trg.id,"treeType");
  nodeLab <- NULL

  if (treeType == 1){
    nodeLab <-  unlist(lapply(tree$nodes,function(x) {
    
    if (!(sum(is.na(tree$split[[x]])))){
        return(tree$split[[x]]$name)
    }
    else return("");
  }))
  }
  .TRgui.set(trg.id,"nodeLab",nodeLab);
  if (!(is.null(nodeLab))){
    mapply(function(n, l, x, y) .TRgui.create.node(trg.id, n, l, x, y),
           tree$nodes, nodeLab, trg$treeCoords[,1], trg$treeCoords[,2])
  }
  else{
    mapply(function(n,  x, y) .TRgui.create.node(trg.id, n, NULL, x, y),
           tree$nodes,  trg$treeCoords[,1], trg$treeCoords[,2])
 }
 }


.TRgui.create.edges <- function(trg.id) {
  trg <- .TRgui.get(trg.id)
  tree <- trg$tree;
  edgematrix <- .TRgui.get(trg.id,"edgesList");

  edgeLab <- NULL;
  if (.TRgui.get(trg.id,"treeType") == 1){
    edgeLab <- unlist(lapply(tree$inner,function(x)
                                {sp <- tree$split[[x]];
                                 if (!(is.null(sp))){
				  if (sp$type==0)
                                   lab <-c(paste("<",format(sp$breaks,digits=3)),paste(">=",format(sp$breaks,digits=3)))
				else lab <- c(paste("!=",sp$breaks),paste("=",sp$breaks));
                                   return(strtrim(lab,8));
                                 }
                                 else{return(c("",""))}}))
  }
                               
  .TRgui.set(trg.id,"edgeLab",edgeLab);
  if (!(is.null(edgeLab))){
    mapply(function(from, to, id,l) .TRgui.create.edge(trg.id, from, to, id,l),
           edgematrix[,1],
           edgematrix[,2], 1:nrow(edgematrix),edgeLab)
  }
  else{
   mapply(function(from, to, id) .TRgui.create.edge(trg.id, from, to, id,NULL),
           edgematrix[,1],
           edgematrix[,2], 1:nrow(edgematrix))
 }
 }





.TRgui.update.node <- function(trg.id, id, x, y) {
  trg <- .TRgui.get(trg.id)
  node.size <- trg$sizeNodeList[[id]];
  node.color <- trg$colorNode[[id]];
  node.out.color <- trg$outColorNode[[id]];
 
  # Vertex
  tkcoords(trg$treeCanvas, paste("node&&n-", id, sep=""),
           x-node.size, y-node.size,
           x+node.size, y+node.size)
  # Label
  #  .TRgui.update.label(trg.id, id, x, y)
  
  # Edges
  edge.from.ids <- as.numeric(tkfind(trg$treeCanvas, "withtag",
                                     paste("from-", id, sep="")))
  edge.to.ids <- as.numeric(tkfind(trg$treeCanvas, "withtag",
                                   paste("to-", id, sep="")))
  for (i in seq(along=edge.from.ids)) {
    .TRgui.update.edge(trg.id, edge.from.ids[i])
  }
}

.TRgui.update.nodes <- function(trg.id) {
  trg <- .TRgui.get(trg.id)
  n <- trg$tree$nbNode;
  mapply(function(v, x, y) .TRgui.update.node(trg.id, v, x, y), 1:n,
         trg$treeCoords[,1], trg$treeCoords[,2])
 }
.TRgui.update.edges <- function(trg.id) {
  trg <- .TRgui.get(trg.id)
  n <- length(length(trg$tree$inner)*2);
  mapply(function(v) .TRgui.update.edgeById(trg.id, v), 1:n);
 }

# Update an edge with given itemid (not edge id!)
.TRgui.update.edge <- function(trg.id, itemid) {
  trg <- .TRgui.get(trg.id)
  tags <- as.character(tkgettags(trg$treeCanvas, itemid))
  from <- as.numeric(substring(grep("from-", tags, value=TRUE, fixed=TRUE),6))
  to <- as.numeric(substring(grep("to-", tags, value=TRUE, fixed=TRUE),4))
  from.c <- trg$treeCoords[from,]
  to.c <- trg$treeCoords[to,]
    phi <- atan2(to.c[2]-from.c[2], to.c[1]-from.c[1])
  r <- sqrt( (to.c[1]-from.c[1])^2 + (to.c[2]-from.c[2])^2 )
  to.c[1] <- from.c[1] + (r-trg$sizeNodeList[[to]])*cos(phi)
    to.c[2] <- from.c[2] + (r-trg$sizeNodeList[[to]])*sin(phi)
  from.c[1] <- from.c[1] +trg$sizeNodeList[[from]]*cos(phi)
  from.c[2] <- from.c[2] + trg$sizeNodeList[[from]]*sin(phi)

  tkcoords(trg$treeCanvas, itemid, from.c[1], from.c[2], to.c[1], to.c[2]);
}  


.TRgui.update.edgeById <- function(trg.id, id) {
  
  trg <- .TRgui.get(trg.id)
  itemid <- as.numeric(tkfind(trg$treeCanvas,"withtag",paste("edge-",id,sep="")));
  .TRgui.update.edge(trg.id,itemid);
}  





###################################################################
# Internal functions, handling data about layout
###################################################################

.TRgui.scale <- function(trg.id){
  trg <- .TRgui.get(trg.id);
  width <- as.numeric(tkwinfo("width",trg$treeCanvas));
  height <- as.numeric(tkwinfo("height",trg$treeCanvas));
  treeCoords <- trg$treeCoords;
  treeCoords[,1] <- trg$treeCoordsNorm[,1]*(width-2*trg$panX)+trg$panX;
  treeCoords[,2] <- trg$treeCoordsNorm[,2]*(height-2*trg$panY)+trg$panY;
  .TRgui.set(trg.id,"width",width);
  .TRgui.set(trg.id,"height",height);
  .TRgui.set(trg.id,"treeCoords",treeCoords);
  
}
  
.TRgui.computeCoords <- function(trg.id){
  trg <- .TRgui.get(trg.id);
  tree <- trg$tree;
  nodeSize <-trg$nodeSize;
  listedge <- lapply(tree$inner,function(x){
    return(c(x,tree$kidslist[[x]][[1]],x,tree$kidslist[[x]][[2]]))
  });
  edgematrix <- matrix(unlist(listedge),ncol=2,byrow=TRUE);
  treeCoords <- layout.norm(layout.reingold.tilford(graph.edgelist(edgematrix-1),root=0,mode="all"),xmin=0,xmax=1,ymin=0,ymax=1);

  propPos <- tree$pcount/(tree$pcount+tree$ncount);
  propNb <- (tree$pcount+tree$ncount)/(tree$pcount[[1]]+tree$ncount[[1]]);
  scaleM <- log(2)/log(1+1/min(propNb));
  propNb <- (trg$maxNodeSize-trg$minNodeSize)/(1-scaleM)*(log(2)/log(1+1/propNb)-1)+trg$maxNodeSize;
  pal <- diverge_hcl(100,h=c(0,120),c=100,l=c(70,100),power=1,gamma=1);

  propPos <- pal[ceiling(propPos*99)+1];
  outColor <- rep("black",length(propPos))
  if (trg$treeType == 1){
    outColor[trg$tree$Lnode] <- "green"
    outColor[trg$tree$Rnode] <- "red"
  }
  
  .TRgui.set(trg.id,"sizeNodeList",propNb);
  .TRgui.set(trg.id,"colorNode",propPos);
  .TRgui.set(trg.id,"outColorNode",outColor);
  .TRgui.set(trg.id,"treeCoords",treeCoords);
  .TRgui.set(trg.id,"treeCoordsNorm",treeCoords);
  .TRgui.set(trg.id,"edgesList",edgematrix)
}  


.TRgui.reinitGUI <- function(trg.id){
  .TRgui.computeCoords(trg.id);
  .TRgui.scale(trg.id);
  .TRgui.update.nodes(trg.id);
  .TRgui.refresh(trg.id);

 top <- .TRgui.get(trg.id,"top");
tkfocus(top);
}


###################################################################
# Internal functions, handling the internal environment
###################################################################

.TRgui.new <- function(trg) {
  id <- get(".next", .TRgui.env)
  assign(".next", id+1, .TRgui.env)
  assign("tmp", trg, .TRgui.env)
  cmd <- paste("trg.", id, "<- tmp", sep="")
  eval(parse(text=cmd), .TRgui.env)
  rm("tmp", envir=.TRgui.env)
  id
}

.TRgui.get <- function(trg.id, what=NULL) {
  if (is.null(what)) {
    get(paste("trg.", trg.id, sep=""), .TRgui.env)
  } else {
    cmd <- paste("trg.", trg.id, "$", what, sep="")
    eval(parse(text=cmd), .TRgui.env)
  }
}

.TRgui.set <- function(trg.id, what, value) {
  assign("tmp", value, .TRgui.env)
  cmd <- paste(sep="", "trg.", trg.id, "$", what, "<-tmp")
  eval(parse(text=cmd), .TRgui.env)
  rm("tmp", envir=.TRgui.env)
}


.TRgui.deselect.all <- function(trg.id) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  ids <- as.numeric(tkfind(treeCanvas, "withtag", "selected"))
  for (i in ids) {
    .TRgui.deselect.this(trg.id, i)
  }
}

.TRgui.select.all.nodes <- function(trg.id) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  nodes <- as.numeric(tkfind(treeCanvas, "withtag", "node"))
  for (i in nodes) {
    .TRgui.select.node(trg.id, i)
  }
}

.TRgui.select.some.nodes <- function(trg.id, vids) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  vids <- unique(vids)
  for (i in vids) {
    tkid <- as.numeric(tkfind(treeCanvas, "withtag",
                              paste(sep="", "node&&n-", i)))
    .TRgui.select.node(trg.id, tkid)
  }
}


.TRgui.select.node <- function(trg.id, tkid) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  tkaddtag(treeCanvas, "selected", "withtag", tkid)
  tkitemconfigure(treeCanvas, tkid, "-outline", "blue",
                  "-width", 2);
  
  .TRgui.updateROC(trg.id);
}

.TRgui.deselect.node <- function(trg.id, tkid) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  outColorNode <- .TRgui.get(trg.id,"outColorNode");
  tkdtag(treeCanvas, tkid, "selected")
  trg <- .TRgui.get(trg.id)
  tags <- as.character(tkgettags(treeCanvas, tkid))
  id <- as.numeric(substring(tags[pmatch("n-", tags)], 3))
  tkitemconfigure(treeCanvas, tkid, "-outline",outColorNode[[id]],
                  "-width", 1)
  .TRgui.updateROC(trg.id);
}

.TRgui.select.current <- function(trg.id) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  tkid <- as.numeric(tkfind(treeCanvas, "withtag", "current"))
  .TRgui.select.this(trg.id, tkid)
}

.TRgui.deselect.current <- function(trg.id) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  tkid <- as.numeric(tkfind(treeCanvas, "withtag", "current"))
  .TRgui.deselect.this(trg.id, tkid)
}

.TRgui.select.this <- function(trg.id, tkid) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  trg <- .TRgui.get(trg.id);
  tags <- as.character(tkgettags(treeCanvas, tkid))
  id <- 1
  if ("node" %in% tags) {
    id<- as.numeric(substring(tags[pmatch("n-",tags)],3));
    .TRgui.select.node(trg.id, tkid)
  }else if ("nodelabel" %in% tags){
    id <- as.numeric(substring(tags[pmatch("nlabel-",tags)],8));
    tkid <- as.character(tkfind(treeCanvas,"withtag",paste(sep="","node&&n-",id)))
    .TRgui.select.node(trg.id,tkid)
  }
  txt <- .TRgui.info2str(trg.id,id);
  tkconfigure(trg$infoLabel,text=txt);
}

.TRgui.deselect.this <- function(trg.id, tkid) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  tags <- as.character(tkgettags(treeCanvas, tkid))
  if ("node" %in% tags) {
    .TRgui.deselect.node(trg.id, tkid)
  }
}
.TRgui.get.selected.nodes <- function(trg.id) {
  treeCanvas <- .TRgui.get(trg.id, "treeCanvas")
  tkids <- as.numeric(tkfind(treeCanvas, "withtag", "node&&selected"))

  ids <- sapply(tkids, function(tkid) {
    tags <- as.character(tkgettags(treeCanvas, tkid))
    id <- as.numeric(substring(tags [pmatch("n-", tags)], 3))
    id})

  ids
}

.TRgui.clean <- function(trg.id){
  treeCanvas <- .TRgui.get(trg.id,"treeCanvas");
  tkdelete(treeCanvas,"all");
}


TRgui.close <- function(trg.id, window.close=TRUE) {
  if (window.close) {
    cmd <- paste(sep="", "trg.", trg.id, "$top")
    top <- eval(parse(text=cmd), .TRgui.env)
    tkbind(top, "<Destroy>", "")
    tkdestroy(top)
  }
  cmd <- paste(sep="", "trg.", trg.id)
#  rm(list=cmd, envir=.TRgui.env)
}




################################################################################
# Two Sample interface






TwoSampleGui <- function(){

  top <- tktoplevel(height="200",width="100")
  mainGuiEnv <- new.env();
  tktitle(top) <- "TwoSample GUI"
  mainFrame <- tkframe(top,height="200",width="100",borderwidth=2);

  infoFrame <- tkframe(mainFrame,borderwidth=5,width=100);
  LRFrame <- tkframe(mainFrame,borderwidth=5,width=100,relief="groove");
  TRFrame <-tkframe(mainFrame,borderwidth=5,width=100,relief="groove");
  
  optTRFrame <- tkframe(TRFrame,borderwidth=2,width=100);
  optLRFrame <- tkframe(LRFrame,borderwidth=2,width=100);

  #info frame
  dataset1 <- tclVar("");
  dataset2 <- tclVar("");
  alpha <- tclVar("5");
  split <- tclVar("60");
  
  entry.dataset1 <- tkentry(infoFrame,width="10",textvariable=dataset1);
  entry.dataset2 <- tkentry(infoFrame,width="10",textvariable=dataset2);
  entry.alpha <- tkentry(infoFrame,width="5",textvariable=alpha);
  entry.split <- tkentry(infoFrame,width="5", textvariable = split);
  tkgrid(tklabel(infoFrame,text="1st Data set: "),entry.dataset1);
  tkgrid(tklabel(infoFrame,text="2nd Data set: "),entry.dataset2);
  tkgrid(tklabel(infoFrame,text="Learning % size: "),entry.split);
  tkgrid(tklabel(infoFrame,text="Confidence level: "),entry.alpha);


  #TreeRank options frame
  dftOpt <- growing_ctrl();
  minOptTR <- tclVar(dftOpt$minsplit);
  maxOptTR <- tclVar(dftOpt$maxdepth);
  mincritOptTR <- tclVar(dftOpt$mincrit);
    forestOptTR<-tclVar(0);

  varSplitTR <- tclVar(100);
  dataSplitTR <- tclVar(100);
  nfcvOptTR <-tclVar("0");
  replOptTR <- tclVar("1");
  entry.minOptTR <-tkentry(optTRFrame,width="5",textvariable=minOptTR);
  entry.mincritOptTR <-tkentry(optTRFrame,width="5",textvariable=mincritOptTR);
  entry.maxOptTR <-tkentry(optTRFrame,width="5",textvariable=maxOptTR);
  entry.forestOptTR <- tkentry(optTRFrame,width=5,textvariable=forestOptTR);
  entry.varSplitTR <- tkentry(optTRFrame,width="5",textvariable=varSplitTR);
  entry.dataSplitTR <- tkentry(optTRFrame,width="5",textvariable= dataSplitTR);
  entry.nfcvOptTR <- tkentry(optTRFrame,width=5,textvariable=nfcvOptTR);
  entry.replOptTR <- tkcheckbutton(optTRFrame,variable = replOptTR);

    tkgrid(tklabel(optTRFrame,text="Minimum Split"),entry.minOptTR,
         tklabel(optTRFrame,text="Forest"),entry.forestOptTR);
  tkgrid(tklabel(optTRFrame,text="Maximum Depth"),entry.maxOptTR,
         tklabel(optTRFrame,text="%Data. split"),entry.dataSplitTR);
  tkgrid(tklabel(optTRFrame,text="Min. Criteria"),entry.mincritOptTR,
         tklabel(optTRFrame,text="Replace"),entry.replOptTR);
  tkgrid(tklabel(optTRFrame,text="n-fold Cross Validation "),entry.nfcvOptTR,
	    tklabel(optTRFrame,text="%Var. split"),entry.varSplitTR);

  tkgrid(tklabel(TRFrame,text="TreeRank Options"));
  tkgrid(optTRFrame);
  
  
  
  #LeafRank
  ## Scan the environment for new LeafRank functions definition
  LRlist <- ls(pattern="LR.*.def",name=globalenv());
  nameLR <- list(LRCart.def$name,LRsvm.def$name,LRforest.def$name);
  funNameLR <- list(LRCart.def$fun,LRsvm.def$fun ,LRforest.def$fun);
  optionLR <- list(LRCart.def$opt,LRsvm.def$opt,LRforest.def$opt);
  opt2cmdLR <- list(LRCart.def$opt2cmd,LRsvm.def$opt2cmd,LRforest.def$opt2cmd);
  lbLR <- tklistbox(LRFrame,height=3,width=10,selectmode="single");
  tkinsert(lbLR,"end",LRCart.def$name);
  tkinsert(lbLR,"end",LRsvm.def$name);
  tkinsert(lbLR,"end",LRforest.def$name);
  for (x in LRlist){
    obj <- eval(parse(text=x),globalenv())
    nameLR <- c(nameLR,obj$name);
    funNameLR <- c(funNameLR,obj$fun);
    optionLR <- c(optionLR,list(obj$opt));
    opt2cmdLR <- c(opt2cmdLR,list(obj$opt2cmd));
    tkinsert(lbLR,"end",obj$name)
  }

  tkselection.set(lbLR,0);
  assign("curLeafRank",1,mainGuiEnv);
  tkgrid(tklabel(LRFrame,text="LeafRank: "),lbLR);

  assign("listVarLR",list(),mainGuiEnv);
  assign("listWidgetLR",list(),mainGuiEnv);

  ## LR Frame building  
  buildLRopt <- function(){
    listVarLR <- list()
    id <- as.numeric(tkcurselection(lbLR))+1;
    if (length(id)<1)
      id <- 1;
    listOptLR <- optionLR[[id]];
    listSlaves <- tclvalue(tkgrid.slaves(optLRFrame));
    if (listSlaves[[1]] !=""){
      sapply(unlist(strsplit(listSlaves,split=" ")),tkgrid.remove)
    }
    listWidgetLR <- list()
    listGrid <- list();
    for (i in 1:length(listOptLR)){
      if (listOptLR[[i]]$type=="entry"){
        tmp <- tclVar(listOptLR[[i]]$default)
        listVarLR <- c(listVarLR,list(tmp))
        listWidgetLR<-c(listWidgetLR,list(tkentry(optLRFrame,width="5",textvariable=tmp)))
      }
      if (listOptLR[[i]]$type=="check"){
        tmp <- tclVar(listOptLR[[i]]$default);
        listVarLR <- c(listVarLR,list(tmp))
        listWidgetLR<-c(listWidgetLR,list(tkcheckbutton(optLRFrame,variable=tmp)))
      }
      if (listOptLR[[i]]$type=="listbox"){
        tmplb <- tklistbox(optLRFrame,height=3,width=6,selectmode="single");
        for (na in listOptLR[[i]]$choiceName){
          tkinsert(tmplb,"end",na);
        }
        tkselection.set(tmplb,listOptLR[[i]]$default);
        listVarLR <- c(listVarLR,list(tmplb));
        listWidgetLR<-c(listWidgetLR,list(tmplb))

      }
      tmpW <- listWidgetLR[[length(listWidgetLR)]]
    }
    for (i in (1:(length(listWidgetLR)/2))){
      tkgrid(tklabel(optLRFrame,text=listOptLR[[(i*2-1)]]$name),
             listWidgetLR[[(i*2-1)]],
             tklabel(optLRFrame,text=listOptLR[[(i*2)]]$name),
             listWidgetLR[[(i*2)]]);
    }
    if (length(listWidgetLR) %% 2 >0)
      tkgrid(tklabel(optLRFrame,text=listOptLR[[length(listOptLR)]]$name),
             listWidgetLR[[length(listOptLR)]]);
    assign("listWidgetLR",listWidgetLR,mainGuiEnv)
    assign("listVarLR",listVarLR,mainGuiEnv)
    assign("curLeafRank",id,mainGuiEnv)
    
  }
  
  buildLRopt();
  tkgrid(optLRFrame)
  tkbind(lbLR,"<<ListboxSelect>>",buildLRopt);


  ##Command Line building
  
  cmdLine <- function(){
    dataset1V <-  tclvalue(dataset1);
    dataset2V <- tclvalue(dataset2);
    alphaV <- tclvalue(alpha);
    splitV <- tclvalue(split);
    
    idLR <- get("curLeafRank",mainGuiEnv);
                                        #LeafRank options
    listOptLR <- optionLR[[idLR]]
    optPar <- list();
    listVarLR <- get("listVarLR",mainGuiEnv)
    for(i in 1:length(listVarLR)){
      
      if (listOptLR[[i]]$type=="listbox"){
        id <- as.numeric(tkcurselection(listVarLR[[i]]))+1;
        tmp<- paste("c(optPar,",listOptLR[[i]]["optName"],"=\"",
                    listOptLR[[i]]$choice[id],"\")",sep="");
      }else{
        tmp <- paste("c(optPar,",listOptLR[[i]]["optName"],"=",tclvalue(listVarLR[[i]]),")",sep="");
      }
      optPar <- eval(parse(text=tmp));
      
    }
    optLR <- opt2cmdLR[[idLR]](optPar);
                                        #TreeRank options
    minOptTRV <- as.double(tclvalue(minOptTR));
    maxOptTRV <- as.double(tclvalue(maxOptTR));
    mincritOptTRV <-as.double(tclvalue(mincritOptTR));
    nfcvOptTRV <- as.integer(tclvalue(nfcvOptTR));
    varSplitTRV <- as.numeric(tclvalue(varSplitTR));
    dataSplitTRV <- as.numeric(tclvalue(dataSplitTR));
    forestTRV <- as.numeric(tclvalue(forestOptTR));

   replTRV <- as.logical(as.numeric(tclvalue(replOptTR)));




        grTRctrl <- paste("growing_ctrl(maxdepth=",maxOptTRV,",mincrit=",mincritOptTRV,",minsplit=",minOptTRV,")",sep="");


    if  (forestTRV>1){
    TRcmd <-  paste("TreeRankForest(ntree=",forestTRV,",replace=",replTRV,",sampsize=",(dataSplitTRV/100),",varsplit=", (varSplitTRV/100),",growing=",grTRctrl,",nfcv=",nfcvOptTRV,",LeafRank= function(...){",funNameLR[[idLR]],"(",optLR,",...)},...)",sep="");
  }
    else     TRcmd <-  paste("TreeRank(growing=",grTRctrl,",nfcv=",nfcvOptTRV,",LeafRank= function(...){",funNameLR[[idLR]],"(",optLR,",...)},...)",sep="");
    cmd <- paste("TwoSample(x=",dataset1V,",y=",dataset2V,",split=",splitV,
                 ",alpha=",alphaV,",TRalgo=function(...) ",TRcmd,")",sep="");
    print(cmd);
  return(cmd);
  
  }
  
  runGui <- function(){
    wobj <- eval(parse(text=cmdLine()));
   assign("wobj",wobj,.GlobalEnv);
   id <- TRplot(wobj$tree);
    .TRgui.addROC(id,getCurves(wobj$tree,wobj$test),"Test sample");
                                        #  return(eval(parse(text=cmdLine())));
    print(wobj$wtest);
    
  }

  exportCmd <- function(){
    cmd <- cmdLine();
    tt <- tktoplevel()
    name <- tclVar("funName");
    entry.Name <- tkentry(tt,width="20",textvariable=name)
    tkgrid(tklabel(tt,text="Fun name"));
    OnOk <- function()
      {
        NameVal <- tclvalue(name);
        tkdestroy(tt)
        assign(NameVal,cmd,.GlobalEnv);
      }
    OK.but <- tkbutton(tt,text=" set ",command=OnOk);
    tkbind(entry.Name,"<Return>",OnOk)
    tkgrid(entry.Name)
    tkgrid(OK.but)
    tkfocus(tt);
  }

  but.run <-tkbutton(mainFrame,text="run",command =runGui);
  #but.exp <- tkbutton(mainFrame,text="export cmd",command=exportCmd);
  tkgrid(infoFrame);
  
  tkgrid(LRFrame);
  tkgrid(TRFrame);
  tkgrid(but.run);
  #tkgrid(but.exp);
  tkgrid(mainFrame);
  tkfocus(top);
}

errorGui <- function(err){
print(err);
}
#line 1 "d:/Rcompile/CRANpkg/local/2.12/TreeRank/R/TRTools.R"
#################################################################################
#
# Many common auxiliary functions for TreeRank and LeafRank:
#   - Pruning
#   - ROC computing
#   - Tree information computing
#
#################################################################################

#################################################################################
#
# checkImpure(weights,y) : check if at least two labels with weights != 0
#                           exists in data y
#
#################################################################################

checkImpure <- function(w,y){
  if (length(y)<2)
    return(FALSE);
  ret <- FALSE
	ytmp <- y[w >0]	
  def <- ytmp[1]
	for (i in 2:length(ytmp)){
		if (ytmp[i] != def) 
		{
			ret <- TRUE
			break;
		}
	}
	ret
}



#################################################################################
#
# growing_ctrl(minsplit,maxdepth,mincrit): growing tree control function
#
#
#################################################################################

growing_ctrl <- function(minsplit = 50,maxdepth =10, mincrit = 0) {

    ret <- list(minsplit = minsplit, maxdepth = maxdepth, mincrit= mincrit)
    return(ret)
}



#################################################################################
#################################################################################
##
## ROC manipulation
##
#################################################################################
#################################################################################

#################################################################################
#
#  auc(roc) :
#  Compute the auc from points list describing the roc
#
#################################################################################


auc <- function(roc){
  l = nrow(roc);
  auc <- sum((roc[2:l,1] - roc[1:(l-1),1])*(roc[2:l,2] +roc[1:(l-1),2]))/2
  auc
}

#################################################################################V1.5
#
#  getROC(tree,data) :
#  Compute the roc. If data is null, return the learning roc.
#
#################################################################################


getROC <- function(obj,data =NULL){
  UseMethod("getROC");
}


getPREC <- function(obj,data =NULL){
  UseMethod("getPREC");
}


getCurves <- function(obj,data=NULL){
UseMethod("getCurves");
}

getCurves.TR_TreeRank <- function(obj,data=NULL){
tree <- obj;
  if (!inherits(tree,"TR_TreeRank"))
    stop("object not of class TR_TreeRank");
  
  if(is.null(data))
data <- obj$data;
  score <- predict(tree,data);
  #Extract the name of the response variable
  resname <-all.vars(terms(tree))[[attr(terms(tree),"response")]];
  response <- data[[resname]];
  #compute the predicted score for data
   prec <- getPRECfromScore(score,response,tree$bestresponse);
  roc<- getROCfromScore(score,response,tree$bestresponse);
  c(list(roc),list(prec))
}          



getPREC.TR_TreeRank <- function(obj, data=NULL){
tree <- obj;
  if (!inherits(tree,"TR_TreeRank"))
    stop("object not of class TR_TreeRank");
  
  if(is.null(data)){
  data <- tree$data
  }
  score <- predict(tree,data);
  #Extract the name of the response variable
  resname <-all.vars(terms(tree))[[attr(terms(tree),"response")]];
  response <- data[[resname]];
  #compute the predicted score for data
   res <- getPRECfromScore(score,response,tree$bestresponse);
  res
}          

getROC.TR_TreeRank <- function(obj, data=NULL){
tree <- obj;
  if (!inherits(tree,"TR_TreeRank"))
    stop("object not of class TR_TreeRank");
  
  if(is.null(data)){
    return(matrix(c(tree$lalpha[tree$leafOrdered],1,tree$lbeta[tree$leafOrdered],1),length(tree$leafOrdered)+1))
  }
  score <- predict(tree,data);
  #Extract the name of the response variable
  resname <-all.vars(terms(tree))[[attr(terms(tree),"response")]];
  response <- data[[resname]];
  #compute the predicted score for data

  res <- getROCfromScore(score,response,tree$bestresponse);
  res
}

getPREC.TR_forest <- function(obj,data=NULL){
tree <- obj;
  if (!(inherits(tree,"TR_forest")))
    stop("objectnot of class TR_forest");
  if (is.null(data))
    data <- tree$forest[[1]]$data
    score <- predict(tree,data);
    resname<- all.vars(terms(tree$forest[[1]]))[[attr(terms(tree$forest[[1]]),"response")]];
    response <- data[[resname]];
      roc <- getPRECfromScore(score,response,tree$forest[[1]]$bestresponse);
     roc
}

getROC.TR_forest <- function(obj,data=NULL){
tree <- obj;
  if (!(inherits(tree,"TR_forest")))
    stop("objectnot of class TR_forest");
  if (is.null(data))
    data <- tree$forest[[1]]$data
    score <- predict(tree,data);
    resname<- all.vars(terms(tree$forest[[1]]))[[attr(terms(tree$forest[[1]]),"response")]];
    response <- data[[resname]];

    roc <- getROCfromScore(score,response,tree$forest[[1]]$bestresponse);
  roc
}




getCurves.TR_forest <- function(obj,data=NULL){
tree <- obj;
  if (!(inherits(tree,"TR_forest")))
    stop("objectnot of class TR_forest");
  if (is.null(data))
    data <- tree$forest[[1]]$data
    score <- predict(tree,data);
    resname<- all.vars(terms(tree$forest[[1]]))[[attr(terms(tree$forest[[1]]),"response")]];
    response <- data[[resname]];

    roc <- getROCfromScore(score,response,tree$forest[[1]]$bestresponse);
    prec <- getPRECfromScore(score,response,tree$forest[[1]]$bestresponse);
  c(list(roc),list(prec))
}



#################################################################################
#
#  getROCfromScore(score,y,bestresponse) :
#  Compute the roc from the score list.
#
#################################################################################




getROCfromScore<- function (score, y, bestresponse){
	orderedIndex <- order(-score)
        alphaList <-  0
	betaList <- 0
	curScore <- score[[orderedIndex[1]]]
	curAlpha <- 0
	curBeta <- 0
	pcount <- 0
	ncount <- 0
	for (i in 1:length(orderedIndex)){
		if(curScore != score[[orderedIndex[i]]])
		{
		   alphaList <- c(alphaList,curAlpha)
		   betaList <- c(betaList,curBeta)
                   		   curScore <- score[[orderedIndex[i]]]	
		}
	if (y[orderedIndex[i]] == bestresponse)
	{
		curBeta <- curBeta +1
		pcount <- pcount +1	
	}
	else {
		curAlpha <- curAlpha +1
		ncount <- ncount +1 	
	}
	}
	alphaList <- c(alphaList,curAlpha)
	betaList <- c(betaList,curBeta)
	alphaList <- alphaList/ncount
	betaList <- betaList/pcount
	matrix(c(alphaList,betaList),length(alphaList))
}

getPRECfromScore <- function(score,y,bestresponse){
  orderedIndex <- order(-score);
  alphaList <-  0
  betaList <- 0
  curScore <- score[[orderedIndex[1]]]
  curAlpha <- 0
  curBeta <- 0
  pcount <- 0
  ncount <- 0
  for (i in 1:length(orderedIndex)){
    if(curScore != score[[orderedIndex[i]]])
      {
        alphaList <- c(alphaList,curAlpha)
        betaList <- c(betaList,curBeta)
        curScore <- score[[orderedIndex[i]]]	
      }
    if (y[orderedIndex[i]] == bestresponse)
      {
        curBeta <- curBeta +1
        pcount <- pcount +1	
      }
    else {
      curAlpha <- curAlpha +1
      ncount <- ncount +1 	
    }
  }

  	
  alphaList <- c(alphaList[-1],curAlpha)
  betaList <- c(betaList[-1],curBeta)
  prec <- c(0,betaList/pcount,1);
  rec <-  c(1,betaList/(alphaList+betaList),0);
  matrix(c(prec,rec),length(prec))
}
#prec TP/TP+FP
# recall TP/TP+FN







#################################################################################
#################################################################################v1
##
##  Tree manipulation
##
#################################################################################
#################################################################################

rpart2TR <- function(tree,bestresponse){
  nbnode <- nrow(tree$frame);

  frame <- tree$frame;
  splits <- tree$splits
  sortIdx <- order(as.numeric(rownames(frame)),decreasing=TRUE);
  sortSplit <- as.numeric(rownames(frame))[which(frame$var != "<leaf>")];
  sortSplit <- order(sortSplit);
  newnodestack <- list();
  pcInit <- sum(tree$y == bestresponse);
  ncInit <- length(tree$y) -pcInit;
  pInit <- pcInit/(pcInit+ncInit);
  idsplit <- length(sortSplit);

  kidslist <- list();
  parentslist <- array();
  split <- list();
  isleaf <- array();
  ldauc <- array();
  lalpha <- array();
  lbeta <- array();
  ncount <- ncInit;
  pcount <- pcInit;
  d <-c(1);
  depth <-array();
  sign <- array();
  parentslist[1] <- NA;
  if (nbnode <2){
    kidslist <- list();
    nbNode <- 1;
    # return(party(ret,data = tree$model,terms=tree$terms));
  }
else{

  for (i in sortIdx){
    d <- floor(log2(as.numeric(rownames(frame)[[i]])))+1;
    if (frame$var[[i]] == "<leaf>"){
      pcount[i] <- sum(tree$where==i & tree$y == bestresponse);
      ncount[i] <- sum(tree$where==i & tree$y !=bestresponse);
      ldauc[i]<-0;
      depth[i]<-d;
      split[i]<-NA;
      kidslist[i]<-NA;
      isleaf[i]<-TRUE;
    }
    else{
      if ((length(newnodestack)<2) || (idsplit<1)){
        stop("Error converting rpart tree to TR tree");
      }

      lnode <- newnodestack[[2]];
      rnode <- newnodestack[[1]];
      pcount[i]<-pc <- pcount[lnode]+pcount[rnode];
      ncount[i]<-nc <- ncount[lnode] + ncount[rnode];
      npc <- pcount[lnode];
      nnc <- ncount[lnode];
      ldauc[i]<- dauc <- -((pc/pcInit)*(nnc/ncInit)-(nc/ncInit)*(npc/pcInit))/2
      sign[i] <- -1;
      if (dauc<0){
        ldauc[i]<- dauc <- -dauc;
        sign[i] <- 1;
      }
      idVar <- which(names(tree$model)==frame$var[[i]])
      tmpname <- as.character(frame[i,"var"]);

      if (attributes(tree$terms)$dataClasses[tmpname] == "numeric"){
        br <- as.numeric(splits[,"index"][[sortSplit[[idsplit]]]])
      split[i]<-list(list(idVar=idVar,name=tmpname,breaks = br,type=0));
	}
      else
	{
 	br <- splits[,"index"][[sortSplit[[idsplit]]]];
	lev <- which(tree$csplit[br,] == 3);
	levVal <- attr(tree,"xlevels")[tmpname][[1]];
	# print(lev)
	lev <- strsplit(levVal, " ")[lev];
      	split[i]<-list(list(idVar=idVar,name=tmpname,breaks = lev,type=1));
	}
      #      sp <- partysplit(idVar, breaks = splits[,"index"][[sortSplit[[idsplit]]]],right=FALSE);
      kidslist[i] = list(c(lnode,rnode));
      parentslist[lnode]<-parentslist[rnode]<-i;
      depth[i]<-d;
      isleaf[i]<-FALSE;
      newnodestack <- newnodestack[c(-1,-2)]
      idsplit <- idsplit-1;
    }
    newnodestack <- c(newnodestack,i);
  }
  if ((length(newnodestack)>1) || (idsplit>0)){
    stop("Error converting rpart tree to TR");
  }
}
   ret <- list();
   ret$nbNode <- max(sortIdx);
   ret$root <- 1L;
   ret$nodes <- 1:ret$nbNode;
   ret$inner <- ret$nodes[!(isleaf)]
   ret$parentslist <- parentslist;
   ret$kidslist <- kidslist;
   ret$lalpha <- lalpha;
   ret$lbeta <- lbeta;
   ret$ldauc <- ldauc;
   ret$isleaf <- isleaf;
   ret$bestresponse <- bestresponse;
   ret$pcount <- pcount;
   ret$ncount <- ncount;
   ret$depth <- depth;
  ret$split <-  split;

#  ret <- data = tree$model,terms=tree$terms);
  ret;
}



#################################################################################
#
# ComputeTreeInfo(tree,pcount,ncount) : Compute auc, delta-auc, TP and FP rate
#         if pcount and ncount are both not null, the computation is done wrt these  lists
#           and not the internal pcount and ncount tree lists.
#
#################################################################################



ComputeTreeInfo <- function(tree,pcount = NULL, ncount = NULL){
  nbnode <- tree$nbNode;
  isleaf <- tree$isleaf;
  lalpha <- rep(0,nbnode);
  lbeta <- rep(0,nbnode);
  lauc <- rep(0,nbnode);
  ldauc <- rep(0,nbnode);
  if (is.null(pcount)){
    pcount <- tree$pcount;
    ncount <- tree$ncount;
  }
  pcinit <- pcount[[1]];
  ncinit <- ncount[[1]];

  nodestack <- tree$root;
  ldauc[[tree$root]] <- 0.;
  lauc[[tree$root]] <- 0.5;
  auc <- 0.5;
  dauc <- 0;

  # Breadth-first exploration of the tree
  while(length(nodestack)>0){
    dauc <- 0
    curnode <- nodestack[[1]];
    nodestack <- nodestack[-1];
     if (!(isleaf[[curnode]])){
        lkid<- tree$kidslist[[curnode]][[1]];
        rkid<- tree$kidslist[[curnode]][[2]];
      alphaR <- 1;
      betaR <- 1;

    #Computing new alpha and beta, cumulative TP and FP rate, auc and dauc
        nalpha <- lalpha[[curnode]] + ncount[[lkid]]/ncinit;
      nbeta <-  lbeta[[curnode]] + pcount[[lkid]]/pcinit;
      lalpha[[lkid]] <-lalpha[[curnode]];
      lbeta[[lkid]] <- lbeta[[curnode]];
      lalpha[[rkid]] <- nalpha;
      lbeta[[rkid]] <- nbeta;
      dauc <-  -((pcount[[curnode]]/pcinit)*(ncount[[lkid]]/ncinit) -(pcount[[lkid]]/pcinit)*(ncount[[curnode]]/ncinit))/2
      auc <-auc + dauc;
      lauc[[curnode]] <- auc;
      ldauc[[curnode]] <- dauc;
      nodestack <- c(nodestack, lkid,rkid);
  }

  }
  if (inherits(tree,"TR_LRCart")){
    sign <- unlist(lapply(tree$sign,function(x){if (is.null(x$sign))
                                                            return(0);
                                                            return(-1*x$sign);
                                                          }))
    ldauc <- sign*ldauc;
    return(list(lalpha = lalpha, lbeta = lbeta, lauc = lauc, ldauc = ldauc,sign=sign));

  }                       
  return(list(lalpha = lalpha, lbeta = lbeta, lauc = lauc, ldauc = ldauc));
}


#################################################################################
#
# subTreeRank : extract a subTree from the list of the new leaves and a tree
#
#################################################################################
 

subTreeRank <- function(tree,listnode)
{
   id <- tree$root;
   nextnode <- 1;
   kidslist <- list();
   parentslist <- array();
   LRList <- list();
   isleaf <-array();
   ldauc <- array();
   lalpha <- array();
   lbeta <- array();
   ncount <- array();
   pcount <- array();
   depth <- c(1);
   nodestack <- list(id);
   nodestackO <- list(id);
   curscore <- 1;
   nodeorder <- array();
   parentslist[1] <- NA;
   while(length(nodestackO)>0){
     idO <- nodestackO[[1]];
     nodestackO <- nodestackO[-1];
     id <- nodestack[[1]];
     nodestack <- nodestack[-1];
     isleaf[id]<-TRUE;
     lalpha[id]<-tree$lalpha[idO];
     lbeta[id] <-tree$lbeta[idO];
     ncount[id] <-tree$ncount[idO];
     pcount[id]<-tree$pcount[idO];
     depth[id] <- tree$depth[idO];
     nodeorder[id] <- curscore;
     curscore <- curscore +1;
     if ((tree$isleaf[idO]) || (idO %in% listnode)){
       kidslist[id]<-NA;
       ldauc[id]<-0;
     	LRList[id]<-NA;  
       next;
     }
     nodestack <- c(nextnode+1,nextnode+2,nodestack);
     nodestackO <- c(tree$kids[[idO]][[1]],
                     tree$kids[[idO]][[2]],nodestackO);
     parentslist[nextnode+1] <- id;
     parentslist[nextnode+2] <- id;
     kidslist[id] <- list(c(nextnode+1,nextnode+2));
     LRList[id] <-tree$LRList[idO];
     nextnode <- nextnode +2;
     ldauc[id]<-tree$ldauc[idO];
     isleaf[id]<- FALSE;
   }

   ret <- tree;
   ret$nbNode <- nextnode;
   score <- array(0,ret$nbNode);
   leaf <- which(isleaf);
   leafOrdered <- order(nodeorder);
   leafOrdered <- leafOrdered[leafOrdered %in% leaf];
   nbLeaf <- length(leafOrdered); 
   for (i in   0:(nbLeaf-1))
      score[leafOrdered[i+1]] <- ((nbLeaf -i)/nbLeaf)
   ret$score <- score;
   ret$nodes <- (1:ret$nbNode);
   ret$leafOrdered <- leafOrdered;
   ret$inner <- ret$nodes[!(isleaf)];
   ret$root <- 1L;
   ret$parentslist <- parentslist;
   ret$kidslist <- kidslist;
   ret$lalpha <- lalpha;
   ret$lbeta <- lbeta;
   ret$ldauc <- ldauc;
   ret$isleaf <- isleaf;
   ret$pcount <- pcount;
   ret$ncount <- ncount;
   ret$depth <- depth;
   ret$LRList <- LRList;
   ret$data <- tree$data;
   return(ret); 
          
}



#################################################################################
#################################################################################
##
##  pruning stuff
##
#################################################################################
#################################################################################


###############################################################
#
# pruneInfo(tree) : compute the informations regarding the pruning process :
#  return : sorted list by pruning level of : node ids of pruned nodes,
#                                             alpha complexity list
#                                             # of terminal nodes
#
###############################################################

getMiss <- function(pcount,ncount){
  if (pcount>ncount){
    return(ncount)
  }
  return(pcount)
}

pruneInfo <- function(tree){
  kidslist <- tree$kidslist
  listnbleaves <- as.double(tree$isleaf)
  cumdauc <- tree$ldauc;
  miss <- array(0,length(tree$pcount))
  pc <- tree$pcount
  nc <- tree$ncount
  isleaftmp <- tree$isleaf;
  listnode <- tree$nodes[tree$isleaf];

  #Compute for each node the cumulative delta-auc of the node + his kids and the number of leaves
  # by a reverse breadth-first exploration
  while (length(listnode)>0){
    id <- listnode[[1]];
    listnode <- listnode[-1];
    if (tree$isleaf[[id]]){
      miss[[id]] <- getMiss(pc[[id]],nc[[id]]);}
    pred <- tree$parentslist[[id]];
    isleaftmp <- c(isleaftmp,id);
    if((!(is.na(pred))) && (pred>0)){
      listnbleaves[[pred]] <- listnbleaves[[pred]]+listnbleaves[[id]];
      cumdauc[[pred]] <- cumdauc[[pred]]+ cumdauc[[id]];
      miss[[pred]] <- miss[[pred]]+miss[[id]];
      if (min(kidslist[[pred]] %in% isleaftmp) == 1)
        listnode <- c(listnode,pred);
    }
  }
  isleaftmp <- tree$isleaf;
  idpruned <- vector(mode="double",0);
  alphalist <- vector(mode="double",0);
  ntermnodes <- vector(mode="double",0);
  listnode <-tree$nodes;
  activenode <- listnode;
  activenode <-activenode[ -which(tree$isleaf)]
  
  while(length(activenode > 0)){
   #Find  next nodes to be pruned wrt (miss-classified / complexity)

#    alpha <- pmax(0,1-cumdauc[activenode])/ pmax(1,listnbleaves[activenode]-1);
#    missloc <- unlist(sapply(activenode,function(x){(getMiss(pc[[x]],nc[[x]])-miss[[x]])/(pc[[x]]+nc[[x]])}));
    
 #   alpha <- missloc/pmax(1,listnbleaves[activenode]-1);
    alpha <- pmax(0,cumdauc[activenode])/pmax(1,listnbleaves[activenode]-1);
    idprune <- which.min(alpha);
    bestalpha <- alpha[[idprune]];
    idprune <- which(alpha == bestalpha)
    idprune <- activenode[idprune];
    kidstmp <- unlist(tree$kidslist[idprune]);

    #desactivate all kids of  next nodes to be pruned
    while (length(kidstmp)> 0){
      idtmp <- kidstmp[[1]];
      kidstmp <- kidstmp[-1];
      if (idtmp %in% activenode){
        isleaftmp[[idtmp]] <- TRUE;
        ltmp <- kidslist[[idtmp]];
        if (length(ltmp)>0){
          kidstmp <- c(kidstmp,ltmp[which(!isleaftmp[ltmp])]);
          activenode <- activenode[-which(activenode ==idtmp)];
        }
      }
    }

    #Update the complexity and the delta-auc of remaining nodes
    for (idtmp in idprune){
      isleaftmp[idtmp] <- TRUE;
      if (idtmp %in% activenode){
        activenode <- activenode[-which(idtmp== activenode)];
        daucdiff <- cumdauc[[idtmp]];
        missdiff <- miss[[idtmp]]-getMiss(pc[[idtmp]],nc[[idtmp]])
        nbleavesdiff <- listnbleaves[[idtmp]] -1;
        idupdate <- idtmp;
        while ((!(is.na(idupdate))) && (idupdate>0)){
          listnbleaves[[idupdate]] <- listnbleaves[[idupdate]]-nbleavesdiff;
          cumdauc[[idupdate]] <- cumdauc[[idupdate]] - daucdiff;
          miss[[idupdate]] <- miss[[idupdate]]-missdiff
          idupdate <- tree$parentslist[[idupdate]];
        }
      }
    }
    #Update return lists information
    idpruned <- c(idpruned,list(idprune));
    alphalist <- c(alphalist,bestalpha);
    ntermnodes <- c(ntermnodes,listnbleaves[[1]]);
  }
  return(list(idpruned = idpruned, alphalist = alphalist, ntermnodes = ntermnodes));
}


###############################################################
#v1
# pruneCV(tree,formula,data, bestresponse, DTalgo = LeafRankCart,pruning)
#
# Main pruning function :
#      DTalgo : function used to grow the tree
#
###############################################################


pruneCV <- function(tree,formula, data, bestresponse, DTalgo = LRCart, nfcv){

  if (nfcv <=1)
    return(tree);
  # if not enough data or tree too small, don't prune
  if (nrow(data)/nfcv <5)return(tree)
  if (tree$nbNode<4)
    return(tree)
  mf <- match.call(expand.dots = FALSE)
  m <- match(c("formula","data"),names(mf),0)
  mf <- mf[c(1,m)]
  mf$drop.unused.levels <-FALSE;
  mf[[1]] <- as.name("model.frame")
  mf <-eval(mf,parent.frame());
  response <- model.response(mf);
  rn <- names(mf)[1]
  response <- model.response(mf);
  x <- mf[,colnames(mf) != "(weights)"]
  inputs <- which(!(colnames(x) %in% rn));
  if (is.null(weights)) weights <-rep.int(1,length(response));

  #Get pruning information on  current tree
  treePI <- pruneInfo(tree);

  #Build folds for cross validation
  index <- array(1:length(data[,1]));
  nc = array(dim=nfcv);
  
#  if (pruning$strat){
 #   indexpos <- sample(array(which(response == bestresponse)));
  # indexneg <- sample(array(index[-indexpos]));
   # nfcpossize <- floor(length(indexpos)/nfcv);
   # nfcnegsize <- floor(length(indexneg)/nfcv);
    #for (i in 1:(nfcv-1)){
     # nc[i] <- list(c(indexpos[(nfcpossize*(i-1)+1):(nfcpossize*i)],indexneg[(nfcnegsize*(i-1)+1):(nfcnegsize*i)]));
    #}
    #nc[nfcv] <- list(c(indexpos[(nfcpossize*(nfcv-1)+1):length(indexpos)],indexneg[(nfcnegsize*(nfcv-1)+1):length(indexneg)]));
  #}
  #else{
    nfcsize <- length(data[,1]) / nfcv;
    index <- sample(length(data[,1]));
    for (i in 1:(nfcv-1))
      nc[i] <- list(index[(nfcsize*(i-1)+1):(nfcsize*i)]);
    nc[nfcv] <- list(index[(nfcsize*(nfcv-1)+1):length(index)]);
  #}

#Do the cross validation
  if (length(treePI$alphalist)<2){
    avgalpha <- c(treePI$alphalist[[1]],1)
  }else
  {
    avgalpha <- c(0,sqrt(treePI$alphalist[2:length(treePI$alphalist)]*treePI$alphalist[1:(length(treePI$alphalist)-1)]),1);
  }
  aucnfcv = array(dim=c(nfcv,length(avgalpha)));
  for (i in 1:nfcv){
    print(c("--- cv learn pass: ",i));
    dtmp<- data[-nc[[i]],]
    rtmp <- response[-nc[[i]]];
    treetmp <- DTalgo(formula = formula,data=dtmp,
                      bestresponse= bestresponse);
    aucnfcv[i,] <- aucTestInfo(treetmp,dtmp,rtmp,bestresponse,avgalpha)
    
  }
  auc <- array();
  for (i in 1:length(avgalpha)){
    auc[i] <-mean(aucnfcv[,i]);
  }
  #aucmax <- max(auc);
  aucmax <- max(auc)
  if (is.na(aucmax))
    return(ret);
  prlevel <- max(which(auc==aucmax));
  ret <- tree;
  if ((length(prlevel)>0) &&(prlevel>1)){
    if(length(unlist(treePI$idpruned[1:(prlevel-1)]))>0){
      ret <- subTreeRank(tree,unlist(treePI$idpruned[1:(prlevel-1)]))
    }
  }
  ret$unpruned <- tree;
  ret;
}

aucTestInfo <- function(tree, data,y,bestresponse,avgalpha){
  if (!(checkImpure(rep(1,length(y)),y))){
    return(array(dim=length(avgalpha)));}
    
  res <- predict(tree,data,type="node");
  treePI <- pruneInfo(tree);
    

  idlist <- tree$nodes;
  ncount <- array(0,dim=length(idlist));
  pcount <- array(0,dim=length(idlist));
  
  #Compute pos and neg count for tree nodes
  for (i in 1:length(res))
    ifelse(y[[i]] == bestresponse,pcount[res[i]] <- pcount[res[i]] +1, ncount[res[i]] <- ncount[res[i]] +1);
  nodestack <- (1:tree$nbNode)[tree$isleaf];
  treated <- vector(mode="integer");
  while (length(nodestack) >0){
    idcur <- nodestack[[1]];
    nodestack <- nodestack[-1];
    idpar <- tree$parentslist[idcur];
    pcount[idpar] <- pcount[idpar] + pcount[idcur];
    ncount[idpar] <- ncount[idpar] + ncount[idcur];
    treated <- c(treated,idcur);
    if ((!(is.na(idpar)))&&(idpar>0))
      if (min(tree$kidslist[[idpar]] %in% treated) == 1)
        nodestack <- c(nodestack,idpar);
  }
  aucinfo <- ComputeTreeInfo(tree,pcount,ncount);
  misscount <- unlist(sapply(1:tree$nbNode,function(x){getMiss(tree$pcount[[x]],tree$ncount[[x]])}));
  auctestlist <- array(dim=length(avgalpha));
  for (i in 1:length(avgalpha)){
    itmp <- which(treePI$alphalist <=avgalpha[i]);
    if (length(itmp)>0){
      idtmp <- unlist(treePI$idpruned[1:max(itmp)]);
      auctestlist[i] <- getAUCsubTree(tree,idtmp,aucinfo$ldauc);
 #     auctestlist[i]<-getMissSubTree(tree,idtmp,misscount);
    }else{
      auctestlist[i] <- 0.5+sum(aucinfo$ldauc);
  #    auctestlist[i] <- getMissSubTree(tree,nodeids(tree,terminal=TRUE),misscount);
        }
  }
  
  return(auctestlist);
}


getMissSubTree <- function(tree,listnode,misscount){
  nodestack<- 1;
  miss <-0;
  while(length(nodestack)>0){
    cur <- nodestack[[1]]
    nodestack <- nodestack[-1];
    if (!(cur %in% listnode)){
      kids <- tree$kidslist[[cur]];
      nodestack <- c(nodestack,unlist(kids));
    }
    else{
      miss <- miss + misscount[[cur]]
    }
  }
  return(miss/(tree$pcount[[1]]+tree$ncount[[1]]));
}


getAUCsubTree <- function(tree,listnode,ldauc){
  nodestack <- 1;
  dauc <-0.5;
  while(length(nodestack)>0){
    cur <- nodestack[[1]]
    nodestack <- nodestack[-1]
    if (!(cur %in% listnode)){
      dauc <- dauc+ldauc[[cur]];
      kids <-tree$kidslist[[cur]];
      if (!(sum(is.na(kids)))){
        nodestack <- c(nodestack,unlist(kids));
      }
    }
  }
  return(dauc)
}
########################################################
#
#  importance Variable
#
########################################################

varImportance <- function(obj,norm=TRUE){
  UseMethod("varImportance");
}

varImportance.default <- function(obj,norm=TRUE){
 NULL;
}

varImportance.TR_forest <- function(obj,norm=TRUE){
  tree <- obj$forest[[1]]
  nr <- attributes(tree$terms)$term.labels;
  res <- array(0,length(nr))
  names(res) <- nr
  for (i in obj$forest){

    restmp <- varImportance(i,FALSE);
    if (is.null(restmp)){return(NULL);}
    for (j in 1:length(restmp)){
      id <- which(names(restmp[j])==names(res));
      res[id] <- res[id]+restmp[j];
    }
  }
  if (norm) ret <- res/max(res)
  else ret <- res;
  ret;
}
    

varImportance.TR_TreeRank<- function(obj,norm=TRUE){
  nr <- attributes(obj$terms)$term.labels;
  res <- array(0,length(nr))
  names(res) <- nr
  
  for (i in obj$inner){

    restmp <- varImportance(getClassifier(obj,i),FALSE)
    if (is.null(restmp)){return(NULL);}
    for (j in 1:length(restmp)){
      id <- which(names(restmp[j])==names(res));
      res[id] <- res[id]+restmp[j]*((obj$pcount[i]*obj$ncount[i])/(obj$pcount[obj$root]*obj$ncount[obj$root]))^2;
    }
  }
  if (norm) ret <- res/max(res)
  else ret <- res;
  ret;
}


plotROC <- function( rocs,colorlist = NULL,points=NULL){
  if (is.null(colorlist)){  colorlist <- list("black","blue","red","green","yellow")}
  plot(function(x){x},0:1, col ="black", xlab = "FP rate", ylab = "TP rate")
  if (length(rocs)>0){
    for (i in 1:length(rocs)){
      curr <- rocs[[i]];
      if (is.list(curr)){
        for(j in 1:length(curr)){
          par(new = T);
          if (nrow(curr[[j]])<100){type <- "b"}
          else{type <-"l"}
          plot(curr[[j]], type=type, col= colorlist[[(i-1) %% length(colorlist) + 1]], xlab="",ylab="",xlim=c(0,1),ylim=c(0,1))
        }
      }else{
        par(new=T);
        if (nrow(rocs[[i]])<100){type <- "b"}
        else{type <-"l"}
        plot(rocs[[i]], type=type, col= colorlist[[(i-1) %% length(colorlist) + 1]], xlab="",ylab="",xlim=c(0,1),ylim=c(0,1))
      }
    }
    
    if (!(is.null(points))){
      points<-c(list(c(0,0)),points,list(c(1,1)))
      tmpm<- matrix(unlist(points),nrow=2);
      par(new=T);
      
      plot(x=tmpm[1,],y=tmpm[2,],xlab="",ylab="",xlim=c(0,1),ylim=c(0,1));
      
    }
    
  }
}


##############################################################
#
# Bagging
#
##############################################################


TreeRankBagging <- function(forest){
  
  res <- list(forest= forest, ntree = length(forest));
  class(res) <- "TR_forest"
  res
}



varDep <- function(obj,data,varx,vary,vminx=min(data[varx]),vmaxx=max(data[varx]),vminy=min(data[vary]),vmaxy=max(data[vary]),subdivx=100,subdivy=subdivx){

   nbex <- nrow(data);
nc <- which(colnames(data) %in%c(varx,vary));
seqx <-  seq(vminx,vmaxx,length.out=subdivx);
seqy <- seq(vminy,vmaxy,length.out=subdivy);
ret <- matrix(nrow=subdivx,ncol=subdivy,dimnames=list(seqx,seqy));
  for (i in 1:length(seqx)){
    for(j in 1:length(seqy)){
   data[,nc[1]] <- seqx[i];
   data[,nc[2]] <- seqy[j];
   pre <-  sum(predict(obj,data)/nbex);
   ret[i,j] <-pre;
  }
  }
ret;
}


TwoSample<- function(x,y,split=60,TRalgo=TreeRank,alpha= 5){
  xn <-nrow(x);
  yn <-nrow(y);
  split <- split/100;
  alpha <- 1-(alpha/100);
  xset <- data.frame(x,"twTRclass"=rep(1,xn));
  yset <- data.frame(y,"twTRclass"=rep(-1,yn));
  xsplit <- ceiling(xn*split);
  ysplit <- ceiling(yn*split);
  idx <- sample(xn,xsplit)
  idy <- sample(yn,ysplit);
  train <- rbind(xset[idx,],yset[idy,]);
  test <- rbind(xset[-idx,],yset[-idy,]);
  tree <- TRalgo(twTRclass ~.,train,bestresponse=1);

  
  score <- predict(tree,test);
  dft <- data.frame(score = score,class=as.factor(test[,"twTRclass"]))
  wtest <- wilcox_test(score~class,dft,conf.level=alpha,conf.int=TRUE);
  return(list(wtest = wtest, tree= tree,train=train,test=test,dft=dft))

}
#line 1 "d:/Rcompile/CRANpkg/local/2.12/TreeRank/R/TreeRank.R"

#################################################################################
#
# TreeRank functions : implementation of the TreeRank algorithm
#
#################################################################################


#################################################################################
#
# predict.TR_TreeRank(object, newdata, type) : predict node or score for newdata
#             object : TreeRank object
# 	      newdata : data for the prediction
#      	      type: node : node id of the prediction
#                   score : normalized score (default)
#
#################################################################################



predict.TR_TreeRank<- function(object, newdata = NULL, type = "score",...)
{
  if (!inherits(object,"TR_TreeRank"))
    stop("object not of class TR_TreeRank");

 if (is.null(newdata))
    return(object$fitted[["(fitted)"]])
  
  retid <- rep(object$root,nrow(newdata));
  indextab <- list(rep(1:nrow(newdata)));
  nodestack <- list(object$root);
  
  while(length(nodestack)>0){
	id <- nodestack[[1]];

	nodestack <- nodestack[-1];
        if (object$isleaf[id]) {
		retid[indextab[[id]]]<- id;
 		next;
	}
        if (length(indextab[[id]]) >0){
	tmp <- predict(getClassifier(object,id),newdata[indextab[[id]],]);
        kids <- object$kidslist[[id]];
        indextab[kids[1]] <- list(indextab[[id]][tmp<0]);
        indextab[kids[2]] <- list(indextab[[id]][tmp>0]);          
        nodestack <- c(nodestack,kids[1],kids[2]);
}
  }
  if (type == "node")
      return(retid)
  return(object$score[retid]);
}




predict.TR_forest<- function(object, newdata = NULL,...){
  if (!inherits(object,"TR_forest"))
    stop("Object not of class TR_forest");
  
  if (is.null(newdata))
    newdata <- object$forest[[1]]$data;
  res <- array(0,dim=nrow(newdata))
  for (i in 1:object$ntree	)
  {
    tmp <- predict(object$forest[[i]],newdata);
    res <- res + tmp;
  }
  res <- res / object$ntree;
  res
}


#################################################################################
#
# getClassifier(tree, id)
#    tree: a TreeRank object
#    id : id of the node
#
# Return : the LeafRank Classifier associated to the node id
#
#################################################################################


getClassifier <- function(tree,id){
  if (!inherits(tree,"TR_TreeRank")){
    stop("object not of class TR_TreeRank");
  }
  tree$LRList[[id]];
}

#################################################################################
#
# TreeRankRec(id,formula,data,response, bestresponse, weights,growing,depth,LeafRank)
#   Main TreeRank recursive function
#    id : id of current underconstruction node
#    formula,data,response,weights:
#    bestresponse : best label value
#    growing : growing control
#    depth : current depth
#    LeafRank : classifier to use to do the split
#
# Return : a TreeRank tree
#
#################################################################################


TreeRankRec <- function(formula, data,  bestresponse, growing = growing_ctrl(), LeafRank = LRCart,varsplit=1){
   
  if (missing(data))
        data <- environment(formula)
  call <- mf  <- match.call(expand.dots = FALSE)
  m <- match(c("formula", "data", "weights"),names(mf), 0)
  mf <- mf[c(1, m)]
  mf$drop.unused.levels <- FALSE
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  Terms <- attr(mf,"terms");
  response <- model.response(mf);
  w <- model.extract(mf,"weights");
  if (length(w)==0L) w <- rep.int(1,length(response));
  rn <- names(mf)[1] 
 x <- mf[,colnames(mf) != "(weights)"]

  inputs <- which(!(colnames(x) %in% rn ))
  
   print(paste("Computing Master Tree - :"));
   pcInit <- sum(w[response == bestresponse]);
   ncInit <- sum(w[response != bestresponse]);
   #initialise root node
   id <- 1;
   nextnode <- 1;
   wtmp <- list(seq(1,length(response)));
   kidslist <- list();
   parentslist <- array();
   LRList <- list();
   isleaf <-array();
   ldauc <- array();
   score <- array();
   lalpha <- 0;
   lbeta <- 0;
   ncount <- ncInit;
   pcount <- pcInit;
   depth <- c(1);
   nodestack <- list(id);
   nodeorder <- array(); 
   curscore <- 1;
   #recursive while
   while(length(nodestack)>0){
     cat(".");
     id <- nodestack[[1]];
     isleaf[id] <- TRUE;
     nodestack <- nodestack[-1];
     tmpdata <- x[wtmp[[id]],];
     tmpweights <- w[wtmp[[id]]];
     tmpresponse <- response[wtmp[[id]]];
     pcount[id] <- sum(tmpweights[tmpresponse == bestresponse]);
     ncount[id] <- sum(tmpweights[tmpresponse != bestresponse]);
     ldauc[id] <- 0;
     nodeorder[id] <- curscore;
     curscore <- curscore+1;
     if ((depth[id] >=growing$maxdepth)|| ((pcount[id]+ncount[id])<growing$minsplit)|| (!checkImpure(tmpweights,tmpresponse))){

 	kidslist[id] <- NA;
 	LRList[id] <- NA;
        next;
    }
	if (varsplit <1)
	xid <- c(1,sample(2:ncol(tmpdata),ceiling(varsplit*(ncol(tmpdata)-1))))
	else xid <- 1:ncol(tmpdata);
	tmpdata <- tmpdata[,xid];
    #Build the LeafRank  classifier for the current node
    if (is.function(LeafRank)){
	lrTree <- LeafRank(formula = formula,data = tmpdata, bestresponse = bestresponse);
	}        
	else{
	LRlist <- LeafRank$LRlist;
	splitD <- LeafRank$split;
	idLearn <- sample(nrow(tmpdata),ceiling(nrow(tmpdata)*splitD));
	listTree <- list();
	listAUC <- list();
	maxauc <- 0;
	maxtree<- NULL;
	print("begin")
	for (alg in LRlist){
#browser()
		tmptree <- alg(formula=formula,data=tmpdata[idLearn,],bestresponse=bestresponse);
		lrResponse <- predict(tmptree,tmpdata[-idLearn,]); 
	        left <- lrResponse <=0;
	        right <- lrResponse >0;
		npc <- sum(tmpweights[(tmpresponse[-idLearn] == bestresponse) & left]);
		nnc <- sum(tmpweights[(tmpresponse[-idLearn] != bestresponse) & left]);
		auctmp = -((pcount[id]/pcInit)*(nnc/ncInit)-(ncount[id]/ncInit)*(npc/pcInit))/2
		if (auctmp>maxauc)
			{
			maxtree <- tmptree;
			maxauc <- auctmp;
			maxalg <- alg;
			}
		
	}
	lrTree <-  alg(formula=formula,data=tmpdata,bestresponse=bestresponse);
	print(class(lrTree))
     }

     if (is.null(lrTree))
       {
         kidslist[id]<-NA;
         LRList[id]<-NA;
         next;
       }
    lrResponse <- predict(lrTree,tmpdata);
   
  
    #Compute left and right node
    left <- lrResponse <=0;
    right <- lrResponse >0;
    npc <- sum(tmpweights[(tmpresponse == bestresponse) & left]);
    nnc <- sum(tmpweights[(tmpresponse != bestresponse) & left]);
    #If a kid is empty, the current node is a leaf
    if (((npc+nnc) == 0) || ((pcount[id]+ncount[id]-(npc+nnc)) == 0)){
       kidslist[id]<-NA;
       LRList[id] <- NA;
       next;
    }
    LRList[id] <- list(lrTree);
    ldauc[id] <- -((pcount[id]/pcInit)*(nnc/ncInit)-(ncount[id]/ncInit)*(npc/pcInit))/2
    nalpha <-  lalpha[id] + nnc/ncInit;
    nbeta <- lbeta[id] + npc/pcInit;
    #build kids
    kidslist[id] <- list(c(nextnode+1,nextnode+2));
    parentslist[nextnode+1] <- parentslist[nextnode+2]<-id;
    depth[nextnode+1]<- depth[nextnode+2] <- depth[id]+1;
    #left node
    lalpha[nextnode+1] <- lalpha[id]
    lbeta[nextnode+1] <- lbeta[id];
    wtmp[nextnode+1] <- list(wtmp[[id]][left]);
    #right node
    lalpha[nextnode+2] <- nalpha;
    lbeta[nextnode+2] <- nbeta;
    wtmp[nextnode+2] <- list(wtmp[[id]][right]);
    isleaf[id] <- FALSE;
    nodestack <- c(nextnode+1,nextnode+2,nodestack);
    nextnode <- nextnode+2;
   


   }
   cat("\n");

   nbNode <- nextnode;
   score <- array(0,nbNode);
   leaf <- which(isleaf);
   leafOrdered <- order(nodeorder);
   leafOrdered <- leafOrdered[leafOrdered %in% leaf];
   nbLeaf <- length(leafOrdered); 
   for (i in   0:(nbLeaf-1))
      score[leafOrdered[i+1]] <- ((nbLeaf -i)/nbLeaf)

   ret <- list();
   ret$leafOrdered <- leafOrdered;
   ret$nodeorder <- nodeorder;
   ret$nodes <- (1:nbNode)
   ret$inner <- ret$nodes[!(isleaf)]
   ret$root <- 1L;
   ret$parentslist <- parentslist;
   ret$kidslist <- kidslist;
   ret$lalpha <- lalpha;
   ret$lbeta <- lbeta;
   ret$ldauc <- ldauc;
   ret$isleaf <- isleaf;
   ret$bestresponse <- bestresponse;
   ret$pcount <- pcount;
   ret$ncount <- ncount;
   ret$depth <- depth;
   ret$LRList <- LRList;
   ret$nbNode <- nextnode;
   ret$score <- score;
   return(ret); 
}



#################################################################################
#
# TreeRankForest(formula,data,bestresponse,ntree,replace,sampsize,varsplit,...)
# TreeRank Forest version
#
#    formula,data 
#    bestresponse : value of the best label 
#    ntree : number of trees to be computed
#    sampsize : percent of the data to use for each tree
#    replace : drawing examples from data with replacement or not
#    varsplit : percent of variables to be used for each internal node of trees.
#
#################################################################################

TreeRankForest <- function(formula,data,bestresponse,ntree=5,replace=TRUE,sampsize=0.5,varsplit=1,...){
  forest <- list();
 if (missing(data))
        data <- environment(formula)
  call <- mf  <- match.call(expand.dots = FALSE)
  m <- match(c("formula", "data", "weights"),names(mf), 0)
  mf <- mf[c(1, m)]
  mf$drop.unused.levels <- FALSE
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  Terms <- attr(mf,"terms");
  for (i in 1:ntree){
    print(paste("Compute tree # ",i,"/",ntree,sep=""));
    tmpdata <- mf[sample(nrow(mf),ceiling(sampsize*nrow(mf)),replace=replace),]
    forest <- c(forest,list(TreeRank(formula,tmpdata,bestresponse,varsplit=varsplit,...)));
  }
  ret <- list(forest= forest,ntree = ntree);
  class(ret) <- "TR_forest";
  ret
}


#################################################################################
#
# TreeRank(formula,data,bestresponse,weights,growing,LeafRank,nfcv)
# Main TreeRank function
#
#    bestresponse : value of the best label 
#    weights : weights on the data
#    growing : growing control of the TreeMaster
#    LeafRank : classifier to use at each node
#               classifier has to take at least args : formula, data, bestresponse, weights
#                   and returns -1/+1 : best/worst ones
#    pruning : pruning control
#    nfcv :  number of cases for  n-fold cross pruning procedure , 0 or 1 = no pruning.
#    varsplit : percent of variables to be used for each node.
#
#################################################################################



TreeRank <- function(formula, data,bestresponse, weights=NULL,growing = growing_ctrl(), LeafRank = LRCart,nfcv=0,varsplit=1)
{


  #Prepare the call to the recursive TreeRank function
  if (missing(data))
        data <- environment(formula)
  call <- mf  <- match.call(expand.dots = FALSE)
  m <- match(c("formula", "data", "weights"),names(mf), 0)
  mf <- mf[c(1, m)]
  mf$drop.unused.levels <- FALSE
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, parent.frame())
  Terms <- attr(mf,"terms");
  y <- model.response(mf);
  w <- model.extract(mf,"weights");
  if (length(w)==0L) w <- rep.int(1,length(y));
  treeMaster <- TreeRankRec(formula = formula, data = mf, bestresponse  = bestresponse,growing = growing, LeafRank =LeafRank,varsplit=varsplit)
   
#  if (prcSplitVar<1){
    #idxVar <- c(which(colnames(x)%in%rn),sample(inputs,ceiling(length(inputs)*prcSplitVar)));
  #}

  #if ((prcSplitData<1) || dataRepl){
    #idxData <-sample(nrow(data),ceiling(nrow(data)*prcSplitData),replace=dataRepl)
  #}
  
#  colname.list <-c(names(data),".TRvar");
#  cols <-lapply(colname.list,function(x)numeric(0));
#  names(cols)<-colname.list;
#  dataN <- do.call("data.frame",cols);

    #Build the Master TreeRank
 #tmpTRdata <- mf[idxData,idxVar];
  #tmpTRy <- y[idxData];
 
  #Compute the TreeRank object
  treeMaster$terms <- Terms;
  treeMaster$formula <- formula;
  treeMaster$call <-call;
  treeMaster$data <-data;
  ret <- treeMaster;
  class(ret) <- c("TR_TreeRank")
  #Do the pruning
  if (nfcv>1){
      print("pruning master tree...");
      tmpTR <- function(...){TreeRank(LeafRank = LeafRank,growing = growing,...)}
      ret <- pruneCV(ret,formula,mf,bestresponse,DTalgo = tmpTR,nfcv);
    }
  ret
}



print.TR_TreeRank <- function(x,...){
object <- x;
  if(!inherits(object,"TR_TreeRank"))
    stop("objectnot of class TR_TreeRank");

  id <- object$root;
  nodestack<-id;
  cat("TreeRank tree\n   id) #pos:#neg dauc score\n\n");

  while(length(nodestack)>0){
    id <- nodestack[[1]];
    nodestack <-nodestack[-1];
    s <- "";
    s <- paste(cat(rep(' ',2*object$depth[id])),id,"| ",object$pcount[id],":",
               object$ncount[id]," ",format(object$ldauc[id],digits=3)," ",format(object$score[id],digits=3),sep="")
    
    if (!(object$isleaf[id])){
      nodestack <- c(object$kidslist[[id]][[1]],object$kidslist[[id]][[2]],nodestack);
    }else{s<- paste(s,"*");}
    cat(paste(s,"\n"));
  }
}
    
    
