.packageName <- "bioDist"
"KLD" <- function(f,g, supp=c(-3,3), subdivisions=1000) {
# f and g must be 1-arg funcs that evaluate
# on vector inputs
  me <- .Machine$double.eps
  wlrat <- function(x) log((f(x)+me)/(g(x)+me))*f(x)
  options(show.error.messages = FALSE)
  on.exit(options(show.error.messages = TRUE))
  xx<- try(integrate( wlrat, supp[1], supp[2], subdivisions=subdivisions ))
  if(inherits(xx, "try-error") )
    return(NA)
  return(xx$value)
}

setGeneric("KLD.matrix", function(x, ...) standardGeneric("KLD.matrix"))

setMethod("KLD.matrix", signature=signature("matrix"), 
    function(x, method=c("locfit", "density"), supp=c(-3,3), 
    subdivisions=1000, diag=FALSE, upper=FALSE){

   x <- as.matrix(x)
   nc <- ncol(x)
   nr <- nrow(x)
   clist <- vector("list", length=nr)
   method = match.arg(method)
   if(method=="locfit")
     {
        for(i in 1:nr)
         clist[[i]] <- locf2func(x[i,])
      }
   else if (method=="density")
      {
         for ( i in 1:nr)
           clist[[i]] <- dens2func(x[i,])
      }
   else 
	stop("method", method, "not supported") 

   rvec<-rep(NA, nr*(nr-1)/2)
   ct <- 1
   for(i in 1:(nr-1))
   for(j in (i+1):nr) {
          if (is.null(supp)) supp <- range(x[c(i,j),])
           rvec[ct] <- KLD(clist[[i]], clist[[j]], supp=supp, 
                                   subdivisions=subdivisions)
           ct <- ct+1
       }
   attributes(rvec) <- list(Size = nr, Labels = row.names(x),
                            Diag = diag, Upper = upper, methods =
                            "KLD", class = "dist")
   rvec

})

setMethod("KLD.matrix", signature=signature("ExpressionSet"),
    function(x, method=c("locfit", "density"), supp=c(-3,3), 
        subdivisions=1000, diag=FALSE, upper=FALSE, sample=TRUE) {
        if( sample ) ep = t(exprs(x)) else ep = exprs(x)
        KLD.matrix(ep, method, supp, subdivisions, diag, upper)
        })


## tentative "list" method for unequal sized samples (added by
## Deepayan Sarkar)

setMethod("KLD.matrix", signature=signature("list"), 
          function(x, method = c("locfit", "density"),
                   supp=c(-3,3), 
                   subdivisions=1000,
                   diag=FALSE, upper=FALSE)
      {
          method <- match.arg(method)
          dfun <- switch(method,
                         locfit = locf2func,
                         density = dens2func)
          n <- length(x)
          if (n < 1) return()
          clist <- vector("list", length=n)
          for (i in seq_len(n)) clist[[i]] <- dfun(x[[i]])
          ans <- matrix(NA, n, n)
          for(i in seq_len(n))
              for(j in seq_len(n))
              {
                  if (is.null(supp))
                      supp <- range(x[[i]], x[[j]], finite = TRUE)
                  ans[i, j] <-
                      if (i == j) 0
                      else KLD(clist[[i]], clist[[j]],
                               supp=supp, 
                               subdivisions=subdivisions)
              }
          ## if (symmetrize) ans <- t(ans) + ans 
          if (!is.null(names(x)))
              rownames(ans) <- colnames(ans) <- names(x)
          ans
      })

setGeneric("KLdist.matrix", function(x, ...) standardGeneric("KLdist.matrix"))

setMethod("KLdist.matrix", signature=signature("matrix"), 
          function(x, nbin=10, symmetrize=FALSE, diag=FALSE, upper=FALSE)
{
   x <- as.matrix(x)
   nc <- ncol(x)
   nr <- nrow(x)
   clist <- vector("list", length=nr)
   me <- .Machine$double.eps
 
   ##note: we combine x and y before binning, to make sure we span
   ##   the range of the data, and we add machine epsilon to 
   ##   protect against +/- Inf; this could use some work.
   appfun <- function(x,y)
    { 
      
      breaks.x <- hist(c(x,y) ,breaks=nbin,plot=FALSE)$breaks
      
      temp1 <- table(cut(y,breaks.x, include.lowest = TRUE))/nc
      temp1 <- temp1+me
      temp2 <- table(cut(x,breaks.x, include.lowest = TRUE))/nc
      temp2 <- temp2 + me
      
      dist <- sum(log(temp2/temp1)*temp2) 
      if(symmetrize)
       {
        dist <- (dist + sum(log(temp1/temp2)*temp1))/2
         }
      return(dist)   
    }
    
   rvec<-rep(NA, nr*(nr-1)/2)
   ct <- 1
   for(i in 1:(nr-1))
       for(j in (i+1):nr) {
           rvec[ct] <- appfun(x[i,], x[j,])
           ct <- ct+1
       }
   attributes(rvec) <- list(Size = nr, Labels = row.names(x),
                            Diag = diag, Upper = upper, methods =
                            "KLdist", class = "dist")
   rvec

} )

