.packageName <- "GlobalAncova"
"GlobalAncova.1gene" <-
function(xx, group, perm=10000)
{
  t.test.result      <- t.test(xx ~ group)
	F.value            <- t.test.result$statistic^2
	p.value.theo       <- 1 - pf(F.value, 1, length(group)-2)

  perm.teststat      <- mt.sample.teststat(xx, group, test="f", B=perm)
  p.value.perm       <- length(perm.teststat[perm.teststat > F.value]) / length(perm.teststat)

	test.result        <- c(F.value, p.value.perm, p.value.theo)
	names(test.result) <- c("F.value", "p.value.perm", "p.value.theo")
  return(test.result)
}

"GlobalAncova" <-
function(xx,group,covars=NULL,perm=10000,test.genes=NULL)
{
if(is.null(test.genes))
  test.genes               <- list(rownames(xx))
if(!is.list(test.genes))
  test.genes               <- list(test.genes)

# if just one gene should be tested
if(is.vector(xx))
  ANOVA.list               <- GlobalAncova.1gene(xx, group, perm)

else
{
many.pathways              <- matrix(0, length(test.genes), 4)
dimnames(many.pathways)    <- list(names(test.genes), c("genes", "F.value", "p.value.perm", "p.value.theo"))

for(j in 1:length(test.genes))			
{						
xx2 <- xx[test.genes[[j]], ]

# dimensions
N.subjects                 <- dim(xx)[[2]]
N.genes                    <- dim(xx2)[[1]]

# if a pathway contains only one gene
if(is.vector(xx2))
{
        ANOVA.list            <- GlobalAncova.1gene(xx2, group, perm)
        many.pathways[j, 1]   <- 1
        many.pathways[j, 2:4] <- ANOVA.list
}

else
{

# design matrices
# Full Model
X.full      <- cbind(1,group,covars)

# Reduced Model gene and covars only
X.redu      <- cbind(rep(1,N.subjects),covars)

# function for hat matrix
        hat.matrix <- function(x){x%*%solve(t(x)%*%x)%*%t(x)}

# Hat matrices according to models
H.full      <- hat.matrix(X.full)
H.redu      <- hat.matrix(X.redu)
I           <- diag(N.subjects)

# Matrix with rows made up by complement of group orthogonal to H.redu
        #X.addi<-matrix(group%*%(I-H.redu),N.genes,N.subjects, byrow<-TRUE) 	

# Function for projection onto one variable
        #project<-function(v,w){(sum(v*w)/sum(w*w))*w}				

# Residuals for calculating sequential sum of squares
rr.full     <- xx2 %*% (I-H.full)
rr.redu     <- xx2 %*% (I-H.redu)
        #rr.addi<-rr.redu-project(rr.redu,X.addi)				

# Sum of squares
SS.total    <- sum((xx2-(sum(xx2)/(N.genes*N.subjects)))^2)
SS.redu     <- sum(rr.redu*rr.redu)
#SS.addi    <- sum(rr.addi*rr.addi)
SS.full     <- sum(rr.full*rr.full)

SS.adjst    <- SS.total-SS.redu
#SS.group   <- SS.redu -SS.addi
#SS.gr.ge   <- SS.addi -SS.full
SS.gr.x.ge  <- SS.redu-SS.full

# DF
        DF.adjst <- dim(X.redu)[[2]]*N.genes-1
        DF.group <- 1
        DF.gr.ge <- N.genes-1
        DF.resid <- N.subjects*N.genes-1-DF.adjst-DF.group-DF.gr.ge

# ANOVA
#SS        <- c(SS.total,SS.adjst,SS.group+SS.gr.ge,SS.full)
SS         <- c(SS.total,SS.adjst,SS.gr.x.ge,SS.full)
DF         <- c(N.genes*N.subjects-1,DF.adjst,DF.group+DF.gr.ge,DF.resid)
MS         <- SS/DF
#F.value   <- c(NA,NA,((SS.group+SS.gr.ge)/(DF.group+DF.gr.ge))/MS[4],NA)
F.value    <- c(NA, NA, MS[3]/MS[4], NA)
        
ANOVA.tab            <- cbind(SS, DF, MS)
dimnames(ANOVA.tab)  <- list(c("Total","Genes adjusted","GroupXGenes","Residual"), c("SS", "DF", "MS"))

# p-value by MC Approximation to Permutation Distribution
# if number of required permutations is small use enumeration 

# Check for enumeration or random selection of permutations
# for enumeration use Sandrin Dudoits mt.sample.label from multtest
perm.enum 	<- choose(N.subjects,sum(group==1))

if(perm < perm.enum)  
  method  	<- "mc"

else 
{ 
method	  	<- "exact"
require(multtest)
perm.mat  	<- mt.sample.label(group,B=perm.enum)
print(paste("enumerating all ",perm.enum," permutations"))
}

# Enable common code for both methods by func sample.use
sample.use 	<- function(i,method)
{
if(method=="mc") 
  sample(N.subjects)
else
  c((1:N.subjects)[perm.mat[i,]==0],(1:N.subjects)[perm.mat[i,]==1])
}

smaller.F 	<- 0

# Fix number of iterations
res.number      <- min(perm,perm.enum)
for(i in 1:res.number)
{

# use residuals under Ho: no group effects and interactions
order           <- sample.use(i,method)
xx.perm         <- rr.redu[,order]

# correct for permutation of covars if present
X.perm.full     <- X.full[order,]
X.perm.full[,2] <- group
H.perm.full     <- hat.matrix(X.perm.full)

rr.full.perm    <- xx.perm%*%(I-H.perm.full)
       
SS.resid        <- sum(rr.full.perm*rr.full.perm)

# use SS.redu from original fit
SS.gr.x.ge      <- SS.redu-SS.resid

smaller.F       <- smaller.F + ((SS.gr.x.ge/(DF.gr.ge+DF.group)/(SS.resid/DF.resid)) < F.value[3])
} 

p.value.perm    <- c(NA,NA,1-(smaller.F/res.number),NA)
p.value.theo    <- c(NA,NA,1-pf(F.value[3],(DF.group+DF.gr.ge),DF.resid),NA)

test.result           <- rbind(F.value[3], p.value.perm[3], p.value.theo[3])
dimnames(test.result) <- list(c("F.value", "p.value.perm", "p.value.theo"), "")
ANOVA.list            <- list("ANOVA.table"=ANOVA.tab,"test.result.GroupXGenes"=test.result)

many.pathways[j, 1]   <- as.numeric(length(test.genes[[j]]))
many.pathways[j, 2:4] <- round(test.result[1:3], 4)
}	
}
}

if(length(test.genes) == 1)
  return(ANOVA.list)	
else
  return(many.pathways)
}

