.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("exprSet"),
    function(x, method=c("locfit", "density"), supp=c(-3,3), 
        subdivisions=1000, diag=FALSE, upper=FALSE) 
        KLD.matrix(x@exprs, method, supp, subdivisions, diag, upper))
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,freq=FALSE,plot=FALSE)$breaks
      
      temp1 <- table(cut(y,breaks.x))/nc
      temp1 <- temp1+me
      temp2 <- table(cut(x,breaks.x))/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("exprSet"),
    function(x, nbin=10, symmetrize=FALSE, diag=FALSE, upper=FALSE) 
        KLdist.matrix(x@exprs, nbin, symmetrize, diag, upper))
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("exprSet"),
    function(x, abs=TRUE,diag=FALSE, upper=FALSE) cor.dist(x@exprs, 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("exprSet"),
    function(x, diag = FALSE, upper = FALSE) euc(x@exprs, diag, upper))
locf2func <- function(x, ...) {
    require(locfit) || stop("can only be used if locfit library is available")
    l = locfit(~x, ...)
    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("exprSet"),
    function(x, diag=FALSE, upper=FALSE) man(x@exprs, 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("exprSet"),
    function(x, nbin=10, diag=FALSE, upper=FALSE) 
        mutualInfo(x@exprs, 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("exprSet"),
    function(x, nbin=10, diag=FALSE, upper=FALSE) 
        MIdist(x@exprs, 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("exprSet"),
    function(x, abs=TRUE,diag=FALSE, upper=FALSE) 
        spearman.dist(x@exprs, 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("exprSet"),
    function(x, abs=TRUE,diag=FALSE, upper=FALSE) 
        tau.dist(x@exprs, abs, diag, upper))
