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

Subversion Repositories bdplot

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