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=bdp()$xaxt,yaxt=bdp()$yaxt,
                   xaxt.in=bdp()$xaxt.in,yaxt.in=bdp()$xaxt.in,
                   xlab=bdp()$xlab, ylab=bdp()$ylab,
                   xlim=bdp()$xlim,ylim=bdp()$ylim,
                   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,
                   ...)
{
 
 
  ## experimental. Is this the right consequence of not having a
  ## device opened?
  
  if(length(dev.list())==0){
    cat("No graphics device is initialised. Running bdopen() without arguments.\n")
    bdopen()
  }
  
 
  
  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
 
  detmar <- function(idx,lab){
    if (is.null(lab)) {
      mar <- prm$mar.lab[idx]
    } else if(all(is.na(lab))) {
      mar <- prm$mar.nolab[idx]
    } else {
      mar <- prm$mar.lab[idx]
    }
    mar
  }
  mar[1] <- detmar(1,xlab)
  mar[2] <- detmar(2,ylab)
    ##  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)
  
### xaxt and yaxt can be set to "axis" which is the special case where the axis is drawn with the axius
  if(class(xaxt)=="function") {
 
    if(prm$debug)
      print(class(x))
 
    if(is.null(xaxt.in))
      xaxt.in <- x
 
    
    draw.xaxis <- "fun"
    xaxt.fun <- xaxt
    xaxt <- "n"
  } else if(xaxt=="axis"){
    xaxt <- "n"
    draw.xaxis <- TRUE
  } else {
    draw.xaxis <- FALSE
  }
  if(class(yaxt)=="function") {
    yaxt(ifelse(is.null(yaxt.in),range(y),yaxt.in))
    draw.yaxis <- FALSE
  } else if(yaxt=="axis"){
    yaxt <- "n"
    draw.yaxis <- TRUE
  } else {
    draw.yaxis <- FALSE
  }
  
 
 
### this variable needs to be initialized
  addcase <- NULL
  
  ## Do the plot
  if(!is.null(y)){
 
    if(!is.null(z)){
      if(prm$debug)
        cat("bdgraphics operating in image plotting mode.\nx and y axis can not be configured.\n")
      image(x=x,y=y,z=z,
            xlab=xlab,
            ylab=ylab,
            ...)
    } else {
      if(prm$debug)
        cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")
      
      ## this is ugly, non standard.
      if(is.null(xlim))
        xlim <- range(x,na.rm=TRUE) #,bdp()$xlim,na.rm=TRUE)
      if(is.null(ylim))
        ylim <- range(y,na.rm=TRUE) #,bdp()$ylim,na.rm=TRUE)
      
      plot(x, y,
           type="n",
           xaxt=xaxt, yaxt=yaxt,
           cex=cex.plot,
           xlab=xlab,
           ylab=ylab,
           xlim=xlim,
           ylim=ylim,
           main=main,
           ...)
 
      addcase <- "plotxy"
      
    }
  } else if (is.numeric(x)){
    if(prm$method=="barplot"){
      if(prm$debug)
        cat("The Bacher/Delff Plotting System (R), (C), TM operating in barplot mode.\n")
      ## this does not provide the full x,y functionality of 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,
              ...)
      draw.xaxis <- FALSE
      draw.yaxis <- FALSE
      
    } else {
      if(prm$debug)
        cat("The Bacher/Delff Plotting System operating in xy-plotting mode, only plotting x.\n")
 
      if(is.null(xlim))
        xlim <- c(1,length(x))#,bdp()$xlim),na.rm=TRUE)
      
      if(is.null(ylim))
        ylim <- range(x,na.rm=TRUE)#,bdp()$ylim,na.rm=TRUE)
      
      plot(x,
           type="n",
           xaxt=xaxt, yaxt=yaxt,
           cex=cex.plot,
           xlab=xlab,
           ylab=ylab,
           xlim=xlim,
           ylim=ylim,
           main=main,
           ...)
      addcase <- "plotx"
    }
  } else if( class(x) == "acf"){
    ## Not cleaned up/checked
    plot(x, xlab="", ylab="", xaxt=xaxt, yaxt=yaxt, 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=xaxt,yaxt=yaxt,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.
    draw.xaxis <- FALSE
    draw.yaxis <- FALSE
  } else if (class(x)=="princomp") {
    if(prm$debug)
      cat("The Bacher/Delff Plotting System operating in princomp plotting mode.\n")
    plot(x,
         main=prm$main,
         ...)
  } else if (prm$method=="image.plot"){
    ### This could be checked in the beginning by is.null(z)
  }
  
###Grid stuff
  ## This really hould be done before adding the rest of the plot contents.
  ## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision
  
  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)}
    }
 
