Subversion Repositories bdplot

Rev

Rev 31 | Rev 33 | Go to most recent revision | Only display areas with differences | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 31 Rev 32
1
### bdplot.R
1
### bdplot.R
2
#### This is a collection of functions that must bpre reachable by the user This is called 
2
#### This is a collection of functions that must bpre reachable by the user This is called 
3
 
3
 
4
 
4
 
5
 
5
 
6
## strategy missing for xytype
6
## strategy missing for xytype
7
## Could we test if there is an active graphics device? And if not, run bdopen()?
7
## Could we test if there is an active graphics device? And if not, run bdopen()?
8
bdplot <- function(x, y=NULL, z=NULL,
8
bdplot <- function(x, y=NULL, z=NULL,
9
                   ## The rest is irrelevant for the user
9
                   ## The rest is irrelevant for the user
10
                   cex.plot=bdp()$cex.plot,
10
                   cex.plot=bdp()$cex.plot,
11
                   xaxt="n",
11
                   xaxt="n",
-
 
12
                   yaxt="n",
12
                   xlab=bdp()$xlab, ylab=bdp()$ylab,
13
                   xlab=bdp()$xlab, ylab=bdp()$ylab,
13
                   xlim=NULL,
14
                   xlim=NULL,
14
                   ylim=NULL,
15
                   ylim=NULL,
15
                   col=bdp()$col,main=NULL,
16
                   col=bdp()$col,main=NULL,
16
                   ## only used in case of plot mode
17
                   ## only used in case of plot mode
17
                   type=bdp()$type,
18
                   type=bdp()$type,
18
                   ## Only used in case of histogram plotting
19
                   ## Only used in case of histogram plotting
19
                   border=bdp()$border,
20
                   border=bdp()$border,
20
                   ...)
21
                   ...)
21
{
22
{
22
  prm <- bdp()
23
  prm <- bdp()
23
 
24
 
24
 
25
 
25
  par(cex.main=prm$cex.main, cex.lab=prm$cex.lab, cex.axis=prm$cex.axis)
26
  par(cex.main=prm$cex.main, cex.lab=prm$cex.lab, cex.axis=prm$cex.axis)
26
  par(tcl=prm$tcl)
27
  par(tcl=prm$tcl)
27
  par(lwd=prm$lwd)
28
  par(lwd=prm$lwd)
28
  par(bty=prm$bty)
29
  par(bty=prm$bty)
29
 
30
 
30
  
31
  
31
  ##Set margins
32
  ##Set margins
32
  mar <- prm$mar.nolab
33
  mar <- prm$mar.nolab
33
  if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }
34
  if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }
34
  if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }
35
  if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }
35
  if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }
36
  if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }
36
  if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }
37
  if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }
37
  par(mar=mar)
38
  par(mar=mar)
38
 
39
 
39
  par(mgp=prm$mgp.global)
40
  par(mgp=prm$mgp.global)
-
 
41
 
-
 
42
  ## if xaxt or yaxt set, axis are drawn automatically in the plot command. Then it should not be done with axis() later
-
 
43
  prm$draw.xaxis <- ifelse(xaxt="n",prm$draw.xaxis,FALSE)
-
 
44
  prm$draw.yaxis <- ifelse(yaxt="n",prm$draw.yaxis,FALSE)
40
  
45
  
41
  ## Do the plot
46
  ## Do the plot
