.packageName <- "gclus"
#Given an nxp matrix m and a function f,
# returns the pxp matrix got by applying f  to all pairs of columns of  m.

colpairs <- function(m,f,diag=0,na.omit=FALSE,...){
    flocal <- function(i,j) 
       if (!is.null(diag) && (i == j))
           diag
        else {
	   x <- m[,i]
	   y <- m[,j]
	   if (na.omit) {
              d <- na.omit(cbind(x,y))
	      x <- d[,1]
	      y <- d[,2]}
	   f(x,y,...) }
       
   p <- ncol(m)
   m1 <- matrix(rep(1:p,p),nrow=p,ncol=p)
   ind <- mapply("c",m1,t(m1))
   ans <- apply(ind,2, function(i) flocal(i[1],i[2]))
   ans <- matrix(ans,nrow=p,ncol=p)
   colnames(ans) <- colnames(m)
   rownames(ans) <- colnames(m)
   ans
   }
	

km2 <- function(x,y){
   x <- x - mean(x)
   y <- y - mean(y)
   sum(x*x)+ sum(y*y)
   }

# Computes the sum of all distances between pairs of
# objects whose coordinates are contained in x and y.
gtot <- function(x,y,...)
	2*sum(dist(cbind(x,y),...))


# Computes the average total  distance from one object to all other 
# objects, where x and y contain the object cordinates.

gave <- function(x,y,...)
   2*sum(dist(cbind(x,y),...))/length(x)


# Computes the cluster diameter- the maximum distance between
# objects whose coordinates are contained in x and y.

diameter <- function(x,y,...){
   d <- dist(cbind(x,y),...)
   max(d)
}

# Computes the cluster star distance- the minimum of the total distance from
# one object to another, where x and y contain the object cordinates.

star <- function(x,y,...){
   d <- vec2distm(dist(cbind(x,y),...))
   min(apply(d,2,sum))
   }


# Computes the silhouette distance of a partition of the objects in
# x and y, where group contains the object memberships.

sil <- function(x,y,groups,...){
   require(cluster)
   igroups <- unclass(factor(groups))
   d <- dist(cbind(x,y),...)
   s <- silhouette(igroups,d)
   summary(s)$avg.width
}

# Computes the agglomerative coefficient, from agnes.

ac <- function(x,y,...){
   require(cluster)
   ag <- agnes(cbind(x,y),keep.diss=FALSE,keep.data=FALSE,...)
   ag$ac
}

# Computes the total line length in a parallel coordinate plot
# of x and y.
pclen <- function(x,y) sum(abs(y-x))

# Computes the average (per object) line length in a parallel coordinate plot
# where each x object is connected to all y objects.
pcglen <- function(x,y)
   sum(outer(x,y,function(a,b) abs(a-b)))/length(x)
	

# Applies the function gfun  to each group of x and y values
# and combines the results using the function cfun.
#(...) arguments are passed to gfun.

partition.crit <- function(x,y,groups,gfun= gave,cfun=sum,...){
   dgroups <- unique(groups)
   gm <- sapply(dgroups,function(g) gfun(x[groups==g],y[groups==g],...))
   cfun(gm)
}





														
lower2upper.tri.inds <-
#copied from lower.to.upper.tri.inds from cluster library
function (n) 
{
    n1 <- as.integer(n - 1)
    if (n1 < 1) 
        stop("`n' must be >= 2")
    else if (n1 == 1) 
        1:1
    else rep(1:n1, 1:n1) + c(0, unlist(lapply(2:n1, function(k) cumsum(c(0, 
        (n - 2):(n - k))))))
}

vec2distm <- function(vec){
    #convert from a vector to a distance matrix
    m <- length(vec)
    n <- (1+sqrt(1+8*m))/2
    ans<- matrix(0,n,n)
    ans[lower.tri(ans)] <- vec
    ans[upper.tri(ans)] <- vec[lower2upper.tri.inds(n)]
    ans
}



vec2dist <- function(vec){
#convert from a vector to a "dis"
     as.dist(vec2distm(vec))
}

# Returns a vector of off-diagonal elements in m.
# The off parameter specifies the distance above the main (0) diagonal.

diag.off <- function(m,off=1)
	m[col(m)==row(m)+off]

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

