Subversion Repositories bdplot

Rev

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