42
  if(!is.null(y)){
47
  if(!is.null(y)){
-
 
48
    if(prm$debug)
43
    ##       cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")
49
      cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")
44
 
50
 
45
    if(is.null(xlim))
51
    if(is.null(xlim))
46
      xlim <- range(x,bdp()$xlim,na.rm=TRUE)
52
      xlim <- range(x,bdp()$xlim,na.rm=TRUE)
47
    if(is.null(ylim))
53
    if(is.null(ylim))
48
      ylim <- range(y,bdp()$ylim,na.rm=TRUE)
54
      ylim <- range(y,bdp()$ylim,na.rm=TRUE)
49
    
55
    
50
    plot(x, y,
56
    plot(x, y,
51
         type=type,
57
         type=type,
52
         xaxt=xaxt, yaxt="n",
58
         xaxt=xaxt, yaxt=yaxt,
53
         cex=cex.plot,
59
         cex=cex.plot,
54
         xlab=xlab,
60
         xlab=xlab,
55
         ylab=ylab,
61
         ylab=ylab,
56
         xlim=xlim,
62
         xlim=xlim,
57
         ylim=ylim,
63
         ylim=ylim,
58
         col=col,
64
         col=col,
59
         main=main,
65
         main=main,
60
         ...)
66
         ...)
61
  } else if (is.numeric(x)){
67
  } else if (is.numeric(x)){
62
    if(prm$method=="barplot"){
68
    if(prm$method=="barplot"){
63
      ## this does not provide the full x,y functionality of barplot
69
      ## this does not provide the full x,y functionality of barplot
64
      barplot(height=x,
70
      barplot(height=x,
65
              ## maybe these two are wrong/stupid?
71
              ## maybe these two are wrong/stupid?
66
              cex.axis=prm$cex.lab,
72
              cex.axis=prm$cex.lab,
67
              cex.names=prm$cex.lab,
73
              cex.names=prm$cex.lab,
68
              col=bdp()$hcol,
74
              col=bdp()$hcol,
69
              border=border,
75
              border=border,
70
              xlab=xlab,
76
              xlab=xlab,
71
              ylab=ylab,
77
              ylab=ylab,
72
              main=main,
78
              main=main,
73
              ...)
79
              ...)
74
      prm$draw.xaxis <- FALSE
80
      prm$draw.xaxis <- FALSE
75
      prm$draw.yaxis <- FALSE
81
      prm$draw.yaxis <- FALSE
76
      
82
      
77
    } else {
83
    } else {
78
 
84
 
79
      if(is.null(xlim))
85
      if(is.null(xlim))
80
        xlim <- range(c(1:length(x),bdp()$xlim),na.rm=TRUE)
86
        xlim <- range(c(1:length(x),bdp()$xlim),na.rm=TRUE)
81
 
87
 
82
      if(is.null(ylim))
88
      if(is.null(ylim))
83
        ylim <- range(x,bdp()$ylim,na.rm=TRUE)
89
        ylim <- range(x,bdp()$ylim,na.rm=TRUE)
84
      
90
      
85
      plot(x,
91
      plot(x,
86
           type=type,
92
           type=type,
87
           xaxt="n", yaxt="n",
93
           xaxt=xaxt, yaxt=yaxt,
88
           cex=cex.plot,
94
           cex=cex.plot,
89
           xlab=xlab,
95
           xlab=xlab,
90
           ylab=ylab,
96
           ylab=ylab,
91
           xlim=xlim,
97
           xlim=xlim,
92
           ylim=ylim,
98
           ylim=ylim,
93
           col=col,
99
           col=col,
94
           main=main,
100
           main=main,
95
           ...)
101
           ...)
96
    }
102
    }
97
  } else if( class(x) == "acf"){
103
  } else if( class(x) == "acf"){
98
    ## Not cleaned up/checked
104
    ## Not cleaned up/checked
99
    plot(x, xlab="", ylab="", xaxt="n", yaxt="n", cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)
105
    plot(x, xlab="", ylab="", xaxt=xaxt, yaxt=yaxt, cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)
100
  }  else if( class(x) == "histogram"){
106
  }  else if( class(x) == "histogram"){
101
    ## Notice: the color of the bars can ONLY be set width bdp(hcol="color").
107
    ## Notice: the color of the bars can ONLY be set width bdp(hcol="color").
102
    plot(x,
108
    plot(x,
103
         xlab=xlab, ylab=ylab,
109
         xlab=xlab, ylab=ylab,
104
         main=prm$main,
110
         main=prm$main,
105
         xaxt="n",yaxt="n",col=bdp()$hcol,
111
         xaxt=xaxt,yaxt=yaxt,col=bdp()$hcol,
106
         border=border,
112
         border=border,
107
         ...)
113
         ...)
108
  } else if( class(x) == "trellis"){
114
  } else if( class(x) == "trellis"){
109
    ## Not cleaned up/checked
115
    ## Not cleaned up/checked
110
    ## very experimental
116
    ## very experimental
111
    cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")
117
    cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")
112
    ##lattice.options(layout.widths = prm$lattice.width,
118
    ##lattice.options(layout.widths = prm$lattice.width,
113
    ##                layout.heights = prm$lattice.height)
119
    ##                layout.heights = prm$lattice.height)
114
    trellis.par.set(prm$myLatticeSettings()) 
120
    trellis.par.set(prm$myLatticeSettings()) 
115
    plot(x,col=col,...)
121
    plot(x,col=col,...)
116
    ## with lattice/trellis, the axis drawing doesn't work.
122
    ## with lattice/trellis, the axis drawing doesn't work.
117
    prm$draw.xaxis <- FALSE
123
    prm$draw.xaxis <- FALSE
118
    prm$draw.yaxis <- FALSE
124
    prm$draw.yaxis <- FALSE
119
  } else if (class(x)=="princomp") {
125
  } else if (class(x)=="princomp") {
120
    plot(x,
126
    plot(x,
121
         main=prm$main,
127
         main=prm$main,
122
         ...)
128
         ...)
123
  } else if (prm$method=="image.plot"){
129
  } else if (prm$method=="image.plot"){
124
    ### This could be checked in the beginning by is.null(z)
130
    ### This could be checked in the beginning by is.null(z)
125
    cat("The Bacher/Delff Plotting System (R), (C), TM operating in image plotting mode.\nx and y axis can not be configured.\n")
131
    cat("The Bacher/Delff Plotting System (R), (C), TM operating in image plotting mode.\nx and y axis can not be configured.\n")
126
    image.plot(x=x,y=y,z=z,
132
    image.plot(x=x,y=y,z=z,
127
               xlab=xlab,
133
               xlab=xlab,
128
               ylab=ylab,
134
               ylab=ylab,
129
               ...)
135
               ...)
130
  } 
136
  } 
131
  
137
  
132
###Grid stuff
138
###Grid stuff
133
  ## This really hould be done before adding the rest of the plot contents.
