.packageName <- "GeneTS"
### avgp.R  (2004-02-15)
###
###    Average periodogram and related stuff
###
### Copyright 2003-04 Konstantinos Fokianos and Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# periodogram  of a single time series x
periodogram.spec.single <- function(x, method="builtin")
{
    if (method=="builtin")
    {
      # demean but do not detrend to avoid artefacts around zero
      spec <- spectrum(x, taper=0, plot=FALSE, fast=FALSE, detrend=FALSE, demean=TRUE)$spec
    } 
    else if (method =="clone")
    {
       x <- x - mean(x) # demean
       
       N<-length(x)
       xfft <- fft(x)
       pgram <- (Mod(xfft)^2/(N))  # squared modulus
       #pgram <- Re(xfft*Conj(xfft)/(N )) #this is the same 
       
       spec <- pgram[1 + (1:floor(N/2)) ] 
    }
    else if (method =="smooth")
     {
      # demean but do not detrend to avoid artefacts around zero
      spec <- spectrum(x, taper=0, plot=FALSE, fast=FALSE, detrend=FALSE, demean=TRUE, span=3)$spec
    } 
   
    return(spec)
}


# periodogram  of multiple time series x
periodogram.spec <- function(x, method="builtin")
{
    f <- periodogram.freq(x)
     
    xm <- as.matrix(x)
     
    num.series <- dim(xm)[2] # number of columns
    spec.matrix <- matrix(NA, nrow=length(f), ncol=num.series)
    for (i in 1:num.series)
    {
       spec.matrix[,i] <- periodogram.spec.single(xm[,i], method=method)
    }
    return(spec.matrix)
}

 
# corresponding frequencies (ranging from 0 to 1/frequency(x))
periodogram.freq <- function(x,  method="builtin")
{
    z <- as.matrix(x)[,1] # use first time series (in first column)
    
    if (method=="builtin")
    {
      # demean but do not detrend to avoid artefacts around zero
      freq <- spectrum(z, taper=0, plot=FALSE, fast=FALSE, detrend=FALSE, demean=TRUE)$freq
    } 
    else if (method =="clone")
    {
       xfreq <- frequency(z)
       N <-length(z)
       Nspec <- floor(N/2)
       freq <- seq(from = xfreq/N, by = xfreq/N, length = Nspec)  
    }
    else if (method =="smooth")
     {
      # demean but do not detrend to avoid artefacts around zero
      freq <- spectrum(z, taper=0, plot=FALSE, fast=FALSE, detrend=FALSE, demean=TRUE, span=3)$freq
    } 
   
    return(freq)
}

# periodogram
periodogram <- function(x,  method="builtin")
{
  list(spec=periodogram.spec(x, method=method), freq=periodogram.freq(x, method=method))
}


# Average Periodogram:
avgp <- function(x, title="untitled", plot=TRUE, angular = FALSE, ...)
{
    f <- periodogram.freq(x, ...)   
    if (angular) f <- 2*pi*f  # use angular frequencies
    spec.matrix <- periodogram.spec(x, ...)
    avg.spec <- apply(spec.matrix,1,mean)
    out = list(freq=f, avg.spec=avg.spec, title=title)
    
    if (plot)
    {
        plot(out[[1]], out[[2]],  type="l", 
        xlab="Fourier Frequencies", ylab="Average Periodogram", ...)
        title(main=title)
	
        return(invisible(out))
    }
    else return(out)  
}


# returns back the m dominant frequencies in single time series periodogram
dominant.freqs.single <- function(x, m=1, ...)
{    
    spec <- periodogram.spec(x, ...) 
    freq <- periodogram.freq(x, ...)
    
    sorted.freqs <- freq[order(-spec)]
    
    sorted.freqs[1:m]
}


# dito, but now also for multiple time series
dominant.freqs <- function(x, m=1, ...)
{
    xm <- as.matrix(x)
     
    num.series <- dim(xm)[2] # number of columns
    freq.matrix <- matrix(NA, nrow=m, ncol=num.series)
    for (i in 1:num.series)
    {
       freq.matrix[,i] <- dominant.freqs.single(xm[,i], m=m, ...)
    }
    
    return(freq.matrix)
}


### bagging.R  (2004-03-15)
###
###     Bagged estimators of cov, cor, and pcor
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA




# bagged estimators

bagged.cov <- function(x, R=1000, ...)
{
  vec.out <- bag.fun(cov, x, R=R, diag=TRUE, ...)
  mat.out <- vec2sm(vec.out, diag=TRUE)
  
  return( mat.out )
}

bagged.cor <- function(x, R=1000, ...)
{
  vec.out <- bag.fun(cor, x, R=R, diag=FALSE, ...)
  mat.out <- vec2sm(vec.out, diag=FALSE)
  diag(mat.out) <- rep(1, dim(mat.out)[1]) # fill diagonal with 1
  
  return( mat.out )
}

bagged.pcor <- function(x, R=1000, ...)
{
  vec.out <- bag.fun(partial.cor, x, R=R, diag=FALSE, ...)
  mat.out <- vec2sm(vec.out, diag=FALSE)
  diag(mat.out) <- rep(1, dim(mat.out)[1]) # fill diagonal with 1
  
  return( mat.out )
}

# internal

