Subversion Repositories bdplot

Rev

Rev 35 | Rev 37 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
5 pdel 1 
### bdplot.R
2 
#### This is a collection of functions that must bpre reachable by the user This is called
3 
 
4 
 
5 
## strategy missing for xytype
6 
## Could we test if there is an active graphics device? And if not, run bdopen()?
7 
bdplot <- function(x, y=NULL, z=NULL,
8 
                   ## The rest is irrelevant for the user
9 
                   cex.plot=bdp()$cex.plot,
34 pdel 10 
                   xaxt=bdp()$xaxt,yaxt=bdp()$yaxt,
36 pdel 11 
                   xaxt.in=bdp()$xaxt.in,yaxt.in=bdp()$xaxt.in,
5 pdel 12 
                   xlab=bdp()$xlab, ylab=bdp()$ylab,
36 pdel 13 
                   xlim=bdp()$xlim,ylim=bdp()$ylim,
5 pdel 14 
                   col=bdp()$col,main=NULL,
15 
                   ## only used in case of plot mode
16 
                   type=bdp()$type,
17 
                   ## Only used in case of histogram plotting
18 
                   border=bdp()$border,
19 
                   ...)
20 
{
36 pdel 21 
 
22 
 
23 
  ## experimental. Is this the right consequence of not having a
24 
  ## device opened?
25 
 
26 
  if(length(dev.list())==0){
27 
    cat("No graphics device is initialised. Running bdopen() without arguments.\n")
28 
    bdopen()
29 
  }
30 
 
31 
 
32 
 
5 pdel 33 
  prm <- bdp()
34 
 
35 
 
9 pdel 36 
  par(cex.main=prm$cex.main, cex.lab=prm$cex.lab, cex.axis=prm$cex.axis)
37 
  par(tcl=prm$tcl)
38 
  par(lwd=prm$lwd)
39 
  par(bty=prm$bty)
40 
 
34 pdel 41 
 
42 
 ##Set margins
5 pdel 43 
  mar <- prm$mar.nolab
44 
  if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }
45 
  if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }
46 
  if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }
47 
  if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }
48 
  par(mar=mar)
49 
 
50 
  par(mgp=prm$mgp.global)
34 pdel 51 
 
52 
### xaxt and yaxt can be set to "axis" which is the special case where the axis is drawn with the axius
35 pdel 53 
  if(class(xaxt)=="function") {
54 
 
55 
    if(prm$debug)
56 
      print(class(x))
36 pdel 57 
 
58 
    if(is.null(xaxt.in))
59 
      xaxt.in <- x
60 
 
61 
 
35 pdel 62 
    draw.xaxis <- "fun"
63 
    xaxt.fun <- xaxt
34 pdel 64 
    xaxt <- "n"
35 pdel 65 
  } else if(xaxt=="axis"){
66 
    xaxt <- "n"
34 pdel 67 
    draw.xaxis <- TRUE
68 
  } else {
69 
    draw.xaxis <- FALSE
70 
  }
35 pdel 71 
  if(class(yaxt)=="function") {
72 
    yaxt(ifelse(is.null(yaxt.in),range(y),yaxt.in))
73 
    draw.yaxis <- FALSE
74 
  } else if(yaxt=="axis"){
34 pdel 75 
    yaxt <- "n"
76 
    draw.yaxis <- TRUE
77 
  } else {
78 
    draw.yaxis <- FALSE
79 
  }
80 
 
81 
 
32 pdel 82 
 
36 pdel 83 
### this variable needs to be initialized
84 
  addcase <- NULL
5 pdel 85 
 
86 
  ## Do the plot
