Re: [R] dendrogram - got it , just need to label :)

From: phlow <florian.kleedorfer_at_austria.fm>
Date: Tue, 22 Jan 2008 06:11:10 -0800 (PST)

Hi!
To label your dendrogram edges with the path to each of them, execute the following script (assuming that your dendrogram is 'dend', see last 2 lines).

dendrapplyGlobal <- function(dend,attrName,FUN,...,attrNameTo=NULL) {

	if (is.null(attrNameTo)) {
		attrNameTo <- attrName
	}
	funcGet <- function(x){
		attr(x,attrName)
	}
	funcSet <- function(x,value){
		attr(x,attrNameTo) <- value
		return(x)
	}
	values <- dendrapplyToVector(dend,funcGet)
	values <- FUN(values,...)
	ret <- dendrapplyFromVector(dend,values,funcSet)
	return(ret)

}

dendrapplyToVector <- function(X,FUN,...) {

	FUN <- match.fun(FUN)
	    if (!inherits(X, "dendrogram")) 
	        stop("'X' is not a dendrogram")
	    Napply <- function(d,path="") {
	    	if (is.leaf(d)) {
	    		ret <- c(FUN(d))
	    		names(ret)[1] <- substr(path,start=1,stop=nchar(path)-1)
	    		return(ret)
	    	} 
	    	ret <- vector()
	    	for (j in seq_along(d)) {
	    		addr <- paste(path,j,".",sep="")
	    		ret <- append(ret,Napply(d[[j]],addr))
	    	}
	    	ret <- append(ret,FUN(d))
	    	names(ret)[length(ret)] <- substr(path,start=1,stop=nchar(path)-1)
	        return(ret)
	    }

    Napply(X)
}

dendrapplyFromVector <- function(X,theVector,FUN,...) {

	FUN <- match.fun(FUN)
	    if (!inherits(X, "dendrogram")) 
	        stop("'X' is not a dendrogram")
	    Napply <- function(d,v) {
	    	if (is.leaf(d)) {
	    		ret <- FUN(d,v)
	    		return(ret)
	    	} else {
	    		ret <- d
                        if (!is.list(ret)) 
	                	ret <- as.list(ret)
	                i <- 1
	                memsum <- 0
	    		for (j in seq_along(d)) {
	    			childrenCount <- getDendrogramNodeCount(d[[j]])
	    			memsum <- memsum + childrenCount
	    			indices <- i:(i+childrenCount-1)
	    			ret[[j]] <- Napply(d[[j]],v[indices])
	    			i <- i + childrenCount
	    		}
	    		ret <- FUN(ret,v[i])
	    	}
	        return(ret)
	    }

    Napply(X,theVector)
}

dend1 <- dendrapplyGlobal(dend,
"height",function(x){names(x)},attrNameTo="edgetext") plot(dend1)

hth,
Florian

-- 
View this message in context: http://www.nabble.com/dendrogram---got-it-%2C-just-need-to-label-%3A%29-tp9403784p15019424.html
Sent from the R help mailing list archive at Nabble.com.

______________________________________________
R-help_at_r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
Received on Tue 22 Jan 2008 - 14:13:16 GMT

Archive maintained by Robert King, hosted by the discipline of statistics at the University of Newcastle, Australia.
Archive generated by hypermail 2.2.0, at Tue 22 Jan 2008 - 14:30:07 GMT.

Mailing list information is available at https://stat.ethz.ch/mailman/listinfo/r-help. Please read the posting guide before posting to the list.

list of date sections of archive