bag.fun <- function(fun, data, R, diag, ...)
{
  # number of variables 
  p <- dim(data)[2]
  
  # index vector for lower triangle
  lo <- lower.tri(matrix(NA, nrow=p, ncol=p), diag=diag)

  # bootstrap function
  boot.fun <- function(data, i) 
  {
    vec <- as.vector( fun(data[i,], ...)[lo] )
      
    # if we get NAs flag result as being erroneous
    if (sum(is.na(vec)) > 0) class(vec) <- "try-error"

    return( vec )
  }   
     
  #bag variable 
  #boot.out <- boot(data=data, statistic=boot.fun, R=R)
  boot.out <- robust.boot(data=data, statistic=boot.fun, R=R)
  
  bag <- apply( boot.out$t, 2, mean)
    
  return( bag )
}


### cor.fit.mixture.R  (2004-03-15)
###
###    Fit mixture model to empirical distribution of (partial)
###    correlation coefficients.
###    
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# fit mixture to empirical (partial) correlations
cor.fit.mixture <- function(r, MAXKAPPA=5000)
{
  # ML estimate based on mixture distribution
  
  MINLOGL = -sqrt(.Machine$double.xmax)
     
  logL.fun <- function(x)
  {
    kappa <- x[1]
    eta0 <- x[2]
    
    if (kappa < 1 || kappa > MAXKAPPA || eta0 < 0 || eta0 > 1)
    {
      logL <- MINLOGL
    }
    else
    {
      logL <- sum(  log(eta0*dcor0(r,kappa)+0.5*(1-eta0)) ) # mixture distribution
    }
       
    return(logL)
  }
     
  # find ML estimate 
  kappa.guess <- cor0.estimate.kappa(r)
  xstart <- c(kappa.guess, 0.9)
          
  #out <- optim(xstart, logL.fun, method="BFGS",
  #    control=list(fnscale=-1))   
            
  #out <- optim(xstart, logL.fun, method="BFGS",
  #   control=list(fnscale=-1, parscale=c(1,0.05)))   
              
  out <- optim(xstart, logL.fun, method="Nelder-Mead",
      control=list(fnscale=-1))   
    
  kappa <- out$par[1]
  eta0 <- out$par[2]
  logL<- out$value
  
  if (abs(kappa - MAXKAPPA) < 0.1) warning("Estimated kappa close to given MAXKAPPA.")

  return( list(kappa=kappa, eta0=eta0, logL=logL) )
}



# posterior probability that true correlation is non-zero
cor.prob.nonzero <- function(r, kappa, eta0)
{
    p0 <- eta0*dcor0(r, kappa)
    pA <- (1-eta0)*0.5 # (1-eta0)*unif(r, -1, 1)
       
    prob <- pA/(p0+pA)
    
    return(prob) 
}

### cor0.estimate.kappa.R (2004-03-15)
###
###    Estimating the Degree of Freedom of the Distribution
###    of the Sample Correlation Coefficient (assuming rho=0)
###    
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# estimate the degree of freedom
cor0.estimate.kappa <- function(r, method=c("fisher", "likelihood", "robust"), MAXKAPPA=5000, w=1.0)
{
  method <- match.arg(method)
  
  z <- z.transform(r) 
  
  if(method == "fisher") # Fisher's rule
  {
    v <- sum(z*z)/(length(z)-1) # variance around 0
    #v <- var(z)
    kappa <- 1/v +2
  }

  if(method == "robust") # Fisher's rule with robust estimate of variance
  {   
    v <- (hubers(z, mu=0, k=w)$s)^2 # robust estimate
    kappa <- 1/v +2
  }
  
  if(method == "likelihood") # ML estimate based on null-distribution
  {
     logL.fun <- function(kappa)
     {
       sum(dcor0(r,kappa,log=TRUE))
     }
     
     # find ML estimate 
     out <- optimize(logL.fun, c(1, MAXKAPPA), maximum = TRUE)
          
     kappa <- out$maximum
  }
    
  return( kappa )
}

### cor0.test.R  (2004-01-15)
###
###    Tests of Vanishing Correlation
###    
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# Test of vanishing partial correlation
#  H0: rho == 0
#  HA: rho != 0
#
# Input:  observed partial correlation r 
#         degree of freedom kappa
# Output: p-value
cor0.test <- function(r, kappa, method=c("student", "dcor0", "ztransform"))
{
  method <- match.arg(method)

  if (method == "student") # exact method
  {
       # t is distributed with df=kappa-1 
       t <- r*sqrt((kappa-1)/(1-r*r))
       
       # two-sided test around zero
       pval <- 2*pt(-abs(t), df=kappa-1)
  }
 
  if (method == "dcor0") # exact method
  {
       # two-sided test around zero
       pval <- 2*pcor0(-abs(r), kappa)
  }
  
  if (method == "ztransform") # approximate method
  {
    # apply Fisher's z-transform
    z <- z.transform(r)
    
    # then use two-sided normal test around zero
    sd <- 1/sqrt(kappa-2)
    pval <- 2*pnorm(-abs(z), mean=0, sd=sd)
  }

  return(pval)
}
### dcor0.R  (2004-03-15)
###
###    Distribution of the Correlation Coefficient (rho=0) 
###    and Related Functions
###    
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# exact likelihood for rho=0
dcor0 <- function (x, kappa, log = FALSE)
{
    r <- x
    
    log.f <- log(kappa - 1) - kappa * log(2) +
             (kappa - 3) * log(1 - r * r)/2 +
             lgamma(kappa) - 2 * lgamma((1 + kappa)/2)
    
    for (i in which(abs(r) == 1) ) # special treatment for abs(r)=1
    {
      if (kappa > 3)  log.f[i] <- -Inf
      if (kappa == 3) log.f[i] <- -log(2)      
      if (kappa < 3)  log.f[i] <- Inf
    }
       
    if (log)
    {
        return(log.f)
    }
    else
    {
        return(exp(log.f))
    }
}


