.packageName <- "nem"
# FULL log marginal likelihood of a models

FULLmLL <- function(Phi,D1,D0,a0,b0,a1,b1,Pe) {
  if (!all(diag(Phi)==1)) stop("\nnem:FULLmLL> Model main diagonal must be 1!")
  
  # make sure model is in right order wrt to count matrices
  Phi <- Phi[colnames(D1),colnames(D1)]

  # compute score
  n01 <- D1 %*% (1-Phi)
  n00 <- D0 %*% (1-Phi)
  n11 <- D1 %*% Phi
  n10 <- D0 %*% Phi
  s0  <- gamma(a0+b0)*gamma(n10+a0)*gamma(n00+b0)/gamma(a0)/gamma(b0)/gamma(n10+n00+a0+b0)
  s1  <- gamma(a1+b1)*gamma(n11+a1)*gamma(n01+b1)/gamma(a1)/gamma(b1)/gamma(n11+n01+a1+b1)
  SP  <- s0*s1*Pe
  s   <- sum(log(rowSums(SP)))

  # posterior effect positions
  ep  <- SP/rowSums(SP)

  # MAP estimate of effect positions
  map <- colnames(D1)[apply(ep,1,which.max)]
  names(map) <- rownames(D1)


  return(list(mLL=s,pos=ep,mappos=map))
}
SCCgraph <- function(x,name=TRUE,nlength=20){

  if (!is(x, "graphNEL") & !is(x,"matrix")) stop("Wrong class of argument 'x': must be 'graphNEL' or 'matrix'")  
  if (is(x,"matrix"))  x <- as(x,"graphNEL")

  scc   <- strongComp(x)
  N     <- length(scc)
  
  # concatenate node names in same scc
  V <- as.character(1:N)
  if (name==TRUE){
    for (i in 1:N){        
        v <- paste(scc[[i]],collapse=":")
        if (nchar(v)>nlength) v <- paste(substr(v,1,nlength-3),"...",sep="")
        V[i] <- v     
    }
    names(scc) <- V
  }

  # which node is in which scc?
  which.scc <- numeric(length(nodes(x)))
  names(which.scc)<-nodes(x)
  for (i in names(scc)) which.scc[scc[[i]]] <- i


  # build scc graph
  edL <- vector("list", length = N)
  names(edL) <- V
  for (i in names(scc)){
    vv <-  scc[[i]]
    ee <- NULL
    for (j in vv) ee <- c(ee,x@edgeL[[j]]$edges)
    ee <- which.scc[ee]
    dup <- duplicated(ee)
    ee <- ee[!dup & !(ee==i)]
    edL[[i]] <- list(edges= ee)
  }
  gR <- new("graphNEL", nodes=V, edgeL=edL, edgemode="directed")

  #-----
  names(scc) <- V

  #-----
  return(list(graph=gR,scc=scc,which.scc=which.scc))
}
enumerate.models <- function(n=4,name=letters[1:n],verbose=TRUE) {

#------------------
# Sanity checks    

 if (n==1) stop("nem> choose n>1!")
 if (n>5)  stop("nem> exhaustive enumeration not feasible with more than 5 perturbed genes")            
 if (n==5) cat ("nem> this will take a while ... \n") 

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

  bc <- bincombinations(n*(n-1))
  fkt1 <- function(x,n,name) {
    M <- diag(n)
    M[which(M==0)]<-x
    dimnames(M) <- list(name,name)
    M <- transitive.closure(M,mat=TRUE,loops=TRUE)
    return(list(M))
  }
  
  models <- apply(bc,1,fkt1,n,name) 
  models <- unique(matrix(unlist(models),ncol=n*n,byrow=TRUE))
  
  fkt2 <- function(x,n,name){
     M <- matrix(x,n)
     dimnames(M) <- list(name,name)
     return(list(M))
  }
  models <- unlist(apply(models,1,fkt2,n,name),recursive=FALSE)
    
  if (verbose) cat("Generated",length(models),"unique models ( out of", 2^(n*(n-1)), ")\n")

  return(models)
}
###################################
local.model.prior <- function(size,n,bias){
  
  nrE <- n*(n - 1)/2
  p <- size/nrE
  model.prior <- c(1-p,p/(bias+2),p/(bias+2),bias*p/(bias+2))
  names(model.prior) <- c("..","->","<-","<->")
  if (!(all(model.prior>0) & sum(model.prior)==1)) stop("That's not a distribution - maybe 'size' is too big!")
  return(model.prior)
}
# log marginal likelihood of models