# Accepts a dissimilarity matrix or "dist" m, and
# returns a  matrix of colors.
# M values are cut into categories using breaks (ranked distances if 
# byrank is true) and categories  are assigned the values in colors.

default.dmat.color <- c("#FDFFDA", "#D2F4F2", "#F4BBDD")

dmat.color <-
function(m, colors = default.dmat.color,byrank=NULL, breaks=length(colors) ){ 
   if (is.matrix(m)) m <- as.dist(m)
   if (is.null(byrank))
   byrank <- length(breaks) == 1
   if (byrank ==TRUE)
       m1 <- rank(as.vector(m))
   else
       m1 <- as.vector(m)
   fac <- cut(m1,breaks,include.lowest=TRUE)
   ans <- colors[as.numeric(fac)]
   ans <- vec2distm(ans)
   diag(ans) <- NA
   attr(ans,"Levels") <- levels(fac)
   if (length(labels(m)) == nrow(ans)){
       rownames(ans) <- labels(m)
       colnames(ans) <- labels(m)}
   ans
	   
}


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

# Extracts information from a matrix of colors suitable for use by
# image.
# 
imageinfo <- function(cmat) {
    n <- nrow(cmat)    
    p <- ncol(cmat) 
    levels <- sort(unique(as.vector(cmat)))
    z <- unclass(factor(cmat,levels= levels, labels=1:length(levels)))
    z <- matrix(z,nrow=n,p)
    list(x=1:p,y=1:n, z =t(z),col=levels)
}
 

# This draws the color matrix cmat.


plotcolors <- function(cmat,  na.color="white", dlabels = NULL, rlabels = FALSE, clabels = FALSE, 
    ptype ="image", border.color = "grey70", pch=15,cex=3,label.cex = .6,...) {
        
    n <- nrow(cmat)    
    p <- ncol(cmat) 
    cmat[is.na(cmat)] <- na.color
    if (ptype=="image") {
	info <- imageinfo(cmat)
	image(info$x, info$y, info$z[, n:1], col = info$col, 
	    axes = FALSE, xlab = "", ylab = "", ...)}
    else {
	y <- rep(n:1,p)
	x <- rep(1:p,rep(n,p)) 
	cmat <- as.vector(cmat)
	plot(x,y,col=cmat,cex=cex,pch=pch,axes=FALSE,xlab="",ylab="",
	    xlim=c(.5,p+.5),ylim=c(.5,n+.5),...)
	
    }
    axis(3, at = 1:p, tick=FALSE,labels = clabels, 
	las = 2, cex.axis = label.cex)
    axis(2, at = n:1, tick=FALSE,labels = rlabels, 
	las = 2, cex.axis =label.cex)
    if (is.vector(dlabels)){
	nl <- length(dlabels)
	text(1:nl,nl:1,dlabels,cex=label.cex)}
    box(col = border.color)
}

    




#-----------------------------------------------------------
# This function draws a scatterplot matrix of data.
# Order, if present, specifies the order of the variables and
# panel.colors, if present should be a matrix of panel colors.
# (...) are graphical parameters.

cpairs <-
function(data,order=NULL,panel.colors=NULL,border.color="grey70",show.points=TRUE,...) {
    textPanelbg <- function(x = 0.5, y = 0.5, txt, cex, font) {
	box(col= border.color)
	text(x, y, txt, cex = cex, font = font)
    }
    
    if (!is.null(order)) {
	data <- data[,order]
	if (!(is.null(panel.colors)))
	   panel.colors <- panel.colors[order,order]}
    
    if (!is.null(panel.colors)) {
	if (ncol(data) != nrow(panel.colors) || ncol(data) != ncol(panel.colors))
	   stop("dimensions do not match")	
	diag(panel.colors) <- NA
	panel.colors <- t(panel.colors)[!is.na(panel.colors)]}
    
    env<- new.env()
    assign("j",1,envir=env) 
    pairs.default(data,...,text.panel = textPanelbg,
	panel = function(x,y,...){
	    j <- get("j",envir=env)
	    reg <- par("usr")
	    if (!(is.null(panel.colors)))
	       rect(reg[1],reg[3],reg[2],reg[4],col=panel.colors[j])
	    box(col=border.color)
	    j <- j+1 
	    assign("j",j,envir=env)
	    if (show.points == TRUE) points(x,y,...)	
	})
    
}