# random number generator
rcor0 <- function(n, kappa)
{
  #If n is a vector, length(n) values will be generated
  if (length(n) > 1)
    num.values <- length(n)
  else
    num.values <- n
  
  cvec <- rep(NA, num.values)
  for (i in 1:num.values)
  {
     x1 <- rnorm(kappa+1)
     x2 <- rnorm(kappa+1)
     cvec[i] <- cor(x1,x2)
  }  
    
  return(cvec)
}


# incomplete beta function
ibeta <- function(z, a, b)
{
  pbeta(z, a, b)*beta(a,b)
}


# distribution function for rho=0
pcor0 <- function(q, kappa, lower.tail=TRUE, log.p=FALSE)
{
  if (kappa == 1)
  {
    value <- rep(0.5, length(q))  
    value[q==-1.0] <- 0.0
    value[q== 1.0] <- 1.0
  }
  else
  { 
    z <- q*q
    a <- 0.5
    b <- (-1 + kappa)/2
    gamma.ratio <- exp(lgamma(b+0.5)-lgamma(b))
  
    value <-  0.5*(1 + (q*ibeta(z, a, b)*gamma.ratio)/
                       (sqrt(pi) * sqrt(z)))
  
    value[q==0] <- 0.5 # special treatment for q=0  
  }      
 
  if (lower.tail == FALSE)
     value <- 1-value
     
  if (log.p == TRUE)
    value <- log(value)
  
  return(value)
}

### fdr.control.R  (2004-01-15)
###
###     Controlling False Discovery Rate in Multiple Testing
###
### Copyright 2003-04 Konstantinos Fokianos and Korbinian Strimmer
###
### Parts of this code is adapted from 
### S-PLUS code (c) by Y. Benjamini (available from
### http://www.math.tau.ac.il/~roee/FDR_Splus.txt ) 
### and from R code (c) J.D. Storey (available from 
### http://faculty.washington.edu/~jstorey/qvalue/ )
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# FDR controlling procedures.
#
# The procedure below controls the False Discovery Rate (FDR) at a
# given level Q using the algorithms described in Benjamini and Hochberg (1995)
# and Storey (2002).  The FDR is the expected proportion
# of false positives (erroneous rejections) among the significant tests (rejections).
# For a given vector of p-values and the desired FDR level Q the corresponding p-value
# cut-off and the q-values for each hypothesis (see Storey (2002) ) are computed.
#
# Notes:  
# -the default settings correspond to the step-up procedure to control the FDR 
#    by Benjamini and Hochberg (1995)
# -q-values for each hypothesis are computed as defined in Storey (2002) JRSSB
# -small sample approximation for q-value (robust=TRUE) is from Storey (2002) JRSSB.
# -default eta0=0 is safe but most conservative choice (for other possibilities
#    see estimate.eta0)
#
# References:
#
# Benjamini, Y., and Y. Hochberg (1995)  Controlling the false
# discovery rate: a practical and powerful approach to multiple testing.
# J. Roy. Statist. Soc. B. 57:289-300
#
# Storey, J.D. (2002) A direct approach to false discovery rates. 
# J. Roy. Statist. Soc. B, 64: 479-498


#Input
#=============================================================================
#p:      a vector of p-values 
#Q:      a level at which to control the FDR (default: 0.05)
#eta0     an estimate of the proportion of null p-values (default 1)
#robust: an indicator of whether it is desired to make the estimate of q-values
#         more robust for small p-values (default: FALSE)
#Output
#=============================================================================
#qvalues          q-values for each hypothesis - see Storey (2002)
#significant      a vector with TRUE/FALSE value for each hypothesis
#num.significant  number of significant hypothesis
#pvalue.cutoff    corresponding p-value cut-off (all p <= pvalue.cutoff significant)

fdr.control <- function(p, Q=0.05, eta0=1.0, robust=FALSE)
{ 
    if(min(p)<0 || max(p)>1)
    {
       stop("p-values not in valid range")
    }
      
    m <- length(p)
       
    # compute q-values
    u <- order(p)
    v <- rank(p)
    qvalue <- eta0*m*p/v
    if(robust)
    {
        qvalue <- eta0*m*p/(v*(1-(1-p)^m))
    }
    qvalue[u[m]] <- min(qvalue[u[m]],1)
    for(i in (m-1):1)
    {
        qvalue[u[i]] <- min(qvalue[u[i]],qvalue[u[i+1]],1)
    }

    # test hypothesis and compute p-value cutoff
    rej <- (qvalue <= Q)
    if ( sum(rej) == 0 )
    {
      cutoff <- 0
    }
    else
    {
      cutoff <- max(p[rej])
    }  
            
    return( list(qvalues=qvalue, significant=rej,
                   num.significant = sum(rej), 
                   pvalue.cutoff=cutoff)
           )
}
### fdr.estimate.eta0.R  (2004-03-15)
###
###     Estimating the Proportion of Null p-Values
###
### Copyright 2003-04 Konstantinos Fokianos and Korbinian Strimmer 
###
### Parts of this code is adapted from 
### S-PLUS code (c) by Y. Benjamini (available from
### http://www.math.tau.ac.il/~roee/FDR_Splus.txt ) 
### and from R code (c) J.D. Storey (available from 
### http://faculty.washington.edu/~jstorey/qvalue/ )
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


