.packageName <- "butler"
# Assert
# Basic assert function that powers all others.
#
# @arguments condition to evaluation for truth
# @arguments message to display if condition is false
# @arguments should warnings be displayed 
# @keyword debugging
assert <- function(condition, msg = "") {
	if (!isTRUE(condition)) {
		if (length(msg) == 1 && msg == "") msg <- paste(deparse(substitute(condition)), "not true")
		throw_assert_error(msg)
	}
}

# is.positive.integer
# Converience function for determining if x is a positive integer
#
# @arguments object to test
# @keyword debugging
is.positive.integer <- function(x) {
	mode(x) == "numeric" && x > 0 && floor(x) == x
}

# Assert warning
# Assert that a warning occured
# @keyword debugging
assert.warning <- function(f, warning = "", msg = "") {
	w <- get_warning(f)
	assert.warning_error(w, warning, msg)
}

# Assert error
# Assert an error occured
# @keyword debugging
assert.error <- function(f, warning = "", msg = "") {
	w <- get_error(f)
	assert.warning_error(w, warning, msg)
}

# Assert warning or error
# Assert a warning of error occured
# @keyword debugging
assert.warning_error <- function(w, warning = "", msg = "") {
	expected <- !(is.na(w) || ((warning != "") && (w$message != warning)))
	if (!expected) {
		if (missing(warning)) {
			msg <- paste(deparse(substitute(condition)), "did not raise a warning")
		} else { 
			msg <- paste(deparse(substitute(condition)), "raised", w$message, "not", warning)
		}
		warning(msg)
	}
	expected
}

# Throw assert error
# Equivalent of stop(msg) but classed so that other methods can recognise it
# @arguments error message to display
# @keyword debugging
throw_assert_error <- function(msg) {
	err <- simpleError(msg)
	class(err) <- c("assertError", class(err))
	stop(err)
}

# Get warning
# Collect any warnings created when running function
# @keyword debugging
get_warning <- function(x) { err <- NA	
	tryCatch(force(x), warning = function(e){err <<- e})
	err
}

# Get error
# Collect any errors created when running function
# @keyword debugging
get_error <- function(x) { err <- NA	
	tryCatch(force(x), error = function(e){err <<- e})
	err
}

# Assert is S3 class
# Assert argument is of given S3 class
# @keyword debugging
assert.isS3class <- function(obj, class, msg = "") {
	if (missing(msg)) msg <- paste(deparse(substitute(obj)), "not S3 class", class)
	assert(class %in% class(obj), msg)	
}

# Is all equal
# Are x and y equal
# @keyword debugging
is.all.equal <- function(x,y) isTRUE(all.equal(x,y))

# Assert equal
# Assert expected and actual are equal
# @keyword debugging
assert.equal <- function(expected, actual, msg = "") {
	if (msg == "") msg <- paste(deparse(substitute(expected)), "does not equal", deparse(substitute(actual)), "because\n:", paste(all.equal(expected, actual), collapse="\n"))
	assert(is.all.equal(expected, actual), msg)	
}
# Is assert error?
# Is x an assertion error?
# @keyword debugging
is.assertError <- function(x) "assertError" %in% class(x)

# Is error?
# Is x an assertion error?
# @keyword debugging
is.error <- function(x) "error" %in% class(x)

# Benchmark
# Compare the performance of different functions
#
# @arguments functions to compare, make sure to name them (see example)
# @arguments number of reps of each function to run
# @keyword debugging
#
#X mean1 = function() {x <- rnorm(1000); mean(x);}
#X mean2 = function() {x <- rnorm(1000); sum(x) / length(x);}
#X mean3 = function() {x <- rnorm(1000); total=0;for(i in 1:length(x)) {total <- total + x[i]}; total/length(x);}
#X mt = benchmark(mean=mean1,sum=mean2,loop=mean3, reps=1000)
#X print(mt)
benchmark <- function(..., reps = 10) {
	args <- list(...)

	#Preconditions
	assert(is.positive.integer(reps), "Number of repetitions (reps) must be a positive integer")	
	assert(length(list) > 0, "Supply functions to test in ...")
	assert(all(as.logical(lapply(args, is.function))),"Arguments to ... expected to be functions")
	assert(!is.null(names(args)), "Functions should be named")

	times <- list()

	for (i in 1:length(args)) {
		functionName <- names(args)[i]
		times[[functionName]] <- system.time(for(j in 1:reps){args[[i]]()}, gcFirst=TRUE)[1:3]
	}
	
	times <- as.data.frame(times)[1:3]
	attr(times, "reps") <- reps
	rownames(times) <- c("system", "user", "total")
	class(times) <- c("benchmark", class(times))

	times
}

