Subversion Repositories bdplot

### 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="n",

                   yaxt="n",

                   xlab=bdp()$xlab, ylab=bdp()$ylab,

                   xlim=NULL,

                   ylim=NULL,

                   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,

                   ...)

{

  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

  if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }

  if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }

  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)

  ## if xaxt or yaxt set, axis are drawn automatically in the plot command. Then it should not be done with axis() later

  prm$draw.xaxis <- ifelse(xaxt="n",prm$draw.xaxis,FALSE)

  prm$draw.yaxis <- ifelse(yaxt="n",prm$draw.yaxis,FALSE)

  ## Do the plot

  if(!is.null(y)){

    if(prm$debug)

      cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")

    if(is.null(xlim))

      xlim <- range(x,bdp()$xlim,na.rm=TRUE)

    if(is.null(ylim))

      ylim <- range(y,bdp()$ylim,na.rm=TRUE)

    plot(x, y,

         type=type,

         xaxt=xaxt, yaxt=yaxt,

         cex=cex.plot,

         xlab=xlab,

         ylab=ylab,

         xlim=xlim,

         ylim=ylim,

         col=col,

         main=main,

         ...)

  } else if (is.numeric(x)){

    if(prm$method=="barplot"){

      ## 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,

              ...)

      prm$draw.xaxis <- FALSE

      prm$draw.yaxis <- FALSE

    } else {

      if(is.null(xlim))

        xlim <- range(c(1:length(x),bdp()$xlim),na.rm=TRUE)

      if(is.null(ylim))

        ylim <- range(x,bdp()$ylim,na.rm=TRUE)

      plot(x,

           type=type,

           xaxt=xaxt, yaxt=yaxt,

           cex=cex.plot,

           xlab=xlab,

           ylab=ylab,

           xlim=xlim,

           ylim=ylim,

           col=col,

           main=main,

           ...)

    }

  } 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.

    prm$draw.xaxis <- FALSE

    prm$draw.yaxis <- FALSE

  } else if (class(x)=="princomp") {

    plot(x,

         main=prm$main,

         ...)

  } else if (prm$method=="image.plot"){

    ### This could be checked in the beginning by is.null(z)

    cat("The Bacher/Delff Plotting System (R), (C), TM operating in image plotting mode.\nx and y axis can not be configured.\n")

    image.plot(x=x,y=y,z=z,

               xlab=xlab,

               ylab=ylab,

               ...)

  } 

###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)}

    }

### 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(prm$draw.xaxis){

    ##    mgp.old <- par()$mgp

    ##    par(mgp) <- mgp.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(prm$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$toplab) ){ mtext(prm$toplab, side=3, line=0.25, cex=prm$cex.lab/scale) }

  if( !is.na(prm$rightlab) ){

    mtext(prm$rightlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)

##    mtext(rightlab, side=4, line=0.5, cex=bdp()$cex.lab,mgp=bdp()$mgp.raxis)

  }

}