Nothing
tests/testthat/test-build_lib.R
In OpenSpecy: Analyze, Process, Identify, and Share Raman and (FT)IR Spectra
tiny_build_lib <- function() {
wavenumber <- seq(100, 6100, by = 100)
base_a <- dnorm(seq(-3, 3, length.out = length(wavenumber)))
base_b <- rev(cumsum(seq_along(wavenumber)) / sum(seq_along(wavenumber)))
spectra <- sapply(seq_len(8), function(i) {
if (i <= 4) base_a + i / 20 else base_b + i / 20
})
colnames(spectra) <- paste0("s", seq_len(ncol(spectra)))
as_OpenSpecy(
wavenumber,
spectra = spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
source = c("A", "B", "C", "C", "A", "B", "C", "C"),
label = c("nylon 6", "polyamides", "plastic", "missing",
"pet", "polyesters", "plastic", "missing"),
material_class = rep(c("class_a", "class_b"), each = 4),
spectrum_type = rep("ftir", 8),
intensity_units = rep("absorbance", 8)
),
attributes = list(intensity_unit = "absorbance")
)
}
reference_workflow_data_path <- function(file) {
roots <- c(
testthat::test_path("..", ".."),
Sys.getenv("GITHUB_WORKSPACE", unset = "")
)
roots <- unique(roots[nzchar(roots)])
candidates <- file.path(roots, "workflows", "data", file)
existing <- candidates[file.exists(candidates)]
testthat::skip_if(
length(existing) == 0L,
"repository-only reference workflow tables are not installed"
)
existing[[1L]]
}
test_that("make_lib_lookup_template() returns or writes deduplicated templates", {
lib <- tiny_build_lib()
template <- make_lib_lookup_template(lib, columns = "source",
add = "LibraryType")
expect_s3_class(template, "data.table")
expect_equal(sort(template$source), c("A", "B", "C"))
expect_true("LibraryType" %in% names(template))
expect_true(all(is.na(template$LibraryType)))
tmp <- tempfile(fileext = ".csv")
invisible(make_lib_lookup_template(lib, columns = "source",
add = "LibraryType", path = tmp))
expect_true(file.exists(tmp))
})
test_that("join_lib_metadata() reports incomplete and duplicate joins", {
lib <- tiny_build_lib()
lookup <- data.table::data.table(source = c("A", "B"),
LibraryType = c("type_a", "type_b"))
expect_warning(
joined <- join_lib_metadata(lib, lookup, by = "source"),
"unmatched_metadata_key"
)
expect_true(check_OpenSpecy(joined))
expect_equal(nrow(joined$metadata), ncol(joined$spectra))
expect_true("source" %in% names(joined$metadata))
expect_false(any(c("source.x", "source.y") %in% names(joined$metadata)))
expect_true("LibraryType" %in% names(joined$metadata))
expect_error(
join_lib_metadata(lib, lookup, by = "source", require_complete = TRUE),
"unmatched_metadata_key"
)
dup_lookup <- data.table::data.table(source = c("A", "A"),
LibraryType = c("x", "y"))
expect_error(join_lib_metadata(lib, dup_lookup, by = "source"),
"unique")
})
test_that("join_material_hierarchy() matches user-specified levels", {
lib <- tiny_build_lib()
hierarchy <- data.table::data.table(
material = c("nylon 6", "pet"),
material_class = c("polyamides", "polyesters"),
material_type = c("plastic", "plastic")
)
expect_warning(
joined <- join_material_hierarchy(
lib,
hierarchy = hierarchy,
key_col = "label",
levels = c("material", "material_class", "material_type"),
output_names = c(material = "joined_material",
material_class = "joined_class",
material_type = "joined_type")
),
"unmatched_hierarchy_key"
)
expect_true(check_OpenSpecy(joined))
expect_equal(joined$metadata$joined_material[1], "nylon 6")
expect_equal(joined$metadata$joined_class[2], "polyamides")
expect_equal(joined$metadata$joined_type[3], "plastic")
expect_true(is.na(joined$metadata$joined_type[4]))
})
test_that("dedupe_spec() keeps identifiers aligned", {
lib <- tiny_build_lib()
lib$spectra[, 2] <- lib$spectra[, 1]
deduped <- dedupe_spec(lib)
expect_true(check_OpenSpecy(deduped))
expect_equal(ncol(deduped$spectra), 7)
expect_identical(colnames(deduped$spectra),
deduped$metadata$sample_name)
})
test_that("build_lib() uses legacy source-stage hashes for sample_name", {
wavenumber <- seq(50, 5000, by = 5)
spectra <- cbind(
sin(wavenumber / 200) + 2,
cos(wavenumber / 250) + 2
)
colnames(spectra) <- c("raw_a", "raw_b")
lib <- as_OpenSpecy(
wavenumber,
spectra = spectra,
metadata = data.table::data.table(sample_name = colnames(spectra)),
attributes = list(intensity_unit = "absorbance")
)
legacy_hash <- function(x, range = NULL, short_value = NULL) {
x <- manage_na(x, type = "remove")
spec <- conform_spec(x, range = range, res = 8)
if (!is.null(short_value) && nrow(spec$spectra) < 3) {
return(rep(short_value, ncol(x$spectra)))
}
spec <- smooth_intens(spec)
vapply(seq_len(ncol(spec$spectra)), function(i) {
digest::digest(
list(as.integer(spec$wavenumber),
as.integer(spec$spectra[, i] * 100)),
algo = "md5"
)
}, FUN.VALUE = character(1))
}
expected <- legacy_hash(lib)
expected_old <- legacy_hash(lib, range = c(100, 4000),
short_value = "new format")
built <- build_lib(
lib,
recipes = list(raw = list()),
dedupe = TRUE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(built$metadata$sample_name, expected)
expect_equal(built$metadata$sample_name_old, expected_old)
expect_equal(colnames(built$spectra), expected)
excluded <- build_lib(
lib,
recipes = list(raw = list()),
exclude_ids = expected_old[1],
dedupe = TRUE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(excluded$metadata$sample_name, expected[2])
})
test_that("reduce_lib() returns medoid ids or reduced OpenSpecy objects", {
lib <- tiny_build_lib()
ids <- reduce_lib(lib, group_cols = "material_class", k = 2, min_n = 2,
return = "ids")
expect_equal(length(ids), 4)
reduced <- reduce_lib(lib, group_cols = "material_class", k = 2, min_n = 2)
expect_true(check_OpenSpecy(reduced))
expect_equal(ncol(reduced$spectra), 4)
})
test_that("reduce_lib() uses cluster PAM medoids and reports useful progress", {
lib <- tiny_build_lib()
ids <- .lib_ids(lib, "sample_name")
reduction_obj <- lib
reduction_obj$spectra <- make_rel(
mean_replace(lib$spectra, na.rm = TRUE), na.rm = TRUE
)
reduction_obj$spectra[!is.finite(reduction_obj$spectra)] <- 0
groups <- do.call(paste, c(lib$metadata[, "material_class", with = FALSE],
sep = "_"))
expected <- unlist(lapply(split(seq_along(groups), groups), function(idx) {
if (length(idx) <= 2L) return(ids[idx])
x <- filter_spec(reduction_obj, idx)
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)
set.seed(OpenSpecy:::.lib_pam_seed(ids[idx]))
ids[idx][cluster::pam(
distance, k = 2, diss = TRUE, variant = "faster"
)$id.med]
}), use.names = FALSE)
messages <- capture.output(
actual <- reduce_lib(
lib, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = TRUE
),
type = "message"
)
expect_equal(actual, expected)
messages <- paste(messages, collapse = "\n")
expect_match(messages, "spectra in .* groups")
expect_match(messages, "PAM group 1/2 starting")
expect_match(messages, "correlation complete")
expect_match(messages, "PAM complete")
expect_match(messages, "variant=faster")
expect_match(messages, "kept=4/8")
expect_silent(
reduce_lib(lib, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = FALSE)
)
expect_error(reduce_lib(lib, progress = NA), "'progress'")
})
test_that("oversized PAM groups use deterministic sampled correlation medoids", {
set.seed(42)
wn <- seq(800, 3200, length.out = 60)
spectra <- matrix(runif(length(wn) * 120L), nrow = length(wn))
colnames(spectra) <- paste0("large_", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(sample_name = colnames(spectra))
)
messages <- capture.output(
first <- OpenSpecy:::.pam_large_group_ids(
lib, id_col = "sample_name", k = 5L, progress = TRUE,
group_label = "test", samples = 3L, sample_size = 60L
),
type = "message"
)
second <- OpenSpecy:::.pam_large_group_ids(
lib, id_col = "sample_name", k = 5L, progress = FALSE,
group_label = "test", samples = 3L, sample_size = 60L
)
expect_identical(first, second)
expect_length(first, 5L)
expect_true(all(first %in% colnames(spectra)))
expect_match(paste(messages, collapse = "\n"), "sampled PAM complete")
})
test_that("build_model_lib() returns the model library artifact structure", {
skip_if_not_installed("glmnet")
lib <- tiny_build_lib()
model <- suppressWarnings(
build_model_lib(lib, type_col = NULL, min_n = 2, nlambda = 3)
)
expect_named(model, c("model", "model_type", "lambda_selected",
"lambda_path_complete", "selected_lambda_converged",
"convergence_error", "training_groups", "selection_metric",
"lambda_metrics", "dimension_conversion", "tests",
"coefficients", "class_names", "class_num",
"observation_count", "fill", "support",
"class_support", "fill_method", "fill_replaced",
"variable_num",
"all_variables", "variables_in"))
expect_true(is_OpenSpecy(model$fill))
expect_identical(model$model_type, "logistic_regression")
expect_identical(model$selection_metric, "macro_class_accuracy")
expect_identical(model$fill_method, "wavenumber_mean")
expect_true(all(c("lambda", "macro_class_accuracy", "overall_accuracy",
"selected", "selection_scope", "selection_rule") %in%
names(model$lambda_metrics)))
expect_true(all(c("factor_num", "name") %in%
names(model$dimension_conversion)))
expect_true(all(c("spectrum_id", "technique", "expected_class",
"predicted_class", "correct", "score", "split",
"provenance") %in% names(model$tests)))
expect_null(model$model$call)
before <- suppressWarnings(match_spec(lib, library = model))
full_bytes <- length(serialize(model$model, NULL))
slim <- OpenSpecy:::.lib_slim_model(model)
after <- suppressWarnings(match_spec(lib, library = slim))
expect_length(slim$model$lambda, 1L)
expect_lt(length(serialize(slim$model, NULL)), full_bytes)
expect_equal(after, before, tolerance = 1e-12)
})
test_that("release sanitizers retain runtime state and remove assessments", {
lib <- tiny_build_lib()
attr(lib, "derivative_order") <- "1"
attr(lib, "transformations") <- list(list(method = "derivative"))
attr(lib, "quality_control_report") <- data.table::data.table(value = 1)
attr(lib, "prune_report") <- list(summary = data.table::data.table(value = 1))
attr(lib$metadata, "join_report") <- data.table::data.table(value = 1)
slim <- OpenSpecy:::.lib_slim_reference_object(lib)
expect_true(check_OpenSpecy(slim))
expect_identical(attr(slim, "derivative_order"), "1")
expect_equal(attr(slim, "transformations"), list(list(method = "derivative")))
expect_null(attr(slim, "quality_control_report", exact = TRUE))
expect_null(attr(slim, "prune_report", exact = TRUE))
expect_null(attr(slim$metadata, "join_report", exact = TRUE))
expect_identical(colnames(slim$spectra), slim$metadata$sample_name)
model <- list(
model = structure(list(), class = "mock_model"),
model_type = "logistic_regression", lambda_selected = 0.1,
dimension_conversion = data.table::data.table(factor_num = 1L, name = "a"),
coefficients = data.table::data.table(), class_names = "a", class_num = 1L,
observation_count = 8L, fill = lib, fill_method = "wavenumber_mean",
variable_num = nrow(lib$spectra), all_variables = lib$wavenumber,
variables_in = lib$wavenumber,
tests = data.table::data.table(correct = TRUE),
lambda_metrics = data.table::data.table(lambda = 0.1),
support = data.table::data.table(spectrum_id = "s1")
)
attr(model, "training_warnings") <- "diagnostic warning"
slim_model <- OpenSpecy:::.lib_slim_model(model)
expect_true(all(names(slim_model) %in%
OpenSpecy:::.lib_runtime_model_fields()))
expect_false(any(c("tests", "lambda_metrics", "support") %in%
names(slim_model)))
expect_null(attr(slim_model, "training_warnings", exact = TRUE))
expect_true(check_OpenSpecy(slim_model$fill))
expect_null(attr(slim_model$fill, "quality_control_report", exact = TRUE))
expect_true(OpenSpecy:::.lib_selected_lambda_converged(list(
model = structure(list(jerr = 0L), class = "glmnet")
)))
expect_false(OpenSpecy:::.lib_selected_lambda_converged(list(
model = structure(list(jerr = -3L), class = "glmnet")
)))
expect_false(OpenSpecy:::.lib_selected_lambda_converged(list(
model = structure(list(jerr = 0L), class = "glmnet"),
selected_lambda_converged = FALSE
)))
})
test_that("official builders can opt into host workers without changing defaults", {
previous <- options("OpenSpecy.build_workers")
on.exit(options(previous), add = TRUE)
options(OpenSpecy.build_workers = NULL)
expect_identical(OpenSpecy:::.lib_build_workers(), 1L)
options(OpenSpecy.build_workers = 8L)
expect_identical(OpenSpecy:::.lib_build_workers(), 8L)
options(OpenSpecy.build_workers = -1L)
expect_identical(OpenSpecy:::.lib_build_workers(), 1L)
})
test_that("build_model_lib() trains and deploys a balanced probability random forest", {
skip_if_not_installed("ranger")
lib <- tiny_build_lib()
lib$spectra[1:3, 1] <- NA_real_
lib$metadata$material_class <- c(rep("class_a", 6), rep("class_b", 2))
model <- build_model_lib(
lib, type_col = NULL, min_n = 2, method = "random_forest",
num.trees = 30L, min.node.size = 1L, mtry = 4L
)
expect_identical(model$model_type, "random_forest")
expect_s3_class(model$model, "ranger")
expect_true(model$fill_replaced >= 3L)
expect_true(all(c("accuracy", "macro_class_accuracy", "mean_score",
"brier_score") %in% names(model$oob_metrics)))
expect_true(all(c("wavenumber", "importance") %in%
names(model$feature_importance)))
expect_equal(model$class_weights$weight, c(2 / 3, 2))
expect_true(all(model$class_weights$application == "case_sampling"))
expect_identical(
model$training_parameters$balance_method,
"inverse_frequency_case_sampling"
)
expect_identical(model$training_parameters$num_threads, 1L)
expect_equal(nrow(model$tests), ncol(lib$spectra))
prediction <- suppressWarnings(match_spec(lib, library = model))
expect_equal(nrow(prediction), ncol(lib$spectra))
expect_true(all(prediction$name %in% c("class_a", "class_b")))
})
test_that("official model building records fit warnings and progress", {
lib <- tiny_build_lib()
messages <- character()
local_mocked_bindings(
train_spec_model = function(...) {
warning("mock convergence warning", call. = FALSE)
list(
observation_count = 4L, class_num = 2L,
lambda_selected = 0.1
)
},
.package = "OpenSpecy"
)
result <- OpenSpecy:::.lib_build_models(
libraries = list(),
medoids = list(derivative = list(nir = lib)),
report = function(message) messages <<- c(messages, message)
)
expect_identical(
result$warnings,
data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative", model = "nir",
warning = "mock convergence warning"
)
)
expect_identical(
attr(result$models$logistic_regression$derivative$nir,
"training_warnings"),
"mock convergence warning"
)
expect_true(any(grepl("model warning", messages, fixed = TRUE)))
expect_true(any(grepl("model complete", messages, fixed = TRUE)))
})
test_that("official random forests train on full libraries rather than medoids", {
skip_if_not_installed("ranger")
base <- tiny_build_lib()
full <- base
full$spectra <- do.call(cbind, lapply(1:3, function(copy) {
values <- base$spectra + copy / 1000
colnames(values) <- paste0(colnames(values), "_", copy)
values
}))
full$metadata <- data.table::rbindlist(lapply(1:3, function(copy) {
metadata <- data.table::copy(base$metadata)
metadata$sample_name <- paste0(metadata$sample_name, "_", copy)
metadata
}))
full <- as_OpenSpecy(full)
result <- OpenSpecy:::.lib_build_models(
libraries = list(raw = list(ftir = full)), medoids = list(),
report = function(...) NULL,
methods = "random_forest",
random_forest_args = list(num.trees = 20L, min.node.size = 1L, mtry = 4L)
)
model <- result$models$random_forest$raw$ftir
expect_identical(model$model_type, "random_forest")
expect_equal(model$observation_count, ncol(full$spectra))
expect_equal(model$training_parameters$num_trees, 20L)
})
test_that("typed random forests do not repeat FTIR and Raman in a combined fit", {
lib <- tiny_build_lib()
local_mocked_bindings(
train_spec_model = function(x, ...) {
list(
model_type = "random_forest",
observation_count = ncol(x$spectra), class_num = 2L,
fill_replaced = 0L,
oob_metrics = data.table::data.table(macro_class_accuracy = 0.5),
training_parameters = data.table::data.table(
num_trees = 20L, mtry = 2L
)
)
},
.package = "OpenSpecy"
)
result <- OpenSpecy:::.lib_build_models(
libraries = list(raw = list(ftir = lib, raman = lib)),
medoids = list(), report = function(...) NULL,
methods = "random_forest"
)
expect_named(result$models$random_forest$raw, c("ftir", "raman"))
})
test_that("build_lib() applies named recipes to merged sources", {
lib <- tiny_build_lib()
built <- build_lib(
list(lib),
recipes = list(raw = list(),
relative = function(x) make_rel(x, na.rm = TRUE)),
dedupe = FALSE,
signal_noise = FALSE
)
expect_named(built, c("raw", "relative"))
expect_true(check_OpenSpecy(built$raw))
expect_true(check_OpenSpecy(built$relative))
})
test_that("build_lib() requires explicit source inputs", {
expect_error(
build_lib(),
"'x' must specify the source library file path"
)
})
test_that("build_lib() converts metadata intensity units before recipes", {
lib <- tiny_build_lib()
lib$spectra <- matrix(
rep(c(50, 25, 0.5, 0.25, 2), each = nrow(lib$spectra)),
nrow = nrow(lib$spectra),
dimnames = list(NULL, paste0("u", 1:5))
)
lib$spectra[1, 2] <- NA_real_
lib$metadata <- data.table::data.table(
sample_name = colnames(lib$spectra),
intensity_units = c(
"Reflectance (%)", "transmittance", "absorbance", "mystery", NA
)
)
attr(lib, "intensity_unit") <- NULL
original <- lib$spectra
expect_warning(
built <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"skipped 2 spectrum/s.*<missing> \\(1\\).*mystery \\(1\\)|skipped 2 spectrum/s.*mystery \\(1\\).*<missing> \\(1\\)"
)
expect_equal(
built$spectra[, 1],
adj_intens(original[, 1], type = "reflectance", make_rel = FALSE)
)
expect_equal(
built$spectra[, 2],
adj_intens(
original[, 2], type = "transmittance", make_rel = FALSE,
na.rm = TRUE
)
)
expect_equal(built$spectra[, 3:5], original[, 3:5])
expect_equal(
built$metadata$intensity_units,
c("absorbance", "absorbance", "absorbance", "mystery", NA)
)
expect_null(attr(built, "intensity_unit"))
expect_true(check_OpenSpecy(built))
})
test_that("build_lib() treats intensity_unit attribute as primary truth", {
lib <- tiny_build_lib()
lib$spectra[,] <- 50
lib$metadata$intensity_units <- "transmittance"
attr(lib, "intensity_unit") <- "reflectance"
built <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE
)$raw
expect_equal(
built$spectra,
adj_intens(lib$spectra, type = "reflectance", make_rel = FALSE)
)
expect_equal(built$metadata$intensity_units, rep("absorbance", 8))
expect_equal(attr(built, "intensity_unit"), "absorbance")
attr(lib, "intensity_unit") <- "absorbance"
unchanged <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE
)$raw
expect_equal(unchanged$spectra, lib$spectra)
expect_equal(unchanged$metadata$intensity_units, rep("absorbance", 8))
})
test_that("build_lib() can preserve declared intensity units", {
lib <- tiny_build_lib()
lib$spectra[,] <- 50
lib$metadata$intensity_units <- "reflectance"
attr(lib, "intensity_unit") <- "reflectance"
built <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE
)$raw
expect_equal(built$spectra, lib$spectra)
expect_equal(built$metadata$intensity_units, rep("reflectance", 8))
expect_equal(attr(built, "intensity_unit"), "reflectance")
lib$metadata$intensity_units <- "transmittance"
preserved <- build_lib(
lib,
recipes = list(raw = list()),
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(preserved$spectra, lib$spectra)
expect_equal(preserved$metadata$intensity_units, rep("transmittance", 8))
expect_equal(attr(preserved, "intensity_unit"), "reflectance")
})
test_that("build_lib() accepts and restricts one OpenSpecy object", {
lib <- tiny_build_lib()
expect_message(
built <- build_lib(
lib,
recipes = list(raw = list()),
restrict_range_args = list(
min = c(100, 2500),
max = c(2000, 4000)
),
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"using one in-memory OpenSpecy source"
)
keep <- lib$wavenumber <= 2000 |
(lib$wavenumber >= 2500 & lib$wavenumber <= 4000)
expect_equal(built$wavenumber, lib$wavenumber[keep])
expect_equal(built$spectra, lib$spectra[keep, , drop = FALSE])
expect_silent(build_lib(
lib,
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
))
expect_error(
build_lib(list(lib), restrict_range_args = list(c(100, 2000))),
"named list"
)
})
test_that("build_lib() reads one or many OpenSpecy objects from each RDS", {
left <- filter_spec(tiny_build_lib(), 1:2)
right <- filter_spec(tiny_build_lib(), 3:4)
single_file <- tempfile(fileext = ".rds")
list_file <- tempfile(fileext = ".RDS")
invalid_file <- tempfile(fileext = ".rds")
saveRDS(left, single_file)
saveRDS(list(left, right), list_file)
saveRDS(list(left, "not OpenSpecy"), invalid_file)
single <- build_lib(
single_file,
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
combined <- build_lib(
list_file,
recipes = list(raw = list()),
range = NULL,
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(single$spectra, left$spectra)
expect_equal(ncol(combined$spectra), 4)
expect_equal(combined$metadata$sample_name, paste0("s", 1:4))
expect_error(
build_lib(invalid_file, progress = FALSE),
"File path 1 must contain one OpenSpecy object or a nonempty list"
)
})
test_that("build_lib() bulk-prepares legacy same-axis source lists", {
lib <- tiny_build_lib()
sources <- split_spec(list(lib))
sources <- lapply(sources, function(x) {
x$spectra <- data.table::as.data.table(x$spectra)
x
})
expect_silent(
built <- build_lib(
sources,
recipes = list(raw = list()),
range = NULL,
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
)
expect_equal(built$wavenumber, lib$wavenumber)
expect_equal(built$spectra, lib$spectra)
expect_equal(built$metadata$sample_name, lib$metadata$sample_name)
})
test_that("build_lib() converts each source before merging", {
left <- filter_spec(tiny_build_lib(), 1:2)
right <- filter_spec(tiny_build_lib(), 3:4)
left$spectra[,] <- 50
right$spectra[,] <- 0.5
attr(left, "intensity_unit") <- "reflectance"
attr(right, "intensity_unit") <- NULL
right$metadata$intensity_units <- "transmittance"
built <- build_lib(
list(left, right),
recipes = list(raw = list()),
range = NULL,
dedupe = FALSE,
signal_noise = FALSE
)$raw
expected <- cbind(
adj_intens(left$spectra, type = "reflectance", make_rel = FALSE),
adj_intens(right$spectra, type = "transmittance", make_rel = FALSE)
)
colnames(expected) <- colnames(built$spectra)
expect_equal(built$spectra, expected)
expect_equal(attr(built, "intensity_unit"), "absorbance")
expect_equal(built$metadata$intensity_units, rep("absorbance", 4))
})
test_that("metadata name helpers support smart and extensible matching", {
expect_equal(
lib_clean_name(c(" User Name ", "Laser (%)", "Method...3")),
c("user_name", "laser_perc", "method_3")
)
name_lookup <- lib_metadata_name_lookup(
campaign_code = "campaign id",
project_code = character(),
review_note = character(),
regex = list(instrument_mode = "^method_[0-9]+$")
)
expect_false(any(c("username", "samplename", "librarytype") %in%
name_lookup$source_name, na.rm = TRUE))
metadata <- data.table::data.table(
UserName = c("alias_a", NA),
user_name = c(NA, "canonical_b"),
ProjectCodes = c("p1", "p2"),
`Review Notes` = c("check", "keep"),
Campaign.ID = c("campaign_a", "campaign_b"),
Method.42 = c("ftir", "raman")
)
cleaned <- lib_clean_metadata(metadata, name_lookup)
expect_equal(cleaned$user_name, c("alias_a", "canonical_b"))
expect_equal(cleaned$project_code, c("p1", "p2"))
expect_equal(cleaned$campaign_code, c("campaign_a", "campaign_b"))
expect_equal(cleaned$review_note, c("check", "keep"))
expect_equal(cleaned$instrument_mode, c("ftir", "raman"))
expect_false("campaign_id" %in% names(cleaned))
cleaned_values <- lib_clean_metadata(
data.table::data.table(
Organization = c(" Monterey Bay Aquarium Research Institute ", "NULL"),
SpectrumType = c("Raman", " not available "),
numeric_value = c(1, 2)
),
clean_values = TRUE
)
expect_equal(
cleaned_values$organization,
c("monterey bay aquarium research institute", NA)
)
expect_equal(cleaned_values$spectrum_type, c("raman", NA))
expect_equal(cleaned_values$numeric_value, c(1, 2))
strict_lookup <- lib_metadata_name_lookup(
project_code = character(),
defaults = FALSE,
match_without_underscores = FALSE,
match_singular_plural = FALSE
)
strict <- lib_clean_metadata(
data.table::data.table(ProjectCodes = "p1"),
strict_lookup
)
expect_named(strict, "projectcodes")
})
test_that("metadata harmonization coalesces reviewed aliases only", {
metadata <- data.table::data.table(
spectrum_identity = c("canonical", NA),
interpretation = c("ignored", "interpreted"),
form_factor = c("film", NA),
shape = c(NA, "fiber"),
datatype = c("absorbance", "raman shift"),
xunits = c("cm-1", NA),
x_unit = c(NA, "1/cm"),
spectrumid = c("a", "b"),
locationdescription = c("left", "right"),
name = c("source name", "source name 2"),
names = c("other meaning", "other meaning 2"),
file = c("raw path", "raw path 2"),
file_name = c("display", "display 2"),
sample = c("source sample", "source sample 2"),
sample_name = c("stable-a", "stable-b")
)
cleaned <- lib_clean_metadata(metadata)
expect_equal(cleaned$spectrum_identity, c("canonical", "interpreted"))
expect_equal(cleaned$material_form, c("film", "fiber"))
expect_equal(cleaned$data_type, c("absorbance", "raman shift"))
expect_equal(cleaned$wavenumber_units, c("cm-1", "1/cm"))
expect_equal(cleaned$spectrum_id, c("a", "b"))
expect_equal(cleaned$location_description, c("left", "right"))
expect_true(all(c("name", "names", "file", "file_name", "sample",
"sample_name") %in% names(cleaned)))
})
test_that("metadata regex lookup reports overlapping patterns", {
name_lookup <- lib_metadata_name_lookup(
defaults = FALSE,
regex = list(
campaign = "^campaign",
identifier = "_id$"
)
)
expect_error(
lib_clean_metadata(
data.table::data.table(Campaign.ID = "campaign_a"),
name_lookup
),
"Multiple metadata name regular expressions.*Campaign.ID"
)
})
test_that("build_lib() cleans and coalesces metadata column names", {
lib <- tiny_build_lib()
lib$metadata[["UserName"]] <- c("alias_a", "alias_b", rep(NA, 6))
lib$metadata[["user name"]] <- c(NA, "canonical_b", rep(NA, 6))
lib$metadata[["NumberofAccumulations"]] <- c(10L, rep(NA_integer_, 7))
lib$metadata[["Number of sample scans"]] <- c(20L, 30L,
rep(NA_integer_, 6))
lib$metadata[["CAS REGISTRY NO"]] <- rep("25038-54-4", 8)
lib$metadata[["Laser (%)"]] <- rep(75, 8)
name_lookup <- lib_metadata_name_lookup(project_code = "Campaign ID")
lib$metadata[["Campaign.ID"]] <- rep("campaign_a", 8)
built <- build_lib(
list(lib),
recipes = list(raw = list()),
metadata_name_lookup = name_lookup,
dedupe = FALSE,
signal_noise = FALSE
)$raw
expect_true(all(grepl("^[a-z0-9]+(?:_[a-z0-9]+)*$",
names(built$metadata))))
expect_equal(built$metadata$user_name[1:2],
c("alias_a", "canonical_b"))
expect_equal(built$metadata$number_of_accumulations[1:2], c(10L, 30L))
expect_equal(built$metadata$cas_number, rep("25038-54-4", 8))
expect_equal(built$metadata$laser_perc, rep(75, 8))
expect_equal(built$metadata$project_code, rep("campaign_a", 8))
expect_false(any(c("username", "numberofaccumulations",
"number_of_sample_scans") %in% names(built$metadata)))
})
test_that("source metadata invalid bytes are normalized before merging", {
invalid <- rawToChar(as.raw(c(0x66, 0x80, 0x6f)))
Encoding(invalid) <- "unknown"
expect_false(validUTF8(invalid))
normalized <- OpenSpecy:::.lib_normalize_metadata_encoding(
data.table::data.table(value = invalid)
)
expect_true(validUTF8(normalized$value))
expect_equal(normalized$value, "fo")
})
test_that("build_lib() runs default joins, processing, SNR, and assessment", {
lib <- tiny_build_lib()
lib$spectra[1, 1] <- -1
source_lookup <- data.table::data.table(
Source = c("A", "B", "C"),
Material = c("mat_a", "mat_b", "mat_c")
)
hierarchy <- data.table::data.table(
Material = c("mat_a", "mat_b", "mat_c"),
`Material Class` = c("class_a", "class_b", "class_c"),
`Material Type` = rep("material", 3)
)
built <- suppressWarnings(build_lib(
list(lib),
metadata_lookups = source_lookup,
material_hierarchy = hierarchy,
assess = TRUE,
dedupe = FALSE
))
expect_named(built, c("raw", "derivative", "nobaseline"))
expect_true(all(vapply(built, check_OpenSpecy, logical(1))))
expect_true(all(c("material", "material_class", "material_type", "sn",
"assessment_flag", "assessment_issue_count",
"assessment_checks", "assessment_issues",
"assessment_potential_fixes") %in%
names(built$raw$metadata)))
expect_equal(attr(built$derivative, "derivative_order"), "1")
expect_equal(attr(built$nobaseline, "baseline"), "nobaseline")
expect_true(built$raw$metadata$assessment_flag[1])
})
test_that("build_lib() skips metadata lookups with no shared key", {
lib <- tiny_build_lib()
no_shared <- data.table::data.table(
missing_key = "not_present",
joined_value = "skipped"
)
no_overlap <- data.table::data.table(
source = "Z",
joined_value = "skipped"
)
output_overlap <- data.table::data.table(
source = c("A", "B", "C"),
library_type = c("polymers", "polymers", "paints"),
spectrum_type = c("ftir", "raman", "ftir")
)
ambiguous <- data.table::data.table(
source = "A",
sample_name = "s1",
joined_value = "ambiguous"
)
expect_message(
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = no_shared,
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"skipping metadata lookup 1/1"
)
expect_false("joined_value" %in% names(built$metadata))
expect_message(
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = no_overlap,
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"no usable shared key values"
)
expect_false("joined_value" %in% names(built$metadata))
lib$metadata$library_type <- c("polymers", "paints", "polymers", "paints",
"polymers", "paints", "polymers", "paints")
lib$metadata$spectrum_type <- "Raman"
bad_utf8 <- rawToChar(as.raw(0xff))
Encoding(bad_utf8) <- "UTF-8"
lib$metadata$library_type[1] <- bad_utf8
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = output_overlap,
dedupe = FALSE,
signal_noise = FALSE,
clean_metadata_values = TRUE,
progress = FALSE
)$raw
expect_false(any(c("library_type.x", "library_type.y",
"spectrum_type.x", "spectrum_type.y") %in%
names(built$metadata)))
expect_equal(built$metadata$library_type[1:3],
c("polymers", "polymers", "paints"))
expect_equal(built$metadata$spectrum_type[1:3],
c("ftir", "raman", "ftir"))
expect_error(
build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = ambiguous,
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
),
"Candidate columns were"
)
})
test_that("build_lib() standardizes source keys before external lookups", {
lib <- filter_spec(tiny_build_lib(), 1:3)
lib$metadata$organization <- c("source org", NA, NA)
lib$metadata$user_name <- c("known", "fallback user", "unmapped")
lib$metadata$library_type <- c("metadata type", NA, NA)
source_lookup <- data.table::data.table(
organization = c("source org", "fallback user"),
library_type = c("organization type", "user type"),
spectrum_type = "raman"
)
built <- suppressWarnings(build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = list(
lookup = source_lookup,
by = "organization",
fill_only = TRUE
),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw)
expect_equal(built$metadata$library_type,
c("metadata type", "user type", NA))
expect_equal(built$metadata$spectrum_type, rep("ftir", 3))
expect_equal(built$metadata$organization,
c("source org", "fallback user", "unmapped"))
expect_equal(built$metadata$library_name,
c("source org", "fallback user", "unmapped"))
expect_equal(
attr(built, "metadata_lookup_reports")$canonical_source_keys[
problem == "filled_canonical_key", n
],
2L
)
})
test_that("build_lib() cleans filename-derived spectrum identities and keys", {
lib <- tiny_build_lib()
lib$metadata$spectrum_identity <- c(
"C:\\incoming\\Sample.CSV", "/tmp/Other.SPC",
"relative/folder/Third.HDF5", "compound pe/pa/pe",
"name.spc.csv", "plain identity", "opus.10", "unsupported.foo"
)
lookup <- data.table::data.table(
spectrum_identity = c(
"sample.csv", "other.spc", "third.hdf5", "compound pe/pa/pe",
"name", "plain identity", "opus.10", "unsupported.foo"
),
material = paste0("material_", seq_len(8))
)
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = list(lookup = lookup, by = "spectrum_identity"),
dedupe = FALSE,
signal_noise = FALSE,
clean_metadata_values = TRUE,
progress = FALSE
)$raw
expect_identical(
built$metadata$spectrum_identity,
c("sample", "other", "third", "compound pe/pa/pe", "name",
"plain identity", "opus", "unsupported.foo")
)
expect_identical(built$metadata$material, lookup$material)
report <- attr(built, "spectrum_identity_cleanup_report")
expect_s3_class(report, "data.table")
expect_equal(sum(report$n), 5L)
expect_true(all(c("original", "spectrum_identity", "n") %in%
names(report)))
})
test_that("build_lib() rejects lookup collisions after identity cleanup", {
lib <- tiny_build_lib()
lib$metadata$spectrum_identity <- rep("same", 8)
lookup <- data.table::data.table(
spectrum_identity = c("same.csv", "same.spc"),
material = c("first", "second")
)
expect_error(
build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = list(lookup = lookup, by = "spectrum_identity"),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
),
"Lookup keys must be unique"
)
})
test_that("prune_lib() orders classes, preserves floors, and audits removals", {
wn <- seq(500, 3500, length.out = 80)
shape_a <- dnorm(seq(-3, 3, length.out = length(wn)))
shape_b <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1)
spectra <- cbind(
shape_a, shape_a * 1.01, shape_a * 0.99, shape_a + 0.002,
shape_b,
shape_b * 1.01, shape_b * 0.99, shape_b + 0.002,
rev(shape_a), rev(shape_a) * 1.01
)
colnames(spectra) <- paste0("id", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(rep("large", 5), rep("medium", 3), rep("small", 2)),
material_type = "plastic",
spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 2, return = "report", progress = FALSE)
expect_true(check_OpenSpecy(report$object))
expect_equal(report$schedule$material_class, c("large", "medium", "small"))
expect_equal(report$schedule$initial_n, c(5L, 3L, 2L))
expect_true(nrow(report$removals) >= 1)
expect_equal(report$summary$reassigned, 0L)
expect_equal(nrow(report$excluded_classes), 0L)
expect_named(
report$excluded_classes,
names(OpenSpecy:::.lib_prune_excluded_class_schema())
)
expect_true(all(table(report$object$metadata$material_class) >= 2))
expect_identical(colnames(report$object$spectra),
report$object$metadata$sample_name)
expect_identical(report$retained_ids, colnames(report$object$spectra))
query <- which(lib$metadata$material_class == "large")
candidates <- seq_len(ncol(lib$spectra))
normalized <- OpenSpecy:::.lib_prune_normalize(
lib$spectra, lib$wavenumber, c(2200, 2420)
)
legacy <- OpenSpecy:::.lib_prune_correlations(
lib, query, candidates, c(2200, 2420), lib$metadata$sample_name
)
actual <- OpenSpecy:::.lib_prune_best_match(
query, candidates, normalized, lib$metadata$sample_name,
exclude_self = TRUE, block_size = 2L
)
bounded_full <- OpenSpecy:::.lib_prune_best_match(
query, candidates, normalized, lib$metadata$sample_name,
exclude_self = TRUE, block_size = length(query)
)
expect_equal(actual, bounded_full)
# Proportional synthetic spectra create several effectively exact ties.
# The bounded implementation deliberately resolves those ties by stable ID;
# BLAS operation shape can make the legacy full matrix select a different
# tied column. Verify that every bounded choice has the same scientific score.
legacy_best <- matrixStats::rowMaxs(legacy)
actual_columns <- match(actual$index, candidates)
legacy_at_actual <- legacy[cbind(seq_along(query), actual_columns)]
tolerance <- sqrt(.Machine$double.eps) * pmax(1, abs(legacy_best))
expect_true(all(abs(legacy_at_actual - legacy_best) <= tolerance))
})
test_that("cross-class pruning closes internal conflicts before independent evidence", {
normalized <- rbind(
high = c(1, 0, 0, 0),
b_l2 = c(1, 0, 0, 0),
b_l3 = c(1, 0, 0, 0),
tie_c = c(0, 1, 0, 0),
tie_d = c(0, 1, 0, 0),
same_source_e = c(0, 0, 1, 0),
same_source_f = c(0, 0, 1, 0),
generic = c(1, 0, 0, 0)
)
ids <- rownames(normalized)
classes <- c("class_a", "class_b", "class_b", "class_c", "class_d",
"class_e", "class_f", "other plastic")
libraries <- c("lib_1", "lib_2", "lib_3", "lib_4", "lib_5",
"lib_6", "lib_6", "lib_7")
pools <- rep("infrared", length(ids))
first <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes, pools, normalized, ids, libraries, threshold = 0.9,
block_size = 2L
)
second <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes, pools, normalized, ids, libraries, threshold = 0.9,
block_size = 5L
)
expect_identical(first$removed_rows, c(1L, 4L, 5L, 6L, 7L))
expect_equal(first$removals, second$removals)
expect_equal(first$removals[spectrum_id == "high", evidence_libraries], 2L)
expect_equal(first$removals[spectrum_id == "high", decision_round], 1L)
expect_true(all(
first$removals[spectrum_id %in% c("tie_c", "tie_d"), reason] ==
"cross_class_equal_library_evidence"
))
expect_true(all(
first$removals[spectrum_id %in% c("same_source_e", "same_source_f"),
phase] == "internal"
))
expect_true(all(
first$removals[spectrum_id %in% c("same_source_e", "same_source_f"),
reason] == "cross_class_equal_internal_degree"
))
expect_false("generic" %in% first$removals$spectrum_id)
})
test_that("internal cross-class majority removes the active high-degree spectrum", {
normalized <- rbind(
suspect = c(1, 0, 0, 0),
reference_1 = c(1, 0, 0, 0),
reference_2 = c(1, 0, 0, 0),
reference_3 = c(1, 0, 0, 0),
tie_a = c(0, 1, 0, 0),
tie_b = c(0, 1, 0, 0)
)
first <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", rep("class_b", 3), "class_c", "class_d"),
pools = rep("ftir", 6), normalized = normalized,
ids = rownames(normalized), library_names = rep("one_library", 6),
threshold = 0.9, min_n = 1, block_size = 2L
)
second <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", rep("class_b", 3), "class_c", "class_d"),
pools = rep("ftir", 6), normalized = normalized,
ids = rownames(normalized), library_names = rep("one_library", 6),
threshold = 0.9, min_n = 1, block_size = 5L
)
expect_identical(first$removed_rows, c(1L, 5L, 6L))
expect_equal(first$removals, second$removals)
expect_equal(first$removals[spectrum_id == "suspect", active_degree], 3L)
expect_equal(first$removals[spectrum_id == "suspect", decision_round], 1L)
expect_true(all(first$removals[spectrum_id %in% c("tie_a", "tie_b"),
decision_round] == 2L))
})
test_that("internal cross-class support counts span the complete database", {
normalized <- rbind(
a_source_1 = c(1, 0, 0, 0),
b_source_1a = c(1, 0, 0, 0),
b_source_1b = c(1, 0, 0, 0),
a_source_2 = c(0, 0, 1, 0),
a_source_3 = c(0, 0, 0, 1)
)
result <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", "class_b", "class_b", "class_a", "class_a"),
pools = rep("ftir", 5), support_groups = rep("ftir", 5),
normalized = normalized, ids = rownames(normalized),
library_names = c("lib_1", "lib_1", "lib_1", "lib_2", "lib_3"),
threshold = 0.9, min_n = 2
)
expect_identical(result$removed_rows, 1L)
expect_equal(result$removals$class_n_before, 3L)
expect_equal(result$removals$class_n_after, 2L)
expect_equal(result$removals$review_status, "automatic")
at_risk <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", "class_b", "class_b", "class_a", "class_a"),
pools = rep("ftir", 5), support_groups = rep("ftir", 5),
normalized = normalized, ids = rownames(normalized),
library_names = c("lib_1", "lib_1", "lib_1", "lib_2", "lib_3"),
threshold = 0.9, min_n = 3
)
expect_equal(at_risk$removals$review_status, "global_support_at_risk")
})
test_that("quarantine bundles retain spectra and review metadata", {
lib <- tiny_build_lib()
lib$metadata[, `:=`(
material_class = rep(c("class_a", "class_b"), 4),
material_type = "plastic", spectrum_type = "ftir",
library_name = rep(c("lib_a", "lib_b"), 4)
)]
ids <- as.character(lib$metadata$sample_name)
removal <- OpenSpecy:::.lib_prune_cross_class_schema()[0]
removal <- data.table::data.table(
phase = "internal", correlation_view = "typed_full",
component_id = "internal:one", spectrum_id = ids[[1L]],
prior_class = "class_a", library_name = "lib_a",
matched_id = ids[[2L]], matched_class = "class_b",
matched_library = "lib_b", correlation = 0.95, pool = "ftir",
active_degree = 3L, matched_active_degree = 1L,
evidence_libraries = 0L, conflicting_spectra = 3L,
matched_evidence_libraries = 0L, decision_round = 1L,
threshold = 0.9, class_n_before = 4L, class_n_after = 3L,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "automatic",
reason = "cross_class_more_internal_conflicts"
)
part <- OpenSpecy:::.lib_quarantine_part(
lib, removal, "derivative", "ftir", min_n = 3
)
bundle <- OpenSpecy:::.lib_quarantine_bundle(
list(part), build_signature = "fixture", thresholds = 0.9
)
output <- tempfile("OpenSpecy-quarantine-review-")
dir.create(output)
on.exit(unlink(output, recursive = TRUE, force = TRUE), add = TRUE)
OpenSpecy:::.lib_write_quarantine_review(bundle, output)
restored <- readRDS(file.path(output, "review", "quarantined_spectra.rds"))
expect_s3_class(restored, "OpenSpecyQuarantine")
expect_named(restored, c("spectra", "conflicts", "manifest"))
expect_true(check_OpenSpecy(restored$spectra[["derivative/ftir"]]))
expect_equal(
restored$spectra[["derivative/ftir"]]$metadata$quarantine_reason,
"cross_class_more_internal_conflicts"
)
expect_true(all(file.exists(file.path(
output, "review",
c("quarantined_spectra_metadata.csv",
"quarantined_spectra_conflicts.csv")
))))
})
test_that("typed closure filters parents before medoid construction", {
wn <- seq(800, 3200, length.out = 60)
peak <- dnorm(seq(-3, 3, length.out = length(wn)))
other_1 <- dnorm(seq(-3, 3, length.out = length(wn)), mean = -1.5)
other_2 <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1.5)
spectra <- cbind(peak, peak * 1.01, peak * 0.99, other_1, other_2)
colnames(spectra) <- c("suspect", "b1", "b2", "a2", "a3")
parent <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c("class_a", "class_b", "class_b", "class_a", "class_a"),
material_type = "plastic", spectrum_type = "ftir",
library_name = c("lib_1", "lib_1", "lib_1", "lib_2", "lib_3")
)
)
closed <- OpenSpecy:::.lib_close_typed_reference_libraries(
list(derivative = list(ftir = parent)),
prune_spec = list(derivative = list(
cross_class = TRUE, cross_class_threshold = 0.9, min_n = 2
)),
progress = FALSE
)
expect_false("suspect" %in%
closed$libraries$derivative$ftir$metadata$sample_name)
expect_equal(unname(table(
closed$libraries$derivative$ftir$metadata$material_class
)["class_a"]), 2L)
expect_true(nrow(closed$removals) >= 1L)
expect_true(any(closed$removals$correlation_view == "typed_full"))
expect_length(closed$quarantine_parts, 1L)
expect_true(check_OpenSpecy(closed$quarantine_parts[[1L]]))
})
test_that("cross-class pruning uses a strict threshold", {
normalized <- rbind(c(1, 0), c(0.9, sqrt(1 - 0.9^2)))
args <- list(
classes = c("class_a", "class_b"), pools = c("infrared", "infrared"),
normalized = normalized, ids = c("a", "b"),
library_names = c("lib_a", "lib_b")
)
exact <- do.call(
OpenSpecy:::.lib_prune_cross_class_conflicts,
c(args, list(threshold = 0.9))
)
below <- do.call(
OpenSpecy:::.lib_prune_cross_class_conflicts,
c(args, list(threshold = 0.899))
)
expect_length(exact$removed_rows, 0L)
expect_identical(below$removed_rows, 1:2)
})
test_that("prune_lib() applies cross-class removal before generic reassignment", {
wn <- seq(500, 3500, length.out = 80)
shape <- dnorm(seq(-3, 3, length.out = length(wn)))
spectra <- cbind(shape, shape * 1.01, shape * 0.99, shape * 1.02)
colnames(spectra) <- c("suspect", "reference_1", "reference_2", "generic")
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c("class_a", "class_b", "class_b", "other plastic"),
material_type = "plastic", spectrum_type = "ftir",
library_name = c("lib_1", "lib_2", "lib_3", "lib_4")
)
)
attr(lib, "test_marker") <- "preserved"
report <- prune_lib(
lib, min_n = 1, cross_class = TRUE, cross_class_threshold = 0.9,
return = "report", progress = FALSE
)
expect_identical(report$cross_class_removals$spectrum_id, "suspect")
expect_equal(report$summary$cross_class_removed, 1L)
expect_false("suspect" %in% report$retained_ids)
expect_equal(
report$object$metadata[sample_name == "generic", material_class],
"class_b"
)
expect_identical(colnames(report$object$spectra),
report$object$metadata$sample_name)
expect_identical(report$object$wavenumber, lib$wavenumber)
expect_identical(attr(report$object, "test_marker"), "preserved")
expect_equal(report$object$spectra,
lib$spectra[, report$retained_ids, drop = FALSE])
recovered <- OpenSpecy:::.lib_recover_library_assessments(
list(derivative = report$object), list()
)
expect_equal(recovered$pruning_removals$spectrum_id, "suspect")
})
test_that("prune_lib() validates cross-class policy inputs", {
lib <- tiny_build_lib()
lib$metadata$material_type <- "plastic"
expect_error(prune_lib(lib, cross_class = NA), "TRUE or FALSE")
expect_error(prune_lib(lib, cross_class_threshold = 1.01), "in \\[0, 1\\]")
expect_error(
prune_lib(lib, cross_class = TRUE),
"requires populated library_name"
)
})
test_that("prune_lib() reassigns undersupported classes by spectrum type", {
wn <- seq(500, 3500, length.out = 40)
spectra <- vapply(seq_len(7), function(i) {
dnorm(seq(-3, 3, length.out = length(wn)), mean = i / 20)
}, numeric(length(wn)))
colnames(spectra) <- c(
"ftir_a1", "ftir_a2", "ftir_rare", "raman_rare1", "raman_rare2",
"ftir_unclassified", "ftir_missing"
)
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(
"stable", "stable", "rare", "rare", "rare", "unclassified", NA
),
material_type = "plastic",
spectrum_type = c(rep("ftir", 3), rep("raman", 2), "ftir", "ftir")
)
)
messages <- capture.output(
report <- prune_lib(
lib, min_n = 2, return = "report", progress = TRUE
),
type = "message"
)
expect_match(
paste(messages, collapse = "\n"),
"minimum support gate reassigned 1 and removed 1 spectrum/spectra"
)
expect_equal(
report$excluded_classes[, c(
"spectrum_type", "material_class", "observed_n", "minimum_spectra",
"shortfall", "destination_class", "spectra_removed", "action", "reason"
), with = FALSE],
data.table::data.table(
spectrum_type = c("ftir", "ftir"),
material_class = c("rare", "unclassified"),
observed_n = c(1L, 1L), minimum_spectra = c(2L, 2L),
shortfall = c(1L, 1L), destination_class = c("stable", NA_character_),
spectra_removed = c(0L, 1L), action = c("reassigned", "dropped"),
reason = c("class_below_min_n_reassigned",
"class_below_min_n_no_eligible_destination")
)
)
expect_true(all(c("raman_rare1", "raman_rare2") %in% report$retained_ids))
expect_true("ftir_missing" %in% report$retained_ids)
expect_true("ftir_rare" %in% report$retained_ids)
expect_false("ftir_unclassified" %in% report$retained_ids)
expect_equal(
report$object$metadata[sample_name == "ftir_rare", material_class],
"stable"
)
expect_equal(
report$reassignments[spectrum_id == "ftir_rare", reason],
"class_below_min_n_reassigned"
)
threshold_removals <- report$removals[reason == "class_below_min_n"]
expect_equal(threshold_removals$spectrum_id, "ftir_unclassified")
expect_true(all(is.na(threshold_removals$matched_id)))
expect_type(threshold_removals$matched_id, "character")
expect_equal(report$summary$classes_excluded, 1L)
expect_equal(report$summary$threshold_removed, 1L)
expect_true(check_OpenSpecy(report$object))
expect_identical(colnames(report$object$spectra),
report$object$metadata$sample_name)
recovered <- OpenSpecy:::.lib_recover_library_assessments(
list(raw = lib, derivative = report$object),
list(metadata_drop = data.table::data.table(metadata_column = character()))
)
expect_named(
recovered$pruning_excluded_classes,
names(OpenSpecy:::.lib_prune_excluded_assessment_schema())
)
expect_equal(unique(recovered$pruning_excluded_classes$artifact),
"derivative")
expect_equal(nrow(recovered$pruning_excluded_classes), 2L)
})
test_that("prune_lib() resolves generic labels before minimum support", {
wn <- seq(500, 3500, length.out = 40)
shape <- dnorm(seq(-3, 3, length.out = length(wn)))
spectra <- cbind(shape, shape * 1.01)
colnames(spectra) <- c("rare", "generic")
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c("polymer rare", "other plastic"),
material_type = "plastic", spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 2, return = "report", progress = FALSE)
expect_equal(report$object$metadata$material_class,
rep("polymer rare", 2))
expect_equal(nrow(report$reassignments), 1L)
expect_equal(nrow(report$excluded_classes), 0L)
expect_equal(report$schedule$initial_n, 2L)
})
test_that("prune_lib() sends an undersupported class to one correlated class", {
wn <- seq(500, 3500, length.out = 40)
shape_a <- dnorm(seq(-3, 3, length.out = length(wn)), mean = -0.5)
shape_b <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1)
spectra <- cbind(
shape_a, shape_a * 1.01, shape_a * 0.99,
shape_b, shape_b * 1.01, shape_b * 0.99,
shape_a * 1.02, shape_a * 0.98
)
colnames(spectra) <- paste0("whole_", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(rep("class_a", 3), rep("class_b", 3), rep("rare", 2)),
material_type = "plastic", spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 3, return = "report", progress = FALSE)
reassigned <- report$reassignments[prior_class == "rare"]
expect_equal(nrow(reassigned), 2L)
expect_identical(unique(reassigned$material_class), "class_a")
expect_true(all(report$object$metadata$sample_name %in%
colnames(lib$spectra)))
expect_false("rare" %in% report$object$metadata$material_class)
expect_equal(
report$excluded_classes[material_class == "rare", action],
"reassigned"
)
})
test_that("prune_lib() retains unclassified spectra outside matching", {
lib <- tiny_build_lib()
lib$metadata$material_type <- "plastic"
lib$metadata$material_class[1:2] <- "unclassified"
protected_ids <- lib$metadata$sample_name[1:2]
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_true(all(protected_ids %in% report$retained_ids))
expect_false("unclassified" %in% report$schedule$material_class)
expect_false(any(report$removals$prior_class == "unclassified"))
expect_false(any(report$removals$matched_class == "unclassified"))
})
test_that("prune_lib() reassigns generic classes and tolerates no candidates", {
lib <- filter_spec(tiny_build_lib(), 1:4)
lib$metadata$material_class <- c("polymer a", "other plastic",
"other material", "other plastic")
lib$metadata$material_type <- c("plastic", "plastic", "mineral", "plastic")
lib$metadata$spectrum_type <- c("ftir", "ftir", "raman", NA)
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_equal(report$object$metadata$material_class[2], "polymer a")
expect_equal(report$object$metadata$material_class[3], "other material")
expect_equal(report$object$metadata$material_class[4], "other plastic")
expect_equal(nrow(report$reassignments), 1)
expect_equal(report$summary$removed, 0L)
})
test_that("prune_lib() constrains generic reassignment and updates type", {
wn <- seq(500, 3500, length.out = 80)
plastic <- dnorm(seq(-3, 3, length.out = length(wn)))
organic <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1)
mineral <- rev(cumsum(seq_along(wn)))
spectra <- cbind(plastic, organic, mineral, plastic, organic, mineral)
colnames(spectra) <- paste0("generic", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(
"polymer a", "organic matter", "mineral",
"other plastic", "other material", "other"
),
material_type = c(
"plastic", "not plastic", "not plastic", "plastic", "not plastic",
"other"
),
spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_equal(
report$object$metadata$material_class[4:6],
c("polymer a", "organic matter", "mineral")
)
expect_equal(
report$object$metadata$material_type[4:6],
c("plastic", "not plastic", "not plastic")
)
expect_equal(nrow(report$reassignments), 3L)
expect_true(all(report$reassignments$reason == "nearest_eligible_class"))
})
test_that("prune_lib() preserves non-generic class labels and empty audits", {
lib <- filter_spec(tiny_build_lib(), 1:2)
lib$metadata$material_class <- c("Polymer A", "Polymer A")
lib$metadata$material_type <- "plastic"
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_equal(report$object$metadata$material_class,
c("Polymer A", "Polymer A"))
expect_s3_class(report$reassignments, "data.table")
expect_s3_class(report$removals, "data.table")
expect_equal(nrow(report$reassignments), 0)
expect_equal(nrow(report$removals), 0)
expect_equal(report$summary$reassigned, 0L)
expect_equal(report$summary$removed, 0L)
})
test_that("build_lib() applies pruning only to named recipes", {
lib <- tiny_build_lib()
lib$metadata$material_type <- "plastic"
built <- build_lib(
lib,
recipes = list(raw = list(), processed = list()),
prune = list(processed = list(min_n = 1, progress = FALSE)),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)
expect_null(attr(built$raw, "prune_report"))
expect_true(is.list(attr(built$processed, "prune_report")))
})
test_that("reference workflow tables encode reviewed taxonomy and source rules", {
classes <- data.table::fread(
reference_workflow_data_path("classes_reference.csv")
)
regex_classes <- data.table::fread(
reference_workflow_data_path("classes_regex.csv")
)
hierarchy <- data.table::fread(
reference_workflow_data_path("material_hierarchy.csv")
)
types <- data.table::fread(
reference_workflow_data_path("library_types.csv")
)
drops <- data.table::fread(
reference_workflow_data_path("metadata_drop_columns.csv")
)
known_bad <- data.table::fread(
reference_workflow_data_path("known_bad_ids.csv")
)
form_regex <- data.table::fread(
reference_workflow_data_path("material_form_regex.csv")
)
common_use <- data.table::fread(
reference_workflow_data_path("common_use_reference.csv")
)
expect_false(anyNA(classes$spectrum_identity))
expect_false(any(classes$spectrum_identity == ""))
expect_identical(anyDuplicated(classes$spectrum_identity), 0L)
expect_false(any(grepl(
"^([0-9]{1,2}-[A-Za-z]{3}|[A-Za-z]{3}-[0-9]{1,2})$",
classes$spectrum_identity
)))
expect_false(any(grepl("^regex:", classes$spectrum_identity)))
expect_named(regex_classes, c("pattern", "material"))
expect_false(anyNA(regex_classes$pattern))
expect_false(any(regex_classes$pattern == ""))
expect_identical(anyDuplicated(regex_classes$pattern), 0L)
class_audit <- predict_class_reference(
classes, regex_classes, return = "report"
)
expect_gte(class_audit$summary$predicted, 0L)
expect_equal(class_audit$summary$clashes, 0L)
expect_gt(class_audit$summary$overlaps, 0L)
expect_true(all(!is.na(regex_classes$material)))
expect_identical(anyDuplicated(known_bad$sample_name), 0L)
expect_true(all(grepl("^[[:xdigit:]]{32}$", known_bad$sample_name)))
expect_identical(anyDuplicated(hierarchy$material), 0L)
expect_silent(OpenSpecy:::.lib_validate_material_form_regex(form_regex))
expect_silent(OpenSpecy:::.lib_validate_common_use_reference(
common_use, hierarchy
))
expect_setequal(
common_use$material_class, unique(hierarchy$material_class)
)
expect_true(all(c("consumer", "industrial", "mixed") %in%
stats::na.omit(common_use$common_use)))
expect_equal(hierarchy[material == "other", material_class], "other")
expect_equal(hierarchy[material == "other", material_type], "other")
expect_equal(classes[spectrum_identity == "pa", material], "polyamides")
exact_classes <- classes[!grepl("^regex:", spectrum_identity)]
expect_identical(
OpenSpecy:::.lib_clean_spectrum_identity(exact_classes$spectrum_identity),
exact_classes$spectrum_identity
)
expect_true(all(
hierarchy[grepl("adipate", material), material_class] == "polyesters"
))
expect_false("polyamides (polylactams)" %in% hierarchy$material_class)
expect_true(all(c("polyamides", "polyacrylamides") %in%
hierarchy$material_class))
expect_equal(
classes[spectrum_identity == "plc004_kn95 outer layer_pp", material],
"poly(propylene)"
)
expect_equal(
classes[spectrum_identity == "plc008_label tape_unknown", material],
"other plastic"
)
expect_true(all(
classes[spectrum_identity %in% c(
"crumb rubber from used tires", "r 4. black bridgestone tire fragment",
"r 5. black michelin tire fragment", "r 6. black bike tire fragment",
"r 8. white bike tire fragment"
), material] == "styrene-butadiene"
))
expect_equal(
classes[spectrum_identity == "poly(ethylene:propylene:diene)", material],
"epdm rubber (ethylene propylene diene monomer rubber)"
)
expect_equal(
classes[spectrum_identity == "lahmian medium acrylic paint", material],
"polyacrylates"
)
expect_true(all(
classes[spectrum_identity %in% c("alkyd varnish", "alkyd_varnish"),
material] == "polyesters"
))
binder_classes <- c(
"acrylic paint" = "polyacrylates",
"acrylic-alkyd paint" = "polyesters",
"acrylic-epoxy paint" = "polydiglycidyl ethers",
"acrylic-urethane paint" = "polyurethanes",
"alkyd paint" = "polyesters",
"chlorosulfonated polyethylene paint" = "polyhaloolefins",
"ethylene-acrylate paint" = "polyolefins",
"nitrocellulose paint" = "polycellulose derivatives",
"other paint" = "other plastic",
"polyester paint" = "polyesters",
"polyvinyl formal paint" = "polyvinylalcohols",
"styrene-acrylic paint" = "polyacrylates",
"urethane paint" = "polyurethanes",
"urethane-alkyd paint" = "polyesters",
"vinyl acetate paint" = "polyvinylesters",
"vinyl chloride paint" = "polyhaloolefins",
"vinyl chloride-vinyl acetate paint" = "polyhaloolefins",
"vinyl-acrylic paint" = "polyacrylates"
)
actual_binders <- classes[
spectrum_identity %in% names(binder_classes),
stats::setNames(material, spectrum_identity)
]
expect_identical(unname(actual_binders[names(binder_classes)]),
unname(binder_classes))
paint_classes <- c("paint", "acrylic paint", "alkyd paint", "urethane paint")
expect_false(any(hierarchy$material_class %in% paint_classes))
expect_false(any(common_use$material_class %in% paint_classes))
organic_recommendations <- c(
"1,5-pentanediol", "11-aminoundecanoic acid", "1-bromobutane",
"1-vinyl-2-pyrolidinone", "2-bromopropanoic acid", "2-butanone",
"2-chloro-4-methylpentane", "2-methyl-2-pentanol", "butyl acrylate",
"ethyl (a-chloromethyl)acrylate", "ethyl acrylate",
"n,n-diethyl-m-toluamide", "n,n-dimethyl-m-toluamide",
"n-butyl benzoate", "n-decyl methacrylate", "n-vinylformamide",
"p-phenylenediamine", "p-vinylbenzyl chloride", "p-xylene",
"propionic acid", "sec-butyl benzoate", "styrene",
"tamoxifen (lot #bcbt3163)"
)
expect_true(all(
classes[spectrum_identity %in% organic_recommendations, material] ==
"organic matter"
))
expect_true(all(
classes[spectrum_identity %in% c(
"c2. blue fiber", "c4. green fiber", "c6. red fiber",
"c8. pink fiber bundle", "c9. grey fiber"
), material] == "other"
))
expect_equal(
classes[spectrum_identity == "fibre_polyamide_6_p6", material],
"nylon 6,6 - poly(hexamethylene adipamide)"
)
expect_equal(
classes[spectrum_identity == "ps 16. purple lego fragment", material],
"acrylonitrile butadiene styrene (abs)"
)
expect_true(all(
classes[spectrum_identity %in% c("polyesterurethane", "polyetherurethane"),
material] == "polyurethanes"
))
expect_true(all(
classes[spectrum_identity %in% c("tylose", "tylose2"), material] ==
"methyl cellulose"
))
expect_true(all(c("microplastix", "nist", "hcmr", "cnr", "vliz",
"nicolas coca") %in% types$organization))
expect_false("user_name" %in% names(types))
expect_equal(types[organization == "nist", spectrum_type], "nir")
expect_equal(
types[organization == "monterey bay aquarium research institute",
spectrum_type],
"raman"
)
expect_equal(
types[organization == "walters art museum pigment library",
c(library_type, spectrum_type)],
c("pigments", "raman")
)
expect_false(anyNA(types$spectrum_type))
expect_false(any(types$spectrum_type == ""))
expect_true(all(c("interpretation", "form_factor", "shape", "x_unit",
"spectrumid", "locationdescription", "v1",
"3997_91411", "polymer_hit_3_labs") %in%
drops$metadata_column))
})
test_that("reference metadata enrichment is ordered and conservative", {
form_regex <- data.table::fread(
reference_workflow_data_path("material_form_regex.csv")
)
common_use <- data.table::fread(
reference_workflow_data_path("common_use_reference.csv")
)
metadata <- data.table::data.table(
sample_name = paste0("s", seq_len(7)),
spectrum_identity = c(
"paint chip", "clear plastic film", "fiber pellet", "profile edge",
"hard plastic", "EPDM gasket", "tyre fragment"
),
material_form = c("rubber", rep(NA_character_, 6)),
notes = c("paint", "sheet", "fiber and pellet", "filmography",
"rigid plastic", "seal", "road wear"),
material_class = c(
"poly(styrene-butadiene) rubber", "polyethylene", "polypropylene",
"other plastic", "polyethylene",
"poly(ethylene-propylene-diene) rubber",
"poly(styrene-butadiene) rubber"
)
)
form <- OpenSpecy:::.lib_enrich_material_form(metadata, form_regex)
expect_identical(
form$data$material_form,
c("rubber", "film plastic", NA, NA, "hard plastic", "rubber", NA)
)
expect_equal(form$summary[metric == "conflicting", value], 2L)
expect_equal(form$summary[metric == "unmatched", value], 1L)
expect_true(all(c("matched_patterns", "evidence", "conflict") %in%
names(form$matches)))
expect_match(form$matches[row_id == 1L, evidence], "material_form=rubber")
expect_silent(empty_form <- OpenSpecy:::.lib_enrich_material_form(
data.table::data.table(spectrum_identity = "profile"), form_regex
))
expect_identical(empty_form$summary$metric,
c("total", "populated", "unmatched", "conflicting"))
use <- OpenSpecy:::.lib_enrich_common_use(form$data, common_use)
expect_identical(
use$data$common_use,
c("mixed", "consumer", "consumer", NA, "consumer", "mixed", "mixed")
)
expect_true(all(c(
"consumer_mass_share", "industrial_mass_share", "source_url",
"retrieved_date"
) %in% names(use$coverage)))
expect_silent(empty_use <- OpenSpecy:::.lib_enrich_common_use(
data.table::data.table(material_class = "other plastic"), common_use
))
expect_identical(empty_use$summary$metric,
c("total", "populated", "unmatched"))
mixed_hierarchy <- data.table::data.table(
material = "example", material_class = "example", material_type = "plastic"
)
mixed_reference <- data.table::data.table(
material_class = "example", common_use = "mixed",
consumer_mass_share = 0.4, industrial_mass_share = 0.4,
unclassified_mass_share = 0.2, basis_year = 2020,
geography = "global", source_url = "https://example.org/source",
retrieved_date = "2026-09-29",
evidence_notes = "review fixture"
)
expect_silent(OpenSpecy:::.lib_validate_common_use_reference(
mixed_reference, mixed_hierarchy
))
mixed_reference$consumer_mass_share <- 0.2
expect_error(
OpenSpecy:::.lib_validate_common_use_reference(
mixed_reference, mixed_hierarchy
),
"valid threshold shares"
)
qualitative_reference <- data.table::copy(mixed_reference)
qualitative_reference[, `:=`(
consumer_mass_share = NA_real_, industrial_mass_share = NA_real_,
unclassified_mass_share = NA_real_, basis_year = NA_integer_,
geography = "general"
)]
expect_silent(OpenSpecy:::.lib_validate_common_use_reference(
qualitative_reference, mixed_hierarchy
))
qualitative_reference$source_url <- NA_character_
expect_error(
OpenSpecy:::.lib_validate_common_use_reference(
qualitative_reference, mixed_hierarchy
),
"source provenance"
)
partial_reference <- data.table::copy(qualitative_reference)
partial_reference$source_url <- "https://example.org/source"
partial_reference$consumer_mass_share <- 0.6
expect_error(
OpenSpecy:::.lib_validate_common_use_reference(
partial_reference, mixed_hierarchy
),
"either all missing or all present"
)
})
test_that("predict_class_reference() fills only blanks and audits overlaps", {
classes <- data.table::data.table(
spectrum_identity = c(
"nylon exact override", "nylon fiber", "nylon blend", "unknown"
),
material = c(
"manual material", NA_character_, NA_character_, NA_character_
)
)
rules <- data.table::data.table(
pattern = c("^nylon", "blend$"),
material = c("polyamides", "polyesters")
)
report <- predict_class_reference(classes, rules, return = "report")
exact <- report$data
expect_equal(exact[spectrum_identity == "nylon exact override", material],
"manual material")
expect_equal(exact[spectrum_identity == "nylon fiber", material],
"polyamides")
expect_true(is.na(exact[spectrum_identity == "nylon blend", material]))
expect_true(is.na(exact[spectrum_identity == "unknown", material]))
expect_equal(report$summary$predicted, 1L)
expect_equal(report$summary$clashes, 1L)
expect_equal(report$summary$unmatched, 2L)
expect_equal(report$summary$overlaps, 1L)
expect_equal(report$clashes$spectrum_identity, "nylon blend")
expect_match(report$clashes$materials, "polyamides")
expect_match(report$clashes$materials, "polyesters")
expect_equal(report$overlaps$spectrum_identity, "nylon exact override")
expect_false(report$overlaps$agreement)
expect_equal(report$predictions$spectrum_identity, "nylon fiber")
})
test_that("reference class completion resolves reviewed wrappers and audits uncertainty", {
lib <- tiny_build_lib()
lib$metadata[, `:=`(
spectrum_identity = c(
"known", "pa_ref.csv", "mffrc001_nylon (pa6)_maker.0",
"cellulose_like_ref.csv", NA_character_, "known_2", "known_3",
"known_4"
),
user_name = c(
NA_character_, "gicquel et al. 2024",
"elise granek and kellie teague", "gicquel et al. 2024",
NA_character_, NA_character_, NA_character_, NA_character_
),
material = NA_character_,
material_type = NA_character_
)]
lib$metadata$material_class <- c(
"known class", rep(NA_character_, 3), rep("known class", 4)
)
classes <- data.table::data.table(
spectrum_identity = c("pa", "nylon", "cellulose_like"),
material = c("polyamides", "polyamides", "organic matter")
)
hierarchy <- data.table::data.table(
material = c("nylon 6 - poly(caprolactam)", "organic matter"),
material_class = c("polyamides", "organic matter"),
material_type = c("plastic", "not plastic")
)
completed <- .lib_complete_reference_classes(lib, classes, hierarchy)
report <- attr(completed, "class_coverage_report")
expect_true(check_OpenSpecy(completed))
expect_false(anyNA(completed$metadata$material_class))
expect_equal(completed$metadata$material_class[2:3],
rep("polyamides", 2))
expect_equal(completed$metadata$class_lookup_key[2:3], c("pa", "nylon"))
expect_equal(completed$metadata$class_assignment_reason[2:3],
rep("reviewed_source_key", 2))
expect_equal(completed$metadata$material_class[4], "organic matter")
expect_equal(completed$metadata$class_assignment_reason[4],
"reviewed_source_key")
expect_identical(completed$metadata$spectrum_identity,
lib$metadata$spectrum_identity)
expect_equal(report[stage == "after", populated_class], nrow(lib$metadata))
expect_equal(report[stage == "after", reviewed_source_key], 3L)
expect_equal(report[stage == "after", unclassified], 0L)
expect_equal(report[stage == "after", other], 0L)
})
test_that("reference class completion labels and caps unresolved other", {
source <- tiny_build_lib()
ids <- paste0("coverage", seq_len(100L))
spectra <- matrix(
rep(source$spectra[, 1L], 100L), nrow = nrow(source$spectra)
)
colnames(spectra) <- ids
metadata <- data.table::data.table(
sample_name = ids, col_id = ids,
spectrum_identity = c(rep("known", 99L), "unknown"),
user_name = NA_character_,
material = c(rep("known", 99L), NA_character_),
material_class = c(rep("known class", 99L), NA_character_),
material_type = c(rep("plastic", 99L), NA_character_),
spectrum_type = "ftir"
)
lib <- as_OpenSpecy(source$wavenumber, spectra, metadata = metadata)
classes <- data.table::data.table(
spectrum_identity = character(), material = character()
)
hierarchy <- data.table::data.table(
material = "known", material_class = "known class",
material_type = "plastic"
)
completed <- .lib_complete_reference_classes(lib, classes, hierarchy)
report <- attr(completed, "class_coverage_report")
expect_equal(completed$metadata$material[100L], "other")
expect_equal(completed$metadata$material_class[100L], "other")
expect_equal(completed$metadata$material_type[100L], "other")
expect_equal(report[stage == "after", unresolved_other], 1L)
expect_equal(report[stage == "after", other_fraction], 0.01)
lib$metadata[99:100, `:=`(
spectrum_identity = c("unknown_2", "unknown"),
material = NA_character_, material_class = NA_character_,
material_type = NA_character_
)]
expect_error(
.lib_complete_reference_classes(lib, classes, hierarchy),
"above the reviewed 1% maximum",
fixed = TRUE
)
})
test_that("official other policy removes unresolved rows and retains broad classes", {
lib <- tiny_build_lib()
lib$metadata[, `:=`(
spectrum_identity = c(NA_character_, paste0("identity_", 2:8)),
sample_id = paste0("sample_", 1:8),
file_name = paste0("file_", 1:8, ".csv"),
organization = source,
user_name = source,
citation = "citation",
other_info = "note",
material = c("other", "other plastic", "polyamide", rep("polyester", 5)),
material_type = c("other", "plastic", "other material", rep("plastic", 5))
)]
lib$metadata$material_class <- c(
"other", "other plastic", "other material", rep("polyesters", 5)
)
removed <- OpenSpecy:::.lib_apply_other_policy(
list(raw = lib), remove_other = TRUE, report = NULL
)
expect_identical(colnames(removed$libraries$raw$spectra), paste0("s", 2:8))
expect_identical(nrow(removed$libraries$raw$metadata), 7L)
expect_named(removed$review, names(OpenSpecy:::.lib_other_review_schema()))
expect_named(removed$summary, names(OpenSpecy:::.lib_other_filter_schema()))
expect_type(removed$review$source_row, "integer")
expect_type(removed$summary$removed, "integer")
expect_equal(removed$review$reason,
c("missing_spectrum_identity", rep("reviewed_broad_category", 2)))
expect_equal(
removed$review$action,
c("removed", rep("retained_reviewed_broad_category", 2))
)
expect_equal(removed$summary[, .(candidates, removed, after)],
data.table::data.table(candidates = 3L, removed = 1L, after = 7L))
expect_true(check_OpenSpecy(removed$libraries$raw))
retained <- OpenSpecy:::.lib_apply_other_policy(
list(raw = lib), remove_other = FALSE, report = NULL
)
expect_identical(ncol(retained$libraries$raw$spectra), 8L)
expect_true(all(
retained$review$action == "retained_for_semisupervised_reassignment"
))
expect_identical(retained$summary$removed, 0L)
expect_identical(formals(build_lib)$remove_other, TRUE)
})
test_that("source-library retention reports complete drops with a stage reason", {
stages <- list(
data.table::data.table(
stage = "prepared", artifact = "raw",
library_name = c("kept", "dropped"), spectra = c(4L, 2L)
),
data.table::data.table(
stage = "post_exclusion", artifact = "raw",
library_name = c("kept", "dropped"), spectra = c(4L, 2L)
),
data.table::data.table(
stage = "core", artifact = "raw",
library_name = c("kept", "dropped"), spectra = c(4L, 2L)
),
data.table::data.table(
stage = "post_other", artifact = "raw",
library_name = "kept", spectra = 4L
),
data.table::data.table(
stage = c("post_quality", "post_prune", "post_transform", "final"),
artifact = "raw", library_name = "kept", spectra = 4L
)
)
report <- OpenSpecy:::.lib_library_retention_report(stages)
expect_equal(report[library_name == "kept", status], "retained")
expect_equal(report[library_name == "dropped", status], "dropped")
expect_equal(
report[library_name == "dropped", reason],
"unresolved_other_policy"
)
expect_equal(report[library_name == "dropped", final_n], 0L)
})
test_that("confusion tables rank the largest misidentifications first", {
tests <- data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "raman", source = "new",
technique = "raman", provenance = "candidate",
expected_class = c(rep("polyethylene", 10), rep("polypropylene", 4)),
predicted_class = c(rep("polyethylene", 5), rep("polypropylene", 5),
rep("polypropylene", 3), "polyethylene")
)
confusion <- OpenSpecy:::.lib_confusion_table(tests)
expect_named(confusion, c(
"algorithm", "artifact", "model", "source", "technique", "provenance",
"expected_class", "predicted_class", "spectra", "misidentified",
"expected_class_spectra", "expected_class_fraction"
), ignore.order = TRUE)
expect_true(confusion$misidentified[[1L]])
expect_equal(confusion$spectra[[1L]], 5L)
expect_equal(
confusion[expected_class == "polyethylene", expected_class_fraction],
c(0.5, 0.5)
)
expect_type(confusion$expected_class_fraction, "double")
expect_named(OpenSpecy:::.lib_confusion_table(tests[0]), names(confusion))
})
test_that("model assessment compares error-mode accuracy percentages", {
tests <- data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "raman", source = "new", technique = "raman",
spectrum_id = paste0("s", 1:8),
correct = c(TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE)
)
flags <- data.table::data.table(
artifact = "derivative", technique = "raman",
spectrum_id = paste0("s", 5:8), error_mode = "low_snr"
)
result <- OpenSpecy:::.lib_model_assessment_correlations(tests, flags)
expect_named(
result, names(OpenSpecy:::.lib_model_assessment_correlation_schema())
)
expect_identical(result$error_mode[[1L]], "low_snr")
expect_equal(result$with_error_accuracy_pct, 0)
expect_equal(result$without_error_accuracy_pct, 100)
expect_equal(result$accuracy_difference_pct, -100)
empty <- OpenSpecy:::.lib_model_assessment_correlations(tests[0], flags)
expect_named(empty, names(result))
expect_type(empty$with_error_accuracy_pct, "double")
})
test_that("reference metadata is ordered by missingness after all-NA removal", {
x <- tiny_build_lib()
x$metadata <- data.table::data.table(
sample_name = colnames(x$spectra),
complete = seq_len(ncol(x$spectra)),
two_missing = c(NA, NA, rep("x", ncol(x$spectra) - 2L)),
one_missing = c(NA, rep("y", ncol(x$spectra) - 1L)),
entirely_missing = rep(NA_character_, ncol(x$spectra))
)
attr(x, "metadata_order_marker") <- "preserved"
finalized <- OpenSpecy:::.lib_finalize_reference_metadata(
libraries = list(raw = list(ftir = x)),
medoids = list(derivative = list(ftir = x))
)
expected <- c("sample_name", "complete", "one_missing", "two_missing")
expect_identical(names(finalized$libraries$raw$ftir$metadata), expected)
expect_identical(names(finalized$medoids$derivative$ftir$metadata), expected)
expect_true(check_OpenSpecy(finalized$libraries$raw$ftir))
expect_identical(
attr(finalized$libraries$raw$ftir, "metadata_order_marker"), "preserved"
)
expect_equal(finalized$assessment$dropped_columns, c(1L, 1L))
expect_equal(finalized$assessment$dropped_names,
rep("entirely_missing", 2L))
expect_equal(finalized$assessment$maximum_missing, c(2L, 2L))
expect_named(
finalized$assessment,
names(OpenSpecy:::.lib_metadata_finalization_schema())
)
})
test_that("build_lib() preserves full source ranges through NA-aware recipes", {
lib <- tiny_build_lib()
left <- lib
left$wavenumber <- lib$wavenumber[1:40]
left$spectra <- lib$spectra[1:40, 1:4, drop = FALSE]
left$metadata <- data.table::copy(lib$metadata[1:4])
right <- lib
right$wavenumber <- lib$wavenumber[22:61]
right$spectra <- lib$spectra[22:61, 5:8, drop = FALSE]
right$metadata <- data.table::copy(lib$metadata[5:8])
built <- build_lib(list(left, right), dedupe = FALSE, signal_noise = FALSE)
expect_true(all(diff(built$raw$wavenumber) == 6))
expect_true(anyNA(built$raw$spectra))
expect_true(anyNA(built$derivative$spectra))
expect_true(any(is.finite(built$derivative$spectra[, 1])))
expect_true(any(is.finite(built$nobaseline$spectra[, 8])))
})
test_that("streamed variable-axis paths match c_spec() interpolation", {
lib <- tiny_build_lib()
left <- filter_spec(lib, 1:4)
left$wavenumber <- lib$wavenumber[1:40]
left$spectra <- left$spectra[1:40, , drop = FALSE]
right <- filter_spec(lib, 5:8)
right$wavenumber <- lib$wavenumber[22:61]
right$spectra <- right$spectra[22:61, , drop = FALSE]
paths <- c(tempfile(fileext = ".rds"), tempfile(fileext = ".rds"))
saveRDS(left, paths[[1L]])
saveRDS(right, paths[[2L]])
expected <- c_spec(list(left, right), range = "full", res = 6)
actual <- build_lib(
paths,
recipes = list(raw = list()),
range = "full",
res = 6,
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(actual$wavenumber, expected$wavenumber)
expect_equal(actual$spectra, expected$spectra, tolerance = 1e-12)
expect_equal(actual$metadata$sample_name, expected$metadata$sample_name)
expect_true(check_OpenSpecy(actual))
})
test_that("source-stage hashes support spectra with no shared finite rows", {
lib <- filter_spec(tiny_build_lib(), 1:2)
midpoint <- floor(nrow(lib$spectra) / 2)
lib$spectra[seq_len(midpoint), 1] <- NA_real_
lib$spectra[seq.int(midpoint + 1L, nrow(lib$spectra)), 2] <- NA_real_
built <- build_lib(
lib, recipes = list(raw = list()), signal_noise = FALSE,
progress = FALSE
)$raw
expect_true(check_OpenSpecy(built))
expect_equal(ncol(built$spectra), 2L)
expect_false(anyNA(built$metadata$sample_name))
expect_identical(colnames(built$spectra), built$metadata$sample_name)
})
test_that("build_lib() applies baseline recipes across source-specific NA tails", {
lib <- filter_spec(tiny_build_lib(), 1:2)
lib$spectra[1:5, 1] <- NA_real_
lib$spectra[57:61, 2] <- NA_real_
built <- build_lib(
list(lib),
recipes = list(nobaseline = list(
conform_spec = FALSE,
smooth_intens = FALSE,
subtr_baseline = TRUE,
make_rel = TRUE
)),
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE
)$nobaseline
expected <- manage_na(lib, fun = subtr_baseline)
expect_equal(built$spectra, expected$spectra, tolerance = 1e-12)
expect_equal(attr(built, "baseline"), "nobaseline")
})
test_that("extdata files combine into a mini library", {
mini_files <- c(
read_extdata("raman_hdpe.csv"),
read_extdata("ftir_ldpe_soil.asp"),
read_extdata("raman_atacamit.spc")
)
mini <- read_any(mini_files, c_spec_args = list(range = "common", res = 10))
expect_true(check_OpenSpecy(mini))
expect_equal(ncol(mini$spectra), 3)
lookup <- data.table::data.table(
file_name = basename(mini_files),
material = c("hdpe", "ldpe in soil", "atacamite"),
material_type = c("plastic", "plastic", "mineral")
)
mini <- join_lib_metadata(mini, lookup, by = "file_name",
require_complete = TRUE)
built <- build_lib(
mini_files,
recipes = list(raw = list()),
metadata_lookups = lookup,
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE
)
expect_true(check_OpenSpecy(built$raw))
expect_true(all(c("material", "material_type") %in% names(built$raw$metadata)))
})
test_that("build_lib() discovers helper data and reuses one artifact bundle", {
# This exercises the complete multi-artifact reference-library workflow.
skip_on_cran()
lib <- tiny_build_lib()
lib$spectra[30, ] <- lib$spectra[30, ] + 10
lib$metadata[, `:=`(
spectrum_identity = label,
organization = source,
user_name = source,
spectrum_id = sample_name
)]
spectra <- do.call(cbind, lapply(seq_len(10), function(copy) {
out <- lib$spectra + copy / 1000
colnames(out) <- paste0(colnames(out), "_", copy)
out
}))
metadata <- data.table::rbindlist(lapply(seq_len(10), function(copy) {
out <- data.table::copy(lib$metadata)
out[, `:=`(
sample_name = paste0(sample_name, "_", copy),
spectrum_id = paste0(spectrum_id, "_", copy)
)]
out
}))
lib <- as_OpenSpecy(
lib$wavenumber, spectra = spectra, metadata = metadata,
attributes = list(intensity_unit = "absorbance")
)
workflow_root <- file.path(
tempdir(), paste0("workflow-", sample.int(1e8, 1))
)
workflow_data <- file.path(workflow_root, "data")
output_dir <- file.path(tempdir(), paste0("output-", sample.int(1e8, 1)))
dir.create(workflow_data, recursive = TRUE)
old_working_dir <- setwd(workflow_root)
on.exit(setwd(old_working_dir), add = TRUE)
data.table::fwrite(data.table::data.table(
spectrum_identity = unique(lib$metadata$spectrum_identity),
material = paste0("material_", seq_along(unique(
lib$metadata$spectrum_identity
)))
), file.path(workflow_data, "classes_reference.csv"))
data.table::fwrite(data.table::data.table(
pattern = "^never[0-9]+$", material = "other material"
), file.path(workflow_data, "classes_regex.csv"))
data.table::fwrite(data.table::data.table(
organization = c("a", "b", "c"), library_type = "test",
spectrum_type = "ftir"
), file.path(workflow_data, "library_types.csv"))
classes <- data.table::fread(
file.path(workflow_data, "classes_reference.csv")
)
data.table::fwrite(data.table::data.table(
material = classes$material,
material_class = rep(c("polyclass_a", "polyclass_b"),
length.out = nrow(classes)),
material_type = "plastic"
), file.path(workflow_data, "material_hierarchy.csv"))
data.table::fwrite(data.table::data.table(sample_name = character()),
file.path(workflow_data, "known_bad_ids.csv"))
data.table::fwrite(data.table::data.table(
metadata_column = "unused_legacy_column"
), file.path(workflow_data, "metadata_drop_columns.csv"))
data.table::fwrite(data.table::data.table(
pattern = "(^|[^[:alnum:]])paint([^[:alnum:]]|$)",
material_form = "paint"
), file.path(workflow_data, "material_form_regex.csv"))
use_classes <- sort(unique(data.table::fread(
file.path(workflow_data, "material_hierarchy.csv")
)$material_class))
data.table::fwrite(data.table::data.table(
material_class = use_classes,
common_use = rep(NA_character_, length(use_classes)),
consumer_mass_share = rep(NA_real_, length(use_classes)),
industrial_mass_share = rep(NA_real_, length(use_classes)),
unclassified_mass_share = rep(NA_real_, length(use_classes)),
basis_year = rep(NA_integer_, length(use_classes)),
geography = rep(NA_character_, length(use_classes)),
source_url = rep(NA_character_, length(use_classes)),
retrieved_date = rep(NA_character_, length(use_classes)),
evidence_notes = rep(NA_character_, length(use_classes))
), file.path(workflow_data, "common_use_reference.csv"))
fixture_prune <- list(
derivative = list(min_n = 10, progress = FALSE),
nobaseline = list(min_n = 10, progress = FALSE)
)
first <- suppressWarnings(build_lib(
lib, output_dir = output_dir,
previous_library_dir = NULL, dedupe = FALSE, signal_noise = FALSE,
progress = FALSE,
prune = fixture_prune,
recipes = list(raw = list(), derivative = list(), nobaseline = list())
))
expect_named(first, c("libraries", "medoids", "models", "assessments"))
expect_named(first$libraries, c("raw", "derivative", "nobaseline"))
expect_named(first$medoids, c("derivative", "nobaseline"))
expect_named(first$models, "logistic_regression")
expect_true(all(vapply(first$libraries, function(recipe) {
all(vapply(recipe, check_OpenSpecy, logical(1)))
}, logical(1))))
expect_true(all(vapply(first$medoids, function(recipe) {
all(vapply(recipe, check_OpenSpecy, logical(1)))
}, logical(1))))
expect_named(first$assessments,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
expect_lte(sum(lengths(first$assessments)), 10L)
expect_true(all(lengths(first$assessments) > 0L))
expect_true(all(vapply(
unlist(first$assessments, recursive = FALSE), nrow, integer(1L)
) > 0L))
expect_identical(attr(first$assessments, "assessment_schema_version"),
"2.0.0")
expect_named(first$assessments$cleanup$dropped_spectrum_identities,
"spectrum_identity")
retention <- first$assessments$cleanup$summary[
assessment_kind == "library_retention"
]
expect_gt(nrow(retention), 0L)
expect_true(all(c("library_name", "prepared_n", "final_n", "status",
"reason") %in% names(retention)))
expect_true(all(vapply(first$libraries$raw, function(object) {
all(c("library_name", "material_form", "common_use") %in%
names(object$metadata))
}, logical(1))))
expect_true(all(vapply(first$libraries$raw, function(object) {
is.list(attr(object, "material_form_enrichment_report", exact = TRUE)) &&
is.list(attr(object, "common_use_enrichment_report", exact = TRUE))
}, logical(1))))
upstream <- attr(first$assessments, "upstream_assessments", exact = TRUE)
expect_true(all(c(
"material_form_enrichment", "material_form_matches",
"material_form_clashes", "common_use_enrichment", "common_use_coverage",
"pruning_removals"
) %in% names(upstream)))
release_dir <- attr(first, "output_dir")
expect_true(all(file.exists(file.path(
release_dir,
c("raw.rds", "derivative.rds", "nobaseline.rds",
"medoid_derivative.rds", "medoid_nobaseline.rds",
"model_derivative.rds", "model_nobaseline.rds",
"model_logistic_regression_derivative.rds",
"model_logistic_regression_nobaseline.rds",
"assessments.rds", "quarantined_spectra.rds",
"reference_library_build.rds")
))))
quarantine <- readRDS(file.path(release_dir, "quarantined_spectra.rds"))
expect_s3_class(quarantine, "OpenSpecyQuarantine")
expect_identical(quarantine$manifest$schema,
"OpenSpecy_quarantined_spectra_v1")
release_index <- readRDS(file.path(release_dir, "reference_library_build.rds"))
expect_identical(
release_index$schema, "OpenSpecy_reference_build_index_v1"
)
expect_false(any(c("libraries", "medoids", "models") %in%
names(release_index)))
expect_lt(file.info(file.path(
release_dir, "reference_library_build.rds"
))$size, 1e6)
release_assessments <- readRDS(file.path(release_dir, "assessments.rds"))
expect_identical(
attr(release_assessments, "assessment_schema_version"), "2.0.0"
)
expect_false(any(c("scope", "expected_class") %in%
names(release_assessments$ref_lib$accuracy)))
expect_true("model_training_tests" %in%
names(attr(release_assessments, "evidence")))
report_attributes <- c(
"join_report", "metadata_lookup_reports",
"spectrum_identity_cleanup_report", "build_stage_report",
"dropped_spectrum_identities", "class_prediction_report",
"class_coverage_report", "other_review_report", "other_filter_report",
"quality_control_report", "prune_report", "identification_support",
"identification_dropped_ids", "identification_minimum_observed",
"identification_finite_coverage", "range_flat_drops",
"library_retention_stages"
)
for (component in c("raw", "derivative", "nobaseline",
"medoid_derivative", "medoid_nobaseline")) {
artifact <- readRDS(file.path(release_dir, paste0(component, ".rds")))
for (object in artifact) {
expect_true(check_OpenSpecy(object))
expect_length(intersect(names(attributes(object)), report_attributes), 0L)
expect_null(attr(object$metadata, "join_report", exact = TRUE))
}
}
model_fields <- OpenSpecy:::.lib_runtime_model_fields()
for (component in c(
"model_logistic_regression_derivative",
"model_logistic_regression_nobaseline"
)) {
artifact <- readRDS(file.path(release_dir, paste0(component, ".rds")))
for (model in artifact) {
expect_true(all(names(model) %in% model_fields))
expect_false(any(c(
"tests", "lambda_metrics", "oob_metrics", "oob_class_accuracy",
"feature_importance", "training_parameters", "class_weights",
"support", "class_support"
) %in% names(model)))
expect_null(attr(model, "training_warnings", exact = TRUE))
}
}
resolved <- OpenSpecy:::.lib_resolve_rebuild_input(
file.path(release_dir, "reference_library_build.rds")
)
expect_named(resolved$libraries, c("raw", "derivative", "nobaseline"))
expect_named(resolved$medoids, c("derivative", "nobaseline"))
expect_named(resolved$models, "logistic_regression")
expect_s3_class(resolved$quarantine, "OpenSpecyQuarantine")
expect_identical(
resolved$quarantine$manifest$schema,
"OpenSpecy_quarantined_spectra_v1"
)
second <- suppressWarnings(build_lib(
lib, output_dir = output_dir,
previous_library_dir = NULL, dedupe = FALSE, signal_noise = FALSE,
progress = FALSE, reuse = TRUE,
prune = fixture_prune,
recipes = list(raw = list(), derivative = list(), nobaseline = list())
))
second_evidence <- attr(second$assessments, "evidence")
expect_true(all(
second_evidence$output_manifest$status == "available"
))
expect_equal(second$libraries$raw$ftir$spectra,
first$libraries$raw$ftir$spectra)
rebuilt <- suppressWarnings(build_lib(
lib, output_dir = output_dir,
previous_library_dir = NULL, dedupe = FALSE, signal_noise = FALSE,
progress = FALSE, reuse = FALSE,
prune = fixture_prune,
recipes = list(raw = list(), derivative = list(), nobaseline = list())
))
expect_named(rebuilt$assessments,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
})
test_that("source-local reference splits prevent self-match leakage", {
old <- tiny_build_lib()
new <- old
new$metadata$sample_name_old <- new$metadata$sample_name
new$metadata$sample_name <- paste0("rebuilt_", new$metadata$sample_name)
colnames(new$spectra) <- new$metadata$sample_name
split <- OpenSpecy:::.lib_source_split(
new, artifact = "raw", source = "new", seed = 71, holdout = 0.25
)
expect_identical(anyDuplicated(split$manifest$group_id), 0L)
expect_true(all(split$manifest$source == "new"))
expect_true(all(split$manifest$split %in% c("train", "test")))
expect_equal(
sum(split$manifest$split == "test"),
round(nrow(split$manifest) * 0.25)
)
expect_length(intersect(
split$manifest[split == "train", group_id],
split$manifest[split == "test", group_id]
), 0L)
messages <- capture.output(
tests <- OpenSpecy:::.lib_reference_holdout_test(
reference = new, data = new, split = split,
artifact = "raw", source = "new", progress = TRUE
),
type = "message"
)
expect_match(paste(messages, collapse = "\n"), "full correlation complete")
expect_true(all(tests$split == "test"))
expect_true(all(tests$provenance == "source_local_reference_holdout"))
old_split <- OpenSpecy:::.lib_source_split(
old, artifact = "raw", source = "old", seed = 72, holdout = 0.25
)
old_tests <- OpenSpecy:::.lib_reference_holdout_test(
reference = old, data = old, split = old_split,
artifact = "raw", source = "old", progress = FALSE
)
expect_true(all(old_split$manifest$source == "old"))
expect_true(all(old_tests$source == "old"))
})
test_that("medoid assessment searches the complete corresponding library", {
lib <- tiny_build_lib()
medoid <- filter_spec(lib, c(1L, 3L))
messages <- capture.output(
tests <- OpenSpecy:::.lib_reference_complete_test(
medoid, lib, artifact = "medoid_derivative_ftir", source = "new",
progress = TRUE, block_size = 2L
),
type = "message"
)
expect_match(paste(messages, collapse = "\n"),
"medoid identifying complete dataset")
expect_equal(nrow(tests), ncol(lib$spectra))
expect_setequal(tests$spectrum_id, lib$metadata$sample_name)
expect_true(all(tests$split == "complete"))
expect_true(all(tests$provenance == "complete_medoid_reference_search"))
})
test_that("complete old-new assessments directly test deployed models", {
skip_if_not_installed("glmnet")
skip_if_not_installed("ranger")
small <- tiny_build_lib()
spectra <- do.call(cbind, lapply(seq_len(5), function(i) {
small$spectra + i / 1000
}))
metadata <- data.table::rbindlist(lapply(seq_len(5), function(i) {
out <- data.table::copy(small$metadata)
out$sample_name <- paste0(out$sample_name, "_", i)
out
}))
colnames(spectra) <- metadata$sample_name
lib <- as_OpenSpecy(
small$wavenumber, spectra = spectra, metadata = metadata,
attributes = list(intensity_unit = "absorbance")
)
model_input <- restrict_range(
lib, min = 800, max = 3200, make_rel = FALSE
)
model <- suppressWarnings(build_model_lib(model_input))
rf_model <- train_spec_model(
model_input, method = "random_forest", num.trees = 20L,
min.node.size = 1L, mtry = 4L
)
model_set <- list(both = model, ftir = model, raman = NULL)
build <- list(
libraries = list(
raw = list(ftir = lib), derivative = list(ftir = lib),
nobaseline = list(ftir = lib)
),
medoids = list(
derivative = list(ftir = model_input),
nobaseline = list(ftir = model_input)
),
models = list(
logistic_regression = list(
derivative = model_set, nobaseline = model_set
),
random_forest = list(raw = list(ftir = rf_model))
),
assessments = list()
)
previous <- file.path(tempdir(), paste0("previous-", sample.int(1e8, 1)))
dir.create(previous, recursive = TRUE)
typed_lib <- list(ftir = lib)
typed_medoid <- list(ftir = model_input)
saveRDS(typed_lib, file.path(previous, "raw.rds"))
saveRDS(typed_lib, file.path(previous, "derivative.rds"))
saveRDS(typed_lib, file.path(previous, "nobaseline.rds"))
saveRDS(typed_medoid, file.path(previous, "medoid_derivative.rds"))
saveRDS(typed_medoid, file.path(previous, "medoid_nobaseline.rds"))
saveRDS(model_set, file.path(previous, "model_derivative.rds"))
saveRDS(model_set, file.path(previous, "model_nobaseline.rds"))
local_mocked_bindings(
train_spec_model = function(...) {
stop("assessment must not retrain a model", call. = FALSE)
},
.package = "OpenSpecy"
)
comparison <- suppressWarnings(OpenSpecy:::.lib_compare_reference_build(
build, previous_library_dir = previous,
seed = 211, holdout = 0.25, progress = FALSE
))
expect_true(all(c(
"models", "split_manifest", "library_identification",
"model_identification", "model_assessment_correlations",
"assess_spec_shifts", "old_new_compatibility"
) %in% names(comparison)))
expect_equal(unique(comparison$split_manifest$artifact), c(
"raw_ftir", "derivative_ftir", "nobaseline_ftir"
))
expect_setequal(unique(comparison$split_manifest$source), c("new", "old"))
expect_gt(nrow(comparison$library_identification), 0L)
expect_gt(nrow(comparison$model_identification), 0L)
expect_setequal(
unique(comparison$model_identification$algorithm),
c("logistic_regression", "random_forest")
)
expect_equal(nrow(comparison$model_assessment_correlations), 0L)
expect_gt(nrow(comparison$assess_spec_shifts), 0L)
expect_equal(
comparison$library_tests[
artifact == "medoid_derivative_ftir" & source == "new", .N
],
ncol(lib$spectra)
)
expect_true(all(comparison$library_tests[
grepl("^medoid_", artifact), split
] == "complete"))
expect_true(all(
comparison$models$logistic_regression$derivative$ftir$tests$provenance ==
"new_logistic_regression_complete_dataset"
))
expect_equal(
nrow(comparison$models$logistic_regression$derivative$ftir$tests),
ncol(lib$spectra)
)
expect_true(all(
comparison$models$random_forest$raw$ftir$tests$provenance ==
"new_random_forest_complete_dataset"
))
expect_equal(
comparison$models$random_forest$raw$ftir$observation_count,
ncol(model_input$spectra)
)
})
test_that("assessment review is process nested, compact, and nonsparse", {
identification <- data.table::data.table(
artifact = rep(c("raw_ftir", "medoid_derivative_ftir"), each = 2L),
source = rep(c("old", "new"), 2L), technique = "ftir",
provenance = "grouped", macro_class_accuracy = c(.5, .8, .9, .7),
coverage = 1, overall_accuracy = c(.6, .85, .91, .75),
spectra = 20L, evaluated = 20L, classes = 2L,
evaluated_classes = 2L, mean_score = .8
)
confusion <- data.table::data.table(
artifact = rep("raw_ftir", 4L), source = rep(c("old", "new"), 2L),
technique = "ftir", provenance = "grouped",
expected_class = c("a", "a", "b", "b"),
predicted_class = c("b", "b", "a", "a"), misidentified = TRUE,
spectra = c(2L, 7L, 1L, 4L), expected_class_spectra = 10L,
expected_class_fraction = c(.2, .7, .1, .4)
)
model_identification <- data.table::copy(identification[artifact == "raw_ftir"])
model_identification[, `:=`(
algorithm = "logistic_regression", artifact = "derivative",
model = "ftir"
)]
correlations <- data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "ftir", technique = "ftir", error_mode = "low_snr",
with_error_accuracy_pct = 50,
without_error_accuracy_pct = 90,
accuracy_difference_pct = -40
)
reviewed <- OpenSpecy:::.lib_assessment_review(list(
build_summary = data.table::data.table(artifact = "raw_ftir", spectra = 20L),
dropped_spectrum_identities = data.table::data.table(
spectrum_identity = c("z", "a", "z")
),
library_identification = identification,
library_class_accuracy = data.table::data.table(
artifact = "raw_ftir", source = "new", technique = "ftir",
provenance = "grouped", expected_class = "class_a",
spectra = 10L, evaluated = 10L, coverage = 1,
class_accuracy = 0.5
),
library_confusion = confusion,
model_identification = model_identification,
model_class_accuracy = data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "ftir", source = "new", technique = "ftir",
provenance = "grouped", expected_class = "class_a",
spectra = 10L, evaluated = 10L, coverage = 1,
class_accuracy = 0.5
),
model_confusion = data.table::copy(confusion)[, `:=`(
algorithm = "logistic_regression", artifact = "derivative", model = "ftir"
)],
model_assessment_correlations = correlations,
assess_spec_shifts = data.table::data.table(
artifact = "raw_ftir", check = "signal", rate_old = .2,
rate_new = .1, rate_shift = -.1
),
old_new_compatibility = data.table::data.table(
artifact = "raw_ftir", spectra_old = 10L, spectra_new = 20L,
spectra_shift = 10L
),
output_manifest = data.table::data.table(
component = "raw", status = "available", path = "raw.rds", size = 1
)
))
expect_named(reviewed,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
expect_lte(sum(lengths(reviewed)), 10L)
expect_true(all(lengths(reviewed) > 0L))
expect_identical(
reviewed$cleanup$dropped_spectrum_identities$spectrum_identity,
c("a", "z")
)
accuracy_names <- names(reviewed$ref_lib$accuracy)
expect_false(any(c("scope", "expected_class", "class_accuracy") %in%
accuracy_names))
expect_true(all(c("source", "overall_accuracy_pct",
"macro_class_accuracy_pct", "class_count") %in%
accuracy_names))
expect_false(any(c("coverage_pct", "mean_score",
"evaluated_classes") %in% accuracy_names))
expect_identical(reviewed$ref_lib$accuracy$source, c("old", "new"))
expect_equal(reviewed$ref_lib$accuracy$macro_class_accuracy_pct, c(50, 80))
expect_identical(reviewed$ref_lib$accuracy$class_count, c(2L, 2L))
expect_identical(
reviewed$model$error_mode_accuracy$accuracy_difference_pct, -40
)
sparse <- unlist(lapply(
unlist(reviewed, recursive = FALSE),
function(value) vapply(value, function(column) mean(is.na(column)),
numeric(1L))
))
expect_true(all(sparse <= 0.10))
})
test_that("assessment shifts merge findings, omit passes, and rank rate shifts", {
summary <- data.table::data.table(
artifact = rep("raw_ftir", 6L), source = rep(c("old", "new"), each = 3L),
check = rep(c("signal", "signal", "range"), 2L),
status = rep(c("pass", "warning", "error"), 2L),
count = c(90L, 5L, 1L, 80L, 10L, 4L),
finding_count = c(0L, 5L, 1L, 0L, 10L, 4L),
example_ids = c("", "a", "b", "", "c", "d"), spectra = 100L
)
shifts <- OpenSpecy:::.lib_assessment_shift_table(summary)
expect_false("status" %in% names(shifts))
expect_equal(shifts[check == "signal", count_old], 5L)
expect_equal(shifts[check == "signal", count_new], 10L)
expect_true(all(diff(shifts$rate_shift) <= 0))
})
test_that("stable groups connect physical IDs and exact spectral content", {
x <- tiny_build_lib()
x$metadata$sample_name_old <- paste0("legacy_", seq_len(nrow(x$metadata)))
x$metadata$sample_name_old[2] <- x$metadata$sample_name_old[1]
x$spectra[, 4] <- x$spectra[, 3]
groups <- OpenSpecy:::.lib_stable_group_info(x)
expect_equal(groups$group_id[1], groups$group_id[2])
expect_equal(groups$group_id[3], groups$group_id[4])
split <- OpenSpecy:::.lib_source_split(
x, artifact = "raw", source = "new", seed = 1, holdout = .25
)
expect_identical(
split$manifest[, data.table::uniqueN(split), by = group_id][, max(V1)],
1L
)
})
test_that("immutable promotion rejects a changed payload", {
path <- tempfile(fileext = ".rds")
first <- OpenSpecy:::.lib_promote_rds(list(value = 1L), path)
expect_equal(first$status, "promoted")
second <- OpenSpecy:::.lib_promote_rds(list(value = 1L), path)
expect_equal(second$status, "verified_existing")
semantic_path <- tempfile(fileext = ".rds")
saveRDS(list(value = 1L), semantic_path, compress = FALSE)
semantic_checksum <- OpenSpecy:::.lib_sha256_file(semantic_path)
semantic <- OpenSpecy:::.lib_promote_rds(
list(value = 1L), semantic_path
)
expect_equal(semantic$status, "verified_existing")
expect_identical(
OpenSpecy:::.lib_sha256_file(semantic_path), semantic_checksum
)
expect_error(
OpenSpecy:::.lib_promote_rds(list(value = 2L), path),
"Immutable release artifact differs"
)
})
test_that("completed release manifests authorize immutable byte reuse", {
path <- tempfile(fileext = ".rds")
manifest <- OpenSpecy:::.lib_promote_rds(list(value = 1L), path)
attr(manifest, "build_signature") <- "signed-build"
verified <- OpenSpecy:::.lib_verify_manifested_release_artifact(
path, manifest
)
expect_equal(verified$status, "verified_existing")
expect_identical(verified$checksum, manifest$checksum)
saveRDS(list(value = 2L), path)
expect_null(OpenSpecy:::.lib_verify_manifested_release_artifact(
path, manifest
))
})
test_that("file signature caching preserves hashes and invalidates on metadata", {
path <- tempfile(fileext = ".txt")
writeLines("first", path)
first <- OpenSpecy:::.lib_file_signatures(path)
second <- OpenSpecy:::.lib_file_signatures(path)
expect_identical(first$checksum, second$checksum)
writeLines("a different sized payload", path)
changed <- OpenSpecy:::.lib_file_signatures(path)
expect_false(identical(first$checksum, changed$checksum))
})
test_that("support and fill helpers use the intended axes", {
x <- tiny_build_lib()
x$spectra[,] <- NA_real_
x$spectra[seq_len(6), 1] <- seq_len(6)
x$spectra[seq_len(7), 2] <- seq_len(7)
support <- OpenSpecy:::.lib_filter_spectral_support(x, min_fraction = 0.1)
expect_equal(support$audit$minimum_observed, rep(7L, 8))
expect_false(support$audit$retained[1])
expect_true(support$audit$retained[2])
spectra <- matrix(c(1, NA, 3, 10, 20, NA), nrow = 3)
spectrum_fill <- OpenSpecy:::.lib_spectrum_mean_replace(spectra)
expect_equal(spectrum_fill[, 1], c(1, 2, 3))
expect_equal(spectrum_fill[, 2], c(10, 20, 15))
wave_fill <- OpenSpecy:::.lib_wavenumber_mean_replace(spectra)
expect_equal(wave_fill$means, c(5.5, 20, 3))
expect_equal(wave_fill$spectra[, 1], c(1, 20, 3))
expect_equal(wave_fill$spectra[, 2], c(10, 20, 3))
})
test_that("medoid selection restores original missing values", {
x <- tiny_build_lib()
x$spectra[10:20, 1] <- NA_real_
ids <- reduce_lib(
x, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = FALSE
)
restored <- filter_spec(x, ids)
if ("s1" %in% ids) {
expect_true(anyNA(restored$spectra[, match("s1", ids)]))
}
flat <- x
flat$spectra[, 1] <- NA_real_
flat$spectra[seq_len(7), 1] <- 1
expect_no_error(reduce_lib(
flat, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = FALSE
))
})
test_that("macro lambda metrics choose class-balanced accuracy", {
outcome <- c(1L, 1L, 1L, 2L)
predictions <- array(0, dim = c(4, 2, 2))
predictions[cbind(seq_len(4), c(1, 1, 1, 1), 1)] <- 1
predictions[cbind(seq_len(4), c(1, 2, 2, 2), 2)] <- 1
metrics <- OpenSpecy:::.lib_macro_lambda_metrics(
predictions, outcome, lambda = c(1, 0.1)
)
expect_equal(metrics$macro_class_accuracy, c(0.5, 2 / 3))
expect_equal(metrics$overall_accuracy, c(0.75, 0.5))
expect_identical(which(metrics$selected), 2L)
})
test_that("rebuild_lib_artifacts reuses completed libraries downstream", {
skip_if_not_installed("glmnet")
base <- tiny_build_lib()
libraries <- lapply(seq_len(3), function(i) {
spectra <- do.call(cbind, lapply(seq_len(3), function(copy) {
base$spectra + copy / 1000
}))
metadata <- data.table::rbindlist(lapply(seq_len(3), function(copy) {
out <- data.table::copy(base$metadata)
out$sample_name <- paste0(out$sample_name, "_", copy)
out
}))
colnames(spectra) <- metadata$sample_name
as_OpenSpecy(base$wavenumber, spectra = spectra, metadata = metadata)
})
names(libraries) <- c("raw", "derivative", "nobaseline")
libraries <- lapply(libraries, function(x) list(ftir = x))
libraries$derivative$ftir$spectra[10:20, 1] <- NA_real_
input <- tempfile(fileext = ".rds")
saveRDS(list(libraries = libraries, assessments = list()), input)
output <- tempfile("downstream-build-")
first <- suppressWarnings(rebuild_lib_artifacts(
input, output_dir = output, previous_library_dir = NULL,
reuse = TRUE, progress = FALSE
))
expect_named(first, c("libraries", "medoids", "models", "assessments"))
expect_true(anyNA(first$medoids$derivative$ftir$spectra))
expect_true(
first$models$logistic_regression$derivative$ftir$fill_replaced > 0L
)
expect_named(first$assessments,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
second <- suppressWarnings(rebuild_lib_artifacts(
input, output_dir = output, previous_library_dir = NULL,
reuse = TRUE, progress = FALSE
))
second_evidence <- attr(second$assessments, "evidence")
expect_true(all(
second_evidence$output_manifest$status == "available"
))
})
test_that("reference quality schemas and type ranges are stable", {
expect_named(OpenSpecy:::.lib_warning_schema(),
c("algorithm", "artifact", "model", "warning"))
expect_type(OpenSpecy:::.lib_warning_schema()$warning, "character")
x <- tiny_build_lib()
x$metadata$spectrum_type <- rep(c("ftir", "raman"), each = 4)
typed <- OpenSpecy:::.lib_partition_reference_libraries(
list(raw = x), report = NULL
)$raw
expect_equal(range(typed$ftir$wavenumber), c(400, 4000))
expect_equal(range(typed$raman$wavenumber), c(200, 4000))
})
test_that("range restriction removes spectra that become flat", {
x <- tiny_build_lib()
x$metadata$spectrum_type <- "raman"
x$spectra[, 1] <- 1
outside_partition <- x$wavenumber > 4000
x$spectra[outside_partition, 1] <- seq_len(sum(outside_partition))
typed <- OpenSpecy:::.lib_partition_reference_libraries(
list(raw = x), report = NULL
)$raw$raman
expect_false("s1" %in% typed$metadata$sample_name)
partition_drops <- attr(typed, "range_flat_drops", exact = TRUE)
expect_equal(partition_drops$spectrum_id, "s1")
expect_equal(partition_drops$reason, "post_partition_flat_spectrum")
model_source <- tiny_build_lib()
model_source$metadata$spectrum_type <- "raman"
model_source$spectra[, 1] <- 1
outside_model <- model_source$wavenumber > 3200
model_source$spectra[outside_model, 1] <- seq_len(sum(outside_model))
medoids <- OpenSpecy:::.lib_build_medoids(
list(derivative = list(raman = model_source)),
report = function(...) NULL, progress = FALSE
)$derivative$raman
expect_false("s1" %in% medoids$metadata$sample_name)
model_drops <- attr(medoids, "range_flat_drops", exact = TRUE)
expect_equal(model_drops$spectrum_id, "s1")
expect_equal(model_drops$reason, "post_model_range_flat_spectrum")
})
test_that("identification ranges retain partial spectra and drop empty ones", {
axis <- seq(400, 4000, by = 6)
spectra <- cbind(
complete = sin(axis / 100),
partial = ifelse(axis < 1200, NA_real_, cos(axis / 90)),
outside_only = ifelse(axis < 800, 1, NA_real_)
)
object <- as_OpenSpecy(
axis, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
spectrum_type = "ftir",
material_class = "plastic"
)
)
restricted <- OpenSpecy:::.lib_restrict_model_range(object, "ftir")
expect_equal(range(restricted$wavenumber), c(802, 3196))
expect_identical(colnames(restricted$spectra), c("complete", "partial"))
expect_identical(
attr(restricted, "identification_dropped_ids"), "outside_only"
)
expect_true(anyNA(restricted$spectra[, "partial"]))
})
test_that("reference regex table contains only genuinely variable rules", {
expect_true(OpenSpecy:::.lib_regex_is_exact_literal(
"^poly\\(amide\\)$"
))
expect_false(OpenSpecy:::.lib_regex_is_exact_literal(
"^olefin[[:space:]]*\\(pe(?:[[:space:]]|\\x2c|\\)|$)"
))
expect_false(OpenSpecy:::.lib_regex_is_exact_literal(
"^(?:cotton|wool|silk)$"
))
regex_reference <- data.table::fread(
reference_workflow_data_path("classes_regex.csv")
)
expect_false(any(vapply(
regex_reference$pattern,
OpenSpecy:::.lib_regex_is_exact_literal,
logical(1)
)))
exact <- data.table::fread(
reference_workflow_data_path("classes_reference.csv")
)
expect_true(all(c(
"epoxide", "poly 1-butene isotactic", "poly 4-methyl-1-pentene",
"poly(amide)", "poly(styrene)", "poly(vinylchloride)",
"polyethylene glycol"
) %in% exact$spectrum_identity))
predicted <- predict_class_reference(
data.table::data.table(
spectrum_identity = c(
"sample sbr rubber", "sample epdm gasket", "sample acrylic paint",
"sample urethane paint", "sample alkyd varnish"
),
material = NA_character_
),
regex_reference, return = "table"
)
expect_identical(
predicted$material,
c(
"styrene-butadiene",
"epdm rubber (ethylene propylene diene monomer rubber)",
"polyacrylates", "polyurethanes", "polyesters"
)
)
})
test_that("official material hierarchy uses concise reviewed polymer classes", {
hierarchy <- data.table::fread(
reference_workflow_data_path("material_hierarchy.csv")
)
expect_identical(anyDuplicated(hierarchy$material), 0L)
expect_false(anyNA(hierarchy$material_class))
expect_false(any(!nzchar(trimws(hierarchy$material_class))))
expect_identical(
hierarchy[material == "poly(ethylene)", material_class], "polyethylene"
)
expect_identical(
hierarchy[material == "poly(propylene)", material_class], "polypropylene"
)
expect_identical(
hierarchy[material == "poly(tetrafluoroethylene)", material_class],
"polytetrafluoroethylene"
)
expect_identical(
hierarchy[material == "poly(ethylene-vinyl acetate) (EVA)",
material_class],
"polyethylene-vinyl acetate"
)
expect_identical(
hierarchy[material == "styrene-butadiene", material_class],
"poly(styrene-butadiene) rubber"
)
expect_identical(
hierarchy[
material == "epdm rubber (ethylene propylene diene monomer rubber)",
material_class
],
"poly(ethylene-propylene-diene) rubber"
)
expect_identical(
hierarchy[material == "poly(ethylene glycol)", material_class],
"polyethers"
)
parenthetical_classes <- unique(
hierarchy[grepl("[()]", material_class), material_class]
)
expect_setequal(parenthetical_classes, c(
"poly(ethylene-propylene-diene) rubber",
"poly(styrene-butadiene) rubber",
"polyhydroxy(meth)acrylates"
))
paint_classes <- c("paint", "acrylic paint", "alkyd paint", "urethane paint")
expect_false(any(hierarchy$material_class %in% paint_classes))
exceptions <- c(
"other plastic"
)
polymer_classes <- unique(hierarchy[material_type == "plastic", material_class])
expect_true(all(startsWith(setdiff(polymer_classes, exceptions), "poly")))
})
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.
tiny_build_lib <- function() {
wavenumber <- seq(100, 6100, by = 100)
base_a <- dnorm(seq(-3, 3, length.out = length(wavenumber)))
base_b <- rev(cumsum(seq_along(wavenumber)) / sum(seq_along(wavenumber)))
spectra <- sapply(seq_len(8), function(i) {
if (i <= 4) base_a + i / 20 else base_b + i / 20
})
colnames(spectra) <- paste0("s", seq_len(ncol(spectra)))
as_OpenSpecy(
wavenumber,
spectra = spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
source = c("A", "B", "C", "C", "A", "B", "C", "C"),
label = c("nylon 6", "polyamides", "plastic", "missing",
"pet", "polyesters", "plastic", "missing"),
material_class = rep(c("class_a", "class_b"), each = 4),
spectrum_type = rep("ftir", 8),
intensity_units = rep("absorbance", 8)
),
attributes = list(intensity_unit = "absorbance")
)
}
reference_workflow_data_path <- function(file) {
roots <- c(
testthat::test_path("..", ".."),
Sys.getenv("GITHUB_WORKSPACE", unset = "")
)
roots <- unique(roots[nzchar(roots)])
candidates <- file.path(roots, "workflows", "data", file)
existing <- candidates[file.exists(candidates)]
testthat::skip_if(
length(existing) == 0L,
"repository-only reference workflow tables are not installed"
)
existing[[1L]]
}
test_that("make_lib_lookup_template() returns or writes deduplicated templates", {
lib <- tiny_build_lib()
template <- make_lib_lookup_template(lib, columns = "source",
add = "LibraryType")
expect_s3_class(template, "data.table")
expect_equal(sort(template$source), c("A", "B", "C"))
expect_true("LibraryType" %in% names(template))
expect_true(all(is.na(template$LibraryType)))
tmp <- tempfile(fileext = ".csv")
invisible(make_lib_lookup_template(lib, columns = "source",
add = "LibraryType", path = tmp))
expect_true(file.exists(tmp))
})
test_that("join_lib_metadata() reports incomplete and duplicate joins", {
lib <- tiny_build_lib()
lookup <- data.table::data.table(source = c("A", "B"),
LibraryType = c("type_a", "type_b"))
expect_warning(
joined <- join_lib_metadata(lib, lookup, by = "source"),
"unmatched_metadata_key"
)
expect_true(check_OpenSpecy(joined))
expect_equal(nrow(joined$metadata), ncol(joined$spectra))
expect_true("source" %in% names(joined$metadata))
expect_false(any(c("source.x", "source.y") %in% names(joined$metadata)))
expect_true("LibraryType" %in% names(joined$metadata))
expect_error(
join_lib_metadata(lib, lookup, by = "source", require_complete = TRUE),
"unmatched_metadata_key"
)
dup_lookup <- data.table::data.table(source = c("A", "A"),
LibraryType = c("x", "y"))
expect_error(join_lib_metadata(lib, dup_lookup, by = "source"),
"unique")
})
test_that("join_material_hierarchy() matches user-specified levels", {
lib <- tiny_build_lib()
hierarchy <- data.table::data.table(
material = c("nylon 6", "pet"),
material_class = c("polyamides", "polyesters"),
material_type = c("plastic", "plastic")
)
expect_warning(
joined <- join_material_hierarchy(
lib,
hierarchy = hierarchy,
key_col = "label",
levels = c("material", "material_class", "material_type"),
output_names = c(material = "joined_material",
material_class = "joined_class",
material_type = "joined_type")
),
"unmatched_hierarchy_key"
)
expect_true(check_OpenSpecy(joined))
expect_equal(joined$metadata$joined_material[1], "nylon 6")
expect_equal(joined$metadata$joined_class[2], "polyamides")
expect_equal(joined$metadata$joined_type[3], "plastic")
expect_true(is.na(joined$metadata$joined_type[4]))
})
test_that("dedupe_spec() keeps identifiers aligned", {
lib <- tiny_build_lib()
lib$spectra[, 2] <- lib$spectra[, 1]
deduped <- dedupe_spec(lib)
expect_true(check_OpenSpecy(deduped))
expect_equal(ncol(deduped$spectra), 7)
expect_identical(colnames(deduped$spectra),
deduped$metadata$sample_name)
})
test_that("build_lib() uses legacy source-stage hashes for sample_name", {
wavenumber <- seq(50, 5000, by = 5)
spectra <- cbind(
sin(wavenumber / 200) + 2,
cos(wavenumber / 250) + 2
)
colnames(spectra) <- c("raw_a", "raw_b")
lib <- as_OpenSpecy(
wavenumber,
spectra = spectra,
metadata = data.table::data.table(sample_name = colnames(spectra)),
attributes = list(intensity_unit = "absorbance")
)
legacy_hash <- function(x, range = NULL, short_value = NULL) {
x <- manage_na(x, type = "remove")
spec <- conform_spec(x, range = range, res = 8)
if (!is.null(short_value) && nrow(spec$spectra) < 3) {
return(rep(short_value, ncol(x$spectra)))
}
spec <- smooth_intens(spec)
vapply(seq_len(ncol(spec$spectra)), function(i) {
digest::digest(
list(as.integer(spec$wavenumber),
as.integer(spec$spectra[, i] * 100)),
algo = "md5"
)
}, FUN.VALUE = character(1))
}
expected <- legacy_hash(lib)
expected_old <- legacy_hash(lib, range = c(100, 4000),
short_value = "new format")
built <- build_lib(
lib,
recipes = list(raw = list()),
dedupe = TRUE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(built$metadata$sample_name, expected)
expect_equal(built$metadata$sample_name_old, expected_old)
expect_equal(colnames(built$spectra), expected)
excluded <- build_lib(
lib,
recipes = list(raw = list()),
exclude_ids = expected_old[1],
dedupe = TRUE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(excluded$metadata$sample_name, expected[2])
})
test_that("reduce_lib() returns medoid ids or reduced OpenSpecy objects", {
lib <- tiny_build_lib()
ids <- reduce_lib(lib, group_cols = "material_class", k = 2, min_n = 2,
return = "ids")
expect_equal(length(ids), 4)
reduced <- reduce_lib(lib, group_cols = "material_class", k = 2, min_n = 2)
expect_true(check_OpenSpecy(reduced))
expect_equal(ncol(reduced$spectra), 4)
})
test_that("reduce_lib() uses cluster PAM medoids and reports useful progress", {
lib <- tiny_build_lib()
ids <- .lib_ids(lib, "sample_name")
reduction_obj <- lib
reduction_obj$spectra <- make_rel(
mean_replace(lib$spectra, na.rm = TRUE), na.rm = TRUE
)
reduction_obj$spectra[!is.finite(reduction_obj$spectra)] <- 0
groups <- do.call(paste, c(lib$metadata[, "material_class", with = FALSE],
sep = "_"))
expected <- unlist(lapply(split(seq_along(groups), groups), function(idx) {
if (length(idx) <= 2L) return(ids[idx])
x <- filter_spec(reduction_obj, idx)
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)
set.seed(OpenSpecy:::.lib_pam_seed(ids[idx]))
ids[idx][cluster::pam(
distance, k = 2, diss = TRUE, variant = "faster"
)$id.med]
}), use.names = FALSE)
messages <- capture.output(
actual <- reduce_lib(
lib, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = TRUE
),
type = "message"
)
expect_equal(actual, expected)
messages <- paste(messages, collapse = "\n")
expect_match(messages, "spectra in .* groups")
expect_match(messages, "PAM group 1/2 starting")
expect_match(messages, "correlation complete")
expect_match(messages, "PAM complete")
expect_match(messages, "variant=faster")
expect_match(messages, "kept=4/8")
expect_silent(
reduce_lib(lib, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = FALSE)
)
expect_error(reduce_lib(lib, progress = NA), "'progress'")
})
test_that("oversized PAM groups use deterministic sampled correlation medoids", {
set.seed(42)
wn <- seq(800, 3200, length.out = 60)
spectra <- matrix(runif(length(wn) * 120L), nrow = length(wn))
colnames(spectra) <- paste0("large_", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(sample_name = colnames(spectra))
)
messages <- capture.output(
first <- OpenSpecy:::.pam_large_group_ids(
lib, id_col = "sample_name", k = 5L, progress = TRUE,
group_label = "test", samples = 3L, sample_size = 60L
),
type = "message"
)
second <- OpenSpecy:::.pam_large_group_ids(
lib, id_col = "sample_name", k = 5L, progress = FALSE,
group_label = "test", samples = 3L, sample_size = 60L
)
expect_identical(first, second)
expect_length(first, 5L)
expect_true(all(first %in% colnames(spectra)))
expect_match(paste(messages, collapse = "\n"), "sampled PAM complete")
})
test_that("build_model_lib() returns the model library artifact structure", {
skip_if_not_installed("glmnet")
lib <- tiny_build_lib()
model <- suppressWarnings(
build_model_lib(lib, type_col = NULL, min_n = 2, nlambda = 3)
)
expect_named(model, c("model", "model_type", "lambda_selected",
"lambda_path_complete", "selected_lambda_converged",
"convergence_error", "training_groups", "selection_metric",
"lambda_metrics", "dimension_conversion", "tests",
"coefficients", "class_names", "class_num",
"observation_count", "fill", "support",
"class_support", "fill_method", "fill_replaced",
"variable_num",
"all_variables", "variables_in"))
expect_true(is_OpenSpecy(model$fill))
expect_identical(model$model_type, "logistic_regression")
expect_identical(model$selection_metric, "macro_class_accuracy")
expect_identical(model$fill_method, "wavenumber_mean")
expect_true(all(c("lambda", "macro_class_accuracy", "overall_accuracy",
"selected", "selection_scope", "selection_rule") %in%
names(model$lambda_metrics)))
expect_true(all(c("factor_num", "name") %in%
names(model$dimension_conversion)))
expect_true(all(c("spectrum_id", "technique", "expected_class",
"predicted_class", "correct", "score", "split",
"provenance") %in% names(model$tests)))
expect_null(model$model$call)
before <- suppressWarnings(match_spec(lib, library = model))
full_bytes <- length(serialize(model$model, NULL))
slim <- OpenSpecy:::.lib_slim_model(model)
after <- suppressWarnings(match_spec(lib, library = slim))
expect_length(slim$model$lambda, 1L)
expect_lt(length(serialize(slim$model, NULL)), full_bytes)
expect_equal(after, before, tolerance = 1e-12)
})
test_that("release sanitizers retain runtime state and remove assessments", {
lib <- tiny_build_lib()
attr(lib, "derivative_order") <- "1"
attr(lib, "transformations") <- list(list(method = "derivative"))
attr(lib, "quality_control_report") <- data.table::data.table(value = 1)
attr(lib, "prune_report") <- list(summary = data.table::data.table(value = 1))
attr(lib$metadata, "join_report") <- data.table::data.table(value = 1)
slim <- OpenSpecy:::.lib_slim_reference_object(lib)
expect_true(check_OpenSpecy(slim))
expect_identical(attr(slim, "derivative_order"), "1")
expect_equal(attr(slim, "transformations"), list(list(method = "derivative")))
expect_null(attr(slim, "quality_control_report", exact = TRUE))
expect_null(attr(slim, "prune_report", exact = TRUE))
expect_null(attr(slim$metadata, "join_report", exact = TRUE))
expect_identical(colnames(slim$spectra), slim$metadata$sample_name)
model <- list(
model = structure(list(), class = "mock_model"),
model_type = "logistic_regression", lambda_selected = 0.1,
dimension_conversion = data.table::data.table(factor_num = 1L, name = "a"),
coefficients = data.table::data.table(), class_names = "a", class_num = 1L,
observation_count = 8L, fill = lib, fill_method = "wavenumber_mean",
variable_num = nrow(lib$spectra), all_variables = lib$wavenumber,
variables_in = lib$wavenumber,
tests = data.table::data.table(correct = TRUE),
lambda_metrics = data.table::data.table(lambda = 0.1),
support = data.table::data.table(spectrum_id = "s1")
)
attr(model, "training_warnings") <- "diagnostic warning"
slim_model <- OpenSpecy:::.lib_slim_model(model)
expect_true(all(names(slim_model) %in%
OpenSpecy:::.lib_runtime_model_fields()))
expect_false(any(c("tests", "lambda_metrics", "support") %in%
names(slim_model)))
expect_null(attr(slim_model, "training_warnings", exact = TRUE))
expect_true(check_OpenSpecy(slim_model$fill))
expect_null(attr(slim_model$fill, "quality_control_report", exact = TRUE))
expect_true(OpenSpecy:::.lib_selected_lambda_converged(list(
model = structure(list(jerr = 0L), class = "glmnet")
)))
expect_false(OpenSpecy:::.lib_selected_lambda_converged(list(
model = structure(list(jerr = -3L), class = "glmnet")
)))
expect_false(OpenSpecy:::.lib_selected_lambda_converged(list(
model = structure(list(jerr = 0L), class = "glmnet"),
selected_lambda_converged = FALSE
)))
})
test_that("official builders can opt into host workers without changing defaults", {
previous <- options("OpenSpecy.build_workers")
on.exit(options(previous), add = TRUE)
options(OpenSpecy.build_workers = NULL)
expect_identical(OpenSpecy:::.lib_build_workers(), 1L)
options(OpenSpecy.build_workers = 8L)
expect_identical(OpenSpecy:::.lib_build_workers(), 8L)
options(OpenSpecy.build_workers = -1L)
expect_identical(OpenSpecy:::.lib_build_workers(), 1L)
})
test_that("build_model_lib() trains and deploys a balanced probability random forest", {
skip_if_not_installed("ranger")
lib <- tiny_build_lib()
lib$spectra[1:3, 1] <- NA_real_
lib$metadata$material_class <- c(rep("class_a", 6), rep("class_b", 2))
model <- build_model_lib(
lib, type_col = NULL, min_n = 2, method = "random_forest",
num.trees = 30L, min.node.size = 1L, mtry = 4L
)
expect_identical(model$model_type, "random_forest")
expect_s3_class(model$model, "ranger")
expect_true(model$fill_replaced >= 3L)
expect_true(all(c("accuracy", "macro_class_accuracy", "mean_score",
"brier_score") %in% names(model$oob_metrics)))
expect_true(all(c("wavenumber", "importance") %in%
names(model$feature_importance)))
expect_equal(model$class_weights$weight, c(2 / 3, 2))
expect_true(all(model$class_weights$application == "case_sampling"))
expect_identical(
model$training_parameters$balance_method,
"inverse_frequency_case_sampling"
)
expect_identical(model$training_parameters$num_threads, 1L)
expect_equal(nrow(model$tests), ncol(lib$spectra))
prediction <- suppressWarnings(match_spec(lib, library = model))
expect_equal(nrow(prediction), ncol(lib$spectra))
expect_true(all(prediction$name %in% c("class_a", "class_b")))
})
test_that("official model building records fit warnings and progress", {
lib <- tiny_build_lib()
messages <- character()
local_mocked_bindings(
train_spec_model = function(...) {
warning("mock convergence warning", call. = FALSE)
list(
observation_count = 4L, class_num = 2L,
lambda_selected = 0.1
)
},
.package = "OpenSpecy"
)
result <- OpenSpecy:::.lib_build_models(
libraries = list(),
medoids = list(derivative = list(nir = lib)),
report = function(message) messages <<- c(messages, message)
)
expect_identical(
result$warnings,
data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative", model = "nir",
warning = "mock convergence warning"
)
)
expect_identical(
attr(result$models$logistic_regression$derivative$nir,
"training_warnings"),
"mock convergence warning"
)
expect_true(any(grepl("model warning", messages, fixed = TRUE)))
expect_true(any(grepl("model complete", messages, fixed = TRUE)))
})
test_that("official random forests train on full libraries rather than medoids", {
skip_if_not_installed("ranger")
base <- tiny_build_lib()
full <- base
full$spectra <- do.call(cbind, lapply(1:3, function(copy) {
values <- base$spectra + copy / 1000
colnames(values) <- paste0(colnames(values), "_", copy)
values
}))
full$metadata <- data.table::rbindlist(lapply(1:3, function(copy) {
metadata <- data.table::copy(base$metadata)
metadata$sample_name <- paste0(metadata$sample_name, "_", copy)
metadata
}))
full <- as_OpenSpecy(full)
result <- OpenSpecy:::.lib_build_models(
libraries = list(raw = list(ftir = full)), medoids = list(),
report = function(...) NULL,
methods = "random_forest",
random_forest_args = list(num.trees = 20L, min.node.size = 1L, mtry = 4L)
)
model <- result$models$random_forest$raw$ftir
expect_identical(model$model_type, "random_forest")
expect_equal(model$observation_count, ncol(full$spectra))
expect_equal(model$training_parameters$num_trees, 20L)
})
test_that("typed random forests do not repeat FTIR and Raman in a combined fit", {
lib <- tiny_build_lib()
local_mocked_bindings(
train_spec_model = function(x, ...) {
list(
model_type = "random_forest",
observation_count = ncol(x$spectra), class_num = 2L,
fill_replaced = 0L,
oob_metrics = data.table::data.table(macro_class_accuracy = 0.5),
training_parameters = data.table::data.table(
num_trees = 20L, mtry = 2L
)
)
},
.package = "OpenSpecy"
)
result <- OpenSpecy:::.lib_build_models(
libraries = list(raw = list(ftir = lib, raman = lib)),
medoids = list(), report = function(...) NULL,
methods = "random_forest"
)
expect_named(result$models$random_forest$raw, c("ftir", "raman"))
})
test_that("build_lib() applies named recipes to merged sources", {
lib <- tiny_build_lib()
built <- build_lib(
list(lib),
recipes = list(raw = list(),
relative = function(x) make_rel(x, na.rm = TRUE)),
dedupe = FALSE,
signal_noise = FALSE
)
expect_named(built, c("raw", "relative"))
expect_true(check_OpenSpecy(built$raw))
expect_true(check_OpenSpecy(built$relative))
})
test_that("build_lib() requires explicit source inputs", {
expect_error(
build_lib(),
"'x' must specify the source library file path"
)
})
test_that("build_lib() converts metadata intensity units before recipes", {
lib <- tiny_build_lib()
lib$spectra <- matrix(
rep(c(50, 25, 0.5, 0.25, 2), each = nrow(lib$spectra)),
nrow = nrow(lib$spectra),
dimnames = list(NULL, paste0("u", 1:5))
)
lib$spectra[1, 2] <- NA_real_
lib$metadata <- data.table::data.table(
sample_name = colnames(lib$spectra),
intensity_units = c(
"Reflectance (%)", "transmittance", "absorbance", "mystery", NA
)
)
attr(lib, "intensity_unit") <- NULL
original <- lib$spectra
expect_warning(
built <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"skipped 2 spectrum/s.*<missing> \\(1\\).*mystery \\(1\\)|skipped 2 spectrum/s.*mystery \\(1\\).*<missing> \\(1\\)"
)
expect_equal(
built$spectra[, 1],
adj_intens(original[, 1], type = "reflectance", make_rel = FALSE)
)
expect_equal(
built$spectra[, 2],
adj_intens(
original[, 2], type = "transmittance", make_rel = FALSE,
na.rm = TRUE
)
)
expect_equal(built$spectra[, 3:5], original[, 3:5])
expect_equal(
built$metadata$intensity_units,
c("absorbance", "absorbance", "absorbance", "mystery", NA)
)
expect_null(attr(built, "intensity_unit"))
expect_true(check_OpenSpecy(built))
})
test_that("build_lib() treats intensity_unit attribute as primary truth", {
lib <- tiny_build_lib()
lib$spectra[,] <- 50
lib$metadata$intensity_units <- "transmittance"
attr(lib, "intensity_unit") <- "reflectance"
built <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE
)$raw
expect_equal(
built$spectra,
adj_intens(lib$spectra, type = "reflectance", make_rel = FALSE)
)
expect_equal(built$metadata$intensity_units, rep("absorbance", 8))
expect_equal(attr(built, "intensity_unit"), "absorbance")
attr(lib, "intensity_unit") <- "absorbance"
unchanged <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE
)$raw
expect_equal(unchanged$spectra, lib$spectra)
expect_equal(unchanged$metadata$intensity_units, rep("absorbance", 8))
})
test_that("build_lib() can preserve declared intensity units", {
lib <- tiny_build_lib()
lib$spectra[,] <- 50
lib$metadata$intensity_units <- "reflectance"
attr(lib, "intensity_unit") <- "reflectance"
built <- build_lib(
list(lib),
recipes = list(raw = list()),
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE
)$raw
expect_equal(built$spectra, lib$spectra)
expect_equal(built$metadata$intensity_units, rep("reflectance", 8))
expect_equal(attr(built, "intensity_unit"), "reflectance")
lib$metadata$intensity_units <- "transmittance"
preserved <- build_lib(
lib,
recipes = list(raw = list()),
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(preserved$spectra, lib$spectra)
expect_equal(preserved$metadata$intensity_units, rep("transmittance", 8))
expect_equal(attr(preserved, "intensity_unit"), "reflectance")
})
test_that("build_lib() accepts and restricts one OpenSpecy object", {
lib <- tiny_build_lib()
expect_message(
built <- build_lib(
lib,
recipes = list(raw = list()),
restrict_range_args = list(
min = c(100, 2500),
max = c(2000, 4000)
),
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"using one in-memory OpenSpecy source"
)
keep <- lib$wavenumber <= 2000 |
(lib$wavenumber >= 2500 & lib$wavenumber <= 4000)
expect_equal(built$wavenumber, lib$wavenumber[keep])
expect_equal(built$spectra, lib$spectra[keep, , drop = FALSE])
expect_silent(build_lib(
lib,
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
))
expect_error(
build_lib(list(lib), restrict_range_args = list(c(100, 2000))),
"named list"
)
})
test_that("build_lib() reads one or many OpenSpecy objects from each RDS", {
left <- filter_spec(tiny_build_lib(), 1:2)
right <- filter_spec(tiny_build_lib(), 3:4)
single_file <- tempfile(fileext = ".rds")
list_file <- tempfile(fileext = ".RDS")
invalid_file <- tempfile(fileext = ".rds")
saveRDS(left, single_file)
saveRDS(list(left, right), list_file)
saveRDS(list(left, "not OpenSpecy"), invalid_file)
single <- build_lib(
single_file,
recipes = list(raw = list()),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
combined <- build_lib(
list_file,
recipes = list(raw = list()),
range = NULL,
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(single$spectra, left$spectra)
expect_equal(ncol(combined$spectra), 4)
expect_equal(combined$metadata$sample_name, paste0("s", 1:4))
expect_error(
build_lib(invalid_file, progress = FALSE),
"File path 1 must contain one OpenSpecy object or a nonempty list"
)
})
test_that("build_lib() bulk-prepares legacy same-axis source lists", {
lib <- tiny_build_lib()
sources <- split_spec(list(lib))
sources <- lapply(sources, function(x) {
x$spectra <- data.table::as.data.table(x$spectra)
x
})
expect_silent(
built <- build_lib(
sources,
recipes = list(raw = list()),
range = NULL,
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
)
expect_equal(built$wavenumber, lib$wavenumber)
expect_equal(built$spectra, lib$spectra)
expect_equal(built$metadata$sample_name, lib$metadata$sample_name)
})
test_that("build_lib() converts each source before merging", {
left <- filter_spec(tiny_build_lib(), 1:2)
right <- filter_spec(tiny_build_lib(), 3:4)
left$spectra[,] <- 50
right$spectra[,] <- 0.5
attr(left, "intensity_unit") <- "reflectance"
attr(right, "intensity_unit") <- NULL
right$metadata$intensity_units <- "transmittance"
built <- build_lib(
list(left, right),
recipes = list(raw = list()),
range = NULL,
dedupe = FALSE,
signal_noise = FALSE
)$raw
expected <- cbind(
adj_intens(left$spectra, type = "reflectance", make_rel = FALSE),
adj_intens(right$spectra, type = "transmittance", make_rel = FALSE)
)
colnames(expected) <- colnames(built$spectra)
expect_equal(built$spectra, expected)
expect_equal(attr(built, "intensity_unit"), "absorbance")
expect_equal(built$metadata$intensity_units, rep("absorbance", 4))
})
test_that("metadata name helpers support smart and extensible matching", {
expect_equal(
lib_clean_name(c(" User Name ", "Laser (%)", "Method...3")),
c("user_name", "laser_perc", "method_3")
)
name_lookup <- lib_metadata_name_lookup(
campaign_code = "campaign id",
project_code = character(),
review_note = character(),
regex = list(instrument_mode = "^method_[0-9]+$")
)
expect_false(any(c("username", "samplename", "librarytype") %in%
name_lookup$source_name, na.rm = TRUE))
metadata <- data.table::data.table(
UserName = c("alias_a", NA),
user_name = c(NA, "canonical_b"),
ProjectCodes = c("p1", "p2"),
`Review Notes` = c("check", "keep"),
Campaign.ID = c("campaign_a", "campaign_b"),
Method.42 = c("ftir", "raman")
)
cleaned <- lib_clean_metadata(metadata, name_lookup)
expect_equal(cleaned$user_name, c("alias_a", "canonical_b"))
expect_equal(cleaned$project_code, c("p1", "p2"))
expect_equal(cleaned$campaign_code, c("campaign_a", "campaign_b"))
expect_equal(cleaned$review_note, c("check", "keep"))
expect_equal(cleaned$instrument_mode, c("ftir", "raman"))
expect_false("campaign_id" %in% names(cleaned))
cleaned_values <- lib_clean_metadata(
data.table::data.table(
Organization = c(" Monterey Bay Aquarium Research Institute ", "NULL"),
SpectrumType = c("Raman", " not available "),
numeric_value = c(1, 2)
),
clean_values = TRUE
)
expect_equal(
cleaned_values$organization,
c("monterey bay aquarium research institute", NA)
)
expect_equal(cleaned_values$spectrum_type, c("raman", NA))
expect_equal(cleaned_values$numeric_value, c(1, 2))
strict_lookup <- lib_metadata_name_lookup(
project_code = character(),
defaults = FALSE,
match_without_underscores = FALSE,
match_singular_plural = FALSE
)
strict <- lib_clean_metadata(
data.table::data.table(ProjectCodes = "p1"),
strict_lookup
)
expect_named(strict, "projectcodes")
})
test_that("metadata harmonization coalesces reviewed aliases only", {
metadata <- data.table::data.table(
spectrum_identity = c("canonical", NA),
interpretation = c("ignored", "interpreted"),
form_factor = c("film", NA),
shape = c(NA, "fiber"),
datatype = c("absorbance", "raman shift"),
xunits = c("cm-1", NA),
x_unit = c(NA, "1/cm"),
spectrumid = c("a", "b"),
locationdescription = c("left", "right"),
name = c("source name", "source name 2"),
names = c("other meaning", "other meaning 2"),
file = c("raw path", "raw path 2"),
file_name = c("display", "display 2"),
sample = c("source sample", "source sample 2"),
sample_name = c("stable-a", "stable-b")
)
cleaned <- lib_clean_metadata(metadata)
expect_equal(cleaned$spectrum_identity, c("canonical", "interpreted"))
expect_equal(cleaned$material_form, c("film", "fiber"))
expect_equal(cleaned$data_type, c("absorbance", "raman shift"))
expect_equal(cleaned$wavenumber_units, c("cm-1", "1/cm"))
expect_equal(cleaned$spectrum_id, c("a", "b"))
expect_equal(cleaned$location_description, c("left", "right"))
expect_true(all(c("name", "names", "file", "file_name", "sample",
"sample_name") %in% names(cleaned)))
})
test_that("metadata regex lookup reports overlapping patterns", {
name_lookup <- lib_metadata_name_lookup(
defaults = FALSE,
regex = list(
campaign = "^campaign",
identifier = "_id$"
)
)
expect_error(
lib_clean_metadata(
data.table::data.table(Campaign.ID = "campaign_a"),
name_lookup
),
"Multiple metadata name regular expressions.*Campaign.ID"
)
})
test_that("build_lib() cleans and coalesces metadata column names", {
lib <- tiny_build_lib()
lib$metadata[["UserName"]] <- c("alias_a", "alias_b", rep(NA, 6))
lib$metadata[["user name"]] <- c(NA, "canonical_b", rep(NA, 6))
lib$metadata[["NumberofAccumulations"]] <- c(10L, rep(NA_integer_, 7))
lib$metadata[["Number of sample scans"]] <- c(20L, 30L,
rep(NA_integer_, 6))
lib$metadata[["CAS REGISTRY NO"]] <- rep("25038-54-4", 8)
lib$metadata[["Laser (%)"]] <- rep(75, 8)
name_lookup <- lib_metadata_name_lookup(project_code = "Campaign ID")
lib$metadata[["Campaign.ID"]] <- rep("campaign_a", 8)
built <- build_lib(
list(lib),
recipes = list(raw = list()),
metadata_name_lookup = name_lookup,
dedupe = FALSE,
signal_noise = FALSE
)$raw
expect_true(all(grepl("^[a-z0-9]+(?:_[a-z0-9]+)*$",
names(built$metadata))))
expect_equal(built$metadata$user_name[1:2],
c("alias_a", "canonical_b"))
expect_equal(built$metadata$number_of_accumulations[1:2], c(10L, 30L))
expect_equal(built$metadata$cas_number, rep("25038-54-4", 8))
expect_equal(built$metadata$laser_perc, rep(75, 8))
expect_equal(built$metadata$project_code, rep("campaign_a", 8))
expect_false(any(c("username", "numberofaccumulations",
"number_of_sample_scans") %in% names(built$metadata)))
})
test_that("source metadata invalid bytes are normalized before merging", {
invalid <- rawToChar(as.raw(c(0x66, 0x80, 0x6f)))
Encoding(invalid) <- "unknown"
expect_false(validUTF8(invalid))
normalized <- OpenSpecy:::.lib_normalize_metadata_encoding(
data.table::data.table(value = invalid)
)
expect_true(validUTF8(normalized$value))
expect_equal(normalized$value, "fo")
})
test_that("build_lib() runs default joins, processing, SNR, and assessment", {
lib <- tiny_build_lib()
lib$spectra[1, 1] <- -1
source_lookup <- data.table::data.table(
Source = c("A", "B", "C"),
Material = c("mat_a", "mat_b", "mat_c")
)
hierarchy <- data.table::data.table(
Material = c("mat_a", "mat_b", "mat_c"),
`Material Class` = c("class_a", "class_b", "class_c"),
`Material Type` = rep("material", 3)
)
built <- suppressWarnings(build_lib(
list(lib),
metadata_lookups = source_lookup,
material_hierarchy = hierarchy,
assess = TRUE,
dedupe = FALSE
))
expect_named(built, c("raw", "derivative", "nobaseline"))
expect_true(all(vapply(built, check_OpenSpecy, logical(1))))
expect_true(all(c("material", "material_class", "material_type", "sn",
"assessment_flag", "assessment_issue_count",
"assessment_checks", "assessment_issues",
"assessment_potential_fixes") %in%
names(built$raw$metadata)))
expect_equal(attr(built$derivative, "derivative_order"), "1")
expect_equal(attr(built$nobaseline, "baseline"), "nobaseline")
expect_true(built$raw$metadata$assessment_flag[1])
})
test_that("build_lib() skips metadata lookups with no shared key", {
lib <- tiny_build_lib()
no_shared <- data.table::data.table(
missing_key = "not_present",
joined_value = "skipped"
)
no_overlap <- data.table::data.table(
source = "Z",
joined_value = "skipped"
)
output_overlap <- data.table::data.table(
source = c("A", "B", "C"),
library_type = c("polymers", "polymers", "paints"),
spectrum_type = c("ftir", "raman", "ftir")
)
ambiguous <- data.table::data.table(
source = "A",
sample_name = "s1",
joined_value = "ambiguous"
)
expect_message(
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = no_shared,
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"skipping metadata lookup 1/1"
)
expect_false("joined_value" %in% names(built$metadata))
expect_message(
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = no_overlap,
dedupe = FALSE,
signal_noise = FALSE
)$raw,
"no usable shared key values"
)
expect_false("joined_value" %in% names(built$metadata))
lib$metadata$library_type <- c("polymers", "paints", "polymers", "paints",
"polymers", "paints", "polymers", "paints")
lib$metadata$spectrum_type <- "Raman"
bad_utf8 <- rawToChar(as.raw(0xff))
Encoding(bad_utf8) <- "UTF-8"
lib$metadata$library_type[1] <- bad_utf8
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = output_overlap,
dedupe = FALSE,
signal_noise = FALSE,
clean_metadata_values = TRUE,
progress = FALSE
)$raw
expect_false(any(c("library_type.x", "library_type.y",
"spectrum_type.x", "spectrum_type.y") %in%
names(built$metadata)))
expect_equal(built$metadata$library_type[1:3],
c("polymers", "polymers", "paints"))
expect_equal(built$metadata$spectrum_type[1:3],
c("ftir", "raman", "ftir"))
expect_error(
build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = ambiguous,
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
),
"Candidate columns were"
)
})
test_that("build_lib() standardizes source keys before external lookups", {
lib <- filter_spec(tiny_build_lib(), 1:3)
lib$metadata$organization <- c("source org", NA, NA)
lib$metadata$user_name <- c("known", "fallback user", "unmapped")
lib$metadata$library_type <- c("metadata type", NA, NA)
source_lookup <- data.table::data.table(
organization = c("source org", "fallback user"),
library_type = c("organization type", "user type"),
spectrum_type = "raman"
)
built <- suppressWarnings(build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = list(
lookup = source_lookup,
by = "organization",
fill_only = TRUE
),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw)
expect_equal(built$metadata$library_type,
c("metadata type", "user type", NA))
expect_equal(built$metadata$spectrum_type, rep("ftir", 3))
expect_equal(built$metadata$organization,
c("source org", "fallback user", "unmapped"))
expect_equal(built$metadata$library_name,
c("source org", "fallback user", "unmapped"))
expect_equal(
attr(built, "metadata_lookup_reports")$canonical_source_keys[
problem == "filled_canonical_key", n
],
2L
)
})
test_that("build_lib() cleans filename-derived spectrum identities and keys", {
lib <- tiny_build_lib()
lib$metadata$spectrum_identity <- c(
"C:\\incoming\\Sample.CSV", "/tmp/Other.SPC",
"relative/folder/Third.HDF5", "compound pe/pa/pe",
"name.spc.csv", "plain identity", "opus.10", "unsupported.foo"
)
lookup <- data.table::data.table(
spectrum_identity = c(
"sample.csv", "other.spc", "third.hdf5", "compound pe/pa/pe",
"name", "plain identity", "opus.10", "unsupported.foo"
),
material = paste0("material_", seq_len(8))
)
built <- build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = list(lookup = lookup, by = "spectrum_identity"),
dedupe = FALSE,
signal_noise = FALSE,
clean_metadata_values = TRUE,
progress = FALSE
)$raw
expect_identical(
built$metadata$spectrum_identity,
c("sample", "other", "third", "compound pe/pa/pe", "name",
"plain identity", "opus", "unsupported.foo")
)
expect_identical(built$metadata$material, lookup$material)
report <- attr(built, "spectrum_identity_cleanup_report")
expect_s3_class(report, "data.table")
expect_equal(sum(report$n), 5L)
expect_true(all(c("original", "spectrum_identity", "n") %in%
names(report)))
})
test_that("build_lib() rejects lookup collisions after identity cleanup", {
lib <- tiny_build_lib()
lib$metadata$spectrum_identity <- rep("same", 8)
lookup <- data.table::data.table(
spectrum_identity = c("same.csv", "same.spc"),
material = c("first", "second")
)
expect_error(
build_lib(
lib,
recipes = list(raw = list()),
metadata_lookups = list(lookup = lookup, by = "spectrum_identity"),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
),
"Lookup keys must be unique"
)
})
test_that("prune_lib() orders classes, preserves floors, and audits removals", {
wn <- seq(500, 3500, length.out = 80)
shape_a <- dnorm(seq(-3, 3, length.out = length(wn)))
shape_b <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1)
spectra <- cbind(
shape_a, shape_a * 1.01, shape_a * 0.99, shape_a + 0.002,
shape_b,
shape_b * 1.01, shape_b * 0.99, shape_b + 0.002,
rev(shape_a), rev(shape_a) * 1.01
)
colnames(spectra) <- paste0("id", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(rep("large", 5), rep("medium", 3), rep("small", 2)),
material_type = "plastic",
spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 2, return = "report", progress = FALSE)
expect_true(check_OpenSpecy(report$object))
expect_equal(report$schedule$material_class, c("large", "medium", "small"))
expect_equal(report$schedule$initial_n, c(5L, 3L, 2L))
expect_true(nrow(report$removals) >= 1)
expect_equal(report$summary$reassigned, 0L)
expect_equal(nrow(report$excluded_classes), 0L)
expect_named(
report$excluded_classes,
names(OpenSpecy:::.lib_prune_excluded_class_schema())
)
expect_true(all(table(report$object$metadata$material_class) >= 2))
expect_identical(colnames(report$object$spectra),
report$object$metadata$sample_name)
expect_identical(report$retained_ids, colnames(report$object$spectra))
query <- which(lib$metadata$material_class == "large")
candidates <- seq_len(ncol(lib$spectra))
normalized <- OpenSpecy:::.lib_prune_normalize(
lib$spectra, lib$wavenumber, c(2200, 2420)
)
legacy <- OpenSpecy:::.lib_prune_correlations(
lib, query, candidates, c(2200, 2420), lib$metadata$sample_name
)
actual <- OpenSpecy:::.lib_prune_best_match(
query, candidates, normalized, lib$metadata$sample_name,
exclude_self = TRUE, block_size = 2L
)
bounded_full <- OpenSpecy:::.lib_prune_best_match(
query, candidates, normalized, lib$metadata$sample_name,
exclude_self = TRUE, block_size = length(query)
)
expect_equal(actual, bounded_full)
# Proportional synthetic spectra create several effectively exact ties.
# The bounded implementation deliberately resolves those ties by stable ID;
# BLAS operation shape can make the legacy full matrix select a different
# tied column. Verify that every bounded choice has the same scientific score.
legacy_best <- matrixStats::rowMaxs(legacy)
actual_columns <- match(actual$index, candidates)
legacy_at_actual <- legacy[cbind(seq_along(query), actual_columns)]
tolerance <- sqrt(.Machine$double.eps) * pmax(1, abs(legacy_best))
expect_true(all(abs(legacy_at_actual - legacy_best) <= tolerance))
})
test_that("cross-class pruning closes internal conflicts before independent evidence", {
normalized <- rbind(
high = c(1, 0, 0, 0),
b_l2 = c(1, 0, 0, 0),
b_l3 = c(1, 0, 0, 0),
tie_c = c(0, 1, 0, 0),
tie_d = c(0, 1, 0, 0),
same_source_e = c(0, 0, 1, 0),
same_source_f = c(0, 0, 1, 0),
generic = c(1, 0, 0, 0)
)
ids <- rownames(normalized)
classes <- c("class_a", "class_b", "class_b", "class_c", "class_d",
"class_e", "class_f", "other plastic")
libraries <- c("lib_1", "lib_2", "lib_3", "lib_4", "lib_5",
"lib_6", "lib_6", "lib_7")
pools <- rep("infrared", length(ids))
first <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes, pools, normalized, ids, libraries, threshold = 0.9,
block_size = 2L
)
second <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes, pools, normalized, ids, libraries, threshold = 0.9,
block_size = 5L
)
expect_identical(first$removed_rows, c(1L, 4L, 5L, 6L, 7L))
expect_equal(first$removals, second$removals)
expect_equal(first$removals[spectrum_id == "high", evidence_libraries], 2L)
expect_equal(first$removals[spectrum_id == "high", decision_round], 1L)
expect_true(all(
first$removals[spectrum_id %in% c("tie_c", "tie_d"), reason] ==
"cross_class_equal_library_evidence"
))
expect_true(all(
first$removals[spectrum_id %in% c("same_source_e", "same_source_f"),
phase] == "internal"
))
expect_true(all(
first$removals[spectrum_id %in% c("same_source_e", "same_source_f"),
reason] == "cross_class_equal_internal_degree"
))
expect_false("generic" %in% first$removals$spectrum_id)
})
test_that("internal cross-class majority removes the active high-degree spectrum", {
normalized <- rbind(
suspect = c(1, 0, 0, 0),
reference_1 = c(1, 0, 0, 0),
reference_2 = c(1, 0, 0, 0),
reference_3 = c(1, 0, 0, 0),
tie_a = c(0, 1, 0, 0),
tie_b = c(0, 1, 0, 0)
)
first <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", rep("class_b", 3), "class_c", "class_d"),
pools = rep("ftir", 6), normalized = normalized,
ids = rownames(normalized), library_names = rep("one_library", 6),
threshold = 0.9, min_n = 1, block_size = 2L
)
second <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", rep("class_b", 3), "class_c", "class_d"),
pools = rep("ftir", 6), normalized = normalized,
ids = rownames(normalized), library_names = rep("one_library", 6),
threshold = 0.9, min_n = 1, block_size = 5L
)
expect_identical(first$removed_rows, c(1L, 5L, 6L))
expect_equal(first$removals, second$removals)
expect_equal(first$removals[spectrum_id == "suspect", active_degree], 3L)
expect_equal(first$removals[spectrum_id == "suspect", decision_round], 1L)
expect_true(all(first$removals[spectrum_id %in% c("tie_a", "tie_b"),
decision_round] == 2L))
})
test_that("internal cross-class support counts span the complete database", {
normalized <- rbind(
a_source_1 = c(1, 0, 0, 0),
b_source_1a = c(1, 0, 0, 0),
b_source_1b = c(1, 0, 0, 0),
a_source_2 = c(0, 0, 1, 0),
a_source_3 = c(0, 0, 0, 1)
)
result <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", "class_b", "class_b", "class_a", "class_a"),
pools = rep("ftir", 5), support_groups = rep("ftir", 5),
normalized = normalized, ids = rownames(normalized),
library_names = c("lib_1", "lib_1", "lib_1", "lib_2", "lib_3"),
threshold = 0.9, min_n = 2
)
expect_identical(result$removed_rows, 1L)
expect_equal(result$removals$class_n_before, 3L)
expect_equal(result$removals$class_n_after, 2L)
expect_equal(result$removals$review_status, "automatic")
at_risk <- OpenSpecy:::.lib_prune_cross_class_conflicts(
classes = c("class_a", "class_b", "class_b", "class_a", "class_a"),
pools = rep("ftir", 5), support_groups = rep("ftir", 5),
normalized = normalized, ids = rownames(normalized),
library_names = c("lib_1", "lib_1", "lib_1", "lib_2", "lib_3"),
threshold = 0.9, min_n = 3
)
expect_equal(at_risk$removals$review_status, "global_support_at_risk")
})
test_that("quarantine bundles retain spectra and review metadata", {
lib <- tiny_build_lib()
lib$metadata[, `:=`(
material_class = rep(c("class_a", "class_b"), 4),
material_type = "plastic", spectrum_type = "ftir",
library_name = rep(c("lib_a", "lib_b"), 4)
)]
ids <- as.character(lib$metadata$sample_name)
removal <- OpenSpecy:::.lib_prune_cross_class_schema()[0]
removal <- data.table::data.table(
phase = "internal", correlation_view = "typed_full",
component_id = "internal:one", spectrum_id = ids[[1L]],
prior_class = "class_a", library_name = "lib_a",
matched_id = ids[[2L]], matched_class = "class_b",
matched_library = "lib_b", correlation = 0.95, pool = "ftir",
active_degree = 3L, matched_active_degree = 1L,
evidence_libraries = 0L, conflicting_spectra = 3L,
matched_evidence_libraries = 0L, decision_round = 1L,
threshold = 0.9, class_n_before = 4L, class_n_after = 3L,
schedule_order = NA_integer_, quarantine_status = "excluded",
review_status = "automatic",
reason = "cross_class_more_internal_conflicts"
)
part <- OpenSpecy:::.lib_quarantine_part(
lib, removal, "derivative", "ftir", min_n = 3
)
bundle <- OpenSpecy:::.lib_quarantine_bundle(
list(part), build_signature = "fixture", thresholds = 0.9
)
output <- tempfile("OpenSpecy-quarantine-review-")
dir.create(output)
on.exit(unlink(output, recursive = TRUE, force = TRUE), add = TRUE)
OpenSpecy:::.lib_write_quarantine_review(bundle, output)
restored <- readRDS(file.path(output, "review", "quarantined_spectra.rds"))
expect_s3_class(restored, "OpenSpecyQuarantine")
expect_named(restored, c("spectra", "conflicts", "manifest"))
expect_true(check_OpenSpecy(restored$spectra[["derivative/ftir"]]))
expect_equal(
restored$spectra[["derivative/ftir"]]$metadata$quarantine_reason,
"cross_class_more_internal_conflicts"
)
expect_true(all(file.exists(file.path(
output, "review",
c("quarantined_spectra_metadata.csv",
"quarantined_spectra_conflicts.csv")
))))
})
test_that("typed closure filters parents before medoid construction", {
wn <- seq(800, 3200, length.out = 60)
peak <- dnorm(seq(-3, 3, length.out = length(wn)))
other_1 <- dnorm(seq(-3, 3, length.out = length(wn)), mean = -1.5)
other_2 <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1.5)
spectra <- cbind(peak, peak * 1.01, peak * 0.99, other_1, other_2)
colnames(spectra) <- c("suspect", "b1", "b2", "a2", "a3")
parent <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c("class_a", "class_b", "class_b", "class_a", "class_a"),
material_type = "plastic", spectrum_type = "ftir",
library_name = c("lib_1", "lib_1", "lib_1", "lib_2", "lib_3")
)
)
closed <- OpenSpecy:::.lib_close_typed_reference_libraries(
list(derivative = list(ftir = parent)),
prune_spec = list(derivative = list(
cross_class = TRUE, cross_class_threshold = 0.9, min_n = 2
)),
progress = FALSE
)
expect_false("suspect" %in%
closed$libraries$derivative$ftir$metadata$sample_name)
expect_equal(unname(table(
closed$libraries$derivative$ftir$metadata$material_class
)["class_a"]), 2L)
expect_true(nrow(closed$removals) >= 1L)
expect_true(any(closed$removals$correlation_view == "typed_full"))
expect_length(closed$quarantine_parts, 1L)
expect_true(check_OpenSpecy(closed$quarantine_parts[[1L]]))
})
test_that("cross-class pruning uses a strict threshold", {
normalized <- rbind(c(1, 0), c(0.9, sqrt(1 - 0.9^2)))
args <- list(
classes = c("class_a", "class_b"), pools = c("infrared", "infrared"),
normalized = normalized, ids = c("a", "b"),
library_names = c("lib_a", "lib_b")
)
exact <- do.call(
OpenSpecy:::.lib_prune_cross_class_conflicts,
c(args, list(threshold = 0.9))
)
below <- do.call(
OpenSpecy:::.lib_prune_cross_class_conflicts,
c(args, list(threshold = 0.899))
)
expect_length(exact$removed_rows, 0L)
expect_identical(below$removed_rows, 1:2)
})
test_that("prune_lib() applies cross-class removal before generic reassignment", {
wn <- seq(500, 3500, length.out = 80)
shape <- dnorm(seq(-3, 3, length.out = length(wn)))
spectra <- cbind(shape, shape * 1.01, shape * 0.99, shape * 1.02)
colnames(spectra) <- c("suspect", "reference_1", "reference_2", "generic")
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c("class_a", "class_b", "class_b", "other plastic"),
material_type = "plastic", spectrum_type = "ftir",
library_name = c("lib_1", "lib_2", "lib_3", "lib_4")
)
)
attr(lib, "test_marker") <- "preserved"
report <- prune_lib(
lib, min_n = 1, cross_class = TRUE, cross_class_threshold = 0.9,
return = "report", progress = FALSE
)
expect_identical(report$cross_class_removals$spectrum_id, "suspect")
expect_equal(report$summary$cross_class_removed, 1L)
expect_false("suspect" %in% report$retained_ids)
expect_equal(
report$object$metadata[sample_name == "generic", material_class],
"class_b"
)
expect_identical(colnames(report$object$spectra),
report$object$metadata$sample_name)
expect_identical(report$object$wavenumber, lib$wavenumber)
expect_identical(attr(report$object, "test_marker"), "preserved")
expect_equal(report$object$spectra,
lib$spectra[, report$retained_ids, drop = FALSE])
recovered <- OpenSpecy:::.lib_recover_library_assessments(
list(derivative = report$object), list()
)
expect_equal(recovered$pruning_removals$spectrum_id, "suspect")
})
test_that("prune_lib() validates cross-class policy inputs", {
lib <- tiny_build_lib()
lib$metadata$material_type <- "plastic"
expect_error(prune_lib(lib, cross_class = NA), "TRUE or FALSE")
expect_error(prune_lib(lib, cross_class_threshold = 1.01), "in \\[0, 1\\]")
expect_error(
prune_lib(lib, cross_class = TRUE),
"requires populated library_name"
)
})
test_that("prune_lib() reassigns undersupported classes by spectrum type", {
wn <- seq(500, 3500, length.out = 40)
spectra <- vapply(seq_len(7), function(i) {
dnorm(seq(-3, 3, length.out = length(wn)), mean = i / 20)
}, numeric(length(wn)))
colnames(spectra) <- c(
"ftir_a1", "ftir_a2", "ftir_rare", "raman_rare1", "raman_rare2",
"ftir_unclassified", "ftir_missing"
)
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(
"stable", "stable", "rare", "rare", "rare", "unclassified", NA
),
material_type = "plastic",
spectrum_type = c(rep("ftir", 3), rep("raman", 2), "ftir", "ftir")
)
)
messages <- capture.output(
report <- prune_lib(
lib, min_n = 2, return = "report", progress = TRUE
),
type = "message"
)
expect_match(
paste(messages, collapse = "\n"),
"minimum support gate reassigned 1 and removed 1 spectrum/spectra"
)
expect_equal(
report$excluded_classes[, c(
"spectrum_type", "material_class", "observed_n", "minimum_spectra",
"shortfall", "destination_class", "spectra_removed", "action", "reason"
), with = FALSE],
data.table::data.table(
spectrum_type = c("ftir", "ftir"),
material_class = c("rare", "unclassified"),
observed_n = c(1L, 1L), minimum_spectra = c(2L, 2L),
shortfall = c(1L, 1L), destination_class = c("stable", NA_character_),
spectra_removed = c(0L, 1L), action = c("reassigned", "dropped"),
reason = c("class_below_min_n_reassigned",
"class_below_min_n_no_eligible_destination")
)
)
expect_true(all(c("raman_rare1", "raman_rare2") %in% report$retained_ids))
expect_true("ftir_missing" %in% report$retained_ids)
expect_true("ftir_rare" %in% report$retained_ids)
expect_false("ftir_unclassified" %in% report$retained_ids)
expect_equal(
report$object$metadata[sample_name == "ftir_rare", material_class],
"stable"
)
expect_equal(
report$reassignments[spectrum_id == "ftir_rare", reason],
"class_below_min_n_reassigned"
)
threshold_removals <- report$removals[reason == "class_below_min_n"]
expect_equal(threshold_removals$spectrum_id, "ftir_unclassified")
expect_true(all(is.na(threshold_removals$matched_id)))
expect_type(threshold_removals$matched_id, "character")
expect_equal(report$summary$classes_excluded, 1L)
expect_equal(report$summary$threshold_removed, 1L)
expect_true(check_OpenSpecy(report$object))
expect_identical(colnames(report$object$spectra),
report$object$metadata$sample_name)
recovered <- OpenSpecy:::.lib_recover_library_assessments(
list(raw = lib, derivative = report$object),
list(metadata_drop = data.table::data.table(metadata_column = character()))
)
expect_named(
recovered$pruning_excluded_classes,
names(OpenSpecy:::.lib_prune_excluded_assessment_schema())
)
expect_equal(unique(recovered$pruning_excluded_classes$artifact),
"derivative")
expect_equal(nrow(recovered$pruning_excluded_classes), 2L)
})
test_that("prune_lib() resolves generic labels before minimum support", {
wn <- seq(500, 3500, length.out = 40)
shape <- dnorm(seq(-3, 3, length.out = length(wn)))
spectra <- cbind(shape, shape * 1.01)
colnames(spectra) <- c("rare", "generic")
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c("polymer rare", "other plastic"),
material_type = "plastic", spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 2, return = "report", progress = FALSE)
expect_equal(report$object$metadata$material_class,
rep("polymer rare", 2))
expect_equal(nrow(report$reassignments), 1L)
expect_equal(nrow(report$excluded_classes), 0L)
expect_equal(report$schedule$initial_n, 2L)
})
test_that("prune_lib() sends an undersupported class to one correlated class", {
wn <- seq(500, 3500, length.out = 40)
shape_a <- dnorm(seq(-3, 3, length.out = length(wn)), mean = -0.5)
shape_b <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1)
spectra <- cbind(
shape_a, shape_a * 1.01, shape_a * 0.99,
shape_b, shape_b * 1.01, shape_b * 0.99,
shape_a * 1.02, shape_a * 0.98
)
colnames(spectra) <- paste0("whole_", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(rep("class_a", 3), rep("class_b", 3), rep("rare", 2)),
material_type = "plastic", spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 3, return = "report", progress = FALSE)
reassigned <- report$reassignments[prior_class == "rare"]
expect_equal(nrow(reassigned), 2L)
expect_identical(unique(reassigned$material_class), "class_a")
expect_true(all(report$object$metadata$sample_name %in%
colnames(lib$spectra)))
expect_false("rare" %in% report$object$metadata$material_class)
expect_equal(
report$excluded_classes[material_class == "rare", action],
"reassigned"
)
})
test_that("prune_lib() retains unclassified spectra outside matching", {
lib <- tiny_build_lib()
lib$metadata$material_type <- "plastic"
lib$metadata$material_class[1:2] <- "unclassified"
protected_ids <- lib$metadata$sample_name[1:2]
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_true(all(protected_ids %in% report$retained_ids))
expect_false("unclassified" %in% report$schedule$material_class)
expect_false(any(report$removals$prior_class == "unclassified"))
expect_false(any(report$removals$matched_class == "unclassified"))
})
test_that("prune_lib() reassigns generic classes and tolerates no candidates", {
lib <- filter_spec(tiny_build_lib(), 1:4)
lib$metadata$material_class <- c("polymer a", "other plastic",
"other material", "other plastic")
lib$metadata$material_type <- c("plastic", "plastic", "mineral", "plastic")
lib$metadata$spectrum_type <- c("ftir", "ftir", "raman", NA)
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_equal(report$object$metadata$material_class[2], "polymer a")
expect_equal(report$object$metadata$material_class[3], "other material")
expect_equal(report$object$metadata$material_class[4], "other plastic")
expect_equal(nrow(report$reassignments), 1)
expect_equal(report$summary$removed, 0L)
})
test_that("prune_lib() constrains generic reassignment and updates type", {
wn <- seq(500, 3500, length.out = 80)
plastic <- dnorm(seq(-3, 3, length.out = length(wn)))
organic <- dnorm(seq(-3, 3, length.out = length(wn)), mean = 1)
mineral <- rev(cumsum(seq_along(wn)))
spectra <- cbind(plastic, organic, mineral, plastic, organic, mineral)
colnames(spectra) <- paste0("generic", seq_len(ncol(spectra)))
lib <- as_OpenSpecy(
wn, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
material_class = c(
"polymer a", "organic matter", "mineral",
"other plastic", "other material", "other"
),
material_type = c(
"plastic", "not plastic", "not plastic", "plastic", "not plastic",
"other"
),
spectrum_type = "ftir"
)
)
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_equal(
report$object$metadata$material_class[4:6],
c("polymer a", "organic matter", "mineral")
)
expect_equal(
report$object$metadata$material_type[4:6],
c("plastic", "not plastic", "not plastic")
)
expect_equal(nrow(report$reassignments), 3L)
expect_true(all(report$reassignments$reason == "nearest_eligible_class"))
})
test_that("prune_lib() preserves non-generic class labels and empty audits", {
lib <- filter_spec(tiny_build_lib(), 1:2)
lib$metadata$material_class <- c("Polymer A", "Polymer A")
lib$metadata$material_type <- "plastic"
report <- prune_lib(lib, min_n = 1, return = "report", progress = FALSE)
expect_equal(report$object$metadata$material_class,
c("Polymer A", "Polymer A"))
expect_s3_class(report$reassignments, "data.table")
expect_s3_class(report$removals, "data.table")
expect_equal(nrow(report$reassignments), 0)
expect_equal(nrow(report$removals), 0)
expect_equal(report$summary$reassigned, 0L)
expect_equal(report$summary$removed, 0L)
})
test_that("build_lib() applies pruning only to named recipes", {
lib <- tiny_build_lib()
lib$metadata$material_type <- "plastic"
built <- build_lib(
lib,
recipes = list(raw = list(), processed = list()),
prune = list(processed = list(min_n = 1, progress = FALSE)),
dedupe = FALSE,
signal_noise = FALSE,
progress = FALSE
)
expect_null(attr(built$raw, "prune_report"))
expect_true(is.list(attr(built$processed, "prune_report")))
})
test_that("reference workflow tables encode reviewed taxonomy and source rules", {
classes <- data.table::fread(
reference_workflow_data_path("classes_reference.csv")
)
regex_classes <- data.table::fread(
reference_workflow_data_path("classes_regex.csv")
)
hierarchy <- data.table::fread(
reference_workflow_data_path("material_hierarchy.csv")
)
types <- data.table::fread(
reference_workflow_data_path("library_types.csv")
)
drops <- data.table::fread(
reference_workflow_data_path("metadata_drop_columns.csv")
)
known_bad <- data.table::fread(
reference_workflow_data_path("known_bad_ids.csv")
)
form_regex <- data.table::fread(
reference_workflow_data_path("material_form_regex.csv")
)
common_use <- data.table::fread(
reference_workflow_data_path("common_use_reference.csv")
)
expect_false(anyNA(classes$spectrum_identity))
expect_false(any(classes$spectrum_identity == ""))
expect_identical(anyDuplicated(classes$spectrum_identity), 0L)
expect_false(any(grepl(
"^([0-9]{1,2}-[A-Za-z]{3}|[A-Za-z]{3}-[0-9]{1,2})$",
classes$spectrum_identity
)))
expect_false(any(grepl("^regex:", classes$spectrum_identity)))
expect_named(regex_classes, c("pattern", "material"))
expect_false(anyNA(regex_classes$pattern))
expect_false(any(regex_classes$pattern == ""))
expect_identical(anyDuplicated(regex_classes$pattern), 0L)
class_audit <- predict_class_reference(
classes, regex_classes, return = "report"
)
expect_gte(class_audit$summary$predicted, 0L)
expect_equal(class_audit$summary$clashes, 0L)
expect_gt(class_audit$summary$overlaps, 0L)
expect_true(all(!is.na(regex_classes$material)))
expect_identical(anyDuplicated(known_bad$sample_name), 0L)
expect_true(all(grepl("^[[:xdigit:]]{32}$", known_bad$sample_name)))
expect_identical(anyDuplicated(hierarchy$material), 0L)
expect_silent(OpenSpecy:::.lib_validate_material_form_regex(form_regex))
expect_silent(OpenSpecy:::.lib_validate_common_use_reference(
common_use, hierarchy
))
expect_setequal(
common_use$material_class, unique(hierarchy$material_class)
)
expect_true(all(c("consumer", "industrial", "mixed") %in%
stats::na.omit(common_use$common_use)))
expect_equal(hierarchy[material == "other", material_class], "other")
expect_equal(hierarchy[material == "other", material_type], "other")
expect_equal(classes[spectrum_identity == "pa", material], "polyamides")
exact_classes <- classes[!grepl("^regex:", spectrum_identity)]
expect_identical(
OpenSpecy:::.lib_clean_spectrum_identity(exact_classes$spectrum_identity),
exact_classes$spectrum_identity
)
expect_true(all(
hierarchy[grepl("adipate", material), material_class] == "polyesters"
))
expect_false("polyamides (polylactams)" %in% hierarchy$material_class)
expect_true(all(c("polyamides", "polyacrylamides") %in%
hierarchy$material_class))
expect_equal(
classes[spectrum_identity == "plc004_kn95 outer layer_pp", material],
"poly(propylene)"
)
expect_equal(
classes[spectrum_identity == "plc008_label tape_unknown", material],
"other plastic"
)
expect_true(all(
classes[spectrum_identity %in% c(
"crumb rubber from used tires", "r 4. black bridgestone tire fragment",
"r 5. black michelin tire fragment", "r 6. black bike tire fragment",
"r 8. white bike tire fragment"
), material] == "styrene-butadiene"
))
expect_equal(
classes[spectrum_identity == "poly(ethylene:propylene:diene)", material],
"epdm rubber (ethylene propylene diene monomer rubber)"
)
expect_equal(
classes[spectrum_identity == "lahmian medium acrylic paint", material],
"polyacrylates"
)
expect_true(all(
classes[spectrum_identity %in% c("alkyd varnish", "alkyd_varnish"),
material] == "polyesters"
))
binder_classes <- c(
"acrylic paint" = "polyacrylates",
"acrylic-alkyd paint" = "polyesters",
"acrylic-epoxy paint" = "polydiglycidyl ethers",
"acrylic-urethane paint" = "polyurethanes",
"alkyd paint" = "polyesters",
"chlorosulfonated polyethylene paint" = "polyhaloolefins",
"ethylene-acrylate paint" = "polyolefins",
"nitrocellulose paint" = "polycellulose derivatives",
"other paint" = "other plastic",
"polyester paint" = "polyesters",
"polyvinyl formal paint" = "polyvinylalcohols",
"styrene-acrylic paint" = "polyacrylates",
"urethane paint" = "polyurethanes",
"urethane-alkyd paint" = "polyesters",
"vinyl acetate paint" = "polyvinylesters",
"vinyl chloride paint" = "polyhaloolefins",
"vinyl chloride-vinyl acetate paint" = "polyhaloolefins",
"vinyl-acrylic paint" = "polyacrylates"
)
actual_binders <- classes[
spectrum_identity %in% names(binder_classes),
stats::setNames(material, spectrum_identity)
]
expect_identical(unname(actual_binders[names(binder_classes)]),
unname(binder_classes))
paint_classes <- c("paint", "acrylic paint", "alkyd paint", "urethane paint")
expect_false(any(hierarchy$material_class %in% paint_classes))
expect_false(any(common_use$material_class %in% paint_classes))
organic_recommendations <- c(
"1,5-pentanediol", "11-aminoundecanoic acid", "1-bromobutane",
"1-vinyl-2-pyrolidinone", "2-bromopropanoic acid", "2-butanone",
"2-chloro-4-methylpentane", "2-methyl-2-pentanol", "butyl acrylate",
"ethyl (a-chloromethyl)acrylate", "ethyl acrylate",
"n,n-diethyl-m-toluamide", "n,n-dimethyl-m-toluamide",
"n-butyl benzoate", "n-decyl methacrylate", "n-vinylformamide",
"p-phenylenediamine", "p-vinylbenzyl chloride", "p-xylene",
"propionic acid", "sec-butyl benzoate", "styrene",
"tamoxifen (lot #bcbt3163)"
)
expect_true(all(
classes[spectrum_identity %in% organic_recommendations, material] ==
"organic matter"
))
expect_true(all(
classes[spectrum_identity %in% c(
"c2. blue fiber", "c4. green fiber", "c6. red fiber",
"c8. pink fiber bundle", "c9. grey fiber"
), material] == "other"
))
expect_equal(
classes[spectrum_identity == "fibre_polyamide_6_p6", material],
"nylon 6,6 - poly(hexamethylene adipamide)"
)
expect_equal(
classes[spectrum_identity == "ps 16. purple lego fragment", material],
"acrylonitrile butadiene styrene (abs)"
)
expect_true(all(
classes[spectrum_identity %in% c("polyesterurethane", "polyetherurethane"),
material] == "polyurethanes"
))
expect_true(all(
classes[spectrum_identity %in% c("tylose", "tylose2"), material] ==
"methyl cellulose"
))
expect_true(all(c("microplastix", "nist", "hcmr", "cnr", "vliz",
"nicolas coca") %in% types$organization))
expect_false("user_name" %in% names(types))
expect_equal(types[organization == "nist", spectrum_type], "nir")
expect_equal(
types[organization == "monterey bay aquarium research institute",
spectrum_type],
"raman"
)
expect_equal(
types[organization == "walters art museum pigment library",
c(library_type, spectrum_type)],
c("pigments", "raman")
)
expect_false(anyNA(types$spectrum_type))
expect_false(any(types$spectrum_type == ""))
expect_true(all(c("interpretation", "form_factor", "shape", "x_unit",
"spectrumid", "locationdescription", "v1",
"3997_91411", "polymer_hit_3_labs") %in%
drops$metadata_column))
})
test_that("reference metadata enrichment is ordered and conservative", {
form_regex <- data.table::fread(
reference_workflow_data_path("material_form_regex.csv")
)
common_use <- data.table::fread(
reference_workflow_data_path("common_use_reference.csv")
)
metadata <- data.table::data.table(
sample_name = paste0("s", seq_len(7)),
spectrum_identity = c(
"paint chip", "clear plastic film", "fiber pellet", "profile edge",
"hard plastic", "EPDM gasket", "tyre fragment"
),
material_form = c("rubber", rep(NA_character_, 6)),
notes = c("paint", "sheet", "fiber and pellet", "filmography",
"rigid plastic", "seal", "road wear"),
material_class = c(
"poly(styrene-butadiene) rubber", "polyethylene", "polypropylene",
"other plastic", "polyethylene",
"poly(ethylene-propylene-diene) rubber",
"poly(styrene-butadiene) rubber"
)
)
form <- OpenSpecy:::.lib_enrich_material_form(metadata, form_regex)
expect_identical(
form$data$material_form,
c("rubber", "film plastic", NA, NA, "hard plastic", "rubber", NA)
)
expect_equal(form$summary[metric == "conflicting", value], 2L)
expect_equal(form$summary[metric == "unmatched", value], 1L)
expect_true(all(c("matched_patterns", "evidence", "conflict") %in%
names(form$matches)))
expect_match(form$matches[row_id == 1L, evidence], "material_form=rubber")
expect_silent(empty_form <- OpenSpecy:::.lib_enrich_material_form(
data.table::data.table(spectrum_identity = "profile"), form_regex
))
expect_identical(empty_form$summary$metric,
c("total", "populated", "unmatched", "conflicting"))
use <- OpenSpecy:::.lib_enrich_common_use(form$data, common_use)
expect_identical(
use$data$common_use,
c("mixed", "consumer", "consumer", NA, "consumer", "mixed", "mixed")
)
expect_true(all(c(
"consumer_mass_share", "industrial_mass_share", "source_url",
"retrieved_date"
) %in% names(use$coverage)))
expect_silent(empty_use <- OpenSpecy:::.lib_enrich_common_use(
data.table::data.table(material_class = "other plastic"), common_use
))
expect_identical(empty_use$summary$metric,
c("total", "populated", "unmatched"))
mixed_hierarchy <- data.table::data.table(
material = "example", material_class = "example", material_type = "plastic"
)
mixed_reference <- data.table::data.table(
material_class = "example", common_use = "mixed",
consumer_mass_share = 0.4, industrial_mass_share = 0.4,
unclassified_mass_share = 0.2, basis_year = 2020,
geography = "global", source_url = "https://example.org/source",
retrieved_date = "2026-09-29",
evidence_notes = "review fixture"
)
expect_silent(OpenSpecy:::.lib_validate_common_use_reference(
mixed_reference, mixed_hierarchy
))
mixed_reference$consumer_mass_share <- 0.2
expect_error(
OpenSpecy:::.lib_validate_common_use_reference(
mixed_reference, mixed_hierarchy
),
"valid threshold shares"
)
qualitative_reference <- data.table::copy(mixed_reference)
qualitative_reference[, `:=`(
consumer_mass_share = NA_real_, industrial_mass_share = NA_real_,
unclassified_mass_share = NA_real_, basis_year = NA_integer_,
geography = "general"
)]
expect_silent(OpenSpecy:::.lib_validate_common_use_reference(
qualitative_reference, mixed_hierarchy
))
qualitative_reference$source_url <- NA_character_
expect_error(
OpenSpecy:::.lib_validate_common_use_reference(
qualitative_reference, mixed_hierarchy
),
"source provenance"
)
partial_reference <- data.table::copy(qualitative_reference)
partial_reference$source_url <- "https://example.org/source"
partial_reference$consumer_mass_share <- 0.6
expect_error(
OpenSpecy:::.lib_validate_common_use_reference(
partial_reference, mixed_hierarchy
),
"either all missing or all present"
)
})
test_that("predict_class_reference() fills only blanks and audits overlaps", {
classes <- data.table::data.table(
spectrum_identity = c(
"nylon exact override", "nylon fiber", "nylon blend", "unknown"
),
material = c(
"manual material", NA_character_, NA_character_, NA_character_
)
)
rules <- data.table::data.table(
pattern = c("^nylon", "blend$"),
material = c("polyamides", "polyesters")
)
report <- predict_class_reference(classes, rules, return = "report")
exact <- report$data
expect_equal(exact[spectrum_identity == "nylon exact override", material],
"manual material")
expect_equal(exact[spectrum_identity == "nylon fiber", material],
"polyamides")
expect_true(is.na(exact[spectrum_identity == "nylon blend", material]))
expect_true(is.na(exact[spectrum_identity == "unknown", material]))
expect_equal(report$summary$predicted, 1L)
expect_equal(report$summary$clashes, 1L)
expect_equal(report$summary$unmatched, 2L)
expect_equal(report$summary$overlaps, 1L)
expect_equal(report$clashes$spectrum_identity, "nylon blend")
expect_match(report$clashes$materials, "polyamides")
expect_match(report$clashes$materials, "polyesters")
expect_equal(report$overlaps$spectrum_identity, "nylon exact override")
expect_false(report$overlaps$agreement)
expect_equal(report$predictions$spectrum_identity, "nylon fiber")
})
test_that("reference class completion resolves reviewed wrappers and audits uncertainty", {
lib <- tiny_build_lib()
lib$metadata[, `:=`(
spectrum_identity = c(
"known", "pa_ref.csv", "mffrc001_nylon (pa6)_maker.0",
"cellulose_like_ref.csv", NA_character_, "known_2", "known_3",
"known_4"
),
user_name = c(
NA_character_, "gicquel et al. 2024",
"elise granek and kellie teague", "gicquel et al. 2024",
NA_character_, NA_character_, NA_character_, NA_character_
),
material = NA_character_,
material_type = NA_character_
)]
lib$metadata$material_class <- c(
"known class", rep(NA_character_, 3), rep("known class", 4)
)
classes <- data.table::data.table(
spectrum_identity = c("pa", "nylon", "cellulose_like"),
material = c("polyamides", "polyamides", "organic matter")
)
hierarchy <- data.table::data.table(
material = c("nylon 6 - poly(caprolactam)", "organic matter"),
material_class = c("polyamides", "organic matter"),
material_type = c("plastic", "not plastic")
)
completed <- .lib_complete_reference_classes(lib, classes, hierarchy)
report <- attr(completed, "class_coverage_report")
expect_true(check_OpenSpecy(completed))
expect_false(anyNA(completed$metadata$material_class))
expect_equal(completed$metadata$material_class[2:3],
rep("polyamides", 2))
expect_equal(completed$metadata$class_lookup_key[2:3], c("pa", "nylon"))
expect_equal(completed$metadata$class_assignment_reason[2:3],
rep("reviewed_source_key", 2))
expect_equal(completed$metadata$material_class[4], "organic matter")
expect_equal(completed$metadata$class_assignment_reason[4],
"reviewed_source_key")
expect_identical(completed$metadata$spectrum_identity,
lib$metadata$spectrum_identity)
expect_equal(report[stage == "after", populated_class], nrow(lib$metadata))
expect_equal(report[stage == "after", reviewed_source_key], 3L)
expect_equal(report[stage == "after", unclassified], 0L)
expect_equal(report[stage == "after", other], 0L)
})
test_that("reference class completion labels and caps unresolved other", {
source <- tiny_build_lib()
ids <- paste0("coverage", seq_len(100L))
spectra <- matrix(
rep(source$spectra[, 1L], 100L), nrow = nrow(source$spectra)
)
colnames(spectra) <- ids
metadata <- data.table::data.table(
sample_name = ids, col_id = ids,
spectrum_identity = c(rep("known", 99L), "unknown"),
user_name = NA_character_,
material = c(rep("known", 99L), NA_character_),
material_class = c(rep("known class", 99L), NA_character_),
material_type = c(rep("plastic", 99L), NA_character_),
spectrum_type = "ftir"
)
lib <- as_OpenSpecy(source$wavenumber, spectra, metadata = metadata)
classes <- data.table::data.table(
spectrum_identity = character(), material = character()
)
hierarchy <- data.table::data.table(
material = "known", material_class = "known class",
material_type = "plastic"
)
completed <- .lib_complete_reference_classes(lib, classes, hierarchy)
report <- attr(completed, "class_coverage_report")
expect_equal(completed$metadata$material[100L], "other")
expect_equal(completed$metadata$material_class[100L], "other")
expect_equal(completed$metadata$material_type[100L], "other")
expect_equal(report[stage == "after", unresolved_other], 1L)
expect_equal(report[stage == "after", other_fraction], 0.01)
lib$metadata[99:100, `:=`(
spectrum_identity = c("unknown_2", "unknown"),
material = NA_character_, material_class = NA_character_,
material_type = NA_character_
)]
expect_error(
.lib_complete_reference_classes(lib, classes, hierarchy),
"above the reviewed 1% maximum",
fixed = TRUE
)
})
test_that("official other policy removes unresolved rows and retains broad classes", {
lib <- tiny_build_lib()
lib$metadata[, `:=`(
spectrum_identity = c(NA_character_, paste0("identity_", 2:8)),
sample_id = paste0("sample_", 1:8),
file_name = paste0("file_", 1:8, ".csv"),
organization = source,
user_name = source,
citation = "citation",
other_info = "note",
material = c("other", "other plastic", "polyamide", rep("polyester", 5)),
material_type = c("other", "plastic", "other material", rep("plastic", 5))
)]
lib$metadata$material_class <- c(
"other", "other plastic", "other material", rep("polyesters", 5)
)
removed <- OpenSpecy:::.lib_apply_other_policy(
list(raw = lib), remove_other = TRUE, report = NULL
)
expect_identical(colnames(removed$libraries$raw$spectra), paste0("s", 2:8))
expect_identical(nrow(removed$libraries$raw$metadata), 7L)
expect_named(removed$review, names(OpenSpecy:::.lib_other_review_schema()))
expect_named(removed$summary, names(OpenSpecy:::.lib_other_filter_schema()))
expect_type(removed$review$source_row, "integer")
expect_type(removed$summary$removed, "integer")
expect_equal(removed$review$reason,
c("missing_spectrum_identity", rep("reviewed_broad_category", 2)))
expect_equal(
removed$review$action,
c("removed", rep("retained_reviewed_broad_category", 2))
)
expect_equal(removed$summary[, .(candidates, removed, after)],
data.table::data.table(candidates = 3L, removed = 1L, after = 7L))
expect_true(check_OpenSpecy(removed$libraries$raw))
retained <- OpenSpecy:::.lib_apply_other_policy(
list(raw = lib), remove_other = FALSE, report = NULL
)
expect_identical(ncol(retained$libraries$raw$spectra), 8L)
expect_true(all(
retained$review$action == "retained_for_semisupervised_reassignment"
))
expect_identical(retained$summary$removed, 0L)
expect_identical(formals(build_lib)$remove_other, TRUE)
})
test_that("source-library retention reports complete drops with a stage reason", {
stages <- list(
data.table::data.table(
stage = "prepared", artifact = "raw",
library_name = c("kept", "dropped"), spectra = c(4L, 2L)
),
data.table::data.table(
stage = "post_exclusion", artifact = "raw",
library_name = c("kept", "dropped"), spectra = c(4L, 2L)
),
data.table::data.table(
stage = "core", artifact = "raw",
library_name = c("kept", "dropped"), spectra = c(4L, 2L)
),
data.table::data.table(
stage = "post_other", artifact = "raw",
library_name = "kept", spectra = 4L
),
data.table::data.table(
stage = c("post_quality", "post_prune", "post_transform", "final"),
artifact = "raw", library_name = "kept", spectra = 4L
)
)
report <- OpenSpecy:::.lib_library_retention_report(stages)
expect_equal(report[library_name == "kept", status], "retained")
expect_equal(report[library_name == "dropped", status], "dropped")
expect_equal(
report[library_name == "dropped", reason],
"unresolved_other_policy"
)
expect_equal(report[library_name == "dropped", final_n], 0L)
})
test_that("confusion tables rank the largest misidentifications first", {
tests <- data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "raman", source = "new",
technique = "raman", provenance = "candidate",
expected_class = c(rep("polyethylene", 10), rep("polypropylene", 4)),
predicted_class = c(rep("polyethylene", 5), rep("polypropylene", 5),
rep("polypropylene", 3), "polyethylene")
)
confusion <- OpenSpecy:::.lib_confusion_table(tests)
expect_named(confusion, c(
"algorithm", "artifact", "model", "source", "technique", "provenance",
"expected_class", "predicted_class", "spectra", "misidentified",
"expected_class_spectra", "expected_class_fraction"
), ignore.order = TRUE)
expect_true(confusion$misidentified[[1L]])
expect_equal(confusion$spectra[[1L]], 5L)
expect_equal(
confusion[expected_class == "polyethylene", expected_class_fraction],
c(0.5, 0.5)
)
expect_type(confusion$expected_class_fraction, "double")
expect_named(OpenSpecy:::.lib_confusion_table(tests[0]), names(confusion))
})
test_that("model assessment compares error-mode accuracy percentages", {
tests <- data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "raman", source = "new", technique = "raman",
spectrum_id = paste0("s", 1:8),
correct = c(TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE)
)
flags <- data.table::data.table(
artifact = "derivative", technique = "raman",
spectrum_id = paste0("s", 5:8), error_mode = "low_snr"
)
result <- OpenSpecy:::.lib_model_assessment_correlations(tests, flags)
expect_named(
result, names(OpenSpecy:::.lib_model_assessment_correlation_schema())
)
expect_identical(result$error_mode[[1L]], "low_snr")
expect_equal(result$with_error_accuracy_pct, 0)
expect_equal(result$without_error_accuracy_pct, 100)
expect_equal(result$accuracy_difference_pct, -100)
empty <- OpenSpecy:::.lib_model_assessment_correlations(tests[0], flags)
expect_named(empty, names(result))
expect_type(empty$with_error_accuracy_pct, "double")
})
test_that("reference metadata is ordered by missingness after all-NA removal", {
x <- tiny_build_lib()
x$metadata <- data.table::data.table(
sample_name = colnames(x$spectra),
complete = seq_len(ncol(x$spectra)),
two_missing = c(NA, NA, rep("x", ncol(x$spectra) - 2L)),
one_missing = c(NA, rep("y", ncol(x$spectra) - 1L)),
entirely_missing = rep(NA_character_, ncol(x$spectra))
)
attr(x, "metadata_order_marker") <- "preserved"
finalized <- OpenSpecy:::.lib_finalize_reference_metadata(
libraries = list(raw = list(ftir = x)),
medoids = list(derivative = list(ftir = x))
)
expected <- c("sample_name", "complete", "one_missing", "two_missing")
expect_identical(names(finalized$libraries$raw$ftir$metadata), expected)
expect_identical(names(finalized$medoids$derivative$ftir$metadata), expected)
expect_true(check_OpenSpecy(finalized$libraries$raw$ftir))
expect_identical(
attr(finalized$libraries$raw$ftir, "metadata_order_marker"), "preserved"
)
expect_equal(finalized$assessment$dropped_columns, c(1L, 1L))
expect_equal(finalized$assessment$dropped_names,
rep("entirely_missing", 2L))
expect_equal(finalized$assessment$maximum_missing, c(2L, 2L))
expect_named(
finalized$assessment,
names(OpenSpecy:::.lib_metadata_finalization_schema())
)
})
test_that("build_lib() preserves full source ranges through NA-aware recipes", {
lib <- tiny_build_lib()
left <- lib
left$wavenumber <- lib$wavenumber[1:40]
left$spectra <- lib$spectra[1:40, 1:4, drop = FALSE]
left$metadata <- data.table::copy(lib$metadata[1:4])
right <- lib
right$wavenumber <- lib$wavenumber[22:61]
right$spectra <- lib$spectra[22:61, 5:8, drop = FALSE]
right$metadata <- data.table::copy(lib$metadata[5:8])
built <- build_lib(list(left, right), dedupe = FALSE, signal_noise = FALSE)
expect_true(all(diff(built$raw$wavenumber) == 6))
expect_true(anyNA(built$raw$spectra))
expect_true(anyNA(built$derivative$spectra))
expect_true(any(is.finite(built$derivative$spectra[, 1])))
expect_true(any(is.finite(built$nobaseline$spectra[, 8])))
})
test_that("streamed variable-axis paths match c_spec() interpolation", {
lib <- tiny_build_lib()
left <- filter_spec(lib, 1:4)
left$wavenumber <- lib$wavenumber[1:40]
left$spectra <- left$spectra[1:40, , drop = FALSE]
right <- filter_spec(lib, 5:8)
right$wavenumber <- lib$wavenumber[22:61]
right$spectra <- right$spectra[22:61, , drop = FALSE]
paths <- c(tempfile(fileext = ".rds"), tempfile(fileext = ".rds"))
saveRDS(left, paths[[1L]])
saveRDS(right, paths[[2L]])
expected <- c_spec(list(left, right), range = "full", res = 6)
actual <- build_lib(
paths,
recipes = list(raw = list()),
range = "full",
res = 6,
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE,
progress = FALSE
)$raw
expect_equal(actual$wavenumber, expected$wavenumber)
expect_equal(actual$spectra, expected$spectra, tolerance = 1e-12)
expect_equal(actual$metadata$sample_name, expected$metadata$sample_name)
expect_true(check_OpenSpecy(actual))
})
test_that("source-stage hashes support spectra with no shared finite rows", {
lib <- filter_spec(tiny_build_lib(), 1:2)
midpoint <- floor(nrow(lib$spectra) / 2)
lib$spectra[seq_len(midpoint), 1] <- NA_real_
lib$spectra[seq.int(midpoint + 1L, nrow(lib$spectra)), 2] <- NA_real_
built <- build_lib(
lib, recipes = list(raw = list()), signal_noise = FALSE,
progress = FALSE
)$raw
expect_true(check_OpenSpecy(built))
expect_equal(ncol(built$spectra), 2L)
expect_false(anyNA(built$metadata$sample_name))
expect_identical(colnames(built$spectra), built$metadata$sample_name)
})
test_that("build_lib() applies baseline recipes across source-specific NA tails", {
lib <- filter_spec(tiny_build_lib(), 1:2)
lib$spectra[1:5, 1] <- NA_real_
lib$spectra[57:61, 2] <- NA_real_
built <- build_lib(
list(lib),
recipes = list(nobaseline = list(
conform_spec = FALSE,
smooth_intens = FALSE,
subtr_baseline = TRUE,
make_rel = TRUE
)),
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE
)$nobaseline
expected <- manage_na(lib, fun = subtr_baseline)
expect_equal(built$spectra, expected$spectra, tolerance = 1e-12)
expect_equal(attr(built, "baseline"), "nobaseline")
})
test_that("extdata files combine into a mini library", {
mini_files <- c(
read_extdata("raman_hdpe.csv"),
read_extdata("ftir_ldpe_soil.asp"),
read_extdata("raman_atacamit.spc")
)
mini <- read_any(mini_files, c_spec_args = list(range = "common", res = 10))
expect_true(check_OpenSpecy(mini))
expect_equal(ncol(mini$spectra), 3)
lookup <- data.table::data.table(
file_name = basename(mini_files),
material = c("hdpe", "ldpe in soil", "atacamite"),
material_type = c("plastic", "plastic", "mineral")
)
mini <- join_lib_metadata(mini, lookup, by = "file_name",
require_complete = TRUE)
built <- build_lib(
mini_files,
recipes = list(raw = list()),
metadata_lookups = lookup,
dedupe = FALSE,
convert_intensity = FALSE,
signal_noise = FALSE
)
expect_true(check_OpenSpecy(built$raw))
expect_true(all(c("material", "material_type") %in% names(built$raw$metadata)))
})
test_that("build_lib() discovers helper data and reuses one artifact bundle", {
# This exercises the complete multi-artifact reference-library workflow.
skip_on_cran()
lib <- tiny_build_lib()
lib$spectra[30, ] <- lib$spectra[30, ] + 10
lib$metadata[, `:=`(
spectrum_identity = label,
organization = source,
user_name = source,
spectrum_id = sample_name
)]
spectra <- do.call(cbind, lapply(seq_len(10), function(copy) {
out <- lib$spectra + copy / 1000
colnames(out) <- paste0(colnames(out), "_", copy)
out
}))
metadata <- data.table::rbindlist(lapply(seq_len(10), function(copy) {
out <- data.table::copy(lib$metadata)
out[, `:=`(
sample_name = paste0(sample_name, "_", copy),
spectrum_id = paste0(spectrum_id, "_", copy)
)]
out
}))
lib <- as_OpenSpecy(
lib$wavenumber, spectra = spectra, metadata = metadata,
attributes = list(intensity_unit = "absorbance")
)
workflow_root <- file.path(
tempdir(), paste0("workflow-", sample.int(1e8, 1))
)
workflow_data <- file.path(workflow_root, "data")
output_dir <- file.path(tempdir(), paste0("output-", sample.int(1e8, 1)))
dir.create(workflow_data, recursive = TRUE)
old_working_dir <- setwd(workflow_root)
on.exit(setwd(old_working_dir), add = TRUE)
data.table::fwrite(data.table::data.table(
spectrum_identity = unique(lib$metadata$spectrum_identity),
material = paste0("material_", seq_along(unique(
lib$metadata$spectrum_identity
)))
), file.path(workflow_data, "classes_reference.csv"))
data.table::fwrite(data.table::data.table(
pattern = "^never[0-9]+$", material = "other material"
), file.path(workflow_data, "classes_regex.csv"))
data.table::fwrite(data.table::data.table(
organization = c("a", "b", "c"), library_type = "test",
spectrum_type = "ftir"
), file.path(workflow_data, "library_types.csv"))
classes <- data.table::fread(
file.path(workflow_data, "classes_reference.csv")
)
data.table::fwrite(data.table::data.table(
material = classes$material,
material_class = rep(c("polyclass_a", "polyclass_b"),
length.out = nrow(classes)),
material_type = "plastic"
), file.path(workflow_data, "material_hierarchy.csv"))
data.table::fwrite(data.table::data.table(sample_name = character()),
file.path(workflow_data, "known_bad_ids.csv"))
data.table::fwrite(data.table::data.table(
metadata_column = "unused_legacy_column"
), file.path(workflow_data, "metadata_drop_columns.csv"))
data.table::fwrite(data.table::data.table(
pattern = "(^|[^[:alnum:]])paint([^[:alnum:]]|$)",
material_form = "paint"
), file.path(workflow_data, "material_form_regex.csv"))
use_classes <- sort(unique(data.table::fread(
file.path(workflow_data, "material_hierarchy.csv")
)$material_class))
data.table::fwrite(data.table::data.table(
material_class = use_classes,
common_use = rep(NA_character_, length(use_classes)),
consumer_mass_share = rep(NA_real_, length(use_classes)),
industrial_mass_share = rep(NA_real_, length(use_classes)),
unclassified_mass_share = rep(NA_real_, length(use_classes)),
basis_year = rep(NA_integer_, length(use_classes)),
geography = rep(NA_character_, length(use_classes)),
source_url = rep(NA_character_, length(use_classes)),
retrieved_date = rep(NA_character_, length(use_classes)),
evidence_notes = rep(NA_character_, length(use_classes))
), file.path(workflow_data, "common_use_reference.csv"))
fixture_prune <- list(
derivative = list(min_n = 10, progress = FALSE),
nobaseline = list(min_n = 10, progress = FALSE)
)
first <- suppressWarnings(build_lib(
lib, output_dir = output_dir,
previous_library_dir = NULL, dedupe = FALSE, signal_noise = FALSE,
progress = FALSE,
prune = fixture_prune,
recipes = list(raw = list(), derivative = list(), nobaseline = list())
))
expect_named(first, c("libraries", "medoids", "models", "assessments"))
expect_named(first$libraries, c("raw", "derivative", "nobaseline"))
expect_named(first$medoids, c("derivative", "nobaseline"))
expect_named(first$models, "logistic_regression")
expect_true(all(vapply(first$libraries, function(recipe) {
all(vapply(recipe, check_OpenSpecy, logical(1)))
}, logical(1))))
expect_true(all(vapply(first$medoids, function(recipe) {
all(vapply(recipe, check_OpenSpecy, logical(1)))
}, logical(1))))
expect_named(first$assessments,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
expect_lte(sum(lengths(first$assessments)), 10L)
expect_true(all(lengths(first$assessments) > 0L))
expect_true(all(vapply(
unlist(first$assessments, recursive = FALSE), nrow, integer(1L)
) > 0L))
expect_identical(attr(first$assessments, "assessment_schema_version"),
"2.0.0")
expect_named(first$assessments$cleanup$dropped_spectrum_identities,
"spectrum_identity")
retention <- first$assessments$cleanup$summary[
assessment_kind == "library_retention"
]
expect_gt(nrow(retention), 0L)
expect_true(all(c("library_name", "prepared_n", "final_n", "status",
"reason") %in% names(retention)))
expect_true(all(vapply(first$libraries$raw, function(object) {
all(c("library_name", "material_form", "common_use") %in%
names(object$metadata))
}, logical(1))))
expect_true(all(vapply(first$libraries$raw, function(object) {
is.list(attr(object, "material_form_enrichment_report", exact = TRUE)) &&
is.list(attr(object, "common_use_enrichment_report", exact = TRUE))
}, logical(1))))
upstream <- attr(first$assessments, "upstream_assessments", exact = TRUE)
expect_true(all(c(
"material_form_enrichment", "material_form_matches",
"material_form_clashes", "common_use_enrichment", "common_use_coverage",
"pruning_removals"
) %in% names(upstream)))
release_dir <- attr(first, "output_dir")
expect_true(all(file.exists(file.path(
release_dir,
c("raw.rds", "derivative.rds", "nobaseline.rds",
"medoid_derivative.rds", "medoid_nobaseline.rds",
"model_derivative.rds", "model_nobaseline.rds",
"model_logistic_regression_derivative.rds",
"model_logistic_regression_nobaseline.rds",
"assessments.rds", "quarantined_spectra.rds",
"reference_library_build.rds")
))))
quarantine <- readRDS(file.path(release_dir, "quarantined_spectra.rds"))
expect_s3_class(quarantine, "OpenSpecyQuarantine")
expect_identical(quarantine$manifest$schema,
"OpenSpecy_quarantined_spectra_v1")
release_index <- readRDS(file.path(release_dir, "reference_library_build.rds"))
expect_identical(
release_index$schema, "OpenSpecy_reference_build_index_v1"
)
expect_false(any(c("libraries", "medoids", "models") %in%
names(release_index)))
expect_lt(file.info(file.path(
release_dir, "reference_library_build.rds"
))$size, 1e6)
release_assessments <- readRDS(file.path(release_dir, "assessments.rds"))
expect_identical(
attr(release_assessments, "assessment_schema_version"), "2.0.0"
)
expect_false(any(c("scope", "expected_class") %in%
names(release_assessments$ref_lib$accuracy)))
expect_true("model_training_tests" %in%
names(attr(release_assessments, "evidence")))
report_attributes <- c(
"join_report", "metadata_lookup_reports",
"spectrum_identity_cleanup_report", "build_stage_report",
"dropped_spectrum_identities", "class_prediction_report",
"class_coverage_report", "other_review_report", "other_filter_report",
"quality_control_report", "prune_report", "identification_support",
"identification_dropped_ids", "identification_minimum_observed",
"identification_finite_coverage", "range_flat_drops",
"library_retention_stages"
)
for (component in c("raw", "derivative", "nobaseline",
"medoid_derivative", "medoid_nobaseline")) {
artifact <- readRDS(file.path(release_dir, paste0(component, ".rds")))
for (object in artifact) {
expect_true(check_OpenSpecy(object))
expect_length(intersect(names(attributes(object)), report_attributes), 0L)
expect_null(attr(object$metadata, "join_report", exact = TRUE))
}
}
model_fields <- OpenSpecy:::.lib_runtime_model_fields()
for (component in c(
"model_logistic_regression_derivative",
"model_logistic_regression_nobaseline"
)) {
artifact <- readRDS(file.path(release_dir, paste0(component, ".rds")))
for (model in artifact) {
expect_true(all(names(model) %in% model_fields))
expect_false(any(c(
"tests", "lambda_metrics", "oob_metrics", "oob_class_accuracy",
"feature_importance", "training_parameters", "class_weights",
"support", "class_support"
) %in% names(model)))
expect_null(attr(model, "training_warnings", exact = TRUE))
}
}
resolved <- OpenSpecy:::.lib_resolve_rebuild_input(
file.path(release_dir, "reference_library_build.rds")
)
expect_named(resolved$libraries, c("raw", "derivative", "nobaseline"))
expect_named(resolved$medoids, c("derivative", "nobaseline"))
expect_named(resolved$models, "logistic_regression")
expect_s3_class(resolved$quarantine, "OpenSpecyQuarantine")
expect_identical(
resolved$quarantine$manifest$schema,
"OpenSpecy_quarantined_spectra_v1"
)
second <- suppressWarnings(build_lib(
lib, output_dir = output_dir,
previous_library_dir = NULL, dedupe = FALSE, signal_noise = FALSE,
progress = FALSE, reuse = TRUE,
prune = fixture_prune,
recipes = list(raw = list(), derivative = list(), nobaseline = list())
))
second_evidence <- attr(second$assessments, "evidence")
expect_true(all(
second_evidence$output_manifest$status == "available"
))
expect_equal(second$libraries$raw$ftir$spectra,
first$libraries$raw$ftir$spectra)
rebuilt <- suppressWarnings(build_lib(
lib, output_dir = output_dir,
previous_library_dir = NULL, dedupe = FALSE, signal_noise = FALSE,
progress = FALSE, reuse = FALSE,
prune = fixture_prune,
recipes = list(raw = list(), derivative = list(), nobaseline = list())
))
expect_named(rebuilt$assessments,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
})
test_that("source-local reference splits prevent self-match leakage", {
old <- tiny_build_lib()
new <- old
new$metadata$sample_name_old <- new$metadata$sample_name
new$metadata$sample_name <- paste0("rebuilt_", new$metadata$sample_name)
colnames(new$spectra) <- new$metadata$sample_name
split <- OpenSpecy:::.lib_source_split(
new, artifact = "raw", source = "new", seed = 71, holdout = 0.25
)
expect_identical(anyDuplicated(split$manifest$group_id), 0L)
expect_true(all(split$manifest$source == "new"))
expect_true(all(split$manifest$split %in% c("train", "test")))
expect_equal(
sum(split$manifest$split == "test"),
round(nrow(split$manifest) * 0.25)
)
expect_length(intersect(
split$manifest[split == "train", group_id],
split$manifest[split == "test", group_id]
), 0L)
messages <- capture.output(
tests <- OpenSpecy:::.lib_reference_holdout_test(
reference = new, data = new, split = split,
artifact = "raw", source = "new", progress = TRUE
),
type = "message"
)
expect_match(paste(messages, collapse = "\n"), "full correlation complete")
expect_true(all(tests$split == "test"))
expect_true(all(tests$provenance == "source_local_reference_holdout"))
old_split <- OpenSpecy:::.lib_source_split(
old, artifact = "raw", source = "old", seed = 72, holdout = 0.25
)
old_tests <- OpenSpecy:::.lib_reference_holdout_test(
reference = old, data = old, split = old_split,
artifact = "raw", source = "old", progress = FALSE
)
expect_true(all(old_split$manifest$source == "old"))
expect_true(all(old_tests$source == "old"))
})
test_that("medoid assessment searches the complete corresponding library", {
lib <- tiny_build_lib()
medoid <- filter_spec(lib, c(1L, 3L))
messages <- capture.output(
tests <- OpenSpecy:::.lib_reference_complete_test(
medoid, lib, artifact = "medoid_derivative_ftir", source = "new",
progress = TRUE, block_size = 2L
),
type = "message"
)
expect_match(paste(messages, collapse = "\n"),
"medoid identifying complete dataset")
expect_equal(nrow(tests), ncol(lib$spectra))
expect_setequal(tests$spectrum_id, lib$metadata$sample_name)
expect_true(all(tests$split == "complete"))
expect_true(all(tests$provenance == "complete_medoid_reference_search"))
})
test_that("complete old-new assessments directly test deployed models", {
skip_if_not_installed("glmnet")
skip_if_not_installed("ranger")
small <- tiny_build_lib()
spectra <- do.call(cbind, lapply(seq_len(5), function(i) {
small$spectra + i / 1000
}))
metadata <- data.table::rbindlist(lapply(seq_len(5), function(i) {
out <- data.table::copy(small$metadata)
out$sample_name <- paste0(out$sample_name, "_", i)
out
}))
colnames(spectra) <- metadata$sample_name
lib <- as_OpenSpecy(
small$wavenumber, spectra = spectra, metadata = metadata,
attributes = list(intensity_unit = "absorbance")
)
model_input <- restrict_range(
lib, min = 800, max = 3200, make_rel = FALSE
)
model <- suppressWarnings(build_model_lib(model_input))
rf_model <- train_spec_model(
model_input, method = "random_forest", num.trees = 20L,
min.node.size = 1L, mtry = 4L
)
model_set <- list(both = model, ftir = model, raman = NULL)
build <- list(
libraries = list(
raw = list(ftir = lib), derivative = list(ftir = lib),
nobaseline = list(ftir = lib)
),
medoids = list(
derivative = list(ftir = model_input),
nobaseline = list(ftir = model_input)
),
models = list(
logistic_regression = list(
derivative = model_set, nobaseline = model_set
),
random_forest = list(raw = list(ftir = rf_model))
),
assessments = list()
)
previous <- file.path(tempdir(), paste0("previous-", sample.int(1e8, 1)))
dir.create(previous, recursive = TRUE)
typed_lib <- list(ftir = lib)
typed_medoid <- list(ftir = model_input)
saveRDS(typed_lib, file.path(previous, "raw.rds"))
saveRDS(typed_lib, file.path(previous, "derivative.rds"))
saveRDS(typed_lib, file.path(previous, "nobaseline.rds"))
saveRDS(typed_medoid, file.path(previous, "medoid_derivative.rds"))
saveRDS(typed_medoid, file.path(previous, "medoid_nobaseline.rds"))
saveRDS(model_set, file.path(previous, "model_derivative.rds"))
saveRDS(model_set, file.path(previous, "model_nobaseline.rds"))
local_mocked_bindings(
train_spec_model = function(...) {
stop("assessment must not retrain a model", call. = FALSE)
},
.package = "OpenSpecy"
)
comparison <- suppressWarnings(OpenSpecy:::.lib_compare_reference_build(
build, previous_library_dir = previous,
seed = 211, holdout = 0.25, progress = FALSE
))
expect_true(all(c(
"models", "split_manifest", "library_identification",
"model_identification", "model_assessment_correlations",
"assess_spec_shifts", "old_new_compatibility"
) %in% names(comparison)))
expect_equal(unique(comparison$split_manifest$artifact), c(
"raw_ftir", "derivative_ftir", "nobaseline_ftir"
))
expect_setequal(unique(comparison$split_manifest$source), c("new", "old"))
expect_gt(nrow(comparison$library_identification), 0L)
expect_gt(nrow(comparison$model_identification), 0L)
expect_setequal(
unique(comparison$model_identification$algorithm),
c("logistic_regression", "random_forest")
)
expect_equal(nrow(comparison$model_assessment_correlations), 0L)
expect_gt(nrow(comparison$assess_spec_shifts), 0L)
expect_equal(
comparison$library_tests[
artifact == "medoid_derivative_ftir" & source == "new", .N
],
ncol(lib$spectra)
)
expect_true(all(comparison$library_tests[
grepl("^medoid_", artifact), split
] == "complete"))
expect_true(all(
comparison$models$logistic_regression$derivative$ftir$tests$provenance ==
"new_logistic_regression_complete_dataset"
))
expect_equal(
nrow(comparison$models$logistic_regression$derivative$ftir$tests),
ncol(lib$spectra)
)
expect_true(all(
comparison$models$random_forest$raw$ftir$tests$provenance ==
"new_random_forest_complete_dataset"
))
expect_equal(
comparison$models$random_forest$raw$ftir$observation_count,
ncol(model_input$spectra)
)
})
test_that("assessment review is process nested, compact, and nonsparse", {
identification <- data.table::data.table(
artifact = rep(c("raw_ftir", "medoid_derivative_ftir"), each = 2L),
source = rep(c("old", "new"), 2L), technique = "ftir",
provenance = "grouped", macro_class_accuracy = c(.5, .8, .9, .7),
coverage = 1, overall_accuracy = c(.6, .85, .91, .75),
spectra = 20L, evaluated = 20L, classes = 2L,
evaluated_classes = 2L, mean_score = .8
)
confusion <- data.table::data.table(
artifact = rep("raw_ftir", 4L), source = rep(c("old", "new"), 2L),
technique = "ftir", provenance = "grouped",
expected_class = c("a", "a", "b", "b"),
predicted_class = c("b", "b", "a", "a"), misidentified = TRUE,
spectra = c(2L, 7L, 1L, 4L), expected_class_spectra = 10L,
expected_class_fraction = c(.2, .7, .1, .4)
)
model_identification <- data.table::copy(identification[artifact == "raw_ftir"])
model_identification[, `:=`(
algorithm = "logistic_regression", artifact = "derivative",
model = "ftir"
)]
correlations <- data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "ftir", technique = "ftir", error_mode = "low_snr",
with_error_accuracy_pct = 50,
without_error_accuracy_pct = 90,
accuracy_difference_pct = -40
)
reviewed <- OpenSpecy:::.lib_assessment_review(list(
build_summary = data.table::data.table(artifact = "raw_ftir", spectra = 20L),
dropped_spectrum_identities = data.table::data.table(
spectrum_identity = c("z", "a", "z")
),
library_identification = identification,
library_class_accuracy = data.table::data.table(
artifact = "raw_ftir", source = "new", technique = "ftir",
provenance = "grouped", expected_class = "class_a",
spectra = 10L, evaluated = 10L, coverage = 1,
class_accuracy = 0.5
),
library_confusion = confusion,
model_identification = model_identification,
model_class_accuracy = data.table::data.table(
algorithm = "logistic_regression", artifact = "derivative",
model = "ftir", source = "new", technique = "ftir",
provenance = "grouped", expected_class = "class_a",
spectra = 10L, evaluated = 10L, coverage = 1,
class_accuracy = 0.5
),
model_confusion = data.table::copy(confusion)[, `:=`(
algorithm = "logistic_regression", artifact = "derivative", model = "ftir"
)],
model_assessment_correlations = correlations,
assess_spec_shifts = data.table::data.table(
artifact = "raw_ftir", check = "signal", rate_old = .2,
rate_new = .1, rate_shift = -.1
),
old_new_compatibility = data.table::data.table(
artifact = "raw_ftir", spectra_old = 10L, spectra_new = 20L,
spectra_shift = 10L
),
output_manifest = data.table::data.table(
component = "raw", status = "available", path = "raw.rds", size = 1
)
))
expect_named(reviewed,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
expect_lte(sum(lengths(reviewed)), 10L)
expect_true(all(lengths(reviewed) > 0L))
expect_identical(
reviewed$cleanup$dropped_spectrum_identities$spectrum_identity,
c("a", "z")
)
accuracy_names <- names(reviewed$ref_lib$accuracy)
expect_false(any(c("scope", "expected_class", "class_accuracy") %in%
accuracy_names))
expect_true(all(c("source", "overall_accuracy_pct",
"macro_class_accuracy_pct", "class_count") %in%
accuracy_names))
expect_false(any(c("coverage_pct", "mean_score",
"evaluated_classes") %in% accuracy_names))
expect_identical(reviewed$ref_lib$accuracy$source, c("old", "new"))
expect_equal(reviewed$ref_lib$accuracy$macro_class_accuracy_pct, c(50, 80))
expect_identical(reviewed$ref_lib$accuracy$class_count, c(2L, 2L))
expect_identical(
reviewed$model$error_mode_accuracy$accuracy_difference_pct, -40
)
sparse <- unlist(lapply(
unlist(reviewed, recursive = FALSE),
function(value) vapply(value, function(column) mean(is.na(column)),
numeric(1L))
))
expect_true(all(sparse <= 0.10))
})
test_that("assessment shifts merge findings, omit passes, and rank rate shifts", {
summary <- data.table::data.table(
artifact = rep("raw_ftir", 6L), source = rep(c("old", "new"), each = 3L),
check = rep(c("signal", "signal", "range"), 2L),
status = rep(c("pass", "warning", "error"), 2L),
count = c(90L, 5L, 1L, 80L, 10L, 4L),
finding_count = c(0L, 5L, 1L, 0L, 10L, 4L),
example_ids = c("", "a", "b", "", "c", "d"), spectra = 100L
)
shifts <- OpenSpecy:::.lib_assessment_shift_table(summary)
expect_false("status" %in% names(shifts))
expect_equal(shifts[check == "signal", count_old], 5L)
expect_equal(shifts[check == "signal", count_new], 10L)
expect_true(all(diff(shifts$rate_shift) <= 0))
})
test_that("stable groups connect physical IDs and exact spectral content", {
x <- tiny_build_lib()
x$metadata$sample_name_old <- paste0("legacy_", seq_len(nrow(x$metadata)))
x$metadata$sample_name_old[2] <- x$metadata$sample_name_old[1]
x$spectra[, 4] <- x$spectra[, 3]
groups <- OpenSpecy:::.lib_stable_group_info(x)
expect_equal(groups$group_id[1], groups$group_id[2])
expect_equal(groups$group_id[3], groups$group_id[4])
split <- OpenSpecy:::.lib_source_split(
x, artifact = "raw", source = "new", seed = 1, holdout = .25
)
expect_identical(
split$manifest[, data.table::uniqueN(split), by = group_id][, max(V1)],
1L
)
})
test_that("immutable promotion rejects a changed payload", {
path <- tempfile(fileext = ".rds")
first <- OpenSpecy:::.lib_promote_rds(list(value = 1L), path)
expect_equal(first$status, "promoted")
second <- OpenSpecy:::.lib_promote_rds(list(value = 1L), path)
expect_equal(second$status, "verified_existing")
semantic_path <- tempfile(fileext = ".rds")
saveRDS(list(value = 1L), semantic_path, compress = FALSE)
semantic_checksum <- OpenSpecy:::.lib_sha256_file(semantic_path)
semantic <- OpenSpecy:::.lib_promote_rds(
list(value = 1L), semantic_path
)
expect_equal(semantic$status, "verified_existing")
expect_identical(
OpenSpecy:::.lib_sha256_file(semantic_path), semantic_checksum
)
expect_error(
OpenSpecy:::.lib_promote_rds(list(value = 2L), path),
"Immutable release artifact differs"
)
})
test_that("completed release manifests authorize immutable byte reuse", {
path <- tempfile(fileext = ".rds")
manifest <- OpenSpecy:::.lib_promote_rds(list(value = 1L), path)
attr(manifest, "build_signature") <- "signed-build"
verified <- OpenSpecy:::.lib_verify_manifested_release_artifact(
path, manifest
)
expect_equal(verified$status, "verified_existing")
expect_identical(verified$checksum, manifest$checksum)
saveRDS(list(value = 2L), path)
expect_null(OpenSpecy:::.lib_verify_manifested_release_artifact(
path, manifest
))
})
test_that("file signature caching preserves hashes and invalidates on metadata", {
path <- tempfile(fileext = ".txt")
writeLines("first", path)
first <- OpenSpecy:::.lib_file_signatures(path)
second <- OpenSpecy:::.lib_file_signatures(path)
expect_identical(first$checksum, second$checksum)
writeLines("a different sized payload", path)
changed <- OpenSpecy:::.lib_file_signatures(path)
expect_false(identical(first$checksum, changed$checksum))
})
test_that("support and fill helpers use the intended axes", {
x <- tiny_build_lib()
x$spectra[,] <- NA_real_
x$spectra[seq_len(6), 1] <- seq_len(6)
x$spectra[seq_len(7), 2] <- seq_len(7)
support <- OpenSpecy:::.lib_filter_spectral_support(x, min_fraction = 0.1)
expect_equal(support$audit$minimum_observed, rep(7L, 8))
expect_false(support$audit$retained[1])
expect_true(support$audit$retained[2])
spectra <- matrix(c(1, NA, 3, 10, 20, NA), nrow = 3)
spectrum_fill <- OpenSpecy:::.lib_spectrum_mean_replace(spectra)
expect_equal(spectrum_fill[, 1], c(1, 2, 3))
expect_equal(spectrum_fill[, 2], c(10, 20, 15))
wave_fill <- OpenSpecy:::.lib_wavenumber_mean_replace(spectra)
expect_equal(wave_fill$means, c(5.5, 20, 3))
expect_equal(wave_fill$spectra[, 1], c(1, 20, 3))
expect_equal(wave_fill$spectra[, 2], c(10, 20, 3))
})
test_that("medoid selection restores original missing values", {
x <- tiny_build_lib()
x$spectra[10:20, 1] <- NA_real_
ids <- reduce_lib(
x, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = FALSE
)
restored <- filter_spec(x, ids)
if ("s1" %in% ids) {
expect_true(anyNA(restored$spectra[, match("s1", ids)]))
}
flat <- x
flat$spectra[, 1] <- NA_real_
flat$spectra[seq_len(7), 1] <- 1
expect_no_error(reduce_lib(
flat, group_cols = "material_class", k = 2, min_n = 2,
return = "ids", progress = FALSE
))
})
test_that("macro lambda metrics choose class-balanced accuracy", {
outcome <- c(1L, 1L, 1L, 2L)
predictions <- array(0, dim = c(4, 2, 2))
predictions[cbind(seq_len(4), c(1, 1, 1, 1), 1)] <- 1
predictions[cbind(seq_len(4), c(1, 2, 2, 2), 2)] <- 1
metrics <- OpenSpecy:::.lib_macro_lambda_metrics(
predictions, outcome, lambda = c(1, 0.1)
)
expect_equal(metrics$macro_class_accuracy, c(0.5, 2 / 3))
expect_equal(metrics$overall_accuracy, c(0.75, 0.5))
expect_identical(which(metrics$selected), 2L)
})
test_that("rebuild_lib_artifacts reuses completed libraries downstream", {
skip_if_not_installed("glmnet")
base <- tiny_build_lib()
libraries <- lapply(seq_len(3), function(i) {
spectra <- do.call(cbind, lapply(seq_len(3), function(copy) {
base$spectra + copy / 1000
}))
metadata <- data.table::rbindlist(lapply(seq_len(3), function(copy) {
out <- data.table::copy(base$metadata)
out$sample_name <- paste0(out$sample_name, "_", copy)
out
}))
colnames(spectra) <- metadata$sample_name
as_OpenSpecy(base$wavenumber, spectra = spectra, metadata = metadata)
})
names(libraries) <- c("raw", "derivative", "nobaseline")
libraries <- lapply(libraries, function(x) list(ftir = x))
libraries$derivative$ftir$spectra[10:20, 1] <- NA_real_
input <- tempfile(fileext = ".rds")
saveRDS(list(libraries = libraries, assessments = list()), input)
output <- tempfile("downstream-build-")
first <- suppressWarnings(rebuild_lib_artifacts(
input, output_dir = output, previous_library_dir = NULL,
reuse = TRUE, progress = FALSE
))
expect_named(first, c("libraries", "medoids", "models", "assessments"))
expect_true(anyNA(first$medoids$derivative$ftir$spectra))
expect_true(
first$models$logistic_regression$derivative$ftir$fill_replaced > 0L
)
expect_named(first$assessments,
c("cleanup", "ref_lib", "medoid", "model", "functionality"))
second <- suppressWarnings(rebuild_lib_artifacts(
input, output_dir = output, previous_library_dir = NULL,
reuse = TRUE, progress = FALSE
))
second_evidence <- attr(second$assessments, "evidence")
expect_true(all(
second_evidence$output_manifest$status == "available"
))
})
test_that("reference quality schemas and type ranges are stable", {
expect_named(OpenSpecy:::.lib_warning_schema(),
c("algorithm", "artifact", "model", "warning"))
expect_type(OpenSpecy:::.lib_warning_schema()$warning, "character")
x <- tiny_build_lib()
x$metadata$spectrum_type <- rep(c("ftir", "raman"), each = 4)
typed <- OpenSpecy:::.lib_partition_reference_libraries(
list(raw = x), report = NULL
)$raw
expect_equal(range(typed$ftir$wavenumber), c(400, 4000))
expect_equal(range(typed$raman$wavenumber), c(200, 4000))
})
test_that("range restriction removes spectra that become flat", {
x <- tiny_build_lib()
x$metadata$spectrum_type <- "raman"
x$spectra[, 1] <- 1
outside_partition <- x$wavenumber > 4000
x$spectra[outside_partition, 1] <- seq_len(sum(outside_partition))
typed <- OpenSpecy:::.lib_partition_reference_libraries(
list(raw = x), report = NULL
)$raw$raman
expect_false("s1" %in% typed$metadata$sample_name)
partition_drops <- attr(typed, "range_flat_drops", exact = TRUE)
expect_equal(partition_drops$spectrum_id, "s1")
expect_equal(partition_drops$reason, "post_partition_flat_spectrum")
model_source <- tiny_build_lib()
model_source$metadata$spectrum_type <- "raman"
model_source$spectra[, 1] <- 1
outside_model <- model_source$wavenumber > 3200
model_source$spectra[outside_model, 1] <- seq_len(sum(outside_model))
medoids <- OpenSpecy:::.lib_build_medoids(
list(derivative = list(raman = model_source)),
report = function(...) NULL, progress = FALSE
)$derivative$raman
expect_false("s1" %in% medoids$metadata$sample_name)
model_drops <- attr(medoids, "range_flat_drops", exact = TRUE)
expect_equal(model_drops$spectrum_id, "s1")
expect_equal(model_drops$reason, "post_model_range_flat_spectrum")
})
test_that("identification ranges retain partial spectra and drop empty ones", {
axis <- seq(400, 4000, by = 6)
spectra <- cbind(
complete = sin(axis / 100),
partial = ifelse(axis < 1200, NA_real_, cos(axis / 90)),
outside_only = ifelse(axis < 800, 1, NA_real_)
)
object <- as_OpenSpecy(
axis, spectra,
metadata = data.table::data.table(
sample_name = colnames(spectra),
spectrum_type = "ftir",
material_class = "plastic"
)
)
restricted <- OpenSpecy:::.lib_restrict_model_range(object, "ftir")
expect_equal(range(restricted$wavenumber), c(802, 3196))
expect_identical(colnames(restricted$spectra), c("complete", "partial"))
expect_identical(
attr(restricted, "identification_dropped_ids"), "outside_only"
)
expect_true(anyNA(restricted$spectra[, "partial"]))
})
test_that("reference regex table contains only genuinely variable rules", {
expect_true(OpenSpecy:::.lib_regex_is_exact_literal(
"^poly\\(amide\\)$"
))
expect_false(OpenSpecy:::.lib_regex_is_exact_literal(
"^olefin[[:space:]]*\\(pe(?:[[:space:]]|\\x2c|\\)|$)"
))
expect_false(OpenSpecy:::.lib_regex_is_exact_literal(
"^(?:cotton|wool|silk)$"
))
regex_reference <- data.table::fread(
reference_workflow_data_path("classes_regex.csv")
)
expect_false(any(vapply(
regex_reference$pattern,
OpenSpecy:::.lib_regex_is_exact_literal,
logical(1)
)))
exact <- data.table::fread(
reference_workflow_data_path("classes_reference.csv")
)
expect_true(all(c(
"epoxide", "poly 1-butene isotactic", "poly 4-methyl-1-pentene",
"poly(amide)", "poly(styrene)", "poly(vinylchloride)",
"polyethylene glycol"
) %in% exact$spectrum_identity))
predicted <- predict_class_reference(
data.table::data.table(
spectrum_identity = c(
"sample sbr rubber", "sample epdm gasket", "sample acrylic paint",
"sample urethane paint", "sample alkyd varnish"
),
material = NA_character_
),
regex_reference, return = "table"
)
expect_identical(
predicted$material,
c(
"styrene-butadiene",
"epdm rubber (ethylene propylene diene monomer rubber)",
"polyacrylates", "polyurethanes", "polyesters"
)
)
})
test_that("official material hierarchy uses concise reviewed polymer classes", {
hierarchy <- data.table::fread(
reference_workflow_data_path("material_hierarchy.csv")
)
expect_identical(anyDuplicated(hierarchy$material), 0L)
expect_false(anyNA(hierarchy$material_class))
expect_false(any(!nzchar(trimws(hierarchy$material_class))))
expect_identical(
hierarchy[material == "poly(ethylene)", material_class], "polyethylene"
)
expect_identical(
hierarchy[material == "poly(propylene)", material_class], "polypropylene"
)
expect_identical(
hierarchy[material == "poly(tetrafluoroethylene)", material_class],
"polytetrafluoroethylene"
)
expect_identical(
hierarchy[material == "poly(ethylene-vinyl acetate) (EVA)",
material_class],
"polyethylene-vinyl acetate"
)
expect_identical(
hierarchy[material == "styrene-butadiene", material_class],
"poly(styrene-butadiene) rubber"
)
expect_identical(
hierarchy[
material == "epdm rubber (ethylene propylene diene monomer rubber)",
material_class
],
"poly(ethylene-propylene-diene) rubber"
)
expect_identical(
hierarchy[material == "poly(ethylene glycol)", material_class],
"polyethers"
)
parenthetical_classes <- unique(
hierarchy[grepl("[()]", material_class), material_class]
)
expect_setequal(parenthetical_classes, c(
"poly(ethylene-propylene-diene) rubber",
"poly(styrene-butadiene) rubber",
"polyhydroxy(meth)acrylates"
))
paint_classes <- c("paint", "acrylic paint", "alkyd paint", "urethane paint")
expect_false(any(hierarchy$material_class %in% paint_classes))
exceptions <- c(
"other plastic"
)
polymer_classes <- unique(hierarchy[material_type == "plastic", material_class])
expect_true(all(startsWith(setdiff(polymer_classes, exceptions), "poly")))
})
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.