R/feem.R

In albatross: PARAFAC Analysis of Fluorescence Excitation-Emission Matrices

# FEEM is a matrix with designated dimensions and ceratin attributes.

feem <- function(x, ...) UseMethod('feem')

feem.character <- feem.connection <- function(x, format, ...) {
	stopifnot(length(x) == 1)
	switch(
		match.arg(format, c('table', 'panorama', 'F900txt')),
		table = read.matrix,
		panorama = read.panorama,
		F900txt = read.F900txt,
	)(x, ...)
}

feem.matrix <- function(x, emission, excitation, scale = 1, ...) {
	stopifnot(
		length(list(...)) == 0, is.numeric(x),
		is.vector(scale, 'numeric'), length(scale) == 1,
		length(emission) == nrow(x), is.vector(emission, 'numeric'),
		length(excitation) == ncol(x), is.vector(excitation, 'numeric')
	)
	structure(
		x,
		emission = emission,
		excitation = excitation,
		scale = unname(scale),
		dimnames = list(emission = emission, excitation = excitation),
		class = 'feem'
	)
}

feem.data.frame <- function(
	x, scale = 1, emission = 'emission', excitation = 'excitation',
	intensity = 'intensity', ...
) {
	stopifnot(
		length(list(...)) == 0, ncol(x) == 3,
		is.numeric(x[,emission]),
		is.numeric(x[,excitation]),
		is.numeric(x[,intensity])
	)
	# NOTE: here we use attributes set by reshape(), which aren't exactly
	# documented, but are pretty stable: attr(ret,'reshapeWide') hasn't
	# changed since at 2004 at the latest
	ret <- reshape(
		x, direction = 'wide', v.names = intensity,
		idvar = emission, timevar = excitation
	)
	feem(as.matrix(ret[,-1]), ret[,1], attr(ret, 'reshapeWide')$times)
}

as.data.frame.feem <- function(x, row.names = NULL, optional = FALSE, ...)
	data.frame(
		emission = attr(x, 'emission')[row(x)][!is.na(x)],
		excitation = attr(x, 'excitation')[col(x)][!is.na(x)],
		intensity = x[!is.na(x)],
		row.names = row.names,
		# ignoring `optional`, since col.names are hard-coded and
		# row.names will either be supplied by user (unlikely) or
		# generated by data.frame() if default NULL is passed
		...
	)

.plot.feem <- function(
	x, xlab, ylab, cuts, col.regions,
	..., translate = FALSE
) {
	# can't use default if caller passes a missing argument
	if (missing(xlab)) xlab <- pgtq("lambda[em]*', nm'", translate)
	if (missing(ylab)) ylab <- pgtq("lambda[ex]*', nm'", translate)
	levelplot(
		x = intensity ~ emission + excitation, data = as.data.frame(x),
		xlab = xlab, ylab = ylab, cuts = cuts, col.regions = col.regions, ...
	)
}

plot.feem <- function(
	x, xlab, ylab, cuts = 128, col.regions = marine.colours(256), ...
) .plot.feem(x, xlab, ylab, cuts, col.regions, ...)

# need custom extract operator to preserve attributes
`[.feem` <- function(x, i, j, drop = TRUE) {
	ret <- NextMethod()
	if (!is.matrix(ret)) return(ret) # return a plain vector if asked to
	feem( # reconstruct the FEEM object
		ret,
		emission = unname(setNames(
			attr(x, 'emission'), dimnames(x)[[1]]
		)[i]),
		excitation = unname(setNames(
			attr(x, 'excitation'), dimnames(x)[[2]]
		)[j]),
		scale = attr(x, 'scale')
	)
}

# replace operator preserves our attributes by default
`[<-.feem` <- function(x, i, j, value) {
	if (nargs() > 3 && inherits(value, 'feem')) {
		# x[] and x[subset] mean something like a vector subset and both
		# result in nargs() of 3, even if i isn't even set, so don't do
		# anything in that case
		# otherwise, the user is doing a matrix subset, and we can
		# perform a sanity check for the wavelengths and the scale value
		xsub <- x[
			if (missing(i)) TRUE else i,
			if (missing(j)) TRUE else j,
			drop = FALSE
		]
		stopifnot(
			attr(xsub, 'emission') == attr(value, 'emission'),
			attr(xsub, 'excitation') == attr(value, 'excitation')
		)
		# scales must match, but user may intend to proceed
		if (attr(x, 'scale') != attr(value, 'scale')) warning(
			'Assigning from FEEM with different scale: LHS(',
			attr(x, 'scale'), ') != RHS(', attr(value, 'scale'), ')'
		)
	}
	NextMethod()
}

t.feem <- function(x) unclass(NextMethod())