mLL <- function(Phi,D1,D0,a,b,Pe) {
  if (!all(diag(Phi)==1)) stop("\nnem:mLL> Model main diagonal must be 1!")
  
  # make sure model is in right order wrt to count matrices
  Phi <- Phi[colnames(D1),colnames(D1)]

  # compute the log-mll score
  L  <- a^(D1 %*% (1-Phi)) * (1-a)^(D0 %*% (1-Phi)) * (1-b)^(D1 %*% Phi) * b^(D0 %*% Phi)
  LP <- L*Pe
  s  <- sum(log(rowSums(LP)))

  # posterior of effect positions
  ep <- LP/rowSums(LP)
  colnames(ep) = colnames(D1) 
 
  # MAP estimate of effect positions
  map <- colnames(D1)[apply(ep,1,which.max)]
  names(map) <- rownames(D1)

  return(list(mLL=s,pos=ep,mappos=map))
}
nem <- function(D,inference="pairwise",models=NULL,type="mLL",para=NULL,hyperpara=NULL,Pe=NULL,Pm=NULL,local.prior.size=length(unique(colnames(D))),local.prior.bias=1,verbose=TRUE){

#------------------------------
# Sanity checks                

if (!(inference %in% c("pairwise","search")))   stop("\nnem> argument 'inference' is not valid\n")
if (!(type %in% c("mLL","FULLmLL")))            stop("\nnem> argument 'type' is not valid")
if (is.null(para)   & is.null(hyperpara))       stop("\nnem> provide either 'para' or 'hyperpara'\n")
if (type=="mLL"     & is.null(para))            stop("\nnem> provide argument 'para'\n")
if (type=="FULLmLL" & is.null(hyperpara))       stop("\nnem> provide argument 'hyperpara'\n")
if (!is.null(hyperpara)){
    if (length(hyperpara)!=4)                   stop("\nnem> 'hyperpara' is not a vector of length 4")
    if (!all(hyperpara > 0))                    stop("\nnem> 'hyperpara' must be >0")
    }
if (!is.null(para)){          
    if (length(para)!=2)                        stop("\nnem> 'para' is not a vector of length 2")
    if (any(para < 0) | any(para > 1))          stop("\nnem> 'para' must be in [0,1]")
    }


Sgenes <- unique(colnames(D))


#------------------------------
# PAIRWISE                     

if (inference == "pairwise"){
        if (local.prior.size <= 0 | local.prior.bias <= 0) stop("\nnem> local prior parameters invalid")
        Pm <- local.model.prior(local.prior.size,length(Sgenes),local.prior.bias)
        result <- pairwise.posterior(D,type,para,hyperpara,Pe,Pm,verbose)     
    }


#------------------------------
# SEARCH                       

if (inference == "search"){ 
        if (is.null(models)) models <- enumerate.models(length(Sgenes),Sgenes,verbose)
        result <- score(models,D,type,para,hyperpara,Pe,verbose)
       }


#------------------------------
# OUTPUT                       
#class(result) <- "nem"
return(result)

}
nem.discretize <- function(D,neg.control=NULL,pos.control=NULL,nfold=2,cutoff=0:10/10, pCounts=20, empPval=.05, verbose=TRUE){

#-------------------------
# sanity checks           

if (is.null(neg.control) & is.null(pos.control))                stop("\nnem> provide at least one control")
if (class(neg.control)=="matrix") if (nrow(neg.control)!=nrow(D))  stop("\nnem> control and data must have the same number of rows")
if (class(pos.control)=="matrix") if (nrow(pos.control)!=nrow(D))  stop("\nnem> control and data must have the same number of rows")
if (class(neg.control)%in%c("integer","numeric") & class(pos.control)%in%c("integer","numeric") & !all(c(neg.control,pos.control))%in%1:ncol(D))    stop("\nnem>controls not in data 'D'")
if (class(neg.control)%in%c("integer","numeric") & class(pos.control)%in%c("integer","numeric") & any(neg.control %in% pos.control))                stop("\nnem>negative and positive controls overlap")

if (!is.null(neg.control) & !is.null(pos.control)) { setting <- "twocontrols" } else { setting <- "onecontrol"}


#-------------------------
# two controls scenario   
# (Markowetz et al, 2005) 

if (setting=="twocontrols"){
if (verbose) cat("discretizing with respect to POS and NEG controls\n")
if (class(neg.control)=="matrix")                   neg <- neg.control 
if (class(neg.control)%in%c("integer","numeric"))   neg <- D[,neg.control] 
if (class(pos.control)=="matrix")                   pos <- pos.control
if (class(pos.control)%in%c("integer","numeric"))   pos <- D[,pos.control]

if (class(neg.control)%in%c("integer","numeric")){d <- neg.control}else{d<-NULL}
if (class(pos.control)%in%c("integer","numeric")) d <- c(d,pos.control)
if (!is.null(d)) dat <- D[,-d]

# select diff - maybe as extra input function??
# should also do downregulation ...
sel <- which(exp(rowMeans(pos) - rowMeans(neg)) > nfold)
dat.sel <- dat[sel,]
pos.sel <- pos[sel,]
neg.sel <- neg[sel,]

# count false decisions for different cutoff levels
count.false.decisions <- function(x){
thrsh    <- x*rowMeans(pos.sel) + (1-x)*rowMeans(neg.sel)
pos.disc <- (pos.sel <= thrsh)*1
neg.disc <- (neg.sel <= thrsh)*1        
a        <- round(sum(pos.disc)/length(pos.disc),2)
b        <- 1-round(sum(neg.disc)/length(neg.disc),2)                   
return(c(a,b))
}
false <- sapply(cutoff,count.false.decisions)
dimnames(false) <- list(c("a","b"),as.character(cutoff))

mycutoff <- cutoff[which.min(false[2,])]

# apply chosen cutoff
thrsh  <- mycutoff*rowMeans(pos.sel) + (1-mycutoff)*rowMeans(neg.sel)
dat.disc <- (dat.sel <= thrsh)*1
pos.disc <- (pos.sel <= thrsh)*1
neg.disc <- (neg.sel <= thrsh)*1        
a <-   round((sum(pos.disc)+pCounts)/(length(pos.disc)+pCounts),2)
b <- 1-round( sum(neg.disc)         /(length(neg.disc)+pCounts),2)                   
para <- c(a,b)
names(para) <- c("a","b")

# output
disc <- list(dat=dat.disc,pos=pos.disc,neg=neg.disc,sel=sel,cutoff=false,para=para)

}


#-------------------------
# one control scenario    

if (setting=="onecontrol"){
if (verbose) cat("discretizing with respect to one control\n")

if (!is.null(pos.control)){
    if (class(pos.control)=="matrix"){                   
        W <- pos.control
        M <- D
        }
    if (class(pos.control)%in%c("integer","numeric")){
        W <- D[,pos.control]
        M <- D[,-pos.control]
        }
    }
if (!is.null(neg.control)){
    if (class(neg.control)=="matrix"){
        W <- neg.control
        M <- D
        }
    if (class(neg.control)%in%c("integer","numeric")){
        W <- D[,neg.control]
        M <- D[,-neg.control]
        }
    }


# empirical distr. function
Wecdf <- apply(W,1,ecdf) 
Mp <- matrix(0,ncol=ncol(M),nrow=nrow(M))   
for (i in 1:nrow(W)){
    Pi <- Wecdf[[i]](M[i,])    
    Mp[i,] <- ifelse(Pi<=.5,Pi,1-Pi)   
} 
Mt <- (Mp <= empPval)*1   
dimnames(Mt) <- dimnames(M)

# output
disc <- list(dat=Mt) 

}


#-------------------------
# output                  
return(disc)

}
pairwise.posterior <- function(D, type="mLL", para=NULL, hyperpara=NULL,
                               Pe=NULL, Pm=NULL, verbose=TRUE) {
                               
  # Sgenes
  Sgenes <- unique(colnames(D))
  nrS <- length(Sgenes)
  nrTest <- nrS*(nrS-1)/2
  if(verbose) cat(nrS,"perturbed genes ->", nrTest, "pairwise tests\n")


  # local model prior
  if (is.null(Pm)) Pm <- rep(.25,4)

  # init output
  graph <- diag(nrS)
  dimnames(graph) <- list(Sgenes,Sgenes)
  scores <- matrix(nrow=nrTest,ncol=5)
  dimnames(scores) <- list(as.character(1:nrTest),c("..","->","<-","<->","support")) 
  ix <- 1

  # loop over edges
  for (i in 1:(nrS-1)) {
    for (j in (i+1):nrS) {

      # data
      x <- Sgenes[i]
      y <- Sgenes[j]
      D.xy <- D[ , which(colnames(D)==x | colnames(D)==y)]
      D.xy <- D.xy[rowSums(D.xy)!=0 ,,drop=FALSE]
      support <- nrow(D.xy)
      
      # four models per edge: x..y  x->y  x<-y  x<->y
      models <- enumerate.models(2,name=c(x,y),verbose=FALSE)

      # score
      ss <- score(models, D.xy, type=type, para=para,
                  hyperpara=hyperpara, Pe=Pe, verbose=FALSE)
      
      post <- exp(ss$mLL) * Pm  # model likelihood times prior
      post <- post/sum(post)    # scaled to [0,1]
      
      # winner
      winner <- models[[which.max(post)]]
      graph[i,j] <- winner[1,2]
      graph[j,i] <- winner[2,1]

      # scores
      scores[ix,] <- c(post,support)
      rownames(scores)[ix] <- paste(c(x,y),collapse=":")

      # counter :(
      ix <- ix + 1

      if(verbose) cat(".")
    }
  }
  if(verbose) cat("\n")  
  
  # estimate effect positions
  if (verbose) cat("estimating effect positions\n")
  ep <- score(list(transitive.closure(graph,mat=TRUE)), D, 
               type=type, 
               para=para,
               hyperpara=hyperpara,
               Pe=Pe, 
               verbose=FALSE)
  
  # remove loops in graph
  graph <- graph-diag(nrS)
  
  # as graphNEL
  graph <- as(graph,"graphNEL")
  
  # output
  res <- list(graph=graph,pos=ep$pos[[1]],mappos=ep$mappos[[1]],scores=scores,type=type,para=para,hyperpara=hyperpara)
  class(res) <- "pairwise"

  return(res)
}

      
plot.effects <- function(x,nem,border=TRUE,...){

int        <- unique(colnames(x))
sccg       <- SCCgraph(nem$graph,name=TRUE)
topo.order <- tsort(sccg$graph)

#----------------------------
# reorder COLUMNS            
#----------------------------

# order
ord        <- unlist(sccg$scc[topo.order])
col.order  <- unlist(lapply(ord,function(y) which(colnames(x) == y)))
D          <- x[,col.order]
Dcn        <- colnames(D)

#----------------------------
# reorder ROWS               
#----------------------------

# estimate effect positions
# old: take them directly from hierarchy:
#      if (class(nem)=="pairwise") mappos <- nem$mappos
#      if (class(nem)=="score")    mappos <- nem$mappos[[which.max(nem$mLL)]]
# new: estimate them from scc graph
colnames(D) <- sccg$which.scc[Dcn]
M <- as(sccg$graph,"matrix") + diag(length(sccg$scc)) 
mappos <- score(D,models=M,type=nem$type,para=nem$para,hyperpara=nem$hyperpara,verbose=FALSE)$mappos[[1]]
colnames(D) <- Dcn

# order 
v <- list()
nr <- list()
for (i in topo.order){
  w <- which(mappos == i)  
  
  if (length(w)==0){ 
    v[[i]]  <- NA
    nr[[i]] <- 1 
    }
  if (length(w)==1){
    v[[i]] <- w
    nr[[i]] <- 1
  }  
  if (length(w) >1){
        d       <- dist(D[w,,drop=FALSE],method="manhattan")
        v[[i]]  <- w[hclust(d)$order]
        nr[[i]] <- length(w) 
    }    
}
v <- rev(unlist(v))
nr <- rev(unlist(nr))

D2 <- matrix(0,nrow=length(v),ncol=ncol(D))
D2[which(!is.na(v)),] <- D[v[which(!is.na(v))],]
dimnames(D2) <- list(rownames(D)[v],colnames(D))

#----------------------------
# PLOT                       
#----------------------------
cs <- cumsum(nr)[-length(nr)]

par(las=2,mgp=c(5.5,1,0),mar=c(7,7,4,7),cex.lab=1.7,cex.main=2,lwd=2)
image(x   = 1:ncol(D2),
      y   = 1:nrow(D2),
      z   = t(D2),
      xlab= "",
      ylab= "",
      xaxt= "n",
      yaxt= "n",
      col = gray(seq(.95,0,length=10)),
      ...
      )
axis(1,1:ncol(D2),colnames(D2))
axis(4,1:nrow(D2),rownames(D2),tick=!is.na(v))
axis(2, c(0,cs) + nr/2 , rev(topo.order),tick=FALSE)
if (border) abline(h=cs+.5,col="red")
}
plot.pairwise <- function(x, what="graph", remove.singletons=FALSE, PDF=FALSE, filename="nemplot.pdf", ...) {

    if (!(what%in%c("graph","pos"))) stop("\nnem> plot either 'graph' or 'pos'")

    if (what=="graph"){
        M <- as(x$graph,"matrix")
        if (all(diag(M)==1)) M <- M-diag(ncol(M))
        if (remove.singletons){
            take  <- colSums(M) != 0 | rowSums(M) != 0
            graph <- graph[take,take]
        }
        gR <- as(M,"graphNEL")
        if (PDF) pdf(file=filename)   
        par(cex.main=2)
        plot(x=gR, y="dot", ...)
        if (PDF) dev.off()
    }

    if(what=="pos"){    
        par(las=2,mgp=c(5.5,1,0),mar=c(6.7,7,4,1),cex.lab=1.7,cex.main=2)
        pos <- x$pos
        image(x=1:4,
            y=1:nrow(pos),
            z = t(pos),
            main = "Posterior effect positions",
            xlab="Perturbations",
            xaxt="n",
            ylab="Effect reporters",
            yaxt="n",
            col=gray(seq(.95,0,length=10))
        )
        abline(v=(1:3)+.5)
        axis(1,1:4,colnames(x$graph))
        effects <- rownames(x$pos)
        axis(2,1:length(effects),effects)
    }


}
  