### Now, grid has bee drawn. Then contents can be added.
 ## add support for more cases! 
  if(!is.null(addcase)){
    if(addcase=="plotxy") {
      bdpoints(x, y,
               type=type,
               cex=cex.plot,
               xlim=xlim,
               ylim=ylim,
               col=col,
               ...)
    } else if (addcase=="plotx"){
      bdpoints(x, y,
               type=type,
               cex=cex.plot,
               xlim=xlim,
               ylim=ylim,
               col=col,
               ...)
    }
  }
 
### Axis stuff This part should be improved. A function that draws
### axis should be run for all four axis. And it should be possible to
### supply whatever vector to base it on (especially relevant for
### taxis and raxis)
  
  ## this is because the use of mgp gives a ridiculous warning when too small
  options(warn=-1)
  if(draw.xaxis=="fun"){
    xaxt.fun(xaxt.in)
  } else if(draw.xaxis){
    ## is the abscissa a time object?
    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)
    }
    
  }
 
  if(draw.yaxis){ axis(2, y,mgp=prm$mgp.yaxis, lwd=prm$lwd) }
  ## top axis
  if(prm$draw.taxis){ axis(3, mgp=prm$mgp.taxis, lwd=prm$lwd) }
  ## axis to the right
  if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }
 
  ## switch back on warnings
  options(warn=0)
 
 
  ##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 36	Rev 37
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	`## strategy missing for xytype`	5	`## strategy missing for xytype`
6	`## Could we test if there is an active graphics device? And if not, run bdopen()?`	6	`## Could we test if there is an active graphics device? And if not, run bdopen()?`
7	`bdplot <- function(x, y=NULL, z=NULL,`	7	`bdplot <- function(x, y=NULL, z=NULL,`
8	`## The rest is irrelevant for the user`	8	`## The rest is irrelevant for the user`
9	`cex.plot=bdp()$cex.plot,`	9	`cex.plot=bdp()$cex.plot,`
10	`xaxt=bdp()$xaxt,yaxt=bdp()$yaxt,`	10	`xaxt=bdp()$xaxt,yaxt=bdp()$yaxt,`
11	`xaxt.in=bdp()$xaxt.in,yaxt.in=bdp()$xaxt.in,`	11	`xaxt.in=bdp()$xaxt.in,yaxt.in=bdp()$xaxt.in,`
12	`xlab=bdp()$xlab, ylab=bdp()$ylab,`	12	`xlab=bdp()$xlab, ylab=bdp()$ylab,`
13	`xlim=bdp()$xlim,ylim=bdp()$ylim,`	13	`xlim=bdp()$xlim,ylim=bdp()$ylim,`
14	`col=bdp()$col,main=NULL,`	14	`col=bdp()$col,main=NULL,`
15	`## only used in case of plot mode`	15	`## only used in case of plot mode`
16	`type=bdp()$type,`	16	`type=bdp()$type,`
17	`## Only used in case of histogram plotting`	17	`## Only used in case of histogram plotting`
18	`border=bdp()$border,`	18	`border=bdp()$border,`
19	`...)`	19	`...)`
20	`{`	20	`{`
21		21
22		22
23	`## experimental. Is this the right consequence of not having a`	23	`## experimental. Is this the right consequence of not having a`
24	`## device opened?`	24	`## device opened?`
25		25
26	`if(length(dev.list())==0){`	26	`if(length(dev.list())==0){`
27	`cat("No graphics device is initialised. Running bdopen() without arguments.\n")`	27	`cat("No graphics device is initialised. Running bdopen() without arguments.\n")`
28	`bdopen()`	28	`bdopen()`
29	`}`	29	`}`
30		30
31		31
32		32
33	`prm <- bdp()`	33	`prm <- bdp()`
34		34
35		35
36	`par(cex.main=prm$cex.main, cex.lab=prm$cex.lab, cex.axis=prm$cex.axis)`	36	`par(cex.main=prm$cex.main, cex.lab=prm$cex.lab, cex.axis=prm$cex.axis)`
37	`par(tcl=prm$tcl)`	37	`par(tcl=prm$tcl)`
38	`par(lwd=prm$lwd)`	38	`par(lwd=prm$lwd)`
39	`par(bty=prm$bty)`	39	`par(bty=prm$bty)`
40		40
41		41
42	`##Set margins`	42	`##Set margins`
43	`mar <- prm$mar.nolab`	43	`mar <- prm$mar.nolab`
-		44
-		45	`detmar <- function(idx,lab){`
-		46	`if (is.null(lab)) {`
-		47	`mar <- prm$mar.lab[idx]`
-		48	`} else if(all(is.na(lab))) {`
-		49	`mar <- prm$mar.nolab[idx]`
-		50	`} else {`
-		51	`mar <- prm$mar.lab[idx]`
-		52	`}`
-		53	`mar`
-		54	`}`
-		55	`mar[1] <- detmar(1,xlab)`
-		56	`mar[2] <- detmar(2,ylab)`
44	`if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }`	57	`## if( !is.na(prm$xlab) ){ mar[1] <- prm$mar.lab[1] }`
45	`if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }`	58	`#if( !is.na(prm$ylab) ){ mar[2] <- prm$mar.lab[2] }`
46	`if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }`	59	`if( any(!is.na(prm$toplab),!is.null(main)) ) { mar[3] <- prm$mar.lab[3] }`
47	`if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }`	60	`if( !is.na(prm$rightlab) ){ mar[4] <- prm$mar.lab[4] }`
48	`par(mar=mar)`	61	`par(mar=mar)`
49		62
50	`par(mgp=prm$mgp.global)`	63	`par(mgp=prm$mgp.global)`
51		64
52	`### xaxt and yaxt can be set to "axis" which is the special case where the axis is drawn with the axius`	65	`### xaxt and yaxt can be set to "axis" which is the special case where the axis is drawn with the axius`
53	`if(class(xaxt)=="function") {`	66	`if(class(xaxt)=="function") {`
54		67
55	`if(prm$debug)`	68	`if(prm$debug)`
56	`print(class(x))`	69	`print(class(x))`
57		70
58	`if(is.null(xaxt.in))`	71	`if(is.null(xaxt.in))`
59	`xaxt.in <- x`	72	`xaxt.in <- x`
60		73
61		74
62	`draw.xaxis <- "fun"`	75	`draw.xaxis <- "fun"`
63	`xaxt.fun <- xaxt`	76	`xaxt.fun <- xaxt`
64	`xaxt <- "n"`	77	`xaxt <- "n"`
65	`} else if(xaxt=="axis"){`	78	`} else if(xaxt=="axis"){`
66	`xaxt <- "n"`	79	`xaxt <- "n"`
67	`draw.xaxis <- TRUE`	80	`draw.xaxis <- TRUE`
68	`} else {`	81	`} else {`
69	`draw.xaxis <- FALSE`	82	`draw.xaxis <- FALSE`
70	`}`	83	`}`
71	`if(class(yaxt)=="function") {`	84	`if(class(yaxt)=="function") {`
72	`yaxt(ifelse(is.null(yaxt.in),range(y),yaxt.in))`	85	`yaxt(ifelse(is.null(yaxt.in),range(y),yaxt.in))`
73	`draw.yaxis <- FALSE`	86	`draw.yaxis <- FALSE`
74	`} else if(yaxt=="axis"){`	87	`} else if(yaxt=="axis"){`
75	`yaxt <- "n"`	88	`yaxt <- "n"`
76	`draw.yaxis <- TRUE`	89	`draw.yaxis <- TRUE`
77	`} else {`	90	`} else {`
78	`draw.yaxis <- FALSE`	91	`draw.yaxis <- FALSE`
79	`}`	92	`}`
80		93
81		94
82		95
83	`### this variable needs to be initialized`	96	`### this variable needs to be initialized`
84	`addcase <- NULL`	97	`addcase <- NULL`
85		98
86	`## Do the plot`	99	`## Do the plot`
87	`if(!is.null(y)){`	100	`if(!is.null(y)){`
88		101
89	`if(!is.null(z)){`	102	`if(!is.null(z)){`
90	`if(prm$debug)`	103	`if(prm$debug)`
91	`cat("bdgraphics operating in image plotting mode.\nx and y axis can not be configured.\n")`	104	`cat("bdgraphics operating in image plotting mode.\nx and y axis can not be configured.\n")`
92	`image(x=x,y=y,z=z,`	105	`image(x=x,y=y,z=z,`
93	`xlab=xlab,`	106	`xlab=xlab,`
94	`ylab=ylab,`	107	`ylab=ylab,`
95	`...)`	108	`...)`
96	`} else {`	109	`} else {`
97	`if(prm$debug)`	110	`if(prm$debug)`
98	`cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")`	111	`cat("The Bacher/Delff Plotting System (R), (C), TM operating in xy-plotting mode.\n")`
99		112
100	`## this is ugly, non standard.`	113	`## this is ugly, non standard.`
101	`if(is.null(xlim))`	114	`if(is.null(xlim))`
102	`xlim <- range(x,na.rm=TRUE) #,bdp()$xlim,na.rm=TRUE)`	115	`xlim <- range(x,na.rm=TRUE) #,bdp()$xlim,na.rm=TRUE)`
103	`if(is.null(ylim))`	116	`if(is.null(ylim))`
104	`ylim <- range(y,na.rm=TRUE) #,bdp()$ylim,na.rm=TRUE)`	117	`ylim <- range(y,na.rm=TRUE) #,bdp()$ylim,na.rm=TRUE)`
105		118
106	`plot(x, y,`	119	`plot(x, y,`
107	`type="n",`	120	`type="n",`
108	`xaxt=xaxt, yaxt=yaxt,`	121	`xaxt=xaxt, yaxt=yaxt,`
109	`cex=cex.plot,`	122	`cex=cex.plot,`
110	`xlab=xlab,`	123	`xlab=xlab,`
111	`ylab=ylab,`	124	`ylab=ylab,`
112	`xlim=xlim,`	125	`xlim=xlim,`
113	`ylim=ylim,`	126	`ylim=ylim,`
114	`main=main,`	127	`main=main,`
115	`...)`	128	`...)`
116		129
117	`addcase <- "plotxy"`	130	`addcase <- "plotxy"`
118		131
119	`}`	132	`}`
120	`} else if (is.numeric(x)){`	133	`} else if (is.numeric(x)){`
121	`if(prm$method=="barplot"){`	134	`if(prm$method=="barplot"){`
122	`if(prm$debug)`	135	`if(prm$debug)`
123	`cat("The Bacher/Delff Plotting System (R), (C), TM operating in barplot mode.\n")`	136	`cat("The Bacher/Delff Plotting System (R), (C), TM operating in barplot mode.\n")`
124	`## this does not provide the full x,y functionality of barplot`	137	`## this does not provide the full x,y functionality of barplot`
125	`barplot(height=x,`	138	`barplot(height=x,`
126	`## maybe these two are wrong/stupid?`	139	`## maybe these two are wrong/stupid?`
127	`cex.axis=prm$cex.lab,`	140	`cex.axis=prm$cex.lab,`
128	`cex.names=prm$cex.lab,`	141	`cex.names=prm$cex.lab,`
129	`col=bdp()$hcol,`	142	`col=bdp()$hcol,`
130	`border=border,`	143	`border=border,`
131	`xlab=xlab,`	144	`xlab=xlab,`
132	`ylab=ylab,`	145	`ylab=ylab,`
133	`main=main,`	146	`main=main,`
134	`...)`	147	`...)`
135	`draw.xaxis <- FALSE`	148	`draw.xaxis <- FALSE`
136	`draw.yaxis <- FALSE`	149	`draw.yaxis <- FALSE`
137		150
138	`} else {`	151	`} else {`
139	`if(prm$debug)`	152	`if(prm$debug)`
140	`cat("The Bacher/Delff Plotting System operating in xy-plotting mode, only plotting x.\n")`	153	`cat("The Bacher/Delff Plotting System operating in xy-plotting mode, only plotting x.\n")`
141		154
142	`if(is.null(xlim))`	155	`if(is.null(xlim))`
143	`xlim <- c(1,length(x))#,bdp()$xlim),na.rm=TRUE)`	156	`xlim <- c(1,length(x))#,bdp()$xlim),na.rm=TRUE)`
144		157
145	`if(is.null(ylim))`	158	`if(is.null(ylim))`
146	`ylim <- range(x,na.rm=TRUE)#,bdp()$ylim,na.rm=TRUE)`	159	`ylim <- range(x,na.rm=TRUE)#,bdp()$ylim,na.rm=TRUE)`
147		160
148	`plot(x,`	161	`plot(x,`
149	`type="n",`	162	`type="n",`
150	`xaxt=xaxt, yaxt=yaxt,`	163	`xaxt=xaxt, yaxt=yaxt,`
151	`cex=cex.plot,`	164	`cex=cex.plot,`
152	`xlab=xlab,`	165	`xlab=xlab,`
153	`ylab=ylab,`	166	`ylab=ylab,`
154	`xlim=xlim,`	167	`xlim=xlim,`
155	`ylim=ylim,`	168	`ylim=ylim,`
156	`main=main,`	169	`main=main,`
157	`...)`	170	`...)`
158	`addcase <- "plotx"`	171	`addcase <- "plotx"`
159	`}`	172	`}`
160	`} else if( class(x) == "acf"){`	173	`} else if( class(x) == "acf"){`
161	`## Not cleaned up/checked`	174	`## Not cleaned up/checked`
162	`plot(x, xlab="", ylab="", xaxt=xaxt, yaxt=yaxt, cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)`	175	`plot(x, xlab="", ylab="", xaxt=xaxt, yaxt=yaxt, cex=prm$cex.plot, xlim=prm$xlim, ylim=prm$ylim,col=col,...)`
163	`} else if( class(x) == "histogram"){`	176	`} else if( class(x) == "histogram"){`
164	`## Notice: the color of the bars can ONLY be set width bdp(hcol="color").`	177	`## Notice: the color of the bars can ONLY be set width bdp(hcol="color").`
165	`plot(x,`	178	`plot(x,`
166	`xlab=xlab, ylab=ylab,`	179	`xlab=xlab, ylab=ylab,`
167	`main=prm$main,`	180	`main=prm$main,`
168	`xaxt=xaxt,yaxt=yaxt,col=bdp()$hcol,`	181	`xaxt=xaxt,yaxt=yaxt,col=bdp()$hcol,`
169	`border=border,`	182	`border=border,`
170	`...)`	183	`...)`
171	`} else if( class(x) == "trellis"){`	184	`} else if( class(x) == "trellis"){`
172	`## Not cleaned up/checked`	185	`## Not cleaned up/checked`
173	`## very experimental`	186	`## very experimental`
174	`cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")`	187	`cat("The Bacher/Delff Plotting System (R), (C), TM operating in lattice mode.\n Remeber that labels must written in the lattice object.\n")`
175	`##lattice.options(layout.widths = prm$lattice.width,`	188	`##lattice.options(layout.widths = prm$lattice.width,`
176	`## layout.heights = prm$lattice.height)`	189	`## layout.heights = prm$lattice.height)`
177	`trellis.par.set(prm$myLatticeSettings())`	190	`trellis.par.set(prm$myLatticeSettings())`
178	`plot(x,col=col,...)`	191	`plot(x,col=col,...)`
179	`## with lattice/trellis, the axis drawing doesn't work.`	192	`## with lattice/trellis, the axis drawing doesn't work.`
180	`draw.xaxis <- FALSE`	193	`draw.xaxis <- FALSE`
181	`draw.yaxis <- FALSE`	194	`draw.yaxis <- FALSE`
182	`} else if (class(x)=="princomp") {`	195	`} else if (class(x)=="princomp") {`
183	`if(prm$debug)`	196	`if(prm$debug)`
184	`cat("The Bacher/Delff Plotting System operating in princomp plotting mode.\n")`	197	`cat("The Bacher/Delff Plotting System operating in princomp plotting mode.\n")`
185	`plot(x,`	198	`plot(x,`
186	`main=prm$main,`	199	`main=prm$main,`
187	`...)`	200	`...)`
188	`} else if (prm$method=="image.plot"){`	201	`} else if (prm$method=="image.plot"){`
189	`### This could be checked in the beginning by is.null(z)`	202	`### This could be checked in the beginning by is.null(z)`
190	`}`	203	`}`
191		204
192	`###Grid stuff`	205	`###Grid stuff`
193	`## This really hould be done before adding the rest of the plot contents.`	206	`## This really hould be done before adding the rest of the plot contents.`
194	`## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision`	207	`## We could make default values for grid.v og grid.h. Man maa kunne lave noget kvalificeret ud fra range og noget heltalsdivision`
195		208
196	`if( prm$grid ){`	209	`if( prm$grid ){`
197	`grid(col=prm$grid.col)`	210	`grid(col=prm$grid.col)`
198	`}`	211	`}`
199	`## vertical lines`	212	`## vertical lines`
200	`if( !is.na(prm$grid.v) ){`	213	`if( !is.na(prm$grid.v) ){`
201	`if(prm$grid.v=="Def"){`	214	`if(prm$grid.v=="Def"){`
202	`grid(nx=NULL,ny=NA,col=prm$grid.col)`	215	`grid(nx=NULL,ny=NA,col=prm$grid.col)`
203	`} else`	216	`} else`
204	`{`	217	`{`
205	`abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)`	218	`abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)`
206	`}`	219	`}`
207	`}`	220	`}`
208		221
209	`if( !is.na(prm$grid.h) ){`	222	`if( !is.na(prm$grid.h) ){`
210	`if(prm$grid.h=="Def"){`	223	`if(prm$grid.h=="Def"){`
211	`grid(nx=NA,ny=NULL,col=prm$grid.col)`	224	`grid(nx=NA,ny=NULL,col=prm$grid.col)`
212	`}else{`	225	`}else{`
213	`abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}`	226	`abline(h=prm$grid.h, lty="dotted", col=prm$grid.col)}`
214	`}`	227	`}`
215		228
216	`### Now, grid has bee drawn. Then contents can be added.`	229	`### Now, grid has bee drawn. Then contents can be added.`
217	`## add support for more cases!`	230	`## add support for more cases!`
218	`if(!is.null(addcase)){`	231	`if(!is.null(addcase)){`
219	`if(addcase=="plotxy") {`	232	`if(addcase=="plotxy") {`
220	`bdpoints(x, y,`	233	`bdpoints(x, y,`
221	`type=type,`	234	`type=type,`
222	`cex=cex.plot,`	235	`cex=cex.plot,`
223	`xlim=xlim,`	236	`xlim=xlim,`
224	`ylim=ylim,`	237	`ylim=ylim,`
225	`col=col,`	238	`col=col,`
226	`...)`	239	`...)`
227	`} else if (addcase=="plotx"){`	240	`} else if (addcase=="plotx"){`
228	`bdpoints(x, y,`	241	`bdpoints(x, y,`
229	`type=type,`	242	`type=type,`
230	`cex=cex.plot,`	243	`cex=cex.plot,`
231	`xlim=xlim,`	244	`xlim=xlim,`
232	`ylim=ylim,`	245	`ylim=ylim,`
233	`col=col,`	246	`col=col,`
234	`...)`	247	`...)`
235	`}`	248	`}`
236	`}`	249	`}`
237		250
238	`### Axis stuff This part should be improved. A function that draws`	251	`### Axis stuff This part should be improved. A function that draws`
239	`### axis should be run for all four axis. And it should be possible to`	252	`### axis should be run for all four axis. And it should be possible to`
240	`### supply whatever vector to base it on (especially relevant for`	253	`### supply whatever vector to base it on (especially relevant for`
241	`### taxis and raxis)`	254	`### taxis and raxis)`
242		255
243	`## this is because the use of mgp gives a ridiculous warning when too small`	256	`## this is because the use of mgp gives a ridiculous warning when too small`
244	`options(warn=-1)`	257	`options(warn=-1)`
245	`if(draw.xaxis=="fun"){`	258	`if(draw.xaxis=="fun"){`
246	`xaxt.fun(xaxt.in)`	259	`xaxt.fun(xaxt.in)`
247	`} else if(draw.xaxis){`	260	`} else if(draw.xaxis){`
248	`## is the abscissa a time object?`	261	`## is the abscissa a time object?`
249	`if( "POSIXt"%in%class(x[1])){`	262	`if( "POSIXt"%in%class(x[1])){`
250	`axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)`	263	`axis.POSIXct(1, x,mgp=prm$mgp.xaxis, lwd=prm$lwd)`
251	`} else {`	264	`} else {`
252	`axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)`	265	`axis(1, mgp=prm$mgp.xaxis, lwd=prm$lwd)`
253	`}`	266	`}`
254		267
255	`}`	268	`}`
256		269
257	`if(draw.yaxis){ axis(2, y,mgp=prm$mgp.yaxis, lwd=prm$lwd) }`	270	`if(draw.yaxis){ axis(2, y,mgp=prm$mgp.yaxis, lwd=prm$lwd) }`
258	`## top axis`	271	`## top axis`
259	`if(prm$draw.taxis){ axis(3, mgp=prm$mgp.taxis, lwd=prm$lwd) }`	272	`if(prm$draw.taxis){ axis(3, mgp=prm$mgp.taxis, lwd=prm$lwd) }`
260	`## axis to the right`	273	`## axis to the right`
261	`if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }`	274	`if(prm$draw.raxis){ axis(4, mgp=prm$mgp.raxis, lwd=prm$lwd) }`
262		275
263	`## switch back on warnings`	276	`## switch back on warnings`
264	`options(warn=0)`	277	`options(warn=0)`
265		278
266		279
267	`##Title stuff`	280	`##Title stuff`
268	`## Hvorfor??`	281	`## Hvorfor??`
269	`scale <- 1`	282	`scale <- 1`
270	`## if( prm$type=="hist" & !is.na(prm$xlab) )`	283	`## if( prm$type=="hist" & !is.na(prm$xlab) )`
271	`# if( !is.na(prm$xlab) ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }`	284	`# if( !is.na(prm$xlab) ){ mtext(prm$xlab, line=prm$xlabLine, side=1, cex=prm$cex.lab/scale) }`
272	`## if( prm$type=="hist" &!is.na(prm$ylab) )`	285	`## if( prm$type=="hist" &!is.na(prm$ylab) )`
273	`# if( !is.na(prm$ylab) ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }`	286	`# if( !is.na(prm$ylab) ){ mtext(prm$ylab, line=prm$ylabLine, side=2, cex=prm$cex.lab/scale) }`
274	`if( !is.na(prm$toplab) ){ mtext(prm$toplab, side=3, line=0.25, cex=prm$cex.lab/scale) }`	287	`if( !is.na(prm$toplab) ){ mtext(prm$toplab, side=3, line=0.25, cex=prm$cex.lab/scale) }`
275	`if( !is.na(prm$rightlab) ){`	288	`if( !is.na(prm$rightlab) ){`
276	`mtext(prm$rightlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)`	289	`mtext(prm$rightlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)`
277	`## mtext(rightlab, side=4, line=0.5, cex=bdp()$cex.lab,mgp=bdp()$mgp.raxis)`	290	`## mtext(rightlab, side=4, line=0.5, cex=bdp()$cex.lab,mgp=bdp()$mgp.raxis)`
278	`}`	291	`}`
279	`}`	292	`}`
280		293
281		294
282		295
283		296

Subversion Repositories bdplot

(root)/bdgraphics/R/4_bdplot.R – Rev 36 → 37