R/utils.R

In VFP: Variance Function Program

# TODO: Add comment
# 
# Author: schueta6
###############################################################################



#' Condition-Handling Without Losing Information.
#' 
#' Function is intented to wrap expressions provided and catching
#' all potentially useful information generated by the wrapped expression, i.e.
#' errors, warnings, and messages.
#' 
#' @param expr		(expression) for which exception handling should be provided
#' @param file		(character) string specifying a file to which all captured output
#' 					shall be written
#' 
#' @return 	(list) with element "result", "status" (0 = no warnings, no errors), 1 = warnings
#' 			were caught, 2 = errors were caught no result generated, "warnings", "errors", 
#' 			"messages"
#' 
#' @author Andre Schuetzenmeister \email{andre.schuetzenmeister@@roche.com}
#' @examples 
#' conditionHandler(warning("This is a warning!"))
#' f <- function(expr){warning("This a warning!"); eval(expr)}
#' conditionHandler(f(1/2))
#' conditionHandler(stop("This is an error!"))
#' conditionHandler(1/"a")

conditionHandler <- function(expr,  file=NULL) 
{
	Warnings <- Errors <- Messages <- NULL
	status   <- 0
	# handle warnings
	WHandler <- function(w) 
	{
		status <<- 1
		Warnings <<- c(Warnings, w$message)#list(w))
		invokeRestart("muffleWarning")		
	}
	# handle messages
	MHandler <- function(m)
	{
		Messages <<- c(Messages, m$message)#list(m))
		invokeRestart("muffleMessage")		
	}
	# handle errors
	if(!is.null(file) && file.exists(file))
	{
		capture.output(
				result <- try(withCallingHandlers(expr, warning = WHandler, message=MHandler), silent=TRUE),
				file=file, append=TRUE)
	}
	else
	{
		result <- try(withCallingHandlers(expr, warning = WHandler, message=MHandler), silent=TRUE)
	}
	
	if(is(result[[1]], "try-error") || is(result, "try-error"))
	{		
		Errors <- attr(result, "condition")$message
		result <- NA
		status <- 2
	}
	
	if(is.null(result))
	{
		status <- 2
		#	Errors <- "A model could not be fitted. Please check 'messages' and 'warnings'!"
		Errors <- paste("A model could not be fitted:", Warnings, Messages, sep=" | ")
	}
	
	res <- list(result = result, status=status, warnings = Warnings, errors = Errors, messages = Messages)
	
	res
} 


#' Transform list of VCA-object into VFP-matrix required for fitting.
#'
#' @param obj		(list) of VCA-objects
#' @param vc		(integer, character) either an integer specifying a variance component
#' 					or the name of a variance component; can also be a vector of integers
#' 					specifying a continuous sequence of variance components always including
#' 					'error' (repeatability)
#' 
#' @author Andre Schuetzenmeister \email{andre.schuetzenmeister@@roche.com}
#' 
#' @examples 
#' \donttest{
#' library(VCA)
#' data(VCAdata1)
#' lst <- anovaVCA(y~(device+lot)/day/run, VCAdata1, by="sample")
#' getMat.VCA(lst)  # automatically selects 'total'
#' # pooled version of intermediate precision (error+run+day)
#' getMat.VCA(lst, 4:6)
#' # only repeatability ('error')
#' getMat.VCA(lst, "error")
#' }

getMat.VCA <- function(obj, vc=1)
{
	stopifnot(class(obj) == "list")
	stopifnot(all(sapply(obj, class) == "VCA"))
	stopifnot(is.numeric(vc) || is.character(vc))
	tab <- obj[[1]]$aov.tab
	if(is.numeric(vc))
	{
		stopifnot(all(vc %in% 1:nrow(tab)))
		nm <- vc
		vc <- rownames(tab)[vc]
	}
	else
	{
		stopifnot(all(vc %in% rownames(tab)))
		nm <- (1:nrow(tab))[which(rownames(tab) %in% vc)]	
	}
	
	if(length(nm) > 1)
	{
		if(max(nm) != nrow(tab) || !(all(diff(nm) == 1)))
			stop("When specifying a sequence of variance components, it must include 'error' and be continuous!")
	}
	if(length(vc) > 1)		
	{
		tmp <- lapply(obj, stepwiseVCA)			# perform all combinations of VCA
		idx <- suppressWarnings(which(unlist(lapply(tmp[[1]], function(x) all(rownames(x$aov.tab) == c("total", vc))))))
		for(i in 1:length(tmp))
			tmp[[i]] <- tmp[[i]][[idx]]
		obj <- tmp
		vc  <- "total"
	}
	
	mat <- t(sapply(obj, function(x) c(Mean=x$Mean, x$aov.tab[vc, c("DF", "VC")])))
	mat <- as.data.frame(mat[order(mat[,"Mean"]),])
	mat
}




