graphclus.R
lower2upper.tri.inds <-
#copied from lower.to.upper.tri.inds from cluster library
function (n)
{
n1 <- as.integer(n - 1)
if (n1 < 1)
stop("`n' must be >= 2")
else if (n1 == 1)
1:1
else rep(1:n1, 1:n1) + c(0, unlist(lapply(2:n1, function(k) cumsum(c(0,
(n - 2):(n - k))))))
}
vec2distm <- function(vec){
#convert from a vector to a distance matrix
m <- length(vec)
n <- (1+sqrt(1+8*m))/2
ans<- matrix(0,n,n)
ans[lower.tri(ans)] <- vec
ans[upper.tri(ans)] <- vec[lower2upper.tri.inds(n)]
ans
}
vec2dist <- function(vec){
#convert from a vector to a "dis"
as.dist(vec2distm(vec))
}
# Returns a vector of off-diagonal elements in m.
# The off parameter specifies the distance above the main (0) diagonal.
diag.off <- function(m,off=1)
m[col(m)==row(m)+off]
#-----------------------------------------------------------
# Accepts a dissimilarity matrix or "dist" m, and
# returns a matrix of colors.
# M values are cut into categories using breaks (ranked distances if
# byrank is true) and categories are assigned the values in colors.
default.dmat.color <- c("#FDFFDA", "#D2F4F2", "#F4BBDD")
dmat.color <-
function(m, colors = default.dmat.color,byrank=NULL, breaks=length(colors) ){
if (is.matrix(m)) m <- as.dist(m)
if (is.null(byrank))
byrank <- length(breaks) == 1
if (byrank ==TRUE)
m1 <- rank(as.vector(m))
else
m1 <- as.vector(m)
fac <- cut(m1,breaks,include.lowest=TRUE)
ans <- colors[as.numeric(fac)]
ans <- vec2distm(ans)
diag(ans) <- NA
attr(ans,"Levels") <- levels(fac)
if (length(labels(m)) == nrow(ans)){
rownames(ans) <- labels(m)
colnames(ans) <- labels(m)}
ans
}
#-----------------------------------------------------------
#
# Extracts information from a matrix of colors suitable for use by
# image.
#
imageinfo <- function(cmat) {
n <- nrow(cmat)
p <- ncol(cmat)
levels <- sort(unique(as.vector(cmat)))
z <- unclass(factor(cmat,levels= levels, labels=1:length(levels)))
z <- matrix(z,nrow=n,p)
list(x=1:p,y=1:n, z =t(z),col=levels)
}
# This draws the color matrix cmat.
plotcolors <- function(cmat, na.color="white", dlabels = NULL, rlabels = FALSE, clabels = FALSE,
ptype ="image", border.color = "grey70", pch=15,cex=3,label.cex = .6,...) {
n <- nrow(cmat)
p <- ncol(cmat)
cmat[is.na(cmat)] <- na.color
if (ptype=="image") {
info <- imageinfo(cmat)
image(info$x, info$y, info$z[, n:1], col = info$col,
axes = FALSE, xlab = "", ylab = "", ...)}
else {
y <- rep(n:1,p)
x <- rep(1:p,rep(n,p))
cmat <- as.vector(cmat)
plot(x,y,col=cmat,cex=cex,pch=pch,axes=FALSE,xlab="",ylab="",
xlim=c(.5,p+.5),ylim=c(.5,n+.5),...)
}
axis(3, at = 1:p, tick=FALSE,labels = clabels,
las = 2, cex.axis = label.cex)
axis(2, at = n:1, tick=FALSE,labels = rlabels,
las = 2, cex.axis =label.cex)
if (is.vector(dlabels)){
nl <- length(dlabels)
text(1:nl,nl:1,dlabels,cex=label.cex)}
box(col = border.color)
}
#-----------------------------------------------------------
# This function draws a scatterplot matrix of data.
# Order, if present, specifies the order of the variables and
# panel.colors, if present should be a matrix of panel colors.
# (...) are graphical parameters.
cpairs <-
function(data,order=NULL,panel.colors=NULL,border.color="grey70",show.points=TRUE,...) {
textPanelbg <- function(x = 0.5, y = 0.5, txt, cex, font) {
box(col= border.color)
text(x, y, txt, cex = cex, font = font)
}
if (!is.null(order)) {
data <- data[,order]
if (!(is.null(panel.colors)))
panel.colors <- panel.colors[order,order]}
if (!is.null(panel.colors)) {
if (ncol(data) != nrow(panel.colors) || ncol(data) != ncol(panel.colors))
stop("dimensions do not match")
diag(panel.colors) <- NA
panel.colors <- t(panel.colors)[!is.na(panel.colors)]}
env<- new.env()
assign("j",1,envir=env)
pairs.default(data,...,text.panel = textPanelbg,
panel = function(x,y,...){
j <- get("j",envir=env)
reg <- par("usr")
if (!(is.null(panel.colors)))
rect(reg[1],reg[3],reg[2],reg[4],col=panel.colors[j])
box(col=border.color)
j <- j+1
assign("j",j,envir=env)
if (show.points == TRUE) points(x,y,...)
})
}
# This function draws a parallel coordinate plot of the data.
# Order, if present, specifies the order of the variables and
# panel.colors, if present should either be a vector of panel colors,
# or a matrix whose i,j the element gives the color for the panel
# showing columns i and j of data. (...) are graphical parameters.
# This function is adapted from parcoord(MASS).
cparcoord <-
function (data, order=NULL,panel.colors=NULL,col=1,lty=1,horizontal=FALSE,mar=NULL,...) {
if (is.null(mar))
if (horizontal==TRUE)
mar <- c(5, 2, 2, 2) + 0.1
else mar <- c(2, 8, 2, 2) + 0.1
if (!is.null(order)) {
data <- data[,order]
if (is.matrix(panel.colors))
panel.colors <- panel.colors[order,order]}
if (is.matrix(panel.colors))
panel.colors <- diag.off(panel.colors)
if (is.vector(panel.colors))
if (ncol(data) -1 != length(panel.colors))
stop("dimensions do not match")
oldpar <- par(mar=mar)
x <- apply(data, 2, function(x) (x - min(x))/(max(x) - min(x)))
p <- ncol(x)
if (horizontal==TRUE){
matplot(1:p, t(x),
xlab = "", ylab = "", axes = FALSE, type="n",...)
axis(1, at = 1:p, labels = colnames(x))
if (!(is.null(panel.colors)))
for (i in 1:(p-1)) rect(i,0,i+1,1, lty=0,col =panel.colors[i])
for (i in 1:p) lines(c(i, i), c(0, 1), col = "grey70")
matpoints(1:p, t(x), type = "l",col=col,lty = lty,...)
}
else {
matplot(t(x), p:1,
xlab = "", ylab = "", axes = FALSE, type="n",...)
axis(2, at = p:1, labels = colnames(x),las=2)
if (!(is.null(panel.colors)))
for (i in 1:(p-1)) rect(0,i,1,i+1, lty=0,col =panel.colors[p-i])
for (i in 1:p) lines(c(0, 1),c(i, i), col = "grey70")
matpoints(t(x), p:1, type = "l",col=col,lty = lty,...)
}
on.exit(par(oldpar))
invisible()
}