# This function draws a parallel coordinate plot  of the data.
# Order, if present, specifies the order of the variables and
# panel.colors, if present should either be a vector of panel colors,
# or a matrix whose i,j the element gives the color for the panel
# showing columns i and j of data. (...) are graphical parameters.
# This function is adapted from parcoord(MASS).


cparcoord <-
function (data, order=NULL,panel.colors=NULL,col=1,lty=1,horizontal=FALSE,mar=NULL,...) {
    if (is.null(mar))
       if (horizontal==TRUE)
          mar <- c(5, 2, 2, 2) + 0.1
        else mar <- c(2, 8, 2, 2) + 0.1
    if (!is.null(order)) {
	data <- data[,order]
	if (is.matrix(panel.colors))
	   panel.colors <- panel.colors[order,order]}
    
    if (is.matrix(panel.colors))
        panel.colors <- diag.off(panel.colors)
      
    if (is.vector(panel.colors))
       if (ncol(data) -1 != length(panel.colors))
          stop("dimensions do not match")
      
    oldpar <- par(mar=mar)
    x <- apply(data, 2, function(x) (x - min(x))/(max(x) - min(x)))
    p <- ncol(x)
    if (horizontal==TRUE){
	matplot(1:p, t(x), 
	    xlab = "", ylab = "", axes = FALSE, type="n",...)
	axis(1, at = 1:p, labels = colnames(x))
	if (!(is.null(panel.colors)))
	for (i in 1:(p-1)) rect(i,0,i+1,1,  lty=0,col =panel.colors[i])
	for (i in 1:p) lines(c(i, i), c(0, 1), col = "grey70")
	matpoints(1:p, t(x), type = "l",col=col,lty = lty,...)  
    }
    else {  
	matplot(t(x), p:1, 
	    xlab = "", ylab = "", axes = FALSE, type="n",...)
	axis(2, at = p:1, labels = colnames(x),las=2)
	if (!(is.null(panel.colors)))
	for (i in 1:(p-1)) rect(0,i,1,i+1,  lty=0,col =panel.colors[p-i])
	for (i in 1:p) lines(c(0, 1),c(i, i), col = "grey70")
	matpoints(t(x), p:1, type = "l",col=col,lty = lty,...)  
    }
    on.exit(par(oldpar))
    invisible()
}



# This function accepts a "dist" or matrix of scores and
# returns an ordering, based on hierarchical clustering.
# If reorder is FALSE, the order returned by hclust is used, 
# otherwise clusters are ordered by placing the nearest end points
# adjacent to each other at a merge.
 
order.hclust <- 
function(merit,reorder=TRUE,...) {
    dis <- - merit
    if (is.matrix(dis)) 
    disd <- as.dist(dis)
    else {
	disd <- dis
	dis <- as.matrix(dis)}
    n <- nrow(dis)
    if (n <= 2)
    ord <- 1:n
    else {
	hc <- hclust(disd,...)
	if (reorder)
	hc <- reorder.hclust(hc,dis)
	ord <- hc$order}
    ord }


# This function accepts hc, the results of a hierarchical clustering
# and a "dist" or distance matrix. It returns a hierarchical clustering obtained by placing 
# the nearest end points adjacent to each other at each
#  merge of the hierarchical clustering

