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,
                   tlab=bdp()$tlab, rlab=bdp()$rlab,
                   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,freq=NULL,
                   ...){
 
 
  ## 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()
 
 
## It's a mess to set cex.lab here. Or it should not be set in
##  functions calls. If set both ways, it's scaled twice, meaning that
##  we don't know how to make it fit with mtext for eg rlab.
  par(cex.main=prm$cex.main, cex.lab=prm$cex.lab,
  cex.axis=prm$cex.axis)
##   par(cex.main=prm$cex.main, 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)
  mar[3] <- detmar(3,tlab)
  mar[4] <- detmar(4,rlab)
    
  ## 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 axis
  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. Why?
  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). What about colors?
  
  ## 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$tlab) ){ mtext(prm$tlab, side=3, line=0.25, cex=prm$cex.lab/scale) }
  if( !is.na(prm$rlab) ){
    mtext(prm$rlab, side=4, line=0.75, cex=prm$cex.lab/scale,mgp=prm$mgp.raxis)
  }
}
 
 
 
 

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

Subversion Repositories bdplot

(root)/bdgraphics/R/4_bdplot.R – Rev 44 → 47