R/sim_plot.R
In bstaggmartin/backwards-BM-simulator: Evolving Rate Models of Continuous Trait Evolution
Defines functions
legend.evorates
pairs.evorates
plot.evorates
def.color.scheme
Documented in
plot.evorates
def.color.scheme<-function(){
rgb(c(0.000,0.545,1.000),
c(0.051,0.400,0.451),
c(0.495,0.545,0.451))
}
#plot an autocorrelated Brownian motion simulation
#add an option to only exponentiate legend? Done
#really need to clean these functions up-->chunks of code identical between plot.evorates and pairs, also many of this code
#should just be internal functions, rather than explicit
#' Plot simulated trait and/or rate data from a
#'
#' @export
plot.evorates<-function(sim,traits=1:ncol(sim$X),style=c('phenogram','phylogram','cladogram','fan','unrooted','radial'),
col=def.color.scheme(),na.col='gray90',val.range=NULL,res=100,
alpha=NA,breaks=NULL,colvec=NULL,lwd=1,lty=1,
xlab=NULL,ylab=NULL,add=F,color.element='R',exp=FALSE,exp.txt=TRUE,...,
legend=T,legend.args=NULL){
tree<-sim$tree
try.style<-try(match.arg(style,c('phenogram','phylogram','cladogram','fan','unrooted','radial')))
if(inherits(try.style,'try-error')){
stop(try.style," is not an available plotting style: please specify one of the following: 'phenogram', 'phylogram', 'cladogram', 'fan', 'unrooted', or 'radial'")
}
style<-try.style
plot.args<-c(names(formals(plot.default)),
names(formals(axis)),names(formals(box)),names(formals(plot.window)),names(formals(title)))
plot.args<-plot.args[-which(plot.args=='...')]
gen.args<-graphics:::.Pars
if(any(names(list(...))=='edge.color')){
warning('plot.evorates uses col rather than edge.color to control line color: edge.color was ignored')
}
if(any(names(list(...))=='edge.width')){
warning('plot.evorates uses lwd rather than edge.width to control line width: edge.width was ignored')
}
if(any(names(list(...))=='edge.lty')){
warning('plot.evorates uses lty rather than edge.lty to control line type: edge.lty was ignored')
}
if(is.null(colnames(sim$X))){
colnames(sim$X)<-paste('trait',1:ncol(sim$X))
}else{
names.lens<-nchar(colnames(sim$X))
colnames(sim$X)<-ifelse(names.lens==0,paste('trait',1:ncol(sim$X)),colnames(sim$X))
}
if(is.numeric(traits)){
traits<-colnames(sim$X)[traits]
}
#check if any trait names not available
traits.exist<-traits%in%colnames(sim$X)
if(all(!traits.exist)){
stop('none of the specified traits found')
}
if(any(!traits.exist)){
warning(paste(traits[which(!traits.exist)],collapse=', '),' not found')
traits<-traits[which(traits.exist)]
}
if(is.null(sim[[color.element]])){
sim[[color.element]]<-0
legend<-F
warning('set legend to FALSE since specified color element is NULL')
}
if(exp){
sim[[color.element]]<-exp(sim[[color.element]])
}
if(length(traits)>2&style=='phenogram'){
pairs(sim,traits=traits,col=col,val.range=val.range,res=res,alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
color.element=color.element,exp=exp,exp.txt=exp.txt,...,
legend=legend,legend.args=legend.args)
}else{
if(is.null(xlab)){
if(length(traits)==1){
xlab<-'time'
}else{
xlab<-traits[1]
}
}
if(is.null(ylab)){
if(length(traits)==1){
ylab<-traits
}else{
ylab<-traits[2]
}
}
if(is.null(colvec)){
if(is.null(breaks)){
if(is.null(val.range)){
val.range<-range(sim[[color.element]],na.rm=TRUE)
}
colramp<-colorRampPalette(col,alpha=T)(res)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
if((val.range[2]-val.range[1])==0){
colvec<-colramp[round((res+1)/2)]
}else{
inds<-round((sim[[color.element]]-val.range[1])/(val.range[2]-val.range[1])*(res-1))+1
inds[inds<1]<-1;inds[inds>res]<-res
colvec<-colramp[inds]
}
}else{
colramp<-colorRampPalette(col,alpha=T)(length(breaks)+1)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
if(is.null(sim[[color.element]])){
colvec<-colramp[round((length(breaks)+2)/2)]
}else{
colvec<-colramp[cut(sim[[color.element]],
c(min(sim[[color.element]],na.rm=TRUE)-1,
breaks,
max(sim[[color.element]],na.rm=TRUE)+1))]
}
}
colvec[is.na(colvec)]<-na.col
}else{
colvec<-rep(colvec,length.out=nrow(tree$edge))
colvec<-alter.cols(colvec,alpha=alpha)
if(legend){
warning('skipped plotting a legend since evorates was plotted with custom color vector')
}
}
lwdvec<-rep(lwd,length.out=nrow(tree$edge))
ltyvec<-rep(lty,length.out=nrow(tree$edge))
if(style=='phenogram'){
n<-length(tree$tip.label)
if(nrow(sim$X)==n){
#will need to be updated to handle multivariate stuff
elen<-tree$edge.length
if(!is.null(sim$R)){
if(color.element=='R'&exp){
elen<-elen*sim$R
}else{
elen<-elen*exp(sim$R)
}
}
elen[is.na(elen)]<-0
tmp<-NULL
for(i in 1:ncol(sim$X)){
XX<-array(NA,c(1,tree$Nnode+n,1),
list(NULL,c(tree$tip.label,1:tree$Nnode+n),NULL))
PP<-XX
LL<-XX
XX[,tree$tip.label,]<-sim$X[tree$tip.label,i]
PP[,tree$tip.label,]<-Inf
LL[,tree$edge[,2],]<-elen
LL[,n+1,]<-0
tmp<-cbind(tmp,.anc.recon(tree,XX,LL,PP,FALSE)[[1]][1,,1])
}
colnames(tmp)<-traits
sim$X<-tmp
}
sim$X<-sim$X[c(tree$tip.label,n+1:tree$Nnode),,drop=F]
if(length(traits)==1){
if(hasArg(node.depths)){
xx<-list(...)$node.depths
}else{
xx<-node.depth.edgelength(tree)
}
if(!add){
do.call(plot,
c(x=list(xx),
y=list(sim$X[,traits]),
xlab=xlab,
ylab=ylab,
col='white',
type='p',
pch=1,
list(...)[!(names(list(...))%in%c('x','y','xlab','ylab','col','type','pch'))&
names(list(...))%in%c(gen.args,plot.args)]))
}
do.call(segments,
c(x0=list(xx[tree$edge[,1]]),x1=list(xx[tree$edge[,2]]),
y0=list(sim$X[,traits][tree$edge[,1]]),y1=list(sim$X[,traits][tree$edge[,2]]),
col=list(colvec),
lwd=list(lwdvec),
lty=list(ltyvec),
list(...)[names(list(...))%in%gen.args]))
}else{
if(!add){
do.call(plot,
c(x=list(sim$X[,traits[1]]),
y=list(sim$X[,traits[2]]),
xlab=xlab,
ylab=ylab,
col='white',
type='p',
pch=1,
list(...)[!(names(list(...))%in%c('x','y','xlab','ylab','col','type','pch'))&
names(list(...))%in%c(gen.args,plot.args)]))
}
do.call(segments,
c(x0=list(sim$X[,traits[1]][tree$edge[,1]]),x1=list(sim$X[,traits[1]][tree$edge[,2]]),
y0=list(sim$X[,traits[2]][tree$edge[,1]]),y1=list(sim$X[,traits[2]][tree$edge[,2]]),
col=list(colvec),
lwd=list(lwdvec),
lty=list(ltyvec),
list(...)[names(list(...))%in%gen.args]))
}
}else{
if(!add){
do.call(plot,
c(x=list(tree),
type=style,
edge.color=rgb(0,0,0,0),
list(...)[!(names(list(...))%in%c('type','edge.color'))]))
}
#no support for adding tip labels if add is set to TRUE...yet
tree.plot<-try(get("last_plot.phylo",envir=.PlotPhyloEnv),silent=T)
if(inherits(tree.plot,'try-error')){
tmpf<-tempfile()
pdf(tmpf)
do.call(plot,
c(x=list(tree),
type=style,
edge.color=list(colvec),
edge.width=list(lwd),
edge.lty=list(lty),
list(...)[!(names(list(...))%in%c('type','edge.color','edge.width','edge.lty'))]))
dev.off()
unlink(tmpf)
tree.plot<-get("last_plot.phylo",envir=.PlotPhyloEnv)
}
tree.plot$type<-tree.plot$type
if(tree.plot$type=='phylogram'){
if(tree.plot$direction=='leftwards'|tree.plot$direction=='rightwards'){
coords.list<-c(y0=list(tree.plot$yy[as.vector(t(tree$edge))]),y1=list(tree.plot$yy[rep(tree$edge[,2],each=2)]),
x0=list(tree.plot$xx[rep(tree$edge[,1],each=2)]),x1=list(tree.plot$xx[as.vector(t(tree$edge))]))
}else{
coords.list<-c(y0=list(tree.plot$yy[rep(tree$edge[,1],each=2)]),y1=list(tree.plot$yy[as.vector(t(tree$edge))]),
x0=list(tree.plot$xx[as.vector(t(tree$edge))]),x1=list(tree.plot$xx[rep(tree$edge[,2],each=2)]))
}
colvec<-rep(colvec,each=2)
lwdvec<-rep(lwdvec,each=2)
ltyvec<-rep(ltyvec,each=2)
}else if(tree.plot$type=='fan'){
r<-sqrt(tree.plot$xx^2+tree.plot$yy^2)
theta<-atan(tree.plot$yy/tree.plot$xx)
probs<-tree.plot$xx<0
theta[probs]<-theta[probs]+pi
tmp<-tree$edge[,2]
base<-theta[tmp[tmp<=Ntip(tree)][1]]
theta[is.nan(theta)]<-base
probs<-theta<base
theta[probs]<-theta[probs]+2*pi
tmp<-as.vector(t(tree$edge))
theta0<-theta[tmp]
theta1<-theta[rep(tree$edge[,2],each=2)]
theta1[1]<-theta0[1]
r0<-r[rep(tree$edge[,1],each=2)]
r1<-r[tmp]
colvec<-rep(colvec,each=2)
lwdvec<-rep(lwdvec,each=2)
ltyvec<-rep(ltyvec,each=2)
#interpolation
if(hasArg(ang.res)){
const<-2*pi/(list(...)$ang.res+1)
}else{
const<-2*pi/100
}
odds<-seq.int(1,length(theta0),2)
tmp.seq<-seq_along(odds)
signs<-sign(theta1[odds]-theta0[odds])
const<-signs*const
interp0<-lapply(tmp.seq,function(ii) seq(theta0[odds[ii]],theta1[odds[ii]],const[ii]))
interp1<-lapply(tmp.seq,function(ii) c(interp0[[ii]][-1],theta1[odds[ii]]))
theta0<-as.list(theta0)
theta0[odds]<-interp0
theta1<-as.list(theta1)
theta1[odds]<-interp1
#replicating everything appropriately
lens<-lengths(theta0)
theta0<-unlist(theta0,use.names=FALSE)
theta1<-unlist(theta1,use.names=FALSE)
r0<-rep(r0,lens)
r1<-rep(r1,lens)
colvec<-rep(colvec,lens)
lwdvec<-rep(lwdvec,lens)
ltyvec<-rep(ltyvec,lens)
coords.list<-c(x0=list(r0*cos(theta0)),
x1=list(r1*cos(theta1)),
y0=list(r0*sin(theta0)),
y1=list(r1*sin(theta1)))
}else{
coords.list<-c(y0=list(tree.plot$yy[tree$edge[,1]]),y1=list(tree.plot$yy[tree$edge[,2]]),
x0=list(tree.plot$xx[tree$edge[,1]]),x1=list(tree.plot$xx[tree$edge[,2]]))
}
do.call(segments,
c(coords.list,
col=list(colvec),
lwd=list(lwdvec),
lty=list(ltyvec),
list(...)[names(list(...))%in%gen.args]))
}
if(legend){
legend.call<-c(sim=list(sim),color.element=color.element,exp=exp,exp.txt=exp.txt,
col=list(col),val.range=list(val.range),res=res,
alpha=if(length(alpha)==1) alpha else list(alpha),breaks=if(length(breaks)==1) breaks else list(breaks),
legend.args)
legend.coords<-do.call(legend.evorates,legend.call)
invisible(legend.coords)
}
}
}
#improve label handling: DONE 8/25
#' @export
pairs.evorates<-function(sim,traits=1:ncol(sim$X),
col=def.color.scheme(),val.range=NULL,res=100,
alpha=NA,breaks=NULL,colvec=NULL,lwd=1,lty=1,
lab=NULL,color.element='R',exp=FALSE,exp.txt=TRUE,...,
legend=T,legend.args=NULL){
tree<-sim$tree
if(is.null(colnames(sim$X))){
colnames(sim$X)<-paste('trait',1:ncol(sim$X))
}else{
names.lens<-nchar(colnames(sim$X))
colnames(sim$X)<-ifelse(names.lens==0,paste('trait',1:ncol(sim$X)),colnames(sim$X))
}
if(is.numeric(traits)){
traits<-colnames(sim$X)[traits]
}
#check if any trait names not available
traits.exist<-traits%in%colnames(sim$X)
if(all(!traits.exist)){
stop('none of the specified traits found')
}
if(any(!traits.exist)){
warning(paste(traits[which(!traits.exist)],collapse=', '),' not found')
traits<-traits[which(traits.exist)]
}
n<-length(tree$tip.label)
if(nrow(sim$X)==n){
#will need to be updated to handle multivariate stuff
elen<-tree$edge.length
if(!is.null(sim$R)){
if(color.element=='R'&exp){
elen<-elen*sim$R
}else{
elen<-elen*exp(sim$R)
}
}
tmp<-NULL
for(i in 1:ncol(sim$X)){
XX<-array(NA,c(1,tree$Nnode+n,1),
list(NULL,c(tree$tip.label,1:tree$Nnode+n),NULL))
PP<-XX
LL<-XX
XX[,tree$tip.label,]<-sim$X[tree$tip.label,i]
PP[,tree$tip.label,]<-Inf
LL[,tree$edge[,2],]<-elen
LL[,n+1,]<-0
tmp<-cbind(tmp,.anc.recon(tree,XX,LL,PP,FALSE)[[1]][1,,1])
}
colnames(tmp)<-traits
sim$X<-tmp
}
sim$X<-sim$X[c(tree$tip.label,n+1:tree$Nnode),,drop=F]
if(is.null(lab)){
lab<-rep(NA,length.out=length(traits))
}
lab<-rep(lab,length.out=length(traits))
lab<-ifelse(is.na(lab),traits,lab)
old.par<-par(no.readonly=T)
par(mfrow=c(length(traits),length(traits)),mar=c(0,0,0,0),oma=c(5.1,4.1,0,0),xpd=T)
for(i in 1:length(traits)){
for(j in 1:length(traits)){
if(j==1){
yaxt=NULL
args.y.mtext<-list(text=lab[i],
side=2,
line=3,
cex=0.75)
}else{
yaxt='n'
args.y.mtext<-list(NULL)
}
if(i==length(traits)){
xaxt=NULL
args.x.mtext<-list(text=lab[j],
side=1,
line=3,
cex=0.75)
}else{
xaxt='n'
args.x.mtext<-list(NULL)
}
if(i==j){
if(i==length(traits)){
plot(sim,traits=c(traits[i],traits[j]),
alpha=0,colvec=rgb(0,0,0,0),
xaxt=xaxt,yaxt=yaxt,xlab='',ylab='',...,
legend=F)
new.range<-range(sim$X[,i])
node.depths<-node.depth.edgelength(tree)
node.depths<-node.depths/max(node.depths)*diff(new.range)+min(new.range)
plot(sim,traits=traits[i],
col=col,val.range=val.range,res=res,
alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
xaxt='n',yaxt=yaxt,add=T,color.element=color.element,node.depths=node.depths,...,
legend=F)
}else{
plot(sim,traits=traits[i],
col=col,val.range=val.range,res=res,
alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
xaxt=xaxt,yaxt=yaxt,color.element=color.element,xlab='',ylab='',...,
legend=F)
}
do.call(mtext,args.x.mtext)
do.call(mtext,args.y.mtext)
}else{
plot(sim,traits=c(traits[j],traits[i]),
col=col,val.range=val.range,res=res,
alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
xaxt=xaxt,yaxt=yaxt,color.element=color.element,xlab='',ylab='',...,
legend=F)
do.call(mtext,args.x.mtext)
do.call(mtext,args.y.mtext)
}
}
}
if(legend){
par(fig=c(0,1,0,1),oma=c(5.1,4.1,0,0),mar=c(0,0,0,0),new=T)
if(is.null(legend.args$box.scale)){
legend.args$box.scale<-1
}
legend.args$box.scale<-legend.args$box.scale*0.4
if(is.null(legend.args$cex)){
legend.args$cex<-1
}
legend.args$cex<-legend.args$cex*0.8
bds<-par('usr')
bds.dims<-c(diff(bds[1:2]),diff(bds[3:4]))
if(length(legend.args$box.offset)==0){
legend.args$box.offset<-rep(NA,2)
}else if(length(legend.args$box.offset)==1){
legend.args$box.offset<-c(legend.args$box.offset,NA)
}
legend.args$box.offset<-ifelse(is.na(legend.args$box.offset),bds.dims/c(40,-20),legend.args$box.offset)
if(is.null(legend.args$xpd)){
legend.args$xpd<-T
}
legend.call<-c(sim=list(sim),color.element=color.element,exp=exp,exp.txt=exp.txt,
col=list(col),val.range=list(val.range),res=res,
alpha=if(length(alpha)==1) alpha else list(alpha),breaks=if(length(breaks)==1) breaks else list(breaks),
legend.args)
do.call(legend.evorates,
legend.call)
}
par(old.par)
}
#plot 3 to 4 numbers next to legend
#exp.txt only works for non-break legends...can't imagine why it would need to be otherwise
#' @export
legend.evorates<-function(sim,location=c('bottomleft','topleft','bottomright','topright'),color.element='R',
exp=FALSE,exp.txt=TRUE,
col=def.color.scheme(),val.range=NULL,res=100,
alpha=NA,breaks=NULL,select.levels=NULL,
box.dims=NULL,box.offset=NULL,box.scale=1,
txt.col=NULL,main=NULL,...){
if(exp){
exp.txt<-FALSE
}
try.location<-try(match.arg(location,c('bottomleft','topleft','bottomright','topright')),silent=T)
if(inherits(try.location,'try-error')){
stop(location," is not an available named position to put the legend: please specify one of the following: 'bottomleft', 'topleft', 'bottomright', or 'topright'")
}
location<-try.location
gen.args<-graphics:::.Pars
poly.args<-names(formals(polygon))
poly.args<-poly.args[-which(poly.args=='...')]
text.args<-names(formals(text.default))
text.args<-text.args[-which(text.args=='...')]
if(is.null(breaks)){
if(is.null(val.range)){
val.range<-range(sim[[color.element]],na.rm=TRUE)
}
colramp<-colorRampPalette(col,alpha=T)(res)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
}else{
colramp<-colorRampPalette(col,alpha=T)(length(breaks)+1)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
if(is.null(select.levels)){
select.levels<-1:length(colramp)
}
select.levels<-select.levels[select.levels>=1&select.levels<=(length(breaks)+1)]
select.levels<-sort(select.levels)
colramp<-colramp[select.levels]
}
bds<-par('usr')
bds.dims<-c(diff(bds[1:2]),diff(bds[3:4]))
if(length(box.dims)==0){
box.dims<-rep(NA,2)
}else if(length(box.dims)==1){
box.dims<-c(box.dims,NA)
}
box.dims<-box.scale*ifelse(is.na(box.dims),bds.dims/c(30,5),box.dims)
if(length(box.offset)==0){
box.offset<-rep(NA,2)
}else if(length(box.offset)==1){
box.offset<-c(box.offset,NA)
}
box.offset<-ifelse(is.na(box.offset),bds.dims/c(8,20),box.offset)
x.offset<-box.offset[1]
y.offset<-box.offset[2]
if(grepl('right',location)){
x.offset<- bds.dims[1]-box.dims[1]-box.offset[1]
}
if(grepl('top',location)){
y.offset<- bds.dims[2]-box.dims[2]-box.offset[2]
}
coords<-list(x=c(0,box.dims[1],box.dims[1],0)+x.offset+bds[1],y=c(0,0,box.dims[2],box.dims[2])+y.offset+bds[3])
# box.midpt<-sapply(coords,mean)
# coords$x<-(coords$x-box.midpt[1])*box.scale+box.midpt[1]
# coords$y<-(coords$y-box.midpt[2])*box.scale+box.midpt[2]
y.int<-seq(coords$y[2],coords$y[3],length.out=length(colramp)+1)
for(i in 1:length(colramp)){
do.call(polygon,
c(x=list(coords$x),
y=list(c(y.int[i],y.int[i],y.int[i+1],y.int[i+1])),
border=NA,
col=colramp[i],
list(...)[!(names(list(...))%in%c('x','y','border','col','adj'))&
names(list(...))%in%gen.args]))
}
do.call(polygon,
c(x=list(coords$x),
y=list(coords$y),
col=NA,
list(...)[!(names(list(...))%in%c('x','y','col','adj'))&
names(list(...))%in%c(gen.args,poly.args)]))
side<-NA
if(hasArg(side)){
if(list(...)$side<=2&list(...)$side>=1){
side<-list(...)$side
}
}
if(is.na(side)){
side<-if(grepl('left',location)) 2 else 1
}
txt.args<-list(...)[!(names(list(...))%in%c('x','y','labels'))&names(list(...))%in%c(gen.args,text.args)]
if(is.null(txt.args$adj)&is.null(txt.args$pos)){
txt.args$pos<-side*2
}
if(!is.null(txt.col)){
txt.args$col<-txt.col
}
if(is.null(breaks)){
if(val.range[2]-val.range[1]==0){
labels<-val.range[1]
}else{
labels<-pretty(seq(val.range[1],val.range[2],length.out=100))
labels<-labels[2:(length(labels)-1)]
}
y.pos<-coords$y[2]+(labels-val.range[1])/
(diff(val.range))*
(coords$y[3]-coords$y[2])
if(exp.txt){
labels<-format(exp(labels),digits=1)
}
do.call(text,
c(x=coords$x[side],
y=list(y.pos),
labels=list(labels),
txt.args))
}else{
labels<-paste(signif(breaks[-length(breaks)],3),signif(breaks[-1],3),sep=' - ')
labels<-c(paste('<',signif(breaks[1],3)),labels,paste('>',signif(breaks[length(breaks)],3)))
labels<-labels[select.levels]
y.pos<-apply(cbind(y.int[-length(y.int)],y.int[-1]),1,mean)
do.call(text,
c(x=coords$x[side],
y=list(y.pos),
labels=list(labels),
txt.args))
}
if(is.null(main)){
if(color.element=='R'){
if(exp|exp.txt){
main<-expression(sigma^2)
}else{
main<-expression(ln~(sigma^2))
}
}else{
main<-substitute(color.element)
}
}
main.side<-NA
if(hasArg(main.side)){
if(list(...)$main.side<=4&list(...)$main.side>=1){
main.side<-list(...)$main.side
}
}
if(is.na(main.side)){
main.side<-if(grepl('left',location)) 2 else 4
}
main.args<-list(...)[!(names(list(...))%in%paste0('main.',c('x','y','labels','side')))&
names(list(...))%in%paste0('main.',c(gen.args,text.args))]
names(main.args)<-gsub('main.','',names(main.args))
txt.args<-txt.args[!names(txt.args)%in%c('srt','pos','adj','offset')]
txt.args[names(main.args)%in%names(txt.args)]<-main.args[names(main.args)%in%names(txt.args)]
main.args<-c(txt.args,main.args[!(names(main.args)%in%names(txt.args))])
if(is.null(main.args$adj)&is.null(main.args$pos)){
main.args$pos<-main.side
if(main.side%in%c(2,4)&is.null(main.args$srt)){
main.args$srt<-90
main.args$pos<-NULL
main.args$adj<-c(0.5,c(-0.3,1.3)[main.side/2])
}
}
if(main.side%in%c(2,4)&is.null(main.args$srt)){
main.args$srt<-90
}
if(is.null(main.args$cex)){
main.args$cex<-1
}
if(main.side%in%c(2,4)){
x.pos<-coords$x[main.side/2]
y.pos<-mean(coords$y[2:3])
if(main.side==4){
x.pos<-x.pos+bds.dims[1]/50
}else{
x.pos<-x.pos-bds.dims[1]/50
}
}else{
x.pos<-mean(coords$x[1:2])
y.pos<-coords$y[main.side/2+1.5]
if(main.side==3){
y.pos<-y.pos+bds.dims[2]/50
}else{
y.pos<-y.pos-bds.dims[2]/50
}
}
do.call(text,
as.list(c(x=x.pos,
y=y.pos,
labels=list(main),
main.args)))
invisible(coords)
}
bstaggmartin/backwards-BM-simulator documentation built on June 3, 2024, 5:51 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions legend.evorates pairs.evorates plot.evorates def.color.scheme
Documented in plot.evorates
def.color.scheme<-function(){
rgb(c(0.000,0.545,1.000),
c(0.051,0.400,0.451),
c(0.495,0.545,0.451))
}
#plot an autocorrelated Brownian motion simulation
#add an option to only exponentiate legend? Done
#really need to clean these functions up-->chunks of code identical between plot.evorates and pairs, also many of this code
#should just be internal functions, rather than explicit
#' Plot simulated trait and/or rate data from a
#'
#' @export
plot.evorates<-function(sim,traits=1:ncol(sim$X),style=c('phenogram','phylogram','cladogram','fan','unrooted','radial'),
col=def.color.scheme(),na.col='gray90',val.range=NULL,res=100,
alpha=NA,breaks=NULL,colvec=NULL,lwd=1,lty=1,
xlab=NULL,ylab=NULL,add=F,color.element='R',exp=FALSE,exp.txt=TRUE,...,
legend=T,legend.args=NULL){
tree<-sim$tree
try.style<-try(match.arg(style,c('phenogram','phylogram','cladogram','fan','unrooted','radial')))
if(inherits(try.style,'try-error')){
stop(try.style," is not an available plotting style: please specify one of the following: 'phenogram', 'phylogram', 'cladogram', 'fan', 'unrooted', or 'radial'")
}
style<-try.style
plot.args<-c(names(formals(plot.default)),
names(formals(axis)),names(formals(box)),names(formals(plot.window)),names(formals(title)))
plot.args<-plot.args[-which(plot.args=='...')]
gen.args<-graphics:::.Pars
if(any(names(list(...))=='edge.color')){
warning('plot.evorates uses col rather than edge.color to control line color: edge.color was ignored')
}
if(any(names(list(...))=='edge.width')){
warning('plot.evorates uses lwd rather than edge.width to control line width: edge.width was ignored')
}
if(any(names(list(...))=='edge.lty')){
warning('plot.evorates uses lty rather than edge.lty to control line type: edge.lty was ignored')
}
if(is.null(colnames(sim$X))){
colnames(sim$X)<-paste('trait',1:ncol(sim$X))
}else{
names.lens<-nchar(colnames(sim$X))
colnames(sim$X)<-ifelse(names.lens==0,paste('trait',1:ncol(sim$X)),colnames(sim$X))
}
if(is.numeric(traits)){
traits<-colnames(sim$X)[traits]
}
#check if any trait names not available
traits.exist<-traits%in%colnames(sim$X)
if(all(!traits.exist)){
stop('none of the specified traits found')
}
if(any(!traits.exist)){
warning(paste(traits[which(!traits.exist)],collapse=', '),' not found')
traits<-traits[which(traits.exist)]
}
if(is.null(sim[[color.element]])){
sim[[color.element]]<-0
legend<-F
warning('set legend to FALSE since specified color element is NULL')
}
if(exp){
sim[[color.element]]<-exp(sim[[color.element]])
}
if(length(traits)>2&style=='phenogram'){
pairs(sim,traits=traits,col=col,val.range=val.range,res=res,alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
color.element=color.element,exp=exp,exp.txt=exp.txt,...,
legend=legend,legend.args=legend.args)
}else{
if(is.null(xlab)){
if(length(traits)==1){
xlab<-'time'
}else{
xlab<-traits[1]
}
}
if(is.null(ylab)){
if(length(traits)==1){
ylab<-traits
}else{
ylab<-traits[2]
}
}
if(is.null(colvec)){
if(is.null(breaks)){
if(is.null(val.range)){
val.range<-range(sim[[color.element]],na.rm=TRUE)
}
colramp<-colorRampPalette(col,alpha=T)(res)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
if((val.range[2]-val.range[1])==0){
colvec<-colramp[round((res+1)/2)]
}else{
inds<-round((sim[[color.element]]-val.range[1])/(val.range[2]-val.range[1])*(res-1))+1
inds[inds<1]<-1;inds[inds>res]<-res
colvec<-colramp[inds]
}
}else{
colramp<-colorRampPalette(col,alpha=T)(length(breaks)+1)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
if(is.null(sim[[color.element]])){
colvec<-colramp[round((length(breaks)+2)/2)]
}else{
colvec<-colramp[cut(sim[[color.element]],
c(min(sim[[color.element]],na.rm=TRUE)-1,
breaks,
max(sim[[color.element]],na.rm=TRUE)+1))]
}
}
colvec[is.na(colvec)]<-na.col
}else{
colvec<-rep(colvec,length.out=nrow(tree$edge))
colvec<-alter.cols(colvec,alpha=alpha)
if(legend){
warning('skipped plotting a legend since evorates was plotted with custom color vector')
}
}
lwdvec<-rep(lwd,length.out=nrow(tree$edge))
ltyvec<-rep(lty,length.out=nrow(tree$edge))
if(style=='phenogram'){
n<-length(tree$tip.label)
if(nrow(sim$X)==n){
#will need to be updated to handle multivariate stuff
elen<-tree$edge.length
if(!is.null(sim$R)){
if(color.element=='R'&exp){
elen<-elen*sim$R
}else{
elen<-elen*exp(sim$R)
}
}
elen[is.na(elen)]<-0
tmp<-NULL
for(i in 1:ncol(sim$X)){
XX<-array(NA,c(1,tree$Nnode+n,1),
list(NULL,c(tree$tip.label,1:tree$Nnode+n),NULL))
PP<-XX
LL<-XX
XX[,tree$tip.label,]<-sim$X[tree$tip.label,i]
PP[,tree$tip.label,]<-Inf
LL[,tree$edge[,2],]<-elen
LL[,n+1,]<-0
tmp<-cbind(tmp,.anc.recon(tree,XX,LL,PP,FALSE)[[1]][1,,1])
}
colnames(tmp)<-traits
sim$X<-tmp
}
sim$X<-sim$X[c(tree$tip.label,n+1:tree$Nnode),,drop=F]
if(length(traits)==1){
if(hasArg(node.depths)){
xx<-list(...)$node.depths
}else{
xx<-node.depth.edgelength(tree)
}
if(!add){
do.call(plot,
c(x=list(xx),
y=list(sim$X[,traits]),
xlab=xlab,
ylab=ylab,
col='white',
type='p',
pch=1,
list(...)[!(names(list(...))%in%c('x','y','xlab','ylab','col','type','pch'))&
names(list(...))%in%c(gen.args,plot.args)]))
}
do.call(segments,
c(x0=list(xx[tree$edge[,1]]),x1=list(xx[tree$edge[,2]]),
y0=list(sim$X[,traits][tree$edge[,1]]),y1=list(sim$X[,traits][tree$edge[,2]]),
col=list(colvec),
lwd=list(lwdvec),
lty=list(ltyvec),
list(...)[names(list(...))%in%gen.args]))
}else{
if(!add){
do.call(plot,
c(x=list(sim$X[,traits[1]]),
y=list(sim$X[,traits[2]]),
xlab=xlab,
ylab=ylab,
col='white',
type='p',
pch=1,
list(...)[!(names(list(...))%in%c('x','y','xlab','ylab','col','type','pch'))&
names(list(...))%in%c(gen.args,plot.args)]))
}
do.call(segments,
c(x0=list(sim$X[,traits[1]][tree$edge[,1]]),x1=list(sim$X[,traits[1]][tree$edge[,2]]),
y0=list(sim$X[,traits[2]][tree$edge[,1]]),y1=list(sim$X[,traits[2]][tree$edge[,2]]),
col=list(colvec),
lwd=list(lwdvec),
lty=list(ltyvec),
list(...)[names(list(...))%in%gen.args]))
}
}else{
if(!add){
do.call(plot,
c(x=list(tree),
type=style,
edge.color=rgb(0,0,0,0),
list(...)[!(names(list(...))%in%c('type','edge.color'))]))
}
#no support for adding tip labels if add is set to TRUE...yet
tree.plot<-try(get("last_plot.phylo",envir=.PlotPhyloEnv),silent=T)
if(inherits(tree.plot,'try-error')){
tmpf<-tempfile()
pdf(tmpf)
do.call(plot,
c(x=list(tree),
type=style,
edge.color=list(colvec),
edge.width=list(lwd),
edge.lty=list(lty),
list(...)[!(names(list(...))%in%c('type','edge.color','edge.width','edge.lty'))]))
dev.off()
unlink(tmpf)
tree.plot<-get("last_plot.phylo",envir=.PlotPhyloEnv)
}
tree.plot$type<-tree.plot$type
if(tree.plot$type=='phylogram'){
if(tree.plot$direction=='leftwards'|tree.plot$direction=='rightwards'){
coords.list<-c(y0=list(tree.plot$yy[as.vector(t(tree$edge))]),y1=list(tree.plot$yy[rep(tree$edge[,2],each=2)]),
x0=list(tree.plot$xx[rep(tree$edge[,1],each=2)]),x1=list(tree.plot$xx[as.vector(t(tree$edge))]))
}else{
coords.list<-c(y0=list(tree.plot$yy[rep(tree$edge[,1],each=2)]),y1=list(tree.plot$yy[as.vector(t(tree$edge))]),
x0=list(tree.plot$xx[as.vector(t(tree$edge))]),x1=list(tree.plot$xx[rep(tree$edge[,2],each=2)]))
}
colvec<-rep(colvec,each=2)
lwdvec<-rep(lwdvec,each=2)
ltyvec<-rep(ltyvec,each=2)
}else if(tree.plot$type=='fan'){
r<-sqrt(tree.plot$xx^2+tree.plot$yy^2)
theta<-atan(tree.plot$yy/tree.plot$xx)
probs<-tree.plot$xx<0
theta[probs]<-theta[probs]+pi
tmp<-tree$edge[,2]
base<-theta[tmp[tmp<=Ntip(tree)][1]]
theta[is.nan(theta)]<-base
probs<-theta<base
theta[probs]<-theta[probs]+2*pi
tmp<-as.vector(t(tree$edge))
theta0<-theta[tmp]
theta1<-theta[rep(tree$edge[,2],each=2)]
theta1[1]<-theta0[1]
r0<-r[rep(tree$edge[,1],each=2)]
r1<-r[tmp]
colvec<-rep(colvec,each=2)
lwdvec<-rep(lwdvec,each=2)
ltyvec<-rep(ltyvec,each=2)
#interpolation
if(hasArg(ang.res)){
const<-2*pi/(list(...)$ang.res+1)
}else{
const<-2*pi/100
}
odds<-seq.int(1,length(theta0),2)
tmp.seq<-seq_along(odds)
signs<-sign(theta1[odds]-theta0[odds])
const<-signs*const
interp0<-lapply(tmp.seq,function(ii) seq(theta0[odds[ii]],theta1[odds[ii]],const[ii]))
interp1<-lapply(tmp.seq,function(ii) c(interp0[[ii]][-1],theta1[odds[ii]]))
theta0<-as.list(theta0)
theta0[odds]<-interp0
theta1<-as.list(theta1)
theta1[odds]<-interp1
#replicating everything appropriately
lens<-lengths(theta0)
theta0<-unlist(theta0,use.names=FALSE)
theta1<-unlist(theta1,use.names=FALSE)
r0<-rep(r0,lens)
r1<-rep(r1,lens)
colvec<-rep(colvec,lens)
lwdvec<-rep(lwdvec,lens)
ltyvec<-rep(ltyvec,lens)
coords.list<-c(x0=list(r0*cos(theta0)),
x1=list(r1*cos(theta1)),
y0=list(r0*sin(theta0)),
y1=list(r1*sin(theta1)))
}else{
coords.list<-c(y0=list(tree.plot$yy[tree$edge[,1]]),y1=list(tree.plot$yy[tree$edge[,2]]),
x0=list(tree.plot$xx[tree$edge[,1]]),x1=list(tree.plot$xx[tree$edge[,2]]))
}
do.call(segments,
c(coords.list,
col=list(colvec),
lwd=list(lwdvec),
lty=list(ltyvec),
list(...)[names(list(...))%in%gen.args]))
}
if(legend){
legend.call<-c(sim=list(sim),color.element=color.element,exp=exp,exp.txt=exp.txt,
col=list(col),val.range=list(val.range),res=res,
alpha=if(length(alpha)==1) alpha else list(alpha),breaks=if(length(breaks)==1) breaks else list(breaks),
legend.args)
legend.coords<-do.call(legend.evorates,legend.call)
invisible(legend.coords)
}
}
}
#improve label handling: DONE 8/25
#' @export
pairs.evorates<-function(sim,traits=1:ncol(sim$X),
col=def.color.scheme(),val.range=NULL,res=100,
alpha=NA,breaks=NULL,colvec=NULL,lwd=1,lty=1,
lab=NULL,color.element='R',exp=FALSE,exp.txt=TRUE,...,
legend=T,legend.args=NULL){
tree<-sim$tree
if(is.null(colnames(sim$X))){
colnames(sim$X)<-paste('trait',1:ncol(sim$X))
}else{
names.lens<-nchar(colnames(sim$X))
colnames(sim$X)<-ifelse(names.lens==0,paste('trait',1:ncol(sim$X)),colnames(sim$X))
}
if(is.numeric(traits)){
traits<-colnames(sim$X)[traits]
}
#check if any trait names not available
traits.exist<-traits%in%colnames(sim$X)
if(all(!traits.exist)){
stop('none of the specified traits found')
}
if(any(!traits.exist)){
warning(paste(traits[which(!traits.exist)],collapse=', '),' not found')
traits<-traits[which(traits.exist)]
}
n<-length(tree$tip.label)
if(nrow(sim$X)==n){
#will need to be updated to handle multivariate stuff
elen<-tree$edge.length
if(!is.null(sim$R)){
if(color.element=='R'&exp){
elen<-elen*sim$R
}else{
elen<-elen*exp(sim$R)
}
}
tmp<-NULL
for(i in 1:ncol(sim$X)){
XX<-array(NA,c(1,tree$Nnode+n,1),
list(NULL,c(tree$tip.label,1:tree$Nnode+n),NULL))
PP<-XX
LL<-XX
XX[,tree$tip.label,]<-sim$X[tree$tip.label,i]
PP[,tree$tip.label,]<-Inf
LL[,tree$edge[,2],]<-elen
LL[,n+1,]<-0
tmp<-cbind(tmp,.anc.recon(tree,XX,LL,PP,FALSE)[[1]][1,,1])
}
colnames(tmp)<-traits
sim$X<-tmp
}
sim$X<-sim$X[c(tree$tip.label,n+1:tree$Nnode),,drop=F]
if(is.null(lab)){
lab<-rep(NA,length.out=length(traits))
}
lab<-rep(lab,length.out=length(traits))
lab<-ifelse(is.na(lab),traits,lab)
old.par<-par(no.readonly=T)
par(mfrow=c(length(traits),length(traits)),mar=c(0,0,0,0),oma=c(5.1,4.1,0,0),xpd=T)
for(i in 1:length(traits)){
for(j in 1:length(traits)){
if(j==1){
yaxt=NULL
args.y.mtext<-list(text=lab[i],
side=2,
line=3,
cex=0.75)
}else{
yaxt='n'
args.y.mtext<-list(NULL)
}
if(i==length(traits)){
xaxt=NULL
args.x.mtext<-list(text=lab[j],
side=1,
line=3,
cex=0.75)
}else{
xaxt='n'
args.x.mtext<-list(NULL)
}
if(i==j){
if(i==length(traits)){
plot(sim,traits=c(traits[i],traits[j]),
alpha=0,colvec=rgb(0,0,0,0),
xaxt=xaxt,yaxt=yaxt,xlab='',ylab='',...,
legend=F)
new.range<-range(sim$X[,i])
node.depths<-node.depth.edgelength(tree)
node.depths<-node.depths/max(node.depths)*diff(new.range)+min(new.range)
plot(sim,traits=traits[i],
col=col,val.range=val.range,res=res,
alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
xaxt='n',yaxt=yaxt,add=T,color.element=color.element,node.depths=node.depths,...,
legend=F)
}else{
plot(sim,traits=traits[i],
col=col,val.range=val.range,res=res,
alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
xaxt=xaxt,yaxt=yaxt,color.element=color.element,xlab='',ylab='',...,
legend=F)
}
do.call(mtext,args.x.mtext)
do.call(mtext,args.y.mtext)
}else{
plot(sim,traits=c(traits[j],traits[i]),
col=col,val.range=val.range,res=res,
alpha=alpha,breaks=breaks,colvec=colvec,lwd=lwd,lty=lty,
xaxt=xaxt,yaxt=yaxt,color.element=color.element,xlab='',ylab='',...,
legend=F)
do.call(mtext,args.x.mtext)
do.call(mtext,args.y.mtext)
}
}
}
if(legend){
par(fig=c(0,1,0,1),oma=c(5.1,4.1,0,0),mar=c(0,0,0,0),new=T)
if(is.null(legend.args$box.scale)){
legend.args$box.scale<-1
}
legend.args$box.scale<-legend.args$box.scale*0.4
if(is.null(legend.args$cex)){
legend.args$cex<-1
}
legend.args$cex<-legend.args$cex*0.8
bds<-par('usr')
bds.dims<-c(diff(bds[1:2]),diff(bds[3:4]))
if(length(legend.args$box.offset)==0){
legend.args$box.offset<-rep(NA,2)
}else if(length(legend.args$box.offset)==1){
legend.args$box.offset<-c(legend.args$box.offset,NA)
}
legend.args$box.offset<-ifelse(is.na(legend.args$box.offset),bds.dims/c(40,-20),legend.args$box.offset)
if(is.null(legend.args$xpd)){
legend.args$xpd<-T
}
legend.call<-c(sim=list(sim),color.element=color.element,exp=exp,exp.txt=exp.txt,
col=list(col),val.range=list(val.range),res=res,
alpha=if(length(alpha)==1) alpha else list(alpha),breaks=if(length(breaks)==1) breaks else list(breaks),
legend.args)
do.call(legend.evorates,
legend.call)
}
par(old.par)
}
#plot 3 to 4 numbers next to legend
#exp.txt only works for non-break legends...can't imagine why it would need to be otherwise
#' @export
legend.evorates<-function(sim,location=c('bottomleft','topleft','bottomright','topright'),color.element='R',
exp=FALSE,exp.txt=TRUE,
col=def.color.scheme(),val.range=NULL,res=100,
alpha=NA,breaks=NULL,select.levels=NULL,
box.dims=NULL,box.offset=NULL,box.scale=1,
txt.col=NULL,main=NULL,...){
if(exp){
exp.txt<-FALSE
}
try.location<-try(match.arg(location,c('bottomleft','topleft','bottomright','topright')),silent=T)
if(inherits(try.location,'try-error')){
stop(location," is not an available named position to put the legend: please specify one of the following: 'bottomleft', 'topleft', 'bottomright', or 'topright'")
}
location<-try.location
gen.args<-graphics:::.Pars
poly.args<-names(formals(polygon))
poly.args<-poly.args[-which(poly.args=='...')]
text.args<-names(formals(text.default))
text.args<-text.args[-which(text.args=='...')]
if(is.null(breaks)){
if(is.null(val.range)){
val.range<-range(sim[[color.element]],na.rm=TRUE)
}
colramp<-colorRampPalette(col,alpha=T)(res)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
}else{
colramp<-colorRampPalette(col,alpha=T)(length(breaks)+1)
colramp<-alter.cols(colramp,alpha=.lin.interp(alpha,length(colramp)))
if(is.null(select.levels)){
select.levels<-1:length(colramp)
}
select.levels<-select.levels[select.levels>=1&select.levels<=(length(breaks)+1)]
select.levels<-sort(select.levels)
colramp<-colramp[select.levels]
}
bds<-par('usr')
bds.dims<-c(diff(bds[1:2]),diff(bds[3:4]))
if(length(box.dims)==0){
box.dims<-rep(NA,2)
}else if(length(box.dims)==1){
box.dims<-c(box.dims,NA)
}
box.dims<-box.scale*ifelse(is.na(box.dims),bds.dims/c(30,5),box.dims)
if(length(box.offset)==0){
box.offset<-rep(NA,2)
}else if(length(box.offset)==1){
box.offset<-c(box.offset,NA)
}
box.offset<-ifelse(is.na(box.offset),bds.dims/c(8,20),box.offset)
x.offset<-box.offset[1]
y.offset<-box.offset[2]
if(grepl('right',location)){
x.offset<- bds.dims[1]-box.dims[1]-box.offset[1]
}
if(grepl('top',location)){
y.offset<- bds.dims[2]-box.dims[2]-box.offset[2]
}
coords<-list(x=c(0,box.dims[1],box.dims[1],0)+x.offset+bds[1],y=c(0,0,box.dims[2],box.dims[2])+y.offset+bds[3])
# box.midpt<-sapply(coords,mean)
# coords$x<-(coords$x-box.midpt[1])*box.scale+box.midpt[1]
# coords$y<-(coords$y-box.midpt[2])*box.scale+box.midpt[2]
y.int<-seq(coords$y[2],coords$y[3],length.out=length(colramp)+1)
for(i in 1:length(colramp)){
do.call(polygon,
c(x=list(coords$x),
y=list(c(y.int[i],y.int[i],y.int[i+1],y.int[i+1])),
border=NA,
col=colramp[i],
list(...)[!(names(list(...))%in%c('x','y','border','col','adj'))&
names(list(...))%in%gen.args]))
}
do.call(polygon,
c(x=list(coords$x),
y=list(coords$y),
col=NA,
list(...)[!(names(list(...))%in%c('x','y','col','adj'))&
names(list(...))%in%c(gen.args,poly.args)]))
side<-NA
if(hasArg(side)){
if(list(...)$side<=2&list(...)$side>=1){
side<-list(...)$side
}
}
if(is.na(side)){
side<-if(grepl('left',location)) 2 else 1
}
txt.args<-list(...)[!(names(list(...))%in%c('x','y','labels'))&names(list(...))%in%c(gen.args,text.args)]
if(is.null(txt.args$adj)&is.null(txt.args$pos)){
txt.args$pos<-side*2
}
if(!is.null(txt.col)){
txt.args$col<-txt.col
}
if(is.null(breaks)){
if(val.range[2]-val.range[1]==0){
labels<-val.range[1]
}else{
labels<-pretty(seq(val.range[1],val.range[2],length.out=100))
labels<-labels[2:(length(labels)-1)]
}
y.pos<-coords$y[2]+(labels-val.range[1])/
(diff(val.range))*
(coords$y[3]-coords$y[2])
if(exp.txt){
labels<-format(exp(labels),digits=1)
}
do.call(text,
c(x=coords$x[side],
y=list(y.pos),
labels=list(labels),
txt.args))
}else{
labels<-paste(signif(breaks[-length(breaks)],3),signif(breaks[-1],3),sep=' - ')
labels<-c(paste('<',signif(breaks[1],3)),labels,paste('>',signif(breaks[length(breaks)],3)))
labels<-labels[select.levels]
y.pos<-apply(cbind(y.int[-length(y.int)],y.int[-1]),1,mean)
do.call(text,
c(x=coords$x[side],
y=list(y.pos),
labels=list(labels),
txt.args))
}
if(is.null(main)){
if(color.element=='R'){
if(exp|exp.txt){
main<-expression(sigma^2)
}else{
main<-expression(ln~(sigma^2))
}
}else{
main<-substitute(color.element)
}
}
main.side<-NA
if(hasArg(main.side)){
if(list(...)$main.side<=4&list(...)$main.side>=1){
main.side<-list(...)$main.side
}
}
if(is.na(main.side)){
main.side<-if(grepl('left',location)) 2 else 4
}
main.args<-list(...)[!(names(list(...))%in%paste0('main.',c('x','y','labels','side')))&
names(list(...))%in%paste0('main.',c(gen.args,text.args))]
names(main.args)<-gsub('main.','',names(main.args))
txt.args<-txt.args[!names(txt.args)%in%c('srt','pos','adj','offset')]
txt.args[names(main.args)%in%names(txt.args)]<-main.args[names(main.args)%in%names(txt.args)]
main.args<-c(txt.args,main.args[!(names(main.args)%in%names(txt.args))])
if(is.null(main.args$adj)&is.null(main.args$pos)){
main.args$pos<-main.side
if(main.side%in%c(2,4)&is.null(main.args$srt)){
main.args$srt<-90
main.args$pos<-NULL
main.args$adj<-c(0.5,c(-0.3,1.3)[main.side/2])
}
}
if(main.side%in%c(2,4)&is.null(main.args$srt)){
main.args$srt<-90
}
if(is.null(main.args$cex)){
main.args$cex<-1
}
if(main.side%in%c(2,4)){
x.pos<-coords$x[main.side/2]
y.pos<-mean(coords$y[2:3])
if(main.side==4){
x.pos<-x.pos+bds.dims[1]/50
}else{
x.pos<-x.pos-bds.dims[1]/50
}
}else{
x.pos<-mean(coords$x[1:2])
y.pos<-coords$y[main.side/2+1.5]
if(main.side==3){
y.pos<-y.pos+bds.dims[2]/50
}else{
y.pos<-y.pos-bds.dims[2]/50
}
}
do.call(text,
as.list(c(x=x.pos,
y=y.pos,
labels=list(main),
main.args)))
invisible(coords)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.