R/boxplot.SK.R

In ScottKnott: The ScottKnott Clustering Algorithm

boxplot.SK <- function(x,
		       mean.type = c('line',
				     'point',
				     'none'),
		       xlab = NULL,
		       mean.col = 'gray',
		       mean.pch = 1,
		       mean.lwd = 1,
		       mean.lty = 1,
		       args.legend = NULL,
		       ...){
	# x is a object of SK class
	fun <- function(m) {
		a <- rep('\n',
			 length(m))
		a[which(m != '')[1]] <- ''
		return(paste(a,
			     m,
			     sep=''))
	}

	if(!inherits(x,
		     'SK'))
		stop("Use only with 'SK' objects!") 

	treat <- eval(getCall(x)$which) 

	if(is.null(xlab)) xlab <- 'Levels' 

	if(inherits(x,'SK.formula')){
		aux2 <- eval(getCall(x)$formula)
		aux3 <- eval(getCall(x)$data)
		response <- as.character(formula(aux2)[[2]])    
	} else if(inherits(x,'SK.aovlist')){
		aux <- eval(getCall(x)$x)
		aux3 <- model.frame(aux)
		response <- as.character(attr(aux,
					      'terms')[[2]]) 
	} else{ 
		aux <- eval(getCall(x)$x)
		aux2 <- eval(getCall(aux)$formula)
		aux3 <- eval(getCall(aux)$data)
		response <- as.character(formula(aux2)[[2]]) 
	} 

	ltreat <- rownames(x$out$Result)
	means <- x$info$Means[['means']] 

	auxinter <- unlist(strsplit(treat,
				    ':')) # objeto criado para auxliar nos casos que envolve interações.

	if(length(auxinter)>1){
		aux3$treat <- with(aux3,
				   interaction(eval(parse(text=treat))))
		aux3$treat <- gsub(':',
				   '/',
				   aux3$treat)
		aux3 <- subset(aux3,
			       treat%in%ltreat)

		treat <- 'treat'

	}

	aux3[[treat]] <- factor(aux3[[treat]],
				levels = ltreat)   

	m.res <- t(x$out$Result[, 2:ncol(x$out$Result)])

	if(dim(m.res)[1] != 1) {
		m.res <- apply(m.res,
			       2,
			       fun)
		id.groups <- c(apply(m.res,
				     2,
				     paste,
				     collapse=''))
	}
	else{
		id.groups <- m.res 
	}

	aux22 <- as.formula(paste(response,
				  '~',
				  treat))

	ngroups <- dim(x$out$Result)[2] - 1
	if(ngroups > 3){
		op <- par('mar')       # Original par('mar')
		np <- op               # A copy
		np[3] <- ngroups + 1   # Changing top to show all letters
		par(mar=np)            # Setting new par('mar')
	}

	gr <- boxplot(aux22,
		      data=aux3,
		      xlab = xlab,
		      ...)# OK lm class!!! 
	axis(3,
	     at     = 1:length(ltreat),
	     labels = id.groups, ...)

	#gr$stats[3, ] <- unclass(with(aux3,
	#                              by(aux3[[response]],
	#                                 aux3[[treat]], 
	#                                 function(x) mean(x,na.rm=TRUE)))) 
	gr$stats[3,] <- means

	switch(match.arg(mean.type),
	       line = {
		       bxp(gr,
			   add = TRUE,
			   frame.plot = FALSE,
			   medcol = mean.col,
			   lty = mean.lty,
			   lwd = mean.lwd,
			   boxlty = 'blank',
			   whisklty="blank",
			   outlty="blank",
			   outpch = NA,
			   staplelty="blank",
			   show.names=FALSE,
			   ...)

		       auxlty <- c(1,
				   mean.lty)
		       auxpch <- NULL
	       },
	       point = {
		       points(means,
			      col = mean.col,
			      lwd = mean.lwd,
			      pch = mean.pch,
			      ...)

		       auxlty <- c(1, NA)
		       auxpch <- c(NA, mean.pch)
	       },
	       none = invisible(NULL))

	if(is.null(args.legend)){

		args.2Kl <- list(x      = 'topleft',
				 legend = c('Median',
					    'Mean'),
				 col    = c('black',
					    mean.col),
				 lwd    = c(1,
					    mean.lwd),
				 bty    = 'n',
				 cex    = 0.8,
				 lty    = auxlty,
				 pch    = auxpch)

		do.call('legend',
			args.2Kl)

	} else {

		args.2Kl <- list(x      = 'topleft',
				 legend = c('Median',
					    'Mean'),
				 col    = c('black',
					    mean.col),
				 lwd    = c(1,
					    mean.lwd),
				 bty    = 'n',
				 cex    = 0.8,
				 lty    = auxlty,
				 pch    = auxpch)

		args.2Kl[names(args.legend)] <- args.legend     

		do.call('legend',
			args.2Kl) 

	}       

	if(ngroups > 3){
		par(mar=op)  # Restoring the original par('mar') 
	}
}