agnes <- function(x, diss = FALSE, metric = "euclidean",
                  stand = FALSE, method = "average")
{
    meanabsdev <- function(y)
    {
        mean(abs(y - mean(y, na.rm = TRUE)), na.rm = TRUE)
    }
    size <- function(d)
    {
        discr <- 1 + 8 * length(d)
        sqrtdiscr <- round(sqrt(discr))
        if(round(sqrtdiscr)^2 != discr)
            return(0)
        (1 + sqrtdiscr)/2
    }
    lower.to.upper.tri.inds <- function(n)
    {
        return(c(0, unlist(lapply(2:(n - 1), function(x, n)
                                  cumsum(c(0, (n - 2):(n - x))), n = n))) +
               rep(1:(n - 1), 1:(n - 1)))
    }
    upper.to.lower.tri.inds <- function(n)
    {
        return(unlist(lapply(0:(n - 2), function(x, n)
                             cumsum(x:(n - 2)), n = n)) +
               rep(1 + cumsum(0:(n - 2)), (n - 1):1))
    }
    if(diss) {
        ## check type of input vector
        if(is.na(min(x)))
            stop("NA-values in the dissimilarity matrix not allowed." )
        if(data.class(x) != "dissimilarity") {
            if(!is.numeric(x) || size(x) == 0)
                stop("x is not of class dissimilarity and can not be converted to this class." )
            ##convert input vector to class "dissimilarity"
            class(x) <- "dissimilarity"
            attr(x, "Size") <- size(x)
            attr(x, "Metric") <- "unspecified"
        }
        n <- attr(x, "Size")
        dv <- x[lower.to.upper.tri.inds(n)]	
        ##prepare arguments for the Fortran call
        dv <- c(0, dv)
        jp <- 1
        valmd <- double(1)
        jtmd <- integer(1)
        ndyst <- 0
        x2 <- double(n)
        jdyss <- 1
        dv2 <- double(1 + (n * (n - 1))/2)
    }
    else {
        ##check type of input matrix
        if((!is.data.frame(x) && !is.numeric(x)) ||
           (!all(sapply(x, data.class) == "numeric")))
            stop("x is not a numeric dataframe or matrix.")
        x <- data.matrix(x)             #standardize, if necessary
        x2 <- if(stand) scale(x, scale = apply(x, 2, meanabsdev)) else x
        ndyst <- if(metric == "manhattan") 2 else 1
        n <- nrow(x2)
        jp <- ncol(x2)
        jtmd <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
        valmisdat <- min(x2, na.rm = TRUE) - 0.5
        x2[is.na(x2)] <- valmisdat
        valmd <- rep(valmisdat, jp)
        jdyss <- 0
        dv <- double(1 + (n * (n - 1))/2)
        dv2 <- double(1 + (n * (n - 1))/2)
    }
    meth <- 1
    if(method == "single")
        meth <- 2
    if(method == "complete")
        meth <- 3
    if(method == "ward")
        meth <- 4
    if(method == "weighted")
        meth <- 5
    jalg <- 1                           #call Fortran routine
    storage.mode(dv) <- "double"
    storage.mode(dv2) <- "double"
    storage.mode(x2) <- "double"
    storage.mode(valmd) <- "double"
    storage.mode(jtmd) <- "integer"
    merge <- matrix(0, n - 1, 2)
    storage.mode(merge) <- "integer"
    res <- .Fortran("twins",
                    as.integer(n),
                    as.integer(jp),
                    x2,
                    dv,
                    dis = dv2,
                    ok = as.integer(jdyss),
                    valmd,
                    jtmd,
                    as.integer(ndyst),
                    as.integer(jalg),
                    as.integer(meth),
                    integer(n),
                    ner = integer(n),
                    ban = double(n),
                    ac = as.double(0),
                    merge = merge,
                    PACKAGE = "cluster")
    if(!diss) {
        ##give warning if some dissimilarities are missing.
        if(res$ok == -1)
            stop("No clustering performed, NA-values in the dissimilarity matrix.\n" )
        ## adapt Fortran output to S:
        ##convert lower matrix, read by rows, to upper matrix, read by rows.
        disv <- res$dis[-1]
        disv[disv == -1] <- NA
        disv <- disv[upper.to.lower.tri.inds(n)]
        class(disv) <- "dissimilarity"
        attr(disv, "Size") <- nrow(x)
        attr(disv, "Metric") <- metric
        attr(disv, "Labels") <- dimnames(x)[[1]]	
        ##add labels to Fortran output
        if(length(dimnames(x)[[1]]) != 0)
            order.lab <- dimnames(x)[[1]][res$ner]
    }
    else {
        disv <- x	
        ##add labels to Fortran output
        if(length(attr(x, "Labels")) != 0)
            order.lab <- attr(x, "Labels")[res$ner]
    }
    clustering <- list(order = res$ner, height = res$ban[-1], ac = res$ac, 
                       merge = res$merge, diss = disv)
    if(exists("order.lab"))
        clustering$order.lab <- order.lab
    if(!diss) {
        x2[x2 == valmisdat] <- NA
        clustering$data <- x2
    }
    class(clustering) <- c("agnes", "twins")
    attr(clustering, "Call") <- sys.call()
    clustering
}

summary.agnes <- function(x, ...)
{
    object <- x
    class(object) <- "summary.agnes"
    object
}

