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

                   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)

  ## Do the plot

  if(!is.null(y)){

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

         cex=cex.plot,

         xlab=xlab,

         ylab=ylab,

         xlim=xlim,

         ylim=ylim,

         col=col,

         main=main,

         ...)

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

    if(prm$method=="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="n", yaxt="n",

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

               ...)

  }

  ## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision

  ##Grid stuff

  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

  if(prm$draw.xaxis){

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

    ##    par(mgp) <- mgp.xaxis

    options(warn=-1)

    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)

    }

    options(warn=0)

  }

  if(prm$draw.yaxis){ axis(2, mgp=prm$mgp.yaxis, lwd=prm$lwd) }

  ## axis to the right

  if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }

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

  }

}