"GlobalAncova.closed" <-
function(xx,group,covars=NULL,test.genes,previous.test=NULL,level=0.05,perm=10000)
{
  # xx: gene expression matrix
  # group: vector containing the group information; must be coded as 0-1
  # covars: covariate information
  # test.genes: list of pathways (each containing a vector of genes)
  # previous.test: result of a GlobalAncova with many pathways simultaneously
  # level: alpha
  # perm: number of permutations
  
  new.data      <- Hnull.family(test.genes)
  result        <- list()
  endresult     <- list()
  just.tested   <- NULL
  sig           <- 1:length(test.genes)
  nsig          <- NULL

  for(i in 1:length(test.genes))
  {
    # hypotheses that must be tested "before" testing the end node
    related            <- grep(names(new.data)[i], names(new.data))
    len                <- lapply(names(new.data[related]), nchar)
    related            <- related[order(unlist(len))]
    
    result.i           <- matrix(NA, length(related), 4)
    dimnames(result.i) <- list(names(new.data[related]), c("genes","F.value","p.value.perm","p.value.theo"))

    for(j in 1:length(related))
      {
        name.j         <- names(new.data[related[j]])
        tested         <- name.j %in% just.tested
        prev.tested    <- name.j %in% rownames(previous.test)
        
        # if node has not been tested before
	if(tested == FALSE & prev.tested==FALSE)
	{
          # if there is only one gene in the pathway
	  if(length(new.data[[related[j]]]) == 1)
	  {
	    ga               <- GlobalAncova(xx[new.data[[related[j]]],],group=group,perm=perm)
      	    result.i[j, 1]   <- length(new.data[[related[j]]])
	    result.i[j, 2:4] <- round(ga, 4)
	    just.tested      <- c(just.tested, name.j)
	  }
	  
	  else
	  {
	    ga               <- GlobalAncova(xx[new.data[[related[j]]], ],group=group,covars=covars,perm=perm)
	    result.i[j, 1]   <- length(new.data[[related[j]]])
	    result.i[j, 2:4] <- round(ga[[2]][1:3], 4)
	    just.tested      <- c(just.tested, name.j)
	  }
	}
	
	# nodes that have been tested before within this function
	else if(tested == TRUE & prev.tested == FALSE)
	{
          list.ind           <- lapply(res.nodes, function(x) name.j %in% x)
          
          # the correct result has to be taken (there might be also rows with only NA's)
          list.ind2          <- 1
          if(sum(unlist(list.ind)) > 1)
          {
            res.lines        <- lapply(result[list.ind==T], function(x) x[rownames(x) == name.j])
            noNAs            <- lapply(res.lines, function(x) !is.na(sum(x)))
            list.ind2        <- which(unlist(noNAs)==TRUE)
          }
          row.ind            <- which(rownames(result[list.ind==T][list.ind2[1]][[1]]) %in% name.j)
          result.i[j, ]      <- result[list.ind==T][list.ind2[1]][[1]][row.ind, ]
        }
        
        # nodes that have been tested before with GlobalAncova (with specified 'test.genes')
        else
          result.i[j, ]      <- previous.test[name.j, ]

        # stop if one of the hypotheses can not be rejected
	if(result.i[j, 3] > level)
	{
	  sig          <- sig[sig != i]
	  nsig         <- c(nsig, i)
	  break
	}
      }
    result            <- c(result, list(result.i))
    res.nodes          <- lapply(result, function(x) rownames(x))
  }
  names(result)       <- names(new.data)[1:length(test.genes)]
  sig.nodes           <- names(new.data[sig])
  nsig.nodes          <- names(new.data[nsig])
  #hypotheses         <- names(new.data)
  #endresult          <- list(hypotheses, new.data, result, sig.nodes, nsig.nodes)
  endresult           <- list(new.data, result, sig.nodes, nsig.nodes)
  #names(endresult)   <- c("hypotheses","new.data","test.results","significant","not.significant")
  names(endresult)    <- c("new.data","test.results","significant","not.significant")
  return(endresult)
}