setMethod("KLdist.matrix", signature=signature("ExpressionSet"),
function(x, nbin=10, symmetrize=FALSE, diag=FALSE, 
         upper=FALSE, sample=TRUE)  {
    if( sample ) ep = t(exprs(x)) else ep = exprs(x)
    KLdist.matrix(ep, nbin, symmetrize, diag, upper)
})




## tentative "list" method for unequal sized samples (added by
## Deepayan Sarkar)


setMethod("KLdist.matrix",
          signature=signature("list"), 
          function(x, 
                   discretize = TRUE, nbin = 10,
                   symmetrize = FALSE,
                   diag = FALSE, upper=FALSE)
      {
          n <- length(x)
          clist <- vector("list", length=n)
          me <- .Machine$double.eps
          
          ##note: we combine x and y before binning, to make sure we span
          ##   the range of the data, and we add machine epsilon to 
          ##   protect against +/- Inf; this could use some work.
          distfun <- function(x, y)
          {
              ## not clear what should be done if exactly one of x and y is a factor
              if (discretize && !is.factor(x))
              {
                  breaks.x <- hist(c(x,y), breaks = nbin, plot = FALSE)$breaks
                  temp1 <- table(cut(y, breaks.x, include.lowest = TRUE)) / length(y)
                  ## temp1 <- temp1 + me
                  temp2 <- table(cut(x, breaks.x, include.lowest = TRUE)) / length(x)
                  ## temp2 <- temp2 + me
                  sum( ifelse(temp2 > 0, log(temp2 / (temp1 + me)) * temp2, 0) , na.rm = TRUE)
              }
              else
              {
                  levs <- sort(unique(c(x, y)))
                  tabx <- table(factor(x, levels = levs)) / length(x)
                  taby <- table(factor(y, levels = levs)) / length(y)
                  sum(ifelse(tabx > 0, log(tabx / (taby + me)) * tabx, 0), na.rm = TRUE)
              }
          }
          ans <- matrix(NA, n, n)
          for(i in seq_len(n))
              for(j in seq_len(n))
              {
                  ans[i, j] <- distfun(x[[i]], x[[j]])
              }
          if(symmetrize) ans <- t(ans) + ans
          if (!is.null(names(x)))
              rownames(ans) <- colnames(ans) <- names(x)
          ans
      })



closest.top <- function(x, dist.mat, top)
{
  dist <- as.matrix(dist.mat)
  vector <- dist[x,colnames(dist) != x]
  return(names(vector)[order(vector)[1:top]])
}

setGeneric("cor.dist", function(x, ...) standardGeneric("cor.dist"))

setMethod("cor.dist", signature=signature("matrix"), 
    function(x, abs=TRUE,diag=FALSE, upper=FALSE)
{
  nr <- nrow(x)
  rvec <- cor(t(x))
  if(abs)
   rvec <- 1-abs(rvec)
  else
    rvec <- 1-rvec
  if(upper)
   rvec <- rvec[upper.tri(rvec,diag=diag)]
  else
     rvec <- rvec[lower.tri(rvec,diag=diag)]
  attributes(rvec) <- list(Size = nr, Labels = rownames(x),
                              Diag = diag, Upper = upper, methods =
                              "cor", class = "dist")
   rvec
} )

setMethod("cor.dist", signature=signature("ExpressionSet"),
    function(x, abs=TRUE,diag=FALSE, upper=FALSE) {
        if( sample ) ep = t(exprs(x)) else ep = exprs(x)
        cor.dist(ep, abs, diag, upper)
    })



"dens2func" <-
function(x, ...) {
    den1 <- density(x, ...)
    f <- function(w) approx(den1$x, den1$y, w, yleft=0, yright=0)$y
    class(f) <- "dfun"
    f
}

setGeneric("euc", function(x, ...) standardGeneric("euc"))

setMethod("euc", signature=signature("matrix"), 
    function(x, diag = FALSE, upper = FALSE)
{
   dist(x, method="euclidean", diag = diag, upper = upper)
} )

setMethod("euc", signature=signature("ExpressionSet"),
    function(x, diag = FALSE, upper = FALSE) euc(exprs(x), diag, upper))
locf2func <- function(x, ..., maxk = 100) {
    if(!require(locfit))
		stop("can only be used if locfit library is available")
    for(i in 1:10) {
		l <- try(locfit(~x, ..., maxk = i * maxk))
		if(!is(l, "try-error"))
			break;
	}
    den1 <- preplot(l,...)
    xvals <- den1$xev[[1]]
    yvals <- den1$trans(den1$fit)
    f <- function(w) approx(xvals, yvals, w, yleft=0, yright=0)$y
    class(f) <- "dfun"
    f
}

