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