# Print benchmark
# Print nicely formatted benchmark results
#
# @arguments benchmark object to display
# @arguments time to display (one of system, user or total)
# @arguments required to match generic
# @keyword debugging
print.benchmark <- function(x, type="total", ...) {
	assert(type %in% c("system", "user", "total"), "Type must be one of: system, user, total")

	reps <- attr(x, "reps")

	times <- as.numeric(x[type,])
	comp <- outer(times, times, "/")
	dimnames(comp) <- list(colnames(x), colnames(x))
	
	cat("Repetitions: ", reps, "\n")
	cat("Timing: ", type, "\n")
	
	display <- matrix(c(
		"", colnames(x),
		"Time (s)", format(times / reps, width=5), 
		"Frequency (per s)", format(reps / times, digits=1)
	), nrow=3, byrow=TRUE)
	dimnames(display) <- list(rep("",dim(display)[1]),rep("",dim(display)[2]))
	print(display, quote=FALSE, right=TRUE)

	cat("\nRelative speeds\n")
	print(comp, digits=2)
}

# Benchmark2
# An extension to benchmark which allows you to specify a (minimum) time for the functions to run
#
# @arguments functions to compare, make sure to name them (see example)
# @arguments (minimum) time, in seconds, to run for
# @arguments number of reps to run between checking time
# @keyword debugging
benchmark2 <- function(..., time = 3, reps = 10) {
	args <- list(...)

	#Preconditions
	assert(mode(reps) == "numeric" && reps > 0 && floor(reps) == reps, "Number of repetitions (reps) must be a positive integer")	
	assert(mode(time) == "numeric" && time > 0, "Amount of time (time) must be a positive number")	
	assert(length(list) > 0, "Supply functions to test in ...")
	assert(all(as.logical(lapply(args, is.function))),"Arguments to ... expected to be functions")
	assert(!is.null(names(args)), "Functions should be named")

	times <- list()
	class(times) <- c("benchmark")
	cur.time <- 0
	totalreps <- 0
	
	while(cur.time < time) {
		for(i in 1:length(args)) {
			functionName <- names(args)[i]
			timing <- system.time(for(j in 1:reps){args[[i]]()}, gcFirst = TRUE)
			if (is.null(times[[functionName]])) {
				times[[functionName]] <- timing
			} else {
				times[[functionName]] <- timing + times[[functionName]]
			}
			totalreps <- totalreps + reps
			cur.time <- cur.time + timing[3]
			print(cur.time)
		}
		 
	}

	attr(times, "reps") <- totalreps
	times
}
# Stop watch
# Profile the performance of function call.
#
# Results can be display nicely using either plot or print.
#
# @seealso \code{\link{print.call.tree}}, \code{\link{plot.call.tree}}
# @arguments function to profile
# @arguments number of times to run
# @arguments interval between samples (in seconds)
# @value call tree
# @keyword debugging
stopwatch <- function(f, reps = 2, interval = 0.02) {
	assert(is.positive.integer(reps), "Repetitions (reps) must be a positive integer");
	assert(is.function(f), "f must be a function");
	
	tmp <- tempfile()
	on.exit(unlink(tmp))
	
	for(i in 1:reps) {
		Rprof(tmp, append=TRUE)
		f()
		Rprof()
	}

	lines <- scan(tmp, what="character", sep="\n")
	clean.lines <- lines[-grep("sample\\.interval=",lines)]
	calls <- sapply(clean.lines, strsplit, split=" ", USE.NAMES = FALSE)
	calls <- sapply(calls, rev)
	
	class(calls) <- "call.tree"
	attr(calls, "interval") <- interval
	attr(calls, "reps") <- reps
	
	calls
} 

# Get calls
# Get all calls at a given level of the call stack
#
# @arguments list of calls
# @arguments level of call stack
# @arguments function name
# @keyword debugging
getCalls <- function(calls, level, value) {
	sapply(calls, function(x) { if (!is.na(x[level]) && x[level] == value) x[(level + 1):length(x)]})
}

# Get first call
# @keyword debugging
getFirstCalls <- function(calls, level) {
	sort(table(sapply(calls, function(x) {x[level]})), decreasing=TRUE)
}

# Get next call
# @keyword debugging
nextCalls <- function(calls, level, value) {
	cur.stack <- getCalls(calls, level, value)
	cur.next.call <- sapply(cur.stack, function(x) {if (!is.null(x)) x[1]})
	cur.next.time <- table(unlist(cur.next.call))
	sort(cur.next.time, decreasing=TRUE)
}