"Hnull.family" <-
function(test.genes)
{
  # 'Hnull.family' builds needed intersections of null hypotheses
  # test.genes: a list of pathways
  
  new.nodes     <- list()
  name          <- list()
  new.data      <- test.genes
  
  for(i in 1:length(test.genes))
  {
    for(j in 1:length(new.data))
    {
        temp.nodes          <- unique(c(new.data[[i]], new.data[[j]]))
        if(!identical(temp.nodes, new.data[[i]]))
	{
          # if node (=null hypothesis) does not exist yet
          samenode          <- lapply(new.nodes, function(x) identical(sort(temp.nodes), x))
          if(sum(as.logical(samenode)) == 0)
	  {
	    name            <- c(name, paste(names(new.data[i]), names(new.data[j]), sep="."))
	    new.nodes       <- c(new.nodes, list(sort(temp.nodes)))
	    namekegg        <- c(names(new.data), paste(names(new.data[i]), names(new.data[j]), sep="."))
	    new.data        <- c(new.data, list(sort(temp.nodes)))
	    names(new.data) <- namekegg
	  }
	}
    }
  }
  return(new.data)
}

"Plot.genes" <-
function (xx, group, covars = NULL)
{
# basic analysis

   N.subjects   <- dim(xx)[[2]]
   N.genes      <- dim(xx)[[1]]
   X.full       <- cbind(1, group, covars)
   X.redu       <- cbind(rep(1, N.subjects), covars)
   hat.matrix   <- function(x)
   {
       x %*% solve(t(x) %*% x) %*% t(x)
   }
   H.full       <- hat.matrix(X.full)
   H.redu       <- hat.matrix(X.redu)
   I            <- diag(N.subjects)
   X.addi       <- matrix(group %*% (I - H.redu), N.genes, N.subjects, byrow <- TRUE)
   project      <- function(v, w)
   {
       (sum(v * w)/sum(w * w)) * w
   }
   rr.full      <- xx %*% (I - H.full)
   rr.redu      <- xx %*% (I - H.redu)

#   modification if test for interaction only is intended
#   rr.addi      <- rr.redu - project(rr.redu, X.addi)

# reduction sum of squares and mean square error

   redu.sq           <- rr.redu^2-rr.full^2

   redu.SSQ.subjects <- apply(redu.sq,2,sum)
   redu.SSQ.genes    <- apply(redu.sq,1,sum)
   msE.genes         <- rowSums(rr.full^2)/(N.subjects-dim(X.full)[2])

# determination of upregulation

   up         <- 0 < (apply(xx[,group==1],1,mean)-apply(xx[,group==0],1,mean))

# plotting results

   horizontal.bars(
    x         = rev(redu.SSQ.genes),
    xlabel    = "Reduction in Sum of Squares",
    ylabel    = "Genes",
    color     = 3-rev(up),
    bar.names = rev(rownames(xx))
   )

#pp       <- rev(sort(c(-.5+(1:N.genes),.5+(1:N.genes)))) <<<<DAS WAR LEIDER FALSCH !!!!!
pp        <- sort(c(-.5+(1:N.genes),.5+(1:N.genes)))
vv        <- rev(rep(msE.genes,rep(2,N.genes)))
lines(vv,pp,type="s",lwd=2)

legend("topright", c("higher expression in group 0", "higher expression in group 1"), col=c(3,2), pch=15) #!
}

