Nothing
# 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())
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.