#' Adapted Version of Function 'signif'
#' 
#' This function adapts base-function \code{\link{signif}}
#' by always returning integer values in case the number of
#' requested significant digits is less than the the number of
#' digits in front of the decimal separator.
#' 
#' @param x			(numeric) value to be rounded to the desired number
#' 					of significant digits
#' @param digits	(integer) number of significant digits
#' @param force		(logical) TRUE = force the return value to have at least 4 significant
#' 					digits, i.e. to integers with less digits zeros will be appended after
#' 					the decimal separator, otherwise the return value will be casted from
#' 					character to numeric
#' @param ...		additional parameters
#' 
#' @return 	number with 'digits' significant digits, if 'force=TRUE' "character" objects will be
#' 			returned otherwise objects of mode "numeric"
#' 
#' @author Andre Schuetzenmeister \email{andre.schuetzenmeister@@roche.com}

Signif <- function(x, digits=4, force=TRUE, ...)
{
	call 	<- match.call()
	manyX 	<- call$manyX
	if(is.null(manyX))
		manyX <- FALSE
	stopifnot(is.numeric(x))
	if(length(x) > 1)
		return(sapply(x, Signif, digits=digits, manyX=TRUE))
	
	if(!manyX && "coef.gnm" %in% class(x))		# assign name to single gnm-coefficient
	{
		x <- as.numeric(x)
		names(x) <- "beta1"
	}
	Ndbc	<- nchar(substr(as.character(x), 1, regexpr("\\.", as.character(x))-1))
	x 		<- signif(x, ifelse(Ndbc > digits, Ndbc, digits))
	NcX		<- nchar(x)
	comma	<- grepl("\\.", x)
	if(comma)
		NcX <- NcX - 1
	if(NcX < digits)
		x <- paste0(x, ifelse(comma, "", "."), paste(rep(0, digits-NcX), collapse=""))
	if(!force)
		x <- as.numeric(x)
	x
}




#' Add a Grid to an Existing Plot.
#' 
#' It is possible to use automatically determined grid lines (\code{x=NULL, y=NULL}) or specifying the number 
#' of cells \code{x=3, y=4} as done by \code{grid}. Additionally, x- and y-locations of grid-lines can be specified,
#' e.g. \code{x=1:10, y=seq(0,10,2)}.
#' 
#' @param x         (integer, numeric) single integer specifies number of cells, numeric vector specifies vertical grid-lines
#' @param y         (integer, numeric) single integer specifies number of cells, numeric vector specifies horizontal grid-lines
#' @param col       (character) color of grid-lines
#' @param lwd       (integer) line width of grid-lines
#' @param lty       (integer) line type of grid-lines
#' 
#' @author Andre Schuetzenmeister \email{andre.schuetzenmeister@@roche.com}

addGrid <- function(x=NULL, y=NULL, col="lightgray", lwd=1L, lty=3L)
{
	if(all(is.null(c(x,y))) || all(length(c(x,y))<2))               # call grid function
		grid(nx=x, ny=y, col=col, lwd=lwd, lty=lty)
	else
	{
		if(length(x) == 0)                                          # NULL
			xticks <- axTicks(side=1)
		else if(length(x) == 1)
		{
			U <- par("usr")
			xticks <- seq.int(U[1L], U[2L], length.out = x + 1)
		}
		else
			xticks <- x
		
		if(length(y) == 0)                                          # NULL
			yticks <- axTicks(side=2)
		else if(length(y) == 1)
		{
			U <- par("usr")
			yticks <- seq.int(U[3L], U[4L], length.out = y + 1)
		}
		else
			yticks <- y
		
		abline(v=xticks, col=col, lwd=lwd, lty=lty)
		abline(h=yticks, col=col, lwd=lwd, lty=lty)
	}
}

#' Convert Color-Name or RGB-Code to Possibly Semi-Transparent RGB-code.
#' 
#' Function takes the name of a color and converts it into the rgb space. Parameter "alpha" allows
#' to specify the transparency within [0,1], 0 meaning completey transparent and 1 meaning completey
#' opaque. If an RGB-code is provided and alpha != 1, the RGB-code of the transparency adapted color 
#' will be returned.
#' 
#' @param col (character) name of the color to be converted/transformed into RGB-space (code). Only
#'               those colors can be used which are part of the set returned by function colors(). Defaults
#'               to "black".
#' @param alpha (numeric) value specifying the transparency to be used, 0 = completely transparent, 
#'               1 = opaque.
#' 
#' @return RGB-code
#' 
#' @author Andre Schuetzenmeister \email{andre.schuetzenmeister@@roche.com}
#' 
#' @examples 
#' # convert character string representing a color to RGB-code
#' # using alpha-channel of .25 (75\% transparent)
#' as.rgb("red", alpha=.25)
#' 
#' # same thing now using the RGB-code of red (alpha=1, i.e. as.rgb("red"))
#' as.rgb("#FF0000FF", alpha=.25)

