Nothing
R/build_lib.R
In OpenSpecy: Analyze, Process, Identify, and Share Raman and (FT)IR Spectra
Defines functions
.lib_build_core
rebuild_lib_artifacts
build_lib
Documented in
build_lib
rebuild_lib_artifacts
#' @rdname build_lib
#' @title Build spectral libraries
#'
#' @description
#' Create reference libraries from source files and OpenSpecy objects.
#' When \code{output_dir} is supplied, \code{build_lib()} runs the official
#' end-to-end workflow and returns raw,
#' processed, medoid, model, and assessment artifacts in one object. Supporting
#' functions remain available for advanced composition.
#'
#' @details
#' \code{build_lib()} combines sources over their full wavenumber range,
#' optionally adds ordinary and hierarchical metadata, removes requested
#' identifiers, optionally generates stable source-stage duplicate IDs, and
#' applies named processing recipes. Source-stage IDs follow the reference
#' library's legacy hash recipe: each source spectrum is trimmed with
#' \code{\link{manage_na}(type = "remove")}, conformed at resolution 8,
#' smoothed, and hashed from the resulting wavenumber/intensity vectors before
#' later merging and range restriction. The older 100--4000 cm-1 hash is kept in
#' \code{sample_name_old} when \code{id_col = "sample_name"} so
#' \code{exclude_ids} can remove both current and legacy curated bad IDs.
#' Metadata column names are first converted to lowercase
#' underscore names and known aliases are coalesced using
#' \code{metadata_name_lookup}; see \code{\link{lib_clean_metadata}()} for
#' automatic and regular-expression matching. Metadata values can optionally be
#' normalized to lowercase trimmed character values before lookup joins.
#' \code{spectrum_identity} is also reduced to a basename when it is a
#' recognizable path, then trailing extensions supported by
#' \code{\link{read_any}()} are removed. The same normalization is applied to
#' exact lookup keys. Regex class rules belong in a separate table and can be
#' applied afterward with \code{\link{predict_class_reference}()}.
#' This keeps filenames usable as identities without treating file containers
#' as part of a material name. By default, each source is also
#' converted to absorbance before merging when its intensity units are known.
#' A nonempty \code{intensity_unit} object attribute takes precedence over the
#' per-spectrum \code{intensity_units} metadata column. Each recipe is either a
#' named list of arguments passed to \code{\link{process_spec}()} or a function
#' accepting one \code{OpenSpecy} object. An empty recipe returns an unprocessed
#' copy. Signal-to-noise is added by default, and optional
#' \code{\link{assess_spec}()} results are summarized into one metadata row per
#' spectrum.
#' Progress messages report named stages and elapsed time by default so
#' long-running builds remain observable.
#'
#' The official workflow requires explicit source paths and an output
#' directory. When \code{workflow_data} is omitted, \code{build_lib()} looks
#' for the curated helper tables under \code{data/} beside the calling script,
#' then under \code{data/} or \code{workflows/data/} in the current working
#' directory. It writes each completed stage under
#' \code{output_dir/checkpoints}, and promotes validated legacy-compatible files
#' into a versioned release directory. With \code{reuse = TRUE}, a checkpoint
#' is reused only when its manifest signature matches the source files, curated
#' tables, relevant arguments, package version, and builder implementation.
#' Full assessments use the complete candidate and legacy artifacts. Seeded
#' ten-percent holdouts are allocated independently within each source across
#' class/type strata after physical identifiers and exact spectral-content
#' duplicates have been joined into stable groups. Candidate artifacts are assessed on candidate data and
#' legacy artifacts on legacy data, so taxonomy changes do not require fuzzy
#' cross-version class matching. Query identifiers are removed from full and
#' references by group before matching to prevent transformed duplicate or
#' physical-replicate self-matches. Each medoid artifact separately identifies
#' its complete corresponding processed library, measuring the deployed medoid
#' search directly without another split. Model assessments do not retrain models:
#' each existing candidate or legacy model identifies its complete corresponding
#' source dataset once. This measures the deployed artifact directly and keeps
#' assessment generation bounded by prediction rather than model fitting.
#' After derivative and baseline-removal processing, FTIR spectra whose
#' 2200--2420 CO2-region maximum exceeds twice the 2420--2550 silent-region
#' maximum are flattened and reassessed; failed postconditions are removed.
#' High-tail checks use each spectrum's finite support;
#' tails are trimmed and reassessed, failed corrections are removed, and
#' spectra with running signal-to-noise below two are removed before pruning.
#' Full artifacts are then partitioned into Raman (200--4000), FTIR
#' (400--4000), and NIR (4000--12000) \code{OpenSpecy} objects.
#' After pruning and class reassignment, the official workflow derives
#' \code{material_form} from the curated form-regex CSV and all atomic metadata
#' values, then joins evidence-backed \code{common_use} by final material class.
#' Existing form values take precedence when uniquely standardized; conflicting
#' form categories remain missing and are audited. Common use may be
#' \code{"consumer"}, \code{"industrial"}, \code{"mixed"}, or missing;
#' quantitative mass shares are retained when available, while sourced
#' qualitative proposals remain explicit in the review table.
#' After full and medoid libraries are complete, metadata columns containing
#' only missing values are removed, except that these two standardized fields
#' are retained, and the remainder are stably ordered from the fewest to the
#' most missing values. Spectra, metadata rows, identifiers, axes, and object
#' attributes are unchanged.
#' Official class completion temporarily assigns unresolved identities to
#' \code{"other"}. By default, spectra with a blank identity or that unresolved
#' literal class are removed before quality control and retained in the
#' \code{other_review} assessment table. Reviewed \code{"other plastic"} and
#' \code{"other material"} rows stay in the reference library and enter
#' \code{prune_lib()}'s nearest-class semisupervised pathway.
#' When requested, \code{prune_lib()} first resolves high-correlation conflicts
#' between different reviewed classes within each source library. It repeatedly
#' removes the spectrum with the most active wrong-class neighbors, recalculates
#' after each round, and removes both endpoints of an adjacent maximum-score
#' tie. It then resolves between-library conflicts by the number of distinct
#' independent libraries supporting the opposing class. Generic and
#' unclassified labels do not participate. Official builds repeat closure on
#' the rounded typed and model-range views before deriving medoids, and retain
#' excluded spectra plus conflict provenance in
#' \code{quarantined_spectra.rds}. Pruning then reassigns generic classes by nearest same-technique
#' correlation: \code{"other"} may use any established class,
#' \code{"other plastic"} requires a plastic candidate, and
#' \code{"other material"} requires \code{"organic matter"} or
#' \code{"mineral"}. The matched material type and a correlation audit are
#' retained. Once those labels are resolved, each class/spectrum-type group with
#' fewer than \code{min_n} spectra is reassigned as a whole to its
#' most-correlated established class in the same technique pool and material
#' type. A group is removed only when no eligible correlated destination
#' exists. The report identifies its support, destination, class-level
#' correlation, action, reason, and affected spectrum identifiers.
#'
#' \code{make_lib_lookup_template()} creates a deduplicated table of metadata
#' values from an \code{OpenSpecy} or \code{Specs} object. Users can fill the
#' added columns in R or write the template to CSV and curate it elsewhere.
#'
#' \code{join_lib_metadata()} left-joins lookup columns onto object metadata and
#' reports unmatched metadata keys, duplicate lookup keys, and missing joined
#' values. Joins are exact; clean or harmonize values before calling this helper.
#'
#' \code{join_material_hierarchy()} joins user-defined hierarchical material
#' metadata. The supplied \code{levels} are tried from most-specific to
#' most-general so a material label can match any level in the hierarchy.
#'
#' \code{dedupe_spec()} hashes the current spectra and wavenumber axis to create
#' stable IDs and remove duplicated spectra. Process or conform spectra before
#' this step when that should affect duplicate detection.
#'
#' \code{reduce_lib()} uses PAM medoids to keep representative spectra within
#' each metadata group. It uses OpenSpecy's optimized correlation routine on
#' relative spectra whose missing values are temporarily replaced by each
#' spectrum's finite mean. Groups of at most 3,000 spectra use exact PAM;
#' oversized groups use five deterministic 1,000-spectrum PAM samples and keep
#' the candidate set with the best full-group correlation-distance objective.
#' Official medoids are then selected from the original object so their genuine
#' missing values are preserved.
#'
#' \code{train_spec_model()} trains either OpenSpecy's multinomial logistic
#' regression model (\code{method = "logistic_regression"}) or an experimental
#' probability random forest (\code{method = "random_forest"}). Logistic
#' regression uses inverse class weights and stratified cross-validation to
#' select the lambda with the highest out-of-fold macro class accuracy. Random
#' forest uses inverse-frequency balanced case sampling and out-of-bag
#' predictions. This improves minority-class representation in each bootstrap
#' sample without applying a second class-vote correction.
#' Treat the stored out-of-bag metrics as fit diagnostics: balanced resampling
#' can make them optimistic. The library workflow separately reports accuracy
#' from applying each deployed model to its complete corresponding dataset.
#' Missing training values are replaced with the finite mean at each
#' wavenumber. The returned model carries the same training-mean filler so
#' \code{\link{match_spec}()} can identify partially covered spectra.
#' \code{build_model_lib()} is the backward-compatible wrapper used by older
#' scripts; \code{build_lib()} calls the dedicated trainer for official models.
#'
#' \code{assess_lib()} returns a compact summary of object validity, library
#' size, class balance, and optionally nearest-neighbor class consistency.
#'
#' \code{rebuild_lib_artifacts()} starts from completed type-keyed libraries
#' and rebuilds only medoids, models, and assessments. Its input and output
#' locations are explicit, and every downstream component is checkpointed so a
#' compatible interrupted run can resume without repeating completed work.
#' Checkpoint and release payloads carry SHA-256 hashes, and an existing
#' versioned release path is accepted only when its payload is unchanged.
#'
#' @param x an \code{OpenSpecy} or \code{Specs} object for metadata helpers.
#' For \code{build_lib()}, one \code{OpenSpecy}, a nonempty list containing only
#' \code{OpenSpecy} objects, or a nonempty character vector of file paths.
#' The official workflow requires \code{x}; it does not guess source-library
#' locations.
#' Each RDS path may store either one \code{OpenSpecy} or a list of them; other
#' paths are read with \code{\link{read_any}()}.
#' Large same-axis source lists are prepared in bulk to avoid repeated legacy
#' object coercion.
#' For \code{rebuild_lib_artifacts()}, a completed four-part build object, its
#' RDS path, or a build/output directory containing completed \code{libraries}
#' checkpoints.
#' @param lookup a data.frame, data.table, or csv file path used as a metadata
#' lookup table.
#' @param by named character vector mapping metadata columns to lookup columns,
#' or an unnamed character vector when the names are the same in both tables.
#' @param columns metadata columns to deduplicate into a template.
#' @param add blank columns to add to a template.
#' @param path optional csv path. If \code{NULL}, template helpers return a
#' data.table.
#' @param hierarchy a data.frame, data.table, or csv file path with hierarchical
#' material metadata.
#' @param key_col metadata column containing material labels to match.
#' @param levels hierarchy columns ordered from most-specific to most-general.
#' @param output_names names to use for hierarchy columns added to metadata.
#' @param require_complete logical; if \code{TRUE}, incomplete joins fail.
#' @param return whether to return an updated \code{OpenSpecy} object, joined
#' table, report list, or selected ids depending on the helper.
#' @param suffixes suffixes used when joined metadata and lookup tables share
#' non-key column names.
#' @param id_col metadata column used as the spectrum identifier.
#' @param exclude_ids identifiers to remove before returning a library.
#' @param duplicate how duplicated generated identifiers should be handled.
#' @param scale numeric multiplier used before hashing intensity values.
#' @param algo hash algorithm passed to \code{\link[digest]{digest}()}.
#' @param recipes named list of \code{\link{process_spec}()} argument lists or
#' functions. Names become names of the returned libraries.
#' @param dedupe logical; whether to generate stable IDs and remove duplicated
#' spectra in \code{build_lib()}.
#' @param range,res wavenumber range and resolution passed to \code{c_spec()}
#' when \code{build_lib()} combines multiple sources.
#' @param restrict_range_args optional named list of arguments passed to
#' \code{\link{restrict_range}()} after unit conversion and source merging.
#' Supplying the list triggers restriction; \code{make_rel = FALSE} is used
#' unless explicitly overridden.
#' @param metadata_lookups a lookup table, csv path, or list of lookup tables and
#' paths. A lookup may instead be supplied as \code{list(lookup = x, by = key)}
#' to use an explicit key (including a named metadata-to-lookup key mapping).
#' \code{fill_only = TRUE} preserves existing nonblank metadata values while
#' filling gaps from the lookup. The older \code{fallback_by} lookup field is
#' deprecated; canonical metadata keys are now filled from reviewed internal
#' aliases before any external join.
#' If non-\code{NULL}, each is joined with
#' \code{join_lib_metadata()}. Automatic ordinary lookups use the single shared
#' column that has overlapping values and unique lookup keys. Lookups with no
#' usable shared key are skipped with a message; lookups with multiple usable
#' shared keys are considered ambiguous and stop. Lookup values that share
#' non-key metadata column names are coalesced back into those columns, with
#' non-missing lookup values taking precedence.
#' @param material_hierarchy hierarchy table or csv path used when
#' non-\code{NULL}. It is joined with \code{join_material_hierarchy()} using the
#' default \code{"material"} metadata key.
#' @param metadata_name_lookup a data.frame or data.table with
#' \code{canonical_name}, \code{source_name}, and optional \code{regex} columns.
#' The default is returned by \code{\link{lib_metadata_name_lookup}()}; use
#' \code{NULL} to clean names without coalescing aliases.
#' @param clean_metadata_values logical or \code{NULL}; whether
#' \code{build_lib()} should lowercase, trim, ASCII-normalize, and normalize
#' blank/unknown character metadata values before joining. \code{NULL} enables
#' cleaning for the official output workflow and disables it for composable
#' in-memory builds. Invalid byte sequences are always converted to UTF-8.
#' @param convert_intensity logical; whether to infer reflectance,
#' transmittance, or absorbance units from each source and convert known
#' non-absorbance spectra with \code{\link{adj_intens}()} before merging.
#' Object attribute \code{intensity_unit} is authoritative when supplied;
#' otherwise metadata column \code{intensity_units} is evaluated per spectrum.
#' @param signal_noise logical; whether to append the default
#' \code{\link{sig_noise}()} result as metadata column \code{sn}.
#' @param assess logical; whether to run \code{\link{assess_spec}()} on each
#' output library and append assessment summaries to its metadata.
#' @param prune \code{NULL}, or a named list mapping recipe names to argument
#' lists for \code{\link{prune_lib}()}. Selected recipes are pruned independently
#' after processing and assessment. \code{NULL} preserves unpruned outputs.
#' @param progress logical; whether \code{build_lib()} reports named processing
#' stages and elapsed time, or \code{reduce_lib()} reports group sizes and
#' correlation/PAM timings.
#' @param workflow_data optional directory containing the curated reference CSV
#' tables. If \code{NULL}, the directory is discovered beside the calling
#' script or under the current working directory.
#' @param output_dir \code{NULL} for the composable in-memory return, or a
#' directory that triggers the complete checkpointed workflow. The official
#' workflow requires an explicit output directory.
#' @param previous_library_dir directory containing the seven legacy artifacts
#' used for complete old/new assessment, \code{"system"}, or \code{NULL} to skip
#' external comparison. The end-to-end workflow defaults to \code{"system"}
#' and retrieves missing artifacts with \code{get_lib()}.
#' @param reuse logical; whether manifest-compatible completed checkpoints and
#' versioned release files may be reused.
#' @param remove_other logical; in the official end-to-end workflow, whether
#' spectra with blank \code{spectrum_identity} or the unresolved literal
#' \code{"other"} class are removed before quality control, medoid selection,
#' and model fitting. Reviewed broad \code{"other plastic"} and
#' \code{"other material"} categories remain in the reference libraries and
#' are eligible for \code{prune_lib()}'s constrained nearest-class
#' reassignment. Removed and reviewed rows remain visible in
#' \code{assessments$cleanup$summary}. Source-only composable builds do not
#' apply the official filter.
#' @param seed fixed seed for the grouped old/new assessment split.
#' @param holdout fraction of stable spectrum groups reserved for assessment.
#' @param group_cols metadata columns defining groups for reduction.
#' @param k maximum representatives to keep for groups larger than
#' \code{min_n}.
#' @param min_n For \code{prune_lib()}, the minimum spectra required for a
#' resolved class within one spectrum type across the complete input database,
#' not within each source library. Smaller groups are reassigned as a whole to
#' their most-correlated eligible class, or removed when no valid destination
#' exists; groups exactly at the threshold are retained. For \code{reduce_lib()},
#' groups with \code{min_n} or fewer spectra are kept whole. Model trainers
#' fit only classes meeting the threshold.
#' @param cross_class logical; whether \code{prune_lib()} should resolve
#' within-library and then independent-library high-correlation matches between
#' different non-generic material classes before generic-class reassignment.
#' This requires complete canonical
#' \code{library_name} metadata. The composable default is \code{FALSE}; the
#' official derivative and no-baseline workflow enables it.
#' @param cross_class_threshold numeric Pearson-correlation threshold in
#' \code{[0, 1]}. Cross-class correlations strictly greater than this value
#' are conflicts when \code{cross_class = TRUE}.
#' @param class_col,type_col metadata columns used for model labels.
#' @param nearest logical; if \code{TRUE}, \code{assess_lib()} compares each
#' spectrum with its highest-correlation neighbor and reports the fraction where
#' that neighbor has the same \code{class_col} value.
#' @param alpha alpha value passed to \code{\link[glmnet]{glmnet}()}.
#' @param method classifier to train: \code{"logistic_regression"} (the
#' backward-compatible default) or \code{"random_forest"}. The latter requires
#' the suggested \pkg{ranger} package.
#' @param seed random seed used before model training.
#' @param grouped logical; whether multinomial coefficients use grouped
#' penalties.
#' @param weights logical; whether to use inverse class-frequency weights for
#' logistic regression or inverse-frequency case sampling for random forest.
#' @param make_relative logical; whether to normalize model inputs with
#' \code{\link{make_rel}()}.
#' @param material_type_col metadata column used to require plastic candidates
#' for \code{"other plastic"} and to update the type after generic-class
#' reassignment. \code{"other material"} candidates are restricted by
#' \code{class_col} to \code{"organic matter"} or \code{"mineral"};
#' \code{"other"} may match any established class in the spectral pool.
#' @param exclude numeric length-two wavenumber interval excluded from pruning
#' correlations.
#' @param \ldots further arguments passed to the underlying operation.
#'
#' @return
#' Each library returned by \code{build_lib()} includes a
#' \code{spectrum_identity_cleanup_report} attribute listing changed original
#' and normalized identities with their counts.
#' In composable mode, \code{build_lib()} returns a named list of
#' \code{OpenSpecy} libraries. Its end-to-end mode returns one list containing
#' \code{libraries}, \code{medoids}, \code{models}, and \code{assessments}.
#' Official libraries and medoids are nested by recipe and then
#' \code{ftir}, \code{raman}, or \code{nir}. Models are nested by algorithm,
#' recipe, and spectrum type. FTIR and Raman medoids/models use
#' 800--3200 while the NIR interval is derived from finite coverage within
#' 4000--12000. Assessments use five ordered process lists:
#' \code{cleanup}, \code{ref_lib}, \code{medoid}, \code{model}, and
#' \code{functionality}, with no more than ten nonempty review tables in total.
#' Every spectrum receives a derived \code{library_name}: populated
#' \code{organization} first, otherwise \code{user_name}. The cleanup summary
#' includes source-library counts at each major stage and identifies the first
#' stage and reason whenever an entire source library is dropped. Accuracy
#' tables contain overall aggregate metrics only in long form, confusion tables
#' retain misidentifications only, and model error-mode tables compare accuracy
#' percentages with and without each automated-test flag. Review tables reject
#' columns with more than 10 percent missing values. Row-level tests, split manifests, model-training
#' diagnostics, and release manifests remain hash-addressed evidence attributes
#' rather than additional review leaves. Each in-memory training model contains
#' one \code{tests} data.table and a one-spectrum \code{fill} object. Versioned
#' release directories instead store global build and model diagnostics only in
#' \code{assessments.rds}; library, medoid, and model files retain only runtime
#' data, scientific attributes, and prediction state. The companion
#' \code{reference_library_build.rds} is a lightweight release index. The
#' companion \code{quarantined_spectra.rds} stores valid \code{OpenSpecy}
#' objects by recipe/type, a long conflict table, and build provenance for
#' spectra excluded by cross-class closure.
#' \code{join_lib_metadata()}, \code{join_material_hierarchy()},
#' \code{dedupe_spec()}, \code{prune_lib()}, and \code{reduce_lib()} return an updated spectral
#' object unless \code{return} requests a table, report, or ids.
#' \code{make_lib_lookup_template()} returns a data.table unless \code{path} is
#' supplied, in which case it writes the csv and invisibly returns the table.
#' \code{train_spec_model()} and \code{build_model_lib()} return a list suitable
#' for AI classification with
#' \code{\link{match_spec}()} and one tidy \code{tests} table instead of
#' separate accuracy/confusion summaries. It also contains typed
#' \code{lambda_metrics} and \code{support} tables. Random-forest results also
#' contain out-of-bag metrics and feature importance. \code{assess_lib()}
#' returns a data.table summary.
#'
#' @examples
#' wavenumber <- seq(100, 6100, by = 100)
#' base_a <- dnorm(seq(-3, 3, length.out = length(wavenumber)))
#' base_b <- rev(cumsum(seq_along(wavenumber)))
#' spectra <- cbind(base_a, base_a + 0.1, base_a + 0.2,
#' base_b, base_b + 0.1, base_b + 0.2)
#' colnames(spectra) <- paste0("s", seq_len(ncol(spectra)))
#' mini <- as_OpenSpecy(
#' wavenumber,
#' spectra = spectra,
#' metadata = data.table::data.table(
#' sample_name = colnames(spectra),
#' source = rep(c("A", "B"), each = 3),
#' label = c("nylon 6", "polyamides", "nylon 6",
#' "pet", "polyesters", "pet"),
#' material_class = rep(c("polyamides", "polyesters"), each = 3),
#' spectrum_type = rep("ftir", 6),
#' intensity_units = rep("absorbance", 6)
#' ),
#' attributes = list(intensity_unit = "absorbance")
#' )
#'
#' name_lookup <- lib_metadata_name_lookup()
#' name_lookup[name_lookup$canonical_name == "material_color", ]
#'
#' make_lib_lookup_template(mini, columns = "source", add = "library_type")
#'
#' source_lookup <- data.frame(
#' source = c("A", "B"),
#' library_type = c("lab", "field"),
#' material = c("nylon 6", "pet")
#' )
#' joined <- join_lib_metadata(mini, source_lookup, by = "source",
#' require_complete = TRUE)
#'
#' hierarchy <- data.frame(
#' material = c("nylon 6", "pet"),
#' material_class = c("polyamides", "polyesters"),
#' material_type = c("plastic", "plastic")
#' )
#' joined <- join_material_hierarchy(joined, hierarchy, key_col = "label",
#' require_complete = TRUE)
#'
#' deduped <- dedupe_spec(joined)
#' reduced <- reduce_lib(deduped, group_cols = "material_class",
#' k = 1, min_n = 1)
#' libs <- build_lib(
#' mini,
#' recipes = list(
#' raw = list(),
#' derivative = list(
#' conform_spec = FALSE,
#' smooth_intens = TRUE,
#' smooth_intens_args = list(window = 15, derivative = 1),
#' make_rel = TRUE
#' )
#' ),
#' metadata_lookups = source_lookup,
#' material_hierarchy = hierarchy,
#' restrict_range_args = list(min = 100, max = 6000),
#' assess = TRUE,
#' dedupe = FALSE
#' )
#'
#' model <- suppressWarnings(train_spec_model(
#' joined, class_col = "material_class", type_col = NULL, min_n = 2,
#' nlambda = 3
#' ))
#' assess_lib(libs$raw, class_col = "material_class", nearest = FALSE)
#'
#' @seealso \code{\link{match_spec}()} for deploying trained models and
#' \code{\link{plotly_spec}()} for logistic coefficient overlays.
#'
#' @author
#' Win Cowger
#'
#' @importFrom data.table as.data.table data.table fread fwrite rbindlist setorder
#' @export
build_lib <- function(x, recipes = .default_lib_recipes(), range = "full",
res = 6, id_col = "sample_name", exclude_ids = NULL,
dedupe = TRUE, metadata_lookups = NULL,
material_hierarchy = NULL,
metadata_name_lookup = lib_metadata_name_lookup(),
clean_metadata_values = NULL,
convert_intensity = TRUE, restrict_range_args = NULL,
signal_noise = TRUE, assess = FALSE, prune = NULL,
progress = TRUE,
workflow_data = NULL,
output_dir = NULL, previous_library_dir = "system",
reuse = TRUE, remove_other = TRUE,
seed = 123, holdout = 0.1,
...) {
if (missing(x)) {
stop(
"'x' must specify the source library file path(s) or OpenSpecy object(s)",
call. = FALSE
)
}
official_mode <- !is.null(output_dir)
if (is.null(clean_metadata_values)) {
clean_metadata_values <- official_mode
}
if (!is.logical(reuse) || length(reuse) != 1L || is.na(reuse)) {
stop("'reuse' must be TRUE or FALSE", call. = FALSE)
}
if (!is.logical(remove_other) || length(remove_other) != 1L ||
is.na(remove_other)) {
stop("'remove_other' must be TRUE or FALSE", call. = FALSE)
}
if (!official_mode) {
return(.lib_build_core(
x = x, recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
progress = progress, ...
))
}
workflow_data <- .lib_find_workflow_data(workflow_data)
.lib_build_reference(
x = x, recipes = recipes, range = range, res = res,
id_col = id_col, exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
progress = progress, workflow_data = workflow_data,
output_dir = output_dir, previous_library_dir = previous_library_dir,
reuse = reuse, remove_other = remove_other,
seed = seed, holdout = holdout, ...
)
}
#' @rdname build_lib
#' @export
rebuild_lib_artifacts <- function(x, output_dir,
previous_library_dir = "system",
reuse = TRUE, seed = 123, holdout = 0.1,
progress = TRUE) {
.lib_rebuild_artifacts(
x = x, output_dir = output_dir,
previous_library_dir = previous_library_dir,
reuse = reuse, seed = seed, holdout = holdout, progress = progress
)
}
.lib_build_core <- function(x, recipes = .default_lib_recipes(), range = "full",
res = 6, id_col = "sample_name",
exclude_ids = NULL, dedupe = TRUE,
metadata_lookups = NULL,
material_hierarchy = NULL,
metadata_name_lookup = lib_metadata_name_lookup(),
clean_metadata_values = FALSE,
convert_intensity = TRUE,
restrict_range_args = NULL,
signal_noise = TRUE, assess = FALSE, prune = NULL,
progress = TRUE, ...) {
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
if (!is.logical(clean_metadata_values) ||
length(clean_metadata_values) != 1L ||
is.na(clean_metadata_values)) {
stop("'clean_metadata_values' must be TRUE or FALSE", call. = FALSE)
}
started <- proc.time()[["elapsed"]]
dot_args <- list(...)
hash_scale <- if (is.null(dot_args$scale)) 100 else dot_args$scale
hash_algo <- if (is.null(dot_args$algo)) "md5" else dot_args$algo
dedupe_duplicate <- if (is.null(dot_args$duplicate)) {
"first"
} else {
match.arg(dot_args$duplicate, c("first", "remove_all", "none"))
}
report <- function(stage) {
if (isTRUE(progress)) {
elapsed <- proc.time()[["elapsed"]] - started
message(sprintf("build_lib [%.1fs]: %s", elapsed, stage))
}
}
validate_sources <- function(source, label) {
if (is_OpenSpecy(source)) {
return(list(source))
}
if (is.list(source) && length(source) > 0L &&
all(vapply(source, is_OpenSpecy, logical(1)))) {
return(source)
}
stop(label, " must contain one OpenSpecy object or a nonempty list of ",
"OpenSpecy objects", call. = FALSE)
}
report("starting")
streamed_records <- NULL
if (is_OpenSpecy(x)) {
sources <- list(x)
report("using one in-memory OpenSpecy source")
} else if (is.character(x)) {
if (length(x) == 0L || anyNA(x) || any(!nzchar(x))) {
stop("'x' must contain one or more nonempty file paths", call. = FALSE)
}
streamed_records <- list()
source_index <- 0L
for (i in seq_along(x)) {
report(sprintf(
"reading path %d/%d (%s)",
i, length(x), basename(x[[i]])
))
if (grepl("\\.rds$", x[[i]], ignore.case = TRUE)) {
source <- readRDS(x[[i]])
} else {
source <- read_any(x[[i]])
}
path_sources <- validate_sources(source, paste0("File path ", i))
for (j in seq_along(path_sources)) {
source_index <- source_index + 1L
streamed_records[[source_index]] <- .lib_source_record(
path_sources[[j]],
source_index,
id_col = if (isTRUE(dedupe)) id_col else NULL,
hash_scale = hash_scale,
hash_algo = hash_algo
)
}
rm(source, path_sources)
gc(verbose = FALSE)
}
report(sprintf(
"streamed %d source object(s) from %d path(s)",
length(streamed_records), length(x)
))
} else {
if (!is.list(x) || length(x) == 0L ||
!all(vapply(x, is_OpenSpecy, logical(1)))) {
stop("'x' must be one OpenSpecy object, file path(s), or a nonempty ",
"list of OpenSpecy objects", call. = FALSE)
}
sources <- x
report(sprintf("using %d in-memory OpenSpecy source(s)", length(sources)))
}
if (is.null(streamed_records)) {
report(sprintf("preparing %d source object(s)", length(sources)))
lib <- .lib_prepare_sources(
sources,
range = range,
res = res,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
id_col = if (isTRUE(dedupe)) id_col else NULL,
hash_scale = hash_scale,
hash_algo = hash_algo,
report = report
)
} else {
lib <- .lib_prepare_records(
streamed_records,
range = range,
res = res,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
report = report
)
rm(streamed_records)
gc(verbose = FALSE)
}
build_stage_report <- data.table::data.table(
stage = "prepared", spectra = ncol(lib$spectra), removed = 0L
)
identity_cleanup_report <- data.table::data.table()
if ("spectrum_identity" %in% names(lib$metadata)) {
identity_before <- as.character(lib$metadata$spectrum_identity)
identity_after <- .lib_clean_spectrum_identity(identity_before)
changed <- xor(is.na(identity_before), is.na(identity_after)) |
(!is.na(identity_before) & !is.na(identity_after) &
identity_before != identity_after)
identity_cleanup_report <- data.table::data.table(
original = identity_before[changed],
spectrum_identity = identity_after[changed]
)[, .(n = .N), by = .(original, spectrum_identity)]
lib$metadata$spectrum_identity <- identity_after
if (any(changed)) {
report(sprintf("cleaned %d spectrum identity value(s)", sum(changed)))
}
}
lib$metadata <- .lib_assign_library_name(lib$metadata)
source_key_report <- .lib_fill_metadata_key(
lib$metadata, canonical = "organization", fallback = "user_name"
)
if (nrow(source_key_report) > 0L) {
filled <- source_key_report[problem == "filled_canonical_key", sum(n)]
conflicts <- source_key_report[problem == "canonical_key_conflict", sum(n)]
report(sprintf(
"standardized source keys (filled=%d; conflicts=%d)",
ifelse(length(filled), filled, 0L),
ifelse(length(conflicts), conflicts, 0L)
))
}
if (!is.null(restrict_range_args)) {
report("restricting the wavenumber range")
if (!is.list(restrict_range_args) ||
is.null(names(restrict_range_args)) ||
any(names(restrict_range_args) == "")) {
stop("'restrict_range_args' must be a named list", call. = FALSE)
}
args <- utils::modifyList(
list(make_rel = FALSE),
restrict_range_args
)
lib <- do.call("restrict_range", c(list(lib), args))
}
lookup_reports <- list()
if (nrow(source_key_report) > 0L) {
lookup_reports$canonical_source_keys <- source_key_report
}
if (!is.null(metadata_lookups)) {
lookups <- if (.lib_is_lookup_spec(metadata_lookups)) {
list(metadata_lookups)
} else if (is.character(metadata_lookups) &&
length(metadata_lookups) > 1L) {
as.list(metadata_lookups)
} else if (is.list(metadata_lookups) &&
!inherits(metadata_lookups, c("data.frame", "data.table"))) {
metadata_lookups
} else {
list(metadata_lookups)
}
for (i in seq_along(lookups)) {
report(sprintf("joining metadata lookup %d/%d", i, length(lookups)))
lookup <- lookups[[i]]
lookup_spec <- .lib_normalize_lookup_spec(lookup)
lookup_table <- lib_clean_metadata(.lib_read_lookup(lookup_spec$lookup),
metadata_name_lookup,
clean_values = clean_metadata_values)
if ("spectrum_identity" %in% names(lookup_table)) {
lookup_table$spectrum_identity <- .lib_clean_spectrum_identity(
lookup_table$spectrum_identity
)
}
lookup_key <- lookup_spec$by
key_merge_report <- data.table::data.table()
if (is.null(lookup_key)) {
auto_key <- .lib_auto_lookup_key(lib$metadata, lookup_table)
if (length(auto_key$shared) == 0L) {
report(sprintf(
"skipping metadata lookup %d/%d; no shared metadata column",
i, length(lookups)
))
next
}
if (length(auto_key$candidates) == 0L) {
report(sprintf(
"skipping metadata lookup %d/%d; no usable shared key values in: %s",
i, length(lookups), paste(auto_key$shared, collapse = ", ")
))
next
}
if (length(auto_key$candidates) > 1L) {
stop("Each automatic metadata lookup must have exactly one usable ",
"shared key. Candidate columns were: ",
paste(auto_key$candidates, collapse = ", "),
". Supply list(lookup = x, by = key) for an explicit join",
call. = FALSE)
}
lookup_key <- auto_key$candidates
}
if (!is.null(lookup_spec$fallback_by)) {
warning(
"'fallback_by' is deprecated; standardize canonical metadata keys ",
"before supplying external lookup tables",
call. = FALSE
)
metadata_key <- if (is.null(names(lookup_key)) ||
all(names(lookup_key) == "")) {
unname(lookup_key)
} else {
names(lookup_key)
}
if (length(metadata_key) != 1L) {
stop("'fallback_by' requires a one-column explicit lookup key",
call. = FALSE)
}
.lib_require_cols(lib$metadata,
c(metadata_key, lookup_spec$fallback_by),
"metadata")
primary <- as.character(lib$metadata[[metadata_key]])
fallback <- as.character(lib$metadata[[lookup_spec$fallback_by]])
primary_blank <- is.na(primary) | !nzchar(trimws(primary))
fallback_present <- !is.na(fallback) & nzchar(trimws(fallback))
filled <- primary_blank & fallback_present
primary[filled] <- fallback[filled]
lib$metadata[[metadata_key]] <- primary
key_merge_report <- data.table::data.table(
problem = "fallback_metadata_key",
column = metadata_key,
value = lookup_spec$fallback_by,
n = sum(filled)
)
}
coalesce_cols <- intersect(
names(lib$metadata),
setdiff(names(lookup_table), unname(lookup_key))
)
lib <- join_lib_metadata(lib, lookup_table, by = lookup_key)
join_report <- attr(lib, "join_report")
report(sprintf(
"metadata lookup %d/%d complete (matched=%d; unmatched=%d)",
i, length(lookups),
nrow(lib$metadata) - sum(join_report[
problem == "unmatched_metadata_key", n
]),
sum(join_report[problem == "unmatched_metadata_key", n])
))
lookup_reports[[paste0("lookup_", i)]] <- data.table::rbindlist(
list(key_merge_report, join_report), fill = TRUE
)
lib$metadata <- .lib_coalesce_joined_metadata(
lib$metadata, coalesce_cols,
lookup_precedence = !isTRUE(lookup_spec$fill_only)
)
}
}
if (!is.null(material_hierarchy)) {
report("joining the material hierarchy")
hierarchy <- lib_clean_metadata(.lib_read_lookup(material_hierarchy),
metadata_name_lookup,
clean_values = clean_metadata_values)
lib <- join_material_hierarchy(lib, hierarchy)
hierarchy_report <- attr(lib, "join_report")
report(sprintf(
"material hierarchy complete (unmatched=%d)",
sum(hierarchy_report[problem == "unmatched_metadata_key", n])
))
}
retention_stages <- .lib_library_stage_counts(
list(source = lib), stage = "prepared"
)[, artifact := NULL]
identity_index <- data.table::data.table(
sample_name = as.character(.lib_ids(lib, "sample_name")),
spectrum_identity = if ("spectrum_identity" %in% names(lib$metadata)) {
as.character(lib$metadata$spectrum_identity)
} else {
NA_character_
}
)
if (!is.null(exclude_ids)) {
before <- ncol(lib$spectra)
lib <- .lib_filter_excluded(lib, exclude_ids, id_col = id_col)
build_stage_report <- data.table::rbindlist(list(
build_stage_report,
data.table::data.table(
stage = "excluded_identifiers", spectra = ncol(lib$spectra),
removed = before - ncol(lib$spectra)
)
))
report(sprintf("removed %d excluded identifier(s)",
before - ncol(lib$spectra)))
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(
list(source = lib), stage = "post_exclusion"
)[, artifact := NULL]
))
if (dedupe) {
before <- ncol(lib$spectra)
report("generating identifiers and removing duplicate spectra")
existing <- .lib_dedupe_existing_ids(
lib,
id_col = id_col,
duplicate = dedupe_duplicate
)
lib <- if (is.null(existing)) {
dedupe_spec(lib, id_col = id_col, ...)
} else {
existing
}
if (!is.null(exclude_ids)) {
lib <- .lib_filter_excluded(lib, exclude_ids, id_col = id_col)
}
build_stage_report <- data.table::rbindlist(list(
build_stage_report,
data.table::data.table(
stage = "deduplicated", spectra = ncol(lib$spectra),
removed = before - ncol(lib$spectra)
)
))
report(sprintf("deduplication complete (removed=%d; retained=%d)",
before - ncol(lib$spectra), ncol(lib$spectra)))
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(
list(source = lib), stage = "core"
)[, artifact := NULL]
))
retained_ids <- as.character(.lib_ids(lib, "sample_name"))
dropped_identities <- identity_index[!sample_name %in% retained_ids &
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(spectrum_identity)))]
apply_recipe <- function(recipe, recipe_name, recipe_index) {
report(sprintf(
"processing recipe %d/%d (%s)",
recipe_index, length(recipes), recipe_name
))
out <- if (is.function(recipe)) {
recipe(lib)
} else if (length(recipe) == 0L) {
lib
} else {
do.call(process_spec, c(list(lib), recipe))
}
if (!is_OpenSpecy(out)) {
stop("Each recipe must return an OpenSpecy object", call. = FALSE)
}
if (isTRUE(signal_noise)) {
report(sprintf("calculating signal-to-noise (%s)", recipe_name))
out$metadata$sn <- sig_noise(out, step = 10)
}
if (isTRUE(assess)) {
report(sprintf("assessing spectra (%s)", recipe_name))
assessment <- assess_spec(out)
out$metadata[, `:=`(
assessment_flag = FALSE,
assessment_issue_count = 0L,
assessment_checks = NA_character_,
assessment_issues = NA_character_,
assessment_potential_fixes = NA_character_
)]
if (nrow(assessment) > 0L) {
summary <- assessment[, .(
assessment_flag = TRUE,
assessment_issue_count = .N,
assessment_checks = paste(unique(get("check")), collapse = "; "),
assessment_issues = paste(unique(get("issue")), collapse = "; "),
assessment_potential_fixes = paste(unique(get("potential_fix")),
collapse = "; ")
), by = "spectrum_id"]
idx <- match(colnames(out$spectra), summary$spectrum_id)
found <- !is.na(idx)
assessment_cols <- setdiff(names(summary), "spectrum_id")
assessment_values <- summary[idx[found], assessment_cols, with = FALSE]
out$metadata[found, (assessment_cols) := assessment_values]
}
}
if (!is.null(prune) && recipe_name %in% names(prune)) {
report(sprintf("pruning library (%s)", recipe_name))
prune_args <- prune[[recipe_name]]
if (is.null(prune_args)) prune_args <- list()
if (!is.list(prune_args) ||
(!is.null(names(prune_args)) && any(names(prune_args) == ""))) {
stop("Each selected 'prune' recipe must contain a named argument list",
call. = FALSE)
}
prune_args$return <- "object"
if (is.null(prune_args$progress)) prune_args$progress <- progress
out <- do.call(prune_lib, c(list(out), prune_args))
}
if (length(lookup_reports) > 0L) {
attr(out, "metadata_lookup_reports") <- lookup_reports
}
attr(out, "spectrum_identity_cleanup_report") <- identity_cleanup_report
attr(out, "build_stage_report") <- build_stage_report
attr(out, "dropped_spectrum_identities") <- dropped_identities
recipe_retention <- data.table::copy(retention_stages)
recipe_retention[, artifact := recipe_name]
data.table::setcolorder(
recipe_retention, c("stage", "artifact", "library_name", "spectra")
)
attr(out, "library_retention_stages") <- recipe_retention
out
}
if (is.null(names(recipes)) || any(names(recipes) == "") ||
anyDuplicated(names(recipes))) {
stop("'recipes' must be a uniquely named list", call. = FALSE)
}
if (!is.null(prune)) {
if (!is.list(prune) || is.null(names(prune)) ||
any(is.na(names(prune)) | names(prune) == "") ||
anyDuplicated(names(prune))) {
stop("'prune' must be NULL or a uniquely named list", call. = FALSE)
}
unknown_prune <- setdiff(names(prune), names(recipes))
if (length(unknown_prune) > 0L) {
stop("'prune' names must identify recipes: ",
paste(unknown_prune, collapse = ", "), call. = FALSE)
}
}
out <- lapply(seq_along(recipes), function(i) {
apply_recipe(recipes[[i]], names(recipes)[[i]], i)
})
names(out) <- names(recipes)
report("complete")
out
}
.lib_clean_spectrum_identity <- function(x) {
out <- trimws(as.character(x))
missing <- is.na(out)
windows_path <- grepl("^[A-Za-z]:[\\\\/]", out) |
grepl("\\\\", out)
unix_path <- grepl("^(?:/|\\./|\\.\\./)", out, perl = TRUE)
out <- gsub("\\\\", "/", out)
extensions <- .supported_spectrum_extensions()
pattern <- paste0(
"\\.(?:", paste(extensions, collapse = "|"), ")$"
)
suffixed_path <- grepl("/", out, fixed = TRUE) &
grepl(pattern, out, ignore.case = TRUE, perl = TRUE)
path <- windows_path | unix_path | suffixed_path
out[path] <- sub(".*/", "", out[path])
repeat {
cleaned <- sub(pattern, "", out, ignore.case = TRUE, perl = TRUE)
if (identical(cleaned, out)) break
out <- cleaned
}
out <- trimws(out)
out[missing | !nzchar(out)] <- NA_character_
out
}
#' Predict blank class-reference values with reviewed regex rules
#'
#' Applies a separate regex reference only to rows whose `material` is blank.
#' Populated exact materials are authoritative and are never overwritten, even
#' when a regex also matches them. A blank row is filled only when all matching
#' patterns name one material. Distinct-material matches remain blank and are
#' reported as clashes. Exact/regex overlaps are allowed and reported for QA.
#' If present, `match_identity` is used for pattern matching while
#' `spectrum_identity` remains the reported exact identity.
#'
#' @param metadata A data.frame or data.table with `spectrum_identity` and
#' `material` columns. Row order is preserved.
#' @param regex_reference A data.frame or data.table with unique `pattern` and
#' nonblank `material` columns.
#' @param return Return the updated table or an audit containing `data`,
#' `summary`, `predictions`, `clashes`, and `overlaps`.
#'
#' @return An updated data.table, or an audit list when `return = "report"`.
#' @export
predict_class_reference <- function(metadata, regex_reference,
return = c("table", "report")) {
return <- match.arg(return)
out <- data.table::as.data.table(data.table::copy(metadata))
rules <- data.table::as.data.table(data.table::copy(regex_reference))
.lib_require_cols(out, c("spectrum_identity", "material"),
"metadata")
.lib_require_cols(rules, c("pattern", "material"), "regex reference")
out$spectrum_identity <- as.character(out$spectrum_identity)
out$material <- as.character(out$material)
rules$pattern <- as.character(rules$pattern)
rules$material <- as.character(rules$material)
blank <- function(value) {
is.na(value) | !nzchar(trimws(as.character(value)))
}
if (any(blank(rules$pattern)) || any(blank(rules$material))) {
stop("Regex-reference patterns and materials must be nonblank",
call. = FALSE)
}
if (anyDuplicated(rules$pattern)) {
stop("Regex-reference patterns must be unique", call. = FALSE)
}
match_value <- if ("match_identity" %in% names(out)) {
value <- as.character(out$match_identity)
value[blank(value)] <- out$spectrum_identity[blank(value)]
value
} else {
out$spectrum_identity
}
missing_identity <- blank(match_value)
match_value[missing_identity] <- ""
hits <- matrix(FALSE, nrow = nrow(out), ncol = nrow(rules))
if (nrow(rules) > 0L && nrow(out) > 0L) {
hits <- vapply(seq_len(nrow(rules)), function(i) {
tryCatch(
grepl(rules$pattern[[i]], match_value, perl = TRUE),
warning = function(w) {
stop("Invalid class regex '", rules$pattern[[i]], "': ",
conditionMessage(w), call. = FALSE)
},
error = function(e) {
stop("Invalid class regex '", rules$pattern[[i]], "': ",
conditionMessage(e), call. = FALSE)
}
)
}, logical(nrow(out)))
if (is.null(dim(hits))) hits <- matrix(hits, ncol = 1L)
}
if (any(missing_identity) && ncol(hits) > 0L) {
hits[missing_identity, ] <- FALSE
}
matched_materials <- lapply(seq_len(nrow(out)), function(i) {
unique(rules$material[which(hits[i, ])])
})
matched_patterns <- lapply(seq_len(nrow(out)), function(i) {
rules$pattern[which(hits[i, ])]
})
blank_material <- blank(out$material)
unique_match <- lengths(matched_materials) == 1L
clash <- lengths(matched_materials) > 1L
predict <- blank_material & unique_match
out$material[predict] <- vapply(
matched_materials[predict], `[[`, character(1), 1L
)
prediction_rows <- which(predict)
predictions <- data.table::data.table(
spectrum_identity = out$spectrum_identity[prediction_rows],
match_identity = match_value[prediction_rows],
material = out$material[prediction_rows],
patterns = vapply(matched_patterns[prediction_rows], paste,
character(1), collapse = "; ")
)[, .(n = .N), by = .(spectrum_identity, match_identity, material, patterns)]
clash_rows <- which(blank_material & clash)
clashes <- if (length(clash_rows) == 0L) {
data.table::data.table(
spectrum_identity = character(), match_identity = character(),
materials = character(), patterns = character(), n = integer()
)
} else {
data.table::data.table(
spectrum_identity = out$spectrum_identity[clash_rows],
match_identity = match_value[clash_rows],
materials = vapply(matched_materials[clash_rows], paste,
character(1), collapse = "; "),
patterns = vapply(matched_patterns[clash_rows], paste,
character(1), collapse = "; ")
)[, .(n = .N),
by = .(spectrum_identity, match_identity, materials, patterns)]
}
overlap_rows <- which(!blank_material & lengths(matched_materials) > 0L)
overlaps <- data.table::data.table(
spectrum_identity = out$spectrum_identity[overlap_rows],
exact_material = out$material[overlap_rows],
regex_materials = vapply(matched_materials[overlap_rows], paste,
character(1), collapse = "; "),
patterns = vapply(matched_patterns[overlap_rows], paste,
character(1), collapse = "; ")
)[, agreement := vapply(seq_len(.N), function(i) {
exact_material[[i]] %in% strsplit(regex_materials[[i]], "; ", fixed = TRUE)[[1L]]
}, logical(1))][, .(n = .N),
by = .(spectrum_identity, exact_material, regex_materials,
patterns, agreement)]
summary <- data.table::data.table(
rows = nrow(out), regex_rules = nrow(rules),
existing = sum(!blank_material), predicted = sum(predict),
clashes = length(clash_rows), overlaps = length(overlap_rows),
unmatched = sum(blank(out$material))
)
if (return == "report") {
return(list(data = out, summary = summary, predictions = predictions,
clashes = clashes, overlaps = overlaps))
}
out
}
# Complete official reference-library class coverage while retaining uncertain
# identities as an explicit review queue. This stays internal because the two
# normalization rules and the reviewed one-percent cap are specific to the
# official library, not a general package API.
.lib_complete_reference_classes <- function(x, classes, hierarchy,
enforce_other_limit = TRUE) {
metadata <- data.table::copy(x$metadata)
blank <- function(value) {
value <- as.character(value)
is.na(value) | !nzchar(trimws(value))
}
missing_before <- blank(metadata$material_class)
identity <- as.character(metadata$spectrum_identity)
user <- as.character(metadata$user_name)
lookup_key <- identity
assignment <- ifelse(missing_before, NA_character_, "existing_or_exact_lookup")
exact_classes <- classes
normalized_key <- rep(NA_character_, nrow(metadata))
direct <- missing_before & !is.na(identity) &
!is.na(match(identity, exact_classes$spectrum_identity))
normalized_key[direct] <- identity[direct]
gicquel <- missing_before & is.na(normalized_key) & !is.na(user) &
user == "gicquel et al. 2024" & !is.na(identity)
normalized_key[gicquel] <- sub(
"_ref(?:_0)?(?:[.]csv)?$", "", identity[gicquel], perl = TRUE
)
mffrc <- missing_before & is.na(normalized_key) & !is.na(user) &
user == "elise granek and kellie teague" & !is.na(identity)
mffrc_base <- sub("[.][0-9]+$", "", identity[mffrc])
mffrc_base <- sub("^mffrc[0-9]+_", "", mffrc_base)
mffrc_base <- sub("_.*$", "", mffrc_base)
mffrc_family <- trimws(sub("[[:space:]]*[(].*$", "", mffrc_base))
mffrc_key <- mffrc_base
use_family <- is.na(match(mffrc_key, exact_classes$spectrum_identity)) &
!is.na(match(mffrc_family, exact_classes$spectrum_identity))
mffrc_key[use_family] <- mffrc_family[use_family]
normalized_key[mffrc] <- mffrc_key
normalized_material <- exact_classes$material[
match(normalized_key, exact_classes$spectrum_identity)
]
resolved <- missing_before & !blank(normalized_material)
lookup_key[resolved] <- normalized_key[resolved]
metadata$material[resolved] <- normalized_material[resolved]
hierarchy_material <- match(metadata$material[resolved], hierarchy$material)
resolved_rows <- which(resolved)
material_rows <- resolved_rows[!is.na(hierarchy_material)]
material_lookup <- hierarchy_material[!is.na(hierarchy_material)]
if (length(material_rows) > 0L) {
metadata$material_class[material_rows] <- hierarchy$material_class[material_lookup]
metadata$material_type[material_rows] <- hierarchy$material_type[material_lookup]
}
class_pairs <- unique(hierarchy[, .(material_class, material_type)])
missing_class_rows <- which(
blank(metadata$material_class) & !blank(metadata$material)
)
reviewed_class_rows <- integer()
if (length(missing_class_rows) > 0L) {
class_lookup <- match(metadata$material[missing_class_rows],
class_pairs$material_class)
reviewed_class_rows <- missing_class_rows[!is.na(class_lookup)]
metadata$material_class[reviewed_class_rows] <-
metadata$material[reviewed_class_rows]
metadata$material_type[reviewed_class_rows] <-
class_pairs$material_type[class_lookup[!is.na(class_lookup)]]
}
source_resolved <- resolved & !blank(metadata$material_class)
assignment[source_resolved] <- "reviewed_source_key"
reviewed_class_key <- seq_len(nrow(metadata)) %in% reviewed_class_rows &
!source_resolved
assignment[reviewed_class_key] <- "reviewed_class_key"
unresolved <- blank(metadata$material_class)
metadata$material[unresolved] <- "other"
metadata$material_class[unresolved] <- "other"
metadata$material_type[unresolved] <- "other"
lookup_key[unresolved] <- identity[unresolved]
assignment[unresolved] <- "unresolved_identity"
other <- !blank(metadata$material_class) &
tolower(trimws(metadata$material_class)) == "other"
other_fraction <- if (nrow(metadata)) sum(other) / nrow(metadata) else 0
if (isTRUE(enforce_other_limit) && other_fraction > 0.01) {
stop(sprintf(
paste0(
"The 'other' class is %.2f%% of the library (%d/%d), above the ",
"reviewed 1%% maximum; review exact class mappings for: %s"
),
100 * other_fraction, sum(other), nrow(metadata),
paste(head(unique(identity[other]), 20L), collapse = ", ")
), call. = FALSE)
}
metadata[, `:=`(class_lookup_key = lookup_key,
class_assignment_reason = assignment)]
report <- data.table::data.table(
stage = c("before", "after"),
populated_class = c(sum(!missing_before), sum(!blank(metadata$material_class))),
reviewed_source_key = c(0L, sum(source_resolved)),
reviewed_class_key = c(0L, sum(reviewed_class_key)),
unclassified = c(0L, 0L), unresolved_other = c(0L, sum(unresolved)),
other = c(0L, sum(other)), other_fraction = c(0, other_fraction),
total = nrow(metadata)
)
stopifnot(report[stage == "after", populated_class] == nrow(metadata))
x$metadata <- metadata
attr(x, "class_coverage_report") <- report
x
}
.lib_other_review_schema <- function() {
data.table::data.table(
artifact = character(), source_row = integer(), spectrum_id = character(),
spectrum_identity = character(), sample_id = character(),
file_name = character(), library_name = character(),
organization = character(), user_name = character(),
citation = character(), other_info = character(), material = character(),
material_class = character(), material_type = character(),
spectrum_type = character(), generic_fields = character(),
reason = character(), action = character()
)
}
.lib_other_filter_schema <- function() {
data.table::data.table(
artifact = character(), action = character(), before = integer(),
candidates = integer(), missing_identity = integer(),
generic_label = integer(), removed = integer(), after = integer()
)
}
.lib_apply_other_policy <- function(libraries, remove_other, report = NULL) {
generic_labels <- c("other", "other plastic", "other material")
reviews <- list()
summaries <- list()
value <- function(metadata, column) {
if (column %in% names(metadata)) as.character(metadata[[column]]) else
rep(NA_character_, nrow(metadata))
}
for (artifact in names(libraries)) {
object <- libraries[[artifact]]
metadata <- object$metadata
identity <- value(metadata, "spectrum_identity")
missing_identity <- is.na(identity) | !nzchar(trimws(identity))
label_columns <- c("material", "material_class", "material_type")
generic_matrix <- vapply(label_columns, function(column) {
tolower(trimws(value(metadata, column))) %in% generic_labels
}, logical(nrow(metadata)))
if (is.null(dim(generic_matrix))) {
generic_matrix <- matrix(generic_matrix, ncol = length(label_columns))
}
generic <- rowSums(generic_matrix) > 0L
candidates <- missing_identity | generic
unresolved <- rowSums(vapply(label_columns, function(column) {
label <- tolower(trimws(value(metadata, column)))
!is.na(label) & label == "other"
}, logical(nrow(metadata)))) > 0L
remove <- isTRUE(remove_other) & (missing_identity | unresolved)
if (any(candidates)) {
rows <- which(candidates)
triggered <- apply(generic_matrix[rows, , drop = FALSE], 1L, function(x) {
paste(label_columns[x], collapse = "; ")
})
review <- data.table::data.table(
artifact = artifact,
source_row = as.integer(rows),
spectrum_id = as.character(.lib_ids(object, "sample_name"))[rows],
spectrum_identity = identity[rows],
sample_id = value(metadata, "sample_id")[rows],
file_name = value(metadata, "file_name")[rows],
library_name = value(metadata, "library_name")[rows],
organization = value(metadata, "organization")[rows],
user_name = value(metadata, "user_name")[rows],
citation = value(metadata, "citation")[rows],
other_info = value(metadata, "other_info")[rows],
material = value(metadata, "material")[rows],
material_class = value(metadata, "material_class")[rows],
material_type = value(metadata, "material_type")[rows],
spectrum_type = value(metadata, "spectrum_type")[rows],
generic_fields = triggered,
reason = data.table::fcase(
missing_identity[rows], "missing_spectrum_identity",
unresolved[rows], "unresolved_other_label",
default = "reviewed_broad_category"
),
action = if (isTRUE(remove_other)) {
ifelse(remove[rows], "removed", "retained_reviewed_broad_category")
} else {
rep("retained_for_semisupervised_reassignment", length(rows))
}
)
reviews[[artifact]] <- review
}
before <- ncol(object$spectra)
if (any(remove)) {
if (all(remove)) {
stop("Removing blank identities and unresolved classes would remove every ",
"spectrum from ", artifact, call. = FALSE)
}
object <- filter_spec(object, !remove)
}
summary <- data.table::data.table(
artifact = artifact,
action = if (isTRUE(remove_other)) {
"remove_unresolved_retain_reviewed_broad"
} else {
"retain_for_semisupervised_reassignment"
},
before = as.integer(before),
candidates = as.integer(sum(candidates)),
missing_identity = as.integer(sum(missing_identity)),
generic_label = as.integer(sum(generic)),
removed = as.integer(sum(remove)),
after = as.integer(ncol(object$spectra))
)
summaries[[artifact]] <- summary
attr(object, "other_review_report") <- if (is.null(reviews[[artifact]])) {
.lib_other_review_schema()
} else {
reviews[[artifact]]
}
attr(object, "other_filter_report") <- summary
libraries[[artifact]] <- object
if (is.function(report)) report(sprintf(
paste0("generic review %s: candidates=%d (missing identity=%d; ",
"generic label=%d); action=%s; affected=%d; library retained=%d"),
artifact, sum(candidates), sum(missing_identity), sum(generic),
if (isTRUE(remove_other)) "reviewed/removed unresolved" else
"queued for reassignment",
sum(remove),
ncol(object$spectra)
))
}
list(
libraries = libraries,
review = if (length(reviews)) {
data.table::rbindlist(reviews, fill = TRUE)
} else {
.lib_other_review_schema()
},
summary = if (length(summaries)) {
data.table::rbindlist(summaries, fill = TRUE)
} else {
.lib_other_filter_schema()
}
)
}
.lib_prepare_sources <- function(sources, range, res, metadata_name_lookup,
clean_metadata_values, convert_intensity,
id_col, hash_scale, hash_algo, report) {
records <- vector("list", length(sources))
for (i in seq_along(sources)) {
if (i == 1L || i == length(sources) || i %% 2500L == 0L) {
report(sprintf("preparing source object %d/%d", i, length(sources)))
}
records[[i]] <- .lib_source_record(
sources[[i]],
i,
id_col = id_col,
hash_scale = hash_scale,
hash_algo = hash_algo
)
}
.lib_prepare_records(
records,
range = range,
res = res,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
report = report
)
}
.lib_prepare_records <- function(records, range, res, metadata_name_lookup,
clean_metadata_values, convert_intensity,
report) {
metadata <- .lib_combined_metadata(
records,
metadata_name_lookup,
clean_metadata_values = clean_metadata_values
)
if (isTRUE(convert_intensity)) {
converted <- .lib_convert_records_intensity(
records,
metadata,
source_label = "source list"
)
records <- converted$records
metadata <- converted$metadata
}
shared_axis <- .lib_same_wavenumber(records)
if (length(records) > 1L) {
if (shared_axis) {
report(sprintf(
"combining %d same-axis source object(s)",
length(records)
))
} else {
report(sprintf(
"merging %d source object(s) with c_spec()",
length(records)
))
}
}
if (length(records) == 1L) {
return(.lib_combine_same_axis_records(
records,
metadata,
range = NULL,
res = res
))
}
if (shared_axis) {
return(.lib_combine_same_axis_records(
records,
metadata,
range = range,
res = res
))
}
.lib_combine_variable_axis_records(
records,
metadata,
range = range,
res = res
)
}
.lib_source_record <- function(source, index, id_col = NULL,
hash_scale = 100, hash_algo = "md5") {
if (!is_OpenSpecy(source)) {
stop("Source ", index, " must be an OpenSpecy object", call. = FALSE)
}
spectra <- .as_spectra_matrix(source$spectra, message_conversion = FALSE)
wavenumber <- source$wavenumber
if (!is.numeric(wavenumber) || !is.vector(wavenumber)) {
stop("Source ", index, " wavenumber must be a numeric vector",
call. = FALSE)
}
if (length(wavenumber) != nrow(spectra)) {
stop("Source ", index, " wavenumber length must match spectra rows",
call. = FALSE)
}
ord <- order(wavenumber)
if (!identical(ord, seq_along(wavenumber))) {
wavenumber <- wavenumber[ord]
spectra <- spectra[ord, , drop = FALSE]
}
metadata <- data.table::as.data.table(data.table::copy(source$metadata))
if (nrow(metadata) != ncol(spectra)) {
stop("Source ", index, " metadata rows must match spectra columns",
call. = FALSE)
}
if (!is.null(id_col)) {
source_ids <- .lib_source_hash_ids(
wavenumber,
spectra,
metadata,
scale = hash_scale,
algo = hash_algo
)
metadata[[id_col]] <- source_ids$current
metadata[[paste0(id_col, "_old")]] <- source_ids$old
colnames(spectra) <- source_ids$current
}
object_unit <- attr(source, "intensity_unit", exact = TRUE)
object_unit <- as.character(object_unit)
object_unit <- object_unit[!is.na(object_unit) & trimws(object_unit) != ""]
if (length(object_unit) > 1L) {
stop("Source ", index,
" attribute 'intensity_unit' must contain at most one value",
call. = FALSE)
}
attribute_names <- c("intensity_unit", "derivative_order", "baseline",
"spectra_type")
attrs <- lapply(attribute_names, attr, x = source)
names(attrs) <- attribute_names
list(
wavenumber = wavenumber,
spectra = spectra,
metadata = metadata,
n = ncol(spectra),
intensity_attr = if (length(object_unit) == 1L) object_unit else NA_character_,
attrs = attrs
)
}
.lib_source_hash_ids <- function(wavenumber, spectra, metadata, scale = 100,
algo = "md5") {
ignored_info <- .spectra_ignore_info(spectra, lead_tail_only = TRUE,
ig = c(NA))
if (any(!ignored_info$has_valid)) {
stop("All intensity values are NA, cannot remove or ignore with manage na.",
call. = FALSE)
}
keep <- rowSums(ignored_info$ignored) == 0L
if (!any(keep)) {
ids <- lapply(seq_len(ncol(spectra)), function(i) {
valid <- !ignored_info$ignored[, i]
current <- .lib_hash_processed_matrix(
wavenumber[valid], spectra[valid, i, drop = FALSE],
range = NULL, res = 8, scale = scale, algo = algo
)
old <- .lib_hash_processed_matrix(
wavenumber[valid], spectra[valid, i, drop = FALSE],
range = c(100, 4000), res = 8, scale = scale, algo = algo,
min_rows = 3L, short_value = "new format"
)
list(current = current[[1L]], old = old[[1L]])
})
return(list(
current = vapply(ids, `[[`, character(1), "current"),
old = vapply(ids, `[[`, character(1), "old")
))
}
wavenumber <- wavenumber[keep]
spectra <- spectra[keep, , drop = FALSE]
current <- .lib_hash_processed_matrix(
wavenumber,
spectra,
range = NULL,
res = 8,
scale = scale,
algo = algo
)
old <- .lib_hash_processed_matrix(
wavenumber,
spectra,
range = c(100, 4000),
res = 8,
scale = scale,
algo = algo,
min_rows = 3L,
short_value = "new format"
)
list(current = current, old = old)
}
.lib_hash_processed_matrix <- function(wavenumber, spectra, range = NULL,
res = 8, scale = 100, algo = "md5",
min_rows = 1L,
short_value = NA_character_) {
conformed <- .lib_conform_hash_matrix(wavenumber, spectra, range = range,
res = res)
if (nrow(conformed$spectra) < min_rows) {
return(rep(short_value, ncol(spectra)))
}
smoothed <- .sgfilt_matrix(conformed$spectra, p = 3, n = 11, m = 1)
smoothed <- make_rel(abs(smoothed))
.lib_hash_spectra_columns(conformed$wavenumber, smoothed, scale, algo)
}
.lib_conform_hash_matrix <- function(wavenumber, spectra, range = NULL,
res = 8) {
if (is.null(range)) range <- wavenumber
range2 <- c(max(min(range), min(wavenumber)),
min(max(range), max(wavenumber)))
wn <- conform_res(range2, res = res)
spectra <- .conform_intens_matrix(
x = wavenumber,
y = spectra,
xout = wn
)
list(wavenumber = wn, spectra = spectra)
}
.lib_hash_spectra_columns <- function(wavenumber, spectra, scale = 100,
algo = "md5") {
vapply(seq_len(ncol(spectra)), function(i) {
digest::digest(
list(as.integer(wavenumber), as.integer(spectra[, i] * scale)),
algo = algo
)
}, FUN.VALUE = character(1))
}
.lib_combined_metadata <- function(records, metadata_name_lookup,
clean_metadata_values = FALSE) {
metadata <- data.table::rbindlist(
lapply(records, `[[`, "metadata"),
fill = TRUE
)
metadata <- .lib_normalize_metadata_encoding(metadata)
metadata <- lib_clean_metadata(
metadata,
metadata_name_lookup,
clean_values = clean_metadata_values
)
metadata <- metadata[, setdiff(names(metadata), c("x", "y")), with = FALSE]
metadata
}
.lib_normalize_metadata_encoding <- function(metadata) {
metadata <- data.table::as.data.table(data.table::copy(metadata))
for (column in names(metadata)) {
value <- metadata[[column]]
if (!is.character(value) && !is.factor(value)) next
value <- iconv(as.character(value), from = "", to = "UTF-8", sub = "")
data.table::set(metadata, j = column, value = value)
}
metadata
}
.lib_same_wavenumber <- function(records) {
if (length(records) <= 1L) return(TRUE)
first <- records[[1L]]$wavenumber
all(vapply(records[-1L], function(record) {
identical(record$wavenumber, first)
}, logical(1)))
}
.lib_common_record_attributes <- function(records) {
attribute_names <- c("intensity_unit", "derivative_order", "baseline",
"spectra_type")
out <- lapply(attribute_names, function(nm) {
values <- lapply(records, function(record) record$attrs[[nm]])
if (all(vapply(values[-1L], identical, logical(1), values[[1L]]))) {
values[[1L]]
} else {
NULL
}
})
names(out) <- attribute_names
out
}
.lib_make_open_specy <- function(wavenumber, spectra, metadata, attributes) {
metadata <- data.table::as.data.table(data.table::copy(metadata))
metadata$col_id <- colnames(spectra)
structure(
list(wavenumber = wavenumber, spectra = spectra, metadata = metadata),
class = c("OpenSpecy", "list"),
intensity_unit = attributes$intensity_unit,
derivative_order = attributes$derivative_order,
baseline = attributes$baseline,
spectra_type = attributes$spectra_type
)
}
.lib_combine_same_axis_records <- function(records, metadata, range, res) {
spectra <- do.call(cbind, lapply(records, `[[`, "spectra"))
colnames(spectra) <- make.unique(
unlist(lapply(records, function(record) colnames(record$spectra)),
use.names = FALSE),
sep = "."
)
attrs <- .lib_common_record_attributes(records)
lib <- .lib_make_open_specy(
records[[1L]]$wavenumber,
spectra,
metadata,
attrs
)
if (!is.null(range)) {
conform_range <- if (is.numeric(range)) {
range
} else if (length(range) == 1L && range %in% c("common", "full")) {
base::range(lib$wavenumber)
} else {
stop("If range is specified it should be numeric, 'full', or 'common'",
call. = FALSE)
}
lib <- conform_spec(
lib,
range = conform_range,
res = res,
allow_na = identical(range, "full") || is.numeric(range)
)
}
as_OpenSpecy(lib)
}
.lib_combine_variable_axis_records <- function(records, metadata, range, res) {
if (is.null(range)) {
stop("wavenumbers need to be identical between spectra; specify how; use ",
"'range' to specify how wavenumbers should be merged", call. = FALSE)
}
pmin <- vapply(records, function(record) min(record$wavenumber), numeric(1))
pmax <- vapply(records, function(record) max(record$wavenumber), numeric(1))
if (is.numeric(range)) {
target_range <- range
allow_na <- TRUE
} else if (length(range) == 1L && range %in% c("common", "full")) {
if (range == "common" &&
(any(max(pmin) > pmax) || any(min(pmax) < pmin))) {
stop("data points need to overlap in their ranges", call. = FALSE)
}
target_range <- if (range == "common") {
c(max(pmin), min(pmax))
} else {
c(min(pmin), max(pmax))
}
allow_na <- identical(range, "full")
} else {
stop("If range is specified it should be numeric, 'full', or 'common'",
call. = FALSE)
}
target_wn <- if (is.null(res)) {
sort(unique(unlist(lapply(records, function(record) {
record$wavenumber[
record$wavenumber >= min(target_range) &
record$wavenumber <= max(target_range)
]
}), use.names = FALSE)))
} else {
conform_res(target_range, res = res)
}
total_columns <- sum(vapply(records, `[[`, integer(1), "n"))
spectra <- matrix(
NA_real_, nrow = length(target_wn), ncol = total_columns
)
source_names <- unlist(lapply(records, function(record) {
colnames(record$spectra)
}), use.names = FALSE)
colnames(spectra) <- make.unique(source_names, sep = ".")
starts <- cumsum(c(1L, head(vapply(records, `[[`, integer(1), "n"), -1L)))
for (i in seq_along(records)) {
record <- records[[i]]
local_range <- c(
max(min(target_range), min(record$wavenumber)),
min(max(target_range), max(record$wavenumber))
)
local_wn <- if (is.null(res)) {
target_wn[target_wn >= min(record$wavenumber) &
target_wn <= max(record$wavenumber)]
} else {
conform_res(local_range, res = res)
}
conformed <- .conform_intens_matrix(
x = record$wavenumber,
y = record$spectra,
xout = local_wn
)
if (!allow_na && !identical(local_wn, target_wn)) {
stop("data points need to overlap in their ranges", call. = FALSE)
}
rows <- match(local_wn, target_wn)
columns <- starts[[i]] + seq_len(record$n) - 1L
spectra[rows, columns] <- conformed
records[[i]]$spectra <- NULL
rm(record, conformed)
}
.lib_make_open_specy(
target_wn,
spectra,
metadata,
.lib_common_record_attributes(records)
) |>
as_OpenSpecy()
}
.lib_convert_records_intensity <- function(records, metadata,
source_label = "source") {
attr_units <- unlist(lapply(records, function(record) {
rep(record$intensity_attr, record$n)
}), use.names = FALSE)
has_attr_unit <- !is.na(attr_units)
if (any(has_attr_unit)) {
if (!"intensity_units" %in% names(metadata)) {
metadata$intensity_units <- NA_character_
}
metadata$intensity_units[has_attr_unit] <- attr_units[has_attr_unit]
}
declared <- if ("intensity_units" %in% names(metadata)) {
as.character(metadata$intensity_units)
} else {
rep(NA_character_, nrow(metadata))
}
canonical <- .lib_canonical_intensity_unit(declared)
starts <- cumsum(c(1L, head(vapply(records, `[[`, integer(1), "n"), -1L)))
for (i in seq_along(records)) {
cols <- starts[[i]] + seq_len(records[[i]]$n) - 1L
records[[i]]$spectra <- .lib_convert_spectra_matrix(
records[[i]]$spectra,
canonical[cols]
)
resolved_i <- !is.na(canonical[cols])
if (all(resolved_i)) {
records[[i]]$attrs$intensity_unit <- "absorbance"
}
}
resolved <- !is.na(canonical)
if (any(resolved)) {
if (!"intensity_units" %in% names(metadata)) {
metadata$intensity_units <- NA_character_
}
metadata$intensity_units[resolved] <- "absorbance"
}
.lib_warn_unknown_intensity(declared, resolved, source_label)
list(records = records, metadata = metadata)
}
.lib_convert_spectra_matrix <- function(spectra, canonical) {
for (type in c("reflectance", "transmittance")) {
idx <- which(canonical == type)
if (length(idx) > 0L) {
spectra[, idx] <- switch(
type,
reflectance = (1 - spectra[, idx, drop = FALSE] / 100)^2 /
(2 * spectra[, idx, drop = FALSE] / 100),
transmittance = log(1 / .matrix_adj_neg(
spectra[, idx, drop = FALSE], na.rm = TRUE
))
)
}
}
spectra
}
.lib_warn_unknown_intensity <- function(declared, resolved, source_label) {
if (!any(!resolved)) return(invisible(NULL))
unresolved <- trimws(as.character(declared[!resolved]))
unresolved[is.na(unresolved) | unresolved == ""] <- "<missing>"
counts <- sort(table(unresolved), decreasing = TRUE)
details <- paste0(names(counts), " (", as.integer(counts), ")")
warning(
"Automatic intensity conversion skipped ", sum(!resolved),
" spectrum/s in ", source_label, " with unknown units: ",
paste(details, collapse = ", "),
". Set attr(x, 'intensity_unit') or metadata$intensity_units to ",
"'absorbance', 'reflectance', or 'transmittance'; use ",
"convert_intensity = FALSE to preserve units without conversion.",
call. = FALSE
)
invisible(NULL)
}
.lib_canonical_intensity_unit <- function(x) {
value <- trimws(tolower(iconv(as.character(x), to = "ASCII", sub = "")))
value[is.na(value) | value == ""] <- NA_character_
out <- rep(NA_character_, length(value))
out[!is.na(value) & grepl("absorb", value)] <- "absorbance"
out[!is.na(value) & grepl("reflec", value)] <- "reflectance"
out[!is.na(value) & grepl("transm", value)] <- "transmittance"
out
}
.lib_convert_intensity <- function(x, source_label = "source") {
x <- as_OpenSpecy(x)
object_unit <- attr(x, "intensity_unit", exact = TRUE)
object_unit <- as.character(object_unit)
object_unit <- object_unit[!is.na(object_unit) & trimws(object_unit) != ""]
if (length(object_unit) > 1L) {
stop("Object attribute 'intensity_unit' must contain at most one value",
call. = FALSE)
}
from_attribute <- length(object_unit) == 1L
declared <- if (from_attribute) {
rep(object_unit, ncol(x$spectra))
} else if ("intensity_units" %in% names(x$metadata)) {
as.character(x$metadata$intensity_units)
} else {
rep(NA_character_, ncol(x$spectra))
}
canonical <- .lib_canonical_intensity_unit(declared)
for (type in c("reflectance", "transmittance")) {
idx <- which(canonical == type)
if (length(idx) > 0L) {
converted <- adj_intens(
filter_spec(x, idx),
type = type,
make_rel = FALSE
)
x$spectra[, idx] <- converted$spectra
}
}
resolved <- !is.na(canonical)
if (any(resolved)) {
if (!"intensity_units" %in% names(x$metadata)) {
x$metadata$intensity_units <- NA_character_
}
x$metadata$intensity_units[resolved] <- "absorbance"
}
if (all(resolved)) {
attr(x, "intensity_unit") <- "absorbance"
} else if (!from_attribute) {
attr(x, "intensity_unit") <- NULL
}
if (any(!resolved)) {
unresolved <- trimws(as.character(declared[!resolved]))
unresolved[is.na(unresolved) | unresolved == ""] <- "<missing>"
counts <- sort(table(unresolved), decreasing = TRUE)
details <- paste0(names(counts), " (", as.integer(counts), ")")
warning(
"Automatic intensity conversion skipped ", sum(!resolved),
" spectrum/s in ", source_label, " with unknown units: ",
paste(details, collapse = ", "),
". Set attr(x, 'intensity_unit') or metadata$intensity_units to ",
"'absorbance', 'reflectance', or 'transmittance'; use ",
"convert_intensity = FALSE to preserve units without conversion.",
call. = FALSE
)
}
x
}
#' Create and apply metadata-name lookup rules
#'
#' @description
#' \code{lib_metadata_name_lookup()} returns the default editable rules used to
#' merge synonymous metadata columns. \code{lib_clean_name()} converts names to
#' lowercase underscore form. \code{lib_clean_metadata()} cleans table names and
#' coalesces columns that map to the same canonical name.
#'
#' @details
#' Exact rules determine a column's target before automatic matching that can
#' ignore underscores and a single terminal plural \code{s}. When values are
#' coalesced, canonical and mechanically equivalent canonical names come before
#' semantic aliases. Regular-expression rules are applied last to names that
#' remain unmatched. Regex patterns are evaluated against names after
#' \code{lib_clean_name()} has been applied.
#'
#' Matching options selected in \code{lib_metadata_name_lookup()} are stored
#' with the returned table and used by \code{lib_clean_metadata()}. User rules
#' supplied through \code{...} are merged with the defaults. Set
#' \code{defaults = FALSE} to construct a lookup from only user rules.
#'
#' @param ... named character vectors of exact aliases, where each argument name
#' is the canonical name, or data.frame/data.table rule tables with
#' \code{canonical_name}, \code{source_name}, and optional \code{regex} columns.
#' @param regex an optional named character vector or named list of regular
#' expressions. Names identify the canonical metadata names.
#' @param defaults logical; whether to include OpenSpecy's default semantic
#' aliases before merging user rules.
#' @param match_without_underscores logical; whether names that differ only by
#' underscores should match automatically.
#' @param match_singular_plural logical; whether names that differ only by one
#' terminal \code{s} should match automatically.
#' @param x a character vector of names for \code{lib_clean_name()}, or a
#' data.frame/data.table for \code{lib_clean_metadata()}.
#' @param name_lookup a table returned by \code{lib_metadata_name_lookup()} or a
#' compatible rule table. Use \code{NULL} to clean names without alias merging.
#' @param clean_values logical; whether \code{lib_clean_metadata()} should also
#' lowercase, trim, ASCII-normalize, and normalize blank/unknown character or
#' factor metadata values.
#'
#' @return \code{lib_metadata_name_lookup()} returns a data.table of rules.
#' \code{lib_clean_name()} returns a character vector.
#' \code{lib_clean_metadata()} returns a data.table with cleaned, coalesced
#' columns.
#'
#' @examples
#' lib_clean_name(c("User Name", "Laser (%)", "Method...3"))
#'
#' name_lookup <- lib_metadata_name_lookup(
#' project_code = "campaign name",
#' regex = list(instrument_mode = "^method_[0-9]+$")
#' )
#' metadata <- data.frame(
#' UserName = c("A", NA),
#' user_name = c(NA, "B"),
#' Campaign.Name = c("one", "two"),
#' Method.23 = c("ftir", "raman")
#' )
#' lib_clean_metadata(metadata, name_lookup)
#'
#' @export
lib_metadata_name_lookup <- function(..., regex = NULL, defaults = TRUE,
match_without_underscores = TRUE,
match_singular_plural = TRUE) {
aliases <- if (isTRUE(defaults)) list(
sample_name = character(),
file_name = character(),
library_type = character(),
contact_info = character(),
organization = character(),
citation = character(),
spectrum_identity = c("substance", "interpretation"),
spectrum_type = character(),
material_form = c("description", "form_factor", "shape",
"form_film_foam_pliable_hard", "form", "state",
"morphology"),
material_producer = character(),
material_purity = character(),
material_quality = c("source_type"),
material_color = c("color", "colour"),
material_other = character(),
cas_number = c("cas_registry_no"),
instrument_used = c("spectrometer_datasystem"),
instrument_accessories = c("instrumentaccesories",
"external_diffuse_reflectance_accessory"),
instrument_mode = c("spectralcollectionmode", "method_3", "method_23"),
intensity_units = c("y_unit"),
data_type = c("datatype"),
wavenumber_units = c("xunits", "x_unit"),
spectral_resolution = c("resolution"),
laser_light_used = c("laser_nm", "laser_frequency"),
number_of_accumulations = c("number_of_sample_scans", "coadded_scans"),
total_acquisition_time_s = c("collection_length", "acq_time_s"),
data_processing_procedure = c("preprocessing", "data_processing",
"data_processing_proceedure"),
level_of_confidence_in_identification = character(),
other_info = c("otherinformation", "otherinfo", "comment", "comments",
"notes"),
baseline_correction = c("baseline"),
smoother = c("smooth"),
user_name = character(),
sample_id = character(),
spectrum_id = c("spectrumid"),
location_description = c("locationdescription"),
longest_dimension = character(),
width = character(),
source = c("source_database", "origin", "nist_source"),
date = c("longdate", "timestamp"),
phase_correction = character(),
apodization = c("apodization_function")
) else list()
rules <- lapply(names(aliases), function(canonical) {
data.table::data.table(
canonical_name = canonical,
source_name = c(canonical, aliases[[canonical]]),
regex = NA_character_
)
})
additions <- list(...)
addition_names <- names(additions)
if (is.null(addition_names)) addition_names <- rep("", length(additions))
for (i in seq_along(additions)) {
addition <- additions[[i]]
if (inherits(addition, c("data.frame", "data.table"))) {
addition <- data.table::as.data.table(data.table::copy(addition))
.lib_require_cols(addition, "canonical_name", "metadata name rule")
if (!"source_name" %in% names(addition)) {
addition$source_name <- NA_character_
}
if (!"regex" %in% names(addition)) addition$regex <- NA_character_
rules[[length(rules) + 1L]] <-
addition[, c("canonical_name", "source_name", "regex"), with = FALSE]
} else {
canonical <- addition_names[i]
if (is.na(canonical) || canonical == "") {
stop("Exact alias additions in '...' must be named or supplied as ",
"rule tables", call. = FALSE)
}
aliases_i <- unlist(addition, use.names = FALSE)
if (!is.character(aliases_i)) {
stop("Exact alias additions in '...' must be character vectors",
call. = FALSE)
}
rules[[length(rules) + 1L]] <- data.table::data.table(
canonical_name = canonical,
source_name = c(canonical, aliases_i),
regex = NA_character_
)
}
}
if (!is.null(regex)) {
if (!is.list(regex)) regex <- as.list(regex)
regex_names <- names(regex)
if (is.null(regex_names) || any(is.na(regex_names) | regex_names == "")) {
stop("'regex' must be a named character vector or named list",
call. = FALSE)
}
regex_rules <- lapply(seq_along(regex), function(i) {
patterns <- unlist(regex[[i]], use.names = FALSE)
if (!is.character(patterns)) {
stop("Each 'regex' entry must contain character patterns",
call. = FALSE)
}
data.table::data.table(
canonical_name = regex_names[i],
source_name = NA_character_,
regex = patterns
)
})
rules <- c(rules, regex_rules)
}
lookup <- if (length(rules) == 0L) {
data.table::data.table(
canonical_name = character(),
source_name = character(),
regex = character()
)
} else {
data.table::rbindlist(rules, use.names = TRUE, fill = TRUE)
}
lookup$canonical_name <- lib_clean_name(lookup$canonical_name)
exact <- !is.na(lookup$source_name)
lookup$source_name[exact] <- lib_clean_name(lookup$source_name[exact])
empty_regex <- !is.na(lookup$regex) & lookup$regex == ""
lookup$regex[empty_regex] <- NA_character_
lookup <- unique(lookup)
has_source <- !is.na(lookup$source_name)
has_regex <- !is.na(lookup$regex)
if (any(has_source == has_regex)) {
stop("Each metadata name rule must contain exactly one of 'source_name' ",
"or 'regex'", call. = FALSE)
}
attr(lookup, "match_without_underscores") <-
isTRUE(match_without_underscores)
attr(lookup, "match_singular_plural") <- isTRUE(match_singular_plural)
lookup
}
.lib_fill_metadata_key <- function(metadata, canonical, fallback) {
if (!inherits(metadata, "data.table")) data.table::setDT(metadata)
if (!fallback %in% names(metadata)) return(data.table::data.table())
if (!canonical %in% names(metadata)) metadata[[canonical]] <- NA_character_
primary <- trimws(as.character(metadata[[canonical]]))
alternate <- trimws(as.character(metadata[[fallback]]))
primary_present <- !is.na(primary) & nzchar(primary)
alternate_present <- !is.na(alternate) & nzchar(alternate)
conflicts <- primary_present & alternate_present & primary != alternate
filled <- !primary_present & alternate_present
primary[filled] <- alternate[filled]
data.table::set(metadata, j = canonical, value = primary)
data.table::rbindlist(list(
data.table::data.table(
problem = "filled_canonical_key", column = canonical,
value = fallback, n = sum(filled)
)[n > 0L],
data.table::data.table(
problem = "canonical_key_conflict", column = canonical,
value = fallback, n = sum(conflicts)
)[n > 0L]
), fill = TRUE)
}
.lib_assign_library_name <- function(metadata) {
metadata <- data.table::as.data.table(metadata)
value <- function(column) {
if (column %in% names(metadata)) {
trimws(as.character(metadata[[column]]))
} else {
rep(NA_character_, nrow(metadata))
}
}
organization <- value("organization")
user_name <- value("user_name")
blank <- is.na(organization) | !nzchar(organization)
organization[blank] <- user_name[blank]
blank <- is.na(organization) | !nzchar(organization)
organization[blank] <- NA_character_
data.table::set(metadata, j = "library_name", value = organization)
metadata
}
.lib_library_stage_counts <- function(libraries, stage) {
rows <- list()
collect <- function(value, artifact) {
if (is_OpenSpecy(value)) {
metadata <- .lib_assign_library_name(data.table::copy(value$metadata))
names <- as.character(metadata$library_name)
names[is.na(names) | !nzchar(trimws(names))] <- "(missing)"
rows[[length(rows) + 1L]] <<- data.table::data.table(
stage = stage, artifact = artifact, library_name = names
)[, .(spectra = .N), by = .(stage, artifact, library_name)]
} else if (is.list(value)) {
for (name in names(value)) collect(value[[name]], artifact)
}
}
for (artifact in names(libraries)) collect(libraries[[artifact]], artifact)
if (!length(rows)) {
return(data.table::data.table(
stage = character(), artifact = character(),
library_name = character(), spectra = integer()
))
}
data.table::rbindlist(rows)[
, .(spectra = sum(spectra)), by = .(stage, artifact, library_name)
]
}
.lib_library_retention_report <- function(stages) {
if (inherits(stages, c("data.frame", "data.table"))) stages <- list(stages)
stages <- data.table::rbindlist(stages, fill = TRUE)
stage_order <- c(
"prepared", "post_exclusion", "core", "post_other", "post_quality",
"post_prune", "post_transform", "final"
)
if (!nrow(stages)) {
out <- data.table::data.table(artifact = character(),
library_name = character())
for (stage in stage_order) out[[paste0(stage, "_n")]] <- integer()
out[, `:=`(status = character(), reason = character())]
return(out)
}
stages <- stages[, lapply(.SD, sum),
by = c("stage", "artifact", "library_name"),
.SDcols = "spectra"]
wide <- data.table::dcast(
stages, stats::as.formula("artifact + library_name ~ stage"),
value.var = "spectra", fill = 0L
)
for (stage in stage_order) {
if (!stage %in% names(wide)) wide[[stage]] <- 0L
}
data.table::setcolorder(wide, c("artifact", "library_name", stage_order))
data.table::setnames(wide, stage_order, paste0(stage_order, "_n"))
wide <- data.table::copy(wide)
count_columns <- paste0(stage_order, "_n")
reason_by_stage <- c(
post_exclusion = "known_bad_identifier",
core = "deduplication",
post_other = "unresolved_other_policy",
post_quality = "quality_control",
post_prune = "class_support_or_correlation_pruning",
post_transform = "post_transform_flat_spectrum",
final = "type_range_or_flat_partition"
)
wide[["status"]] <- data.table::fcase(
wide[["final_n"]] == 0L, "dropped",
wide[["final_n"]] < wide[["prepared_n"]], "partially_retained",
default = "retained"
)
wide[["reason"]] <- NA_character_
for (i in 2:length(stage_order)) {
stage <- stage_order[[i]]
previous <- count_columns[[i - 1L]]
current <- count_columns[[i]]
rows <- wide$status == "dropped" & is.na(wide$reason) &
wide[[previous]] > 0L & wide[[current]] == 0L
wide$reason[rows] <- unname(reason_by_stage[[stage]])
}
partial <- wide[["status"]] == "partially_retained"
wide[["reason"]][partial] <- "one_or_more_spectra_removed_during_cleanup"
unexplained <- wide[["status"]] == "dropped" & is.na(wide[["reason"]])
wide[["reason"]][unexplained] <- "not_retained"
data.table::setorder(wide, artifact, library_name)
wide[]
}
#' @rdname build_lib
#' @export
make_lib_lookup_template <- function(x, columns, add = NULL, path = NULL) {
if (inherits(x, "FileSpecs"))
.filespec_stop_unsupported("make_lib_lookup_template()")
if (!(is_OpenSpecy(x) || is_Specs(x))) {
stop("'x' must be an OpenSpecy or Specs object", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x$metadata))
.lib_require_cols(metadata, columns, "metadata")
template <- data.table::as.data.table(metadata[, columns, with = FALSE])
template <- unique(template)
if (!is.null(add)) {
for (col in add) {
if (!col %in% names(template)) template[[col]] <- NA_character_
}
}
if (!is.null(path)) {
data.table::fwrite(template, path, na = "")
return(invisible(template))
}
template
}
#' @rdname build_lib
#' @export
join_lib_metadata <- function(x, lookup, by, require_complete = FALSE,
return = c("object", "table", "report"),
suffixes = c(".x", ".y")) {
if (inherits(x, "FileSpecs"))
.filespec_stop_unsupported("join_lib_metadata()")
return <- match.arg(return)
is_os <- is_OpenSpecy(x)
is_specs <- is_Specs(x)
if (!(is_os || is_specs)) {
stop("'x' must be an OpenSpecy or Specs object", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x$metadata))
lookup <- .lib_read_lookup(lookup)
keys <- if (is.null(names(by)) || all(names(by) == "")) {
list(x = unname(by), y = unname(by))
} else {
list(x = names(by), y = unname(by))
}
.lib_require_cols(metadata, keys$x, "metadata")
.lib_require_cols(lookup, keys$y, "lookup")
make_key <- function(tab, cols) {
vals <- lapply(cols, function(col) as.character(tab[[col]]))
any_na <- Reduce(`|`, lapply(vals, is.na))
key <- do.call(paste, c(vals, sep = "\r"))
key[any_na] <- NA_character_
key
}
metadata_key <- make_key(metadata, keys$x)
lookup_key <- make_key(lookup, keys$y)
value_cols <- setdiff(names(lookup), keys$y)
dups <- duplicated(lookup_key) | duplicated(lookup_key, fromLast = TRUE)
dups[is.na(lookup_key)] <- FALSE
dup_report <- if (any(dups)) {
data.table::data.table(value = lookup_key[dups])[
, .(n = .N), by = "value"][
, `:=`(problem = "duplicate_lookup_key",
column = paste(keys$y, collapse = "|"))][
, .(problem, column, value, n)]
} else {
data.table::data.table(problem = character(), column = character(),
value = character(), n = integer())
}
if (nrow(dup_report) > 0) {
attr(dup_report, "data") <- lookup
stop("Lookup keys must be unique before joining. Duplicate keys: ",
paste(head(dup_report$value, 10), collapse = ", "), call. = FALSE)
}
missing_key <- is.na(metadata_key) | !metadata_key %in% lookup_key
unmatched <- data.table::data.table(value = metadata_key[missing_key])[
!is.na(value), .(n = .N), by = "value"][
, `:=`(problem = "unmatched_metadata_key",
column = paste(keys$x, collapse = "|"))][
, .(problem, column, value, n)]
missing_values <- data.table::data.table()
matched <- match(metadata_key, lookup_key)
if (length(value_cols) > 0 && any(!is.na(matched))) {
for (col in value_cols) {
vals <- lookup[[col]][matched]
miss <- !is.na(matched) & is.na(vals)
if (any(miss)) {
missing_values <- rbind(missing_values, data.table::data.table(
problem = "missing_joined_value",
column = col,
value = metadata_key[miss],
n = 1L
)[, .(n = .N), by = .(problem, column, value)], fill = TRUE)
}
}
}
report <- data.table::rbindlist(list(unmatched, missing_values), fill = TRUE)
.lib_alert_join_report(report, require_complete)
lookup_values <- lookup[, setdiff(names(lookup), keys$y), with = FALSE]
meta <- data.table::copy(metadata)
look <- data.table::copy(lookup_values)
meta$..join_key <- metadata_key
meta$..row_id <- seq_len(nrow(meta))
look$..join_key <- lookup_key
joined <- merge(meta, look, by = "..join_key", all.x = TRUE, sort = FALSE,
suffixes = suffixes)
data.table::setorder(joined, "..row_id")
joined[, c("..join_key", "..row_id") := NULL]
attr(joined, "join_report") <- report
if (return == "report") return(list(data = joined, report = report))
if (return == "table") return(joined)
x$metadata <- joined
attr(x, "join_report") <- report
x
}
#' @rdname build_lib
#' @export
join_material_hierarchy <- function(x, hierarchy, key_col = "material",
levels = c("material", "material_class",
"material_type"),
output_names = levels,
require_complete = FALSE,
return = c("object", "table", "report")) {
if (inherits(x, "FileSpecs"))
.filespec_stop_unsupported("join_material_hierarchy()")
return <- match.arg(return)
is_os <- is_OpenSpecy(x)
is_specs <- is_Specs(x)
if (!(is_os || is_specs)) {
stop("'x' must be an OpenSpecy or Specs object", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x$metadata))
hierarchy <- .lib_read_lookup(hierarchy)
if (!is.null(names(output_names)) && any(names(output_names) != "")) {
missing <- setdiff(levels, names(output_names))
if (length(missing) > 0) {
stop("'output_names' is missing hierarchy levels: ",
paste(missing, collapse = ", "), call. = FALSE)
}
output_names <- unname(output_names[levels])
}
if (length(output_names) != length(levels)) {
stop("'output_names' must have the same length as 'levels'", call. = FALSE)
}
.lib_require_cols(metadata, key_col, "metadata")
.lib_require_cols(hierarchy, levels, "hierarchy")
keys <- as.character(metadata[[key_col]])
out <- metadata
for (col in output_names) out[[col]] <- NA_character_
matched_level <- rep(NA_character_, nrow(out))
remaining <- seq_len(nrow(out))
duplicate_reports <- list()
for (i in seq_along(levels)) {
if (length(remaining) == 0L) break
level <- levels[i]
cols <- levels[i:length(levels)]
h <- unique(hierarchy[, cols, with = FALSE])
h_key <- as.character(h[[level]])
dups <- duplicated(h_key) | duplicated(h_key, fromLast = TRUE)
dups[is.na(h_key)] <- FALSE
if (any(dups)) {
duplicate_reports[[level]] <- data.table::data.table(
problem = "duplicate_hierarchy_key",
level = level,
value = unique(h_key[dups])
)
next
}
idx <- match(keys[remaining], h_key)
found <- !is.na(idx)
rows <- remaining[found]
if (length(rows) > 0) {
for (j in i:length(levels)) {
out[[output_names[j]]][rows] <- h[[levels[j]]][idx[found]]
}
matched_level[rows] <- level
remaining <- remaining[!found]
}
}
unmatched <- data.table::data.table(value = keys[is.na(matched_level)])[
!is.na(value), .(n = .N), by = "value"][
, `:=`(problem = "unmatched_hierarchy_key",
column = "hierarchy")][
, .(problem, column, value, n)]
duplicates <- data.table::rbindlist(duplicate_reports, fill = TRUE)
if (nrow(duplicates) > 0) {
duplicates[, `:=`(column = level, n = 1L)]
duplicates <- duplicates[, .(problem, column, value, n)]
}
report <- data.table::rbindlist(list(unmatched, duplicates), fill = TRUE)
.lib_alert_join_report(report, require_complete)
attr(out, "join_report") <- report
if (return == "report") return(list(data = out, report = report))
if (return == "table") return(out)
x$metadata <- out
attr(x, "join_report") <- report
x
}
#' @rdname build_lib
#' @export
dedupe_spec <- function(x, id_col = "sample_name", exclude_ids = NULL,
duplicate = c("first", "remove_all", "none"),
scale = 100, algo = "md5") {
duplicate <- match.arg(duplicate)
x <- as_OpenSpecy(x)
ids <- vapply(seq_len(ncol(x$spectra)), function(i) {
digest::digest(list(as.integer(x$wavenumber),
as.integer(x$spectra[, i] * scale)),
algo = algo)
}, FUN.VALUE = character(1))
x$metadata[[id_col]] <- ids
colnames(x$spectra) <- ids
x$metadata$col_id <- ids
keep <- rep(TRUE, length(ids))
if (!is.null(exclude_ids)) keep <- keep & !ids %in% exclude_ids
if (duplicate == "first") keep <- keep & !duplicated(ids)
if (duplicate == "remove_all") {
keep <- keep & !(duplicated(ids) | duplicated(ids, fromLast = TRUE))
}
if (!all(keep)) x <- filter_spec(x, keep)
x
}
#' @rdname build_lib
#' @export
prune_lib <- function(x, class_col = "material_class",
type_col = "spectrum_type",
material_type_col = "material_type",
id_col = "sample_name", min_n = 10,
cross_class = FALSE,
cross_class_threshold = 0.9,
exclude = c(2200, 2420),
return = c("object", "ids", "report"),
progress = TRUE) {
return <- match.arg(return)
x <- as_OpenSpecy(x)
.lib_require_cols(x$metadata, c(class_col, type_col, material_type_col),
"metadata")
if (length(min_n) != 1L || is.na(min_n) || min_n < 1 || min_n %% 1 != 0) {
stop("'min_n' must be one positive whole number", call. = FALSE)
}
if (!is.logical(cross_class) || length(cross_class) != 1L ||
is.na(cross_class)) {
stop("'cross_class' must be TRUE or FALSE", call. = FALSE)
}
if (!is.numeric(cross_class_threshold) ||
length(cross_class_threshold) != 1L ||
!is.finite(cross_class_threshold) || cross_class_threshold < 0 ||
cross_class_threshold > 1) {
stop("'cross_class_threshold' must be one finite number in [0, 1]",
call. = FALSE)
}
if (!is.numeric(exclude) || length(exclude) != 2L || anyNA(exclude)) {
stop("'exclude' must be two finite wavenumbers", call. = FALSE)
}
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
metadata <- data.table::copy(x$metadata)
ids <- .lib_ids(x, id_col)
classes <- trimws(as.character(metadata[[class_col]]))
material_types <- trimws(tolower(as.character(
metadata[[material_type_col]]
)))
spectrum_types <- trimws(tolower(as.character(metadata[[type_col]])))
pools <- .lib_prune_pools(metadata[[type_col]])
normalized <- .lib_prune_normalize(x$spectra, x$wavenumber, exclude)
before_n <- length(ids)
cross_class_removals <- .lib_prune_cross_class_schema()
cross_class_conflicts <- .lib_prune_conflict_edge_schema()
if (isTRUE(cross_class)) {
if (!"library_name" %in% names(metadata)) {
stop(
"'cross_class = TRUE' requires populated library_name metadata for ",
"every resolved class spectrum", call. = FALSE
)
}
library_names <- trimws(as.character(metadata$library_name))
class_keys <- tolower(classes)
resolved <- !is.na(classes) & nzchar(classes) &
!class_keys %in% c(
"other", "other plastic", "other material", "unclassified"
)
if (any(resolved & (is.na(library_names) | !nzchar(library_names)))) {
stop(
"'cross_class = TRUE' requires populated library_name metadata for ",
"every resolved class spectrum", call. = FALSE
)
}
cross_normalized <- .lib_prune_normalize(
x$spectra, x$wavenumber, exclude = NULL
)
conflict <- .lib_prune_cross_class_conflicts(
classes, spectrum_types, cross_normalized, ids, library_names,
threshold = cross_class_threshold, progress = progress,
block_size = 256L, support_groups = spectrum_types, min_n = min_n,
correlation_view = "prune_full"
)
cross_class_removals <- conflict$removals
cross_class_conflicts <- conflict$conflicts
if (length(conflict$removed_rows)) {
keep <- rep(TRUE, length(ids))
keep[conflict$removed_rows] <- FALSE
if (!any(keep)) {
stop("Cross-class pruning would remove every spectrum",
call. = FALSE)
}
x <- filter_spec(x, keep)
metadata <- data.table::copy(x$metadata)
ids <- ids[keep]
classes <- classes[keep]
material_types <- material_types[keep]
spectrum_types <- spectrum_types[keep]
pools <- pools[keep]
library_names <- library_names[keep]
normalized <- normalized[keep, , drop = FALSE]
}
rm(cross_normalized)
}
generic_reassigned <- .lib_reassign_other_classes(
classes, material_types, pools, normalized, ids, progress = progress
)
classes <- generic_reassigned$classes
material_types <- generic_reassigned$material_types
small_reassigned <- .lib_reassign_small_classes(
classes, material_types, spectrum_types, pools, normalized, ids,
min_n = min_n, progress = progress
)
classes <- small_reassigned$classes
material_types <- small_reassigned$material_types
reassignment_report <- data.table::rbindlist(list(
generic_reassigned$report, small_reassigned$report
), fill = TRUE)
metadata[[class_col]] <- classes
metadata[[material_type_col]] <- material_types
protected <- tolower(classes) %in% c(
"unclassified", "other", "other plastic", "other material"
)
support <- data.table::data.table(
row = seq_along(ids), spectrum_type = spectrum_types, pool = pools,
material_class = classes
)[
!is.na(spectrum_type) & nzchar(spectrum_type) &
!is.na(material_class) & nzchar(material_class),
.(observed_n = .N), by = .(spectrum_type, pool, material_class)
]
if (nrow(support)) {
data.table::setorder(
support, spectrum_type, -observed_n, material_class
)
}
excluded_classes <- small_reassigned$classes_report
if (!nrow(excluded_classes)) {
excluded_classes <- .lib_prune_excluded_class_schema()
}
threshold_rows <- small_reassigned$dropped_rows
active <- rep(TRUE, length(ids))
active[threshold_rows] <- FALSE
if (isTRUE(progress)) {
if (nrow(excluded_classes)) {
preview_n <- min(8L, nrow(excluded_classes))
preview <- excluded_classes[seq_len(preview_n), sprintf(
"%s / %s (n=%d; shortfall=%d)",
spectrum_type, material_class, observed_n, shortfall
)]
if (nrow(excluded_classes) > preview_n) {
preview <- c(
preview,
sprintf("and %d more", nrow(excluded_classes) - preview_n)
)
}
message(sprintf(
paste0("prune_lib: minimum support gate reassigned %d and removed %d ",
"spectrum/spectra across %d class/type group(s) below ",
"min_n=%d: %s"),
nrow(small_reassigned$report), length(threshold_rows),
nrow(excluded_classes), min_n,
paste(preview, collapse = "; ")
))
} else {
message(sprintf(
paste0("prune_lib: minimum support gate complete ",
"(%d class/type group(s); none below min_n=%d)"),
nrow(support), min_n
))
}
}
schedule <- data.table::data.table(
pool = pools[active],
material_class = classes[active],
is_protected = protected[active]
)[!is.na(pool) & !is.na(material_class) & nzchar(material_class),
.(initial_n = .N, is_protected = all(is_protected)),
by = .(pool, material_class)][is_protected == FALSE]
if (nrow(schedule) > 0L) {
data.table::setorder(schedule, pool, -initial_n, material_class)
schedule[, schedule_order := seq_len(.N), by = pool]
} else {
schedule[, schedule_order := integer()]
}
removal_rows <- if (nrow(cross_class_removals)) {
list(cross_class_removals)
} else {
list()
}
if (length(threshold_rows)) {
removal_rows[[length(removal_rows) + 1L]] <- data.table::data.table(
spectrum_id = ids[threshold_rows],
prior_class = classes[threshold_rows],
matched_id = NA_character_, matched_class = NA_character_,
correlation = NA_real_, pool = pools[threshold_rows],
schedule_order = NA_integer_, reason = "class_below_min_n"
)
}
removal_i <- length(removal_rows)
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: starting %d scheduled class(es) across %d spectrum pool(s)",
nrow(schedule), length(unique(stats::na.omit(pools)))
))
}
if (nrow(schedule) > 0L) {
for (s in seq_len(nrow(schedule))) {
target_pool <- schedule$pool[[s]]
target_class <- schedule$material_class[[s]]
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: %s / %s (%d initially)",
target_pool, target_class, schedule$initial_n[[s]]
))
}
initial_target <- which(active & pools == target_pool &
!is.na(classes) & classes == target_class)
candidates <- which(active & pools == target_pool & !protected)
candidate_order <- order(ids[candidates], candidates, na.last = TRUE)
candidates <- candidates[candidate_order]
iteration <- 0L
best_index <- rep(NA_integer_, length(active))
best_correlation <- rep(NA_real_, length(active))
query <- initial_target
repeat {
target <- which(active & pools == target_pool &
!is.na(classes) & classes == target_class)
if (length(target) <= min_n) break
if (length(query) > 0L) {
active_candidates <- candidates[active[candidates]]
correlation_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: %s / %s blockwise correlation starting ",
"(%d query; %d eligible; iteration=%d)"),
target_pool, target_class, length(query),
length(active_candidates), iteration + 1L
))
}
best <- .lib_prune_best_match(
query, active_candidates, normalized, ids,
exclude_self = TRUE, block_size = 32L
)
best_index[query] <- best$index
best_correlation[query] <- best$correlation
rm(best)
gc(verbose = FALSE, full = TRUE)
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: %s / %s blockwise correlation complete ",
"(%d query; %d eligible; %.1fs)"),
target_pool, target_class, length(query),
length(active_candidates),
proc.time()[["elapsed"]] - correlation_started
))
}
}
target_best <- best_index[target]
target_correlation <- best_correlation[target]
conflicts <- which(
!is.na(target_best) & is.finite(target_correlation) &
classes[target_best] != target_class
)
conflicts <- conflicts[!is.na(conflicts)]
if (length(conflicts) == 0L) break
removable_n <- min(length(conflicts), length(target) - min_n)
if (removable_n < 1L) break
conflict_rows <- data.table::data.table(
query = target[conflicts],
matched = target_best[conflicts],
correlation = target_correlation[conflicts]
)
conflict_rows[, query_id := ids[query]]
data.table::setorder(conflict_rows, -correlation, query_id)
conflict_rows <- conflict_rows[seq_len(removable_n)]
active[conflict_rows$query] <- FALSE
iteration <- iteration + 1L
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: %s / %s iteration %d ",
"(removed=%d; retained=%d)"),
target_pool, target_class, iteration, nrow(conflict_rows),
sum(active[initial_target])
))
}
removal_i <- removal_i + 1L
removal_rows[[removal_i]] <- conflict_rows[, .(
spectrum_id = ids[query],
prior_class = classes[query],
matched_id = ids[matched],
matched_class = classes[matched],
correlation,
pool = target_pool,
schedule_order = schedule$schedule_order[[s]],
reason = "top_match_other_class"
)]
remaining_target <- target[active[target]]
query <- remaining_target[
is.na(best_index[remaining_target]) |
!active[best_index[remaining_target]]
]
if (length(query) == 0L) {
break
}
}
if (isTRUE(progress)) {
retained <- sum(active & pools == target_pool &
!is.na(classes) & classes == target_class)
message(sprintf(
"prune_lib: %s / %s complete (retained=%d; removed=%d)",
target_pool, target_class, retained,
schedule$initial_n[[s]] - retained
))
}
}
}
if (isTRUE(cross_class) && any(active)) {
active_rows <- which(active)
closure_normalized <- .lib_prune_normalize(
x$spectra[, active_rows, drop = FALSE], x$wavenumber, exclude = NULL
)
closure <- .lib_prune_cross_class_conflicts(
classes[active_rows], spectrum_types[active_rows], closure_normalized,
ids[active_rows], library_names[active_rows],
threshold = cross_class_threshold, progress = progress,
block_size = 256L, support_groups = spectrum_types[active_rows],
min_n = min_n, correlation_view = "post_reassignment_full"
)
if (nrow(closure$removals)) {
closure$removals[, phase := "final_closure"]
cross_class_removals <- data.table::rbindlist(
list(cross_class_removals, closure$removals), fill = TRUE
)
removal_i <- removal_i + 1L
removal_rows[[removal_i]] <- closure$removals
active[active_rows[closure$removed_rows]] <- FALSE
}
if (nrow(closure$conflicts)) {
closure$conflicts[, phase := "final_closure"]
cross_class_conflicts <- data.table::rbindlist(
list(cross_class_conflicts, closure$conflicts), fill = TRUE
)
}
rm(closure_normalized, closure)
resolved_active <- active & !protected & !is.na(spectrum_types) &
nzchar(spectrum_types) & !is.na(classes) & nzchar(classes)
final_support <- data.table::data.table(
row = which(resolved_active),
spectrum_type = spectrum_types[resolved_active],
material_class = classes[resolved_active]
)[, .(rows = list(row), observed_n = .N),
by = .(spectrum_type, material_class)]
small_final <- final_support[observed_n < min_n]
if (nrow(small_final)) {
drop <- unlist(small_final$rows, use.names = FALSE)
count_lookup <- small_final$observed_n[match(
paste(spectrum_types[drop], classes[drop]),
paste(small_final$spectrum_type, small_final$material_class)
)]
floor_removals <- data.table::data.table(
phase = "final_closure", correlation_view = "global_support",
component_id = NA_character_, spectrum_id = ids[drop],
prior_class = classes[drop], library_name = library_names[drop],
matched_id = NA_character_, matched_class = NA_character_,
matched_library = NA_character_, correlation = NA_real_,
pool = spectrum_types[drop], active_degree = 0L,
matched_active_degree = 0L, evidence_libraries = 0L,
conflicting_spectra = 0L, matched_evidence_libraries = 0L,
decision_round = NA_integer_, threshold = cross_class_threshold,
class_n_before = as.integer(count_lookup), class_n_after = 0L,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "global_support_at_risk",
reason = "class_below_global_min_n_after_closure"
)
active[drop] <- FALSE
cross_class_removals <- data.table::rbindlist(
list(cross_class_removals, floor_removals), fill = TRUE
)
removal_i <- removal_i + 1L
removal_rows[[removal_i]] <- floor_removals
}
}
rm(normalized)
removals <- if (length(removal_rows) > 0L) {
data.table::rbindlist(removal_rows, fill = TRUE)
} else {
data.table::data.table(
spectrum_id = character(), prior_class = character(),
matched_id = character(), matched_class = character(),
correlation = numeric(), pool = character(), schedule_order = integer(),
reason = character()
)
}
retained_ids <- ids[active]
out <- x
out$metadata <- metadata
if (!all(active)) out <- filter_spec(out, active)
audit <- list(
retained_ids = retained_ids,
schedule = schedule,
excluded_classes = excluded_classes,
reassignments = reassignment_report,
cross_class_removals = cross_class_removals,
cross_class_conflicts = cross_class_conflicts,
removals = removals,
summary = data.table::data.table(
before = before_n,
after = sum(active),
reassigned = nrow(reassignment_report),
classes_excluded = sum(excluded_classes$action == "dropped"),
cross_class_removed = nrow(cross_class_removals),
threshold_removed = length(threshold_rows),
removed = before_n - sum(active)
)
)
attr(out, "prune_report") <- audit
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: complete (before=%d; after=%d; reassigned=%d; ",
"classes_excluded=%d; cross_class_removed=%d; ",
"threshold_removed=%d; removed=%d)"),
before_n, sum(active), nrow(reassignment_report),
sum(excluded_classes$action == "dropped"),
nrow(cross_class_removals), length(threshold_rows),
before_n - sum(active)
))
}
if (return == "ids") return(retained_ids)
if (return == "report") return(c(list(object = out), audit))
out
}
.lib_prune_excluded_class_schema <- function() {
data.table::data.table(
spectrum_type = character(), pool = character(),
material_class = character(), observed_n = integer(),
minimum_spectra = integer(), shortfall = integer(),
destination_class = character(), mean_correlation = numeric(),
spectra_removed = integer(), action = character(), reason = character()
)
}
.lib_prune_excluded_assessment_schema <- function() {
out <- .lib_prune_excluded_class_schema()
out[, artifact := character()]
data.table::setcolorder(out, c("artifact", setdiff(names(out), "artifact")))
out
}
.lib_prune_pools <- function(type) {
type <- trimws(tolower(as.character(type)))
out <- ifelse(type %in% c("ftir", "nir"), "ftir_nir",
ifelse(type == "raman", "raman", type))
out[is.na(type) | !nzchar(type)] <- NA_character_
out
}
.lib_prune_normalize <- function(spectra, wavenumber, exclude) {
use <- if (is.null(exclude)) {
rep(TRUE, length(wavenumber))
} else {
limits <- sort(exclude)
wavenumber < limits[[1L]] | wavenumber > limits[[2L]]
}
if (!any(use)) {
stop("'exclude' removes every wavenumber", call. = FALSE)
}
# Reproduce cor_spec()'s exact make_rel -> mean replacement -> correlation
# scaling sequence in bounded spectrum blocks. Preserving that operation
# order keeps deterministic tie-breaking while avoiding full correlation
# matrices during pruning.
values <- matrix(NA_real_, nrow = ncol(spectra), ncol = sum(use))
row_block <- 256L
blocks <- split(seq_len(nrow(values)),
ceiling(seq_len(nrow(values)) / row_block))
for (block_index in seq_along(blocks)) {
block <- blocks[[block_index]]
part <- spectra[use, block, drop = FALSE]
part <- make_rel(part, na.rm = TRUE)
part <- .matrix_mean_replace(part)
values[block, ] <- .scale_correlation_spectra(part)
}
values
}
.lib_prune_best_match <- function(query, candidates, normalized, ids,
exclude_self = FALSE, block_size = 32L) {
candidate_order <- order(ids[candidates], candidates, na.last = TRUE)
candidates <- candidates[candidate_order]
best_index <- rep(NA_integer_, length(query))
best_correlation <- rep(NA_real_, length(query))
blocks <- split(seq_along(query),
ceiling(seq_along(query) / as.integer(block_size)))
for (block_index in seq_along(blocks)) {
block <- blocks[[block_index]]
# Multiply against the resident normalized matrix and subset the small
# correlation block, rather than copying the full candidate library for
# every query block.
cors <- tcrossprod(normalized[query[block], , drop = FALSE], normalized)
cors <- cors[, candidates, drop = FALSE]
cors[!is.finite(cors)] <- -Inf
if (isTRUE(exclude_self)) {
self_col <- match(query[block], candidates)
has_self <- !is.na(self_col)
cors[cbind(which(has_self), self_col[has_self])] <- -Inf
}
top <- matrixStats::rowMaxs(cors)
tolerance <- sqrt(.Machine$double.eps) * pmax(1, abs(top))
near_top <- abs(cors - top) <= tolerance
near_top[is.na(near_top)] <- FALSE
local <- max.col(near_top, ties.method = "first")
scores <- cors[cbind(seq_along(block), local)]
ok <- is.finite(scores)
best_index[block[ok]] <- candidates[local[ok]]
best_correlation[block[ok]] <- scores[ok]
rm(cors, top, tolerance, near_top, local, scores)
if (block_index %% 8L == 0L) {
gc(verbose = FALSE, full = TRUE)
}
}
gc(verbose = FALSE, full = TRUE)
list(index = best_index, correlation = best_correlation)
}
.lib_prune_cross_class_schema <- function() {
data.table::data.table(
phase = character(), correlation_view = character(),
component_id = character(),
spectrum_id = character(), prior_class = character(),
library_name = character(), matched_id = character(),
matched_class = character(), matched_library = character(),
correlation = numeric(), pool = character(),
active_degree = integer(), matched_active_degree = integer(),
evidence_libraries = integer(), conflicting_spectra = integer(),
matched_evidence_libraries = integer(), decision_round = integer(),
threshold = numeric(), class_n_before = integer(),
class_n_after = integer(), schedule_order = integer(),
quarantine_status = character(), review_status = character(),
reason = character()
)
}
.lib_prune_conflict_edge_schema <- function() {
data.table::data.table(
phase = character(), correlation_view = character(),
component_id = character(), pool = character(),
spectrum_id = character(), prior_class = character(),
library_name = character(), matched_id = character(),
matched_class = character(), matched_library = character(),
correlation = numeric(), same_library = logical(),
class_pair_libraries = integer(), review_status = character(),
threshold = numeric()
)
}
.lib_prune_removal_assessment_schema <- function() {
out <- .lib_prune_cross_class_schema()
out[, artifact := character()]
data.table::setcolorder(out, c("artifact", setdiff(names(out), "artifact")))
out
}
.lib_prune_internal_class_conflicts <- function(
classes, pools, normalized, ids, library_names, threshold,
support_groups = pools, min_n = 1L, correlation_view = "prune_full",
progress = FALSE, block_size = 32L) {
n <- length(ids)
stopifnot(
length(classes) == n, length(pools) == n,
length(library_names) == n, length(support_groups) == n,
nrow(normalized) == n
)
generic <- c("other", "other plastic", "other material", "unclassified")
class_keys <- tolower(trimws(classes))
eligible <- !is.na(pools) & nzchar(pools) &
!is.na(classes) & nzchar(classes) & !class_keys %in% generic &
!is.na(library_names) & nzchar(library_names)
groups <- unique(data.table::data.table(
pool = pools[eligible], library_name = library_names[eligible]
))
data.table::setorder(groups, pool, library_name)
edge_rows <- list()
edge_i <- 0L
started <- proc.time()[["elapsed"]]
for (group_i in seq_len(nrow(groups))) {
pool <- groups$pool[[group_i]]
library_name <- groups$library_name[[group_i]]
candidates <- which(
eligible & pools == pool & library_names == library_name
)
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
if (length(candidates) < 2L) next
blocks <- split(candidates, ceiling(seq_along(candidates) / block_size))
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
matched <- candidates[
candidates > q & cors[row, ] > threshold &
classes[candidates] != classes[[q]]
]
if (!length(matched)) next
edge_i <- edge_i + 1L
edge_rows[[edge_i]] <- data.table::data.table(
from = q, to = matched,
correlation = cors[row, match(matched, candidates)],
pool = pool, library_name = library_name
)
}
rm(cors)
}
}
edges <- if (length(edge_rows)) {
data.table::rbindlist(edge_rows)
} else {
data.table::data.table(
from = integer(), to = integer(), correlation = numeric(),
pool = character(), library_name = character()
)
}
if (!nrow(edges)) {
return(list(
removed_rows = integer(), removals = .lib_prune_cross_class_schema(),
conflicts = .lib_prune_conflict_edge_schema()
))
}
parent <- seq_len(n)
find_root <- function(value) {
while (parent[[value]] != value) value <- parent[[value]]
value
}
for (edge_i in seq_len(nrow(edges))) {
left <- find_root(edges$from[[edge_i]])
right <- find_root(edges$to[[edge_i]])
if (left != right) parent[[max(left, right)]] <- min(left, right)
}
vertices <- sort(unique(c(edges$from, edges$to)))
roots <- vapply(vertices, find_root, integer(1L))
root_labels <- vapply(split(vertices, roots), function(rows) {
sort(ids[rows], na.last = TRUE)[[1L]]
}, character(1L))
component <- rep(NA_character_, n)
component[vertices] <- paste0("internal:", root_labels[as.character(roots)])
pair_left <- pmin(classes[edges$from], classes[edges$to])
pair_right <- pmax(classes[edges$from], classes[edges$to])
pair_stats <- data.table::data.table(
pool = edges$pool, class_left = pair_left, class_right = pair_right,
library_name = edges$library_name
)[, .(class_pair_libraries = data.table::uniqueN(library_name)),
by = .(pool, class_left, class_right)]
pair_lookup <- pair_stats[data.table::data.table(
pool = edges$pool, class_left = pair_left, class_right = pair_right
), on = .(pool, class_left, class_right)]$class_pair_libraries
active <- eligible
decisions <- list()
decision_i <- 0L
round <- 0L
repeat {
edge_active <- active[edges$from] & active[edges$to]
current <- edges[edge_active]
if (!nrow(current)) break
degree <- tabulate(c(current$from, current$to), nbins = n)
maximum <- max(degree)
top <- which(active & degree == maximum)
tied_edges <- current[from %in% top & to %in% top]
if (nrow(tied_edges)) {
remove <- sort(unique(c(tied_edges$from, tied_edges$to)))
tied <- rep(TRUE, length(remove))
} else {
remove <- top[order(ids[top], top, na.last = TRUE)][[1L]]
tied <- FALSE
}
round <- round + 1L
for (remove_i in seq_along(remove)) {
q <- remove[[remove_i]]
incident <- current[from == q | to == q]
neighbor <- ifelse(incident$from == q, incident$to, incident$from)
selected_order <- order(
-incident$correlation, ids[neighbor], neighbor, na.last = TRUE
)
selected_row <- selected_order[[1L]]
matched <- neighbor[[selected_row]]
class_before <- sum(
active & support_groups == support_groups[[q]] &
classes == classes[[q]], na.rm = TRUE
)
class_removed <- sum(
remove %in% which(
active & support_groups == support_groups[[q]] &
classes == classes[[q]]
)
)
class_after <- class_before - class_removed
incident_rows <- which(
(edges$from == q | edges$to == q) & edge_active
)
recurrent <- any(pair_lookup[incident_rows] >= 2L)
review <- if (class_after > 0L && class_after < min_n) {
"global_support_at_risk"
} else if (recurrent) {
"recurrent_class_pair"
} else {
"automatic"
}
decision_i <- decision_i + 1L
decisions[[decision_i]] <- data.table::data.table(
phase = "internal", correlation_view = correlation_view,
component_id = component[[q]], spectrum_id = ids[[q]],
prior_class = classes[[q]], library_name = library_names[[q]],
matched_id = ids[[matched]], matched_class = classes[[matched]],
matched_library = library_names[[matched]],
correlation = incident$correlation[[selected_row]], pool = pools[[q]],
active_degree = degree[[q]],
matched_active_degree = degree[[matched]], evidence_libraries = 0L,
conflicting_spectra = degree[[q]],
matched_evidence_libraries = 0L, decision_round = round,
threshold = threshold, class_n_before = class_before,
class_n_after = class_after, schedule_order = NA_integer_,
quarantine_status = "excluded", review_status = review,
reason = if (isTRUE(tied[[remove_i]])) {
"cross_class_equal_internal_degree"
} else {
"cross_class_more_internal_conflicts"
}
)
}
active[remove] <- FALSE
}
removals <- data.table::rbindlist(decisions, fill = TRUE)
if (!nrow(removals)) removals <- .lib_prune_cross_class_schema()
data.table::setorder(removals, decision_round, -active_degree, spectrum_id)
conflicts <- data.table::data.table(
phase = "internal", correlation_view = correlation_view,
component_id = component[edges$from], pool = edges$pool,
spectrum_id = ids[edges$from], prior_class = classes[edges$from],
library_name = library_names[edges$from], matched_id = ids[edges$to],
matched_class = classes[edges$to],
matched_library = library_names[edges$to],
correlation = edges$correlation, same_library = TRUE,
class_pair_libraries = pair_lookup,
review_status = ifelse(
pair_lookup >= 2L, "recurrent_class_pair", "automatic"
), threshold = threshold
)
if (isTRUE(progress)) message(sprintf(
paste0("prune_lib: internal cross-class pass complete ",
"(edges=%d; removed=%d; elapsed=%.1fs)"),
nrow(edges), nrow(removals), proc.time()[["elapsed"]] - started
))
list(
removed_rows = which(!active & eligible), removals = removals,
conflicts = conflicts
)
}
.lib_prune_between_library_conflicts <- function(classes, pools, normalized, ids,
library_names, threshold,
correlation_view = "prune_full",
progress = FALSE,
block_size = 32L) {
n <- length(ids)
started <- proc.time()[["elapsed"]]
stopifnot(
length(classes) == n, length(pools) == n,
length(library_names) == n, nrow(normalized) == n
)
generic <- c("other", "other plastic", "other material", "unclassified")
class_keys <- tolower(trimws(classes))
eligible <- !is.na(pools) & nzchar(pools) &
!is.na(classes) & nzchar(classes) & !class_keys %in% generic
evidence_libraries <- integer(n)
conflicting_spectra <- integer(n)
pool_values <- sort(unique(pools[eligible]))
pool_values <- pool_values[!is.na(pool_values) & nzchar(pool_values)]
for (pool in pool_values) {
candidates <- which(eligible & pools == pool)
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
blocks <- split(candidates, ceiling(seq_along(candidates) / block_size))
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: cross-class evidence scan %s starting ",
"(%d spectra; %d features; block=%d; threshold > %.4f)"),
pool, length(candidates), ncol(normalized), block_size, threshold
))
}
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
matched <- candidates[
cors[row, ] > threshold & candidates != q &
library_names[candidates] != library_names[[q]] &
classes[candidates] != classes[[q]]
]
conflicting_spectra[[q]] <- length(matched)
if (length(matched)) {
evidence_libraries[[q]] <- length(unique(library_names[matched]))
}
}
rm(cors)
}
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: cross-class evidence scan %s complete ",
"(flagged=%d; max_libraries=%d; elapsed=%.1fs)"),
pool, sum(conflicting_spectra[candidates] > 0L),
max(evidence_libraries[candidates], 0L),
proc.time()[["elapsed"]] - started
))
}
}
scores <- sort(unique(evidence_libraries[conflicting_spectra > 0L]),
decreasing = TRUE)
scores <- scores[scores > 0L]
if (!length(scores)) {
return(list(removed_rows = integer(), removals =
.lib_prune_cross_class_schema()))
}
active <- eligible
decision_match <- rep(NA_integer_, n)
decision_correlation <- rep(NA_real_, n)
decision_round <- integer(n)
decision_reason <- rep(NA_character_, n)
for (round in seq_along(scores)) {
score <- scores[[round]]
remove_round <- integer()
for (pool in pool_values) {
query_rows <- which(
active & pools == pool & evidence_libraries == score
)
if (!length(query_rows)) next
candidates <- which(active & pools == pool)
candidates <- candidates[
order(ids[candidates], candidates, na.last = TRUE)
]
blocks <- split(
query_rows, ceiling(seq_along(query_rows) / block_size)
)
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
matched <- candidates[
cors[row, ] > threshold & candidates != q &
library_names[candidates] != library_names[[q]] &
classes[candidates] != classes[[q]]
]
if (!length(matched)) next
if (any(evidence_libraries[matched] > score)) {
stop("Internal cross-class pruning order invariant failed",
call. = FALSE)
}
tied <- matched[evidence_libraries[matched] == score]
decision_candidates <- if (length(tied)) tied else matched
candidate_columns <- match(decision_candidates, candidates)
candidate_correlations <- cors[row, candidate_columns]
best_order <- order(
-candidate_correlations, ids[decision_candidates],
decision_candidates, na.last = TRUE
)
selected <- decision_candidates[best_order[[1L]]]
decision_match[[q]] <- selected
decision_correlation[[q]] <- cors[
row, match(selected, candidates)
]
decision_round[[q]] <- round
decision_reason[[q]] <- if (length(tied)) {
"cross_class_equal_library_evidence"
} else {
"cross_class_more_library_evidence"
}
remove_round <- c(remove_round, q)
}
rm(cors)
}
}
remove_round <- sort(unique(remove_round))
active[remove_round] <- FALSE
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: cross-class decision round %d/%d ",
"(evidence_libraries=%d; removed=%d; active=%d; elapsed=%.1fs)"),
round, length(scores), score, length(remove_round), sum(active),
proc.time()[["elapsed"]] - started
))
}
}
retained <- which(active)
for (pool in pool_values) {
candidates <- retained[pools[retained] == pool]
if (length(candidates) < 2L) next
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
blocks <- split(candidates, ceiling(seq_along(candidates) / block_size))
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
conflict <- candidates[
cors[row, ] > threshold & candidates != q &
library_names[candidates] != library_names[[q]] &
classes[candidates] != classes[[q]]
]
if (length(conflict)) {
stop(
"Cross-class pruning postcondition failed for retained spectra: ",
ids[[q]], " and ", ids[[conflict[[1L]]]], call. = FALSE
)
}
}
rm(cors)
}
}
removed_rows <- which(decision_round > 0L)
matched_rows <- decision_match[removed_rows]
removals <- data.table::data.table(
phase = "independent", correlation_view = correlation_view,
component_id = NA_character_,
spectrum_id = ids[removed_rows], prior_class = classes[removed_rows],
library_name = library_names[removed_rows],
matched_id = ids[matched_rows], matched_class = classes[matched_rows],
matched_library = library_names[matched_rows],
correlation = decision_correlation[removed_rows],
pool = pools[removed_rows],
evidence_libraries = evidence_libraries[removed_rows],
conflicting_spectra = conflicting_spectra[removed_rows],
active_degree = conflicting_spectra[removed_rows],
matched_active_degree = conflicting_spectra[matched_rows],
matched_evidence_libraries = evidence_libraries[matched_rows],
decision_round = decision_round[removed_rows], threshold = threshold,
class_n_before = NA_integer_, class_n_after = NA_integer_,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "automatic", reason = decision_reason[removed_rows]
)
data.table::setorder(
removals, decision_round, -evidence_libraries, spectrum_id
)
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: cross-class conflict pass complete (removed=%d; elapsed=%.1fs)",
length(removed_rows), proc.time()[["elapsed"]] - started
))
}
list(removed_rows = removed_rows, removals = removals)
}
.lib_prune_cross_class_conflicts <- function(
classes, pools, normalized, ids, library_names, threshold,
support_groups = pools, min_n = 1L, correlation_view = "prune_full",
progress = FALSE, block_size = 32L) {
internal <- .lib_prune_internal_class_conflicts(
classes, pools, normalized, ids, library_names, threshold,
support_groups = support_groups, min_n = min_n,
correlation_view = correlation_view, progress = progress,
block_size = block_size
)
keep <- setdiff(seq_along(ids), internal$removed_rows)
independent <- .lib_prune_between_library_conflicts(
classes[keep], pools[keep], normalized[keep, , drop = FALSE], ids[keep],
library_names[keep], threshold, correlation_view = correlation_view,
progress = progress, block_size = block_size
)
independent_rows <- keep[independent$removed_rows]
conflicts <- internal$conflicts
if (nrow(independent$removals)) {
independent_edges <- independent$removals[, .(
phase, correlation_view, component_id, pool,
spectrum_id, prior_class, library_name, matched_id, matched_class,
matched_library, correlation, same_library = FALSE,
class_pair_libraries = pmax(
evidence_libraries, matched_evidence_libraries, na.rm = TRUE
), review_status, threshold
)]
conflicts <- data.table::rbindlist(
list(conflicts, independent_edges), fill = TRUE
)
}
list(
removed_rows = sort(unique(c(internal$removed_rows, independent_rows))),
removals = data.table::rbindlist(
list(internal$removals, independent$removals), fill = TRUE
),
conflicts = conflicts
)
}
.lib_prune_correlations <- function(x, query, candidates, exclude, ids) {
limits <- sort(exclude)
use <- x$wavenumber < limits[[1L]] | x$wavenumber > limits[[2L]]
query_spec <- x
query_spec$wavenumber <- x$wavenumber[use]
query_spec$spectra <- x$spectra[use, query, drop = FALSE]
query_spec$metadata <- x$metadata[query]
colnames(query_spec$spectra) <- ids[query]
candidate_spec <- x
candidate_spec$wavenumber <- x$wavenumber[use]
candidate_spec$spectra <- x$spectra[use, candidates, drop = FALSE]
candidate_spec$metadata <- x$metadata[candidates]
colnames(candidate_spec$spectra) <- ids[candidates]
# cor_spec() returns library spectra by query spectra. Passing the target
# class as the library gives the row-by-candidate layout needed by max.col()
# without transposing or copying the full correlation matrix.
correlations <- cor_spec(
candidate_spec, library = query_spec, compute = "optimized"
)
correlations[!is.finite(correlations)] <- -Inf
self_column <- match(query, candidates)
has_self <- !is.na(self_column)
correlations[cbind(which(has_self), self_column[has_self])] <- -Inf
correlations
}
.lib_reassign_other_classes <- function(classes, material_types, pools,
normalized, ids, progress = FALSE) {
class_keys <- tolower(classes)
generic_labels <- c("other", "other plastic", "other material")
generic <- which(class_keys %in% generic_labels)
rows <- list()
if (isTRUE(progress) && length(generic)) {
message(sprintf(
"prune_lib: reassigning %d generic-class spectrum/spectra",
length(generic)
))
}
groups <- split(generic, paste(pools[generic], class_keys[generic], sep = "\r"))
for (query in groups) {
generic_class <- class_keys[[query[[1L]]]]
target_pool <- pools[[query[[1L]]]]
eligible <- !is.na(pools) & pools == target_pool &
!class_keys %in% c(generic_labels, "unclassified") &
!is.na(classes) & nzchar(classes)
if (identical(generic_class, "other plastic")) {
eligible <- eligible & material_types == "plastic"
} else if (identical(generic_class, "other material")) {
eligible <- eligible & class_keys %in% c("organic matter", "mineral")
}
candidates <- which(eligible)
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: %s / %s reassignment (%d query; %d eligible)",
target_pool, generic_class, length(query), length(candidates)
))
}
if (length(candidates) == 0L) next
best <- .lib_prune_best_match(query, candidates, normalized, ids)
matched <- which(!is.na(best$index))
if (!length(matched)) next
query_rows <- query[matched]
candidate_rows <- best$index[matched]
prior_class <- classes[query_rows]
prior_type <- material_types[query_rows]
classes[query_rows] <- classes[candidate_rows]
material_types[query_rows] <- material_types[candidate_rows]
rows[[length(rows) + 1L]] <- data.table::data.table(
spectrum_id = ids[query_rows], prior_class,
material_class = classes[query_rows], prior_material_type = prior_type,
material_type = material_types[query_rows],
matched_id = ids[candidate_rows],
correlation = best$correlation[matched], pool = pools[query_rows],
reason = "nearest_eligible_class"
)
}
report <- if (length(rows) > 0L) {
data.table::rbindlist(rows, fill = TRUE)
} else {
data.table::data.table(
spectrum_id = character(), prior_class = character(),
material_class = character(), prior_material_type = character(),
material_type = character(), matched_id = character(),
correlation = numeric(), pool = character(), reason = character()
)
}
if (isTRUE(progress) && length(generic)) {
message(sprintf(
"prune_lib: generic-class reassignment complete (reassigned=%d; retained=%d)",
nrow(report), length(generic) - nrow(report)
))
}
list(classes = classes, material_types = material_types, report = report)
}
.lib_reassign_small_classes <- function(classes, material_types,
spectrum_types, pools, normalized,
ids, min_n, progress = FALSE) {
generic <- c("other", "other plastic", "other material", "unclassified")
support <- data.table::data.table(
row = seq_along(ids), spectrum_type = spectrum_types, pool = pools,
material_class = classes, material_type = material_types
)[
!is.na(spectrum_type) & nzchar(spectrum_type) &
!is.na(material_class) & nzchar(material_class),
.(
observed_n = .N,
material_type = {
values <- unique(material_type[!is.na(material_type) &
nzchar(material_type)])
if (length(values) == 1L) values else NA_character_
}
),
by = .(spectrum_type, pool, material_class)
]
small <- support[observed_n < min_n]
if (nrow(small)) {
data.table::setorder(small, spectrum_type, material_class)
}
established <- support[
observed_n >= min_n & !tolower(material_class) %in% generic
]
report_rows <- list()
class_rows <- list()
dropped_rows <- integer()
for (i in seq_len(nrow(small))) {
item <- small[i]
query <- which(
spectrum_types == item$spectrum_type & pools == item$pool &
!is.na(classes) & classes == item$material_class
)
eligible_classes <- established[
spectrum_type == item$spectrum_type & pool == item$pool,
material_class
]
candidates <- which(
spectrum_types == item$spectrum_type & pools == item$pool &
classes %in% eligible_classes
)
if (!is.na(item$material_type)) {
candidates <- candidates[
material_types[candidates] == item$material_type
]
}
candidates <- candidates[!is.na(candidates)]
match <- .lib_prune_best_class(
query, candidates, classes, normalized, ids
)
if (is.null(match) || tolower(item$material_class) == "unclassified") {
dropped_rows <- c(dropped_rows, query)
class_rows[[length(class_rows) + 1L]] <- data.table::data.table(
spectrum_type = item$spectrum_type, pool = item$pool,
material_class = item$material_class,
observed_n = as.integer(item$observed_n),
minimum_spectra = as.integer(min_n),
shortfall = as.integer(min_n - item$observed_n),
destination_class = NA_character_, mean_correlation = NA_real_,
spectra_removed = as.integer(item$observed_n), action = "dropped",
reason = "class_below_min_n_no_eligible_destination"
)
next
}
prior_class <- classes[query]
prior_type <- material_types[query]
classes[query] <- match$material_class
material_types[query] <- material_types[match$index]
report_rows[[length(report_rows) + 1L]] <- data.table::data.table(
spectrum_id = ids[query], prior_class,
material_class = classes[query], prior_material_type = prior_type,
material_type = material_types[query],
matched_id = ids[match$index], correlation = match$correlation,
pool = pools[query], reason = "class_below_min_n_reassigned"
)
class_rows[[length(class_rows) + 1L]] <- data.table::data.table(
spectrum_type = item$spectrum_type, pool = item$pool,
material_class = item$material_class,
observed_n = as.integer(item$observed_n),
minimum_spectra = as.integer(min_n),
shortfall = as.integer(min_n - item$observed_n),
destination_class = match$material_class,
mean_correlation = match$mean_correlation,
spectra_removed = 0L, action = "reassigned",
reason = "class_below_min_n_reassigned"
)
}
report <- if (length(report_rows)) {
data.table::rbindlist(report_rows, fill = TRUE)
} else {
.lib_prune_reassignment_schema()
}
classes_report <- if (length(class_rows)) {
data.table::rbindlist(class_rows, fill = TRUE)
} else {
.lib_prune_excluded_class_schema()
}
if (isTRUE(progress) && nrow(small)) {
message(sprintf(
paste0("prune_lib: small-class reassignment complete ",
"(classes=%d; reassigned=%d; dropped=%d)"),
nrow(small), sum(classes_report$action == "reassigned"),
sum(classes_report$action == "dropped")
))
}
list(
classes = classes, material_types = material_types, report = report,
classes_report = classes_report,
dropped_rows = sort(unique(as.integer(dropped_rows)))
)
}
.lib_prune_best_class <- function(query, candidates, classes, normalized, ids) {
if (!length(query) || !length(candidates)) return(NULL)
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
destination <- sort(unique(classes[candidates]))
destination <- destination[!is.na(destination) & nzchar(destination)]
if (!length(destination)) return(NULL)
correlations <- tcrossprod(
normalized[query, , drop = FALSE], normalized
)[, candidates, drop = FALSE]
correlations[!is.finite(correlations)] <- -Inf
scores <- vapply(destination, function(class) {
columns <- which(classes[candidates] == class)
best <- matrixStats::rowMaxs(correlations[, columns, drop = FALSE])
if (any(!is.finite(best))) -Inf else mean(best)
}, numeric(1L))
if (!any(is.finite(scores))) return(NULL)
best_score <- max(scores)
tolerance <- sqrt(.Machine$double.eps) * max(1, abs(best_score))
selected <- destination[which(abs(scores - best_score) <= tolerance)[[1L]]]
selected_candidates <- candidates[classes[candidates] == selected]
selected_columns <- match(selected_candidates, candidates)
selected_correlations <- correlations[, selected_columns, drop = FALSE]
top <- matrixStats::rowMaxs(selected_correlations)
near_top <- abs(selected_correlations - top) <=
sqrt(.Machine$double.eps) * pmax(1, abs(top))
local <- max.col(near_top, ties.method = "first")
list(
material_class = selected,
mean_correlation = unname(best_score),
index = selected_candidates[local],
correlation = selected_correlations[cbind(seq_along(query), local)]
)
}
#' @rdname build_lib
#' @export
reduce_lib <- function(x, group_cols = "material_class", id_col = "sample_name",
k = 50, min_n = k, return = c("object", "ids"),
progress = FALSE, ...) {
return <- match.arg(return)
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
x <- as_OpenSpecy(x)
.lib_require_cols(x$metadata, group_cols, "metadata")
ids <- .lib_ids(x, id_col)
groups <- do.call(paste, c(x$metadata[, group_cols, with = FALSE], sep = "_"))
group_index <- split(seq_along(groups), groups)
reduce_group <- lengths(group_index) > min_n & lengths(group_index) > k
reduce_number <- cumsum(reduce_group)
reduce_total <- sum(reduce_group)
reduction_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: %d spectra in %d groups; %d group(s) require PAM (k=%d)",
length(ids), length(group_index), reduce_total, k
))
}
keep_ids <- unlist(lapply(seq_along(group_index), function(group_i) {
idx <- group_index[[group_i]]
if (!reduce_group[[group_i]]) return(ids[idx])
reduce_i <- reduce_number[[group_i]]
values <- vapply(group_cols, function(column) {
value <- as.character(x$metadata[[column]][idx[[1L]]])
if (is.na(value) || !nzchar(value)) value <- "<missing>"
paste0(column, "=", value)
}, character(1))
label <- paste(values, collapse = ", ")
group_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM group %d/%d starting (%s; n=%d; k=%d)",
reduce_i, reduce_total, label, length(idx), k
))
}
reduction_group <- filter_spec(x, idx)
fill_started <- proc.time()[["elapsed"]]
missing_values <- sum(!is.finite(reduction_group$spectra))
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: spectrum-mean fill starting ",
"(%s; n=%d; missing=%d)"),
label, length(idx), missing_values
))
}
reduction_group$spectra <- make_rel(
.lib_spectrum_mean_replace(reduction_group$spectra), na.rm = TRUE
)
# A constant spectrum has no relative range. Keep it as a flat zero
# candidate so the support rule, rather than complete-case behavior,
# controls eligibility; cor_spec() will assign it no positive similarity.
reduction_group$spectra[!is.finite(reduction_group$spectra)] <- 0
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: spectrum-mean fill complete ",
"(%s; replaced=%d; %.1fs)"),
label, missing_values,
proc.time()[["elapsed"]] - fill_started
))
}
selected <- .pam_group_ids(
reduction_group, id_col = id_col, k = k,
progress = progress, group_label = label, ...
)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM group %d/%d complete (kept=%d/%d; %.1fs)",
reduce_i, reduce_total, length(selected), length(idx),
proc.time()[["elapsed"]] - group_started
))
}
selected
}), use.names = FALSE)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: complete (kept=%d/%d; %.1fs)",
length(keep_ids), length(ids),
proc.time()[["elapsed"]] - reduction_started
))
}
if (return == "ids") return(keep_ids)
filter_spec(x, keep_ids)
}
#' @rdname build_lib
#' @export
build_model_lib <- function(x, class_col = "material_class",
type_col = "spectrum_type", min_n = 10,
alpha = 0.1, seed = 123,
grouped = TRUE, weights = TRUE,
make_relative = TRUE,
method = c("logistic_regression", "random_forest"),
...) {
train_spec_model(
x = x, class_col = class_col, type_col = type_col, min_n = min_n,
alpha = alpha, seed = seed, grouped = grouped, weights = weights,
make_relative = make_relative, method = method, ...
)
}
.lib_build_workers <- function() {
workers <- suppressWarnings(as.integer(
getOption("OpenSpecy.build_workers", 1L)
))
if (length(workers) != 1L || is.na(workers) || workers < 1L) return(1L)
workers
}
.lib_cv_glmnet <- function(arguments, workers, folds, seed) {
workers <- min(as.integer(workers), as.integer(folds))
can_parallelize <- workers > 1L &&
requireNamespace("doFuture", quietly = TRUE) &&
requireNamespace("doRNG", quietly = TRUE) &&
requireNamespace("future", quietly = TRUE) &&
requireNamespace("foreach", quietly = TRUE)
if (!can_parallelize) return(do.call(glmnet::cv.glmnet, arguments))
# A maintainer workflow may register one persistent doFuture backend so
# successive model fits do not repeatedly start and stop worker processes.
if (identical(foreach::getDoParName(), "doFuture")) {
doRNG::registerDoRNG(seed)
on.exit(doFuture::registerDoFuture(), add = TRUE)
arguments$parallel <- TRUE
return(do.call(glmnet::cv.glmnet, arguments))
}
previous_plan <- future::plan()
on.exit({
future::plan(previous_plan)
foreach::registerDoSEQ()
}, add = TRUE)
doFuture::registerDoFuture()
future::plan(future::multisession, workers = workers)
doRNG::registerDoRNG(seed)
arguments$parallel <- TRUE
do.call(glmnet::cv.glmnet, arguments)
}
#' @rdname build_lib
#' @export
train_spec_model <- function(x, class_col = "material_class",
type_col = "spectrum_type", min_n = 10,
alpha = 0.1, seed = 123,
grouped = TRUE, weights = TRUE,
make_relative = TRUE,
method = c("logistic_regression", "random_forest"),
...) {
method <- match.arg(method)
x <- as_OpenSpecy(x)
.lib_require_cols(x$metadata, class_col, "metadata")
supported <- .lib_filter_spectral_support(x, min_fraction = 0.1)
x <- supported$object
support <- supported$audit
wavenumbers <- x$wavenumber
spectra <- x$spectra
if (make_relative) spectra <- make_rel(spectra, na.rm = TRUE)
metadata <- data.table::copy(x$metadata)
labels <- as.character(metadata[[class_col]])
if (!is.null(type_col) && type_col %in% names(metadata)) {
types <- as.character(metadata[[type_col]])
labels <- ifelse(is.na(types), labels, paste(types, labels, sep = "_"))
}
keep <- !is.na(labels)
tab <- table(labels[keep])
class_support <- data.table::data.table(
class = names(tab), spectra = as.integer(tab),
minimum_spectra = rep.int(as.integer(min_n), length(tab)),
retained = as.integer(tab) >= min_n
)
keep <- keep & labels %in% names(tab)[tab >= min_n]
spectra <- spectra[, keep, drop = FALSE]
labels <- labels[keep]
metadata <- metadata[keep, ]
if (ncol(spectra) == 0 || length(unique(labels)) < 2) {
stop("At least two classes with 'min_n' spectra are required to train a model",
call. = FALSE)
}
grouping_object <- x
grouping_object$spectra <- spectra
grouping_object$metadata <- metadata
group_ids <- .lib_stable_group_info(grouping_object)$group_id
filled <- .lib_wavenumber_mean_replace(spectra)
spectra <- filled$spectra
train <- t(spectra)
colnames(train) <- as.character(wavenumbers)
outcome <- as.integer(factor(labels))
weight_vec <- NULL
if (weights) weight_vec <- 1 / (table(outcome)[as.character(outcome)] / length(outcome))
dimension_conversion <- unique(data.table::data.table(
factor_num = outcome,
name = labels
))
fill_values <- filled$means
fill <- as_OpenSpecy(
wavenumbers,
spectra = matrix(
fill_values, ncol = 1L,
dimnames = list(NULL, "model_training_mean")
),
metadata = data.table::data.table(sample_name = "model_training_mean")
)
if (identical(method, "random_forest")) {
return(.lib_build_random_forest(
train = train, outcome = outcome, labels = labels, metadata = metadata,
type_col = type_col, weights = weights, seed = seed,
dimension_conversion = dimension_conversion, fill = fill,
support = support, class_support = class_support,
fill_replaced = filled$replaced, ...
))
}
set.seed(seed)
glmnet_args <- list(
x = train,
y = outcome,
alpha = alpha,
family = "multinomial",
intercept = FALSE,
type.multinomial = if (grouped) "grouped" else "ungrouped",
maxit = 1000000L
)
if (!is.null(weight_vec)) glmnet_args$weights <- as.numeric(weight_vec)
user_args <- list(...)
glmnet_args[names(user_args)] <- user_args
group_labels <- unique(data.table::data.table(
group_id = group_ids, outcome = outcome
))
mixed_groups <- group_labels[, data.table::uniqueN(outcome), by = group_id][
V1 > 1L, group_id
]
if (length(mixed_groups)) {
stop("Stable spectral groups span multiple model classes", call. = FALSE)
}
class_groups <- split(group_labels$group_id, group_labels$outcome)
nfolds <- min(5L, min(lengths(class_groups)))
if (nfolds >= 3L) {
group_fold <- character()
fold_value <- integer()
for (groups in class_groups) {
assignments <- sample(rep(seq_len(nfolds), length.out = length(groups)))
group_fold <- c(group_fold, groups)
fold_value <- c(fold_value, assignments)
}
foldid <- fold_value[match(group_ids, group_fold)]
cv_args <- glmnet_args
cv_args$foldid <- foldid
cv_args$nfolds <- nfolds
cv_args$type.measure <- "class"
cv_args$keep <- TRUE
fit <- .lib_cv_glmnet(
cv_args, workers = .lib_build_workers(), folds = nfolds, seed = seed
)
model <- fit$glmnet.fit
lambda_metrics <- .lib_macro_lambda_metrics(
fit$fit.preval, outcome = outcome, lambda = fit$lambda
)
selected_index <- which(lambda_metrics$selected)[[1L]]
lambda <- lambda_metrics$lambda[selected_index]
} else {
model <- do.call(glmnet::glmnet, glmnet_args)
lambda <- min(model$lambda)
selected_index <- length(model$lambda)
lambda_metrics <- data.table::data.table(
lambda = as.numeric(lambda), macro_class_accuracy = NA_real_,
overall_accuracy = NA_real_, selected = TRUE,
selection_scope = "minimum_lambda_insufficient_folds",
selection_rule = "minimum_lambda_without_three_folds"
)
}
convergence_error <- if (is.null(model$jerr)) 0L else as.integer(model$jerr)
selected_lambda_converged <- convergence_error == 0L ||
selected_index < length(model$lambda)
# Calls produced through do.call() can capture the complete training matrix
# and outcome. They are not used by coef() or predict(), and retaining them
# needlessly adds many megabytes to checkpoints and release artifacts.
model$call <- NULL
coefficients <- stats::coef(model, s = lambda)
coef_list <- if (is.list(coefficients)) coefficients else list(coefficients)
rows <- lapply(seq_along(coef_list), function(item) {
data.table::data.table(
dimensions_used = coef_list[[item]]@i,
dimension_units = coef_list[[item]]@x,
variable = item
)
})
coefficient_values <- data.table::rbindlist(rows)
wave <- data.table::data.table(
names = coef_list[[1]]@Dimnames[[1]],
id = seq_along(coef_list[[1]]@Dimnames[[1]]) - 1L
)
coefficients_join <- merge(coefficient_values, dimension_conversion,
by.x = "variable", by.y = "factor_num",
all.x = TRUE)
coefficients_join <- merge(coefficients_join, wave,
by.x = "dimensions_used", by.y = "id",
all.x = FALSE)
coefficients_join$names <- suppressWarnings(as.numeric(ifelse(
coefficients_join$names == "(Intercept)", "0", coefficients_join$names
)))
predictions <- predict(model, newx = train, s = lambda, type = "response")
pred <- .ai_prediction_table(predictions, n = nrow(train))
actual <- data.table::data.table(row_id = seq_along(outcome),
actual_label = outcome,
actual_name = labels)
tests <- merge(pred, actual, by.x = "x", by.y = "row_id", all.x = TRUE)
tests <- merge(tests, dimension_conversion, by.x = "y",
by.y = "factor_num", all.x = TRUE)
names(tests)[names(tests) == "name"] <- "predicted_class"
ids <- if ("sample_name" %in% names(metadata)) {
as.character(metadata$sample_name)
} else {
rownames(train)
}
if (is.null(ids)) ids <- paste0("spectrum_", seq_len(nrow(train)))
technique <- if (!is.null(type_col) && type_col %in% names(metadata)) {
as.character(metadata[[type_col]])
} else {
NA_character_
}
tests[, `:=`(
spectrum_id = ids[x],
technique = technique[x],
expected_class = actual_name,
correct = actual_name == predicted_class,
score = value,
split = "training",
provenance = "model_fit"
)]
tests <- tests[, .(
spectrum_id, technique, expected_class, predicted_class, correct, score,
split, provenance
)]
list(
model = model,
model_type = "logistic_regression",
lambda_selected = lambda,
lambda_path_complete = convergence_error == 0L,
selected_lambda_converged = selected_lambda_converged,
convergence_error = convergence_error,
training_groups = data.table::uniqueN(group_ids),
selection_metric = "macro_class_accuracy",
lambda_metrics = lambda_metrics,
dimension_conversion = dimension_conversion,
tests = tests,
coefficients = coefficients_join,
class_names = unique(labels),
class_num = length(unique(outcome)),
observation_count = length(labels),
fill = fill,
support = support,
class_support = class_support,
fill_method = "wavenumber_mean",
fill_replaced = as.integer(filled$replaced),
variable_num = nrow(coefficients_join),
all_variables = as.numeric(colnames(train)),
variables_in = coefficients_join$names
)
}
.lib_build_random_forest <- function(train, outcome, labels, metadata,
type_col, weights, seed,
dimension_conversion, fill, support,
class_support, fill_replaced, ...) {
if (!requireNamespace("ranger", quietly = TRUE)) {
stop(
"Training a random-forest model requires the suggested 'ranger' package",
call. = FALSE
)
}
p <- ncol(train)
outcome_factor <- factor(outcome, levels = sort(unique(outcome)))
class_counts <- table(outcome_factor)
class_weights <- length(outcome) /
(length(class_counts) * as.numeric(class_counts))
names(class_weights) <- names(class_counts)
class_weight_table <- merge(
data.table::data.table(
factor_num = as.integer(names(class_counts)),
spectra = as.integer(class_counts),
weight = if (isTRUE(weights)) as.numeric(class_weights) else 1,
application = if (isTRUE(weights)) "case_sampling" else "none"
),
dimension_conversion,
by = "factor_num", all.x = TRUE, sort = FALSE
)
ranger_args <- list(
x = train,
y = outcome_factor,
probability = TRUE,
num.trees = 500L,
mtry = max(1L, min(p, max(floor(sqrt(p)), floor(p / 20)))),
min.node.size = 10L,
importance = "permutation",
write.forest = TRUE,
oob.error = TRUE,
# Package and CI runs remain single-threaded by default. Official builders
# can opt into the host's cores without expanding the public API.
num.threads = .lib_build_workers(),
seed = as.integer(seed),
verbose = FALSE
)
if (isTRUE(weights)) {
ranger_args$case.weights <- as.numeric(
class_weights[as.character(outcome_factor)]
)
}
user_args <- list(...)
protected <- intersect(
names(user_args), c("x", "y", "probability", "write.forest", "oob.error")
)
if (length(protected)) {
stop(
"Random-forest arguments managed by train_spec_model() cannot be ",
"overridden: ", paste(protected, collapse = ", "), call. = FALSE
)
}
ranger_args[names(user_args)] <- user_args
set.seed(seed)
model <- do.call(ranger::ranger, ranger_args)
predictions <- model$predictions
pred <- .ai_prediction_table(predictions, n = nrow(train))
actual <- data.table::data.table(
row_id = seq_along(outcome),
actual_label = outcome,
actual_name = labels
)
tests <- merge(pred, actual, by.x = "x", by.y = "row_id", all.x = TRUE)
tests <- merge(
tests, dimension_conversion, by.x = "y", by.y = "factor_num",
all.x = TRUE
)
names(tests)[names(tests) == "name"] <- "predicted_class"
ids <- if ("sample_name" %in% names(metadata)) {
as.character(metadata$sample_name)
} else {
rownames(train)
}
if (is.null(ids)) ids <- paste0("spectrum_", seq_len(nrow(train)))
technique <- if (!is.null(type_col) && type_col %in% names(metadata)) {
as.character(metadata[[type_col]])
} else {
NA_character_
}
tests[, `:=`(
spectrum_id = ids[x],
technique = technique[x],
expected_class = actual_name,
correct = actual_name == predicted_class,
score = value,
split = "oob",
provenance = "model_oob"
)]
tests <- tests[, .(
spectrum_id, technique, expected_class, predicted_class, correct, score,
split, provenance
)]
class_accuracy <- tests[, .(
spectra = .N,
accuracy = mean(correct, na.rm = TRUE),
mean_score = mean(score, na.rm = TRUE)
), by = expected_class]
valid_accuracy <- class_accuracy$accuracy[is.finite(class_accuracy$accuracy)]
oob_metrics <- data.table::data.table(
spectra = nrow(tests),
classes = nrow(class_accuracy),
accuracy = mean(tests$correct, na.rm = TRUE),
macro_class_accuracy = if (length(valid_accuracy)) {
mean(valid_accuracy)
} else {
NA_real_
},
mean_score = mean(tests$score, na.rm = TRUE),
brier_score = as.numeric(model$prediction.error)
)
feature_importance <- data.table::data.table(
wavenumber = suppressWarnings(as.numeric(names(model$variable.importance))),
importance = as.numeric(model$variable.importance)
)
parameters <- data.table::data.table(
num_trees = as.integer(model$num.trees),
mtry = as.integer(model$mtry),
min_node_size = as.integer(ranger_args$min.node.size),
num_threads = as.integer(ranger_args$num.threads),
case_weighted = isTRUE(weights),
class_weighted = FALSE,
balance_method = if (isTRUE(weights)) {
if ("case.weights" %in% names(user_args)) {
"user_case_sampling"
} else {
"inverse_frequency_case_sampling"
}
} else {
"none"
},
importance = as.character(ranger_args$importance)
)
list(
model = model,
model_type = "random_forest",
lambda_selected = NA_real_,
selection_metric = "oob_macro_class_accuracy",
lambda_metrics = data.table::data.table(
lambda = numeric(), macro_class_accuracy = numeric(),
overall_accuracy = numeric(), selected = logical(),
selection_scope = character(), selection_rule = character()
),
dimension_conversion = dimension_conversion,
tests = tests,
coefficients = data.table::data.table(),
feature_importance = feature_importance,
oob_metrics = oob_metrics,
oob_class_accuracy = class_accuracy,
training_parameters = parameters,
class_weights = class_weight_table,
class_names = unique(labels),
class_num = length(unique(outcome)),
observation_count = length(labels),
fill = fill,
support = support,
class_support = class_support,
fill_method = "wavenumber_mean",
fill_replaced = as.integer(fill_replaced),
variable_num = p,
all_variables = as.numeric(colnames(train)),
variables_in = as.numeric(colnames(train))
)
}
.lib_spectrum_mean_replace <- function(spectra) {
spectra[!is.finite(spectra)] <- NA_real_
out <- mean_replace(spectra, na.rm = TRUE)
if (any(!is.finite(out))) {
stop("Spectrum-wise mean replacement left non-finite values", call. = FALSE)
}
out
}
.lib_wavenumber_mean_replace <- function(spectra) {
spectra[!is.finite(spectra)] <- NA_real_
means <- rowMeans(spectra, na.rm = TRUE)
missing_means <- which(!is.finite(means))
if (length(missing_means)) {
stop(
"Cannot fit a model because ", length(missing_means),
" wavenumber(s) have no finite training values",
call. = FALSE
)
}
missing <- is.na(spectra)
if (any(missing)) {
index <- which(missing, arr.ind = TRUE)
spectra[index] <- means[index[, "row"]]
}
list(spectra = spectra, means = means, replaced = sum(missing))
}
.lib_macro_lambda_metrics <- function(predictions, outcome, lambda) {
dimensions <- dim(predictions)
if (length(dimensions) != 3L || dimensions[1L] != length(outcome) ||
dimensions[3L] != length(lambda)) {
stop("Unexpected multinomial cross-validation prediction shape",
call. = FALSE)
}
predicted <- apply(predictions, c(1L, 3L), which.max)
if (is.null(dim(predicted))) {
predicted <- matrix(predicted, nrow = length(outcome))
}
macro <- vapply(seq_along(lambda), function(i) {
class_accuracy <- vapply(split(seq_along(outcome), outcome), function(rows) {
mean(predicted[rows, i] == outcome[rows], na.rm = TRUE)
}, numeric(1))
mean(class_accuracy, na.rm = TRUE)
}, numeric(1))
overall <- vapply(seq_along(lambda), function(i) {
mean(predicted[, i] == outcome, na.rm = TRUE)
}, numeric(1))
best <- which.max(macro)
data.table::data.table(
lambda = as.numeric(lambda), macro_class_accuracy = macro,
overall_accuracy = overall, selected = seq_along(lambda) == best,
selection_scope = "out_of_fold",
selection_rule = "max_macro_accuracy_then_largest_lambda"
)
}
.lib_support_schema <- function() {
data.table::data.table(
spectrum_id = character(), observed = integer(), available = integer(),
observed_fraction = numeric(), minimum_observed = integer(),
retained = logical()
)
}
.lib_filter_spectral_support <- function(x, min_fraction = 0.1,
id_col = "sample_name") {
x <- as_OpenSpecy(x)
if (!is.numeric(min_fraction) || length(min_fraction) != 1L ||
is.na(min_fraction) || min_fraction <= 0 || min_fraction > 1) {
stop("'min_fraction' must be in (0, 1]", call. = FALSE)
}
finite <- is.finite(x$spectra)
observed <- colSums(finite)
available <- nrow(finite)
minimum <- as.integer(ceiling(min_fraction * available))
retained <- observed >= minimum
audit <- data.table::data.table(
spectrum_id = as.character(.lib_ids(x, id_col)),
observed = as.integer(observed), available = as.integer(available),
observed_fraction = as.numeric(observed / available),
minimum_observed = rep.int(minimum, length(observed)),
retained = retained
)
rm(finite)
if (!any(retained)) {
stop(
"No spectra meet the minimum observed support of ",
format(min_fraction * 100, trim = TRUE), "% (", minimum, " of ",
available, " wavenumbers)", call. = FALSE
)
}
out <- if (all(retained)) x else filter_spec(x, retained)
attr(out, "identification_support") <- audit
attr(out, "identification_dropped_ids") <- audit[!retained, spectrum_id]
attr(out, "identification_minimum_observed") <- minimum
attr(out, "identification_finite_coverage") <- mean(observed / available)
list(object = out, audit = audit)
}
#' @rdname build_lib
#' @export
assess_lib <- function(x, class_col = NULL, id_col = "sample_name",
nearest = !is.null(class_col)) {
x <- as_OpenSpecy(x)
valid <- suppressWarnings(check_OpenSpecy(x))
out <- data.table::data.table(
metric = c("valid_OpenSpecy", "spectra", "wavenumbers"),
value = c(as.character(valid), ncol(x$spectra), length(x$wavenumber))
)
if (!is.null(class_col) && class_col %in% names(x$metadata)) {
counts <- data.table::data.table(class = x$metadata[[class_col]])[
, .N, by = "class"]
out <- rbind(out, data.table::data.table(
metric = c("classes", "smallest_class"),
value = c(length(unique(counts$class)), min(counts$N))
), fill = TRUE)
}
if (nearest && ncol(x$spectra) > 1 && class_col %in% names(x$metadata)) {
cors <- cor_spec(x, x)
diag(cors) <- NA
top <- max_cor_named(cors)
ids <- .lib_ids(x, id_col)
matched <- x$metadata[[class_col]][match(names(top), ids)]
accuracy <- mean(matched == x$metadata[[class_col]], na.rm = TRUE)
out <- rbind(out, data.table::data.table(
metric = "nearest_class_accuracy",
value = accuracy
), fill = TRUE)
}
out
}
.default_lib_recipes <- function() {
list(
raw = list(),
derivative = list(
conform_spec = FALSE,
smooth_intens = TRUE,
smooth_intens_args = list(
polynomial = 3,
window = 15,
derivative = 1,
abs = TRUE
),
subtr_baseline = FALSE,
make_rel = TRUE
),
nobaseline = list(
conform_spec = FALSE,
smooth_intens = FALSE,
subtr_baseline = TRUE,
make_rel = TRUE
)
)
}
.lib_reference_sources <- function(source_file, processed_dir,
progress = TRUE) {
processed <- character()
if (!is.null(processed_dir) && dir.exists(processed_dir)) {
processed <- list.files(
processed_dir, pattern = "[.]rds$", recursive = TRUE,
full.names = TRUE, ignore.case = TRUE
)
processed <- processed[grepl(
"[/\\\\]Processed[/\\\\]", processed, ignore.case = TRUE
)]
}
source <- if (!is.null(source_file) && file.exists(source_file)) {
source_file
} else {
character()
}
files <- unique(c(processed, source))
if (length(files) == 0L) {
stop(
"No official reference-library sources were found. Set ",
"OPENSPECY_SOURCE_FILE and/or OPENSPECY_PROCESSED_DIR, or supply 'x'",
call. = FALSE
)
}
if (isTRUE(progress)) {
message(sprintf(
"build_lib: discovered %d processed source(s) plus %d raw source(s)",
length(processed), length(source)
))
}
files
}
.lib_build_reference <- function(x, recipes, range, res, id_col, exclude_ids,
dedupe, metadata_lookups,
material_hierarchy, metadata_name_lookup,
clean_metadata_values, convert_intensity,
restrict_range_args, signal_noise, assess,
prune, progress, workflow_data, output_dir,
previous_library_dir, reuse, remove_other,
seed, holdout,
...) {
if (!is.character(output_dir) || length(output_dir) != 1L ||
is.na(output_dir) || !nzchar(output_dir)) {
stop("'output_dir' must be one nonempty path in end-to-end mode",
call. = FALSE)
}
if (!is.numeric(seed) || length(seed) != 1L || is.na(seed)) {
stop("'seed' must be one finite number", call. = FALSE)
}
if (!is.numeric(holdout) || length(holdout) != 1L || is.na(holdout) ||
holdout <= 0 || holdout >= 1) {
stop("'holdout' must be between zero and one", call. = FALSE)
}
started <- proc.time()[["elapsed"]]
report <- function(stage) {
if (isTRUE(progress)) {
message(sprintf(
"build_lib [%.1fs]: %s",
proc.time()[["elapsed"]] - started, stage
))
}
}
report("resolving official lookup and exclusion tables")
tables <- .lib_reference_tables(workflow_data)
.lib_validate_reference_tables(tables)
classes_exact <- tables$classes_reference[
!is.na(material) & nzchar(material), .(spectrum_identity, material)
]
type_lookup <- data.table::copy(tables$library_types)
if ("spectrum_type" %in% names(type_lookup)) {
type_lookup[grepl(";", spectrum_type, fixed = TRUE),
spectrum_type := NA_character_]
}
if (is.null(metadata_lookups)) {
metadata_lookups <- list(
list(lookup = classes_exact, by = "spectrum_identity"),
list(lookup = type_lookup, by = "organization", fill_only = TRUE)
)
}
if (is.null(material_hierarchy)) {
material_hierarchy <- tables$material_hierarchy
}
if (is.null(exclude_ids)) exclude_ids <- tables$known_bad_ids$sample_name
signature <- .lib_build_signature(
x,
workflow_paths = unlist(tables$paths, use.names = FALSE),
arguments = list(
recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
remove_other = remove_other, seed = seed, holdout = holdout
)
)
# Keep completed libraries, medoids, and production models reusable when
# only assessment, reporting, or export code changes. Bump this version
# whenever those scientific artifacts intentionally change.
artifact_signature <- .lib_component_signature(
x,
workflow_paths = unlist(tables$paths, use.names = FALSE),
arguments = list(
recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
remove_other = remove_other
),
component_version = "reference-artifacts-v12-correlation-closure-quarantine"
)
# Keep expensive spectral preprocessing reusable when only downstream class,
# pruning, assessment, or export code changes. Bump component_version only
# when a core transformation intentionally changes its scientific output.
core_signature <- .lib_component_signature(
x,
workflow_paths = unlist(
tables$paths[c(
"classes_reference", "library_types", "material_hierarchy",
"known_bad_ids"
)],
use.names = FALSE
),
arguments = list(
recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess
),
component_version = "core-libraries-v2-library-name"
)
checkpoints <- .lib_checkpoint_manager(
output_dir, signature = artifact_signature, reuse = reuse, report = report
)
libraries <- checkpoints$get("libraries")
local_assessments <- checkpoints$get("library_assessments")
quarantine <- checkpoints$get("quarantined_spectra")
if (is.null(libraries)) {
core_path <- file.path(output_dir, "checkpoints", "core_libraries.rds")
core <- checkpoints$get("core_libraries", key = core_signature)
if (is.null(core)) {
report("building raw, derivative, and nobaseline libraries")
core <- .lib_build_core(
x = x, recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = NULL,
progress = progress, ...
)
checkpoints$put("core_libraries", core, key = core_signature)
for (name in names(core)) {
checkpoints$put(
paste0("core_library_", name), core[[name]], key = core_signature
)
}
}
rm(core)
gc(verbose = FALSE)
completed <- .lib_complete_reference_build(
readRDS(core_path), tables = tables, prune = prune,
remove_other = remove_other,
progress = progress,
report = report
)
libraries <- completed$libraries
local_assessments <- completed$assessments
quarantine <- completed$quarantine
quarantine$manifest$build_signature <- artifact_signature
quarantine$manifest$source_hashes <- artifact_signature
.lib_write_quarantine_review(quarantine, output_dir)
checkpoints$put("libraries", libraries)
checkpoints$put("library_assessments", local_assessments)
checkpoints$put("quarantined_spectra", quarantine)
for (name in names(libraries)) {
checkpoints$put(paste0("library_", name), libraries[[name]])
}
} else if (is.null(local_assessments)) {
report("reconstructing completed-library assessments from attributes")
local_assessments <- .lib_recover_library_assessments(libraries, tables)
checkpoints$put("library_assessments", local_assessments)
}
if (is.null(quarantine)) {
quarantine <- .lib_quarantine_bundle(build_signature = artifact_signature)
.lib_write_quarantine_review(quarantine, output_dir)
checkpoints$put("quarantined_spectra", quarantine)
}
medoids <- checkpoints$get("medoids")
if (is.null(medoids)) {
medoids <- .lib_build_medoids(
libraries, report = report, checkpoints = checkpoints,
progress = progress
)
checkpoints$put("medoids", medoids)
}
correlation_closure <- .lib_validate_medoid_parent_closure(
libraries, medoids, prune_spec = prune, report = report
)
local_assessments$correlation_closure <- correlation_closure
report("finalizing library metadata by missing-value count")
finalized <- .lib_finalize_reference_metadata(libraries, medoids)
libraries <- finalized$libraries
medoids <- finalized$medoids
local_assessments$metadata_finalization <- finalized$assessment
models <- checkpoints$get("models_logistic_regression_parallel_rng_v2")
model_warnings <- .lib_warning_schema()
if (is.null(models)) {
model_result <- .lib_build_models(
libraries, medoids, report = report, checkpoints = checkpoints
)
models <- model_result$models
model_warnings <- model_result$warnings
checkpoints$put("models_logistic_regression_parallel_rng_v2", models)
}
build <- list(
libraries = libraries,
medoids = medoids,
models = models,
assessments = .lib_local_build_assessments(
libraries, medoids, models, local_assessments, model_warnings
)
)
prior_signature <- .lib_previous_signature(previous_library_dir)
assessment_key <- digest::digest(
list(
artifact_signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "typed-legacy-bundles-v18-accuracy-comparison"
),
algo = "sha256"
)
fallback_assessment_key <- digest::digest(
list(
artifact_signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "selected-lambda-logistic-v14"
),
algo = "sha256"
)
cached_assessments <- checkpoints$get(
"assessment_components_parallel_rng_v1", key = assessment_key
)
if (!is.null(cached_assessments)) {
build$assessments <- cached_assessments
validated_models <- checkpoints$get(
"validated_models_parallel_rng_v1", key = assessment_key
)
if (!is.null(validated_models)) build$models <- validated_models
} else if (!is.null(previous_library_dir)) {
report("assessing complete candidate and legacy artifacts")
comparison <- .lib_compare_reference_build(
build, previous_library_dir = previous_library_dir,
seed = seed, holdout = holdout, progress = progress,
checkpoints = checkpoints, checkpoint_key = assessment_key,
checkpoint_fallback_key = fallback_assessment_key
)
if (!is.null(comparison$models)) {
build$models <- comparison$models
checkpoints$put(
"validated_models_parallel_rng_v1", build$models, key = assessment_key
)
comparison$models <- NULL
}
build$assessments[names(comparison)] <- comparison
}
build$assessments$output_manifest <- checkpoints$manifest()
assessment_components <- build$assessments
checkpoints$put(
"assessment_components_parallel_rng_v1", assessment_components,
key = assessment_key
)
build$assessments <- .lib_assessment_review(assessment_components)
.lib_validate_reference_build(build)
checkpoints$put("assessments", build$assessments, key = assessment_key)
checkpoints$put("reference_library_build", build, key = assessment_key)
release_signature <- .lib_release_signature(assessment_key)
report("promoting validated artifacts to a versioned release directory")
promotion <- .lib_promote_reference_build(
build, quarantine = quarantine, output_dir = output_dir,
signature = release_signature, reuse = reuse, progress = report
)
build <- .lib_finalize_reference_release(
build, assessment_components, promotion, release_signature, report
)
report("complete")
build
}
.lib_rebuild_artifacts <- function(x, output_dir, previous_library_dir,
reuse, seed, holdout, progress) {
if (missing(x)) {
stop("'x' must specify a completed build or checkpoint", call. = FALSE)
}
if (!is.character(output_dir) || length(output_dir) != 1L ||
is.na(output_dir) || !nzchar(output_dir)) {
stop("'output_dir' must be one nonempty path", call. = FALSE)
}
if (!is.logical(reuse) || length(reuse) != 1L || is.na(reuse)) {
stop("'reuse' must be TRUE or FALSE", call. = FALSE)
}
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
if (!is.numeric(seed) || length(seed) != 1L || !is.finite(seed)) {
stop("'seed' must be one finite number", call. = FALSE)
}
if (!is.numeric(holdout) || length(holdout) != 1L || is.na(holdout) ||
holdout <= 0 || holdout >= 1) {
stop("'holdout' must be between zero and one", call. = FALSE)
}
started <- proc.time()[["elapsed"]]
report <- function(stage) {
if (isTRUE(progress)) message(sprintf(
"rebuild_lib_artifacts [%.1fs]: %s",
proc.time()[["elapsed"]] - started, stage
))
}
report("resolving completed libraries and upstream assessments")
input <- .lib_resolve_rebuild_input(x)
libraries <- .lib_drop_typed_range_flats(input$libraries, report = report)
completed <- input$assessments
quarantine <- input$quarantine
signature <- digest::digest(list(
input = input$signature,
downstream_version = "full-library-random-forest-model-v5-range-flat-filter"
), algo = "sha256")
checkpoints <- .lib_checkpoint_manager(
output_dir, signature = signature, reuse = reuse, report = report
)
medoids <- checkpoints$get("medoids")
if (is.null(medoids) && !is.null(input$medoids)) {
report("reusing compatible medoids supplied by the completed build")
medoids <- input$medoids
checkpoints$put("medoids", medoids)
}
if (is.null(medoids)) {
medoids <- .lib_build_medoids(
libraries, report = report, checkpoints = checkpoints,
progress = progress
)
checkpoints$put("medoids", medoids)
}
report("finalizing library metadata by missing-value count")
finalized <- .lib_finalize_reference_metadata(libraries, medoids)
libraries <- finalized$libraries
medoids <- finalized$medoids
if (is.null(completed)) completed <- list()
completed$metadata_finalization <- finalized$assessment
models <- checkpoints$get("models_logistic_regression_parallel_rng_v2")
model_warnings <- .lib_warning_schema()
if (is.null(models)) {
supplied_models <- input$models
if (!is.null(supplied_models$logistic_regression)) {
for (recipe in names(supplied_models$logistic_regression)) {
for (type in names(supplied_models$logistic_regression[[recipe]])) {
stage <- paste(
"model", "logistic_regression", recipe, type, sep = "_"
)
stage <- paste0(stage, "_parallel_rng_v1")
if (is.null(checkpoints$get(stage))) {
model <- supplied_models$logistic_regression[[recipe]][[type]]
if (is.null(model$model_type)) model$model_type <- "logistic_regression"
checkpoints$put(stage, model)
}
}
}
report("reusing compatible logistic models supplied by the completed build")
}
result <- .lib_build_models(
libraries, medoids, report = report, checkpoints = checkpoints
)
models <- result$models
model_warnings <- result$warnings
checkpoints$put("models_logistic_regression_parallel_rng_v2", models)
}
build <- list(
libraries = libraries, medoids = medoids, models = models,
assessments = .lib_local_build_assessments(
libraries, medoids, models, completed, model_warnings
)
)
prior_signature <- .lib_previous_signature(previous_library_dir)
assessment_key <- digest::digest(list(
signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "typed-legacy-bundles-v18-accuracy-comparison"
), algo = "sha256")
fallback_assessment_key <- digest::digest(list(
signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "selected-lambda-logistic-v14"
), algo = "sha256")
cached <- checkpoints$get(
"assessment_components_parallel_rng_v1", key = assessment_key
)
if (!is.null(cached)) {
build$assessments <- cached
validated <- checkpoints$get(
"validated_models_parallel_rng_v1", key = assessment_key
)
if (!is.null(validated)) build$models <- validated
} else if (!is.null(previous_library_dir)) {
report("assessing candidate and legacy artifacts on source-local cohorts")
comparison <- .lib_compare_reference_build(
build, previous_library_dir = previous_library_dir,
seed = seed, holdout = holdout, progress = progress,
checkpoints = checkpoints, checkpoint_key = assessment_key,
checkpoint_fallback_key = fallback_assessment_key
)
if (!is.null(comparison$models)) {
build$models <- comparison$models
checkpoints$put(
"validated_models_parallel_rng_v1", build$models, key = assessment_key
)
comparison$models <- NULL
}
build$assessments[names(comparison)] <- comparison
}
build$assessments$output_manifest <- checkpoints$manifest()
assessment_components <- build$assessments
checkpoints$put(
"assessment_components_parallel_rng_v1", assessment_components,
key = assessment_key
)
build$assessments <- .lib_assessment_review(assessment_components)
.lib_validate_reference_build(build)
checkpoints$put("assessments", build$assessments, key = assessment_key)
checkpoints$put("reference_library_build", build, key = assessment_key)
release_signature <- .lib_release_signature(assessment_key)
report("promoting downstream artifacts to a versioned release directory")
promotion <- .lib_promote_reference_build(
build, quarantine = quarantine, output_dir = output_dir,
signature = release_signature, reuse = reuse, progress = report
)
build <- .lib_finalize_reference_release(
build, assessment_components, promotion, release_signature, report
)
report("complete")
build
}
.lib_resolve_rebuild_input <- function(x) {
source_path <- NULL
source_signature <- NULL
sibling_assessments <- NULL
if (is.character(x)) {
if (length(x) != 1L || is.na(x) || !nzchar(x)) {
stop("'x' must be one completed-build or checkpoint path", call. = FALSE)
}
if (dir.exists(x)) {
candidates <- c(
file.path(x, "checkpoints", "libraries.rds"),
file.path(x, "libraries.rds"),
file.path(x, "reference_library_build.rds"),
file.path(x, "checkpoints", "reference_library_build.rds")
)
releases <- list.files(
file.path(x, "releases"), pattern = "reference_library_build[.]rds$",
recursive = TRUE, full.names = TRUE
)
candidates <- c(candidates, releases)
candidates <- candidates[file.exists(candidates)]
if (!length(candidates)) {
stop("No completed libraries checkpoint was found under 'x'",
call. = FALSE)
}
source_path <- candidates[[1L]]
} else if (file.exists(x)) {
source_path <- x
} else {
stop("'x' does not exist: ", x, call. = FALSE)
}
manifest_path <- sub("[.]rds$", ".manifest.rds", source_path)
manifest <- if (file.exists(manifest_path)) {
tryCatch(readRDS(manifest_path), error = function(error) NULL)
} else NULL
source_signature <- if (is.list(manifest) &&
!is.null(manifest$signature)) {
manifest$signature
} else {
digest::digest(.lib_file_signatures(source_path), algo = "sha256")
}
if (identical(basename(source_path), "libraries.rds")) {
sibling <- file.path(dirname(source_path), "library_assessments.rds")
if (file.exists(sibling)) sibling_assessments <- readRDS(sibling)
}
x <- readRDS(source_path)
if (.lib_is_release_index(x)) {
source_signature <- x$build_signature
x <- .lib_load_release_index(x, dirname(source_path))
}
}
if (!is.list(x)) {
stop("'x' must resolve to a completed build or nested libraries list",
call. = FALSE)
}
medoids <- NULL
models <- NULL
quarantine <- NULL
if (!is.null(x$libraries)) {
libraries <- x$libraries
assessments <- .lib_upstream_assessments(x$assessments)
medoids <- x$medoids
models <- x$models
quarantine <- x$quarantine
if (!is.null(models) &&
!any(c("logistic_regression", "random_forest") %in% names(models))) {
models <- list(logistic_regression = models)
}
if (is.null(source_signature)) {
source_signature <- attr(x, "build_signature", exact = TRUE)
}
} else {
libraries <- x
assessments <- .lib_upstream_assessments(sibling_assessments)
}
required <- c("derivative", "nobaseline")
if (!all(required %in% names(libraries))) {
stop("Completed libraries must contain derivative and nobaseline recipes",
call. = FALSE)
}
valid_recipe <- vapply(libraries[required], function(recipe) {
is.list(recipe) && length(recipe) > 0L &&
all(vapply(recipe, is_OpenSpecy, logical(1)))
}, logical(1))
if (!all(valid_recipe)) {
stop("Derivative and nobaseline libraries must be spectrum-type lists of OpenSpecy objects",
call. = FALSE)
}
if (is.null(source_signature) || !length(source_signature) ||
is.na(source_signature[[1L]])) {
source_signature <- digest::digest(libraries, algo = "sha256")
}
list(
libraries = libraries, medoids = medoids, models = models,
assessments = assessments, quarantine = quarantine,
signature = as.character(source_signature[[1L]]), path = source_path
)
}
.lib_upstream_assessments <- function(assessments) {
if (is.null(assessments) || !is.list(assessments)) return(NULL)
nested <- attr(assessments, "upstream_assessments", exact = TRUE)
if (!is.null(nested)) return(nested)
keep <- c(
"lookup_coverage", "identity_cleanup", "class_prediction",
"class_coverage", "type_coverage", "material_form_enrichment",
"material_form_matches", "material_form_clashes",
"common_use_enrichment", "common_use_coverage",
"exclusions_deduplication",
"other_review", "other_filter", "filters", "metadata_drop",
"metadata_finalization", "pruning", "pruning_excluded_classes",
"pruning_reassignments", "pruning_removals", "pruning_conflicts",
"correlation_closure",
"quality_control", "automated_test_flags", "library_retention",
"dropped_spectrum_identities",
"model_assessment_correlations"
)
assessments[intersect(keep, names(assessments))]
}
.lib_find_workflow_data <- function(workflow_data = NULL,
script_dirs = NULL) {
if (!is.null(workflow_data)) return(workflow_data)
if (is.null(script_dirs)) {
script_paths <- unlist(lapply(sys.frames(), function(frame) {
path <- frame$ofile
if (is.null(path)) character() else as.character(path)
}), use.names = FALSE)
script_dirs <- dirname(normalizePath(
script_paths[file.exists(script_paths)], mustWork = FALSE
))
}
candidates <- unique(c(
file.path(rev(script_dirs), "data"),
file.path(getwd(), "data"),
file.path(getwd(), "workflows", "data")
))
required <- c(
"classes_reference.csv", "classes_regex.csv", "library_types.csv",
"material_hierarchy.csv", "known_bad_ids.csv",
"metadata_drop_columns.csv", "material_form_regex.csv",
"common_use_reference.csv"
)
complete <- vapply(candidates, function(path) {
dir.exists(path) && all(file.exists(file.path(path, required)))
}, logical(1))
if (!any(complete)) {
stop(
"Could not locate the reference helper tables. Put them in data/ ",
"beside the calling script or supply 'workflow_data'. Searched: ",
paste(candidates, collapse = ", "),
call. = FALSE
)
}
normalizePath(candidates[which(complete)[1L]], mustWork = TRUE)
}
.lib_reference_tables <- function(workflow_data) {
if (!is.character(workflow_data) || length(workflow_data) != 1L ||
is.na(workflow_data) || !nzchar(workflow_data)) {
stop("'workflow_data' must be one nonempty directory", call. = FALSE)
}
files <- c(
classes_reference = "classes_reference.csv",
classes_regex = "classes_regex.csv",
library_types = "library_types.csv",
material_hierarchy = "material_hierarchy.csv",
known_bad_ids = "known_bad_ids.csv",
metadata_drop = "metadata_drop_columns.csv",
material_form_regex = "material_form_regex.csv",
common_use_reference = "common_use_reference.csv"
)
paths <- stats::setNames(file.path(workflow_data, unname(files)), names(files))
missing <- !file.exists(paths)
if (any(missing)) {
stop("Missing workflow data file(s): ",
paste(paths[missing], collapse = ", "), call. = FALSE)
}
out <- lapply(paths, data.table::fread)
out$paths <- as.list(paths)
out
}
.lib_validate_reference_regex <- function(regex_reference) {
.lib_require_cols(regex_reference, c("pattern", "material"),
"classes_regex")
literal_only <- vapply(
regex_reference$pattern, .lib_regex_is_exact_literal, logical(1)
)
if (any(literal_only)) {
stop(
"Literal-only anchored class patterns belong in classes_reference.csv: ",
paste(regex_reference$pattern[literal_only], collapse = ", "),
call. = FALSE
)
}
invisible(TRUE)
}
.lib_validate_reference_tables <- function(tables) {
.lib_require_cols(
tables$classes_reference, c("spectrum_identity", "material"),
"classes_reference"
)
identity <- trimws(as.character(tables$classes_reference$spectrum_identity))
if (any(is.na(identity) | !nzchar(identity)) || anyDuplicated(identity)) {
stop("classes_reference keys must be nonblank and unique", call. = FALSE)
}
spreadsheet_date <- grepl(
"^([0-9]{1,2}-[A-Za-z]{3}|[A-Za-z]{3}-[0-9]{1,2})$", identity
)
if (any(spreadsheet_date)) {
stop(
"classes_reference contains spreadsheet-style date coercions: ",
paste(identity[spreadsheet_date], collapse = ", "), call. = FALSE
)
}
.lib_validate_reference_regex(tables$classes_regex)
.lib_require_cols(tables$known_bad_ids, "sample_name", "known_bad_ids")
known_bad <- trimws(as.character(tables$known_bad_ids$sample_name))
if (any(is.na(known_bad) | !nzchar(known_bad)) || anyDuplicated(known_bad) ||
any(!grepl("^[[:xdigit:]]{32}$", known_bad))) {
stop("known_bad_ids must contain unique exact 32-character hexadecimal IDs",
call. = FALSE)
}
.lib_require_cols(
tables$material_hierarchy,
c("material", "material_class", "material_type"), "material_hierarchy"
)
material <- trimws(as.character(tables$material_hierarchy$material))
if (any(is.na(material) | !nzchar(material)) || anyDuplicated(material)) {
stop("material_hierarchy material keys must be nonblank and unique",
call. = FALSE)
}
material_class <- trimws(as.character(
tables$material_hierarchy$material_class
))
material_type <- trimws(tolower(as.character(
tables$material_hierarchy$material_type
)))
paint_classes <- c("paint", "acrylic paint", "alkyd paint", "urethane paint")
if (any(tolower(material_class) %in% paint_classes)) {
stop("material_hierarchy material_class must describe chemistry, not paint form",
call. = FALSE)
}
invalid_plastic_class <- material_type == "plastic" &
!is.na(material_class) & nzchar(material_class) &
material_class != "other plastic" & !startsWith(tolower(material_class),
"poly")
if (any(invalid_plastic_class)) {
stop(
"Standard plastic material classes must start with 'poly': ",
paste(sort(unique(material_class[invalid_plastic_class])),
collapse = ", "), call. = FALSE
)
}
.lib_validate_material_form_regex(tables$material_form_regex)
.lib_validate_common_use_reference(
tables$common_use_reference, tables$material_hierarchy
)
invisible(TRUE)
}
.lib_validate_material_form_regex <- function(regex_reference) {
.lib_require_cols(
regex_reference, c("pattern", "material_form"), "material_form_regex"
)
pattern <- trimws(as.character(regex_reference$pattern))
material_form <- trimws(as.character(regex_reference$material_form))
if (any(is.na(pattern) | !nzchar(pattern)) || anyDuplicated(pattern)) {
stop("material_form_regex patterns must be nonblank and unique",
call. = FALSE)
}
allowed <- c(
"paint", "rubber", "hard plastic", "fiber", "pellet",
"film plastic", "fragment", "foam", "sphere/bead"
)
invalid_form <- is.na(material_form) | !material_form %in% allowed
if (any(invalid_form)) {
stop(
"material_form_regex has unsupported material_form values: ",
paste(unique(material_form[invalid_form]), collapse = ", "),
call. = FALSE
)
}
invalid_pattern <- vapply(pattern, function(value) {
inherits(try(grepl(value, "", perl = TRUE), silent = TRUE), "try-error")
}, logical(1L))
if (any(invalid_pattern)) {
stop("material_form_regex contains invalid regular expressions: ",
paste(pattern[invalid_pattern], collapse = ", "), call. = FALSE)
}
empty_match <- vapply(pattern, grepl, logical(1L), x = "", perl = TRUE)
if (any(empty_match)) {
stop("material_form_regex patterns may not match empty text: ",
paste(pattern[empty_match], collapse = ", "), call. = FALSE)
}
invisible(TRUE)
}
.lib_validate_common_use_reference <- function(reference, hierarchy) {
required <- c(
"material_class", "common_use", "consumer_mass_share",
"industrial_mass_share", "unclassified_mass_share", "basis_year",
"geography", "source_url", "retrieved_date", "evidence_notes"
)
.lib_require_cols(reference, required, "common_use_reference")
material_class <- trimws(as.character(reference$material_class))
if (any(is.na(material_class) | !nzchar(material_class)) ||
anyDuplicated(material_class)) {
stop("common_use_reference material_class keys must be nonblank and unique",
call. = FALSE)
}
hierarchy_classes <- sort(unique(trimws(
as.character(hierarchy$material_class)
)))
if (!setequal(material_class, hierarchy_classes)) {
stop(
"common_use_reference must contain every hierarchy class exactly once; ",
"missing: ", paste(setdiff(hierarchy_classes, material_class),
collapse = ", "),
"; stale: ", paste(setdiff(material_class, hierarchy_classes),
collapse = ", "),
call. = FALSE
)
}
common_use <- trimws(as.character(reference$common_use))
common_use[is.na(common_use) | !nzchar(common_use)] <- NA_character_
invalid_use <- !is.na(common_use) &
!common_use %in% c("consumer", "industrial", "mixed")
if (any(invalid_use)) {
stop("common_use_reference has unsupported common_use values: ",
paste(unique(common_use[invalid_use]), collapse = ", "),
call. = FALSE)
}
shares <- data.frame(
consumer = suppressWarnings(as.numeric(reference$consumer_mass_share)),
industrial = suppressWarnings(as.numeric(reference$industrial_mass_share)),
unclassified = suppressWarnings(as.numeric(
reference$unclassified_mass_share
))
)
invalid_share <- vapply(shares, function(value) {
any(!is.na(value) & (!is.finite(value) | value < 0 | value > 1))
}, logical(1L))
if (any(invalid_share)) {
stop("common_use_reference shares must be proportions in [0, 1]",
call. = FALSE)
}
share_sum <- rowSums(shares, na.rm = TRUE)
if (any(share_sum > 1 + 1e-8)) {
stop("common_use_reference shares may not sum above one", call. = FALSE)
}
labelled <- !is.na(common_use)
share_present <- rowSums(!is.na(shares)) > 0L
complete_share <- stats::complete.cases(shares)
if (any(share_present & !complete_share)) {
stop(
"common_use_reference shares must be either all missing or all present",
call. = FALSE
)
}
if (any(!labelled & share_present)) {
stop("common_use_reference shares require a common_use label",
call. = FALSE)
}
valid_label <- rep(TRUE, nrow(reference))
consumer <- common_use == "consumer" & labelled & complete_share
industrial <- common_use == "industrial" & labelled & complete_share
mixed <- common_use == "mixed" & labelled & complete_share
valid_label[consumer] <- shares$consumer[consumer] > 0.5
valid_label[industrial] <- shares$industrial[industrial] > 0.5
valid_label[mixed] <-
shares$consumer[mixed] >= 0.25 & shares$industrial[mixed] >= 0.25 &
shares$consumer[mixed] <= 0.5 & shares$industrial[mixed] <= 0.5 &
shares$consumer[mixed] + shares$industrial[mixed] >= 0.75
source_provenance <- c("source_url", "retrieved_date", "evidence_notes")
source_ok <- lapply(source_provenance, function(column) {
value <- trimws(as.character(reference[[column]]))
!is.na(value) & nzchar(value)
})
source_complete <- Reduce(`&`, source_ok)
quantitative_provenance <- lapply(c("basis_year", "geography"),
function(column) {
value <- trimws(as.character(reference[[column]]))
!is.na(value) & nzchar(value)
})
quantitative_complete <- Reduce(`&`, quantitative_provenance)
invalid <- labelled & (
!valid_label | !source_complete |
(complete_share & !quantitative_complete)
)
if (any(invalid)) {
stop(
"common_use_reference labels require source provenance and, when ",
"quantitative shares are supplied, valid threshold shares and complete ",
"quantitative provenance: ",
paste(material_class[invalid], collapse = ", "),
call. = FALSE
)
}
invisible(TRUE)
}
.lib_normalize_enrichment_text <- function(value) {
value <- suppressWarnings(as.character(value))
value[is.na(value)] <- ""
ascii <- iconv(value, from = "", to = "ASCII//TRANSLIT")
ascii[is.na(ascii)] <- value[is.na(ascii)]
trimws(gsub("[[:space:]]+", " ", tolower(ascii), perl = TRUE))
}
.lib_regex_row_hits <- function(text, patterns) {
hits <- vector("list", length(text))
for (pattern_index in seq_along(patterns)) {
matched <- which(grepl(patterns[[pattern_index]], text, perl = TRUE))
for (row_index in matched) {
hits[[row_index]] <- c(hits[[row_index]], pattern_index)
}
}
hits
}
.lib_enrich_material_form <- function(metadata, regex_reference) {
out <- data.table::copy(data.table::as.data.table(metadata))
row_count <- nrow(out)
atomic <- vapply(out, function(value) {
is.atomic(value) && length(value) == row_count
}, logical(1L))
searchable <- out[, names(out)[atomic], with = FALSE]
search_values <- lapply(searchable, function(value) {
value <- suppressWarnings(as.character(value))
value[is.na(value)] <- ""
value
})
if (length(search_values)) {
corpus <- .lib_normalize_enrichment_text(do.call(
paste, c(search_values, list(sep = "\u001f"))
))
} else {
corpus <- rep("", row_count)
}
direct <- if ("material_form" %in% names(out)) {
.lib_normalize_enrichment_text(out[["material_form"]])
} else {
rep("", row_count)
}
patterns <- as.character(regex_reference$pattern)
forms <- as.character(regex_reference$material_form)
direct_hits <- .lib_regex_row_hits(direct, patterns)
direct_forms <- lapply(direct_hits, function(index) unique(forms[index]))
use_corpus <- lengths(direct_forms) == 0L
selected_hits <- direct_hits
evidence_source <- rep("material_form", row_count)
if (any(use_corpus)) {
corpus_hits <- .lib_regex_row_hits(corpus[use_corpus], patterns)
selected_hits[use_corpus] <- corpus_hits
evidence_source[use_corpus] <- "all_metadata"
}
matched_forms <- lapply(selected_hits, function(index) unique(forms[index]))
form_count <- lengths(matched_forms)
result <- rep(NA_character_, row_count)
unique_match <- form_count == 1L
result[unique_match] <- vapply(
matched_forms[unique_match], `[[`, character(1L), 1L
)
conflict <- form_count > 1L
out[, material_form := result]
matched_rows <- which(form_count > 0L)
normalized_matches <- lapply(search_values, function(value) {
.lib_normalize_enrichment_text(value[matched_rows])
})
evidence <- vapply(seq_along(matched_rows), function(match_position) {
row_index <- matched_rows[[match_position]]
if (identical(evidence_source[[row_index]], "material_form")) {
return(paste0("material_form=", direct[[row_index]]))
}
values <- character()
for (pattern_index in selected_hits[[row_index]]) {
for (column_name in names(normalized_matches)) {
value <- normalized_matches[[column_name]][[match_position]]
if (nzchar(value) && grepl(patterns[[pattern_index]], value,
perl = TRUE)) {
values <- c(values, paste0(
column_name, "=", substr(value, 1L, 160L)
))
break
}
}
}
paste(unique(values), collapse = " | ")
}, character(1L))
matches <- data.table::data.table(
row_id = as.integer(matched_rows),
sample_name = if ("sample_name" %in% names(out)) {
as.character(out[["sample_name"]][matched_rows])
} else {
rep(NA_character_, length(matched_rows))
},
material_form = result[matched_rows],
evidence_source = evidence_source[matched_rows],
matched_forms = vapply(
matched_forms[matched_rows], paste, character(1L), collapse = " | "
),
matched_patterns = vapply(selected_hits[matched_rows], function(index) {
paste(patterns[index], collapse = " | ")
}, character(1L)),
evidence = evidence,
conflict = conflict[matched_rows]
)
category <- sort(unique(stats::na.omit(result)))
category_metric <- if (length(category)) {
paste0("material_form:", category)
} else {
character()
}
summary <- data.table::data.table(
metric = c(
"total", "populated", "unmatched", "conflicting",
category_metric
),
value = as.integer(c(
row_count, sum(!is.na(result)), sum(form_count == 0L), sum(conflict),
vapply(
category, function(value) sum(result == value, na.rm = TRUE),
integer(1L)
)
))
)
list(
data = out, summary = summary, matches = matches,
clashes = matches[matches[["conflict"]]]
)
}
.lib_enrich_common_use <- function(metadata, reference) {
out <- data.table::copy(data.table::as.data.table(metadata))
common_use <- trimws(as.character(reference$common_use))
common_use[is.na(common_use) | !nzchar(common_use)] <- NA_character_
material_class <- if ("material_class" %in% names(out)) {
as.character(out[["material_class"]])
} else {
rep(NA_character_, nrow(out))
}
reference_index <- match(material_class, as.character(reference$material_class))
result <- common_use[reference_index]
out[, common_use := result]
category <- sort(unique(stats::na.omit(result)))
category_metric <- if (length(category)) {
paste0("common_use:", category)
} else {
character()
}
summary <- data.table::data.table(
metric = c(
"total", "populated", "unmatched", category_metric
),
value = as.integer(c(
nrow(out), sum(!is.na(result)), sum(is.na(result)),
vapply(
category, function(value) sum(result == value, na.rm = TRUE),
integer(1L)
)
))
)
classes <- sort(unique(stats::na.omit(material_class)))
class_index <- match(classes, as.character(reference$material_class))
coverage <- data.table::data.table(
material_class = classes,
spectra = vapply(
classes, function(value) {
sum(!is.na(material_class) & material_class == value)
}, integer(1L)
),
common_use = common_use[class_index],
consumer_mass_share = as.numeric(reference$consumer_mass_share[class_index]),
industrial_mass_share = as.numeric(reference$industrial_mass_share[class_index]),
unclassified_mass_share = as.numeric(
reference$unclassified_mass_share[class_index]
),
basis_year = as.character(reference$basis_year[class_index]),
geography = as.character(reference$geography[class_index]),
source_url = as.character(reference$source_url[class_index]),
retrieved_date = as.character(reference$retrieved_date[class_index]),
evidence_notes = as.character(reference$evidence_notes[class_index])
)
list(data = out, summary = summary, coverage = coverage)
}
.lib_regex_is_exact_literal <- function(pattern) {
if (is.na(pattern) || !startsWith(pattern, "^") ||
!endsWith(pattern, "$")) return(FALSE)
body <- substr(pattern, 2L, nchar(pattern) - 1L)
chars <- strsplit(body, "", fixed = TRUE)[[1L]]
if (length(chars) == 0L) return(TRUE)
metacharacters <- c(".", "(", ")", "+", "*", "?", "{", "}",
"|", "[", "]", "^", "$")
variable_escapes <- c(
"A", "B", "b", "D", "d", "G", "K", "N", "P", "p", "Q",
"R", "S", "s", "W", "w", "X", "x", "Z", "z", "0", "1",
"2", "3", "4", "5", "6", "7", "8", "9"
)
escaped <- FALSE
for (char in chars) {
if (escaped) {
if (char %in% variable_escapes) return(FALSE)
escaped <- FALSE
} else if (identical(char, "\\")) {
escaped <- TRUE
} else if (char %in% metacharacters) {
return(FALSE)
}
}
!escaped
}
.lib_build_signature <- function(x, workflow_paths, arguments) {
sources <- if (is.character(x)) {
.lib_file_signatures(x)
} else {
data.table::data.table(
path = "<in-memory>", size = as.numeric(utils::object.size(x)),
modified = NA_character_, checksum = digest::digest(x, algo = "sha256")
)
}
workflow <- .lib_file_signatures(workflow_paths, checksum_limit = Inf)
description <- if (file.exists("DESCRIPTION")) {
read.dcf("DESCRIPTION", fields = "Version")[[1L]]
} else {
NA_character_
}
code_checksum <- if (file.exists(file.path("R", "build_lib.R"))) {
.lib_sha256_file(file.path("R", "build_lib.R"))
} else {
NA_character_
}
digest::digest(
list(sources = sources, workflow = workflow, arguments = arguments,
version = description, code = code_checksum,
git = .lib_git_state(), runtime = .lib_runtime_provenance()),
algo = "sha256"
)
}
.lib_release_signature <- function(assessment_signature) {
package_source <- .lib_file_signatures(
c("DESCRIPTION", file.path("R", "build_lib.R")), checksum_limit = Inf
)
digest::digest(
list(
assessment = assessment_signature, package_source = package_source,
git = .lib_git_state(), runtime = .lib_runtime_provenance()
),
algo = "sha256"
)
}
.lib_component_signature <- function(x, workflow_paths, arguments,
component_version) {
sources <- if (is.character(x)) {
.lib_file_signatures(x)
} else {
data.table::data.table(
path = "<in-memory>", size = as.numeric(utils::object.size(x)),
modified = NA_character_, checksum = digest::digest(x, algo = "sha256")
)
}
workflow <- .lib_file_signatures(workflow_paths, checksum_limit = Inf)
digest::digest(
list(
sources = sources, workflow = workflow, arguments = arguments,
component_version = component_version,
runtime = .lib_runtime_provenance()
),
algo = "sha256"
)
}
.lib_file_signature_cache <- new.env(parent = emptyenv())
.lib_file_signatures <- function(paths, checksum_limit = 50 * 1024^2) {
paths <- unique(as.character(paths))
info <- file.info(paths)
normalized <- normalizePath(paths, mustWork = FALSE)
checksum <- rep(NA_character_, length(paths))
use <- !is.na(info$size) & !is.na(info$isdir) & !info$isdir
for (i in which(use)) {
cache_key <- digest::digest(
list(path = normalized[[i]], size = as.numeric(info$size[[i]]),
modified = as.character(info$mtime[[i]])),
algo = "sha256"
)
if (exists(cache_key, envir = .lib_file_signature_cache,
inherits = FALSE)) {
checksum[[i]] <- get(
cache_key, envir = .lib_file_signature_cache, inherits = FALSE
)
} else {
checksum[[i]] <- .lib_sha256_file(paths[[i]])
assign(cache_key, checksum[[i]], envir = .lib_file_signature_cache)
}
}
data.table::data.table(
path = normalized,
size = as.numeric(info$size), checksum_algorithm = "sha256",
modified = as.character(info$mtime), checksum = checksum
)
}
.lib_sha256_file <- function(path) {
digest::digest(file = path, algo = "sha256", serialize = FALSE)
}
.lib_git_state <- function() {
run <- function(args) {
value <- tryCatch(
suppressWarnings(system2("git", args, stdout = TRUE, stderr = FALSE)),
error = function(error) character()
)
paste(value, collapse = "\n")
}
list(
commit = run(c("rev-parse", "HEAD")),
tracked_status_sha256 = digest::digest(
run(c("status", "--porcelain", "--untracked-files=no")), algo = "sha256"
)
)
}
.lib_runtime_provenance <- function() {
packages <- c("OpenSpecy", "data.table", "digest", "glmnet", "ranger")
versions <- vapply(packages, function(package) {
if (identical(package, "OpenSpecy") && file.exists("DESCRIPTION")) {
return(as.character(read.dcf("DESCRIPTION", fields = "Version")[[1L]]))
}
if (requireNamespace(package, quietly = TRUE)) {
as.character(utils::packageVersion(package))
} else {
NA_character_
}
}, character(1))
list(R = R.version.string, platform = R.version$platform, packages = versions)
}
.lib_checkpoint_manager <- function(output_dir, signature, reuse, report) {
checkpoint_dir <- file.path(output_dir, "checkpoints")
dir.create(checkpoint_dir, recursive = TRUE, showWarnings = FALSE)
events <- list()
event_i <- 0L
record <- function(component, status, path, key, size = NA_real_,
checksum = NA_character_) {
event_i <<- event_i + 1L
events[[event_i]] <<- data.table::data.table(
component = component, status = status,
path = normalizePath(path, mustWork = FALSE), signature = key,
size = as.numeric(size), checksum_algorithm = "sha256",
checksum = as.character(checksum)
)
}
paths <- function(stage) {
safe <- gsub("[^A-Za-z0-9_.-]+", "_", stage)
list(
object = file.path(checkpoint_dir, paste0(safe, ".rds")),
manifest = file.path(checkpoint_dir, paste0(safe, ".manifest.rds"))
)
}
get <- function(stage, key = signature) {
target <- paths(stage)
if (!isTRUE(reuse) || !file.exists(target$object) ||
!file.exists(target$manifest)) return(NULL)
manifest <- tryCatch(readRDS(target$manifest), error = function(e) NULL)
info <- file.info(target$object)
checksum <- if (!is.na(info$size)) .lib_sha256_file(target$object) else NA_character_
if (!is.list(manifest) || !identical(manifest$signature, key) ||
!isTRUE(manifest$complete) || !identical(manifest$checksum, checksum) ||
!identical(as.numeric(manifest$size), as.numeric(info$size))) {
record(stage, "invalidated", target$object, key)
return(NULL)
}
object <- tryCatch(readRDS(target$object), error = function(e) NULL)
if (is.null(object)) {
record(stage, "unreadable", target$object, key)
return(NULL)
}
report(paste0("reusing checkpoint: ", stage))
record(stage, "reused", target$object, key, info$size, checksum)
object
}
put <- function(stage, object, key = signature) {
target <- paths(stage)
.lib_atomic_saveRDS(object, target$object)
info <- file.info(target$object)
checksum <- .lib_sha256_file(target$object)
.lib_atomic_saveRDS(
list(signature = key, complete = TRUE, size = as.numeric(info$size),
checksum_algorithm = "sha256", checksum = checksum),
target$manifest
)
record(stage, "built", target$object, key, info$size, checksum)
invisible(object)
}
manifest <- function() {
if (length(events) == 0L) {
return(data.table::data.table(
component = character(), status = character(), path = character(),
signature = character(), size = numeric(),
checksum_algorithm = character(), checksum = character()
))
}
data.table::rbindlist(events, fill = TRUE)
}
list(get = get, put = put, manifest = manifest)
}
.lib_atomic_saveRDS <- function(object, path) {
dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
temporary <- tempfile(pattern = paste0(basename(path), "."),
tmpdir = dirname(path))
on.exit(if (file.exists(temporary)) unlink(temporary), add = TRUE)
saveRDS(object, temporary)
if (file.exists(path)) unlink(path)
if (!file.rename(temporary, path)) {
stop("Could not promote completed component to ", path, call. = FALSE)
}
invisible(path)
}
.lib_atomic_fwrite <- function(object, path) {
dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
temporary <- tempfile(pattern = paste0(basename(path), "."),
tmpdir = dirname(path), fileext = ".csv")
on.exit(if (file.exists(temporary)) unlink(temporary), add = TRUE)
data.table::fwrite(object, temporary)
if (file.exists(path)) unlink(path)
if (!file.rename(temporary, path)) {
stop("Could not promote review table to ", path, call. = FALSE)
}
invisible(path)
}
.lib_write_quarantine_review <- function(quarantine, output_dir) {
review_dir <- file.path(output_dir, "review")
.lib_atomic_saveRDS(
quarantine, file.path(review_dir, "quarantined_spectra.rds")
)
metadata <- data.table::rbindlist(lapply(names(quarantine$spectra), function(name) {
out <- data.table::copy(quarantine$spectra[[name]]$metadata)
out[, quarantine_object := name]
out
}), fill = TRUE)
if (!nrow(metadata)) {
metadata <- data.table::data.table(
quarantine_object = character(), quarantine_key = character(),
sample_name = character(), material_class = character(),
quarantine_status = character(), quarantine_phase = character(),
quarantine_reason = character(), review_status = character()
)
}
.lib_atomic_fwrite(
metadata, file.path(review_dir, "quarantined_spectra_metadata.csv")
)
.lib_atomic_fwrite(
quarantine$conflicts,
file.path(review_dir, "quarantined_spectra_conflicts.csv")
)
invisible(review_dir)
}
.lib_promote_rds <- function(object, path) {
dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
temporary <- tempfile(pattern = paste0(basename(path), "."),
tmpdir = dirname(path))
on.exit(if (file.exists(temporary)) unlink(temporary), add = TRUE)
saveRDS(object, temporary)
checksum <- .lib_sha256_file(temporary)
size <- as.numeric(file.info(temporary)$size)
status <- "promoted"
if (file.exists(path)) {
existing_checksum <- .lib_sha256_file(path)
if (!identical(existing_checksum, checksum)) {
# Some model backends serialize semantically identical internal state
# differently after a save/load cycle (observed for ranger on R-devel).
# Preserve the already-promoted immutable bytes only when both payloads
# deserialize to identical R objects; genuine content drift still fails.
existing <- tryCatch(readRDS(path), error = function(error) NULL)
candidate <- tryCatch(readRDS(temporary), error = function(error) NULL)
if (is.null(existing) || is.null(candidate) ||
!identical(existing, candidate)) {
stop("Immutable release artifact differs from existing payload: ", path,
call. = FALSE)
}
checksum <- existing_checksum
size <- as.numeric(file.info(path)$size)
}
status <- "verified_existing"
unlink(temporary)
} else if (!file.rename(temporary, path)) {
stop("Could not promote completed component to ", path, call. = FALSE)
}
data.table::data.table(
component = tools::file_path_sans_ext(basename(path)), status = status,
path = normalizePath(path, mustWork = FALSE), size = size,
checksum_algorithm = "sha256", checksum = checksum
)
}
.lib_promote_build_index <- function(signature, artifact_manifest, path) {
index <- .lib_release_index(signature, artifact_manifest)
.lib_promote_rds(index, path)
}
.lib_finalize_reference_release <- function(build, assessment_components,
promotion, signature, report) {
release_dir <- promotion$directory
assessment_components$output_manifest <- data.table::copy(promotion$manifest)
assessment_components$output_manifest[, status := "available"]
build$assessments <- .lib_assessment_review(assessment_components)
.lib_validate_reference_build(build)
attr(build, "output_dir") <- normalizePath(release_dir, mustWork = FALSE)
attr(build, "build_signature") <- signature
report("serializing standalone reference-library assessments")
assessments_manifest <- .lib_promote_rds(
build$assessments, file.path(release_dir, "assessments.rds")
)
artifact_manifest <- data.table::rbindlist(
list(promotion$manifest, assessments_manifest), fill = TRUE
)
report("serializing the lightweight reference-library release index")
index_manifest <- .lib_promote_build_index(
signature, artifact_manifest,
file.path(release_dir, "reference_library_build.rds")
)
release_manifest <- data.table::rbindlist(
list(artifact_manifest, index_manifest), fill = TRUE
)
release_manifest[, status := "available"]
attr(release_manifest, "build_signature") <- signature
.lib_promote_rds(
release_manifest, file.path(release_dir, "release_manifest.rds")
)
build
}
.lib_complete_reference_build <- function(libraries, tables, prune,
remove_other, progress, report) {
retention_stages <- data.table::rbindlist(lapply(
libraries,
function(object) attr(object, "library_retention_stages", exact = TRUE)
), fill = TRUE)
identity_index <- data.table::rbindlist(lapply(names(libraries), function(name) {
metadata <- libraries[[name]]$metadata
data.table::data.table(
artifact = name,
sample_name = as.character(.lib_ids(libraries[[name]], "sample_name")),
spectrum_identity = if ("spectrum_identity" %in% names(metadata)) {
as.character(metadata$spectrum_identity)
} else {
NA_character_
}
)
}), fill = TRUE)
core_dropped <- data.table::rbindlist(lapply(libraries, function(object) {
attr(object, "dropped_spectrum_identities", exact = TRUE)
}), fill = TRUE)
prediction_rows <- list()
coverage_rows <- list()
for (name in names(libraries)) {
report(paste0("completing class metadata (", name, ")"))
prediction <- predict_class_reference(
libraries[[name]]$metadata, tables$classes_regex, return = "report"
)
if (nrow(prediction$clashes) > 0L) {
stop("Class regex clashes require exact material entries: ",
paste(head(prediction$clashes$spectrum_identity, 20L),
collapse = ", "), call. = FALSE)
}
libraries[[name]]$metadata <- prediction$data
libraries[[name]] <- join_material_hierarchy(
libraries[[name]], tables$material_hierarchy
)
attr(libraries[[name]], "class_prediction_report") <- prediction[
c("summary", "predictions", "clashes", "overlaps")
]
libraries[[name]] <- .lib_complete_reference_classes(
libraries[[name]], classes = tables$classes_reference,
hierarchy = tables$material_hierarchy,
enforce_other_limit = !isTRUE(remove_other)
)
prediction_rows[[name]] <- data.table::data.table(
artifact = name, metric = names(prediction$summary),
value = as.numeric(unlist(prediction$summary, use.names = FALSE))
)
coverage <- attr(libraries[[name]], "class_coverage_report")
coverage_rows[[name]] <- data.table::data.table(
artifact = name, stage = coverage$stage,
populated_class = coverage$populated_class,
reviewed_source_key = coverage$reviewed_source_key,
reviewed_class_key = coverage$reviewed_class_key,
unclassified = coverage$unclassified,
unresolved_other = coverage$unresolved_other,
other = coverage$other,
other_fraction = coverage$other_fraction
)
}
other_policy <- .lib_apply_other_policy(
libraries, remove_other = remove_other, report = report
)
libraries <- other_policy$libraries
other_policy$libraries <- NULL
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_other")
), fill = TRUE)
type_coverage <- data.table::rbindlist(lapply(names(libraries), function(name) {
metadata <- libraries[[name]]$metadata
data.table::data.table(
artifact = name, field = c("library_type", "spectrum_type"),
populated = c(
sum(!is.na(metadata$library_type) & nzchar(metadata$library_type)),
sum(!is.na(metadata$spectrum_type) & nzchar(metadata$spectrum_type))
), total = nrow(metadata)
)
}))
if (any(type_coverage$populated != type_coverage$total)) {
stop("Blank library_type or spectrum_type values remain after source lookup",
call. = FALSE)
}
quality_store <- new.env(parent = emptyenv())
quality_store$libraries <- libraries
rm(libraries)
gc(verbose = FALSE)
quality <- .lib_quality_control_processed(
quality_store, report = report,
artifact_ratio = 2, tail_n = 5L, max_crop = 0.2,
snr_threshold = 2
)
libraries <- quality$libraries
quality$libraries <- NULL
rm(quality_store)
gc(verbose = FALSE)
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_quality")
), fill = TRUE)
prune_spec <- prune
if (is.null(prune_spec)) {
prune_spec <- list(
derivative = list(cross_class = TRUE),
nobaseline = list(cross_class = TRUE)
)
}
prune_rows <- list()
prune_excluded_rows <- list()
prune_reassignment_rows <- list()
prune_removal_rows <- list()
prune_conflict_rows <- list()
quarantine_parts <- list()
prune_targets <- intersect(names(prune_spec), names(libraries))
library_order <- names(libraries)
prune_paths <- character()
if (length(prune_targets) > 0L) {
report("staging libraries for bounded pruning")
prune_paths <- stats::setNames(vapply(library_order, function(name) {
tempfile(paste0("openspecy-prune-", name, "-"), fileext = ".rds")
}, character(1L)), library_order)
on.exit(unlink(prune_paths[file.exists(prune_paths)]), add = TRUE)
for (name in library_order) {
saveRDS(libraries[[name]], prune_paths[[name]], compress = FALSE)
libraries[[name]] <- NULL
gc(verbose = FALSE, full = TRUE)
}
}
for (name in prune_targets) {
report(paste0("pruning ", name))
args <- prune_spec[[name]]
if (is.null(args)) args <- list()
if (is.null(args$progress)) args$progress <- progress
args$return <- "report"
library <- readRDS(prune_paths[[name]])
pruned <- do.call(prune_lib, c(list(library), args))
if (nrow(pruned$cross_class_conflicts)) {
prune_conflict_rows[[paste0(name, "_prune")]] <- data.table::copy(
pruned$cross_class_conflicts
)[, artifact := name][]
}
if (nrow(pruned$cross_class_removals)) {
min_n <- if (is.null(args$min_n)) 10L else as.integer(args$min_n)
quarantine_parts <- c(
quarantine_parts,
.lib_typed_quarantine_parts(
library, pruned$cross_class_removals, name, min_n
)
)
}
rm(library)
prune_rows[[name]] <- data.table::copy(pruned$summary)[
, artifact := name][]
if (nrow(pruned$excluded_classes)) {
prune_excluded_rows[[name]] <- data.table::copy(
pruned$excluded_classes
)[, artifact := name][]
data.table::setcolorder(
prune_excluded_rows[[name]],
c("artifact", setdiff(names(prune_excluded_rows[[name]]), "artifact"))
)
}
if (nrow(pruned$reassignments)) {
prune_reassignment_rows[[name]] <- data.table::copy(
pruned$reassignments
)[, artifact := name][]
}
if (nrow(pruned$removals)) {
prune_removal_rows[[name]] <- data.table::copy(
pruned$removals
)[, artifact := name][]
data.table::setcolorder(
prune_removal_rows[[name]],
c("artifact", setdiff(names(prune_removal_rows[[name]]), "artifact"))
)
}
saveRDS(pruned$object, prune_paths[[name]], compress = FALSE)
pruned$object <- NULL
rm(pruned)
gc(verbose = FALSE, full = TRUE)
}
if (length(prune_targets) > 0L) {
report("restoring pruned libraries")
libraries <- stats::setNames(lapply(prune_paths, readRDS), library_order)
unlink(prune_paths[file.exists(prune_paths)])
prune_paths <- character()
gc(verbose = FALSE, full = TRUE)
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_prune")
), fill = TRUE)
if (!isTRUE(remove_other) && nrow(other_policy$review)) {
other_policy$review[
action == "retained_for_semisupervised_reassignment",
action := "retained_unresolved"
]
if (length(prune_reassignment_rows)) {
reassigned_ids <- data.table::rbindlist(
prune_reassignment_rows, fill = TRUE
)[, .(artifact, spectrum_id)]
other_policy$review[
reassigned_ids,
on = .(artifact, spectrum_id),
action := "reassigned"
]
}
}
material_form_rows <- list()
material_form_match_rows <- list()
material_form_clash_rows <- list()
common_use_rows <- list()
common_use_coverage_rows <- list()
for (name in names(libraries)) {
report(paste0("enriching material form and common use (", name, ")"))
form <- .lib_enrich_material_form(
libraries[[name]]$metadata, tables$material_form_regex
)
libraries[[name]]$metadata <- form$data
attr(libraries[[name]], "material_form_enrichment_report") <- form[
c("summary", "matches", "clashes")
]
material_form_rows[[name]] <- data.table::copy(form$summary)
material_form_rows[[name]][, artifact := name]
if (nrow(form$matches)) {
material_form_match_rows[[name]] <- data.table::copy(form$matches)
material_form_match_rows[[name]][, artifact := name]
}
if (nrow(form$clashes)) {
material_form_clash_rows[[name]] <- data.table::copy(form$clashes)
material_form_clash_rows[[name]][, artifact := name]
}
use <- .lib_enrich_common_use(
libraries[[name]]$metadata, tables$common_use_reference
)
libraries[[name]]$metadata <- use$data
attr(libraries[[name]], "common_use_enrichment_report") <- use[
c("summary", "coverage")
]
common_use_rows[[name]] <- data.table::copy(use$summary)
common_use_rows[[name]][, artifact := name]
common_use_coverage_rows[[name]] <- data.table::copy(use$coverage)
common_use_coverage_rows[[name]][, artifact := name]
}
superseded_drop <- c(
"x", "y", "xunits", "interpretation", "form_factor", "shape",
"x_unit", "spectrumid", "locationdescription", "datatype"
)
optional_drop <- grepl("^assessment_", tables$metadata_drop$metadata_column)
drop_status <- data.table::data.table(
metadata_column = tables$metadata_drop$metadata_column,
status = ifelse(
tables$metadata_drop$metadata_column %in% names(libraries$raw$metadata),
"present",
ifelse(
tables$metadata_drop$metadata_column %in% superseded_drop,
"superseded_absent",
ifelse(optional_drop, "optional_absent", "stale_absent")
)
)
)
report(paste0(
"metadata drop QA: ",
paste(drop_status[, paste0(status, "=", .N), by = status]$V1,
collapse = "; ")
))
automated_test_flags <- .lib_collect_automated_test_flags(libraries)
before_filter <- ncol(libraries$raw$spectra)
material_type <- as.character(libraries$raw$metadata$material_type)
if (any(is.na(material_type) | !nzchar(trimws(material_type)))) {
stop("Blank material_type values remain after reviewed class cleanup",
call. = FALSE)
}
libraries <- lapply(libraries, function(object) {
drop_cols <- intersect(
tables$metadata_drop$metadata_column, names(object$metadata)
)
if (length(drop_cols) > 0L) object$metadata[, (drop_cols) := NULL]
object
})
for (name in intersect(c("derivative", "nobaseline"), names(libraries))) {
libraries[[name]]$spectra <- round(libraries[[name]]$spectra, 3)
finite_range <- apply(libraries[[name]]$spectra, 2L, function(values) {
values <- values[is.finite(values)]
if (length(values)) diff(range(values)) else 0
})
flat <- !is.finite(finite_range) | finite_range <= 0
if (any(flat)) {
flat_rows <- data.table::data.table(
artifact = name,
spectrum_id = as.character(.lib_ids(libraries[[name]], "sample_name"))[flat],
spectrum_type = as.character(libraries[[name]]$metadata$spectrum_type)[flat],
check = "flat_spectrum", action = "drop",
before_value = finite_range[flat], after_value = NA_real_,
threshold = 0, removed = TRUE, reason = "post_transform_flat_spectrum"
)
quality$assessment <- data.table::rbindlist(
list(quality$assessment, flat_rows), fill = TRUE
)
libraries[[name]] <- filter_spec(libraries[[name]], !flat)
}
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_transform")
), fill = TRUE)
report(sprintf("reviewed exclusions and flat-spectrum checks complete (removed=%d; retained=%d)",
before_filter - ncol(libraries$raw$spectra),
ncol(libraries$raw$spectra)))
retained_index <- data.table::rbindlist(lapply(names(libraries), function(name) {
data.table::data.table(
artifact = name,
sample_name = as.character(.lib_ids(libraries[[name]], "sample_name"))
)
}))
post_dropped <- identity_index[
!retained_index, on = .(artifact, sample_name),
.(spectrum_identity)
]
dropped_spectrum_identities <- data.table::rbindlist(
list(core_dropped, post_dropped), fill = TRUE
)[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(spectrum_identity)))
]
partition_store <- new.env(parent = emptyenv())
partition_store$libraries <- libraries
rm(libraries)
gc(verbose = FALSE, full = TRUE)
libraries <- .lib_partition_reference_libraries(partition_store, report)
rm(partition_store)
gc(verbose = FALSE, full = TRUE)
closure <- .lib_close_typed_reference_libraries(
libraries, prune_spec = prune_spec, report = report, progress = progress
)
libraries <- closure$libraries
closure$libraries <- NULL
if (nrow(closure$removals)) {
prune_removal_rows$final_closure <- closure$removals
}
if (nrow(closure$conflicts)) {
prune_conflict_rows$final_closure <- closure$conflicts
}
quarantine_parts <- c(quarantine_parts, closure$quarantine_parts)
if (nrow(closure$support_drops)) {
quality$assessment <- data.table::rbindlist(
list(quality$assessment, closure$support_drops), fill = TRUE
)
}
quarantine <- .lib_quarantine_bundle(
quarantine_parts,
conflicts = if (length(prune_conflict_rows)) {
data.table::rbindlist(prune_conflict_rows, fill = TRUE)
} else .lib_prune_conflict_edge_schema(),
thresholds = unlist(lapply(prune_targets, function(name) {
args <- prune_spec[[name]]
if (is.null(args$cross_class_threshold)) 0.9 else
args$cross_class_threshold
}), use.names = FALSE)
)
range_flat_rows <- data.table::rbindlist(lapply(names(libraries), function(recipe) {
data.table::rbindlist(lapply(libraries[[recipe]], function(object) {
attr(object, "range_flat_drops", exact = TRUE)
}), fill = TRUE)
}), fill = TRUE)
if (nrow(range_flat_rows)) {
quality$assessment <- data.table::rbindlist(
list(quality$assessment, range_flat_rows), fill = TRUE
)
dropped_spectrum_identities <- data.table::rbindlist(
list(
dropped_spectrum_identities,
range_flat_rows[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity)
]
),
fill = TRUE
)[, .(spectrum_identity = sort(unique(spectrum_identity)))]
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "final")
), fill = TRUE)
library_retention <- .lib_library_retention_report(retention_stages)
list(
libraries = libraries,
assessments = list(
class_prediction = data.table::rbindlist(prediction_rows, fill = TRUE),
class_coverage = data.table::rbindlist(coverage_rows, fill = TRUE),
type_coverage = type_coverage,
material_form_enrichment = data.table::rbindlist(
material_form_rows, fill = TRUE
),
material_form_matches = data.table::rbindlist(
material_form_match_rows, fill = TRUE
),
material_form_clashes = data.table::rbindlist(
material_form_clash_rows, fill = TRUE
),
common_use_enrichment = data.table::rbindlist(
common_use_rows, fill = TRUE
),
common_use_coverage = data.table::rbindlist(
common_use_coverage_rows, fill = TRUE
),
other_review = other_policy$review,
other_filter = other_policy$summary,
pruning = data.table::rbindlist(prune_rows, fill = TRUE),
pruning_excluded_classes = if (length(prune_excluded_rows)) {
data.table::rbindlist(prune_excluded_rows, fill = TRUE)
} else {
.lib_prune_excluded_assessment_schema()
},
pruning_reassignments = if (length(prune_reassignment_rows)) {
data.table::rbindlist(prune_reassignment_rows, fill = TRUE)
} else {
.lib_prune_reassignment_schema()
},
pruning_removals = if (length(prune_removal_rows)) {
data.table::rbindlist(prune_removal_rows, fill = TRUE)
} else {
.lib_prune_removal_assessment_schema()
},
pruning_conflicts = if (length(prune_conflict_rows)) {
data.table::rbindlist(prune_conflict_rows, fill = TRUE)
} else {
out <- .lib_prune_conflict_edge_schema()
out[, artifact := character()]
out
},
automated_test_flags = automated_test_flags,
quality_control = quality$assessment,
library_retention = library_retention,
dropped_spectrum_identities = dropped_spectrum_identities,
filters = data.table::data.table(
stage = "special_filter", before = before_filter,
after = ncol(libraries$raw$spectra),
removed = before_filter - ncol(libraries$raw$spectra)
),
metadata_drop = drop_status
),
quarantine = quarantine
)
}
.lib_quality_schema <- function() {
data.table::data.table(
artifact = character(), spectrum_id = character(),
spectrum_type = character(), check = character(), action = character(),
before_value = numeric(), after_value = numeric(), threshold = numeric(),
removed = logical(), reason = character()
)
}
.lib_warning_schema <- function() {
data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
warning = character()
)
}
.lib_prune_reassignment_schema <- function() {
data.table::data.table(
artifact = character(), spectrum_id = character(),
prior_class = character(), material_class = character(),
prior_material_type = character(), material_type = character(),
matched_id = character(), correlation = numeric(), pool = character(),
reason = character()
)
}
.lib_quality_control_processed <- function(libraries, report,
artifact_ratio = 2,
tail_n = 5L,
max_crop = 0.2,
snr_threshold = 2) {
assessment <- list()
detached <- is.environment(libraries)
store <- if (detached) libraries else NULL
recipe_names <- if (detached) names(store$libraries) else names(libraries)
for (recipe in intersect(c("derivative", "nobaseline"), recipe_names)) {
x <- if (detached) store$libraries[[recipe]] else libraries[[recipe]]
if (detached) {
store$libraries[[recipe]] <- NULL
gc(verbose = FALSE)
}
started <- proc.time()[["elapsed"]]
ids <- .lib_ids(x, "sample_name")
type <- tolower(as.character(x$metadata$spectrum_type))
report(sprintf(
"quality gate %s: starting (spectra=%d; wavenumbers=%d)",
recipe, ncol(x$spectra), nrow(x$spectra)
))
metrics <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)
co2 <- type == "ftir" & is.finite(metrics$co2_ratio) &
metrics$co2_ratio > artifact_ratio
co2[is.na(co2)] <- FALSE
if (any(co2)) {
corrected <- flatten_range(
filter_spec(x, co2), min = 2200, max = 2420, make_rel = FALSE
)
x$spectra[, co2] <- corrected$spectra
}
co2_after <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)$co2_ratio
failed_co2 <- co2 & (!is.finite(co2_after) |
co2_after > artifact_ratio)
failed_co2[is.na(failed_co2)] <- TRUE
assessment[[paste0(recipe, "_co2")]] <- data.table::data.table(
artifact = recipe, spectrum_id = ids[co2], spectrum_type = type[co2],
check = "co2_region", action = ifelse(failed_co2[co2], "drop", "flatten"),
before_value = metrics$co2_ratio[co2], after_value = co2_after[co2],
threshold = artifact_ratio, removed = failed_co2[co2],
reason = ifelse(
failed_co2[co2], "co2_postcondition_failed",
"co2_to_silent_ratio_corrected"
)
)
report(sprintf(
"quality gate %s: CO2 flatten complete (flattened=%d; failed=%d)",
recipe, sum(co2), sum(failed_co2)
))
tail_before <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)$tail_ratio
tail_flag <- is.finite(tail_before) & tail_before > artifact_ratio
tail_flag[is.na(tail_flag)] <- FALSE
correction <- .lib_trim_high_tail_matrix(
x$wavenumber, x$spectra[, tail_flag, drop = FALSE],
artifact_ratio = artifact_ratio, tail_n = tail_n,
max_crop = max_crop, co2_region = c(2200, 2420)
)
if (any(tail_flag)) x$spectra[, tail_flag] <- correction$spectra
tail_after <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)$tail_ratio
failed_tail <- rep(FALSE, ncol(x$spectra))
failed_tail[tail_flag] <- !correction$passed
assessment[[paste0(recipe, "_tail")]] <- data.table::data.table(
artifact = recipe, spectrum_id = ids[tail_flag],
spectrum_type = type[tail_flag], check = "high_tail",
action = ifelse(correction$passed, "trim", "drop"),
before_value = tail_before[tail_flag], after_value = tail_after[tail_flag],
threshold = artifact_ratio, removed = !correction$passed,
reason = correction$reason
)
report(sprintf(
"quality gate %s: high-tail correction complete (flagged=%d; corrected=%d; failed=%d)",
recipe, sum(tail_flag), sum(correction$passed), sum(!correction$passed)
))
snr <- sig_noise(x, metric = "run_sig_over_noise", step = 10,
na.rm = TRUE)
low_snr <- !is.finite(snr) | snr < snr_threshold
assessment[[paste0(recipe, "_snr")]] <- data.table::data.table(
artifact = recipe, spectrum_id = ids[low_snr],
spectrum_type = type[low_snr], check = "low_snr", action = "drop",
before_value = as.numeric(snr[low_snr]), after_value = NA_real_,
threshold = snr_threshold, removed = TRUE,
reason = ifelse(is.finite(snr[low_snr]),
"running_snr_below_threshold", "running_snr_unavailable")
)
remove <- failed_co2 | failed_tail | low_snr
if (all(remove)) {
stop("Quality control removed every spectrum from ", recipe,
call. = FALSE)
}
x <- filter_spec(x, !remove)
x$metadata$sn <- snr[!remove]
attr(x, "quality_control_report") <- data.table::rbindlist(
assessment[grepl(paste0("^", recipe, "_"), names(assessment))],
fill = TRUE
)
if (detached) store$libraries[[recipe]] <- x else libraries[[recipe]] <- x
report(sprintf(
"quality gate %s: complete (removed=%d; retained=%d; %.1fs)",
recipe, sum(remove), ncol(x$spectra),
proc.time()[["elapsed"]] - started
))
}
rows <- data.table::rbindlist(assessment, fill = TRUE)
if (!nrow(rows)) rows <- .lib_quality_schema()
if (detached) libraries <- store$libraries
list(libraries = libraries, assessment = rows)
}
.lib_trim_high_tail_matrix <- function(wavenumber, spectra,
artifact_ratio = 2, tail_n = 5L,
max_crop = 0.2,
co2_region = c(2200, 2420)) {
if (!ncol(spectra)) {
return(list(spectra = spectra, passed = logical(), reason = character()))
}
passed <- logical(ncol(spectra))
reason <- rep("corrected", ncol(spectra))
for (column in seq_len(ncol(spectra))) {
values <- spectra[, column]
original <- which(is.finite(values))
if (length(original) <= 2L * tail_n) {
reason[column] <- "insufficient_finite_range"
next
}
original_span <- abs(wavenumber[max(original)] - wavenumber[min(original)])
repeat {
finite <- which(is.finite(values))
if (length(finite) <= 2L * tail_n) {
reason[column] <- "insufficient_finite_range"
break
}
normalized <- values
lo <- min(normalized[finite])
span <- max(normalized[finite]) - lo
if (!is.finite(span) || span <= 0) {
reason[column] <- "flat_or_unavailable"
break
}
normalized[finite] <- (normalized[finite] - lo) / span
left <- head(finite, tail_n)
right <- utils::tail(finite, tail_n)
control <- setdiff(
finite,
c(left, right, which(wavenumber >= co2_region[1L] &
wavenumber <= co2_region[2L]))
)
control_max <- if (length(control)) max(normalized[control]) else NA_real_
if (!is.finite(control_max)) {
reason[column] <- "control_unavailable"
break
}
left_ratio <- max(normalized[left]) / control_max
right_ratio <- max(normalized[right]) / control_max
trim_left <- is.finite(left_ratio) && left_ratio > artifact_ratio
trim_right <- is.finite(right_ratio) && right_ratio > artifact_ratio
if (!trim_left && !trim_right) {
spectra[, column] <- values
passed[column] <- TRUE
break
}
if (trim_left) values[min(finite)] <- NA_real_
if (trim_right) values[max(finite)] <- NA_real_
remaining <- which(is.finite(values))
cropped <- 1 - abs(wavenumber[max(remaining)] -
wavenumber[min(remaining)]) / original_span
if (!is.finite(cropped) || cropped > max_crop) {
reason[column] <- "max_crop_exceeded"
break
}
}
}
list(spectra = spectra, passed = passed, reason = reason)
}
.lib_type_ranges <- function() {
list(raman = c(200, 4000), ftir = c(400, 4000), nir = c(4000, 12000))
}
.lib_drop_blank_metadata <- function(x) {
blank <- vapply(x$metadata, function(column) {
if (is.character(column)) {
all(is.na(column) | !nzchar(trimws(column)))
} else {
all(is.na(column))
}
}, logical(1))
blank[names(blank) %in% c("material_form", "common_use")] <- FALSE
if (any(blank)) x$metadata[, (names(blank)[blank]) := NULL]
x
}
.lib_flat_spectrum_mask <- function(x) {
if (!is_OpenSpecy(x) || !ncol(x$spectra)) return(logical())
vapply(seq_len(ncol(x$spectra)), function(column) {
values <- x$spectra[, column]
values <- values[is.finite(values)]
length(values) == 0L || diff(range(values)) <= 0
}, logical(1))
}
.lib_drop_range_flat_spectra <- function(x, artifact, spectrum_type,
reason, report = NULL) {
flat <- .lib_flat_spectrum_mask(x)
if (!any(flat)) return(x)
support <- attr(x, "identification_support", exact = TRUE)
metadata <- x$metadata[flat, , drop = FALSE]
rows <- data.table::data.table(
artifact = artifact,
spectrum_id = as.character(.lib_ids(x, "sample_name"))[flat],
spectrum_identity = if ("spectrum_identity" %in% names(metadata)) {
as.character(metadata$spectrum_identity)
} else {
NA_character_
},
spectrum_type = spectrum_type,
check = "flat_spectrum", action = "drop",
before_value = 0, after_value = NA_real_, threshold = 0,
removed = TRUE, reason = reason
)
x <- filter_spec(x, !flat)
if (!is.null(support) && nrow(support)) {
support <- data.table::copy(support)
support[spectrum_id %in% rows$spectrum_id, retained := FALSE]
attr(x, "identification_support") <- support
attr(x, "identification_dropped_ids") <- unique(c(
attr(x, "identification_dropped_ids", exact = TRUE),
rows$spectrum_id
))
}
attr(x, "range_flat_drops") <- rows
if (!is.null(report)) report(sprintf(
"discarded flat spectra after range restriction (%s/%s; removed=%d)",
artifact, spectrum_type, nrow(rows)
))
x
}
.lib_drop_typed_range_flats <- function(libraries, report = NULL) {
for (recipe in names(libraries)) {
for (type in names(libraries[[recipe]])) {
libraries[[recipe]][[type]] <- .lib_drop_range_flat_spectra(
libraries[[recipe]][[type]], artifact = recipe,
spectrum_type = type, reason = "post_partition_flat_spectrum",
report = report
)
}
}
libraries
}
.lib_partition_reference_libraries <- function(libraries, report = NULL) {
ranges <- .lib_type_ranges()
stored <- is.environment(libraries)
source <- if (stored) NULL else libraries
recipes <- if (stored) names(libraries$libraries) else names(source)
out_all <- stats::setNames(vector("list", length(recipes)), recipes)
for (recipe in recipes) {
x <- if (stored) libraries$libraries[[recipe]] else source[[recipe]]
if (stored) {
libraries$libraries[[recipe]] <- NULL
gc(verbose = FALSE, full = TRUE)
}
out <- lapply(names(ranges), function(type) {
subset <- .lib_filter_optional_type(x, type)
if (is.null(subset)) return(NULL)
limits <- ranges[[type]]
inside <- subset$wavenumber >= limits[1L] &
subset$wavenumber <= limits[2L]
if (sum(inside) < 2L) return(NULL)
subset <- restrict_range(
subset, min = limits[1L], max = limits[2L], make_rel = FALSE
)
subset <- .lib_drop_blank_metadata(subset)
subset <- .lib_drop_range_flat_spectra(
subset, artifact = recipe, spectrum_type = type,
reason = "post_partition_flat_spectrum", report = report
)
if (!is.null(report)) report(sprintf(
"partitioned %s/%s (spectra=%d; range=%g-%g; wavenumbers=%d)",
recipe, type, ncol(subset$spectra), limits[1L], limits[2L],
nrow(subset$spectra)
))
subset
})
names(out) <- names(ranges)
out_all[[recipe]] <- Filter(Negate(is.null), out)
rm(x, out)
gc(verbose = FALSE, full = TRUE)
}
out_all
}
.lib_quarantine_part <- function(x, removals, artifact, spectrum_type, min_n) {
if (!is_OpenSpecy(x) || !nrow(removals)) return(NULL)
ids <- as.character(.lib_ids(x, "sample_name"))
removal_ids <- unique(as.character(removals$spectrum_id))
keep <- ids %in% removal_ids
keep[is.na(keep)] <- FALSE
if (!any(keep)) return(NULL)
out <- filter_spec(x, keep)
max_or_na <- function(value) {
value <- value[is.finite(value)]
if (length(value)) max(value) else NA_real_
}
min_or_na <- function(value) {
value <- value[is.finite(value)]
if (length(value)) min(value) else NA_integer_
}
collapse_values <- function(value) {
value <- sort(unique(as.character(value[!is.na(value) & nzchar(value)])))
if (length(value)) paste(value, collapse = "; ") else NA_character_
}
summary <- removals[spectrum_id %in% ids, .(
quarantine_status = collapse_values(quarantine_status),
quarantine_phase = collapse_values(phase),
quarantine_reason = collapse_values(reason),
component_id = collapse_values(component_id),
correlation_view = collapse_values(correlation_view),
threshold = max_or_na(threshold),
decision_round = min_or_na(decision_round),
active_degree = as.integer(max_or_na(active_degree)),
max_wrong_class_correlation = max_or_na(correlation),
opposing_classes = collapse_values(matched_class),
opposing_libraries = collapse_values(matched_library),
class_n_before = as.integer(max_or_na(class_n_before)),
review_status = collapse_values(review_status)
), by = spectrum_id]
out_ids <- as.character(.lib_ids(out, "sample_name"))
summary <- summary[match(out_ids, spectrum_id)]
added <- setdiff(names(summary), "spectrum_id")
added_values <- summary[, added, with = FALSE]
out$metadata[, (added) := added_values]
out$metadata[, `:=`(
quarantine_recipe = artifact,
quarantine_spectrum_type = spectrum_type,
quarantine_key = paste(artifact, spectrum_type, out_ids, sep = "/"),
min_n = as.integer(min_n)
)]
out
}
.lib_typed_quarantine_parts <- function(x, removals, artifact, min_n) {
if (!is_OpenSpecy(x) || !nrow(removals)) return(list())
types <- sort(unique(tolower(as.character(x$metadata$spectrum_type))))
types <- intersect(types[!is.na(types) & nzchar(types)],
names(.lib_type_ranges()))
out <- lapply(types, function(type) {
object <- .lib_filter_optional_type(x, type)
if (is.null(object)) return(NULL)
ids <- as.character(.lib_ids(object, "sample_name"))
rows <- removals[spectrum_id %in% ids]
if (!nrow(rows)) return(NULL)
limits <- .lib_type_ranges()[[type]]
object <- restrict_range(
object, min = limits[[1L]], max = limits[[2L]], make_rel = FALSE
)
.lib_quarantine_part(object, rows, artifact, type, min_n)
})
names(out) <- paste(artifact, types, sep = "/")
Filter(Negate(is.null), out)
}
.lib_quarantine_bundle <- function(parts = list(), conflicts = NULL,
build_signature = NA_character_,
thresholds = numeric()) {
parts <- Filter(Negate(is.null), parts)
spectra <- list()
if (length(parts)) {
keys <- vapply(parts, function(object) {
paste(
unique(as.character(object$metadata$quarantine_recipe))[[1L]],
unique(as.character(object$metadata$quarantine_spectrum_type))[[1L]],
sep = "/"
)
}, character(1L))
grouped <- split(parts, keys)
spectra <- lapply(names(grouped), function(key) {
out <- .lib_bind_same_axis(grouped[[key]], paste("quarantine", key))
ids <- as.character(.lib_ids(out, "sample_name"))
if (anyDuplicated(ids)) {
stop("Quarantine bundle contains duplicate composite IDs for ", key,
call. = FALSE)
}
out
})
names(spectra) <- names(grouped)
}
if (is.null(conflicts) || !nrow(conflicts)) {
conflicts <- .lib_prune_conflict_edge_schema()
} else {
conflicts <- data.table::as.data.table(data.table::copy(conflicts))
}
structure(list(
spectra = spectra,
conflicts = conflicts,
manifest = list(
schema = "OpenSpecy_quarantined_spectra_v1",
build_signature = as.character(build_signature),
thresholds = sort(unique(as.numeric(thresholds))),
source_hashes = as.character(build_signature)
)
), class = c("OpenSpecyQuarantine", "list"))
}
.lib_close_typed_reference_libraries <- function(libraries, prune_spec,
report = NULL,
progress = FALSE) {
removal_rows <- list()
conflict_rows <- list()
quarantine_parts <- list()
support_rows <- list()
row_i <- 0L
conflict_i <- 0L
part_i <- 0L
support_i <- 0L
generic <- c("other", "other plastic", "other material", "unclassified")
for (artifact in intersect(c("derivative", "nobaseline"), names(libraries))) {
args <- if (is.null(prune_spec)) list(cross_class = TRUE) else prune_spec[[artifact]]
if (is.null(args)) args <- list()
if (!isTRUE(args$cross_class)) next
threshold <- if (is.null(args$cross_class_threshold)) 0.9 else
as.numeric(args$cross_class_threshold)
min_n <- if (is.null(args$min_n)) 10L else as.integer(args$min_n)
for (type in names(libraries[[artifact]])) {
parent <- libraries[[artifact]][[type]]
model_supported <- .lib_restrict_model_range(parent, type)
model_supported <- .lib_drop_range_flat_spectra(
model_supported, artifact = artifact, spectrum_type = type,
reason = "pre_medoid_model_range_flat_spectrum", report = report
)
parent_ids <- as.character(.lib_ids(parent, "sample_name"))
supported_ids <- as.character(.lib_ids(model_supported, "sample_name"))
unsupported <- !parent_ids %in% supported_ids
if (any(unsupported)) {
support_i <- support_i + 1L
support_rows[[support_i]] <- data.table::data.table(
artifact = artifact, spectrum_id = parent_ids[unsupported],
spectrum_type = type, check = "identification_support",
action = "drop", before_value = NA_real_, after_value = NA_real_,
threshold = 0.1, removed = TRUE,
reason = "below_model_range_observed_support"
)
parent <- filter_spec(parent, !unsupported)
}
close_view <- function(object, view) {
ids <- as.character(.lib_ids(object, "sample_name"))
metadata <- object$metadata
result <- .lib_prune_cross_class_conflicts(
classes = as.character(metadata$material_class),
pools = rep(type, length(ids)),
normalized = .lib_prune_normalize(
object$spectra, object$wavenumber, exclude = NULL
),
ids = ids,
library_names = as.character(metadata$library_name),
threshold = threshold, support_groups = rep(type, length(ids)),
min_n = min_n, correlation_view = view,
progress = progress, block_size = 128L
)
if (nrow(result$removals)) result$removals[, phase := "final_closure"]
if (nrow(result$conflicts)) result$conflicts[, phase := "final_closure"]
result
}
full_result <- close_view(parent, "typed_full")
if (nrow(full_result$removals)) {
row_i <- row_i + 1L
removal_rows[[row_i]] <- full_result$removals[, artifact := artifact][]
part_i <- part_i + 1L
quarantine_parts[[part_i]] <- .lib_quarantine_part(
parent, full_result$removals, artifact, type, min_n
)
parent <- filter_spec(parent, -full_result$removed_rows)
}
if (nrow(full_result$conflicts)) {
conflict_i <- conflict_i + 1L
conflict_rows[[conflict_i]] <- full_result$conflicts[, artifact := artifact][]
}
model_view <- .lib_restrict_model_range(parent, type)
model_result <- close_view(model_view, "model_range")
if (nrow(model_result$removals)) {
row_i <- row_i + 1L
removal_rows[[row_i]] <- model_result$removals[, artifact := artifact][]
part_i <- part_i + 1L
quarantine_parts[[part_i]] <- .lib_quarantine_part(
parent, model_result$removals, artifact, type, min_n
)
remove_ids <- model_result$removals$spectrum_id
parent <- filter_spec(
parent, !as.character(.lib_ids(parent, "sample_name")) %in% remove_ids
)
}
if (nrow(model_result$conflicts)) {
conflict_i <- conflict_i + 1L
conflict_rows[[conflict_i]] <- model_result$conflicts[, artifact := artifact][]
}
classes <- as.character(parent$metadata$material_class)
class_keys <- tolower(trimws(classes))
support <- data.table::data.table(
material_class = classes,
resolved = !is.na(classes) & nzchar(classes) &
!class_keys %in% generic
)[resolved == TRUE, .N, by = material_class]
small <- support[N < min_n, material_class]
if (length(small)) {
drop <- which(classes %in% small)
ids <- as.character(.lib_ids(parent, "sample_name"))
counts <- support$N[match(classes[drop], support$material_class)]
floor_removals <- data.table::data.table(
phase = "final_closure", correlation_view = "global_support",
component_id = NA_character_, spectrum_id = ids[drop],
prior_class = classes[drop],
library_name = as.character(parent$metadata$library_name)[drop],
matched_id = NA_character_, matched_class = NA_character_,
matched_library = NA_character_, correlation = NA_real_, pool = type,
active_degree = 0L, matched_active_degree = 0L,
evidence_libraries = 0L, conflicting_spectra = 0L,
matched_evidence_libraries = 0L, decision_round = NA_integer_,
threshold = threshold, class_n_before = counts, class_n_after = 0L,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "global_support_at_risk",
reason = "class_below_global_min_n_after_closure"
)
row_i <- row_i + 1L
removal_rows[[row_i]] <- floor_removals[, artifact := artifact][]
part_i <- part_i + 1L
quarantine_parts[[part_i]] <- .lib_quarantine_part(
parent, floor_removals, artifact, type, min_n
)
parent <- filter_spec(parent, -drop)
}
libraries[[artifact]][[type]] <- parent
if (!is.null(report)) report(sprintf(
"final correlation closure %s/%s complete (retained=%d)",
artifact, type, ncol(parent$spectra)
))
}
}
list(
libraries = libraries,
removals = if (length(removal_rows)) {
data.table::rbindlist(removal_rows, fill = TRUE)
} else .lib_prune_removal_assessment_schema(),
conflicts = if (length(conflict_rows)) {
data.table::rbindlist(conflict_rows, fill = TRUE)
} else {
out <- .lib_prune_conflict_edge_schema()
out[, artifact := character()]
out
},
quarantine_parts = Filter(Negate(is.null), quarantine_parts),
support_drops = if (length(support_rows)) {
data.table::rbindlist(support_rows, fill = TRUE)
} else .lib_quality_schema()
)
}
.lib_build_medoids <- function(libraries, report, checkpoints = NULL,
progress = TRUE) {
processed <- intersect(c("derivative", "nobaseline"), names(libraries))
out <- lapply(processed, function(name) {
types <- libraries[[name]]
stats::setNames(lapply(names(types), function(type) {
stage <- paste0("medoid_", name, "_", type)
cached <- if (is.null(checkpoints)) NULL else checkpoints$get(stage)
if (!is.null(cached)) return(cached)
x <- .lib_restrict_model_range(types[[type]], type)
dropped <- attr(x, "identification_dropped_ids", exact = TRUE)
if (length(dropped)) report(sprintf(
paste0("discarded spectra below 10%% observed support ",
"(%s/%s; removed=%d; minimum=%d/%d wavenumbers)"),
name, type, length(dropped)
, attr(x, "identification_minimum_observed", exact = TRUE),
nrow(x$spectra)
))
x <- .lib_drop_range_flat_spectra(
x, artifact = paste0("medoid_", name), spectrum_type = type,
reason = "post_model_range_flat_spectrum", report = report
)
flat_drops <- attr(x, "range_flat_drops", exact = TRUE)
if (!is.null(flat_drops) && nrow(flat_drops)) {
dropped <- unique(c(dropped, flat_drops$spectrum_id))
}
report(sprintf(
"selecting medoids (%s/%s; spectra=%d; wavenumbers=%d; range=%g-%g)",
name, type, ncol(x$spectra), nrow(x$spectra),
min(x$wavenumber), max(x$wavenumber)
))
ids <- reduce_lib(
x,
group_cols = intersect(c("organization", "material_class"),
names(x$metadata)),
k = 50, min_n = 50, return = "ids",
progress = progress
)
result <- filter_spec(x, ids)
attr(result, "identification_range") <- range(x$wavenumber)
attr(result, "identification_support") <-
attr(x, "identification_support", exact = TRUE)
attr(result, "identification_dropped_ids") <- dropped
attr(result, "identification_minimum_observed") <-
attr(x, "identification_minimum_observed", exact = TRUE)
attr(result, "range_flat_drops") <- flat_drops
if (!is.null(checkpoints)) checkpoints$put(stage, result)
result
}), names(types))
})
names(out) <- processed
out
}
.lib_validate_medoid_parent_closure <- function(libraries, medoids, prune_spec,
report = NULL,
block_size = 128L) {
rows <- list()
row_i <- 0L
generic <- c("other", "other plastic", "other material", "unclassified")
for (artifact in intersect(names(medoids), names(libraries))) {
args <- if (is.null(prune_spec)) list(cross_class = TRUE) else prune_spec[[artifact]]
if (is.null(args)) args <- list()
if (!isTRUE(args$cross_class)) next
threshold <- if (is.null(args$cross_class_threshold)) 0.9 else
as.numeric(args$cross_class_threshold)
for (type in intersect(names(medoids[[artifact]]), names(libraries[[artifact]]))) {
parent <- .lib_restrict_model_range(libraries[[artifact]][[type]], type)
medoid <- medoids[[artifact]][[type]]
parent_ids <- as.character(.lib_ids(parent, "sample_name"))
medoid_ids <- as.character(.lib_ids(medoid, "sample_name"))
index <- match(medoid_ids, parent_ids)
if (anyNA(index)) {
stop("Medoid IDs are absent from the closed parent: ", artifact,
"/", type, call. = FALSE)
}
parent_classes <- as.character(parent$metadata$material_class)
medoid_classes <- as.character(medoid$metadata$material_class)
if (!identical(parent_classes[index], medoid_classes) ||
!identical(parent$wavenumber, medoid$wavenumber) ||
!isTRUE(all.equal(
parent$spectra[, index, drop = FALSE], medoid$spectra,
tolerance = 0, check.attributes = FALSE
))) {
stop("Medoids are not unchanged spectra from the closed parent: ",
artifact, "/", type, call. = FALSE)
}
parent_normalized <- .lib_prune_normalize(
parent$spectra, parent$wavenumber, exclude = NULL
)
medoid_normalized <- parent_normalized[index, , drop = FALSE]
eligible_parent <- !tolower(trimws(parent_classes)) %in% generic
eligible_medoid <- !tolower(trimws(medoid_classes)) %in% generic
eligible_parent[is.na(eligible_parent)] <- FALSE
eligible_medoid[is.na(eligible_medoid)] <- FALSE
maximum <- -Inf
wrong_pairs <- 0L
blocks <- split(
seq_along(parent_ids),
ceiling(seq_along(parent_ids) / as.integer(block_size))
)
for (block in blocks) {
cors <- tcrossprod(
parent_normalized[block, , drop = FALSE], medoid_normalized
)
different <- outer(
parent_classes[block], medoid_classes, FUN = "!="
)
different[is.na(different)] <- FALSE
valid <- outer(eligible_parent[block], eligible_medoid, FUN = "&") &
different
scores <- cors[valid & is.finite(cors)]
if (length(scores)) {
maximum <- max(maximum, max(scores))
wrong_pairs <- wrong_pairs + sum(scores > threshold)
}
rm(cors, different, valid, scores)
}
if (wrong_pairs > 0L) {
stop(
"Closed parent-to-medoid correlation invariant failed for ",
artifact, "/", type, " (", wrong_pairs, " pair(s) > ",
threshold, ")", call. = FALSE
)
}
row_i <- row_i + 1L
rows[[row_i]] <- data.table::data.table(
artifact = artifact, spectrum_type = type,
parent_spectra = length(parent_ids), medoid_spectra = length(medoid_ids),
threshold = threshold,
max_wrong_class_correlation = if (is.finite(maximum)) maximum else NA_real_,
wrong_class_pairs_above_threshold = wrong_pairs,
ids_unchanged = TRUE, classes_unchanged = TRUE,
spectra_unchanged = TRUE
)
if (!is.null(report)) report(sprintf(
"validated parent-to-medoid closure %s/%s (pairs>%g: %d)",
artifact, type, threshold, wrong_pairs
))
}
}
data.table::rbindlist(rows, fill = TRUE)
}
.lib_build_models <- function(libraries, medoids, report, checkpoints = NULL,
methods = "logistic_regression",
random_forest_args = list()) {
methods <- match.arg(
methods, c("logistic_regression", "random_forest"), several.ok = TRUE
)
if (!is.list(random_forest_args) ||
(length(random_forest_args) &&
(is.null(names(random_forest_args)) || any(!nzchar(names(random_forest_args)))))) {
stop("'random_forest_args' must be a named list", call. = FALSE)
}
models <- list()
warnings <- list()
configurations <- list(
logistic_regression = list(
source = medoids,
recipes = intersect(c("derivative", "nobaseline"), names(medoids)),
args = list()
),
random_forest = list(
source = libraries,
recipes = intersect(c("raw", "derivative", "nobaseline"),
names(libraries)),
args = random_forest_args
)
)
configurations <- configurations[methods]
for (algorithm in names(configurations)) {
configuration <- configurations[[algorithm]]
models[[algorithm]] <- list()
for (recipe in configuration$recipes) {
sources <- lapply(names(configuration$source[[recipe]]), function(type) {
.lib_restrict_model_range(configuration$source[[recipe]][[type]], type)
}) |> stats::setNames(names(configuration$source[[recipe]]))
# The historical logistic artifact retains its combined FTIR/Raman
# member. Probability forests are deployed as typed models, so fitting a
# second forest over the already-covered FTIR and Raman rows would only
# duplicate the two largest training jobs.
if (identical(algorithm, "logistic_regression") &&
all(c("ftir", "raman") %in% names(sources))) {
sources$both <- .lib_bind_same_axis(
list(sources$ftir, sources$raman),
label = paste0(recipe, " FTIR/Raman model input")
)
}
models[[algorithm]][[recipe]] <- list()
for (type in names(sources)) {
stage <- paste0(
paste("model", algorithm, recipe, type, sep = "_"),
if (identical(algorithm, "logistic_regression")) {
"_parallel_rng_v1"
} else {
""
}
)
cached <- if (is.null(checkpoints)) NULL else checkpoints$get(stage)
if (!is.null(cached)) {
models[[algorithm]][[recipe]][[type]] <- cached
cached_warnings <- attr(cached, "training_warnings", exact = TRUE)
if(length(cached_warnings)) warnings[[length(warnings) + 1L]] <-
data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = as.character(cached_warnings)
)
next
}
if (is.null(sources[[type]])) {
warnings[[length(warnings) + 1L]] <- data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = "No spectra were available for this technique"
)
models[[algorithm]][[recipe]][[type]] <- NULL
next
}
model_started <- proc.time()[["elapsed"]]
model_classes <- if("material_class" %in% names(sources[[type]]$metadata)) {
data.table::uniqueN(sources[[type]]$metadata$material_class,
na.rm = TRUE)
} else NA_integer_
report(sprintf(
paste0("training model (%s/%s/%s; spectra=%d; wavenumbers=%d; ",
"classes=%s)"),
algorithm, recipe, type, ncol(sources[[type]]$spectra),
nrow(sources[[type]]$spectra),
if(is.na(model_classes)) "unknown" else model_classes
))
training_warnings <- character()
models[[algorithm]][[recipe]][[type]] <- tryCatch(
withCallingHandlers(
do.call(
train_spec_model,
c(
list(sources[[type]], method = algorithm),
configuration$args
)
),
warning = function(condition) {
message <- conditionMessage(condition)
training_warnings <<- unique(c(training_warnings, message))
report(sprintf("model warning (%s/%s/%s): %s",
algorithm, recipe, type, message))
invokeRestart("muffleWarning")
}
),
error = function(error) {
warnings[[length(warnings) + 1L]] <<- data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = conditionMessage(error)
)
NULL
}
)
if(length(training_warnings)) {
warnings[[length(warnings) + 1L]] <- data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = training_warnings
)
}
if(!is.null(models[[algorithm]][[recipe]][[type]])) {
attr(models[[algorithm]][[recipe]][[type]], "training_warnings") <-
training_warnings
}
if (!is.null(checkpoints) &&
!is.null(models[[algorithm]][[recipe]][[type]])) {
checkpoints$put(stage, models[[algorithm]][[recipe]][[type]])
}
if (!is.null(models[[algorithm]][[recipe]][[type]])) {
fitted <- models[[algorithm]][[recipe]][[type]]
fill_replaced <- fitted$fill_replaced
if (is.null(fill_replaced)) fill_replaced <- 0L
if (identical(algorithm, "random_forest")) {
metrics <- fitted$oob_metrics
parameters <- fitted$training_parameters
report(sprintf(
paste0("model complete (%s/%s/%s; observations=%d; classes=%d; ",
"filled=%d; trees=%d; mtry=%d; OOB macro accuracy=%.4f; %.1fs)"),
algorithm, recipe, type, fitted$observation_count,
fitted$class_num, fill_replaced, parameters$num_trees,
parameters$mtry, metrics$macro_class_accuracy,
proc.time()[["elapsed"]] - model_started
))
} else {
report(sprintf(
paste0("model complete (%s/%s/%s; observations=%d; classes=%d; ",
"filled=%d; lambda=%.6g by macro class accuracy; %.1fs)"),
algorithm, recipe, type, fitted$observation_count,
fitted$class_num, fill_replaced, fitted$lambda_selected,
proc.time()[["elapsed"]] - model_started
))
}
}
}
}
}
list(
models = models,
warnings = if (length(warnings)) {
data.table::rbindlist(warnings, fill = TRUE)
} else {
.lib_warning_schema()
}
)
}
.lib_restrict_model_range <- function(x, type) {
type <- tolower(type)
if (type %in% c("ftir", "raman")) {
limits <- c(800, 3200)
} else if (identical(type, "nir")) {
finite_fraction <- rowMeans(is.finite(x$spectra))
usable <- x$wavenumber >= 4000 & x$wavenumber <= 12000 &
finite_fraction >= 0.9
if (!any(usable)) {
usable <- x$wavenumber >= 4000 & x$wavenumber <= 12000 &
finite_fraction > 0
}
runs <- rle(usable)
candidates <- which(runs$values)
if (!length(candidates)) {
stop("NIR spectra have no finite values in 4000-12000", call. = FALSE)
}
run <- candidates[which.max(runs$lengths[candidates])]
ends <- cumsum(runs$lengths)
starts <- ends - runs$lengths + 1L
indices <- seq.int(starts[run], ends[run])
limits <- range(x$wavenumber[indices])
} else {
stop("Unsupported spectrum type: ", type, call. = FALSE)
}
out <- restrict_range(
x, min = limits[1L], max = limits[2L], make_rel = FALSE
)
supported <- .lib_filter_spectral_support(out, min_fraction = 0.1)
out <- supported$object
attr(out, "identification_range") <- limits
out
}
.lib_bind_same_axis <- function(objects, label = "objects") {
objects <- Filter(Negate(is.null), objects)
if (!length(objects)) return(NULL)
axes <- lapply(objects, `[[`, "wavenumber")
if (!all(vapply(axes[-1L], identical, logical(1), axes[[1L]]))) {
stop(label, " do not share an identical wavenumber axis", call. = FALSE)
}
out <- objects[[1L]]
out$spectra <- do.call(cbind, lapply(objects, `[[`, "spectra"))
out$metadata <- data.table::rbindlist(
lapply(objects, `[[`, "metadata"), fill = TRUE
)
out <- as_OpenSpecy(out)
out
}
.lib_filter_optional_type <- function(x, type) {
if (!is_OpenSpecy(x) && is.list(x) && length(x) && !is.null(names(x))) {
index <- match(tolower(type), tolower(names(x)))
if (is.na(index)) return(NULL)
candidate <- x[[index]]
if (!is_OpenSpecy(candidate)) {
stop("Typed reference-library component '", names(x)[[index]],
"' is not an OpenSpecy object", call. = FALSE)
}
return(candidate)
}
if (!is_OpenSpecy(x)) return(NULL)
keep <- !is.na(x$metadata$spectrum_type) &
tolower(x$metadata$spectrum_type) == type
if (!any(keep)) return(NULL)
filter_spec(x, keep)
}
.lib_recover_library_assessments <- function(libraries, tables) {
artifacts <- .lib_named_typed_objects(libraries)
collect_enrichment <- function(attribute, field) {
data.table::rbindlist(lapply(names(artifacts), function(name) {
report <- attr(artifacts[[name]], attribute, exact = TRUE)
if (is.null(report) || is.null(report[[field]]) ||
!nrow(report[[field]])) return(NULL)
out <- data.table::copy(report[[field]])
out[, artifact := name]
out
}), fill = TRUE)
}
material_form_enrichment <- collect_enrichment(
"material_form_enrichment_report", "summary"
)
material_form_matches <- collect_enrichment(
"material_form_enrichment_report", "matches"
)
material_form_clashes <- collect_enrichment(
"material_form_enrichment_report", "clashes"
)
common_use_enrichment <- collect_enrichment(
"common_use_enrichment_report", "summary"
)
common_use_coverage <- collect_enrichment(
"common_use_enrichment_report", "coverage"
)
prediction <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "class_prediction_report")
if (is.null(report) || is.null(report$summary)) return(NULL)
data.table::data.table(
artifact = name, metric = names(report$summary),
value = as.numeric(unlist(report$summary, use.names = FALSE))
)
}), fill = TRUE)
coverage <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "class_coverage_report")
if (is.null(report)) return(NULL)
out <- data.table::copy(data.table::as.data.table(report))
out[, artifact := name]
out
}), fill = TRUE)
type_coverage <- data.table::rbindlist(lapply(names(libraries), function(name) {
metadata <- libraries[[name]]$metadata
data.table::data.table(
artifact = name, field = c("library_type", "spectrum_type"),
populated = c(
sum(!is.na(metadata$library_type) & nzchar(metadata$library_type)),
sum(!is.na(metadata$spectrum_type) & nzchar(metadata$spectrum_type))
), total = nrow(metadata)
)
}))
pruning <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$summary)) return(NULL)
out <- data.table::copy(report$summary)
out[, artifact := name]
out
}), fill = TRUE)
pruning_excluded_classes <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$excluded_classes) ||
!nrow(report$excluded_classes)) return(NULL)
out <- data.table::copy(report$excluded_classes)
out[, artifact := name]
data.table::setcolorder(
out, c("artifact", setdiff(names(out), "artifact"))
)
out
}
), fill = TRUE)
if (!nrow(pruning_excluded_classes)) {
pruning_excluded_classes <- .lib_prune_excluded_assessment_schema()
}
other_review <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "other_review_report")
if (is.null(report) || !nrow(report)) return(NULL)
data.table::copy(report)
}), fill = TRUE)
if (!nrow(other_review)) other_review <- .lib_other_review_schema()
other_filter <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "other_filter_report")
if (is.null(report) || !nrow(report)) return(NULL)
data.table::copy(report)
}), fill = TRUE)
if (!nrow(other_filter)) other_filter <- .lib_other_filter_schema()
pruning_reassignments <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$reassignments) ||
!nrow(report$reassignments)) return(NULL)
data.table::copy(report$reassignments)[, artifact := name][]
}
), fill = TRUE)
if (!nrow(pruning_reassignments)) {
pruning_reassignments <- .lib_prune_reassignment_schema()
}
pruning_removals <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$removals) ||
!nrow(report$removals)) return(NULL)
out <- data.table::copy(report$removals)
out[, artifact := name]
data.table::setcolorder(
out, c("artifact", setdiff(names(out), "artifact"))
)
out
}
), fill = TRUE)
if (!nrow(pruning_removals)) {
pruning_removals <- .lib_prune_removal_assessment_schema()
}
pruning_conflicts <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$cross_class_conflicts) ||
!nrow(report$cross_class_conflicts)) return(NULL)
out <- data.table::copy(report$cross_class_conflicts)
out[, artifact := name]
out
}
), fill = TRUE)
if (!nrow(pruning_conflicts)) {
pruning_conflicts <- .lib_prune_conflict_edge_schema()
pruning_conflicts[, artifact := character()]
}
raw_coverage <- attr(libraries$raw, "class_coverage_report")
before_filter <- if (is.null(raw_coverage) || nrow(raw_coverage) == 0L) {
NA_integer_
} else {
as.integer(raw_coverage$total[[nrow(raw_coverage)]])
}
after_filter <- ncol(libraries$raw$spectra)
metadata_drop <- data.table::data.table(
metadata_column = tables$metadata_drop$metadata_column,
status = ifelse(
tables$metadata_drop$metadata_column %in% names(libraries$raw$metadata),
"retained", "removed_or_absent"
)
)
dropped_spectrum_identities <- data.table::rbindlist(lapply(
libraries, function(object) {
attr(object, "dropped_spectrum_identities", exact = TRUE)
}
), fill = TRUE)
if (!"spectrum_identity" %in% names(dropped_spectrum_identities)) {
dropped_spectrum_identities <- data.table::data.table(
spectrum_identity = character()
)
} else {
dropped_spectrum_identities <- dropped_spectrum_identities[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(spectrum_identity)))
]
}
list(
class_prediction = prediction,
class_coverage = coverage,
type_coverage = type_coverage,
material_form_enrichment = material_form_enrichment,
material_form_matches = material_form_matches,
material_form_clashes = material_form_clashes,
common_use_enrichment = common_use_enrichment,
common_use_coverage = common_use_coverage,
other_review = other_review,
other_filter = other_filter,
pruning = pruning,
pruning_excluded_classes = pruning_excluded_classes,
pruning_reassignments = pruning_reassignments,
pruning_removals = pruning_removals,
pruning_conflicts = pruning_conflicts,
filters = data.table::data.table(
stage = "special_filter", before = before_filter,
after = after_filter,
removed = if (is.na(before_filter)) NA_integer_ else
before_filter - after_filter
),
metadata_drop = metadata_drop,
library_retention = .lib_library_retention_report(list(
.lib_library_stage_counts(libraries, stage = "final")
)),
dropped_spectrum_identities = dropped_spectrum_identities
)
}
.lib_model_assessment_tables <- function(models) {
table_fields <- c(
"tests", "lambda_metrics", "oob_metrics", "oob_class_accuracy",
"feature_importance", "training_parameters", "class_weights"
)
out <- stats::setNames(vector("list", length(table_fields)), table_fields)
for (algorithm in names(models)) {
for (recipe in names(models[[algorithm]])) {
for (type in names(models[[algorithm]][[recipe]])) {
model <- models[[algorithm]][[recipe]][[type]]
if (is.null(model)) next
for (field in table_fields) {
value <- model[[field]]
if (is.null(value) || !length(value)) next
value <- data.table::copy(data.table::as.data.table(value))
if (!nrow(value)) next
value[, `:=`(
algorithm = algorithm, artifact = recipe, model = type
)]
data.table::setcolorder(
value,
c("algorithm", "artifact", "model",
setdiff(names(value), c("algorithm", "artifact", "model")))
)
out[[field]][[length(out[[field]]) + 1L]] <- value
}
}
}
}
lapply(out, function(rows) {
if (!length(rows)) return(data.table::data.table())
data.table::rbindlist(rows, fill = TRUE, use.names = TRUE)
})
}
.lib_collect_automated_test_flags <- function(libraries) {
rows <- lapply(names(libraries), function(artifact) {
object <- libraries[[artifact]]
if (!is_OpenSpecy(object)) return(NULL)
metadata <- data.table::as.data.table(object$metadata)
required <- c("assessment_flag", "assessment_checks")
if (!all(required %in% names(metadata))) return(NULL)
keep <- !is.na(metadata$assessment_flag) & metadata$assessment_flag &
!is.na(metadata$assessment_checks) &
nzchar(trimws(metadata$assessment_checks))
if (!any(keep)) return(NULL)
ids <- .lib_ids(object, "sample_name")
technique <- if ("spectrum_type" %in% names(metadata)) {
as.character(metadata$spectrum_type)
} else {
rep("all", nrow(metadata))
}
checks <- strsplit(as.character(metadata$assessment_checks[keep]),
";\\s*")
data.table::data.table(
artifact = artifact,
technique = rep(technique[keep], lengths(checks)),
spectrum_id = rep(as.character(ids[keep]), lengths(checks)),
error_mode = trimws(unlist(checks, use.names = FALSE))
)[nzchar(error_mode)]
})
out <- unique(data.table::rbindlist(rows, fill = TRUE))
if (nrow(out)) return(out[])
data.table::data.table(
artifact = character(), technique = character(),
spectrum_id = character(), error_mode = character()
)
}
.lib_local_build_assessments <- function(libraries, medoids, models,
completed, model_warnings) {
artifacts <- c(
.lib_named_typed_objects(libraries),
.lib_named_typed_objects(medoids, prefix = "medoid_")
)
summary <- data.table::rbindlist(lapply(names(artifacts), function(name) {
data.table::data.table(
artifact = name,
valid_OpenSpecy = suppressWarnings(check_OpenSpecy(artifacts[[name]])),
spectra = ncol(artifacts[[name]]$spectra),
wavenumbers = length(artifacts[[name]]$wavenumber),
metadata_columns = ncol(artifacts[[name]]$metadata)
)
}), fill = TRUE)
model_summary <- data.table::rbindlist(lapply(names(models), function(algorithm) {
data.table::rbindlist(lapply(names(models[[algorithm]]), function(recipe) {
data.table::rbindlist(lapply(names(models[[algorithm]][[recipe]]), function(type) {
model <- models[[algorithm]][[recipe]][[type]]
oob <- if (is.null(model)) NULL else model$oob_metrics
data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
trained = !is.null(model),
classes = if (is.null(model)) NA_integer_ else model$class_num,
observations = if (is.null(model)) NA_integer_ else
model$observation_count,
fill_replaced = if (is.null(model)) NA_integer_ else
model$fill_replaced,
lambda_selected = if (is.null(model)) NA_real_ else
model$lambda_selected,
oob_accuracy = if (is.null(oob)) NA_real_ else oob$accuracy,
oob_macro_class_accuracy = if (is.null(oob)) NA_real_ else
oob$macro_class_accuracy,
oob_brier_score = if (is.null(oob)) NA_real_ else
oob$brier_score
)
}), fill = TRUE)
}), fill = TRUE)
}), fill = TRUE)
support_rows <- list()
class_support_rows <- list()
for (recipe in names(medoids)) {
for (type in names(medoids[[recipe]])) {
audit <- attr(
medoids[[recipe]][[type]], "identification_support", exact = TRUE
)
if (is.null(audit)) next
audit <- data.table::copy(audit)
audit[, `:=`(stage = "medoid", algorithm = NA_character_,
artifact = recipe, model = type)]
support_rows[[length(support_rows) + 1L]] <- audit
}
}
for (algorithm in names(models)) {
for (recipe in names(models[[algorithm]])) {
for (type in names(models[[algorithm]][[recipe]])) {
model <- models[[algorithm]][[recipe]][[type]]
if (is.null(model) || is.null(model$support)) next
audit <- data.table::copy(model$support)
audit[, `:=`(stage = "model", algorithm = algorithm,
artifact = recipe, model = type)]
support_rows[[length(support_rows) + 1L]] <- audit
if (!is.null(model$class_support)) {
class_audit <- data.table::copy(model$class_support)
class_audit[, `:=`(algorithm = algorithm, artifact = recipe,
model = type)]
class_support_rows[[length(class_support_rows) + 1L]] <- class_audit
}
}
}
}
support <- if (length(support_rows)) {
data.table::rbindlist(support_rows, fill = TRUE)
} else {
out <- .lib_support_schema()
out[, `:=`(stage = character(), algorithm = character(), artifact = character(),
model = character())]
data.table::setcolorder(
out, c("stage", "algorithm", "artifact", "model", setdiff(names(out),
c("stage", "algorithm", "artifact", "model")))
)
out
}
class_support <- if (length(class_support_rows)) {
data.table::rbindlist(class_support_rows, fill = TRUE)
} else {
data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
class = character(),
spectra = integer(), minimum_spectra = integer(), retained = logical()
)
}
library_artifacts <- .lib_named_typed_objects(libraries)
lookup_coverage <- data.table::rbindlist(lapply(names(library_artifacts), function(name) {
reports <- attr(library_artifacts[[name]], "metadata_lookup_reports")
if (is.null(reports) || length(reports) == 0L) return(NULL)
data.table::rbindlist(lapply(names(reports), function(stage) {
out <- data.table::copy(reports[[stage]])
out[, `:=`(artifact = name, stage = stage)]
out
}), fill = TRUE)
}), fill = TRUE)
identity_cleanup <- data.table::rbindlist(lapply(names(library_artifacts), function(name) {
out <- attr(library_artifacts[[name]], "spectrum_identity_cleanup_report")
if (is.null(out) || nrow(out) == 0L) return(NULL)
out <- data.table::copy(out)
out[, artifact := name]
out
}), fill = TRUE)
exclusions <- data.table::rbindlist(lapply(names(library_artifacts), function(name) {
out <- attr(library_artifacts[[name]], "build_stage_report")
if (is.null(out) || nrow(out) == 0L) return(NULL)
out <- data.table::copy(out)
out[, artifact := name]
out
}), fill = TRUE)
model_tables <- .lib_model_assessment_tables(models)
defaults <- list(
build_summary = summary,
lookup_coverage = lookup_coverage,
identity_cleanup = identity_cleanup,
class_prediction = data.table::data.table(),
class_coverage = data.table::data.table(),
type_coverage = data.table::data.table(),
material_form_enrichment = data.table::data.table(),
material_form_matches = data.table::data.table(),
material_form_clashes = data.table::data.table(),
common_use_enrichment = data.table::data.table(),
common_use_coverage = data.table::data.table(),
other_review = .lib_other_review_schema(),
other_filter = .lib_other_filter_schema(),
exclusions_deduplication = exclusions,
filters = data.table::data.table(),
metadata_drop = data.table::data.table(),
metadata_finalization = .lib_metadata_finalization_schema(),
pruning = data.table::data.table(),
pruning_excluded_classes = .lib_prune_excluded_assessment_schema(),
pruning_reassignments = .lib_prune_reassignment_schema(),
pruning_removals = .lib_prune_removal_assessment_schema(),
pruning_conflicts = .lib_prune_conflict_edge_schema(),
correlation_closure = data.table::data.table(),
medoid_model_summary = model_summary,
medoid_model_support = support,
model_class_support = class_support,
model_training_tests = model_tables$tests,
model_lambda_metrics = model_tables$lambda_metrics,
model_oob_metrics = model_tables$oob_metrics,
model_oob_class_accuracy = model_tables$oob_class_accuracy,
model_feature_importance = model_tables$feature_importance,
model_training_parameters = model_tables$training_parameters,
model_class_weights = model_tables$class_weights,
split_manifest = data.table::data.table(),
library_identification = data.table::data.table(),
library_confusion = data.table::data.table(),
model_identification = data.table::data.table(),
model_confusion = data.table::data.table(),
model_assessment_correlations =
.lib_model_assessment_correlation_schema(),
automated_test_flags = data.table::data.table(
artifact = character(), technique = character(),
spectrum_id = character(), error_mode = character()
),
assess_spec_shifts = data.table::data.table(),
old_new_compatibility = data.table::data.table(),
quality_control = .lib_quality_schema(),
library_retention = data.table::data.table(),
dropped_spectrum_identities = data.table::data.table(
spectrum_identity = character()
),
warnings = if (nrow(model_warnings)) model_warnings else
.lib_warning_schema(),
output_manifest = data.table::data.table()
)
if (!is.null(completed)) defaults[names(completed)] <- completed
range_flat <- data.table::rbindlist(lapply(
c(
.lib_named_typed_objects(libraries),
.lib_named_typed_objects(medoids, prefix = "medoid_")
),
function(object) attr(object, "range_flat_drops", exact = TRUE)
), fill = TRUE)
if (nrow(range_flat)) {
defaults$quality_control <- unique(data.table::rbindlist(
list(defaults$quality_control, range_flat), fill = TRUE
))
range_flat_identities <- range_flat[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity)
]
defaults$dropped_spectrum_identities <- data.table::rbindlist(
list(defaults$dropped_spectrum_identities, range_flat_identities),
fill = TRUE
)[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(as.character(spectrum_identity))))
]
}
defaults
}
.lib_bind_assessment_tables <- function(assessments, table_names) {
rows <- lapply(intersect(table_names, names(assessments)), function(name) {
value <- assessments[[name]]
if (!inherits(value, c("data.frame", "data.table")) || !nrow(value)) {
return(NULL)
}
value <- data.table::copy(data.table::as.data.table(value))
value[, assessment_kind := name]
data.table::setcolorder(
value, c("assessment_kind", setdiff(names(value), "assessment_kind"))
)
value
})
data.table::rbindlist(rows, fill = TRUE, use.names = TRUE)
}
.lib_pivot_assessment_sources <- function(x, id_cols, value_cols,
shift_cols = character()) {
if (is.null(x) || !nrow(x)) return(data.table::data.table())
x <- data.table::copy(data.table::as.data.table(x))
id_cols <- intersect(id_cols, names(x))
value_cols <- intersect(value_cols, names(x))
if (!"source" %in% names(x) || !length(id_cols) || !length(value_cols)) {
return(x)
}
x <- x[source %in% c("old", "new")]
if (!nrow(x)) return(data.table::data.table())
duplicate_key <- c(id_cols, "source")
if (anyDuplicated(x[, ..duplicate_key])) {
stop("Assessment rows are not unique for old/new pivot keys",
call. = FALSE)
}
formula <- stats::as.formula(paste(paste(id_cols, collapse = " + "),
"~ source"))
out <- data.table::copy(data.table::dcast(
x, formula, value.var = value_cols, sep = "_", drop = TRUE
))
template <- x[0]
for (metric in value_cols) {
for (source in c("old", "new")) {
column <- paste0(metric, "_", source)
if (!column %in% names(out)) {
prototype <- template[[metric]]
value <- if (is.integer(prototype)) NA_integer_ else if (
is.numeric(prototype)
) NA_real_ else if (is.logical(prototype)) NA else NA_character_
data.table::set(out, j = column, value = value)
}
}
if (metric %in% shift_cols) {
data.table::set(
out, j = paste0(metric, "_shift"),
value = out[[paste0(metric, "_new")]] -
out[[paste0(metric, "_old")]]
)
}
}
paired <- unlist(lapply(value_cols, function(metric) {
columns <- c(paste0(metric, "_old"), paste0(metric, "_new"))
if (metric %in% shift_cols) columns <- c(columns, paste0(metric, "_shift"))
columns
}), use.names = FALSE)
data.table::setcolorder(out, c(id_cols, paired, setdiff(names(out), c(id_cols, paired))))
out[]
}
.lib_accuracy_review <- function(summary, medoid = FALSE) {
summary <- data.table::copy(data.table::as.data.table(summary))
if (!nrow(summary) || !"artifact" %in% names(summary)) {
return(data.table::data.table())
}
is_medoid <- grepl("^medoid_", summary$artifact)
out <- summary[is_medoid == medoid]
if (!nrow(out)) return(out)
out[, `:=`(
overall_accuracy_pct = 100 * overall_accuracy,
macro_class_accuracy_pct = 100 * macro_class_accuracy,
class_count = as.integer(evaluated_classes)
)]
keep <- intersect(c(
"algorithm", "artifact", "model", "technique", "source", "provenance",
"spectra", "class_count", "overall_accuracy_pct",
"macro_class_accuracy_pct"
), names(out))
out <- out[, ..keep]
out[, .source_order := match(source, c("old", "new"))]
data.table::setorderv(
out, intersect(c("algorithm", "artifact", "model", "technique",
".source_order"), names(out)),
rep(1L, length(intersect(
c("algorithm", "artifact", "model", "technique", ".source_order"),
names(out)
)))
)
out[, .source_order := NULL]
out[]
}
.lib_confusion_review <- function(confusion, medoid = NULL) {
rows <- data.table::copy(data.table::as.data.table(confusion))
if (!nrow(rows)) return(data.table::data.table())
if (!is.null(medoid)) {
is_medoid <- grepl("^medoid_", rows$artifact)
rows <- rows[is_medoid == medoid]
}
out <- rows[misidentified %in% TRUE]
if (!nrow(out)) return(out)
out[is.na(predicted_class) | !nzchar(predicted_class),
predicted_class := "unclassified"]
out[, expected_class_pct := 100 * expected_class_fraction]
keep <- intersect(c(
"algorithm", "artifact", "model", "technique", "source", "provenance",
"expected_class", "predicted_class", "spectra",
"expected_class_spectra", "expected_class_pct"
), names(out))
out <- out[, ..keep]
data.table::setorderv(
out,
intersect(c("algorithm", "artifact", "model", "technique", "source",
"spectra", "expected_class", "predicted_class"), names(out)),
c(rep(1L, length(intersect(
c("algorithm", "artifact", "model", "technique", "source"), names(out)
))), -1L, 1L, 1L)
)
out[]
}
.lib_model_diagnostics_review <- function(assessments) {
out <- data.table::copy(data.table::as.data.table(
assessments$model_assessment_correlations
))
if (nrow(out)) data.table::setorderv(
out, c("accuracy_difference_pct", "algorithm", "artifact", "model",
"technique", "error_mode"), c(1L, 1L, 1L, 1L, 1L, 1L)
)
out[]
}
.lib_cleanup_review <- function(assessments, table_names) {
rows <- lapply(intersect(table_names, names(assessments)), function(name) {
value <- assessments[[name]]
if (!inherits(value, c("data.frame", "data.table")) || !nrow(value)) {
return(NULL)
}
value <- data.table::as.data.table(value)
data.table::data.table(
assessment = name,
rows = as.integer(nrow(value)),
artifacts = as.integer(if ("artifact" %in% names(value)) {
data.table::uniqueN(value$artifact, na.rm = TRUE)
} else 0L),
spectrum_records = as.integer(if ("spectrum_id" %in% names(value)) {
data.table::uniqueN(value$spectrum_id, na.rm = TRUE)
} else if ("n" %in% names(value)) {
sum(value$n, na.rm = TRUE)
} else 0L),
removed_spectra = as.integer(if ("removed" %in% names(value)) {
sum(as.numeric(value$removed), na.rm = TRUE)
} else if ("spectra_removed" %in% names(value)) {
sum(value$spectra_removed, na.rm = TRUE)
} else 0L)
)
})
out <- data.table::rbindlist(rows, fill = TRUE)
if (nrow(out)) data.table::setorder(out, assessment)
out[]
}
.lib_functionality_review <- function(shifts) {
shifts <- data.table::copy(data.table::as.data.table(shifts))
if (!nrow(shifts)) return(data.table::data.table())
for (column in c("rate_old", "rate_new")) {
if (!column %in% names(shifts)) shifts[[column]] <- 0
shifts[is.na(get(column)), (column) := 0]
}
out <- shifts[, .(
artifact, check,
old_error_pct = 100 * rate_old,
new_error_pct = 100 * rate_new,
change_pct = 100 * (rate_new - rate_old)
)]
data.table::setorderv(out, c("change_pct", "artifact", "check"),
c(-1L, 1L, 1L))
out[]
}
.lib_assessment_review <- function(assessments) {
if (is.list(assessments) && identical(
names(assessments), c("cleanup", "ref_lib", "medoid", "model", "functionality")
)) return(assessments)
cleanup_names <- c(
"lookup_coverage", "identity_cleanup", "class_prediction", "class_coverage",
"type_coverage", "material_form_enrichment", "material_form_matches",
"material_form_clashes", "common_use_enrichment", "common_use_coverage",
"other_review", "other_filter", "exclusions_deduplication",
"filters", "metadata_drop", "metadata_finalization", "pruning",
"pruning_excluded_classes", "pruning_reassignments", "pruning_removals",
"pruning_conflicts", "correlation_closure",
"quality_control",
"library_retention"
)
cleanup_summary <- data.table::copy(data.table::as.data.table(
assessments$library_retention
))
if (nrow(cleanup_summary)) {
if ("reason" %in% names(cleanup_summary)) {
cleanup_summary[is.na(reason) | !nzchar(trimws(reason)),
reason := "retained"]
}
cleanup_summary[, assessment_kind := "library_retention"]
data.table::setcolorder(
cleanup_summary,
c("assessment_kind", setdiff(names(cleanup_summary), "assessment_kind"))
)
} else {
cleanup_summary <- .lib_cleanup_review(assessments, cleanup_names)
}
dropped <- assessments$dropped_spectrum_identities
if (is.null(dropped) || !nrow(dropped)) {
dropped <- data.table::data.table(spectrum_identity = character())
} else {
dropped <- data.table::data.table(
spectrum_identity = sort(unique(as.character(dropped$spectrum_identity)))
)[!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity))]
}
ref_accuracy <- .lib_accuracy_review(
assessments$library_identification, medoid = FALSE
)
medoid_accuracy <- .lib_accuracy_review(
assessments$library_identification, medoid = TRUE
)
ref_confusion <- .lib_confusion_review(
assessments$library_confusion, medoid = FALSE
)
medoid_confusion <- .lib_confusion_review(
assessments$library_confusion, medoid = TRUE
)
model_accuracy <- .lib_accuracy_review(assessments$model_identification)
model_confusion <- .lib_confusion_review(assessments$model_confusion)
model_diagnostics <- .lib_model_diagnostics_review(assessments)
functionality <- .lib_functionality_review(assessments$assess_spec_shifts)
compact <- function(values) {
values[vapply(values, function(value) {
inherits(value, c("data.frame", "data.table")) && nrow(value) > 0L
}, logical(1))]
}
out <- list(
cleanup = compact(list(
summary = cleanup_summary,
dropped_spectrum_identities = dropped
)),
ref_lib = compact(list(accuracy = ref_accuracy, confusion = ref_confusion)),
medoid = compact(list(accuracy = medoid_accuracy, confusion = medoid_confusion)),
model = compact(list(
accuracy = model_accuracy, confusion = model_confusion,
error_mode_accuracy = model_diagnostics
)),
functionality = compact(list(comparison = functionality))
)
fallback <- c(
cleanup = "summary", ref_lib = "accuracy", medoid = "accuracy",
model = "error_mode_accuracy", functionality = "comparison"
)
for (process in names(out)) {
if (!length(out[[process]])) {
out[[process]][[fallback[[process]]]] <- data.table::data.table(
status = "not_available_for_this_build"
)
}
}
evidence_names <- intersect(
c("split_manifest", "library_tests", "model_training_tests", "model_tests",
"model_lambda_metrics", "model_oob_metrics", "model_oob_class_accuracy",
"model_feature_importance", "model_training_parameters",
"model_class_weights", "medoid_model_summary", "medoid_model_support",
"model_class_support", "warnings", "old_new_compatibility",
"build_summary", "assess_spec_shifts", "output_manifest",
"pruning_conflicts", "correlation_closure"),
names(assessments)
)
evidence <- assessments[evidence_names]
attr(evidence, "sha256") <- vapply(evidence, digest::digest, character(1),
algo = "sha256")
attr(out, "assessment_schema_version") <- "2.0.0"
attr(out, "evidence") <- evidence
attr(out, "upstream_assessments") <- assessments[intersect(
cleanup_names, names(assessments)
)]
out
}
.lib_named_typed_objects <- function(x, prefix = "") {
out <- list()
for (recipe in names(x)) {
item <- x[[recipe]]
if (is_OpenSpecy(item)) {
out[[paste0(prefix, recipe)]] <- item
} else if (is.list(item)) {
for (type in names(item)) {
if (is_OpenSpecy(item[[type]])) {
out[[paste0(prefix, recipe, "_", type)]] <- item[[type]]
}
}
}
}
out
}
.lib_metadata_finalization_schema <- function() {
data.table::data.table(
artifact = character(), spectra = integer(), before_columns = integer(),
after_columns = integer(), dropped_columns = integer(),
dropped_names = character(), minimum_missing = integer(),
maximum_missing = integer()
)
}
.lib_finalize_one_metadata <- function(x, artifact) {
if (!is_OpenSpecy(x)) {
stop("Metadata finalization requires an OpenSpecy object", call. = FALSE)
}
metadata <- data.table::copy(x$metadata)
before <- ncol(metadata)
missing <- vapply(metadata, function(column) {
as.integer(sum(is.na(column)))
}, integer(1L))
fully_missing <- if (nrow(metadata)) {
names(missing)[missing == nrow(metadata)]
} else {
character()
}
fully_missing <- setdiff(
fully_missing, c("material_form", "common_use")
)
if (length(fully_missing)) metadata[, (fully_missing) := NULL]
remaining_missing <- missing[setdiff(names(missing), fully_missing)]
if (length(remaining_missing)) {
ordered <- names(remaining_missing)[order(
remaining_missing, seq_along(remaining_missing)
)]
data.table::setcolorder(metadata, ordered)
}
out <- x
out$metadata <- metadata
if (!check_OpenSpecy(out)) {
stop("Metadata finalization broke the OpenSpecy object contract for '",
artifact, "'", call. = FALSE)
}
assessment <- data.table::data.table(
artifact = artifact,
spectra = as.integer(nrow(metadata)),
before_columns = as.integer(before),
after_columns = as.integer(ncol(metadata)),
dropped_columns = as.integer(length(fully_missing)),
dropped_names = paste(fully_missing, collapse = "; "),
minimum_missing = if (length(remaining_missing)) {
as.integer(min(remaining_missing))
} else {
NA_integer_
},
maximum_missing = if (length(remaining_missing)) {
as.integer(max(remaining_missing))
} else {
NA_integer_
}
)
list(object = out, assessment = assessment)
}
.lib_finalize_reference_metadata <- function(libraries, medoids) {
assessment <- list()
finalize <- function(collection, prefix = "") {
for (recipe in names(collection)) {
for (type in names(collection[[recipe]])) {
if (!is_OpenSpecy(collection[[recipe]][[type]])) next
artifact <- paste0(prefix, recipe, "_", type)
result <- .lib_finalize_one_metadata(
collection[[recipe]][[type]], artifact
)
collection[[recipe]][[type]] <- result$object
assessment[[artifact]] <<- result$assessment
}
}
collection
}
libraries <- finalize(libraries)
medoids <- finalize(medoids, prefix = "medoid_")
list(
libraries = libraries,
medoids = medoids,
assessment = if (length(assessment)) {
data.table::rbindlist(assessment, fill = TRUE)
} else {
.lib_metadata_finalization_schema()
}
)
}
.lib_model_assessment_correlation_schema <- function() {
data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
technique = character(), error_mode = character(),
with_error_accuracy_pct = numeric(),
without_error_accuracy_pct = numeric(),
accuracy_difference_pct = numeric()
)
}
.lib_model_assessment_correlations <- function(tests, flags) {
schema <- .lib_model_assessment_correlation_schema()
if (is.null(tests) || !nrow(tests) || is.null(flags) || !nrow(flags)) {
return(schema)
}
tests <- data.table::copy(data.table::as.data.table(tests))
flags <- unique(data.table::copy(data.table::as.data.table(flags)))
test_required <- c(
"algorithm", "artifact", "model", "source", "technique",
"spectrum_id", "correct"
)
flag_required <- c("artifact", "technique", "spectrum_id", "error_mode")
missing <- c(setdiff(test_required, names(tests)),
setdiff(flag_required, names(flags)))
if (length(missing)) {
stop("Model error-mode assessment rows are missing: ",
paste(unique(missing), collapse = ", "), call. = FALSE)
}
tests <- tests[source == "new" & !is.na(correct), ..test_required]
flags <- flags[
!is.na(error_mode) & nzchar(trimws(error_mode)), ..flag_required
]
modes <- unique(flags[, .(artifact, technique, error_mode)])
if (!nrow(tests) || !nrow(modes)) return(schema)
rows <- merge(
tests, modes, by = c("artifact", "technique"), allow.cartesian = TRUE
)
flags[, has_error := TRUE]
rows <- merge(
rows, flags,
by = c("artifact", "technique", "spectrum_id", "error_mode"),
all.x = TRUE, sort = FALSE
)
rows[is.na(has_error), has_error := FALSE]
groups <- c("algorithm", "artifact", "model", "technique", "error_mode")
out <- rows[, .(
error_spectra = as.integer(sum(has_error)),
with_error_accuracy_pct = 100 * mean(correct[has_error]),
no_error_spectra = as.integer(sum(!has_error)),
without_error_accuracy_pct = 100 * mean(correct[!has_error])
), by = groups]
out <- out[error_spectra > 0L & no_error_spectra > 0L]
if (!nrow(out)) return(schema)
out[, accuracy_difference_pct :=
with_error_accuracy_pct - without_error_accuracy_pct]
out[, c("error_spectra", "no_error_spectra") := NULL]
data.table::setcolorder(out, names(schema))
data.table::setorderv(
out, c("accuracy_difference_pct", groups),
c(1L, rep(1L, length(groups)))
)
out[]
}
.lib_previous_signature <- function(path) {
if (is.null(path)) return("none")
resolved <- if (identical(path, "system")) {
system.file("extdata", package = "OpenSpecy")
} else {
path
}
types <- c(
"raw", "derivative", "nobaseline", "medoid_derivative",
"medoid_nobaseline", "model_derivative", "model_nobaseline"
)
files <- file.path(resolved, paste0(types, ".rds"))
digest::digest(.lib_file_signatures(files, checksum_limit = Inf),
algo = "sha256")
}
.lib_compare_reference_build <- function(build, previous_library_dir,
seed, holdout, progress,
checkpoints = NULL,
checkpoint_key = NULL,
checkpoint_fallback_key = NULL) {
prior <- .lib_load_previous_libraries(previous_library_dir, progress)
get_checkpoint <- function(stage, stable = FALSE) {
if (is.null(checkpoints)) return(NULL)
value <- checkpoints$get(stage, key = checkpoint_key)
can_fallback <- isTRUE(stable) && is.null(value) &&
!is.null(checkpoint_fallback_key) &&
!identical(checkpoint_key, checkpoint_fallback_key)
if (can_fallback) {
value <- checkpoints$get(stage, key = checkpoint_fallback_key)
if (!is.null(value)) checkpoints$put(stage, value, key = checkpoint_key)
}
value
}
reference_pairs <- list()
for (recipe in intersect(names(build$libraries),
c("raw", "derivative", "nobaseline"))) {
for (type in names(build$libraries[[recipe]])) {
artifact <- paste(recipe, type, sep = "_")
reference_pairs[[artifact]] <- list(
recipe = recipe, type = type, kind = "full"
)
}
}
for (recipe in intersect(names(build$medoids),
c("derivative", "nobaseline"))) {
legacy <- prior[[paste0("medoid_", recipe)]]
for (type in names(build$medoids[[recipe]])) {
artifact <- paste("medoid", recipe, type, sep = "_")
reference_pairs[[artifact]] <- list(
recipe = recipe, type = type, kind = "medoid"
)
}
}
materialize_pair <- function(spec) {
recipe <- spec$recipe
type <- spec$type
if (identical(spec$kind, "full")) {
old <- .lib_filter_optional_type(prior[[recipe]], type)
if (is.null(old)) return(NULL)
new <- build$libraries[[recipe]][[type]]
limits <- range(new$wavenumber)
old <- restrict_range(old, min = limits[1L], max = limits[2L],
make_rel = FALSE)
return(list(
new_reference = new, old_reference = old,
new_data = new, old_data = old
))
}
old <- .lib_filter_optional_type(
prior[[paste0("medoid_", recipe)]], type
)
old_full <- .lib_filter_optional_type(prior[[recipe]], type)
if (is.null(old) || is.null(old_full)) return(NULL)
new <- build$medoids[[recipe]][[type]]
limits <- range(new$wavenumber)
old <- restrict_range(old, min = limits[1L], max = limits[2L],
make_rel = FALSE)
list(
new_reference = new, old_reference = old,
new_data = .lib_restrict_to_reference(
build$libraries[[recipe]][[type]], new
),
old_data = .lib_restrict_to_reference(old_full, old)
)
}
compatibility <- get_checkpoint("assessment_compatibility", stable = TRUE)
compatibility_rows <- list()
split_rows <- list()
reference_tests <- list()
assessment_summaries <- list()
for (i in seq_along(reference_pairs)) {
artifact <- names(reference_pairs)[[i]]
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: identify %s (%d/%d)",
artifact, i, length(reference_pairs)
))
}
pair <- materialize_pair(reference_pairs[[artifact]])
if (is.null(pair)) next
if (is.null(compatibility)) {
compatibility_rows[[artifact]] <- .lib_compatibility_rows(
pair$new_reference, pair$old_reference, artifact
)
}
for (source in c("new", "old")) {
is_medoid <- identical(reference_pairs[[artifact]]$kind, "medoid")
split <- NULL
if (!is_medoid) {
split_stage <- paste0("assessment_split_", artifact, "_", source)
split <- get_checkpoint(split_stage, stable = TRUE)
if (is.null(split)) {
split <- .lib_source_split(
pair[[paste0(source, "_data")]], artifact = artifact,
source = source,
seed = seed + i * 2L + match(source, c("new", "old")),
holdout = holdout
)
if (!is.null(checkpoints)) {
checkpoints$put(split_stage, split, key = checkpoint_key)
}
}
split_rows[[paste(artifact, source, sep = "_")]] <- split$manifest
}
stage <- paste0(
"assessment_reference_", if (is_medoid) "complete_" else "",
artifact, "_", source, if (is_medoid) "_v1" else ""
)
tests <- get_checkpoint(stage, stable = !is_medoid)
if (is.null(tests)) {
test_args <- list(
reference = pair[[paste0(source, "_reference")]],
data = pair[[paste0(source, "_data")]],
artifact = artifact, source = source, progress = progress
)
tests <- if (is_medoid) {
do.call(.lib_reference_complete_test, test_args)
} else {
test_args$split <- split
do.call(.lib_reference_holdout_test, test_args)
}
if (!is.null(checkpoints)) {
checkpoints$put(stage, tests, key = checkpoint_key)
}
}
reference_tests[[paste0(artifact, "_", source)]] <- tests
stage <- paste0("assessment_spectra_", artifact, "_", source)
summary <- get_checkpoint(stage, stable = TRUE)
if (is.null(summary)) {
assessment_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: assess_spec %s/%s starting (spectra=%d)",
artifact, source,
ncol(pair[[paste0(source, "_reference")]]$spectra)
))
}
summary <- .lib_assess_spec_summary(
pair[[paste0(source, "_reference")]], artifact, source
)
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: assess_spec %s/%s complete (%.1fs)",
artifact, source,
proc.time()[["elapsed"]] - assessment_started
))
}
if (!is.null(checkpoints)) {
checkpoints$put(stage, summary, key = checkpoint_key)
}
}
assessment_summaries[[paste0(artifact, "_", source)]] <- summary
}
rm(pair)
gc(verbose = FALSE)
}
if (is.null(compatibility)) {
compatibility <- data.table::rbindlist(compatibility_rows, fill = TRUE)
if (!is.null(checkpoints)) {
checkpoints$put("assessment_compatibility", compatibility,
key = checkpoint_key)
}
}
split_manifest <- data.table::rbindlist(split_rows, fill = TRUE)
reference_tests <- data.table::rbindlist(reference_tests, fill = TRUE)
if (!nrow(reference_tests)) {
stop(
"No comparable legacy reference-library spectra were assessed; ",
"verify that prior artifacts contain typed OpenSpecy components",
call. = FALSE
)
}
if (!nrow(compatibility)) {
stop("Legacy compatibility assessment produced no artifact rows",
call. = FALSE)
}
library_identification <- .lib_identification_summary(reference_tests)
library_confusion <- .lib_confusion_table(reference_tests)
assess_spec_shifts <- .lib_assessment_shift_table(
data.table::rbindlist(assessment_summaries, fill = TRUE)
)
model_tests <- list()
updated_models <- build$models
algorithms <- intersect(
c("logistic_regression", "random_forest"), names(updated_models)
)
for (algorithm in algorithms) {
recipes <- names(updated_models[[algorithm]])
sources <- if (identical(algorithm, "logistic_regression")) {
c("new", "old")
} else {
"new"
}
for (recipe in recipes) {
legacy_model <- if (identical(algorithm, "logistic_regression")) {
prior[[paste0("model_", recipe)]]
} else {
NULL
}
for (source in sources) {
model_set <- if (source == "new") {
updated_models[[algorithm]][[recipe]]
} else {
legacy_model
}
source_object <- function(type) {
if (source == "new") {
build$libraries[[recipe]][[type]]
} else {
.lib_filter_optional_type(prior[[recipe]], type)
}
}
for (type in names(model_set)) {
if (is.null(model_set[[type]])) next
component_types <- if (identical(type, "both")) {
c("ftir", "raman")
} else {
type
}
query_parts <- list()
for (actual_type in component_types) {
eligible <- tryCatch(
.lib_restrict_model_range(source_object(actual_type), actual_type),
error = function(error) NULL
)
if (!is.null(eligible)) query_parts[[actual_type]] <- eligible
}
if (!all(component_types %in% names(query_parts))) next
query <- if (length(component_types) == 1L) {
query_parts[[1L]]
} else {
.lib_bind_same_axis(query_parts, "combined model test spectra")
}
rm(query_parts)
gc(verbose = FALSE)
model_started <- proc.time()[["elapsed"]]
provenance <- paste0(source, "_", algorithm, "_complete_dataset")
if (isTRUE(progress)) message(
"build_lib assessment: existing model ", algorithm, "/",
recipe, "/", type, "/", source, " identifying complete dataset (",
ncol(query$spectra), ")"
)
stage <- paste0(
"assessment_model_complete_", algorithm, "_", recipe, "_", type,
"_", source, "_v1"
)
tests <- if (is.null(checkpoints)) NULL else
checkpoints$get(stage, key = checkpoint_key)
if (is.null(tests)) {
tests <- .lib_model_complete_test(
model_set[[type]], query, recipe, type,
algorithm = algorithm, source = source, provenance = provenance
)
if (!is.null(checkpoints)) {
checkpoints$put(stage, tests, key = checkpoint_key)
}
}
if (source == "new") {
updated_models[[algorithm]][[recipe]][[type]]$tests <- tests
}
key <- paste(algorithm, recipe, type, source, sep = "_")
model_tests[[key]] <- tests
if (isTRUE(progress)) message(sprintf(
paste0("build_lib assessment: existing model ",
"%s/%s/%s/%s complete (%.1fs)"),
algorithm, recipe, type, source,
proc.time()[["elapsed"]] - model_started
))
rm(query)
gc(verbose = FALSE, full = TRUE)
}
gc(verbose = FALSE, full = TRUE)
}
}
}
split_manifest <- data.table::rbindlist(
split_rows, fill = TRUE
)
model_tests <- data.table::rbindlist(model_tests, fill = TRUE)
model_identification <- .lib_identification_summary(model_tests)
model_confusion <- .lib_confusion_table(model_tests)
automated_test_flags <- build$assessments$automated_test_flags
if (is.null(automated_test_flags) || !nrow(automated_test_flags)) {
quality <- data.table::copy(data.table::as.data.table(
build$assessments$quality_control
))
if (nrow(quality) && all(c(
"artifact", "spectrum_type", "spectrum_id", "check"
) %in% names(quality))) {
automated_test_flags <- unique(quality[, .(
artifact, technique = spectrum_type, spectrum_id,
error_mode = check
)])
}
}
model_assessment_correlations <- .lib_model_assessment_correlations(
model_tests, automated_test_flags
)
list(
models = updated_models,
split_manifest = split_manifest,
library_tests = reference_tests,
library_identification = library_identification,
library_confusion = library_confusion,
model_identification = model_identification,
model_tests = model_tests,
model_confusion = model_confusion,
model_assessment_correlations = model_assessment_correlations,
assess_spec_shifts = assess_spec_shifts,
old_new_compatibility = compatibility
)
}
.lib_load_previous_libraries <- function(path, progress) {
types <- c(
"raw", "derivative", "nobaseline", "medoid_derivative",
"medoid_nobaseline", "model_derivative", "model_nobaseline"
)
resolved <- if (identical(path, "system")) {
system.file("extdata", package = "OpenSpecy")
} else {
path
}
if (!nzchar(resolved)) {
stop("Could not resolve 'previous_library_dir'", call. = FALSE)
}
missing <- !file.exists(file.path(resolved, paste0(types, ".rds")))
if (any(missing)) {
if (isTRUE(progress)) {
message("build_lib assessment: retrieving missing legacy artifacts")
}
get_lib(types[missing], path = path)
}
missing <- !file.exists(file.path(resolved, paste0(types, ".rds")))
if (any(missing)) {
stop("Legacy artifact(s) remain unavailable: ",
paste(types[missing], collapse = ", "), call. = FALSE)
}
setNames(lapply(file.path(resolved, paste0(types, ".rds")), readRDS), types)
}
.lib_compatibility_rows <- function(new, old, artifact) {
new_ids <- .lib_ids(new, "sample_name")
old_ids <- .lib_ids(old, "sample_name")
new_names <- names(new$metadata)
old_names <- names(old$metadata)
data.table::data.table(
artifact = artifact,
spectra_old = ncol(old$spectra), spectra_new = ncol(new$spectra),
spectra_shift = ncol(new$spectra) - ncol(old$spectra),
wavenumbers_old = length(old$wavenumber),
wavenumbers_new = length(new$wavenumber),
wavenumbers_shift = length(new$wavenumber) - length(old$wavenumber),
metadata_columns_old = length(old_names),
metadata_columns_new = length(new_names),
metadata_columns_shift = length(new_names) - length(old_names),
shared_identifiers = length(intersect(new_ids, old_ids)),
identifiers_old_only = length(setdiff(old_ids, new_ids)),
identifiers_new_only = length(setdiff(new_ids, old_ids)),
axes_identical = identical(new$wavenumber, old$wavenumber),
metadata_old_only = paste(setdiff(old_names, new_names), collapse = "; "),
metadata_new_only = paste(setdiff(new_names, old_names), collapse = "; ")
)
}
.lib_restrict_to_reference <- function(x, reference) {
limits <- range(reference$wavenumber)
out <- restrict_range(
x, min = limits[1L], max = limits[2L], make_rel = FALSE
)
.lib_filter_spectral_support(out, min_fraction = 0.1)$object
}
.lib_source_split <- function(x, artifact, source, seed, holdout) {
rows <- .lib_split_rows(x, source)
groups <- rows[, .(
material_class = .lib_first_value(material_class),
spectrum_type = .lib_first_value(spectrum_type)
), by = group_id]
groups[, stratum := paste(
ifelse(is.na(spectrum_type), "unknown", spectrum_type),
ifelse(is.na(material_class), "unclassified", material_class), sep = "\r"
)]
allocation <- groups[, .(available = .N), by = stratum]
allocation[, `:=`(
expected = available * holdout,
selected = as.integer(floor(available * holdout))
)]
target <- min(nrow(groups), max(1L, as.integer(round(nrow(groups) * holdout))))
set.seed(seed)
allocation[, `:=`(
remainder = expected - selected,
tie_break = stats::runif(.N)
)]
data.table::setorder(allocation, -remainder, tie_break, stratum)
remaining <- target - sum(allocation$selected)
while (remaining > 0L) {
eligible <- which(allocation$selected < allocation$available)
if (!length(eligible)) break
take <- head(eligible, remaining)
allocation$selected[take] <- allocation$selected[take] + 1L
remaining <- remaining - length(take)
}
test_groups <- unlist(lapply(seq_len(nrow(allocation)), function(i) {
count <- allocation$selected[[i]]
if (!count) return(character())
sample(groups[stratum == allocation$stratum[[i]], group_id], count)
}), use.names = FALSE)
groups[, `:=`(
artifact = artifact, source = source,
split = ifelse(group_id %in% test_groups, "test", "train")
)]
list(
manifest = groups[, .(
artifact, source, group_id, split, material_class, spectrum_type
)],
rows = rows
)
}
.lib_split_rows <- function(x, source, group_ids = NULL) {
metadata <- x$metadata
grouping <- NULL
if (is.null(group_ids)) {
grouping <- .lib_stable_group_info(x)
group_ids <- grouping$group_id
}
if (length(group_ids) != ncol(x$spectra)) {
stop("Comparison group identifiers are not aligned to spectra",
call. = FALSE)
}
data.table::data.table(
source = source, row = seq_along(group_ids), group_id = group_ids,
physical_id = if (is.null(grouping)) NA_character_ else grouping$physical_id,
content_hash = if (is.null(grouping)) NA_character_ else grouping$content_hash,
spectrum_id = as.character(.lib_ids(x, "sample_name")),
material_class = if ("material_class" %in% names(metadata))
as.character(metadata$material_class) else NA_character_,
spectrum_type = if ("spectrum_type" %in% names(metadata))
as.character(metadata$spectrum_type) else NA_character_
)
}
.lib_comparison_group_ids <- function(x) {
.lib_stable_group_info(x)$group_id
}
.lib_stable_group_info <- function(x) {
ids <- as.character(.lib_ids(x, "sample_name"))
metadata <- x$metadata
if ("sample_name_old" %in% names(metadata)) {
legacy_ids <- trimws(as.character(metadata$sample_name_old))
usable <- !is.na(legacy_ids) & nzchar(legacy_ids) &
tolower(legacy_ids) != "new format"
ids[usable] <- legacy_ids[usable]
}
missing <- is.na(ids) | !nzchar(trimws(ids))
ids[missing] <- paste0("row_", which(missing))
content_hash <- vapply(seq_len(ncol(x$spectra)), function(i) {
digest::digest(
list(x$wavenumber, as.numeric(x$spectra[, i])),
algo = "sha256"
)
}, character(1))
parent <- seq_along(ids)
find_root <- function(i) {
while (parent[[i]] != i) {
parent[[i]] <<- parent[[parent[[i]]]]
i <- parent[[i]]
}
i
}
unite <- function(left, right) {
left <- find_root(left)
right <- find_root(right)
if (left != right) parent[[right]] <<- left
}
edges <- data.table::rbindlist(list(
data.table::data.table(token = paste0("id:", ids), row = seq_along(ids))[
, if (.N > 1L) .(row = row[-1L], anchor = row[[1L]]) else NULL,
by = token
],
data.table::data.table(
token = paste0("content:", content_hash), row = seq_along(ids)
)[, if (.N > 1L) .(row = row[-1L], anchor = row[[1L]]) else NULL,
by = token]
), fill = TRUE)
if (nrow(edges)) {
for (i in seq_len(nrow(edges))) unite(edges$row[[i]], edges$anchor[[i]])
}
roots <- vapply(seq_along(ids), find_root, integer(1))
group_id <- data.table::data.table(
row = seq_along(ids), root = roots, physical_id = ids,
content_hash = content_hash
)[, .(
group_id = paste0("group_", substr(digest::digest(
sort(unique(c(physical_id, content_hash))), algo = "sha256"
), 1L, 24L))
), by = root][data.table::data.table(row = seq_along(ids), root = roots),
on = "root", group_id]
list(group_id = group_id, physical_id = ids, content_hash = content_hash)
}
.lib_first_value <- function(x) {
x <- as.character(x)
x <- x[!is.na(x) & nzchar(x)]
if (length(x)) x[[1L]] else NA_character_
}
.lib_reference_holdout_test <- function(reference, data, split,
artifact, source,
progress = FALSE) {
test_groups <- split$manifest[split == "test", group_id]
source_rows <- split$rows
test_idx <- source_rows[group_id %in% test_groups, row]
if (length(test_idx) == 0L) {
return(data.table::data.table())
}
query <- filter_spec(data, test_idx)
query_ids <- .lib_ids(query, "sample_name")
reference_ids <- .lib_ids(reference, "sample_name")
reference_groups <- split$rows$group_id[
match(reference_ids, split$rows$spectrum_id)
]
keep_reference <- !is.na(reference_groups) &
!reference_groups %in% test_groups
if (!any(keep_reference)) return(data.table::data.table())
library <- if (all(keep_reference)) reference else
filter_spec(reference, keep_reference)
library_ids <- .lib_ids(library, "sample_name")
started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
paste0(
"build_lib assessment: %s/%s reference identification starting ",
"(test=%d; train=%d)"
),
artifact, source, length(test_idx), ncol(library$spectra)
))
}
cors <- cor_spec(query, library = library, compute = "optimized")
if (isTRUE(progress)) {
message(sprintf(
paste0(
"build_lib assessment: %s/%s full correlation complete ",
"(%d x %d; %.1fs)"
),
artifact, source, nrow(cors), ncol(cors),
proc.time()[["elapsed"]] - started
))
}
top <- max_cor_named(cors)
matched_rows <- match(names(top), library_ids)
rm(cors)
expected <- as.character(query$metadata$material_class)
predicted <- as.character(library$metadata$material_class[matched_rows])
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: %s/%s reference identification complete (%.1fs)",
artifact, source, proc.time()[["elapsed"]] - started
))
}
data.table::data.table(
artifact = artifact, source = source,
spectrum_id = query_ids,
technique = as.character(query$metadata$spectrum_type),
expected_class = expected, predicted_class = predicted,
correct = expected == predicted,
score = as.numeric(top), split = "test",
provenance = "source_local_reference_holdout"
)
}
.lib_reference_complete_test <- function(reference, data, artifact, source,
progress = FALSE,
block_size = 1000L) {
block_size <- max(1L, as.integer(block_size))
query_ids <- .lib_ids(data, "sample_name")
library_ids <- .lib_ids(reference, "sample_name")
blocks <- split(
seq_len(ncol(data$spectra)),
ceiling(seq_len(ncol(data$spectra)) / block_size)
)
started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) message(sprintf(
paste0("build_lib assessment: %s/%s medoid identifying complete ",
"dataset (query=%d; reference=%d; blocks=%d)"),
artifact, source, ncol(data$spectra), ncol(reference$spectra),
length(blocks)
))
rows <- lapply(seq_along(blocks), function(i) {
idx <- blocks[[i]]
query <- if (length(idx) == ncol(data$spectra)) data else
filter_spec(data, idx)
cors <- cor_spec(query, library = reference, compute = "optimized")
top <- max_cor_named(cors)
matched_rows <- match(names(top), library_ids)
rm(cors)
expected <- as.character(query$metadata$material_class)
predicted <- as.character(reference$metadata$material_class[matched_rows])
if (isTRUE(progress)) message(sprintf(
"build_lib assessment: %s/%s medoid block %d/%d complete",
artifact, source, i, length(blocks)
))
data.table::data.table(
artifact = artifact, source = source,
spectrum_id = query_ids[idx],
technique = as.character(query$metadata$spectrum_type),
expected_class = expected, predicted_class = predicted,
correct = expected == predicted, score = as.numeric(top),
split = "complete", provenance = "complete_medoid_reference_search"
)
})
if (isTRUE(progress)) message(sprintf(
"build_lib assessment: %s/%s complete medoid search finished (%.1fs)",
artifact, source, proc.time()[["elapsed"]] - started
))
data.table::rbindlist(rows, fill = TRUE)
}
.lib_model_complete_test <- function(model, x, artifact, type, algorithm, source,
provenance) {
fill <- model$fill
if (!is_OpenSpecy(fill)) {
variables <- as.numeric(model$all_variables)
fill <- as_OpenSpecy(
variables,
spectra = matrix(
0, nrow = length(variables), ncol = 1L,
dimnames = list(NULL, "model_zero_fill")
),
metadata = data.table::data.table(sample_name = "model_zero_fill")
)
}
prediction <- match_spec(x, library = model, fill = fill)
predicted <- if ("name" %in% names(prediction)) {
as.character(prediction$name)
} else if ("predicted_name" %in% names(prediction)) {
as.character(prediction$predicted_name)
} else {
rep(NA_character_, nrow(prediction))
}
expected <- as.character(x$metadata$material_class)
technique <- if ("spectrum_type" %in% names(x$metadata)) {
as.character(x$metadata$spectrum_type)
} else {
NA_character_
}
typed_expected <- paste(technique, expected, sep = "_")
use_typed <- !is.na(typed_expected) & typed_expected %in% model$class_names
expected[use_typed] <- typed_expected[use_typed]
data.table::data.table(
algorithm = algorithm, artifact = artifact, model = type, source = source,
spectrum_id = .lib_ids(x, "sample_name"), technique = technique,
expected_class = expected, predicted_class = predicted,
correct = expected == predicted,
score = if ("value" %in% names(prediction)) prediction$value else NA_real_,
split = "complete", provenance = provenance
)
}
.lib_align_model_input <- function(x, model) {
variables <- as.numeric(model$all_variables)
keep <- match(variables, x$wavenumber)
if (anyNA(keep)) {
stop("Model variables are not available on the comparison spectrum axis",
call. = FALSE)
}
out <- x
out$wavenumber <- x$wavenumber[keep]
out$spectra <- x$spectra[keep, , drop = FALSE]
out
}
.lib_identification_summary <- function(tests) {
if (nrow(tests) == 0L) return(data.table::data.table())
group_cols <- intersect(
c("algorithm", "artifact", "model", "source", "technique", "provenance"),
names(tests)
)
overall <- tests[, .(
spectra = .N, evaluated = sum(!is.na(correct)),
coverage = mean(!is.na(correct)),
overall_accuracy = if (all(is.na(correct))) NA_real_ else
mean(correct, na.rm = TRUE),
mean_score = if (all(is.na(score))) NA_real_ else mean(score, na.rm = TRUE)
), by = group_cols]
class_summary <- tests[, .(
class_accuracy = if (all(is.na(correct))) NA_real_ else
mean(correct, na.rm = TRUE),
class_spectra = .N,
class_evaluated = sum(!is.na(correct))
), by = c(group_cols, "expected_class")]
macro <- class_summary[, .(
macro_class_accuracy = if (all(is.na(class_accuracy))) NA_real_ else
mean(class_accuracy, na.rm = TRUE),
classes = .N,
evaluated_classes = sum(!is.na(class_accuracy))
), by = group_cols]
out <- merge(overall, macro, by = group_cols, all = TRUE)
data.table::setcolorder(
out,
c(group_cols, "macro_class_accuracy", "coverage", "overall_accuracy",
"spectra", "evaluated", "classes", "evaluated_classes", "mean_score")
)
out
}
.lib_confusion_table <- function(tests) {
if (!nrow(tests)) {
return(data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
source = character(),
technique = character(), provenance = character(),
expected_class = character(), predicted_class = character(),
misidentified = logical(), spectra = integer(),
expected_class_spectra = integer(), expected_class_fraction = numeric()
))
}
group_cols <- intersect(
c("algorithm", "artifact", "model", "source", "technique", "provenance"),
names(tests)
)
out <- tests[, .(spectra = .N),
by = c(group_cols, "expected_class", "predicted_class")]
out[, misidentified := is.na(expected_class) | is.na(predicted_class) |
expected_class != predicted_class]
expected_groups <- c(group_cols, "expected_class")
out[, `:=`(
expected_class_spectra = as.integer(sum(spectra)),
expected_class_fraction = spectra / sum(spectra)
), by = expected_groups]
data.table::setcolorder(
out,
c(group_cols, "expected_class", "predicted_class", "misidentified",
"spectra", "expected_class_spectra", "expected_class_fraction")
)
data.table::setorderv(
out,
c(group_cols, "misidentified", "spectra", "expected_class",
"predicted_class"),
c(rep(1L, length(group_cols)), -1L, -1L, 1L, 1L), na.last = TRUE
)
out
}
.lib_assess_spec_summary <- function(x, artifact, source) {
assessed <- assess_spec(x, report = "all")
summary <- assessed[, .(
count = .N,
finding_count = sum(finding_count, na.rm = TRUE),
example_ids = paste(
head(unique(spectrum_id[status != "pass"]), 20L), collapse = "; "
)
), by = .(check, status)]
summary[, `:=`(
artifact = artifact, source = source,
spectra = ncol(x$spectra), rate = count / ncol(x$spectra)
)]
summary
}
.lib_assessment_shift_table <- function(summary) {
if (nrow(summary) == 0L) return(summary)
summary <- summary[status %in% c("error", "warning"), .(
count = sum(count, na.rm = TRUE),
finding_count = sum(finding_count, na.rm = TRUE),
example_ids = paste(unique(example_ids[nzchar(example_ids)]), collapse = "; "),
spectra = if (all(is.na(spectra))) NA_integer_ else max(spectra, na.rm = TRUE)
), by = .(artifact, source, check)]
summary[, rate := count / spectra]
if (!nrow(summary)) return(summary)
old <- summary[source == "old"]
new <- summary[source == "new"]
by <- c("artifact", "check")
out <- merge(
old, new, by = by, all = TRUE, suffixes = c("_old", "_new")
)
for (column in c("count", "finding_count", "spectra", "rate")) {
old_col <- paste0(column, "_old")
new_col <- paste0(column, "_new")
out[[paste0(column, "_shift")]] <- out[[new_col]] - out[[old_col]]
}
out$relative_rate_shift <- ifelse(
is.na(out$rate_old) | out$rate_old == 0,
NA_real_, (out$rate_new - out$rate_old) / out$rate_old
)
data.table::setorderv(
out, c("rate_shift", "artifact", "check"), c(-1L, 1L, 1L),
na.last = TRUE
)
out
}
.lib_validate_reference_build <- function(build) {
process_names <- c("cleanup", "ref_lib", "medoid", "model", "functionality")
if (!identical(names(build$assessments), process_names)) {
stop("Assessment review must contain the five ordered process groups",
call. = FALSE)
}
leaf_count <- sum(lengths(build$assessments))
if (leaf_count > 10L || any(lengths(build$assessments) == 0L)) {
stop("Assessment review must contain 1-10 nonempty process tables",
call. = FALSE)
}
leaves <- unlist(build$assessments, recursive = FALSE, use.names = TRUE)
empty <- !vapply(leaves, function(value) {
inherits(value, c("data.frame", "data.table")) && nrow(value) > 0L
}, logical(1))
if (any(empty)) {
stop("Assessment review contains empty or non-tabular leaves: ",
paste(names(leaves)[empty], collapse = ", "), call. = FALSE)
}
sparse <- unlist(lapply(names(leaves), function(name) {
value <- leaves[[name]]
if (!nrow(value)) return(character())
missing <- vapply(value, function(column) mean(is.na(column)), numeric(1L))
columns <- names(missing)[missing > 0.10]
if (!length(columns)) return(character())
paste0(name, "$", columns)
}), use.names = FALSE)
if (length(sparse)) {
stop("Assessment review contains columns with more than 10% missing ",
"values: ", paste(sparse, collapse = ", "), call. = FALSE)
}
artifacts <- c(
.lib_named_typed_objects(build$libraries),
.lib_named_typed_objects(build$medoids, prefix = "medoid_")
)
invalid <- vapply(artifacts, function(object) {
!isTRUE(suppressWarnings(check_OpenSpecy(object))) ||
any(!is.finite(object$wavenumber)) || anyDuplicated(object$wavenumber) ||
is.unsorted(object$wavenumber, strictly = TRUE) ||
ncol(object$spectra) != nrow(object$metadata)
}, logical(1))
if (any(invalid)) {
stop("Invalid OpenSpecy release artifact(s): ",
paste(names(artifacts)[invalid], collapse = ", "), call. = FALSE)
}
flat <- vapply(artifacts, function(object) {
any(vapply(seq_len(ncol(object$spectra)), function(i) {
values <- object$spectra[, i]
values <- values[is.finite(values)]
length(values) == 0L || diff(range(values)) <= 0
}, logical(1)))
}, logical(1))
if (any(flat)) {
stop("Flat or unavailable spectra remain in release artifact(s): ",
paste(names(artifacts)[flat], collapse = ", "), call. = FALSE)
}
expected <- list()
if (!is.null(build$models$logistic_regression)) {
expected$logistic_regression <- lapply(build$medoids, function(types) {
out <- names(types)
if (all(c("ftir", "raman") %in% out)) out <- c(out, "both")
out
})
}
if (!is.null(build$models$random_forest)) {
expected$random_forest <- lapply(build$libraries, names)
}
problems <- character()
if (is.null(expected$logistic_regression)) {
problems <- c(problems, "logistic_regression missing")
}
for (algorithm in names(expected)) {
for (recipe in names(expected[[algorithm]])) {
for (type in expected[[algorithm]][[recipe]]) {
model <- build$models[[algorithm]][[recipe]][[type]]
label <- paste(algorithm, recipe, type, sep = "/")
if (is.null(model)) {
problems <- c(problems, paste0(label, " missing"))
next
}
required <- c("model", "class_names", "class_num", "fill", "all_variables")
if (!all(required %in% names(model)) || !is_OpenSpecy(model$fill)) {
problems <- c(problems, paste0(label, " incomplete"))
}
if (identical(algorithm, "logistic_regression") &&
!.lib_selected_lambda_converged(model)) {
problems <- c(problems, paste0(label, " selected lambda unconverged"))
}
}
}
}
if (length(problems)) {
stop("Reference build completeness validation failed: ",
paste(problems, collapse = "; "), call. = FALSE)
}
evidence <- attr(build$assessments, "evidence", exact = TRUE)
split_manifest <- evidence$split_manifest
if (!is.null(split_manifest) && nrow(split_manifest)) {
overlap <- split_manifest[, data.table::uniqueN(split),
by = .(artifact, source, group_id)][V1 > 1L]
if (nrow(overlap)) {
stop("Assessment group leakage remains after split construction",
call. = FALSE)
}
}
invisible(build)
}
.lib_selected_lambda_converged <- function(model) {
# Full training checkpoints retain the explicit diagnostic. Release models
# intentionally omit assessment-only fields, but the retained one-lambda
# glmnet object still carries jerr, which is sufficient to validate it when
# a completed release is used as the input to a later assessment rebuild.
if (!is.null(model$selected_lambda_converged)) {
return(isTRUE(model$selected_lambda_converged))
}
error <- model$model$jerr
is.numeric(error) && length(error) == 1L && !is.na(error) && error == 0L
}
.lib_runtime_open_specy_attributes <- function() {
c(
"names", "class", "intensity_unit", "intensity_units",
"derivative_order", "baseline", "spectra_type", "transformations",
"identification_range"
)
}
.lib_keep_attributes <- function(x, keep) {
object_attributes <- attributes(x)
attributes(x) <- object_attributes[intersect(keep, names(object_attributes))]
x
}
.lib_slim_reference_object <- function(x) {
if (!is_OpenSpecy(x)) {
stop("Release sanitization requires an OpenSpecy object", call. = FALSE)
}
x <- .lib_keep_attributes(x, .lib_runtime_open_specy_attributes())
x$wavenumber <- .lib_keep_attributes(x$wavenumber, "names")
x$spectra <- .lib_keep_attributes(
x$spectra,
c("dim", "dimnames", "names", "row.names", "class", ".internal.selfref")
)
x$metadata <- .lib_keep_attributes(
x$metadata, c("names", "row.names", "class", ".internal.selfref")
)
x
}
.lib_slim_reference_collection <- function(collection) {
lapply(collection, function(recipe) {
if (is_OpenSpecy(recipe)) return(.lib_slim_reference_object(recipe))
lapply(recipe, .lib_slim_reference_object)
})
}
.lib_runtime_model_fields <- function() {
c(
"model", "model_type", "lambda_selected", "dimension_conversion",
"coefficients", "class_names", "class_num", "observation_count", "fill",
"fill_method", "variable_num", "all_variables", "variables_in"
)
}
.lib_slim_glmnet_model <- function(model, lambda_selected) {
if (!inherits(model, "glmnet")) return(model)
if (!is.numeric(lambda_selected) || length(lambda_selected) != 1L ||
!is.finite(lambda_selected) || !length(model$lambda)) {
stop("A finite selected lambda is required to slim a glmnet model",
call. = FALSE)
}
selected <- which.min(abs(model$lambda - lambda_selected))
subset_path <- function(value) {
if (is.null(value)) return(NULL)
if (is.list(value) && !inherits(value, "Matrix")) {
return(lapply(value, subset_path))
}
if (length(dim(value)) == 2L) return(value[, selected, drop = FALSE])
value[selected]
}
model$a0 <- subset_path(model$a0)
model$beta <- subset_path(model$beta)
model$dfmat <- subset_path(model$dfmat)
model$df <- subset_path(model$df)
model$lambda <- as.numeric(lambda_selected)
model$dev.ratio <- subset_path(model$dev.ratio)
if (length(model$dim) >= 2L) model$dim[[2L]] <- 1L
keep <- c(
"a0", "beta", "dfmat", "df", "dim", "lambda", "dev.ratio",
"nulldev", "npasses", "jerr", "offset", "classnames", "nobs"
)
out <- model[intersect(keep, names(model))]
class(out) <- class(model)
out
}
.lib_slim_model <- function(model) {
if (is.null(model)) return(NULL)
fields <- intersect(.lib_runtime_model_fields(), names(model))
out <- model[fields]
if (inherits(out$model, "glmnet")) {
out$model <- .lib_slim_glmnet_model(out$model, out$lambda_selected)
}
if (is_OpenSpecy(out$fill)) out$fill <- .lib_slim_reference_object(out$fill)
out
}
.lib_slim_model_collection <- function(models) {
lapply(models, function(recipes) {
lapply(recipes, function(types) lapply(types, .lib_slim_model))
})
}
.lib_release_index <- function(signature, artifact_manifest) {
files <- stats::setNames(
basename(as.character(artifact_manifest$path)),
as.character(artifact_manifest$component)
)
structure(
list(
schema = "OpenSpecy_reference_build_index_v1",
build_signature = signature,
artifacts = files,
assessments = "assessments.rds",
release_manifest = "release_manifest.rds"
),
build_signature = signature
)
}
.lib_is_release_index <- function(x) {
is.list(x) && identical(x$schema, "OpenSpecy_reference_build_index_v1") &&
is.character(x$artifacts) && length(x$artifacts) > 0L
}
.lib_load_release_index <- function(index, directory) {
artifact_path <- function(component) {
file <- index$artifacts[[component]]
if (is.null(file) || !nzchar(file)) return(NULL)
path <- file.path(directory, file)
if (!file.exists(path)) {
stop("Release index artifact is missing: ", path, call. = FALSE)
}
path
}
load_artifact <- function(component) {
path <- artifact_path(component)
if (is.null(path)) NULL else readRDS(path)
}
libraries <- stats::setNames(lapply(
intersect(c("raw", "derivative", "nobaseline"), names(index$artifacts)),
load_artifact
), intersect(c("raw", "derivative", "nobaseline"), names(index$artifacts)))
medoid_components <- intersect(
c("medoid_derivative", "medoid_nobaseline"), names(index$artifacts)
)
medoids <- stats::setNames(
lapply(medoid_components, load_artifact), sub("^medoid_", "", medoid_components)
)
models <- list(logistic_regression = list(), random_forest = list())
for (algorithm in names(models)) {
prefix <- paste0("model_", algorithm, "_")
components <- names(index$artifacts)[startsWith(names(index$artifacts), prefix)]
recipes <- sub(paste0("^", prefix), "", components)
models[[algorithm]] <- stats::setNames(lapply(components, load_artifact), recipes)
}
models <- Filter(length, models)
assessments_path <- file.path(directory, index$assessments)
assessments <- if (file.exists(assessments_path)) readRDS(assessments_path) else NULL
quarantine <- if ("quarantined_spectra" %in% names(index$artifacts)) {
load_artifact("quarantined_spectra")
} else NULL
list(
libraries = libraries, medoids = medoids, models = models,
assessments = assessments, quarantine = quarantine
)
}
.lib_promote_reference_build <- function(build, output_dir, signature, reuse,
progress = NULL, quarantine = NULL) {
release_dir <- file.path(output_dir, "releases", substr(signature, 1L, 12L))
dir.create(release_dir, recursive = TRUE, showWarnings = FALSE)
prior_manifest <- NULL
manifest_path <- file.path(release_dir, "release_manifest.rds")
if (isTRUE(reuse) && file.exists(manifest_path)) {
candidate_manifest <- tryCatch(
readRDS(manifest_path), error = function(error) NULL
)
if (inherits(candidate_manifest, c("data.frame", "data.table")) &&
identical(
attr(candidate_manifest, "build_signature", exact = TRUE),
signature
)) {
prior_manifest <- data.table::as.data.table(candidate_manifest)
}
}
release_libraries <- .lib_slim_reference_collection(build$libraries)
release_medoids <- .lib_slim_reference_collection(build$medoids)
release_models <- .lib_slim_model_collection(build$models)
model_artifacts <- list()
for (algorithm in names(release_models)) {
for (recipe in names(release_models[[algorithm]])) {
model_artifacts[[paste("model", algorithm, recipe, sep = "_")]] <-
release_models[[algorithm]][[recipe]]
}
}
logistic <- release_models$logistic_regression
if (!is.null(logistic)) {
for (recipe in intersect(c("derivative", "nobaseline"), names(logistic))) {
# Retain the historical filenames consumed by get_lib() and older clients.
model_artifacts[[paste0("model_", recipe)]] <- logistic[[recipe]]
}
}
artifacts <- c(
release_libraries,
setNames(release_medoids, paste0("medoid_", names(release_medoids))),
model_artifacts
)
if (!is.null(quarantine)) {
quarantine$manifest$release_signature <- signature
artifacts[["quarantined_spectra"]] <- quarantine
}
manifest <- lapply(names(artifacts), function(name) {
path <- file.path(release_dir, paste0(name, ".rds"))
if(is.function(progress)) {
progress(paste0("verifying/promoting release artifact: ", name))
}
verified <- .lib_verify_manifested_release_artifact(path, prior_manifest)
if (!is.null(verified)) verified else .lib_promote_rds(artifacts[[name]], path)
})
list(
directory = release_dir,
manifest = data.table::rbindlist(manifest, fill = TRUE)
)
}
.lib_verify_manifested_release_artifact <- function(path, manifest) {
if (is.null(manifest) || !file.exists(path)) return(NULL)
component <- tools::file_path_sans_ext(basename(path))
normalized <- normalizePath(path, mustWork = TRUE)
manifest_paths <- normalizePath(
as.character(manifest$path), mustWork = FALSE
)
row <- manifest[
as.character(manifest$component) == component & manifest_paths == normalized
]
if (nrow(row) != 1L || !identical(row$checksum_algorithm, "sha256")) {
return(NULL)
}
info <- file.info(path)
checksum <- .lib_sha256_file(path)
if (!identical(as.numeric(row$size), as.numeric(info$size)) ||
!identical(as.character(row$checksum), checksum)) {
return(NULL)
}
readable <- tryCatch({
readRDS(path)
TRUE
}, error = function(error) FALSE)
if (!isTRUE(readable)) return(NULL)
data.table::data.table(
component = component, status = "verified_existing",
path = normalized, size = as.numeric(info$size),
checksum_algorithm = "sha256", checksum = checksum
)
}
.lib_is_lookup_spec <- function(x) {
is.list(x) && !inherits(x, c("data.frame", "data.table")) &&
all(c("lookup", "by") %in% names(x))
}
.lib_normalize_lookup_spec <- function(x) {
if (!.lib_is_lookup_spec(x)) {
return(list(lookup = x, by = NULL, fallback_by = NULL,
fill_only = FALSE))
}
extra <- setdiff(names(x), c("lookup", "by", "fallback_by", "fill_only"))
if (length(extra) > 0L) {
stop("Explicit metadata lookup specifications only accept 'lookup', ",
"'by', 'fallback_by', and 'fill_only'", call. = FALSE)
}
if (is.null(x$by) || !is.character(x$by) || length(x$by) < 1L ||
anyNA(x$by) || any(!nzchar(x$by))) {
stop("Explicit metadata lookup 'by' must contain column names",
call. = FALSE)
}
if (!is.null(x$fallback_by) &&
(!is.character(x$fallback_by) || length(x$fallback_by) != 1L ||
is.na(x$fallback_by) || !nzchar(x$fallback_by))) {
stop("Explicit metadata lookup 'fallback_by' must be one column name",
call. = FALSE)
}
if (is.null(x$fallback_by)) x$fallback_by <- NULL
if (is.null(x$fill_only)) x$fill_only <- FALSE
if (!is.logical(x$fill_only) || length(x$fill_only) != 1L ||
is.na(x$fill_only)) {
stop("Explicit metadata lookup 'fill_only' must be TRUE or FALSE",
call. = FALSE)
}
x
}
.lib_auto_lookup_key <- function(metadata, lookup_table) {
metadata <- data.table::as.data.table(metadata)
lookup_table <- data.table::as.data.table(lookup_table)
shared <- intersect(names(metadata), names(lookup_table))
if (length(shared) == 0L) {
return(list(shared = shared, candidates = character()))
}
usable <- vapply(shared, function(col) {
metadata_values <- .lib_key_values(metadata[[col]])
lookup_values <- .lib_key_values(lookup_table[[col]], unique = FALSE)
if (length(metadata_values) == 0L || length(lookup_values) == 0L) {
return(FALSE)
}
has_overlap <- any(metadata_values %in% unique(lookup_values))
unique_lookup_keys <- !anyDuplicated(lookup_values)
has_overlap && unique_lookup_keys
}, logical(1))
list(shared = shared, candidates = shared[usable])
}
.lib_key_values <- function(x, unique = TRUE) {
values <- as.character(x)
values <- values[!is.na(values)]
values <- values[nzchar(values, keepNA = FALSE)]
if (isTRUE(unique)) values <- unique(values)
values
}
.lib_read_lookup <- function(x) {
if (is.character(x) && length(x) == 1 && file.exists(x)) {
return(data.table::fread(x))
}
data.table::as.data.table(data.table::copy(x))
}
#' @rdname lib_metadata_name_lookup
#' @export
lib_clean_name <- function(x) {
x <- iconv(as.character(x), to = "ASCII", sub = "")
x <- tolower(trimws(x))
x <- gsub("%", "perc", x, fixed = TRUE)
x <- gsub("->", "_", x, fixed = TRUE)
x <- gsub("[^a-z0-9_]+", "_", x)
x <- gsub("_+", "_", x)
x <- gsub("^_+|_+$", "", x)
x[is.na(x) | x == ""] <- "column"
x
}
#' @rdname lib_metadata_name_lookup
#' @export
lib_clean_metadata <- function(x,
name_lookup = lib_metadata_name_lookup(),
clean_values = FALSE) {
if (!is.logical(clean_values) || length(clean_values) != 1L ||
is.na(clean_values)) {
stop("'clean_values' must be TRUE or FALSE", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x))
original_names <- names(metadata)
cleaned_names <- lib_clean_name(original_names)
canonical_names <- cleaned_names
rule_priority <- rep(Inf, length(cleaned_names))
lookup <- NULL
if (!is.null(name_lookup)) {
match_without_underscores <-
attr(name_lookup, "match_without_underscores", exact = TRUE)
match_singular_plural <-
attr(name_lookup, "match_singular_plural", exact = TRUE)
if (is.null(match_without_underscores)) match_without_underscores <- TRUE
if (is.null(match_singular_plural)) match_singular_plural <- TRUE
lookup <- data.table::as.data.table(data.table::copy(name_lookup))
.lib_require_cols(lookup, "canonical_name", "metadata name lookup")
if (!"source_name" %in% names(lookup)) {
lookup$source_name <- NA_character_
}
if (!"regex" %in% names(lookup)) lookup$regex <- NA_character_
lookup <- lookup[, c("canonical_name", "source_name", "regex"),
with = FALSE]
lookup$canonical_name <- lib_clean_name(lookup$canonical_name)
exact <- !is.na(lookup$source_name)
lookup$source_name[exact] <- lib_clean_name(lookup$source_name[exact])
empty_regex <- !is.na(lookup$regex) & lookup$regex == ""
lookup$regex[empty_regex] <- NA_character_
lookup <- unique(lookup)
has_source <- !is.na(lookup$source_name)
has_regex <- !is.na(lookup$regex)
if (any(has_source == has_regex)) {
stop("Each metadata name rule must contain exactly one of ",
"'source_name' or 'regex'", call. = FALSE)
}
exact_rules <- lookup[has_source, ]
source_groups <- split(exact_rules$canonical_name,
exact_rules$source_name)
ambiguous <- names(source_groups)[vapply(
source_groups,
function(value) length(unique(value)) > 1L,
logical(1)
)]
if (length(ambiguous) > 0) {
stop("Exact metadata name aliases map to multiple canonical names: ",
paste(ambiguous, collapse = ", "), call. = FALSE)
}
matched <- match(cleaned_names, exact_rules$source_name)
found <- !is.na(matched)
canonical_names[found] <- exact_rules$canonical_name[matched[found]]
exact_is_canonical <- exact_rules$source_name ==
exact_rules$canonical_name
rule_priority[found] <- ifelse(
exact_is_canonical[matched[found]],
matched[found],
2L * nrow(exact_rules) + matched[found]
)
smart_key <- function(value) {
if (isTRUE(match_without_underscores)) {
value <- gsub("_", "", value, fixed = TRUE)
}
if (isTRUE(match_singular_plural)) value <- sub("s$", "", value)
value
}
unresolved <- !found
if (any(unresolved) &&
(isTRUE(match_without_underscores) ||
isTRUE(match_singular_plural)) &&
nrow(exact_rules) > 0L) {
rule_keys <- smart_key(exact_rules$source_name)
name_keys <- smart_key(cleaned_names)
key_groups <- split(exact_rules$canonical_name, rule_keys)
ambiguous_keys <- names(key_groups)[vapply(
key_groups,
function(value) length(unique(value)) > 1L,
logical(1)
)]
conflicting <- which(unresolved & name_keys %in% ambiguous_keys)
if (length(conflicting) > 0L) {
details <- vapply(conflicting, function(i) {
canonical <- unique(key_groups[[name_keys[i]]])
paste0("'", original_names[i], "' -> ",
paste(canonical, collapse = ", "))
}, character(1))
stop("Automatic metadata name matching is ambiguous: ",
paste(details, collapse = "; "),
". Add an exact alias or disable the relevant smart matching ",
"option.", call. = FALSE)
}
smart_match <- match(name_keys[unresolved], rule_keys)
smart_found <- !is.na(smart_match)
unresolved_rows <- which(unresolved)
rows <- unresolved_rows[smart_found]
matched_rules <- smart_match[smart_found]
canonical_names[rows] <- exact_rules$canonical_name[matched_rules]
rule_priority[rows] <- ifelse(
exact_is_canonical[matched_rules],
nrow(exact_rules) + matched_rules,
3L * nrow(exact_rules) + matched_rules
)
found[rows] <- TRUE
}
regex_rules <- lookup[has_regex, ]
regex_matches <- vector("list", length(cleaned_names))
if (nrow(regex_rules) > 0L) {
pattern_hits <- lapply(seq_len(nrow(regex_rules)), function(i) {
tryCatch(
grepl(regex_rules$regex[i], cleaned_names, perl = TRUE),
warning = function(w) {
stop("Invalid metadata name regex '", regex_rules$regex[i],
"' for '", regex_rules$canonical_name[i], "': ",
conditionMessage(w), call. = FALSE)
},
error = function(e) {
stop("Invalid metadata name regex '", regex_rules$regex[i],
"' for '", regex_rules$canonical_name[i], "': ",
conditionMessage(e), call. = FALSE)
}
)
})
for (i in seq_along(cleaned_names)) {
regex_matches[[i]] <- which(vapply(
pattern_hits,
function(hit) isTRUE(hit[i]),
logical(1)
))
}
overlapping <- which(lengths(regex_matches) > 1L)
if (length(overlapping) > 0L) {
details <- vapply(overlapping, function(i) {
rows <- regex_matches[[i]]
rules <- paste0(
"'", regex_rules$regex[rows], "' -> '",
regex_rules$canonical_name[rows], "'"
)
paste0("'", original_names[i], "' matched ",
paste(rules, collapse = ", "))
}, character(1))
stop("Multiple metadata name regular expressions matched the same ",
"column: ", paste(details, collapse = "; "),
". Make the patterns mutually exclusive.", call. = FALSE)
}
regex_found <- !found & lengths(regex_matches) == 1L
for (i in which(regex_found)) {
row <- regex_matches[[i]]
canonical_names[i] <- regex_rules$canonical_name[row]
rule_priority[i] <- 4L * nrow(exact_rules) + row
}
}
}
output_names <- unique(canonical_names)
output <- lapply(output_names, function(canonical) {
positions <- which(canonical_names == canonical)
if (!is.null(lookup)) {
positions <- positions[order(
cleaned_names[positions] != canonical,
rule_priority[positions],
positions
)]
} else {
positions <- positions[order(cleaned_names[positions] != canonical,
positions)]
}
values <- lapply(positions, function(position) metadata[[position]])
signatures <- vapply(values, function(value) {
paste(typeof(value), paste(class(value), collapse = "/"), sep = ":")
}, character(1))
if (length(unique(signatures)) > 1L ||
any(vapply(values, is.factor, logical(1)))) {
values <- lapply(values, as.character)
}
result <- values[[1]]
if (length(values) > 1L) {
for (candidate in values[-1L]) {
fill <- is.na(result) & !is.na(candidate)
result[fill] <- candidate[fill]
}
}
result
})
names(output) <- output_names
output <- data.table::as.data.table(output)
if (isTRUE(clean_values)) output <- .lib_clean_metadata_values(output)
output
}
.lib_clean_metadata_values <- function(x) {
out <- data.table::as.data.table(data.table::copy(x))
for (col in names(out)) {
value <- out[[col]]
if (!is.character(value) && !is.factor(value)) next
value <- iconv(as.character(value), to = "ASCII", sub = "")
value <- tolower(trimws(value))
value[value %in% c("", "na", "null", "not available")] <- NA_character_
data.table::set(out, j = col, value = value)
}
out
}
.lib_coalesce_joined_metadata <- function(metadata, columns,
suffixes = c(".x", ".y"),
lookup_precedence = TRUE) {
metadata <- data.table::as.data.table(metadata)
for (col in columns) {
left <- paste0(col, suffixes[[1L]])
right <- paste0(col, suffixes[[2L]])
if (!all(c(left, right) %in% names(metadata))) next
result <- metadata[[left]]
replacement <- metadata[[right]]
use_replacement <- !is.na(replacement)
if (is.character(replacement)) {
use_replacement <- use_replacement & nzchar(replacement)
}
if (!isTRUE(lookup_precedence)) {
keep_existing <- !is.na(result)
if (is.character(result)) keep_existing <- keep_existing & nzchar(result)
use_replacement <- use_replacement & !keep_existing
}
result[use_replacement] <- replacement[use_replacement]
data.table::set(metadata, j = left, value = result)
data.table::setnames(metadata, left, col)
metadata[, (right) := NULL]
}
metadata
}
.lib_require_cols <- function(x, cols, label) {
missing <- setdiff(cols, names(x))
if (length(missing) > 0) {
stop("Missing ", label, " columns: ", paste(missing, collapse = ", "),
call. = FALSE)
}
}
.lib_alert_join_report <- function(report, require_complete) {
if (nrow(report) == 0) return(invisible(NULL))
summary <- report[, .(n = sum(n)), by = .(problem, column)]
msg <- paste(apply(summary, 1, function(x) {
paste0(x[["problem"]], " in ", x[["column"]], ": ", x[["n"]])
}), collapse = "; ")
if (require_complete) stop(msg, call. = FALSE)
warning(msg, call. = FALSE)
invisible(NULL)
}
.lib_ids <- function(x, id_col) {
if (id_col %in% names(x$metadata)) return(as.character(x$metadata[[id_col]]))
colnames(x$spectra)
}
.lib_filter_excluded <- function(x, exclude_ids, id_col = "sample_name") {
exclude_ids <- as.character(exclude_ids)
metadata_cols <- intersect(
c(id_col, paste0(id_col, "_old"), "col_id"),
names(x$metadata)
)
metadata_hit <- rep(FALSE, nrow(x$metadata))
for (col in metadata_cols) {
metadata_hit <- metadata_hit |
as.character(x$metadata[[col]]) %in% exclude_ids
}
spectra_hit <- colnames(x$spectra) %in% exclude_ids
keep <- !(metadata_hit | spectra_hit)
if (!all(keep)) x <- filter_spec(x, keep)
x
}
.lib_dedupe_existing_ids <- function(x, id_col = "sample_name",
duplicate = "first") {
if (!id_col %in% names(x$metadata)) return(NULL)
ids <- as.character(x$metadata[[id_col]])
if (length(ids) != ncol(x$spectra) ||
any(is.na(ids) | !nzchar(ids))) {
return(NULL)
}
x$metadata[[id_col]] <- ids
colnames(x$spectra) <- ids
x$metadata$col_id <- ids
keep <- rep(TRUE, length(ids))
if (duplicate == "first") keep <- keep & !duplicated(ids)
if (duplicate == "remove_all") {
keep <- keep & !(duplicated(ids) | duplicated(ids, fromLast = TRUE))
}
if (!all(keep)) x <- filter_spec(x, keep)
x
}
.pam_group_ids <- function(x, id_col, k, progress = FALSE,
group_label = "group", ...) {
x <- as_OpenSpecy(x)
ids <- .lib_ids(x, id_col)
if (ncol(x$spectra) <= k) return(ids)
if (ncol(x$spectra) > 3000L) {
return(.pam_large_group_ids(
x, id_col = id_col, k = k, progress = progress,
group_label = group_label, ...
))
}
correlation_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: correlation starting (%s; n=%d)",
group_label, length(ids)
))
}
cors <- cor_spec(x, x, compute = "optimized")
cors[is.na(cors)] <- 0
cors <- pmax(pmin(cors, 1), -1)
diag(cors) <- 1
distance <- stats::as.dist(1 - cors)
rm(cors)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: correlation complete (%s; n=%d; %.1fs)",
group_label, length(ids),
proc.time()[["elapsed"]] - correlation_started
))
}
user_args <- list(...)
if (length(user_args) > 0L) {
if (is.null(names(user_args)) || any(names(user_args) == "")) {
stop("PAM arguments passed through '...' must be named",
call. = FALSE)
}
supported <- c(
"medoids", "nstart", "do.swap", "variant", "pamonce", "trace.lev"
)
unsupported <- setdiff(names(user_args), supported)
if (length(unsupported) > 0L) {
stop("Unsupported reduce_lib() PAM argument(s): ",
paste(unsupported, collapse = ", "), call. = FALSE)
}
}
pam_args <- list(
x = distance, k = min(k, length(ids) - 1L), diss = TRUE,
variant = "faster"
)
pam_args[names(user_args)] <- user_args
if ("pamonce" %in% names(user_args) && !"variant" %in% names(user_args)) {
pam_args$variant <- NULL
}
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM starting (%s; n=%d; k=%d; variant=%s)",
group_label, length(ids), pam_args$k,
if (is.null(pam_args$variant)) "custom" else pam_args$variant
))
}
pam_started <- proc.time()[["elapsed"]]
seed_exists <- exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
if (seed_exists) old_seed <- get(".Random.seed", envir = .GlobalEnv)
on.exit({
if (seed_exists) {
assign(".Random.seed", old_seed, envir = .GlobalEnv)
} else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
rm(".Random.seed", envir = .GlobalEnv)
}
}, add = TRUE)
set.seed(.lib_pam_seed(ids))
result <- do.call(cluster::pam, pam_args)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM complete (%s; n=%d; k=%d; %.1fs)",
group_label, length(ids), length(result$id.med),
proc.time()[["elapsed"]] - pam_started
))
}
ids[result$id.med]
}
.pam_large_group_ids <- function(x, id_col, k, progress = FALSE,
group_label = "group", samples = 5L,
sample_size = 1000L, ...) {
ids <- .lib_ids(x, id_col)
count <- length(ids)
sample_size <- min(count, max(as.integer(sample_size), 2L * k + 1L))
samples <- max(1L, as.integer(samples))
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: sampled PAM starting ",
"(%s; n=%d; k=%d; samples=%d; sample_size=%d)"),
group_label, count, k, samples, sample_size
))
}
normalized <- .lib_prune_normalize(
x$spectra, x$wavenumber, c(Inf, Inf)
)
seed_exists <- exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
if (seed_exists) old_seed <- get(".Random.seed", envir = .GlobalEnv)
on.exit({
if (seed_exists) {
assign(".Random.seed", old_seed, envir = .GlobalEnv)
} else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
rm(".Random.seed", envir = .GlobalEnv)
}
}, add = TRUE)
set.seed(.lib_pam_seed(ids))
best_indices <- integer()
best_objective <- Inf
for (sample_i in seq_len(samples)) {
sampled <- sort(sample.int(count, sample_size))
sampled_object <- filter_spec(x, sampled)
sampled_ids <- .pam_group_ids(
sampled_object, id_col = id_col, k = k, progress = FALSE,
group_label = group_label, ...
)
candidate_indices <- match(sampled_ids, ids)
correlations <- tcrossprod(
normalized, normalized[candidate_indices, , drop = FALSE]
)
correlations[!is.finite(correlations)] <- -1
correlations <- pmax(pmin(correlations, 1), -1)
objective <- sum(1 - matrixStats::rowMaxs(correlations))
if (objective < best_objective) {
best_objective <- objective
best_indices <- candidate_indices
}
rm(sampled_object, sampled_ids, correlations)
gc(verbose = FALSE, full = TRUE)
}
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: sampled PAM complete ",
"(%s; n=%d; k=%d; objective=%.6g)"),
group_label, count, length(best_indices), best_objective
))
}
ids[best_indices]
}
.lib_pam_seed <- function(ids) {
hash <- digest::digest(as.character(ids), algo = "xxhash32")
as.integer(strtoi(substr(hash, 1L, 7L), base = 16L))
}
Try the OpenSpecy package in your browser
Any scripts or data that you put into this service are public.
OpenSpecy documentation built on Oct. 6, 2026, 1:07 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .lib_build_core rebuild_lib_artifacts build_lib
Documented in build_lib rebuild_lib_artifacts
#' @rdname build_lib
#' @title Build spectral libraries
#'
#' @description
#' Create reference libraries from source files and OpenSpecy objects.
#' When \code{output_dir} is supplied, \code{build_lib()} runs the official
#' end-to-end workflow and returns raw,
#' processed, medoid, model, and assessment artifacts in one object. Supporting
#' functions remain available for advanced composition.
#'
#' @details
#' \code{build_lib()} combines sources over their full wavenumber range,
#' optionally adds ordinary and hierarchical metadata, removes requested
#' identifiers, optionally generates stable source-stage duplicate IDs, and
#' applies named processing recipes. Source-stage IDs follow the reference
#' library's legacy hash recipe: each source spectrum is trimmed with
#' \code{\link{manage_na}(type = "remove")}, conformed at resolution 8,
#' smoothed, and hashed from the resulting wavenumber/intensity vectors before
#' later merging and range restriction. The older 100--4000 cm-1 hash is kept in
#' \code{sample_name_old} when \code{id_col = "sample_name"} so
#' \code{exclude_ids} can remove both current and legacy curated bad IDs.
#' Metadata column names are first converted to lowercase
#' underscore names and known aliases are coalesced using
#' \code{metadata_name_lookup}; see \code{\link{lib_clean_metadata}()} for
#' automatic and regular-expression matching. Metadata values can optionally be
#' normalized to lowercase trimmed character values before lookup joins.
#' \code{spectrum_identity} is also reduced to a basename when it is a
#' recognizable path, then trailing extensions supported by
#' \code{\link{read_any}()} are removed. The same normalization is applied to
#' exact lookup keys. Regex class rules belong in a separate table and can be
#' applied afterward with \code{\link{predict_class_reference}()}.
#' This keeps filenames usable as identities without treating file containers
#' as part of a material name. By default, each source is also
#' converted to absorbance before merging when its intensity units are known.
#' A nonempty \code{intensity_unit} object attribute takes precedence over the
#' per-spectrum \code{intensity_units} metadata column. Each recipe is either a
#' named list of arguments passed to \code{\link{process_spec}()} or a function
#' accepting one \code{OpenSpecy} object. An empty recipe returns an unprocessed
#' copy. Signal-to-noise is added by default, and optional
#' \code{\link{assess_spec}()} results are summarized into one metadata row per
#' spectrum.
#' Progress messages report named stages and elapsed time by default so
#' long-running builds remain observable.
#'
#' The official workflow requires explicit source paths and an output
#' directory. When \code{workflow_data} is omitted, \code{build_lib()} looks
#' for the curated helper tables under \code{data/} beside the calling script,
#' then under \code{data/} or \code{workflows/data/} in the current working
#' directory. It writes each completed stage under
#' \code{output_dir/checkpoints}, and promotes validated legacy-compatible files
#' into a versioned release directory. With \code{reuse = TRUE}, a checkpoint
#' is reused only when its manifest signature matches the source files, curated
#' tables, relevant arguments, package version, and builder implementation.
#' Full assessments use the complete candidate and legacy artifacts. Seeded
#' ten-percent holdouts are allocated independently within each source across
#' class/type strata after physical identifiers and exact spectral-content
#' duplicates have been joined into stable groups. Candidate artifacts are assessed on candidate data and
#' legacy artifacts on legacy data, so taxonomy changes do not require fuzzy
#' cross-version class matching. Query identifiers are removed from full and
#' references by group before matching to prevent transformed duplicate or
#' physical-replicate self-matches. Each medoid artifact separately identifies
#' its complete corresponding processed library, measuring the deployed medoid
#' search directly without another split. Model assessments do not retrain models:
#' each existing candidate or legacy model identifies its complete corresponding
#' source dataset once. This measures the deployed artifact directly and keeps
#' assessment generation bounded by prediction rather than model fitting.
#' After derivative and baseline-removal processing, FTIR spectra whose
#' 2200--2420 CO2-region maximum exceeds twice the 2420--2550 silent-region
#' maximum are flattened and reassessed; failed postconditions are removed.
#' High-tail checks use each spectrum's finite support;
#' tails are trimmed and reassessed, failed corrections are removed, and
#' spectra with running signal-to-noise below two are removed before pruning.
#' Full artifacts are then partitioned into Raman (200--4000), FTIR
#' (400--4000), and NIR (4000--12000) \code{OpenSpecy} objects.
#' After pruning and class reassignment, the official workflow derives
#' \code{material_form} from the curated form-regex CSV and all atomic metadata
#' values, then joins evidence-backed \code{common_use} by final material class.
#' Existing form values take precedence when uniquely standardized; conflicting
#' form categories remain missing and are audited. Common use may be
#' \code{"consumer"}, \code{"industrial"}, \code{"mixed"}, or missing;
#' quantitative mass shares are retained when available, while sourced
#' qualitative proposals remain explicit in the review table.
#' After full and medoid libraries are complete, metadata columns containing
#' only missing values are removed, except that these two standardized fields
#' are retained, and the remainder are stably ordered from the fewest to the
#' most missing values. Spectra, metadata rows, identifiers, axes, and object
#' attributes are unchanged.
#' Official class completion temporarily assigns unresolved identities to
#' \code{"other"}. By default, spectra with a blank identity or that unresolved
#' literal class are removed before quality control and retained in the
#' \code{other_review} assessment table. Reviewed \code{"other plastic"} and
#' \code{"other material"} rows stay in the reference library and enter
#' \code{prune_lib()}'s nearest-class semisupervised pathway.
#' When requested, \code{prune_lib()} first resolves high-correlation conflicts
#' between different reviewed classes within each source library. It repeatedly
#' removes the spectrum with the most active wrong-class neighbors, recalculates
#' after each round, and removes both endpoints of an adjacent maximum-score
#' tie. It then resolves between-library conflicts by the number of distinct
#' independent libraries supporting the opposing class. Generic and
#' unclassified labels do not participate. Official builds repeat closure on
#' the rounded typed and model-range views before deriving medoids, and retain
#' excluded spectra plus conflict provenance in
#' \code{quarantined_spectra.rds}. Pruning then reassigns generic classes by nearest same-technique
#' correlation: \code{"other"} may use any established class,
#' \code{"other plastic"} requires a plastic candidate, and
#' \code{"other material"} requires \code{"organic matter"} or
#' \code{"mineral"}. The matched material type and a correlation audit are
#' retained. Once those labels are resolved, each class/spectrum-type group with
#' fewer than \code{min_n} spectra is reassigned as a whole to its
#' most-correlated established class in the same technique pool and material
#' type. A group is removed only when no eligible correlated destination
#' exists. The report identifies its support, destination, class-level
#' correlation, action, reason, and affected spectrum identifiers.
#'
#' \code{make_lib_lookup_template()} creates a deduplicated table of metadata
#' values from an \code{OpenSpecy} or \code{Specs} object. Users can fill the
#' added columns in R or write the template to CSV and curate it elsewhere.
#'
#' \code{join_lib_metadata()} left-joins lookup columns onto object metadata and
#' reports unmatched metadata keys, duplicate lookup keys, and missing joined
#' values. Joins are exact; clean or harmonize values before calling this helper.
#'
#' \code{join_material_hierarchy()} joins user-defined hierarchical material
#' metadata. The supplied \code{levels} are tried from most-specific to
#' most-general so a material label can match any level in the hierarchy.
#'
#' \code{dedupe_spec()} hashes the current spectra and wavenumber axis to create
#' stable IDs and remove duplicated spectra. Process or conform spectra before
#' this step when that should affect duplicate detection.
#'
#' \code{reduce_lib()} uses PAM medoids to keep representative spectra within
#' each metadata group. It uses OpenSpecy's optimized correlation routine on
#' relative spectra whose missing values are temporarily replaced by each
#' spectrum's finite mean. Groups of at most 3,000 spectra use exact PAM;
#' oversized groups use five deterministic 1,000-spectrum PAM samples and keep
#' the candidate set with the best full-group correlation-distance objective.
#' Official medoids are then selected from the original object so their genuine
#' missing values are preserved.
#'
#' \code{train_spec_model()} trains either OpenSpecy's multinomial logistic
#' regression model (\code{method = "logistic_regression"}) or an experimental
#' probability random forest (\code{method = "random_forest"}). Logistic
#' regression uses inverse class weights and stratified cross-validation to
#' select the lambda with the highest out-of-fold macro class accuracy. Random
#' forest uses inverse-frequency balanced case sampling and out-of-bag
#' predictions. This improves minority-class representation in each bootstrap
#' sample without applying a second class-vote correction.
#' Treat the stored out-of-bag metrics as fit diagnostics: balanced resampling
#' can make them optimistic. The library workflow separately reports accuracy
#' from applying each deployed model to its complete corresponding dataset.
#' Missing training values are replaced with the finite mean at each
#' wavenumber. The returned model carries the same training-mean filler so
#' \code{\link{match_spec}()} can identify partially covered spectra.
#' \code{build_model_lib()} is the backward-compatible wrapper used by older
#' scripts; \code{build_lib()} calls the dedicated trainer for official models.
#'
#' \code{assess_lib()} returns a compact summary of object validity, library
#' size, class balance, and optionally nearest-neighbor class consistency.
#'
#' \code{rebuild_lib_artifacts()} starts from completed type-keyed libraries
#' and rebuilds only medoids, models, and assessments. Its input and output
#' locations are explicit, and every downstream component is checkpointed so a
#' compatible interrupted run can resume without repeating completed work.
#' Checkpoint and release payloads carry SHA-256 hashes, and an existing
#' versioned release path is accepted only when its payload is unchanged.
#'
#' @param x an \code{OpenSpecy} or \code{Specs} object for metadata helpers.
#' For \code{build_lib()}, one \code{OpenSpecy}, a nonempty list containing only
#' \code{OpenSpecy} objects, or a nonempty character vector of file paths.
#' The official workflow requires \code{x}; it does not guess source-library
#' locations.
#' Each RDS path may store either one \code{OpenSpecy} or a list of them; other
#' paths are read with \code{\link{read_any}()}.
#' Large same-axis source lists are prepared in bulk to avoid repeated legacy
#' object coercion.
#' For \code{rebuild_lib_artifacts()}, a completed four-part build object, its
#' RDS path, or a build/output directory containing completed \code{libraries}
#' checkpoints.
#' @param lookup a data.frame, data.table, or csv file path used as a metadata
#' lookup table.
#' @param by named character vector mapping metadata columns to lookup columns,
#' or an unnamed character vector when the names are the same in both tables.
#' @param columns metadata columns to deduplicate into a template.
#' @param add blank columns to add to a template.
#' @param path optional csv path. If \code{NULL}, template helpers return a
#' data.table.
#' @param hierarchy a data.frame, data.table, or csv file path with hierarchical
#' material metadata.
#' @param key_col metadata column containing material labels to match.
#' @param levels hierarchy columns ordered from most-specific to most-general.
#' @param output_names names to use for hierarchy columns added to metadata.
#' @param require_complete logical; if \code{TRUE}, incomplete joins fail.
#' @param return whether to return an updated \code{OpenSpecy} object, joined
#' table, report list, or selected ids depending on the helper.
#' @param suffixes suffixes used when joined metadata and lookup tables share
#' non-key column names.
#' @param id_col metadata column used as the spectrum identifier.
#' @param exclude_ids identifiers to remove before returning a library.
#' @param duplicate how duplicated generated identifiers should be handled.
#' @param scale numeric multiplier used before hashing intensity values.
#' @param algo hash algorithm passed to \code{\link[digest]{digest}()}.
#' @param recipes named list of \code{\link{process_spec}()} argument lists or
#' functions. Names become names of the returned libraries.
#' @param dedupe logical; whether to generate stable IDs and remove duplicated
#' spectra in \code{build_lib()}.
#' @param range,res wavenumber range and resolution passed to \code{c_spec()}
#' when \code{build_lib()} combines multiple sources.
#' @param restrict_range_args optional named list of arguments passed to
#' \code{\link{restrict_range}()} after unit conversion and source merging.
#' Supplying the list triggers restriction; \code{make_rel = FALSE} is used
#' unless explicitly overridden.
#' @param metadata_lookups a lookup table, csv path, or list of lookup tables and
#' paths. A lookup may instead be supplied as \code{list(lookup = x, by = key)}
#' to use an explicit key (including a named metadata-to-lookup key mapping).
#' \code{fill_only = TRUE} preserves existing nonblank metadata values while
#' filling gaps from the lookup. The older \code{fallback_by} lookup field is
#' deprecated; canonical metadata keys are now filled from reviewed internal
#' aliases before any external join.
#' If non-\code{NULL}, each is joined with
#' \code{join_lib_metadata()}. Automatic ordinary lookups use the single shared
#' column that has overlapping values and unique lookup keys. Lookups with no
#' usable shared key are skipped with a message; lookups with multiple usable
#' shared keys are considered ambiguous and stop. Lookup values that share
#' non-key metadata column names are coalesced back into those columns, with
#' non-missing lookup values taking precedence.
#' @param material_hierarchy hierarchy table or csv path used when
#' non-\code{NULL}. It is joined with \code{join_material_hierarchy()} using the
#' default \code{"material"} metadata key.
#' @param metadata_name_lookup a data.frame or data.table with
#' \code{canonical_name}, \code{source_name}, and optional \code{regex} columns.
#' The default is returned by \code{\link{lib_metadata_name_lookup}()}; use
#' \code{NULL} to clean names without coalescing aliases.
#' @param clean_metadata_values logical or \code{NULL}; whether
#' \code{build_lib()} should lowercase, trim, ASCII-normalize, and normalize
#' blank/unknown character metadata values before joining. \code{NULL} enables
#' cleaning for the official output workflow and disables it for composable
#' in-memory builds. Invalid byte sequences are always converted to UTF-8.
#' @param convert_intensity logical; whether to infer reflectance,
#' transmittance, or absorbance units from each source and convert known
#' non-absorbance spectra with \code{\link{adj_intens}()} before merging.
#' Object attribute \code{intensity_unit} is authoritative when supplied;
#' otherwise metadata column \code{intensity_units} is evaluated per spectrum.
#' @param signal_noise logical; whether to append the default
#' \code{\link{sig_noise}()} result as metadata column \code{sn}.
#' @param assess logical; whether to run \code{\link{assess_spec}()} on each
#' output library and append assessment summaries to its metadata.
#' @param prune \code{NULL}, or a named list mapping recipe names to argument
#' lists for \code{\link{prune_lib}()}. Selected recipes are pruned independently
#' after processing and assessment. \code{NULL} preserves unpruned outputs.
#' @param progress logical; whether \code{build_lib()} reports named processing
#' stages and elapsed time, or \code{reduce_lib()} reports group sizes and
#' correlation/PAM timings.
#' @param workflow_data optional directory containing the curated reference CSV
#' tables. If \code{NULL}, the directory is discovered beside the calling
#' script or under the current working directory.
#' @param output_dir \code{NULL} for the composable in-memory return, or a
#' directory that triggers the complete checkpointed workflow. The official
#' workflow requires an explicit output directory.
#' @param previous_library_dir directory containing the seven legacy artifacts
#' used for complete old/new assessment, \code{"system"}, or \code{NULL} to skip
#' external comparison. The end-to-end workflow defaults to \code{"system"}
#' and retrieves missing artifacts with \code{get_lib()}.
#' @param reuse logical; whether manifest-compatible completed checkpoints and
#' versioned release files may be reused.
#' @param remove_other logical; in the official end-to-end workflow, whether
#' spectra with blank \code{spectrum_identity} or the unresolved literal
#' \code{"other"} class are removed before quality control, medoid selection,
#' and model fitting. Reviewed broad \code{"other plastic"} and
#' \code{"other material"} categories remain in the reference libraries and
#' are eligible for \code{prune_lib()}'s constrained nearest-class
#' reassignment. Removed and reviewed rows remain visible in
#' \code{assessments$cleanup$summary}. Source-only composable builds do not
#' apply the official filter.
#' @param seed fixed seed for the grouped old/new assessment split.
#' @param holdout fraction of stable spectrum groups reserved for assessment.
#' @param group_cols metadata columns defining groups for reduction.
#' @param k maximum representatives to keep for groups larger than
#' \code{min_n}.
#' @param min_n For \code{prune_lib()}, the minimum spectra required for a
#' resolved class within one spectrum type across the complete input database,
#' not within each source library. Smaller groups are reassigned as a whole to
#' their most-correlated eligible class, or removed when no valid destination
#' exists; groups exactly at the threshold are retained. For \code{reduce_lib()},
#' groups with \code{min_n} or fewer spectra are kept whole. Model trainers
#' fit only classes meeting the threshold.
#' @param cross_class logical; whether \code{prune_lib()} should resolve
#' within-library and then independent-library high-correlation matches between
#' different non-generic material classes before generic-class reassignment.
#' This requires complete canonical
#' \code{library_name} metadata. The composable default is \code{FALSE}; the
#' official derivative and no-baseline workflow enables it.
#' @param cross_class_threshold numeric Pearson-correlation threshold in
#' \code{[0, 1]}. Cross-class correlations strictly greater than this value
#' are conflicts when \code{cross_class = TRUE}.
#' @param class_col,type_col metadata columns used for model labels.
#' @param nearest logical; if \code{TRUE}, \code{assess_lib()} compares each
#' spectrum with its highest-correlation neighbor and reports the fraction where
#' that neighbor has the same \code{class_col} value.
#' @param alpha alpha value passed to \code{\link[glmnet]{glmnet}()}.
#' @param method classifier to train: \code{"logistic_regression"} (the
#' backward-compatible default) or \code{"random_forest"}. The latter requires
#' the suggested \pkg{ranger} package.
#' @param seed random seed used before model training.
#' @param grouped logical; whether multinomial coefficients use grouped
#' penalties.
#' @param weights logical; whether to use inverse class-frequency weights for
#' logistic regression or inverse-frequency case sampling for random forest.
#' @param make_relative logical; whether to normalize model inputs with
#' \code{\link{make_rel}()}.
#' @param material_type_col metadata column used to require plastic candidates
#' for \code{"other plastic"} and to update the type after generic-class
#' reassignment. \code{"other material"} candidates are restricted by
#' \code{class_col} to \code{"organic matter"} or \code{"mineral"};
#' \code{"other"} may match any established class in the spectral pool.
#' @param exclude numeric length-two wavenumber interval excluded from pruning
#' correlations.
#' @param \ldots further arguments passed to the underlying operation.
#'
#' @return
#' Each library returned by \code{build_lib()} includes a
#' \code{spectrum_identity_cleanup_report} attribute listing changed original
#' and normalized identities with their counts.
#' In composable mode, \code{build_lib()} returns a named list of
#' \code{OpenSpecy} libraries. Its end-to-end mode returns one list containing
#' \code{libraries}, \code{medoids}, \code{models}, and \code{assessments}.
#' Official libraries and medoids are nested by recipe and then
#' \code{ftir}, \code{raman}, or \code{nir}. Models are nested by algorithm,
#' recipe, and spectrum type. FTIR and Raman medoids/models use
#' 800--3200 while the NIR interval is derived from finite coverage within
#' 4000--12000. Assessments use five ordered process lists:
#' \code{cleanup}, \code{ref_lib}, \code{medoid}, \code{model}, and
#' \code{functionality}, with no more than ten nonempty review tables in total.
#' Every spectrum receives a derived \code{library_name}: populated
#' \code{organization} first, otherwise \code{user_name}. The cleanup summary
#' includes source-library counts at each major stage and identifies the first
#' stage and reason whenever an entire source library is dropped. Accuracy
#' tables contain overall aggregate metrics only in long form, confusion tables
#' retain misidentifications only, and model error-mode tables compare accuracy
#' percentages with and without each automated-test flag. Review tables reject
#' columns with more than 10 percent missing values. Row-level tests, split manifests, model-training
#' diagnostics, and release manifests remain hash-addressed evidence attributes
#' rather than additional review leaves. Each in-memory training model contains
#' one \code{tests} data.table and a one-spectrum \code{fill} object. Versioned
#' release directories instead store global build and model diagnostics only in
#' \code{assessments.rds}; library, medoid, and model files retain only runtime
#' data, scientific attributes, and prediction state. The companion
#' \code{reference_library_build.rds} is a lightweight release index. The
#' companion \code{quarantined_spectra.rds} stores valid \code{OpenSpecy}
#' objects by recipe/type, a long conflict table, and build provenance for
#' spectra excluded by cross-class closure.
#' \code{join_lib_metadata()}, \code{join_material_hierarchy()},
#' \code{dedupe_spec()}, \code{prune_lib()}, and \code{reduce_lib()} return an updated spectral
#' object unless \code{return} requests a table, report, or ids.
#' \code{make_lib_lookup_template()} returns a data.table unless \code{path} is
#' supplied, in which case it writes the csv and invisibly returns the table.
#' \code{train_spec_model()} and \code{build_model_lib()} return a list suitable
#' for AI classification with
#' \code{\link{match_spec}()} and one tidy \code{tests} table instead of
#' separate accuracy/confusion summaries. It also contains typed
#' \code{lambda_metrics} and \code{support} tables. Random-forest results also
#' contain out-of-bag metrics and feature importance. \code{assess_lib()}
#' returns a data.table summary.
#'
#' @examples
#' wavenumber <- seq(100, 6100, by = 100)
#' base_a <- dnorm(seq(-3, 3, length.out = length(wavenumber)))
#' base_b <- rev(cumsum(seq_along(wavenumber)))
#' spectra <- cbind(base_a, base_a + 0.1, base_a + 0.2,
#' base_b, base_b + 0.1, base_b + 0.2)
#' colnames(spectra) <- paste0("s", seq_len(ncol(spectra)))
#' mini <- as_OpenSpecy(
#' wavenumber,
#' spectra = spectra,
#' metadata = data.table::data.table(
#' sample_name = colnames(spectra),
#' source = rep(c("A", "B"), each = 3),
#' label = c("nylon 6", "polyamides", "nylon 6",
#' "pet", "polyesters", "pet"),
#' material_class = rep(c("polyamides", "polyesters"), each = 3),
#' spectrum_type = rep("ftir", 6),
#' intensity_units = rep("absorbance", 6)
#' ),
#' attributes = list(intensity_unit = "absorbance")
#' )
#'
#' name_lookup <- lib_metadata_name_lookup()
#' name_lookup[name_lookup$canonical_name == "material_color", ]
#'
#' make_lib_lookup_template(mini, columns = "source", add = "library_type")
#'
#' source_lookup <- data.frame(
#' source = c("A", "B"),
#' library_type = c("lab", "field"),
#' material = c("nylon 6", "pet")
#' )
#' joined <- join_lib_metadata(mini, source_lookup, by = "source",
#' require_complete = TRUE)
#'
#' hierarchy <- data.frame(
#' material = c("nylon 6", "pet"),
#' material_class = c("polyamides", "polyesters"),
#' material_type = c("plastic", "plastic")
#' )
#' joined <- join_material_hierarchy(joined, hierarchy, key_col = "label",
#' require_complete = TRUE)
#'
#' deduped <- dedupe_spec(joined)
#' reduced <- reduce_lib(deduped, group_cols = "material_class",
#' k = 1, min_n = 1)
#' libs <- build_lib(
#' mini,
#' recipes = list(
#' raw = list(),
#' derivative = list(
#' conform_spec = FALSE,
#' smooth_intens = TRUE,
#' smooth_intens_args = list(window = 15, derivative = 1),
#' make_rel = TRUE
#' )
#' ),
#' metadata_lookups = source_lookup,
#' material_hierarchy = hierarchy,
#' restrict_range_args = list(min = 100, max = 6000),
#' assess = TRUE,
#' dedupe = FALSE
#' )
#'
#' model <- suppressWarnings(train_spec_model(
#' joined, class_col = "material_class", type_col = NULL, min_n = 2,
#' nlambda = 3
#' ))
#' assess_lib(libs$raw, class_col = "material_class", nearest = FALSE)
#'
#' @seealso \code{\link{match_spec}()} for deploying trained models and
#' \code{\link{plotly_spec}()} for logistic coefficient overlays.
#'
#' @author
#' Win Cowger
#'
#' @importFrom data.table as.data.table data.table fread fwrite rbindlist setorder
#' @export
build_lib <- function(x, recipes = .default_lib_recipes(), range = "full",
res = 6, id_col = "sample_name", exclude_ids = NULL,
dedupe = TRUE, metadata_lookups = NULL,
material_hierarchy = NULL,
metadata_name_lookup = lib_metadata_name_lookup(),
clean_metadata_values = NULL,
convert_intensity = TRUE, restrict_range_args = NULL,
signal_noise = TRUE, assess = FALSE, prune = NULL,
progress = TRUE,
workflow_data = NULL,
output_dir = NULL, previous_library_dir = "system",
reuse = TRUE, remove_other = TRUE,
seed = 123, holdout = 0.1,
...) {
if (missing(x)) {
stop(
"'x' must specify the source library file path(s) or OpenSpecy object(s)",
call. = FALSE
)
}
official_mode <- !is.null(output_dir)
if (is.null(clean_metadata_values)) {
clean_metadata_values <- official_mode
}
if (!is.logical(reuse) || length(reuse) != 1L || is.na(reuse)) {
stop("'reuse' must be TRUE or FALSE", call. = FALSE)
}
if (!is.logical(remove_other) || length(remove_other) != 1L ||
is.na(remove_other)) {
stop("'remove_other' must be TRUE or FALSE", call. = FALSE)
}
if (!official_mode) {
return(.lib_build_core(
x = x, recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
progress = progress, ...
))
}
workflow_data <- .lib_find_workflow_data(workflow_data)
.lib_build_reference(
x = x, recipes = recipes, range = range, res = res,
id_col = id_col, exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
progress = progress, workflow_data = workflow_data,
output_dir = output_dir, previous_library_dir = previous_library_dir,
reuse = reuse, remove_other = remove_other,
seed = seed, holdout = holdout, ...
)
}
#' @rdname build_lib
#' @export
rebuild_lib_artifacts <- function(x, output_dir,
previous_library_dir = "system",
reuse = TRUE, seed = 123, holdout = 0.1,
progress = TRUE) {
.lib_rebuild_artifacts(
x = x, output_dir = output_dir,
previous_library_dir = previous_library_dir,
reuse = reuse, seed = seed, holdout = holdout, progress = progress
)
}
.lib_build_core <- function(x, recipes = .default_lib_recipes(), range = "full",
res = 6, id_col = "sample_name",
exclude_ids = NULL, dedupe = TRUE,
metadata_lookups = NULL,
material_hierarchy = NULL,
metadata_name_lookup = lib_metadata_name_lookup(),
clean_metadata_values = FALSE,
convert_intensity = TRUE,
restrict_range_args = NULL,
signal_noise = TRUE, assess = FALSE, prune = NULL,
progress = TRUE, ...) {
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
if (!is.logical(clean_metadata_values) ||
length(clean_metadata_values) != 1L ||
is.na(clean_metadata_values)) {
stop("'clean_metadata_values' must be TRUE or FALSE", call. = FALSE)
}
started <- proc.time()[["elapsed"]]
dot_args <- list(...)
hash_scale <- if (is.null(dot_args$scale)) 100 else dot_args$scale
hash_algo <- if (is.null(dot_args$algo)) "md5" else dot_args$algo
dedupe_duplicate <- if (is.null(dot_args$duplicate)) {
"first"
} else {
match.arg(dot_args$duplicate, c("first", "remove_all", "none"))
}
report <- function(stage) {
if (isTRUE(progress)) {
elapsed <- proc.time()[["elapsed"]] - started
message(sprintf("build_lib [%.1fs]: %s", elapsed, stage))
}
}
validate_sources <- function(source, label) {
if (is_OpenSpecy(source)) {
return(list(source))
}
if (is.list(source) && length(source) > 0L &&
all(vapply(source, is_OpenSpecy, logical(1)))) {
return(source)
}
stop(label, " must contain one OpenSpecy object or a nonempty list of ",
"OpenSpecy objects", call. = FALSE)
}
report("starting")
streamed_records <- NULL
if (is_OpenSpecy(x)) {
sources <- list(x)
report("using one in-memory OpenSpecy source")
} else if (is.character(x)) {
if (length(x) == 0L || anyNA(x) || any(!nzchar(x))) {
stop("'x' must contain one or more nonempty file paths", call. = FALSE)
}
streamed_records <- list()
source_index <- 0L
for (i in seq_along(x)) {
report(sprintf(
"reading path %d/%d (%s)",
i, length(x), basename(x[[i]])
))
if (grepl("\\.rds$", x[[i]], ignore.case = TRUE)) {
source <- readRDS(x[[i]])
} else {
source <- read_any(x[[i]])
}
path_sources <- validate_sources(source, paste0("File path ", i))
for (j in seq_along(path_sources)) {
source_index <- source_index + 1L
streamed_records[[source_index]] <- .lib_source_record(
path_sources[[j]],
source_index,
id_col = if (isTRUE(dedupe)) id_col else NULL,
hash_scale = hash_scale,
hash_algo = hash_algo
)
}
rm(source, path_sources)
gc(verbose = FALSE)
}
report(sprintf(
"streamed %d source object(s) from %d path(s)",
length(streamed_records), length(x)
))
} else {
if (!is.list(x) || length(x) == 0L ||
!all(vapply(x, is_OpenSpecy, logical(1)))) {
stop("'x' must be one OpenSpecy object, file path(s), or a nonempty ",
"list of OpenSpecy objects", call. = FALSE)
}
sources <- x
report(sprintf("using %d in-memory OpenSpecy source(s)", length(sources)))
}
if (is.null(streamed_records)) {
report(sprintf("preparing %d source object(s)", length(sources)))
lib <- .lib_prepare_sources(
sources,
range = range,
res = res,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
id_col = if (isTRUE(dedupe)) id_col else NULL,
hash_scale = hash_scale,
hash_algo = hash_algo,
report = report
)
} else {
lib <- .lib_prepare_records(
streamed_records,
range = range,
res = res,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
report = report
)
rm(streamed_records)
gc(verbose = FALSE)
}
build_stage_report <- data.table::data.table(
stage = "prepared", spectra = ncol(lib$spectra), removed = 0L
)
identity_cleanup_report <- data.table::data.table()
if ("spectrum_identity" %in% names(lib$metadata)) {
identity_before <- as.character(lib$metadata$spectrum_identity)
identity_after <- .lib_clean_spectrum_identity(identity_before)
changed <- xor(is.na(identity_before), is.na(identity_after)) |
(!is.na(identity_before) & !is.na(identity_after) &
identity_before != identity_after)
identity_cleanup_report <- data.table::data.table(
original = identity_before[changed],
spectrum_identity = identity_after[changed]
)[, .(n = .N), by = .(original, spectrum_identity)]
lib$metadata$spectrum_identity <- identity_after
if (any(changed)) {
report(sprintf("cleaned %d spectrum identity value(s)", sum(changed)))
}
}
lib$metadata <- .lib_assign_library_name(lib$metadata)
source_key_report <- .lib_fill_metadata_key(
lib$metadata, canonical = "organization", fallback = "user_name"
)
if (nrow(source_key_report) > 0L) {
filled <- source_key_report[problem == "filled_canonical_key", sum(n)]
conflicts <- source_key_report[problem == "canonical_key_conflict", sum(n)]
report(sprintf(
"standardized source keys (filled=%d; conflicts=%d)",
ifelse(length(filled), filled, 0L),
ifelse(length(conflicts), conflicts, 0L)
))
}
if (!is.null(restrict_range_args)) {
report("restricting the wavenumber range")
if (!is.list(restrict_range_args) ||
is.null(names(restrict_range_args)) ||
any(names(restrict_range_args) == "")) {
stop("'restrict_range_args' must be a named list", call. = FALSE)
}
args <- utils::modifyList(
list(make_rel = FALSE),
restrict_range_args
)
lib <- do.call("restrict_range", c(list(lib), args))
}
lookup_reports <- list()
if (nrow(source_key_report) > 0L) {
lookup_reports$canonical_source_keys <- source_key_report
}
if (!is.null(metadata_lookups)) {
lookups <- if (.lib_is_lookup_spec(metadata_lookups)) {
list(metadata_lookups)
} else if (is.character(metadata_lookups) &&
length(metadata_lookups) > 1L) {
as.list(metadata_lookups)
} else if (is.list(metadata_lookups) &&
!inherits(metadata_lookups, c("data.frame", "data.table"))) {
metadata_lookups
} else {
list(metadata_lookups)
}
for (i in seq_along(lookups)) {
report(sprintf("joining metadata lookup %d/%d", i, length(lookups)))
lookup <- lookups[[i]]
lookup_spec <- .lib_normalize_lookup_spec(lookup)
lookup_table <- lib_clean_metadata(.lib_read_lookup(lookup_spec$lookup),
metadata_name_lookup,
clean_values = clean_metadata_values)
if ("spectrum_identity" %in% names(lookup_table)) {
lookup_table$spectrum_identity <- .lib_clean_spectrum_identity(
lookup_table$spectrum_identity
)
}
lookup_key <- lookup_spec$by
key_merge_report <- data.table::data.table()
if (is.null(lookup_key)) {
auto_key <- .lib_auto_lookup_key(lib$metadata, lookup_table)
if (length(auto_key$shared) == 0L) {
report(sprintf(
"skipping metadata lookup %d/%d; no shared metadata column",
i, length(lookups)
))
next
}
if (length(auto_key$candidates) == 0L) {
report(sprintf(
"skipping metadata lookup %d/%d; no usable shared key values in: %s",
i, length(lookups), paste(auto_key$shared, collapse = ", ")
))
next
}
if (length(auto_key$candidates) > 1L) {
stop("Each automatic metadata lookup must have exactly one usable ",
"shared key. Candidate columns were: ",
paste(auto_key$candidates, collapse = ", "),
". Supply list(lookup = x, by = key) for an explicit join",
call. = FALSE)
}
lookup_key <- auto_key$candidates
}
if (!is.null(lookup_spec$fallback_by)) {
warning(
"'fallback_by' is deprecated; standardize canonical metadata keys ",
"before supplying external lookup tables",
call. = FALSE
)
metadata_key <- if (is.null(names(lookup_key)) ||
all(names(lookup_key) == "")) {
unname(lookup_key)
} else {
names(lookup_key)
}
if (length(metadata_key) != 1L) {
stop("'fallback_by' requires a one-column explicit lookup key",
call. = FALSE)
}
.lib_require_cols(lib$metadata,
c(metadata_key, lookup_spec$fallback_by),
"metadata")
primary <- as.character(lib$metadata[[metadata_key]])
fallback <- as.character(lib$metadata[[lookup_spec$fallback_by]])
primary_blank <- is.na(primary) | !nzchar(trimws(primary))
fallback_present <- !is.na(fallback) & nzchar(trimws(fallback))
filled <- primary_blank & fallback_present
primary[filled] <- fallback[filled]
lib$metadata[[metadata_key]] <- primary
key_merge_report <- data.table::data.table(
problem = "fallback_metadata_key",
column = metadata_key,
value = lookup_spec$fallback_by,
n = sum(filled)
)
}
coalesce_cols <- intersect(
names(lib$metadata),
setdiff(names(lookup_table), unname(lookup_key))
)
lib <- join_lib_metadata(lib, lookup_table, by = lookup_key)
join_report <- attr(lib, "join_report")
report(sprintf(
"metadata lookup %d/%d complete (matched=%d; unmatched=%d)",
i, length(lookups),
nrow(lib$metadata) - sum(join_report[
problem == "unmatched_metadata_key", n
]),
sum(join_report[problem == "unmatched_metadata_key", n])
))
lookup_reports[[paste0("lookup_", i)]] <- data.table::rbindlist(
list(key_merge_report, join_report), fill = TRUE
)
lib$metadata <- .lib_coalesce_joined_metadata(
lib$metadata, coalesce_cols,
lookup_precedence = !isTRUE(lookup_spec$fill_only)
)
}
}
if (!is.null(material_hierarchy)) {
report("joining the material hierarchy")
hierarchy <- lib_clean_metadata(.lib_read_lookup(material_hierarchy),
metadata_name_lookup,
clean_values = clean_metadata_values)
lib <- join_material_hierarchy(lib, hierarchy)
hierarchy_report <- attr(lib, "join_report")
report(sprintf(
"material hierarchy complete (unmatched=%d)",
sum(hierarchy_report[problem == "unmatched_metadata_key", n])
))
}
retention_stages <- .lib_library_stage_counts(
list(source = lib), stage = "prepared"
)[, artifact := NULL]
identity_index <- data.table::data.table(
sample_name = as.character(.lib_ids(lib, "sample_name")),
spectrum_identity = if ("spectrum_identity" %in% names(lib$metadata)) {
as.character(lib$metadata$spectrum_identity)
} else {
NA_character_
}
)
if (!is.null(exclude_ids)) {
before <- ncol(lib$spectra)
lib <- .lib_filter_excluded(lib, exclude_ids, id_col = id_col)
build_stage_report <- data.table::rbindlist(list(
build_stage_report,
data.table::data.table(
stage = "excluded_identifiers", spectra = ncol(lib$spectra),
removed = before - ncol(lib$spectra)
)
))
report(sprintf("removed %d excluded identifier(s)",
before - ncol(lib$spectra)))
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(
list(source = lib), stage = "post_exclusion"
)[, artifact := NULL]
))
if (dedupe) {
before <- ncol(lib$spectra)
report("generating identifiers and removing duplicate spectra")
existing <- .lib_dedupe_existing_ids(
lib,
id_col = id_col,
duplicate = dedupe_duplicate
)
lib <- if (is.null(existing)) {
dedupe_spec(lib, id_col = id_col, ...)
} else {
existing
}
if (!is.null(exclude_ids)) {
lib <- .lib_filter_excluded(lib, exclude_ids, id_col = id_col)
}
build_stage_report <- data.table::rbindlist(list(
build_stage_report,
data.table::data.table(
stage = "deduplicated", spectra = ncol(lib$spectra),
removed = before - ncol(lib$spectra)
)
))
report(sprintf("deduplication complete (removed=%d; retained=%d)",
before - ncol(lib$spectra), ncol(lib$spectra)))
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(
list(source = lib), stage = "core"
)[, artifact := NULL]
))
retained_ids <- as.character(.lib_ids(lib, "sample_name"))
dropped_identities <- identity_index[!sample_name %in% retained_ids &
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(spectrum_identity)))]
apply_recipe <- function(recipe, recipe_name, recipe_index) {
report(sprintf(
"processing recipe %d/%d (%s)",
recipe_index, length(recipes), recipe_name
))
out <- if (is.function(recipe)) {
recipe(lib)
} else if (length(recipe) == 0L) {
lib
} else {
do.call(process_spec, c(list(lib), recipe))
}
if (!is_OpenSpecy(out)) {
stop("Each recipe must return an OpenSpecy object", call. = FALSE)
}
if (isTRUE(signal_noise)) {
report(sprintf("calculating signal-to-noise (%s)", recipe_name))
out$metadata$sn <- sig_noise(out, step = 10)
}
if (isTRUE(assess)) {
report(sprintf("assessing spectra (%s)", recipe_name))
assessment <- assess_spec(out)
out$metadata[, `:=`(
assessment_flag = FALSE,
assessment_issue_count = 0L,
assessment_checks = NA_character_,
assessment_issues = NA_character_,
assessment_potential_fixes = NA_character_
)]
if (nrow(assessment) > 0L) {
summary <- assessment[, .(
assessment_flag = TRUE,
assessment_issue_count = .N,
assessment_checks = paste(unique(get("check")), collapse = "; "),
assessment_issues = paste(unique(get("issue")), collapse = "; "),
assessment_potential_fixes = paste(unique(get("potential_fix")),
collapse = "; ")
), by = "spectrum_id"]
idx <- match(colnames(out$spectra), summary$spectrum_id)
found <- !is.na(idx)
assessment_cols <- setdiff(names(summary), "spectrum_id")
assessment_values <- summary[idx[found], assessment_cols, with = FALSE]
out$metadata[found, (assessment_cols) := assessment_values]
}
}
if (!is.null(prune) && recipe_name %in% names(prune)) {
report(sprintf("pruning library (%s)", recipe_name))
prune_args <- prune[[recipe_name]]
if (is.null(prune_args)) prune_args <- list()
if (!is.list(prune_args) ||
(!is.null(names(prune_args)) && any(names(prune_args) == ""))) {
stop("Each selected 'prune' recipe must contain a named argument list",
call. = FALSE)
}
prune_args$return <- "object"
if (is.null(prune_args$progress)) prune_args$progress <- progress
out <- do.call(prune_lib, c(list(out), prune_args))
}
if (length(lookup_reports) > 0L) {
attr(out, "metadata_lookup_reports") <- lookup_reports
}
attr(out, "spectrum_identity_cleanup_report") <- identity_cleanup_report
attr(out, "build_stage_report") <- build_stage_report
attr(out, "dropped_spectrum_identities") <- dropped_identities
recipe_retention <- data.table::copy(retention_stages)
recipe_retention[, artifact := recipe_name]
data.table::setcolorder(
recipe_retention, c("stage", "artifact", "library_name", "spectra")
)
attr(out, "library_retention_stages") <- recipe_retention
out
}
if (is.null(names(recipes)) || any(names(recipes) == "") ||
anyDuplicated(names(recipes))) {
stop("'recipes' must be a uniquely named list", call. = FALSE)
}
if (!is.null(prune)) {
if (!is.list(prune) || is.null(names(prune)) ||
any(is.na(names(prune)) | names(prune) == "") ||
anyDuplicated(names(prune))) {
stop("'prune' must be NULL or a uniquely named list", call. = FALSE)
}
unknown_prune <- setdiff(names(prune), names(recipes))
if (length(unknown_prune) > 0L) {
stop("'prune' names must identify recipes: ",
paste(unknown_prune, collapse = ", "), call. = FALSE)
}
}
out <- lapply(seq_along(recipes), function(i) {
apply_recipe(recipes[[i]], names(recipes)[[i]], i)
})
names(out) <- names(recipes)
report("complete")
out
}
.lib_clean_spectrum_identity <- function(x) {
out <- trimws(as.character(x))
missing <- is.na(out)
windows_path <- grepl("^[A-Za-z]:[\\\\/]", out) |
grepl("\\\\", out)
unix_path <- grepl("^(?:/|\\./|\\.\\./)", out, perl = TRUE)
out <- gsub("\\\\", "/", out)
extensions <- .supported_spectrum_extensions()
pattern <- paste0(
"\\.(?:", paste(extensions, collapse = "|"), ")$"
)
suffixed_path <- grepl("/", out, fixed = TRUE) &
grepl(pattern, out, ignore.case = TRUE, perl = TRUE)
path <- windows_path | unix_path | suffixed_path
out[path] <- sub(".*/", "", out[path])
repeat {
cleaned <- sub(pattern, "", out, ignore.case = TRUE, perl = TRUE)
if (identical(cleaned, out)) break
out <- cleaned
}
out <- trimws(out)
out[missing | !nzchar(out)] <- NA_character_
out
}
#' Predict blank class-reference values with reviewed regex rules
#'
#' Applies a separate regex reference only to rows whose `material` is blank.
#' Populated exact materials are authoritative and are never overwritten, even
#' when a regex also matches them. A blank row is filled only when all matching
#' patterns name one material. Distinct-material matches remain blank and are
#' reported as clashes. Exact/regex overlaps are allowed and reported for QA.
#' If present, `match_identity` is used for pattern matching while
#' `spectrum_identity` remains the reported exact identity.
#'
#' @param metadata A data.frame or data.table with `spectrum_identity` and
#' `material` columns. Row order is preserved.
#' @param regex_reference A data.frame or data.table with unique `pattern` and
#' nonblank `material` columns.
#' @param return Return the updated table or an audit containing `data`,
#' `summary`, `predictions`, `clashes`, and `overlaps`.
#'
#' @return An updated data.table, or an audit list when `return = "report"`.
#' @export
predict_class_reference <- function(metadata, regex_reference,
return = c("table", "report")) {
return <- match.arg(return)
out <- data.table::as.data.table(data.table::copy(metadata))
rules <- data.table::as.data.table(data.table::copy(regex_reference))
.lib_require_cols(out, c("spectrum_identity", "material"),
"metadata")
.lib_require_cols(rules, c("pattern", "material"), "regex reference")
out$spectrum_identity <- as.character(out$spectrum_identity)
out$material <- as.character(out$material)
rules$pattern <- as.character(rules$pattern)
rules$material <- as.character(rules$material)
blank <- function(value) {
is.na(value) | !nzchar(trimws(as.character(value)))
}
if (any(blank(rules$pattern)) || any(blank(rules$material))) {
stop("Regex-reference patterns and materials must be nonblank",
call. = FALSE)
}
if (anyDuplicated(rules$pattern)) {
stop("Regex-reference patterns must be unique", call. = FALSE)
}
match_value <- if ("match_identity" %in% names(out)) {
value <- as.character(out$match_identity)
value[blank(value)] <- out$spectrum_identity[blank(value)]
value
} else {
out$spectrum_identity
}
missing_identity <- blank(match_value)
match_value[missing_identity] <- ""
hits <- matrix(FALSE, nrow = nrow(out), ncol = nrow(rules))
if (nrow(rules) > 0L && nrow(out) > 0L) {
hits <- vapply(seq_len(nrow(rules)), function(i) {
tryCatch(
grepl(rules$pattern[[i]], match_value, perl = TRUE),
warning = function(w) {
stop("Invalid class regex '", rules$pattern[[i]], "': ",
conditionMessage(w), call. = FALSE)
},
error = function(e) {
stop("Invalid class regex '", rules$pattern[[i]], "': ",
conditionMessage(e), call. = FALSE)
}
)
}, logical(nrow(out)))
if (is.null(dim(hits))) hits <- matrix(hits, ncol = 1L)
}
if (any(missing_identity) && ncol(hits) > 0L) {
hits[missing_identity, ] <- FALSE
}
matched_materials <- lapply(seq_len(nrow(out)), function(i) {
unique(rules$material[which(hits[i, ])])
})
matched_patterns <- lapply(seq_len(nrow(out)), function(i) {
rules$pattern[which(hits[i, ])]
})
blank_material <- blank(out$material)
unique_match <- lengths(matched_materials) == 1L
clash <- lengths(matched_materials) > 1L
predict <- blank_material & unique_match
out$material[predict] <- vapply(
matched_materials[predict], `[[`, character(1), 1L
)
prediction_rows <- which(predict)
predictions <- data.table::data.table(
spectrum_identity = out$spectrum_identity[prediction_rows],
match_identity = match_value[prediction_rows],
material = out$material[prediction_rows],
patterns = vapply(matched_patterns[prediction_rows], paste,
character(1), collapse = "; ")
)[, .(n = .N), by = .(spectrum_identity, match_identity, material, patterns)]
clash_rows <- which(blank_material & clash)
clashes <- if (length(clash_rows) == 0L) {
data.table::data.table(
spectrum_identity = character(), match_identity = character(),
materials = character(), patterns = character(), n = integer()
)
} else {
data.table::data.table(
spectrum_identity = out$spectrum_identity[clash_rows],
match_identity = match_value[clash_rows],
materials = vapply(matched_materials[clash_rows], paste,
character(1), collapse = "; "),
patterns = vapply(matched_patterns[clash_rows], paste,
character(1), collapse = "; ")
)[, .(n = .N),
by = .(spectrum_identity, match_identity, materials, patterns)]
}
overlap_rows <- which(!blank_material & lengths(matched_materials) > 0L)
overlaps <- data.table::data.table(
spectrum_identity = out$spectrum_identity[overlap_rows],
exact_material = out$material[overlap_rows],
regex_materials = vapply(matched_materials[overlap_rows], paste,
character(1), collapse = "; "),
patterns = vapply(matched_patterns[overlap_rows], paste,
character(1), collapse = "; ")
)[, agreement := vapply(seq_len(.N), function(i) {
exact_material[[i]] %in% strsplit(regex_materials[[i]], "; ", fixed = TRUE)[[1L]]
}, logical(1))][, .(n = .N),
by = .(spectrum_identity, exact_material, regex_materials,
patterns, agreement)]
summary <- data.table::data.table(
rows = nrow(out), regex_rules = nrow(rules),
existing = sum(!blank_material), predicted = sum(predict),
clashes = length(clash_rows), overlaps = length(overlap_rows),
unmatched = sum(blank(out$material))
)
if (return == "report") {
return(list(data = out, summary = summary, predictions = predictions,
clashes = clashes, overlaps = overlaps))
}
out
}
# Complete official reference-library class coverage while retaining uncertain
# identities as an explicit review queue. This stays internal because the two
# normalization rules and the reviewed one-percent cap are specific to the
# official library, not a general package API.
.lib_complete_reference_classes <- function(x, classes, hierarchy,
enforce_other_limit = TRUE) {
metadata <- data.table::copy(x$metadata)
blank <- function(value) {
value <- as.character(value)
is.na(value) | !nzchar(trimws(value))
}
missing_before <- blank(metadata$material_class)
identity <- as.character(metadata$spectrum_identity)
user <- as.character(metadata$user_name)
lookup_key <- identity
assignment <- ifelse(missing_before, NA_character_, "existing_or_exact_lookup")
exact_classes <- classes
normalized_key <- rep(NA_character_, nrow(metadata))
direct <- missing_before & !is.na(identity) &
!is.na(match(identity, exact_classes$spectrum_identity))
normalized_key[direct] <- identity[direct]
gicquel <- missing_before & is.na(normalized_key) & !is.na(user) &
user == "gicquel et al. 2024" & !is.na(identity)
normalized_key[gicquel] <- sub(
"_ref(?:_0)?(?:[.]csv)?$", "", identity[gicquel], perl = TRUE
)
mffrc <- missing_before & is.na(normalized_key) & !is.na(user) &
user == "elise granek and kellie teague" & !is.na(identity)
mffrc_base <- sub("[.][0-9]+$", "", identity[mffrc])
mffrc_base <- sub("^mffrc[0-9]+_", "", mffrc_base)
mffrc_base <- sub("_.*$", "", mffrc_base)
mffrc_family <- trimws(sub("[[:space:]]*[(].*$", "", mffrc_base))
mffrc_key <- mffrc_base
use_family <- is.na(match(mffrc_key, exact_classes$spectrum_identity)) &
!is.na(match(mffrc_family, exact_classes$spectrum_identity))
mffrc_key[use_family] <- mffrc_family[use_family]
normalized_key[mffrc] <- mffrc_key
normalized_material <- exact_classes$material[
match(normalized_key, exact_classes$spectrum_identity)
]
resolved <- missing_before & !blank(normalized_material)
lookup_key[resolved] <- normalized_key[resolved]
metadata$material[resolved] <- normalized_material[resolved]
hierarchy_material <- match(metadata$material[resolved], hierarchy$material)
resolved_rows <- which(resolved)
material_rows <- resolved_rows[!is.na(hierarchy_material)]
material_lookup <- hierarchy_material[!is.na(hierarchy_material)]
if (length(material_rows) > 0L) {
metadata$material_class[material_rows] <- hierarchy$material_class[material_lookup]
metadata$material_type[material_rows] <- hierarchy$material_type[material_lookup]
}
class_pairs <- unique(hierarchy[, .(material_class, material_type)])
missing_class_rows <- which(
blank(metadata$material_class) & !blank(metadata$material)
)
reviewed_class_rows <- integer()
if (length(missing_class_rows) > 0L) {
class_lookup <- match(metadata$material[missing_class_rows],
class_pairs$material_class)
reviewed_class_rows <- missing_class_rows[!is.na(class_lookup)]
metadata$material_class[reviewed_class_rows] <-
metadata$material[reviewed_class_rows]
metadata$material_type[reviewed_class_rows] <-
class_pairs$material_type[class_lookup[!is.na(class_lookup)]]
}
source_resolved <- resolved & !blank(metadata$material_class)
assignment[source_resolved] <- "reviewed_source_key"
reviewed_class_key <- seq_len(nrow(metadata)) %in% reviewed_class_rows &
!source_resolved
assignment[reviewed_class_key] <- "reviewed_class_key"
unresolved <- blank(metadata$material_class)
metadata$material[unresolved] <- "other"
metadata$material_class[unresolved] <- "other"
metadata$material_type[unresolved] <- "other"
lookup_key[unresolved] <- identity[unresolved]
assignment[unresolved] <- "unresolved_identity"
other <- !blank(metadata$material_class) &
tolower(trimws(metadata$material_class)) == "other"
other_fraction <- if (nrow(metadata)) sum(other) / nrow(metadata) else 0
if (isTRUE(enforce_other_limit) && other_fraction > 0.01) {
stop(sprintf(
paste0(
"The 'other' class is %.2f%% of the library (%d/%d), above the ",
"reviewed 1%% maximum; review exact class mappings for: %s"
),
100 * other_fraction, sum(other), nrow(metadata),
paste(head(unique(identity[other]), 20L), collapse = ", ")
), call. = FALSE)
}
metadata[, `:=`(class_lookup_key = lookup_key,
class_assignment_reason = assignment)]
report <- data.table::data.table(
stage = c("before", "after"),
populated_class = c(sum(!missing_before), sum(!blank(metadata$material_class))),
reviewed_source_key = c(0L, sum(source_resolved)),
reviewed_class_key = c(0L, sum(reviewed_class_key)),
unclassified = c(0L, 0L), unresolved_other = c(0L, sum(unresolved)),
other = c(0L, sum(other)), other_fraction = c(0, other_fraction),
total = nrow(metadata)
)
stopifnot(report[stage == "after", populated_class] == nrow(metadata))
x$metadata <- metadata
attr(x, "class_coverage_report") <- report
x
}
.lib_other_review_schema <- function() {
data.table::data.table(
artifact = character(), source_row = integer(), spectrum_id = character(),
spectrum_identity = character(), sample_id = character(),
file_name = character(), library_name = character(),
organization = character(), user_name = character(),
citation = character(), other_info = character(), material = character(),
material_class = character(), material_type = character(),
spectrum_type = character(), generic_fields = character(),
reason = character(), action = character()
)
}
.lib_other_filter_schema <- function() {
data.table::data.table(
artifact = character(), action = character(), before = integer(),
candidates = integer(), missing_identity = integer(),
generic_label = integer(), removed = integer(), after = integer()
)
}
.lib_apply_other_policy <- function(libraries, remove_other, report = NULL) {
generic_labels <- c("other", "other plastic", "other material")
reviews <- list()
summaries <- list()
value <- function(metadata, column) {
if (column %in% names(metadata)) as.character(metadata[[column]]) else
rep(NA_character_, nrow(metadata))
}
for (artifact in names(libraries)) {
object <- libraries[[artifact]]
metadata <- object$metadata
identity <- value(metadata, "spectrum_identity")
missing_identity <- is.na(identity) | !nzchar(trimws(identity))
label_columns <- c("material", "material_class", "material_type")
generic_matrix <- vapply(label_columns, function(column) {
tolower(trimws(value(metadata, column))) %in% generic_labels
}, logical(nrow(metadata)))
if (is.null(dim(generic_matrix))) {
generic_matrix <- matrix(generic_matrix, ncol = length(label_columns))
}
generic <- rowSums(generic_matrix) > 0L
candidates <- missing_identity | generic
unresolved <- rowSums(vapply(label_columns, function(column) {
label <- tolower(trimws(value(metadata, column)))
!is.na(label) & label == "other"
}, logical(nrow(metadata)))) > 0L
remove <- isTRUE(remove_other) & (missing_identity | unresolved)
if (any(candidates)) {
rows <- which(candidates)
triggered <- apply(generic_matrix[rows, , drop = FALSE], 1L, function(x) {
paste(label_columns[x], collapse = "; ")
})
review <- data.table::data.table(
artifact = artifact,
source_row = as.integer(rows),
spectrum_id = as.character(.lib_ids(object, "sample_name"))[rows],
spectrum_identity = identity[rows],
sample_id = value(metadata, "sample_id")[rows],
file_name = value(metadata, "file_name")[rows],
library_name = value(metadata, "library_name")[rows],
organization = value(metadata, "organization")[rows],
user_name = value(metadata, "user_name")[rows],
citation = value(metadata, "citation")[rows],
other_info = value(metadata, "other_info")[rows],
material = value(metadata, "material")[rows],
material_class = value(metadata, "material_class")[rows],
material_type = value(metadata, "material_type")[rows],
spectrum_type = value(metadata, "spectrum_type")[rows],
generic_fields = triggered,
reason = data.table::fcase(
missing_identity[rows], "missing_spectrum_identity",
unresolved[rows], "unresolved_other_label",
default = "reviewed_broad_category"
),
action = if (isTRUE(remove_other)) {
ifelse(remove[rows], "removed", "retained_reviewed_broad_category")
} else {
rep("retained_for_semisupervised_reassignment", length(rows))
}
)
reviews[[artifact]] <- review
}
before <- ncol(object$spectra)
if (any(remove)) {
if (all(remove)) {
stop("Removing blank identities and unresolved classes would remove every ",
"spectrum from ", artifact, call. = FALSE)
}
object <- filter_spec(object, !remove)
}
summary <- data.table::data.table(
artifact = artifact,
action = if (isTRUE(remove_other)) {
"remove_unresolved_retain_reviewed_broad"
} else {
"retain_for_semisupervised_reassignment"
},
before = as.integer(before),
candidates = as.integer(sum(candidates)),
missing_identity = as.integer(sum(missing_identity)),
generic_label = as.integer(sum(generic)),
removed = as.integer(sum(remove)),
after = as.integer(ncol(object$spectra))
)
summaries[[artifact]] <- summary
attr(object, "other_review_report") <- if (is.null(reviews[[artifact]])) {
.lib_other_review_schema()
} else {
reviews[[artifact]]
}
attr(object, "other_filter_report") <- summary
libraries[[artifact]] <- object
if (is.function(report)) report(sprintf(
paste0("generic review %s: candidates=%d (missing identity=%d; ",
"generic label=%d); action=%s; affected=%d; library retained=%d"),
artifact, sum(candidates), sum(missing_identity), sum(generic),
if (isTRUE(remove_other)) "reviewed/removed unresolved" else
"queued for reassignment",
sum(remove),
ncol(object$spectra)
))
}
list(
libraries = libraries,
review = if (length(reviews)) {
data.table::rbindlist(reviews, fill = TRUE)
} else {
.lib_other_review_schema()
},
summary = if (length(summaries)) {
data.table::rbindlist(summaries, fill = TRUE)
} else {
.lib_other_filter_schema()
}
)
}
.lib_prepare_sources <- function(sources, range, res, metadata_name_lookup,
clean_metadata_values, convert_intensity,
id_col, hash_scale, hash_algo, report) {
records <- vector("list", length(sources))
for (i in seq_along(sources)) {
if (i == 1L || i == length(sources) || i %% 2500L == 0L) {
report(sprintf("preparing source object %d/%d", i, length(sources)))
}
records[[i]] <- .lib_source_record(
sources[[i]],
i,
id_col = id_col,
hash_scale = hash_scale,
hash_algo = hash_algo
)
}
.lib_prepare_records(
records,
range = range,
res = res,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
report = report
)
}
.lib_prepare_records <- function(records, range, res, metadata_name_lookup,
clean_metadata_values, convert_intensity,
report) {
metadata <- .lib_combined_metadata(
records,
metadata_name_lookup,
clean_metadata_values = clean_metadata_values
)
if (isTRUE(convert_intensity)) {
converted <- .lib_convert_records_intensity(
records,
metadata,
source_label = "source list"
)
records <- converted$records
metadata <- converted$metadata
}
shared_axis <- .lib_same_wavenumber(records)
if (length(records) > 1L) {
if (shared_axis) {
report(sprintf(
"combining %d same-axis source object(s)",
length(records)
))
} else {
report(sprintf(
"merging %d source object(s) with c_spec()",
length(records)
))
}
}
if (length(records) == 1L) {
return(.lib_combine_same_axis_records(
records,
metadata,
range = NULL,
res = res
))
}
if (shared_axis) {
return(.lib_combine_same_axis_records(
records,
metadata,
range = range,
res = res
))
}
.lib_combine_variable_axis_records(
records,
metadata,
range = range,
res = res
)
}
.lib_source_record <- function(source, index, id_col = NULL,
hash_scale = 100, hash_algo = "md5") {
if (!is_OpenSpecy(source)) {
stop("Source ", index, " must be an OpenSpecy object", call. = FALSE)
}
spectra <- .as_spectra_matrix(source$spectra, message_conversion = FALSE)
wavenumber <- source$wavenumber
if (!is.numeric(wavenumber) || !is.vector(wavenumber)) {
stop("Source ", index, " wavenumber must be a numeric vector",
call. = FALSE)
}
if (length(wavenumber) != nrow(spectra)) {
stop("Source ", index, " wavenumber length must match spectra rows",
call. = FALSE)
}
ord <- order(wavenumber)
if (!identical(ord, seq_along(wavenumber))) {
wavenumber <- wavenumber[ord]
spectra <- spectra[ord, , drop = FALSE]
}
metadata <- data.table::as.data.table(data.table::copy(source$metadata))
if (nrow(metadata) != ncol(spectra)) {
stop("Source ", index, " metadata rows must match spectra columns",
call. = FALSE)
}
if (!is.null(id_col)) {
source_ids <- .lib_source_hash_ids(
wavenumber,
spectra,
metadata,
scale = hash_scale,
algo = hash_algo
)
metadata[[id_col]] <- source_ids$current
metadata[[paste0(id_col, "_old")]] <- source_ids$old
colnames(spectra) <- source_ids$current
}
object_unit <- attr(source, "intensity_unit", exact = TRUE)
object_unit <- as.character(object_unit)
object_unit <- object_unit[!is.na(object_unit) & trimws(object_unit) != ""]
if (length(object_unit) > 1L) {
stop("Source ", index,
" attribute 'intensity_unit' must contain at most one value",
call. = FALSE)
}
attribute_names <- c("intensity_unit", "derivative_order", "baseline",
"spectra_type")
attrs <- lapply(attribute_names, attr, x = source)
names(attrs) <- attribute_names
list(
wavenumber = wavenumber,
spectra = spectra,
metadata = metadata,
n = ncol(spectra),
intensity_attr = if (length(object_unit) == 1L) object_unit else NA_character_,
attrs = attrs
)
}
.lib_source_hash_ids <- function(wavenumber, spectra, metadata, scale = 100,
algo = "md5") {
ignored_info <- .spectra_ignore_info(spectra, lead_tail_only = TRUE,
ig = c(NA))
if (any(!ignored_info$has_valid)) {
stop("All intensity values are NA, cannot remove or ignore with manage na.",
call. = FALSE)
}
keep <- rowSums(ignored_info$ignored) == 0L
if (!any(keep)) {
ids <- lapply(seq_len(ncol(spectra)), function(i) {
valid <- !ignored_info$ignored[, i]
current <- .lib_hash_processed_matrix(
wavenumber[valid], spectra[valid, i, drop = FALSE],
range = NULL, res = 8, scale = scale, algo = algo
)
old <- .lib_hash_processed_matrix(
wavenumber[valid], spectra[valid, i, drop = FALSE],
range = c(100, 4000), res = 8, scale = scale, algo = algo,
min_rows = 3L, short_value = "new format"
)
list(current = current[[1L]], old = old[[1L]])
})
return(list(
current = vapply(ids, `[[`, character(1), "current"),
old = vapply(ids, `[[`, character(1), "old")
))
}
wavenumber <- wavenumber[keep]
spectra <- spectra[keep, , drop = FALSE]
current <- .lib_hash_processed_matrix(
wavenumber,
spectra,
range = NULL,
res = 8,
scale = scale,
algo = algo
)
old <- .lib_hash_processed_matrix(
wavenumber,
spectra,
range = c(100, 4000),
res = 8,
scale = scale,
algo = algo,
min_rows = 3L,
short_value = "new format"
)
list(current = current, old = old)
}
.lib_hash_processed_matrix <- function(wavenumber, spectra, range = NULL,
res = 8, scale = 100, algo = "md5",
min_rows = 1L,
short_value = NA_character_) {
conformed <- .lib_conform_hash_matrix(wavenumber, spectra, range = range,
res = res)
if (nrow(conformed$spectra) < min_rows) {
return(rep(short_value, ncol(spectra)))
}
smoothed <- .sgfilt_matrix(conformed$spectra, p = 3, n = 11, m = 1)
smoothed <- make_rel(abs(smoothed))
.lib_hash_spectra_columns(conformed$wavenumber, smoothed, scale, algo)
}
.lib_conform_hash_matrix <- function(wavenumber, spectra, range = NULL,
res = 8) {
if (is.null(range)) range <- wavenumber
range2 <- c(max(min(range), min(wavenumber)),
min(max(range), max(wavenumber)))
wn <- conform_res(range2, res = res)
spectra <- .conform_intens_matrix(
x = wavenumber,
y = spectra,
xout = wn
)
list(wavenumber = wn, spectra = spectra)
}
.lib_hash_spectra_columns <- function(wavenumber, spectra, scale = 100,
algo = "md5") {
vapply(seq_len(ncol(spectra)), function(i) {
digest::digest(
list(as.integer(wavenumber), as.integer(spectra[, i] * scale)),
algo = algo
)
}, FUN.VALUE = character(1))
}
.lib_combined_metadata <- function(records, metadata_name_lookup,
clean_metadata_values = FALSE) {
metadata <- data.table::rbindlist(
lapply(records, `[[`, "metadata"),
fill = TRUE
)
metadata <- .lib_normalize_metadata_encoding(metadata)
metadata <- lib_clean_metadata(
metadata,
metadata_name_lookup,
clean_values = clean_metadata_values
)
metadata <- metadata[, setdiff(names(metadata), c("x", "y")), with = FALSE]
metadata
}
.lib_normalize_metadata_encoding <- function(metadata) {
metadata <- data.table::as.data.table(data.table::copy(metadata))
for (column in names(metadata)) {
value <- metadata[[column]]
if (!is.character(value) && !is.factor(value)) next
value <- iconv(as.character(value), from = "", to = "UTF-8", sub = "")
data.table::set(metadata, j = column, value = value)
}
metadata
}
.lib_same_wavenumber <- function(records) {
if (length(records) <= 1L) return(TRUE)
first <- records[[1L]]$wavenumber
all(vapply(records[-1L], function(record) {
identical(record$wavenumber, first)
}, logical(1)))
}
.lib_common_record_attributes <- function(records) {
attribute_names <- c("intensity_unit", "derivative_order", "baseline",
"spectra_type")
out <- lapply(attribute_names, function(nm) {
values <- lapply(records, function(record) record$attrs[[nm]])
if (all(vapply(values[-1L], identical, logical(1), values[[1L]]))) {
values[[1L]]
} else {
NULL
}
})
names(out) <- attribute_names
out
}
.lib_make_open_specy <- function(wavenumber, spectra, metadata, attributes) {
metadata <- data.table::as.data.table(data.table::copy(metadata))
metadata$col_id <- colnames(spectra)
structure(
list(wavenumber = wavenumber, spectra = spectra, metadata = metadata),
class = c("OpenSpecy", "list"),
intensity_unit = attributes$intensity_unit,
derivative_order = attributes$derivative_order,
baseline = attributes$baseline,
spectra_type = attributes$spectra_type
)
}
.lib_combine_same_axis_records <- function(records, metadata, range, res) {
spectra <- do.call(cbind, lapply(records, `[[`, "spectra"))
colnames(spectra) <- make.unique(
unlist(lapply(records, function(record) colnames(record$spectra)),
use.names = FALSE),
sep = "."
)
attrs <- .lib_common_record_attributes(records)
lib <- .lib_make_open_specy(
records[[1L]]$wavenumber,
spectra,
metadata,
attrs
)
if (!is.null(range)) {
conform_range <- if (is.numeric(range)) {
range
} else if (length(range) == 1L && range %in% c("common", "full")) {
base::range(lib$wavenumber)
} else {
stop("If range is specified it should be numeric, 'full', or 'common'",
call. = FALSE)
}
lib <- conform_spec(
lib,
range = conform_range,
res = res,
allow_na = identical(range, "full") || is.numeric(range)
)
}
as_OpenSpecy(lib)
}
.lib_combine_variable_axis_records <- function(records, metadata, range, res) {
if (is.null(range)) {
stop("wavenumbers need to be identical between spectra; specify how; use ",
"'range' to specify how wavenumbers should be merged", call. = FALSE)
}
pmin <- vapply(records, function(record) min(record$wavenumber), numeric(1))
pmax <- vapply(records, function(record) max(record$wavenumber), numeric(1))
if (is.numeric(range)) {
target_range <- range
allow_na <- TRUE
} else if (length(range) == 1L && range %in% c("common", "full")) {
if (range == "common" &&
(any(max(pmin) > pmax) || any(min(pmax) < pmin))) {
stop("data points need to overlap in their ranges", call. = FALSE)
}
target_range <- if (range == "common") {
c(max(pmin), min(pmax))
} else {
c(min(pmin), max(pmax))
}
allow_na <- identical(range, "full")
} else {
stop("If range is specified it should be numeric, 'full', or 'common'",
call. = FALSE)
}
target_wn <- if (is.null(res)) {
sort(unique(unlist(lapply(records, function(record) {
record$wavenumber[
record$wavenumber >= min(target_range) &
record$wavenumber <= max(target_range)
]
}), use.names = FALSE)))
} else {
conform_res(target_range, res = res)
}
total_columns <- sum(vapply(records, `[[`, integer(1), "n"))
spectra <- matrix(
NA_real_, nrow = length(target_wn), ncol = total_columns
)
source_names <- unlist(lapply(records, function(record) {
colnames(record$spectra)
}), use.names = FALSE)
colnames(spectra) <- make.unique(source_names, sep = ".")
starts <- cumsum(c(1L, head(vapply(records, `[[`, integer(1), "n"), -1L)))
for (i in seq_along(records)) {
record <- records[[i]]
local_range <- c(
max(min(target_range), min(record$wavenumber)),
min(max(target_range), max(record$wavenumber))
)
local_wn <- if (is.null(res)) {
target_wn[target_wn >= min(record$wavenumber) &
target_wn <= max(record$wavenumber)]
} else {
conform_res(local_range, res = res)
}
conformed <- .conform_intens_matrix(
x = record$wavenumber,
y = record$spectra,
xout = local_wn
)
if (!allow_na && !identical(local_wn, target_wn)) {
stop("data points need to overlap in their ranges", call. = FALSE)
}
rows <- match(local_wn, target_wn)
columns <- starts[[i]] + seq_len(record$n) - 1L
spectra[rows, columns] <- conformed
records[[i]]$spectra <- NULL
rm(record, conformed)
}
.lib_make_open_specy(
target_wn,
spectra,
metadata,
.lib_common_record_attributes(records)
) |>
as_OpenSpecy()
}
.lib_convert_records_intensity <- function(records, metadata,
source_label = "source") {
attr_units <- unlist(lapply(records, function(record) {
rep(record$intensity_attr, record$n)
}), use.names = FALSE)
has_attr_unit <- !is.na(attr_units)
if (any(has_attr_unit)) {
if (!"intensity_units" %in% names(metadata)) {
metadata$intensity_units <- NA_character_
}
metadata$intensity_units[has_attr_unit] <- attr_units[has_attr_unit]
}
declared <- if ("intensity_units" %in% names(metadata)) {
as.character(metadata$intensity_units)
} else {
rep(NA_character_, nrow(metadata))
}
canonical <- .lib_canonical_intensity_unit(declared)
starts <- cumsum(c(1L, head(vapply(records, `[[`, integer(1), "n"), -1L)))
for (i in seq_along(records)) {
cols <- starts[[i]] + seq_len(records[[i]]$n) - 1L
records[[i]]$spectra <- .lib_convert_spectra_matrix(
records[[i]]$spectra,
canonical[cols]
)
resolved_i <- !is.na(canonical[cols])
if (all(resolved_i)) {
records[[i]]$attrs$intensity_unit <- "absorbance"
}
}
resolved <- !is.na(canonical)
if (any(resolved)) {
if (!"intensity_units" %in% names(metadata)) {
metadata$intensity_units <- NA_character_
}
metadata$intensity_units[resolved] <- "absorbance"
}
.lib_warn_unknown_intensity(declared, resolved, source_label)
list(records = records, metadata = metadata)
}
.lib_convert_spectra_matrix <- function(spectra, canonical) {
for (type in c("reflectance", "transmittance")) {
idx <- which(canonical == type)
if (length(idx) > 0L) {
spectra[, idx] <- switch(
type,
reflectance = (1 - spectra[, idx, drop = FALSE] / 100)^2 /
(2 * spectra[, idx, drop = FALSE] / 100),
transmittance = log(1 / .matrix_adj_neg(
spectra[, idx, drop = FALSE], na.rm = TRUE
))
)
}
}
spectra
}
.lib_warn_unknown_intensity <- function(declared, resolved, source_label) {
if (!any(!resolved)) return(invisible(NULL))
unresolved <- trimws(as.character(declared[!resolved]))
unresolved[is.na(unresolved) | unresolved == ""] <- "<missing>"
counts <- sort(table(unresolved), decreasing = TRUE)
details <- paste0(names(counts), " (", as.integer(counts), ")")
warning(
"Automatic intensity conversion skipped ", sum(!resolved),
" spectrum/s in ", source_label, " with unknown units: ",
paste(details, collapse = ", "),
". Set attr(x, 'intensity_unit') or metadata$intensity_units to ",
"'absorbance', 'reflectance', or 'transmittance'; use ",
"convert_intensity = FALSE to preserve units without conversion.",
call. = FALSE
)
invisible(NULL)
}
.lib_canonical_intensity_unit <- function(x) {
value <- trimws(tolower(iconv(as.character(x), to = "ASCII", sub = "")))
value[is.na(value) | value == ""] <- NA_character_
out <- rep(NA_character_, length(value))
out[!is.na(value) & grepl("absorb", value)] <- "absorbance"
out[!is.na(value) & grepl("reflec", value)] <- "reflectance"
out[!is.na(value) & grepl("transm", value)] <- "transmittance"
out
}
.lib_convert_intensity <- function(x, source_label = "source") {
x <- as_OpenSpecy(x)
object_unit <- attr(x, "intensity_unit", exact = TRUE)
object_unit <- as.character(object_unit)
object_unit <- object_unit[!is.na(object_unit) & trimws(object_unit) != ""]
if (length(object_unit) > 1L) {
stop("Object attribute 'intensity_unit' must contain at most one value",
call. = FALSE)
}
from_attribute <- length(object_unit) == 1L
declared <- if (from_attribute) {
rep(object_unit, ncol(x$spectra))
} else if ("intensity_units" %in% names(x$metadata)) {
as.character(x$metadata$intensity_units)
} else {
rep(NA_character_, ncol(x$spectra))
}
canonical <- .lib_canonical_intensity_unit(declared)
for (type in c("reflectance", "transmittance")) {
idx <- which(canonical == type)
if (length(idx) > 0L) {
converted <- adj_intens(
filter_spec(x, idx),
type = type,
make_rel = FALSE
)
x$spectra[, idx] <- converted$spectra
}
}
resolved <- !is.na(canonical)
if (any(resolved)) {
if (!"intensity_units" %in% names(x$metadata)) {
x$metadata$intensity_units <- NA_character_
}
x$metadata$intensity_units[resolved] <- "absorbance"
}
if (all(resolved)) {
attr(x, "intensity_unit") <- "absorbance"
} else if (!from_attribute) {
attr(x, "intensity_unit") <- NULL
}
if (any(!resolved)) {
unresolved <- trimws(as.character(declared[!resolved]))
unresolved[is.na(unresolved) | unresolved == ""] <- "<missing>"
counts <- sort(table(unresolved), decreasing = TRUE)
details <- paste0(names(counts), " (", as.integer(counts), ")")
warning(
"Automatic intensity conversion skipped ", sum(!resolved),
" spectrum/s in ", source_label, " with unknown units: ",
paste(details, collapse = ", "),
". Set attr(x, 'intensity_unit') or metadata$intensity_units to ",
"'absorbance', 'reflectance', or 'transmittance'; use ",
"convert_intensity = FALSE to preserve units without conversion.",
call. = FALSE
)
}
x
}
#' Create and apply metadata-name lookup rules
#'
#' @description
#' \code{lib_metadata_name_lookup()} returns the default editable rules used to
#' merge synonymous metadata columns. \code{lib_clean_name()} converts names to
#' lowercase underscore form. \code{lib_clean_metadata()} cleans table names and
#' coalesces columns that map to the same canonical name.
#'
#' @details
#' Exact rules determine a column's target before automatic matching that can
#' ignore underscores and a single terminal plural \code{s}. When values are
#' coalesced, canonical and mechanically equivalent canonical names come before
#' semantic aliases. Regular-expression rules are applied last to names that
#' remain unmatched. Regex patterns are evaluated against names after
#' \code{lib_clean_name()} has been applied.
#'
#' Matching options selected in \code{lib_metadata_name_lookup()} are stored
#' with the returned table and used by \code{lib_clean_metadata()}. User rules
#' supplied through \code{...} are merged with the defaults. Set
#' \code{defaults = FALSE} to construct a lookup from only user rules.
#'
#' @param ... named character vectors of exact aliases, where each argument name
#' is the canonical name, or data.frame/data.table rule tables with
#' \code{canonical_name}, \code{source_name}, and optional \code{regex} columns.
#' @param regex an optional named character vector or named list of regular
#' expressions. Names identify the canonical metadata names.
#' @param defaults logical; whether to include OpenSpecy's default semantic
#' aliases before merging user rules.
#' @param match_without_underscores logical; whether names that differ only by
#' underscores should match automatically.
#' @param match_singular_plural logical; whether names that differ only by one
#' terminal \code{s} should match automatically.
#' @param x a character vector of names for \code{lib_clean_name()}, or a
#' data.frame/data.table for \code{lib_clean_metadata()}.
#' @param name_lookup a table returned by \code{lib_metadata_name_lookup()} or a
#' compatible rule table. Use \code{NULL} to clean names without alias merging.
#' @param clean_values logical; whether \code{lib_clean_metadata()} should also
#' lowercase, trim, ASCII-normalize, and normalize blank/unknown character or
#' factor metadata values.
#'
#' @return \code{lib_metadata_name_lookup()} returns a data.table of rules.
#' \code{lib_clean_name()} returns a character vector.
#' \code{lib_clean_metadata()} returns a data.table with cleaned, coalesced
#' columns.
#'
#' @examples
#' lib_clean_name(c("User Name", "Laser (%)", "Method...3"))
#'
#' name_lookup <- lib_metadata_name_lookup(
#' project_code = "campaign name",
#' regex = list(instrument_mode = "^method_[0-9]+$")
#' )
#' metadata <- data.frame(
#' UserName = c("A", NA),
#' user_name = c(NA, "B"),
#' Campaign.Name = c("one", "two"),
#' Method.23 = c("ftir", "raman")
#' )
#' lib_clean_metadata(metadata, name_lookup)
#'
#' @export
lib_metadata_name_lookup <- function(..., regex = NULL, defaults = TRUE,
match_without_underscores = TRUE,
match_singular_plural = TRUE) {
aliases <- if (isTRUE(defaults)) list(
sample_name = character(),
file_name = character(),
library_type = character(),
contact_info = character(),
organization = character(),
citation = character(),
spectrum_identity = c("substance", "interpretation"),
spectrum_type = character(),
material_form = c("description", "form_factor", "shape",
"form_film_foam_pliable_hard", "form", "state",
"morphology"),
material_producer = character(),
material_purity = character(),
material_quality = c("source_type"),
material_color = c("color", "colour"),
material_other = character(),
cas_number = c("cas_registry_no"),
instrument_used = c("spectrometer_datasystem"),
instrument_accessories = c("instrumentaccesories",
"external_diffuse_reflectance_accessory"),
instrument_mode = c("spectralcollectionmode", "method_3", "method_23"),
intensity_units = c("y_unit"),
data_type = c("datatype"),
wavenumber_units = c("xunits", "x_unit"),
spectral_resolution = c("resolution"),
laser_light_used = c("laser_nm", "laser_frequency"),
number_of_accumulations = c("number_of_sample_scans", "coadded_scans"),
total_acquisition_time_s = c("collection_length", "acq_time_s"),
data_processing_procedure = c("preprocessing", "data_processing",
"data_processing_proceedure"),
level_of_confidence_in_identification = character(),
other_info = c("otherinformation", "otherinfo", "comment", "comments",
"notes"),
baseline_correction = c("baseline"),
smoother = c("smooth"),
user_name = character(),
sample_id = character(),
spectrum_id = c("spectrumid"),
location_description = c("locationdescription"),
longest_dimension = character(),
width = character(),
source = c("source_database", "origin", "nist_source"),
date = c("longdate", "timestamp"),
phase_correction = character(),
apodization = c("apodization_function")
) else list()
rules <- lapply(names(aliases), function(canonical) {
data.table::data.table(
canonical_name = canonical,
source_name = c(canonical, aliases[[canonical]]),
regex = NA_character_
)
})
additions <- list(...)
addition_names <- names(additions)
if (is.null(addition_names)) addition_names <- rep("", length(additions))
for (i in seq_along(additions)) {
addition <- additions[[i]]
if (inherits(addition, c("data.frame", "data.table"))) {
addition <- data.table::as.data.table(data.table::copy(addition))
.lib_require_cols(addition, "canonical_name", "metadata name rule")
if (!"source_name" %in% names(addition)) {
addition$source_name <- NA_character_
}
if (!"regex" %in% names(addition)) addition$regex <- NA_character_
rules[[length(rules) + 1L]] <-
addition[, c("canonical_name", "source_name", "regex"), with = FALSE]
} else {
canonical <- addition_names[i]
if (is.na(canonical) || canonical == "") {
stop("Exact alias additions in '...' must be named or supplied as ",
"rule tables", call. = FALSE)
}
aliases_i <- unlist(addition, use.names = FALSE)
if (!is.character(aliases_i)) {
stop("Exact alias additions in '...' must be character vectors",
call. = FALSE)
}
rules[[length(rules) + 1L]] <- data.table::data.table(
canonical_name = canonical,
source_name = c(canonical, aliases_i),
regex = NA_character_
)
}
}
if (!is.null(regex)) {
if (!is.list(regex)) regex <- as.list(regex)
regex_names <- names(regex)
if (is.null(regex_names) || any(is.na(regex_names) | regex_names == "")) {
stop("'regex' must be a named character vector or named list",
call. = FALSE)
}
regex_rules <- lapply(seq_along(regex), function(i) {
patterns <- unlist(regex[[i]], use.names = FALSE)
if (!is.character(patterns)) {
stop("Each 'regex' entry must contain character patterns",
call. = FALSE)
}
data.table::data.table(
canonical_name = regex_names[i],
source_name = NA_character_,
regex = patterns
)
})
rules <- c(rules, regex_rules)
}
lookup <- if (length(rules) == 0L) {
data.table::data.table(
canonical_name = character(),
source_name = character(),
regex = character()
)
} else {
data.table::rbindlist(rules, use.names = TRUE, fill = TRUE)
}
lookup$canonical_name <- lib_clean_name(lookup$canonical_name)
exact <- !is.na(lookup$source_name)
lookup$source_name[exact] <- lib_clean_name(lookup$source_name[exact])
empty_regex <- !is.na(lookup$regex) & lookup$regex == ""
lookup$regex[empty_regex] <- NA_character_
lookup <- unique(lookup)
has_source <- !is.na(lookup$source_name)
has_regex <- !is.na(lookup$regex)
if (any(has_source == has_regex)) {
stop("Each metadata name rule must contain exactly one of 'source_name' ",
"or 'regex'", call. = FALSE)
}
attr(lookup, "match_without_underscores") <-
isTRUE(match_without_underscores)
attr(lookup, "match_singular_plural") <- isTRUE(match_singular_plural)
lookup
}
.lib_fill_metadata_key <- function(metadata, canonical, fallback) {
if (!inherits(metadata, "data.table")) data.table::setDT(metadata)
if (!fallback %in% names(metadata)) return(data.table::data.table())
if (!canonical %in% names(metadata)) metadata[[canonical]] <- NA_character_
primary <- trimws(as.character(metadata[[canonical]]))
alternate <- trimws(as.character(metadata[[fallback]]))
primary_present <- !is.na(primary) & nzchar(primary)
alternate_present <- !is.na(alternate) & nzchar(alternate)
conflicts <- primary_present & alternate_present & primary != alternate
filled <- !primary_present & alternate_present
primary[filled] <- alternate[filled]
data.table::set(metadata, j = canonical, value = primary)
data.table::rbindlist(list(
data.table::data.table(
problem = "filled_canonical_key", column = canonical,
value = fallback, n = sum(filled)
)[n > 0L],
data.table::data.table(
problem = "canonical_key_conflict", column = canonical,
value = fallback, n = sum(conflicts)
)[n > 0L]
), fill = TRUE)
}
.lib_assign_library_name <- function(metadata) {
metadata <- data.table::as.data.table(metadata)
value <- function(column) {
if (column %in% names(metadata)) {
trimws(as.character(metadata[[column]]))
} else {
rep(NA_character_, nrow(metadata))
}
}
organization <- value("organization")
user_name <- value("user_name")
blank <- is.na(organization) | !nzchar(organization)
organization[blank] <- user_name[blank]
blank <- is.na(organization) | !nzchar(organization)
organization[blank] <- NA_character_
data.table::set(metadata, j = "library_name", value = organization)
metadata
}
.lib_library_stage_counts <- function(libraries, stage) {
rows <- list()
collect <- function(value, artifact) {
if (is_OpenSpecy(value)) {
metadata <- .lib_assign_library_name(data.table::copy(value$metadata))
names <- as.character(metadata$library_name)
names[is.na(names) | !nzchar(trimws(names))] <- "(missing)"
rows[[length(rows) + 1L]] <<- data.table::data.table(
stage = stage, artifact = artifact, library_name = names
)[, .(spectra = .N), by = .(stage, artifact, library_name)]
} else if (is.list(value)) {
for (name in names(value)) collect(value[[name]], artifact)
}
}
for (artifact in names(libraries)) collect(libraries[[artifact]], artifact)
if (!length(rows)) {
return(data.table::data.table(
stage = character(), artifact = character(),
library_name = character(), spectra = integer()
))
}
data.table::rbindlist(rows)[
, .(spectra = sum(spectra)), by = .(stage, artifact, library_name)
]
}
.lib_library_retention_report <- function(stages) {
if (inherits(stages, c("data.frame", "data.table"))) stages <- list(stages)
stages <- data.table::rbindlist(stages, fill = TRUE)
stage_order <- c(
"prepared", "post_exclusion", "core", "post_other", "post_quality",
"post_prune", "post_transform", "final"
)
if (!nrow(stages)) {
out <- data.table::data.table(artifact = character(),
library_name = character())
for (stage in stage_order) out[[paste0(stage, "_n")]] <- integer()
out[, `:=`(status = character(), reason = character())]
return(out)
}
stages <- stages[, lapply(.SD, sum),
by = c("stage", "artifact", "library_name"),
.SDcols = "spectra"]
wide <- data.table::dcast(
stages, stats::as.formula("artifact + library_name ~ stage"),
value.var = "spectra", fill = 0L
)
for (stage in stage_order) {
if (!stage %in% names(wide)) wide[[stage]] <- 0L
}
data.table::setcolorder(wide, c("artifact", "library_name", stage_order))
data.table::setnames(wide, stage_order, paste0(stage_order, "_n"))
wide <- data.table::copy(wide)
count_columns <- paste0(stage_order, "_n")
reason_by_stage <- c(
post_exclusion = "known_bad_identifier",
core = "deduplication",
post_other = "unresolved_other_policy",
post_quality = "quality_control",
post_prune = "class_support_or_correlation_pruning",
post_transform = "post_transform_flat_spectrum",
final = "type_range_or_flat_partition"
)
wide[["status"]] <- data.table::fcase(
wide[["final_n"]] == 0L, "dropped",
wide[["final_n"]] < wide[["prepared_n"]], "partially_retained",
default = "retained"
)
wide[["reason"]] <- NA_character_
for (i in 2:length(stage_order)) {
stage <- stage_order[[i]]
previous <- count_columns[[i - 1L]]
current <- count_columns[[i]]
rows <- wide$status == "dropped" & is.na(wide$reason) &
wide[[previous]] > 0L & wide[[current]] == 0L
wide$reason[rows] <- unname(reason_by_stage[[stage]])
}
partial <- wide[["status"]] == "partially_retained"
wide[["reason"]][partial] <- "one_or_more_spectra_removed_during_cleanup"
unexplained <- wide[["status"]] == "dropped" & is.na(wide[["reason"]])
wide[["reason"]][unexplained] <- "not_retained"
data.table::setorder(wide, artifact, library_name)
wide[]
}
#' @rdname build_lib
#' @export
make_lib_lookup_template <- function(x, columns, add = NULL, path = NULL) {
if (inherits(x, "FileSpecs"))
.filespec_stop_unsupported("make_lib_lookup_template()")
if (!(is_OpenSpecy(x) || is_Specs(x))) {
stop("'x' must be an OpenSpecy or Specs object", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x$metadata))
.lib_require_cols(metadata, columns, "metadata")
template <- data.table::as.data.table(metadata[, columns, with = FALSE])
template <- unique(template)
if (!is.null(add)) {
for (col in add) {
if (!col %in% names(template)) template[[col]] <- NA_character_
}
}
if (!is.null(path)) {
data.table::fwrite(template, path, na = "")
return(invisible(template))
}
template
}
#' @rdname build_lib
#' @export
join_lib_metadata <- function(x, lookup, by, require_complete = FALSE,
return = c("object", "table", "report"),
suffixes = c(".x", ".y")) {
if (inherits(x, "FileSpecs"))
.filespec_stop_unsupported("join_lib_metadata()")
return <- match.arg(return)
is_os <- is_OpenSpecy(x)
is_specs <- is_Specs(x)
if (!(is_os || is_specs)) {
stop("'x' must be an OpenSpecy or Specs object", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x$metadata))
lookup <- .lib_read_lookup(lookup)
keys <- if (is.null(names(by)) || all(names(by) == "")) {
list(x = unname(by), y = unname(by))
} else {
list(x = names(by), y = unname(by))
}
.lib_require_cols(metadata, keys$x, "metadata")
.lib_require_cols(lookup, keys$y, "lookup")
make_key <- function(tab, cols) {
vals <- lapply(cols, function(col) as.character(tab[[col]]))
any_na <- Reduce(`|`, lapply(vals, is.na))
key <- do.call(paste, c(vals, sep = "\r"))
key[any_na] <- NA_character_
key
}
metadata_key <- make_key(metadata, keys$x)
lookup_key <- make_key(lookup, keys$y)
value_cols <- setdiff(names(lookup), keys$y)
dups <- duplicated(lookup_key) | duplicated(lookup_key, fromLast = TRUE)
dups[is.na(lookup_key)] <- FALSE
dup_report <- if (any(dups)) {
data.table::data.table(value = lookup_key[dups])[
, .(n = .N), by = "value"][
, `:=`(problem = "duplicate_lookup_key",
column = paste(keys$y, collapse = "|"))][
, .(problem, column, value, n)]
} else {
data.table::data.table(problem = character(), column = character(),
value = character(), n = integer())
}
if (nrow(dup_report) > 0) {
attr(dup_report, "data") <- lookup
stop("Lookup keys must be unique before joining. Duplicate keys: ",
paste(head(dup_report$value, 10), collapse = ", "), call. = FALSE)
}
missing_key <- is.na(metadata_key) | !metadata_key %in% lookup_key
unmatched <- data.table::data.table(value = metadata_key[missing_key])[
!is.na(value), .(n = .N), by = "value"][
, `:=`(problem = "unmatched_metadata_key",
column = paste(keys$x, collapse = "|"))][
, .(problem, column, value, n)]
missing_values <- data.table::data.table()
matched <- match(metadata_key, lookup_key)
if (length(value_cols) > 0 && any(!is.na(matched))) {
for (col in value_cols) {
vals <- lookup[[col]][matched]
miss <- !is.na(matched) & is.na(vals)
if (any(miss)) {
missing_values <- rbind(missing_values, data.table::data.table(
problem = "missing_joined_value",
column = col,
value = metadata_key[miss],
n = 1L
)[, .(n = .N), by = .(problem, column, value)], fill = TRUE)
}
}
}
report <- data.table::rbindlist(list(unmatched, missing_values), fill = TRUE)
.lib_alert_join_report(report, require_complete)
lookup_values <- lookup[, setdiff(names(lookup), keys$y), with = FALSE]
meta <- data.table::copy(metadata)
look <- data.table::copy(lookup_values)
meta$..join_key <- metadata_key
meta$..row_id <- seq_len(nrow(meta))
look$..join_key <- lookup_key
joined <- merge(meta, look, by = "..join_key", all.x = TRUE, sort = FALSE,
suffixes = suffixes)
data.table::setorder(joined, "..row_id")
joined[, c("..join_key", "..row_id") := NULL]
attr(joined, "join_report") <- report
if (return == "report") return(list(data = joined, report = report))
if (return == "table") return(joined)
x$metadata <- joined
attr(x, "join_report") <- report
x
}
#' @rdname build_lib
#' @export
join_material_hierarchy <- function(x, hierarchy, key_col = "material",
levels = c("material", "material_class",
"material_type"),
output_names = levels,
require_complete = FALSE,
return = c("object", "table", "report")) {
if (inherits(x, "FileSpecs"))
.filespec_stop_unsupported("join_material_hierarchy()")
return <- match.arg(return)
is_os <- is_OpenSpecy(x)
is_specs <- is_Specs(x)
if (!(is_os || is_specs)) {
stop("'x' must be an OpenSpecy or Specs object", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x$metadata))
hierarchy <- .lib_read_lookup(hierarchy)
if (!is.null(names(output_names)) && any(names(output_names) != "")) {
missing <- setdiff(levels, names(output_names))
if (length(missing) > 0) {
stop("'output_names' is missing hierarchy levels: ",
paste(missing, collapse = ", "), call. = FALSE)
}
output_names <- unname(output_names[levels])
}
if (length(output_names) != length(levels)) {
stop("'output_names' must have the same length as 'levels'", call. = FALSE)
}
.lib_require_cols(metadata, key_col, "metadata")
.lib_require_cols(hierarchy, levels, "hierarchy")
keys <- as.character(metadata[[key_col]])
out <- metadata
for (col in output_names) out[[col]] <- NA_character_
matched_level <- rep(NA_character_, nrow(out))
remaining <- seq_len(nrow(out))
duplicate_reports <- list()
for (i in seq_along(levels)) {
if (length(remaining) == 0L) break
level <- levels[i]
cols <- levels[i:length(levels)]
h <- unique(hierarchy[, cols, with = FALSE])
h_key <- as.character(h[[level]])
dups <- duplicated(h_key) | duplicated(h_key, fromLast = TRUE)
dups[is.na(h_key)] <- FALSE
if (any(dups)) {
duplicate_reports[[level]] <- data.table::data.table(
problem = "duplicate_hierarchy_key",
level = level,
value = unique(h_key[dups])
)
next
}
idx <- match(keys[remaining], h_key)
found <- !is.na(idx)
rows <- remaining[found]
if (length(rows) > 0) {
for (j in i:length(levels)) {
out[[output_names[j]]][rows] <- h[[levels[j]]][idx[found]]
}
matched_level[rows] <- level
remaining <- remaining[!found]
}
}
unmatched <- data.table::data.table(value = keys[is.na(matched_level)])[
!is.na(value), .(n = .N), by = "value"][
, `:=`(problem = "unmatched_hierarchy_key",
column = "hierarchy")][
, .(problem, column, value, n)]
duplicates <- data.table::rbindlist(duplicate_reports, fill = TRUE)
if (nrow(duplicates) > 0) {
duplicates[, `:=`(column = level, n = 1L)]
duplicates <- duplicates[, .(problem, column, value, n)]
}
report <- data.table::rbindlist(list(unmatched, duplicates), fill = TRUE)
.lib_alert_join_report(report, require_complete)
attr(out, "join_report") <- report
if (return == "report") return(list(data = out, report = report))
if (return == "table") return(out)
x$metadata <- out
attr(x, "join_report") <- report
x
}
#' @rdname build_lib
#' @export
dedupe_spec <- function(x, id_col = "sample_name", exclude_ids = NULL,
duplicate = c("first", "remove_all", "none"),
scale = 100, algo = "md5") {
duplicate <- match.arg(duplicate)
x <- as_OpenSpecy(x)
ids <- vapply(seq_len(ncol(x$spectra)), function(i) {
digest::digest(list(as.integer(x$wavenumber),
as.integer(x$spectra[, i] * scale)),
algo = algo)
}, FUN.VALUE = character(1))
x$metadata[[id_col]] <- ids
colnames(x$spectra) <- ids
x$metadata$col_id <- ids
keep <- rep(TRUE, length(ids))
if (!is.null(exclude_ids)) keep <- keep & !ids %in% exclude_ids
if (duplicate == "first") keep <- keep & !duplicated(ids)
if (duplicate == "remove_all") {
keep <- keep & !(duplicated(ids) | duplicated(ids, fromLast = TRUE))
}
if (!all(keep)) x <- filter_spec(x, keep)
x
}
#' @rdname build_lib
#' @export
prune_lib <- function(x, class_col = "material_class",
type_col = "spectrum_type",
material_type_col = "material_type",
id_col = "sample_name", min_n = 10,
cross_class = FALSE,
cross_class_threshold = 0.9,
exclude = c(2200, 2420),
return = c("object", "ids", "report"),
progress = TRUE) {
return <- match.arg(return)
x <- as_OpenSpecy(x)
.lib_require_cols(x$metadata, c(class_col, type_col, material_type_col),
"metadata")
if (length(min_n) != 1L || is.na(min_n) || min_n < 1 || min_n %% 1 != 0) {
stop("'min_n' must be one positive whole number", call. = FALSE)
}
if (!is.logical(cross_class) || length(cross_class) != 1L ||
is.na(cross_class)) {
stop("'cross_class' must be TRUE or FALSE", call. = FALSE)
}
if (!is.numeric(cross_class_threshold) ||
length(cross_class_threshold) != 1L ||
!is.finite(cross_class_threshold) || cross_class_threshold < 0 ||
cross_class_threshold > 1) {
stop("'cross_class_threshold' must be one finite number in [0, 1]",
call. = FALSE)
}
if (!is.numeric(exclude) || length(exclude) != 2L || anyNA(exclude)) {
stop("'exclude' must be two finite wavenumbers", call. = FALSE)
}
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
metadata <- data.table::copy(x$metadata)
ids <- .lib_ids(x, id_col)
classes <- trimws(as.character(metadata[[class_col]]))
material_types <- trimws(tolower(as.character(
metadata[[material_type_col]]
)))
spectrum_types <- trimws(tolower(as.character(metadata[[type_col]])))
pools <- .lib_prune_pools(metadata[[type_col]])
normalized <- .lib_prune_normalize(x$spectra, x$wavenumber, exclude)
before_n <- length(ids)
cross_class_removals <- .lib_prune_cross_class_schema()
cross_class_conflicts <- .lib_prune_conflict_edge_schema()
if (isTRUE(cross_class)) {
if (!"library_name" %in% names(metadata)) {
stop(
"'cross_class = TRUE' requires populated library_name metadata for ",
"every resolved class spectrum", call. = FALSE
)
}
library_names <- trimws(as.character(metadata$library_name))
class_keys <- tolower(classes)
resolved <- !is.na(classes) & nzchar(classes) &
!class_keys %in% c(
"other", "other plastic", "other material", "unclassified"
)
if (any(resolved & (is.na(library_names) | !nzchar(library_names)))) {
stop(
"'cross_class = TRUE' requires populated library_name metadata for ",
"every resolved class spectrum", call. = FALSE
)
}
cross_normalized <- .lib_prune_normalize(
x$spectra, x$wavenumber, exclude = NULL
)
conflict <- .lib_prune_cross_class_conflicts(
classes, spectrum_types, cross_normalized, ids, library_names,
threshold = cross_class_threshold, progress = progress,
block_size = 256L, support_groups = spectrum_types, min_n = min_n,
correlation_view = "prune_full"
)
cross_class_removals <- conflict$removals
cross_class_conflicts <- conflict$conflicts
if (length(conflict$removed_rows)) {
keep <- rep(TRUE, length(ids))
keep[conflict$removed_rows] <- FALSE
if (!any(keep)) {
stop("Cross-class pruning would remove every spectrum",
call. = FALSE)
}
x <- filter_spec(x, keep)
metadata <- data.table::copy(x$metadata)
ids <- ids[keep]
classes <- classes[keep]
material_types <- material_types[keep]
spectrum_types <- spectrum_types[keep]
pools <- pools[keep]
library_names <- library_names[keep]
normalized <- normalized[keep, , drop = FALSE]
}
rm(cross_normalized)
}
generic_reassigned <- .lib_reassign_other_classes(
classes, material_types, pools, normalized, ids, progress = progress
)
classes <- generic_reassigned$classes
material_types <- generic_reassigned$material_types
small_reassigned <- .lib_reassign_small_classes(
classes, material_types, spectrum_types, pools, normalized, ids,
min_n = min_n, progress = progress
)
classes <- small_reassigned$classes
material_types <- small_reassigned$material_types
reassignment_report <- data.table::rbindlist(list(
generic_reassigned$report, small_reassigned$report
), fill = TRUE)
metadata[[class_col]] <- classes
metadata[[material_type_col]] <- material_types
protected <- tolower(classes) %in% c(
"unclassified", "other", "other plastic", "other material"
)
support <- data.table::data.table(
row = seq_along(ids), spectrum_type = spectrum_types, pool = pools,
material_class = classes
)[
!is.na(spectrum_type) & nzchar(spectrum_type) &
!is.na(material_class) & nzchar(material_class),
.(observed_n = .N), by = .(spectrum_type, pool, material_class)
]
if (nrow(support)) {
data.table::setorder(
support, spectrum_type, -observed_n, material_class
)
}
excluded_classes <- small_reassigned$classes_report
if (!nrow(excluded_classes)) {
excluded_classes <- .lib_prune_excluded_class_schema()
}
threshold_rows <- small_reassigned$dropped_rows
active <- rep(TRUE, length(ids))
active[threshold_rows] <- FALSE
if (isTRUE(progress)) {
if (nrow(excluded_classes)) {
preview_n <- min(8L, nrow(excluded_classes))
preview <- excluded_classes[seq_len(preview_n), sprintf(
"%s / %s (n=%d; shortfall=%d)",
spectrum_type, material_class, observed_n, shortfall
)]
if (nrow(excluded_classes) > preview_n) {
preview <- c(
preview,
sprintf("and %d more", nrow(excluded_classes) - preview_n)
)
}
message(sprintf(
paste0("prune_lib: minimum support gate reassigned %d and removed %d ",
"spectrum/spectra across %d class/type group(s) below ",
"min_n=%d: %s"),
nrow(small_reassigned$report), length(threshold_rows),
nrow(excluded_classes), min_n,
paste(preview, collapse = "; ")
))
} else {
message(sprintf(
paste0("prune_lib: minimum support gate complete ",
"(%d class/type group(s); none below min_n=%d)"),
nrow(support), min_n
))
}
}
schedule <- data.table::data.table(
pool = pools[active],
material_class = classes[active],
is_protected = protected[active]
)[!is.na(pool) & !is.na(material_class) & nzchar(material_class),
.(initial_n = .N, is_protected = all(is_protected)),
by = .(pool, material_class)][is_protected == FALSE]
if (nrow(schedule) > 0L) {
data.table::setorder(schedule, pool, -initial_n, material_class)
schedule[, schedule_order := seq_len(.N), by = pool]
} else {
schedule[, schedule_order := integer()]
}
removal_rows <- if (nrow(cross_class_removals)) {
list(cross_class_removals)
} else {
list()
}
if (length(threshold_rows)) {
removal_rows[[length(removal_rows) + 1L]] <- data.table::data.table(
spectrum_id = ids[threshold_rows],
prior_class = classes[threshold_rows],
matched_id = NA_character_, matched_class = NA_character_,
correlation = NA_real_, pool = pools[threshold_rows],
schedule_order = NA_integer_, reason = "class_below_min_n"
)
}
removal_i <- length(removal_rows)
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: starting %d scheduled class(es) across %d spectrum pool(s)",
nrow(schedule), length(unique(stats::na.omit(pools)))
))
}
if (nrow(schedule) > 0L) {
for (s in seq_len(nrow(schedule))) {
target_pool <- schedule$pool[[s]]
target_class <- schedule$material_class[[s]]
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: %s / %s (%d initially)",
target_pool, target_class, schedule$initial_n[[s]]
))
}
initial_target <- which(active & pools == target_pool &
!is.na(classes) & classes == target_class)
candidates <- which(active & pools == target_pool & !protected)
candidate_order <- order(ids[candidates], candidates, na.last = TRUE)
candidates <- candidates[candidate_order]
iteration <- 0L
best_index <- rep(NA_integer_, length(active))
best_correlation <- rep(NA_real_, length(active))
query <- initial_target
repeat {
target <- which(active & pools == target_pool &
!is.na(classes) & classes == target_class)
if (length(target) <= min_n) break
if (length(query) > 0L) {
active_candidates <- candidates[active[candidates]]
correlation_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: %s / %s blockwise correlation starting ",
"(%d query; %d eligible; iteration=%d)"),
target_pool, target_class, length(query),
length(active_candidates), iteration + 1L
))
}
best <- .lib_prune_best_match(
query, active_candidates, normalized, ids,
exclude_self = TRUE, block_size = 32L
)
best_index[query] <- best$index
best_correlation[query] <- best$correlation
rm(best)
gc(verbose = FALSE, full = TRUE)
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: %s / %s blockwise correlation complete ",
"(%d query; %d eligible; %.1fs)"),
target_pool, target_class, length(query),
length(active_candidates),
proc.time()[["elapsed"]] - correlation_started
))
}
}
target_best <- best_index[target]
target_correlation <- best_correlation[target]
conflicts <- which(
!is.na(target_best) & is.finite(target_correlation) &
classes[target_best] != target_class
)
conflicts <- conflicts[!is.na(conflicts)]
if (length(conflicts) == 0L) break
removable_n <- min(length(conflicts), length(target) - min_n)
if (removable_n < 1L) break
conflict_rows <- data.table::data.table(
query = target[conflicts],
matched = target_best[conflicts],
correlation = target_correlation[conflicts]
)
conflict_rows[, query_id := ids[query]]
data.table::setorder(conflict_rows, -correlation, query_id)
conflict_rows <- conflict_rows[seq_len(removable_n)]
active[conflict_rows$query] <- FALSE
iteration <- iteration + 1L
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: %s / %s iteration %d ",
"(removed=%d; retained=%d)"),
target_pool, target_class, iteration, nrow(conflict_rows),
sum(active[initial_target])
))
}
removal_i <- removal_i + 1L
removal_rows[[removal_i]] <- conflict_rows[, .(
spectrum_id = ids[query],
prior_class = classes[query],
matched_id = ids[matched],
matched_class = classes[matched],
correlation,
pool = target_pool,
schedule_order = schedule$schedule_order[[s]],
reason = "top_match_other_class"
)]
remaining_target <- target[active[target]]
query <- remaining_target[
is.na(best_index[remaining_target]) |
!active[best_index[remaining_target]]
]
if (length(query) == 0L) {
break
}
}
if (isTRUE(progress)) {
retained <- sum(active & pools == target_pool &
!is.na(classes) & classes == target_class)
message(sprintf(
"prune_lib: %s / %s complete (retained=%d; removed=%d)",
target_pool, target_class, retained,
schedule$initial_n[[s]] - retained
))
}
}
}
if (isTRUE(cross_class) && any(active)) {
active_rows <- which(active)
closure_normalized <- .lib_prune_normalize(
x$spectra[, active_rows, drop = FALSE], x$wavenumber, exclude = NULL
)
closure <- .lib_prune_cross_class_conflicts(
classes[active_rows], spectrum_types[active_rows], closure_normalized,
ids[active_rows], library_names[active_rows],
threshold = cross_class_threshold, progress = progress,
block_size = 256L, support_groups = spectrum_types[active_rows],
min_n = min_n, correlation_view = "post_reassignment_full"
)
if (nrow(closure$removals)) {
closure$removals[, phase := "final_closure"]
cross_class_removals <- data.table::rbindlist(
list(cross_class_removals, closure$removals), fill = TRUE
)
removal_i <- removal_i + 1L
removal_rows[[removal_i]] <- closure$removals
active[active_rows[closure$removed_rows]] <- FALSE
}
if (nrow(closure$conflicts)) {
closure$conflicts[, phase := "final_closure"]
cross_class_conflicts <- data.table::rbindlist(
list(cross_class_conflicts, closure$conflicts), fill = TRUE
)
}
rm(closure_normalized, closure)
resolved_active <- active & !protected & !is.na(spectrum_types) &
nzchar(spectrum_types) & !is.na(classes) & nzchar(classes)
final_support <- data.table::data.table(
row = which(resolved_active),
spectrum_type = spectrum_types[resolved_active],
material_class = classes[resolved_active]
)[, .(rows = list(row), observed_n = .N),
by = .(spectrum_type, material_class)]
small_final <- final_support[observed_n < min_n]
if (nrow(small_final)) {
drop <- unlist(small_final$rows, use.names = FALSE)
count_lookup <- small_final$observed_n[match(
paste(spectrum_types[drop], classes[drop]),
paste(small_final$spectrum_type, small_final$material_class)
)]
floor_removals <- data.table::data.table(
phase = "final_closure", correlation_view = "global_support",
component_id = NA_character_, spectrum_id = ids[drop],
prior_class = classes[drop], library_name = library_names[drop],
matched_id = NA_character_, matched_class = NA_character_,
matched_library = NA_character_, correlation = NA_real_,
pool = spectrum_types[drop], active_degree = 0L,
matched_active_degree = 0L, evidence_libraries = 0L,
conflicting_spectra = 0L, matched_evidence_libraries = 0L,
decision_round = NA_integer_, threshold = cross_class_threshold,
class_n_before = as.integer(count_lookup), class_n_after = 0L,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "global_support_at_risk",
reason = "class_below_global_min_n_after_closure"
)
active[drop] <- FALSE
cross_class_removals <- data.table::rbindlist(
list(cross_class_removals, floor_removals), fill = TRUE
)
removal_i <- removal_i + 1L
removal_rows[[removal_i]] <- floor_removals
}
}
rm(normalized)
removals <- if (length(removal_rows) > 0L) {
data.table::rbindlist(removal_rows, fill = TRUE)
} else {
data.table::data.table(
spectrum_id = character(), prior_class = character(),
matched_id = character(), matched_class = character(),
correlation = numeric(), pool = character(), schedule_order = integer(),
reason = character()
)
}
retained_ids <- ids[active]
out <- x
out$metadata <- metadata
if (!all(active)) out <- filter_spec(out, active)
audit <- list(
retained_ids = retained_ids,
schedule = schedule,
excluded_classes = excluded_classes,
reassignments = reassignment_report,
cross_class_removals = cross_class_removals,
cross_class_conflicts = cross_class_conflicts,
removals = removals,
summary = data.table::data.table(
before = before_n,
after = sum(active),
reassigned = nrow(reassignment_report),
classes_excluded = sum(excluded_classes$action == "dropped"),
cross_class_removed = nrow(cross_class_removals),
threshold_removed = length(threshold_rows),
removed = before_n - sum(active)
)
)
attr(out, "prune_report") <- audit
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: complete (before=%d; after=%d; reassigned=%d; ",
"classes_excluded=%d; cross_class_removed=%d; ",
"threshold_removed=%d; removed=%d)"),
before_n, sum(active), nrow(reassignment_report),
sum(excluded_classes$action == "dropped"),
nrow(cross_class_removals), length(threshold_rows),
before_n - sum(active)
))
}
if (return == "ids") return(retained_ids)
if (return == "report") return(c(list(object = out), audit))
out
}
.lib_prune_excluded_class_schema <- function() {
data.table::data.table(
spectrum_type = character(), pool = character(),
material_class = character(), observed_n = integer(),
minimum_spectra = integer(), shortfall = integer(),
destination_class = character(), mean_correlation = numeric(),
spectra_removed = integer(), action = character(), reason = character()
)
}
.lib_prune_excluded_assessment_schema <- function() {
out <- .lib_prune_excluded_class_schema()
out[, artifact := character()]
data.table::setcolorder(out, c("artifact", setdiff(names(out), "artifact")))
out
}
.lib_prune_pools <- function(type) {
type <- trimws(tolower(as.character(type)))
out <- ifelse(type %in% c("ftir", "nir"), "ftir_nir",
ifelse(type == "raman", "raman", type))
out[is.na(type) | !nzchar(type)] <- NA_character_
out
}
.lib_prune_normalize <- function(spectra, wavenumber, exclude) {
use <- if (is.null(exclude)) {
rep(TRUE, length(wavenumber))
} else {
limits <- sort(exclude)
wavenumber < limits[[1L]] | wavenumber > limits[[2L]]
}
if (!any(use)) {
stop("'exclude' removes every wavenumber", call. = FALSE)
}
# Reproduce cor_spec()'s exact make_rel -> mean replacement -> correlation
# scaling sequence in bounded spectrum blocks. Preserving that operation
# order keeps deterministic tie-breaking while avoiding full correlation
# matrices during pruning.
values <- matrix(NA_real_, nrow = ncol(spectra), ncol = sum(use))
row_block <- 256L
blocks <- split(seq_len(nrow(values)),
ceiling(seq_len(nrow(values)) / row_block))
for (block_index in seq_along(blocks)) {
block <- blocks[[block_index]]
part <- spectra[use, block, drop = FALSE]
part <- make_rel(part, na.rm = TRUE)
part <- .matrix_mean_replace(part)
values[block, ] <- .scale_correlation_spectra(part)
}
values
}
.lib_prune_best_match <- function(query, candidates, normalized, ids,
exclude_self = FALSE, block_size = 32L) {
candidate_order <- order(ids[candidates], candidates, na.last = TRUE)
candidates <- candidates[candidate_order]
best_index <- rep(NA_integer_, length(query))
best_correlation <- rep(NA_real_, length(query))
blocks <- split(seq_along(query),
ceiling(seq_along(query) / as.integer(block_size)))
for (block_index in seq_along(blocks)) {
block <- blocks[[block_index]]
# Multiply against the resident normalized matrix and subset the small
# correlation block, rather than copying the full candidate library for
# every query block.
cors <- tcrossprod(normalized[query[block], , drop = FALSE], normalized)
cors <- cors[, candidates, drop = FALSE]
cors[!is.finite(cors)] <- -Inf
if (isTRUE(exclude_self)) {
self_col <- match(query[block], candidates)
has_self <- !is.na(self_col)
cors[cbind(which(has_self), self_col[has_self])] <- -Inf
}
top <- matrixStats::rowMaxs(cors)
tolerance <- sqrt(.Machine$double.eps) * pmax(1, abs(top))
near_top <- abs(cors - top) <= tolerance
near_top[is.na(near_top)] <- FALSE
local <- max.col(near_top, ties.method = "first")
scores <- cors[cbind(seq_along(block), local)]
ok <- is.finite(scores)
best_index[block[ok]] <- candidates[local[ok]]
best_correlation[block[ok]] <- scores[ok]
rm(cors, top, tolerance, near_top, local, scores)
if (block_index %% 8L == 0L) {
gc(verbose = FALSE, full = TRUE)
}
}
gc(verbose = FALSE, full = TRUE)
list(index = best_index, correlation = best_correlation)
}
.lib_prune_cross_class_schema <- function() {
data.table::data.table(
phase = character(), correlation_view = character(),
component_id = character(),
spectrum_id = character(), prior_class = character(),
library_name = character(), matched_id = character(),
matched_class = character(), matched_library = character(),
correlation = numeric(), pool = character(),
active_degree = integer(), matched_active_degree = integer(),
evidence_libraries = integer(), conflicting_spectra = integer(),
matched_evidence_libraries = integer(), decision_round = integer(),
threshold = numeric(), class_n_before = integer(),
class_n_after = integer(), schedule_order = integer(),
quarantine_status = character(), review_status = character(),
reason = character()
)
}
.lib_prune_conflict_edge_schema <- function() {
data.table::data.table(
phase = character(), correlation_view = character(),
component_id = character(), pool = character(),
spectrum_id = character(), prior_class = character(),
library_name = character(), matched_id = character(),
matched_class = character(), matched_library = character(),
correlation = numeric(), same_library = logical(),
class_pair_libraries = integer(), review_status = character(),
threshold = numeric()
)
}
.lib_prune_removal_assessment_schema <- function() {
out <- .lib_prune_cross_class_schema()
out[, artifact := character()]
data.table::setcolorder(out, c("artifact", setdiff(names(out), "artifact")))
out
}
.lib_prune_internal_class_conflicts <- function(
classes, pools, normalized, ids, library_names, threshold,
support_groups = pools, min_n = 1L, correlation_view = "prune_full",
progress = FALSE, block_size = 32L) {
n <- length(ids)
stopifnot(
length(classes) == n, length(pools) == n,
length(library_names) == n, length(support_groups) == n,
nrow(normalized) == n
)
generic <- c("other", "other plastic", "other material", "unclassified")
class_keys <- tolower(trimws(classes))
eligible <- !is.na(pools) & nzchar(pools) &
!is.na(classes) & nzchar(classes) & !class_keys %in% generic &
!is.na(library_names) & nzchar(library_names)
groups <- unique(data.table::data.table(
pool = pools[eligible], library_name = library_names[eligible]
))
data.table::setorder(groups, pool, library_name)
edge_rows <- list()
edge_i <- 0L
started <- proc.time()[["elapsed"]]
for (group_i in seq_len(nrow(groups))) {
pool <- groups$pool[[group_i]]
library_name <- groups$library_name[[group_i]]
candidates <- which(
eligible & pools == pool & library_names == library_name
)
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
if (length(candidates) < 2L) next
blocks <- split(candidates, ceiling(seq_along(candidates) / block_size))
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
matched <- candidates[
candidates > q & cors[row, ] > threshold &
classes[candidates] != classes[[q]]
]
if (!length(matched)) next
edge_i <- edge_i + 1L
edge_rows[[edge_i]] <- data.table::data.table(
from = q, to = matched,
correlation = cors[row, match(matched, candidates)],
pool = pool, library_name = library_name
)
}
rm(cors)
}
}
edges <- if (length(edge_rows)) {
data.table::rbindlist(edge_rows)
} else {
data.table::data.table(
from = integer(), to = integer(), correlation = numeric(),
pool = character(), library_name = character()
)
}
if (!nrow(edges)) {
return(list(
removed_rows = integer(), removals = .lib_prune_cross_class_schema(),
conflicts = .lib_prune_conflict_edge_schema()
))
}
parent <- seq_len(n)
find_root <- function(value) {
while (parent[[value]] != value) value <- parent[[value]]
value
}
for (edge_i in seq_len(nrow(edges))) {
left <- find_root(edges$from[[edge_i]])
right <- find_root(edges$to[[edge_i]])
if (left != right) parent[[max(left, right)]] <- min(left, right)
}
vertices <- sort(unique(c(edges$from, edges$to)))
roots <- vapply(vertices, find_root, integer(1L))
root_labels <- vapply(split(vertices, roots), function(rows) {
sort(ids[rows], na.last = TRUE)[[1L]]
}, character(1L))
component <- rep(NA_character_, n)
component[vertices] <- paste0("internal:", root_labels[as.character(roots)])
pair_left <- pmin(classes[edges$from], classes[edges$to])
pair_right <- pmax(classes[edges$from], classes[edges$to])
pair_stats <- data.table::data.table(
pool = edges$pool, class_left = pair_left, class_right = pair_right,
library_name = edges$library_name
)[, .(class_pair_libraries = data.table::uniqueN(library_name)),
by = .(pool, class_left, class_right)]
pair_lookup <- pair_stats[data.table::data.table(
pool = edges$pool, class_left = pair_left, class_right = pair_right
), on = .(pool, class_left, class_right)]$class_pair_libraries
active <- eligible
decisions <- list()
decision_i <- 0L
round <- 0L
repeat {
edge_active <- active[edges$from] & active[edges$to]
current <- edges[edge_active]
if (!nrow(current)) break
degree <- tabulate(c(current$from, current$to), nbins = n)
maximum <- max(degree)
top <- which(active & degree == maximum)
tied_edges <- current[from %in% top & to %in% top]
if (nrow(tied_edges)) {
remove <- sort(unique(c(tied_edges$from, tied_edges$to)))
tied <- rep(TRUE, length(remove))
} else {
remove <- top[order(ids[top], top, na.last = TRUE)][[1L]]
tied <- FALSE
}
round <- round + 1L
for (remove_i in seq_along(remove)) {
q <- remove[[remove_i]]
incident <- current[from == q | to == q]
neighbor <- ifelse(incident$from == q, incident$to, incident$from)
selected_order <- order(
-incident$correlation, ids[neighbor], neighbor, na.last = TRUE
)
selected_row <- selected_order[[1L]]
matched <- neighbor[[selected_row]]
class_before <- sum(
active & support_groups == support_groups[[q]] &
classes == classes[[q]], na.rm = TRUE
)
class_removed <- sum(
remove %in% which(
active & support_groups == support_groups[[q]] &
classes == classes[[q]]
)
)
class_after <- class_before - class_removed
incident_rows <- which(
(edges$from == q | edges$to == q) & edge_active
)
recurrent <- any(pair_lookup[incident_rows] >= 2L)
review <- if (class_after > 0L && class_after < min_n) {
"global_support_at_risk"
} else if (recurrent) {
"recurrent_class_pair"
} else {
"automatic"
}
decision_i <- decision_i + 1L
decisions[[decision_i]] <- data.table::data.table(
phase = "internal", correlation_view = correlation_view,
component_id = component[[q]], spectrum_id = ids[[q]],
prior_class = classes[[q]], library_name = library_names[[q]],
matched_id = ids[[matched]], matched_class = classes[[matched]],
matched_library = library_names[[matched]],
correlation = incident$correlation[[selected_row]], pool = pools[[q]],
active_degree = degree[[q]],
matched_active_degree = degree[[matched]], evidence_libraries = 0L,
conflicting_spectra = degree[[q]],
matched_evidence_libraries = 0L, decision_round = round,
threshold = threshold, class_n_before = class_before,
class_n_after = class_after, schedule_order = NA_integer_,
quarantine_status = "excluded", review_status = review,
reason = if (isTRUE(tied[[remove_i]])) {
"cross_class_equal_internal_degree"
} else {
"cross_class_more_internal_conflicts"
}
)
}
active[remove] <- FALSE
}
removals <- data.table::rbindlist(decisions, fill = TRUE)
if (!nrow(removals)) removals <- .lib_prune_cross_class_schema()
data.table::setorder(removals, decision_round, -active_degree, spectrum_id)
conflicts <- data.table::data.table(
phase = "internal", correlation_view = correlation_view,
component_id = component[edges$from], pool = edges$pool,
spectrum_id = ids[edges$from], prior_class = classes[edges$from],
library_name = library_names[edges$from], matched_id = ids[edges$to],
matched_class = classes[edges$to],
matched_library = library_names[edges$to],
correlation = edges$correlation, same_library = TRUE,
class_pair_libraries = pair_lookup,
review_status = ifelse(
pair_lookup >= 2L, "recurrent_class_pair", "automatic"
), threshold = threshold
)
if (isTRUE(progress)) message(sprintf(
paste0("prune_lib: internal cross-class pass complete ",
"(edges=%d; removed=%d; elapsed=%.1fs)"),
nrow(edges), nrow(removals), proc.time()[["elapsed"]] - started
))
list(
removed_rows = which(!active & eligible), removals = removals,
conflicts = conflicts
)
}
.lib_prune_between_library_conflicts <- function(classes, pools, normalized, ids,
library_names, threshold,
correlation_view = "prune_full",
progress = FALSE,
block_size = 32L) {
n <- length(ids)
started <- proc.time()[["elapsed"]]
stopifnot(
length(classes) == n, length(pools) == n,
length(library_names) == n, nrow(normalized) == n
)
generic <- c("other", "other plastic", "other material", "unclassified")
class_keys <- tolower(trimws(classes))
eligible <- !is.na(pools) & nzchar(pools) &
!is.na(classes) & nzchar(classes) & !class_keys %in% generic
evidence_libraries <- integer(n)
conflicting_spectra <- integer(n)
pool_values <- sort(unique(pools[eligible]))
pool_values <- pool_values[!is.na(pool_values) & nzchar(pool_values)]
for (pool in pool_values) {
candidates <- which(eligible & pools == pool)
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
blocks <- split(candidates, ceiling(seq_along(candidates) / block_size))
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: cross-class evidence scan %s starting ",
"(%d spectra; %d features; block=%d; threshold > %.4f)"),
pool, length(candidates), ncol(normalized), block_size, threshold
))
}
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
matched <- candidates[
cors[row, ] > threshold & candidates != q &
library_names[candidates] != library_names[[q]] &
classes[candidates] != classes[[q]]
]
conflicting_spectra[[q]] <- length(matched)
if (length(matched)) {
evidence_libraries[[q]] <- length(unique(library_names[matched]))
}
}
rm(cors)
}
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: cross-class evidence scan %s complete ",
"(flagged=%d; max_libraries=%d; elapsed=%.1fs)"),
pool, sum(conflicting_spectra[candidates] > 0L),
max(evidence_libraries[candidates], 0L),
proc.time()[["elapsed"]] - started
))
}
}
scores <- sort(unique(evidence_libraries[conflicting_spectra > 0L]),
decreasing = TRUE)
scores <- scores[scores > 0L]
if (!length(scores)) {
return(list(removed_rows = integer(), removals =
.lib_prune_cross_class_schema()))
}
active <- eligible
decision_match <- rep(NA_integer_, n)
decision_correlation <- rep(NA_real_, n)
decision_round <- integer(n)
decision_reason <- rep(NA_character_, n)
for (round in seq_along(scores)) {
score <- scores[[round]]
remove_round <- integer()
for (pool in pool_values) {
query_rows <- which(
active & pools == pool & evidence_libraries == score
)
if (!length(query_rows)) next
candidates <- which(active & pools == pool)
candidates <- candidates[
order(ids[candidates], candidates, na.last = TRUE)
]
blocks <- split(
query_rows, ceiling(seq_along(query_rows) / block_size)
)
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
matched <- candidates[
cors[row, ] > threshold & candidates != q &
library_names[candidates] != library_names[[q]] &
classes[candidates] != classes[[q]]
]
if (!length(matched)) next
if (any(evidence_libraries[matched] > score)) {
stop("Internal cross-class pruning order invariant failed",
call. = FALSE)
}
tied <- matched[evidence_libraries[matched] == score]
decision_candidates <- if (length(tied)) tied else matched
candidate_columns <- match(decision_candidates, candidates)
candidate_correlations <- cors[row, candidate_columns]
best_order <- order(
-candidate_correlations, ids[decision_candidates],
decision_candidates, na.last = TRUE
)
selected <- decision_candidates[best_order[[1L]]]
decision_match[[q]] <- selected
decision_correlation[[q]] <- cors[
row, match(selected, candidates)
]
decision_round[[q]] <- round
decision_reason[[q]] <- if (length(tied)) {
"cross_class_equal_library_evidence"
} else {
"cross_class_more_library_evidence"
}
remove_round <- c(remove_round, q)
}
rm(cors)
}
}
remove_round <- sort(unique(remove_round))
active[remove_round] <- FALSE
if (isTRUE(progress)) {
message(sprintf(
paste0("prune_lib: cross-class decision round %d/%d ",
"(evidence_libraries=%d; removed=%d; active=%d; elapsed=%.1fs)"),
round, length(scores), score, length(remove_round), sum(active),
proc.time()[["elapsed"]] - started
))
}
}
retained <- which(active)
for (pool in pool_values) {
candidates <- retained[pools[retained] == pool]
if (length(candidates) < 2L) next
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
blocks <- split(candidates, ceiling(seq_along(candidates) / block_size))
for (query in blocks) {
cors <- tcrossprod(
normalized[query, , drop = FALSE],
normalized[candidates, , drop = FALSE]
)
cors[!is.finite(cors)] <- -Inf
for (row in seq_along(query)) {
q <- query[[row]]
conflict <- candidates[
cors[row, ] > threshold & candidates != q &
library_names[candidates] != library_names[[q]] &
classes[candidates] != classes[[q]]
]
if (length(conflict)) {
stop(
"Cross-class pruning postcondition failed for retained spectra: ",
ids[[q]], " and ", ids[[conflict[[1L]]]], call. = FALSE
)
}
}
rm(cors)
}
}
removed_rows <- which(decision_round > 0L)
matched_rows <- decision_match[removed_rows]
removals <- data.table::data.table(
phase = "independent", correlation_view = correlation_view,
component_id = NA_character_,
spectrum_id = ids[removed_rows], prior_class = classes[removed_rows],
library_name = library_names[removed_rows],
matched_id = ids[matched_rows], matched_class = classes[matched_rows],
matched_library = library_names[matched_rows],
correlation = decision_correlation[removed_rows],
pool = pools[removed_rows],
evidence_libraries = evidence_libraries[removed_rows],
conflicting_spectra = conflicting_spectra[removed_rows],
active_degree = conflicting_spectra[removed_rows],
matched_active_degree = conflicting_spectra[matched_rows],
matched_evidence_libraries = evidence_libraries[matched_rows],
decision_round = decision_round[removed_rows], threshold = threshold,
class_n_before = NA_integer_, class_n_after = NA_integer_,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "automatic", reason = decision_reason[removed_rows]
)
data.table::setorder(
removals, decision_round, -evidence_libraries, spectrum_id
)
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: cross-class conflict pass complete (removed=%d; elapsed=%.1fs)",
length(removed_rows), proc.time()[["elapsed"]] - started
))
}
list(removed_rows = removed_rows, removals = removals)
}
.lib_prune_cross_class_conflicts <- function(
classes, pools, normalized, ids, library_names, threshold,
support_groups = pools, min_n = 1L, correlation_view = "prune_full",
progress = FALSE, block_size = 32L) {
internal <- .lib_prune_internal_class_conflicts(
classes, pools, normalized, ids, library_names, threshold,
support_groups = support_groups, min_n = min_n,
correlation_view = correlation_view, progress = progress,
block_size = block_size
)
keep <- setdiff(seq_along(ids), internal$removed_rows)
independent <- .lib_prune_between_library_conflicts(
classes[keep], pools[keep], normalized[keep, , drop = FALSE], ids[keep],
library_names[keep], threshold, correlation_view = correlation_view,
progress = progress, block_size = block_size
)
independent_rows <- keep[independent$removed_rows]
conflicts <- internal$conflicts
if (nrow(independent$removals)) {
independent_edges <- independent$removals[, .(
phase, correlation_view, component_id, pool,
spectrum_id, prior_class, library_name, matched_id, matched_class,
matched_library, correlation, same_library = FALSE,
class_pair_libraries = pmax(
evidence_libraries, matched_evidence_libraries, na.rm = TRUE
), review_status, threshold
)]
conflicts <- data.table::rbindlist(
list(conflicts, independent_edges), fill = TRUE
)
}
list(
removed_rows = sort(unique(c(internal$removed_rows, independent_rows))),
removals = data.table::rbindlist(
list(internal$removals, independent$removals), fill = TRUE
),
conflicts = conflicts
)
}
.lib_prune_correlations <- function(x, query, candidates, exclude, ids) {
limits <- sort(exclude)
use <- x$wavenumber < limits[[1L]] | x$wavenumber > limits[[2L]]
query_spec <- x
query_spec$wavenumber <- x$wavenumber[use]
query_spec$spectra <- x$spectra[use, query, drop = FALSE]
query_spec$metadata <- x$metadata[query]
colnames(query_spec$spectra) <- ids[query]
candidate_spec <- x
candidate_spec$wavenumber <- x$wavenumber[use]
candidate_spec$spectra <- x$spectra[use, candidates, drop = FALSE]
candidate_spec$metadata <- x$metadata[candidates]
colnames(candidate_spec$spectra) <- ids[candidates]
# cor_spec() returns library spectra by query spectra. Passing the target
# class as the library gives the row-by-candidate layout needed by max.col()
# without transposing or copying the full correlation matrix.
correlations <- cor_spec(
candidate_spec, library = query_spec, compute = "optimized"
)
correlations[!is.finite(correlations)] <- -Inf
self_column <- match(query, candidates)
has_self <- !is.na(self_column)
correlations[cbind(which(has_self), self_column[has_self])] <- -Inf
correlations
}
.lib_reassign_other_classes <- function(classes, material_types, pools,
normalized, ids, progress = FALSE) {
class_keys <- tolower(classes)
generic_labels <- c("other", "other plastic", "other material")
generic <- which(class_keys %in% generic_labels)
rows <- list()
if (isTRUE(progress) && length(generic)) {
message(sprintf(
"prune_lib: reassigning %d generic-class spectrum/spectra",
length(generic)
))
}
groups <- split(generic, paste(pools[generic], class_keys[generic], sep = "\r"))
for (query in groups) {
generic_class <- class_keys[[query[[1L]]]]
target_pool <- pools[[query[[1L]]]]
eligible <- !is.na(pools) & pools == target_pool &
!class_keys %in% c(generic_labels, "unclassified") &
!is.na(classes) & nzchar(classes)
if (identical(generic_class, "other plastic")) {
eligible <- eligible & material_types == "plastic"
} else if (identical(generic_class, "other material")) {
eligible <- eligible & class_keys %in% c("organic matter", "mineral")
}
candidates <- which(eligible)
if (isTRUE(progress)) {
message(sprintf(
"prune_lib: %s / %s reassignment (%d query; %d eligible)",
target_pool, generic_class, length(query), length(candidates)
))
}
if (length(candidates) == 0L) next
best <- .lib_prune_best_match(query, candidates, normalized, ids)
matched <- which(!is.na(best$index))
if (!length(matched)) next
query_rows <- query[matched]
candidate_rows <- best$index[matched]
prior_class <- classes[query_rows]
prior_type <- material_types[query_rows]
classes[query_rows] <- classes[candidate_rows]
material_types[query_rows] <- material_types[candidate_rows]
rows[[length(rows) + 1L]] <- data.table::data.table(
spectrum_id = ids[query_rows], prior_class,
material_class = classes[query_rows], prior_material_type = prior_type,
material_type = material_types[query_rows],
matched_id = ids[candidate_rows],
correlation = best$correlation[matched], pool = pools[query_rows],
reason = "nearest_eligible_class"
)
}
report <- if (length(rows) > 0L) {
data.table::rbindlist(rows, fill = TRUE)
} else {
data.table::data.table(
spectrum_id = character(), prior_class = character(),
material_class = character(), prior_material_type = character(),
material_type = character(), matched_id = character(),
correlation = numeric(), pool = character(), reason = character()
)
}
if (isTRUE(progress) && length(generic)) {
message(sprintf(
"prune_lib: generic-class reassignment complete (reassigned=%d; retained=%d)",
nrow(report), length(generic) - nrow(report)
))
}
list(classes = classes, material_types = material_types, report = report)
}
.lib_reassign_small_classes <- function(classes, material_types,
spectrum_types, pools, normalized,
ids, min_n, progress = FALSE) {
generic <- c("other", "other plastic", "other material", "unclassified")
support <- data.table::data.table(
row = seq_along(ids), spectrum_type = spectrum_types, pool = pools,
material_class = classes, material_type = material_types
)[
!is.na(spectrum_type) & nzchar(spectrum_type) &
!is.na(material_class) & nzchar(material_class),
.(
observed_n = .N,
material_type = {
values <- unique(material_type[!is.na(material_type) &
nzchar(material_type)])
if (length(values) == 1L) values else NA_character_
}
),
by = .(spectrum_type, pool, material_class)
]
small <- support[observed_n < min_n]
if (nrow(small)) {
data.table::setorder(small, spectrum_type, material_class)
}
established <- support[
observed_n >= min_n & !tolower(material_class) %in% generic
]
report_rows <- list()
class_rows <- list()
dropped_rows <- integer()
for (i in seq_len(nrow(small))) {
item <- small[i]
query <- which(
spectrum_types == item$spectrum_type & pools == item$pool &
!is.na(classes) & classes == item$material_class
)
eligible_classes <- established[
spectrum_type == item$spectrum_type & pool == item$pool,
material_class
]
candidates <- which(
spectrum_types == item$spectrum_type & pools == item$pool &
classes %in% eligible_classes
)
if (!is.na(item$material_type)) {
candidates <- candidates[
material_types[candidates] == item$material_type
]
}
candidates <- candidates[!is.na(candidates)]
match <- .lib_prune_best_class(
query, candidates, classes, normalized, ids
)
if (is.null(match) || tolower(item$material_class) == "unclassified") {
dropped_rows <- c(dropped_rows, query)
class_rows[[length(class_rows) + 1L]] <- data.table::data.table(
spectrum_type = item$spectrum_type, pool = item$pool,
material_class = item$material_class,
observed_n = as.integer(item$observed_n),
minimum_spectra = as.integer(min_n),
shortfall = as.integer(min_n - item$observed_n),
destination_class = NA_character_, mean_correlation = NA_real_,
spectra_removed = as.integer(item$observed_n), action = "dropped",
reason = "class_below_min_n_no_eligible_destination"
)
next
}
prior_class <- classes[query]
prior_type <- material_types[query]
classes[query] <- match$material_class
material_types[query] <- material_types[match$index]
report_rows[[length(report_rows) + 1L]] <- data.table::data.table(
spectrum_id = ids[query], prior_class,
material_class = classes[query], prior_material_type = prior_type,
material_type = material_types[query],
matched_id = ids[match$index], correlation = match$correlation,
pool = pools[query], reason = "class_below_min_n_reassigned"
)
class_rows[[length(class_rows) + 1L]] <- data.table::data.table(
spectrum_type = item$spectrum_type, pool = item$pool,
material_class = item$material_class,
observed_n = as.integer(item$observed_n),
minimum_spectra = as.integer(min_n),
shortfall = as.integer(min_n - item$observed_n),
destination_class = match$material_class,
mean_correlation = match$mean_correlation,
spectra_removed = 0L, action = "reassigned",
reason = "class_below_min_n_reassigned"
)
}
report <- if (length(report_rows)) {
data.table::rbindlist(report_rows, fill = TRUE)
} else {
.lib_prune_reassignment_schema()
}
classes_report <- if (length(class_rows)) {
data.table::rbindlist(class_rows, fill = TRUE)
} else {
.lib_prune_excluded_class_schema()
}
if (isTRUE(progress) && nrow(small)) {
message(sprintf(
paste0("prune_lib: small-class reassignment complete ",
"(classes=%d; reassigned=%d; dropped=%d)"),
nrow(small), sum(classes_report$action == "reassigned"),
sum(classes_report$action == "dropped")
))
}
list(
classes = classes, material_types = material_types, report = report,
classes_report = classes_report,
dropped_rows = sort(unique(as.integer(dropped_rows)))
)
}
.lib_prune_best_class <- function(query, candidates, classes, normalized, ids) {
if (!length(query) || !length(candidates)) return(NULL)
candidates <- candidates[order(ids[candidates], candidates, na.last = TRUE)]
destination <- sort(unique(classes[candidates]))
destination <- destination[!is.na(destination) & nzchar(destination)]
if (!length(destination)) return(NULL)
correlations <- tcrossprod(
normalized[query, , drop = FALSE], normalized
)[, candidates, drop = FALSE]
correlations[!is.finite(correlations)] <- -Inf
scores <- vapply(destination, function(class) {
columns <- which(classes[candidates] == class)
best <- matrixStats::rowMaxs(correlations[, columns, drop = FALSE])
if (any(!is.finite(best))) -Inf else mean(best)
}, numeric(1L))
if (!any(is.finite(scores))) return(NULL)
best_score <- max(scores)
tolerance <- sqrt(.Machine$double.eps) * max(1, abs(best_score))
selected <- destination[which(abs(scores - best_score) <= tolerance)[[1L]]]
selected_candidates <- candidates[classes[candidates] == selected]
selected_columns <- match(selected_candidates, candidates)
selected_correlations <- correlations[, selected_columns, drop = FALSE]
top <- matrixStats::rowMaxs(selected_correlations)
near_top <- abs(selected_correlations - top) <=
sqrt(.Machine$double.eps) * pmax(1, abs(top))
local <- max.col(near_top, ties.method = "first")
list(
material_class = selected,
mean_correlation = unname(best_score),
index = selected_candidates[local],
correlation = selected_correlations[cbind(seq_along(query), local)]
)
}
#' @rdname build_lib
#' @export
reduce_lib <- function(x, group_cols = "material_class", id_col = "sample_name",
k = 50, min_n = k, return = c("object", "ids"),
progress = FALSE, ...) {
return <- match.arg(return)
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
x <- as_OpenSpecy(x)
.lib_require_cols(x$metadata, group_cols, "metadata")
ids <- .lib_ids(x, id_col)
groups <- do.call(paste, c(x$metadata[, group_cols, with = FALSE], sep = "_"))
group_index <- split(seq_along(groups), groups)
reduce_group <- lengths(group_index) > min_n & lengths(group_index) > k
reduce_number <- cumsum(reduce_group)
reduce_total <- sum(reduce_group)
reduction_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: %d spectra in %d groups; %d group(s) require PAM (k=%d)",
length(ids), length(group_index), reduce_total, k
))
}
keep_ids <- unlist(lapply(seq_along(group_index), function(group_i) {
idx <- group_index[[group_i]]
if (!reduce_group[[group_i]]) return(ids[idx])
reduce_i <- reduce_number[[group_i]]
values <- vapply(group_cols, function(column) {
value <- as.character(x$metadata[[column]][idx[[1L]]])
if (is.na(value) || !nzchar(value)) value <- "<missing>"
paste0(column, "=", value)
}, character(1))
label <- paste(values, collapse = ", ")
group_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM group %d/%d starting (%s; n=%d; k=%d)",
reduce_i, reduce_total, label, length(idx), k
))
}
reduction_group <- filter_spec(x, idx)
fill_started <- proc.time()[["elapsed"]]
missing_values <- sum(!is.finite(reduction_group$spectra))
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: spectrum-mean fill starting ",
"(%s; n=%d; missing=%d)"),
label, length(idx), missing_values
))
}
reduction_group$spectra <- make_rel(
.lib_spectrum_mean_replace(reduction_group$spectra), na.rm = TRUE
)
# A constant spectrum has no relative range. Keep it as a flat zero
# candidate so the support rule, rather than complete-case behavior,
# controls eligibility; cor_spec() will assign it no positive similarity.
reduction_group$spectra[!is.finite(reduction_group$spectra)] <- 0
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: spectrum-mean fill complete ",
"(%s; replaced=%d; %.1fs)"),
label, missing_values,
proc.time()[["elapsed"]] - fill_started
))
}
selected <- .pam_group_ids(
reduction_group, id_col = id_col, k = k,
progress = progress, group_label = label, ...
)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM group %d/%d complete (kept=%d/%d; %.1fs)",
reduce_i, reduce_total, length(selected), length(idx),
proc.time()[["elapsed"]] - group_started
))
}
selected
}), use.names = FALSE)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: complete (kept=%d/%d; %.1fs)",
length(keep_ids), length(ids),
proc.time()[["elapsed"]] - reduction_started
))
}
if (return == "ids") return(keep_ids)
filter_spec(x, keep_ids)
}
#' @rdname build_lib
#' @export
build_model_lib <- function(x, class_col = "material_class",
type_col = "spectrum_type", min_n = 10,
alpha = 0.1, seed = 123,
grouped = TRUE, weights = TRUE,
make_relative = TRUE,
method = c("logistic_regression", "random_forest"),
...) {
train_spec_model(
x = x, class_col = class_col, type_col = type_col, min_n = min_n,
alpha = alpha, seed = seed, grouped = grouped, weights = weights,
make_relative = make_relative, method = method, ...
)
}
.lib_build_workers <- function() {
workers <- suppressWarnings(as.integer(
getOption("OpenSpecy.build_workers", 1L)
))
if (length(workers) != 1L || is.na(workers) || workers < 1L) return(1L)
workers
}
.lib_cv_glmnet <- function(arguments, workers, folds, seed) {
workers <- min(as.integer(workers), as.integer(folds))
can_parallelize <- workers > 1L &&
requireNamespace("doFuture", quietly = TRUE) &&
requireNamespace("doRNG", quietly = TRUE) &&
requireNamespace("future", quietly = TRUE) &&
requireNamespace("foreach", quietly = TRUE)
if (!can_parallelize) return(do.call(glmnet::cv.glmnet, arguments))
# A maintainer workflow may register one persistent doFuture backend so
# successive model fits do not repeatedly start and stop worker processes.
if (identical(foreach::getDoParName(), "doFuture")) {
doRNG::registerDoRNG(seed)
on.exit(doFuture::registerDoFuture(), add = TRUE)
arguments$parallel <- TRUE
return(do.call(glmnet::cv.glmnet, arguments))
}
previous_plan <- future::plan()
on.exit({
future::plan(previous_plan)
foreach::registerDoSEQ()
}, add = TRUE)
doFuture::registerDoFuture()
future::plan(future::multisession, workers = workers)
doRNG::registerDoRNG(seed)
arguments$parallel <- TRUE
do.call(glmnet::cv.glmnet, arguments)
}
#' @rdname build_lib
#' @export
train_spec_model <- function(x, class_col = "material_class",
type_col = "spectrum_type", min_n = 10,
alpha = 0.1, seed = 123,
grouped = TRUE, weights = TRUE,
make_relative = TRUE,
method = c("logistic_regression", "random_forest"),
...) {
method <- match.arg(method)
x <- as_OpenSpecy(x)
.lib_require_cols(x$metadata, class_col, "metadata")
supported <- .lib_filter_spectral_support(x, min_fraction = 0.1)
x <- supported$object
support <- supported$audit
wavenumbers <- x$wavenumber
spectra <- x$spectra
if (make_relative) spectra <- make_rel(spectra, na.rm = TRUE)
metadata <- data.table::copy(x$metadata)
labels <- as.character(metadata[[class_col]])
if (!is.null(type_col) && type_col %in% names(metadata)) {
types <- as.character(metadata[[type_col]])
labels <- ifelse(is.na(types), labels, paste(types, labels, sep = "_"))
}
keep <- !is.na(labels)
tab <- table(labels[keep])
class_support <- data.table::data.table(
class = names(tab), spectra = as.integer(tab),
minimum_spectra = rep.int(as.integer(min_n), length(tab)),
retained = as.integer(tab) >= min_n
)
keep <- keep & labels %in% names(tab)[tab >= min_n]
spectra <- spectra[, keep, drop = FALSE]
labels <- labels[keep]
metadata <- metadata[keep, ]
if (ncol(spectra) == 0 || length(unique(labels)) < 2) {
stop("At least two classes with 'min_n' spectra are required to train a model",
call. = FALSE)
}
grouping_object <- x
grouping_object$spectra <- spectra
grouping_object$metadata <- metadata
group_ids <- .lib_stable_group_info(grouping_object)$group_id
filled <- .lib_wavenumber_mean_replace(spectra)
spectra <- filled$spectra
train <- t(spectra)
colnames(train) <- as.character(wavenumbers)
outcome <- as.integer(factor(labels))
weight_vec <- NULL
if (weights) weight_vec <- 1 / (table(outcome)[as.character(outcome)] / length(outcome))
dimension_conversion <- unique(data.table::data.table(
factor_num = outcome,
name = labels
))
fill_values <- filled$means
fill <- as_OpenSpecy(
wavenumbers,
spectra = matrix(
fill_values, ncol = 1L,
dimnames = list(NULL, "model_training_mean")
),
metadata = data.table::data.table(sample_name = "model_training_mean")
)
if (identical(method, "random_forest")) {
return(.lib_build_random_forest(
train = train, outcome = outcome, labels = labels, metadata = metadata,
type_col = type_col, weights = weights, seed = seed,
dimension_conversion = dimension_conversion, fill = fill,
support = support, class_support = class_support,
fill_replaced = filled$replaced, ...
))
}
set.seed(seed)
glmnet_args <- list(
x = train,
y = outcome,
alpha = alpha,
family = "multinomial",
intercept = FALSE,
type.multinomial = if (grouped) "grouped" else "ungrouped",
maxit = 1000000L
)
if (!is.null(weight_vec)) glmnet_args$weights <- as.numeric(weight_vec)
user_args <- list(...)
glmnet_args[names(user_args)] <- user_args
group_labels <- unique(data.table::data.table(
group_id = group_ids, outcome = outcome
))
mixed_groups <- group_labels[, data.table::uniqueN(outcome), by = group_id][
V1 > 1L, group_id
]
if (length(mixed_groups)) {
stop("Stable spectral groups span multiple model classes", call. = FALSE)
}
class_groups <- split(group_labels$group_id, group_labels$outcome)
nfolds <- min(5L, min(lengths(class_groups)))
if (nfolds >= 3L) {
group_fold <- character()
fold_value <- integer()
for (groups in class_groups) {
assignments <- sample(rep(seq_len(nfolds), length.out = length(groups)))
group_fold <- c(group_fold, groups)
fold_value <- c(fold_value, assignments)
}
foldid <- fold_value[match(group_ids, group_fold)]
cv_args <- glmnet_args
cv_args$foldid <- foldid
cv_args$nfolds <- nfolds
cv_args$type.measure <- "class"
cv_args$keep <- TRUE
fit <- .lib_cv_glmnet(
cv_args, workers = .lib_build_workers(), folds = nfolds, seed = seed
)
model <- fit$glmnet.fit
lambda_metrics <- .lib_macro_lambda_metrics(
fit$fit.preval, outcome = outcome, lambda = fit$lambda
)
selected_index <- which(lambda_metrics$selected)[[1L]]
lambda <- lambda_metrics$lambda[selected_index]
} else {
model <- do.call(glmnet::glmnet, glmnet_args)
lambda <- min(model$lambda)
selected_index <- length(model$lambda)
lambda_metrics <- data.table::data.table(
lambda = as.numeric(lambda), macro_class_accuracy = NA_real_,
overall_accuracy = NA_real_, selected = TRUE,
selection_scope = "minimum_lambda_insufficient_folds",
selection_rule = "minimum_lambda_without_three_folds"
)
}
convergence_error <- if (is.null(model$jerr)) 0L else as.integer(model$jerr)
selected_lambda_converged <- convergence_error == 0L ||
selected_index < length(model$lambda)
# Calls produced through do.call() can capture the complete training matrix
# and outcome. They are not used by coef() or predict(), and retaining them
# needlessly adds many megabytes to checkpoints and release artifacts.
model$call <- NULL
coefficients <- stats::coef(model, s = lambda)
coef_list <- if (is.list(coefficients)) coefficients else list(coefficients)
rows <- lapply(seq_along(coef_list), function(item) {
data.table::data.table(
dimensions_used = coef_list[[item]]@i,
dimension_units = coef_list[[item]]@x,
variable = item
)
})
coefficient_values <- data.table::rbindlist(rows)
wave <- data.table::data.table(
names = coef_list[[1]]@Dimnames[[1]],
id = seq_along(coef_list[[1]]@Dimnames[[1]]) - 1L
)
coefficients_join <- merge(coefficient_values, dimension_conversion,
by.x = "variable", by.y = "factor_num",
all.x = TRUE)
coefficients_join <- merge(coefficients_join, wave,
by.x = "dimensions_used", by.y = "id",
all.x = FALSE)
coefficients_join$names <- suppressWarnings(as.numeric(ifelse(
coefficients_join$names == "(Intercept)", "0", coefficients_join$names
)))
predictions <- predict(model, newx = train, s = lambda, type = "response")
pred <- .ai_prediction_table(predictions, n = nrow(train))
actual <- data.table::data.table(row_id = seq_along(outcome),
actual_label = outcome,
actual_name = labels)
tests <- merge(pred, actual, by.x = "x", by.y = "row_id", all.x = TRUE)
tests <- merge(tests, dimension_conversion, by.x = "y",
by.y = "factor_num", all.x = TRUE)
names(tests)[names(tests) == "name"] <- "predicted_class"
ids <- if ("sample_name" %in% names(metadata)) {
as.character(metadata$sample_name)
} else {
rownames(train)
}
if (is.null(ids)) ids <- paste0("spectrum_", seq_len(nrow(train)))
technique <- if (!is.null(type_col) && type_col %in% names(metadata)) {
as.character(metadata[[type_col]])
} else {
NA_character_
}
tests[, `:=`(
spectrum_id = ids[x],
technique = technique[x],
expected_class = actual_name,
correct = actual_name == predicted_class,
score = value,
split = "training",
provenance = "model_fit"
)]
tests <- tests[, .(
spectrum_id, technique, expected_class, predicted_class, correct, score,
split, provenance
)]
list(
model = model,
model_type = "logistic_regression",
lambda_selected = lambda,
lambda_path_complete = convergence_error == 0L,
selected_lambda_converged = selected_lambda_converged,
convergence_error = convergence_error,
training_groups = data.table::uniqueN(group_ids),
selection_metric = "macro_class_accuracy",
lambda_metrics = lambda_metrics,
dimension_conversion = dimension_conversion,
tests = tests,
coefficients = coefficients_join,
class_names = unique(labels),
class_num = length(unique(outcome)),
observation_count = length(labels),
fill = fill,
support = support,
class_support = class_support,
fill_method = "wavenumber_mean",
fill_replaced = as.integer(filled$replaced),
variable_num = nrow(coefficients_join),
all_variables = as.numeric(colnames(train)),
variables_in = coefficients_join$names
)
}
.lib_build_random_forest <- function(train, outcome, labels, metadata,
type_col, weights, seed,
dimension_conversion, fill, support,
class_support, fill_replaced, ...) {
if (!requireNamespace("ranger", quietly = TRUE)) {
stop(
"Training a random-forest model requires the suggested 'ranger' package",
call. = FALSE
)
}
p <- ncol(train)
outcome_factor <- factor(outcome, levels = sort(unique(outcome)))
class_counts <- table(outcome_factor)
class_weights <- length(outcome) /
(length(class_counts) * as.numeric(class_counts))
names(class_weights) <- names(class_counts)
class_weight_table <- merge(
data.table::data.table(
factor_num = as.integer(names(class_counts)),
spectra = as.integer(class_counts),
weight = if (isTRUE(weights)) as.numeric(class_weights) else 1,
application = if (isTRUE(weights)) "case_sampling" else "none"
),
dimension_conversion,
by = "factor_num", all.x = TRUE, sort = FALSE
)
ranger_args <- list(
x = train,
y = outcome_factor,
probability = TRUE,
num.trees = 500L,
mtry = max(1L, min(p, max(floor(sqrt(p)), floor(p / 20)))),
min.node.size = 10L,
importance = "permutation",
write.forest = TRUE,
oob.error = TRUE,
# Package and CI runs remain single-threaded by default. Official builders
# can opt into the host's cores without expanding the public API.
num.threads = .lib_build_workers(),
seed = as.integer(seed),
verbose = FALSE
)
if (isTRUE(weights)) {
ranger_args$case.weights <- as.numeric(
class_weights[as.character(outcome_factor)]
)
}
user_args <- list(...)
protected <- intersect(
names(user_args), c("x", "y", "probability", "write.forest", "oob.error")
)
if (length(protected)) {
stop(
"Random-forest arguments managed by train_spec_model() cannot be ",
"overridden: ", paste(protected, collapse = ", "), call. = FALSE
)
}
ranger_args[names(user_args)] <- user_args
set.seed(seed)
model <- do.call(ranger::ranger, ranger_args)
predictions <- model$predictions
pred <- .ai_prediction_table(predictions, n = nrow(train))
actual <- data.table::data.table(
row_id = seq_along(outcome),
actual_label = outcome,
actual_name = labels
)
tests <- merge(pred, actual, by.x = "x", by.y = "row_id", all.x = TRUE)
tests <- merge(
tests, dimension_conversion, by.x = "y", by.y = "factor_num",
all.x = TRUE
)
names(tests)[names(tests) == "name"] <- "predicted_class"
ids <- if ("sample_name" %in% names(metadata)) {
as.character(metadata$sample_name)
} else {
rownames(train)
}
if (is.null(ids)) ids <- paste0("spectrum_", seq_len(nrow(train)))
technique <- if (!is.null(type_col) && type_col %in% names(metadata)) {
as.character(metadata[[type_col]])
} else {
NA_character_
}
tests[, `:=`(
spectrum_id = ids[x],
technique = technique[x],
expected_class = actual_name,
correct = actual_name == predicted_class,
score = value,
split = "oob",
provenance = "model_oob"
)]
tests <- tests[, .(
spectrum_id, technique, expected_class, predicted_class, correct, score,
split, provenance
)]
class_accuracy <- tests[, .(
spectra = .N,
accuracy = mean(correct, na.rm = TRUE),
mean_score = mean(score, na.rm = TRUE)
), by = expected_class]
valid_accuracy <- class_accuracy$accuracy[is.finite(class_accuracy$accuracy)]
oob_metrics <- data.table::data.table(
spectra = nrow(tests),
classes = nrow(class_accuracy),
accuracy = mean(tests$correct, na.rm = TRUE),
macro_class_accuracy = if (length(valid_accuracy)) {
mean(valid_accuracy)
} else {
NA_real_
},
mean_score = mean(tests$score, na.rm = TRUE),
brier_score = as.numeric(model$prediction.error)
)
feature_importance <- data.table::data.table(
wavenumber = suppressWarnings(as.numeric(names(model$variable.importance))),
importance = as.numeric(model$variable.importance)
)
parameters <- data.table::data.table(
num_trees = as.integer(model$num.trees),
mtry = as.integer(model$mtry),
min_node_size = as.integer(ranger_args$min.node.size),
num_threads = as.integer(ranger_args$num.threads),
case_weighted = isTRUE(weights),
class_weighted = FALSE,
balance_method = if (isTRUE(weights)) {
if ("case.weights" %in% names(user_args)) {
"user_case_sampling"
} else {
"inverse_frequency_case_sampling"
}
} else {
"none"
},
importance = as.character(ranger_args$importance)
)
list(
model = model,
model_type = "random_forest",
lambda_selected = NA_real_,
selection_metric = "oob_macro_class_accuracy",
lambda_metrics = data.table::data.table(
lambda = numeric(), macro_class_accuracy = numeric(),
overall_accuracy = numeric(), selected = logical(),
selection_scope = character(), selection_rule = character()
),
dimension_conversion = dimension_conversion,
tests = tests,
coefficients = data.table::data.table(),
feature_importance = feature_importance,
oob_metrics = oob_metrics,
oob_class_accuracy = class_accuracy,
training_parameters = parameters,
class_weights = class_weight_table,
class_names = unique(labels),
class_num = length(unique(outcome)),
observation_count = length(labels),
fill = fill,
support = support,
class_support = class_support,
fill_method = "wavenumber_mean",
fill_replaced = as.integer(fill_replaced),
variable_num = p,
all_variables = as.numeric(colnames(train)),
variables_in = as.numeric(colnames(train))
)
}
.lib_spectrum_mean_replace <- function(spectra) {
spectra[!is.finite(spectra)] <- NA_real_
out <- mean_replace(spectra, na.rm = TRUE)
if (any(!is.finite(out))) {
stop("Spectrum-wise mean replacement left non-finite values", call. = FALSE)
}
out
}
.lib_wavenumber_mean_replace <- function(spectra) {
spectra[!is.finite(spectra)] <- NA_real_
means <- rowMeans(spectra, na.rm = TRUE)
missing_means <- which(!is.finite(means))
if (length(missing_means)) {
stop(
"Cannot fit a model because ", length(missing_means),
" wavenumber(s) have no finite training values",
call. = FALSE
)
}
missing <- is.na(spectra)
if (any(missing)) {
index <- which(missing, arr.ind = TRUE)
spectra[index] <- means[index[, "row"]]
}
list(spectra = spectra, means = means, replaced = sum(missing))
}
.lib_macro_lambda_metrics <- function(predictions, outcome, lambda) {
dimensions <- dim(predictions)
if (length(dimensions) != 3L || dimensions[1L] != length(outcome) ||
dimensions[3L] != length(lambda)) {
stop("Unexpected multinomial cross-validation prediction shape",
call. = FALSE)
}
predicted <- apply(predictions, c(1L, 3L), which.max)
if (is.null(dim(predicted))) {
predicted <- matrix(predicted, nrow = length(outcome))
}
macro <- vapply(seq_along(lambda), function(i) {
class_accuracy <- vapply(split(seq_along(outcome), outcome), function(rows) {
mean(predicted[rows, i] == outcome[rows], na.rm = TRUE)
}, numeric(1))
mean(class_accuracy, na.rm = TRUE)
}, numeric(1))
overall <- vapply(seq_along(lambda), function(i) {
mean(predicted[, i] == outcome, na.rm = TRUE)
}, numeric(1))
best <- which.max(macro)
data.table::data.table(
lambda = as.numeric(lambda), macro_class_accuracy = macro,
overall_accuracy = overall, selected = seq_along(lambda) == best,
selection_scope = "out_of_fold",
selection_rule = "max_macro_accuracy_then_largest_lambda"
)
}
.lib_support_schema <- function() {
data.table::data.table(
spectrum_id = character(), observed = integer(), available = integer(),
observed_fraction = numeric(), minimum_observed = integer(),
retained = logical()
)
}
.lib_filter_spectral_support <- function(x, min_fraction = 0.1,
id_col = "sample_name") {
x <- as_OpenSpecy(x)
if (!is.numeric(min_fraction) || length(min_fraction) != 1L ||
is.na(min_fraction) || min_fraction <= 0 || min_fraction > 1) {
stop("'min_fraction' must be in (0, 1]", call. = FALSE)
}
finite <- is.finite(x$spectra)
observed <- colSums(finite)
available <- nrow(finite)
minimum <- as.integer(ceiling(min_fraction * available))
retained <- observed >= minimum
audit <- data.table::data.table(
spectrum_id = as.character(.lib_ids(x, id_col)),
observed = as.integer(observed), available = as.integer(available),
observed_fraction = as.numeric(observed / available),
minimum_observed = rep.int(minimum, length(observed)),
retained = retained
)
rm(finite)
if (!any(retained)) {
stop(
"No spectra meet the minimum observed support of ",
format(min_fraction * 100, trim = TRUE), "% (", minimum, " of ",
available, " wavenumbers)", call. = FALSE
)
}
out <- if (all(retained)) x else filter_spec(x, retained)
attr(out, "identification_support") <- audit
attr(out, "identification_dropped_ids") <- audit[!retained, spectrum_id]
attr(out, "identification_minimum_observed") <- minimum
attr(out, "identification_finite_coverage") <- mean(observed / available)
list(object = out, audit = audit)
}
#' @rdname build_lib
#' @export
assess_lib <- function(x, class_col = NULL, id_col = "sample_name",
nearest = !is.null(class_col)) {
x <- as_OpenSpecy(x)
valid <- suppressWarnings(check_OpenSpecy(x))
out <- data.table::data.table(
metric = c("valid_OpenSpecy", "spectra", "wavenumbers"),
value = c(as.character(valid), ncol(x$spectra), length(x$wavenumber))
)
if (!is.null(class_col) && class_col %in% names(x$metadata)) {
counts <- data.table::data.table(class = x$metadata[[class_col]])[
, .N, by = "class"]
out <- rbind(out, data.table::data.table(
metric = c("classes", "smallest_class"),
value = c(length(unique(counts$class)), min(counts$N))
), fill = TRUE)
}
if (nearest && ncol(x$spectra) > 1 && class_col %in% names(x$metadata)) {
cors <- cor_spec(x, x)
diag(cors) <- NA
top <- max_cor_named(cors)
ids <- .lib_ids(x, id_col)
matched <- x$metadata[[class_col]][match(names(top), ids)]
accuracy <- mean(matched == x$metadata[[class_col]], na.rm = TRUE)
out <- rbind(out, data.table::data.table(
metric = "nearest_class_accuracy",
value = accuracy
), fill = TRUE)
}
out
}
.default_lib_recipes <- function() {
list(
raw = list(),
derivative = list(
conform_spec = FALSE,
smooth_intens = TRUE,
smooth_intens_args = list(
polynomial = 3,
window = 15,
derivative = 1,
abs = TRUE
),
subtr_baseline = FALSE,
make_rel = TRUE
),
nobaseline = list(
conform_spec = FALSE,
smooth_intens = FALSE,
subtr_baseline = TRUE,
make_rel = TRUE
)
)
}
.lib_reference_sources <- function(source_file, processed_dir,
progress = TRUE) {
processed <- character()
if (!is.null(processed_dir) && dir.exists(processed_dir)) {
processed <- list.files(
processed_dir, pattern = "[.]rds$", recursive = TRUE,
full.names = TRUE, ignore.case = TRUE
)
processed <- processed[grepl(
"[/\\\\]Processed[/\\\\]", processed, ignore.case = TRUE
)]
}
source <- if (!is.null(source_file) && file.exists(source_file)) {
source_file
} else {
character()
}
files <- unique(c(processed, source))
if (length(files) == 0L) {
stop(
"No official reference-library sources were found. Set ",
"OPENSPECY_SOURCE_FILE and/or OPENSPECY_PROCESSED_DIR, or supply 'x'",
call. = FALSE
)
}
if (isTRUE(progress)) {
message(sprintf(
"build_lib: discovered %d processed source(s) plus %d raw source(s)",
length(processed), length(source)
))
}
files
}
.lib_build_reference <- function(x, recipes, range, res, id_col, exclude_ids,
dedupe, metadata_lookups,
material_hierarchy, metadata_name_lookup,
clean_metadata_values, convert_intensity,
restrict_range_args, signal_noise, assess,
prune, progress, workflow_data, output_dir,
previous_library_dir, reuse, remove_other,
seed, holdout,
...) {
if (!is.character(output_dir) || length(output_dir) != 1L ||
is.na(output_dir) || !nzchar(output_dir)) {
stop("'output_dir' must be one nonempty path in end-to-end mode",
call. = FALSE)
}
if (!is.numeric(seed) || length(seed) != 1L || is.na(seed)) {
stop("'seed' must be one finite number", call. = FALSE)
}
if (!is.numeric(holdout) || length(holdout) != 1L || is.na(holdout) ||
holdout <= 0 || holdout >= 1) {
stop("'holdout' must be between zero and one", call. = FALSE)
}
started <- proc.time()[["elapsed"]]
report <- function(stage) {
if (isTRUE(progress)) {
message(sprintf(
"build_lib [%.1fs]: %s",
proc.time()[["elapsed"]] - started, stage
))
}
}
report("resolving official lookup and exclusion tables")
tables <- .lib_reference_tables(workflow_data)
.lib_validate_reference_tables(tables)
classes_exact <- tables$classes_reference[
!is.na(material) & nzchar(material), .(spectrum_identity, material)
]
type_lookup <- data.table::copy(tables$library_types)
if ("spectrum_type" %in% names(type_lookup)) {
type_lookup[grepl(";", spectrum_type, fixed = TRUE),
spectrum_type := NA_character_]
}
if (is.null(metadata_lookups)) {
metadata_lookups <- list(
list(lookup = classes_exact, by = "spectrum_identity"),
list(lookup = type_lookup, by = "organization", fill_only = TRUE)
)
}
if (is.null(material_hierarchy)) {
material_hierarchy <- tables$material_hierarchy
}
if (is.null(exclude_ids)) exclude_ids <- tables$known_bad_ids$sample_name
signature <- .lib_build_signature(
x,
workflow_paths = unlist(tables$paths, use.names = FALSE),
arguments = list(
recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
remove_other = remove_other, seed = seed, holdout = holdout
)
)
# Keep completed libraries, medoids, and production models reusable when
# only assessment, reporting, or export code changes. Bump this version
# whenever those scientific artifacts intentionally change.
artifact_signature <- .lib_component_signature(
x,
workflow_paths = unlist(tables$paths, use.names = FALSE),
arguments = list(
recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = prune,
remove_other = remove_other
),
component_version = "reference-artifacts-v12-correlation-closure-quarantine"
)
# Keep expensive spectral preprocessing reusable when only downstream class,
# pruning, assessment, or export code changes. Bump component_version only
# when a core transformation intentionally changes its scientific output.
core_signature <- .lib_component_signature(
x,
workflow_paths = unlist(
tables$paths[c(
"classes_reference", "library_types", "material_hierarchy",
"known_bad_ids"
)],
use.names = FALSE
),
arguments = list(
recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess
),
component_version = "core-libraries-v2-library-name"
)
checkpoints <- .lib_checkpoint_manager(
output_dir, signature = artifact_signature, reuse = reuse, report = report
)
libraries <- checkpoints$get("libraries")
local_assessments <- checkpoints$get("library_assessments")
quarantine <- checkpoints$get("quarantined_spectra")
if (is.null(libraries)) {
core_path <- file.path(output_dir, "checkpoints", "core_libraries.rds")
core <- checkpoints$get("core_libraries", key = core_signature)
if (is.null(core)) {
report("building raw, derivative, and nobaseline libraries")
core <- .lib_build_core(
x = x, recipes = recipes, range = range, res = res, id_col = id_col,
exclude_ids = exclude_ids, dedupe = dedupe,
metadata_lookups = metadata_lookups,
material_hierarchy = material_hierarchy,
metadata_name_lookup = metadata_name_lookup,
clean_metadata_values = clean_metadata_values,
convert_intensity = convert_intensity,
restrict_range_args = restrict_range_args,
signal_noise = signal_noise, assess = assess, prune = NULL,
progress = progress, ...
)
checkpoints$put("core_libraries", core, key = core_signature)
for (name in names(core)) {
checkpoints$put(
paste0("core_library_", name), core[[name]], key = core_signature
)
}
}
rm(core)
gc(verbose = FALSE)
completed <- .lib_complete_reference_build(
readRDS(core_path), tables = tables, prune = prune,
remove_other = remove_other,
progress = progress,
report = report
)
libraries <- completed$libraries
local_assessments <- completed$assessments
quarantine <- completed$quarantine
quarantine$manifest$build_signature <- artifact_signature
quarantine$manifest$source_hashes <- artifact_signature
.lib_write_quarantine_review(quarantine, output_dir)
checkpoints$put("libraries", libraries)
checkpoints$put("library_assessments", local_assessments)
checkpoints$put("quarantined_spectra", quarantine)
for (name in names(libraries)) {
checkpoints$put(paste0("library_", name), libraries[[name]])
}
} else if (is.null(local_assessments)) {
report("reconstructing completed-library assessments from attributes")
local_assessments <- .lib_recover_library_assessments(libraries, tables)
checkpoints$put("library_assessments", local_assessments)
}
if (is.null(quarantine)) {
quarantine <- .lib_quarantine_bundle(build_signature = artifact_signature)
.lib_write_quarantine_review(quarantine, output_dir)
checkpoints$put("quarantined_spectra", quarantine)
}
medoids <- checkpoints$get("medoids")
if (is.null(medoids)) {
medoids <- .lib_build_medoids(
libraries, report = report, checkpoints = checkpoints,
progress = progress
)
checkpoints$put("medoids", medoids)
}
correlation_closure <- .lib_validate_medoid_parent_closure(
libraries, medoids, prune_spec = prune, report = report
)
local_assessments$correlation_closure <- correlation_closure
report("finalizing library metadata by missing-value count")
finalized <- .lib_finalize_reference_metadata(libraries, medoids)
libraries <- finalized$libraries
medoids <- finalized$medoids
local_assessments$metadata_finalization <- finalized$assessment
models <- checkpoints$get("models_logistic_regression_parallel_rng_v2")
model_warnings <- .lib_warning_schema()
if (is.null(models)) {
model_result <- .lib_build_models(
libraries, medoids, report = report, checkpoints = checkpoints
)
models <- model_result$models
model_warnings <- model_result$warnings
checkpoints$put("models_logistic_regression_parallel_rng_v2", models)
}
build <- list(
libraries = libraries,
medoids = medoids,
models = models,
assessments = .lib_local_build_assessments(
libraries, medoids, models, local_assessments, model_warnings
)
)
prior_signature <- .lib_previous_signature(previous_library_dir)
assessment_key <- digest::digest(
list(
artifact_signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "typed-legacy-bundles-v18-accuracy-comparison"
),
algo = "sha256"
)
fallback_assessment_key <- digest::digest(
list(
artifact_signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "selected-lambda-logistic-v14"
),
algo = "sha256"
)
cached_assessments <- checkpoints$get(
"assessment_components_parallel_rng_v1", key = assessment_key
)
if (!is.null(cached_assessments)) {
build$assessments <- cached_assessments
validated_models <- checkpoints$get(
"validated_models_parallel_rng_v1", key = assessment_key
)
if (!is.null(validated_models)) build$models <- validated_models
} else if (!is.null(previous_library_dir)) {
report("assessing complete candidate and legacy artifacts")
comparison <- .lib_compare_reference_build(
build, previous_library_dir = previous_library_dir,
seed = seed, holdout = holdout, progress = progress,
checkpoints = checkpoints, checkpoint_key = assessment_key,
checkpoint_fallback_key = fallback_assessment_key
)
if (!is.null(comparison$models)) {
build$models <- comparison$models
checkpoints$put(
"validated_models_parallel_rng_v1", build$models, key = assessment_key
)
comparison$models <- NULL
}
build$assessments[names(comparison)] <- comparison
}
build$assessments$output_manifest <- checkpoints$manifest()
assessment_components <- build$assessments
checkpoints$put(
"assessment_components_parallel_rng_v1", assessment_components,
key = assessment_key
)
build$assessments <- .lib_assessment_review(assessment_components)
.lib_validate_reference_build(build)
checkpoints$put("assessments", build$assessments, key = assessment_key)
checkpoints$put("reference_library_build", build, key = assessment_key)
release_signature <- .lib_release_signature(assessment_key)
report("promoting validated artifacts to a versioned release directory")
promotion <- .lib_promote_reference_build(
build, quarantine = quarantine, output_dir = output_dir,
signature = release_signature, reuse = reuse, progress = report
)
build <- .lib_finalize_reference_release(
build, assessment_components, promotion, release_signature, report
)
report("complete")
build
}
.lib_rebuild_artifacts <- function(x, output_dir, previous_library_dir,
reuse, seed, holdout, progress) {
if (missing(x)) {
stop("'x' must specify a completed build or checkpoint", call. = FALSE)
}
if (!is.character(output_dir) || length(output_dir) != 1L ||
is.na(output_dir) || !nzchar(output_dir)) {
stop("'output_dir' must be one nonempty path", call. = FALSE)
}
if (!is.logical(reuse) || length(reuse) != 1L || is.na(reuse)) {
stop("'reuse' must be TRUE or FALSE", call. = FALSE)
}
if (!is.logical(progress) || length(progress) != 1L || is.na(progress)) {
stop("'progress' must be TRUE or FALSE", call. = FALSE)
}
if (!is.numeric(seed) || length(seed) != 1L || !is.finite(seed)) {
stop("'seed' must be one finite number", call. = FALSE)
}
if (!is.numeric(holdout) || length(holdout) != 1L || is.na(holdout) ||
holdout <= 0 || holdout >= 1) {
stop("'holdout' must be between zero and one", call. = FALSE)
}
started <- proc.time()[["elapsed"]]
report <- function(stage) {
if (isTRUE(progress)) message(sprintf(
"rebuild_lib_artifacts [%.1fs]: %s",
proc.time()[["elapsed"]] - started, stage
))
}
report("resolving completed libraries and upstream assessments")
input <- .lib_resolve_rebuild_input(x)
libraries <- .lib_drop_typed_range_flats(input$libraries, report = report)
completed <- input$assessments
quarantine <- input$quarantine
signature <- digest::digest(list(
input = input$signature,
downstream_version = "full-library-random-forest-model-v5-range-flat-filter"
), algo = "sha256")
checkpoints <- .lib_checkpoint_manager(
output_dir, signature = signature, reuse = reuse, report = report
)
medoids <- checkpoints$get("medoids")
if (is.null(medoids) && !is.null(input$medoids)) {
report("reusing compatible medoids supplied by the completed build")
medoids <- input$medoids
checkpoints$put("medoids", medoids)
}
if (is.null(medoids)) {
medoids <- .lib_build_medoids(
libraries, report = report, checkpoints = checkpoints,
progress = progress
)
checkpoints$put("medoids", medoids)
}
report("finalizing library metadata by missing-value count")
finalized <- .lib_finalize_reference_metadata(libraries, medoids)
libraries <- finalized$libraries
medoids <- finalized$medoids
if (is.null(completed)) completed <- list()
completed$metadata_finalization <- finalized$assessment
models <- checkpoints$get("models_logistic_regression_parallel_rng_v2")
model_warnings <- .lib_warning_schema()
if (is.null(models)) {
supplied_models <- input$models
if (!is.null(supplied_models$logistic_regression)) {
for (recipe in names(supplied_models$logistic_regression)) {
for (type in names(supplied_models$logistic_regression[[recipe]])) {
stage <- paste(
"model", "logistic_regression", recipe, type, sep = "_"
)
stage <- paste0(stage, "_parallel_rng_v1")
if (is.null(checkpoints$get(stage))) {
model <- supplied_models$logistic_regression[[recipe]][[type]]
if (is.null(model$model_type)) model$model_type <- "logistic_regression"
checkpoints$put(stage, model)
}
}
}
report("reusing compatible logistic models supplied by the completed build")
}
result <- .lib_build_models(
libraries, medoids, report = report, checkpoints = checkpoints
)
models <- result$models
model_warnings <- result$warnings
checkpoints$put("models_logistic_regression_parallel_rng_v2", models)
}
build <- list(
libraries = libraries, medoids = medoids, models = models,
assessments = .lib_local_build_assessments(
libraries, medoids, models, completed, model_warnings
)
)
prior_signature <- .lib_previous_signature(previous_library_dir)
assessment_key <- digest::digest(list(
signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "typed-legacy-bundles-v18-accuracy-comparison"
), algo = "sha256")
fallback_assessment_key <- digest::digest(list(
signature, prior_signature, seed = seed, holdout = holdout,
assessment_version = "selected-lambda-logistic-v14"
), algo = "sha256")
cached <- checkpoints$get(
"assessment_components_parallel_rng_v1", key = assessment_key
)
if (!is.null(cached)) {
build$assessments <- cached
validated <- checkpoints$get(
"validated_models_parallel_rng_v1", key = assessment_key
)
if (!is.null(validated)) build$models <- validated
} else if (!is.null(previous_library_dir)) {
report("assessing candidate and legacy artifacts on source-local cohorts")
comparison <- .lib_compare_reference_build(
build, previous_library_dir = previous_library_dir,
seed = seed, holdout = holdout, progress = progress,
checkpoints = checkpoints, checkpoint_key = assessment_key,
checkpoint_fallback_key = fallback_assessment_key
)
if (!is.null(comparison$models)) {
build$models <- comparison$models
checkpoints$put(
"validated_models_parallel_rng_v1", build$models, key = assessment_key
)
comparison$models <- NULL
}
build$assessments[names(comparison)] <- comparison
}
build$assessments$output_manifest <- checkpoints$manifest()
assessment_components <- build$assessments
checkpoints$put(
"assessment_components_parallel_rng_v1", assessment_components,
key = assessment_key
)
build$assessments <- .lib_assessment_review(assessment_components)
.lib_validate_reference_build(build)
checkpoints$put("assessments", build$assessments, key = assessment_key)
checkpoints$put("reference_library_build", build, key = assessment_key)
release_signature <- .lib_release_signature(assessment_key)
report("promoting downstream artifacts to a versioned release directory")
promotion <- .lib_promote_reference_build(
build, quarantine = quarantine, output_dir = output_dir,
signature = release_signature, reuse = reuse, progress = report
)
build <- .lib_finalize_reference_release(
build, assessment_components, promotion, release_signature, report
)
report("complete")
build
}
.lib_resolve_rebuild_input <- function(x) {
source_path <- NULL
source_signature <- NULL
sibling_assessments <- NULL
if (is.character(x)) {
if (length(x) != 1L || is.na(x) || !nzchar(x)) {
stop("'x' must be one completed-build or checkpoint path", call. = FALSE)
}
if (dir.exists(x)) {
candidates <- c(
file.path(x, "checkpoints", "libraries.rds"),
file.path(x, "libraries.rds"),
file.path(x, "reference_library_build.rds"),
file.path(x, "checkpoints", "reference_library_build.rds")
)
releases <- list.files(
file.path(x, "releases"), pattern = "reference_library_build[.]rds$",
recursive = TRUE, full.names = TRUE
)
candidates <- c(candidates, releases)
candidates <- candidates[file.exists(candidates)]
if (!length(candidates)) {
stop("No completed libraries checkpoint was found under 'x'",
call. = FALSE)
}
source_path <- candidates[[1L]]
} else if (file.exists(x)) {
source_path <- x
} else {
stop("'x' does not exist: ", x, call. = FALSE)
}
manifest_path <- sub("[.]rds$", ".manifest.rds", source_path)
manifest <- if (file.exists(manifest_path)) {
tryCatch(readRDS(manifest_path), error = function(error) NULL)
} else NULL
source_signature <- if (is.list(manifest) &&
!is.null(manifest$signature)) {
manifest$signature
} else {
digest::digest(.lib_file_signatures(source_path), algo = "sha256")
}
if (identical(basename(source_path), "libraries.rds")) {
sibling <- file.path(dirname(source_path), "library_assessments.rds")
if (file.exists(sibling)) sibling_assessments <- readRDS(sibling)
}
x <- readRDS(source_path)
if (.lib_is_release_index(x)) {
source_signature <- x$build_signature
x <- .lib_load_release_index(x, dirname(source_path))
}
}
if (!is.list(x)) {
stop("'x' must resolve to a completed build or nested libraries list",
call. = FALSE)
}
medoids <- NULL
models <- NULL
quarantine <- NULL
if (!is.null(x$libraries)) {
libraries <- x$libraries
assessments <- .lib_upstream_assessments(x$assessments)
medoids <- x$medoids
models <- x$models
quarantine <- x$quarantine
if (!is.null(models) &&
!any(c("logistic_regression", "random_forest") %in% names(models))) {
models <- list(logistic_regression = models)
}
if (is.null(source_signature)) {
source_signature <- attr(x, "build_signature", exact = TRUE)
}
} else {
libraries <- x
assessments <- .lib_upstream_assessments(sibling_assessments)
}
required <- c("derivative", "nobaseline")
if (!all(required %in% names(libraries))) {
stop("Completed libraries must contain derivative and nobaseline recipes",
call. = FALSE)
}
valid_recipe <- vapply(libraries[required], function(recipe) {
is.list(recipe) && length(recipe) > 0L &&
all(vapply(recipe, is_OpenSpecy, logical(1)))
}, logical(1))
if (!all(valid_recipe)) {
stop("Derivative and nobaseline libraries must be spectrum-type lists of OpenSpecy objects",
call. = FALSE)
}
if (is.null(source_signature) || !length(source_signature) ||
is.na(source_signature[[1L]])) {
source_signature <- digest::digest(libraries, algo = "sha256")
}
list(
libraries = libraries, medoids = medoids, models = models,
assessments = assessments, quarantine = quarantine,
signature = as.character(source_signature[[1L]]), path = source_path
)
}
.lib_upstream_assessments <- function(assessments) {
if (is.null(assessments) || !is.list(assessments)) return(NULL)
nested <- attr(assessments, "upstream_assessments", exact = TRUE)
if (!is.null(nested)) return(nested)
keep <- c(
"lookup_coverage", "identity_cleanup", "class_prediction",
"class_coverage", "type_coverage", "material_form_enrichment",
"material_form_matches", "material_form_clashes",
"common_use_enrichment", "common_use_coverage",
"exclusions_deduplication",
"other_review", "other_filter", "filters", "metadata_drop",
"metadata_finalization", "pruning", "pruning_excluded_classes",
"pruning_reassignments", "pruning_removals", "pruning_conflicts",
"correlation_closure",
"quality_control", "automated_test_flags", "library_retention",
"dropped_spectrum_identities",
"model_assessment_correlations"
)
assessments[intersect(keep, names(assessments))]
}
.lib_find_workflow_data <- function(workflow_data = NULL,
script_dirs = NULL) {
if (!is.null(workflow_data)) return(workflow_data)
if (is.null(script_dirs)) {
script_paths <- unlist(lapply(sys.frames(), function(frame) {
path <- frame$ofile
if (is.null(path)) character() else as.character(path)
}), use.names = FALSE)
script_dirs <- dirname(normalizePath(
script_paths[file.exists(script_paths)], mustWork = FALSE
))
}
candidates <- unique(c(
file.path(rev(script_dirs), "data"),
file.path(getwd(), "data"),
file.path(getwd(), "workflows", "data")
))
required <- c(
"classes_reference.csv", "classes_regex.csv", "library_types.csv",
"material_hierarchy.csv", "known_bad_ids.csv",
"metadata_drop_columns.csv", "material_form_regex.csv",
"common_use_reference.csv"
)
complete <- vapply(candidates, function(path) {
dir.exists(path) && all(file.exists(file.path(path, required)))
}, logical(1))
if (!any(complete)) {
stop(
"Could not locate the reference helper tables. Put them in data/ ",
"beside the calling script or supply 'workflow_data'. Searched: ",
paste(candidates, collapse = ", "),
call. = FALSE
)
}
normalizePath(candidates[which(complete)[1L]], mustWork = TRUE)
}
.lib_reference_tables <- function(workflow_data) {
if (!is.character(workflow_data) || length(workflow_data) != 1L ||
is.na(workflow_data) || !nzchar(workflow_data)) {
stop("'workflow_data' must be one nonempty directory", call. = FALSE)
}
files <- c(
classes_reference = "classes_reference.csv",
classes_regex = "classes_regex.csv",
library_types = "library_types.csv",
material_hierarchy = "material_hierarchy.csv",
known_bad_ids = "known_bad_ids.csv",
metadata_drop = "metadata_drop_columns.csv",
material_form_regex = "material_form_regex.csv",
common_use_reference = "common_use_reference.csv"
)
paths <- stats::setNames(file.path(workflow_data, unname(files)), names(files))
missing <- !file.exists(paths)
if (any(missing)) {
stop("Missing workflow data file(s): ",
paste(paths[missing], collapse = ", "), call. = FALSE)
}
out <- lapply(paths, data.table::fread)
out$paths <- as.list(paths)
out
}
.lib_validate_reference_regex <- function(regex_reference) {
.lib_require_cols(regex_reference, c("pattern", "material"),
"classes_regex")
literal_only <- vapply(
regex_reference$pattern, .lib_regex_is_exact_literal, logical(1)
)
if (any(literal_only)) {
stop(
"Literal-only anchored class patterns belong in classes_reference.csv: ",
paste(regex_reference$pattern[literal_only], collapse = ", "),
call. = FALSE
)
}
invisible(TRUE)
}
.lib_validate_reference_tables <- function(tables) {
.lib_require_cols(
tables$classes_reference, c("spectrum_identity", "material"),
"classes_reference"
)
identity <- trimws(as.character(tables$classes_reference$spectrum_identity))
if (any(is.na(identity) | !nzchar(identity)) || anyDuplicated(identity)) {
stop("classes_reference keys must be nonblank and unique", call. = FALSE)
}
spreadsheet_date <- grepl(
"^([0-9]{1,2}-[A-Za-z]{3}|[A-Za-z]{3}-[0-9]{1,2})$", identity
)
if (any(spreadsheet_date)) {
stop(
"classes_reference contains spreadsheet-style date coercions: ",
paste(identity[spreadsheet_date], collapse = ", "), call. = FALSE
)
}
.lib_validate_reference_regex(tables$classes_regex)
.lib_require_cols(tables$known_bad_ids, "sample_name", "known_bad_ids")
known_bad <- trimws(as.character(tables$known_bad_ids$sample_name))
if (any(is.na(known_bad) | !nzchar(known_bad)) || anyDuplicated(known_bad) ||
any(!grepl("^[[:xdigit:]]{32}$", known_bad))) {
stop("known_bad_ids must contain unique exact 32-character hexadecimal IDs",
call. = FALSE)
}
.lib_require_cols(
tables$material_hierarchy,
c("material", "material_class", "material_type"), "material_hierarchy"
)
material <- trimws(as.character(tables$material_hierarchy$material))
if (any(is.na(material) | !nzchar(material)) || anyDuplicated(material)) {
stop("material_hierarchy material keys must be nonblank and unique",
call. = FALSE)
}
material_class <- trimws(as.character(
tables$material_hierarchy$material_class
))
material_type <- trimws(tolower(as.character(
tables$material_hierarchy$material_type
)))
paint_classes <- c("paint", "acrylic paint", "alkyd paint", "urethane paint")
if (any(tolower(material_class) %in% paint_classes)) {
stop("material_hierarchy material_class must describe chemistry, not paint form",
call. = FALSE)
}
invalid_plastic_class <- material_type == "plastic" &
!is.na(material_class) & nzchar(material_class) &
material_class != "other plastic" & !startsWith(tolower(material_class),
"poly")
if (any(invalid_plastic_class)) {
stop(
"Standard plastic material classes must start with 'poly': ",
paste(sort(unique(material_class[invalid_plastic_class])),
collapse = ", "), call. = FALSE
)
}
.lib_validate_material_form_regex(tables$material_form_regex)
.lib_validate_common_use_reference(
tables$common_use_reference, tables$material_hierarchy
)
invisible(TRUE)
}
.lib_validate_material_form_regex <- function(regex_reference) {
.lib_require_cols(
regex_reference, c("pattern", "material_form"), "material_form_regex"
)
pattern <- trimws(as.character(regex_reference$pattern))
material_form <- trimws(as.character(regex_reference$material_form))
if (any(is.na(pattern) | !nzchar(pattern)) || anyDuplicated(pattern)) {
stop("material_form_regex patterns must be nonblank and unique",
call. = FALSE)
}
allowed <- c(
"paint", "rubber", "hard plastic", "fiber", "pellet",
"film plastic", "fragment", "foam", "sphere/bead"
)
invalid_form <- is.na(material_form) | !material_form %in% allowed
if (any(invalid_form)) {
stop(
"material_form_regex has unsupported material_form values: ",
paste(unique(material_form[invalid_form]), collapse = ", "),
call. = FALSE
)
}
invalid_pattern <- vapply(pattern, function(value) {
inherits(try(grepl(value, "", perl = TRUE), silent = TRUE), "try-error")
}, logical(1L))
if (any(invalid_pattern)) {
stop("material_form_regex contains invalid regular expressions: ",
paste(pattern[invalid_pattern], collapse = ", "), call. = FALSE)
}
empty_match <- vapply(pattern, grepl, logical(1L), x = "", perl = TRUE)
if (any(empty_match)) {
stop("material_form_regex patterns may not match empty text: ",
paste(pattern[empty_match], collapse = ", "), call. = FALSE)
}
invisible(TRUE)
}
.lib_validate_common_use_reference <- function(reference, hierarchy) {
required <- c(
"material_class", "common_use", "consumer_mass_share",
"industrial_mass_share", "unclassified_mass_share", "basis_year",
"geography", "source_url", "retrieved_date", "evidence_notes"
)
.lib_require_cols(reference, required, "common_use_reference")
material_class <- trimws(as.character(reference$material_class))
if (any(is.na(material_class) | !nzchar(material_class)) ||
anyDuplicated(material_class)) {
stop("common_use_reference material_class keys must be nonblank and unique",
call. = FALSE)
}
hierarchy_classes <- sort(unique(trimws(
as.character(hierarchy$material_class)
)))
if (!setequal(material_class, hierarchy_classes)) {
stop(
"common_use_reference must contain every hierarchy class exactly once; ",
"missing: ", paste(setdiff(hierarchy_classes, material_class),
collapse = ", "),
"; stale: ", paste(setdiff(material_class, hierarchy_classes),
collapse = ", "),
call. = FALSE
)
}
common_use <- trimws(as.character(reference$common_use))
common_use[is.na(common_use) | !nzchar(common_use)] <- NA_character_
invalid_use <- !is.na(common_use) &
!common_use %in% c("consumer", "industrial", "mixed")
if (any(invalid_use)) {
stop("common_use_reference has unsupported common_use values: ",
paste(unique(common_use[invalid_use]), collapse = ", "),
call. = FALSE)
}
shares <- data.frame(
consumer = suppressWarnings(as.numeric(reference$consumer_mass_share)),
industrial = suppressWarnings(as.numeric(reference$industrial_mass_share)),
unclassified = suppressWarnings(as.numeric(
reference$unclassified_mass_share
))
)
invalid_share <- vapply(shares, function(value) {
any(!is.na(value) & (!is.finite(value) | value < 0 | value > 1))
}, logical(1L))
if (any(invalid_share)) {
stop("common_use_reference shares must be proportions in [0, 1]",
call. = FALSE)
}
share_sum <- rowSums(shares, na.rm = TRUE)
if (any(share_sum > 1 + 1e-8)) {
stop("common_use_reference shares may not sum above one", call. = FALSE)
}
labelled <- !is.na(common_use)
share_present <- rowSums(!is.na(shares)) > 0L
complete_share <- stats::complete.cases(shares)
if (any(share_present & !complete_share)) {
stop(
"common_use_reference shares must be either all missing or all present",
call. = FALSE
)
}
if (any(!labelled & share_present)) {
stop("common_use_reference shares require a common_use label",
call. = FALSE)
}
valid_label <- rep(TRUE, nrow(reference))
consumer <- common_use == "consumer" & labelled & complete_share
industrial <- common_use == "industrial" & labelled & complete_share
mixed <- common_use == "mixed" & labelled & complete_share
valid_label[consumer] <- shares$consumer[consumer] > 0.5
valid_label[industrial] <- shares$industrial[industrial] > 0.5
valid_label[mixed] <-
shares$consumer[mixed] >= 0.25 & shares$industrial[mixed] >= 0.25 &
shares$consumer[mixed] <= 0.5 & shares$industrial[mixed] <= 0.5 &
shares$consumer[mixed] + shares$industrial[mixed] >= 0.75
source_provenance <- c("source_url", "retrieved_date", "evidence_notes")
source_ok <- lapply(source_provenance, function(column) {
value <- trimws(as.character(reference[[column]]))
!is.na(value) & nzchar(value)
})
source_complete <- Reduce(`&`, source_ok)
quantitative_provenance <- lapply(c("basis_year", "geography"),
function(column) {
value <- trimws(as.character(reference[[column]]))
!is.na(value) & nzchar(value)
})
quantitative_complete <- Reduce(`&`, quantitative_provenance)
invalid <- labelled & (
!valid_label | !source_complete |
(complete_share & !quantitative_complete)
)
if (any(invalid)) {
stop(
"common_use_reference labels require source provenance and, when ",
"quantitative shares are supplied, valid threshold shares and complete ",
"quantitative provenance: ",
paste(material_class[invalid], collapse = ", "),
call. = FALSE
)
}
invisible(TRUE)
}
.lib_normalize_enrichment_text <- function(value) {
value <- suppressWarnings(as.character(value))
value[is.na(value)] <- ""
ascii <- iconv(value, from = "", to = "ASCII//TRANSLIT")
ascii[is.na(ascii)] <- value[is.na(ascii)]
trimws(gsub("[[:space:]]+", " ", tolower(ascii), perl = TRUE))
}
.lib_regex_row_hits <- function(text, patterns) {
hits <- vector("list", length(text))
for (pattern_index in seq_along(patterns)) {
matched <- which(grepl(patterns[[pattern_index]], text, perl = TRUE))
for (row_index in matched) {
hits[[row_index]] <- c(hits[[row_index]], pattern_index)
}
}
hits
}
.lib_enrich_material_form <- function(metadata, regex_reference) {
out <- data.table::copy(data.table::as.data.table(metadata))
row_count <- nrow(out)
atomic <- vapply(out, function(value) {
is.atomic(value) && length(value) == row_count
}, logical(1L))
searchable <- out[, names(out)[atomic], with = FALSE]
search_values <- lapply(searchable, function(value) {
value <- suppressWarnings(as.character(value))
value[is.na(value)] <- ""
value
})
if (length(search_values)) {
corpus <- .lib_normalize_enrichment_text(do.call(
paste, c(search_values, list(sep = "\u001f"))
))
} else {
corpus <- rep("", row_count)
}
direct <- if ("material_form" %in% names(out)) {
.lib_normalize_enrichment_text(out[["material_form"]])
} else {
rep("", row_count)
}
patterns <- as.character(regex_reference$pattern)
forms <- as.character(regex_reference$material_form)
direct_hits <- .lib_regex_row_hits(direct, patterns)
direct_forms <- lapply(direct_hits, function(index) unique(forms[index]))
use_corpus <- lengths(direct_forms) == 0L
selected_hits <- direct_hits
evidence_source <- rep("material_form", row_count)
if (any(use_corpus)) {
corpus_hits <- .lib_regex_row_hits(corpus[use_corpus], patterns)
selected_hits[use_corpus] <- corpus_hits
evidence_source[use_corpus] <- "all_metadata"
}
matched_forms <- lapply(selected_hits, function(index) unique(forms[index]))
form_count <- lengths(matched_forms)
result <- rep(NA_character_, row_count)
unique_match <- form_count == 1L
result[unique_match] <- vapply(
matched_forms[unique_match], `[[`, character(1L), 1L
)
conflict <- form_count > 1L
out[, material_form := result]
matched_rows <- which(form_count > 0L)
normalized_matches <- lapply(search_values, function(value) {
.lib_normalize_enrichment_text(value[matched_rows])
})
evidence <- vapply(seq_along(matched_rows), function(match_position) {
row_index <- matched_rows[[match_position]]
if (identical(evidence_source[[row_index]], "material_form")) {
return(paste0("material_form=", direct[[row_index]]))
}
values <- character()
for (pattern_index in selected_hits[[row_index]]) {
for (column_name in names(normalized_matches)) {
value <- normalized_matches[[column_name]][[match_position]]
if (nzchar(value) && grepl(patterns[[pattern_index]], value,
perl = TRUE)) {
values <- c(values, paste0(
column_name, "=", substr(value, 1L, 160L)
))
break
}
}
}
paste(unique(values), collapse = " | ")
}, character(1L))
matches <- data.table::data.table(
row_id = as.integer(matched_rows),
sample_name = if ("sample_name" %in% names(out)) {
as.character(out[["sample_name"]][matched_rows])
} else {
rep(NA_character_, length(matched_rows))
},
material_form = result[matched_rows],
evidence_source = evidence_source[matched_rows],
matched_forms = vapply(
matched_forms[matched_rows], paste, character(1L), collapse = " | "
),
matched_patterns = vapply(selected_hits[matched_rows], function(index) {
paste(patterns[index], collapse = " | ")
}, character(1L)),
evidence = evidence,
conflict = conflict[matched_rows]
)
category <- sort(unique(stats::na.omit(result)))
category_metric <- if (length(category)) {
paste0("material_form:", category)
} else {
character()
}
summary <- data.table::data.table(
metric = c(
"total", "populated", "unmatched", "conflicting",
category_metric
),
value = as.integer(c(
row_count, sum(!is.na(result)), sum(form_count == 0L), sum(conflict),
vapply(
category, function(value) sum(result == value, na.rm = TRUE),
integer(1L)
)
))
)
list(
data = out, summary = summary, matches = matches,
clashes = matches[matches[["conflict"]]]
)
}
.lib_enrich_common_use <- function(metadata, reference) {
out <- data.table::copy(data.table::as.data.table(metadata))
common_use <- trimws(as.character(reference$common_use))
common_use[is.na(common_use) | !nzchar(common_use)] <- NA_character_
material_class <- if ("material_class" %in% names(out)) {
as.character(out[["material_class"]])
} else {
rep(NA_character_, nrow(out))
}
reference_index <- match(material_class, as.character(reference$material_class))
result <- common_use[reference_index]
out[, common_use := result]
category <- sort(unique(stats::na.omit(result)))
category_metric <- if (length(category)) {
paste0("common_use:", category)
} else {
character()
}
summary <- data.table::data.table(
metric = c(
"total", "populated", "unmatched", category_metric
),
value = as.integer(c(
nrow(out), sum(!is.na(result)), sum(is.na(result)),
vapply(
category, function(value) sum(result == value, na.rm = TRUE),
integer(1L)
)
))
)
classes <- sort(unique(stats::na.omit(material_class)))
class_index <- match(classes, as.character(reference$material_class))
coverage <- data.table::data.table(
material_class = classes,
spectra = vapply(
classes, function(value) {
sum(!is.na(material_class) & material_class == value)
}, integer(1L)
),
common_use = common_use[class_index],
consumer_mass_share = as.numeric(reference$consumer_mass_share[class_index]),
industrial_mass_share = as.numeric(reference$industrial_mass_share[class_index]),
unclassified_mass_share = as.numeric(
reference$unclassified_mass_share[class_index]
),
basis_year = as.character(reference$basis_year[class_index]),
geography = as.character(reference$geography[class_index]),
source_url = as.character(reference$source_url[class_index]),
retrieved_date = as.character(reference$retrieved_date[class_index]),
evidence_notes = as.character(reference$evidence_notes[class_index])
)
list(data = out, summary = summary, coverage = coverage)
}
.lib_regex_is_exact_literal <- function(pattern) {
if (is.na(pattern) || !startsWith(pattern, "^") ||
!endsWith(pattern, "$")) return(FALSE)
body <- substr(pattern, 2L, nchar(pattern) - 1L)
chars <- strsplit(body, "", fixed = TRUE)[[1L]]
if (length(chars) == 0L) return(TRUE)
metacharacters <- c(".", "(", ")", "+", "*", "?", "{", "}",
"|", "[", "]", "^", "$")
variable_escapes <- c(
"A", "B", "b", "D", "d", "G", "K", "N", "P", "p", "Q",
"R", "S", "s", "W", "w", "X", "x", "Z", "z", "0", "1",
"2", "3", "4", "5", "6", "7", "8", "9"
)
escaped <- FALSE
for (char in chars) {
if (escaped) {
if (char %in% variable_escapes) return(FALSE)
escaped <- FALSE
} else if (identical(char, "\\")) {
escaped <- TRUE
} else if (char %in% metacharacters) {
return(FALSE)
}
}
!escaped
}
.lib_build_signature <- function(x, workflow_paths, arguments) {
sources <- if (is.character(x)) {
.lib_file_signatures(x)
} else {
data.table::data.table(
path = "<in-memory>", size = as.numeric(utils::object.size(x)),
modified = NA_character_, checksum = digest::digest(x, algo = "sha256")
)
}
workflow <- .lib_file_signatures(workflow_paths, checksum_limit = Inf)
description <- if (file.exists("DESCRIPTION")) {
read.dcf("DESCRIPTION", fields = "Version")[[1L]]
} else {
NA_character_
}
code_checksum <- if (file.exists(file.path("R", "build_lib.R"))) {
.lib_sha256_file(file.path("R", "build_lib.R"))
} else {
NA_character_
}
digest::digest(
list(sources = sources, workflow = workflow, arguments = arguments,
version = description, code = code_checksum,
git = .lib_git_state(), runtime = .lib_runtime_provenance()),
algo = "sha256"
)
}
.lib_release_signature <- function(assessment_signature) {
package_source <- .lib_file_signatures(
c("DESCRIPTION", file.path("R", "build_lib.R")), checksum_limit = Inf
)
digest::digest(
list(
assessment = assessment_signature, package_source = package_source,
git = .lib_git_state(), runtime = .lib_runtime_provenance()
),
algo = "sha256"
)
}
.lib_component_signature <- function(x, workflow_paths, arguments,
component_version) {
sources <- if (is.character(x)) {
.lib_file_signatures(x)
} else {
data.table::data.table(
path = "<in-memory>", size = as.numeric(utils::object.size(x)),
modified = NA_character_, checksum = digest::digest(x, algo = "sha256")
)
}
workflow <- .lib_file_signatures(workflow_paths, checksum_limit = Inf)
digest::digest(
list(
sources = sources, workflow = workflow, arguments = arguments,
component_version = component_version,
runtime = .lib_runtime_provenance()
),
algo = "sha256"
)
}
.lib_file_signature_cache <- new.env(parent = emptyenv())
.lib_file_signatures <- function(paths, checksum_limit = 50 * 1024^2) {
paths <- unique(as.character(paths))
info <- file.info(paths)
normalized <- normalizePath(paths, mustWork = FALSE)
checksum <- rep(NA_character_, length(paths))
use <- !is.na(info$size) & !is.na(info$isdir) & !info$isdir
for (i in which(use)) {
cache_key <- digest::digest(
list(path = normalized[[i]], size = as.numeric(info$size[[i]]),
modified = as.character(info$mtime[[i]])),
algo = "sha256"
)
if (exists(cache_key, envir = .lib_file_signature_cache,
inherits = FALSE)) {
checksum[[i]] <- get(
cache_key, envir = .lib_file_signature_cache, inherits = FALSE
)
} else {
checksum[[i]] <- .lib_sha256_file(paths[[i]])
assign(cache_key, checksum[[i]], envir = .lib_file_signature_cache)
}
}
data.table::data.table(
path = normalized,
size = as.numeric(info$size), checksum_algorithm = "sha256",
modified = as.character(info$mtime), checksum = checksum
)
}
.lib_sha256_file <- function(path) {
digest::digest(file = path, algo = "sha256", serialize = FALSE)
}
.lib_git_state <- function() {
run <- function(args) {
value <- tryCatch(
suppressWarnings(system2("git", args, stdout = TRUE, stderr = FALSE)),
error = function(error) character()
)
paste(value, collapse = "\n")
}
list(
commit = run(c("rev-parse", "HEAD")),
tracked_status_sha256 = digest::digest(
run(c("status", "--porcelain", "--untracked-files=no")), algo = "sha256"
)
)
}
.lib_runtime_provenance <- function() {
packages <- c("OpenSpecy", "data.table", "digest", "glmnet", "ranger")
versions <- vapply(packages, function(package) {
if (identical(package, "OpenSpecy") && file.exists("DESCRIPTION")) {
return(as.character(read.dcf("DESCRIPTION", fields = "Version")[[1L]]))
}
if (requireNamespace(package, quietly = TRUE)) {
as.character(utils::packageVersion(package))
} else {
NA_character_
}
}, character(1))
list(R = R.version.string, platform = R.version$platform, packages = versions)
}
.lib_checkpoint_manager <- function(output_dir, signature, reuse, report) {
checkpoint_dir <- file.path(output_dir, "checkpoints")
dir.create(checkpoint_dir, recursive = TRUE, showWarnings = FALSE)
events <- list()
event_i <- 0L
record <- function(component, status, path, key, size = NA_real_,
checksum = NA_character_) {
event_i <<- event_i + 1L
events[[event_i]] <<- data.table::data.table(
component = component, status = status,
path = normalizePath(path, mustWork = FALSE), signature = key,
size = as.numeric(size), checksum_algorithm = "sha256",
checksum = as.character(checksum)
)
}
paths <- function(stage) {
safe <- gsub("[^A-Za-z0-9_.-]+", "_", stage)
list(
object = file.path(checkpoint_dir, paste0(safe, ".rds")),
manifest = file.path(checkpoint_dir, paste0(safe, ".manifest.rds"))
)
}
get <- function(stage, key = signature) {
target <- paths(stage)
if (!isTRUE(reuse) || !file.exists(target$object) ||
!file.exists(target$manifest)) return(NULL)
manifest <- tryCatch(readRDS(target$manifest), error = function(e) NULL)
info <- file.info(target$object)
checksum <- if (!is.na(info$size)) .lib_sha256_file(target$object) else NA_character_
if (!is.list(manifest) || !identical(manifest$signature, key) ||
!isTRUE(manifest$complete) || !identical(manifest$checksum, checksum) ||
!identical(as.numeric(manifest$size), as.numeric(info$size))) {
record(stage, "invalidated", target$object, key)
return(NULL)
}
object <- tryCatch(readRDS(target$object), error = function(e) NULL)
if (is.null(object)) {
record(stage, "unreadable", target$object, key)
return(NULL)
}
report(paste0("reusing checkpoint: ", stage))
record(stage, "reused", target$object, key, info$size, checksum)
object
}
put <- function(stage, object, key = signature) {
target <- paths(stage)
.lib_atomic_saveRDS(object, target$object)
info <- file.info(target$object)
checksum <- .lib_sha256_file(target$object)
.lib_atomic_saveRDS(
list(signature = key, complete = TRUE, size = as.numeric(info$size),
checksum_algorithm = "sha256", checksum = checksum),
target$manifest
)
record(stage, "built", target$object, key, info$size, checksum)
invisible(object)
}
manifest <- function() {
if (length(events) == 0L) {
return(data.table::data.table(
component = character(), status = character(), path = character(),
signature = character(), size = numeric(),
checksum_algorithm = character(), checksum = character()
))
}
data.table::rbindlist(events, fill = TRUE)
}
list(get = get, put = put, manifest = manifest)
}
.lib_atomic_saveRDS <- function(object, path) {
dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
temporary <- tempfile(pattern = paste0(basename(path), "."),
tmpdir = dirname(path))
on.exit(if (file.exists(temporary)) unlink(temporary), add = TRUE)
saveRDS(object, temporary)
if (file.exists(path)) unlink(path)
if (!file.rename(temporary, path)) {
stop("Could not promote completed component to ", path, call. = FALSE)
}
invisible(path)
}
.lib_atomic_fwrite <- function(object, path) {
dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
temporary <- tempfile(pattern = paste0(basename(path), "."),
tmpdir = dirname(path), fileext = ".csv")
on.exit(if (file.exists(temporary)) unlink(temporary), add = TRUE)
data.table::fwrite(object, temporary)
if (file.exists(path)) unlink(path)
if (!file.rename(temporary, path)) {
stop("Could not promote review table to ", path, call. = FALSE)
}
invisible(path)
}
.lib_write_quarantine_review <- function(quarantine, output_dir) {
review_dir <- file.path(output_dir, "review")
.lib_atomic_saveRDS(
quarantine, file.path(review_dir, "quarantined_spectra.rds")
)
metadata <- data.table::rbindlist(lapply(names(quarantine$spectra), function(name) {
out <- data.table::copy(quarantine$spectra[[name]]$metadata)
out[, quarantine_object := name]
out
}), fill = TRUE)
if (!nrow(metadata)) {
metadata <- data.table::data.table(
quarantine_object = character(), quarantine_key = character(),
sample_name = character(), material_class = character(),
quarantine_status = character(), quarantine_phase = character(),
quarantine_reason = character(), review_status = character()
)
}
.lib_atomic_fwrite(
metadata, file.path(review_dir, "quarantined_spectra_metadata.csv")
)
.lib_atomic_fwrite(
quarantine$conflicts,
file.path(review_dir, "quarantined_spectra_conflicts.csv")
)
invisible(review_dir)
}
.lib_promote_rds <- function(object, path) {
dir.create(dirname(path), recursive = TRUE, showWarnings = FALSE)
temporary <- tempfile(pattern = paste0(basename(path), "."),
tmpdir = dirname(path))
on.exit(if (file.exists(temporary)) unlink(temporary), add = TRUE)
saveRDS(object, temporary)
checksum <- .lib_sha256_file(temporary)
size <- as.numeric(file.info(temporary)$size)
status <- "promoted"
if (file.exists(path)) {
existing_checksum <- .lib_sha256_file(path)
if (!identical(existing_checksum, checksum)) {
# Some model backends serialize semantically identical internal state
# differently after a save/load cycle (observed for ranger on R-devel).
# Preserve the already-promoted immutable bytes only when both payloads
# deserialize to identical R objects; genuine content drift still fails.
existing <- tryCatch(readRDS(path), error = function(error) NULL)
candidate <- tryCatch(readRDS(temporary), error = function(error) NULL)
if (is.null(existing) || is.null(candidate) ||
!identical(existing, candidate)) {
stop("Immutable release artifact differs from existing payload: ", path,
call. = FALSE)
}
checksum <- existing_checksum
size <- as.numeric(file.info(path)$size)
}
status <- "verified_existing"
unlink(temporary)
} else if (!file.rename(temporary, path)) {
stop("Could not promote completed component to ", path, call. = FALSE)
}
data.table::data.table(
component = tools::file_path_sans_ext(basename(path)), status = status,
path = normalizePath(path, mustWork = FALSE), size = size,
checksum_algorithm = "sha256", checksum = checksum
)
}
.lib_promote_build_index <- function(signature, artifact_manifest, path) {
index <- .lib_release_index(signature, artifact_manifest)
.lib_promote_rds(index, path)
}
.lib_finalize_reference_release <- function(build, assessment_components,
promotion, signature, report) {
release_dir <- promotion$directory
assessment_components$output_manifest <- data.table::copy(promotion$manifest)
assessment_components$output_manifest[, status := "available"]
build$assessments <- .lib_assessment_review(assessment_components)
.lib_validate_reference_build(build)
attr(build, "output_dir") <- normalizePath(release_dir, mustWork = FALSE)
attr(build, "build_signature") <- signature
report("serializing standalone reference-library assessments")
assessments_manifest <- .lib_promote_rds(
build$assessments, file.path(release_dir, "assessments.rds")
)
artifact_manifest <- data.table::rbindlist(
list(promotion$manifest, assessments_manifest), fill = TRUE
)
report("serializing the lightweight reference-library release index")
index_manifest <- .lib_promote_build_index(
signature, artifact_manifest,
file.path(release_dir, "reference_library_build.rds")
)
release_manifest <- data.table::rbindlist(
list(artifact_manifest, index_manifest), fill = TRUE
)
release_manifest[, status := "available"]
attr(release_manifest, "build_signature") <- signature
.lib_promote_rds(
release_manifest, file.path(release_dir, "release_manifest.rds")
)
build
}
.lib_complete_reference_build <- function(libraries, tables, prune,
remove_other, progress, report) {
retention_stages <- data.table::rbindlist(lapply(
libraries,
function(object) attr(object, "library_retention_stages", exact = TRUE)
), fill = TRUE)
identity_index <- data.table::rbindlist(lapply(names(libraries), function(name) {
metadata <- libraries[[name]]$metadata
data.table::data.table(
artifact = name,
sample_name = as.character(.lib_ids(libraries[[name]], "sample_name")),
spectrum_identity = if ("spectrum_identity" %in% names(metadata)) {
as.character(metadata$spectrum_identity)
} else {
NA_character_
}
)
}), fill = TRUE)
core_dropped <- data.table::rbindlist(lapply(libraries, function(object) {
attr(object, "dropped_spectrum_identities", exact = TRUE)
}), fill = TRUE)
prediction_rows <- list()
coverage_rows <- list()
for (name in names(libraries)) {
report(paste0("completing class metadata (", name, ")"))
prediction <- predict_class_reference(
libraries[[name]]$metadata, tables$classes_regex, return = "report"
)
if (nrow(prediction$clashes) > 0L) {
stop("Class regex clashes require exact material entries: ",
paste(head(prediction$clashes$spectrum_identity, 20L),
collapse = ", "), call. = FALSE)
}
libraries[[name]]$metadata <- prediction$data
libraries[[name]] <- join_material_hierarchy(
libraries[[name]], tables$material_hierarchy
)
attr(libraries[[name]], "class_prediction_report") <- prediction[
c("summary", "predictions", "clashes", "overlaps")
]
libraries[[name]] <- .lib_complete_reference_classes(
libraries[[name]], classes = tables$classes_reference,
hierarchy = tables$material_hierarchy,
enforce_other_limit = !isTRUE(remove_other)
)
prediction_rows[[name]] <- data.table::data.table(
artifact = name, metric = names(prediction$summary),
value = as.numeric(unlist(prediction$summary, use.names = FALSE))
)
coverage <- attr(libraries[[name]], "class_coverage_report")
coverage_rows[[name]] <- data.table::data.table(
artifact = name, stage = coverage$stage,
populated_class = coverage$populated_class,
reviewed_source_key = coverage$reviewed_source_key,
reviewed_class_key = coverage$reviewed_class_key,
unclassified = coverage$unclassified,
unresolved_other = coverage$unresolved_other,
other = coverage$other,
other_fraction = coverage$other_fraction
)
}
other_policy <- .lib_apply_other_policy(
libraries, remove_other = remove_other, report = report
)
libraries <- other_policy$libraries
other_policy$libraries <- NULL
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_other")
), fill = TRUE)
type_coverage <- data.table::rbindlist(lapply(names(libraries), function(name) {
metadata <- libraries[[name]]$metadata
data.table::data.table(
artifact = name, field = c("library_type", "spectrum_type"),
populated = c(
sum(!is.na(metadata$library_type) & nzchar(metadata$library_type)),
sum(!is.na(metadata$spectrum_type) & nzchar(metadata$spectrum_type))
), total = nrow(metadata)
)
}))
if (any(type_coverage$populated != type_coverage$total)) {
stop("Blank library_type or spectrum_type values remain after source lookup",
call. = FALSE)
}
quality_store <- new.env(parent = emptyenv())
quality_store$libraries <- libraries
rm(libraries)
gc(verbose = FALSE)
quality <- .lib_quality_control_processed(
quality_store, report = report,
artifact_ratio = 2, tail_n = 5L, max_crop = 0.2,
snr_threshold = 2
)
libraries <- quality$libraries
quality$libraries <- NULL
rm(quality_store)
gc(verbose = FALSE)
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_quality")
), fill = TRUE)
prune_spec <- prune
if (is.null(prune_spec)) {
prune_spec <- list(
derivative = list(cross_class = TRUE),
nobaseline = list(cross_class = TRUE)
)
}
prune_rows <- list()
prune_excluded_rows <- list()
prune_reassignment_rows <- list()
prune_removal_rows <- list()
prune_conflict_rows <- list()
quarantine_parts <- list()
prune_targets <- intersect(names(prune_spec), names(libraries))
library_order <- names(libraries)
prune_paths <- character()
if (length(prune_targets) > 0L) {
report("staging libraries for bounded pruning")
prune_paths <- stats::setNames(vapply(library_order, function(name) {
tempfile(paste0("openspecy-prune-", name, "-"), fileext = ".rds")
}, character(1L)), library_order)
on.exit(unlink(prune_paths[file.exists(prune_paths)]), add = TRUE)
for (name in library_order) {
saveRDS(libraries[[name]], prune_paths[[name]], compress = FALSE)
libraries[[name]] <- NULL
gc(verbose = FALSE, full = TRUE)
}
}
for (name in prune_targets) {
report(paste0("pruning ", name))
args <- prune_spec[[name]]
if (is.null(args)) args <- list()
if (is.null(args$progress)) args$progress <- progress
args$return <- "report"
library <- readRDS(prune_paths[[name]])
pruned <- do.call(prune_lib, c(list(library), args))
if (nrow(pruned$cross_class_conflicts)) {
prune_conflict_rows[[paste0(name, "_prune")]] <- data.table::copy(
pruned$cross_class_conflicts
)[, artifact := name][]
}
if (nrow(pruned$cross_class_removals)) {
min_n <- if (is.null(args$min_n)) 10L else as.integer(args$min_n)
quarantine_parts <- c(
quarantine_parts,
.lib_typed_quarantine_parts(
library, pruned$cross_class_removals, name, min_n
)
)
}
rm(library)
prune_rows[[name]] <- data.table::copy(pruned$summary)[
, artifact := name][]
if (nrow(pruned$excluded_classes)) {
prune_excluded_rows[[name]] <- data.table::copy(
pruned$excluded_classes
)[, artifact := name][]
data.table::setcolorder(
prune_excluded_rows[[name]],
c("artifact", setdiff(names(prune_excluded_rows[[name]]), "artifact"))
)
}
if (nrow(pruned$reassignments)) {
prune_reassignment_rows[[name]] <- data.table::copy(
pruned$reassignments
)[, artifact := name][]
}
if (nrow(pruned$removals)) {
prune_removal_rows[[name]] <- data.table::copy(
pruned$removals
)[, artifact := name][]
data.table::setcolorder(
prune_removal_rows[[name]],
c("artifact", setdiff(names(prune_removal_rows[[name]]), "artifact"))
)
}
saveRDS(pruned$object, prune_paths[[name]], compress = FALSE)
pruned$object <- NULL
rm(pruned)
gc(verbose = FALSE, full = TRUE)
}
if (length(prune_targets) > 0L) {
report("restoring pruned libraries")
libraries <- stats::setNames(lapply(prune_paths, readRDS), library_order)
unlink(prune_paths[file.exists(prune_paths)])
prune_paths <- character()
gc(verbose = FALSE, full = TRUE)
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_prune")
), fill = TRUE)
if (!isTRUE(remove_other) && nrow(other_policy$review)) {
other_policy$review[
action == "retained_for_semisupervised_reassignment",
action := "retained_unresolved"
]
if (length(prune_reassignment_rows)) {
reassigned_ids <- data.table::rbindlist(
prune_reassignment_rows, fill = TRUE
)[, .(artifact, spectrum_id)]
other_policy$review[
reassigned_ids,
on = .(artifact, spectrum_id),
action := "reassigned"
]
}
}
material_form_rows <- list()
material_form_match_rows <- list()
material_form_clash_rows <- list()
common_use_rows <- list()
common_use_coverage_rows <- list()
for (name in names(libraries)) {
report(paste0("enriching material form and common use (", name, ")"))
form <- .lib_enrich_material_form(
libraries[[name]]$metadata, tables$material_form_regex
)
libraries[[name]]$metadata <- form$data
attr(libraries[[name]], "material_form_enrichment_report") <- form[
c("summary", "matches", "clashes")
]
material_form_rows[[name]] <- data.table::copy(form$summary)
material_form_rows[[name]][, artifact := name]
if (nrow(form$matches)) {
material_form_match_rows[[name]] <- data.table::copy(form$matches)
material_form_match_rows[[name]][, artifact := name]
}
if (nrow(form$clashes)) {
material_form_clash_rows[[name]] <- data.table::copy(form$clashes)
material_form_clash_rows[[name]][, artifact := name]
}
use <- .lib_enrich_common_use(
libraries[[name]]$metadata, tables$common_use_reference
)
libraries[[name]]$metadata <- use$data
attr(libraries[[name]], "common_use_enrichment_report") <- use[
c("summary", "coverage")
]
common_use_rows[[name]] <- data.table::copy(use$summary)
common_use_rows[[name]][, artifact := name]
common_use_coverage_rows[[name]] <- data.table::copy(use$coverage)
common_use_coverage_rows[[name]][, artifact := name]
}
superseded_drop <- c(
"x", "y", "xunits", "interpretation", "form_factor", "shape",
"x_unit", "spectrumid", "locationdescription", "datatype"
)
optional_drop <- grepl("^assessment_", tables$metadata_drop$metadata_column)
drop_status <- data.table::data.table(
metadata_column = tables$metadata_drop$metadata_column,
status = ifelse(
tables$metadata_drop$metadata_column %in% names(libraries$raw$metadata),
"present",
ifelse(
tables$metadata_drop$metadata_column %in% superseded_drop,
"superseded_absent",
ifelse(optional_drop, "optional_absent", "stale_absent")
)
)
)
report(paste0(
"metadata drop QA: ",
paste(drop_status[, paste0(status, "=", .N), by = status]$V1,
collapse = "; ")
))
automated_test_flags <- .lib_collect_automated_test_flags(libraries)
before_filter <- ncol(libraries$raw$spectra)
material_type <- as.character(libraries$raw$metadata$material_type)
if (any(is.na(material_type) | !nzchar(trimws(material_type)))) {
stop("Blank material_type values remain after reviewed class cleanup",
call. = FALSE)
}
libraries <- lapply(libraries, function(object) {
drop_cols <- intersect(
tables$metadata_drop$metadata_column, names(object$metadata)
)
if (length(drop_cols) > 0L) object$metadata[, (drop_cols) := NULL]
object
})
for (name in intersect(c("derivative", "nobaseline"), names(libraries))) {
libraries[[name]]$spectra <- round(libraries[[name]]$spectra, 3)
finite_range <- apply(libraries[[name]]$spectra, 2L, function(values) {
values <- values[is.finite(values)]
if (length(values)) diff(range(values)) else 0
})
flat <- !is.finite(finite_range) | finite_range <= 0
if (any(flat)) {
flat_rows <- data.table::data.table(
artifact = name,
spectrum_id = as.character(.lib_ids(libraries[[name]], "sample_name"))[flat],
spectrum_type = as.character(libraries[[name]]$metadata$spectrum_type)[flat],
check = "flat_spectrum", action = "drop",
before_value = finite_range[flat], after_value = NA_real_,
threshold = 0, removed = TRUE, reason = "post_transform_flat_spectrum"
)
quality$assessment <- data.table::rbindlist(
list(quality$assessment, flat_rows), fill = TRUE
)
libraries[[name]] <- filter_spec(libraries[[name]], !flat)
}
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "post_transform")
), fill = TRUE)
report(sprintf("reviewed exclusions and flat-spectrum checks complete (removed=%d; retained=%d)",
before_filter - ncol(libraries$raw$spectra),
ncol(libraries$raw$spectra)))
retained_index <- data.table::rbindlist(lapply(names(libraries), function(name) {
data.table::data.table(
artifact = name,
sample_name = as.character(.lib_ids(libraries[[name]], "sample_name"))
)
}))
post_dropped <- identity_index[
!retained_index, on = .(artifact, sample_name),
.(spectrum_identity)
]
dropped_spectrum_identities <- data.table::rbindlist(
list(core_dropped, post_dropped), fill = TRUE
)[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(spectrum_identity)))
]
partition_store <- new.env(parent = emptyenv())
partition_store$libraries <- libraries
rm(libraries)
gc(verbose = FALSE, full = TRUE)
libraries <- .lib_partition_reference_libraries(partition_store, report)
rm(partition_store)
gc(verbose = FALSE, full = TRUE)
closure <- .lib_close_typed_reference_libraries(
libraries, prune_spec = prune_spec, report = report, progress = progress
)
libraries <- closure$libraries
closure$libraries <- NULL
if (nrow(closure$removals)) {
prune_removal_rows$final_closure <- closure$removals
}
if (nrow(closure$conflicts)) {
prune_conflict_rows$final_closure <- closure$conflicts
}
quarantine_parts <- c(quarantine_parts, closure$quarantine_parts)
if (nrow(closure$support_drops)) {
quality$assessment <- data.table::rbindlist(
list(quality$assessment, closure$support_drops), fill = TRUE
)
}
quarantine <- .lib_quarantine_bundle(
quarantine_parts,
conflicts = if (length(prune_conflict_rows)) {
data.table::rbindlist(prune_conflict_rows, fill = TRUE)
} else .lib_prune_conflict_edge_schema(),
thresholds = unlist(lapply(prune_targets, function(name) {
args <- prune_spec[[name]]
if (is.null(args$cross_class_threshold)) 0.9 else
args$cross_class_threshold
}), use.names = FALSE)
)
range_flat_rows <- data.table::rbindlist(lapply(names(libraries), function(recipe) {
data.table::rbindlist(lapply(libraries[[recipe]], function(object) {
attr(object, "range_flat_drops", exact = TRUE)
}), fill = TRUE)
}), fill = TRUE)
if (nrow(range_flat_rows)) {
quality$assessment <- data.table::rbindlist(
list(quality$assessment, range_flat_rows), fill = TRUE
)
dropped_spectrum_identities <- data.table::rbindlist(
list(
dropped_spectrum_identities,
range_flat_rows[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity)
]
),
fill = TRUE
)[, .(spectrum_identity = sort(unique(spectrum_identity)))]
}
retention_stages <- data.table::rbindlist(list(
retention_stages,
.lib_library_stage_counts(libraries, stage = "final")
), fill = TRUE)
library_retention <- .lib_library_retention_report(retention_stages)
list(
libraries = libraries,
assessments = list(
class_prediction = data.table::rbindlist(prediction_rows, fill = TRUE),
class_coverage = data.table::rbindlist(coverage_rows, fill = TRUE),
type_coverage = type_coverage,
material_form_enrichment = data.table::rbindlist(
material_form_rows, fill = TRUE
),
material_form_matches = data.table::rbindlist(
material_form_match_rows, fill = TRUE
),
material_form_clashes = data.table::rbindlist(
material_form_clash_rows, fill = TRUE
),
common_use_enrichment = data.table::rbindlist(
common_use_rows, fill = TRUE
),
common_use_coverage = data.table::rbindlist(
common_use_coverage_rows, fill = TRUE
),
other_review = other_policy$review,
other_filter = other_policy$summary,
pruning = data.table::rbindlist(prune_rows, fill = TRUE),
pruning_excluded_classes = if (length(prune_excluded_rows)) {
data.table::rbindlist(prune_excluded_rows, fill = TRUE)
} else {
.lib_prune_excluded_assessment_schema()
},
pruning_reassignments = if (length(prune_reassignment_rows)) {
data.table::rbindlist(prune_reassignment_rows, fill = TRUE)
} else {
.lib_prune_reassignment_schema()
},
pruning_removals = if (length(prune_removal_rows)) {
data.table::rbindlist(prune_removal_rows, fill = TRUE)
} else {
.lib_prune_removal_assessment_schema()
},
pruning_conflicts = if (length(prune_conflict_rows)) {
data.table::rbindlist(prune_conflict_rows, fill = TRUE)
} else {
out <- .lib_prune_conflict_edge_schema()
out[, artifact := character()]
out
},
automated_test_flags = automated_test_flags,
quality_control = quality$assessment,
library_retention = library_retention,
dropped_spectrum_identities = dropped_spectrum_identities,
filters = data.table::data.table(
stage = "special_filter", before = before_filter,
after = ncol(libraries$raw$spectra),
removed = before_filter - ncol(libraries$raw$spectra)
),
metadata_drop = drop_status
),
quarantine = quarantine
)
}
.lib_quality_schema <- function() {
data.table::data.table(
artifact = character(), spectrum_id = character(),
spectrum_type = character(), check = character(), action = character(),
before_value = numeric(), after_value = numeric(), threshold = numeric(),
removed = logical(), reason = character()
)
}
.lib_warning_schema <- function() {
data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
warning = character()
)
}
.lib_prune_reassignment_schema <- function() {
data.table::data.table(
artifact = character(), spectrum_id = character(),
prior_class = character(), material_class = character(),
prior_material_type = character(), material_type = character(),
matched_id = character(), correlation = numeric(), pool = character(),
reason = character()
)
}
.lib_quality_control_processed <- function(libraries, report,
artifact_ratio = 2,
tail_n = 5L,
max_crop = 0.2,
snr_threshold = 2) {
assessment <- list()
detached <- is.environment(libraries)
store <- if (detached) libraries else NULL
recipe_names <- if (detached) names(store$libraries) else names(libraries)
for (recipe in intersect(c("derivative", "nobaseline"), recipe_names)) {
x <- if (detached) store$libraries[[recipe]] else libraries[[recipe]]
if (detached) {
store$libraries[[recipe]] <- NULL
gc(verbose = FALSE)
}
started <- proc.time()[["elapsed"]]
ids <- .lib_ids(x, "sample_name")
type <- tolower(as.character(x$metadata$spectrum_type))
report(sprintf(
"quality gate %s: starting (spectra=%d; wavenumbers=%d)",
recipe, ncol(x$spectra), nrow(x$spectra)
))
metrics <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)
co2 <- type == "ftir" & is.finite(metrics$co2_ratio) &
metrics$co2_ratio > artifact_ratio
co2[is.na(co2)] <- FALSE
if (any(co2)) {
corrected <- flatten_range(
filter_spec(x, co2), min = 2200, max = 2420, make_rel = FALSE
)
x$spectra[, co2] <- corrected$spectra
}
co2_after <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)$co2_ratio
failed_co2 <- co2 & (!is.finite(co2_after) |
co2_after > artifact_ratio)
failed_co2[is.na(failed_co2)] <- TRUE
assessment[[paste0(recipe, "_co2")]] <- data.table::data.table(
artifact = recipe, spectrum_id = ids[co2], spectrum_type = type[co2],
check = "co2_region", action = ifelse(failed_co2[co2], "drop", "flatten"),
before_value = metrics$co2_ratio[co2], after_value = co2_after[co2],
threshold = artifact_ratio, removed = failed_co2[co2],
reason = ifelse(
failed_co2[co2], "co2_postcondition_failed",
"co2_to_silent_ratio_corrected"
)
)
report(sprintf(
"quality gate %s: CO2 flatten complete (flattened=%d; failed=%d)",
recipe, sum(co2), sum(failed_co2)
))
tail_before <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)$tail_ratio
tail_flag <- is.finite(tail_before) & tail_before > artifact_ratio
tail_flag[is.na(tail_flag)] <- FALSE
correction <- .lib_trim_high_tail_matrix(
x$wavenumber, x$spectra[, tail_flag, drop = FALSE],
artifact_ratio = artifact_ratio, tail_n = tail_n,
max_crop = max_crop, co2_region = c(2200, 2420)
)
if (any(tail_flag)) x$spectra[, tail_flag] <- correction$spectra
tail_after <- .artifact_ratio_metrics(
x, tail_n = tail_n, co2_region = c(2200, 2420),
silent_region = c(2420, 2550)
)$tail_ratio
failed_tail <- rep(FALSE, ncol(x$spectra))
failed_tail[tail_flag] <- !correction$passed
assessment[[paste0(recipe, "_tail")]] <- data.table::data.table(
artifact = recipe, spectrum_id = ids[tail_flag],
spectrum_type = type[tail_flag], check = "high_tail",
action = ifelse(correction$passed, "trim", "drop"),
before_value = tail_before[tail_flag], after_value = tail_after[tail_flag],
threshold = artifact_ratio, removed = !correction$passed,
reason = correction$reason
)
report(sprintf(
"quality gate %s: high-tail correction complete (flagged=%d; corrected=%d; failed=%d)",
recipe, sum(tail_flag), sum(correction$passed), sum(!correction$passed)
))
snr <- sig_noise(x, metric = "run_sig_over_noise", step = 10,
na.rm = TRUE)
low_snr <- !is.finite(snr) | snr < snr_threshold
assessment[[paste0(recipe, "_snr")]] <- data.table::data.table(
artifact = recipe, spectrum_id = ids[low_snr],
spectrum_type = type[low_snr], check = "low_snr", action = "drop",
before_value = as.numeric(snr[low_snr]), after_value = NA_real_,
threshold = snr_threshold, removed = TRUE,
reason = ifelse(is.finite(snr[low_snr]),
"running_snr_below_threshold", "running_snr_unavailable")
)
remove <- failed_co2 | failed_tail | low_snr
if (all(remove)) {
stop("Quality control removed every spectrum from ", recipe,
call. = FALSE)
}
x <- filter_spec(x, !remove)
x$metadata$sn <- snr[!remove]
attr(x, "quality_control_report") <- data.table::rbindlist(
assessment[grepl(paste0("^", recipe, "_"), names(assessment))],
fill = TRUE
)
if (detached) store$libraries[[recipe]] <- x else libraries[[recipe]] <- x
report(sprintf(
"quality gate %s: complete (removed=%d; retained=%d; %.1fs)",
recipe, sum(remove), ncol(x$spectra),
proc.time()[["elapsed"]] - started
))
}
rows <- data.table::rbindlist(assessment, fill = TRUE)
if (!nrow(rows)) rows <- .lib_quality_schema()
if (detached) libraries <- store$libraries
list(libraries = libraries, assessment = rows)
}
.lib_trim_high_tail_matrix <- function(wavenumber, spectra,
artifact_ratio = 2, tail_n = 5L,
max_crop = 0.2,
co2_region = c(2200, 2420)) {
if (!ncol(spectra)) {
return(list(spectra = spectra, passed = logical(), reason = character()))
}
passed <- logical(ncol(spectra))
reason <- rep("corrected", ncol(spectra))
for (column in seq_len(ncol(spectra))) {
values <- spectra[, column]
original <- which(is.finite(values))
if (length(original) <= 2L * tail_n) {
reason[column] <- "insufficient_finite_range"
next
}
original_span <- abs(wavenumber[max(original)] - wavenumber[min(original)])
repeat {
finite <- which(is.finite(values))
if (length(finite) <= 2L * tail_n) {
reason[column] <- "insufficient_finite_range"
break
}
normalized <- values
lo <- min(normalized[finite])
span <- max(normalized[finite]) - lo
if (!is.finite(span) || span <= 0) {
reason[column] <- "flat_or_unavailable"
break
}
normalized[finite] <- (normalized[finite] - lo) / span
left <- head(finite, tail_n)
right <- utils::tail(finite, tail_n)
control <- setdiff(
finite,
c(left, right, which(wavenumber >= co2_region[1L] &
wavenumber <= co2_region[2L]))
)
control_max <- if (length(control)) max(normalized[control]) else NA_real_
if (!is.finite(control_max)) {
reason[column] <- "control_unavailable"
break
}
left_ratio <- max(normalized[left]) / control_max
right_ratio <- max(normalized[right]) / control_max
trim_left <- is.finite(left_ratio) && left_ratio > artifact_ratio
trim_right <- is.finite(right_ratio) && right_ratio > artifact_ratio
if (!trim_left && !trim_right) {
spectra[, column] <- values
passed[column] <- TRUE
break
}
if (trim_left) values[min(finite)] <- NA_real_
if (trim_right) values[max(finite)] <- NA_real_
remaining <- which(is.finite(values))
cropped <- 1 - abs(wavenumber[max(remaining)] -
wavenumber[min(remaining)]) / original_span
if (!is.finite(cropped) || cropped > max_crop) {
reason[column] <- "max_crop_exceeded"
break
}
}
}
list(spectra = spectra, passed = passed, reason = reason)
}
.lib_type_ranges <- function() {
list(raman = c(200, 4000), ftir = c(400, 4000), nir = c(4000, 12000))
}
.lib_drop_blank_metadata <- function(x) {
blank <- vapply(x$metadata, function(column) {
if (is.character(column)) {
all(is.na(column) | !nzchar(trimws(column)))
} else {
all(is.na(column))
}
}, logical(1))
blank[names(blank) %in% c("material_form", "common_use")] <- FALSE
if (any(blank)) x$metadata[, (names(blank)[blank]) := NULL]
x
}
.lib_flat_spectrum_mask <- function(x) {
if (!is_OpenSpecy(x) || !ncol(x$spectra)) return(logical())
vapply(seq_len(ncol(x$spectra)), function(column) {
values <- x$spectra[, column]
values <- values[is.finite(values)]
length(values) == 0L || diff(range(values)) <= 0
}, logical(1))
}
.lib_drop_range_flat_spectra <- function(x, artifact, spectrum_type,
reason, report = NULL) {
flat <- .lib_flat_spectrum_mask(x)
if (!any(flat)) return(x)
support <- attr(x, "identification_support", exact = TRUE)
metadata <- x$metadata[flat, , drop = FALSE]
rows <- data.table::data.table(
artifact = artifact,
spectrum_id = as.character(.lib_ids(x, "sample_name"))[flat],
spectrum_identity = if ("spectrum_identity" %in% names(metadata)) {
as.character(metadata$spectrum_identity)
} else {
NA_character_
},
spectrum_type = spectrum_type,
check = "flat_spectrum", action = "drop",
before_value = 0, after_value = NA_real_, threshold = 0,
removed = TRUE, reason = reason
)
x <- filter_spec(x, !flat)
if (!is.null(support) && nrow(support)) {
support <- data.table::copy(support)
support[spectrum_id %in% rows$spectrum_id, retained := FALSE]
attr(x, "identification_support") <- support
attr(x, "identification_dropped_ids") <- unique(c(
attr(x, "identification_dropped_ids", exact = TRUE),
rows$spectrum_id
))
}
attr(x, "range_flat_drops") <- rows
if (!is.null(report)) report(sprintf(
"discarded flat spectra after range restriction (%s/%s; removed=%d)",
artifact, spectrum_type, nrow(rows)
))
x
}
.lib_drop_typed_range_flats <- function(libraries, report = NULL) {
for (recipe in names(libraries)) {
for (type in names(libraries[[recipe]])) {
libraries[[recipe]][[type]] <- .lib_drop_range_flat_spectra(
libraries[[recipe]][[type]], artifact = recipe,
spectrum_type = type, reason = "post_partition_flat_spectrum",
report = report
)
}
}
libraries
}
.lib_partition_reference_libraries <- function(libraries, report = NULL) {
ranges <- .lib_type_ranges()
stored <- is.environment(libraries)
source <- if (stored) NULL else libraries
recipes <- if (stored) names(libraries$libraries) else names(source)
out_all <- stats::setNames(vector("list", length(recipes)), recipes)
for (recipe in recipes) {
x <- if (stored) libraries$libraries[[recipe]] else source[[recipe]]
if (stored) {
libraries$libraries[[recipe]] <- NULL
gc(verbose = FALSE, full = TRUE)
}
out <- lapply(names(ranges), function(type) {
subset <- .lib_filter_optional_type(x, type)
if (is.null(subset)) return(NULL)
limits <- ranges[[type]]
inside <- subset$wavenumber >= limits[1L] &
subset$wavenumber <= limits[2L]
if (sum(inside) < 2L) return(NULL)
subset <- restrict_range(
subset, min = limits[1L], max = limits[2L], make_rel = FALSE
)
subset <- .lib_drop_blank_metadata(subset)
subset <- .lib_drop_range_flat_spectra(
subset, artifact = recipe, spectrum_type = type,
reason = "post_partition_flat_spectrum", report = report
)
if (!is.null(report)) report(sprintf(
"partitioned %s/%s (spectra=%d; range=%g-%g; wavenumbers=%d)",
recipe, type, ncol(subset$spectra), limits[1L], limits[2L],
nrow(subset$spectra)
))
subset
})
names(out) <- names(ranges)
out_all[[recipe]] <- Filter(Negate(is.null), out)
rm(x, out)
gc(verbose = FALSE, full = TRUE)
}
out_all
}
.lib_quarantine_part <- function(x, removals, artifact, spectrum_type, min_n) {
if (!is_OpenSpecy(x) || !nrow(removals)) return(NULL)
ids <- as.character(.lib_ids(x, "sample_name"))
removal_ids <- unique(as.character(removals$spectrum_id))
keep <- ids %in% removal_ids
keep[is.na(keep)] <- FALSE
if (!any(keep)) return(NULL)
out <- filter_spec(x, keep)
max_or_na <- function(value) {
value <- value[is.finite(value)]
if (length(value)) max(value) else NA_real_
}
min_or_na <- function(value) {
value <- value[is.finite(value)]
if (length(value)) min(value) else NA_integer_
}
collapse_values <- function(value) {
value <- sort(unique(as.character(value[!is.na(value) & nzchar(value)])))
if (length(value)) paste(value, collapse = "; ") else NA_character_
}
summary <- removals[spectrum_id %in% ids, .(
quarantine_status = collapse_values(quarantine_status),
quarantine_phase = collapse_values(phase),
quarantine_reason = collapse_values(reason),
component_id = collapse_values(component_id),
correlation_view = collapse_values(correlation_view),
threshold = max_or_na(threshold),
decision_round = min_or_na(decision_round),
active_degree = as.integer(max_or_na(active_degree)),
max_wrong_class_correlation = max_or_na(correlation),
opposing_classes = collapse_values(matched_class),
opposing_libraries = collapse_values(matched_library),
class_n_before = as.integer(max_or_na(class_n_before)),
review_status = collapse_values(review_status)
), by = spectrum_id]
out_ids <- as.character(.lib_ids(out, "sample_name"))
summary <- summary[match(out_ids, spectrum_id)]
added <- setdiff(names(summary), "spectrum_id")
added_values <- summary[, added, with = FALSE]
out$metadata[, (added) := added_values]
out$metadata[, `:=`(
quarantine_recipe = artifact,
quarantine_spectrum_type = spectrum_type,
quarantine_key = paste(artifact, spectrum_type, out_ids, sep = "/"),
min_n = as.integer(min_n)
)]
out
}
.lib_typed_quarantine_parts <- function(x, removals, artifact, min_n) {
if (!is_OpenSpecy(x) || !nrow(removals)) return(list())
types <- sort(unique(tolower(as.character(x$metadata$spectrum_type))))
types <- intersect(types[!is.na(types) & nzchar(types)],
names(.lib_type_ranges()))
out <- lapply(types, function(type) {
object <- .lib_filter_optional_type(x, type)
if (is.null(object)) return(NULL)
ids <- as.character(.lib_ids(object, "sample_name"))
rows <- removals[spectrum_id %in% ids]
if (!nrow(rows)) return(NULL)
limits <- .lib_type_ranges()[[type]]
object <- restrict_range(
object, min = limits[[1L]], max = limits[[2L]], make_rel = FALSE
)
.lib_quarantine_part(object, rows, artifact, type, min_n)
})
names(out) <- paste(artifact, types, sep = "/")
Filter(Negate(is.null), out)
}
.lib_quarantine_bundle <- function(parts = list(), conflicts = NULL,
build_signature = NA_character_,
thresholds = numeric()) {
parts <- Filter(Negate(is.null), parts)
spectra <- list()
if (length(parts)) {
keys <- vapply(parts, function(object) {
paste(
unique(as.character(object$metadata$quarantine_recipe))[[1L]],
unique(as.character(object$metadata$quarantine_spectrum_type))[[1L]],
sep = "/"
)
}, character(1L))
grouped <- split(parts, keys)
spectra <- lapply(names(grouped), function(key) {
out <- .lib_bind_same_axis(grouped[[key]], paste("quarantine", key))
ids <- as.character(.lib_ids(out, "sample_name"))
if (anyDuplicated(ids)) {
stop("Quarantine bundle contains duplicate composite IDs for ", key,
call. = FALSE)
}
out
})
names(spectra) <- names(grouped)
}
if (is.null(conflicts) || !nrow(conflicts)) {
conflicts <- .lib_prune_conflict_edge_schema()
} else {
conflicts <- data.table::as.data.table(data.table::copy(conflicts))
}
structure(list(
spectra = spectra,
conflicts = conflicts,
manifest = list(
schema = "OpenSpecy_quarantined_spectra_v1",
build_signature = as.character(build_signature),
thresholds = sort(unique(as.numeric(thresholds))),
source_hashes = as.character(build_signature)
)
), class = c("OpenSpecyQuarantine", "list"))
}
.lib_close_typed_reference_libraries <- function(libraries, prune_spec,
report = NULL,
progress = FALSE) {
removal_rows <- list()
conflict_rows <- list()
quarantine_parts <- list()
support_rows <- list()
row_i <- 0L
conflict_i <- 0L
part_i <- 0L
support_i <- 0L
generic <- c("other", "other plastic", "other material", "unclassified")
for (artifact in intersect(c("derivative", "nobaseline"), names(libraries))) {
args <- if (is.null(prune_spec)) list(cross_class = TRUE) else prune_spec[[artifact]]
if (is.null(args)) args <- list()
if (!isTRUE(args$cross_class)) next
threshold <- if (is.null(args$cross_class_threshold)) 0.9 else
as.numeric(args$cross_class_threshold)
min_n <- if (is.null(args$min_n)) 10L else as.integer(args$min_n)
for (type in names(libraries[[artifact]])) {
parent <- libraries[[artifact]][[type]]
model_supported <- .lib_restrict_model_range(parent, type)
model_supported <- .lib_drop_range_flat_spectra(
model_supported, artifact = artifact, spectrum_type = type,
reason = "pre_medoid_model_range_flat_spectrum", report = report
)
parent_ids <- as.character(.lib_ids(parent, "sample_name"))
supported_ids <- as.character(.lib_ids(model_supported, "sample_name"))
unsupported <- !parent_ids %in% supported_ids
if (any(unsupported)) {
support_i <- support_i + 1L
support_rows[[support_i]] <- data.table::data.table(
artifact = artifact, spectrum_id = parent_ids[unsupported],
spectrum_type = type, check = "identification_support",
action = "drop", before_value = NA_real_, after_value = NA_real_,
threshold = 0.1, removed = TRUE,
reason = "below_model_range_observed_support"
)
parent <- filter_spec(parent, !unsupported)
}
close_view <- function(object, view) {
ids <- as.character(.lib_ids(object, "sample_name"))
metadata <- object$metadata
result <- .lib_prune_cross_class_conflicts(
classes = as.character(metadata$material_class),
pools = rep(type, length(ids)),
normalized = .lib_prune_normalize(
object$spectra, object$wavenumber, exclude = NULL
),
ids = ids,
library_names = as.character(metadata$library_name),
threshold = threshold, support_groups = rep(type, length(ids)),
min_n = min_n, correlation_view = view,
progress = progress, block_size = 128L
)
if (nrow(result$removals)) result$removals[, phase := "final_closure"]
if (nrow(result$conflicts)) result$conflicts[, phase := "final_closure"]
result
}
full_result <- close_view(parent, "typed_full")
if (nrow(full_result$removals)) {
row_i <- row_i + 1L
removal_rows[[row_i]] <- full_result$removals[, artifact := artifact][]
part_i <- part_i + 1L
quarantine_parts[[part_i]] <- .lib_quarantine_part(
parent, full_result$removals, artifact, type, min_n
)
parent <- filter_spec(parent, -full_result$removed_rows)
}
if (nrow(full_result$conflicts)) {
conflict_i <- conflict_i + 1L
conflict_rows[[conflict_i]] <- full_result$conflicts[, artifact := artifact][]
}
model_view <- .lib_restrict_model_range(parent, type)
model_result <- close_view(model_view, "model_range")
if (nrow(model_result$removals)) {
row_i <- row_i + 1L
removal_rows[[row_i]] <- model_result$removals[, artifact := artifact][]
part_i <- part_i + 1L
quarantine_parts[[part_i]] <- .lib_quarantine_part(
parent, model_result$removals, artifact, type, min_n
)
remove_ids <- model_result$removals$spectrum_id
parent <- filter_spec(
parent, !as.character(.lib_ids(parent, "sample_name")) %in% remove_ids
)
}
if (nrow(model_result$conflicts)) {
conflict_i <- conflict_i + 1L
conflict_rows[[conflict_i]] <- model_result$conflicts[, artifact := artifact][]
}
classes <- as.character(parent$metadata$material_class)
class_keys <- tolower(trimws(classes))
support <- data.table::data.table(
material_class = classes,
resolved = !is.na(classes) & nzchar(classes) &
!class_keys %in% generic
)[resolved == TRUE, .N, by = material_class]
small <- support[N < min_n, material_class]
if (length(small)) {
drop <- which(classes %in% small)
ids <- as.character(.lib_ids(parent, "sample_name"))
counts <- support$N[match(classes[drop], support$material_class)]
floor_removals <- data.table::data.table(
phase = "final_closure", correlation_view = "global_support",
component_id = NA_character_, spectrum_id = ids[drop],
prior_class = classes[drop],
library_name = as.character(parent$metadata$library_name)[drop],
matched_id = NA_character_, matched_class = NA_character_,
matched_library = NA_character_, correlation = NA_real_, pool = type,
active_degree = 0L, matched_active_degree = 0L,
evidence_libraries = 0L, conflicting_spectra = 0L,
matched_evidence_libraries = 0L, decision_round = NA_integer_,
threshold = threshold, class_n_before = counts, class_n_after = 0L,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "global_support_at_risk",
reason = "class_below_global_min_n_after_closure"
)
row_i <- row_i + 1L
removal_rows[[row_i]] <- floor_removals[, artifact := artifact][]
part_i <- part_i + 1L
quarantine_parts[[part_i]] <- .lib_quarantine_part(
parent, floor_removals, artifact, type, min_n
)
parent <- filter_spec(parent, -drop)
}
libraries[[artifact]][[type]] <- parent
if (!is.null(report)) report(sprintf(
"final correlation closure %s/%s complete (retained=%d)",
artifact, type, ncol(parent$spectra)
))
}
}
list(
libraries = libraries,
removals = if (length(removal_rows)) {
data.table::rbindlist(removal_rows, fill = TRUE)
} else .lib_prune_removal_assessment_schema(),
conflicts = if (length(conflict_rows)) {
data.table::rbindlist(conflict_rows, fill = TRUE)
} else {
out <- .lib_prune_conflict_edge_schema()
out[, artifact := character()]
out
},
quarantine_parts = Filter(Negate(is.null), quarantine_parts),
support_drops = if (length(support_rows)) {
data.table::rbindlist(support_rows, fill = TRUE)
} else .lib_quality_schema()
)
}
.lib_build_medoids <- function(libraries, report, checkpoints = NULL,
progress = TRUE) {
processed <- intersect(c("derivative", "nobaseline"), names(libraries))
out <- lapply(processed, function(name) {
types <- libraries[[name]]
stats::setNames(lapply(names(types), function(type) {
stage <- paste0("medoid_", name, "_", type)
cached <- if (is.null(checkpoints)) NULL else checkpoints$get(stage)
if (!is.null(cached)) return(cached)
x <- .lib_restrict_model_range(types[[type]], type)
dropped <- attr(x, "identification_dropped_ids", exact = TRUE)
if (length(dropped)) report(sprintf(
paste0("discarded spectra below 10%% observed support ",
"(%s/%s; removed=%d; minimum=%d/%d wavenumbers)"),
name, type, length(dropped)
, attr(x, "identification_minimum_observed", exact = TRUE),
nrow(x$spectra)
))
x <- .lib_drop_range_flat_spectra(
x, artifact = paste0("medoid_", name), spectrum_type = type,
reason = "post_model_range_flat_spectrum", report = report
)
flat_drops <- attr(x, "range_flat_drops", exact = TRUE)
if (!is.null(flat_drops) && nrow(flat_drops)) {
dropped <- unique(c(dropped, flat_drops$spectrum_id))
}
report(sprintf(
"selecting medoids (%s/%s; spectra=%d; wavenumbers=%d; range=%g-%g)",
name, type, ncol(x$spectra), nrow(x$spectra),
min(x$wavenumber), max(x$wavenumber)
))
ids <- reduce_lib(
x,
group_cols = intersect(c("organization", "material_class"),
names(x$metadata)),
k = 50, min_n = 50, return = "ids",
progress = progress
)
result <- filter_spec(x, ids)
attr(result, "identification_range") <- range(x$wavenumber)
attr(result, "identification_support") <-
attr(x, "identification_support", exact = TRUE)
attr(result, "identification_dropped_ids") <- dropped
attr(result, "identification_minimum_observed") <-
attr(x, "identification_minimum_observed", exact = TRUE)
attr(result, "range_flat_drops") <- flat_drops
if (!is.null(checkpoints)) checkpoints$put(stage, result)
result
}), names(types))
})
names(out) <- processed
out
}
.lib_validate_medoid_parent_closure <- function(libraries, medoids, prune_spec,
report = NULL,
block_size = 128L) {
rows <- list()
row_i <- 0L
generic <- c("other", "other plastic", "other material", "unclassified")
for (artifact in intersect(names(medoids), names(libraries))) {
args <- if (is.null(prune_spec)) list(cross_class = TRUE) else prune_spec[[artifact]]
if (is.null(args)) args <- list()
if (!isTRUE(args$cross_class)) next
threshold <- if (is.null(args$cross_class_threshold)) 0.9 else
as.numeric(args$cross_class_threshold)
for (type in intersect(names(medoids[[artifact]]), names(libraries[[artifact]]))) {
parent <- .lib_restrict_model_range(libraries[[artifact]][[type]], type)
medoid <- medoids[[artifact]][[type]]
parent_ids <- as.character(.lib_ids(parent, "sample_name"))
medoid_ids <- as.character(.lib_ids(medoid, "sample_name"))
index <- match(medoid_ids, parent_ids)
if (anyNA(index)) {
stop("Medoid IDs are absent from the closed parent: ", artifact,
"/", type, call. = FALSE)
}
parent_classes <- as.character(parent$metadata$material_class)
medoid_classes <- as.character(medoid$metadata$material_class)
if (!identical(parent_classes[index], medoid_classes) ||
!identical(parent$wavenumber, medoid$wavenumber) ||
!isTRUE(all.equal(
parent$spectra[, index, drop = FALSE], medoid$spectra,
tolerance = 0, check.attributes = FALSE
))) {
stop("Medoids are not unchanged spectra from the closed parent: ",
artifact, "/", type, call. = FALSE)
}
parent_normalized <- .lib_prune_normalize(
parent$spectra, parent$wavenumber, exclude = NULL
)
medoid_normalized <- parent_normalized[index, , drop = FALSE]
eligible_parent <- !tolower(trimws(parent_classes)) %in% generic
eligible_medoid <- !tolower(trimws(medoid_classes)) %in% generic
eligible_parent[is.na(eligible_parent)] <- FALSE
eligible_medoid[is.na(eligible_medoid)] <- FALSE
maximum <- -Inf
wrong_pairs <- 0L
blocks <- split(
seq_along(parent_ids),
ceiling(seq_along(parent_ids) / as.integer(block_size))
)
for (block in blocks) {
cors <- tcrossprod(
parent_normalized[block, , drop = FALSE], medoid_normalized
)
different <- outer(
parent_classes[block], medoid_classes, FUN = "!="
)
different[is.na(different)] <- FALSE
valid <- outer(eligible_parent[block], eligible_medoid, FUN = "&") &
different
scores <- cors[valid & is.finite(cors)]
if (length(scores)) {
maximum <- max(maximum, max(scores))
wrong_pairs <- wrong_pairs + sum(scores > threshold)
}
rm(cors, different, valid, scores)
}
if (wrong_pairs > 0L) {
stop(
"Closed parent-to-medoid correlation invariant failed for ",
artifact, "/", type, " (", wrong_pairs, " pair(s) > ",
threshold, ")", call. = FALSE
)
}
row_i <- row_i + 1L
rows[[row_i]] <- data.table::data.table(
artifact = artifact, spectrum_type = type,
parent_spectra = length(parent_ids), medoid_spectra = length(medoid_ids),
threshold = threshold,
max_wrong_class_correlation = if (is.finite(maximum)) maximum else NA_real_,
wrong_class_pairs_above_threshold = wrong_pairs,
ids_unchanged = TRUE, classes_unchanged = TRUE,
spectra_unchanged = TRUE
)
if (!is.null(report)) report(sprintf(
"validated parent-to-medoid closure %s/%s (pairs>%g: %d)",
artifact, type, threshold, wrong_pairs
))
}
}
data.table::rbindlist(rows, fill = TRUE)
}
.lib_build_models <- function(libraries, medoids, report, checkpoints = NULL,
methods = "logistic_regression",
random_forest_args = list()) {
methods <- match.arg(
methods, c("logistic_regression", "random_forest"), several.ok = TRUE
)
if (!is.list(random_forest_args) ||
(length(random_forest_args) &&
(is.null(names(random_forest_args)) || any(!nzchar(names(random_forest_args)))))) {
stop("'random_forest_args' must be a named list", call. = FALSE)
}
models <- list()
warnings <- list()
configurations <- list(
logistic_regression = list(
source = medoids,
recipes = intersect(c("derivative", "nobaseline"), names(medoids)),
args = list()
),
random_forest = list(
source = libraries,
recipes = intersect(c("raw", "derivative", "nobaseline"),
names(libraries)),
args = random_forest_args
)
)
configurations <- configurations[methods]
for (algorithm in names(configurations)) {
configuration <- configurations[[algorithm]]
models[[algorithm]] <- list()
for (recipe in configuration$recipes) {
sources <- lapply(names(configuration$source[[recipe]]), function(type) {
.lib_restrict_model_range(configuration$source[[recipe]][[type]], type)
}) |> stats::setNames(names(configuration$source[[recipe]]))
# The historical logistic artifact retains its combined FTIR/Raman
# member. Probability forests are deployed as typed models, so fitting a
# second forest over the already-covered FTIR and Raman rows would only
# duplicate the two largest training jobs.
if (identical(algorithm, "logistic_regression") &&
all(c("ftir", "raman") %in% names(sources))) {
sources$both <- .lib_bind_same_axis(
list(sources$ftir, sources$raman),
label = paste0(recipe, " FTIR/Raman model input")
)
}
models[[algorithm]][[recipe]] <- list()
for (type in names(sources)) {
stage <- paste0(
paste("model", algorithm, recipe, type, sep = "_"),
if (identical(algorithm, "logistic_regression")) {
"_parallel_rng_v1"
} else {
""
}
)
cached <- if (is.null(checkpoints)) NULL else checkpoints$get(stage)
if (!is.null(cached)) {
models[[algorithm]][[recipe]][[type]] <- cached
cached_warnings <- attr(cached, "training_warnings", exact = TRUE)
if(length(cached_warnings)) warnings[[length(warnings) + 1L]] <-
data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = as.character(cached_warnings)
)
next
}
if (is.null(sources[[type]])) {
warnings[[length(warnings) + 1L]] <- data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = "No spectra were available for this technique"
)
models[[algorithm]][[recipe]][[type]] <- NULL
next
}
model_started <- proc.time()[["elapsed"]]
model_classes <- if("material_class" %in% names(sources[[type]]$metadata)) {
data.table::uniqueN(sources[[type]]$metadata$material_class,
na.rm = TRUE)
} else NA_integer_
report(sprintf(
paste0("training model (%s/%s/%s; spectra=%d; wavenumbers=%d; ",
"classes=%s)"),
algorithm, recipe, type, ncol(sources[[type]]$spectra),
nrow(sources[[type]]$spectra),
if(is.na(model_classes)) "unknown" else model_classes
))
training_warnings <- character()
models[[algorithm]][[recipe]][[type]] <- tryCatch(
withCallingHandlers(
do.call(
train_spec_model,
c(
list(sources[[type]], method = algorithm),
configuration$args
)
),
warning = function(condition) {
message <- conditionMessage(condition)
training_warnings <<- unique(c(training_warnings, message))
report(sprintf("model warning (%s/%s/%s): %s",
algorithm, recipe, type, message))
invokeRestart("muffleWarning")
}
),
error = function(error) {
warnings[[length(warnings) + 1L]] <<- data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = conditionMessage(error)
)
NULL
}
)
if(length(training_warnings)) {
warnings[[length(warnings) + 1L]] <- data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
warning = training_warnings
)
}
if(!is.null(models[[algorithm]][[recipe]][[type]])) {
attr(models[[algorithm]][[recipe]][[type]], "training_warnings") <-
training_warnings
}
if (!is.null(checkpoints) &&
!is.null(models[[algorithm]][[recipe]][[type]])) {
checkpoints$put(stage, models[[algorithm]][[recipe]][[type]])
}
if (!is.null(models[[algorithm]][[recipe]][[type]])) {
fitted <- models[[algorithm]][[recipe]][[type]]
fill_replaced <- fitted$fill_replaced
if (is.null(fill_replaced)) fill_replaced <- 0L
if (identical(algorithm, "random_forest")) {
metrics <- fitted$oob_metrics
parameters <- fitted$training_parameters
report(sprintf(
paste0("model complete (%s/%s/%s; observations=%d; classes=%d; ",
"filled=%d; trees=%d; mtry=%d; OOB macro accuracy=%.4f; %.1fs)"),
algorithm, recipe, type, fitted$observation_count,
fitted$class_num, fill_replaced, parameters$num_trees,
parameters$mtry, metrics$macro_class_accuracy,
proc.time()[["elapsed"]] - model_started
))
} else {
report(sprintf(
paste0("model complete (%s/%s/%s; observations=%d; classes=%d; ",
"filled=%d; lambda=%.6g by macro class accuracy; %.1fs)"),
algorithm, recipe, type, fitted$observation_count,
fitted$class_num, fill_replaced, fitted$lambda_selected,
proc.time()[["elapsed"]] - model_started
))
}
}
}
}
}
list(
models = models,
warnings = if (length(warnings)) {
data.table::rbindlist(warnings, fill = TRUE)
} else {
.lib_warning_schema()
}
)
}
.lib_restrict_model_range <- function(x, type) {
type <- tolower(type)
if (type %in% c("ftir", "raman")) {
limits <- c(800, 3200)
} else if (identical(type, "nir")) {
finite_fraction <- rowMeans(is.finite(x$spectra))
usable <- x$wavenumber >= 4000 & x$wavenumber <= 12000 &
finite_fraction >= 0.9
if (!any(usable)) {
usable <- x$wavenumber >= 4000 & x$wavenumber <= 12000 &
finite_fraction > 0
}
runs <- rle(usable)
candidates <- which(runs$values)
if (!length(candidates)) {
stop("NIR spectra have no finite values in 4000-12000", call. = FALSE)
}
run <- candidates[which.max(runs$lengths[candidates])]
ends <- cumsum(runs$lengths)
starts <- ends - runs$lengths + 1L
indices <- seq.int(starts[run], ends[run])
limits <- range(x$wavenumber[indices])
} else {
stop("Unsupported spectrum type: ", type, call. = FALSE)
}
out <- restrict_range(
x, min = limits[1L], max = limits[2L], make_rel = FALSE
)
supported <- .lib_filter_spectral_support(out, min_fraction = 0.1)
out <- supported$object
attr(out, "identification_range") <- limits
out
}
.lib_bind_same_axis <- function(objects, label = "objects") {
objects <- Filter(Negate(is.null), objects)
if (!length(objects)) return(NULL)
axes <- lapply(objects, `[[`, "wavenumber")
if (!all(vapply(axes[-1L], identical, logical(1), axes[[1L]]))) {
stop(label, " do not share an identical wavenumber axis", call. = FALSE)
}
out <- objects[[1L]]
out$spectra <- do.call(cbind, lapply(objects, `[[`, "spectra"))
out$metadata <- data.table::rbindlist(
lapply(objects, `[[`, "metadata"), fill = TRUE
)
out <- as_OpenSpecy(out)
out
}
.lib_filter_optional_type <- function(x, type) {
if (!is_OpenSpecy(x) && is.list(x) && length(x) && !is.null(names(x))) {
index <- match(tolower(type), tolower(names(x)))
if (is.na(index)) return(NULL)
candidate <- x[[index]]
if (!is_OpenSpecy(candidate)) {
stop("Typed reference-library component '", names(x)[[index]],
"' is not an OpenSpecy object", call. = FALSE)
}
return(candidate)
}
if (!is_OpenSpecy(x)) return(NULL)
keep <- !is.na(x$metadata$spectrum_type) &
tolower(x$metadata$spectrum_type) == type
if (!any(keep)) return(NULL)
filter_spec(x, keep)
}
.lib_recover_library_assessments <- function(libraries, tables) {
artifacts <- .lib_named_typed_objects(libraries)
collect_enrichment <- function(attribute, field) {
data.table::rbindlist(lapply(names(artifacts), function(name) {
report <- attr(artifacts[[name]], attribute, exact = TRUE)
if (is.null(report) || is.null(report[[field]]) ||
!nrow(report[[field]])) return(NULL)
out <- data.table::copy(report[[field]])
out[, artifact := name]
out
}), fill = TRUE)
}
material_form_enrichment <- collect_enrichment(
"material_form_enrichment_report", "summary"
)
material_form_matches <- collect_enrichment(
"material_form_enrichment_report", "matches"
)
material_form_clashes <- collect_enrichment(
"material_form_enrichment_report", "clashes"
)
common_use_enrichment <- collect_enrichment(
"common_use_enrichment_report", "summary"
)
common_use_coverage <- collect_enrichment(
"common_use_enrichment_report", "coverage"
)
prediction <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "class_prediction_report")
if (is.null(report) || is.null(report$summary)) return(NULL)
data.table::data.table(
artifact = name, metric = names(report$summary),
value = as.numeric(unlist(report$summary, use.names = FALSE))
)
}), fill = TRUE)
coverage <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "class_coverage_report")
if (is.null(report)) return(NULL)
out <- data.table::copy(data.table::as.data.table(report))
out[, artifact := name]
out
}), fill = TRUE)
type_coverage <- data.table::rbindlist(lapply(names(libraries), function(name) {
metadata <- libraries[[name]]$metadata
data.table::data.table(
artifact = name, field = c("library_type", "spectrum_type"),
populated = c(
sum(!is.na(metadata$library_type) & nzchar(metadata$library_type)),
sum(!is.na(metadata$spectrum_type) & nzchar(metadata$spectrum_type))
), total = nrow(metadata)
)
}))
pruning <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$summary)) return(NULL)
out <- data.table::copy(report$summary)
out[, artifact := name]
out
}), fill = TRUE)
pruning_excluded_classes <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$excluded_classes) ||
!nrow(report$excluded_classes)) return(NULL)
out <- data.table::copy(report$excluded_classes)
out[, artifact := name]
data.table::setcolorder(
out, c("artifact", setdiff(names(out), "artifact"))
)
out
}
), fill = TRUE)
if (!nrow(pruning_excluded_classes)) {
pruning_excluded_classes <- .lib_prune_excluded_assessment_schema()
}
other_review <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "other_review_report")
if (is.null(report) || !nrow(report)) return(NULL)
data.table::copy(report)
}), fill = TRUE)
if (!nrow(other_review)) other_review <- .lib_other_review_schema()
other_filter <- data.table::rbindlist(lapply(names(libraries), function(name) {
report <- attr(libraries[[name]], "other_filter_report")
if (is.null(report) || !nrow(report)) return(NULL)
data.table::copy(report)
}), fill = TRUE)
if (!nrow(other_filter)) other_filter <- .lib_other_filter_schema()
pruning_reassignments <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$reassignments) ||
!nrow(report$reassignments)) return(NULL)
data.table::copy(report$reassignments)[, artifact := name][]
}
), fill = TRUE)
if (!nrow(pruning_reassignments)) {
pruning_reassignments <- .lib_prune_reassignment_schema()
}
pruning_removals <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$removals) ||
!nrow(report$removals)) return(NULL)
out <- data.table::copy(report$removals)
out[, artifact := name]
data.table::setcolorder(
out, c("artifact", setdiff(names(out), "artifact"))
)
out
}
), fill = TRUE)
if (!nrow(pruning_removals)) {
pruning_removals <- .lib_prune_removal_assessment_schema()
}
pruning_conflicts <- data.table::rbindlist(lapply(
names(libraries), function(name) {
report <- attr(libraries[[name]], "prune_report")
if (is.null(report) || is.null(report$cross_class_conflicts) ||
!nrow(report$cross_class_conflicts)) return(NULL)
out <- data.table::copy(report$cross_class_conflicts)
out[, artifact := name]
out
}
), fill = TRUE)
if (!nrow(pruning_conflicts)) {
pruning_conflicts <- .lib_prune_conflict_edge_schema()
pruning_conflicts[, artifact := character()]
}
raw_coverage <- attr(libraries$raw, "class_coverage_report")
before_filter <- if (is.null(raw_coverage) || nrow(raw_coverage) == 0L) {
NA_integer_
} else {
as.integer(raw_coverage$total[[nrow(raw_coverage)]])
}
after_filter <- ncol(libraries$raw$spectra)
metadata_drop <- data.table::data.table(
metadata_column = tables$metadata_drop$metadata_column,
status = ifelse(
tables$metadata_drop$metadata_column %in% names(libraries$raw$metadata),
"retained", "removed_or_absent"
)
)
dropped_spectrum_identities <- data.table::rbindlist(lapply(
libraries, function(object) {
attr(object, "dropped_spectrum_identities", exact = TRUE)
}
), fill = TRUE)
if (!"spectrum_identity" %in% names(dropped_spectrum_identities)) {
dropped_spectrum_identities <- data.table::data.table(
spectrum_identity = character()
)
} else {
dropped_spectrum_identities <- dropped_spectrum_identities[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(spectrum_identity)))
]
}
list(
class_prediction = prediction,
class_coverage = coverage,
type_coverage = type_coverage,
material_form_enrichment = material_form_enrichment,
material_form_matches = material_form_matches,
material_form_clashes = material_form_clashes,
common_use_enrichment = common_use_enrichment,
common_use_coverage = common_use_coverage,
other_review = other_review,
other_filter = other_filter,
pruning = pruning,
pruning_excluded_classes = pruning_excluded_classes,
pruning_reassignments = pruning_reassignments,
pruning_removals = pruning_removals,
pruning_conflicts = pruning_conflicts,
filters = data.table::data.table(
stage = "special_filter", before = before_filter,
after = after_filter,
removed = if (is.na(before_filter)) NA_integer_ else
before_filter - after_filter
),
metadata_drop = metadata_drop,
library_retention = .lib_library_retention_report(list(
.lib_library_stage_counts(libraries, stage = "final")
)),
dropped_spectrum_identities = dropped_spectrum_identities
)
}
.lib_model_assessment_tables <- function(models) {
table_fields <- c(
"tests", "lambda_metrics", "oob_metrics", "oob_class_accuracy",
"feature_importance", "training_parameters", "class_weights"
)
out <- stats::setNames(vector("list", length(table_fields)), table_fields)
for (algorithm in names(models)) {
for (recipe in names(models[[algorithm]])) {
for (type in names(models[[algorithm]][[recipe]])) {
model <- models[[algorithm]][[recipe]][[type]]
if (is.null(model)) next
for (field in table_fields) {
value <- model[[field]]
if (is.null(value) || !length(value)) next
value <- data.table::copy(data.table::as.data.table(value))
if (!nrow(value)) next
value[, `:=`(
algorithm = algorithm, artifact = recipe, model = type
)]
data.table::setcolorder(
value,
c("algorithm", "artifact", "model",
setdiff(names(value), c("algorithm", "artifact", "model")))
)
out[[field]][[length(out[[field]]) + 1L]] <- value
}
}
}
}
lapply(out, function(rows) {
if (!length(rows)) return(data.table::data.table())
data.table::rbindlist(rows, fill = TRUE, use.names = TRUE)
})
}
.lib_collect_automated_test_flags <- function(libraries) {
rows <- lapply(names(libraries), function(artifact) {
object <- libraries[[artifact]]
if (!is_OpenSpecy(object)) return(NULL)
metadata <- data.table::as.data.table(object$metadata)
required <- c("assessment_flag", "assessment_checks")
if (!all(required %in% names(metadata))) return(NULL)
keep <- !is.na(metadata$assessment_flag) & metadata$assessment_flag &
!is.na(metadata$assessment_checks) &
nzchar(trimws(metadata$assessment_checks))
if (!any(keep)) return(NULL)
ids <- .lib_ids(object, "sample_name")
technique <- if ("spectrum_type" %in% names(metadata)) {
as.character(metadata$spectrum_type)
} else {
rep("all", nrow(metadata))
}
checks <- strsplit(as.character(metadata$assessment_checks[keep]),
";\\s*")
data.table::data.table(
artifact = artifact,
technique = rep(technique[keep], lengths(checks)),
spectrum_id = rep(as.character(ids[keep]), lengths(checks)),
error_mode = trimws(unlist(checks, use.names = FALSE))
)[nzchar(error_mode)]
})
out <- unique(data.table::rbindlist(rows, fill = TRUE))
if (nrow(out)) return(out[])
data.table::data.table(
artifact = character(), technique = character(),
spectrum_id = character(), error_mode = character()
)
}
.lib_local_build_assessments <- function(libraries, medoids, models,
completed, model_warnings) {
artifacts <- c(
.lib_named_typed_objects(libraries),
.lib_named_typed_objects(medoids, prefix = "medoid_")
)
summary <- data.table::rbindlist(lapply(names(artifacts), function(name) {
data.table::data.table(
artifact = name,
valid_OpenSpecy = suppressWarnings(check_OpenSpecy(artifacts[[name]])),
spectra = ncol(artifacts[[name]]$spectra),
wavenumbers = length(artifacts[[name]]$wavenumber),
metadata_columns = ncol(artifacts[[name]]$metadata)
)
}), fill = TRUE)
model_summary <- data.table::rbindlist(lapply(names(models), function(algorithm) {
data.table::rbindlist(lapply(names(models[[algorithm]]), function(recipe) {
data.table::rbindlist(lapply(names(models[[algorithm]][[recipe]]), function(type) {
model <- models[[algorithm]][[recipe]][[type]]
oob <- if (is.null(model)) NULL else model$oob_metrics
data.table::data.table(
algorithm = algorithm, artifact = recipe, model = type,
trained = !is.null(model),
classes = if (is.null(model)) NA_integer_ else model$class_num,
observations = if (is.null(model)) NA_integer_ else
model$observation_count,
fill_replaced = if (is.null(model)) NA_integer_ else
model$fill_replaced,
lambda_selected = if (is.null(model)) NA_real_ else
model$lambda_selected,
oob_accuracy = if (is.null(oob)) NA_real_ else oob$accuracy,
oob_macro_class_accuracy = if (is.null(oob)) NA_real_ else
oob$macro_class_accuracy,
oob_brier_score = if (is.null(oob)) NA_real_ else
oob$brier_score
)
}), fill = TRUE)
}), fill = TRUE)
}), fill = TRUE)
support_rows <- list()
class_support_rows <- list()
for (recipe in names(medoids)) {
for (type in names(medoids[[recipe]])) {
audit <- attr(
medoids[[recipe]][[type]], "identification_support", exact = TRUE
)
if (is.null(audit)) next
audit <- data.table::copy(audit)
audit[, `:=`(stage = "medoid", algorithm = NA_character_,
artifact = recipe, model = type)]
support_rows[[length(support_rows) + 1L]] <- audit
}
}
for (algorithm in names(models)) {
for (recipe in names(models[[algorithm]])) {
for (type in names(models[[algorithm]][[recipe]])) {
model <- models[[algorithm]][[recipe]][[type]]
if (is.null(model) || is.null(model$support)) next
audit <- data.table::copy(model$support)
audit[, `:=`(stage = "model", algorithm = algorithm,
artifact = recipe, model = type)]
support_rows[[length(support_rows) + 1L]] <- audit
if (!is.null(model$class_support)) {
class_audit <- data.table::copy(model$class_support)
class_audit[, `:=`(algorithm = algorithm, artifact = recipe,
model = type)]
class_support_rows[[length(class_support_rows) + 1L]] <- class_audit
}
}
}
}
support <- if (length(support_rows)) {
data.table::rbindlist(support_rows, fill = TRUE)
} else {
out <- .lib_support_schema()
out[, `:=`(stage = character(), algorithm = character(), artifact = character(),
model = character())]
data.table::setcolorder(
out, c("stage", "algorithm", "artifact", "model", setdiff(names(out),
c("stage", "algorithm", "artifact", "model")))
)
out
}
class_support <- if (length(class_support_rows)) {
data.table::rbindlist(class_support_rows, fill = TRUE)
} else {
data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
class = character(),
spectra = integer(), minimum_spectra = integer(), retained = logical()
)
}
library_artifacts <- .lib_named_typed_objects(libraries)
lookup_coverage <- data.table::rbindlist(lapply(names(library_artifacts), function(name) {
reports <- attr(library_artifacts[[name]], "metadata_lookup_reports")
if (is.null(reports) || length(reports) == 0L) return(NULL)
data.table::rbindlist(lapply(names(reports), function(stage) {
out <- data.table::copy(reports[[stage]])
out[, `:=`(artifact = name, stage = stage)]
out
}), fill = TRUE)
}), fill = TRUE)
identity_cleanup <- data.table::rbindlist(lapply(names(library_artifacts), function(name) {
out <- attr(library_artifacts[[name]], "spectrum_identity_cleanup_report")
if (is.null(out) || nrow(out) == 0L) return(NULL)
out <- data.table::copy(out)
out[, artifact := name]
out
}), fill = TRUE)
exclusions <- data.table::rbindlist(lapply(names(library_artifacts), function(name) {
out <- attr(library_artifacts[[name]], "build_stage_report")
if (is.null(out) || nrow(out) == 0L) return(NULL)
out <- data.table::copy(out)
out[, artifact := name]
out
}), fill = TRUE)
model_tables <- .lib_model_assessment_tables(models)
defaults <- list(
build_summary = summary,
lookup_coverage = lookup_coverage,
identity_cleanup = identity_cleanup,
class_prediction = data.table::data.table(),
class_coverage = data.table::data.table(),
type_coverage = data.table::data.table(),
material_form_enrichment = data.table::data.table(),
material_form_matches = data.table::data.table(),
material_form_clashes = data.table::data.table(),
common_use_enrichment = data.table::data.table(),
common_use_coverage = data.table::data.table(),
other_review = .lib_other_review_schema(),
other_filter = .lib_other_filter_schema(),
exclusions_deduplication = exclusions,
filters = data.table::data.table(),
metadata_drop = data.table::data.table(),
metadata_finalization = .lib_metadata_finalization_schema(),
pruning = data.table::data.table(),
pruning_excluded_classes = .lib_prune_excluded_assessment_schema(),
pruning_reassignments = .lib_prune_reassignment_schema(),
pruning_removals = .lib_prune_removal_assessment_schema(),
pruning_conflicts = .lib_prune_conflict_edge_schema(),
correlation_closure = data.table::data.table(),
medoid_model_summary = model_summary,
medoid_model_support = support,
model_class_support = class_support,
model_training_tests = model_tables$tests,
model_lambda_metrics = model_tables$lambda_metrics,
model_oob_metrics = model_tables$oob_metrics,
model_oob_class_accuracy = model_tables$oob_class_accuracy,
model_feature_importance = model_tables$feature_importance,
model_training_parameters = model_tables$training_parameters,
model_class_weights = model_tables$class_weights,
split_manifest = data.table::data.table(),
library_identification = data.table::data.table(),
library_confusion = data.table::data.table(),
model_identification = data.table::data.table(),
model_confusion = data.table::data.table(),
model_assessment_correlations =
.lib_model_assessment_correlation_schema(),
automated_test_flags = data.table::data.table(
artifact = character(), technique = character(),
spectrum_id = character(), error_mode = character()
),
assess_spec_shifts = data.table::data.table(),
old_new_compatibility = data.table::data.table(),
quality_control = .lib_quality_schema(),
library_retention = data.table::data.table(),
dropped_spectrum_identities = data.table::data.table(
spectrum_identity = character()
),
warnings = if (nrow(model_warnings)) model_warnings else
.lib_warning_schema(),
output_manifest = data.table::data.table()
)
if (!is.null(completed)) defaults[names(completed)] <- completed
range_flat <- data.table::rbindlist(lapply(
c(
.lib_named_typed_objects(libraries),
.lib_named_typed_objects(medoids, prefix = "medoid_")
),
function(object) attr(object, "range_flat_drops", exact = TRUE)
), fill = TRUE)
if (nrow(range_flat)) {
defaults$quality_control <- unique(data.table::rbindlist(
list(defaults$quality_control, range_flat), fill = TRUE
))
range_flat_identities <- range_flat[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity)
]
defaults$dropped_spectrum_identities <- data.table::rbindlist(
list(defaults$dropped_spectrum_identities, range_flat_identities),
fill = TRUE
)[
!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity)),
.(spectrum_identity = sort(unique(as.character(spectrum_identity))))
]
}
defaults
}
.lib_bind_assessment_tables <- function(assessments, table_names) {
rows <- lapply(intersect(table_names, names(assessments)), function(name) {
value <- assessments[[name]]
if (!inherits(value, c("data.frame", "data.table")) || !nrow(value)) {
return(NULL)
}
value <- data.table::copy(data.table::as.data.table(value))
value[, assessment_kind := name]
data.table::setcolorder(
value, c("assessment_kind", setdiff(names(value), "assessment_kind"))
)
value
})
data.table::rbindlist(rows, fill = TRUE, use.names = TRUE)
}
.lib_pivot_assessment_sources <- function(x, id_cols, value_cols,
shift_cols = character()) {
if (is.null(x) || !nrow(x)) return(data.table::data.table())
x <- data.table::copy(data.table::as.data.table(x))
id_cols <- intersect(id_cols, names(x))
value_cols <- intersect(value_cols, names(x))
if (!"source" %in% names(x) || !length(id_cols) || !length(value_cols)) {
return(x)
}
x <- x[source %in% c("old", "new")]
if (!nrow(x)) return(data.table::data.table())
duplicate_key <- c(id_cols, "source")
if (anyDuplicated(x[, ..duplicate_key])) {
stop("Assessment rows are not unique for old/new pivot keys",
call. = FALSE)
}
formula <- stats::as.formula(paste(paste(id_cols, collapse = " + "),
"~ source"))
out <- data.table::copy(data.table::dcast(
x, formula, value.var = value_cols, sep = "_", drop = TRUE
))
template <- x[0]
for (metric in value_cols) {
for (source in c("old", "new")) {
column <- paste0(metric, "_", source)
if (!column %in% names(out)) {
prototype <- template[[metric]]
value <- if (is.integer(prototype)) NA_integer_ else if (
is.numeric(prototype)
) NA_real_ else if (is.logical(prototype)) NA else NA_character_
data.table::set(out, j = column, value = value)
}
}
if (metric %in% shift_cols) {
data.table::set(
out, j = paste0(metric, "_shift"),
value = out[[paste0(metric, "_new")]] -
out[[paste0(metric, "_old")]]
)
}
}
paired <- unlist(lapply(value_cols, function(metric) {
columns <- c(paste0(metric, "_old"), paste0(metric, "_new"))
if (metric %in% shift_cols) columns <- c(columns, paste0(metric, "_shift"))
columns
}), use.names = FALSE)
data.table::setcolorder(out, c(id_cols, paired, setdiff(names(out), c(id_cols, paired))))
out[]
}
.lib_accuracy_review <- function(summary, medoid = FALSE) {
summary <- data.table::copy(data.table::as.data.table(summary))
if (!nrow(summary) || !"artifact" %in% names(summary)) {
return(data.table::data.table())
}
is_medoid <- grepl("^medoid_", summary$artifact)
out <- summary[is_medoid == medoid]
if (!nrow(out)) return(out)
out[, `:=`(
overall_accuracy_pct = 100 * overall_accuracy,
macro_class_accuracy_pct = 100 * macro_class_accuracy,
class_count = as.integer(evaluated_classes)
)]
keep <- intersect(c(
"algorithm", "artifact", "model", "technique", "source", "provenance",
"spectra", "class_count", "overall_accuracy_pct",
"macro_class_accuracy_pct"
), names(out))
out <- out[, ..keep]
out[, .source_order := match(source, c("old", "new"))]
data.table::setorderv(
out, intersect(c("algorithm", "artifact", "model", "technique",
".source_order"), names(out)),
rep(1L, length(intersect(
c("algorithm", "artifact", "model", "technique", ".source_order"),
names(out)
)))
)
out[, .source_order := NULL]
out[]
}
.lib_confusion_review <- function(confusion, medoid = NULL) {
rows <- data.table::copy(data.table::as.data.table(confusion))
if (!nrow(rows)) return(data.table::data.table())
if (!is.null(medoid)) {
is_medoid <- grepl("^medoid_", rows$artifact)
rows <- rows[is_medoid == medoid]
}
out <- rows[misidentified %in% TRUE]
if (!nrow(out)) return(out)
out[is.na(predicted_class) | !nzchar(predicted_class),
predicted_class := "unclassified"]
out[, expected_class_pct := 100 * expected_class_fraction]
keep <- intersect(c(
"algorithm", "artifact", "model", "technique", "source", "provenance",
"expected_class", "predicted_class", "spectra",
"expected_class_spectra", "expected_class_pct"
), names(out))
out <- out[, ..keep]
data.table::setorderv(
out,
intersect(c("algorithm", "artifact", "model", "technique", "source",
"spectra", "expected_class", "predicted_class"), names(out)),
c(rep(1L, length(intersect(
c("algorithm", "artifact", "model", "technique", "source"), names(out)
))), -1L, 1L, 1L)
)
out[]
}
.lib_model_diagnostics_review <- function(assessments) {
out <- data.table::copy(data.table::as.data.table(
assessments$model_assessment_correlations
))
if (nrow(out)) data.table::setorderv(
out, c("accuracy_difference_pct", "algorithm", "artifact", "model",
"technique", "error_mode"), c(1L, 1L, 1L, 1L, 1L, 1L)
)
out[]
}
.lib_cleanup_review <- function(assessments, table_names) {
rows <- lapply(intersect(table_names, names(assessments)), function(name) {
value <- assessments[[name]]
if (!inherits(value, c("data.frame", "data.table")) || !nrow(value)) {
return(NULL)
}
value <- data.table::as.data.table(value)
data.table::data.table(
assessment = name,
rows = as.integer(nrow(value)),
artifacts = as.integer(if ("artifact" %in% names(value)) {
data.table::uniqueN(value$artifact, na.rm = TRUE)
} else 0L),
spectrum_records = as.integer(if ("spectrum_id" %in% names(value)) {
data.table::uniqueN(value$spectrum_id, na.rm = TRUE)
} else if ("n" %in% names(value)) {
sum(value$n, na.rm = TRUE)
} else 0L),
removed_spectra = as.integer(if ("removed" %in% names(value)) {
sum(as.numeric(value$removed), na.rm = TRUE)
} else if ("spectra_removed" %in% names(value)) {
sum(value$spectra_removed, na.rm = TRUE)
} else 0L)
)
})
out <- data.table::rbindlist(rows, fill = TRUE)
if (nrow(out)) data.table::setorder(out, assessment)
out[]
}
.lib_functionality_review <- function(shifts) {
shifts <- data.table::copy(data.table::as.data.table(shifts))
if (!nrow(shifts)) return(data.table::data.table())
for (column in c("rate_old", "rate_new")) {
if (!column %in% names(shifts)) shifts[[column]] <- 0
shifts[is.na(get(column)), (column) := 0]
}
out <- shifts[, .(
artifact, check,
old_error_pct = 100 * rate_old,
new_error_pct = 100 * rate_new,
change_pct = 100 * (rate_new - rate_old)
)]
data.table::setorderv(out, c("change_pct", "artifact", "check"),
c(-1L, 1L, 1L))
out[]
}
.lib_assessment_review <- function(assessments) {
if (is.list(assessments) && identical(
names(assessments), c("cleanup", "ref_lib", "medoid", "model", "functionality")
)) return(assessments)
cleanup_names <- c(
"lookup_coverage", "identity_cleanup", "class_prediction", "class_coverage",
"type_coverage", "material_form_enrichment", "material_form_matches",
"material_form_clashes", "common_use_enrichment", "common_use_coverage",
"other_review", "other_filter", "exclusions_deduplication",
"filters", "metadata_drop", "metadata_finalization", "pruning",
"pruning_excluded_classes", "pruning_reassignments", "pruning_removals",
"pruning_conflicts", "correlation_closure",
"quality_control",
"library_retention"
)
cleanup_summary <- data.table::copy(data.table::as.data.table(
assessments$library_retention
))
if (nrow(cleanup_summary)) {
if ("reason" %in% names(cleanup_summary)) {
cleanup_summary[is.na(reason) | !nzchar(trimws(reason)),
reason := "retained"]
}
cleanup_summary[, assessment_kind := "library_retention"]
data.table::setcolorder(
cleanup_summary,
c("assessment_kind", setdiff(names(cleanup_summary), "assessment_kind"))
)
} else {
cleanup_summary <- .lib_cleanup_review(assessments, cleanup_names)
}
dropped <- assessments$dropped_spectrum_identities
if (is.null(dropped) || !nrow(dropped)) {
dropped <- data.table::data.table(spectrum_identity = character())
} else {
dropped <- data.table::data.table(
spectrum_identity = sort(unique(as.character(dropped$spectrum_identity)))
)[!is.na(spectrum_identity) & nzchar(trimws(spectrum_identity))]
}
ref_accuracy <- .lib_accuracy_review(
assessments$library_identification, medoid = FALSE
)
medoid_accuracy <- .lib_accuracy_review(
assessments$library_identification, medoid = TRUE
)
ref_confusion <- .lib_confusion_review(
assessments$library_confusion, medoid = FALSE
)
medoid_confusion <- .lib_confusion_review(
assessments$library_confusion, medoid = TRUE
)
model_accuracy <- .lib_accuracy_review(assessments$model_identification)
model_confusion <- .lib_confusion_review(assessments$model_confusion)
model_diagnostics <- .lib_model_diagnostics_review(assessments)
functionality <- .lib_functionality_review(assessments$assess_spec_shifts)
compact <- function(values) {
values[vapply(values, function(value) {
inherits(value, c("data.frame", "data.table")) && nrow(value) > 0L
}, logical(1))]
}
out <- list(
cleanup = compact(list(
summary = cleanup_summary,
dropped_spectrum_identities = dropped
)),
ref_lib = compact(list(accuracy = ref_accuracy, confusion = ref_confusion)),
medoid = compact(list(accuracy = medoid_accuracy, confusion = medoid_confusion)),
model = compact(list(
accuracy = model_accuracy, confusion = model_confusion,
error_mode_accuracy = model_diagnostics
)),
functionality = compact(list(comparison = functionality))
)
fallback <- c(
cleanup = "summary", ref_lib = "accuracy", medoid = "accuracy",
model = "error_mode_accuracy", functionality = "comparison"
)
for (process in names(out)) {
if (!length(out[[process]])) {
out[[process]][[fallback[[process]]]] <- data.table::data.table(
status = "not_available_for_this_build"
)
}
}
evidence_names <- intersect(
c("split_manifest", "library_tests", "model_training_tests", "model_tests",
"model_lambda_metrics", "model_oob_metrics", "model_oob_class_accuracy",
"model_feature_importance", "model_training_parameters",
"model_class_weights", "medoid_model_summary", "medoid_model_support",
"model_class_support", "warnings", "old_new_compatibility",
"build_summary", "assess_spec_shifts", "output_manifest",
"pruning_conflicts", "correlation_closure"),
names(assessments)
)
evidence <- assessments[evidence_names]
attr(evidence, "sha256") <- vapply(evidence, digest::digest, character(1),
algo = "sha256")
attr(out, "assessment_schema_version") <- "2.0.0"
attr(out, "evidence") <- evidence
attr(out, "upstream_assessments") <- assessments[intersect(
cleanup_names, names(assessments)
)]
out
}
.lib_named_typed_objects <- function(x, prefix = "") {
out <- list()
for (recipe in names(x)) {
item <- x[[recipe]]
if (is_OpenSpecy(item)) {
out[[paste0(prefix, recipe)]] <- item
} else if (is.list(item)) {
for (type in names(item)) {
if (is_OpenSpecy(item[[type]])) {
out[[paste0(prefix, recipe, "_", type)]] <- item[[type]]
}
}
}
}
out
}
.lib_metadata_finalization_schema <- function() {
data.table::data.table(
artifact = character(), spectra = integer(), before_columns = integer(),
after_columns = integer(), dropped_columns = integer(),
dropped_names = character(), minimum_missing = integer(),
maximum_missing = integer()
)
}
.lib_finalize_one_metadata <- function(x, artifact) {
if (!is_OpenSpecy(x)) {
stop("Metadata finalization requires an OpenSpecy object", call. = FALSE)
}
metadata <- data.table::copy(x$metadata)
before <- ncol(metadata)
missing <- vapply(metadata, function(column) {
as.integer(sum(is.na(column)))
}, integer(1L))
fully_missing <- if (nrow(metadata)) {
names(missing)[missing == nrow(metadata)]
} else {
character()
}
fully_missing <- setdiff(
fully_missing, c("material_form", "common_use")
)
if (length(fully_missing)) metadata[, (fully_missing) := NULL]
remaining_missing <- missing[setdiff(names(missing), fully_missing)]
if (length(remaining_missing)) {
ordered <- names(remaining_missing)[order(
remaining_missing, seq_along(remaining_missing)
)]
data.table::setcolorder(metadata, ordered)
}
out <- x
out$metadata <- metadata
if (!check_OpenSpecy(out)) {
stop("Metadata finalization broke the OpenSpecy object contract for '",
artifact, "'", call. = FALSE)
}
assessment <- data.table::data.table(
artifact = artifact,
spectra = as.integer(nrow(metadata)),
before_columns = as.integer(before),
after_columns = as.integer(ncol(metadata)),
dropped_columns = as.integer(length(fully_missing)),
dropped_names = paste(fully_missing, collapse = "; "),
minimum_missing = if (length(remaining_missing)) {
as.integer(min(remaining_missing))
} else {
NA_integer_
},
maximum_missing = if (length(remaining_missing)) {
as.integer(max(remaining_missing))
} else {
NA_integer_
}
)
list(object = out, assessment = assessment)
}
.lib_finalize_reference_metadata <- function(libraries, medoids) {
assessment <- list()
finalize <- function(collection, prefix = "") {
for (recipe in names(collection)) {
for (type in names(collection[[recipe]])) {
if (!is_OpenSpecy(collection[[recipe]][[type]])) next
artifact <- paste0(prefix, recipe, "_", type)
result <- .lib_finalize_one_metadata(
collection[[recipe]][[type]], artifact
)
collection[[recipe]][[type]] <- result$object
assessment[[artifact]] <<- result$assessment
}
}
collection
}
libraries <- finalize(libraries)
medoids <- finalize(medoids, prefix = "medoid_")
list(
libraries = libraries,
medoids = medoids,
assessment = if (length(assessment)) {
data.table::rbindlist(assessment, fill = TRUE)
} else {
.lib_metadata_finalization_schema()
}
)
}
.lib_model_assessment_correlation_schema <- function() {
data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
technique = character(), error_mode = character(),
with_error_accuracy_pct = numeric(),
without_error_accuracy_pct = numeric(),
accuracy_difference_pct = numeric()
)
}
.lib_model_assessment_correlations <- function(tests, flags) {
schema <- .lib_model_assessment_correlation_schema()
if (is.null(tests) || !nrow(tests) || is.null(flags) || !nrow(flags)) {
return(schema)
}
tests <- data.table::copy(data.table::as.data.table(tests))
flags <- unique(data.table::copy(data.table::as.data.table(flags)))
test_required <- c(
"algorithm", "artifact", "model", "source", "technique",
"spectrum_id", "correct"
)
flag_required <- c("artifact", "technique", "spectrum_id", "error_mode")
missing <- c(setdiff(test_required, names(tests)),
setdiff(flag_required, names(flags)))
if (length(missing)) {
stop("Model error-mode assessment rows are missing: ",
paste(unique(missing), collapse = ", "), call. = FALSE)
}
tests <- tests[source == "new" & !is.na(correct), ..test_required]
flags <- flags[
!is.na(error_mode) & nzchar(trimws(error_mode)), ..flag_required
]
modes <- unique(flags[, .(artifact, technique, error_mode)])
if (!nrow(tests) || !nrow(modes)) return(schema)
rows <- merge(
tests, modes, by = c("artifact", "technique"), allow.cartesian = TRUE
)
flags[, has_error := TRUE]
rows <- merge(
rows, flags,
by = c("artifact", "technique", "spectrum_id", "error_mode"),
all.x = TRUE, sort = FALSE
)
rows[is.na(has_error), has_error := FALSE]
groups <- c("algorithm", "artifact", "model", "technique", "error_mode")
out <- rows[, .(
error_spectra = as.integer(sum(has_error)),
with_error_accuracy_pct = 100 * mean(correct[has_error]),
no_error_spectra = as.integer(sum(!has_error)),
without_error_accuracy_pct = 100 * mean(correct[!has_error])
), by = groups]
out <- out[error_spectra > 0L & no_error_spectra > 0L]
if (!nrow(out)) return(schema)
out[, accuracy_difference_pct :=
with_error_accuracy_pct - without_error_accuracy_pct]
out[, c("error_spectra", "no_error_spectra") := NULL]
data.table::setcolorder(out, names(schema))
data.table::setorderv(
out, c("accuracy_difference_pct", groups),
c(1L, rep(1L, length(groups)))
)
out[]
}
.lib_previous_signature <- function(path) {
if (is.null(path)) return("none")
resolved <- if (identical(path, "system")) {
system.file("extdata", package = "OpenSpecy")
} else {
path
}
types <- c(
"raw", "derivative", "nobaseline", "medoid_derivative",
"medoid_nobaseline", "model_derivative", "model_nobaseline"
)
files <- file.path(resolved, paste0(types, ".rds"))
digest::digest(.lib_file_signatures(files, checksum_limit = Inf),
algo = "sha256")
}
.lib_compare_reference_build <- function(build, previous_library_dir,
seed, holdout, progress,
checkpoints = NULL,
checkpoint_key = NULL,
checkpoint_fallback_key = NULL) {
prior <- .lib_load_previous_libraries(previous_library_dir, progress)
get_checkpoint <- function(stage, stable = FALSE) {
if (is.null(checkpoints)) return(NULL)
value <- checkpoints$get(stage, key = checkpoint_key)
can_fallback <- isTRUE(stable) && is.null(value) &&
!is.null(checkpoint_fallback_key) &&
!identical(checkpoint_key, checkpoint_fallback_key)
if (can_fallback) {
value <- checkpoints$get(stage, key = checkpoint_fallback_key)
if (!is.null(value)) checkpoints$put(stage, value, key = checkpoint_key)
}
value
}
reference_pairs <- list()
for (recipe in intersect(names(build$libraries),
c("raw", "derivative", "nobaseline"))) {
for (type in names(build$libraries[[recipe]])) {
artifact <- paste(recipe, type, sep = "_")
reference_pairs[[artifact]] <- list(
recipe = recipe, type = type, kind = "full"
)
}
}
for (recipe in intersect(names(build$medoids),
c("derivative", "nobaseline"))) {
legacy <- prior[[paste0("medoid_", recipe)]]
for (type in names(build$medoids[[recipe]])) {
artifact <- paste("medoid", recipe, type, sep = "_")
reference_pairs[[artifact]] <- list(
recipe = recipe, type = type, kind = "medoid"
)
}
}
materialize_pair <- function(spec) {
recipe <- spec$recipe
type <- spec$type
if (identical(spec$kind, "full")) {
old <- .lib_filter_optional_type(prior[[recipe]], type)
if (is.null(old)) return(NULL)
new <- build$libraries[[recipe]][[type]]
limits <- range(new$wavenumber)
old <- restrict_range(old, min = limits[1L], max = limits[2L],
make_rel = FALSE)
return(list(
new_reference = new, old_reference = old,
new_data = new, old_data = old
))
}
old <- .lib_filter_optional_type(
prior[[paste0("medoid_", recipe)]], type
)
old_full <- .lib_filter_optional_type(prior[[recipe]], type)
if (is.null(old) || is.null(old_full)) return(NULL)
new <- build$medoids[[recipe]][[type]]
limits <- range(new$wavenumber)
old <- restrict_range(old, min = limits[1L], max = limits[2L],
make_rel = FALSE)
list(
new_reference = new, old_reference = old,
new_data = .lib_restrict_to_reference(
build$libraries[[recipe]][[type]], new
),
old_data = .lib_restrict_to_reference(old_full, old)
)
}
compatibility <- get_checkpoint("assessment_compatibility", stable = TRUE)
compatibility_rows <- list()
split_rows <- list()
reference_tests <- list()
assessment_summaries <- list()
for (i in seq_along(reference_pairs)) {
artifact <- names(reference_pairs)[[i]]
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: identify %s (%d/%d)",
artifact, i, length(reference_pairs)
))
}
pair <- materialize_pair(reference_pairs[[artifact]])
if (is.null(pair)) next
if (is.null(compatibility)) {
compatibility_rows[[artifact]] <- .lib_compatibility_rows(
pair$new_reference, pair$old_reference, artifact
)
}
for (source in c("new", "old")) {
is_medoid <- identical(reference_pairs[[artifact]]$kind, "medoid")
split <- NULL
if (!is_medoid) {
split_stage <- paste0("assessment_split_", artifact, "_", source)
split <- get_checkpoint(split_stage, stable = TRUE)
if (is.null(split)) {
split <- .lib_source_split(
pair[[paste0(source, "_data")]], artifact = artifact,
source = source,
seed = seed + i * 2L + match(source, c("new", "old")),
holdout = holdout
)
if (!is.null(checkpoints)) {
checkpoints$put(split_stage, split, key = checkpoint_key)
}
}
split_rows[[paste(artifact, source, sep = "_")]] <- split$manifest
}
stage <- paste0(
"assessment_reference_", if (is_medoid) "complete_" else "",
artifact, "_", source, if (is_medoid) "_v1" else ""
)
tests <- get_checkpoint(stage, stable = !is_medoid)
if (is.null(tests)) {
test_args <- list(
reference = pair[[paste0(source, "_reference")]],
data = pair[[paste0(source, "_data")]],
artifact = artifact, source = source, progress = progress
)
tests <- if (is_medoid) {
do.call(.lib_reference_complete_test, test_args)
} else {
test_args$split <- split
do.call(.lib_reference_holdout_test, test_args)
}
if (!is.null(checkpoints)) {
checkpoints$put(stage, tests, key = checkpoint_key)
}
}
reference_tests[[paste0(artifact, "_", source)]] <- tests
stage <- paste0("assessment_spectra_", artifact, "_", source)
summary <- get_checkpoint(stage, stable = TRUE)
if (is.null(summary)) {
assessment_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: assess_spec %s/%s starting (spectra=%d)",
artifact, source,
ncol(pair[[paste0(source, "_reference")]]$spectra)
))
}
summary <- .lib_assess_spec_summary(
pair[[paste0(source, "_reference")]], artifact, source
)
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: assess_spec %s/%s complete (%.1fs)",
artifact, source,
proc.time()[["elapsed"]] - assessment_started
))
}
if (!is.null(checkpoints)) {
checkpoints$put(stage, summary, key = checkpoint_key)
}
}
assessment_summaries[[paste0(artifact, "_", source)]] <- summary
}
rm(pair)
gc(verbose = FALSE)
}
if (is.null(compatibility)) {
compatibility <- data.table::rbindlist(compatibility_rows, fill = TRUE)
if (!is.null(checkpoints)) {
checkpoints$put("assessment_compatibility", compatibility,
key = checkpoint_key)
}
}
split_manifest <- data.table::rbindlist(split_rows, fill = TRUE)
reference_tests <- data.table::rbindlist(reference_tests, fill = TRUE)
if (!nrow(reference_tests)) {
stop(
"No comparable legacy reference-library spectra were assessed; ",
"verify that prior artifacts contain typed OpenSpecy components",
call. = FALSE
)
}
if (!nrow(compatibility)) {
stop("Legacy compatibility assessment produced no artifact rows",
call. = FALSE)
}
library_identification <- .lib_identification_summary(reference_tests)
library_confusion <- .lib_confusion_table(reference_tests)
assess_spec_shifts <- .lib_assessment_shift_table(
data.table::rbindlist(assessment_summaries, fill = TRUE)
)
model_tests <- list()
updated_models <- build$models
algorithms <- intersect(
c("logistic_regression", "random_forest"), names(updated_models)
)
for (algorithm in algorithms) {
recipes <- names(updated_models[[algorithm]])
sources <- if (identical(algorithm, "logistic_regression")) {
c("new", "old")
} else {
"new"
}
for (recipe in recipes) {
legacy_model <- if (identical(algorithm, "logistic_regression")) {
prior[[paste0("model_", recipe)]]
} else {
NULL
}
for (source in sources) {
model_set <- if (source == "new") {
updated_models[[algorithm]][[recipe]]
} else {
legacy_model
}
source_object <- function(type) {
if (source == "new") {
build$libraries[[recipe]][[type]]
} else {
.lib_filter_optional_type(prior[[recipe]], type)
}
}
for (type in names(model_set)) {
if (is.null(model_set[[type]])) next
component_types <- if (identical(type, "both")) {
c("ftir", "raman")
} else {
type
}
query_parts <- list()
for (actual_type in component_types) {
eligible <- tryCatch(
.lib_restrict_model_range(source_object(actual_type), actual_type),
error = function(error) NULL
)
if (!is.null(eligible)) query_parts[[actual_type]] <- eligible
}
if (!all(component_types %in% names(query_parts))) next
query <- if (length(component_types) == 1L) {
query_parts[[1L]]
} else {
.lib_bind_same_axis(query_parts, "combined model test spectra")
}
rm(query_parts)
gc(verbose = FALSE)
model_started <- proc.time()[["elapsed"]]
provenance <- paste0(source, "_", algorithm, "_complete_dataset")
if (isTRUE(progress)) message(
"build_lib assessment: existing model ", algorithm, "/",
recipe, "/", type, "/", source, " identifying complete dataset (",
ncol(query$spectra), ")"
)
stage <- paste0(
"assessment_model_complete_", algorithm, "_", recipe, "_", type,
"_", source, "_v1"
)
tests <- if (is.null(checkpoints)) NULL else
checkpoints$get(stage, key = checkpoint_key)
if (is.null(tests)) {
tests <- .lib_model_complete_test(
model_set[[type]], query, recipe, type,
algorithm = algorithm, source = source, provenance = provenance
)
if (!is.null(checkpoints)) {
checkpoints$put(stage, tests, key = checkpoint_key)
}
}
if (source == "new") {
updated_models[[algorithm]][[recipe]][[type]]$tests <- tests
}
key <- paste(algorithm, recipe, type, source, sep = "_")
model_tests[[key]] <- tests
if (isTRUE(progress)) message(sprintf(
paste0("build_lib assessment: existing model ",
"%s/%s/%s/%s complete (%.1fs)"),
algorithm, recipe, type, source,
proc.time()[["elapsed"]] - model_started
))
rm(query)
gc(verbose = FALSE, full = TRUE)
}
gc(verbose = FALSE, full = TRUE)
}
}
}
split_manifest <- data.table::rbindlist(
split_rows, fill = TRUE
)
model_tests <- data.table::rbindlist(model_tests, fill = TRUE)
model_identification <- .lib_identification_summary(model_tests)
model_confusion <- .lib_confusion_table(model_tests)
automated_test_flags <- build$assessments$automated_test_flags
if (is.null(automated_test_flags) || !nrow(automated_test_flags)) {
quality <- data.table::copy(data.table::as.data.table(
build$assessments$quality_control
))
if (nrow(quality) && all(c(
"artifact", "spectrum_type", "spectrum_id", "check"
) %in% names(quality))) {
automated_test_flags <- unique(quality[, .(
artifact, technique = spectrum_type, spectrum_id,
error_mode = check
)])
}
}
model_assessment_correlations <- .lib_model_assessment_correlations(
model_tests, automated_test_flags
)
list(
models = updated_models,
split_manifest = split_manifest,
library_tests = reference_tests,
library_identification = library_identification,
library_confusion = library_confusion,
model_identification = model_identification,
model_tests = model_tests,
model_confusion = model_confusion,
model_assessment_correlations = model_assessment_correlations,
assess_spec_shifts = assess_spec_shifts,
old_new_compatibility = compatibility
)
}
.lib_load_previous_libraries <- function(path, progress) {
types <- c(
"raw", "derivative", "nobaseline", "medoid_derivative",
"medoid_nobaseline", "model_derivative", "model_nobaseline"
)
resolved <- if (identical(path, "system")) {
system.file("extdata", package = "OpenSpecy")
} else {
path
}
if (!nzchar(resolved)) {
stop("Could not resolve 'previous_library_dir'", call. = FALSE)
}
missing <- !file.exists(file.path(resolved, paste0(types, ".rds")))
if (any(missing)) {
if (isTRUE(progress)) {
message("build_lib assessment: retrieving missing legacy artifacts")
}
get_lib(types[missing], path = path)
}
missing <- !file.exists(file.path(resolved, paste0(types, ".rds")))
if (any(missing)) {
stop("Legacy artifact(s) remain unavailable: ",
paste(types[missing], collapse = ", "), call. = FALSE)
}
setNames(lapply(file.path(resolved, paste0(types, ".rds")), readRDS), types)
}
.lib_compatibility_rows <- function(new, old, artifact) {
new_ids <- .lib_ids(new, "sample_name")
old_ids <- .lib_ids(old, "sample_name")
new_names <- names(new$metadata)
old_names <- names(old$metadata)
data.table::data.table(
artifact = artifact,
spectra_old = ncol(old$spectra), spectra_new = ncol(new$spectra),
spectra_shift = ncol(new$spectra) - ncol(old$spectra),
wavenumbers_old = length(old$wavenumber),
wavenumbers_new = length(new$wavenumber),
wavenumbers_shift = length(new$wavenumber) - length(old$wavenumber),
metadata_columns_old = length(old_names),
metadata_columns_new = length(new_names),
metadata_columns_shift = length(new_names) - length(old_names),
shared_identifiers = length(intersect(new_ids, old_ids)),
identifiers_old_only = length(setdiff(old_ids, new_ids)),
identifiers_new_only = length(setdiff(new_ids, old_ids)),
axes_identical = identical(new$wavenumber, old$wavenumber),
metadata_old_only = paste(setdiff(old_names, new_names), collapse = "; "),
metadata_new_only = paste(setdiff(new_names, old_names), collapse = "; ")
)
}
.lib_restrict_to_reference <- function(x, reference) {
limits <- range(reference$wavenumber)
out <- restrict_range(
x, min = limits[1L], max = limits[2L], make_rel = FALSE
)
.lib_filter_spectral_support(out, min_fraction = 0.1)$object
}
.lib_source_split <- function(x, artifact, source, seed, holdout) {
rows <- .lib_split_rows(x, source)
groups <- rows[, .(
material_class = .lib_first_value(material_class),
spectrum_type = .lib_first_value(spectrum_type)
), by = group_id]
groups[, stratum := paste(
ifelse(is.na(spectrum_type), "unknown", spectrum_type),
ifelse(is.na(material_class), "unclassified", material_class), sep = "\r"
)]
allocation <- groups[, .(available = .N), by = stratum]
allocation[, `:=`(
expected = available * holdout,
selected = as.integer(floor(available * holdout))
)]
target <- min(nrow(groups), max(1L, as.integer(round(nrow(groups) * holdout))))
set.seed(seed)
allocation[, `:=`(
remainder = expected - selected,
tie_break = stats::runif(.N)
)]
data.table::setorder(allocation, -remainder, tie_break, stratum)
remaining <- target - sum(allocation$selected)
while (remaining > 0L) {
eligible <- which(allocation$selected < allocation$available)
if (!length(eligible)) break
take <- head(eligible, remaining)
allocation$selected[take] <- allocation$selected[take] + 1L
remaining <- remaining - length(take)
}
test_groups <- unlist(lapply(seq_len(nrow(allocation)), function(i) {
count <- allocation$selected[[i]]
if (!count) return(character())
sample(groups[stratum == allocation$stratum[[i]], group_id], count)
}), use.names = FALSE)
groups[, `:=`(
artifact = artifact, source = source,
split = ifelse(group_id %in% test_groups, "test", "train")
)]
list(
manifest = groups[, .(
artifact, source, group_id, split, material_class, spectrum_type
)],
rows = rows
)
}
.lib_split_rows <- function(x, source, group_ids = NULL) {
metadata <- x$metadata
grouping <- NULL
if (is.null(group_ids)) {
grouping <- .lib_stable_group_info(x)
group_ids <- grouping$group_id
}
if (length(group_ids) != ncol(x$spectra)) {
stop("Comparison group identifiers are not aligned to spectra",
call. = FALSE)
}
data.table::data.table(
source = source, row = seq_along(group_ids), group_id = group_ids,
physical_id = if (is.null(grouping)) NA_character_ else grouping$physical_id,
content_hash = if (is.null(grouping)) NA_character_ else grouping$content_hash,
spectrum_id = as.character(.lib_ids(x, "sample_name")),
material_class = if ("material_class" %in% names(metadata))
as.character(metadata$material_class) else NA_character_,
spectrum_type = if ("spectrum_type" %in% names(metadata))
as.character(metadata$spectrum_type) else NA_character_
)
}
.lib_comparison_group_ids <- function(x) {
.lib_stable_group_info(x)$group_id
}
.lib_stable_group_info <- function(x) {
ids <- as.character(.lib_ids(x, "sample_name"))
metadata <- x$metadata
if ("sample_name_old" %in% names(metadata)) {
legacy_ids <- trimws(as.character(metadata$sample_name_old))
usable <- !is.na(legacy_ids) & nzchar(legacy_ids) &
tolower(legacy_ids) != "new format"
ids[usable] <- legacy_ids[usable]
}
missing <- is.na(ids) | !nzchar(trimws(ids))
ids[missing] <- paste0("row_", which(missing))
content_hash <- vapply(seq_len(ncol(x$spectra)), function(i) {
digest::digest(
list(x$wavenumber, as.numeric(x$spectra[, i])),
algo = "sha256"
)
}, character(1))
parent <- seq_along(ids)
find_root <- function(i) {
while (parent[[i]] != i) {
parent[[i]] <<- parent[[parent[[i]]]]
i <- parent[[i]]
}
i
}
unite <- function(left, right) {
left <- find_root(left)
right <- find_root(right)
if (left != right) parent[[right]] <<- left
}
edges <- data.table::rbindlist(list(
data.table::data.table(token = paste0("id:", ids), row = seq_along(ids))[
, if (.N > 1L) .(row = row[-1L], anchor = row[[1L]]) else NULL,
by = token
],
data.table::data.table(
token = paste0("content:", content_hash), row = seq_along(ids)
)[, if (.N > 1L) .(row = row[-1L], anchor = row[[1L]]) else NULL,
by = token]
), fill = TRUE)
if (nrow(edges)) {
for (i in seq_len(nrow(edges))) unite(edges$row[[i]], edges$anchor[[i]])
}
roots <- vapply(seq_along(ids), find_root, integer(1))
group_id <- data.table::data.table(
row = seq_along(ids), root = roots, physical_id = ids,
content_hash = content_hash
)[, .(
group_id = paste0("group_", substr(digest::digest(
sort(unique(c(physical_id, content_hash))), algo = "sha256"
), 1L, 24L))
), by = root][data.table::data.table(row = seq_along(ids), root = roots),
on = "root", group_id]
list(group_id = group_id, physical_id = ids, content_hash = content_hash)
}
.lib_first_value <- function(x) {
x <- as.character(x)
x <- x[!is.na(x) & nzchar(x)]
if (length(x)) x[[1L]] else NA_character_
}
.lib_reference_holdout_test <- function(reference, data, split,
artifact, source,
progress = FALSE) {
test_groups <- split$manifest[split == "test", group_id]
source_rows <- split$rows
test_idx <- source_rows[group_id %in% test_groups, row]
if (length(test_idx) == 0L) {
return(data.table::data.table())
}
query <- filter_spec(data, test_idx)
query_ids <- .lib_ids(query, "sample_name")
reference_ids <- .lib_ids(reference, "sample_name")
reference_groups <- split$rows$group_id[
match(reference_ids, split$rows$spectrum_id)
]
keep_reference <- !is.na(reference_groups) &
!reference_groups %in% test_groups
if (!any(keep_reference)) return(data.table::data.table())
library <- if (all(keep_reference)) reference else
filter_spec(reference, keep_reference)
library_ids <- .lib_ids(library, "sample_name")
started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
paste0(
"build_lib assessment: %s/%s reference identification starting ",
"(test=%d; train=%d)"
),
artifact, source, length(test_idx), ncol(library$spectra)
))
}
cors <- cor_spec(query, library = library, compute = "optimized")
if (isTRUE(progress)) {
message(sprintf(
paste0(
"build_lib assessment: %s/%s full correlation complete ",
"(%d x %d; %.1fs)"
),
artifact, source, nrow(cors), ncol(cors),
proc.time()[["elapsed"]] - started
))
}
top <- max_cor_named(cors)
matched_rows <- match(names(top), library_ids)
rm(cors)
expected <- as.character(query$metadata$material_class)
predicted <- as.character(library$metadata$material_class[matched_rows])
if (isTRUE(progress)) {
message(sprintf(
"build_lib assessment: %s/%s reference identification complete (%.1fs)",
artifact, source, proc.time()[["elapsed"]] - started
))
}
data.table::data.table(
artifact = artifact, source = source,
spectrum_id = query_ids,
technique = as.character(query$metadata$spectrum_type),
expected_class = expected, predicted_class = predicted,
correct = expected == predicted,
score = as.numeric(top), split = "test",
provenance = "source_local_reference_holdout"
)
}
.lib_reference_complete_test <- function(reference, data, artifact, source,
progress = FALSE,
block_size = 1000L) {
block_size <- max(1L, as.integer(block_size))
query_ids <- .lib_ids(data, "sample_name")
library_ids <- .lib_ids(reference, "sample_name")
blocks <- split(
seq_len(ncol(data$spectra)),
ceiling(seq_len(ncol(data$spectra)) / block_size)
)
started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) message(sprintf(
paste0("build_lib assessment: %s/%s medoid identifying complete ",
"dataset (query=%d; reference=%d; blocks=%d)"),
artifact, source, ncol(data$spectra), ncol(reference$spectra),
length(blocks)
))
rows <- lapply(seq_along(blocks), function(i) {
idx <- blocks[[i]]
query <- if (length(idx) == ncol(data$spectra)) data else
filter_spec(data, idx)
cors <- cor_spec(query, library = reference, compute = "optimized")
top <- max_cor_named(cors)
matched_rows <- match(names(top), library_ids)
rm(cors)
expected <- as.character(query$metadata$material_class)
predicted <- as.character(reference$metadata$material_class[matched_rows])
if (isTRUE(progress)) message(sprintf(
"build_lib assessment: %s/%s medoid block %d/%d complete",
artifact, source, i, length(blocks)
))
data.table::data.table(
artifact = artifact, source = source,
spectrum_id = query_ids[idx],
technique = as.character(query$metadata$spectrum_type),
expected_class = expected, predicted_class = predicted,
correct = expected == predicted, score = as.numeric(top),
split = "complete", provenance = "complete_medoid_reference_search"
)
})
if (isTRUE(progress)) message(sprintf(
"build_lib assessment: %s/%s complete medoid search finished (%.1fs)",
artifact, source, proc.time()[["elapsed"]] - started
))
data.table::rbindlist(rows, fill = TRUE)
}
.lib_model_complete_test <- function(model, x, artifact, type, algorithm, source,
provenance) {
fill <- model$fill
if (!is_OpenSpecy(fill)) {
variables <- as.numeric(model$all_variables)
fill <- as_OpenSpecy(
variables,
spectra = matrix(
0, nrow = length(variables), ncol = 1L,
dimnames = list(NULL, "model_zero_fill")
),
metadata = data.table::data.table(sample_name = "model_zero_fill")
)
}
prediction <- match_spec(x, library = model, fill = fill)
predicted <- if ("name" %in% names(prediction)) {
as.character(prediction$name)
} else if ("predicted_name" %in% names(prediction)) {
as.character(prediction$predicted_name)
} else {
rep(NA_character_, nrow(prediction))
}
expected <- as.character(x$metadata$material_class)
technique <- if ("spectrum_type" %in% names(x$metadata)) {
as.character(x$metadata$spectrum_type)
} else {
NA_character_
}
typed_expected <- paste(technique, expected, sep = "_")
use_typed <- !is.na(typed_expected) & typed_expected %in% model$class_names
expected[use_typed] <- typed_expected[use_typed]
data.table::data.table(
algorithm = algorithm, artifact = artifact, model = type, source = source,
spectrum_id = .lib_ids(x, "sample_name"), technique = technique,
expected_class = expected, predicted_class = predicted,
correct = expected == predicted,
score = if ("value" %in% names(prediction)) prediction$value else NA_real_,
split = "complete", provenance = provenance
)
}
.lib_align_model_input <- function(x, model) {
variables <- as.numeric(model$all_variables)
keep <- match(variables, x$wavenumber)
if (anyNA(keep)) {
stop("Model variables are not available on the comparison spectrum axis",
call. = FALSE)
}
out <- x
out$wavenumber <- x$wavenumber[keep]
out$spectra <- x$spectra[keep, , drop = FALSE]
out
}
.lib_identification_summary <- function(tests) {
if (nrow(tests) == 0L) return(data.table::data.table())
group_cols <- intersect(
c("algorithm", "artifact", "model", "source", "technique", "provenance"),
names(tests)
)
overall <- tests[, .(
spectra = .N, evaluated = sum(!is.na(correct)),
coverage = mean(!is.na(correct)),
overall_accuracy = if (all(is.na(correct))) NA_real_ else
mean(correct, na.rm = TRUE),
mean_score = if (all(is.na(score))) NA_real_ else mean(score, na.rm = TRUE)
), by = group_cols]
class_summary <- tests[, .(
class_accuracy = if (all(is.na(correct))) NA_real_ else
mean(correct, na.rm = TRUE),
class_spectra = .N,
class_evaluated = sum(!is.na(correct))
), by = c(group_cols, "expected_class")]
macro <- class_summary[, .(
macro_class_accuracy = if (all(is.na(class_accuracy))) NA_real_ else
mean(class_accuracy, na.rm = TRUE),
classes = .N,
evaluated_classes = sum(!is.na(class_accuracy))
), by = group_cols]
out <- merge(overall, macro, by = group_cols, all = TRUE)
data.table::setcolorder(
out,
c(group_cols, "macro_class_accuracy", "coverage", "overall_accuracy",
"spectra", "evaluated", "classes", "evaluated_classes", "mean_score")
)
out
}
.lib_confusion_table <- function(tests) {
if (!nrow(tests)) {
return(data.table::data.table(
algorithm = character(), artifact = character(), model = character(),
source = character(),
technique = character(), provenance = character(),
expected_class = character(), predicted_class = character(),
misidentified = logical(), spectra = integer(),
expected_class_spectra = integer(), expected_class_fraction = numeric()
))
}
group_cols <- intersect(
c("algorithm", "artifact", "model", "source", "technique", "provenance"),
names(tests)
)
out <- tests[, .(spectra = .N),
by = c(group_cols, "expected_class", "predicted_class")]
out[, misidentified := is.na(expected_class) | is.na(predicted_class) |
expected_class != predicted_class]
expected_groups <- c(group_cols, "expected_class")
out[, `:=`(
expected_class_spectra = as.integer(sum(spectra)),
expected_class_fraction = spectra / sum(spectra)
), by = expected_groups]
data.table::setcolorder(
out,
c(group_cols, "expected_class", "predicted_class", "misidentified",
"spectra", "expected_class_spectra", "expected_class_fraction")
)
data.table::setorderv(
out,
c(group_cols, "misidentified", "spectra", "expected_class",
"predicted_class"),
c(rep(1L, length(group_cols)), -1L, -1L, 1L, 1L), na.last = TRUE
)
out
}
.lib_assess_spec_summary <- function(x, artifact, source) {
assessed <- assess_spec(x, report = "all")
summary <- assessed[, .(
count = .N,
finding_count = sum(finding_count, na.rm = TRUE),
example_ids = paste(
head(unique(spectrum_id[status != "pass"]), 20L), collapse = "; "
)
), by = .(check, status)]
summary[, `:=`(
artifact = artifact, source = source,
spectra = ncol(x$spectra), rate = count / ncol(x$spectra)
)]
summary
}
.lib_assessment_shift_table <- function(summary) {
if (nrow(summary) == 0L) return(summary)
summary <- summary[status %in% c("error", "warning"), .(
count = sum(count, na.rm = TRUE),
finding_count = sum(finding_count, na.rm = TRUE),
example_ids = paste(unique(example_ids[nzchar(example_ids)]), collapse = "; "),
spectra = if (all(is.na(spectra))) NA_integer_ else max(spectra, na.rm = TRUE)
), by = .(artifact, source, check)]
summary[, rate := count / spectra]
if (!nrow(summary)) return(summary)
old <- summary[source == "old"]
new <- summary[source == "new"]
by <- c("artifact", "check")
out <- merge(
old, new, by = by, all = TRUE, suffixes = c("_old", "_new")
)
for (column in c("count", "finding_count", "spectra", "rate")) {
old_col <- paste0(column, "_old")
new_col <- paste0(column, "_new")
out[[paste0(column, "_shift")]] <- out[[new_col]] - out[[old_col]]
}
out$relative_rate_shift <- ifelse(
is.na(out$rate_old) | out$rate_old == 0,
NA_real_, (out$rate_new - out$rate_old) / out$rate_old
)
data.table::setorderv(
out, c("rate_shift", "artifact", "check"), c(-1L, 1L, 1L),
na.last = TRUE
)
out
}
.lib_validate_reference_build <- function(build) {
process_names <- c("cleanup", "ref_lib", "medoid", "model", "functionality")
if (!identical(names(build$assessments), process_names)) {
stop("Assessment review must contain the five ordered process groups",
call. = FALSE)
}
leaf_count <- sum(lengths(build$assessments))
if (leaf_count > 10L || any(lengths(build$assessments) == 0L)) {
stop("Assessment review must contain 1-10 nonempty process tables",
call. = FALSE)
}
leaves <- unlist(build$assessments, recursive = FALSE, use.names = TRUE)
empty <- !vapply(leaves, function(value) {
inherits(value, c("data.frame", "data.table")) && nrow(value) > 0L
}, logical(1))
if (any(empty)) {
stop("Assessment review contains empty or non-tabular leaves: ",
paste(names(leaves)[empty], collapse = ", "), call. = FALSE)
}
sparse <- unlist(lapply(names(leaves), function(name) {
value <- leaves[[name]]
if (!nrow(value)) return(character())
missing <- vapply(value, function(column) mean(is.na(column)), numeric(1L))
columns <- names(missing)[missing > 0.10]
if (!length(columns)) return(character())
paste0(name, "$", columns)
}), use.names = FALSE)
if (length(sparse)) {
stop("Assessment review contains columns with more than 10% missing ",
"values: ", paste(sparse, collapse = ", "), call. = FALSE)
}
artifacts <- c(
.lib_named_typed_objects(build$libraries),
.lib_named_typed_objects(build$medoids, prefix = "medoid_")
)
invalid <- vapply(artifacts, function(object) {
!isTRUE(suppressWarnings(check_OpenSpecy(object))) ||
any(!is.finite(object$wavenumber)) || anyDuplicated(object$wavenumber) ||
is.unsorted(object$wavenumber, strictly = TRUE) ||
ncol(object$spectra) != nrow(object$metadata)
}, logical(1))
if (any(invalid)) {
stop("Invalid OpenSpecy release artifact(s): ",
paste(names(artifacts)[invalid], collapse = ", "), call. = FALSE)
}
flat <- vapply(artifacts, function(object) {
any(vapply(seq_len(ncol(object$spectra)), function(i) {
values <- object$spectra[, i]
values <- values[is.finite(values)]
length(values) == 0L || diff(range(values)) <= 0
}, logical(1)))
}, logical(1))
if (any(flat)) {
stop("Flat or unavailable spectra remain in release artifact(s): ",
paste(names(artifacts)[flat], collapse = ", "), call. = FALSE)
}
expected <- list()
if (!is.null(build$models$logistic_regression)) {
expected$logistic_regression <- lapply(build$medoids, function(types) {
out <- names(types)
if (all(c("ftir", "raman") %in% out)) out <- c(out, "both")
out
})
}
if (!is.null(build$models$random_forest)) {
expected$random_forest <- lapply(build$libraries, names)
}
problems <- character()
if (is.null(expected$logistic_regression)) {
problems <- c(problems, "logistic_regression missing")
}
for (algorithm in names(expected)) {
for (recipe in names(expected[[algorithm]])) {
for (type in expected[[algorithm]][[recipe]]) {
model <- build$models[[algorithm]][[recipe]][[type]]
label <- paste(algorithm, recipe, type, sep = "/")
if (is.null(model)) {
problems <- c(problems, paste0(label, " missing"))
next
}
required <- c("model", "class_names", "class_num", "fill", "all_variables")
if (!all(required %in% names(model)) || !is_OpenSpecy(model$fill)) {
problems <- c(problems, paste0(label, " incomplete"))
}
if (identical(algorithm, "logistic_regression") &&
!.lib_selected_lambda_converged(model)) {
problems <- c(problems, paste0(label, " selected lambda unconverged"))
}
}
}
}
if (length(problems)) {
stop("Reference build completeness validation failed: ",
paste(problems, collapse = "; "), call. = FALSE)
}
evidence <- attr(build$assessments, "evidence", exact = TRUE)
split_manifest <- evidence$split_manifest
if (!is.null(split_manifest) && nrow(split_manifest)) {
overlap <- split_manifest[, data.table::uniqueN(split),
by = .(artifact, source, group_id)][V1 > 1L]
if (nrow(overlap)) {
stop("Assessment group leakage remains after split construction",
call. = FALSE)
}
}
invisible(build)
}
.lib_selected_lambda_converged <- function(model) {
# Full training checkpoints retain the explicit diagnostic. Release models
# intentionally omit assessment-only fields, but the retained one-lambda
# glmnet object still carries jerr, which is sufficient to validate it when
# a completed release is used as the input to a later assessment rebuild.
if (!is.null(model$selected_lambda_converged)) {
return(isTRUE(model$selected_lambda_converged))
}
error <- model$model$jerr
is.numeric(error) && length(error) == 1L && !is.na(error) && error == 0L
}
.lib_runtime_open_specy_attributes <- function() {
c(
"names", "class", "intensity_unit", "intensity_units",
"derivative_order", "baseline", "spectra_type", "transformations",
"identification_range"
)
}
.lib_keep_attributes <- function(x, keep) {
object_attributes <- attributes(x)
attributes(x) <- object_attributes[intersect(keep, names(object_attributes))]
x
}
.lib_slim_reference_object <- function(x) {
if (!is_OpenSpecy(x)) {
stop("Release sanitization requires an OpenSpecy object", call. = FALSE)
}
x <- .lib_keep_attributes(x, .lib_runtime_open_specy_attributes())
x$wavenumber <- .lib_keep_attributes(x$wavenumber, "names")
x$spectra <- .lib_keep_attributes(
x$spectra,
c("dim", "dimnames", "names", "row.names", "class", ".internal.selfref")
)
x$metadata <- .lib_keep_attributes(
x$metadata, c("names", "row.names", "class", ".internal.selfref")
)
x
}
.lib_slim_reference_collection <- function(collection) {
lapply(collection, function(recipe) {
if (is_OpenSpecy(recipe)) return(.lib_slim_reference_object(recipe))
lapply(recipe, .lib_slim_reference_object)
})
}
.lib_runtime_model_fields <- function() {
c(
"model", "model_type", "lambda_selected", "dimension_conversion",
"coefficients", "class_names", "class_num", "observation_count", "fill",
"fill_method", "variable_num", "all_variables", "variables_in"
)
}
.lib_slim_glmnet_model <- function(model, lambda_selected) {
if (!inherits(model, "glmnet")) return(model)
if (!is.numeric(lambda_selected) || length(lambda_selected) != 1L ||
!is.finite(lambda_selected) || !length(model$lambda)) {
stop("A finite selected lambda is required to slim a glmnet model",
call. = FALSE)
}
selected <- which.min(abs(model$lambda - lambda_selected))
subset_path <- function(value) {
if (is.null(value)) return(NULL)
if (is.list(value) && !inherits(value, "Matrix")) {
return(lapply(value, subset_path))
}
if (length(dim(value)) == 2L) return(value[, selected, drop = FALSE])
value[selected]
}
model$a0 <- subset_path(model$a0)
model$beta <- subset_path(model$beta)
model$dfmat <- subset_path(model$dfmat)
model$df <- subset_path(model$df)
model$lambda <- as.numeric(lambda_selected)
model$dev.ratio <- subset_path(model$dev.ratio)
if (length(model$dim) >= 2L) model$dim[[2L]] <- 1L
keep <- c(
"a0", "beta", "dfmat", "df", "dim", "lambda", "dev.ratio",
"nulldev", "npasses", "jerr", "offset", "classnames", "nobs"
)
out <- model[intersect(keep, names(model))]
class(out) <- class(model)
out
}
.lib_slim_model <- function(model) {
if (is.null(model)) return(NULL)
fields <- intersect(.lib_runtime_model_fields(), names(model))
out <- model[fields]
if (inherits(out$model, "glmnet")) {
out$model <- .lib_slim_glmnet_model(out$model, out$lambda_selected)
}
if (is_OpenSpecy(out$fill)) out$fill <- .lib_slim_reference_object(out$fill)
out
}
.lib_slim_model_collection <- function(models) {
lapply(models, function(recipes) {
lapply(recipes, function(types) lapply(types, .lib_slim_model))
})
}
.lib_release_index <- function(signature, artifact_manifest) {
files <- stats::setNames(
basename(as.character(artifact_manifest$path)),
as.character(artifact_manifest$component)
)
structure(
list(
schema = "OpenSpecy_reference_build_index_v1",
build_signature = signature,
artifacts = files,
assessments = "assessments.rds",
release_manifest = "release_manifest.rds"
),
build_signature = signature
)
}
.lib_is_release_index <- function(x) {
is.list(x) && identical(x$schema, "OpenSpecy_reference_build_index_v1") &&
is.character(x$artifacts) && length(x$artifacts) > 0L
}
.lib_load_release_index <- function(index, directory) {
artifact_path <- function(component) {
file <- index$artifacts[[component]]
if (is.null(file) || !nzchar(file)) return(NULL)
path <- file.path(directory, file)
if (!file.exists(path)) {
stop("Release index artifact is missing: ", path, call. = FALSE)
}
path
}
load_artifact <- function(component) {
path <- artifact_path(component)
if (is.null(path)) NULL else readRDS(path)
}
libraries <- stats::setNames(lapply(
intersect(c("raw", "derivative", "nobaseline"), names(index$artifacts)),
load_artifact
), intersect(c("raw", "derivative", "nobaseline"), names(index$artifacts)))
medoid_components <- intersect(
c("medoid_derivative", "medoid_nobaseline"), names(index$artifacts)
)
medoids <- stats::setNames(
lapply(medoid_components, load_artifact), sub("^medoid_", "", medoid_components)
)
models <- list(logistic_regression = list(), random_forest = list())
for (algorithm in names(models)) {
prefix <- paste0("model_", algorithm, "_")
components <- names(index$artifacts)[startsWith(names(index$artifacts), prefix)]
recipes <- sub(paste0("^", prefix), "", components)
models[[algorithm]] <- stats::setNames(lapply(components, load_artifact), recipes)
}
models <- Filter(length, models)
assessments_path <- file.path(directory, index$assessments)
assessments <- if (file.exists(assessments_path)) readRDS(assessments_path) else NULL
quarantine <- if ("quarantined_spectra" %in% names(index$artifacts)) {
load_artifact("quarantined_spectra")
} else NULL
list(
libraries = libraries, medoids = medoids, models = models,
assessments = assessments, quarantine = quarantine
)
}
.lib_promote_reference_build <- function(build, output_dir, signature, reuse,
progress = NULL, quarantine = NULL) {
release_dir <- file.path(output_dir, "releases", substr(signature, 1L, 12L))
dir.create(release_dir, recursive = TRUE, showWarnings = FALSE)
prior_manifest <- NULL
manifest_path <- file.path(release_dir, "release_manifest.rds")
if (isTRUE(reuse) && file.exists(manifest_path)) {
candidate_manifest <- tryCatch(
readRDS(manifest_path), error = function(error) NULL
)
if (inherits(candidate_manifest, c("data.frame", "data.table")) &&
identical(
attr(candidate_manifest, "build_signature", exact = TRUE),
signature
)) {
prior_manifest <- data.table::as.data.table(candidate_manifest)
}
}
release_libraries <- .lib_slim_reference_collection(build$libraries)
release_medoids <- .lib_slim_reference_collection(build$medoids)
release_models <- .lib_slim_model_collection(build$models)
model_artifacts <- list()
for (algorithm in names(release_models)) {
for (recipe in names(release_models[[algorithm]])) {
model_artifacts[[paste("model", algorithm, recipe, sep = "_")]] <-
release_models[[algorithm]][[recipe]]
}
}
logistic <- release_models$logistic_regression
if (!is.null(logistic)) {
for (recipe in intersect(c("derivative", "nobaseline"), names(logistic))) {
# Retain the historical filenames consumed by get_lib() and older clients.
model_artifacts[[paste0("model_", recipe)]] <- logistic[[recipe]]
}
}
artifacts <- c(
release_libraries,
setNames(release_medoids, paste0("medoid_", names(release_medoids))),
model_artifacts
)
if (!is.null(quarantine)) {
quarantine$manifest$release_signature <- signature
artifacts[["quarantined_spectra"]] <- quarantine
}
manifest <- lapply(names(artifacts), function(name) {
path <- file.path(release_dir, paste0(name, ".rds"))
if(is.function(progress)) {
progress(paste0("verifying/promoting release artifact: ", name))
}
verified <- .lib_verify_manifested_release_artifact(path, prior_manifest)
if (!is.null(verified)) verified else .lib_promote_rds(artifacts[[name]], path)
})
list(
directory = release_dir,
manifest = data.table::rbindlist(manifest, fill = TRUE)
)
}
.lib_verify_manifested_release_artifact <- function(path, manifest) {
if (is.null(manifest) || !file.exists(path)) return(NULL)
component <- tools::file_path_sans_ext(basename(path))
normalized <- normalizePath(path, mustWork = TRUE)
manifest_paths <- normalizePath(
as.character(manifest$path), mustWork = FALSE
)
row <- manifest[
as.character(manifest$component) == component & manifest_paths == normalized
]
if (nrow(row) != 1L || !identical(row$checksum_algorithm, "sha256")) {
return(NULL)
}
info <- file.info(path)
checksum <- .lib_sha256_file(path)
if (!identical(as.numeric(row$size), as.numeric(info$size)) ||
!identical(as.character(row$checksum), checksum)) {
return(NULL)
}
readable <- tryCatch({
readRDS(path)
TRUE
}, error = function(error) FALSE)
if (!isTRUE(readable)) return(NULL)
data.table::data.table(
component = component, status = "verified_existing",
path = normalized, size = as.numeric(info$size),
checksum_algorithm = "sha256", checksum = checksum
)
}
.lib_is_lookup_spec <- function(x) {
is.list(x) && !inherits(x, c("data.frame", "data.table")) &&
all(c("lookup", "by") %in% names(x))
}
.lib_normalize_lookup_spec <- function(x) {
if (!.lib_is_lookup_spec(x)) {
return(list(lookup = x, by = NULL, fallback_by = NULL,
fill_only = FALSE))
}
extra <- setdiff(names(x), c("lookup", "by", "fallback_by", "fill_only"))
if (length(extra) > 0L) {
stop("Explicit metadata lookup specifications only accept 'lookup', ",
"'by', 'fallback_by', and 'fill_only'", call. = FALSE)
}
if (is.null(x$by) || !is.character(x$by) || length(x$by) < 1L ||
anyNA(x$by) || any(!nzchar(x$by))) {
stop("Explicit metadata lookup 'by' must contain column names",
call. = FALSE)
}
if (!is.null(x$fallback_by) &&
(!is.character(x$fallback_by) || length(x$fallback_by) != 1L ||
is.na(x$fallback_by) || !nzchar(x$fallback_by))) {
stop("Explicit metadata lookup 'fallback_by' must be one column name",
call. = FALSE)
}
if (is.null(x$fallback_by)) x$fallback_by <- NULL
if (is.null(x$fill_only)) x$fill_only <- FALSE
if (!is.logical(x$fill_only) || length(x$fill_only) != 1L ||
is.na(x$fill_only)) {
stop("Explicit metadata lookup 'fill_only' must be TRUE or FALSE",
call. = FALSE)
}
x
}
.lib_auto_lookup_key <- function(metadata, lookup_table) {
metadata <- data.table::as.data.table(metadata)
lookup_table <- data.table::as.data.table(lookup_table)
shared <- intersect(names(metadata), names(lookup_table))
if (length(shared) == 0L) {
return(list(shared = shared, candidates = character()))
}
usable <- vapply(shared, function(col) {
metadata_values <- .lib_key_values(metadata[[col]])
lookup_values <- .lib_key_values(lookup_table[[col]], unique = FALSE)
if (length(metadata_values) == 0L || length(lookup_values) == 0L) {
return(FALSE)
}
has_overlap <- any(metadata_values %in% unique(lookup_values))
unique_lookup_keys <- !anyDuplicated(lookup_values)
has_overlap && unique_lookup_keys
}, logical(1))
list(shared = shared, candidates = shared[usable])
}
.lib_key_values <- function(x, unique = TRUE) {
values <- as.character(x)
values <- values[!is.na(values)]
values <- values[nzchar(values, keepNA = FALSE)]
if (isTRUE(unique)) values <- unique(values)
values
}
.lib_read_lookup <- function(x) {
if (is.character(x) && length(x) == 1 && file.exists(x)) {
return(data.table::fread(x))
}
data.table::as.data.table(data.table::copy(x))
}
#' @rdname lib_metadata_name_lookup
#' @export
lib_clean_name <- function(x) {
x <- iconv(as.character(x), to = "ASCII", sub = "")
x <- tolower(trimws(x))
x <- gsub("%", "perc", x, fixed = TRUE)
x <- gsub("->", "_", x, fixed = TRUE)
x <- gsub("[^a-z0-9_]+", "_", x)
x <- gsub("_+", "_", x)
x <- gsub("^_+|_+$", "", x)
x[is.na(x) | x == ""] <- "column"
x
}
#' @rdname lib_metadata_name_lookup
#' @export
lib_clean_metadata <- function(x,
name_lookup = lib_metadata_name_lookup(),
clean_values = FALSE) {
if (!is.logical(clean_values) || length(clean_values) != 1L ||
is.na(clean_values)) {
stop("'clean_values' must be TRUE or FALSE", call. = FALSE)
}
metadata <- data.table::as.data.table(data.table::copy(x))
original_names <- names(metadata)
cleaned_names <- lib_clean_name(original_names)
canonical_names <- cleaned_names
rule_priority <- rep(Inf, length(cleaned_names))
lookup <- NULL
if (!is.null(name_lookup)) {
match_without_underscores <-
attr(name_lookup, "match_without_underscores", exact = TRUE)
match_singular_plural <-
attr(name_lookup, "match_singular_plural", exact = TRUE)
if (is.null(match_without_underscores)) match_without_underscores <- TRUE
if (is.null(match_singular_plural)) match_singular_plural <- TRUE
lookup <- data.table::as.data.table(data.table::copy(name_lookup))
.lib_require_cols(lookup, "canonical_name", "metadata name lookup")
if (!"source_name" %in% names(lookup)) {
lookup$source_name <- NA_character_
}
if (!"regex" %in% names(lookup)) lookup$regex <- NA_character_
lookup <- lookup[, c("canonical_name", "source_name", "regex"),
with = FALSE]
lookup$canonical_name <- lib_clean_name(lookup$canonical_name)
exact <- !is.na(lookup$source_name)
lookup$source_name[exact] <- lib_clean_name(lookup$source_name[exact])
empty_regex <- !is.na(lookup$regex) & lookup$regex == ""
lookup$regex[empty_regex] <- NA_character_
lookup <- unique(lookup)
has_source <- !is.na(lookup$source_name)
has_regex <- !is.na(lookup$regex)
if (any(has_source == has_regex)) {
stop("Each metadata name rule must contain exactly one of ",
"'source_name' or 'regex'", call. = FALSE)
}
exact_rules <- lookup[has_source, ]
source_groups <- split(exact_rules$canonical_name,
exact_rules$source_name)
ambiguous <- names(source_groups)[vapply(
source_groups,
function(value) length(unique(value)) > 1L,
logical(1)
)]
if (length(ambiguous) > 0) {
stop("Exact metadata name aliases map to multiple canonical names: ",
paste(ambiguous, collapse = ", "), call. = FALSE)
}
matched <- match(cleaned_names, exact_rules$source_name)
found <- !is.na(matched)
canonical_names[found] <- exact_rules$canonical_name[matched[found]]
exact_is_canonical <- exact_rules$source_name ==
exact_rules$canonical_name
rule_priority[found] <- ifelse(
exact_is_canonical[matched[found]],
matched[found],
2L * nrow(exact_rules) + matched[found]
)
smart_key <- function(value) {
if (isTRUE(match_without_underscores)) {
value <- gsub("_", "", value, fixed = TRUE)
}
if (isTRUE(match_singular_plural)) value <- sub("s$", "", value)
value
}
unresolved <- !found
if (any(unresolved) &&
(isTRUE(match_without_underscores) ||
isTRUE(match_singular_plural)) &&
nrow(exact_rules) > 0L) {
rule_keys <- smart_key(exact_rules$source_name)
name_keys <- smart_key(cleaned_names)
key_groups <- split(exact_rules$canonical_name, rule_keys)
ambiguous_keys <- names(key_groups)[vapply(
key_groups,
function(value) length(unique(value)) > 1L,
logical(1)
)]
conflicting <- which(unresolved & name_keys %in% ambiguous_keys)
if (length(conflicting) > 0L) {
details <- vapply(conflicting, function(i) {
canonical <- unique(key_groups[[name_keys[i]]])
paste0("'", original_names[i], "' -> ",
paste(canonical, collapse = ", "))
}, character(1))
stop("Automatic metadata name matching is ambiguous: ",
paste(details, collapse = "; "),
". Add an exact alias or disable the relevant smart matching ",
"option.", call. = FALSE)
}
smart_match <- match(name_keys[unresolved], rule_keys)
smart_found <- !is.na(smart_match)
unresolved_rows <- which(unresolved)
rows <- unresolved_rows[smart_found]
matched_rules <- smart_match[smart_found]
canonical_names[rows] <- exact_rules$canonical_name[matched_rules]
rule_priority[rows] <- ifelse(
exact_is_canonical[matched_rules],
nrow(exact_rules) + matched_rules,
3L * nrow(exact_rules) + matched_rules
)
found[rows] <- TRUE
}
regex_rules <- lookup[has_regex, ]
regex_matches <- vector("list", length(cleaned_names))
if (nrow(regex_rules) > 0L) {
pattern_hits <- lapply(seq_len(nrow(regex_rules)), function(i) {
tryCatch(
grepl(regex_rules$regex[i], cleaned_names, perl = TRUE),
warning = function(w) {
stop("Invalid metadata name regex '", regex_rules$regex[i],
"' for '", regex_rules$canonical_name[i], "': ",
conditionMessage(w), call. = FALSE)
},
error = function(e) {
stop("Invalid metadata name regex '", regex_rules$regex[i],
"' for '", regex_rules$canonical_name[i], "': ",
conditionMessage(e), call. = FALSE)
}
)
})
for (i in seq_along(cleaned_names)) {
regex_matches[[i]] <- which(vapply(
pattern_hits,
function(hit) isTRUE(hit[i]),
logical(1)
))
}
overlapping <- which(lengths(regex_matches) > 1L)
if (length(overlapping) > 0L) {
details <- vapply(overlapping, function(i) {
rows <- regex_matches[[i]]
rules <- paste0(
"'", regex_rules$regex[rows], "' -> '",
regex_rules$canonical_name[rows], "'"
)
paste0("'", original_names[i], "' matched ",
paste(rules, collapse = ", "))
}, character(1))
stop("Multiple metadata name regular expressions matched the same ",
"column: ", paste(details, collapse = "; "),
". Make the patterns mutually exclusive.", call. = FALSE)
}
regex_found <- !found & lengths(regex_matches) == 1L
for (i in which(regex_found)) {
row <- regex_matches[[i]]
canonical_names[i] <- regex_rules$canonical_name[row]
rule_priority[i] <- 4L * nrow(exact_rules) + row
}
}
}
output_names <- unique(canonical_names)
output <- lapply(output_names, function(canonical) {
positions <- which(canonical_names == canonical)
if (!is.null(lookup)) {
positions <- positions[order(
cleaned_names[positions] != canonical,
rule_priority[positions],
positions
)]
} else {
positions <- positions[order(cleaned_names[positions] != canonical,
positions)]
}
values <- lapply(positions, function(position) metadata[[position]])
signatures <- vapply(values, function(value) {
paste(typeof(value), paste(class(value), collapse = "/"), sep = ":")
}, character(1))
if (length(unique(signatures)) > 1L ||
any(vapply(values, is.factor, logical(1)))) {
values <- lapply(values, as.character)
}
result <- values[[1]]
if (length(values) > 1L) {
for (candidate in values[-1L]) {
fill <- is.na(result) & !is.na(candidate)
result[fill] <- candidate[fill]
}
}
result
})
names(output) <- output_names
output <- data.table::as.data.table(output)
if (isTRUE(clean_values)) output <- .lib_clean_metadata_values(output)
output
}
.lib_clean_metadata_values <- function(x) {
out <- data.table::as.data.table(data.table::copy(x))
for (col in names(out)) {
value <- out[[col]]
if (!is.character(value) && !is.factor(value)) next
value <- iconv(as.character(value), to = "ASCII", sub = "")
value <- tolower(trimws(value))
value[value %in% c("", "na", "null", "not available")] <- NA_character_
data.table::set(out, j = col, value = value)
}
out
}
.lib_coalesce_joined_metadata <- function(metadata, columns,
suffixes = c(".x", ".y"),
lookup_precedence = TRUE) {
metadata <- data.table::as.data.table(metadata)
for (col in columns) {
left <- paste0(col, suffixes[[1L]])
right <- paste0(col, suffixes[[2L]])
if (!all(c(left, right) %in% names(metadata))) next
result <- metadata[[left]]
replacement <- metadata[[right]]
use_replacement <- !is.na(replacement)
if (is.character(replacement)) {
use_replacement <- use_replacement & nzchar(replacement)
}
if (!isTRUE(lookup_precedence)) {
keep_existing <- !is.na(result)
if (is.character(result)) keep_existing <- keep_existing & nzchar(result)
use_replacement <- use_replacement & !keep_existing
}
result[use_replacement] <- replacement[use_replacement]
data.table::set(metadata, j = left, value = result)
data.table::setnames(metadata, left, col)
metadata[, (right) := NULL]
}
metadata
}
.lib_require_cols <- function(x, cols, label) {
missing <- setdiff(cols, names(x))
if (length(missing) > 0) {
stop("Missing ", label, " columns: ", paste(missing, collapse = ", "),
call. = FALSE)
}
}
.lib_alert_join_report <- function(report, require_complete) {
if (nrow(report) == 0) return(invisible(NULL))
summary <- report[, .(n = sum(n)), by = .(problem, column)]
msg <- paste(apply(summary, 1, function(x) {
paste0(x[["problem"]], " in ", x[["column"]], ": ", x[["n"]])
}), collapse = "; ")
if (require_complete) stop(msg, call. = FALSE)
warning(msg, call. = FALSE)
invisible(NULL)
}
.lib_ids <- function(x, id_col) {
if (id_col %in% names(x$metadata)) return(as.character(x$metadata[[id_col]]))
colnames(x$spectra)
}
.lib_filter_excluded <- function(x, exclude_ids, id_col = "sample_name") {
exclude_ids <- as.character(exclude_ids)
metadata_cols <- intersect(
c(id_col, paste0(id_col, "_old"), "col_id"),
names(x$metadata)
)
metadata_hit <- rep(FALSE, nrow(x$metadata))
for (col in metadata_cols) {
metadata_hit <- metadata_hit |
as.character(x$metadata[[col]]) %in% exclude_ids
}
spectra_hit <- colnames(x$spectra) %in% exclude_ids
keep <- !(metadata_hit | spectra_hit)
if (!all(keep)) x <- filter_spec(x, keep)
x
}
.lib_dedupe_existing_ids <- function(x, id_col = "sample_name",
duplicate = "first") {
if (!id_col %in% names(x$metadata)) return(NULL)
ids <- as.character(x$metadata[[id_col]])
if (length(ids) != ncol(x$spectra) ||
any(is.na(ids) | !nzchar(ids))) {
return(NULL)
}
x$metadata[[id_col]] <- ids
colnames(x$spectra) <- ids
x$metadata$col_id <- ids
keep <- rep(TRUE, length(ids))
if (duplicate == "first") keep <- keep & !duplicated(ids)
if (duplicate == "remove_all") {
keep <- keep & !(duplicated(ids) | duplicated(ids, fromLast = TRUE))
}
if (!all(keep)) x <- filter_spec(x, keep)
x
}
.pam_group_ids <- function(x, id_col, k, progress = FALSE,
group_label = "group", ...) {
x <- as_OpenSpecy(x)
ids <- .lib_ids(x, id_col)
if (ncol(x$spectra) <= k) return(ids)
if (ncol(x$spectra) > 3000L) {
return(.pam_large_group_ids(
x, id_col = id_col, k = k, progress = progress,
group_label = group_label, ...
))
}
correlation_started <- proc.time()[["elapsed"]]
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: correlation starting (%s; n=%d)",
group_label, length(ids)
))
}
cors <- cor_spec(x, x, compute = "optimized")
cors[is.na(cors)] <- 0
cors <- pmax(pmin(cors, 1), -1)
diag(cors) <- 1
distance <- stats::as.dist(1 - cors)
rm(cors)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: correlation complete (%s; n=%d; %.1fs)",
group_label, length(ids),
proc.time()[["elapsed"]] - correlation_started
))
}
user_args <- list(...)
if (length(user_args) > 0L) {
if (is.null(names(user_args)) || any(names(user_args) == "")) {
stop("PAM arguments passed through '...' must be named",
call. = FALSE)
}
supported <- c(
"medoids", "nstart", "do.swap", "variant", "pamonce", "trace.lev"
)
unsupported <- setdiff(names(user_args), supported)
if (length(unsupported) > 0L) {
stop("Unsupported reduce_lib() PAM argument(s): ",
paste(unsupported, collapse = ", "), call. = FALSE)
}
}
pam_args <- list(
x = distance, k = min(k, length(ids) - 1L), diss = TRUE,
variant = "faster"
)
pam_args[names(user_args)] <- user_args
if ("pamonce" %in% names(user_args) && !"variant" %in% names(user_args)) {
pam_args$variant <- NULL
}
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM starting (%s; n=%d; k=%d; variant=%s)",
group_label, length(ids), pam_args$k,
if (is.null(pam_args$variant)) "custom" else pam_args$variant
))
}
pam_started <- proc.time()[["elapsed"]]
seed_exists <- exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
if (seed_exists) old_seed <- get(".Random.seed", envir = .GlobalEnv)
on.exit({
if (seed_exists) {
assign(".Random.seed", old_seed, envir = .GlobalEnv)
} else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
rm(".Random.seed", envir = .GlobalEnv)
}
}, add = TRUE)
set.seed(.lib_pam_seed(ids))
result <- do.call(cluster::pam, pam_args)
if (isTRUE(progress)) {
message(sprintf(
"reduce_lib: PAM complete (%s; n=%d; k=%d; %.1fs)",
group_label, length(ids), length(result$id.med),
proc.time()[["elapsed"]] - pam_started
))
}
ids[result$id.med]
}
.pam_large_group_ids <- function(x, id_col, k, progress = FALSE,
group_label = "group", samples = 5L,
sample_size = 1000L, ...) {
ids <- .lib_ids(x, id_col)
count <- length(ids)
sample_size <- min(count, max(as.integer(sample_size), 2L * k + 1L))
samples <- max(1L, as.integer(samples))
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: sampled PAM starting ",
"(%s; n=%d; k=%d; samples=%d; sample_size=%d)"),
group_label, count, k, samples, sample_size
))
}
normalized <- .lib_prune_normalize(
x$spectra, x$wavenumber, c(Inf, Inf)
)
seed_exists <- exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
if (seed_exists) old_seed <- get(".Random.seed", envir = .GlobalEnv)
on.exit({
if (seed_exists) {
assign(".Random.seed", old_seed, envir = .GlobalEnv)
} else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
rm(".Random.seed", envir = .GlobalEnv)
}
}, add = TRUE)
set.seed(.lib_pam_seed(ids))
best_indices <- integer()
best_objective <- Inf
for (sample_i in seq_len(samples)) {
sampled <- sort(sample.int(count, sample_size))
sampled_object <- filter_spec(x, sampled)
sampled_ids <- .pam_group_ids(
sampled_object, id_col = id_col, k = k, progress = FALSE,
group_label = group_label, ...
)
candidate_indices <- match(sampled_ids, ids)
correlations <- tcrossprod(
normalized, normalized[candidate_indices, , drop = FALSE]
)
correlations[!is.finite(correlations)] <- -1
correlations <- pmax(pmin(correlations, 1), -1)
objective <- sum(1 - matrixStats::rowMaxs(correlations))
if (objective < best_objective) {
best_objective <- objective
best_indices <- candidate_indices
}
rm(sampled_object, sampled_ids, correlations)
gc(verbose = FALSE, full = TRUE)
}
if (isTRUE(progress)) {
message(sprintf(
paste0("reduce_lib: sampled PAM complete ",
"(%s; n=%d; k=%d; objective=%.6g)"),
group_label, count, length(best_indices), best_objective
))
}
ids[best_indices]
}
.lib_pam_seed <- function(ids) {
hash <- digest::digest(as.character(ids), algo = "xxhash32")
as.integer(strtoi(substr(hash, 1L, 7L), base = 16L))
}
Try the OpenSpecy package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.