print.agnes <- function(x, ...)
{
    cat("Merge:\n")
    print(x$merge, ...)
    cat("Order of objects:\n")
    print(if(length(x$order.lab) != 0) x$order.lab else x$order,
          quote = FALSE, ...)
    cat("Height:\n")
    print(x$height, ...)
    cat("Agglomerative coefficient:\n")
    print(x$ac, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

print.summary.agnes <- function(x, ...)
{
    cat("Merge:\n")
    print(x$merge, ...)
    cat("Order of objects:\n")
    print(if(length(x$order.lab) != 0) x$order.lab else x$order,
          quote = FALSE, ...)
    cat("Height:\n")
    print(x$height, ...)
    cat("Agglomerative coefficient:\n")
    print(x$ac, ...)
    cat("\n")
    ## only extra  compared to print.agnes:
    print(x$diss, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

#### CLARA := Clustering LARge Applications
####
#### Note that the algorithm is O(n), but O(ns^2) where ns == sampsize

### FIXME :
##  should not necessarily keep data in result, because "large" !
##  OTOH, data is used for clusplot.partition() 

## Note:  ./plotpart.q	is also working with clara() objects 


clara <- function(x, k, metric = "euclidean", stand = FALSE,
		  samples = 5, sampsize = 40 + 2 * k)
{
    meanabsdev <- function(y)
	mean(abs(y - mean(y, na.rm = TRUE)), na.rm = TRUE)
    upper.to.lower.tri.inds <- function(n)
    {
	return(unlist(lapply(0:(n - 2), function(x, n)
			     cumsum(x:(n - 2)), n = n)) +
	       rep(1 + cumsum(0:(n - 2)), (n - 1):1))
    }
    ## check type of input matrix and values of input numbers
    if((!is.data.frame(x) && !is.numeric(x)) ||
       (!all(sapply(x, data.class) == "numeric")))
	stop(message = "x is not a numeric dataframe or matrix.")
    x <- data.matrix(x)
    n <- nrow(x)
    if((k <- as.integer(k)) < 1 || k > n - 1)
	stop("The number of cluster should be at least 1 and at most n-1." )
    if((sampsize <- as.integer(sampsize)) < k)
	stop(paste(c("'sampsize' should be at least", k,
		     "(number of clusters)"), collapse = " "))
    if(n < sampsize)
	stop(paste(c("Number of objects is", n,
		     ", should be at least", sampsize, "(sampsize)"),
		   collapse = " "))
    namx <- dimnames(x)[[1]]
    ## standardize, if necessary
    x2 <- if(stand) scale(x, scale = apply(x, 2, meanabsdev)) else x
    ## put info about metric, size and NAs in arguments for the Fortran call
    jp <- ncol(x2)
    jtmd  <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
    mdata <- is.na(min(x2))

    ## FIXME: The following will go wrong as soon as  min(x2) < -5e15
    valmisdat <- min(x2, na.rm = TRUE) - 0.5
    x2[is.na(x2)] <- valmisdat

    x3 <- as.double(as.vector(t(x2)))# transposing LARGE x ..not efficient ....
    ## call Fortran routine
    res <- .Fortran("clara",
		    as.integer(n),
		    as.integer(jp),
		    as.integer(k),
		    clu = x3,# transpose (x [n * jp] )
		    nran  = as.integer(samples),
		    nsam  = sampsize,
		    dis	  = double(1 + (sampsize * (sampsize - 1))/2),
		    mdata = as.integer(mdata),
		    valmd = rep(as.double(valmisdat), jp),
		    jtmd  = as.integer(jtmd),
		    ndyst = as.integer(if(metric == "manhattan") 2 else 1),
		    integer(sampsize),
		    integer(sampsize),
		    sample = integer(sampsize),# = nbest
		    integer(k),
		    med = integer(k),# = nrx
		    double(k),
		    double(k),
		    double(k),
		    avdis  = double(k),# = ttbes
		    maxdis = double(k),# = rdbes
		    ratdis = double(k),# = rabes
		    size  = integer(k),# = mtt
		    obj	  = double(1),
		    avsil = double(k),
		    ttsil = double(1),
		    silinf = matrix(0, sampsize, 4),
		    jstop = as.integer(0),
		    double(sampsize),
		    double(sampsize),
		    double(sampsize),
		    integer(sampsize),
		    integer(sampsize),
		    integer(sampsize),
		    integer(sampsize),
		    integer(sampsize),
		    integer(sampsize),
		    PACKAGE = "cluster")	
    ## give a warning when errors occured
    if(res$jstop == 1)
	stop("For each sample at least one object was found which could not be assigned to a cluster (because of missing values).")
    if(res$jstop == 2)
	stop("Each of the random samples contains objects between which no distance can be computed.")
    sildim <- res$silinf[, 4]	
    ## adapt Fortran output to S:
    ## convert lower matrix, read by rows, to upper matrix, read by rows.
    disv <- res$dis[-1]
    disv[disv == -1] <- NA
    disv <- disv[upper.to.lower.tri.inds(sampsize)]
    class(disv) <- "dissimilarity"
    attr(disv, "Size") <- sampsize
    attr(disv, "Metric") <- metric	
    attr(disv, "Labels") <- namx[res$sample]
    ## add labels to Fortran output
    res$med <- x[res$med, ]
    res$clu <- matrix(res$clu, nrow = n, ncol = jp, byrow = TRUE)[, 1]
    if(length(namx) != 0) {
	sildim <- namx[sildim]
	res$sample <- namx[res$sample]
	names(res$clu) <- namx
    }
    ## add dimnames to Fortran output
    clusinf <- cbind(size = res$size, "max_diss" = res$maxdis,
		     "av_diss" = res$avdis, isolation = res$ratdis)
    if(k != 1) {
	dimnames(res$silinf) <- list(sildim,
				     c("cluster", "neighbor", "sil_width", ""))
	clustering <- list(sample = res$sample, medoids = res$med, 
			   clustering = res$clu, objective = res$obj,
			   clusinfo = clusinf,
			   silinfo = list(width = res$silinf[, -4], 
			   clus.avg.widths = res$avsil[1:k],
			   avg.width = res$ttsil),
			   diss = disv)
    }
    else {
	clustering <- list(sample = res$sample, medoids = res$med, 
			   clustering = res$clu, objective = res$obj,
			   clusinfo = clusinf, diss = disv)
    }
    x2[x2 == valmisdat] <- NA
    clustering$data <- x2
    class(clustering) <- c("clara", "partition")
    attr(clustering, "Call") <- sys.call()
    clustering
}

print.clara <- function(x, ...)
{
    cat("Best sample:\n");		print(x$sample, quote = FALSE, ...)
    cat("Medoids:\n");			print(x$medoids, ...)
    cat("Clustering vector:\n");	print(x$clustering, ...)
    cat("Objective function:\n");	print(x$objective, ...)
    cat("\nAvailable components:\n");	print(names(x), ...)
    invisible(x)
}

summary.clara <- function(x, ...)
{
    class(x) <- "summary.clara"
    x
}

print.summary.clara <- function(x, ...)
{
    cat("Best sample:\n");		print(x$sample, quote = FALSE, ...)
    cat("Medoids:\n");			print(x$medoids, ...)
    cat("Clustering vector:\n");	print(x$clustering, ...)
    cat("Objective function:\n");	print(x$objective, ...)
    cat("\nNumerical information per cluster:\n")
    print(x$clusinfo, ...)
    if(length(x$silinfo) != 0) {
	cat("\nSilhouette plot information for best sample:\n")
	print(x$silinfo[[1]], ...)
	cat("Average silhouette width per cluster:\n")
	print(x$silinfo[[2]], ...)
	cat("Average silhouette width of best sample:\n")
	print(x$silinfo[[3]], ...)
    }
    cat("\n")
    print(x$diss, ...)
    cat("\nAvailable components:\n");	print(names(x), ...)
    invisible(x)
}

daisy <-
function(x, metric = c("euclidean","manhattan"), stand = FALSE, type = list())
{
    ## check type of input matrix
    if(!is.data.frame(x) && !is.numeric(x))
        stop("x is not a dataframe or a numeric matrix.")
    if(!is.null(tA <- type$asymm) &&
       !all(sapply(lapply(as.data.frame(x[,tA]),
                          function(y) levels(as.factor(y))), length) == 2))
        stop("asymmetric binary variable has more than 2 levels.")
    ## transform variables and construct `type' vector
    type2 <- sapply(x, data.class)
    x <- data.matrix(x)
    n <- nrow(x)
    if(length(type) > 0) {
        if(!is.list(type)) stop("invalid `type'; must be named list")
        tT <- type$ ordratio
        tL <- type$ logratio
        x[, names(type2[tT])] <- codes(as.ordered(x[, names(type2[tT])]))
        x[, names(type2[tL])] <- log10(           x[, names(type2[tL])])
        type2[type$asymm] <- "A"
        type2[tT] 	  <- "T" # was "O" (till 2000-12-14) accidentally !
    }
    type2[type2 == "numeric"] <- "I"
    type2[type2 == "ordered"] <- "O"
    type2[type2 == "factor"] <- "N"
    ## standardize, if necessary
    if(all(type2 == "I")) {
        if(stand)
            x <- scale(x, scale = apply(x, 2,
                          function(y)
                          mean(abs(y - mean(y, na.rm = TRUE)), na.rm = TRUE)))
        jdat <- 2
        metric <- match.arg(metric)
        ndyst <- if(metric == "manhattan") 2 else 1
    }
    else { ## mixed case
        if(!missing(metric))
            warning("`metric' is not used with mixed variables")
        colmin   <- apply(x, 2, min, na.rm = TRUE)
        colrange <- apply(x, 2, max, na.rm = TRUE) - colmin
        x <- scale(x, center = colmin, scale = colrange)
        jdat <- 1
        ndyst <- 0
    }
    ## 	type2 <- paste(type2, collapse = "")
    ## put info about NAs in arguments for the Fortran call
    jtmd <- ifelse(is.na(rep(1, n) %*% x), -1, 1)
    valmisdat <- min(x, na.rm = TRUE) - 0.5
    x[is.na(x)] <- valmisdat
    valmd <- rep(valmisdat, ncol(x))
    ## call Fortran routine
    storage.mode(x) <- "double"
    storage.mode(valmd) <- "double"
    storage.mode(jtmd) <- "integer"
    type3 <- as.integer(match(type2, c('A','S','N','O','I','T')))
    res <- .Fortran("daisy",
                    as.integer(n),
                    as.integer(ncol(x)),
                    x,
                    valmd,
                    jtmd,
                    as.integer(jdat),
                    type3,
                    as.integer(ndyst),
                    dis = double(1 + (n * (n - 1))/2),
                    PACKAGE = "cluster")
    ## adapt Fortran output to S:
    ## convert lower matrix, read by rows, to upper matrix, read by rows.
    disv <- res$dis[-1]
    disv[disv == -1] <- NA
    full <- matrix(0, n, n)
    full[!lower.tri(full, diag = TRUE)] <- disv
    disv <- t(full)[lower.tri(full)]
    ## give warning if some dissimilarities are missimg
    if(is.na(min(disv))) attr(disv, "NA.message") <-
        "NA-values in the dissimilarity matrix !"
    ## construct S object -- "dist" methods are *there* !
    class(disv) <- c("dissimilarity", "dist")
    attr(disv, "Labels") <- dimnames(x)[[1]]
    attr(disv, "Size") <- n
    attr(disv, "Metric") <- ifelse(ndyst == 0, "mixed", metric)
    disv
}

print.dissimilarity <- function(x, ...)
{
    cat("Dissimilarities :\n")
    print(as.vector(x), ...)
    cat("\n")
    if(!is.null(attr(x, "na.message")))
        cat("Warning : ", attr(x, "NA.message"), "\n")
    cat("Metric : ", attr(x, "Metric"), "\n")
    cat("Number of objects : ", attr(x, "Size"), "\n")
    invisible(x)
}

summary.dissimilarity <- function(x, ...)
{
    cat(length(x), "dissimilarities, summarized :\n")
    print(sx <- summary(as.vector(x), ...))
    cat("\n")
    if(!is.null(attr(x, "na.message")))
        cat("Warning : ", attr(x, "NA.message"), "\n")
    cat("Metric : ", attr(x, "Metric"), "\n",
        "Number of objects : ", attr(x, "Size"), "\n", sep="")
    invisible(sx)
}
diana <- function(x, diss = FALSE, metric = "euclidean", stand = FALSE)
{
    meanabsdev <- function(y)
    {
	mean(abs(y - mean(y, na.rm = TRUE)), na.rm = TRUE)
    }
    size <- function(d)
    {
	discr <- 1 + 8 * length(d)
	sqrtdiscr <- round(sqrt(discr))
	if(round(sqrtdiscr)^2 != discr)
	    return(0)
	(1 + sqrtdiscr)/2
    }
    lower.to.upper.tri.inds <- function(n)
    {
	return(c(0, unlist(lapply(2:(n - 1), function(x, n)
				  cumsum(c(0, (n - 2):(n - x))), n = n))) +
	       rep(1:(n - 1), 1:(n - 1)))
    }
    upper.to.lower.tri.inds <- function(n)
    {
	return(unlist(lapply(0:(n - 2), function(x, n)
			     cumsum(x:(n - 2)), n = n)) +
	       rep(1 + cumsum(0:(n - 2)), (n - 1):1))
    }
    if(diss) {
	##check type of input vector
	if(is.na(min(x)))
	    stop("NA-values in the dissimilarity matrix not allowed.")
	if(data.class(x) != "dissimilarity") {
	    if(!is.numeric(x) || size(x) == 0)
		stop("x is not of class dissimilarity and can not be converted to this class."
		     )
	    ##convert input vector to class "dissimilarity"
	    class(x) <- "dissimilarity"
	    attr(x, "Size") <- size(x)
	    attr(x, "Metric") <- "unspecified"
	}
	n <- attr(x, "Size")
	dv <- x[lower.to.upper.tri.inds(n)]	
	##prepare arguments for the Fortran call
	dv <- c(0, dv)
	jp <- 1
	valmd <- double(1)
	jtmd <- integer(1)
	ndyst <- 0
	x2 <- double(n)
	jdyss <- 1
	dv2 <- double(1 + (n * (n - 1))/2)
    }
    else {
	##check type of input matrix 
	if((!is.data.frame(x) && !is.numeric(x)) ||
	   (!all(sapply(x, data.class) == "numeric")))
	    stop("x is not a numeric dataframe or matrix.")
	x <- data.matrix(x) # standardize, if necessary
	x2 <- if(stand) scale(x, scale = apply(x, 2, meanabsdev)) else x
	ndyst <- if(metric == "manhattan") 2 else 1
	n <- nrow(x2)
	jp <- ncol(x2)
	jtmd <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
	valmisdat <- min(x2, na.rm = TRUE) - 0.5
	x2[is.na(x2)] <- valmisdat
	valmd <- rep(valmisdat, jp)
	jdyss <- 0
	dv <- double(1 + (n * (n - 1))/2)
	dv2 <- double(1 + (n * (n - 1))/2)
    }
    jalg <- 2
    ## call Fortran routine
    storage.mode(dv) <- "double"
    storage.mode(dv2) <- "double"
    storage.mode(x2) <- "double"
    storage.mode(valmd) <- "double"
    storage.mode(jtmd) <- "integer"
    merge <- matrix(0, n - 1, 2)
    storage.mode(merge) <- "integer"
    res <- .Fortran("twins",
		    as.integer(n),
		    as.integer(jp),
		    x2,
		    dv,
		    dis = dv2,
		    ok = as.integer(jdyss),
		    valmd,
		    jtmd,
		    as.integer(ndyst),
		    as.integer(jalg),
		    as.integer(0),
		    integer(n),
		    ner = integer(n),
		    ban = double(n),
		    dc = as.double(0),
		    merge = merge,
		    PACKAGE = "cluster")
    if(!diss) {
	## give warning if some dissimilarities are missing.
	if(res$ok == -1)
	    stop("No clustering performed, NA-values in the dissimilarity matrix.\n"
		 )
	## adapt Fortran output to S:
	## convert lower matrix, read by rows, to upper matrix, read by rows.
	disv <- res$dis[-1]
	disv[disv == -1] <- NA
	disv <- disv[upper.to.lower.tri.inds(n)]
	class(disv) <- "dissimilarity"
	attr(disv, "Size") <- nrow(x)
	attr(disv, "Metric") <- metric
	attr(disv, "Labels") <- dimnames(x)[[1]]	
	##add labels to Fortran output
	if(length(dimnames(x)[[1]]) != 0) {
	    order.lab <- dimnames(x)[[1]][res$ner]
	}
    }
    else {
	disv <- x
	##add labels to Fortran output
	if(length(attr(x, "Labels")) != 0) {
	    order.lab <- attr(x, "Labels")[res$ner]
	}
    }
    clustering <- list(order = res$ner, height = res$ban[-1], dc = res$dc, 
		       merge = res$merge, diss = disv)
    if(exists("order.lab"))
	clustering$order.lab <- order.lab
    if(!diss) {
	x2[x2 == valmisdat] <- NA
	clustering$data <- x2
    }
    class(clustering) <- c("diana", "twins")
    attr(clustering, "Call") <- sys.call()
    clustering
}

print.diana <- function(x, ...)
{
    cat("Merge:\n")
    print(x$merge, ...)
    cat("Order of objects:\n")
    print(if (length(x$order.lab) != 0) x$order.lab else x$order,
	  quote = FALSE, ...)
    cat("Height:\n")
    print(x$height, ...)
    cat("Divisive coefficient:\n")
    print(x$dc, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

summary.diana <- function(x, ...)
{
    object <- x
    class(object) <- "summary.diana"
    object
}

print.summary.diana <- function(x, ...)
{
    cat("Merge:\n")
    print(x$merge, ...)
    cat("Order of objects:\n")
    print(if (length(x$order.lab) != 0) x$order.lab else x$order,
	  quote = FALSE, ...)
    cat("Height:\n")
    print(x$height, ...)
    cat("Divisive coefficient:\n")
    print(x$dc, ...)
    cat("\n")
    print(x$diss, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}
fanny <- function(x, k, diss = FALSE, metric = "euclidean", stand = FALSE)
{
    meanabsdev <- function(y)
    {
	mean(abs(y - mean(y, na.rm = TRUE)), na.rm = TRUE)
    }
    size <- function(d)
    {
	discr <- 1 + 8 * length(d)
	sqrtdiscr <- round(sqrt(discr))
	if(round(sqrtdiscr)^2 != discr)
	    return(0)
	(1 + sqrtdiscr)/2
    }
    if(diss) {
	## check type of input vector
	if(is.na(min(x)))
	    stop("NA-values in the dissimilarity matrix not allowed.")
	if(data.class(x) != "dissimilarity") {
	    if(!is.numeric(x) || size(x) == 0)
		stop("x is not of class dissimilarity and can not be converted to this class." )	
	    ## convert input vector to class "dissimilarity"
	    class(x) <- "dissimilarity"
	    attr(x, "Size") <- size(x)
	    attr(x, "Metric") <- "unspecified"
	}
	## prepare arguments for the Fortran call
	n <- attr(x, "Size")
	if((k < 1) || (k > floor(n/2) - 1))
	    stop("The number of cluster should be at least 1 and at most n/2 - 1." )
	dv <- c(x, 0)
	jp <- 1
	valmd <- double(1)
	jtmd <- integer(1)
	ndyst <- 0
	x2 <- double(n)
	jdyss <- 1
    }
    else {
	##check type of input matrix 
	if((!is.data.frame(x) && !is.numeric(x)) ||
	   (!all(sapply(x, data.class) == "numeric")))
	    stop("x is not a numeric dataframe or matrix.")
	x <- data.matrix(x)	
	## standardize, if necessary
	x2 <- if(stand) scale(x, scale = apply(x, 2, meanabsdev)) else x
	##put info about metric, size and NAs in arguments for the Fortran call
	ndyst <- if(metric == "manhattan") 2 else 1
	n <- nrow(x2)
	if((k < 1) || (k > floor(n/2) - 1))
	    stop("The number of cluster should be at least 1 and at most n/2 - 1."
		 )
	jp <- ncol(x2)
	jtmd <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
	valmisdat <- min(x2, na.rm = TRUE) - 0.5
	x2[is.na(x2)] <- valmisdat
	valmd <- rep(valmisdat, jp)
	jdyss <- 0
	dv <- double(1 + (n * (n - 1))/2)
    }
    ##call Fortran routine
    storage.mode(dv) <- "double"
    storage.mode(x2) <- "double"
    storage.mode(valmd) <- "double"
    storage.mode(jtmd) <- "integer"
    res <- .Fortran("fanny",
		    as.integer(n),
		    as.integer(jp),
		    as.integer(k),
		    x2,
		    dis = dv,
		    ok = as.integer(jdyss),
		    valmd,
		    jtmd,
		    as.integer(ndyst),
		    integer(n),
		    integer(n),
		    integer(n),
		    double(n),
		    p = matrix(0, n, k),
		    matrix(0, n, k),
		    avsil = double(k),
		    integer(k),
		    double(k),
		    double(k),
		    double(n),
		    ttsil = as.double(0),
		    eda = as.double(0),
		    edb = as.double(0),
		    obj = double(2),
		    clu = integer(n),
		    silinf = matrix(0, n, 4),
		    as.double(1e-15),
		    PACKAGE = "cluster")
    sildim <- res$silinf[, 4]
    if(diss) {
	disv <- x	
	##add labels to Fortran output
	if(length(attr(x, "Labels")) != 0) {
	    sildim <- attr(x, "Labels")[sildim]
	    dimnames(res$p) <- list(attr(x, "Labels"), NULL)
	    names(res$clu) <- attr(x, "Labels")
	}
    }
    else {
	##give warning if some dissimilarities are missing.
	if(res$ok == -1)
	    stop("No clustering performed, NA-values in the dissimilarity matrix.")	
	disv <- res$dis[ - (1 + (n * (n - 1))/2)]
	disv[disv == -1] <- NA
	class(disv) <- "dissimilarity"
	attr(disv, "Size") <- nrow(x)
	attr(disv, "Metric") <- metric
	attr(disv, "Labels") <- dimnames(x)[[1]]	
	##add labels to Fortran output
	if(length(dimnames(x)[[1]]) != 0) {
	    sildim <- dimnames(x)[[1]][sildim]
	    dimnames(res$p) <- list(dimnames(x)[[1]], NULL)
	    names(res$clu) <- dimnames(x)[[1]]
	}
    }
    ##add dimnames to Fortran output
    names(res$obj) <- c("iterations", "objective")
    res$coeff <- c(res$eda, res$edb)
    names(res$coeff) <- c("dunn_coeff", "normalized")
    if(k != 1) {
	dimnames(res$silinf) <- list(sildim,
				     c("cluster", "neighbor", "sil_width", ""))
	clustering <- list(membership = res$p, coeff = res$coeff, 
			   clustering = res$clu, objective = res$obj,
			   silinfo = 
			   list(widths = res$silinf[, -4],
				clus.avg.widths = res$avsil[1:k],
				avg.width = res$ttsil),
			   diss = disv)
    }
    else {
	clustering <- list(membership = res$p, coeff = res$coeff, 
			   clustering = res$clu, objective = res$obj,
			   diss = disv)
    }
    if(!diss) {
	x2[x2 == valmisdat] <- NA
	clustering$data <- x2
    }
    class(clustering) <- c("fanny", "partition")
    attr(clustering, "Call") <- sys.call()
    clustering
}

print.fanny <- function(x, ...)
{
    print(x$objective, ...)
    cat("Membership coefficients:\n")
    print(x$membership, ...)
    cat("Coefficients:\n")
    print(x$coeff, ...)
    cat("Closest hard clustering:\n")
    print(x$clustering, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

summary.fanny <- function(x, ...)
{
    object <- x
    class(object) <- "summary.fanny"
    object
}

print.summary.fanny <- function(x, ...)
{
    print(x$objective, ...)
    cat("Membership coefficients:\n")
    print(x$membership, ...)
    cat("Coefficients:\n")
    print(x$coeff, ...)
    cat("Closest hard clustering:\n")
    print(x$clustering, ...)
    if(length(x$silinfo) != 0) {
	cat("\nSilhouette plot information:\n")
	print(x$silinfo[[1]], ...)
	cat("Average silhouette width per cluster:\n")
	print(x$silinfo[[2]], ...)
	cat("Average silhouette width of total data set:\n")
	print(x$silinfo[[3]], ...)
    }
    cat("\n")
    print(x$diss, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

mona <- function(x)
{
    levs <- function(y) levels(as.factor(y))

    ## check type of input matrix
    if(!is.matrix(x) && !is.data.frame(x))
        stop("x must be a matrix or data frame.")
    if(!all(sapply(lapply(as.data.frame(x), levs), length) == 2))
        stop(message = "All variables must be binary (factor with 2 levels).")
    n <- nrow(x)
    jp <- ncol(x)	
    ##change levels of input matrix
    x2 <- apply(as.matrix(x), 2, factor)
    x2[x2 == "1"] <- "0"
    x2[x2 == "2"] <- "1"
    x2[x2 == "NA"] <- "2"
    ##	x2 <- paste(x2, collapse = "")	
    ##	storage.mode(x2) <- "character"
    ## call Fortran routine
    storage.mode(x2) <- "integer"        
    res <- .Fortran("mona",
                    as.integer(n),
                    as.integer(jp),
                    x2 = x2,
                    error = as.integer(0),
                    nban = integer(n),
                    ner = integer(n),
                    integer(n),
                    lava = integer(n),
                    integer(jp),
                    PACKAGE = "cluster")	
    ##give a warning when errors occured
    if(res$error == 1)
        stop("No clustering performed, an object was found with all values missing." )
    if(res$error == 2)
        stop("No clustering performed, a variable was found with at least 50% missing values." )
    if(res$error == 3)
        stop(message = "No clustering performed, a variable was found with all non missing values identical." )
    if(res$error == 4)
        stop("No clustering performed, all variables have at least one missing value." )
    res$x2 <- matrix(as.numeric(substring(res$x2,
                                          1:nchar(res$x2), 1:nchar(res$x2))),
                     n, jp)
    dimnames(res$x2) <- dimnames(x)	
    ##add labels to Fortran output
    if(length(dimnames(x)[[1]]) != 0)
        order.lab <- dimnames(x)[[1]][res$ner]
    if(length(dimnames(x)[[2]]) != 0) {
        lava <- as.character(res$lava)
        lava[lava != "0"] <- dimnames(x)[[2]][res$lava]
        lava[lava == "0"] <- "NULL"
        res$lava <- lava
    }
    ##construct S object
    clustering <- list(data = res$x2, order = res$ner,
                       variable = res$lava[ -1 ], step = res$nban[-1])
    if(exists("order.lab"))
        clustering$order.lab <- order.lab
    class(clustering) <- "mona"
    attr(clustering, "Call") <- sys.call()
    clustering
}

print.mona <- function(x, ...)
{
    cat("Revised data:\n")
    print(x$data, quote = FALSE, ...)
    cat("Order of objects:\n")
    print(if (length(x$order.lab) != 0) x$order.lab else x$order,
          quote = FALSE, ...)
    cat("Variable used:\n")
    print(x$variable, quote = FALSE, ...)
    cat("Separation step:\n")
    print(x$step, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

summary.mona <- function(x, ...)
{
    object <- x
    class(object) <- "summary.mona"
    object
}

print.summary.mona <- function(x, ...)
{
    print.mona(x, ...)
    invisible(x)
}

#### PAM : Partitioning Around Medoids

pam <- function(x, k, diss = FALSE, metric = "euclidean", stand = FALSE)
{
    meanabsdev <- function(y) mean(abs(y - mean(y, na.rm=TRUE)), na.rm=TRUE)
    size <- function(d)
    {
	discr <- 1 + 8 * length(d)
	sqrtdiscr <- round(sqrt(discr))
	if(round(sqrtdiscr)^2 != discr)
	    return(0)
	(1 + sqrtdiscr)/2
    }
    lower.to.upper.tri.inds <- function(n)
    {
	return(c(0, unlist(lapply(2:(n - 1), function(x, n)
				  cumsum(c(0, (n - 2):(n - x))), n = n))) +
	       rep(1:(n - 1), 1:(n - 1)))
    }
    upper.to.lower.tri.inds <- function(n)
    {
	return(unlist(lapply(0:(n - 2), function(x, n)
			     cumsum(x:(n - 2)), n = n)) +
	       rep(1 + cumsum(0:(n - 2)), (n - 1):1))
    }
    if(diss) {
	## check type of input vector
	if(is.na(min(x)))
	    stop("NA-values in the dissimilarity matrix not allowed.")
	if(data.class(x) != "dissimilarity") {
	    if(!is.numeric(x) || size(x) == 0)
		stop("x is not of class dissimilarity and can not be converted to this class." )	
	    ## convert input vector to class "dissimilarity"
	    class(x) <- "dissimilarity"
	    attr(x, "Size") <- size(x)
	    attr(x, "Metric") <- "unspecified"
	}
	## adapt S dissimilarities to Fortran:
	## convert upper matrix, read by rows, to lower matrix, read by rows.
	n <- attr(x, "Size")
	if((k < 1) || (k > n - 1))
	    stop("The number of cluster should be at least 1 and at most n-1.")
	dv <- x[lower.to.upper.tri.inds(n)]	
	## prepare arguments for the Fortran call
	dv <- c(0, dv)
	jp <- 1
	valmd <- double(1)
	jtmd <- integer(1)
	ndyst <- 0
	x2 <- double(n)
    }
    else {
	## check type of input matrix
	if((!is.data.frame(x) && !is.numeric(x)) ||
	   !all(sapply(x, data.class) == "numeric"))
	    stop("x is not a numeric dataframe or matrix.")
	x <- data.matrix(x)	
	## standardize, if necessary
	x2 <- if(stand) scale(x, scale = apply(x, 2, meanabsdev)) else x
	## put info about metric, size and NAs in arguments for the Fortran call
	ndyst <- if(metric == "manhattan") 2 else 1
	n <- nrow(x2)
	if((k < 1) || (k > n - 1))
	    stop("The number of cluster should be at least 1 and at most n-1.")
	jp <- ncol(x2)
	jtmd <- as.integer(ifelse(is.na(rep(1, n) %*% x2), -1, 1))
	valmisdat <- min(x2, na.rm = TRUE) - 0.5
	x2[is.na(x2)] <- valmisdat
	valmd <- rep(valmisdat, jp)
	dv <- double(1 + (n * (n - 1))/2)
    }
    ## call Fortran routine
    storage.mode(dv) <- "double"
    storage.mode(x2) <- "double"
    storage.mode(valmd) <- "double"
    res <- .Fortran("pam",
		    as.integer(n),
		    as.integer(jp),
		    as.integer(k),
		    x = x2,
		    dys = dv,
                    jdyss = as.integer(diss),# 0/1
		    valmd,
		    jtmd,
		    as.integer(ndyst),
		    integer(n),
		    integer(n),
		    integer(n),
		    double(n),
		    double(n),
		    avsil = double(n),
		    double(n),
		    ttsil = as.double(0),
		    med = integer(k),
		    obj = double(2),
		    clu = integer(n),
		    clusinf = matrix(0, k, 5),
		    silinf = matrix(0, n, 4),
		    isol = integer(k),
		    PACKAGE = "cluster")
    sildim <- res$silinf[, 4]
    if(diss) {
	disv <- x	
	## add labels to Fortran output
	if(length(attr(x, "Labels")) != 0) {
	    sildim <- attr(x, "Labels")[sildim]
	    names(res$clu) <- attr(x, "Labels")
	    res$med <- attr(x, "Labels")[res$med]
	}
    }
    else {
	## give warning if some dissimilarities are missing.
	if(res$jdyss == -1)
	    stop("No clustering performed, NA-values in the dissimilarity matrix.")	
	## adapt Fortran output to S:
	## convert lower matrix, read by rows, to upper matrix, read by rows.
	disv <- res$dys[-1]
	disv[disv == -1] <- NA
	disv <- disv[upper.to.lower.tri.inds(n)]
	class(disv) <- "dissimilarity"
	attr(disv, "Size") <- nrow(x)
	attr(disv, "Metric") <- metric
	attr(disv, "Labels") <- dimnames(x)[[1]]	
	## add labels to Fortran output
	res$med <- x[res$med,  ]
	if(length((dimnames(x)[[1]])) != 0) {
	    sildim <- dimnames(x)[[1]][sildim]
	    names(res$clu) <- dimnames(x)[[1]]
	}
    }
    ## add dimnames to Fortran output
    names(res$obj) <- c("build", "swap")
    res$isol <- factor(res$isol, levels = c(0, 1, 2),
		       labels = c("no", "L", "L*"))
    names(res$isol) <- 1:k
    dimnames(res$clusinf) <- list(NULL, c("size", "max_diss", "av_diss",
					  "diameter", "separation"))
    ## construct S object
    clustering <-
        if(k != 1) {
            dimnames(res$silinf) <-
                list(sildim, c("cluster", "neighbor", "sil_width", ""))
            list(medoids = res$med, clustering = res$clu, 
                 objective = res$obj, isolation = res$isol,
                 clusinfo = res$clusinf,
                 silinfo =
                 list(widths = res$silinf[, -4], 
                      clus.avg.widths = res$avsil[1:k],
                      avg.width = res$ttsil),
                 diss = disv)
        }
        else list(medoids = res$med, clustering = res$clu, 
                  objective = res$obj, isolation = res$isol,
                  clusinfo = res$clusinf, diss = disv)
    if(!diss) {
	x2[x2 == valmisdat] <- NA
	clustering$data <- x2
    }
    class(clustering) <- c("pam", "partition")
    attr(clustering, "Call") <- sys.call()
    clustering
}

print.pam <- function(x, ...)
{
    cat("Medoids:\n")
    print(x$medoids, ...)
    cat("Clustering vector:\n")
    print(x$clustering, ...)
    cat("Objective function:\n")
    print(x$objective, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

summary.pam <- function(x, ...)
{
    class(x) <- "summary.pam"
    x
}

print.summary.pam <- function(x, ...)
{
    cat("Medoids:\n")
    print(x$medoids, ...)
    cat("Clustering vector:\n")
    print(x$clustering, ...)
    cat("Objective function:\n")
    print(x$objective, ...)
    cat("\nNumerical information per cluster:\n")
    print(x$clusinfo, ...)
    cat("\nIsolated clusters:\n")
    cat("L-clusters: ")
    print(names(x$isolation[x$isolation == "L"]), quote = FALSE, ...)
    cat("L*-clusters: ")
    print(names(x$isolation[x$isolation == "L*"]), quote = FALSE, ...)
    if(length(x$silinfo) != 0) {
	cat("\nSilhouette plot information:\n")
	print(x$silinfo[[1]], ...)
	cat("Average silhouette width per cluster:\n")
	print(x$silinfo[[2]], ...)
	cat("Average silhouette width of total data set:\n")
	print(x$silinfo[[3]], ...)
    }
    cat("\n")
    print(x$diss, ...)
    cat("\nAvailable components:\n")
    print(names(x), ...)
    invisible(x)
}

pltree <- function(x, ...) UseMethod("pltree")

pltree.twins <-
  function(x, main = paste("Dendrogram of ", deparse(call)), ...)
{
    call <- attr(x, "Call")
    labels <- NULL
    if(length(x$order.lab) != 0) {
        names(x$order) <- names(x$order.lab) <- 1:length(x$order)
        labels <- x$order.lab[names(sort(x$order))]
    }
    x <- list(order = x$order, height = sort(x$height), merge = x$merge)

 if( sapply(R.version[c("major","minor")], as.numeric) %*% c(10,1) >= 12 ) {
    if(is.null(labels))
         plclust(x,                  main = main, ylab = "Height", ...)
    else plclust(x, labels = labels, main = main, ylab = "Height", ...)
 } else { ## R <= 1.1
    if(is.null(labels))
         plclust(x,                , ylab = "Height", ...)
    else plclust(x, labels = labels, ylab = "Height", ...)
    title(main = main, ...)
 }    
    invisible()
}

## plot.diana() & plot.agnes() are  almost identical;
##  just the bannerplot differs a bit ....

plot.agnes <- function(x, ask = FALSE, which.plots = NULL, 
                       main = NULL,
                       sub = paste("Agglomerative Coefficient = ",
                                   round(x$ac, digits = 2)),
                       adj = 0, nmax.lab = 35, max.strlen = 5, ...)
{
    bannerplot <- function(x, ...)
    {
        w <- rev(x$height)
        m <- max(x$height)
        w <- rbind(w, m - w)
        barplot(w, xlab = "Height", horiz = TRUE, inside = FALSE,
                space = 0, axes = FALSE, col = c(0, 2),
                mgp = c(2.5, 1, 0), ...)
        title(main = main1, sub = sub, adj = adj)
        flrm <- floor(m)
        at.vals <- c(seq(0, flrm, length = 11), m)
        lab.vals<- c(seq(0, flrm, length = 11), round(m, digits = 2))
        axis(1, at = at.vals, labels = lab.vals, ...)
        if(length(x$order) < nmax.lab) {
            names <- if (length(x$order.lab) != 0)
                substring(rev(x$order.lab), 1, max.strlen)
            else rev(x$order)
            axis(4, at = 0:(length(x$order) - 1), 
                 labels = names, pos = m, mgp = c(3, 1.25, 0), ...)
        } 
    }

    if(is.null(main)) {
        ## Different default for banner & pltree:
        cl <- deparse(attr(x, "Call"))
        main1 <- paste("Banner of ", cl)
        main2 <- paste("Dendrogram of ", cl)
    }
    else { # same title for both
        main1 <- .Alias(main)
        main2 <- .Alias(main)
    }
    if(is.null(which.plots)) { ## Use `menu' ..

        choices <- c("All", "Banner", "Clustering Tree")
        choices <- substring(choices, 1, 40)
        tmenu <- paste("plot:", choices)
        pick <- 2
        ask.now <- ask
        while(pick <= length(tmenu) + 2) {
            if(ask.now)
                pick <- menu(tmenu, title = 
                             "\nMake a plot selection (or 0 to exit):\n") + 1
            switch(pick,
                   return(invisible(x)),
                   ask.now <- FALSE,
                   bannerplot(x, ...),
                   pltree(x, main = main2, sub = sub, ...)
                   )
            if(!ask.now)
                pick <- pick + 1
            if(pick == length(tmenu) + 2)
                ask.now <- ask
        }
    }
    else for(i in which.plots)
        switch(i,
               bannerplot(x, ...),
               pltree    (x, main = main2, sub = sub, ...)
               )
    invisible()
}

plot.diana <-
function(x, ask = FALSE, which.plots = NULL,
         main = paste("Banner of ", deparse(attr(x, "Call"))),
         sub  = paste("Divisive Coefficient = ", round(x$dc, digits = 2)),
         adj = 0, nmax.lab = 35, max.strlen = 5, ...)
{
    bannerplot <- function(x, ...)
    {
        w <- rev(x$height)
        m <- max(x$height)
        w <- rbind(m - w, w)
        barplot(w, xlab = "Height", horiz = TRUE, inside = FALSE,
                space = 0, axes = FALSE, col = c(2, 0),
                mgp = c(2.5, 1, 0), ...)
        title(main = main1, sub = sub, adj = adj)
        flrm <- floor(m)
        at.vals <- c(0, seq(0, flrm, length = 11) + m - flrm)
        lab.vals <- c(round(m, digits = 2),
                      rev(seq(0, flrm, length = 11)))
        axis(1, at = at.vals, labels = lab.vals, ...)
        if(length(x$order) < nmax.lab) {
            names <- if (length(x$order.lab) != 0)
                substring(rev(x$order.lab), 1, max.strlen)
            else rev(x$order)
            axis(2, at = 0:(length(x$order) - 1), 
                 labels = names, pos = 0, mgp = c(3, 1.5, 0), ...)
        }
    }

    if(is.null(main)) {
        ## Different default for banner & pltree:
        cl <- deparse(attr(x, "Call"))
        main1 <- paste("Banner of ", cl)
        main2 <- paste("Dendrogram of ", cl)
    }
    else { # same title for both
        main1 <- .Alias(main)
        main2 <- .Alias(main)
    }
    if(is.null(which.plots)) { ## Use `menu' ..
        choices <- c("All", "Banner", "Clustering Tree")
        tmenu <- paste("plot:", choices)
        pick <- 3
        ask.now <- ask
        while(pick <= length(tmenu) + 2) {
            if(ask.now)
                pick <- menu(tmenu, title = 
                             "\nMake a plot selection (or 0 to exit):\n") + 1
            switch(pick,
                   return(invisible(x)),
                   ask.now <- FALSE,
                   bannerplot(x, ...),
                       pltree(x, main = main2, sub = sub, ...)
                   )
            if(!ask.now)
                pick <- pick + 1
            if(pick == length(tmenu) + 2)
                ask.now <- ask
        }
    }
    else for(i in which.plots)
        switch(i,
               bannerplot(x, ...),# i = 1
               pltree    (x, main = main2, sub = sub, ...) # i = 2
               )
    invisible()
}

plot.mona <- function(x, main = paste("Banner of ", deparse(attr(x, "Call"))),
                      col = 2, axes = TRUE, adj = 0,
                      nmax.lab = 35, max.strlen = 5,  ...)
{
    w <- rev(x$step)
    w[w==0] <- max(w)+1
    m <- max(w)
    barplot(rbind(w, m - w), xlab = "Separation step", horiz = TRUE, 
            inside = FALSE, space = 0, axes = FALSE,
            col = c(col, 0), mgp = c(2.5, 1, 0), ...)
    title(main = main, adj = adj, ...)
    if(axes) axis(1, at = 0:m, labels = 0:m, ...)
    if(length(x$order) < nmax.lab) {
        names <- if (length(x$order.lab) != 0)
            substring(rev(x$order.lab), 1, max.strlen)
        else rev(x$order)
        if(axes)
            axis(2, at = 0:(length(x$order) - 1), labels = names, pos = 0, 
                 mgp = c(3, 1.5, 0), las = 1, ...)
    }
    names <- rev(x$variable)
    names[rev(x$step) == 0] <- ""
    text(w, 0:(length(x$order) - 2) + 0.5, labels = paste(" ", names),
         adj = adj, col = col, ...)
    invisible()
}
plot.partition <-
function(x, ask = FALSE, cor = TRUE, stand = FALSE, lines = 2,
         shade = FALSE, color = FALSE, labels = 0, plotchar = TRUE,
         span = TRUE, xlim = NULL, ylim = NULL, ...)
{
    choices <- c("All", "Clusplot", "Silhouette Plot")
    choices <- substring(choices, 1, 40)
    tmenu <- paste("plot:", choices)
    pick <- 4
    ask.now <- ask
    z <- NULL
    while(pick <= length(tmenu) + 2) {
        if(ask.now)
            pick <- menu(tmenu, title = 
                         "\nMake a plot selection (or 0 to exit):\n") + 1
        switch(pick,
               return(invisible(x)),
               ask.now <- FALSE
               ,{
                   clusplot(x, cor = cor, stand = stand, lines = lines,
                            shade = shade, color = color, labels = labels,
                            plotchar = plotchar, span = span, 
                            xlim = xlim, ylim = ylim, ...)
               }
               ,{
                   if(length(x$silinfo) == 0)
                       stop("No silhouette plot available when the number of clusters equals 1." )
                   s <- rev(x$silinfo[[1]][, 3])
                   space <- c(0, rev(diff(x$silinfo[[1]][, 1])))
                   space[space != 0] <- 0.5
                   names <- if(length(s) < 40)
                       substring(rev(dimnames(x$silinfo[[1]])[[1]]), 1, 5)
                   barplot(s, space = space, names = names,
                           xlab = "Silhouette width",
                           xlim = c(min(0, min(s)), 1), horiz = TRUE,
                           mgp = c(2.5, 1, 0), ...)
                   title(main = paste("Silhouette plot of ", 
                         deparse(attr(x, "Call"))),
                         sub = paste("Average silhouette width : ",
                         round(x$ silinfo$avg.width, digits = 2)), adj = 0)
               }
               )
        if(!ask.now)
            pick <- pick + 1
        if(pick == length(tmenu) + 2)
            ask.now <- ask
    }
    invisible()
}

clusplot <- function(x, ...) UseMethod("clusplot")

clusplot.default <-
function(x, clus, diss = FALSE, cor = TRUE, stand = FALSE, lines = 2,
         shade = FALSE, color = FALSE, labels = 0, plotchar = TRUE,
         col.p = "dark green", # was 5 (= shaded col)
         col.txt = col.p,
         span = TRUE, xlim = NULL, ylim = NULL, ...)
{	
    size <- function(d)
    {
        discr <- 1 + 8 * length(d)
        sqrtdiscr <- round(sqrt(discr))
        if(round(sqrtdiscr)^2 != discr) 0 else (1 + sqrtdiscr)/2
    }
    ellipse <- function(A, dist, loc, n = 201)
    {
        ## Return (x,y) points on ellipse boundary
        detA <- A[1, 1] * A[2, 2] - A[1, 2]^2
        yl2 <- A[2, 2] * dist^2
        y <- seq( - sqrt(yl2), sqrt(yl2), leng = n)
        sqrt.discr <- sqrt(detA/A[2, 2]^2 * pmax(0, yl2 - y^2))
        sqrt.discr[c(1, n)] <- 0
        b <- loc[1] + A[1, 2]/A[2, 2] * y
        x1 <- b - sqrt.discr
        x2 <- b + sqrt.discr
        y <- loc[2] + y
        return(rbind(cbind(x1, y), cbind(rev(x2), rev(y))))
    }

    kleur <- function(n, verhoud, z, dens, col, ...)
    {
        verhoud1 <- order(verhoud)
        if(n <= 4) {
            for(i in 1:n) {
                j <- verhoud1[i]
                polygon(z[[j]], ##not yet density = dens[j],
                        col = col[i], ...)
            }
        }
        else {
## if(exists("pam", mode = "function") == FALSE) {
##   print("Looking for function pam in library(cluster) to compute the color effect for more than 4 clusters." )
##   library(cluster)
## }
            j <- pam(sort(verhoud), 4)$clustering
            for(i in 1:n) {
                q <- verhoud1[i]
                polygon(z[[q]], ##not yet density = dens[q],
                        col = col[j[i]], ...)
            }
        }
    }
    clas.snijpunt <- function(x, loc, m, n, p)
    {
        if(     loc[n, m] <= x[1, m] && x[1, m] <= loc[p, m]) x[1, ]
        else if(loc[n, m] <= x[2, m] && x[2, m] <= loc[p, m]) x[2, ]
        else NA
    }
    plotje <- function(x, ...)
    {
        polygon(x, ##not yet density = 0,
                col = 5, ...)
    }
    notavail <- function(x)
    {
        x[x == "NA"] <- median(x, na.rm = TRUE)
        return(x)
    }
    coord.snijp1 <- function(x, gemid)
    {
        x[2, 2] - 2 * x[1, 2] * gemid + x[1, 1] * gemid^2
    }
    coord.snijp2 <- function(x, dist, y)
    {
        ((x[1, 1] * x[2, 2] - x[1, 2]^2) * dist^2)/y
    }
    coord.snijp3 <- function(x, y, n, gemid)
    {
        matrix(c(x[n, 1] + sqrt(y), x[n, 1] - sqrt(y),
                 x[n, 2] + gemid * sqrt(y),
                 x[n, 2] - gemid * sqrt(y)), ncol = 2)
    }

    ## BEGIN ----
    
    namx <- deparse(substitute(x))
    if(is.data.frame(x))
        x <- data.matrix(x)
    if(!is.numeric(x))
        stop("x is not numeric")

    labels1 <- NULL
    if(diss) {
        if(is.na(min(x)))
            stop(message = "NA-values in x are not allowed.")
        if((data.class(x)) != "dissimilarity") {
            if((size(x)) == 0) {
                if((n <- nrow(x)) != ncol(x))
                    stop("Distances must be result of dist or a square matrix.")
                if(all.equal(x, t(x)) != TRUE)
                    stop("the square matrix is not symmetric.")
                labels1 <-
                    if(length(dimnames(x)[[1]]) == 0) 1:nrow(x)
                    else dimnames(x)[[1]]
            }
            else {
                if(!is.vector(x)) {
                    if(length(attr(x, "Labels")) != 0)
                        labels1 <- attr(x, "Labels")
                    x <- as.matrix(x)
                    if((n <- nrow(x)) == ncol(x) &&
                       all.equal(x, t(x)) == TRUE) {
                        labels1 <-
                            if(length(dimnames(x)[[1]]) == 0) 1:nrow(x)
                            else dimnames(x)[[1]]
                    }
                    else {
                        if(is.null(labels1))
                            labels1 <- 1:size(x)
                        attr(x, "Size") <- size(x)
                    }
                }
                else {
                    attr(x, "Size") <- size(x)
                    labels1 <- 1:size(x)
                }
            }
        }
        else {
            labels1 <-
                if(length(attr(x, "Labels")) == 0)
                    1:attr(x, "Size")
                else attr(x, "Labels")
        }
        ##x1 <- cmd(x, k = 2, eig = T, add = T)
        ##if(x1$ac < 0)
        ##	x1 <- cmd(x, k = 2, eig = T)
        x1 <- cmdscale(x, k = 2, eig = TRUE)
        var.dec <- sum(x1$eig)/sum(diag(x1$x))
        if (var.dec < 0) var.dec <- 0
        if (var.dec > 1) var.dec <- 1
        x1 <- x1$points
    }
    else { ## Not (diss)

        if(is.na(min(x))) {
            y <- is.na(x)
            y1 <- apply(y, 1, sum)
            y2 <- apply(y, 2, sum)
            if((sum(y1 == ncol(x)) != 0) && (sum(y2 == nrow(x)) != 0))
                stop("some objects and some variables contain only missing values"
                     )
            if(sum(y1 == nrow(x)) != 0)
                stop("one or more objects contain only missing values")
            if(sum(y2 == nrow(x)) != 0)
                stop("one or more variables contain only missing values")
            print("There were missing values and they were displaced by the median of the corresponding variable(s)"
                  )
            x <- apply(x, 2, notavail)
        }
        if(!is.matrix(x))
            stop("x is not allowed")
        ## ELSE
        labels1 <- 
            if(length(dimnames(x)[[1]]) == 0) 1:nrow(x)
            else dimnames(x)[[1]]
        
        if(ncol(x) == 1) {
            hulp <- rep(0, length(x))
            x1 <- matrix(c(t(x), hulp), ncol = 2)
            var.dec <- 1
        }
        else {
            prim.pr <- princomp(x, scores = TRUE, cor = ncol(x) != 2)
            x1 <- prim.pr$scores
            
            var.dec <- cumsum(prim.pr$sdev^2/sum(prim.pr$ sdev^2))[2]
            x1 <- cbind(x1[, 1], x1[, 2])
        }
    }
    clus <- as.vector(clus)
    if(length(clus) != length(x1[, 1]))
        stop("The clustering vector has not the good length")
    clus <- as.factor(clus)
    if(sum(is.na(clus)) != 0)
        stop("NA-values are not allowed in clustering vector")
    if(stand)
        x1 <- scale(x1)

    rangx <- range(x1[, 1])
    rangy <- range(x1[, 2])
    minx <- rangx[1]
    maxx <- rangx[2]
    miny <- rangy[1]
    maxy <- rangy[2]
    levclus <- levels(clus)
    n <- length(levclus)
    z <- A <- as.list(0)
    maxima <- loc <- matrix(0, ncol = 2, nrow = n)
    dist <- verhoud <- as.vector(0)
    verhouding <- 0
    num1 <- 10
    num2 <- 40
    num3 <- 90
    num4 <- 37
    num5 <- 3
    num6 <- 70

    for(i in 1:n) {
        x <- x1[clus == levclus[i], ]
        cov <-
          if(is.vector(x)) {
            x <- matrix(x, ncol = 2, byrow = TRUE)
            var(rbind(x, c(0, 0)))
          }
          else var(x)
        aantal <- nrow(x)
        x.1 <- range(x[, 1])
        y.1 <- range(x[, 2])
        notrank2 <- qr(cov, tol = 0.001)$rank != 2
        if(!span && notrank2) {
            dist[i] <- 1
            if((abs(diff(x.1)) > (diff(rangx)/70)) ||
               (abs(diff(y.1)) > (diff(rangy)/50))) {
                loc[i, ] <- c(x.1[1] + diff(x.1)/2, y.1[1] + diff(y.1)/2)
                a <- sqrt((loc[i, 1] - x.1[1])^2 + (loc[i, 2] - y.1[1])^2)
                a <- a + 0.05 * a
                if(abs(diff(x.1)) > (diff(rangx)/70)) {
                    ind1 <- (1:aantal)[x[,1]==max(x[,1])][1]
                    ind2 <- (1:aantal)[x[,1]==min(x[,1])][1]
                    q <- atan((x[ind1, 2] - x[ind2, 2])/
                              (x[ind1, 1] - x[ind2, 1]))
                    b <-
                        if(diff(rangy) == 0)
                            1
                        else if(abs(diff(y.1)) > (diff(rangy)/50)) 
                            diff(y.1)/num1
                        else diff(rangy)/num2
                }
                else {
                    b <- if(diff(rangx) == 0) 1 else diff(rangx)/num2
                    q <- pi/2
                }
                D <- diag(c(a^2, b^2))
                R <- cbind(c(  cos(q), sin(q)),
                           c(- sin(q), cos(q)))
                A[[i]] <- (R %*% D) %*% t(R)
            }
            else {
                a <- diff(rangx)/num3
                b <- diff(rangy)/num6
                if(a == 0) a <- 1
                if(b == 0) b <- 1
                A[[i]] <- diag(c(a^2, b^2))
                loc[i, ] <- x[1, ]
            }
            oppervlak <- pi * a * b
        }
        else if(span && notrank2) {
            dist[i] <- 1
            if(sum(x[, 1] != x[1, 1]) != 0 ||
               sum(x[, 2] != x[1, 2]) != 0) {
                loc[i, ] <- c(x.1[1] + diff(x.1)/2,
                              y.1[1] + diff(y.1)/2)
                a <- sqrt((loc[i, 1] - x.1[1])^2 +
                          (loc[i, 2] - y.1[1])^2)
                if(sum(x[, 1] != x[1, 1]) != 0) {
                    ind1 <- (1:aantal)[x[,1]==max(x[,1])][1]
                    ind2 <- (1:aantal)[x[,1]==min(x[,1])][1]
                    q <- atan((x[ind1, 2] - x[ind2, 2])/
                              (x[ind1, 1] - x[ind2, 1]))
                }
                else {
                    q <- pi/2
                }
                b <- 1e-7
                D <- diag(c(a^2, b^2))
                R <- cbind(c(  cos(q), sin(q)),
                           c(- sin(q), cos(q)))
                A[[i]] <- (R %*% D) %*% t(R)
            }
            else {
                a <- diff(rangx)/num3
                b <- diff(rangy)/num6
                if(a == 0) a <- 1
                if(b == 0) b <- 1
                A[[i]] <- diag(c(a^2, b^2))
                loc[i, ] <- x[1, ]
            }
            oppervlak <- pi * a * b

        }
        else { ## rank2
            if(!span) {
                loc[i, ] <- apply(x, 2, mean)
                dist[i] <- sqrt(max(mahalanobis(x, loc[i, ], cov))) 
                dist[i] <- dist[i] + 0.01 * dist[i]
            }
            else { ## span and rank2
                x2 <- cbind(matrix(1, aantal, 1), x)
                l1 <- matrix(0, 3, 3)
                sqdist <- prob <- rep(0, aantal)
                storage.mode(sqdist) <- "double"
                storage.mode(prob) <- "double"
                storage.mode(l1) <- "double"
                storage.mode(x2) <- "double"
                res <- .Fortran("spannel",
                                as.integer(aantal),
                                ndep= as.integer(2),
                                dat = x2,
                                eps = as.double(0.01),
                                sqdist = sqdist,
                                l1,
                                double(2),
                                double(2),
                                prob = prob,
                                double(3),
                                ierr = as.integer(0),
                                PACKAGE = "cluster")
                if(res$ierr != 0)
                    print("Error in Fortran routine computing the MVE-ellipsoid, please use the option exactmve=F"
                          )
                cov <- cov.wt(x, res$prob)$cov
                loc[i, ] <- cov.wt(x, res$prob)$center
                dist[i] <- sqrt(weighted.mean(res$sqdist, res$prob))
            }
            A[[i]] <- cov
            oppervlak <- pi * dist[i]^2 *
                sqrt(cov[1, 1] * cov[2, 2] - cov[1, 2]^2)
        }
        z[[i]] <- ellipse(A[[i]], dist[i], loc[i, ])
        rang <- c(range(z[[i]][, 1]), range(z[[i]][, 2]))
        maxima[i, ] <- z[[i]][201, ]
        minx <- min(minx, rang[1])
        maxx <- max(maxx, rang[2])
        miny <- min(miny, rang[3])
        maxy <- max(maxy, rang[4])
        verhoud[i] <- aantal/oppervlak
        if(verhoud[i] < 1e7)
            verhouding <- verhouding + verhoud[i]
    }
    if(verhouding == 0)
        verhouding <- 1
    density <- (verhoud * num4)/verhouding + num5
    density[density > 41] <- 41
    if (span) {
        if (rangx[1]==rangx[2]) {
            minx <- x1[1, 1] - 1
            maxx <- x1[1, 1] + 1
        }
        if (rangy[1]==rangy[2]) {
            miny <- x1[1, 2] - 1
            maxy <- x1[1, 2] + 1
        }
    }		
    if(!is.null(xlim)) {
        if(xlim[1] < minx) minx <- xlim[1]
        if(xlim[2] > maxx) maxx <- xlim[2]
    }
    if(!is.null(ylim)) {
        if(ylim[1] < miny) miny <- ylim[1]
        if(ylim[2] > maxy) maxy <- ylim[2]
    }

    ## --- Now plotting starts ---

    plot(x1[, 1], x1[, 2], xlim = c(minx, maxx), ylim = c(miny, maxy),
         xlab = "Component 1", ylab = "Component 2",
         main = paste("CLUSPLOT(", namx,")"),
         type = if(plotchar) "n" else "p", # if(plotchar) add points later
         col = col.p, ...)
    title(sub = paste("These two components explain",
          round(100 * var.dec, digits = 2), "% of the point variability."),
          adj = 0)

    color1 <- c(2, 4, 6, 3)

    if(shade && color) {
        kleur(n, verhoud, z, density, color1, ...)
    }
    else if(shade) {
        for(i in 1:n)
            polygon(z[[i]], ##not yet density = density[i],
                    col = 5, ...)
    }
    else if(color) {
        dens <- vector(mode = "numeric", length = n)
        kleur(n, verhoud, z, dens, color1, ...)
    }
    else {
        sapply(z, plotje, ...)
    }

    ## points after polygon in order to write ON TOP:
    if(plotchar) {
        karakter <- c(1:19)
        for(i in 1:n) {
            x <- x1[clus == levclus[i],  , drop = FALSE]
            kar <- 1+(i-1) %% 19
            points(x[, 1], x[, 2], pch = karakter[kar], col = col.p, ...)
        }
    }

    if((lines == 1 || lines == 2) && n > 1) {
        afstand <- matrix(0, ncol = n, nrow = n)
        for(i in 1:(n - 1)) {
            for(j in (i + 1):n) {
                gemid <- (loc[j, 2] - loc[i, 2])/(loc[j, 1] - loc[i, 1])
                s0 <- coord.snijp1(A[[i]], gemid)
                b0 <- coord.snijp2(A[[i]], dist[i], s0)
                snijp.1 <- coord.snijp3(loc, b0, i, gemid)
                s1 <- coord.snijp1(A[[j]], gemid)
                b1 <- coord.snijp2(A[[j]], dist[j], s1)
                snijp.2 <- coord.snijp3(loc, b1, j, gemid)
                if(loc[i, 1] != loc[j, 1]) {
                    if(loc[i, 1] < loc[j, 1]) {
                        punt.1 <- clas.snijpunt(snijp.1, loc, 1, i, j)
                        punt.2 <- clas.snijpunt(snijp.2, loc, 1, i, j)
                    }
                    else {
                        punt.1 <- clas.snijpunt(snijp.1, loc, 1, j, i)
                        punt.2 <- clas.snijpunt(snijp.2, loc, 1, j, i)
                    }
                }
                else {
                    if(loc[i, 2] < loc[j, 2]) {
                        punt.1 <- clas.snijpunt(snijp.1, loc, 2, i, j)
                        punt.2 <- clas.snijpunt(snijp.2, loc, 2, i, j)
                    }
                    else {
                        punt.1 <- clas.snijpunt(snijp.1, loc, 2, j, i)
                        punt.2 <- clas.snijpunt(snijp.2, loc, 2, j, i)
                    }
                }
                if((punt.1[1] == "NA") || (punt.2[1] == "NA") ||
                   (sqrt((punt.1[1] - loc[i, 1])^2 +
                         (punt.1[2] - loc[i, 2])^2) +
                    sqrt((punt.2[1] - loc[j, 1])^2 +
                         (punt.2[2] - loc[j, 2])^2)) > 
                   sqrt((loc[j, 1] - loc[i, 1])^2 +
                        (loc[j, 2] - loc[i, 2])^2))
                {
                    afstand[i, j] <- NA
                }
                else if(lines == 1) {
                    afstand[i, j] <- sqrt((loc[i, 1] - loc[j, 1])^2 +
                                          (loc[i, 2] - loc[j, 2])^2)
                    segments(loc[i, 1], loc[i, 2],
                             loc[j, 1], loc[j, 2], col = 6, ...)
                }
                else {
                    afstand[i, j] <- sqrt((punt.1[1] - punt.2[1])^2 +
                                          (punt.1[2] - punt.2[2])^2)
                    segments(punt.1[1], punt.1[2],
                             punt.2[1], punt.2[2], col = 6, ...)
                }
            }
        }
        afstand <- t(afstand) + afstand
    }
    else afstand <- NULL

    ## FIXME: The following is *not* elegant..
    if(labels == 1) {
        for(i in 1:n) {
            x1 <- rbind(x1, z[[i]][cumsum(rep(10, 40)), ])
            labels1 <- c(labels1, rep(levclus[i], 40))
        }
        identify(x1[, 1], x1[, 2], labels1, col = col.txt)
    }
    else if(labels == 2) {
        x1 <- rbind(x1, maxima)
        labels1 <- c(labels1, levclus)
        x1[, 1] <- x1[, 1] + (maxx - minx)/130
        x1[, 2] <- x1[, 2] + (maxy - miny)/50
        text(x1, labels = labels1, col = col.txt)
    }
    else if(labels == 3) {
        x1[, 1] <- x1[, 1] + (maxx - minx)/130
        x1[, 2] <- x1[, 2] + (maxy - miny)/50
        text(x1, labels = labels1, col = col.txt)
    }
    else if(labels == 4) {
        maxima[, 1] <- maxima[, 1] + (maxx - minx)/ 130
        maxima[, 2] <- maxima[, 2] + (maxy - miny)/ 50
        text(maxima, labels = levclus, col = col.txt)
    }

    density[density == 41] <- NA
    invisible(list(Distances = afstand, Shading = density))
}

clusplot.partition <- function(x, ...)
{
    if(length(x$data) != 0 && 
       (!is.na(min(x$data)) || data.class(x) == "clara"))
         invisible(clusplot.default(x$data, x$clustering, diss = FALSE, ...))
    else invisible(clusplot.default(x$diss, x$clustering, diss = TRUE, ...))
}




.First.lib <- function(lib, pkg) {
  require(mva)
  library.dynam("cluster", pkg, lib)
  assign("plclust", .Alias(plot.hclust), pos = "package:cluster")
}
