From 4407c72a4f5076db3bdd6f6eca557ba9ef454045 Mon Sep 17 00:00:00 2001 From: "Liam J. Revell" Date: Tue, 19 Sep 2017 12:11:00 -0500 Subject: [PATCH] small update to phenogram to permit custom tip positions --- R/phenogram.R | 50 ++++++++++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 22 deletions(-) diff --git a/R/phenogram.R b/R/phenogram.R index d04de46f..f6af3029 100644 --- a/R/phenogram.R +++ b/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) + } } }