
# Microarray surface plot
# Surface plot with sensible defaults for microarrays
surfaceplot.ma <- function(
	formula, data, 
	aspect = "xy",
	prepanel = function() {list(dx=1, dy=1)},
	allow.multiple = TRUE,
	as.table = TRUE,
	panel = panel.ma.surface,
	col.regions = pal(), 
	tipRows = NULL, tipCols = 0,
	main = NULL,
	ylab = NULL, ...
) {
	
	#if plot x vs. y, draw tip grid
	lf <- latticeParseFormula(formula, data, dim=3)
	if (lf$right.x.name == "x" && lf$right.y.name %in% c("y","-y")) {
		try({
			tipCols = seq(0,max(data$x), by=max(data$spotCol))+0.5
			tipRows = seq(0,max(data$y), by=max(data$spotRow))+0.5
		})
	}
		
	if (missing(main)) {
		main <- paste("Surface plot of",  lf$left.name)
	}
	
	levelplot(formula, data, allow.multiple=allow.multiple, as.table = as.table, panel=panel, main=main, prepanel=prepanel, aspect=aspect, col.regions=col.regions, ylab=ylab, tipRows = tipRows, tipCols = tipCols, ...)	
}

panel.ma.surface <- function(..., tipRows, tipCols, grid.col = "grey80") {
	panel.superpose.surface(...)

	if (!missing(tipRows)) {
		panel.abline(h = tipRows, col = grid.col)
	}
	if (!missing(tipCols)) {
		panel.abline(v = tipCols, col = grid.col)
	}
}

panel.superpose.surface <- function (
	x, y, z, groups, subscripts, panel.base = panel.levelplot, panel.superpose = panel.contour.smooth, contour.col = "#BF2828", ..., region, contour, at
) {
	if (missing(groups)) {
		panel.base(x = x, y = y, z = z, subscripts = subscripts, contour=FALSE, at=at, ...)
		return()
	}
	
	x <- x[subscripts]; y <- y[subscripts]; z <- z[subscripts]
	groups <- groups[subscripts]
	
	if (is.factor(groups)) { 
		vals <- levels(groups)
	} else { 
		vals <- sort(unique(groups))
	}
	nvals <- length(vals)
	
	first <- TRUE
	for (i in seq(along = vals)) {
		id <- (groups == vals[i])
		if (first) {
			panel.base(x = x[id], y = y[id], z = z[id], groups = groups[id], subscripts = TRUE, 
				contour=FALSE, region=TRUE, col=col, at=at, ...)
			first <- FALSE
		} else {
			panel.superpose(x = x[id], y = y[id], z = z[id], groups = groups[id], subscripts = TRUE, 
				contour=TRUE, region=FALSE, col=contour.col, at = seq(min(z[id]), max(z[id]), length=10), ...)
		}
	}	
}

panel.surface.smooth <- function(x, y, z, zcol, at, subscripts, surface.theta = 3, ..., contour, region, col.regions) {
	x <- x[subscripts]; y <- y[subscripts]; z <- z[subscripts];
	z.smooth <- smooth.grid(x, y, z, surface.theta)
	
	zcol <- cut(z.smooth, at, labels=FALSE)
	panel.levelplot(x, y, z.smooth, zcol=zcol, subscripts=TRUE, ..., at=at, contour = FALSE, region = TRUE, col.regions=col.regions)
}

panel.contour.smooth <- function(x, y, z, zcol, at, subscripts, contour.theta = 3, ..., contour, region, col.regions) {
	x <- x[subscripts]; y <- y[subscripts]; z <- z[subscripts];
	z.smooth <- smooth.grid(x, y, z, contour.theta)
	
	zcol <- cut(z.smooth, at, labels=FALSE)
	panel.levelplot(x, y, z.smooth, zcol=zcol, subscripts=TRUE, ..., at=at, contour = TRUE, region = FALSE, col.regions=col.regions)
}

smooth.grid <- function(x, y, z, theta=2) {
	if (!require("fields")) {stop("Fields library required for smoothed panels")}
	image.smooth(matrix(z[order(y, x)], nrow=max(x)), theta=theta)[(y-1)*max(x) + x]
}


# Modified xy panel function that scales spots to z values
panel.spot <- function (x, y, z, subscripts, col, ...) {
  
	z.range <- range(z, na.rm = TRUE)
	
	x <- as.numeric(x)[subscripts]
	y <- as.numeric(y)[subscripts]
	z <- as.numeric(z)[subscripts] 

	col <- c("#BF2828","black")[cut(z, c(-Inf, 0, Inf), labels=FALSE)] #colour negatives red
	z[is.infinite(z)] <- NA

	if (min(z, na.rm=TRUE) < 0 && max(z, na.rm=TRUE) > 0) {
		#if 0 in range scale absolutes
		z <- abs(z)
		scale <- z  / diff(z.range)
	} else {
		scale <- (z - min(z.range)) / diff(z.range)
	}
	
	radii <- scale *.65

	grid.circle(x = x, y = y, r = radii, 
		default.units = "native", 
		gp = gpar(fill = col, col = NULL))
}


scale_to_unit <- function(x) { (x - min(x)) / diff(range(x))}