139
  ## This really hould be done before adding the rest of the plot contents.
134
  ## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision
140
  ## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision
135
  
141
  
136
  if( prm$grid ){
142
  if( prm$grid ){
137
    grid(col=prm$grid.col)
143
    grid(col=prm$grid.col)
138
  }
144
  }
139
  ## vertical lines
145
  ## vertical lines
140
  if( !is.na(prm$grid.v) ){
146
  if( !is.na(prm$grid.v) ){
141
    if(prm$grid.v=="Def"){
147
    if(prm$grid.v=="Def"){
142
      grid(nx=NULL,ny=NA,col=prm$grid.col)
148
      grid(nx=NULL,ny=NA,col=prm$grid.col)
143
    } else
149
    } else
144
    {
150
    {
145
      abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)
151
      abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)
146
    }
152
    }
147
  }
153
  }
148
 
154
 
149
  if( !is.na(prm$grid.h) ){
155
  if( !is.na(prm$grid.h) ){
150
    if(prm$grid.h=="Def"){
156
    if(prm$grid.h=="Def"){
151
      grid(nx=NA,ny=NULL,col=prm$grid.col)
157
      grid(nx=NA,ny=NULL,col=prm$grid.col)
152
    }else{
158
    }else{
153
      abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}
159
      abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}
154
    }
160
    }
155
 
161
 
156
### Axis stuff This part should be improved. A function that draws
162
### Axis stuff This part should be improved. A function that draws
157
### axis should be run for all four axis. And it should be possible to
163
### axis should be run for all four axis. And it should be possible to
158
### supply whatever vector to base it on (especially relevant for
164
### supply whatever vector to base it on (especially relevant for
159
### taxis and raxis)
165
### taxis and raxis)
160
  
166
  
161
  ## this is because the use of mgp gives a ridiculous warning when too small
167
  ## this is because the use of mgp gives a ridiculous warning when too small
162
  options(warn=-1)
168
  options(warn=-1)
163
  if(prm$draw.xaxis){
169
  if(prm$draw.xaxis){
164
    ##    mgp.old <- par()$mgp
170
    ##    mgp.old <- par()$mgp
165
    ##    par(mgp) <- mgp.xaxis
171
    ##    par(mgp) <- mgp.xaxis
166
    ## is the abscissa a time object?
172
    ## is the abscissa a time object?
167
    if( "POSIXt"%in%class(x[1])){
173
    if( "POSIXt"%in%class(x[1])){
168
      axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)
174
      axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)
169
    } else {
175
    } else {
170
      axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)
176
      axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)
171
    }
177
    }
172
    
178
    
173
  }
179
  }
174
 
180
 
175
  if(prm$draw.yaxis){ axis(2, y,mgp=prm$mgp.yaxis, lwd=prm$lwd) }
181
  if(prm$draw.yaxis){ axis(2, y,mgp=prm$mgp.yaxis, lwd=prm$lwd) }
176
  ## top axis
182
  ## top axis
177
  if(prm$draw.taxis){ axis(3, mgp=prm$mgp.taxis, lwd=prm$lwd) }
183
  if(prm$draw.taxis){ axis(3, mgp=prm$mgp.taxis, lwd=prm$lwd) }
178
  ## axis to the right
184
  ## axis to the right
179
  if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }
185
  if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }
180
 
186
 
181
  ## switch back on warnings
187
  ## switch back on warnings
182
  options(warn=0)
188
  options(warn=0)
183
 
189
 
184
 
190
 
185
  ##Title stuff
191
  ##Title stuff
186
  ## Hvorfor??
192
  ## Hvorfor??
187
  scale <- 1
193
  scale <- 1
188
  ##  if( prm$type=="hist" & !is.na(prm$xlab) )
194
  ##  if( prm$type=="hist" & !is.na(prm$xlab) )
189
#  if( !is.na(prm$xlab)  ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }
195
#  if( !is.na(prm$xlab)  ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }
190
  ##  if( prm$type=="hist" &!is.na(prm$ylab) )
196
  ##  if( prm$type=="hist" &!is.na(prm$ylab) )
191
#  if( !is.na(prm$ylab)  ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }
197
#  if( !is.na(prm$ylab)  ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }
192
  if( !is.na(prm$toplab) ){ mtext(prm$toplab, side=3, line=0.25, cex=prm$cex.lab/scale) }
198
  if( !is.na(prm$toplab) ){ mtext(prm$toplab, side=3, line=0.25, cex=prm$cex.lab/scale) }
193
  if( !is.na(prm$rightlab) ){
199
  if( !is.na(prm$rightlab) ){
194
    mtext(prm$rightlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)
200
    mtext(prm$rightlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)
195
##    mtext(rightlab, side=4, line=0.5, cex=bdp()$cex.lab,mgp=bdp()$mgp.raxis)
201
##    mtext(rightlab, side=4, line=0.5, cex=bdp()$cex.lab,mgp=bdp()$mgp.raxis)
196
  }
202
  }
197
}
203
}
198
 
204
 
199
 
205
 
200
 
206
 
201
 
207