setGeneric("man", function(x, ...) standardGeneric("man"))

setMethod("man", signature=signature("matrix"),
    function(x, diag = FALSE, upper = FALSE)
{
  dist(x, method="manhattan", diag=diag, upper=upper)
} )

setMethod("man", signature=signature("ExpressionSet"),
    function(x, diag=FALSE, upper=FALSE) man(exprs(x), diag, upper))

setGeneric("mutualInfo", function(x, ...) standardGeneric("mutualInfo"))

setMethod("mutualInfo", signature=signature("matrix"),
    function(x, nbin=10, diag=FALSE, upper=FALSE)
{
   x <- as.matrix(x)
   nc <- ncol(x)
   nr <- nrow(x)
   clist <- vector("list", length=nr)
   for(i in 1:nr)
       clist[[i]] <- cut(x[i,], breaks=nbin)

   ppfun <- function(pp) {pp<-pp[pp>0]; -sum(pp*log(pp ))}
   appfun <- function(x,y) {ppfun(table(x)/nc)+ppfun(table(y)/nc) -
                                 ppfun(c(table(x, y)/nc))}

   rvec<-rep(NA, nr*(nr-1)/2)
   ct <- 1
   for(i in 1:(nr-1))
       for(j in (i+1):nr) {
           rvec[ct] <- appfun(clist[[i]], clist[[j]])
           ct <- ct+1
   }   
   attributes(rvec) <- list(Size = nr, Labels = row.names(x),
                            Diag = diag, Upper = upper, methods =
                            "mutualInfo", class = "dist")
   rvec
} )

setMethod("mutualInfo", signature=signature("ExpressionSet"),
    function(x, nbin=10, diag=FALSE, upper=FALSE, sample=TRUE) {
        if( sample ) ep = t(exprs(x)) else ep = exprs(x)
        mutualInfo(ep, nbin, diag, upper)
    })


setGeneric("MIdist", function(x, ...) standardGeneric("MIdist"))

setMethod("MIdist", signature=signature("matrix"),
    function(x, nbin=10, diag=FALSE, upper=FALSE) 
  1 - (1 - exp(-2*mutualInfo(x, nbin, diag, upper)))^.5
)

setMethod("MIdist", signature=signature("ExpressionSet"),
    function(x, nbin=10, diag=FALSE, upper=FALSE, sample=TRUE) {
        if( sample ) ep = t(exprs(x)) else ep = exprs(x)
        MIdist(ep, nbin, diag, upper)
        })
setGeneric("spearman.dist", function(x, ...) standardGeneric("spearman.dist"))

setMethod("spearman.dist", signature=signature("matrix"), 
    function(x, abs=TRUE,diag=FALSE, upper=FALSE)
{
  nr <- nrow(x)
  rvec <- cor(t(x), method="spearman")
  if(abs)
   rvec <- 1-abs(rvec)
  else
    rvec <- 1-rvec
  if(upper)
   rvec <- rvec[upper.tri(rvec,diag=diag)]
  else
     rvec <- rvec[lower.tri(rvec,diag=diag)]
  attributes(rvec) <- list(Size = nr, Labels = rownames(x),
                              Diag = diag, Upper = upper, methods =
                              "spearman", class = "dist")
   rvec
} )

setMethod("spearman.dist", signature=signature("ExpressionSet"),
    function(x, abs=TRUE,diag=FALSE, upper=FALSE, sample=TRUE) {
        if( sample ) ep = t(exprs(x)) else ep = exprs(x)
        spearman.dist(ep, abs, diag, upper)})
setGeneric("tau.dist", function(x, ...) standardGeneric("tau.dist"))

setMethod("tau.dist", signature=signature("matrix"), 
    function(x, abs=TRUE,diag=FALSE, upper=FALSE)
{
  nr <- nrow(x)
  rvec <- cor(t(x), method="kendall")
  if(abs)
   rvec <- 1-abs(rvec)
  else
    rvec <- 1-rvec
  if(upper)
   rvec <- rvec[upper.tri(rvec,diag=diag)]
  else
     rvec <- rvec[lower.tri(rvec,diag=diag)]
  attributes(rvec) <- list(Size = nr, Labels = rownames(x),
                              Diag = diag, Upper = upper, methods =
                              "kendall", class = "dist")
   rvec
} )

setMethod("tau.dist", signature=signature("ExpressionSet"),
    function(x, abs=TRUE,diag=FALSE, upper=FALSE, sample=TRUE) {
        if( sample ) ep = t(exprs(x)) else ep = exprs(x)
        tau.dist(ep, abs, diag, upper)})
.onLoad <- function(libname, pkgname) require("methods")
