WebSVN – bdplot – Diff – /bdgraphics/R/4_bdplot.R


### bdplot.R
#### This is a collection of functions that must bpre reachable by the user This is called 
 
 
 
## strategy missing for xytype
## Could we test if there is an active graphics device? And if not, run bdopen()?
bdplot <- function(x, y=NULL, z=NULL,
                   ## The rest is irrelevant for the user
                   cex.plot=bdp()$cex.plot,
                   xaxt="n",
                   xlab=bdp()$xlab, ylab=bdp()$ylab,
                   xlim=range(x,bdp()$xlim,na.rm=TRUE),
                   ylim=range(bdp()$ylim,y,na.rm=TRUE),
                   col=bdp()$col,main=NULL,
                   ## only used in case of plot mode
                   type=bdp()$type,
                   ## Only used in case of histogram plotting
                   border=bdp()$border,
                   ...)
{
  prm <- bdp()
 
 
  ##Set margins
  mar <- prm$mar.nolab
  if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }
  if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }
  if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }
  if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }
  par(mar=mar)
 
  par(mgp=prm$mgp.global)
  
  ## Do the plot
  ## the method variable could be used more intelligently. If x is numeric, only three methods are possible: plot, barplot, image.plot.
    ## maybe this check can be skipped. I guess x and y can just be deleted from these commands  
 ## if( prm$method=="xy"){
  
  if(!is.null(y)){
    ##       cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")
    
    plot(x, y,
         type=type,
         xaxt=xaxt, yaxt="n",
         cex=cex.plot,
         xlab=xlab,
         ylab=ylab,
         xlim=xlim,
         ylim=ylim,
         col=col,
         main=main,
         ...)
  } else if (is.numeric(x)){
    if(prm$method=="barplot"){
      barplot(height=x,
              ## maybe these two are wrong/stupid?
              cex.axis=prm$cex.lab,
              cex.names=prm$cex.lab,
              col=bdp()$hcol,
              border=border,
              xlab=xlab,
              ylab=ylab,
              main=main,
              ...)
      prm$draw.xaxis <- FALSE
      prm$draw.yaxis <- FALSE
      
    } else {
      plot(x,
           type=type,
           xaxt="n", yaxt="n",
           cex=cex.plot,
           xlab=xlab,
           ylab=ylab,
           ylim=xlim,
           col=col,
           main=main,
           ...)
    }
  } else if( class(x) == "acf"){
    ## Not cleaned up/checked
    plot(x, xlab="", ylab="", xaxt="n", yaxt="n", cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)
  }
  else if( class(x) == "histogram"){
    ## Notice: the color of the bars can ONLY be set with bdp(hcol="color").
    plot(x,
         xlab=xlab, ylab=ylab,
         main=prm$main,
         xaxt="n",yaxt="n",col=bdp()$hcol,
         border=border,
         ...)
  } else if( class(x) == "trellis"){
    ## Not cleaned up/checked
    ## very experimental
    cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")
    ##lattice.options(layout.widths = prm$lattice.width,
    ##                layout.heights = prm$lattice.height)
    trellis.par.set(prm$myLatticeSettings()) 
    plot(x,col=col,...)
    ## with lattice/trellis, the axis drawing doesn't work.
    prm$draw.xaxis <- FALSE
    prm$draw.yaxis <- FALSE
  }
  else if (prm$method=="image.plot"){
    cat("The Bacher/Delff Plotting System (R), (C), TM operating in image plotting mode.\nx and y axis can not be configured.\n")
    image.plot(x=x,y=y,z=z,
               xlab=xlab,
               ylab=ylab,
               ...)
  }
  
  ## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision
  
  ##Grid stuff
  if( prm$grid ){
    grid(col=prm$grid.col)
  }
  ## vertical lines
  if( !is.na(prm$grid.v) ){
    if(prm$grid.v=="Def"){
      grid(nx=NULL,ny=NA,col=prm$grid.col)
    } else
    {
      abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)
    }
  }
 
  if( !is.na(prm$grid.h) ){
    if(prm$grid.h=="Def"){
      grid(nx=NA,ny=NULL,col=prm$grid.col)
    }else{
      abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}
    }
 
  ## Axis stuff
  if(prm$draw.xaxis){
    ##    mgp.old <- par()$mgp
    ##    par(mgp) <- mgp.xaxis
    options(warn=-1)
    if( "POSIXt"%in%class(x[1])){
      axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)
    } else {
      axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)
    }
    options(warn=0)
    
  }
  if(prm$draw.yaxis){ axis(2, mgp=prm$mgp.yaxis, lwd=prm$lwd) }
  
  ##Title stuff
  ## Hvorfor??
  scale <- 1
  ##  if( prm$type=="hist" & !is.na(prm$xlab) )
#  if( !is.na(prm$xlab)  ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }
  ##  if( prm$type=="hist" &!is.na(prm$ylab) )