#Input
#=============================================================================
#p: a vector of p-values 
#method:  method for computing eta0
#lambda:  optional tuning parameter (vector, needed for "bootstrap" and "smoothing") 
#
#  conservative: Benjamini and Hochberg (1995) JRSSB
#  adaptive:     Benjamini and Hochberg (2000) J. Behav. Educ. Statist.
#  bootstrap:    Storey (2002) JRSSB
#  smoother:     Storey and Tibshirani (2003) PNAS

#Output
#=============================================================================
#eta0: an estimate of the proportion of null p-values

fdr.estimate.eta0 <- function(p,
    method=c("conservative", "adaptive", "bootstrap", "smoother"),
    lambda=seq(0,0.95,0.05) )
{
    method <- match.arg(method)
    
    # conservative method is default to force people
    # to think about their choice ...
    
    
    ########
    
    if (method == "conservative") # Benjamini and Hochberg (1995)
    {
        return(1.0)
    }

    ########
   
    if (method == "adaptive") # Benjamini and Hochberg (2000)
    {
        m <- length(p)
	sortp <- sort(p)
	s <- sort(1 - sortp)/(1:m)
	
	m0raw <- m
        i <- m
        while(i > 1 && s[i] <= s[i - 1]) i <- i - 1
        if(i > 1)
            m0raw <- 1/s[i - 1]
        else m0raw <- 1/s[1]
        
	m0 <- min(floor(1 + m0raw), m)
        
	eta0 <- m0/m   

        return(eta0)   
    }

    ########
    
    # for the remaining methods we require a lambda vector
    if (length(lambda)<4)
        stop("At least 4 values in lambda tuning vector required")
    
    eta0 <- rep(0,length(lambda))
    for(i in 1:length(lambda))
    {
        eta0[i] <- mean(p >= lambda[i])/(1-lambda[i])
    }
        
    ########
   
    if(method == "bootstrap") # Storey (2002) JRSSB
    {
            m <- length(p)
	    mineta0 <- min(eta0)
            mse <- rep(0,length(lambda))
            eta0.boot <- rep(0,length(lambda))
            for(i in 1:100) {
                p.boot <- sample(p,size=m,replace=TRUE)
                for(i in 1:length(lambda)) {
                    eta0.boot[i] <- mean(p.boot>lambda[i])/(1-lambda[i])
                }
                mse <- mse + (eta0.boot-mineta0)^2
            }
            eta0 <- min(eta0[mse==min(mse)])
            eta0 <- min(eta0,1)
	    
	    return (eta0)
    }    
 
    ########
 
    if(method == "smoother") # Storey and Tibshirani (2003) PNAS
    {
            seta0 <- smooth.spline(lambda,eta0,df=3)
            eta0 <- predict(seta0,x=max(lambda))$y
            eta0 <- min(eta0,1)
	    
	    return(eta0)
    }    
}
### fisher.g.test.R (2004-02-15)
###
###     Fisher's exact g test
###
### Copyright 2003-04 Konstantinos Fokianos and Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# The following function calculates the p-value of
# Fisher's exact g test given a single time series
#
# note that constant times series result in a p-value of 1
# (i.e. the null hypothesis of a purely random process is not rejected)

# Fishers exact g test (single time series, x is a vector)
fisher.g.test.single <- function(x, ...) 
{
    # constant time series result in a p-value of 1
    if( is.constant.single(x) ) return(1)
    
    m <- floor(length(x)/2)
    f.spec <- periodogram.spec(x, ...)
      
    # Max Periodogram at Frequency w1 in radians/unit time:
    w1 <- (1:length(f.spec))[f.spec == max(f.spec)][1] # [1] because we may have multiple maxima...    
    fisher   <- f.spec[w1]/sum(f.spec)
    upper    <- floor(1/fisher)
    compose  <- rep(NA, length=upper)
    for (j in 1:upper)
    {
      compose[j]  <- (gamma(m+1)/(gamma(j+1)*gamma(m-j+1)))*((-1)^(j-1))*(1-j*fisher)^(m-1)
    }
    pval  <- sum(compose)  
    if (pval > 1) pval <- 1 # this may happen due to numerical error
    
    return(pval)
}

