"agnes"<-
function(x, diss = F, metric = "euclidean", stand = F, method = "average")
{
	meanabsdev <- function(y)
	{
		mean(abs(y - mean(y, na.rm = T)), na.rm = T)
	}
	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(message = 
				"NA-values in the dissimilarity matrix not allowed."
				)
		if(data.class(x) != "dissimilarity") {
			if(!is.numeric(x) || size(x) == 0)
				stop(message = 
				  "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(message = 
				"x is not a numeric dataframe or matrix.")
		x <- data.matrix(x)	#standardize, if necessary
		if(stand) {
			x2 <- scale(x, scale = apply(x, 2, meanabsdev))
		}
		else x2 <- x
		if(metric == "manhattan")
			ndyst <- 2
		else ndyst <- 1
		n <- nrow(x2)
		jp <- ncol(x2)
		jtmd <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
		valmisdat <- min(x2, na.rm = T) - 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)
	if(!diss) {
#give warning if some dissimilarities are missing.
		if(res$ok == -1) stop(message = 
				"No clustering performed, NA-values in the dissimilarity matrix.\n"
				)	#adapt Fortran output to S-Plus:
#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
}
"print.agnes"<-
function(x, ...)
{
	cat("Merge:\n")
	print(x$merge, ...)
	cat("Order of objects:\n")
	if (length(x$order.lab) != 0)
		print(x$order.lab, quote = F, ...)
	else
		print(x$order, quote = F, ...)
	cat("Height:\n")
	print(x$height, ...)
	cat("Agglomerative coefficient:\n")
	print(x$ac, ...)
	cat("\nAvailable arguments:\n")
	print(names(x), ...)
	invisible(x)
}
"summary.agnes"<-
function(x)
{
	object <- x
	class(object) <- "summary.agnes"
	object
}
"print.summary.agnes"<-
function(x, ...)
{
	cat("Merge:\n")
	print(x$merge, ...)
	cat("Order of objects:\n")
	if (length(x$order.lab) != 0)
		print(x$order.lab, quote = F, ...)
	else
		print(x$order, quote = F, ...)
	cat("Height:\n")
	print(x$height, ...)
	cat("Agglomerative coefficient:\n")
	print(x$ac, ...)
	cat("\n")
	print(x$diss, ...)
	cat("\nAvailable arguments:\n")
	print(names(x), ...)
	invisible(x)
}
"clara" <-
function(x, k, metric = "euclidean", stand = F, samples = 5, sampsize = 40 + 2 *
	k)
{
	meanabsdev <- function(y)
	{
		mean(abs(y - mean(y, na.rm = T)), na.rm = T)
	}
	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 < 1) || (k > n - 1))
		stop(message = "The number of cluster should be at least 1 and at most n-1."
			)
	if(sampsize < k) {
		warning <- paste(c("'sampsize' should be at least", k,
			"(number of clusters)"), collapse = " ")
		stop(message = warning)
	}
	if(n < sampsize) {
		warning <- paste(c("Number of objects is", n,
			", should be at least", sampsize, "(sampsize)"),
			collapse = " ")
		stop(message = warning)
	}
#standardize, if necessary
	if(stand) {
		x2 <- scale(x, scale = apply(x, 2, meanabsdev))
	}
	else x2 <- x
#put info about metric, size and NAs in arguments for the Fortran call
	if(metric == "manhattan")
		ndyst <- 2
	else ndyst <- 1
	n <- nrow(x2)
	jp <- ncol(x2)
	jtmd <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
	mdata <- ifelse(is.na(min(x2)), 1, 0)
	valmisdat <- min(x2, na.rm = T) - 0.5
	x2[is.na(x2)] <- valmisdat
	valmd <- rep(valmisdat, jp)
	jdyss <- 0
	x3 <- as.vector(t(x2))	
