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=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,freq=NULL,

                   ...){

  ## 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). What about colors?

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

  }

}