Nothing
# normalize ---------------------------------------------------------------
#' Normalize spectral data
#'
#' This method returns a spectral object of the same class as the one supplied
#' as argument but with the spectral data normalized to 1.0 at a specific
#' wavelength. When the object contains multiple spectra, the normalisation is
#' applied to each spectrum individually.
#'
#' @details By default normalization is done based on the maximum of the
#' spectral data. It is possible to also do the normalization based on a
#' user-supplied wavelength expressed in nanometres or the minimum. An
#' existing normalization can be updated for a different unit of expression or
#' after a conversion to a related spectral quantity.
#'
#' By default the function is applied to the whole spectrum, but by passing a
#' range of wavelengths as input, the search, e.g., for the maximum, can be
#' limited to a range of wavelengths of interest instead of the whole
#' spectrum.
#'
#' In 'photobiology' (>= 0.10.8) detailed information about the normalization
#' is stored in an attribute. In 'photobiology' (>= 0.10.10)
#' applying a new normalization to an already normalized spectrum recomputes
#' the multiplier factors stored in the attributes whenever possible. This
#' ensures that the returned object is identical, except for possible
#' accumulated loss of precision due to floating-point arithmetic,
#' independently of the previous application of a different normalization.
#'
#' @note When the spectrum passed as argument to \code{x} had been previously
#' scaled, in 'photobiology' (<= 0.10.9) the scaling attribute was always
#' removed and no normalization factors returned. In 'photobiology'
#' (>= 0.10.10) scaling information can be preserved by passing
#' \code{keep.scaling = TRUE}.
#'
#' By default if \code{x} contains one or more \code{NA} values and the
#' normalization is based on a summary quantity, the returned spectrum will
#' contain only \code{NA} values. If \code{na.rm == TRUE} then the summary
#' quantity will be calculated after striping \code{NA} values, and only the
#' values that were \code{NA} in \code{x} will be \code{NA} values in the
#' returned spectrum.
#'
#' When a numeric value is passed as argument to keep.scaling, the scaling
#' uses \code{f = "total"} or \code{f = "mean"} depending on the class of
#' \code{x}. Prescaling is only occasionally needed.
#'
#' Method \code{normalize} is implemented for \code{solute_spct} objects but
#' as the spectral data stored in them are a description of an intensive
#' property of a substance, normalization is unlikely to useful. To represent
#' solutions of specific concentrations of solutes, \code{filter_spct} objects
#' should be used instead.
#'
#' @param x An R object
#' @param ... not used in current version
#'
#' @return A copy of the object passed as argument to \code{x} with the values
#' of the spectral quantity rescaled to 1 at the normalization wavelength. If
#' the normalization wavelength is not already present in \code{x}, it is
#' added by interpolation---i.e. the returned value may be one row longer than
#' \code{x}. Attributes \code{normalized} and \code{normalization} are set to
#' keep a log of the computations applied.
#'
#' @examples
#'
#' normalize(sun.spct)
#' normalise(sun.spct) # equivalent
#'
#' normalize(sun.spct, norm = "max")
#' normalize(sun.spct, norm = 400)
#'
#' @export
#'
#' @family rescaling functions
#'
normalize <- function(x, ...) UseMethod("normalize")
#' @rdname normalize
#'
#' @note \code{normalise()} is a synonym for this \code{normalize()} method.
#'
#' @export
#'
normalise <- normalize
#' @describeIn normalize Default for generic function
#'
#' @export
#'
normalize.default <- function(x, ...) {
warning("'normalize' is not defined for objects of class '", class(x)[1], "'.")
x
}
#' @describeIn normalize Normalize a \code{source_spct} object.
#'
#' @param range An R object on which \code{range()} returns a numeric vector of
#' length 2 with the limits of a range of wavelengths in nm, with min and max
#' wavelengths (nm) used to set boundaries for search for normalization.
#' @param norm numeric Normalization wavelength (nm) or character string "max",
#' or "min" for normalization at the corresponding wavelength, "update" to
#' update the normalization after modifying units of expression, quantity
#' or range but respecting the previously used criterion, or "skip" to force
#' return of \code{x} unchanged.
#' @param unit.out character Allowed values "energy", and "photon",
#' or its alias "quantum"
#' @param keep.scaling logical or numeric Flag to indicate if any existing
#' scaling should be preserved or not. The default, \code{FALSE}, preserves
#' the behaviour of versions (<= 0.10.9). If numeric, the spectrum is scaled
#' to this value before normalization and marked as not scaled.
#' @param na.rm logical indicating whether \code{NA} values should be stripped
#' before calculating the summary (e.g. "max") used for normalization.
#'
#' @export
#'
normalize.source_spct <- function(x,
...,
range = NULL,
norm = "max",
unit.out = getOption("photobiology.radiation.unit",
default = "energy"),
keep.scaling = FALSE,
na.rm = FALSE) {
if (getMultipleWl(x) > 1L) {
# brute force and slow approach, unsuitable for long time series
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.source_mspct(x = mspct,
range = range,
norm = norm,
unit.out = unit.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
if (is.numeric(keep.scaling)) {
if (!norm %in% c("update", "skip")) {
x <- setNormalised(x, FALSE)
}
x <- fscale(x,
range = range,
f = "total",
target = keep.scaling,
unit.out = unit.out,
set.scaled = FALSE)
keep.scaling <- FALSE
}
if (unit.out == "energy") {
return(normalize_spct(spct = q2e(x, action = "replace.raw"),
range = range,
norm = norm,
col.names = "s.e.irrad",
keep.scaling = keep.scaling,
na.rm = na.rm,
...))
} else if (unit.out %in% c("photon", "quantum") ) {
return(normalize_spct(spct = e2q(x, action = "replace.raw"),
range = range,
norm = norm,
col.names = "s.q.irrad",
keep.scaling = keep.scaling,
na.rm = na.rm,
...))
} else {
stop("'unit.out ", unit.out, " is unknown")
}
}
#' @describeIn normalize Normalize a response spectrum.
#'
#' @export
#'
normalize.response_spct <- function(x,
...,
range = NULL,
norm = "max",
unit.out = getOption("photobiology.radiation.unit",
default = "energy"),
keep.scaling = FALSE,
na.rm = FALSE) {
if (getMultipleWl(x) > 1L) {
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.response_mspct(x = mspct,
range = range,
norm = norm,
unit.out = unit.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
if (is.numeric(keep.scaling)) {
if (!norm %in% c("update", "skip")) {
x <- setNormalised(x, FALSE)
}
x <- fscale(x,
range = range,
f = "total",
target = keep.scaling,
unit.out = unit.out,
set.scaled = FALSE)
keep.scaling <- FALSE
}
if (unit.out == "energy") {
return(normalize_spct(spct = q2e(x, action = "replace.raw"),
range = range,
norm = norm,
col.names = "s.e.response",
keep.scaling = keep.scaling,
na.rm = na.rm,
...))
} else if (unit.out %in% c("photon", "quantum") ) {
return(normalize_spct(spct = e2q(x, action = "replace.raw"),
range = range,
norm = norm,
col.names = "s.q.response",
keep.scaling = keep.scaling,
na.rm = na.rm,
...))
} else {
stop("'unit.out ", unit.out, " is unknown")
}
}
#' @describeIn normalize Normalize a filter spectrum.
#'
#' @param qty.out character string Allowed values are "transmittance", and
#' "absorbance" indicating on which quantity to apply the normalization.
#'
#' @export
#'
normalize.filter_spct <-
function(x,
...,
range = NULL,
norm = "max",
qty.out = getOption("photobiology.filter.qty",
default = "transmittance"),
keep.scaling = FALSE,
na.rm = FALSE) {
if (getMultipleWl(x) > 1L) {
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.filter_mspct(x = mspct,
range = range,
norm = norm,
qty.out = qty.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
if (is.numeric(keep.scaling)) {
if (!norm %in% c("update", "skip")) {
x <- setNormalised(x, FALSE)
}
x <- fscale(x,
range = range,
f = "mean",
target = keep.scaling,
qty.out = qty.out,
set.scaled = FALSE)
keep.scaling <- FALSE
}
if (qty.out == "transmittance") {
return(normalize_spct(spct = A2T(x, action = "replace.raw"),
range = range,
norm = norm,
col.names = "Tfr",
keep.scaling = keep.scaling,
na.rm = na.rm,
...))
} else if (qty.out == "absorbance") {
return(normalize_spct(spct = T2A(x, action = "replace.raw"),
range = range,
norm = norm,
col.names = "A",
keep.scaling = keep.scaling,
na.rm = na.rm,
...))
} else if (qty.out == "absorptance") {
return(normalize_spct(spct = T2Afr(x, action = "replace.raw"),
range = range,
norm = norm,
col.names = "Afr",
keep.scaling = keep.scaling,
na.rm = na.rm,
...))
} else {
stop("'qty.out ", qty.out, " is unknown")
}
}
#' @describeIn normalize Normalize a reflector spectrum.
#'
#' @export
#'
normalize.reflector_spct <-
function(x,
...,
range = NULL,
norm = "max",
qty.out = NULL,
keep.scaling = FALSE,
na.rm = FALSE) {
if (getMultipleWl(x) > 1L) {
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.reflector_mspct(x = mspct,
range = range,
norm = norm,
qty.out = qty.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
if (is.numeric(keep.scaling)) {
if (!norm %in% c("update", "skip")) {
x <- setNormalised(x, FALSE)
}
x <- fscale(x,
range = range,
f = "mean",
target = keep.scaling,
set.scaled = FALSE)
keep.scaling <- FALSE
}
normalize_spct(spct = x,
range = range,
norm = norm,
col.names = "Rfr",
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
}
#' @describeIn normalize Normalize a solute spectrum.
#'
#' @export
#'
normalize.solute_spct <-
function(x,
...,
range = NULL,
norm = "max",
keep.scaling = FALSE,
na.rm = FALSE) {
# for consistency use qty.out parameter and add support!!!
if (getMultipleWl(x) > 1L) {
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.solute_mspct(x = mspct,
range = range,
norm = norm,
# qty.out = qty.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
if (is.numeric(keep.scaling)) {
warning("Scaling before normalization not supported for class ", class(x)[1])
keep.scaling <- FALSE
}
cols <- intersect(c("K.mole", "K.mass"), names(x))
if (length(cols) == 1) {
col.name <- cols
} else {
stop("Invalid number of columns found:", length(cols))
}
normalize_spct(spct = x,
range = range,
norm = norm,
col.names = col.name,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
}
#' @describeIn normalize Normalize a raw spectrum.
#'
#' @export
#'
normalize.raw_spct <-
function(x,
...,
range = NULL,
norm = "max",
keep.scaling = FALSE,
na.rm = FALSE) {
if (getMultipleWl(x) > 1L) {
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.raw_mspct(x = mspct,
range = range,
norm = norm,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
if (is.numeric(keep.scaling)) {
if (!norm %in% c("update", "skip")) {
x <- setNormalised(x, FALSE)
}
x <- fscale(x,
range = range,
f = "mean",
target = keep.scaling,
set.scaled = FALSE)
keep.scaling <- FALSE
}
normalize_spct(spct = x,
range = range,
norm = norm,
col.names = grep("^counts", names(x), value = TRUE),
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
}
#' @describeIn normalize Normalize a cps spectrum.
#'
#' @export
#'
normalize.cps_spct <-
function(x,
...,
range = NULL,
norm = "max",
keep.scaling = FALSE,
na.rm = FALSE) {
if (getMultipleWl(x) > 1L) {
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.cps_mspct(x = mspct,
range = range,
norm = norm,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
if (is.numeric(keep.scaling)) {
if (!norm %in% c("update", "skip")) {
x <- setNormalised(x, FALSE)
}
x <- fscale(x,
range = range,
f = "mean",
target = keep.scaling,
set.scaled = FALSE)
keep.scaling <- FALSE
}
normalize_spct(spct = x,
range = range,
norm = norm,
col.names = grep("^cps", names(x), value = TRUE),
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
}
#' @describeIn normalize Normalize a raw spectrum.
#'
#' @param col.names character vector containing the names of columns or
#' variables to which to apply the normalization.
#'
#' @export
#'
normalize.generic_spct <-
function(x,
...,
range = NULL,
norm = "max",
col.names,
keep.scaling = FALSE,
na.rm = FALSE) {
if (is.numeric(keep.scaling)) {
warning("Pre-scaling before normalization not implemented for class ", class(x)[1])
keep.scaling <- FALSE
}
if (getMultipleWl(x) > 1L) {
mspct <- subset2mspct(x,
idx.var = getIdFactor(x),
drop.idx = FALSE)
mspct <-
normalize.generic_mspct(x = mspct,
range = range,
norm = norm,
col.names = col.names,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
return(rbindspct(mspct, idfactor = getIdFactor(x), attrs.simplify = TRUE))
}
normalize_spct(spct = x,
range = range,
norm = norm,
col.names = col.names,
keep.scaling = keep.scaling,
na.rm = na.rm,
...)
}
# collections of spectra --------------------------------------------------
#' @describeIn normalize Normalize the members of a source_mspct object.
#'
#' @param .parallel if TRUE, apply function in parallel, using parallel backend
#' provided by foreach
#' @param .paropts a list of additional options passed into the foreach function
#' when parallel computation is enabled. This is important if (for example)
#' your code relies on external data or packages: use the .export and
#' .packages arguments to supply them so that all cluster nodes have the
#' correct environment set up for computing.
#'
#' @export
#'
normalize.source_mspct <-
function(x,
...,
range = NULL,
norm = "max",
unit.out = getOption("photobiology.radiation.unit",
default = "energy"),
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize.source_spct,
range = range,
norm = norm,
unit.out = unit.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
#' @describeIn normalize Normalize the members of a response_mspct object.
#'
#' @export
#'
normalize.response_mspct <-
function(x,
...,
range = NULL,
norm = "max",
unit.out = getOption("photobiology.radiation.unit",
default = "energy"),
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize.response_spct,
range = range,
norm = norm,
unit.out = unit.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
#' @describeIn normalize Normalize the members of a filter_mspct object.
#'
#' @export
#'
normalize.filter_mspct <-
function(x,
...,
range = NULL,
norm = "max",
qty.out = getOption("photobiology.filter.qty",
default = "transmittance"),
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize.filter_spct,
range = range,
norm = norm,
qty.out = qty.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
#' @describeIn normalize Normalize the members of a reflector_mspct object.
#'
#' @export
#'
normalize.reflector_mspct <- function(x,
...,
range = x,
norm = "max",
qty.out = NULL,
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize.reflector_spct,
range = range,
norm = norm,
qty.out = qty.out,
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
#' @describeIn normalize Normalize the members of a raw_mspct object.
#'
#' @export
#'
normalize.raw_mspct <- function(x,
...,
range = x,
norm = "max",
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize.raw_spct,
range = range,
norm = norm,
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
#' @describeIn normalize Normalize the members of a cps_mspct object.
#'
#' @export
#'
normalize.cps_mspct <- function(x,
...,
range = x,
norm = "max",
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize.cps_spct,
range = range,
norm = norm,
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
#' @describeIn normalize Normalize the members of a solute_mspct object.
#'
#' @export
#'
normalize.solute_mspct <- function(x,
...,
range = x,
norm = "max",
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize.solute_spct,
range = range,
norm = norm,
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
#' @describeIn normalize Normalize the members of a solute_mspct object.
#'
#' @export
#'
normalize.generic_mspct <- function(x,
...,
range = NULL,
norm = "max",
col.names,
keep.scaling = FALSE,
na.rm = FALSE,
.parallel = FALSE,
.paropts = NULL) {
if (!length(x)) return(x) # class of x in no case changes
msmsply(x,
normalize, # members can be heterogeneous
range = range,
norm = "max",
keep.scaling = keep.scaling,
na.rm = na.rm,
...,
.parallel = .parallel,
.paropts = .paropts)
}
# PRIVATE -----------------------------------------------------------------
#' @keywords internal
#'
normalize_spct <- function(spct,
range,
norm,
col.names,
na.rm,
keep.scaling,
...) {
stopifnot(is.generic_spct(spct))
# handle "skip" early so that long-form multiple spectra or missing columns
# do not trigger errors
if (is.na(norm) ||
is.null(norm) ||
norm == "skip" ||
(norm == "update" && !is_normalized(spct))) {
return(spct)
}
stopifnot("Missing columns" = all(col.names %in% colnames(spct)),
"Multiple spectra in long form" = getMultipleWl(spct) == 1L)
if (na.rm) {
x <- na.omit(spct)
} else {
x <- spct
}
if (is.null(range) || all(is.na(range))) {
range <- wl_range(x, na.rm = TRUE)
} else {
x <- trim_wl(x, range)
range <- wl_range(x, na.rm = TRUE) # if range was broader x is not expanded
}
stopifnot(nrow(x) > 2) # too short a slice
updating <- is_normalized(spct)
if (updating) {
old.normalization.ls <- getNormalization(spct)
has.normalization.metadata <- !any(is.na(unlist(old.normalization.ls)))
if (norm == "update") {
if (!has.normalization.metadata) {
warning("Normalization not updated: action not supported for objects created with 'photobiology' (<= 0.10.9).")
return(spct)
} else {
norm <- old.normalization.ls$norm.type
if (norm == "wavelength") {
norm <- old.normalization.ls$norm.wl
}
}
}
} else if (norm == "update") {
# not normalized, nothing to update
return(spct)
}
norm.arg <- norm
# normalization will wipe out any existing scaling except for its effect
# on the computed factors.
if (is_scaled(spct) && !keep.scaling) {
# Only behaviour in <= 0.10.9
# remove scaling metadata and do not save norm.factors
scale.is.dirty <- TRUE
setScaled(spct, scaled = FALSE)
} else {
# retain scaling metadata and save norm.factors
scale.is.dirty <- FALSE
}
if (updating) {
# We remove old normalization
setNormalized(spct, norm = FALSE)
}
# rescaling needed
scale.factors <- numeric(0)
for (col in col.names) {
if (is.character(norm)) {
if (norm %in% c("max", "maximum")) {
idx <- which.max(x[[col]])
} else if (norm %in% c("min", "minimum")) {
idx <- which.min(x[[col]])
} else {
warning("Invalid 'norm' value: '", norm, "'")
idx <- NA
}
scale.factor <- 1 / x[idx, col, drop = TRUE]
norm <- x[idx, "w.length", drop = TRUE]
} else if (is.numeric(norm)) {
if (norm >= range[1] && norm <= range[2]) {
tmp.spct <- spct[ , c("w.length", col)]
class(tmp.spct) <- class(spct)
scale.factor <- 1 /
interpolate_spct(spct = tmp.spct, w.length.out = norm)[ , eval(col)]
} else {
warning("'norm = ", norm, "' value outside spectral data range of ",
round(min(tmp.spct), 1), " to ", round(max(tmp.spct), 1), " (nm)")
scale.factor <- NA
}
} else {
stop("'norm' should be numeric or character")
}
scale.factors <- c(scale.factors, scale.factor)
spct[[col]] <- spct[ , col, drop = TRUE] * scale.factor
}
# filter_spct, reflector_spct and object_spct -> different quantities
# source_spct, response_spct -> photon and energy conversion depends on wl
if (updating && has.normalization.metadata &&
length(scale.factors) == length(old.normalization.ls[["norm.factors"]]) &&
all(col.names == old.normalization.ls[["norm.cols"]])) { #
scale.factors <- scale.factors / old.normalization.ls[["norm.factors"]]
updating <- FALSE
}
z <- setNormalized(spct,
norm = norm,
norm.type =
if (is.character(norm.arg)) {
norm.arg
} else if (is.numeric(norm.arg)) {
"wavelength"
},
norm.factors =
if (scale.is.dirty || updating) {
rep(NA_real_, length(col.names))
} else {
scale.factors
},
norm.cols = col.names,
norm.range = range)
z # setNormalized makes its returned value invisible
}
# is_normalized function --------------------------------------------------
#' Query whether a generic spectrum has been normalized.
#'
#' This function tests a \code{generic_spct} object for an attribute that
#' signals whether the spectral data has been normalized or not after the object
#' was created.
#'
#' @param x An R object.
#'
#' @return A \code{logical} value indicating if \code{x} is normalized or not,
#' for collections of spectra, a named list with \code{logicals} as members.
#' If \code{x} is not a \code{generic_spct} or \code{generic_mspct} object the
#' value returned is \code{NA}.
#'
#' @export
#' @family rescaling functions
#'
is_normalized <- function(x) {
if (is.generic_spct(x) || is.summary_generic_spct(x)) {
spct.attr <- attr(x, "normalized", exact = TRUE)
# in some versions a logical was used, but later the normalization wavelength
# in old versions the attribute was set only when normalization was applied
stopifnot(is.null(spct.attr) || is.numeric(spct.attr) || is.logical(spct.attr))
!is.null(spct.attr) && as.logical(spct.attr)
} else if (is.generic_mspct(x)) {
return(mslply(x, is_normalized))
} else {
return(NA)
}
}
#' @rdname is_normalized
#'
#' @note \code{is_normalised()} is a synonym for this \code{is_normalized()}
#' method.
#'
#' @export
#'
is_normalised <- is_normalized
# getNormalized -----------------------------------------------------------
#' Query the "normalized" and "normalization" attributes
#'
#' Functions to read the "normalized" and "normalization" attributes of an
#' existing generic_spct object.
#'
#' @param x a generic_spct object.
#' @param .force.numeric logical If \code{TRUE} always silently return a
#' numeric value, with \code{FALSE} encoded as zero, and character values
#' as \code{NA}.
#'
#' @details Spectral data that has been normalized needs to be used diffferently
#' in computations than data expresed in original units. These two functions
#' make it possible to query if data stored in an object of class
#' \code{generic_spct} or of a derived class contains data expressed in
#' physical units or normalized. In the later case, it is possible to also
#' query how the normalization was done.
#'
#' @return \code{getNormalized()} returns numeric or logical (possibly character
#' for objects created with earlier versions); for collections of spectra, a
#' named list, with one member for each spectrum. If \code{x} is not a
#' \code{generic_spct} object, \code{NA} or a list with fields set to NAs is
#' returned. Objects created with versions of package 'photobiology' earlier
#' than 0.10.8 are lacking the detailed normalization metadata.
#'
#' @export
#'
#' @examples
#'
#' getNormalized(sun.spct)
#' getNormalization(sun.spct)
#'
#' sun_norm.spct <- normalize(sun.spct)
#'
#' getNormalized(sun_norm.spct)
#' getNormalization(sun_norm.spct)
#'
#' getNormalization(e2q(sun_norm.spct))
#'
#' gel_norm.spct <- normalize(yellow_gel.spct)
#'
#' getNormalized(gel_norm.spct)
#' getNormalization(gel_norm.spct)
#'
#' getNormalization(T2Afr(gel_norm.spct))
#' getNormalization(any2A(gel_norm.spct))
#'
#' @family rescaling functions
#'
getNormalized <- function(x,
.force.numeric = FALSE) {
if (is.generic_spct(x) || is.summary_generic_spct(x)) {
normalized <- attr(x, "normalized", exact = TRUE)
if (is.null(normalized) || is.na(normalized)) {
# need to handle objects created with very old versions
normalized <- FALSE
}
} else if (is.generic_mspct(x)) {
return(mslply(x, getNormalized, .force.numeric = .force.numeric))
} else {
warning("Method 'getNormalized()' not implemented for class: ",
class(x)[1])
normalized <- NA
}
if (.force.numeric) {
suppressWarnings(as.numeric(normalized[[1]]))
} else {
normalized[[1]]
}
}
#' @rdname getNormalized
#'
#' @note \code{getNormalised()} is a synonym for this \code{getNormalized()}
#' method.
#'
#' @export
#'
getNormalised <- getNormalized
#' @rdname getNormalized
#'
#' @return \code{getNormalization()} returns a list with five fields: norm.type,
#' norm.wl, norm.factors, norm.cols, norm.range. For collections of spectra, a
#' named list of lists, with one member list for each member of the collection
#' of spectra. See \code{\link{setNormalized}()} for the values stored in the
#' fields.
#'
#' @export
#'
getNormalization <- function(x) {
if (is.generic_spct(x) || is.summary_generic_spct(x)) {
if (is_normalized(x)) {
# attribute in use >= 0.10.8
normalization.list <- attr(x, "normalization", exact = TRUE)
if (is.list(normalization.list)) {
if (!exists("norm.range", normalization.list)) {
# norm.range is missing 0.10.8 and 0.10.9
normalization.list[["norm.range"]] <- rep(NA_real_, 2)
}
return(normalization.list)
}
}
} else if (is.generic_mspct(x)) {
return(mslply(x, getNormalization))
} else {
warning("Method 'getNormalization()' not implemented for class: ",
class(x)[1])
}
list(norm.type = NA_character_,
norm.wl = NA_real_,
norm.factors = NA_real_,
norm.cols = NA_character_,
norm.range = rep(NA_real_, 2))
}
#' @rdname getNormalized
#' @export
#'
getNormalisation <- getNormalization
#' Set the "normalized" and "normalization" attributes
#'
#' Function to write the "normalized" attribute of an existing generic_spct
#' object.
#'
#' @param x a generic_spct object.
#' @param norm numeric (or logical) Normalization wavelength (nanometres).
#' @param norm.type character Type of normalization applied.
#' @param norm.factors numeric The scaling factor(s) so that dividing the spectral
#' values by this factor reverts the normalization.
#' @param norm.cols character The name(s) of the data columns normalized.
#' @param norm.range numeric The wavelength range used for normalization (nm).
#' @param verbose logical Flag enabling or silencing informative warnings.
#'
#' @details This function \strong{is used internally}, although occasionally
#' users may want to use it to "pretend" that spectral data have not been
#' normalized. Use \code{\link{normalize}()} methods to apply a normalization
#' and set the attributes accordingly. Function \code{setNormalized()} only
#' sets the attributes that store the metadata corresponding to an already
#' applied normalization. Thus a trace of the transformations applied to
#' spectral data is kept, which currently is used to renormalize the spectra
#' when the quantity used for expression is changed with a conversion
#' function. It is also used in other packages like 'ggspectra' when
#' generating automatically axis labels. If \code{x} is not a
#' \code{generic_spct} object, \code{x} is not modified.
#'
#' @note Passing a \code{logical} as argument to \code{norm} is deprecated
#' but accepted silently for backwards compatibility.
#'
#' @export
#' @family rescaling functions
#'
setNormalized <- function(x,
norm = FALSE,
norm.type = NA_character_,
norm.factors = NA_real_,
norm.cols = NA_character_,
norm.range = rep(NA_real_, 2),
verbose = getOption("verbose_as_default", default = FALSE)) {
stopifnot("'norm' must be numeric or logical, but it is not" =
is.numeric(norm) || is.logical(norm))
name <- substitute(x)
if ((is.generic_spct(x) || is.summary_generic_spct(x)) &&
(is.na(norm) || is.numeric(norm) || is.logical(norm))) {
attr(x, "normalized") <- norm
normalization.ls <- list(norm.type = norm.type,
norm.wl = ifelse(is.numeric(norm),
norm,
NA_real_),
norm.factors = norm.factors,
norm.cols = norm.cols,
norm.range = norm.range)
if (verbose && norm && anyNA(normalization.ls, recursive = TRUE)) {
message("\"normalized\" attribute set to TRUE, with missing ",
paste(names(normalization.ls)[which(is.na(normalization.ls))], collapse = ". "),
"data.")
}
attr(x, "normalization") <- normalization.ls
if (is.name(name)) {
name <- as.character(name)
assign(name, x, parent.frame(), inherits = TRUE)
}
}
invisible(x)
}
#' @rdname setNormalized
#'
#' @note \code{setNormalised()} is a synonym for this \code{setNormalized()}
#' method.
#'
#' @export
#'
setNormalised <- setNormalized
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.