plot.score <- function(x, what="graph", remove.singletons=FALSE, PDF=FALSE, filename="nemplot.pdf", ...) {

    if (!(what%in%c("graph","mLL","pos"))) stop("\nnem> invalid plotting type: plot either 'graph', 'mLL', or 'pos'")

    if (what=="graph"){
        M <- as(x$graph,"matrix")
        if (all(diag(M)==1)) M <- M-diag(ncol(M))
        if (remove.singletons){
            take  <- colSums(M) != 0 | rowSums(M) != 0
            graph <- graph[take,take]
        }
        gR <- as(M,"graphNEL")
        if (PDF) pdf(file=filename)   
        par(cex.main=2)
        plot(x=gR, y="dot", ...)
        if (PDF) dev.off()
    }

    if(what=="mLL"){
       par(cex=1.3)
      ss <- sort(unique(x$mLL),decreasing=TRUE)[1:30]
      plot(x=1:length(ss), y=ss, pch=19, main="Score distribution",
        xlab=paste("30 top ranked models"),
        ylab="Marginal log-likelihood", 
        ylim=c(ss[length(ss)]-10,ss[1]+10)
        )
      points(1,max(unique(x$mLL)),pch=21,cex=1.7,lwd=2)

    }
    
    if(what=="pos"){    
        winner <- which.max(x$mLL)
        par(las=2,mgp=c(5.5,1,0),mar=c(6.7,7,4,1),cex.lab=1.3,cex.main=1.7)
        pos <- x$pos[[winner]]
        image(x=1:4,
            y=1:nrow(pos),
            z = t(pos),
            main = "Posterior effect positions",
            xlab="Perturbations",
            xaxt="n",
            ylab="Effect reporters",
            yaxt="n",
            col=gray(seq(.95,0,length=10))
        )
        abline(v=(1:3)+.5)
        axis(1,1:4,colnames(x$graph))
        effects <- rownames(x$pos[[winner]])
        axis(2,1:length(effects),effects)
    }

}
  