# Print call tree
# Attractively print call tree
# @keyword debugging
print.call.tree <- function(x, startlevel = 3, depth = 8, mintime = 2, ...) {
	assert(is.positive.integer(startlevel), "Start level must be a positive integer");
	assert(is.positive.integer(depth), "Depth must be a positive integer");
	assert(is.positive.integer(mintime), "Minimum time (mintime) level must be a positive integer");
	
	depth <- startlevel + depth
	
	first.x <- getFirstCalls(x,startlevel)
	for(call in names(first.x)) {
		displayCallNode(x, startlevel, call, depth, mintime)
	}
}

# Display call node
# @keyword debugging
displayCallNode <- function(calls, level, value, depth, mintime) {
	next.calls <- nextCalls(calls, level, value)
	if (sum(next.calls) >= mintime) {
		cat(rep("  ", level - 1), value, " (", sum(next.calls),")", "\n", sep="")
		if(sum(next.calls) > 0 && level < depth) {
			for(i in 1:length(next.calls)) {
				displayCallNode(calls, level + 1, names(next.calls)[i], depth, mintime)
			}
		}
	}
}

# Plot call tree
# Attractively plot call tree
# @keyword debugging
plot.call.tree <- function(x, startlevel = 1, depth = 5, mintime = 2, ...) {
	plot(x=0, y=0, ylim=c(0,depth+1), xlim=c(0,100),type="n", xlab="", ylab="", mai=0)
	depth <- startlevel + depth
	
	first.x <- getFirstCalls(x,startlevel)
	for(call in names(first.x)) {
		plotCallNode(x, startlevel, call, 0, 100, mintime, startlevel, depth)
	}
}

# Plot call node
# Recursively function that powers plot.call.tree
# @keyword debugging
plotCallNode <- function(calls, level, value, start, end, mintime, startlevel, depth) {
	if (level > depth) return()
	if (end - start < mintime) return()
	next.calls <- nextCalls(calls, level, value)
	
	displevel <- level - startlevel + 1
	
	if (sum(next.calls)  >= mintime) {
		rect(start,displevel-1,end,displevel)
		text(start, displevel-0.5, pos=4,value, cex=0.8)
	
		breakdown <- start + c(0,cumsum(next.calls) / sum(next.calls)) * (end-start)
		for(i in 1:length(next.calls)) {
			plotCallNode(calls, level+1, names(next.calls)[i], breakdown[i], breakdown[i + 1], mintime, startlevel, depth)
		}
	}
}
# Test.
# Run all tests in given file and return results
#
# Displays status for each test as run and then reports particular errors
# ...F..E.. 8/10 successful, then report errors
#
# parse file, & for each expression:
#  * if contains assert, increment test count, then try to run test
#		store result + warning + expression in results[[i]]
#		cat ., E or W as appropriate
#  * eval other lines as usual
#  * output results to list failures 
# @arguments path to file
# @keyword debugging
test <- function(path, print=TRUE) {	
	expressions <- parse(path)

	results <- lapply(expressions, expression.test, print)
	if (print) cat("\n")
	
	sapply(results, print.test.result)
	invisible(results)
}

# Print test result
# 
# @keyword debugging
print.test.result <- function(x, ...) {
	if (is.assertError(x$error)) {
		cat(paste("\nAssert failure in ", x$test, ":\n", x$message, "\n", sep=""))
	} else if (is.error(x$error)) {
		cat(paste("\nError in ", x$test, ":\n", x$message, "\n", sep=""))
	}
}

# Is this expression a test?
# Determine whether expression is a test and should be run when "test"-ing a file
#
# An expression is a test if it is a function whose name begins with test.
# @arguments expression to test
# @keyword debugging
is.test <- function(expression) {
	if (length(expression) < 2) return(FALSE)
	text <- as.character(expression[[2]])
	isTRUE(grep("^(test)", text) >= 0)	
}

# Expression test.
# Run test and display status
#
# @arguments expression to test
# @arguments print results?
# @keyword debugging
expression.test <- function(expression, print=TRUE) {
	if (!is.test(expression)) return()
	result <- test.result(expression)
	if (!print) return(result)

	if (is.assertError(result$error)) {
		cat("F")
	} else if (is.error(result$error)) {
		cat("E")
	} else {
		cat(".")
	}
	result
}

# Eval expression and return list with errors, warnings and the deparsed expression
# @keyword debugging
test.result <- function(expression) {
	error <- get_error(eval(expression, list())())
	list(
		test = as.character(expression[[2]]),
		error = error, #, enclos=NULL,
		message = error$message
	)
}