87 
  if(!is.null(y)){
22 pdel 88 
 
34 pdel 89 
    if(!is.null(z)){
90 
      if(prm$debug)
91 
        cat("bdgraphics operating in image plotting mode.\nx and y axis can not be configured.\n")
92 
      image(x=x,y=y,z=z,
93 
            xlab=xlab,
94 
            ylab=ylab,
95 
            ...)
96 
    } else {
97 
      if(prm$debug)
98 
        cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")
99 
 
100 
      ## this is ugly, non standard.
101 
      if(is.null(xlim))
36 pdel 102 
        xlim <- range(x,na.rm=TRUE) #,bdp()$xlim,na.rm=TRUE)
34 pdel 103 
      if(is.null(ylim))
36 pdel 104 
        ylim <- range(y,na.rm=TRUE) #,bdp()$ylim,na.rm=TRUE)
34 pdel 105 
 
106 
      plot(x, y,
36 pdel 107 
           type="n",
34 pdel 108 
           xaxt=xaxt, yaxt=yaxt,
109 
           cex=cex.plot,
110 
           xlab=xlab,
111 
           ylab=ylab,
112 
           xlim=xlim,
113 
           ylim=ylim,
114 
           main=main,
115 
           ...)
36 pdel 116 
 
117 
      addcase <- "plotxy"
118 
 
34 pdel 119 
    }
5 pdel 120 
  } else if (is.numeric(x)){
7 pdel 121 
    if(prm$method=="barplot"){
34 pdel 122 
      if(prm$debug)
123 
        cat("The Bacher/Delff Plotting System (R), (C), TM operating in barplot mode.\n")
29 pdel 124 
      ## this does not provide the full x,y functionality of barplot
7 pdel 125 
      barplot(height=x,
126 
              ## maybe these two are wrong/stupid?
127 
              cex.axis=prm$cex.lab,
128 
              cex.names=prm$cex.lab,
129 
              col=bdp()$hcol,
130 
              border=border,
131 
              xlab=xlab,
132 
              ylab=ylab,
133 
              main=main,
134 
              ...)
34 pdel 135 
      draw.xaxis <- FALSE
136 
      draw.yaxis <- FALSE
7 pdel 137 
 
138 
    } else {
34 pdel 139 
      if(prm$debug)
140 
        cat("The Bacher/Delff Plotting System operating in xy-plotting mode, only plotting x.\n")
36 pdel 141 
 
22 pdel 142 
      if(is.null(xlim))
36 pdel 143 
        xlim <- c(1,length(x))#,bdp()$xlim),na.rm=TRUE)
34 pdel 144 
 
22 pdel 145 
      if(is.null(ylim))
36 pdel 146 
        ylim <- range(x,na.rm=TRUE)#,bdp()$ylim,na.rm=TRUE)
22 pdel 147 
 
7 pdel 148 
      plot(x,
36 pdel 149 
           type="n",
32 pdel 150 
           xaxt=xaxt, yaxt=yaxt,
7 pdel 151 
           cex=cex.plot,
152 
           xlab=xlab,
153 
           ylab=ylab,
22 pdel 154 
           xlim=xlim,
21 pdel 155 
           ylim=ylim,
7 pdel 156 
           main=main,
157 
           ...)
36 pdel 158 
      addcase <- "plotx"
7 pdel 159 
    }
5 pdel 160 
  } else if( class(x) == "acf"){
161 
    ## Not cleaned up/checked
32 pdel 162 
    plot(x, xlab="", ylab="", xaxt=xaxt, yaxt=yaxt, cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)
28 pdel 163 
  }  else if( class(x) == "histogram"){
15 pdel 164 
    ## Notice: the color of the bars can ONLY be set width bdp(hcol="color").
5 pdel 165 
    plot(x,
166 
         xlab=xlab, ylab=ylab,
167 
         main=prm$main,
32 pdel 168 
         xaxt=xaxt,yaxt=yaxt,col=bdp()$hcol,
5 pdel 169 
         border=border,
170 
         ...)
171 
  } else if( class(x) == "trellis"){
172 
    ## Not cleaned up/checked
173 
    ## very experimental
174 
    cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")
175 
    ##lattice.options(layout.widths = prm$lattice.width,
176 
    ##                layout.heights = prm$lattice.height)
177 
    trellis.par.set(prm$myLatticeSettings())
178 
    plot(x,col=col,...)
179 
    ## with lattice/trellis, the axis drawing doesn't work.
34 pdel 180 
    draw.xaxis <- FALSE
181 
    draw.yaxis <- FALSE
28 pdel 182 
  } else if (class(x)=="princomp") {
34 pdel 183 
    if(prm$debug)
184 
      cat("The Bacher/Delff Plotting System operating in princomp plotting mode.\n")
28 pdel 185 
    plot(x,
186 
         main=prm$main,
187 
         ...)
188 
  } else if (prm$method=="image.plot"){
15 pdel 189 
    ### This could be checked in the beginning by is.null(z)
34 pdel 190 
  }