as.rgb <- function(col="black", alpha=1)
{
	if(length(col) > 1 && (length(alpha) == 1 || length(alpha) < length(col)))         # unclear which alpha to use or only one alpha specified
	{
		if(length(alpha) < length(col) && length(alpha) > 1)
			warning("Multiple (but too few) 'alpha' specified! Only use 'alpha[1]' for each color!")
		return(sapply(col, as.rgb, alpha=alpha[1]))
	}
	if(length(col) > 1 && length(col) <= length(alpha))                                 # process each color separately
	{
		res <- character()
		for(i in 1:length(col))
			res <- c(res, as.rgb(col[i], alpha[i]))
		return(res)
	}
	if( col %in% colors() )
		return( rgb(t(col2rgb(col))/255, alpha=alpha) )
	else
	{
		col <- sub("#", "", col)
		R <- as.numeric(paste("0x", substr(col, 1,2), sep=""))
		G <- as.numeric(paste("0x", substr(col, 3,4), sep=""))
		B <- as.numeric(paste("0x", substr(col, 5,6), sep=""))
		return( rgb(R/255, G/255, B/255, alpha=alpha, maxColorValue=1) )
	}        
}


#' Add Legend to Right Margin.
#' 
#' This function accepts all parameters applicable in and forwards them to function \code{\link{legend}}.
#' There will be only made some modifications to the X-coordinate ensuring that the legend is plotted in
#' the right margin of the graphic device. Make sure that you have reserved sufficient space in the right
#' margin, e.g. 'plot.VFP(....., mar=c(4,5,4,10))'.
#' 
#' @param x			(character, numeric) either one of the character strings "center","bottomright", "bottom", "bottomleft", 
#' 					"left", "topleft", "top", "topright", "right" or a numeric values specifying the X-coordinate in user
#' 					coordinates
#' @param y			(numeric) value specifying the Y-coordiante in user coordinates, only used in case 'x' is numeric
#' @param offset	(numeric) value in [0, 0.5] specifying the offset as fraction in regard to width of the right margin
#' @param ...		all parameters applicable in function \code{\link{legend}}
#' 
#' @author Andre Schuetzenmeister \email{andre.schuetzenmeister@@roche.com}
#' 
#' @examples 
#' \donttest{
#' library(VCA)
#' data(VCAdata1)
#' # perform VCA-anaylsis
#' lst <- anovaVCA(y~(device+lot)/day/run, VCAdata1, by="sample")
#' # transform list of VCA-objects into required matrix
#' mat <- getMat.VCA(lst)		# automatically selects "total"
#' mat
#' 
#' # fit all 9 models batch-wise
#' res <- fit.vfp(model.no=1:10, Data=mat)
#' 
#' plot(res, mar=c(5.1, 4.1, 4.1,15), Crit=NULL)
#' 
#' legend.rm(cex=1.25, text.font=10,
#' 	 legend=c(
#'     paste0("AIC:    ", signif(as.numeric(res$AIC["Model_6"]), 4)),
#' 	   paste0("Dev:    ", signif(as.numeric(res$Deviance["Model_6"]), 4)),
#'     paste0("RSS:    ", signif(as.numeric(res$RSS["Model_6"]),4))))

#' }

legend.rm <- function(	x=c("center","bottomright", "bottom", "bottomleft", 
				"left", "topleft", "top", "topright", "right"), 
		y=NULL, offset=.05, ...)
{
	stopifnot(	is.numeric(x) || is.character(x) )
	if(is.character(x))
	{
		x <- match.arg(x[1], choices=c("center","bottomright", "bottom", "bottomleft", 
						"left", "topleft", "top", "topright", "right"))
	}else
	{
		stopifnot(is.numeric(y))
	}
	
	par(xpd=TRUE)
	args <- list(...)
	
	USR  <- par("usr")
	PLT  <- par("plt")
	FIG  <- par("fig")
	
	wrm <- FIG[2] - PLT[2]						# width right margin
	hrm	<- PLT[4] - PLT[3]
	
	if(is.character(x))
	{
		X.orig	<- x
		xjust 	<- 0.5							# defaults to center
		x 		<- PLT[2] + 0.5 * wrm
		yjust   <- 0.5
		y		<- PLT[3] + 0.5 * hrm
		
		if(grepl("left", X.orig))
		{
			xjust 	<- 0
			x 		<- PLT[2] + offset * wrm
		}		
		if(grepl("right", X.orig))
		{
			xjust 	<- 1
			x 		<- PLT[2] + (1-offset) * wrm
		}
		if(grepl("top", X.orig))
		{
			yjust 	<- 1
			y 		<- PLT[3] + (1-offset) * hrm
		}
		if(grepl("bottom", X.orig))
		{
			yjust 	<- 0
			y 		<- PLT[3] + offset * hrm
		}
	}
	
	x <- grconvertX(x, from="nic", to="user")
	y <- grconvertY(y, from="nic", to="user")
	
	args$x 		<- x
	args$y 		<- y
	args$xjust 	<- xjust
	args$yjust 	<- yjust
	
	do.call(legend, args)
	par(xpd=FALSE)
}