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=range(x,bdp()$xlim,na.rm=TRUE),

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

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

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

  ## the method variable could be used more intelligently. If x is numeric, only three methods are possible: plot, barplot, image.plot.

    ## maybe this check can be skipped. I guess x and y can just be deleted from these commands  

 ## if( prm$method=="xy"){

  if(!is.null(y)){

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

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

    plot(x,

         type=type,

         xaxt="n", yaxt="n",

         cex=cex.plot,

         xlab=xlab,

         ylab=ylab,

         ylim=xlim,

         col=col,

         main=main,

         ...)

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

    barplot(height=x,

            ## maybe these two are wrong/stupid?

            cex.axis=prm$cex.lab,

            cex.names=prm$cex.lab,

            xlab=xlab,

            ylab=ylab,

            col=col,

            main=main,

            ...)

    prm$draw.xaxis <- FALSE

    prm$draw.yaxis <- FALSE

  } 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 with 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"){

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

  ##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$xxlab, side=3, line=0.25, cex=prm$cex.lab/scale) }

  if( !is.na(prm$rightlab) ){ mtext(prm$yylab, side=4, line=0.25, cex=prm$cex.lab/scale) }

}

## a function to add points or lines to a plot. det kan skrives meget

## paenere, om en streng indeholder en karakter.

## grep("l",type)

bdxyadd <- function(x,y=NULL,type=bdp()$type,lwd=bdp()$lwd,pch=bdp()$pch,col=bdp()$col,...){

  prm <- .bdgetpars()

  if(any(type=="p",type=="l",type=="s")){

    if(!is.null(y)){

      points(x,y,cex=prm$cex.plot,pch=prm$pch,type=type,col=col,...)

    } else {

      points(x,cex=prm$cex.plot,pch=prm$pch,col=col,type=type,...)

    }

  } else if (type=="lp"|type=="pl"){

    if(!is.null(y)){

      points(x,y,cex=prm$cex.plot,pch=prm$pch,col=col,...)

      lines(x,y,lwd=lwd,col=col,...)

    } else {

      points(x,cex=prm$cex.plot,pch=prm$pch,col=col,...)

      lines(x,lwd=lwd,col=col,...)

    }

  }

}

bdlegend <- function(legend,cex=bdp()$cex.legend,x=bdp()$pos.legend,bg=bdp()$bg.legend,col=bdp()$col,...){

  prm <- .bdgetpars()

  ## dette er noget rod med baade x og pos, hvis man giver begge dele fucker det op.

  legend(x=x,

         cex=cex,

         legend=legend,

         bg=bg,

         col=col,

         ...)

}