# Fishers exact g test (multiple time series)
fisher.g.test <- function(x, ...) 
{
  xm <- as.matrix(x)
  
  num.series <- dim(xm)[2] # number of columns
  pvalues <- rep(NA, length=num.series)
  for (i in 1:num.series)
  {
     pvalues[i] <- fisher.g.test.single(xm[,i], ...)
  }
  
  return(pvalues)
}
### ggm.estimate.pcor  (2004-03-15)
###
###     Various small-samples estimators of GGM partial correlation coefficients
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# estimate partial correlation coefficients
ggm.estimate.pcor <- function(x, method=c("observed.pcor",
  "partial.bagged.cor", "bagged.pcor"), R=1000, ...)
{
  method <- match.arg(method)
 
  ########
  
  if (method == "observed.pcor")
  {
    return( partial.cor(x, ...) )
  } 

  ########
  
  if (method == "partial.bagged.cor")
  {
     cor.bag <- bagged.cor(x, R=R, ...)   
     return( cor2pcor(cor.bag) )
  } 
  
  ########

  if (method == "bagged.pcor")
  {  
     return( bagged.pcor(x, R=R, ...) )
  } 
}


### ggm.plot.graph  (2004-03-15)
###
###   Plotting the GGM network
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# requires the installation of the "graph" library

# generate a graph object from and edge list
# (such as obtained from ggm.test.edges) 
ggm.make.graph <- function(edge.list, num.nodes)
{
  if (!is.graph.loaded())
  {
    stop("This function requires the installation of the \"graph\" package from Bioconductor")
  }
  else
  {   
    # create empty graph with no edges
    V <- as.character(1:num.nodes)
    edL <- vector("list", length=num.nodes)
    names(edL) <- V
    gR <- new("graphNEL", nodes=V, edgeL=edL)
   
    # add edges and edge weights (correlations)
    gX <- addEdge(as.character(edge.list[,2]),
                  as.character(edge.list[,3]),
                  gR,
                  round(edge.list[,1], digits=2) )
  
    return(gX)
  }
}

# print vector of edge weights
show.edge.weights <- function(gr)
{
  if (!is.graph.loaded())
  {
    stop("This function requires the installation of the \"graph\" package from Bioconductor")
  }
  else
  {   
    if(is.graph.from.BioC13())
    {
      edgeWeightVector(gr, duplicates=FALSE)
    }
    else
    {
      em <- edgeMatrix(gr, duplicates=FALSE)
      eWV(gr, em)           
    }
  }
}



# requires installation of the "Rgraphviz" library

# plot network 
ggm.plot.graph <- function(gr, node.labels=NULL, show.edge.labels=TRUE, col.pos="black", col.neg="grey", ...)
{
  if (!is.Rgraphviz.loaded())
  {
    stop("This function requires the installation of the \"Rgraphviz\" package from Bioconductor")
  }
  else
  {      
    if (is.Rgraphviz.from.BioC13()) 
    {
      
      if(show.edge.labels) # plot edge labels
      {
        elab <- weightLabels(gr)
        if (is.null(node.labels))
        {
          plot(gr, "neato", edgeLabels=elab,
            fixedNodeSize=FALSE, nodeShape="ellipse", ...)
        }
        else
        {
          plot(gr, "neato", edgeLabels=elab, nodeLabels=node.labels,
            fixedNodeSize=FALSE, nodeShape="ellipse", ...)
        }
      }
      else # don't plot edge labels
      {
        if (is.null(node.labels))
        {
          plot(gr, "neato", fixedNodeSize=FALSE, nodeShape="ellipse", ...)
        }
        else
        {
          plot(gr, "neato", nodeLabels=node.labels,
            fixedNodeSize=FALSE, nodeShape="ellipse", ...)
        }      
      }

    }
    else
    {
      # general graph attributes
      gAttrs <- getDefaultAttrs(layoutType="neato")
      gAttrs$edge$color <- "black"    
      gAttrs$node$shape <- "ellipse"
      gAttrs$node$fixedsize <- FALSE
      
      if (!is.null(node.labels))
      {
        # node attributes
        # node.labels are given by the user
        node.names <- nodes(gr)
      
        nAttrs <- list()
        nAttrs$label <- node.labels
        names(nAttrs$label) <- node.names
      }
  
      #  edge attributes
      em <- edgeMatrix(gr)
      emv <- eWV(gr, em, sep="~")
      edge.names <- names(emv)
      edge.labels <- as.character(emv)
      
      eAttrs <- list()
      
      if (show.edge.labels)
      {
        eAttrs$label <- edge.labels
        names(eAttrs$label) <- edge.names
      }
      
      # color edges according to positive and negative correlation
      eAttrs$color <- rep(col.pos, length(edge.labels))
      eAttrs$color[emv < 0] <- col.neg
      names(eAttrs$color) <- edge.names
  
      if (is.null(node.labels))
      {
        plot(gr, "neato", attrs=gAttrs, edgeAttrs = eAttrs, ...)
      }
      else
      {
        plot(gr, "neato", attrs=gAttrs, nodeAttrs=nAttrs, edgeAttrs = eAttrs, ...)
      }
    }
   
  }
}

### ggm.simulate.data  (2004-01-15)
###
###     Simulate GGM data
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# Simulate data from a given GGM model
#  input:  matrix with partial correlations 
#  output: multinormal data (with mu=0 and var=1)
ggm.simulate.data <- function(sample.size, pcor)
{
  mu <- rep(0, dim(pcor)[1])
  
  cor.mat <- pcor2cor(pcor)
  
  return( myrmvnorm(sample.size, mu, cor.mat) )
}


########## internal ##########