print.pairwise <- function(x, ...) {

  # general
  cat("Object of class 'pairwise' generated by 'pairwise.posterior()'\n")
  cat("\n")
  
  # slots
  cat("$graph:  phenotypic hierarchy on",ncol(x$graph),"genes)\n")
  cat("$scores: posterior distributions of local models\n")
  cat("\n")
  
  # summary
  cat("Summary of MAP estimates:\n") 
  tmp         <- table(apply(x$scores[,1:4],1,which.max))
  summ        <- c(sum(tmp),tmp[1],tmp[2]+tmp[3],tmp[4])
  names(summ) <- c("all","..","->","<->")
  print(summ)
  
  #
  #cat("\n")
  #cat("plot this object to see the graph\n")

}
  
print.score <- function(x, ...) {

  # general
  cat("Object of class 'score' generated by 'score()'\n")
  cat("\n")
  
  # slots
  cat("$graph:  phenotypic hierarchy on",ncol(x$graph),"genes\n")
  cat("$mLL:    a vector of length",length(x$mLL),"\n")
  cat("$pos:    a list   of length",length(x$pos),"\n")
  cat("$mappos: a vector of length",length(x$mappos),"\n")
  
  #cat("\n")  
  #cat("plot this object to see the graph\n")

}
  
prune.graph <- function(g,cutIN=NULL,cutOUT=NULL,quant=.95,verbose=TRUE){

if (class(g)=="matrix") g <- as(g,"graphNEL")

# compute degree of nodes
dg <- degree(g)
dc <- degree(transitive.closure(g,loops=FALSE))

# compute missing edges in and out
miss.in  <- dc$inDegree  - dg$inDegree
miss.out <- dc$outDegree - dg$outDegree

if (is.null(cutIN )) cutIN  <- ceiling(quantile(miss.in ,quant))
if (is.null(cutOUT)) cutOUT <- ceiling(quantile(miss.out,quant))
if (verbose) cat("cutIN:",cutIN," -  cutOUT:",cutOUT,"\n")
if (cutIN==0 | cutOUT==0) warning("ALL edges removed since at least one cutoff is 0")

# remove in-edges
#----------------------------
iE <- inEdges(g)
nrIN <- 0
removeIN <- nodes(g)[which(miss.in >= cutIN)]
# make sure there are edges
removeIN <- removeIN[!unlist(lapply(iE[removeIN],function(x) length(x)==0))]
for(i in removeIN){ 
    g <- removeEdge(iE[[i]],i,g)
    nrIN <- nrIN + length(iE[[i]])
    }

# remove out-edges
#----------------------------
E <- edges(g)
nrOUT <- 0
removeOUT <- nodes(g)[which(miss.out >= cutOUT)]
# make sure that edges were not removed in last step
removeOUT <- removeOUT[!unlist(lapply(E[removeOUT],function(x) length(x)==0))]
for(j in removeOUT){ 
    g <- removeEdge(j,E[[j]],g)
    nrOUT <- nrOUT + length(E[[i]])
    }

# output
nr <- nrIN + nrOUT
if (verbose) if (nr==1) cat("Removed 1 edge\n") else cat("Removed",nr,"edges\n")
return(list(graph=g,removed=nr,missing.in=miss.in,missing.out=miss.out))
}
score <- function(models,D,type="mLL", para=NULL, hyperpara=NULL, Pe=NULL,verbose=TRUE) {

  #if single model as input
  if (class(models)=="matrix") models <- list(models)  

  # Which Sgenes were silenced?
  Sgenes <- unique(colnames(D))
  nrS <- length(Sgenes)
  
  # check that all models have S-genes as names
  fkt <- function(x,s){
     ss <- sort(s)
     c1 <- all(sort(colnames(x))==ss)
     c2 <- all(sort(rownames(x))==ss)
     return(c1 & c2)
  }
  if (!all(sapply(models,fkt,s=Sgenes))) stop("\nnem:score> models must have same names as data")

  # if no prior is supplied:
  # assume uniform prior over E-gene positions
  if (is.null(Pe)) Pe <- matrix(1/nrS,nrow=nrow(D),ncol=nrS)
  
  # make count matrices D0 and D1
  # nrow=#E-genes and ncol=#S-genes
  # D0[i,j] = how often NO EFFECT at E_i when S_j was silenced
  # D1[i,j] = how often    EFFECT at E_i when S_j was silenced
  D0  <- matrix(NA,ncol=nrS,nrow=nrow(D),dimnames=list(rownames(D),Sgenes))
  D1  <- D0
  for (i in 1:nrS) {
    Di     <- D[,colnames(D) == Sgenes[i],drop=FALSE]
    D0[,i] <- rowSums(Di==0)
    D1[,i] <- rowSums(Di==1)    
  }  

  # log marginal likelihood of all models
  if (type=="mLL"){
    if (verbose==TRUE) cat("Computing marginal likelihood for",length(models),"models\n")
    a <- para[1]
    b <- para[2]
    results <- sapply(models,mLL,D1,D0,a,b,Pe)
    s       <- unlist(results["mLL",])
    ep      <- results["pos",]
    map     <- results["mappos",]
  }

  # FULL log marginal likelihood of all models
  if (type=="FULLmLL"){
    if (verbose==TRUE) cat("Computing FULL marginal likelihood for",length(models),"models\n")
    a0 <- hyperpara[1]
    b0 <- hyperpara[2]
    a1 <- hyperpara[3]
    b1 <- hyperpara[4]
    results <- sapply(models,FULLmLL,D1,D0,a0,b0,a1,b1,Pe)
    s       <- unlist(results["mLL",])
    ep      <- results["pos",]
    map     <- results["mappos",]

  }

  # winning model
  winner <- as(models[[which.max(s)]],"graphNEL")

  # output
  res <- list(graph=winner,mLL=s,pos=ep, mappos=map, type=type, para=para, hyperpara=hyperpara)
  class(res) <- "score"
  return(res)  
}
transitive.closure <- function(g,mat=FALSE,loops=TRUE){

    if (!(class(g)%in%c("graphNEL","matrix"))) stop("Input must be either graphNEL object or adjacency matrix")
    
    #-- adjacency matrix
        if (class(g)=="matrix"){
        n <- ncol(g)
        matExpIterativ <- function(x,pow,y=x,z=x,i=1) {
            while(i < pow) {
                z <- z %*% x
                y <- y+z
                i <- i+1
            }
        return(y)
        }

        h <- matExpIterativ(g,n)
        h <- (h>0)*1   
        dimnames(h) <- dimnames(g)
        if (!loops) diag(h) <- rep(0,n) else diag(h) <- rep(1,n)
        if (!mat) h <- as(h,"graphNEL")
    }

    #-- graphNEL object
    if (class(g)=="graphNEL"){
        tc <- RBGL::transitive.closure(g)    
        if (loops) tc$edges <- unique(cbind(tc$edges,rbind(tc$nodes,tc$nodes)),MARGIN=2)

        h <- ftM2graphNEL(ft=t(tc$edges),V=tc$nodes)
        if (mat) h <- as(h, "matrix")
    } 
       
    return(h)
}
transitive.reduction <-
function(g){
with.children <- sapply(edgeL(g),function(x) length(x$edges)>0)
# loop over nodes with children
for(i in nodes(g)[with.children]){
  visited <- rep(FALSE,length(nodes(g)))
  names(visited) <- nodes(g)
  #loop over children of 'i' which have children of their own
  for (j in names(which(with.children[adj(g,i)[[1]]])) ){
    # loop over grandchildren of 'i' which have not been visited yet
    for (k in names(which(!visited[adj(g,j)[[1]]]))){
      # if grandchild can also be reached directly -> remove it
      if (k %in% adj(g,i)[[1]]){
        g <- removeEdge(i,k,g)
        visited[k] <- TRUE
      }
    }
  }
}
return(g)
}