#  if( !is.na(prm$ylab)  ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }
  if( !is.na(prm$toplab) ){ mtext(prm$xxlab, side=3, line=0.25, cex=prm$cex.lab/scale) }
  if( !is.na(prm$rightlab) ){ mtext(prm$yylab, side=4, line=0.25, cex=prm$cex.lab/scale) }
}
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

Rev 7	Rev 8
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	`xlab=bdp()$xlab, ylab=bdp()$ylab,`	12	`xlab=bdp()$xlab, ylab=bdp()$ylab,`
13	`xlim=range(x,bdp()$xlim,na.rm=TRUE),`	13	`xlim=range(x,bdp()$xlim,na.rm=TRUE),`
14	`ylim=range(bdp()$ylim,y,na.rm=TRUE),`	14	`ylim=range(bdp()$ylim,y,na.rm=TRUE),`
15	`col=bdp()$col,main=NULL,`	15	`col=bdp()$col,main=NULL,`
16	`## only used in case of plot mode`	16	`## only used in case of plot mode`
17	`type=bdp()$type,`	17	`type=bdp()$type,`
18	`## Only used in case of histogram plotting`	18	`## Only used in case of histogram plotting`
19	`border=bdp()$border,`	19	`border=bdp()$border,`
20	`...)`	20	`...)`
21	`{`	21	`{`
22	`prm <- bdp()`	22	`prm <- bdp()`
23		23
24		24
25	`##Set margins`	25	`##Set margins`
26	`mar <- prm$mar.nolab`	26	`mar <- prm$mar.nolab`
27	`if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }`	27	`if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }`
28	`if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }`	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] }`	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] }`	30	`if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }`
31	`par(mar=mar)`	31	`par(mar=mar)`
32		32
33	`par(mgp=prm$mgp.global)`	33	`par(mgp=prm$mgp.global)`
34		34
35	`## Do the plot`	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.`	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`	37	`## maybe this check can be skipped. I guess x and y can just be deleted from these commands`
38	`## if( prm$method=="xy"){`	38	`## if( prm$method=="xy"){`
39		39
40	`if(!is.null(y)){`	40	`if(!is.null(y)){`
41	`## cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")`	41	`## cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")`
42		42
43	`plot(x, y,`	43	`plot(x, y,`
44	`type=type,`	44	`type=type,`
45	`xaxt=xaxt, yaxt="n",`	45	`xaxt=xaxt, yaxt="n",`
46	`cex=cex.plot,`	46	`cex=cex.plot,`
47	`xlab=xlab,`	47	`xlab=xlab,`
48	`ylab=ylab,`	48	`ylab=ylab,`
49	`xlim=xlim,`	49	`xlim=xlim,`
50	`ylim=ylim,`	50	`ylim=ylim,`
51	`col=col,`	51	`col=col,`
52	`main=main,`	52	`main=main,`
53	`...)`	53	`...)`
54	`} else if (is.numeric(x)){`	54	`} else if (is.numeric(x)){`
55	`if(prm$method=="barplot"){`	55	`if(prm$method=="barplot"){`
56	`barplot(height=x,`	56	`barplot(height=x,`
57	`## maybe these two are wrong/stupid?`	57	`## maybe these two are wrong/stupid?`
58	`cex.axis=prm$cex.lab,`	58	`cex.axis=prm$cex.lab,`
59	`cex.names=prm$cex.lab,`	59	`cex.names=prm$cex.lab,`
60	`col=bdp()$hcol,`	60	`col=bdp()$hcol,`
61	`border=border,`	61	`border=border,`
62	`xlab=xlab,`	62	`xlab=xlab,`
63	`ylab=ylab,`	63	`ylab=ylab,`
64	`main=main,`	64	`main=main,`
65	`...)`	65	`...)`
66	`prm$draw.xaxis <- FALSE`	66	`prm$draw.xaxis <- FALSE`
67	`prm$draw.yaxis <- FALSE`	67	`prm$draw.yaxis <- FALSE`
68		68
69	`} else {`	69	`} else {`
70	`plot(x,`	70	`plot(x,`
71	`type=type,`	71	`type=type,`
72	`xaxt="n", yaxt="n",`	72	`xaxt="n", yaxt="n",`
73	`cex=cex.plot,`	73	`cex=cex.plot,`
74	`xlab=xlab,`	74	`xlab=xlab,`
75	`ylab=ylab,`	75	`ylab=ylab,`
76	`ylim=xlim,`	76	`ylim=xlim,`
77	`col=col,`	77	`col=col,`
78	`main=main,`	78	`main=main,`
79	`...)`	79	`...)`
80	`}`	80	`}`
81	`} else if( class(x) == "acf"){`	81	`} else if( class(x) == "acf"){`
82	`## Not cleaned up/checked`	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,...)`	83	`plot(x, xlab="", ylab="", xaxt="n", yaxt="n", cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)`
84	`}`	84	`}`
85	`else if( class(x) == "histogram"){`	85	`else if( class(x) == "histogram"){`
86	`## Notice: the color of the bars can ONLY be set with bdp(hcol="color").`	86	`## Notice: the color of the bars can ONLY be set with bdp(hcol="color").`
87	`plot(x,`	87	`plot(x,`
88	`xlab=xlab, ylab=ylab,`	88	`xlab=xlab, ylab=ylab,`
89	`main=prm$main,`	89	`main=prm$main,`
90	`xaxt="n",yaxt="n",col=bdp()$hcol,`	90	`xaxt="n",yaxt="n",col=bdp()$hcol,`
91	`border=border,`	91	`border=border,`
92	`...)`	92	`...)`
93	`} else if( class(x) == "trellis"){`	93	`} else if( class(x) == "trellis"){`
94	`## Not cleaned up/checked`	94	`## Not cleaned up/checked`
95	`## very experimental`	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")`	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,`	97	`##lattice.options(layout.widths = prm$lattice.width,`
98	`## layout.heights = prm$lattice.height)`	98	`## layout.heights = prm$lattice.height)`
99	`trellis.par.set(prm$myLatticeSettings())`	99	`trellis.par.set(prm$myLatticeSettings())`
100	`plot(x,col=col,...)`	100	`plot(x,col=col,...)`
101	`## with lattice/trellis, the axis drawing doesn't work.`	101	`## with lattice/trellis, the axis drawing doesn't work.`
102	`prm$draw.xaxis <- FALSE`	102	`prm$draw.xaxis <- FALSE`
103	`prm$draw.yaxis <- FALSE`	103	`prm$draw.yaxis <- FALSE`
104	`}`	104	`}`
105	`else if (prm$method=="image.plot"){`	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")`	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,`	107	`image.plot(x=x,y=y,z=z,`
108	`xlab=xlab,`	108	`xlab=xlab,`
109	`ylab=ylab,`	109	`ylab=ylab,`
110	`...)`	110	`...)`
111	`}`	111	`}`
112		112
113	`## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision`	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		114
115	`##Grid stuff`	115	`##Grid stuff`
116	`if( prm$grid ){`	116	`if( prm$grid ){`
117	`grid(col=prm$grid.col)`	117	`grid(col=prm$grid.col)`
118	`}`	118	`}`
119	`## vertical lines`	119	`## vertical lines`
120	`if( !is.na(prm$grid.v) ){`	120	`if( !is.na(prm$grid.v) ){`
121	`if(prm$grid.v=="Def"){`	121	`if(prm$grid.v=="Def"){`
122	`grid(nx=NULL,ny=NA,col=prm$grid.col)`	122	`grid(nx=NULL,ny=NA,col=prm$grid.col)`
123	`} else`	123	`} else`
124	`{`	124	`{`
125	`abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)`	125	`abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)`
126	`}`	126	`}`
127	`}`	127	`}`
128		128
129	`if( !is.na(prm$grid.h) ){`	129	`if( !is.na(prm$grid.h) ){`
130	`if(prm$grid.h=="Def"){`	130	`if(prm$grid.h=="Def"){`
131	`grid(nx=NA,ny=NULL,col=prm$grid.col)`	131	`grid(nx=NA,ny=NULL,col=prm$grid.col)`
132	`}else{`	132	`}else{`
133	`abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}`	133	`abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}`
134	`}`	134	`}`
135		135
136	`## Axis stuff`	136	`## Axis stuff`
137	`if(prm$draw.xaxis){`	137	`if(prm$draw.xaxis){`
138	`## mgp.old <- par()$mgp`	138	`## mgp.old <- par()$mgp`
139	`## par(mgp) <- mgp.xaxis`	139	`## par(mgp) <- mgp.xaxis`
140	`options(warn=-1)`	140	`options(warn=-1)`
141	`if( "POSIXt"%in%class(x[1])){`	141	`if( "POSIXt"%in%class(x[1])){`
142	`axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)`	142	`axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)`
143	`} else {`	143	`} else {`
144	`axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)`	144	`axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)`
145	`}`	145	`}`
146	`options(warn=0)`	146	`options(warn=0)`
147		147
148	`}`	148	`}`
149	`if(prm$draw.yaxis){ axis(2, mgp=prm$mgp.yaxis, lwd=prm$lwd) }`	149	`if(prm$draw.yaxis){ axis(2, mgp=prm$mgp.yaxis, lwd=prm$lwd) }`
150		150
151	`##Title stuff`	151	`##Title stuff`
152	`## Hvorfor??`	152	`## Hvorfor??`
153	`scale <- 1`	153	`scale <- 1`
154	`## if( prm$type=="hist" & !is.na(prm$xlab) )`	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) }`	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) )`	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) }`	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) }`	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) }`	159	`if( !is.na(prm$rightlab) ){ mtext(prm$yylab, side=4, line=0.25, cex=prm$cex.lab/scale) }`
160	`}`	160	`}`
161		161
162		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		163
202		164

Subversion Repositories bdplot

(root)/bdgraphics/R/4_bdplot.R – Rev 7 → 8