reorder.hclust <-
function(x,dis,...) {
    if (! is.matrix(dis)) dis <- as.matrix(dis)
    merges <- x$merge
    n <- nrow(merges)
    endpoints <- matrix(0,n,2)
    dir <- matrix(1,n,2)
    for (i in 1:n) {
	j <- merges[i,1]
	k <- merges[i,2]
	if ((j < 0) && (k < 0)) {
	    endpoints[i,1] <- -j
	    endpoints[i,2] <- -k}
	else if (j < 0) {
	    j <- -j
	    endpoints[i,1] <- j
	    if (dis[j,endpoints[k,1]] < dis[j,endpoints[k,2]])        
	    endpoints[i,2] <- endpoints[k,2]
	    else {
		endpoints[i,2] <- endpoints[k,1]
		dir[i,2] <- -1}}
	else if (k < 0) {
	    k <- -k
	    endpoints[i,2] <- k     
	    if (dis[k,endpoints[j,1]] < dis[k,endpoints[j,2]]){
		endpoints[i,1] <- endpoints[j,2]
		dir[i,1] <- -1 }
	    else {
		endpoints[i,1] <- endpoints[j,1]
	    }}
	else {
	    d11 <- dis[endpoints[j,1],endpoints[k,1]]
	    d12 <- dis[endpoints[j,1],endpoints[k,2]]
	    d21 <- dis[endpoints[j,2],endpoints[k,1]]
	    d22 <- dis[endpoints[j,2],endpoints[k,2]]
	    dmin <- min(d11,d12,d21,d22)
	    if (dmin == d21) {
		endpoints[i,1] <- endpoints[j,1]
		endpoints[i,2] <- endpoints[k,2]
	    }
	    
	    else if (dmin == d11) {
		endpoints[i,1] <- endpoints[j,2]
		endpoints[i,2] <- endpoints[k,2]
		dir[i,1] <- -1
	    }
	    else if (dmin == d12) {
		endpoints[i,1] <- endpoints[j,2]
		endpoints[i,2] <- endpoints[k,1]
		dir[i,1] <- -1
		dir[i,2] <- -1
	    }
	    else  {
		endpoints[i,1] <- endpoints[j,1]
		endpoints[i,2] <- endpoints[k,1]
		dir[i,2] <- -1}}
    }
    for (i in n:2) {
	if (dir[i,1] == -1) {
	    m <- merges[i,1]
	    if (m > 0) {
		m1 <- merges[m,1]
		merges[m,1] <- merges[m,2]
		merges[m,2] <- m1
		if (dir[m,1] == dir[m,2]) 
		dir[m,] <- -dir[m,] 
	    }}
	if (dir[i,2] == -1) {
	    m <- merges[i,2]
	    if (m > 0) {
		m1 <- merges[m,1]
		merges[m,1] <- merges[m,2]
		merges[m,2] <- m1
		if (dir[m,1] == dir[m,2]) 
		dir[m,] <- -dir[m,] 
	    }}	      
	
    }
    
    clusters <- as.list(1:n)
    for (i in 1:n) {
	j <- merges[i,1]
	k <- merges[i,2]
	if ((j < 0) && (k < 0)) 
	clusters[[i]] <- c(-j,-k)
	else if (j < 0)
	clusters[[i]] <- c(-j,clusters[[k]])
	else if (k < 0)
	clusters[[i]] <- c(clusters[[j]],-k)
	else clusters[[i]] <- c(clusters[[j]], clusters[[k]])}
    
    x1 <- x
    x1$merge <- merges
    x1$order <- clusters[[n]]
    x1
    
    
}

# Given a list whose ith element contains the indices
# of objects in the ith cluster, returns a vector whose ith 
# element gives the cluster number of the ith object.

clus2memship <- 
function(clusters) {
    ans <- 1:length(unlist(clusters))
    i <- 1
    for (cl in clusters) {
	ans[cl] <- i
	i <- i+1
    }
    ans    
}



# Given a vector whose ith elements gives the cluster number of the
# ith object, returns a list whose ith element contains the indices
# of objects in the ith cluster
memship2clus <-
function(memship) {
    m <- sort(unique(memship))
    index <- seq(along=memship)
    sapply(m, function(g) index[memship==g],simplify=FALSE)
}
    

