small update to phenogram to permit custom tip positions

R/phenogram.R

@@ -46,6 +46,8 @@ phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FAL
 	else hold<-TRUE
 	if(hasArg(quiet)) quiet<-list(...)$quiet
 	else quiet<-FALSE
+	if(hasArg(label.pos)) label.pos<-list(...)$label.pos
+	else label.pos<-NULL
 	## end optional arguments
 	# check tree
 	if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
@@ -81,7 +83,7 @@ phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FAL
 		if(is.null(colors)) colors<-"black"
 		if(!add){ 
 			plot(H[1,],X[1,],type=type,lwd=lwd,lty=lty,col=colors,xlim=xlim,ylim=ylim,log=log,asp=asp,xlab="",ylab="",frame=FALSE, axes=FALSE)
-			if(spread.labels) tt<-spreadlabels(tree,x,fsize=fsize,cost=spread.cost,range=spread.range) else tt<-x[1:length(tree$tip)]
+			if(spread.labels) tt<-spreadlabels(tree,x,fsize=fsize,cost=spread.cost,range=spread.range,label.pos=label.pos) else tt<-x[1:length(tree$tip)]
 			if(tree$edge[1,2]<=length(tree$tip)){
 				if(fsize&&!add){
 					text(gsub("_"," ",tree$tip.label[tree$edge[1,2]]),x=H[1,2]+link,y=tt[tree$edge[1,2]],cex=fsize,font=ftype,pos=4,offset=offset)
@@ -115,6 +117,7 @@ phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FAL
 				if(i==1&&j==1&&!add) {
 					plot(a,b,col=colors[names(tree$maps[[i]])[j]],type=type,lwd=lwd,lty=lty,xlim=xlim,ylim=ylim,log=log,asp=asp,axes=FALSE,xlab="",ylab="")
 					if(spread.labels) tt<-spreadlabels(tree,x[1:length(tree$tip)],fsize=fsize,cost=spread.cost,range=spread.range) else tt<-x[1:length(tree$tip)]
+					print(tt)
 				} else lines(a,b,col=colors[names(tree$maps[[i]])[j]],lwd=lwd,lty=lty,type=type)
 				y<-a[2]
 			}
@@ -148,28 +151,31 @@ phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FAL
 
 ## function to spread labels
 ## written by Liam J. Revell 2013, 2014, 2016
-spreadlabels<-function(tree,x,fsize=1,cost=c(1,1),range=NULL){
-	if(is.null(range)) range<-range(x)
-	yy<-x[1:Ntip(tree)]
-	zz<-setNames((rank(yy,ties.method="random")-1)/(length(yy)-1)*diff(range(yy))+range(yy)[1],names(yy))
-	mm<-max(fsize*strheight(tree$tip.label))
-	ff<-function(zz,yy,cost,mo=1,ms=1){
-		ZZ<-cbind(zz-mm/2,zz+mm/2)
-		ZZ<-ZZ[order(zz),]
-		oo<-0
-		for(i in 2:nrow(ZZ)) 
-			oo<-if(ZZ[i-1,2]>ZZ[i,1]) oo<-oo+ZZ[i-1,2]-ZZ[i,1] else oo<-oo
-		pp<-sum((zz-yy)^2)
-		oo<-if(oo<(1e-6*diff(par()$usr[3:4]))) 0 else oo
-		pp<-if(pp<(1e-6*diff(par()$usr[3:4]))) 0 else pp
-		oo/mo*cost[1]+pp/ms*cost[2]
-	}
-	mo<-ff(yy,zz,cost=c(1,0))
-	ms<-ff(yy,zz,cost=c(0,1))
-	if(mo==0&&ms==0) return(yy)
+spreadlabels<-function(tree,x,fsize=1,cost=c(1,1),range=NULL,label.pos=NULL){
+	if(!is.null(label.pos)) return(label.pos[tree$tip.label])
 	else {
-		rr<-optim(zz,ff,yy=yy,mo=mo,ms=ms,cost=cost,method="L-BFGS-B",lower=rep(range[1],length(yy)),upper=rep(range[2],length(yy)))
-		return(rr$par)
+		if(is.null(range)) range<-range(x)
+		yy<-x[1:Ntip(tree)]
+		zz<-setNames((rank(yy,ties.method="random")-1)/(length(yy)-1)*diff(range(yy))+range(yy)[1],names(yy))
+		mm<-max(fsize*strheight(tree$tip.label))
+		ff<-function(zz,yy,cost,mo=1,ms=1){
+			ZZ<-cbind(zz-mm/2,zz+mm/2)
+			ZZ<-ZZ[order(zz),]
+			oo<-0
+			for(i in 2:nrow(ZZ)) 
+				oo<-if(ZZ[i-1,2]>ZZ[i,1]) oo<-oo+ZZ[i-1,2]-ZZ[i,1] else oo<-oo
+			pp<-sum((zz-yy)^2)
+			oo<-if(oo<(1e-6*diff(par()$usr[3:4]))) 0 else oo
+			pp<-if(pp<(1e-6*diff(par()$usr[3:4]))) 0 else pp
+			oo/mo*cost[1]+pp/ms*cost[2]
+		}
+		mo<-ff(yy,zz,cost=c(1,0))
+		ms<-ff(yy,zz,cost=c(0,1))
+		if(mo==0&&ms==0) return(yy)
+		else {
+			rr<-optim(zz,ff,yy=yy,mo=mo,ms=ms,cost=cost,method="L-BFGS-B",lower=rep(range[1],length(yy)),upper=rep(range[2],length(yy)))
+			return(rr$par)
+		}
 	}
 }