# modified from mvtnorm package
# generate multinormal data
myrmvnorm <- function(n, mean, sigma)
{
  sigsvd <- svd(sigma)
  retval <- t(sigsvd$v %*% (t(sigsvd$u) * sqrt(sigsvd$d)))
  retval <- matrix(rnorm(n * ncol(sigma)), nrow = n) %*% retval
  retval <- sweep(retval, 2, mean, "+")
  
  return(retval)
}

### ggm.simulate.pcor  (2004-01-15)
###
###     Simulate GGM Networks
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# chose random GGM network
#  returns a positive definite partial correlation matrix
#  with the given proportion of non-zero elements
ggm.simulate.pcor <- function(num.nodes, etaA=0.05)
{
  # num.nodes:  number of nodes in the network
  # etaA:          proportion of edges in the graph
  
  ####################
  eps <- 0.0001
  # eps:        additional additive component to diag(precision_matrix)
  ####################
  
  
  num.edges <- num.nodes*(num.nodes-1)/2
  num.elements <- ceiling(num.edges*etaA) 

  # determine position of the non-zero elements
  element.idx <- sample(1:num.edges, num.elements)
  precision.lo <- rep(0,num.edges)
  
  # draw number 
  precision.lo[element.idx] <- runif(num.elements,-1.0,+1.0)
 
  # construct symmetric matrix
  precision <- matrix(0, nrow=num.nodes, ncol=num.nodes)
  precision[lower.tri(precision)] <- precision.lo
  for(i in 1:(num.nodes-1))
  {
    for(j in (i+1):num.nodes)
    {
	precision[i,j] <- precision[j,i]
    }
  }
	
  # construct diagonally dominant matrix (so that it is positive definite)	
  for(i in 1:num.nodes)
  {
    diag(precision)[i] <- sum(abs(precision[,i]))+eps	
  }	
  pcor <- standardize.cov(precision)

 
  return(pcor)
}
### ggm.test.edges  (2004-03-15)
###
###   Compute p-values, q-values and posterior probabilities for GGM edges
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


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


# assign p-values, q-values and posterior probabilities to each edge
ggm.test.edges <- function(r.mat, MAXKAPPA=5000, kappa=NULL, eta0=NULL)
{
   pcor <- sm2vec(r.mat)
   indexes <- sm.indexes(r.mat)
   colnames(indexes) <- c("node1", "node2")
   
   if (is.null(kappa) || is.null(eta0))
   {
     # estimate kappa and eta0
     mfit <- cor.fit.mixture(pcor)
     kappa <-  mfit$kappa
     eta0 <- mfit$eta0  
   }
      
   pval <- cor0.test(pcor, kappa)
   fdr.out <- fdr.control(pval, eta0=eta0)
   qval <- fdr.out$qvalues
   prob <- cor.prob.nonzero(pcor, kappa, eta0)

   result <- cbind(pcor, indexes, pval, qval, prob)

   # sort according to magnitude of correlation 
   sort.idx <- order(-abs(result[,1]))
   result <- result[sort.idx,]
   
   # return as data frame
   return(as.data.frame(result))
}

### is.constant.R  (2004-02-15)
###
###     Simple check for constant time series
###
### Copyright 2003-04 Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# checks wether a vector (time series) is constant
is.constant.single <- function(v)
{
   tmp <- v[1]
   flag <- TRUE
   for (i in 2:length(c))
   {
      if (v[i] != tmp)
      {
         flag = FALSE
	 break
      }
   }
   flag
}


# dito, but also for an array of time series
is.constant <- function(x)
{
  return( apply(as.matrix(x), 2, is.constant.single) )    
} 
### kappa2N.R (2004-01-15)
###
###    Conversion of kappa to N and vice versaa 
###    
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# sample size corresponding to kappa and G
kappa2N <- function(kappa, G=2)
{
  return( kappa+G-1 )
}

# sample size corresponding to N and G
N2kappa <- function(N, G=2)
{
  return( N-G+1 )
}


### mat.util.R  (2004-03-15)
###
###     Library utility functions
###
### Copyright 2004 Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# check R version
isR181 <- function()
{
  if (R.version$major == "1" &&  R.version$minor == "8.1")
  {
     return(TRUE)
  }
  else
  {
     return(FALSE)
  }
}


# get package version
getPackageVersion <- function(pkg)
{
  if(isR181())
    return( package.description(pkg, fields="Version") )
  else
    return( packageDescription(pkg, fields="Version") )
}


# check graph/BioC version
is.graph.from.BioC13 <- function()
{
  if ( getPackageVersion("graph") == "1.2.0")
    return(TRUE)
  else
   return(FALSE)  
}


# check graph/BioC version
is.Rgraphviz.from.BioC13 <- function()
{
  if ( getPackageVersion("Rgraphviz") == "1.3.0")
    return(TRUE)
  else
   return(FALSE)  
}


# check whether graph package is loaded 
is.graph.loaded <- function()
{
 if (sum(.packages() == "graph") > 0)
   return(TRUE)
 else
   return(FALSE)
}

# check whether Rgraphviz package is loaded 
is.Rgraphviz.loaded <- function()
{
 if (sum(.packages() == "Rgraphviz") > 0)
   return(TRUE)
 else
   return(FALSE)
}

