Rev 37 | Rev 43 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
### bdplot.R
#### This is a collection of functions that must bpre reachable by the user This is called
## strategy missing for xytype
## Could we test if there is an active graphics device? And if not, run bdopen()?
bdplot <- function(x, y=NULL, z=NULL,
## The rest is irrelevant for the user
cex.plot=bdp()$cex.plot,
xaxt=bdp()$xaxt,yaxt=bdp()$yaxt,
xaxt.in=bdp()$xaxt.in,yaxt.in=bdp()$xaxt.in,
xlab=bdp()$xlab, ylab=bdp()$ylab,
tlab=bdp()$tlab, rlab=bdp()$rlab,
xlim=bdp()$xlim,ylim=bdp()$ylim,
col=bdp()$col,main=NULL,
## only used in case of plot mode
type=bdp()$type,
## Only used in case of histogram plotting
border=bdp()$border,
...){
## experimental. Is this the right consequence of not having a
## device opened?
if(length(dev.list())==0){
cat("No graphics device is initialised. Running bdopen() without arguments.\n")
bdopen()
}
prm <- bdp()
par(cex.main=prm$cex.main, cex.lab=prm$cex.lab, cex.axis=prm$cex.axis)
par(tcl=prm$tcl)
par(lwd=prm$lwd)
par(bty=prm$bty)
##Set margins
mar <- prm$mar.nolab
detmar <- function(idx,lab){
if (is.null(lab)) {
mar <- prm$mar.lab[idx]
} else if(all(is.na(lab))) {
mar <- prm$mar.nolab[idx]
} else {
mar <- prm$mar.lab[idx]
}
mar
}
mar[1] <- detmar(1,xlab)
mar[2] <- detmar(2,ylab)
mar[3] <- detmar(3,tlab)
mar[4] <- detmar(4,rlab)
## if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }
## if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }
par(mar=mar)
par(mgp=prm$mgp.global)
### xaxt and yaxt can be set to "axis" which is the special case where the axis is drawn with the axius
if(class(xaxt)=="function") {
if(prm$debug)
print(class(x))
if(is.null(xaxt.in))
xaxt.in <- x
draw.xaxis <- "fun"
xaxt.fun <- xaxt
xaxt <- "n"
} else if(xaxt=="axis"){
xaxt <- "n"
draw.xaxis <- TRUE
} else {
draw.xaxis <- FALSE
}
if(class(yaxt)=="function") {
yaxt(ifelse(is.null(yaxt.in),range(y),yaxt.in))
draw.yaxis <- FALSE
} else if(yaxt=="axis"){
yaxt <- "n"
draw.yaxis <- TRUE
} else {
draw.yaxis <- FALSE
}
### this variable needs to be initialized. Why?
addcase <- NULL
## Do the plot
if(!is.null(y)){
if(!is.null(z)){
if(prm$debug)
cat("bdgraphics operating in image plotting mode.\nx and y axis can not be configured.\n")
image(x=x,y=y,z=z,
xlab=xlab,
ylab=ylab,
...)
} else {
if(prm$debug)
cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")
## this is ugly, non standard.
if(is.null(xlim))
xlim <- range(x,na.rm=TRUE) #,bdp()$xlim,na.rm=TRUE)
if(is.null(ylim))
ylim <- range(y,na.rm=TRUE) #,bdp()$ylim,na.rm=TRUE)
plot(x, y,
type="n",
xaxt=xaxt, yaxt=yaxt,
cex=cex.plot,
xlab=xlab,
ylab=ylab,
xlim=xlim,
ylim=ylim,
main=main,
...)
addcase <- "plotxy"
}
} else if (is.numeric(x)){
if(prm$method=="barplot"){
if(prm$debug)
cat("The Bacher/Delff Plotting System (R), (C), TM operating in barplot mode.\n")
## this does not provide the full x,y functionality of barplot
barplot(height=x,
## maybe these two are wrong/stupid?
cex.axis=prm$cex.lab,
cex.names=prm$cex.lab,
col=bdp()$hcol,
border=border,
xlab=xlab,
ylab=ylab,
main=main,
...)
draw.xaxis <- FALSE
draw.yaxis <- FALSE
} else {
if(prm$debug)
cat("The Bacher/Delff Plotting System operating in xy-plotting mode, only plotting x.\n")
if(is.null(xlim))
xlim <- c(1,length(x))#,bdp()$xlim),na.rm=TRUE)
if(is.null(ylim))
ylim <- range(x,na.rm=TRUE)#,bdp()$ylim,na.rm=TRUE)
plot(x,
type="n",
xaxt=xaxt, yaxt=yaxt,
cex=cex.plot,
xlab=xlab,
ylab=ylab,
xlim=xlim,
ylim=ylim,
main=main,
...)
addcase <- "plotx"
}
} else if( class(x) == "acf"){
## Not cleaned up/checked
plot(x, xlab="", ylab="", xaxt=xaxt, yaxt=yaxt, cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)
} else if( class(x) == "histogram"){
## Notice: the color of the bars can ONLY be set width bdp(hcol="color").
plot(x,
xlab=xlab, ylab=ylab,
main=prm$main,
xaxt=xaxt,yaxt=yaxt,col=bdp()$hcol,
border=border,
...)
} else if( class(x) == "trellis"){
## Not cleaned up/checked
## very experimental
cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")
##lattice.options(layout.widths = prm$lattice.width,
## layout.heights = prm$lattice.height)
trellis.par.set(prm$myLatticeSettings())
plot(x,col=col,...)
## with lattice/trellis, the axis drawing doesn't work.
draw.xaxis <- FALSE
draw.yaxis <- FALSE
} else if (class(x)=="princomp") {
if(prm$debug)
cat("The Bacher/Delff Plotting System operating in princomp plotting mode.\n")
plot(x,
main=prm$main,
...)
} else if (prm$method=="image.plot"){
### This could be checked in the beginning by is.null(z)
}
###Grid stuff
## This really hould be done before adding the rest of the plot contents.
## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision
if( prm$grid ){
grid(col=prm$grid.col)
}
## vertical lines
if( !is.na(prm$grid.v) ){
if(prm$grid.v=="Def"){
grid(nx=NULL,ny=NA,col=prm$grid.col)
} else
{
abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)
}
}
if( !is.na(prm$grid.h) ){
if(prm$grid.h=="Def"){
grid(nx=NA,ny=NULL,col=prm$grid.col)
}else{
abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}
}
### Now, grid has bee drawn. Then contents can be added.
## add support for more cases!
if(!is.null(addcase)){
if(addcase=="plotxy") {
bdpoints(x, y,
type=type,
cex=cex.plot,
xlim=xlim,
ylim=ylim,
col=col,
...)
} else if (addcase=="plotx"){
bdpoints(x, y,
type=type,
cex=cex.plot,
xlim=xlim,
ylim=ylim,
col=col,
...)
}
}
### Axis stuff This part should be improved. A function that draws
### axis should be run for all four axis. And it should be possible to
### supply whatever vector to base it on (especially relevant for
### taxis and raxis)
## this is because the use of mgp gives a ridiculous warning when too small
options(warn=-1)
if(draw.xaxis=="fun"){
xaxt.fun(xaxt.in)
} else if(draw.xaxis){
## is the abscissa a time object?
if( "POSIXt"%in%class(x[1])){
axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)
} else {
axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)
}
}
if(draw.yaxis){ axis(2, y,mgp=prm$mgp.yaxis, lwd=prm$lwd) }
## top axis
if(prm$draw.taxis){ axis(3, mgp=prm$mgp.taxis, lwd=prm$lwd) }
## axis to the right
if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }
## switch back on warnings
options(warn=0)
##Title stuff
## Hvorfor??
scale <- 1
## if( prm$type=="hist" & !is.na(prm$xlab) )
# if( !is.na(prm$xlab) ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }
## if( prm$type=="hist" &!is.na(prm$ylab) )
# if( !is.na(prm$ylab) ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }
if( !is.na(prm$tlab) ){ mtext(prm$tlab, side=3, line=0.25, cex=prm$cex.lab/scale) }
if( !is.na(prm$rlab) ){
mtext(prm$rlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)
}
}