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

Subversion Repositories bdplot

(root)/bdgraphics/R/4_bdplot.R – Rev 51 → 52