### mat.convert.R  (2004-01-15)
###
###     Convert symmetric matrix to vector and back
###
### Copyright 2003-04 Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# convert symmetric matrix to vector
sm2vec <- function(m, diag = FALSE)
{
    return( as.vector(m[lower.tri(m, diag)]) )
}

# corresponding indexes
sm.indexes <- function(m, diag = FALSE)
{
  m.dim <- length(diag(m))
 
  if (diag == TRUE)
    num.entries <- m.dim*(m.dim+1)/2
  else
    num.entries <- m.dim*(m.dim-1)/2
    
  index1 <- rep(NA, num.entries )
  index2 <- rep(NA, num.entries )

  if (diag == TRUE)
    delta <- 0
  else
    delta <- 1

  z <- 1
  for (i in 1:(m.dim-delta))
    for (j in (i+delta):m.dim)
    {
      index1[z] <- i
      index2[z] <- j
      z <- z+1
    }
      
 return( cbind(index1, index2) )
}

# convert vector to symmetric matrix
#
# note: if diag=FALSE then the diagonal will consist of NAs
#
vec2sm <- function(vec, diag = FALSE, order = NULL)
{
  # dimension of matrix
  n <- (sqrt(1+8*length(vec))+1)/2
  if (diag == TRUE) n <- n-1
  if ( ceiling(n) != floor(n) )
    stop("Length of vector incompatible with symmetric matrix")
       
  # fill lower triangle of matrix     
  m <- matrix(NA, nrow=n, ncol=n)
  lo <- lower.tri(m, diag)
  if (is.null(order))
  {
    m[lo] <- vec
  }
  else
  {
    # sort vector according to order
    vec.in.order <- rep(NA, length(order))
    vec.in.order[order] <- vec
    m[lo] <- vec.in.order
  }
  
  # symmetrize
  for (i in 1:(n-1))
    for (j in (i+1):n)
         m[i, j] <- m[j, i]   
  
  return( m )
}
### mat.util.R  (2004-01-15)
###
###     Some matrix utility functions
###
### Copyright 2003-04 Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# checks whether a matrix is positive definite
is.positive.definite <- function(m, eps = .Machine$double.eps)
{   
  eval <- eigen(m)$values
  
  if ( sum(eval >= eps) == length(eval) )
    return(TRUE)
  else
    return(FALSE)
}


# rank and condition of a matrix 
rank.condition <- function (m, tol = sqrt(.Machine$double.eps))
{
    d <- svd(m, nv=0)$d
    eps <- max(d) * tol
    r <- sum(d > eps)
    c <- max(d)/min(d)
    return(list(rank = r, condition = c))
}


# checks whether a matrix is a square matrix
is.square <- function(m)
{
  if(nrow(m) == ncol(m))
    return(TRUE)
  else
   return(FALSE)
}

# checks whether a matrix is symmetric
is.symmetric <- function(m, eps = .Machine$double.eps)
{
  if ( is.square(m) == FALSE) return(FALSE)

  num.col = ncol(m)
  for (i in 1:(num.col-1))
    for (j in (i+1):num.col)
    {      
      if (  abs(m[i,j] - m[j,i]) >= eps  ) 
      {
	return(FALSE)
      }
    
    }
   return(TRUE)
}
### pcor.R  (2004-03-15)
###
###    Partial Correlation computed by Inversion 
###    of the Covariance or Correlation Matrix
###    
###
### Copyright 2003-04 Juliane Schaefer and Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


#
# partial correlation matrix
#
# input: covariance matrix or correlation matrix
# ouput: partial correlation matrix
#
cor2pcor <- function(m, exact.inversion=FALSE, ...)
{
  # standardize
  m <- standardize.cov(m)
  
  # invert, then negate off-diagonal entries
  if (exact.inversion)
  {
    m <- -solve(m)
  }
  else
  {
    m <- -pseudoinverse(m, ...)
  }
  diag(m) <- -diag(m)

  # standardize and return  
  return(standardize.cov(m))
}


#
# backtransformation to correlation matrix
#
# input: partial correlation matrix
# ouput: correlation matrix
pcor2cor <- function(m, exact.inversion=FALSE, ...)
{
  # standardize
  m <- standardize.cov(m)

  # negate off-diagonal entries, then invert
  m <- -m
  diag(m) <- -diag(m)
  if (exact.inversion)
  {
    m <- solve(m)
  }
  else
  {
    m <- pseudoinverse(m, ...)
  }
  
  
  # standardize and return 
  return(standardize.cov(m))
}


#
# compute partial correlations given the data x 
#
partial.cor <- function(x, 
   use=c("all.obs", "complete.obs", "pairwise.complete.obs"),
   method=c("pearson", "kendall", "spearman"),
   exact.inversion=FALSE, ...)
{
  use <- match.arg(use)
  method <- match.arg(method)
  
  return( cor2pcor(cor(x, use=use, method=method), exact.inversion, ...) )
}

### pseudoinverse.R  (2004-01-15)
###
###    Computation of the Pseudoinverse of a Matrix
###
### Copyright 2003-04 Korbinian Strimmer
###
### This is essentially a proxy to "ginv" from the MASS package
### by B. Venables and B. Ripley.
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA



