[R] A patch for boxplot.R

[Yusuke Uchiyama]

Hello,

I made a patch for boxplot.R.

These changes allow you to determine the color of upper half, center line, and lower half  of a box separately.

You can specify these colors by topcol, center, and bottomcol, respectively.

I will appreciate any suggestion for better implementation and I hope that these features are included to a future version of R.

Yusuke Uchiyama
e-mail: yusuke at kais.kyoto-u.ac.jp

----please cut---

*** boxplot.R.org	Tue Jan 12 12:18:48 1999
--- boxplot.R	Mon Jan 11 22:55:31 1999
***************
*** 1,6 ****
  boxplot <- function(x, ..., range=1.5, width=NULL, varwidth=FALSE,
  		    notch=FALSE, names.x, data=sys.frame(sys.parent()),
! 		    plot=TRUE, border=par("fg"), col=NULL, log="", pars=NULL)
  {
      args <- list(x,...)
      namedargs <-
--- 1,6 ----
  boxplot <- function(x, ..., range=1.5, width=NULL, varwidth=FALSE,
  		    notch=FALSE, names.x, data=sys.frame(sys.parent()),
! 		    plot=TRUE, border=par("fg"), center=par("fg"), topcol=NULL,bottomcol=NULL, log="", pars=NULL)
  {
      args <- list(x,...)
      namedargs <-
***************
*** 31,37 ****
  	groups[i] <- list(boxplot.stats(groups[[i]], range))
      if(plot) {
  	bxp(groups, width, varwidth=varwidth, notch=notch,
! 	    border=border, col=col, log=log, pars=pars)
  	invisible(groups)
      }
      else groups
--- 31,37 ----
  	groups[i] <- list(boxplot.stats(groups[[i]], range))
      if(plot) {
  	bxp(groups, width, varwidth=varwidth, notch=notch,
! 	    border=border, center=center, topcol=topcol, bottomcol=bottomcol, log=log, pars=pars)
  	invisible(groups)
      }
      else groups
***************
*** 51,59 ****
  
  bxp <- function(z, notch=FALSE, width=NULL, varwidth=FALSE,
  		notch.frac = 0.5,
! 		border=par("fg"), col=NULL, log="", pars=NULL, ...)
  {
!     bplt <- function(x, wid, stats, out, conf, notch, border, col)
      {
  	## Draw single box plot.
  	pars <- c(pars, list(...))# from bxp(...).
--- 51,59 ----
  
  bxp <- function(z, notch=FALSE, width=NULL, varwidth=FALSE,
  		notch.frac = 0.5,
! 		border=par("fg"), center=par("fg"), topcol=NULL,bottomcol=NULL, log="", pars=NULL, ...)
  {
!     bplt <- function(x, wid, stats, out, conf, notch, border, center, topcol, bottomcol)
      {
  	## Draw single box plot.
  	pars <- c(pars, list(...))# from bxp(...).
***************
*** 62,79 ****
  	    ## stats = +/- Inf:	 polygon & segments should handle
  	    wid <- wid/2
  	    if(notch) {
! 		xx <- x+wid*c(-1,1, 1, notch.frac, 1,
! 			      1,-1,-1,-notch.frac,-1)
! 		yy <- c(stats[c(2,2)],conf[1],stats[3],conf[2],
! 			stats[c(4,4)],conf[2],stats[3],conf[1])
! 		polygon(xx, yy, col=col, border=border)
! 		segments(x-wid/2,stats[3], x+wid/2,stats[3], col=border)
  	    }
  	    else {
  		xx <- x+wid*c(-1,1,1,-1)
! 		yy <- stats[c(2,2,4,4)]
! 		polygon(xx, yy, col=col, border=border)
! 		segments(x-wid,stats[3],x+wid,stats[3],col=border)
  	    }
  	    segments(rep(x,2),stats[c(1,5)], rep(x,2),
  		     stats[c(2,4)], lty="dashed",col=border)
--- 62,82 ----
  	    ## stats = +/- Inf:	 polygon & segments should handle
  	    wid <- wid/2
  	    if(notch) {
! 		xxtop <- x+wid*c(-1,1, 1, notch.frac, -notch.frac,-1)
! 		xxbttm <- x+wid*c(-1,1, 1, notch.frac, -notch.frac,-1)
! 		yytop <- c(stats[c(2,2)],conf[1],stats[c(3,3)],conf[1])
! 		yybttm <- c(stats[c(4,4)],conf[2],stats[c(3,3)],conf[2])
! 		polygon(xxtop, yytop, col=topcol, border=border)
! 		polygon(xxbttm, yybttm, col=bottomcol, border=border)
! 		segments(x-wid/2,stats[3], x+wid/2,stats[3], col=center)
  	    }
  	    else {
  		xx <- x+wid*c(-1,1,1,-1)
! 		yytop <- stats[c(2,2,3,3)]
!                 yybttm <- stats[c(3,3,4,4)]
! 		polygon(xx, yytop, col=topcol, border=border)
! 		polygon(xx, yybttm, col=bottomcol, border=border)
! 		segments(x-wid,stats[3],x+wid,stats[3],col=center)
  	    }
  	    segments(rep(x,2),stats[c(1,5)], rep(x,2),
  		     stats[c(2,4)], lty="dashed",col=border)
***************
*** 112,117 ****
--- 115,123 ----
      if(missing(border) || length(border)==0)
  	border <- par("fg")
  
+     if(missing(center) || length(center)==0)
+ 	center <- par("fg")
+ 
      plot.new()
      plot.window(xlim=c(0.5,n+0.5), ylim=ylim, log=log)
  
***************
*** 122,128 ****
  	     conf = z[[i]]$conf,
  	     notch= notch,
  	     border=border[(i-1)%%length(border)+1],
! 	     col=if(is.null(col)) col else col[(i-1)%%length(col)+1])
  
      if(is.null(pars$axes) || pars$axes) {
  	if(n > 1) axis(1, at=1:n, labels=names(z))
--- 128,137 ----
  	     conf = z[[i]]$conf,
  	     notch= notch,
  	     border=border[(i-1)%%length(border)+1],
! 	     center=center[(i-1)%%length(border)+1],
! 	     topcol=if(is.null(topcol)) topcol else topcol[(i-1)%%length(topcol)+1],
! 	     bottomcol=if(is.null(bottomcol)) bottomcol else bottomcol[(i-1)%%length(bottomcol)+1])
! 
  
      if(is.null(pars$axes) || pars$axes) {
  	if(n > 1) axis(1, at=1:n, labels=names(z))
***************
*** 132,134 ****
--- 141,158 ----
      box()
      invisible(1:n)
  }
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-help mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-help-request at stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._