# This function accepts a "dist" or matrix of  scores and
# returns an approximate Robinson ordering, used for scatterplot matrices.
# 
order.single <-
function(merit,clusters=NULL) {
    if (is.null(clusters))
    order.hclust(merit, TRUE,method = "single")
    else {
	dis <- - merit
	if (is.matrix(dis)) {
	    dism <- dis
	    dis <- as.dist(dis) } 
	else 
	dism <- as.matrix(dis)
	n <- nrow(dism)
	
	if (n <= 2)
	clus <- 1:n
	else {
	    cind <- col(matrix(0,n,n))
	    cind <- cind[lower.tri(cind)]
	    rind <- row(matrix(0,n,n))
	    rind <- rind[lower.tri(rind)]
	    d <- cbind(as.vector(dis),rind,cind)
	    d <- d[sort.list(d[,1],),]
	    
	    if (is.null(clusters)) {
		memship <- 1:n
		clusters <- as.list(1:n)}
		else memship <- clus2memship(clusters)		
		
		m <- length(dis)
		for (i in 1:m) {
		    j <- memship[d[i,2]]
		    k <- memship[d[i,3]]
		    if (j!= k) {
			if (j > k) {
			    r <- j
			    j <- k
			    k <- r}
			memship[memship==k] <- j
			clusj <- clusters[[j]]
			clusk <- clusters[[k]]
			dll <- dism[clusj[1], clusk[1]]
			dlr <- dism[clusj[1], clusk[length(clusk)]] 
			drl <- dism[clusj[length(clusj)], clusk[1]] 
			drr <- dism[clusj[length(clusj)], clusk[length(clusk)]] 	
			mind <- min(dll,dlr,drl,drr)
			if (drl==mind)
			NULL
			else if (dlr==mind) {
			    clusj <-rev(clusj)
			    clusk <- rev(clusk)}
			else if (dll ==mind)
			clusj <- rev(clusj)
			else clusk <- rev(clusk)
			clusters[[j]] <- c(clusj,clusk)
		    }
		    if (length(clusters[[1]]) == n) break
		}
		clus <- clusters[[1]]}
	     clus}}
    

    
	

# This function accepts a "dist" or matrix of scores and
# returns an improved ordering, for parallel coordinate displays.

order.endlink <-
function(merit,clusters=NULL) {
    dis <- - merit
    if (is.matrix(dis)) {
	dism <- dis
	dis <- as.dist(dis) } 
    else {
	dism <- as.matrix(dis)}
    n <- nrow(dism)
    if (n <= 2)
    clus <- 1:n
    else {
	cind <- col(matrix(0,n,n))
	cind <- cind[lower.tri(cind)]
	rind <- row(matrix(0,n,n))
	rind <- rind[lower.tri(rind)]
	d <- cbind(as.vector(dis),rind,cind)
	d <- d[sort.list(d[,1],),]
	if (is.null(clusters)) {
	    memship <- 1:n
	    clusters <- as.list(1:n)}
	else memship <- clus2memship(clusters)
	m <- n*(n-1)/2
	for (i in 1:m) {
	    j <- memship[d[i,2]]
	    k <- memship[d[i,3]]
	    if (!(j == k || j == -1 || k == -1)) {
		if (j > k) {
		    r <- j
		    j <- k
		    k <- r
		}
		clusj <- clusters[[j]]
		clusk <- clusters[[k]]
		dll <- dism[clusj[1], clusk[1]]
		dlr <- dism[clusj[1], clusk[length(clusk)]] 
		drl <- dism[clusj[length(clusj)], clusk[1]] 
		drr <- dism[clusj[length(clusj)], clusk[length(clusk)]] 	
		
		mind <- min(dll,dlr,drl,drr)
		if (drl==mind)
		NULL
		else if (dlr==mind) {
		    clusj <-rev(clusj)
		    clusk <- rev(clusk)}
		else if (dll ==mind)
		clusj <- rev(clusj)
		else clusk <- rev(clusk)
		clusters[[j]] <- c(clusj,clusk)
		if (! (length(clusj) == 1))
		memship[clusj[length(clusj)]] <- -1
		if (! (length(clusk) == 1))
		memship[clusk[1]] <- -1
		memship[clusk[length(clusk)]] <- j
	    }
	    if (length(clusters[[1]]) == n) break
	}
	clus<- clusters[[1]]
    }
    
    clus
}



# This function takes a merit measure and clusters, either a vector
# giving the cluster number of the ith items, or a list whose ith element
# gives the indices of the elements in the ith cluster.
# Objects within a cluster are ordered with within.order
# and clusters are ordered with between.order.
# 
order.clusters <- function(merit,clusters,within.order = order.single, 
    between.order= order.single,...) {
    if (!is.list(clusters))
    clusters <- memship2clus(clusters)
    if (!is.matrix(merit)) 
    merit <- as.matrix(merit) 
    if (!is.null(within.order)) {
	clusl <- lapply(clusters, function(g)
	    within.order(merit[g,g],...))
	newclusl <- lapply(1:length(clusters),function(i) clusters[[i]][clusl[[i]]])
    }
    else newclusl <- clusters
    if (!is.null(between.order))
    between.order(merit,newclusl)
    else unlist(newclusl)
    
}




