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

Subversion Repositories bdplot

(root)/bdgraphics/R/4_bdplot.R – Rev 55 → 56