WebSVN – bdplot – Diff – /bdgraphics/R/4_bdplot.R


o### 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,debug=FALSE,
                   ...){
  if(debug) browser()
## set this to TRUE if something is returned. eg, happens in barplot 
  ret <- FALSE
  ## 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)
    }
##    browser()
    mar <- c(detmar(1,xlab),
             detmar(2,ylab),
             detmar(3,tlab)+ifelse(is.null(main),0,prm$mar.main),
             detmar(4,rlab))
##    print(length(mar))
##    print(mar)    
  }
  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
      retval <- 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,
                        ylim=ylim,
                        main=main,
                        ...)
      ret <- TRUE
      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="", xaxt=xaxt, yaxt=yaxt, cex=prm$cex.plot, xlim=xlim, ylim=ylim,col=col,ylab=ylab,...)
  }  else if( class(x) == "histogram"){
    ## Notice: the color of the bars can ONLY be set width bdp(hcol="color").
    if(prm$debug) {browser()}
    if(is.null(freq)){
    freq=TRUE}
    if(is.null(xlim)){
      xlim <- range(x$breaks)
    }
    plot(x,
         xlab=xlab,ylab=ylab,
         main=main,freq=freq,
         xlim=xlim,
         ylim=ylim,
         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=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=bdp()$cex.plot)
    ### 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=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( any(!is.na(prm$grid.v)) ){
    if(prm$grid.v[1]=="Def"){
      grid(nx=NULL,ny=NA,col=prm$grid.col)
    } else
    {
      abline(v=prm$grid.v, lty="dotted", col=prm$grid.col)
    }
  }
 
  if( any(!is.na(prm$grid.h)) ){
    if(prm$grid.h[1]=="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.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)
  }
  if(ret){
    invisible(ret)
  }
}
 
 
 

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

Subversion Repositories bdplot

(root)/bdgraphics/R/4_bdplot.R – Rev 69 → 73