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
 
 
 
 
  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 width 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"){
    ### This could be checked in the beginning by is.null(z)
    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) }
  ## axis to the right
  if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, 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$toplab, side=3, line=0.25, cex=prm$cex.lab/scale) }
  if( !is.na(prm$rightlab) ){
    mtext(prm$rightlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)
##    mtext(rightlab, side=4, line=0.5, cex=bdp()$cex.lab,mgp=bdp()$mgp.raxis)
  }
}
 
 
 
 

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

Subversion Repositories bdplot

(root)/bdgraphics/R/4_bdplot.R – Rev 12 → 15