7 pdel 191 
 
31 pdel 192 
###Grid stuff
193 
  ## This really hould be done before adding the rest of the plot contents.
5 pdel 194 
  ## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision
195 
 
196 
  if( prm$grid ){
197 
    grid(col=prm$grid.col)
198 
  }
199 
  ## vertical lines
200 
  if( !is.na(prm$grid.v) ){
201 
    if(prm$grid.v=="Def"){
202 
      grid(nx=NULL,ny=NA,col=prm$grid.col)
203 
    } else
204 
    {
205 
      abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)
206 
    }
207 
  }
208 
 
209 
  if( !is.na(prm$grid.h) ){
210 
    if(prm$grid.h=="Def"){
211 
      grid(nx=NA,ny=NULL,col=prm$grid.col)
212 
    }else{
213 
      abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}
214 
    }
215 
 
36 pdel 216 
### Now, grid has bee drawn. Then contents can be added.
217 
 ## add support for more cases!
218 
  if(!is.null(addcase)){
219 
    if(addcase=="plotxy") {
220 
      bdpoints(x, y,
221 
               type=type,
222 
               cex=cex.plot,
223 
               xlim=xlim,
224 
               ylim=ylim,
225 
               col=col,
226 
               ...)
227 
    } else if (addcase=="plotx"){
228 
      bdpoints(x, y,
229 
               type=type,
230 
               cex=cex.plot,
231 
               xlim=xlim,
232 
               ylim=ylim,
233 
               col=col,
234 
               ...)
235 
    }
236 
  }
237 
 
31 pdel 238 
### Axis stuff This part should be improved. A function that draws
239 
### axis should be run for all four axis. And it should be possible to
240 
### supply whatever vector to base it on (especially relevant for
241 
### taxis and raxis)
242 
 
243 
  ## this is because the use of mgp gives a ridiculous warning when too small
244 
  options(warn=-1)
35 pdel 245 
  if(draw.xaxis=="fun"){
36 pdel 246 
    xaxt.fun(xaxt.in)
35 pdel 247 
  } else if(draw.xaxis){
31 pdel 248 
    ## is the abscissa a time object?
5 pdel 249 
    if( "POSIXt"%in%class(x[1])){
250 
      axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)
251 
    } else {
252 
      axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)
253 
    }
254 
 
255 
  }
31 pdel 256 
 
34 pdel 257 
  if(draw.yaxis){ axis(2, y,mgp=prm$mgp.yaxis, lwd=prm$lwd) }
31 pdel 258 
  ## top axis
259 
  if(prm$draw.taxis){ axis(3, mgp=prm$mgp.taxis, lwd=prm$lwd) }
12 pdel 260 
  ## axis to the right
261 
  if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }
31 pdel 262 
 
263 
  ## switch back on warnings
264 
  options(warn=0)
265 
 
266 
 
5 pdel 267 
  ##Title stuff
268 
  ## Hvorfor??
269 
  scale <- 1
270 
  ##  if( prm$type=="hist" & !is.na(prm$xlab) )
271 
#  if( !is.na(prm$xlab)  ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }
272 
  ##  if( prm$type=="hist" &!is.na(prm$ylab) )
273 
#  if( !is.na(prm$ylab)  ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }
12 pdel 274 
  if( !is.na(prm$toplab) ){ mtext(prm$toplab, side=3, line=0.25, cex=prm$cex.lab/scale) }
275 
  if( !is.na(prm$rightlab) ){
276 
    mtext(prm$rightlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)
277 
##    mtext(rightlab, side=4, line=0.5, cex=bdp()$cex.lab,mgp=bdp()$mgp.raxis)
278 
  }
5 pdel 279 
}
280 
 
281 
 
282