"Plot.subjects" <-
function (xx, group, covars = NULL, sort = FALSE)
{
# basic analysis

    N.subjects  <- dim(xx)[[2]]
    N.genes     <- dim(xx)[[1]]
    X.full      <- cbind(1, group, covars)
    X.redu      <- cbind(rep(1, N.subjects), covars)
    hat.matrix  <- function(x)
    {
        x %*% solve(t(x) %*% x) %*% t(x)
    }
    H.full      <- hat.matrix(X.full)
    H.redu      <- hat.matrix(X.redu)
    I           <- diag(N.subjects)
    X.addi      <- matrix(group %*% (I - H.redu), N.genes, N.subjects, byrow <- TRUE)
    project     <- function(v, w)
    {
        (sum(v * w)/sum(w * w)) * w
    }
    rr.full     <- xx %*% (I - H.full)
    rr.redu     <- xx %*% (I - H.redu)

#   modification if test for interaction only is intended
#   rr.addi      <- rr.redu - project(rr.redu, X.addi)

# reduction in sum of squares
    redu.sq           <- rr.redu^2-rr.full^2

    redu.SSQ.subjects <- apply(redu.sq,2,sum)
    redu.SSQ.genes    <- apply(redu.sq,1,sum)

# plotting results

    if(is.null(colnames(xx)))						
	colnames(xx) <- seq(1:dim(xx)[2])				

    if(sort == TRUE)							
    {									
	horizontal.bars(
		x         = rev(redu.SSQ.subjects[order(group)]),	
		xlabel    = "Reduction in Sum of Squares",		
    ylabel    = "Subjects",
		color     = 3-rev(sort(group)),				
    bar.names = rev(colnames(xx)[order(group)])
		)
    	legend("topright", c("group 0", "group 1"), col=c(3,2), pch=15)	
    }									
 
    else								
    horizontal.bars(
        x         = rev(redu.SSQ.subjects),
        xlabel    = "Reduction in Sum of Squares",
        ylabel    = "Subjects",
	      color     = 3-rev(group),
        bar.names = rev(colnames(xx))
    )
    legend("topright", c("group 0", "group 1"), col=c(3,2), pch=15) 	
}

"horizontal.bars" <-
function(x,xlabel="",ylabel="",color=NULL,labelsize=.75,bar.names=NULL)
{
        # function for plotting horizontal bars with labels added at right margin
        # bars are determined by value of x which is assumed to be a vector
        # no formal check of variables performed
        # setting the plot region

        xlim    <- 0.05*c(-1,1)*range(x)+c(min(x),max(x))
        xlim[1] <- min(0,xlim[1])
        n       <- length(x)
        ylim    <- c(0,n+1)

        # enlarging right margin for bar.names

        if(!is.null(bar.names)&length(bar.names)==n)
    {
        names   <- TRUE
                   plot.new()
        w       <- 1.5 * max(strwidth(bar.names, "inches", labelsize))
        oldmai  <- par("mai")
                   par(mai=c(oldmai[1:3],max(w,oldmai[4])), new=TRUE)
    }
        # plotting bars with border=F nothing appears color is NULL


plot(0,type="n",xlim=xlim,ylim=ylim,yaxt="n",xlab=xlabel,ylab=ylabel)
                rect(rep(0,n),(1:n)-.3,x,(1:n)+.3,col=color,border=FALSE)
                box()

        # adding bar.names at right margin

        if(names)
   {
                axis(4,at=1:n,bar.names,cex.axis=labelsize,las=2)
                par(mai=oldmai)
   }
}

