Subversion Repositories bdplot

Rev

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