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,

                   cex.main=bdp()$cex.main,

                   cex.sub=bdp()$cex.sub,

                   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,

                   ...){

## set this to TRUE if something is returned. eg, happens in barplot 

  ret <- FALSE

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

  }

## we'd like to be able to setup the plotting device from different functions. It's better to use bdp() to handle values then.

  bdp(xlab=xlab,ylab=ylab,rlab=rlab,tlab=tlab,

      cex.plot=cex.plot)

  prm <- bdp()

############# init starts - to be put in seperate function?

## It's a mess to set cex.lab here. Or it should not be set in

##  functions calls. If set both ways, it's scaled twice, meaning that

##  we don't know how to make it fit with mtext for eg rlab.

  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. If mar is set, then that should be used.

  if (!is.null(prm$mar)){

    print(prm$mar)

    mar <- prm$mar

  } else {

    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]

      }

      return(mar)

    }

##    browser()

    mar <- c(detmar(1,xlab),

             detmar(2,ylab),

             detmar(3,tlab)+ifelse(is.null(main),0,prm$mar.main),

             detmar(4,rlab))

##    print(length(mar))

##    print(mar)    

  }

  par(mar=mar)

  par(mgp=prm$mgp.global)

########### init done

### xaxt and yaxt can be set to "axis" which is the special case where the axis is drawn with the axis

  if(class(xaxt)=="function") {

    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)

      xlabel <- if (!missing(x)) 

        deparse(substitute(x))

      ylabel <- if (!missing(y)) 

        deparse(substitute(y))

      ##       xy <- xy.coords(x, y, xlabel, ylabel, log)

      xlab <- ifelse(is.null(xlab), xlabel, xlab)

      ylab <- ifelse(is.null(ylab), ylabel, ylab)

      ## here we make the empty plot

      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

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

                        ylim=ylim,

                        main=main,

                        ...)

      ret <- TRUE

      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").

    if(prm$debug) {browser()}

    if(is.null(freq)){

    freq=TRUE}

    if(is.null(xlim)){

      xlim <- range(x$breaks)

    }

    plot(x,

         xlab=xlab,ylab=ylab,

         main=main,freq=freq,

         xlim=xlim,

         ylim=ylim,

         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=main,

         ...)

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

    print("lm mode. This is experimental, mar and oma are set to fixed values.")

    par(mar=c(2,2,2,.3))

    par(oma = c(0, 0, 0, 0))

    par(cex=bdp()$cex.plot)

    ### cex.caption is the title over each plot, cex.id magnification of point labels. What is eg "Cook's distance" written inside the plots?

    plot.lm(x,cex.caption=cex.sub,cex.id=.5)##,cex=cex.plot)

  }  else if (class(x)=="data.frame") {

    print("data.frame mode")

    plot(x,main=main,

         xaxt=xaxt,yaxt=yaxt)

  }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( any(!is.na(prm$grid.v)) ){

    if(prm$grid.v[1]=="Def"){

      grid(nx=NULL,ny=NA,col=prm$grid.col)

    } else

    {

      abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)

    }

  }

  if( any(!is.na(prm$grid.h)) ){

    if(prm$grid.h[1]=="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.1

  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)

  }

  if(ret){

    invisible(ret)

  }

}