#call Fortran routine
	storage.mode(x3) <- "double"
	storage.mode(valmd) <- "double"
	storage.mode(jtmd) <- "integer"
	res <- .Fortran("clara",
		as.integer(n),
		as.integer(jp),
		as.integer(k),
		clu = x3,
		as.integer(samples),
		as.integer(sampsize),
		dis = double(1 + (sampsize * (sampsize - 1))/2),
		as.integer(mdata),
		valmd,
		jtmd,
		as.integer(ndyst),
		integer(sampsize),
		integer(sampsize),
		sample = integer(sampsize),
		integer(k),
		med = integer(k),
		double(k),
		double(k),
		double(k),
		avdis = double(k),
		maxdis = double(k),
		ratdis = double(k),
		size = integer(k),
		obj = as.double(0),
		avsil = double(k),
		ttsil = as.double(0),
		silinf = matrix(0, sampsize, 4),
		stop = as.integer(0),
		double(sampsize),
		double(sampsize),
		double(sampsize),
		integer(sampsize),
		integer(sampsize),
		integer(sampsize),
		integer(sampsize),
		integer(sampsize),
		integer(sampsize))	
#give a warning when errors occured
	if(res$stop == 1)
		stop(message = "For each sample at least one object was found which could not be assigned to a cluster (because of missing values)."
			)
	if(res$stop == 2)
		stop(message = "Each of the random samples contains objects between which no distance can be computed."
			)
	sildim <- res$silinf[, 4]	
#adapt Fortran output to S-Plus:
#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") <- dimnames(x)[[1]][res$sample]
#add labels to Fortran output
	res$med <- x[res$med,  ]
	res$clu <- matrix(res$clu, nrow = n, ncol = jp, byrow = T)[, 1]
	if(length(dimnames(x)[[1]]) != 0) {
		sildim <- dimnames(x)[[1]][sildim]
		res$sample <- dimnames(x)[[1]][res$sample]
		names(res$clu) <- dimnames(x)[[1]]
	}
#add dimnames to Fortran output
	clusinf <- cbind(res$size, res$maxdis, res$avdis, res$ratdis)
	dimnames(clusinf) <- list(NULL, c("size", "max_diss", "av_diss",
		"isolation"))
	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 = F, ...)
	cat("Medoids:\n")
	print(x$medoids, ...)
	cat("Clustering vector:\n")
	print(x$clustering, ...)
	cat("Objective function:\n")
	print(x$objective, ...)
	cat("\nAvailable arguments:\n")
	print(names(x), ...)
	invisible(x)
}

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

"print.summary.clara" <-
function(x, ...)
{
	cat("Best sample:\n")
	print(x$sample, quote = F, ...)
	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 arguments:\n")
	print(names(x), ...)
	invisible(x)
}

"daisy" <-
function(x, metric = "euclidean", stand = F, type = list())
{
	meanabsdev <- function(y)
	{
		mean(abs(y - mean(y, na.rm = T)), na.rm = T)
	}
	levs <- function(y)
	{
		levels(as.factor(y))
	}
#check type of input matrix 
	if(!is.data.frame(x) && !is.numeric(x))
		stop(message = "x is not a dataframe or a numeric matrix.")
	if(!is.null(type$asymm)) if(!all(sapply(lapply(as.data.frame(x[, type$
			asymm]), levs), length) == 2))
			stop(message =
				"asymmetric binary variable has more than 2 levels."
				)	
#transform variables and construct `type' vector
	type2 <- sapply(x, data.class)
	x <- data.matrix(x)
	x[, names(type2[type$ordratio])] <- codes(as.ordered(x[, names(type2[
		type$ordratio])]))
	x[, names(type2[type$logratio])] <- log10(x[, names(type2[type$logratio
		])])
	type2[type$asymm] <- "A"
	type2[type$ordratio] <- "O"
	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, meanabsdev))
		}
		jdat <- "2"
		if(metric == "manhattan")
			ndyst <- 2
		else ndyst <- 1
	}
	else {
		colmin <- apply(x, 2, min, na.rm = T)
		colextr <- apply(x, 2, max, na.rm = T) - colmin
		x <- scale(x, center = colmin, scale = colextr)
		jdat <- "1"
		ndyst <- 0
	}
	type2 <- paste(type2, collapse = "")