# pseudoinverse of a matrix
pseudoinverse <- function (m, tol = sqrt(.Machine$double.eps))
{
    return( ginv(m, tol) )
}
### robust.boot.R  (2004-02-15)
###
###     Reobust error resistant bootstrap algorithm
###
### Copyright 2003-04 Korbinian Strimmer
###
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# simple bootstrap function (robust against errors)
robust.boot <- function(data, statistic, R)
{
  idx <- 1:dim(data)[1]
  
  # determine dimension of statistic
  repeat
  {
    bx <- sample(idx, replace=TRUE)
    val <- try(statistic(data, bx)) 
    
    if (class(val) != "try-error") break
  }
  dim.statistic <- length(val)
  output <- matrix(nrow=R, ncol=dim.statistic)
  
  replicate.count <- 0
  error.count <- 0
  while (replicate.count < R)
  {
    bx <- sample(idx, replace=TRUE)
    val <- try(statistic(data, bx)) 
    
    if (class(val) == "try-error") # if we get a numerical error we simply repeat the draw ..
    {
      error.count <- error.count+1
      #cat("Bootstrapping continues, drawing an alternative bootstrap sample ...\n")
      
      if (error.count > R) stop("Too many errors encountered during the bootstrap.")
    }
    else
    {
      replicate.count <- replicate.count+1
      output[replicate.count,] <- val
    }
  }
  
  if (error.count > 0) warning(paste(error.count, "out of", R, "bootstrap samples were repeated due to errors."))
  
  return(list(t=output))
} 

### standardize.cov.R (2004-01-15)
###
###    Determine Correlation Matrix from Covariance Matrix, and
###    Rebuild Covariance Matrix from Correlation Matrix and Variances
###    
###
### Copyright 2003-04 Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


#
# standardize covariance matrix
#
# input:  covariance matrix    m(ij)
# output: correlation matrix   m(ij)/sqrt(m(ii)*m(jj))
#
standardize.cov <- function(m)
{
  d <- diag(m)
    
  if( sum(d == 1.0) == length(d) )
    return(m) # already standardized
    
    if (sum(d > 0) != length(d))
    {
       	warning("zero/negative diagonal elements present - check numerical accuracy")
	
	# workaround - be careful with results!
        d[d == 0] <- .Machine$double.eps  # make zero entries positive	
	d[d < 0] <- -d[d < 0] # take absolute value of negative entries
    }
    
  # standardize
  resid.sd <- 1/sqrt(diag(m))
  cr <- sweep(sweep(m, 1, resid.sd, "*"), 2, resid.sd, "*") 
  
  # correct numerical glitches
  cr[cr > 1] <- 1
  cr[cr < -1] <- -1
  
  return(cr)
}


#
# rebuild covariance matrix
#
# input:  correlation matrix           rho(ij)
#         vector with variances        var(i) 
# output: correlation matrix   rho(ij)*sqrt(var(i)*var(j))
#
rebuild.cov <- function(r, v)
{
  resid.sd <- sqrt(v)
  m <- sweep(sweep(r, 1, resid.sd, "*"), 2, resid.sd, "*") 
    
  return(m)
}


### z.transform.R  (2004-01-15)
###
###    Variance-Stabilizing Transformations of the Correlation Coefficient
###    
###
### Copyright 2003-04 Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


# Fisher's z-transform 
z.transform <- function(r)
{
  return( atanh(r) )
}


# Hotelling's second-order transform
hotelling.transform <- function(r, kappa)
{
  z <- z.transform(r)
  
  return( z - (3*z+r)/(4*kappa) )
}
### zzz.R  (2004-03-15)
###
###    Startup of GeneTS package
###    
###
### Copyright 2003-04 Korbinian Strimmer
###
### This file is part of the `GeneTS' library for R and related languages.
### It is made available under the terms of the GNU General Public
### License, version 2, or at your option, any later version,
### incorporated herein by reference.
### 
### This program is distributed in the hope that it will be
### useful, but WITHOUT ANY WARRANTY; without even the implied
### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
### PURPOSE.  See the GNU General Public License for more
### details.
### 
### You should have received a copy of the GNU General Public
### License along with this program; if not, write to the Free
### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
### MA 02111-1307, USA


.First.lib <- function(libname, pkgname)
{
  # some startup stuff
  
  # for R = 1.8.1: we need to load the "ts" and "modereg" packages (used in fdr.estimate.eta0)
  # from R 1.9 on "ts" and "modreg" are merged into the "stats" package 
  if (isR181())
  {
     library(ts)
     library(modreg)
  }
  else
  {
     library(stats)
  }
 
  # load the MASS package (for pseudoinverse and robust variance estimates)
  library(MASS)
  
  #my.require <- function(pkg) # pkg must be a string
  #{
  #   cat(paste("Loading the \"", pkg, "\" package ...\n", sep=""))
  #   return(class(try(library(pkg, character.only=TRUE), silent=TRUE)) != "try-error")
  #}
  
  # try to load the graph package
  GRAPH.LIB <- TRUE
  if (require("graph") == FALSE)
  {
    cat("The \"graph\" package from Bioconductor is not installed, therefore network plotting is unavailable in GeneTS.\n")
    GRAPH.LIB <- FALSE   
  }
  
  # try to load the Rgraphviz library
  if (GRAPH.LIB)
  {
    if (require("Rgraphviz") == FALSE)
    {
      cat("The \"Rgraphviz\" package is not installed, therefore network plotting is not available in GeneTS.\n")
    } 
  }
}
