| 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,
|
|
|
13 |
xlim=range(x,bdp()$xlim,na.rm=TRUE),
|
|
|
14 |
ylim=range(bdp()$ylim,y,na.rm=TRUE),
|
|
|
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 |
|
|
|
25 |
##Set margins
|
|
|
26 |
mar <- prm$mar.nolab
|
|
|
27 |
if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }
|
|
|
28 |
if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }
|
|
|
29 |
if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }
|
|
|
30 |
if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }
|
|
|
31 |
par(mar=mar)
|
|
|
32 |
|
|
|
33 |
par(mgp=prm$mgp.global)
|
|
|
34 |
|
|
|
35 |
## Do the plot
|
|
|
36 |
## the method variable could be used more intelligently. If x is numeric, only three methods are possible: plot, barplot, image.plot.
|
|
|
37 |
## maybe this check can be skipped. I guess x and y can just be deleted from these commands
|
|
|
38 |
## if( prm$method=="xy"){
|
|
|
39 |
|
|
|
40 |
if(!is.null(y)){
|
|
|
41 |
## cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")
|
|
|
42 |
|
|
|
43 |
plot(x, y,
|
|
|
44 |
type=type,
|
|
|
45 |
xaxt=xaxt, yaxt="n",
|
|
|
46 |
cex=cex.plot,
|
|
|
47 |
xlab=xlab,
|
|
|
48 |
ylab=ylab,
|
|
|
49 |
xlim=xlim,
|
|
|
50 |
ylim=ylim,
|
|
|
51 |
col=col,
|
|
|
52 |
main=main,
|
|
|
53 |
...)
|
|
|
54 |
} else if (is.numeric(x)){
|
| 7 |
pdel |
55 |
if(prm$method=="barplot"){
|
|
|
56 |
barplot(height=x,
|
|
|
57 |
## maybe these two are wrong/stupid?
|
|
|
58 |
cex.axis=prm$cex.lab,
|
|
|
59 |
cex.names=prm$cex.lab,
|
|
|
60 |
col=bdp()$hcol,
|
|
|
61 |
border=border,
|
|
|
62 |
xlab=xlab,
|
|
|
63 |
ylab=ylab,
|
|
|
64 |
main=main,
|
|
|
65 |
...)
|
|
|
66 |
prm$draw.xaxis <- FALSE
|
|
|
67 |
prm$draw.yaxis <- FALSE
|
|
|
68 |
|
|
|
69 |
} else {
|
|
|
70 |
plot(x,
|
|
|
71 |
type=type,
|
|
|
72 |
xaxt="n", yaxt="n",
|
|
|
73 |
cex=cex.plot,
|
|
|
74 |
xlab=xlab,
|
|
|
75 |
ylab=ylab,
|
|
|
76 |
ylim=xlim,
|
|
|
77 |
col=col,
|
|
|
78 |
main=main,
|
|
|
79 |
...)
|
|
|
80 |
}
|
| 5 |
pdel |
81 |
} else if( class(x) == "acf"){
|
|
|
82 |
## Not cleaned up/checked
|
|
|
83 |
plot(x, xlab="", ylab="", xaxt="n", yaxt="n", cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)
|
|
|
84 |
}
|
|
|
85 |
else if( class(x) == "histogram"){
|
|
|
86 |
## Notice: the color of the bars can ONLY be set with bdp(hcol="color").
|
|
|
87 |
plot(x,
|
|
|
88 |
xlab=xlab, ylab=ylab,
|
|
|
89 |
main=prm$main,
|
|
|
90 |
xaxt="n",yaxt="n",col=bdp()$hcol,
|
|
|
91 |
border=border,
|
|
|
92 |
...)
|
|
|
93 |
} else if( class(x) == "trellis"){
|
|
|
94 |
## Not cleaned up/checked
|
|
|
95 |
## very experimental
|
|
|
96 |
cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")
|
|
|
97 |
##lattice.options(layout.widths = prm$lattice.width,
|
|
|
98 |
## layout.heights = prm$lattice.height)
|
|
|
99 |
trellis.par.set(prm$myLatticeSettings())
|
|
|
100 |
plot(x,col=col,...)
|
|
|
101 |
## with lattice/trellis, the axis drawing doesn't work.
|
|
|
102 |
prm$draw.xaxis <- FALSE
|
|
|
103 |
prm$draw.yaxis <- FALSE
|
|
|
104 |
}
|
|
|
105 |
else if (prm$method=="image.plot"){
|
|
|
106 |
cat("The Bacher/Delff Plotting System (R), (C), TM operating in image plotting mode.\nx and y axis can not be configured.\n")
|
|
|
107 |
image.plot(x=x,y=y,z=z,
|
|
|
108 |
xlab=xlab,
|
|
|
109 |
ylab=ylab,
|
|
|
110 |
...)
|
|
|
111 |
}
|
| 7 |
pdel |
112 |
|
| 5 |
pdel |
113 |
## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision
|
|
|
114 |
|
|
|
115 |
##Grid stuff
|
|
|
116 |
if( prm$grid ){
|
|
|
117 |
grid(col=prm$grid.col)
|
|
|
118 |
}
|
|
|
119 |
## vertical lines
|
|
|
120 |
if( !is.na(prm$grid.v) ){
|
|
|
121 |
if(prm$grid.v=="Def"){
|
|
|
122 |
grid(nx=NULL,ny=NA,col=prm$grid.col)
|
|
|
123 |
} else
|
|
|
124 |
{
|
|
|
125 |
abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)
|
|
|
126 |
}
|
|
|
127 |
}
|
|
|
128 |
|
|
|
129 |
if( !is.na(prm$grid.h) ){
|
|
|
130 |
if(prm$grid.h=="Def"){
|
|
|
131 |
grid(nx=NA,ny=NULL,col=prm$grid.col)
|
|
|
132 |
}else{
|
|
|
133 |
abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}
|
|
|
134 |
}
|
|
|
135 |
|
|
|
136 |
## Axis stuff
|
|
|
137 |
if(prm$draw.xaxis){
|
|
|
138 |
## mgp.old <- par()$mgp
|
|
|
139 |
## par(mgp) <- mgp.xaxis
|
|
|
140 |
options(warn=-1)
|
|
|
141 |
if( "POSIXt"%in%class(x[1])){
|
|
|
142 |
axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)
|
|
|
143 |
} else {
|
|
|
144 |
axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)
|
|
|
145 |
}
|
|
|
146 |
options(warn=0)
|
|
|
147 |
|
|
|
148 |
}
|
|
|
149 |
if(prm$draw.yaxis){ axis(2, mgp=prm$mgp.yaxis, lwd=prm$lwd) }
|
|
|
150 |
|
|
|
151 |
##Title stuff
|
|
|
152 |
## Hvorfor??
|
|
|
153 |
scale <- 1
|
|
|
154 |
## if( prm$type=="hist" & !is.na(prm$xlab) )
|
|
|
155 |
# if( !is.na(prm$xlab) ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }
|
|
|
156 |
## if( prm$type=="hist" &!is.na(prm$ylab) )
|
|
|
157 |
# if( !is.na(prm$ylab) ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }
|
|
|
158 |
if( !is.na(prm$toplab) ){ mtext(prm$xxlab, side=3, line=0.25, cex=prm$cex.lab/scale) }
|
|
|
159 |
if( !is.na(prm$rightlab) ){ mtext(prm$yylab, side=4, line=0.25, cex=prm$cex.lab/scale) }
|
|
|
160 |
}
|
|
|
161 |
|
|
|
162 |
|
|
|
163 |
## a function to add points or lines to a plot. det kan skrives meget
|
|
|
164 |
## paenere, om en streng indeholder en karakter.
|
|
|
165 |
|
|
|
166 |
## grep("l",type)
|
|
|
167 |
|
|
|
168 |
bdxyadd <- function(x,y=NULL,type=bdp()$type,lwd=bdp()$lwd,pch=bdp()$pch,col=bdp()$col,...){
|
|
|
169 |
|
|
|
170 |
prm <- .bdgetpars()
|
|
|
171 |
|
|
|
172 |
if(any(type=="p",type=="l",type=="s")){
|
|
|
173 |
if(!is.null(y)){
|
|
|
174 |
points(x,y,cex=prm$cex.plot,pch=prm$pch,type=type,col=col,...)
|
|
|
175 |
} else {
|
|
|
176 |
points(x,cex=prm$cex.plot,pch=prm$pch,col=col,type=type,...)
|
|
|
177 |
}
|
|
|
178 |
} else if (type=="lp"|type=="pl"){
|
|
|
179 |
if(!is.null(y)){
|
|
|
180 |
points(x,y,cex=prm$cex.plot,pch=prm$pch,col=col,...)
|
|
|
181 |
lines(x,y,lwd=lwd,col=col,...)
|
|
|
182 |
} else {
|
|
|
183 |
points(x,cex=prm$cex.plot,pch=prm$pch,col=col,...)
|
|
|
184 |
lines(x,lwd=lwd,col=col,...)
|
|
|
185 |
}
|
|
|
186 |
}
|
|
|
187 |
}
|
|
|
188 |
|
|
|
189 |
|
|
|
190 |
bdlegend <- function(legend,cex=bdp()$cex.legend,x=bdp()$pos.legend,bg=bdp()$bg.legend,col=bdp()$col,...){
|
|
|
191 |
prm <- .bdgetpars()
|
|
|
192 |
## dette er noget rod med baade x og pos, hvis man giver begge dele fucker det op.
|
|
|
193 |
legend(x=x,
|
|
|
194 |
cex=cex,
|
|
|
195 |
legend=legend,
|
|
|
196 |
bg=bg,
|
|
|
197 |
col=col,
|
|
|
198 |
...)
|
|
|
199 |
|
|
|
200 |
}
|
|
|
201 |
|