Subversion Repositories bdplot

Rev

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