#put info about NAs in arguments for the Fortran call
	jtmd <- ifelse(is.na(rep(1, nrow(x)) %*% x), -1, 1)
	valmisdat <- min(x, na.rm = T) - 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"
	storage.mode(type2) <- "character"
	res <- .Fortran("daisy",
		as.integer(nrow(x)),
		as.integer(ncol(x)),
		x,
		valmd,
		jtmd,
		as.character(jdat),
		type2,
		as.integer(ndyst),
		dis = double(1 + (nrow(x) * (nrow(x) - 1))/2))	
#adapt Fortran output to S-Plus:
#convert lower matrix, read by rows, to upper matrix, read by rows.
	disv <- res$dis[-1]
	disv[disv == -1] <- NA
	full <- matrix(0, nrow(x), nrow(x))
	full[!lower.tri(full, diag = T)] <- 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-Plus object
	class(disv) <- "dissimilarity"
	attr(disv, "Labels") <- dimnames(x)[[1]]
	attr(disv, "Size") <- nrow(x)
	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)
}
"diana"<-
function(x, diss = F, metric = "euclidean", stand = F)
{
	meanabsdev <- function(y)
	{
		mean(abs(y - mean(y, na.rm = T)), na.rm = T)
	}
	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(message = 
				"NA-values in the dissimilarity matrix not allowed."
				)
		if(data.class(x) != "dissimilarity") {
			if(!is.numeric(x) || size(x) == 0)
				stop(message = 
				  "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(message = 
				"x is not a numeric dataframe or matrix.")
		x <- data.matrix(x)	#standardize, if necessary
		if(stand) {
			x2 <- scale(x, scale = apply(x, 2, meanabsdev))
		}
		else x2 <- x
		if(metric == "manhattan")
			ndyst <- 2
		else ndyst <- 1
		n <- nrow(x2)
		jp <- ncol(x2)
		jtmd <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
		valmisdat <- min(x2, na.rm = T) - 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)
	if(!diss) {
#give warning if some dissimilarities are missing.
		if(res$ok == -1) stop(message = 
				"No clustering performed, NA-values in the dissimilarity matrix.\n"
				)	#adapt Fortran output to S-Plus:
#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")
	if (length(x$order.lab) != 0)
		print(x$order.lab, quote = F, ...)
	else
		print(x$order, quote = F, ...)
	cat("Height:\n")
	print(x$height, ...)
	cat("Divisive coefficient:\n")
	print(x$dc, ...)
	cat("\nAvailable arguments:\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")
	if (length(x$order.lab) != 0)
		print(x$order.lab, quote = F, ...)
	else
		print(x$order, quote = F, ...)
	cat("Height:\n")
	print(x$height, ...)
	cat("Divisive coefficient:\n")
	print(x$dc, ...)
	cat("\n")
	print(x$diss, ...)
	cat("\nAvailable arguments:\n")
	print(names(x), ...)
	invisible(x)
}
"fanny" <-
function(x, k, diss = F, metric = "euclidean", stand = F)
{
	meanabsdev <- function(y)
	{
		mean(abs(y - mean(y, na.rm = T)), na.rm = T)
	}
	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(message =
				"NA-values in the dissimilarity matrix not allowed."
				)
		if(data.class(x) != "dissimilarity") {
			if(!is.numeric(x) || size(x) == 0) stop(message =
				  "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(message = 
				"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(message = 
				"x is not a numeric dataframe or matrix.")
		x <- data.matrix(x)	
#standardize, if necessary
		if(stand) {
			x2 <- scale(x, scale = apply(x, 2, meanabsdev))
		}
		else x2 <- x
#put info about metric, size and NAs in arguments for the Fortran call
		if(metric == "manhattan")
			ndyst <- 2
		else ndyst <- 1
		n <- nrow(x2)
		if((k < 1) || (k > floor(n/2) - 1))
			stop(message = 
				"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 = T) - 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))
	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(message =
				"No clustering performed, NA-values in the dissimilarity matrix.\n"
				)	
		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 arguments:\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 arguments:\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 = "")	
#call Fortran routine
##	storage.mode(x2) <- "character"
	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))	
#give a warning when errors occured
	if(res$error == 1)
		stop(message = "No clustering performed, an object was found with all values missing."
			)
	if(res$error == 2)
		stop(message = "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(message = "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-Plus 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 = F, ...)
	cat("Order of objects:\n")
	if (length(x$order.lab) != 0)
		print(x$order.lab, quote = F, ...)
	else
		print(x$order, quote = F, ...)
	cat("Variable used:\n")
	print(x$variable, quote = F, ...)
	cat("Separation step:\n")
	print(x$step, ...)
	cat("\nAvailable arguments:\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" <-
function(x, k, diss = F, metric = "euclidean", stand = F)
{
	meanabsdev <- function(y)
	{
		mean(abs(y - mean(y, na.rm = T)), na.rm = T)
	}
	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(message =
				"NA-values in the dissimilarity matrix not allowed."
				)
		if(data.class(x) != "dissimilarity") {
			if(!is.numeric(x) || size(x) == 0) stop(message =
				  "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-Plus 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(message = 
				"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)
		jdyss <- 1
	}
	else {
#check type of input matrix
		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)	
#standardize, if necessary
		if(stand) {
			x2 <- scale(x, scale = apply(x, 2, meanabsdev))
		}
		else x2 <- x
#put info about metric, size and NAs in arguments for the Fortran call
		if(metric == "manhattan")
			ndyst <- 2
		else ndyst <- 1
		n <- nrow(x2)
		if((k < 1) || (k > n - 1))
			stop(message = 
				"The number of cluster should be at least 1 and at most n-1."
				)
		jp <- ncol(x2)
		jtmd <- ifelse(is.na(rep(1, n) %*% x2), -1, 1)
		valmisdat <- min(x2, na.rm = T) - 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("pam",
		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),
		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))
	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$ok == -1)
		          stop(message =
				"No clustering performed, NA-values in the dissimilarity matrix.\n"
				)	
#adapt Fortran output to S-Plus:
#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
		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"))
	if(k != 1) {
		dimnames(res$silinf) <- list(sildim, c("cluster", "neighbor", 
			"sil_width", ""))	#construct S-Plus object
		clustering <- 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 {
		clustering <- 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 arguments:\n")
	print(names(x), ...)
	invisible(x)
}

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

"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 = F, ...)
	cat("L*-clusters: ")
	print(names(x$isolation[x$isolation == "L*"]), quote = F, ...)
	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 arguments:\n")
	print(names(x), ...)
	invisible(x)
}

"pltree"<-
function(x, ...)
{
	UseMethod("pltree")
}
"pltree.twins"<-
function(x, ...)
{
	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(is.null(labels))
		plclust(x, plot = T, ylab = "Height", ...)
	else plclust(x, labels = labels, plot = T, ylab = "Height", 
			...)
	title(main = paste("Clustering tree of ", deparse(call)), adj = 0)
	invisible()
}
"plot.agnes"<-
function(x, ask = F, ...)
{
	choices <- c("All", "Banner", "Clustering Tree")
	choices <- substring(choices, 1, 40)
	tmenu <- paste("plot:", choices)
	pick <- 3
	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 <- F,
			{
				w <- rev(x$height)
				m <- max(x$height)
				w <- rbind(w, m - w)
				barplot(w, xlab = "Height", horiz = T, inside
				   = F, space = 0, axes = F, col = c(0, 2), mgp
				   = c(2.5, 1, 0), ...)
				title(main = paste("Banner of ", deparse(attr(x,
				  "Call"))), sub = paste(
				  "Agglomerative Coefficient = ", round(x$ac, 
				  digits = 2)), adj = 0)
				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) < 35) {
					names <- if (length(x$order.lab) != 0)
					     substring(rev(x$order.lab), 1, 5)
						 else rev(x$order)
					axis(4, at = 0:(length(x$order) - 1), 
					  labels = names, pos = m, mgp = c(3, 
					  1.25, 0), ...)
				} 
			}
			,
			{
				pltree(x, ...)
			}
			)
		if(!ask.now)
			pick <- pick + 1
		if(pick == length(tmenu) + 2)
			ask.now <- ask
	}
	invisible()
}
"plot.diana"<-
function(x, ask = F, ...)
{
	choices <- c("All", "Banner", "Clustering Tree")
	choices <- substring(choices, 1, 40)
	tmenu <- paste("plot:", choices)
	pick <- 3
	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 <- F,
			{
				w <- rev(x$height)
				m <- max(x$height)
				w <- rbind(m - w, w)
				barplot(w, xlab = "Height",  
				  horiz = T, inside = F, space = 0, axes = F, 
				  col = c(2, 0), mgp = c(2.5, 1, 0), ...)
				title(main = paste("Banner of ", deparse(attr(x,
				  "Call"))), sub = paste(
				  "Divisive Coefficient = ", round(x$dc, digits
				   = 2)), adj = 0)
				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) < 35) {
					names <- if (length(x$order.lab) != 0)
					     substring(rev(x$order.lab), 1, 5)
				   		else rev(x$order)
					axis(2, at = 0:(length(x$order) - 1), 
					  labels = names, pos = 0, mgp = c(3, 
					  1.5, 0), ...)
				}
			}
			,
			{
				pltree(x, ...)
			}
			)
		if(!ask.now)
			pick <- pick + 1
		if(pick == length(tmenu) + 2)
			ask.now <- ask
	}
	invisible()
}
"plot.mona" <- 
function(x, ...)
{
	w <- rev(x$step)
	w[w==0] <- max(w)+1
	m <- max(w)
	barplot(rbind(w, m - w), xlab = "Separation step", horiz = T, 
		inside = F, space = 0, axes = F, col = c(2, 0), mgp
		 = c(2.5, 1, 0), ...)
	title(main = paste("Banner of ", deparse(attr(x, "Call"))), adj = 0)
	axis(1, at = 0:m, labels = 0:m, ...)
	if(length(x$order) < 35) {
		names <- if (length(x$order.lab) != 0)
				substring(rev(x$order.lab), 1, 5)
			else rev(x$order)
		axis(2, at = 0:(length(x$order) - 1), labels = names, pos = 0, 
		  mgp = c(3, 1.5, 0), ...)
	}
	names <- rev(x$variable)
	names[rev(x$step) == 0] <- ""
	text(w, 0:(length(x$order) - 2) + 0.5, labels = paste(" ", names), adj
		 = 0, col = 2, ...)
	invisible()
}
"plot.partition" <-
function(x, ask = F, cor = T, stand = F, lines = 2, shade = F, color = F, 
	labels = 0, plotchar = T, span = T, 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 <- F,
			{
				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(message = 
				    "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)
				   else NULL
				barplot(s, space = space, names = names, xlab
				   = "Silhouette width", xlim
				   = c(min(0, min(s)), 1), horiz = T, 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 = F, cor = T, stand = F, lines = 2, shade = F, color = F,
	labels = 0, plotchar = T, span = T, xlim = NULL, ylim = NULL, ...)
{	
	size <- function(d)
	{
		discr <- 1 + 8 * length(d)
		sqrtdiscr <- round(sqrt(discr))
		if(round(sqrtdiscr)^2 != discr)
			return(0)
		(1 + sqrtdiscr)/2
	}
	ellipse <- function(A, dist, loc)
	{
		detA <- A[1, 1] * A[2, 2] - A[1, 2]^2
		ylimit <- sqrt(A[2, 2]) * dist
		y <- seq( - ylimit, ylimit, 0.01 * ylimit)
		sqrt.discr <- sqrt(detA/A[2, 2]^2 * (A[2, 2] * dist^2 - y^2))
		sqrt.discr[c(1, length(sqrt.discr))] <- 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]], density = dens[j], col = col[i],
				  ...)
			}
		}
		else {
			if(exists("pam", mode = "function") == F) {
				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]], 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])) {
			f <- x[1,  ]
		}
		else {
			if((loc[n, m] <= x[2, m]) && (x[2, m] <= loc[p, m])) {
				f <- x[2,  ]
			}
			else {
				f <- NA
			}
		}
		return(f)
	}
	plotje <- function(x, ...)
	{
		polygon(x, density = 0, col = 5, ...)
	}
	notavail <- function(x)
	{
		x[x == "NA"] <- median(x, na.rm = T)
		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)
	}
	if(is.data.frame(x)) {
		x <- as.matrix(x)
	}
	if(!is.numeric(x))
		stop(message = "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(message = 
				    "Distances must be result of dist or a square matrix."
				    )
				if(all.equal(x, t(x)) != T)
				  stop(message = 
				    "the square matrix is not symmetric.")
				if(length(dimnames(x)[[1]]) == 0) {
				  labels1 <- c(1:nrow(x))
				}
				else {
				  labels1 <- dimnames(x)[[1]]
				}
			}
			else {
				if(is.vector(x) == F) {
				  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)) == T)) {
				    if(length(dimnames(x)[[1]]) == 0)
				      labels1 <- c(1:nrow(x))
				    else labels1 <- dimnames(x)[[1]]
				  }
				  else {
				    if(is.null(labels1))
				      labels1 <- c(1:size(x))
				    attr(x, "Size") <- size(x)
				  }
				}
				else {
				  attr(x, "Size") <- size(x)
				  labels1 <- c(1:size(x))
				}
			}
		}
		else {
			if(length(attr(x, "Labels")) == 0)
				labels1 <- c(1:attr(x, "Size"))
			else labels1 <- 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 = T)
		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 {
		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(message = 
				  "some objects and some variables contain only missing values"
				  )
			if(sum(y1 == nrow(x)) != 0)
				stop(message = 
				  "one or more objects contain only missing values"
				  )
			if(sum(y2 == nrow(x)) != 0)
				stop(message = 
				  "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(message = "x is not allowed")
		}
		else {
			if(length(dimnames(x)[[1]]) == 0) {
				labels1 <- c(1:nrow(x))
			}
			else {
				labels1 <- dimnames(x)[[1]]
			}
			if(ncol(x) == 1) {
				hulp <- rep(0, length(x))
				x1 <- matrix(c(t(x), hulp), ncol = 2)
				var.dec <- 1
			}
			else {
				if(ncol(x) == 2) {
				  prim.pr <- princomp(x, scores = T, cor = F)
				  x1 <- prim.pr$scores
				}
				else {
				  prim.pr <- princomp(x, scores = T, cor = cor)
				  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(message = "The clustering vector has not the good length")
	clus <- as.factor(clus)
	if(sum(is.na(clus)) != 0)
		stop(message = "NA-values are not allowed in clustering vector"
			)
	if(stand == T) {
		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)
	loc <- matrix(0, ncol = 2, nrow = n)
	dist <- verhoud <- as.vector(0)
	verhouding <- 0
	maxima <- matrix(0, ncol = 2, nrow = n)
	num1 <- 10
	num2 <- 40
	num3 <- 90
	num4 <- 37
	num5 <- 3
	num6 <- 70
	for(i in 1:n) {
		x <- x1[clus == levclus[i],  ]
		if(is.vector(x)) {
			x <- matrix(x, ncol = 2, byrow = T)
			cov <- var(rbind(x, c(0, 0)))
		}
		else {
			cov <- var(x)
		}
		aantal <- nrow(x)
		x.1 <- range(x[, 1])
		y.1 <- range(x[, 2])
		if(span == F && (qr(cov, tol = 0.001)$rank != 2)) {
			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.050000000000000003 * 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]))
				  if(diff(rangy) == 0) {
				    b <- 1
				  }
				  else {
				    if(abs(diff(y.1)) > (diff(rangy)/50)) {
				      b <- diff(y.1)/num1
				    }
				    else {
				      b <- diff(rangy)/num2
				    }
				  }
				}
				else {
				  if(diff(rangx) == 0) {
				    b <- 1
				  }
				  else {
				    b <- diff(rangx)/num2
				  }
				  q <- pi/2
				}
				D <- matrix(c(a^2, 0, 0, b^2), ncol = 2)
				R <- matrix(c(cos(q), sin(q),  - sin(q), cos(q)
				  ), ncol = 2)
				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]] <- matrix(c(a^2, 0, 0, b^2), ncol = 2)
				loc[i,  ] <- x[1,  ]
			}
			oppervlak <- pi * a * b
		}
		else {
			if((span == T && (qr(cov, tol = 0.001)$rank != 2))) {
				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]))
				    b <- 9.9999999999999995e-08
				  }
				  else {
				    b <- 9.9999999999999995e-08
				    q <- pi/2
				  }
				  D <- matrix(c(a^2, 0, 0, b^2), ncol = 2)
				  R <- matrix(c(cos(q), sin(q),  - sin(q), cos(
				    q)), ncol = 2)
				  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]] <- matrix(c(a^2, 0, 0, b^2), ncol = 2)
				  loc[i,  ] <- x[1,  ]
				}
				oppervlak <- pi * a * b
			}
			else {
				if(span == F) {
				  loc[i,  ] <- apply(x, 2, mean)
				  dist[i] <- sqrt(max(mahalanobis(x, loc[i,  ], 
				    cov)))
				  dist[i] <- dist[i] + 0.01 * dist[i]
				}
				else {
				  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),
				    as.integer(2),
				    x2,
				    as.double(0.01),
				    sqdist = sqdist,
				    l1,
				    double(2),
				    double(2),
				    prob = prob,
				    double(3),
				    stop = as.integer(0))
				  if(res$stop != 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] < 10000000)
			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) == F) {
		if(xlim[1] < minx)
			minx <- xlim[1]
		if(xlim[2] > maxx)
			maxx <- xlim[2]
	}
	if(is.null(ylim) == F) {
		if(ylim[1] < miny)
			miny <- ylim[1]
		if(ylim[2] > maxy)
			maxy <- ylim[2]
	}
	if(plotchar == F) {
		plot(x1[, 1], x1[, 2], xlim = c(minx, maxx), ylim = c(miny, 
			maxy), xlab = "Component 1", ylab = "Component 2", col
			 = 5, ...)
	}
	else {
		x <- x1[clus == levclus[1],  , drop = F]
		plot(x[, 1], x[, 2], xlim = c(minx, maxx), ylim = c(miny, maxy),
			xlab = "Component 1", ylab = "Component 2", col = 5, 
			...)
		if(n != 1) {
			karakter <- c(0:18)
			for(i in (2:n)) {
				x <- x1[clus == levclus[i],  , drop = F]
				kar <- i - floor((i - 1)/19) * 19
				points(x[, 1], x[, 2], pch = karakter[kar], col
				   = 5, ...)
			}
		}
	}
	title("CLUSPLOT")
	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 == T) && (color == T)) {
		kleur(n, verhoud, z, density, color1, ...)
	}
	else {
		if(shade == T) {
			for(i in 1:n) {
				polygon(z[[i]], density = density[i], col = 5, 
				  ...)
			}
		}
		else {
			if(color == T) {
				dens <- vector(mode = "numeric", length = n)
				kleur(n, verhoud, z, dens, color1, ...)
			}
			else {
				sapply(z, plotje, ...)
			}
		}
	}
	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")) 
				  {
				  afstand[i, j] <- NA
				}
				else {
				  if((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 = 5, ...)
				    }
				    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 = 5, ...)
				    }
				  }
				}
			}
		}
		afstand <- t(afstand) + afstand
	}
	else afstand <- NULL
	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 = 5)
	}
	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 = 5)
		}
		else {
			if(labels == 3) {
				x1[, 1] <- x1[, 1] + (maxx - minx)/130
				x1[, 2] <- x1[, 2] + (maxy - miny)/50
				text(x1, labels = labels1, col = 5)
			}
			else {
				if(labels == 4) {
				  maxima[, 1] <- maxima[, 1] + (maxx - minx)/
				    130
				  maxima[, 2] <- maxima[, 2] + (maxy - miny)/50
				  text(maxima, labels = levclus, col = 
				    5)
				}
			}
		}
	}
	density[density == 41] <- NA
	summary. <- list(afstand, density)
	names(summary.) <- c("Distances", "Shading")
	invisible(summary.)
}
"clusplot.partition"<-
function(x, ...)
{
	if(length(x$data) != 0) 
		if(!is.na(min(x$data)))
			invisible(clusplot.default(x$data, x$clustering, 
				diss = F, ...))
		else {
			if(data.class(x) == "clara")
				invisible(clusplot.default(x$data, 
					x$clustering, diss = F, ...))
			else invisible(clusplot.default(x$diss, x$clustering, 
				diss = T, ...))
		}
	else invisible(clusplot.default(x$diss, x$clustering, diss = T, ...))
}


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