Nothing
inst/shiny/global.R
In OpenSpecy: Analyze, Process, Identify, and Share Raman and (FT)IR Spectra
if (file.exists("wasm-config.R")) {
source("wasm-config.R", local = TRUE)
}
app_wasm_mode <- function() {
env <- tolower(Sys.getenv("OPENSPECY_SHINY_WASM", ""))
isTRUE(getOption("openspecy.shiny.wasm", FALSE)) ||
env %in% c("1", "true", "yes", "on")
}
# Resolve local-only filesystem controls dynamically so Shinylive's dependency
# scanner does not pull shinyFiles or desktop GUI packages into WebAssembly.
app_shiny_files <- function(name) {
if(app_wasm_mode()) {
stop("Local filesystem controls are unavailable in WebAssembly mode.",
call. = FALSE)
}
getExportedValue("shinyFiles", name)
}
app_local_file_extensions <- function() {
c(
"csv", "asp", "tsv", "spc", "jdx", "dx", "RData", "spa", "0",
"zip", "img", "h5", "txt", "json", "rds", "hdr", "dat",
"jpg", "jpeg", "png"
)
}
app_native_dialog_available <- function(
os_type = .Platform$OS.type,
sysname = unname(Sys.info()[["sysname"]]),
tcltk_available = isTRUE(capabilities("tcltk")) &&
requireNamespace("tcltk", quietly = TRUE)) {
identical(os_type, "windows") ||
(identical(sysname, "Darwin") && isTRUE(tcltk_available))
}
app_choose_local_paths <- function(
chooser = NULL, os_type = .Platform$OS.type,
sysname = unname(Sys.info()[["sysname"]]),
tcltk_available = isTRUE(capabilities("tcltk")) &&
requireNamespace("tcltk", quietly = TRUE)) {
if(is.null(chooser)) {
if(identical(os_type, "windows")) {
chooser <- utils::choose.files
} else if(identical(sysname, "Darwin") && isTRUE(tcltk_available)) {
chooser <- getExportedValue("tcltk", "tk_choose.files")
} else {
stop(
"A native multi-file dialog is unavailable; use Filesystem browser.",
call. = FALSE
)
}
}
patterns <- paste0("*.", app_local_file_extensions(), collapse = ";")
filters <- matrix(
c("Spectral files", patterns, "All files", "*.*"),
ncol = 2L, byrow = TRUE,
dimnames = list(NULL, c("Description", "Extensions"))
)
selected <- chooser(
default = "", caption = "Select OpenSpecy spectral files",
multi = TRUE, filters = filters, index = 1L
)
selected <- as.character(selected)
selected <- selected[!is.na(selected) & nzchar(selected)]
if(!length(selected)) return(character())
normalizePath(selected, winslash = "/", mustWork = TRUE)
}
validate_wasm_package_version <- function() {
if (!app_wasm_mode()) return(invisible(TRUE))
expected <- getOption("openspecy.shiny.wasm.package_version", "")
actual <- as.character(utils::packageVersion("OpenSpecy"))
if (!nzchar(expected) || !identical(actual, expected)) {
commit <- getOption("openspecy.shiny.wasm.package_sha", "unknown")
stop(
"The WebAssembly app loaded OpenSpecy ", actual,
" but its pinned build requires ", expected,
" from commit ", commit, ".",
call. = FALSE
)
}
invisible(TRUE)
}
#remotes::install_github("wincowgerDEV/OpenSpecy-package@vignettes")
# Libraries ----
library(shiny)
library(shinyjs)
library(shinyWidgets)
library(dplyr)
library(plotly)
library(data.table)
library(DT)
library(digest)
#library(curl)
#library(loggit)
library(bs4Dash)
library(ggplot2)
library(reshape2)
library(OpenSpecy)
validate_wasm_package_version()
#library(glmnet)
# Shared, structured explanations for the in-place "What this changes"
# disclosures. Stable topic IDs keep guidance aligned with the controls.
app_guidance_registry <- list(
min_max_normalize = list(
title = "Min-Max Normalize",
controls = "make_rel_decision",
body = c(
"Min-Max Normalize rescales every plotted raw, active, and reference spectrum to a zero-to-one relative-intensity scale after the selected corrections, so flattening or other processing cannot leave the active trace on a different display scale.",
"Turning the owner switch off is a true no-op: uploaded intensity units and scale are retained. This can make absolute intensity differences easier to see, but magnitude may dominate visual comparisons."
)
),
smoothing_derivative = list(
title = "Smoothing / Derivative",
controls = c(
"smooth_decision", "smoother", "derivative_order",
"smoother_window", "derivative_abs"
),
body = c(
"Polynomial chooses the Savitzky-Golay polynomial order (0-5); Wavenumber Window is the smoothing width in cm^-1, where a larger window suppresses more noise but can blur narrow bands.",
"Derivative Order 0 smooths without differentiating; higher orders emphasize spectral shape changes and also amplify noise. Absolute Value folds negative derivative values above zero.",
"When Smoothing / Derivative is off, every child value is ignored. The Derivative identification library expects this switch on with order 1 and Absolute Value on; a deliberate preprocessed upload may still proceed after the Run warning."
)
),
baseline_correction = list(
title = "Baseline Correction",
controls = c(
"baseline_decision", "baseline_method", "baseline", "refit",
"baseline_lambda", "baseline_hwi", "iterations"
),
body = c(
"Modified Polynomial estimates a whole-spectrum baseline; a higher polynomial degree can follow more curvature but can also remove broad real bands. Refit performs one final fit after iterative rejection.",
"Fill Peaks uses a unitless smoothing-penalty setting plus a Local Half-Window measured in sampled wavenumber buckets; larger values produce a smoother or broader baseline estimate. Iterations controls repeated peak suppression.",
"When Baseline Correction is off, all child settings are ignored. The No Baseline identification library expects correction on and no active derivative transform; deliberately preprocessed uploads may still proceed after the Run warning."
)
),
identification_strategy = list(
title = "Identification Strategy",
controls = c(
"identification_active", "id_spec_type", "id_strategy", "lib_type",
"top_n_input", "top_n_per_organization", "filter_lib", "lib_org"
),
body = c(
"Spectrum Type limits candidate references when the measurement type is known; All searches FTIR, Raman, and NIR. Library Type trades reference detail against runtime. Top N limits retained model probabilities too; for spectral libraries, Top N per organization retains that many candidates from every selected organization and turning it off applies Top N globally.",
"Derivative requires absolute first-derivative preprocessing. No Baseline requires baseline correction and no active derivative. A mismatch can make scores scientifically misleading, so Run reports a nonblocking warning with the corrective controls.",
"Turning Identification off skips library/model loading, matching, Top Matches, and material-dependent spatial grouping. Filter Library is also a no-op while its owner switch is off."
)
),
custom_ratios = list(
title = "Custom Ratios",
controls = c(
"quant_ratio_name", "quant_ratio_type", "quant_numerator_area_min",
"quant_numerator_area_max", "quant_denominator_area_min",
"quant_denominator_area_max", "quant_numerator_peak",
"quant_denominator_peak", "quant_ratio_add"
),
body = c(
"Every saved ratio uses the same final processed spectrum shown as the primary Spectra trace; a library-reference overlay is never used as a second quantification pipeline.",
"Area ratio integrates numerator and denominator ranges in cm^-1. Peak ratio compares the nearest sampled intensities at two requested wavenumbers; narrower choices are more sensitive to axis resolution and peak-position uncertainty.",
"For a polyethylene carbonyl-area demonstration, use 1650-1850 cm^-1 over 1420-1500 cm^-1. Interpret any ratio only with a method suitable for the material, instrument, preprocessing, and a meaningful nonzero denominator."
)
)
)
app_guidance_topic <- function(topic) {
if(length(topic) != 1L || is.na(topic) || !nzchar(topic) ||
!topic %in% names(app_guidance_registry)) {
stop("Unknown app guidance topic: ", paste(topic, collapse = ", "),
call. = FALSE)
}
guidance <- app_guidance_registry[[topic]]
if(!is.list(guidance) || !isTruthy(guidance$title) ||
!length(guidance$controls) || !length(guidance$body) ||
any(!nzchar(trimws(guidance$body)))) {
stop("App guidance topic is incomplete: ", topic, call. = FALSE)
}
guidance
}
app_guidance_text <- function(topic) app_guidance_topic(topic)$body
app_tab_switch_ids <- function() {
list(
preprocessing = c(
"make_rel_decision", "smooth_decision", "conform_decision",
"intensity_decision", "baseline_decision", "range_decision",
"co2_decision", "spike_decision", "saturation_decision"
),
identification = c(
"identification_active", "filter_lib"
),
advanced = c(
"cor_threshold_decision", "threshold_decision", "collapse_decision",
"spatial_decision", "simple_metadata", "show_peak_positions",
"load_entire_map", "xy_grid"
)
)
}
app_tab_all_off_values <- function(tab) {
ids <- app_tab_switch_ids()[[tab]]
if(is.null(ids)) stop("Unknown settings tab: ", tab, call. = FALSE)
stats::setNames(rep(FALSE, length(ids)), ids)
}
app_tab_active_states <- function(settings, ratio_definitions,
measurement_definitions) {
switch_ids <- app_tab_switch_ids()
states <- vapply(switch_ids, function(ids) {
any(vapply(ids, function(id) isTRUE(settings[[id]]), logical(1)))
}, logical(1))
c(
states,
quantification = nrow(ratio_definitions) > 0L ||
nrow(measurement_definitions) > 0L
)
}
# Return Run-time compatibility notices without blocking or changing expert
# workflows. Configuration changes alone never call this helper from server.R;
# the Run observer owns presentation of the result.
app_identification_compatibility_warnings <- function(settings) {
if(!is.list(settings) || !isTRUE(settings$identification_active)) {
return(character())
}
strategy <- as.character(settings$id_strategy)[1L]
smooth <- isTRUE(settings$smooth_decision)
derivative <- suppressWarnings(as.integer(settings$derivative_order)[1L])
derivative_active <- smooth && !is.na(derivative) && derivative > 0L
messages <- character()
if(identical(strategy, "deriv") &&
(!smooth || !identical(derivative, 1L) ||
!isTRUE(settings$derivative_abs))) {
messages <- c(messages, paste(
"Derivative library compatibility: turn on Smoothing / Derivative,",
"set Derivative Order to 1, and turn on Absolute Value."
))
}
if(identical(strategy, "nobaseline") &&
(!isTRUE(settings$baseline_decision) || derivative_active)) {
messages <- c(messages, paste(
"No Baseline library compatibility: turn on Baseline Correction and",
"use Derivative Order 0 (or turn Smoothing / Derivative off)."
))
}
if(length(messages)) {
messages <- paste0(
messages,
" If the upload was deliberately preprocessed this way, you may proceed."
)
}
messages
}
app_initial_result_selection <- function(object, pixel_to_unit = NULL) {
if(is.null(object) || is.null(object$spectra) || ncol(object$spectra) < 1L) {
return(list(plot = NA_integer_, pixel = NA_integer_, table = 1L))
}
pixel <- 1L
if(!is.null(pixel_to_unit)) {
mapping <- data.table::as.data.table(pixel_to_unit)
if(all(c("kept", "unit_index", "pixel_index") %in% names(mapping))) {
candidates <- mapping[
kept & !is.na(unit_index) & unit_index == 1L,
pixel_index
]
if(length(candidates) && !is.na(candidates[[1L]])) {
pixel <- as.integer(candidates[[1L]])
}
}
}
list(plot = 1L, pixel = pixel, table = 1L)
}
# Build the full source-pixel projection used when analysis has not supplied a
# particle mapping. Specs stores source identifiers and coordinates separately
# from its compact value matrix, so treating it like an OpenSpecy object drops
# pixel_id and leaves map outputs unable to align after a Run.
app_identity_pixel_mapping <- function(object, eligible = NULL) {
compact <- is_Specs(object)
metadata <- if(compact) {
data.table::as.data.table(specs_metadata(object))
} else data.table::as.data.table(object$metadata)
coordinates <- if(compact) {
data.table::as.data.table(specs_coordinates(object))
} else NULL
ids <- if(compact) {
as.character(coordinates$source_id)
} else colnames(object$spectra)
if(is.null(ids)) ids <- paste0("pixel_", seq_len(nrow(metadata)))
count <- length(ids)
eligible <- if(is.null(eligible)) rep(TRUE, count) else as.logical(eligible)
if(length(eligible) != count) {
stop("Pixel eligibility must align with every source spectrum.",
call. = FALSE)
}
eligible[is.na(eligible)] <- FALSE
x <- if("x" %in% names(metadata)) metadata$x else if(compact &&
"x" %in% names(coordinates)) coordinates$x else seq_len(count) - 1
y <- if("y" %in% names(metadata)) metadata$y else if(compact &&
"y" %in% names(coordinates)) coordinates$y else rep(0, count)
data.table::data.table(
pixel_index = seq_len(count), pixel_id = ids,
source_id = OpenSpecy:::.particle_source_vector(metadata, count),
x = x, y = y, eligible = eligible, material = NA_character_,
region_id = ids, cluster_id = NA_character_, unit_id = ids,
unit_index = ifelse(eligible, seq_len(count), NA_integer_),
area = 1L, kept = eligible,
rejection_reason = ifelse(eligible, NA_character_, "threshold")
)
}
app_first_retained_pixel <- function(mapping) {
mapping <- data.table::as.data.table(mapping)
required <- c("pixel_index", "kept")
if(!all(required %in% names(mapping))) {
stop("Pixel mapping is missing retained-selection columns.", call. = FALSE)
}
pixels <- mapping[kept == TRUE & !is.na(pixel_index), pixel_index]
if(!length(pixels)) return(NA_integer_)
as.integer(pixels[[1L]])
}
app_selected_rank_index <- function(selected_row, row_count) {
row_count <- suppressWarnings(as.integer(row_count)[1L])
if(is.na(row_count) || row_count < 1L) return(NA_integer_)
selected_row <- suppressWarnings(as.integer(selected_row)[1L])
if(is.na(selected_row)) selected_row <- 1L
min(max(1L, selected_row), row_count)
}
app_has_clickable_heatmap <- function(data, spectrum_count) {
!is.null(data) && !identical(data$type, "empty") &&
is.finite(spectrum_count) && spectrum_count > 1L
}
app_download_choices <- function(has_upload, identification,
collapse = FALSE, compact = FALSE) {
tests <- c("Test Data", "Test Map")
metadata <- "User Metadata"
if (!isTRUE(has_upload)) return(c(tests, metadata))
choices <- if (isTRUE(identification)) {
c("Top Matches", "Processed Spectra")
} else {
"Processed Spectra"
}
if (isTRUE(compact)) choices <- c(choices, "Compact Map (RDS)")
if (isTRUE(collapse)) choices <- c(choices, "Thresholded Particles")
c(choices, tests, metadata)
}
app_download_label <- function(selection) {
labels <- c(
"Test Data" = "Download Test Data",
"Test Map" = "Download Test Map",
"Processed Spectra" = "Download Processed Spectra",
"Compact Map (RDS)" = "Download Compact Map (RDS)",
"Top Matches" = "Download Top Matches",
"Thresholded Particles" = "Download Thresholded Particles",
"User Metadata" = "Download User Metadata"
)
if(length(selection) != 1L || is.na(selection) ||
!selection %in% names(labels)) {
return("Download selected")
}
unname(labels[[selection]])
}
app_upload_limit_bytes <- function() {
10 * 1024^3
}
app_max_request_size_bytes <- function() {
app_upload_limit_bytes()
}
app_upload_limit_label <- function() {
"10 GiB"
}
app_upload_guidance <- function() {
paste0(
"The upload ceiling is ", app_upload_limit_label(),
" total. Choose fewer or smaller files and try again."
)
}
app_write_particle_archive <- function(files, destination, root) {
files <- normalizePath(files, winslash = "/", mustWork = TRUE)
root <- normalizePath(root, winslash = "/", mustWork = TRUE)
relative <- substring(files, nchar(root) + 2L)
if(!length(files) || any(!startsWith(files, paste0(root, "/"))) ||
any(!nzchar(relative))) {
stop("Particle archive files must be inside the completed output directory.",
call. = FALSE)
}
zip::zipr(destination, files = files, root = root,
include_directories = FALSE)
invisible(destination)
}
app_validate_upload_size <- function(file_info) {
limit <- app_upload_limit_bytes()
if(is.null(file_info) || (is.data.frame(file_info) && !nrow(file_info))) {
return(list(ok = TRUE, size = 0, limit = limit,
message = app_upload_guidance()))
}
if(!is.data.frame(file_info) || !"size" %in% names(file_info)) {
return(list(
ok = FALSE, size = NA_real_, limit = limit,
message = paste(
"Open Specy could not verify the selected file sizes.",
app_upload_guidance()
)
))
}
sizes <- suppressWarnings(as.numeric(file_info$size))
if(length(sizes) != nrow(file_info) || any(!is.finite(sizes) | sizes < 0)) {
return(list(
ok = FALSE, size = NA_real_, limit = limit,
message = paste(
"Every selected file must report a valid nonnegative size.",
app_upload_guidance()
)
))
}
total <- sum(sizes)
ok <- total <= limit
list(ok = ok, size = total, limit = limit,
message = app_upload_guidance())
}
app_mounted_file_info <- function(value) {
if(is.null(value) || !identical(value$transport, "workerfs")) {
stop("Mounted file metadata is missing its WORKERFS transport marker.",
call. = FALSE)
}
mount_id <- as.character(value$mount_id)
if(length(mount_id) != 1L || !grepl("^[0-9a-f]{32}$", mount_id)) {
stop("Mounted file metadata has an invalid session identifier.",
call. = FALSE)
}
fields <- lapply(c("name", "size", "type", "datapath"), function(field) {
unlist(value[[field]], use.names = FALSE)
})
names(fields) <- c("name", "size", "type", "datapath")
count <- length(fields$name)
if(!count || any(vapply(fields, length, integer(1)) != count)) {
stop("Mounted file metadata columns do not align.", call. = FALSE)
}
names_safe <- nzchar(fields$name) &
!fields$name %in% c(".", "..") &
!grepl("[\\/[:cntrl:]]", fields$name)
if(!all(names_safe) || anyDuplicated(tolower(fields$name))) {
stop("Mounted files require safe, case-insensitively unique names.",
call. = FALSE)
}
prefix <- paste0("/tmp/openspecy-upload-", mount_id, "/")
expected_paths <- paste0(prefix, fields$name)
if(!identical(as.character(fields$datapath), expected_paths)) {
stop("Mounted file paths escaped their session directory.", call. = FALSE)
}
data.frame(
name = as.character(fields$name),
size = as.numeric(fields$size),
type = as.character(fields$type),
datapath = as.character(fields$datapath),
stringsAsFactors = FALSE
)
}
app_native_file_info <- function(value) {
value <- data.frame(value, stringsAsFactors = FALSE)
required <- c("name", "size", "type", "datapath")
if (!nrow(value) || !all(required %in% names(value))) {
stop("Native file selection did not return complete file metadata.",
call. = FALSE)
}
paths <- normalizePath(value$datapath, winslash = "/", mustWork = TRUE)
if (any(file.info(paths)$isdir)) {
stop("Native selection must contain files, not directories.",
call. = FALSE)
}
if (anyDuplicated(tolower(paths))) {
stop("Selected files must be unique.", call. = FALSE)
}
value$datapath <- paths
value$size <- as.numeric(file.info(paths)$size)
value[, required, drop = FALSE]
}
app_direct_file_info <- function(paths) {
paths <- as.character(paths)
paths <- paths[!is.na(paths) & nzchar(paths)]
if(!length(paths)) return(NULL)
app_native_file_info(data.frame(
name = basename(paths), size = as.numeric(file.info(paths)$size),
type = "", datapath = paths, stringsAsFactors = FALSE
))
}
app_local_file_info <- function(value, roots) {
value <- app_native_file_info(value)
paths <- value$datapath
root_paths <- unique(normalizePath(
unname(as.character(roots)), winslash = "/", mustWork = TRUE
))
root_prefixes <- paste0(sub("/+$", "", root_paths), "/")
inside <- vapply(paths, function(path) {
any(path == root_paths | startsWith(path, root_prefixes))
}, logical(1))
if(!all(inside)) {
stop("Local file selection escaped the configured filesystem roots.",
call. = FALSE)
}
value
}
app_local_roots <- function() {
if(identical(.Platform$OS.type, "windows")) {
candidates <- paste0(LETTERS, ":/")
paths <- candidates[dir.exists(candidates)]
names(paths) <- sub(":/$", "", paths)
} else {
paths <- c(root = "/")
}
if(!length(paths)) {
stop("No readable local filesystem roots were found.", call. = FALSE)
}
stats::setNames(
normalizePath(paths, winslash = "/", mustWork = TRUE), names(paths)
)
}
# data.table::fread() memory-maps filename inputs. webR's 32-bit runtime cannot
# mmap a WORKERFS-backed browser File, even when the file itself is tiny. Feed
# direct mounted text through fread's text parser so delimiter/type inference
# and the resulting OpenSpecy format stay the same without the unsupported map.
app_workerfs_fread <- function(file, ...) {
lines <- readLines(file, warn = FALSE)
data.table::fread(text = paste(lines, collapse = "\n"), ...)
}
app_read_uploaded_members <- function(paths, mounted = FALSE,
representation = "OpenSpecy",
background_filter = NULL,
spectral_smooth = FALSE,
sigma = c(1, 1, 1)) {
paths <- as.character(paths)
image_paths <- paths[grepl("\\.(jpg|jpeg|png)$", paths, ignore.case = TRUE)]
spectral_paths <- setdiff(paths, image_paths)
if(!length(spectral_paths)) {
stop("Select a supported spectral file with the visual image.",
call. = FALSE)
}
mounted_text <- isTRUE(mounted) &
grepl("\\.(xyz|csv|tsv|txt)$", paths, ignore.case = TRUE)
read_one <- function(path, use_workerfs_text) {
if(isTRUE(use_workerfs_text)) {
read_text(file = path, method = app_workerfs_fread)
} else if(grepl("\\.(zip|h5)$", path, ignore.case = TRUE)) {
read_any(
file = path, c_spec = FALSE, representation = representation,
background_filter = background_filter,
spectral_smooth = spectral_smooth, sigma = sigma
)
} else {
read_any(file = path, c_spec = FALSE)
}
}
envi_pair <- length(spectral_paths) == 2L &&
any(grepl("\\.(dat|img)$", spectral_paths, ignore.case = TRUE)) &&
any(grepl("\\.hdr$", spectral_paths, ignore.case = TRUE))
attach_envi_image <- function(object) {
if(!envi_pair || !length(image_paths)) return(object)
binary <- spectral_paths[grepl("\\.(dat|img)$", spectral_paths,
ignore.case = TRUE)][[1L]]
stem <- tolower(tools::file_path_sans_ext(basename(binary)))
matching <- image_paths[
tolower(tools::file_path_sans_ext(basename(image_paths))) == stem
]
if(length(matching) != 1L) {
warning(
if(length(matching)) {
"Multiple basename-matched ENVI images were supplied; continuing without an overlay."
} else {
"The ENVI image basename does not match the DAT/IMG file; continuing without an overlay."
}, call. = FALSE
)
return(object)
}
detection <- tryCatch(detect_image_origin(matching[[1L]]),
error = identity)
if(inherits(detection, "error")) {
warning("Could not detect a red map boundary in ",
basename(matching[[1L]]), "; continuing without an overlay.",
call. = FALSE)
return(object)
}
add_visual_image(
object, matching[[1L]], bottom_left = detection$bottom_left,
top_right = detection$top_right,
detection_method = detection$detection_method,
diagnostics = detection$diagnostics
)
}
if(envi_pair && identical(representation, "Specs")) {
return(attach_envi_image(open_specs(spectral_paths)))
}
if(envi_pair) {
return(attach_envi_image(read_any(file = spectral_paths, c_spec = FALSE)))
}
if(length(spectral_paths) > 1L) {
mounted_spectral <- isTRUE(mounted) &
grepl("\\.(xyz|csv|tsv|txt)$", spectral_paths, ignore.case = TRUE)
return(Map(read_one, spectral_paths, mounted_spectral))
}
read_one(spectral_paths[[1L]],
isTRUE(mounted) && grepl("\\.(xyz|csv|tsv|txt)$",
spectral_paths[[1L]], ignore.case = TRUE))
}
app_upload_failure_guidance <- function(elapsed_seconds, mounted = FALSE) {
elapsed <- max(0, suppressWarnings(as.numeric(elapsed_seconds)[[1L]]))
route <- if(isTRUE(mounted)) {
paste(
"The browser mount succeeded, but full in-memory reading or allocation",
"did not. For an ENVI ZIP, try selecting the extracted HDR and DAT",
"files together to avoid ZIP extraction overhead."
)
} else {
paste(
"Local Shiny reads the selected source path directly; confirm the file",
"is still available and readable."
)
}
paste0(
"The read/materialize phase failed after ", sprintf("%.1f", elapsed),
" seconds. ", route,
" Close other memory-heavy tabs or applications before retrying."
)
}
# Vector-safe threshold truth table shared by map projection and direct tests.
# Correlation uses an inclusive minimum (equal passes); signal/noise uses strict
# interior bounds (equal to either bound fails).
app_threshold_rejection_mask <- function(values, enabled, minimum,
maximum = NULL) {
values <- suppressWarnings(as.numeric(values))
if(!isTRUE(enabled)) return(rep(FALSE, length(values)))
minimum <- suppressWarnings(as.numeric(minimum))
if(length(minimum) != 1L || is.na(minimum)) {
stop("A threshold minimum must be one numeric value.", call. = FALSE)
}
if(is.null(maximum)) return(is.na(values) | values < minimum)
maximum <- suppressWarnings(as.numeric(maximum))
if(length(maximum) != 1L || is.na(maximum)) {
stop("A threshold maximum must be one numeric value.", call. = FALSE)
}
is.na(values) | values <= minimum | values >= maximum
}
# Grid-shaped plot data for an ordinary uploaded map's heatmap (Match
# Name/ID/Value, Signal/Noise), matching the same contract.
app_ordinary_heatmap_data <- function(metadata, values, categorical,
legend_title, rejected = NULL,
rejection_reason = NULL,
axis_unit = "pixel") {
rejected <- if(is.null(rejected)) rep(FALSE, length(values)) else {
out <- as.logical(rejected)
if(length(out) != length(values)) {
stop("The heatmap threshold mask does not align with its values.",
call. = FALSE)
}
out[is.na(out)] <- FALSE
out
}
if(is.null(rejection_reason)) {
rejection_reason <- rep("active threshold", length(values))
}
if(length(rejection_reason) != length(values)) {
stop("The heatmap rejection reasons do not align with its values.",
call. = FALSE)
}
rejection_reason <- as.character(rejection_reason)
rejection_reason[!rejected] <- NA_character_
rejected_grid <- OpenSpecy:::.particle_map_grid(
metadata, ifelse(rejected, 1, NA_real_), 1, c(0, 0)
)$z
reason_levels <- unique(rejection_reason[rejected & !is.na(rejection_reason)])
reason_codes <- match(rejection_reason, reason_levels)
reason_grid <- OpenSpecy:::.particle_map_grid(
metadata, reason_codes, 1, c(0, 0)
)$z
reason_grid <- matrix(
ifelse(is.na(reason_grid), NA_character_, reason_levels[reason_grid]),
nrow = nrow(reason_grid), ncol = ncol(reason_grid)
)
if(categorical) {
values <- droplevels(values)
levels <- levels(values)
grid <- OpenSpecy:::.particle_map_grid(metadata, as.integer(values), 1,
c(0, 0))
list(type = "heatmap_categorical", x = grid$x, y = grid$y, z = grid$z,
levels = levels, legend_title = legend_title,
palette = app_category_palette(levels), rejected = rejected_grid,
rejection_reason = reason_grid, axis_unit = axis_unit)
} else {
grid <- OpenSpecy:::.particle_map_grid(metadata, values, 1, c(0, 0))
list(type = "heatmap", x = grid$x, y = grid$y, z = grid$z,
legend_title = legend_title, rejected = rejected_grid,
rejection_reason = reason_grid, axis_unit = axis_unit)
}
}
app_reference_for_query <- function(reference, query, preserve_axis = TRUE) {
if(identical(reference$wavenumber, query$wavenumber)) {
return(reference)
}
conform_spec(
reference, range = query$wavenumber, res = NULL,
# An "all" reference combines the independently ranged FTIR, Raman, and
# NIR libraries. References outside the query's support are deliberately
# NA padded and cor_spec() ignores them; rejecting those NAs here would
# make the complete-library option unusable.
allow_na = anyNA(reference$spectra),
type = if(isTRUE(preserve_axis)) "mean_up" else "roll"
)
}
app_identification_block_progress <- function(
query_count, library_count, block_size, completed_blocks = 0L,
total_blocks = NULL, progress_start = 76, progress_end = 88) {
scalar_count <- function(value, fallback = 0L) {
value <- suppressWarnings(as.integer(value)[1L])
if(is.na(value) || value < 0L) fallback else value
}
query_count <- scalar_count(query_count)
library_count <- scalar_count(library_count)
block_size <- max(1L, scalar_count(block_size, 1L))
if(is.null(total_blocks)) {
total_blocks <- as.integer(max(1L, ceiling(query_count / block_size)))
} else {
total_blocks <- max(1L, scalar_count(total_blocks, 1L))
}
completed_blocks <- min(
total_blocks, scalar_count(completed_blocks)
)
block_fraction <- completed_blocks / total_blocks
block_percent <- as.integer(floor(100 * block_fraction))
list(
message = paste0(
"Identifying spectra (", block_percent, "% of blocks complete)"
),
detail = paste0(
"Completed ", completed_blocks, " of ", total_blocks, " block",
if(total_blocks == 1L) "" else "s", " while comparing ",
format(query_count, big.mark = ","), " ",
if(query_count == 1L) "spectrum" else "spectra", " with ",
format(library_count, big.mark = ","), " references; block size ",
format(block_size, big.mark = ","), "."
),
progress = progress_start +
(progress_end - progress_start) * block_fraction,
completed_blocks = completed_blocks,
total_blocks = total_blocks,
block_percent = block_percent
)
}
app_file_stream_processing_issues <- function(settings,
spatial_smooth = FALSE) {
if(!is.list(settings)) {
stop("Streaming processing settings must be a named list.", call. = FALSE)
}
issues <- character()
if(isTRUE(settings$saturation_decision)) {
issues <- c(issues, "turn off Saturation Correction")
}
if(isTRUE(settings$co2_decision) && isTRUE(settings$co2_automate)) {
issues <- c(issues, "turn off automatic CO2 flattening")
}
if(isTRUE(settings$range_decision) && isTRUE(settings$range_automate)) {
issues <- c(issues, "turn off automatic range restriction")
}
unique(issues)
}
# Raw/Spatial signal/noise never applies Min-Max Normalize. Fully Processed
# deliberately bypasses this helper and uses the complete enabled recipe.
app_snr_processing_settings <- function(settings) {
if(!is.list(settings)) {
stop("Signal/noise processing settings must be a list.", call. = FALSE)
}
settings$make_rel_decision <- FALSE
settings
}
# Raw/Spatial signal thresholding intentionally omits the ordinary baseline,
# spectral smoothing, range, and normalization steps, but intensity units are
# not optional scientific decoration: a selected transmittance/reflectance
# conversion must happen before S/N is interpreted as absorbance-like data.
app_intensity_snr_basis <- function(x, settings) {
if(!inherits(x, "OpenSpecy") || !is.list(settings)) {
stop("Intensity-adjusted S/N requires OpenSpecy data and settings.",
call. = FALSE)
}
if(!isTRUE(settings$intensity_decision)) return(x)
type <- if(is.null(settings$intensity_corr)) "none" else
as.character(settings$intensity_corr)[[1L]]
adjusted <- adj_intens(x, type = type, make_rel = FALSE)
if(!identical(type, "none")) attr(adjusted, "intensity_unit") <- "absorbance"
adjusted
}
app_prepare_correlation_reference <- function(reference) {
if(!inherits(reference, "OpenSpecy")) {
stop("The correlation reference must be OpenSpecy.", call. = FALSE)
}
values <- make_rel(reference$spectra, na.rm = TRUE)
values <- OpenSpecy:::.matrix_mean_replace(values)
list(
wavenumber = reference$wavenumber,
library_id = colnames(reference$spectra),
scaled = OpenSpecy:::.scale_correlation_spectra(values)
)
}
# Match one processed query chunk while bounding both score-matrix dimensions.
# The scaled reference is reusable across file chunks; every library block is
# discarded after updating one global winning score/index per query spectrum.
app_match_prepared_best <- function(query, prepared,
library_block_size = 1000L) {
if(!inherits(query, "OpenSpecy") || !is.list(prepared) ||
!identical(query$wavenumber, prepared$wavenumber)) {
stop("The processed query and prepared reference axes must match.",
call. = FALSE)
}
library_block_size <- suppressWarnings(as.integer(library_block_size)[1L])
if(is.na(library_block_size) || library_block_size < 1L) {
stop("'library_block_size' must be a positive whole number.",
call. = FALSE)
}
library_count <- nrow(prepared$scaled)
if(length(prepared$library_id) != library_count || library_count < 1L) {
stop("The prepared correlation reference is empty or invalid.",
call. = FALSE)
}
query_values <- make_rel(query$spectra, na.rm = TRUE)
query_values <- OpenSpecy:::.matrix_mean_replace(query_values)
scaled_query <- OpenSpecy:::.scale_correlation_spectra(query_values)
query_count <- nrow(scaled_query)
best_value <- rep(NA_real_, query_count)
best_index <- rep(NA_integer_, query_count)
starts <- seq.int(1L, library_count, by = library_block_size)
query_columns <- seq_len(query_count)
for(start in starts) {
rows <- seq.int(
start, min(library_count, start + library_block_size - 1L)
)
scores <- tcrossprod(
prepared$scaled[rows, , drop = FALSE], scaled_query
)
ranked_scores <- scores
ranked_scores[!is.finite(ranked_scores)] <- -Inf
local_index <- max.col(t(ranked_scores), ties.method = "first")
candidate_value <- scores[cbind(local_index, query_columns)]
candidate_index <- rows[local_index]
update <- is.na(best_index) |
(!is.na(candidate_value) &
(is.na(best_value) | candidate_value > best_value))
best_value[update] <- candidate_value[update]
best_index[update] <- candidate_index[update]
rm(
scores, ranked_scores, local_index, candidate_value, candidate_index,
update
)
}
data.table::data.table(
object_id = colnames(query$spectra),
library_id = prepared$library_id[best_index],
match_val = best_value
)
}
app_match_bounded_best <- function(query, reference, block_size = 1000L,
progress = NULL) {
if(!inherits(query, "OpenSpecy") || !inherits(reference, "OpenSpecy") ||
!identical(query$wavenumber, reference$wavenumber)) {
stop("Bounded matching requires OpenSpecy objects on one axis.",
call. = FALSE)
}
block_size <- suppressWarnings(as.integer(block_size)[1L])
if(is.na(block_size) || block_size < 1L) {
stop("'block_size' must be a positive whole number.", call. = FALSE)
}
prepared <- app_prepare_correlation_reference(reference)
chunks <- split(
seq_len(ncol(query$spectra)),
ceiling(seq_len(ncol(query$spectra)) / block_size)
)
result <- vector("list", length(chunks))
for(i in seq_along(chunks)) {
rows <- chunks[[i]]
block <- filter_spec(
query, logic = seq_len(ncol(query$spectra)) %in% rows
)
result[[i]] <- app_match_prepared_best(
block, prepared, library_block_size = block_size
)
if(!is.null(progress)) {
progress(i, length(chunks), sum(lengths(chunks[seq_len(i)])))
}
}
data.table::rbindlist(result, use.names = TRUE)
}
# Stream a FileSpecs query through caller-owned processing and matching
# callbacks. Only one bounded spectral block and one winning match per source
# spectrum survive; full library-by-query correlation matrices are discarded
# by the callback before the next file block is read.
app_stream_filespec_best_matches <- function(
source, eligible, process, identify, chunk_size = 1000L, progress = NULL,
spatial_smooth = FALSE, sigma = c(1, 1, 1)) {
if(!inherits(source, "FileSpecs")) {
stop("Streaming identification requires a FileSpecs source.", call. = FALSE)
}
if(!is.function(process) || !is.function(identify)) {
stop("Streaming identification requires process and identify functions.",
call. = FALSE)
}
if(!is.null(progress) && !is.function(progress)) {
stop("'progress' must be NULL or a function.", call. = FALSE)
}
index <- OpenSpecy:::.filespec_index(source)
if(!is.logical(eligible) || length(eligible) != nrow(index)) {
stop("'eligible' must have one logical value per file-backed spectrum.",
call. = FALSE)
}
eligible[is.na(eligible)] <- FALSE
positions <- which(eligible)
if(!length(positions)) {
return(data.table::data.table(
object_id = character(), library_id = character(), match_val = numeric()
))
}
chunk_size <- OpenSpecy:::.filespec_bounded_chunk_size(
length(OpenSpecy:::.filespec_axis(source)), chunk_size
)
row_chunks <- if(isTRUE(spatial_smooth)) {
col_chunk <- OpenSpecy:::.filespec_column_chunk_id(index, chunk_size)
if(is.null(col_chunk)) {
stop("Spatial smoothing requires a complete rectangular file-backed grid.",
call. = FALSE)
}
split(seq_along(positions), col_chunk[positions])
} else {
split(seq_along(positions), ceiling(seq_along(positions) / chunk_size))
}
object_id <- character(length(positions))
library_id <- character(length(positions))
match_val <- rep(NA_real_, length(positions))
for(i in seq_along(row_chunks)) {
rows <- row_chunks[[i]]
query <- if(isTRUE(spatial_smooth)) {
values <- OpenSpecy:::.filespec_smoothed_values(
source, index, positions[rows], bands = NULL, sigma1 = sigma
)
OpenSpecy:::.filespec_values_to_OpenSpecy(source, values)
} else {
decompress_spec(source, index = positions[rows])
}
processed <- process(query)
if(!inherits(processed, "OpenSpecy")) {
stop("The streaming process callback must return OpenSpecy.",
call. = FALSE)
}
query_ids <- colnames(processed$spectra)
matches <- data.table::as.data.table(identify(processed))
required <- c("object_id", "library_id", "match_val")
if(!all(required %in% names(matches))) {
stop("The streaming match callback returned an invalid match table.",
call. = FALSE)
}
matches[, .stream_order := seq_len(.N)]
data.table::setorderv(
matches, c("object_id", "match_val", ".stream_order"),
c(1L, -1L, 1L), na.last = TRUE
)
best <- matches[!duplicated(object_id)]
aligned <- match(query_ids, best$object_id)
if(length(query_ids) != length(rows) || anyNA(aligned)) {
stop("Streamed match rows do not align with the processed spectra.",
call. = FALSE)
}
object_id[rows] <- query_ids
library_id[rows] <- as.character(best$library_id[aligned])
match_val[rows] <- as.numeric(best$match_val[aligned])
if(!is.null(progress)) {
progress(
completed_blocks = i, total_blocks = length(row_chunks),
completed_spectra = sum(lengths(row_chunks[seq_len(i)])),
total_spectra = length(positions), chunk_size = chunk_size
)
}
rm(query, processed, matches, best)
if(i %% 5L == 0L || i == length(row_chunks)) {
invisible(gc(verbose = FALSE))
}
}
result <- data.table::data.table(
object_id = object_id, library_id = library_id, match_val = match_val
)
attr(result, "chunk_size") <- chunk_size
result
}
# Build the Cluster Buster background from bounded, fully processed query
# chunks. Summing after `process()` is essential: the temporary background must
# inhabit the same processed feature space as matching, not the raw map space.
app_stream_filespec_processed_mean <- function(
source, eligible, process, chunk_size = 1000L, progress = NULL,
spatial_smooth = FALSE, sigma = c(1, 1, 1)) {
if(!inherits(source, "FileSpecs") || !is.function(process)) {
stop("A FileSpecs source and processing callback are required.", call. = FALSE)
}
index <- OpenSpecy:::.filespec_index(source)
if(!is.logical(eligible) || length(eligible) != nrow(index)) {
stop("'eligible' must have one logical value per file-backed spectrum.",
call. = FALSE)
}
eligible[is.na(eligible)] <- FALSE
positions <- which(eligible)
if(!length(positions)) {
stop("Cluster Buster requires at least one retained spectrum.", call. = FALSE)
}
chunk_size <- OpenSpecy:::.filespec_bounded_chunk_size(
length(OpenSpecy:::.filespec_axis(source)), chunk_size
)
chunks <- if(isTRUE(spatial_smooth)) {
column_chunk <- OpenSpecy:::.filespec_column_chunk_id(index, chunk_size)
if(is.null(column_chunk)) {
stop("Spatial smoothing requires a complete rectangular file-backed grid.",
call. = FALSE)
}
split(seq_along(positions), column_chunk[positions])
} else {
split(seq_along(positions), ceiling(seq_along(positions) / chunk_size))
}
total <- NULL
axis <- NULL
preserve_uploaded_axis <- FALSE
count <- 0L
for(i in seq_along(chunks)) {
rows <- chunks[[i]]
query <- if(isTRUE(spatial_smooth)) {
values <- OpenSpecy:::.filespec_smoothed_values(
source, index, positions[rows], bands = NULL, sigma1 = sigma
)
OpenSpecy:::.filespec_values_to_OpenSpecy(source, values)
} else {
decompress_spec(source, index = positions[rows])
}
processed <- process(query)
if(!inherits(processed, "OpenSpecy")) {
stop("The streaming process callback must return OpenSpecy.", call. = FALSE)
}
if(is.null(axis)) {
axis <- processed$wavenumber
preserve_uploaded_axis <- isTRUE(attr(
processed, "preserve_uploaded_axis", exact = TRUE
))
total <- rowSums(processed$spectra)
} else {
if(!identical(axis, processed$wavenumber)) {
stop("Streamed preprocessing produced inconsistent wavenumber axes.",
call. = FALSE)
}
total <- total + rowSums(processed$spectra)
}
count <- count + ncol(processed$spectra)
if(!is.null(progress)) {
progress(
completed_blocks = i, total_blocks = length(chunks),
completed_spectra = sum(lengths(chunks[seq_len(i)])),
total_spectra = length(positions), chunk_size = chunk_size
)
}
rm(query, processed)
}
spectra <- matrix(
total / count, ncol = 1L,
dimnames = list(as.character(axis), "background")
)
result <- as_OpenSpecy(
axis, spectra = spectra,
metadata = data.table::data.table(
col_id = "background", sample_name = "background",
spectrum_identity = "background", material_class = "background",
organization = "Temporary map background"
), compute_file_id = FALSE
)
attr(result, "preserve_uploaded_axis") <- preserve_uploaded_axis
result
}
app_cluster_buster_background <- function(processed) {
if(!inherits(processed, "OpenSpecy") || ncol(processed$spectra) < 1L) {
stop("Cluster Buster requires processed retained spectra.", call. = FALSE)
}
spectra <- matrix(
rowMeans(processed$spectra), ncol = 1L,
dimnames = list(as.character(processed$wavenumber), "background")
)
result <- as_OpenSpecy(
processed$wavenumber, spectra = spectra,
metadata = data.table::data.table(
col_id = "background", sample_name = "background",
spectrum_identity = "background", material_class = "background",
organization = "Temporary map background"
), compute_file_id = FALSE
)
attr(result, "preserve_uploaded_axis") <- isTRUE(attr(
processed, "preserve_uploaded_axis", exact = TRUE
))
result
}
app_append_cluster_buster_background <- function(reference, background) {
if(!inherits(reference, "OpenSpecy") || !inherits(background, "OpenSpecy") ||
ncol(background$spectra) != 1L ||
!identical(reference$wavenumber, background$wavenumber)) {
stop("The reference and one-spectrum background must share an axis.",
call. = FALSE)
}
if("background" %in% colnames(reference$spectra)) {
stop("The selected library already contains a spectrum named 'background'.",
call. = FALSE)
}
result <- reference
result$spectra <- cbind(reference$spectra, background$spectra)
result$metadata <- data.table::rbindlist(
list(
data.table::as.data.table(reference$metadata),
data.table::as.data.table(background$metadata)
), use.names = TRUE, fill = TRUE
)
result$metadata$col_id <- colnames(result$spectra)
result
}
app_cluster_buster_decisions <- function(
matches, pixel_ids, signal_keep, correlation_enabled = FALSE,
minimum = -Inf, background_id = "background") {
matches <- data.table::as.data.table(matches)
required <- c("object_id", "library_id", "match_val")
if(!all(required %in% names(matches))) {
stop("Cluster Buster matches are missing required columns.", call. = FALSE)
}
pixel_ids <- as.character(pixel_ids)
signal_keep <- as.logical(signal_keep)
if(length(pixel_ids) != length(signal_keep) || anyNA(pixel_ids) ||
anyDuplicated(pixel_ids)) {
stop("Cluster Buster pixel identifiers and S/N mask do not align.",
call. = FALSE)
}
signal_keep[is.na(signal_keep)] <- FALSE
index <- match(pixel_ids, as.character(matches$object_id))
winner <- as.character(matches$library_id[index])
score <- as.numeric(matches$match_val[index])
background <- signal_keep & (is.na(winner) | winner == background_id)
correlation <- signal_keep & !background & isTRUE(correlation_enabled) &
(!is.finite(score) | score < as.numeric(minimum)[1L])
keep <- signal_keep & !background & !correlation
reason <- rep(NA_character_, length(pixel_ids))
reason[!signal_keep] <- "signal/noise"
reason[background] <- "background"
reason[correlation] <- "correlation"
data.table::data.table(
pixel_id = pixel_ids, signal_keep = signal_keep,
library_id = winner, match_val = score,
background_rejected = background,
correlation_rejected = correlation, keep = keep,
rejection_reason = reason
)
}
app_rejected_spectrum <- function(wavenumber) {
axis <- as.numeric(wavenumber)
spectra <- matrix(0, nrow = length(axis), ncol = 1L,
dimnames = list(NULL, "No retained particle"))
as_OpenSpecy(
axis, spectra = spectra,
metadata = data.frame(selection = "No retained particle")
)
}
app_standardize_material_class <- function(x) {
values <- as.character(x)
sub("^(ftir|raman|nir)[_-]+", "", values, ignore.case = TRUE)
}
app_pixel_calibration <- function(pixel_size = 1, pixel_unit = "pixel") {
size <- suppressWarnings(as.numeric(pixel_size))
if(length(size) != 1L || is.na(size) || !is.finite(size) || size <= 0) {
stop("Pixel edge length must be one positive finite number.", call. = FALSE)
}
unit <- trimws(as.character(pixel_unit)[1L])
if(is.na(unit) || !nzchar(unit)) unit <- "pixel"
suffix_unit <- gsub("[µμ]", "u", unit)
suffix <- tolower(gsub("[^A-Za-z0-9]+", "_", suffix_unit))
suffix <- gsub("^_+|_+$", "", suffix)
if(!nzchar(suffix)) suffix <- "pixel"
list(
size = size, unit = unit, length_suffix = suffix,
area_suffix = paste0(suffix, "2"),
volume_suffix = paste0(suffix, "3")
)
}
app_source_pixel_calibration <- function(source) {
calibration <- attr(source, "spatial_calibration", exact = TRUE)
candidates <- if(is.list(calibration) && !is.null(calibration$x_origin)) {
list(calibration)
} else if(is.list(calibration)) {
Filter(function(item) is.list(item) && !is.null(item$x_origin), calibration)
} else {
list()
}
if(length(candidates)) {
inferred <- lapply(candidates, function(item) {
steps <- abs(suppressWarnings(as.numeric(c(item$x_step, item$y_step))))
unit <- if(is.null(item$unit) || !length(item$unit)) "" else
trimws(as.character(item$unit)[[1L]])
known_unit <- !is.na(unit) && nzchar(unit) &&
!tolower(unit) %in% c("map unit", "map units", "unknown")
square <- length(steps) == 2L && all(is.finite(steps)) &&
all(steps > 0) && isTRUE(all.equal(
steps[[1L]], steps[[2L]], tolerance = 1e-8
))
if(!known_unit || !square) return(NULL)
list(size = mean(steps), unit = unit)
})
if(any(lengths(inferred) == 0L)) return(NULL)
sizes <- vapply(inferred, `[[`, numeric(1L), "size")
units <- vapply(inferred, `[[`, character(1L), "unit")
consistent_size <- all(vapply(
sizes,
function(value) isTRUE(all.equal(value, sizes[[1L]], tolerance = 1e-8)),
logical(1L)
))
consistent_unit <- length(unique(tolower(units))) == 1L
if(consistent_size && consistent_unit) {
return(app_pixel_calibration(sizes[[1L]], units[[1L]]))
}
return(NULL)
}
# Processed particle RDS files already contain physical x/y values, so their
# unit-bearing metadata contract uses a neutral scale of one on re-upload.
spatial_unit <- attr(source, "openspecy_spatial_unit", exact = TRUE)
if(isTruthy(spatial_unit)) app_pixel_calibration(1, spatial_unit) else NULL
}
app_coordinate_calibration <- function(calibration) {
if(!is.list(calibration) || is.null(calibration$x_origin)) return(NULL)
values <- suppressWarnings(as.numeric(c(
calibration$x_origin, calibration$y_origin,
calibration$x_step, calibration$y_step
)))
if(length(values) != 4L || any(!is.finite(values)) ||
any(values[3:4] == 0)) return(NULL)
unit <- if(isTruthy(calibration$unit)) {
trimws(as.character(calibration$unit)[[1L]])
} else "map unit"
list(
x_origin = values[[1L]], y_origin = values[[2L]],
x_step = values[[3L]], y_step = values[[4L]], unit = unit,
source = if(isTruthy(calibration$source)) {
as.character(calibration$source)[[1L]]
} else "source metadata"
)
}
app_source_coordinate_calibration <- function(source) {
app_coordinate_calibration(
attr(source, "spatial_calibration", exact = TRUE)
)
}
# Particle RDS downloads use unit-bearing metadata names (for example,
# x_pixel/y_pixel or x_um/y_um). Restore the canonical x/y aliases needed by
# the map pipeline when one of those downloads is uploaded again, while
# retaining every reported unit-bearing column unchanged.
app_restore_spatial_coordinates <- function(x) {
if(!is_OpenSpecy(x) || is.null(x$metadata)) return(x)
metadata <- data.table::copy(data.table::as.data.table(x$metadata))
if(all(c("x", "y") %in% names(metadata))) return(x)
coordinate_pair <- function(prefix = "") {
x_prefix <- paste0("^", prefix, "x_")
x_names <- grep(x_prefix, names(metadata), value = TRUE)
if(!length(x_names)) return(NULL)
suffixes <- sub(x_prefix, "", x_names)
y_names <- paste0(prefix, "y_", suffixes)
valid <- y_names %in% names(metadata)
if(!any(valid)) return(NULL)
first <- which(valid)[[1L]]
list(x = x_names[[first]], y = y_names[[first]], unit = suffixes[[first]])
}
pair <- coordinate_pair()
if(is.null(pair)) pair <- coordinate_pair("centroid_")
if(is.null(pair)) return(x)
x_values <- suppressWarnings(as.numeric(metadata[[pair$x]]))
y_values <- suppressWarnings(as.numeric(metadata[[pair$y]]))
if(length(x_values) != nrow(metadata) || length(y_values) != nrow(metadata) ||
!any(is.finite(x_values) & is.finite(y_values))) return(x)
metadata[, `:=`(x = x_values, y = y_values)]
x$metadata <- metadata
if(is.null(attr(x, "openspecy_spatial_unit", exact = TRUE))) {
attr(x, "openspecy_spatial_unit") <- pair$unit
}
x
}
app_calibrate_spatial_metadata <- function(metadata, pixel_size = 1,
pixel_unit = "pixel") {
calibration <- app_pixel_calibration(pixel_size, pixel_unit)
result <- data.table::copy(data.table::as.data.table(metadata))
for(column in intersect(c("x", "y"), names(result))) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size
}
attr(result, "openspecy_spatial_unit") <- calibration$unit
result
}
app_project_source_coordinates <- function(source, metadata,
pixel_size = 1,
pixel_unit = "pixel") {
result <- data.table::copy(data.table::as.data.table(metadata))
if(all(c("stage_x_nm", "stage_y_nm") %in% names(result))) {
stage_x <- suppressWarnings(as.numeric(result$stage_x_nm))
stage_y <- suppressWarnings(as.numeric(result$stage_y_nm))
if(length(stage_x) == nrow(result) && length(stage_y) == nrow(result) &&
all(is.finite(stage_x)) && all(is.finite(stage_y))) {
result[, `:=`(grid_x = x, grid_y = y, x = stage_x, y = stage_y)]
attr(result, "openspecy_spatial_unit") <- "nm"
return(list(metadata = result, unit = "nm", source = "H5 stage"))
}
}
calibration <- app_source_coordinate_calibration(source)
if(!is.null(calibration)) {
result[, `:=`(
grid_x = x, grid_y = y,
x = calibration$x_origin + as.numeric(x) * calibration$x_step,
y = calibration$y_origin + as.numeric(y) * calibration$y_step
)]
unit <- calibration$unit
attr(result, "openspecy_spatial_unit") <- unit
return(list(metadata = result, unit = unit,
source = calibration$source))
}
fallback <- app_calibrate_spatial_metadata(result, pixel_size, pixel_unit)
list(metadata = fallback, unit = attr(fallback, "openspecy_spatial_unit"),
source = "manual pixel calibration")
}
app_registered_visual <- function(source) {
if(is.null(source)) return(NULL)
visual <- if(inherits(source, "FileSpecs") &&
identical(source$source$backend, "h5")) {
tryCatch(OpenSpecy:::.filespec_materialize_visual(source),
error = function(e) NULL)
} else {
tryCatch(visual_image(source), error = function(e) NULL)
}
if(is.null(visual) || is.null(visual$image) ||
is.null(visual$bottom_left) || is.null(visual$top_right)) return(NULL)
image <- tryCatch(OpenSpecy:::.image_rgb_array(visual$image),
error = function(e) NULL)
if(is.null(image)) return(NULL)
rows <- range(round(c(visual$bottom_left[[2L]], visual$top_right[[2L]])))
cols <- range(round(c(visual$bottom_left[[1L]], visual$top_right[[1L]])))
rows <- pmin(pmax(rows, 1L), dim(image)[[1L]])
cols <- pmin(pmax(cols, 1L), dim(image)[[2L]])
if(rows[[1L]] > rows[[2L]] || cols[[1L]] > cols[[2L]]) return(NULL)
cropped <- image[seq.int(rows[[1L]], rows[[2L]]),
seq.int(cols[[1L]], cols[[2L]]), , drop = FALSE]
list(image = cropped, transform = visual$transform,
detection_method = visual$detection_method,
source = visual$source)
}
app_heatmap_cell_range <- function(values) {
values <- sort(unique(as.numeric(values[is.finite(values)])))
if(!length(values)) return(c(0, 1))
if(length(values) == 1L) return(values + c(-0.5, 0.5))
c(
values[[1L]] - (values[[2L]] - values[[1L]]) / 2,
values[[length(values)]] +
(values[[length(values)]] - values[[length(values) - 1L]]) / 2
)
}
app_visual_trace_geometry <- function(x, y, image) {
x_boundary <- app_heatmap_cell_range(x)
y_boundary <- app_heatmap_cell_range(y)
image_rows <- dim(image)[[1L]]
image_cols <- dim(image)[[2L]]
list(
# The detected red-frame pixels are the map boundary, rather than the
# centers of the first and last heatmap cells.
x0 = x_boundary[[1L]],
y0 = y_boundary[[2L]],
dx = diff(x_boundary) / max(image_cols - 1L, 1L),
dy = -diff(y_boundary) / max(image_rows - 1L, 1L),
x_boundary = x_boundary,
y_boundary = y_boundary
)
}
app_visual_layout_image <- function(x, y, image, opacity = 1) {
geometry <- app_visual_trace_geometry(x, y, image)
opacity <- suppressWarnings(as.numeric(opacity))
if(length(opacity) != 1L || !is.finite(opacity)) opacity <- 1
list(
source = plotly:::raster2uri(image),
xref = "x", yref = "y",
x = geometry$x_boundary[[1L]], y = geometry$y_boundary[[2L]],
sizex = diff(geometry$x_boundary), sizey = diff(geometry$y_boundary),
xanchor = "left", yanchor = "top", sizing = "stretch",
opacity = pmin(pmax(opacity, 0), 1), layer = "above"
)
}
app_selection_shape <- function(x, y, select) {
if(is.null(select) || length(select$x) != 1L || length(select$y) != 1L ||
!is.finite(select$x) || !is.finite(select$y)) return(NULL)
x_boundary <- app_heatmap_cell_range(x)
y_boundary <- app_heatmap_cell_range(y)
x_radius <- diff(x_boundary) / max(length(unique(x)), 1L) * 0.4
y_radius <- diff(y_boundary) / max(length(unique(y)), 1L) * 0.4
list(
type = "circle", xref = "x", yref = "y",
x0 = select$x - x_radius, x1 = select$x + x_radius,
y0 = select$y - y_radius, y1 = select$y + y_radius,
fillcolor = "#FFFFFF", opacity = 1,
line = list(color = "#FFFFFF", width = 2), layer = "above"
)
}
app_particle_metadata_units <- function(metadata, pixel_size = 1,
pixel_unit = "pixel",
coordinate_calibration = NULL) {
coordinate_calibration <- app_coordinate_calibration(
coordinate_calibration
)
report_unit <- if(is.null(coordinate_calibration)) {
pixel_unit
} else coordinate_calibration$unit
calibration <- app_pixel_calibration(pixel_size, report_unit)
result <- data.table::copy(data.table::as.data.table(metadata))
x_coordinates <- intersect(c("x", "centroid_x", "first_x", "rand_x"),
names(result))
y_coordinates <- intersect(c("y", "centroid_y", "first_y", "rand_y"),
names(result))
dimensions <- intersect(
c("perimeter", "rectangular_min", "feret_min", "feret_max"),
names(result)
)
coordinates <- c(x_coordinates, y_coordinates)
linear <- c(coordinates, dimensions)
area <- intersect(c("area", "convex_hull_area"), names(result))
if(is.null(coordinate_calibration)) {
for(column in coordinates) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size
}
} else {
for(column in x_coordinates) {
result[[column]] <- coordinate_calibration$x_origin +
as.numeric(result[[column]]) * coordinate_calibration$x_step
}
for(column in y_coordinates) {
result[[column]] <- coordinate_calibration$y_origin +
as.numeric(result[[column]]) * coordinate_calibration$y_step
}
}
for(column in dimensions) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size
}
for(column in area) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size^2
}
if("area" %in% names(result)) {
volume_name <- paste0("volume_", calibration$volume_suffix)
result[[volume_name]] <- sqrt(pmax(result$area, 0))^3
}
if(length(linear)) {
data.table::setnames(
result, linear, paste0(linear, "_", calibration$length_suffix)
)
}
if(length(area)) {
data.table::setnames(
result, area, paste0(area, "_", calibration$area_suffix)
)
}
app_round_reported_metadata(result)
}
app_round_reported_metadata <- function(metadata, digits = 3L) {
result <- data.table::copy(data.table::as.data.table(metadata))
measurement_stems <- c(
"perimeter", "rectangular_min", "feret_min", "feret_max",
"convex_hull_area", "volume"
)
measurement_pattern <- paste0("^(", paste(measurement_stems,
collapse = "|"), ")($|_)")
columns <- unique(c(
grep(measurement_pattern, names(result), value = TRUE),
intersect(c("match_val", "max_cor_val", "signal_to_noise"),
names(result))
))
for(column in columns) {
result[[column]] <- base::signif(as.numeric(result[[column]]), digits)
}
result
}
app_match_value_label <- function(model_library = FALSE) {
if(isTRUE(model_library)) "Probability" else "Correlation"
}
app_signal_metric_label <- function(metric) {
labels <- c(
run_sig_over_noise = "Signal Over Noise",
sig_times_noise = "Signal Times Noise",
log_tot_sig = "Total Signal"
)
metric <- as.character(metric)[1L]
if(is.na(metric) || !metric %in% names(labels)) return("Signal to Noise")
unname(labels[[metric]])
}
app_selection_metadata_display <- function(metadata, simple = TRUE,
particle = FALSE,
library = FALSE,
pixel_size = 1,
pixel_unit = "pixel",
coordinate_calibration = NULL,
match_label = "Correlation",
signal_label = "Signal to Noise") {
coordinate_calibration <- app_coordinate_calibration(
coordinate_calibration
)
report_unit <- if(is.null(coordinate_calibration)) {
pixel_unit
} else coordinate_calibration$unit
calibration <- app_pixel_calibration(pixel_size, report_unit)
result <- app_particle_metadata_units(
metadata, pixel_size, pixel_unit, coordinate_calibration
)
result <- app_round_reported_metadata(result)
if("material_class" %in% names(result)) {
result$material_class <- app_standardize_material_class(
result$material_class
)
}
if(!isTRUE(simple)) return(result)
if(!"match_val" %in% names(result) && "max_cor_val" %in% names(result)) {
result[, match_val := max_cor_val]
}
particle_columns <- if(isTRUE(particle)) c(
paste0("area_", calibration$area_suffix),
paste0("perimeter_", calibration$length_suffix),
paste0("rectangular_min_", calibration$length_suffix),
paste0("feret_min_", calibration$length_suffix),
paste0("feret_max_", calibration$length_suffix),
paste0("convex_hull_area_", calibration$area_suffix),
paste0("volume_", calibration$volume_suffix),
paste0("first_x_", calibration$length_suffix),
paste0("first_y_", calibration$length_suffix)
) else character()
coordinate_columns <- paste0(c("x", "y"), "_", calibration$length_suffix)
coordinate_columns <- intersect(coordinate_columns, names(result))
keep <- intersect(
c("material_class", "match_val",
if(isTRUE(library)) c("spectrum_identity", "organization") else NULL,
"signal_to_noise", particle_columns, "file_name", "col_id",
coordinate_columns),
names(result)
)
result <- result[, keep, with = FALSE]
friendly <- c(
material_class = "Material Class",
match_val = match_label,
spectrum_identity = "Spectrum Identity",
organization = "Organization",
signal_to_noise = signal_label,
file_name = "File Name",
col_id = "Column ID"
)
coordinate_friendly <- ifelse(
startsWith(coordinate_columns, "x_"), "X", "Y"
)
names(coordinate_friendly) <- coordinate_columns
particle_friendly <- c(
paste0("Area (", calibration$unit, "^2)"),
paste0("Perimeter (", calibration$unit, ")"),
paste0("Rectangular Minimum (", calibration$unit, ")"),
paste0("Feret Minimum (", calibration$unit, ")"),
paste0("Feret Maximum (", calibration$unit, ")"),
paste0("Convex Hull Area (", calibration$unit, "^2)"),
paste0("Estimated Volume (", calibration$unit, "^3)"),
paste0("First X (", calibration$unit, ")"),
paste0("First Y (", calibration$unit, ")")
)
names(particle_friendly) <- particle_columns
labels <- c(friendly, particle_friendly, coordinate_friendly)
data.table::setnames(result, keep, unname(labels[keep]))
result
}
app_particle_metadata_fields <- c(
"x", "y", "z", "centroid_x", "centroid_y", "first_x", "first_y",
"area", "perimeter", "rectangular_min", "feret_min", "feret_max",
"convex_hull_area",
"volume", "pixel_index", "region_id", "cluster_id", "unit_id",
"unit_index"
)
app_without_particle_metadata <- function(metadata) {
result <- data.table::copy(data.table::as.data.table(metadata))
drop <- intersect(app_particle_metadata_fields, names(result))
if(length(drop)) result[, (drop) := NULL]
result
}
app_particle_summary_table <- function(object, pixel_size = 1,
pixel_unit = "pixel",
material = NULL) {
calibration <- app_pixel_calibration(pixel_size, pixel_unit)
md <- app_particle_metadata_units(
object$metadata, pixel_size = pixel_size, pixel_unit = pixel_unit
)
if(!nrow(md)) return(data.table::data.table(
material_class = character(), particle_count = integer(),
total_particle_count = integer(), percentage = numeric(),
confidence_level = numeric(), percentage_uncertainty = numeric(),
percentage_ci_lower = numeric(), percentage_ci_upper = numeric(),
total_concentration_rsd = numeric()
))
material <- if(!is.null(material)) {
if(length(material) != nrow(md)) {
stop("Particle summary material classes do not align with particles.",
call. = FALSE)
}
app_standardize_material_class(material)
} else if("material_class" %in% names(md)) {
app_standardize_material_class(md$material_class)
} else rep("unidentified", nrow(md))
material[is.na(material) | !nzchar(material)] <- "unknown"
area_column <- paste0("area_", calibration$area_suffix)
area <- if(area_column %in% names(md)) {
as.numeric(md[[area_column]])
} else rep(1, nrow(md))
result <- data.table::data.table(material_class = material, area = area)[, .(
particle_count = .N,
total_area = sum(area, na.rm = TRUE),
mean_area = mean(area, na.rm = TRUE),
median_area = stats::median(area, na.rm = TRUE)
), by = material_class][order(-particle_count, material_class)]
total_count <- sum(result$particle_count)
percentage <- 100 * result$particle_count / total_count
uncertainty <- material_percentage_uncertainty(total_count, percentage)
result <- cbind(result, data.table::data.table(
total_particle_count = rep(as.integer(total_count), nrow(result)),
percentage = percentage,
confidence_level = rep(0.95, nrow(result)),
percentage_uncertainty = uncertainty,
percentage_ci_lower = pmax(0, percentage - uncertainty),
percentage_ci_upper = pmin(100, percentage + uncertainty),
total_concentration_rsd = rep(total_count^(-1 / 2), nrow(result))
))
data.table::setnames(
result, c("total_area", "mean_area", "median_area"),
paste0(c("total_area_", "mean_area_", "median_area_"),
calibration$area_suffix)
)
result
}
app_particle_size_plot <- function(object, pixel_size = 1,
pixel_unit = "pixel") {
data <- app_particle_size_data(object, pixel_size, pixel_unit)
ggplot2::ggplot(data) +
ggplot2::geom_rect(
ggplot2::aes(
xmin = bin_min, xmax = bin_max, ymin = 0, ymax = count
),
fill = app_plot_palette$primary, color = app_plot_palette$panel
) +
theme_black_minimal(base_size = 15) +
ggplot2::labs(
x = paste0("Nominal Particle Size (", attr(data, "unit"), ")"),
y = "Count"
)
}
app_particle_size_data <- function(object, pixel_size = 1,
pixel_unit = "pixel", bins = 30L) {
calibration <- app_pixel_calibration(pixel_size, pixel_unit)
md <- app_particle_metadata_units(
object$metadata, pixel_size = pixel_size, pixel_unit = pixel_unit
)
area_column <- paste0("area_", calibration$area_suffix)
area <- if(area_column %in% names(md)) as.numeric(md[[area_column]]) else
numeric()
size <- sqrt(area[is.finite(area) & area >= 0])
if(!length(size)) {
result <- data.frame(
bin_min = numeric(), bin_max = numeric(), bin_mid = numeric(),
count = integer()
)
} else if(length(size) == 1L) {
half_width <- if(size[[1L]] == 0) 0.5 else
max(abs(size[[1L]]) * 0.05, sqrt(.Machine$double.eps))
result <- data.frame(
bin_min = size[[1L]] - half_width,
bin_max = size[[1L]] + half_width,
bin_mid = size[[1L]], count = 1L
)
} else {
histogram <- graphics::hist(size, breaks = bins, plot = FALSE,
include.lowest = TRUE, right = TRUE)
result <- data.frame(
bin_min = utils::head(histogram$breaks, -1L),
bin_max = utils::tail(histogram$breaks, -1L),
bin_mid = histogram$mids,
count = as.integer(histogram$counts)
)
}
attr(result, "unit") <- calibration$unit
result
}
app_particle_size_plotly <- function(object, pixel_size = 1,
pixel_unit = "pixel") {
data <- app_particle_size_data(object, pixel_size, pixel_unit)
unit <- attr(data, "unit")
xaxis <- list(title = paste0("Nominal Particle Size (", unit, ")"))
if(nrow(data) == 1L && data$count[[1L]] == 1L) {
padding <- (data$bin_max[[1L]] - data$bin_min[[1L]]) / 2
xaxis$range <- c(data$bin_min[[1L]] - padding,
data$bin_max[[1L]] + padding)
}
plotly::plot_ly(
data,
x = ~bin_mid,
y = ~count,
width = as.numeric(data$bin_max - data$bin_min),
type = "bar",
marker = list(
color = app_plot_palette$primary,
line = list(color = app_plot_palette$panel, width = 1)
),
customdata = ~cbind(bin_min, bin_max),
hovertemplate = paste0(
"Bin: %{customdata[0]:.4g} to %{customdata[1]:.4g} ", unit,
"<br>Count: %{y}<extra></extra>"
)
) |>
plotly::layout(
xaxis = xaxis,
yaxis = list(title = "Count", rangemode = "tozero"),
paper_bgcolor = app_theme$panel,
plot_bgcolor = app_theme$panel,
font = list(color = app_theme$text),
showlegend = FALSE
) |>
plotly::config(displaylogo = FALSE)
}
app_material_summary_data <- function(material, confidence = 0.95) {
values <- app_standardize_material_class(material)
values[is.na(values) | !nzchar(values)] <- "unknown"
counts <- sort(table(values), decreasing = FALSE)
total_count <- sum(counts)
percentage <- 100 * as.numeric(counts) / total_count
uncertainty <- material_percentage_uncertainty(
total_count, percentage, confidence
)
class_data <- data.frame(
material_class = names(counts), count = as.numeric(counts),
percentage = percentage, confidence_level = confidence,
percentage_uncertainty = uncertainty,
percentage_ci_lower = pmax(0, percentage - uncertainty),
percentage_ci_upper = pmin(100, percentage + uncertainty),
total_concentration_rsd = total_count^(-1 / 2),
uncertainty_type = "Material percentage CI",
stringsAsFactors = FALSE
)
class_data$count_uncertainty <-
total_count * class_data$percentage_uncertainty / 100
all_data <- data.frame(
material_class = "All Materials", count = total_count, percentage = 100,
confidence_level = confidence, percentage_uncertainty = NA_real_,
percentage_ci_lower = NA_real_, percentage_ci_upper = NA_real_,
total_concentration_rsd = total_count^(-1 / 2),
uncertainty_type = "Total concentration RSD",
count_uncertainty = sqrt(total_count), stringsAsFactors = FALSE
)
result <- rbind(class_data, all_data)
result$count_lower <- pmax(0, result$count - result$count_uncertainty)
result$count_upper <- result$count + result$count_uncertainty
result
}
app_material_summary_plot <- function(material, palette = NULL) {
data <- app_material_summary_data(material)
values <- data$material_class
if(is.null(palette)) palette <- app_category_palette(values)
missing_levels <- setdiff(unique(values), names(palette))
if(length(missing_levels)) {
palette <- c(palette, app_category_palette(missing_levels))
}
data$material_class <- factor(data$material_class, levels = values)
ggplot2::ggplot(data, ggplot2::aes(y = material_class, x = count,
fill = material_class)) +
ggplot2::geom_col() +
ggplot2::geom_segment(
ggplot2::aes(x = count_lower, xend = count_upper,
y = material_class, yend = material_class),
inherit.aes = FALSE, color = app_theme$text, linewidth = 0.8
) +
ggplot2::scale_fill_manual(
values = palette, na.value = app_theme$muted, drop = FALSE
) +
theme_black_minimal(base_size = 15) +
ggplot2::theme(legend.position = "none") +
ggplot2::labs(x = "Count", y = "Material Class")
}
app_material_summary_plotly <- function(material, palette = NULL) {
data <- app_material_summary_data(material)
if(is.null(palette)) palette <- app_category_palette(data$material_class)
missing_levels <- setdiff(unique(data$material_class), names(palette))
if(length(missing_levels)) {
palette <- c(palette, app_category_palette(missing_levels))
}
colors <- unname(palette[data$material_class])
material_hover <- paste0(
"Material: ", data$material_class,
"<br>Count: ", format(data$count, trim = TRUE),
"<br>Percentage: ", format(signif(data$percentage, 4), trim = TRUE), "%",
ifelse(
is.finite(data$percentage_uncertainty),
paste0(
"<br>", format(100 * data$confidence_level, trim = TRUE),
"% CI: ", format(signif(data$percentage_ci_lower, 4), trim = TRUE),
"% to ", format(signif(data$percentage_ci_upper, 4), trim = TRUE), "%",
"<br>Half-width: ",
format(signif(data$percentage_uncertainty, 4), trim = TRUE),
" percentage points"
),
""
),
"<br>Total concentration RSD: ",
format(signif(data$total_concentration_rsd, 4), trim = TRUE),
"<br>Uncertainty shown: ", data$uncertainty_type
)
plotly::plot_ly(
data,
x = ~count,
y = ~factor(material_class, levels = material_class),
type = "bar", orientation = "h",
marker = list(color = colors),
error_x = list(
type = "data", array = data$count_uncertainty,
symmetric = TRUE, visible = TRUE, color = app_theme$text
),
text = material_hover,
textposition = "none",
hovertemplate = "%{text}<extra></extra>"
) |>
plotly::layout(
xaxis = list(title = "Count", rangemode = "tozero"),
yaxis = list(title = "Material Class"),
paper_bgcolor = app_theme$panel,
plot_bgcolor = app_theme$panel,
font = list(color = app_theme$text), showlegend = FALSE
) |>
plotly::config(displaylogo = FALSE)
}
app_histogram_ggplot <- function(values, thresholds = numeric(), xlab) {
frame <- data.frame(value = as.numeric(values))
frame <- frame[is.finite(frame$value), , drop = FALSE]
plot <- ggplot2::ggplot(frame, ggplot2::aes(x = value)) +
ggplot2::geom_histogram(
bins = 30L, fill = app_plot_palette$primary,
color = app_plot_palette$panel
) +
theme_black_minimal(base_size = 15) +
ggplot2::labs(x = xlab, y = "Count")
if(nrow(frame)) {
data_range <- range(frame$value)
plot <- plot +
ggplot2::scale_x_continuous(expand = c(0, 0)) +
ggplot2::coord_cartesian(xlim = data_range)
for(value in thresholds[is.finite(thresholds)]) {
clamped <- min(max(value, data_range[1L]), data_range[2L])
plot <- plot + ggplot2::geom_vline(
xintercept = clamped, color = app_theme$reference,
linewidth = 0.8, linetype = "dashed"
)
}
}
plot
}
app_heatmap_ggplot <- function(data) {
grid <- expand.grid(x = data$x, y = data$y)
grid$value <- as.vector(data$z)
rejected <- if(is.null(data$rejected)) rep(FALSE, nrow(grid)) else
!is.na(as.vector(data$rejected))
grid$rejected <- rejected
categorical <- identical(data$type, "heatmap_categorical") ||
identical(data$type, "heatmap_binary")
if(categorical) {
levels <- if(identical(data$type, "heatmap_binary")) data$labels else
data$levels
grid$value <- factor(levels[as.integer(grid$value)], levels = levels)
palette <- if(!is.null(data$palette)) data$palette[levels] else
app_category_palette(levels)
plot <- ggplot2::ggplot(grid, ggplot2::aes(x = x, y = y, fill = value)) +
ggplot2::geom_tile() +
ggplot2::scale_fill_manual(values = palette, na.value = app_theme$panel_2,
drop = FALSE)
} else {
plot <- ggplot2::ggplot(grid, ggplot2::aes(x = x, y = y, fill = value)) +
ggplot2::geom_tile() +
ggplot2::scale_fill_gradientn(
colours = vapply(app_heatmap_colorscale, `[[`, "", 2L),
na.value = app_theme$panel_2
)
}
if(any(rejected)) {
plot <- plot + ggplot2::geom_tile(
data = grid[rejected, , drop = FALSE], fill = "black"
)
}
axis_unit <- if(isTruthy(data$axis_unit)) data$axis_unit else "pixel"
plot <- plot + ggplot2::coord_equal() + theme_black_minimal(base_size = 13) +
ggplot2::labs(
x = paste0("X (", axis_unit, ")"),
y = paste0("Y (", axis_unit, ")"), fill = data$legend_title
)
# Particle Unit and Match ID are per-particle identifiers -- essentially
# as many categories as there are particles -- so a legend is never
# useful for them, unlike Material Class's small fixed vocabulary.
if(identical(data$legend_title, "Particle Unit") ||
identical(data$legend_title, "Match ID")) {
plot <- plot + ggplot2::theme(legend.position = "none")
}
plot
}
app_ggplot_legend_grob <- function(plot) {
built <- ggplot2::ggplotGrob(plot)
positions <- which(grepl("^guide-box", built$layout$name))
if(!length(positions)) return(NULL)
for(position in positions) {
candidate <- built$grobs[[position]]
if(inherits(candidate, "gtable") && length(candidate$grobs)) {
return(candidate)
}
}
NULL
}
app_heatmap_export_components <- function(data) {
plot <- app_heatmap_ggplot(data)
list(
heatmap = plot + ggplot2::theme(legend.position = "none"),
legend = app_ggplot_legend_grob(plot)
)
}
app_write_ggplot_png <- function(plot, path, width = 8, height = 6) {
ggplot2::ggsave(
filename = path, plot = plot, width = width, height = height,
units = "in", dpi = 150, bg = app_plot_palette$panel
)
invisible(path)
}
app_write_grob_png <- function(grob, path, width = 4, height = 5) {
grDevices::png(
filename = path, width = width, height = height, units = "in",
res = 150, bg = app_plot_palette$panel
)
on.exit(grDevices::dev.off(), add = TRUE)
grid::grid.newpage()
grid::grid.draw(grob)
invisible(path)
}
app_uploaded_metadata_cache <- function(x, signal_to_noise) {
compact <- is_Specs(x)
spectrum_ids <- if(compact) {
as.character(specs_coordinates(x)$source_id)
} else colnames(x$spectra)
metadata <- if(compact) {
data.table::copy(data.table::as.data.table(specs_metadata(x)))
} else data.table::copy(data.table::as.data.table(x$metadata))
if(compact && !"col_id" %in% names(metadata)) {
metadata[, col_id := spectrum_ids]
}
if(is.null(spectrum_ids) || anyNA(spectrum_ids) || anyDuplicated(spectrum_ids) ||
!"col_id" %in% names(metadata)) {
stop("Uploaded spectra and metadata require unique identifiers.",
call. = FALSE)
}
metadata_ids <- as.character(metadata$col_id)
spectrum_index <- match(metadata_ids, spectrum_ids)
if(nrow(metadata) != length(spectrum_ids) || anyNA(metadata_ids) ||
anyDuplicated(metadata_ids) || anyNA(spectrum_index) ||
length(signal_to_noise) != length(spectrum_ids)) {
stop("Uploaded metadata does not align with the processed spectra.",
call. = FALSE)
}
metadata$signal_to_noise <- signal_to_noise[spectrum_index]
metadata <- metadata[
, !vapply(metadata, OpenSpecy::is_empty_vector, logical(1)), with = FALSE
]
metadata$.openspecy_index <- as.integer(spectrum_index)
metadata$.openspecy_coord_key <- if(all(c("x", "y") %in% names(metadata))) {
paste(metadata$x, metadata$y)
} else {
rep.int(NA_character_, nrow(metadata))
}
data.table::setcolorder(
metadata,
c(".openspecy_index", ".openspecy_coord_key",
setdiff(names(metadata), c(".openspecy_index", ".openspecy_coord_key")))
)
metadata
}
# Metadata columns worth surfacing as a per-pixel "z variable": present, and
# not constant across every row. Excludes duplicated file/instrument-level
# metadata (file_name, organization, fixed acquisition settings, etc.) that
# repeats identically for every pixel and adds no spatial signal.
app_metadata_variable_columns <- function(metadata, exclude = character()) {
candidates <- setdiff(names(metadata), exclude)
keep <- vapply(candidates, function(col) {
values <- metadata[[col]]
length(unique(values[!is.na(values)])) > 1L
}, logical(1))
candidates[keep]
}
# Large sources get x/y/z/col_id plus any other per-pixel "z variable" only
# -- the columns a heatmap could be colored by -- dropping duplicated
# file-level metadata that would otherwise repeat unchanged across a huge
# number of rows. Smaller sources keep every column but move the same set to
# the front, so both cases surface what's spatially informative first.
app_uploaded_metadata_large_threshold <- 100000L
app_uploaded_metadata_display <- function(metadata, large = NULL) {
display <- metadata[
, !names(metadata) %in% c(".openspecy_index", ".openspecy_coord_key"),
with = FALSE
]
display <- app_round_reported_metadata(display)
if(is.null(large)) {
large <- nrow(display) > app_uploaded_metadata_large_threshold
}
front <- intersect(c("x", "y", "z", "col_id"), names(display))
front <- c(front, app_metadata_variable_columns(display, exclude = front))
if(isTRUE(large)) {
return(display[, front, with = FALSE])
}
data.table::setcolorder(display, c(front, setdiff(names(display), front)))
display
}
app_uploaded_metadata_spectrum <- function(metadata, rows_selected) {
row <- suppressWarnings(as.integer(rows_selected))
row <- row[
!is.na(row) & row >= 1L & row <= nrow(metadata)
]
if(length(row) != 1L) return(integer())
as.integer(metadata$.openspecy_index[[row]])
}
app_uploaded_metadata_row <- function(metadata, spectrum_index) {
spectrum_index <- suppressWarnings(as.integer(spectrum_index))
if(length(spectrum_index) != 1L || is.na(spectrum_index)) return(integer())
row <- match(spectrum_index, metadata$.openspecy_index)
if(is.na(row)) integer() else as.integer(row)
}
app_uploaded_metadata_table <- function(metadata, selected = integer(),
simple = TRUE, particle = FALSE,
pixel_size = 1,
pixel_unit = "pixel",
match_label = "Correlation",
signal_label = "Signal to Noise") {
large <- !isTRUE(simple) &&
nrow(metadata) > app_uploaded_metadata_large_threshold
caption <- if(isTRUE(simple)) {
"Uploaded Metadata"
} else if(isTRUE(large)) {
paste0(
"Uploaded Metadata (", format(nrow(metadata), big.mark = ","),
" spectra: showing only x/y/z and other per-pixel columns that vary",
" across spectra; unchanging file-level columns are hidden)"
)
} else {
"Uploaded Metadata"
}
display <- if(isTRUE(simple)) {
app_selection_metadata_display(
metadata, simple = TRUE, particle = particle,
pixel_size = pixel_size, pixel_unit = pixel_unit,
match_label = match_label, signal_label = signal_label
)
} else {
app_uploaded_metadata_display(metadata, large = large)
}
DT::datatable(
display,
escape = TRUE,
options = list(
scrollX = TRUE,
sDom = '<"top">lrt<"bottom">ip',
lengthChange = FALSE,
pageLength = 5
),
rownames = FALSE,
filter = "top",
caption = caption,
style = "bootstrap",
selection = list(mode = "single", selected = selected)
)
}
app_selected_metadata <- function(x, selected_match, signal_to_noise) {
# Downloaded/matched output keeps every column regardless of source size --
# the large-source reduction in app_uploaded_metadata_display() is a
# display-only convenience for the Uploaded Metadata tab.
metadata <- app_uploaded_metadata_display(
app_uploaded_metadata_cache(x, signal_to_noise), large = FALSE
)
selected_match <- data.table::copy(
data.table::as.data.table(selected_match)
)
if("material_class" %in% names(metadata) &&
"material_class" %in% names(selected_match)) {
metadata[, material_class := NULL]
}
result <- metadata[selected_match, on = c(col_id = "object_id")]
result <- result[
, !vapply(result, OpenSpecy::is_empty_vector, logical(1)), with = FALSE
] %>%
dplyr::select(
dplyr::any_of(c(
"file_name", "col_id", "material_class", "spectrum_identity",
"match_val", "signal_to_noise"
)),
dplyr::everything()
)
result
}
app_matches_for_object <- function(matches, object_id) {
matches <- data.table::as.data.table(matches)
object_id <- as.character(object_id)
if(!"object_id" %in% names(matches) || length(object_id) != 1L ||
is.na(object_id)) {
stop("A single valid spectrum identifier is required.", call. = FALSE)
}
selected_rows <- which(as.character(matches[["object_id"]]) == object_id)
data.table::copy(matches[selected_rows])
}
app_map_color_choices <- function(identification_active, model_library,
collapse, availability = NULL,
signal_label = "Signal/Noise") {
choices <- c(
if(isTRUE(identification_active)) "Material Class" else NA_character_,
if(isTRUE(identification_active) && !isTRUE(model_library))
"Match ID" else NA_character_,
if(isTRUE(identification_active)) "Match Value" else NA_character_,
"Signal/Noise",
if(isTRUE(collapse)) "Particle Unit" else NA_character_
)
choices <- choices[!is.na(choices)]
if(!is.null(availability)) {
available <- as.logical(availability[choices])
available[is.na(available)] <- FALSE
choices <- choices[available]
}
labels <- choices
signal_label <- as.character(signal_label)[1L]
if(is.na(signal_label) || !nzchar(trimws(signal_label))) {
signal_label <- "Signal/Noise"
}
labels[choices == "Signal/Noise"] <- signal_label
stats::setNames(choices, labels)
}
# The Top Matches table shows the ranked candidate list for the SELECTED
# spectrum in real-library mode (matches_to_single_result already scoped to
# one spectrum), but AI mode's matches_to_single_result has one prediction
# row per spectrum in the whole dataset instead of ranked candidates, so it
# must be indexed down to the selection first. any_of() drops columns AI
# mode's narrower match_val/material_class shape doesn't have, instead of
# erroring on a literal select() of library-metadata columns that don't
# exist there.
app_top_matches_table <- function(matches_to_single_result, model_library,
selected_index, simple = TRUE,
match_label = app_match_value_label(
model_library
)) {
matches_to_single_result <- data.table::as.data.table(matches_to_single_result)
result <- if(isTRUE(model_library)) {
rows <- if("spectrum_index" %in% names(matches_to_single_result)) {
matches_to_single_result[spectrum_index == selected_index]
} else {
matches_to_single_result[selected_index, ]
}
if("prediction_rank" %in% names(rows)) {
data.table::setorder(rows, prediction_rank)
}
rows %>%
dplyr::select(dplyr::any_of(c(
"prediction_rank", "match_val", "material_class", "spectrum_identity",
"organization", "sample_name"
)))
} else {
matches_to_single_result %>%
dplyr::select("match_val", "material_class", "spectrum_identity",
"organization", "sample_name")
}
result <- data.table::as.data.table(result)
result <- app_round_reported_metadata(result)
if(!isTRUE(simple)) return(result)
result <- app_selection_metadata_display(
result, simple = TRUE, library = TRUE, match_label = match_label
)
columns <- intersect(
c(match_label, "Material Class", "Spectrum Identity", "Organization"),
names(result)
)
result[, columns, with = FALSE]
}
# Resolve the explanatory logistic model from the same compact prediction rows
# that feed Top Matches. Predictions may contain several spectra and several
# type-specific models, so both axes must be selected before interpreting the
# table row number.
app_selected_model_explanation <- function(predictions, library,
selected_index,
selected_row = 1L) {
empty <- list(model = NULL, model_class = NULL)
predictions <- data.table::as.data.table(predictions)
selected_index <- suppressWarnings(as.integer(selected_index)[1L])
if(!nrow(predictions) || is.na(selected_index) || selected_index < 1L) {
return(empty)
}
rows <- if("spectrum_index" %in% names(predictions)) {
predictions[spectrum_index == selected_index]
} else if("x" %in% names(predictions)) {
predictions[x == selected_index]
} else if(selected_index <= nrow(predictions)) {
predictions[selected_index]
} else {
predictions[0L]
}
if(!nrow(rows)) return(empty)
if("prediction_rank" %in% names(rows)) {
data.table::setorder(rows, prediction_rank)
} else if("rank" %in% names(rows)) {
data.table::setorder(rows, rank)
}
selected_row <- suppressWarnings(as.integer(selected_row)[1L])
if(is.na(selected_row) || selected_row < 1L) selected_row <- 1L
selected <- rows[min(selected_row, nrow(rows))]
model <- library
if(inherits(model, "openspecy_typed_models")) {
type_column <- intersect(c("spectrum_type", "type"), names(selected))
if(!length(type_column)) return(empty)
type <- as.character(selected[[type_column[[1L]]]][[1L]])
if(!isTruthy(type) || is.null(model[[type]])) return(empty)
model <- model[[type]]
}
model_type <- if(is.null(model$model_type)) {
"logistic_regression"
} else {
as.character(model$model_type)[1L]
}
class_column <- intersect(
c(".model_class_key", "model_class", "material_class", "name"),
names(selected)
)
if(!identical(model_type, "logistic_regression") || !length(class_column)) {
return(empty)
}
model_class <- as.character(selected[[class_column[[1L]]]][[1L]])
if(is.na(model_class) || !nzchar(model_class)) return(empty)
list(model = model, model_class = model_class)
}
# Project a one-pass pixel Top-N result onto collapsed units without averaging
# incomplete reference coverage into a synthetic correlation. Each retained
# value remains an actual member-pixel correlation and carries its provenance.
app_aggregate_unit_matches <- function(matches, mapping, unit_ids, library_ids,
top_n = 10L, library_groups = NULL) {
matches <- data.table::copy(data.table::as.data.table(matches))
mapping <- data.table::copy(data.table::as.data.table(mapping))
if(!all(c("object_id", "library_id", "match_val") %in% names(matches)) ||
!all(c("pixel_id", "unit_id", "pixel_index", "kept") %in%
names(mapping))) {
stop("Unit-match projection received incomplete matches or mapping.",
call. = FALSE)
}
unit_ids <- as.character(unit_ids)
library_ids <- as.character(library_ids)
if(anyDuplicated(unit_ids) || anyDuplicated(library_ids)) {
stop("Unit and library identifiers must be unique.", call. = FALSE)
}
top_n <- suppressWarnings(as.integer(top_n))
if(length(top_n) != 1L || is.na(top_n) || top_n < 1L) top_n <- 1L
top_n <- min(top_n, length(library_ids))
if(!is.null(library_groups)) {
library_groups <- trimws(as.character(library_groups))
if(length(library_groups) != length(library_ids) || anyNA(library_groups) ||
any(!nzchar(library_groups))) {
stop("Library groups must align with every library identifier.",
call. = FALSE)
}
}
membership <- mapping[
kept & !is.na(unit_id),
.(object_id = pixel_id, unit_id, pixel_index)
]
joined <- merge(
matches, membership, by = "object_id", all = FALSE, sort = FALSE,
allow.cartesian = TRUE
)
if(!nrow(joined)) {
return(data.table::data.table(
object_id = character(), library_id = character(), match_val = numeric(),
source_pixel_id = character()
))
}
joined[, `:=`(
source_pixel_id = object_id,
library_order = match(library_id, library_ids),
unit_order = match(unit_id, unit_ids)
)]
joined[, library_group := if(is.null(library_groups)) {
"__all__"
} else library_groups[library_order]]
if(anyNA(joined$library_order) || anyNA(joined$unit_order)) {
stop("Unit-match projection identifiers do not align.", call. = FALSE)
}
data.table::setorder(
joined, unit_order, -match_val, library_order, pixel_index, na.last = TRUE
)
ranked <- joined[, .SD[1L], by = .(unit_id, library_id)]
data.table::setorder(
ranked, unit_order, -match_val, library_order, pixel_index,
na.last = TRUE
)
ranked[, .rank := seq_len(.N), by = .(unit_id, library_group)]
ranked <- ranked[.rank <= top_n]
ranked[, .(
object_id = unit_id, library_id, match_val, source_pixel_id
)]
}
# Join and format the already-ranked blockwise result used by every app
# identification consumer. No correlation matrix is reconstructed here.
app_top_matches_export_compact <- function(
matches, library_metadata, spectrum_metadata, signal_to_noise,
match_threshold, signal_threshold = c(-Inf, Inf), top_n = 1L,
top_n_by = NULL, simple = TRUE, quant_columns = character(),
match_label = "Correlation", signal_label = "Signal to Noise") {
matches <- data.table::copy(data.table::as.data.table(matches))
required_matches <- c("object_id", "library_id", "match_val")
if(!all(required_matches %in% names(matches)) || !nrow(matches)) {
stop("Top Matches requires a nonempty ranked match table.", call. = FALSE)
}
library_metadata <- data.table::as.data.table(library_metadata)
spectrum_metadata <- data.table::as.data.table(spectrum_metadata)
if(!all(c("sample_name", "material_class") %in%
names(library_metadata))) {
stop("Reference metadata is missing Top Matches identifiers.",
call. = FALSE)
}
if(!all(c("file_name", "col_id") %in% names(spectrum_metadata))) {
stop("Uploaded metadata is missing Top Matches identifiers.",
call. = FALSE)
}
library_ids <- as.character(library_metadata$sample_name)
spectrum_ids <- as.character(spectrum_metadata$col_id)
if(anyDuplicated(library_ids) || anyDuplicated(spectrum_ids)) {
stop("Top Matches identifiers must be unique.", call. = FALSE)
}
if(any(!matches$library_id %in% library_ids) ||
any(!matches$object_id %in% spectrum_ids)) {
stop("Top Matches metadata does not align with the ranked matches.",
call. = FALSE)
}
top_n <- suppressWarnings(as.integer(top_n))
if(length(top_n) != 1L || is.na(top_n) || top_n < 1L) top_n <- 1L
top_n <- min(top_n, length(library_ids))
if(!is.null(top_n_by)) {
if(!is.character(top_n_by) || length(top_n_by) != 1L ||
!top_n_by %in% names(library_metadata)) {
stop("Top Matches grouping column is missing from reference metadata.",
call. = FALSE)
}
groups <- trimws(as.character(library_metadata[[top_n_by]]))
if(anyNA(groups) || any(!nzchar(groups))) {
stop("Top Matches grouping values must be nonblank.", call. = FALSE)
}
matches[, .match_group := groups[match(library_id, library_ids)]]
} else {
matches[, .match_group := "__all__"]
}
matches[, .rank := seq_len(.N), by = .(object_id, .match_group)]
matches <- matches[.rank <= top_n]
matches[, c(".rank", ".match_group") := NULL]
thresholds <- suppressWarnings(as.numeric(signal_threshold))
thresholds <- thresholds[!is.na(thresholds)]
signal_min <- if(length(thresholds)) thresholds[[1L]] else -Inf
signal_max <- if(length(thresholds) > 1L) thresholds[[2L]] else Inf
if(length(signal_to_noise) != length(spectrum_ids)) {
stop("Signal-to-noise values do not align with uploaded spectra.",
call. = FALSE)
}
if(!is.null(names(signal_to_noise)) &&
all(spectrum_ids %in% names(signal_to_noise))) {
signal_to_noise <- signal_to_noise[spectrum_ids]
}
spectrum_details <- data.table::data.table(
col_id = spectrum_ids,
match_threshold = match_threshold,
signal_to_noise = as.numeric(signal_to_noise),
signal_threshold_min = signal_min,
signal_threshold_max = signal_max,
good_signal = is.finite(as.numeric(signal_to_noise)) &
as.numeric(signal_to_noise) > signal_min &
as.numeric(signal_to_noise) < signal_max
)
spectrum_details <- spectrum_details[spectrum_metadata, on = "col_id"]
library_for_join <- data.table::copy(library_metadata)[
, !names(library_metadata) %in% c("col_id", "file_name"), with = FALSE
]
data.table::setnames(
library_for_join, "material_class", ".reference_material_class"
)
if("spectrum_identity" %in% names(library_for_join)) {
data.table::setnames(
library_for_join, "spectrum_identity", ".reference_spectrum_identity"
)
} else {
library_for_join[, .reference_spectrum_identity := NA_character_]
}
result <- matches %>%
dplyr::left_join(library_for_join,
by = c("library_id" = "sample_name")) %>%
dplyr::left_join(spectrum_details,
by = c("object_id" = "col_id")) %>%
dplyr::rename(sample_name = library_id, col_id = object_id) %>%
dplyr::mutate(
good_match_vals = is.finite(match_val) & match_val >= match_threshold,
good_matches = good_match_vals & good_signal,
material_class = ifelse(
good_match_vals & !is.na(.reference_material_class) &
nzchar(.reference_material_class),
.reference_material_class, "unknown"
),
spectrum_identity = .reference_spectrum_identity
) %>%
dplyr::select(-dplyr::starts_with(".reference_")) %>%
data.table::as.data.table()
keep <- !vapply(result, OpenSpecy::is_empty_vector, logical(1)) |
names(result) %in% quant_columns
result <- result[, keep, with = FALSE] %>%
dplyr::select(
dplyr::any_of(c(
"file_name", "col_id", "material_class", "spectrum_identity",
"match_val", "signal_to_noise"
)),
dplyr::everything()
)
result <- app_without_particle_metadata(result)
result <- app_round_reported_metadata(result)
if(isTRUE(simple)) {
result <- app_selection_metadata_display(
result, simple = TRUE, particle = FALSE, library = TRUE,
match_label = match_label, signal_label = signal_label
)
}
data.table::as.data.table(result)
}
app_empty_ratio_definitions <- function() {
data.frame(
id = integer(),
name = character(),
column = character(),
type = character(),
numerator_min = numeric(),
numerator_max = numeric(),
denominator_min = numeric(),
denominator_max = numeric(),
stringsAsFactors = FALSE
)
}
app_empty_measurement_definitions <- function() {
data.frame(
id = integer(),
name = character(),
column = character(),
type = character(),
minimum = numeric(),
maximum = numeric(),
stringsAsFactors = FALSE
)
}
# Input IDs are kept as the exported column names so the settings snapshot is
# readable beside the app source without promising a future import contract.
app_user_metadata_input_ids <- c(
# Preprocessing
"spike_decision", "spike_method", "spike_direction",
"spike_width_threshold", "spike_noise_multiplier",
"spike_interpolation_window", "spike_residual_threshold",
"spike_residual_window",
"saturation_decision", "saturation_mode", "saturation_ceiling",
"saturation_max_loss", "make_rel_decision", "smooth_decision",
"smoother", "derivative_order", "smoother_window", "derivative_abs",
"conform_decision", "conform_selection", "conform_res",
"intensity_decision", "intensity_corr", "baseline_decision",
"baseline_method", "baseline", "refit", "baseline_lambda",
"baseline_hwi", "iterations", "range_decision", "range_automate",
"range_artifact_ratio", "MinRange", "MaxRange", "co2_decision",
"co2_automate", "co2_artifact_ratio", "MinFlat", "MaxFlat",
# Identification
"identification_active", "id_spec_type", "id_strategy", "lib_type",
"top_n_input", "top_n_per_organization", "filter_lib", "lib_org",
# Advanced
"threshold_decision", "signal_basis", "MinSNR", "MaxSNR",
"signal_selection",
"cor_threshold_decision", "MinCor", "spatial_decision", "sigma",
"xy_grid", "load_entire_map", "identify_batch_size",
"collapse_decision", "collapse_type",
"particle_id_strategy",
"particle_pca_components", "particle_cluster_k", "particle_area_threshold",
"pixel_size", "pixel_unit", "simple_metadata", "show_peak_positions",
"peak_count", "visual_overlay", "overlay_transparency",
# Quantification builder
"quant_ratio_name", "quant_ratio_type",
"quant_numerator_area_min", "quant_numerator_area_max",
"quant_denominator_area_min", "quant_denominator_area_max",
"quant_numerator_peak", "quant_denominator_peak",
"quant_measurement_name", "quant_measurement_type",
"quant_measurement_area_min", "quant_measurement_area_max",
"quant_measurement_wavenumber"
)
# These controls change only presentation/export formatting and must remain
# live without marking an otherwise completed scientific analysis stale.
app_live_display_input_ids <- c(
"pixel_size", "pixel_unit", "simple_metadata", "show_peak_positions",
"peak_count", "visual_overlay", "overlay_transparency"
)
app_logical_setting_ids <- c(
"spike_decision", "saturation_decision", "make_rel_decision",
"smooth_decision", "derivative_abs", "conform_decision",
"intensity_decision", "baseline_decision", "refit", "range_decision",
"range_automate", "co2_decision", "co2_automate",
"identification_active", "top_n_per_organization", "filter_lib",
"threshold_decision", "cor_threshold_decision", "spatial_decision",
"xy_grid", "load_entire_map", "collapse_decision", "simple_metadata",
"show_peak_positions", "visual_overlay"
)
app_numeric_setting_ids <- c(
"spike_width_threshold", "spike_noise_multiplier",
"spike_interpolation_window", "spike_residual_threshold",
"spike_residual_window", "saturation_ceiling",
"saturation_max_loss", "derivative_order", "smoother_window",
"conform_res", "baseline", "baseline_lambda", "baseline_hwi",
"iterations", "range_artifact_ratio", "MinRange", "MaxRange",
"co2_artifact_ratio", "MinFlat", "MaxFlat", "top_n_input", "MinSNR",
"MaxSNR", "MinCor", "sigma", "identify_batch_size",
"particle_pca_components", "particle_cluster_k", "particle_area_threshold",
"pixel_size", "peak_count", "overlay_transparency",
"quant_numerator_area_min", "quant_numerator_area_max",
"quant_denominator_area_min", "quant_denominator_area_max",
"quant_numerator_peak", "quant_denominator_peak",
"quant_measurement_area_min", "quant_measurement_area_max",
"quant_measurement_wavenumber"
)
app_saturation_value <- function(mode = "auto", ceiling = NULL) {
mode <- match.arg(mode, c("auto", "threshold"))
if(identical(mode, "auto")) return("auto")
if(!is.numeric(ceiling) || length(ceiling) != 1L ||
!is.finite(ceiling)) {
stop("Enter one finite detector ceiling for threshold saturation mode.",
call. = FALSE)
}
as.numeric(ceiling)
}
app_apply_spectral_corrections <- function(
x,
spike = TRUE,
spike_args = list(),
saturation = "auto",
saturation_args = list()) {
if(!inherits(x, "OpenSpecy")) {
stop("'x' must be an OpenSpecy object", call. = FALSE)
}
if(!is.list(spike_args) || !is.list(saturation_args)) {
stop("Correction arguments must be supplied as lists.", call. = FALSE)
}
current <- x
if(isTRUE(spike)) {
current <- do.call(correct_spike, c(list(x = current), spike_args))
}
if(!is.null(saturation)) {
current <- withCallingHandlers(
do.call(
restrict_range,
c(list(x = current, saturation = saturation, make_rel = FALSE),
saturation_args)
),
warning = function(warning) invokeRestart("muffleWarning")
)
}
attr(current, "app_automatic_correction_state") <- c(
spike = isTRUE(spike), saturation = !is.null(saturation)
)
current
}
app_copy_correction_history <- function(from, to) {
for(name in c(
"automatic_spike", "saturation_restriction",
"app_automatic_correction_state")) {
value <- attr(from, name, exact = TRUE)
if(!is.null(value)) attr(to, name) <- value
}
to
}
app_conform_axis <- function(x, resolution) {
target <- conform_res(x$wavenumber, res = resolution)
diagnostic <- attr(x, "saturation_restriction", exact = TRUE)
excluded <- if(is.list(diagnostic) && isTRUE(diagnostic$applied)) {
diagnostic$excluded_ranges
} else {
NULL
}
if(!is.null(excluded) && nrow(excluded)) {
keep <- rep(TRUE, length(target))
for(i in seq_len(nrow(excluded))) {
keep <- keep & !(target >= excluded$region_min[[i]] &
target <= excluded$region_max[[i]])
}
target <- target[keep]
}
if(length(target) < 3L) {
stop("Correction and conformation left fewer than three wavenumbers.",
call. = FALSE)
}
target
}
# "Mean Up" is a resolution-aware conform strategy, not a fixed conform type:
# the uploaded spectra are only resampled to the requested resolution when
# that target is finer (a smaller cm^-1 step) than what was actually
# uploaded; otherwise the uploaded axis is left alone and the reference
# library is conformed onto it instead (see identify_blockwise's
# preserve_axis), since aggregating real uploaded data down to a coarser
# axis would discard information the library doesn't have to begin with.
app_conform_preserve_axis <- function(uploaded, conform_decision,
conform_selection, conform_res) {
if(!identical(conform_selection, "mean_up")) return(FALSE)
if(!isTRUE(conform_decision)) return(TRUE)
native_res <- spec_res(uploaded)
!is.finite(native_res) || as.numeric(conform_res) >= native_res
}
app_attach_correction_metadata <- function(x) {
x <- as_OpenSpecy(x)
x$metadata <- data.table::copy(x$metadata)
spike <- attr(x, "automatic_spike", exact = TRUE)
if(is.list(spike)) {
x$metadata$spike_correction_applied <- isTRUE(spike$applied)
x$metadata$spike_correction_reason <- as.character(spike$reason)
x$metadata$spike_corrected_region_count <-
nrow(spike$corrected_regions)
}
saturation <- attr(x, "saturation_restriction", exact = TRUE)
if(is.list(saturation)) {
format_ranges <- function(ranges) {
if(is.null(ranges) || !nrow(ranges)) return(NA_character_)
paste0(
format(ranges$region_min, trim = TRUE), "-",
format(ranges$region_max, trim = TRUE),
collapse = " | "
)
}
x$metadata$saturation_restriction_applied <-
isTRUE(saturation$applied)
x$metadata$saturation_restriction_reason <-
as.character(saturation$reason)
x$metadata$saturation_loss_fraction <-
as.numeric(saturation$saturation_loss_fraction)
x$metadata$saturation_proposed_loss_fraction <-
as.numeric(saturation$proposed_saturation_loss_fraction)
x$metadata$saturation_excluded_ranges <-
format_ranges(saturation$excluded_ranges)
x$metadata$saturation_proposed_excluded_ranges <-
format_ranges(saturation$proposed_excluded_ranges)
x$metadata$saturation_detected_spectra <- paste(
saturation$detected_spectra, collapse = " | "
)
}
x
}
app_metadata_scalar <- function(value, separator = " | ") {
if(is.null(value) || !length(value)) return(NA_character_)
if(inherits(value, "POSIXt")) {
value <- format(value, "%Y-%m-%d %H:%M:%S %z")
}
if(is.factor(value)) value <- as.character(value)
if(is.list(value)) value <- unlist(value, recursive = TRUE, use.names = FALSE)
if(!length(value)) return(NA_character_)
if(length(value) == 1L && is.atomic(value)) return(value[[1L]])
paste(as.character(value), collapse = separator)
}
app_saved_ratio_definitions <- function(definitions) {
if(is.null(definitions) || !is.data.frame(definitions) ||
!nrow(definitions)) {
return(NA_character_)
}
required <- names(app_empty_ratio_definitions())
if(!all(required %in% names(definitions))) {
stop("Saved ratio definitions have an unexpected structure.",
call. = FALSE)
}
paste(vapply(seq_len(nrow(definitions)), function(i) {
definition <- definitions[i, required, drop = FALSE]
paste(
paste0("id=", definition$id[[1L]]),
paste0("name=", definition$name[[1L]]),
paste0("column=", definition$column[[1L]]),
paste0("type=", definition$type[[1L]]),
paste0("numerator_min=", definition$numerator_min[[1L]]),
paste0("numerator_max=", definition$numerator_max[[1L]]),
paste0("denominator_min=", definition$denominator_min[[1L]]),
paste0("denominator_max=", definition$denominator_max[[1L]]),
sep = "; "
)
}, character(1)), collapse = " || ")
}
app_saved_measurement_definitions <- function(definitions) {
if(is.null(definitions) || !is.data.frame(definitions) ||
!nrow(definitions)) {
return(NA_character_)
}
required <- names(app_empty_measurement_definitions())
if(!all(required %in% names(definitions))) {
stop("Saved measurement definitions have an unexpected structure.",
call. = FALSE)
}
paste(vapply(seq_len(nrow(definitions)), function(i) {
definition <- definitions[i, required, drop = FALSE]
paste(
paste0("id=", definition$id[[1L]]),
paste0("name=", definition$name[[1L]]),
paste0("column=", definition$column[[1L]]),
paste0("type=", definition$type[[1L]]),
paste0("minimum=", definition$minimum[[1L]]),
paste0("maximum=", definition$maximum[[1L]]),
sep = "; "
)
}, character(1)), collapse = " || ")
}
app_user_metadata_snapshot <- function(settings, definitions, recorded_at,
app_version, session_id,
source = NULL, file_info = NULL,
measurements =
app_empty_measurement_definitions()) {
if(!is.list(settings)) {
stop("App settings must be supplied as a named list.", call. = FALSE)
}
uploaded <- !is.null(source)
spectra_count <- if(uploaded && is_Specs(source)) {
specs_source_count(source)
} else if(uploaded) ncol(source$spectra) else NA_integer_
source_axis <- if(uploaded && inherits(source, "FileSpecs")) {
OpenSpecy:::.filespec_axis(source)
} else if(uploaded && is_Specs(source)) {
source$variables
} else if(uploaded) source$wavenumber else numeric()
wavenumber_count <- if(uploaded) length(source_axis) else NA_integer_
wavenumber_min <- if(uploaded && wavenumber_count) {
min(source_axis, na.rm = TRUE)
} else NA_real_
wavenumber_max <- if(uploaded && wavenumber_count) {
max(source_axis, na.rm = TRUE)
} else NA_real_
data_digest <- if(uploaded) {
digest::digest(source, algo = "md5")
} else NA_character_
file_value <- function(name) {
if(is.null(file_info) || !is.data.frame(file_info) ||
!name %in% names(file_info)) return(NA_character_)
app_metadata_scalar(file_info[[name]])
}
settings <- stats::setNames(lapply(app_user_metadata_input_ids, function(id) {
app_metadata_scalar(settings[[id]])
}), app_user_metadata_input_ids)
snapshot <- c(
list(
metadata_schema_version = 1L,
recorded_at = app_metadata_scalar(recorded_at),
app_version = app_metadata_scalar(app_version),
session_id = app_metadata_scalar(session_id),
data_uploaded = uploaded,
data_file_name = file_value("name"),
data_file_size_bytes = file_value("size"),
data_file_type = file_value("type"),
data_file_last_modified = file_value("lastModified"),
data_digest_md5 = data_digest,
data_spectrum_count = spectra_count,
data_wavenumber_count = wavenumber_count,
data_wavenumber_min = wavenumber_min,
data_wavenumber_max = wavenumber_max
),
settings,
list(
quant_saved_ratio_count = if(is.data.frame(definitions)) {
nrow(definitions)
} else 0L,
quant_saved_ratio_definitions = app_saved_ratio_definitions(definitions),
quant_saved_measurement_count = if(is.data.frame(measurements)) {
nrow(measurements)
} else 0L,
quant_saved_measurement_definitions =
app_saved_measurement_definitions(measurements)
)
)
snapshot <- lapply(snapshot, app_metadata_scalar)
if(any(lengths(snapshot) != 1L)) {
stop("Every user metadata field must contain exactly one value.",
call. = FALSE)
}
snapshot
}
app_parse_saved_definitions <- function(value, template) {
if(length(value) != 1L || is.na(value) || !nzchar(trimws(value))) {
return(template)
}
rows <- strsplit(as.character(value), " \\|\\| ")[[1L]]
required <- names(template)
parsed <- lapply(rows, function(row) {
fields <- strsplit(row, "; ", fixed = TRUE)[[1L]]
pairs <- strsplit(fields, "=", fixed = TRUE)
keys <- vapply(pairs, `[[`, character(1L), 1L)
values <- vapply(pairs, function(x) paste(x[-1L], collapse = "="),
character(1L))
if(anyDuplicated(keys) || !setequal(keys, required)) {
stop("A saved quantification definition has unexpected fields.",
call. = FALSE)
}
stats::setNames(as.list(values[match(required, keys)]), required)
})
out <- data.table::rbindlist(parsed, fill = FALSE)
for(name in required) {
if(is.integer(template[[name]])) {
out[[name]] <- suppressWarnings(as.integer(out[[name]]))
} else if(is.numeric(template[[name]])) {
out[[name]] <- suppressWarnings(as.numeric(out[[name]]))
} else {
out[[name]] <- as.character(out[[name]])
}
if(anyNA(out[[name]])) {
stop("A saved quantification definition contains an invalid '", name,
"' value.", call. = FALSE)
}
}
as.data.frame(out[, required, with = FALSE], stringsAsFactors = FALSE)
}
app_standard_settings_choices <- c(
"Default" = "default",
"MIPPR - Thermo Fisher iN10 MX" = "mippr_in10_mx"
)
app_standard_settings <- function(preset, defaults) {
preset <- match.arg(preset, unname(app_standard_settings_choices))
if(!is.list(defaults) ||
!all(app_user_metadata_input_ids %in% names(defaults))) {
stop("App defaults are not ready; wait for the controls to finish loading.",
call. = FALSE)
}
settings <- defaults[app_user_metadata_input_ids]
if(identical(preset, "mippr_in10_mx")) {
overrides <- list(
spatial_decision = TRUE,
collapse_decision = TRUE,
threshold_decision = TRUE,
signal_selection = "sig_times_noise",
MinSNR = 0.01,
cor_threshold_decision = FALSE,
load_entire_map = TRUE,
id_spec_type = "ftir",
top_n_per_organization = FALSE,
co2_decision = TRUE,
co2_automate = FALSE,
range_decision = TRUE,
range_automate = FALSE,
MinRange = 800,
MaxRange = 3200
)
settings[names(overrides)] <- overrides
}
list(
settings = settings,
ratios = app_empty_ratio_definitions(),
measurements = app_empty_measurement_definitions(),
unknown = character(),
preset = preset
)
}
app_user_metadata_import <- function(snapshot, defaults) {
if(!is.data.frame(snapshot) || nrow(snapshot) != 1L) {
stop("Load Settings requires exactly one CSV data row.", call. = FALSE)
}
if(anyDuplicated(names(snapshot))) {
stop("Load Settings CSV column names must be unique.", call. = FALSE)
}
version <- if("metadata_schema_version" %in% names(snapshot)) {
suppressWarnings(as.integer(snapshot$metadata_schema_version[[1L]]))
} else 1L
if(length(version) != 1L || is.na(version) || version != 1L) {
stop("Unsupported settings metadata schema version: ",
as.character(snapshot$metadata_schema_version[[1L]]), call. = FALSE)
}
if(!is.list(defaults) || !all(app_user_metadata_input_ids %in% names(defaults))) {
stop("App defaults are not ready; wait for the Advanced tab to finish loading.",
call. = FALSE)
}
settings <- defaults[app_user_metadata_input_ids]
present <- intersect(app_user_metadata_input_ids, names(snapshot))
for(id in present) {
raw <- snapshot[[id]][[1L]]
if(length(raw) != 1L || is.na(raw) ||
(is.character(raw) && !nzchar(trimws(raw)))) next
if(id %in% app_logical_setting_ids) {
text <- tolower(trimws(as.character(raw)))
if(!text %in% c("true", "false", "1", "0")) {
stop("Setting '", id, "' must be TRUE or FALSE.", call. = FALSE)
}
settings[[id]] <- text %in% c("true", "1")
} else if(id %in% app_numeric_setting_ids) {
value <- suppressWarnings(as.numeric(raw))
if(length(value) != 1L || !is.finite(value)) {
stop("Setting '", id, "' must be a finite number.", call. = FALSE)
}
settings[[id]] <- value
} else if(identical(id, "lib_org")) {
settings[[id]] <- strsplit(as.character(raw), " \\| ")[[1L]]
} else {
settings[[id]] <- as.character(raw)
}
}
saved_value <- function(name) {
if(name %in% names(snapshot)) snapshot[[name]][[1L]] else NA_character_
}
ratios <- app_parse_saved_definitions(
saved_value("quant_saved_ratio_definitions"),
app_empty_ratio_definitions()
)
measurements <- app_parse_saved_definitions(
saved_value("quant_saved_measurement_definitions"),
app_empty_measurement_definitions()
)
provenance <- c(
"metadata_schema_version", "recorded_at", "app_version", "session_id",
"data_uploaded", "data_file_name", "data_file_size_bytes",
"data_file_type", "data_file_last_modified", "data_digest_md5",
"data_spectrum_count", "data_wavenumber_count", "data_wavenumber_min",
"data_wavenumber_max", "quant_saved_ratio_count",
"quant_saved_ratio_definitions", "quant_saved_measurement_count",
"quant_saved_measurement_definitions"
)
list(
settings = settings, ratios = ratios, measurements = measurements,
unknown = setdiff(names(snapshot), c(app_user_metadata_input_ids,
provenance))
)
}
app_quantification_source_value <- "displayed_processed_spectra"
app_ratio_column_name <- function(name, type) {
if(!is.character(name) || length(name) != 1L || is.na(name) ||
!nzchar(trimws(name))) {
stop("Enter a nonempty ratio name before adding it.", call. = FALSE)
}
type <- match.arg(type, c("area", "peak"))
plain <- iconv(trimws(name), to = "ASCII//TRANSLIT", sub = "")
slug <- tolower(gsub("[^A-Za-z0-9]+", "_", plain))
slug <- gsub("^_+|_+$", "", slug)
if(is.na(slug) || !nzchar(slug)) {
stop("The ratio name must contain at least one letter or number.",
call. = FALSE)
}
paste0(type, "_ratio_", slug)
}
app_add_ratio_definition <- function(definitions, name, type, numerator,
denominator, axis = NULL) {
expected <- names(app_empty_ratio_definitions())
if(!is.data.frame(definitions) || !identical(names(definitions), expected)) {
stop("Ratio definitions have an unexpected structure.", call. = FALSE)
}
type <- match.arg(type, c("area", "peak"))
name <- trimws(name)
column <- app_ratio_column_name(name, type)
if(column %in% definitions$column) {
stop("A ratio with the same metadata name has already been added.",
call. = FALSE)
}
validate_axis <- !is.null(axis)
if(validate_axis) {
axis <- sort(unique(as.numeric(axis)))
axis <- axis[is.finite(axis)]
if(!length(axis)) {
stop("The processed spectrum does not have a valid wavenumber axis.",
call. = FALSE)
}
}
normalize_selection <- function(value, expected_length, label) {
if(!is.numeric(value) || length(value) != expected_length ||
any(!is.finite(value))) {
stop(label, " must contain ", expected_length,
" finite wavenumber value", if(expected_length == 1L) "." else "s.",
call. = FALSE)
}
sort(as.numeric(value))
}
if(identical(type, "area")) {
numerator <- normalize_selection(numerator, 2L, "Numerator range")
denominator <- normalize_selection(denominator, 2L, "Denominator range")
} else {
numerator <- rep(normalize_selection(numerator, 1L, "Numerator point"), 2L)
denominator <- rep(normalize_selection(
denominator, 1L, "Denominator point"
), 2L)
}
values <- c(numerator, denominator)
if(validate_axis &&
any(values < axis[[1L]] | values > axis[[length(axis)]])) {
stop(
"Ratio selections must stay within the displayed processed wavenumber range.",
call. = FALSE
)
}
if(validate_axis && identical(type, "area") &&
(!any(axis >= numerator[[1L]] & axis <= numerator[[2L]]) ||
!any(axis >= denominator[[1L]] & axis <= denominator[[2L]]))) {
stop(
"Each area range must contain at least one displayed processed wavenumber.",
call. = FALSE
)
}
next_id <- if(nrow(definitions)) max(definitions$id) + 1L else 1L
rbind(
definitions,
data.frame(
id = next_id,
name = name,
column = column,
type = type,
numerator_min = numerator[[1L]],
numerator_max = numerator[[2L]],
denominator_min = denominator[[1L]],
denominator_max = denominator[[2L]],
stringsAsFactors = FALSE
)
)
}
app_ratio_definition_label <- function(definition) {
if(identical(definition$type[[1L]], "area")) {
paste0(
definition$name[[1L]], " (area: ",
format(definition$numerator_min[[1L]]), "-",
format(definition$numerator_max[[1L]]), " / ",
format(definition$denominator_min[[1L]]), "-",
format(definition$denominator_max[[1L]]), " cm^-1)"
)
} else {
paste0(
definition$name[[1L]], " (peak: ",
format(definition$numerator_min[[1L]]), " / ",
format(definition$denominator_min[[1L]]), " cm^-1)"
)
}
}
app_quantification_defaults <- function(axis, type = c("area", "peak")) {
type <- match.arg(type)
axis <- sort(unique(as.numeric(axis)))
axis <- axis[is.finite(axis)]
if(length(axis) < 2L) {
stop("Process a spectrum with at least two distinct wavenumbers.",
call. = FALSE)
}
axis_min <- min(axis)
axis_max <- max(axis)
if(axis_min >= axis_max) {
stop("The processed wavenumber range must contain at least two values.",
call. = FALSE)
}
clamp_value <- function(value) {
as.numeric(pmax(axis_min, pmin(axis_max, value)))
}
closest_value <- function(value) {
as.numeric(axis[[which.min(abs(axis - value))]])
}
# Numeric inputs permit exact typed values. Points are resolved to measured
# data by point_intensity() or peak_ratio() when quantification runs.
step <- min(diff(axis)) / 10
if(identical(type, "area")) {
scenario <- c(1650, 1850, 1420, 1500)
if(all(scenario >= axis_min & scenario <= axis_max)) {
numerator <- sort(vapply(scenario[1:2], closest_value, numeric(1)))
denominator <- sort(vapply(
scenario[3:4], closest_value, numeric(1)
))
} else {
selections <- axis[pmax(
1L,
pmin(length(axis), round(c(.60, .78, .24, .42) * length(axis)))
)]
numerator <- sort(clamp_value(selections[1:2]))
denominator <- sort(clamp_value(selections[3:4]))
}
} else {
scenario <- c(1715, 1460)
if(all(scenario >= axis_min & scenario <= axis_max)) {
numerator <- closest_value(scenario[[1L]])
denominator <- closest_value(scenario[[2L]])
} else {
numerator <- clamp_value(
axis[[max(1L, round(.67 * length(axis)))]]
)
denominator <- clamp_value(
axis[[max(1L, round(.33 * length(axis)))]]
)
}
}
list(
min = axis_min,
max = axis_max,
step = step,
numerator = numerator,
denominator = denominator
)
}
# Retained as an internal compatibility alias for saved app tests and sessions;
# the UI now uses numeric inputs, not sliders.
app_ratio_slider_defaults <- app_quantification_defaults
app_measurement_column_name <- function(name, type) {
if(!is.character(name) || length(name) != 1L || is.na(name) ||
!nzchar(trimws(name))) {
stop("Enter a nonempty measurement name before adding it.", call. = FALSE)
}
type <- match.arg(type, c("area", "point"))
plain <- iconv(trimws(name), to = "ASCII//TRANSLIT", sub = "")
slug <- tolower(gsub("[^A-Za-z0-9]+", "_", plain))
slug <- gsub("^_+|_+$", "", slug)
if(is.na(slug) || !nzchar(slug)) {
stop("The measurement name must contain at least one letter or number.",
call. = FALSE)
}
paste0(if(identical(type, "area")) {
"area_under_band_"
} else {
"point_intensity_"
}, slug)
}
app_add_measurement_definition <- function(definitions, name, type, values,
axis = NULL) {
expected <- names(app_empty_measurement_definitions())
if(!is.data.frame(definitions) || !identical(names(definitions), expected)) {
stop("Measurement definitions have an unexpected structure.",
call. = FALSE)
}
type <- match.arg(type, c("area", "point"))
name <- trimws(name)
column <- app_measurement_column_name(name, type)
if(column %in% definitions$column) {
stop("A measurement with the same metadata name has already been added.",
call. = FALSE)
}
validate_axis <- !is.null(axis)
if(validate_axis) {
axis <- sort(unique(as.numeric(axis)))
axis <- axis[is.finite(axis)]
if(!length(axis)) {
stop("The processed spectrum does not have a valid wavenumber axis.",
call. = FALSE)
}
}
expected_length <- if(identical(type, "area")) 2L else 1L
if(!is.numeric(values) || length(values) != expected_length ||
any(!is.finite(values))) {
stop(
if(identical(type, "area")) {
"Measurement area must contain two finite wavenumber values."
} else {
"Measurement point must contain one finite wavenumber value."
},
call. = FALSE
)
}
values <- sort(as.numeric(values))
if(identical(type, "point")) values <- rep(values, 2L)
if(validate_axis &&
any(values < axis[[1L]] | values > axis[[length(axis)]])) {
stop(
"Measurement selections must stay within the displayed processed wavenumber range.",
call. = FALSE
)
}
if(validate_axis && identical(type, "area") &&
!any(axis >= values[[1L]] & axis <= values[[2L]])) {
stop(
"The measurement area must contain at least one displayed processed wavenumber.",
call. = FALSE
)
}
next_id <- if(nrow(definitions)) max(definitions$id) + 1L else 1L
rbind(
definitions,
data.frame(
id = next_id,
name = name,
column = column,
type = type,
minimum = values[[1L]],
maximum = values[[2L]],
stringsAsFactors = FALSE
)
)
}
app_measurement_definition_label <- function(definition) {
if(identical(definition$type[[1L]], "area")) {
paste0(
definition$name[[1L]], " (area: ",
format(definition$minimum[[1L]]), "-",
format(definition$maximum[[1L]]), " cm^-1)"
)
} else {
paste0(
definition$name[[1L]], " (intensity: ",
format(definition$minimum[[1L]]), " cm^-1)"
)
}
}
app_ratio_definitions_text <- function(definitions) {
if(!nrow(definitions)) return(character())
paste(
vapply(seq_len(nrow(definitions)), function(i) {
app_ratio_definition_label(definitions[i, , drop = FALSE])
}, character(1)),
collapse = "; "
)
}
app_measurement_definitions_text <- function(definitions) {
if(!nrow(definitions)) return(character())
paste(
vapply(seq_len(nrow(definitions)), function(i) {
app_measurement_definition_label(definitions[i, , drop = FALSE])
}, character(1)),
collapse = "; "
)
}
app_quantification_definitions_text <- function(ratios, measurements) {
parts <- c(
if(nrow(ratios)) paste0("Ratios: ", app_ratio_definitions_text(ratios)),
if(nrow(measurements)) paste0(
"Measurements: ", app_measurement_definitions_text(measurements)
)
)
paste(parts, collapse = "; ")
}
app_ratio_metadata_columns <- function(
definitions,
measurements = app_empty_measurement_definitions()) {
if(!nrow(definitions) && !nrow(measurements)) return(character())
c("quantification_source", "quantification_definitions",
definitions$column, measurements$column)
}
app_area_ratio <- function(source, numerator, denominator) {
source <- as_OpenSpecy(source)
axis <- source$wavenumber
named_na <- stats::setNames(
rep(NA_real_, ncol(source$spectra)), colnames(source$spectra)
)
complete <- all(c(numerator, denominator) >= min(axis) &
c(numerator, denominator) <= max(axis)) &&
any(axis >= numerator[[1L]] & axis <= numerator[[2L]]) &&
any(axis >= denominator[[1L]] & axis <= denominator[[2L]])
if(!complete) {
warning("The source spectrum does not fully cover this area ratio; returning NA.",
call. = FALSE)
return(named_na)
}
numerator_values <- area_under_band(
source, min = numerator[[1L]], max = numerator[[2L]]
)
denominator_values <- area_under_band(
source, min = denominator[[1L]], max = denominator[[2L]]
)
values <- numerator_values / denominator_values
invalid <- !is.finite(numerator_values) | !is.finite(denominator_values) |
denominator_values == 0 | !is.finite(values)
if(any(invalid)) {
warning("One or more area ratios had a zero or non-finite value; returning NA for those spectra.",
call. = FALSE)
values[invalid] <- NA_real_
}
values
}
app_area_measurement <- function(source, bounds) {
source <- as_OpenSpecy(source)
axis <- source$wavenumber
named_na <- stats::setNames(
rep(NA_real_, ncol(source$spectra)), colnames(source$spectra)
)
complete <- length(bounds) == 2L && all(is.finite(bounds)) &&
all(bounds >= min(axis) & bounds <= max(axis)) &&
any(axis >= bounds[[1L]] & axis <= bounds[[2L]])
if(!complete) {
warning(
"The source spectrum does not fully cover this area measurement; returning NA.",
call. = FALSE
)
return(named_na)
}
area_under_band(source, min = bounds[[1L]], max = bounds[[2L]])
}
app_attach_quantification <- function(
x,
definitions,
measurements = app_empty_measurement_definitions()) {
x <- as_OpenSpecy(x)
if(!nrow(definitions) && !nrow(measurements)) return(x)
x$metadata <- data.table::copy(x$metadata)
x$metadata$quantification_source <- app_quantification_source_value
x$metadata$quantification_definitions <-
app_quantification_definitions_text(definitions, measurements)
for(i in seq_len(nrow(definitions))) {
definition <- definitions[i, , drop = FALSE]
values <- if(identical(definition$type[[1L]], "area")) {
app_area_ratio(
x,
c(definition$numerator_min[[1L]], definition$numerator_max[[1L]]),
c(definition$denominator_min[[1L]], definition$denominator_max[[1L]])
)
} else {
peak_ratio(
x,
numerator = definition$numerator_min[[1L]],
denominator = definition$denominator_min[[1L]],
method = "nearest"
)
}
if(length(values) != nrow(x$metadata)) {
stop("Quantification returned an unexpected number of values for '",
definition$name[[1L]], "'.", call. = FALSE)
}
x$metadata[[definition$column[[1L]]]] <- as.numeric(values)
}
for(i in seq_len(nrow(measurements))) {
definition <- measurements[i, , drop = FALSE]
values <- if(identical(definition$type[[1L]], "area")) {
app_area_measurement(
x,
c(definition$minimum[[1L]], definition$maximum[[1L]])
)
} else {
point_intensity(
x,
wavenumber = definition$minimum[[1L]],
method = "nearest"
)
}
if(length(values) != nrow(x$metadata)) {
stop("Quantification returned an unexpected number of values for '",
definition$name[[1L]], "'.", call. = FALSE)
}
x$metadata[[definition$column[[1L]]]] <- as.numeric(values)
}
x
}
.app_range_assessment <- function(x, check, correction_args = list()) {
check <- match.arg(check, c("co2_region", "high_tail"))
value_or <- function(name, default) {
value <- correction_args[[name]]
if(is.null(value)) default else value
}
artifact_ratio <- value_or("artifact_ratio", 3)
tail_n <- value_or("tail_n", 5L)
co2_region <- if(identical(check, "co2_region")) {
min <- value_or("min", 2200)
max <- value_or("max", 2420)
if(length(min) != 1L || length(max) != 1L) {
stop("automatic CO2 correction requires one flattening range",
call. = FALSE)
}
c(min, max)
} else {
value_or("co2_region", c(2200, 2420))
}
issues <- assess_spec(
x,
checks = check,
artifact_ratio = artifact_ratio,
tail_n = tail_n,
co2_region = co2_region
)
failures <- length(unique(issues$spectrum_index))
total <- ncol(x$spectra)
list(
issues = issues,
failures = failures,
passes = total - failures,
total = total
)
}
.app_range_candidate_preserves_batch <- function(before, candidate) {
if(!inherits(candidate, "OpenSpecy") ||
ncol(candidate$spectra) != ncol(before$spectra) ||
!identical(colnames(candidate$spectra), colnames(before$spectra)) ||
!identical(candidate$metadata, before$metadata)) {
return(FALSE)
}
original_attributes <- attributes(before)
protected <- setdiff(names(original_attributes), c("names", "class"))
all(vapply(protected, function(name) {
identical(attr(candidate, name), original_attributes[[name]])
}, logical(1)))
}
.app_range_diagnostic <- function(step, check, enabled, attempted, accepted,
total, before, after, reason,
message = "",
original_range = c(NA_real_, NA_real_),
applied_range = c(NA_real_, NA_real_)) {
normalize_range <- function(value) {
value <- suppressWarnings(as.numeric(value))
if(length(value) < 2L || any(!is.finite(value[1:2]))) {
return(c(NA_real_, NA_real_))
}
range(value[1:2])
}
original_range <- normalize_range(original_range)
applied_range <- normalize_range(applied_range)
data.frame(
step = step,
check = check,
enabled = enabled,
attempted = attempted,
accepted = accepted,
total_spectra = as.integer(total),
before_passes = as.integer(before),
after_passes = as.integer(after),
reason = reason,
message = message,
original_range_min = original_range[[1L]],
original_range_max = original_range[[2L]],
applied_range_min = applied_range[[1L]],
applied_range_max = applied_range[[2L]],
stringsAsFactors = FALSE
)
}
.app_attempt_range_automation <- function(x, step, correction_args = list()) {
check <- if(identical(step, "flatten_range")) "co2_region" else "high_tail"
if(identical(step, "flatten_range")) {
if(is.null(correction_args$min)) correction_args$min <- 2200
if(is.null(correction_args$max)) correction_args$max <- 2420
}
before <- .app_range_assessment(x, check, correction_args)
if(before$failures == 0L) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, FALSE, FALSE, before$total,
before$passes, before$passes, "no_failures"
)
))
}
correction <- if(identical(step, "flatten_range")) {
flatten_range
} else {
restrict_range
}
correction_args$x <- NULL
correction_args$automate <- TRUE
if(is.null(correction_args$make_rel)) correction_args$make_rel <- FALSE
candidate <- tryCatch(
do.call(correction, c(list(x = x), correction_args)),
error = function(e) e
)
if(inherits(candidate, "error")) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, FALSE, before$total,
before$passes, before$passes, "correction_error",
conditionMessage(candidate)
)
))
}
if(!.app_range_candidate_preserves_batch(x, candidate)) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, FALSE, before$total,
before$passes, before$passes, "invalid_candidate",
"candidate changed spectrum identifiers, metadata, or input attributes"
)
))
}
after <- tryCatch(
.app_range_assessment(candidate, check, correction_args),
error = function(e) e
)
if(inherits(after, "error")) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, FALSE, before$total,
before$passes, before$passes, "assessment_error",
conditionMessage(after)
)
))
}
accepted <- after$passes > before$passes
correction_detail <- attr(
candidate,
if(identical(step, "flatten_range")) {
"automatic_flatten"
} else {
"automatic_tail"
},
exact = TRUE
)
original_range <- if(is.list(correction_detail) &&
!is.null(correction_detail$original_range)) {
correction_detail$original_range
} else {
range(x$wavenumber, na.rm = TRUE)
}
applied_range <- if(identical(step, "flatten_range")) {
if(is.list(correction_detail) && !is.null(correction_detail$region)) {
correction_detail$region
} else {
c(correction_args$min, correction_args$max)
}
} else if(is.list(correction_detail) &&
!is.null(correction_detail$corrected_range)) {
correction_detail$corrected_range
} else {
range(candidate$wavenumber, na.rm = TRUE)
}
list(
data = if(accepted) candidate else x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, accepted, before$total,
before$passes, after$passes,
if(accepted) "improved" else "not_improved",
original_range = original_range,
applied_range = applied_range
)
)
}
app_apply_range_automation <- function(x, flatten = TRUE, restrict = TRUE,
flatten_args = list(),
restrict_args = list()) {
if(!inherits(x, "OpenSpecy")) {
stop("'x' must be an OpenSpecy object", call. = FALSE)
}
current <- x
diagnostics <- list()
steps <- list(
list(name = "flatten_range", check = "co2_region", enabled = flatten,
args = flatten_args),
list(name = "restrict_range", check = "high_tail", enabled = restrict,
args = restrict_args)
)
for(step in steps) {
if(!isTRUE(step$enabled)) {
total <- ncol(current$spectra)
diagnostics[[length(diagnostics) + 1L]] <- .app_range_diagnostic(
step$name, step$check, FALSE, FALSE, FALSE, total,
NA_integer_, NA_integer_, "disabled"
)
next
}
result <- .app_attempt_range_automation(
current, step$name, correction_args = step$args
)
current <- result$data
diagnostics[[length(diagnostics) + 1L]] <- result$diagnostic
}
list(data = current, diagnostics = do.call(rbind, diagnostics))
}
app_theme <- list(
canvas = "#050B14",
panel = "#0B1929",
panel_2 = "#10243A",
border = "#168FC2",
accent = "#38BDF8",
success = "#22C55E",
text = "#E6EDF7",
muted = "#A9B8CB",
grid = "#28536F",
axis = "#6F86A3",
raw = "#CBD5E1",
reference = "#FB7185",
spectrum = "#FFFFFF"
)
app_theme_css <- function(theme = app_theme) {
required <- c(
"canvas", "panel", "panel_2", "border", "accent", "success",
"text", "muted", "grid", "axis", "raw", "spectrum"
)
if(!is.list(theme) || !all(required %in% names(theme))) {
stop("The app theme is missing one or more required color tokens.",
call. = FALSE)
}
values <- unlist(theme[required], use.names = TRUE)
css_names <- gsub("_", "-", names(values), fixed = TRUE)
paste0(
":root {\n",
paste0(" --openspecy-", css_names, ": ", values, ";",
collapse = "\n"),
"\n}\n"
)
}
app_plot_palette <- list(
panel = app_theme$panel,
grid = app_theme$grid,
axis = app_theme$axis,
text = app_theme$text,
primary = app_theme$accent,
raw = app_theme$raw,
peak = "#3B82F6",
reference = app_theme$reference,
spectrum = app_theme$spectrum
)
# Okabe-Ito hues, ordered from cool to warm and lifted away from the very dark
# end of common perceptually uniform scales so every value remains visible on
# the application's navy canvas.
app_heatmap_colorscale <- list(
c(0.00, "#56B4E9"),
c(0.20, "#44B9A8"),
c(0.40, "#009E73"),
c(0.60, "#F0E442"),
c(0.80, "#E69F00"),
c(1.00, "#CC79A7")
)
app_heatmap_legend_layout <- function(title = NULL) {
list(
margin = list(t = 18, r = 24, b = 58, l = 66)
)
}
app_heatmap_legend_model <- function(data, max_categories = 30L) {
title <- if(isTruthy(data$legend_title)) data$legend_title else "Value"
categorical <- identical(data$type, "heatmap_categorical") ||
identical(data$type, "heatmap_binary")
if(categorical) {
levels <- if(identical(data$type, "heatmap_binary")) {
as.character(data$labels)
} else as.character(data$levels)
colors <- if(!is.null(data$palette)) data$palette[levels] else
app_category_palette(levels)[levels]
return(list(
title = title, categorical = TRUE, too_many = length(levels) > max_categories,
levels = levels, colors = unname(colors), range = NULL, ticks = NULL
))
}
values <- as.numeric(data$z)
values <- values[is.finite(values)]
value_range <- if(length(values)) range(values) else c(NA_real_, NA_real_)
ticks <- if(all(is.finite(value_range))) {
if(identical(value_range[[1L]], value_range[[2L]])) {
rep(value_range[[1L]], 5L)
} else {
seq(value_range[[1L]], value_range[[2L]], length.out = 5L)
}
} else numeric()
list(
title = title, categorical = FALSE, too_many = FALSE,
levels = NULL, colors = vapply(app_heatmap_colorscale, `[[`, "", 2L),
range = value_range, ticks = ticks
)
}
app_heatmap_legend_content <- function(model) {
if(isTRUE(model$too_many)) {
return(tags$p(
"More than 30 categories are present, so a categorical legend would not be useful. Use the heatmap hover information to inspect individual pixels."
))
}
if(isTRUE(model$categorical)) {
return(tags$div(
class = "openspecy-modal-legend-grid",
lapply(seq_along(model$levels), function(i) tags$div(
class = "openspecy-modal-legend-item",
tags$span(
`aria-hidden` = "true",
style = paste0(
"display:inline-block;width:1rem;height:1rem;margin-right:.55rem;",
"vertical-align:middle;border:1px solid #d8e2ec;background:",
model$colors[[i]], ";"
)
),
tags$span(model$levels[[i]])
))
))
}
labels <- if(length(model$ticks)) {
format(signif(model$ticks, 3), trim = TRUE)
} else "No finite values"
tags$div(
tags$div(
`aria-hidden` = "true",
style = paste0(
"height:1.25rem;border:1px solid #d8e2ec;background:linear-gradient(90deg,",
paste(model$colors, collapse = ","), ");"
)
),
tags$div(
style = "display:flex;justify-content:space-between;margin-top:.35rem;",
lapply(labels, tags$span)
)
)
}
app_category_colors <- c(
"#56B4E9", "#E69F00", "#009E73", "#F0E442", "#CC79A7",
"#D55E00", "#7FDBFF", "#98D8C8", "#F4A6C1", "#FDD17A"
)
# One canonical color per label, shared by the app heatmap and Summary
# material-class bar chart, and consistent with particle_image()'s package
# static export. Known material-class names
# (R/particle_image.R's .particle_material_palette()) always get their fixed
# color; anything else cycles the app's categorical palette in sorted order.
app_category_palette <- function(values) {
labels <- if(is.factor(values)) {
levels(values)
} else {
sort(unique(as.character(values[!is.na(values)])))
}
if(!length(labels)) return(stats::setNames(character(), character()))
known <- OpenSpecy:::.particle_material_palette()
matched <- labels %in% names(known)
colors <- rep(NA_character_, length(labels))
colors[matched] <- unname(known[labels[matched]])
if(any(!matched)) {
colors[!matched] <- rep(app_category_colors,
length.out = sum(!matched))
}
stats::setNames(colors, labels)
}
app_category_colorscale <- function(values) {
palette <- app_category_palette(values)
count <- length(palette)
if(!count) return(app_heatmap_colorscale)
if(count == 1L) {
return(list(c(0, unname(palette[[1L]])),
c(1, unname(palette[[1L]]))))
}
centers <- seq(0, 1, length.out = count)
edges <- c(0, (centers[-1L] + centers[-count]) / 2, 1)
unlist(lapply(seq_len(count), function(i) {
list(
c(edges[[i]], unname(palette[[i]])),
c(edges[[i + 1L]], unname(palette[[i]]))
)
}), recursive = FALSE)
}
app_quality_checks <- c(
"silent_region", "missing_values", "flat_spectrum",
"negative_intensity", "co2_region", "high_tail", "spike", "saturation"
)
app_automatic_quality_checks <- c(
"spike", "saturation", "co2_region", "high_tail"
)
app_quality_success_description <- function(row) {
if(!is.data.frame(row) || nrow(row) != 1L || !"check" %in% names(row)) {
stop("A success description requires one quality-report row.",
call. = FALSE)
}
check <- as.character(row$check[[1L]])
if("issue" %in% names(row) &&
identical(as.character(row$issue[[1L]]), "Region not in spectrum")) {
return(as.character(row$description[[1L]]))
}
switch(
check,
silent_region = {
region <- if(all(c("region_min", "region_max") %in% names(row)) &&
is.finite(row$region_min[[1L]]) &&
is.finite(row$region_max[[1L]])) {
paste0(
" in ", format(row$region_min[[1L]], trim = TRUE), "-",
format(row$region_max[[1L]], trim = TRUE), " cm^-1"
)
} else " in the configured silent region"
paste0(
"The maximum intensity", region,
" stayed at or below the spectrum-wide high-quantile threshold."
)
},
missing_values =
"No NA, NaN, Inf, or -Inf intensity values were detected.",
flat_spectrum = paste(
"The finite intensity range exceeds the configured flat-spectrum",
"tolerance, so the spectrum is not constant."
),
negative_intensity = paste(
"The minimum finite intensity stayed at or above the allowed negative",
"threshold."
),
co2_region = {
region <- if(all(c("region_min", "region_max") %in% names(row)) &&
is.finite(row$region_min[[1L]]) &&
is.finite(row$region_max[[1L]])) {
paste0(
" in ", format(row$region_min[[1L]], trim = TRUE), "-",
format(row$region_max[[1L]], trim = TRUE), " cm^-1"
)
} else " in the configured CO2 region"
paste0(
"The normalized maximum", region,
" stayed below the artifact ratio threshold relative to the rest",
" of the spectrum."
)
},
high_tail = paste(
"The normalized maximum in the first and last tail points stayed",
"below the artifact ratio threshold relative to the rest of the",
"spectrum."
),
spike = "No isolated single-point spikes were detected.",
low_snr = {
metric <- if("metric" %in% names(row) &&
isTruthy(row$metric[[1L]])) {
as.character(row$metric[[1L]])
} else "signal-to-noise"
paste0(
"The ", metric,
" metric stayed at or above the configured threshold."
)
},
saturation = "No saturated spectral intervals were detected.",
as.character(row$description[[1L]])
)
}
app_mark_absent_quality_regions <- function(report, wavenumber, regions) {
if(is.null(report) || !is.data.frame(report) || !nrow(report)) return(report)
wavenumber <- suppressWarnings(as.numeric(wavenumber))
for(check in intersect(names(regions), unique(as.character(report$check)))) {
region <- suppressWarnings(as.numeric(regions[[check]]))
if(length(region) != 2L || any(!is.finite(region))) next
region <- sort(region)
if(any(wavenumber >= region[[1L]] & wavenumber <= region[[2L]],
na.rm = TRUE)) next
rows <- which(report$check == check)
report$status[rows] <- "pass"
report$issue[rows] <- "Region not in spectrum"
report$description[rows] <- paste0(
"The configured ", gsub("_", " ", check), " (",
region[[1L]], "-", region[[2L]],
" cm^-1) is outside the restricted spectrum, so the check was skipped."
)
report$likely_cause[rows] <- NA_character_
report$potential_fix[rows] <- "No action required."
if("finding_count" %in% names(report)) report$finding_count[rows] <- 0L
}
report
}
app_quality_ui_report <- function(report) {
if(is.null(report) || !is.data.frame(report) || !nrow(report)) return(report)
if(!all(c("status", "test_id", "check") %in% names(report))) {
stop("Quality reports must include 'status', 'test_id', and 'check'.",
call. = FALSE)
}
# assess_spec() returns a data.table. Convert before filtering so helper
# arguments such as `status` cannot be shadowed by same-named columns in
# data.table's non-standard evaluation.
report <- as.data.frame(report, stringsAsFactors = FALSE)
# spike/saturation/co2_region/high_tail (app_automatic_quality_checks)
# used to be filtered out here on the assumption they'd only ever be
# reported via Automatic Corrections Made. They're now also included in
# Warnings/Successes for the viewed spectrum -- independent of whether
# the matching correction is actually applied -- so no longer excluded.
report$status <- ifelse(
report$status %in% c("pass", "success"), "success", "warning"
)
success_rows <- which(report$status == "success")
for(i in success_rows) {
report$description[[i]] <- app_quality_success_description(
report[i, , drop = FALSE]
)
}
report
}
app_quality_status_report <- function(report, status) {
target_status <- match.arg(status, c("warning", "success"))
if(is.null(report) || !is.data.frame(report) || !nrow(report)) {
return(data.frame())
}
report <- app_quality_ui_report(report)
report[
report$status == target_status & !duplicated(report$test_id), ,
drop = FALSE
]
}
app_threshold_quality_report <- function(
spectrum_id,
snr_value = NULL,
snr_threshold = NULL,
signal_metric = "run_sig_over_noise",
correlation_value = NULL,
correlation_threshold = NULL) {
empty <- function() {
data.frame(
status = character(), test_id = character(), check = character(),
description = character(), likely_cause = character(),
potential_fix = character(), metric = character(), value = numeric(),
threshold = numeric(), region_min = numeric(), region_max = numeric(),
stringsAsFactors = FALSE
)
}
if(length(spectrum_id) != 1L || is.na(spectrum_id) ||
!nzchar(as.character(spectrum_id))) {
stop("Threshold quality findings require one spectrum ID.",
call. = FALSE)
}
signal_details <- switch(
match.arg(signal_metric, c(
"run_sig_over_noise", "sig_times_noise", "log_tot_sig"
)),
run_sig_over_noise = list(
label = "Signal-to-noise ratio", metric = "snr"
),
sig_times_noise = list(
label = "Signal times noise", metric = "signal_times_noise"
),
log_tot_sig = list(
label = "Total signal", metric = "total_signal"
)
)
make_row <- function(check, label, metric, observed, threshold,
warning_cause, warning_fix) {
if(is.null(threshold)) return(NULL)
if(!is.numeric(threshold) || length(threshold) != 1L ||
!is.finite(threshold)) {
stop(label, " threshold must be one finite number.", call. = FALSE)
}
if(!is.numeric(observed) || length(observed) != 1L) {
stop(label, " value must be one numeric value.", call. = FALSE)
}
observed <- as.numeric(observed)
threshold <- as.numeric(threshold)
# Infinite SNR is a valid result when signal is positive and estimated
# noise is zero. Compare infinities normally; only missing/NaN values are
# unavailable.
evaluable <- !is.na(observed)
passed <- evaluable && observed > threshold
relation <- if(!evaluable) {
"could not be evaluated against"
} else if(passed) {
"is above"
} else if(observed < threshold) {
"is below"
} else {
"is equal to and does not exceed"
}
observed_text <- if(evaluable) {
format(signif(observed, 5), trim = TRUE)
} else {
"an unavailable value"
}
data.frame(
status = if(passed) "success" else "warning",
test_id = paste("app_threshold", spectrum_id, check, sep = ":"),
check = check,
description = paste(
label, observed_text, relation, "the configured threshold",
paste0(format(signif(threshold, 5), trim = TRUE), ".")
),
likely_cause = if(passed) NA_character_ else if(evaluable) {
warning_cause
} else {
paste(label, "was unavailable for the selected spectrum.")
},
potential_fix = if(passed) "No action required." else warning_fix,
metric = metric,
value = observed,
threshold = threshold,
region_min = NA_real_,
region_max = NA_real_,
stringsAsFactors = FALSE
)
}
rows <- Filter(Negate(is.null), list(
make_row(
"snr_threshold", signal_details$label, signal_details$metric,
snr_value, snr_threshold,
"The selected spectrum has less signal separation than requested.",
paste(
"Review the SNR threshold and acquisition settings; consider",
"recollecting the spectrum if the weak signal is unexpected."
)
),
make_row(
"correlation_threshold", "Correlation", "correlation",
correlation_value, correlation_threshold,
"The selected spectrum's best library match is weaker than requested.",
paste(
"Review the correlation threshold, preprocessing, and candidate",
"matches before interpreting the identification."
)
)
))
if(!length(rows)) return(empty())
do.call(rbind, rows)
}
app_quality_counts <- function(report) {
statuses <- c("warning", "success")
if(is.null(report) || !is.data.frame(report) || !nrow(report)) {
return(stats::setNames(rep.int(0L, length(statuses)), statuses))
}
stats::setNames(
vapply(statuses, function(status) {
nrow(app_quality_status_report(report, status))
}, integer(1)),
statuses
)
}
app_quality_evidence <- function(row) {
parts <- character()
if(length(row$metric) && !is.na(row$metric) && nzchar(row$metric)) {
parts <- c(parts, paste0("Metric: ", row$metric))
}
if(length(row$value) && !is.na(row$value)) {
parts <- c(parts, paste0("Observed: ", signif(row$value, 5)))
}
if(length(row$threshold) && is.finite(row$threshold)) {
parts <- c(parts, paste0("Threshold: ", signif(row$threshold, 5)))
}
if(length(row$candidate_max) && is.finite(row$candidate_max)) {
candidate_label <- if(identical(row$metric, "saturated_interval_count")) {
"Detector ceiling"
} else {
"Candidate maximum"
}
parts <- c(parts, paste0(
candidate_label, ": ", signif(row$candidate_max, 5)
))
}
if(length(row$control_max) && is.finite(row$control_max)) {
parts <- c(parts, paste0(
"Control maximum: ", signif(row$control_max, 5)
))
}
if(length(row$region_min) && length(row$region_max) &&
is.finite(row$region_min) && is.finite(row$region_max)) {
parts <- c(parts, paste0(
"Region: ", format(row$region_min, trim = TRUE), "-",
format(row$region_max, trim = TRUE), " cm^-1"
))
}
if(!length(parts)) "No numeric exception was recorded." else
paste(parts, collapse = "; ")
}
app_quality_modal_content <- function(report, status) {
status <- match.arg(status, c("warning", "success"))
if(is.null(report)) {
return(tags$p("Upload a spectrum to run the quality checks."))
}
if(!is.data.frame(report)) {
stop("Quality modal content requires a data frame or NULL.", call. = FALSE)
}
rows <- app_quality_status_report(report, status)
if(!nrow(rows)) {
return(tags$p(paste0("No ", status, " findings for this spectrum.")))
}
tagList(lapply(seq_len(nrow(rows)), function(i) {
row <- rows[i, , drop = FALSE]
tags$section(
class = paste("openspecy-quality-finding", paste0(
"openspecy-quality-finding-", row$status[[1L]]
)),
`data-quality-status` = row$status[[1L]],
`data-quality-test-id` = row$test_id[[1L]],
tags$h4(gsub("_", " ", row$check[[1L]], fixed = TRUE)),
tags$p(tags$strong("Finding: "), row$description[[1L]]),
tags$p(tags$strong("Evidence: "), app_quality_evidence(row)),
if(identical(status, "warning")) {
tags$p(
tags$strong("Interpretation: "),
ifelse(
is.na(row$likely_cause[[1L]]),
"No likely cause was recorded.",
row$likely_cause[[1L]]
)
)
},
if(identical(status, "warning")) {
tags$p(tags$strong("Action: "), row$potential_fix[[1L]])
}
)
}))
}
app_format_wavenumber_ranges <- function(ranges, maximum = 4L) {
if(is.null(ranges) || !is.data.frame(ranges) || !nrow(ranges) ||
!all(c("region_min", "region_max") %in% names(ranges))) {
return("no recorded wavenumber range")
}
maximum <- suppressWarnings(as.integer(maximum))
if(length(maximum) != 1L || is.na(maximum) || maximum < 1L) maximum <- 4L
ranges <- unique(ranges[, c("region_min", "region_max"), drop = FALSE])
ranges <- ranges[
is.finite(ranges$region_min) & is.finite(ranges$region_max), , drop = FALSE
]
if(!nrow(ranges)) return("no recorded wavenumber range")
labels <- vapply(seq_len(min(nrow(ranges), maximum)), function(i) {
bounds <- sort(c(ranges$region_min[[i]], ranges$region_max[[i]]))
formatted <- format(signif(bounds, 7), trim = TRUE)
if(isTRUE(all.equal(bounds[[1L]], bounds[[2L]]))) {
paste0(formatted[[1L]], " cm^-1")
} else {
paste0(formatted[[1L]], "-", formatted[[2L]], " cm^-1")
}
}, character(1))
if(nrow(ranges) > maximum) {
labels <- c(labels, paste0("and ", nrow(ranges) - maximum, " more"))
}
paste(labels, collapse = ", ")
}
app_automatic_report <- function(
x = NULL,
diagnostics = data.frame(),
enabled = c(spike = FALSE, saturation = FALSE,
flatten = FALSE, tails = FALSE)) {
enabled_names <- c("spike", "saturation", "flatten", "tails")
enabled <- enabled[enabled_names]
enabled[is.na(enabled)] <- FALSE
enabled <- stats::setNames(as.logical(enabled), enabled_names)
recorded_state <- if(is.null(x)) NULL else
attr(x, "app_automatic_correction_state", exact = TRUE)
if(is.logical(recorded_state) &&
all(c("spike", "saturation") %in% names(recorded_state))) {
enabled[c("spike", "saturation")] <-
recorded_state[c("spike", "saturation")]
}
make_row <- function(step, label, is_enabled, applied, outcome, summary) {
data.frame(
step = step,
label = label,
enabled = isTRUE(is_enabled),
applied = isTRUE(applied),
outcome = outcome,
summary = summary,
stringsAsFactors = FALSE
)
}
attr_or_null <- function(name) {
if(is.null(x)) NULL else attr(x, name, exact = TRUE)
}
attr_row <- function(step, label, is_enabled, diagnostic,
applied_summary, clean_summary) {
if(!isTRUE(is_enabled)) {
return(make_row(step, label, FALSE, FALSE, "disabled",
"This automatic correction is disabled."))
}
if(is.null(x)) {
return(make_row(step, label, TRUE, FALSE, "pending",
"Upload spectra to run this automatic check."))
}
if(is.null(diagnostic)) {
return(make_row(step, label, TRUE, FALSE, "not_needed", clean_summary))
}
if(isTRUE(diagnostic$applied)) {
return(make_row(step, label, TRUE, TRUE, "applied",
applied_summary(diagnostic)))
}
rejected <- if(is.data.frame(diagnostic$rejected_regions)) {
diagnostic$rejected_regions
} else data.frame()
rejection_detail <- if(nrow(rejected) && "reason" %in% names(rejected)) {
paste0(
"; across correction passes, safeguards left ", nrow(rejected),
" candidate region",
if(nrow(rejected) == 1L) "" else "s", " unchanged (",
paste(unique(gsub("_", " ", rejected$reason, fixed = TRUE)),
collapse = ", "), ")"
)
} else ""
make_row(
step, label, TRUE, FALSE, "rejected",
paste0(
"A candidate correction was not applied (",
gsub("_", " ", as.character(diagnostic$reason), fixed = TRUE),
rejection_detail, ")."
)
)
}
spike <- attr_or_null("automatic_spike")
saturation <- attr_or_null("saturation_restriction")
rows <- list(
attr_row(
"spike", "Spike correction", enabled[["spike"]], spike,
function(value) {
corrected_count <- nrow(value$corrected_regions)
rejected <- if(is.data.frame(value$rejected_regions)) {
value$rejected_regions
} else data.frame()
remaining <- if(nrow(rejected)) paste0(
" Across correction passes, safeguards left ", nrow(rejected),
" candidate region",
if(nrow(rejected) == 1L) "" else "s", " unchanged (",
paste(unique(gsub("_", " ", rejected$reason, fixed = TRUE)),
collapse = ", "), ")."
) else ""
paste0(
"Corrected ", corrected_count, " spike region",
if(corrected_count == 1L) "" else "s", " across ",
length(value$affected_spectra), " spectrum",
if(length(value$affected_spectra) == 1L) "" else "s", " at ",
app_format_wavenumber_ranges(value$corrected_regions), ".",
remaining
)
},
"No correctable spike regions were detected."
),
attr_row(
"saturation", "Saturation restriction", enabled[["saturation"]],
saturation,
function(value) paste0(
"Removed ", value$excluded_interval_count, " shared saturated range",
if(value$excluded_interval_count == 1L) "" else "s", " at ",
app_format_wavenumber_ranges(value$excluded_ranges), " (",
signif(100 * value$saturation_loss_fraction, 3),
"% of the wavenumber span)."
),
"No shared saturated ranges were detected."
)
)
range_row <- function(step, check, label, is_enabled) {
if(!isTRUE(is_enabled)) {
return(make_row(step, label, FALSE, FALSE, "disabled",
"This automatic correction is disabled."))
}
if(is.null(x)) {
return(make_row(step, label, TRUE, FALSE, "pending",
"Upload spectra to run this automatic check."))
}
row <- if(is.data.frame(diagnostics) && nrow(diagnostics)) {
diagnostics[diagnostics$check == check, , drop = FALSE]
} else data.frame()
if(!nrow(row)) {
return(make_row(step, label, TRUE, FALSE, "not_needed",
"No automatic correction was necessary."))
}
row <- row[nrow(row), , drop = FALSE]
total <- row$total_spectra[[1L]]
before <- total - row$before_passes[[1L]]
after <- total - row$after_passes[[1L]]
comparison <- paste0(
"Problematic spectra: ", before, " of ", total, " before; ",
after, " of ", total, " after the candidate correction."
)
if(isTRUE(row$accepted[[1L]])) {
numeric_field <- function(name) {
if(!name %in% names(row)) return(NA_real_)
suppressWarnings(as.numeric(row[[name]][[1L]]))
}
format_range <- function(minimum, maximum) paste0(
format(signif(minimum, 7), trim = TRUE), "-",
format(signif(maximum, 7), trim = TRUE), " cm^-1"
)
applied_min <- numeric_field("applied_range_min")
applied_max <- numeric_field("applied_range_max")
original_min <- numeric_field("original_range_min")
original_max <- numeric_field("original_range_max")
range_detail <- if(identical(step, "flatten") &&
all(is.finite(c(applied_min, applied_max)))) {
paste0("Flattened ", format_range(applied_min, applied_max), ".")
} else if(identical(step, "tails") &&
all(is.finite(c(
original_min, original_max, applied_min, applied_max
)))) {
paste0(
"Restricted the shared wavenumber axis from ",
format_range(original_min, original_max), " to ",
format_range(applied_min, applied_max), "."
)
} else {
"The corrected range was retained."
}
return(make_row(step, label, TRUE, TRUE, "applied", paste(
range_detail, comparison, "The improved correction was retained."
)))
}
if(identical(row$reason[[1L]], "no_failures")) {
return(make_row(step, label, TRUE, FALSE, "not_needed", paste(
comparison, "No correction was necessary."
)))
}
detail <- if(nzchar(row$message[[1L]])) {
paste0(" ", row$message[[1L]])
} else ""
make_row(step, label, TRUE, FALSE, "rejected", paste0(
comparison, " The candidate was not retained (",
gsub("_", " ", row$reason[[1L]], fixed = TRUE), ").", detail
))
}
rows[[3L]] <- range_row(
"flatten", "co2_region", "CO2 flattening", enabled[["flatten"]]
)
rows[[4L]] <- range_row(
"tails", "high_tail", "High-tail range restriction", enabled[["tails"]]
)
do.call(rbind, rows)
}
app_automatic_modal_content <- function(report) {
if(is.null(report) || !is.data.frame(report) || !nrow(report)) {
return(tags$p("Upload spectra to review automatic corrections."))
}
tagList(lapply(seq_len(nrow(report)), function(i) {
row <- report[i, , drop = FALSE]
tags$section(
class = paste(
"openspecy-quality-finding openspecy-quality-finding-automatic",
paste0("openspecy-automatic-outcome-", row$outcome[[1L]]),
if(isTRUE(row$applied[[1L]])) "openspecy-automatic-applied" else ""
),
tags$h4(row$label[[1L]]),
tags$p(tags$strong("Status: "),
gsub("_", " ", row$outcome[[1L]], fixed = TRUE)),
tags$p(tags$strong("Details: "), row$summary[[1L]])
)
}))
}
app_summary_row <- function(items) {
if(!is.list(items)) {
stop("Summary items must be supplied as a list.", call. = FALSE)
}
items <- Filter(function(item) !is.null(item), items)
count <- length(items)
if(count == 0L) return(NULL)
widths <- rep.int(12L %/% count, count)
remainder <- 12L %% count
if(remainder > 0L) {
widths[seq_len(remainder)] <- widths[seq_len(remainder)] + 1L
}
columns <- Map(
function(item, width) {
shiny::column(width, class = "openspecy-summary-panel", item)
},
items,
widths
)
do.call(
shiny::fluidRow,
c(list(class = "openspecy-summary-grid"), unname(columns))
)
}
# Even color steps across an integer 1..length(colors) domain, for indexed
# (categorical/binary) plotly heatmap traces.
app_indexed_colorscale <- function(colors) {
count <- length(colors)
if (!count) return(list(c(0, app_theme$muted), c(1, app_theme$muted)))
if (count == 1L) return(list(c(0, unname(colors[[1L]])),
c(1, unname(colors[[1L]]))))
centers <- seq(0, 1, length.out = count)
edges <- c(0, (centers[-1L] + centers[-count]) / 2, 1)
unlist(lapply(seq_len(count), function(i) {
list(c(edges[[i]], unname(colors[[i]])),
c(edges[[i + 1L]], unname(colors[[i]])))
}), recursive = FALSE)
}
# Per-cell hover text for a heatmap-family plot-data list. Returns a
# character matrix with the same dims as t(data$z), matching plotly's
# column-major (x-major) layout for a transposed z matrix.
app_heatmap_hover_text <- function(data, legend_title, levels = NULL) {
xs <- data$x
ys <- data$y
axis_unit <- if(isTruthy(data$axis_unit)) data$axis_unit else "pixel"
z_t <- t(data$z)
z_label <- if (!is.null(levels)) {
ifelse(is.na(z_t), NA_character_, levels[z_t])
} else {
ifelse(is.na(z_t), NA_character_, format(signif(z_t, 3), trim = TRUE))
}
value_line <- ifelse(
is.na(z_label), "no data", paste0(legend_title, ": ", z_label)
)
matrix(
paste0("x (", axis_unit, "): ", rep(xs, each = length(ys)),
"<br>y (", axis_unit, "): ",
rep(ys, times = length(xs)), "<br>", value_line),
nrow = length(ys), ncol = length(xs)
)
}
# Render one automate_particle_analysis() plot-data list (see
# R/automate_particle_analysis.R) as a themed, interactive plotly object.
# Uses the shared heatmapA/MyPlotC Plotly theme: a heatmap trace
# (hover-only metadata, no click popover) plus a second, always-present
# plus an optional registered raster in Plotly's explicit above-trace image
# layer. A selected cell is drawn in the still-higher shape layer. `select` is
# the currently selected point's data coordinates (list(x=, y=)) or NULL.
app_particle_plotly <- function(data, source = "heat_plot", select = NULL) {
if (is.null(data) || identical(data$type, "empty")) {
reason <- if (!is.null(data$reason)) data$reason else "no data available"
plot <- plotly::plot_ly(source = source) |>
plotly::layout(
annotations = list(list(
text = reason, showarrow = FALSE, x = 0.5, y = 0.5,
xref = "paper", yref = "paper",
font = list(color = app_plot_palette$text, size = 13)
)),
xaxis = list(visible = FALSE), yaxis = list(visible = FALSE)
) |>
app_style_plotly()
return(plotly::event_register(plot, "plotly_click"))
}
if (identical(data$type, "histogram")) {
finite_values <- data$values[is.finite(data$values)]
data_range <- if (length(finite_values)) range(finite_values) else c(0, 1)
clamped_thresholds <- pmin(
pmax(data$thresholds[is.finite(data$thresholds)], data_range[1L]),
data_range[2L]
)
plot <- plotly::plot_ly(
x = data$values, type = "histogram",
marker = list(color = app_plot_palette$primary), source = source
) |>
plotly::layout(
xaxis = list(title = data$xlab, range = data_range),
yaxis = list(title = "Count"),
shapes = lapply(clamped_thresholds, function(v) list(
type = "line", x0 = v, x1 = v, y0 = 0, y1 = 1, yref = "paper",
line = list(color = app_theme$reference, width = 2, dash = "dash")
))
) |>
app_style_plotly()
return(plot)
}
legend_title <- if (isTruthy(data$legend_title)) data$legend_title else
"Value"
categorical <- data$type %in% c("heatmap_binary", "heatmap_categorical")
levels <- NULL
if (identical(data$type, "heatmap_binary")) {
z <- t(data$z) + 1L
levels <- data$labels
colorscale <- app_indexed_colorscale(
c(app_theme$panel_2, app_theme$accent)
)
} else if (identical(data$type, "heatmap_categorical")) {
z <- t(data$z)
levels <- data$levels
colors <- if (!is.null(data$palette)) data$palette[levels] else
app_category_palette(levels)
colorscale <- app_indexed_colorscale(colors[levels])
} else {
z <- t(data$z)
colorscale <- app_heatmap_colorscale
}
# A continuous z matrix with no finite values (e.g. every pixel currently
# rejected for this metric) leaves Plotly's automatic domain detection
# nothing to work with, which throws "wasn't able to determine range of
# domain" instead of just rendering an empty/fully-masked map.
continuous_range <- if (categorical) {
c(NA_real_, NA_real_)
} else {
finite_z <- z[is.finite(z)]
if (length(finite_z)) {
range(finite_z)
} else {
c(0, 1)
}
}
if (!categorical && continuous_range[[1L]] == continuous_range[[2L]]) {
continuous_range <- continuous_range + c(-0.5, 0.5)
}
hover_text <- app_heatmap_hover_text(data, legend_title, levels)
rejected <- if(is.null(data$rejected)) {
matrix(NA_real_, nrow = nrow(data$z), ncol = ncol(data$z))
} else {
data$rejected
}
rejected_z <- t(ifelse(is.na(rejected) | rejected == 0, NA_real_, 1))
rejected_reason <- if(is.null(data$rejection_reason)) {
matrix("active threshold", nrow = nrow(data$z), ncol = ncol(data$z))
} else {
data$rejection_reason
}
rejected_text <- t(ifelse(
is.na(rejected) | rejected == 0,
NA_character_,
paste0("Rejected: ", rejected_reason)
))
legend_layout <- app_heatmap_legend_layout(legend_title)
axis_unit <- if(isTruthy(data$axis_unit)) data$axis_unit else "pixel"
overlay_opacity <- suppressWarnings(as.numeric(data$overlay_opacity))
if(length(overlay_opacity) != 1L || !is.finite(overlay_opacity)) {
overlay_opacity <- 1
}
overlay_opacity <- pmin(pmax(overlay_opacity, 0), 1)
plot <- plotly::plot_ly(source = source) |>
plotly::add_trace(
x = data$x, y = data$y, z = z, type = "heatmap",
colorscale = colorscale,
zmin = if (categorical) 0.5 else continuous_range[[1L]],
zmax = if (categorical) length(levels) + 0.5 else continuous_range[[2L]],
showscale = FALSE,
hoverinfo = "text", text = hover_text, hoverongaps = FALSE
) |>
plotly::add_trace(
x = data$x, y = data$y, z = rejected_z, type = "heatmap",
colorscale = list(c(0, "#000000"), c(1, "#000000")),
zmin = 0, zmax = 1, showscale = FALSE,
hoverinfo = "text", text = rejected_text, hoverongaps = FALSE,
name = "Rejected"
)
layout_images <- list()
if(!is.null(data$visual_image) && length(dim(data$visual_image)) == 3L) {
image <- pmin(pmax(data$visual_image, 0), 1)
layout_images <- list(app_visual_layout_image(
data$x, data$y, image, overlay_opacity
))
}
selection_shape <- app_selection_shape(data$x, data$y, select)
layout_shapes <- if(is.null(selection_shape)) list() else list(selection_shape)
plot <- plot |>
plotly::layout(
xaxis = list(title = paste0("X (", axis_unit, ")")),
yaxis = list(title = paste0("Y (", axis_unit, ")"),
scaleanchor = "x", scaleratio = 1),
images = layout_images, shapes = layout_shapes,
showlegend = FALSE, margin = legend_layout$margin
) |>
app_style_plotly()
plotly::event_register(plot, "plotly_click")
}
app_style_plotly <- function(plot) {
plotly::layout(
plot,
plot_bgcolor = app_plot_palette$panel,
paper_bgcolor = app_plot_palette$panel,
font = list(color = app_plot_palette$text),
xaxis = list(
gridcolor = app_plot_palette$grid,
zerolinecolor = app_plot_palette$grid,
linecolor = app_plot_palette$axis,
tickcolor = app_plot_palette$axis
),
yaxis = list(
gridcolor = app_plot_palette$grid,
zerolinecolor = app_plot_palette$grid,
linecolor = app_plot_palette$axis,
tickcolor = app_plot_palette$axis
),
hoverlabel = list(
bgcolor = app_theme$panel_2,
bordercolor = app_plot_palette$axis,
font = list(color = app_plot_palette$text)
)
)
}
app_spectrum_legend_layout <- function(plot_width = NULL,
model_overlay = FALSE) {
width <- suppressWarnings(as.numeric(plot_width))
width <- if(length(width)) width[[1L]] else NA_real_
if(!is.finite(width)) width <- 900
compact <- width < 640
list(
legend = list(
orientation = "h", x = 0, xanchor = "left",
y = 1.03, yanchor = "bottom", traceorder = "normal"
),
margin = list(
t = 92,
r = if(isTRUE(model_overlay)) {
if(compact) 92 else 112
} else 24,
b = 64,
l = if(compact) 62 else 72
)
)
}
# Find derivative-zero maxima on exactly one displayed processed spectrum.
# A flat-topped peak is represented by the middle sample of the zero-difference
# plateau bracketed by a positive and then negative first difference.
app_peak_positions <- function(x, top_n = 7L) {
if(!inherits(x, "OpenSpecy") || ncol(x$spectra) != 1L) {
stop("Peak positions require exactly one OpenSpecy spectrum.",
call. = FALSE)
}
top_n <- suppressWarnings(as.integer(top_n))
if(length(top_n) != 1L || is.na(top_n) || top_n < 1L || top_n > 20L) {
stop("'top_n' must be an integer from 1 through 20.", call. = FALSE)
}
y <- as.numeric(x$spectra[, 1L])
wn <- as.numeric(x$wavenumber)
if(length(y) < 3L) return(data.frame(
index = integer(), wavenumber = numeric(), intensity = numeric(),
rank = integer(), label = character()
))
delta <- diff(y)
candidates <- integer()
i <- 1L
while(i < length(delta)) {
if(is.finite(delta[[i]]) && delta[[i]] > 0) {
j <- i + 1L
while(j <= length(delta) && is.finite(delta[[j]]) &&
delta[[j]] == 0) j <- j + 1L
if(j <= length(delta) && is.finite(delta[[j]]) && delta[[j]] < 0) {
candidates <- c(candidates, as.integer(floor((i + 1L + j) / 2L)))
i <- j
}
}
i <- i + 1L
}
candidates <- candidates[
is.finite(y[candidates]) & is.finite(wn[candidates]) &
candidates > 1L & candidates < length(y)
]
if(!length(candidates)) return(data.frame(
index = integer(), wavenumber = numeric(), intensity = numeric(),
rank = integer(), label = character()
))
ordered <- candidates[order(-y[candidates], wn[candidates], candidates,
method = "radix")]
ordered <- head(ordered, top_n)
data.frame(
index = ordered, wavenumber = wn[ordered], intensity = y[ordered],
rank = seq_along(ordered),
label = format(round(wn[ordered], 1L), trim = TRUE, nsmall = 0),
stringsAsFactors = FALSE
)
}
app_spectrum_plot <- function(active, raw = NULL, reference = NULL,
model = NULL, model_class = NULL,
peaks = NULL,
make_rel = FALSE, source = "B",
plot_width = NULL) {
prepare_trace <- function(x, normalize = FALSE) {
if(is.null(x)) return(NULL)
x <- as_OpenSpecy(x)
if(isTRUE(normalize)) x <- OpenSpecy::make_rel(x, na.rm = TRUE)
if(ncol(x$spectra) < 1L) return(NULL)
data.frame(
wavenumber = x$wavenumber,
intensity = as.numeric(as.matrix(x$spectra)[, 1L])
)
}
add_spectrum <- function(plot, values, name, color, width, dash = "solid") {
if(is.null(values)) return(plot)
plotly::add_trace(
plot,
data = values,
x = ~wavenumber,
y = ~intensity,
type = "scatter",
mode = "lines",
name = name,
legendgroup = name,
showlegend = TRUE,
line = list(color = color, width = width, dash = dash),
hovertemplate = paste0(
name, "<br>%{x:.1f} cm<sup>-1</sup><br>",
"%{y:.4g}<extra></extra>"
),
inherit = FALSE
)
}
plot <- plotly::plot_ly(source = source)
has_weight_overlay <- FALSE
if(!is.null(model) && isTruthy(model_class)) {
weights <- tryCatch(
OpenSpecy::model_class_weights(model, model_class),
error = function(error) NULL
)
if(!is.null(weights) && nrow(weights)) {
has_weight_overlay <- TRUE
display_model_class <- app_standardize_material_class(model_class)
limit <- max(abs(weights$weight), na.rm = TRUE)
if(!is.finite(limit) || limit == 0) limit <- 1
plot <- plotly::add_trace(
plot,
x = weights$wavenumber, y = c(0, 1),
z = rbind(weights$weight, weights$weight),
type = "heatmap", yaxis = "y2",
colorscale = list(
c(0, "#d73027"), c(0.5, "#fee08b"), c(1, "#1a9850")
),
zmin = -limit, zmax = limit, zmid = 0, opacity = 0.28,
legendgroup = "logistic_weight", showlegend = FALSE,
showscale = TRUE,
colorbar = list(
title = "Logistic<br>weight", thickness = 12,
x = 1.02, xanchor = "left", xpad = 8,
y = 0.5, yanchor = "middle", len = 0.86
),
hovertemplate = paste0(
"%{x:.1f} cm<sup>-1</sup><br>weight %{z:.4g}<extra>",
display_model_class, "</extra>"
),
inherit = FALSE
)
plot <- plotly::add_trace(
plot,
x = weights$wavenumber[[1L]], y = 2, yaxis = "y2",
type = "scatter", mode = "markers",
name = "Logistic weight", legendgroup = "logistic_weight",
showlegend = TRUE,
marker = list(color = "#1a9850", size = 9, symbol = "square"),
hoverinfo = "skip", inherit = FALSE
)
}
}
plot <- add_spectrum(
plot, prepare_trace(raw, normalize = make_rel), "Raw spectrum",
"rgba(203, 213, 225, 0.24)", 1.2
)
plot <- add_spectrum(
# Normalization is display-only; quantification continues to use the
# canonical processed values even when all plotted traces are rescaled.
plot, prepare_trace(active, normalize = make_rel), "Active spectrum",
app_plot_palette$spectrum, 2.4
)
plot <- add_spectrum(
plot, prepare_trace(reference, normalize = make_rel),
"Identification match",
app_plot_palette$reference, 2.2, "dot"
)
if(!is.null(peaks) && nrow(peaks)) {
plot <- plotly::add_trace(
plot, data = peaks, x = ~wavenumber, y = ~intensity,
type = "scatter", mode = "markers", name = "Peak positions",
marker = list(color = app_plot_palette$peak, size = 8,
line = list(color = app_plot_palette$panel, width = 1)),
hovertemplate = paste0(
"Peak rank %{customdata}<br>%{x:.1f} cm<sup>-1</sup><br>",
"%{y:.4g}<extra></extra>"
),
customdata = ~rank, inherit = FALSE
)
}
legend_layout <- app_spectrum_legend_layout(
plot_width, model_overlay = has_weight_overlay
)
legend <- c(
legend_layout$legend,
list(
bgcolor = "rgba(11, 25, 41, 0.82)",
bordercolor = app_plot_palette$grid,
borderwidth = 1,
font = list(color = app_plot_palette$text),
groupclick = "togglegroup"
)
)
plotly::layout(
plot,
xaxis = list(
title = "wavenumber [cm<sup>-1</sup>]",
autorange = "reversed"
),
yaxis = list(title = "intensity [-]"),
yaxis2 = list(overlaying = "y", range = c(0, 1), visible = FALSE,
fixedrange = TRUE),
legend = legend,
margin = legend_layout$margin
)
}
app_empty_spectrum_plot <- function(
message = "Upload some data to get started."
) {
annotation <- if(isTruthy(message)) list(list(
text = as.character(message)[[1L]], x = 0.5, y = 0.5,
xref = "paper", yref = "paper", showarrow = FALSE,
font = list(color = app_theme$muted, size = 18)
)) else list()
plotly::plot_ly(x = numeric(), y = numeric(),
type = "scatter", mode = "lines") |>
plotly::layout(
xaxis = list(title = "wavenumber [cm<sup>-1</sup>]",
range = c(4000, 400)),
yaxis = list(title = "intensity [-]", range = c(0, 1)),
annotations = annotation
) |>
app_style_plotly()
}
# App metadata ----
metadata_file <- ".openspecy-shiny-metadata.rds"
read_app_metadata <- function(path = metadata_file) {
if (!file.exists(path)) {
return(NULL)
}
tryCatch(readRDS(path), error = function(...) NULL)
}
build_version_display <- function(metadata) {
default_href <- "https://github.com/Moore-Institute-4-Plastic-Pollution-Res/openspecy?tab=readme-ov-file#version-history"
default_text <- paste0("Last Updated: ", format(Sys.Date()))
default_title <- "Click here to view older versions of this app"
if (is.null(metadata)) {
return(list(text = default_text, href = default_href, title = default_title))
}
commit <- metadata$commit
ref <- metadata$ref
owner <- metadata$owner
repo <- metadata$repo
downloaded_time <- metadata$downloaded_at
text <- paste0("App metadata date: ", downloaded_time)
commit_display <- NULL
if (!is.null(commit)) {
commit_display <- substr(commit, 1, min(nchar(commit), 7))
text <- paste0(text, " • Commit ", commit_display)
}
href <- default_href
if (!is.null(owner) && !is.null(repo)) {
href <- sprintf("https://github.com/%s/%s/commits", owner, repo)
if (!is.null(ref)) {
href <- sprintf("%s/%s", href, utils::URLencode(ref, reserved = TRUE))
}
}
title <- default_title
if (!is.null(downloaded_time) || !is.null(commit)) {
parts <- c()
if (!is.null(downloaded_time)) {
parts <- c(parts, paste0("App metadata date ", downloaded_time))
}
if (!is.null(commit)) {
parts <- c(parts, paste0("Commit ", commit))
}
if (length(parts)) {
title <- paste(parts, collapse = " — ")
}
}
list(text = text, href = href, title = title)
}
app_metadata <- read_app_metadata()
app_version_display <- build_version_display(app_metadata)
# The app now ships inside the OpenSpecy package. Override the historical
# remote-download metadata with package release metadata.
build_version_display <- function() {
package_version <- tryCatch(
as.character(utils::packageVersion("OpenSpecy")),
error = function(...) "development"
)
list(
text = paste0("OpenSpecy ", package_version),
href = "https://github.com/wincowgerDEV/OpenSpecy-package/releases",
title = "Click here to view OpenSpecy package releases"
)
}
app_version_display <- build_version_display()
app_library_dir <- function() {
configured <- Sys.getenv("OPENSPECY_SHINY_LIBRARY_PATH", "")
if (!nzchar(configured)) {
configured <- shiny::getShinyOption("library_path", default = "")
}
dir <- if (nzchar(configured) && !identical(configured, "system")) {
configured
} else {
file.path(tools::R_user_dir("OpenSpecy", "cache"),
"reference_libraries")
}
dir.create(dir, recursive = TRUE, showWarnings = FALSE)
dir
}
app_wasm_library_types <- function() {
configured <- getOption("openspecy.shiny.wasm.libraries", character())
if (length(configured)) return(configured)
c("medoid_derivative", "medoid_nobaseline",
"model_derivative", "model_nobaseline")
}
app_library_type_choices <- function() {
if (app_wasm_mode()) {
return(c("Medoid" = "medoid", "Multinomial" = "model"))
}
c("Full" = "full", "Medoid" = "medoid", "Multinomial" = "model")
}
app_reference_spectrum_types <- c("ftir", "raman", "nir")
# New reference artifacts are keyed by spectrum type because their supported
# axes differ. A specific selection takes one member. "all" combines real
# libraries onto their full union axis (with intentional NA padding), while
# model artifacts remain a typed set so each model can use its own axis/fill.
app_select_library_spectrum_type <- function(artifact,
spectrum_type = "all") {
spectrum_type <- match.arg(
spectrum_type, c("all", app_reference_spectrum_types)
)
if(is_OpenSpecy(artifact)) return(artifact)
if(!is.list(artifact)) {
stop("The selected reference artifact has an unsupported structure.",
call. = FALSE)
}
available <- intersect(app_reference_spectrum_types, names(artifact))
if(!length(available)) {
if(all(c("model", "dimension_conversion") %in% names(artifact))) {
# Compatibility for pre-type-split model artifacts. They cannot supply
# NIR, but remain usable until the new typed artifact is installed.
return(artifact)
}
stop("The selected reference artifact has no FTIR, Raman, or NIR member.",
call. = FALSE)
}
if(!identical(spectrum_type, "all")) {
selected <- artifact[[spectrum_type]]
if(is.null(selected)) {
stop("The selected reference artifact has no '", spectrum_type,
"' member.", call. = FALSE)
}
return(selected)
}
typed <- artifact[available]
if(all(vapply(typed, is_OpenSpecy, logical(1)))) {
combined <- c_spec(unname(typed), range = "full", res = 6)
attr(combined, "openspecy_spectrum_types") <- available
return(combined)
}
structure(typed, class = c("openspecy_typed_models", "list"))
}
app_classify_model_library <- function(x, library, top_n = 5L) {
classify_one <- function(model) {
fill <- model$fill
model_axis <- if(is_OpenSpecy(fill)) {
fill$wavenumber
} else {
suppressWarnings(as.numeric(unique(model$all_variables)))
}
model_axis <- model_axis[is.finite(model_axis)]
overlap <- if(length(model_axis)) {
x$wavenumber >= min(model_axis) & x$wavenumber <= max(model_axis)
} else logical()
if(!length(model_axis) || sum(overlap, na.rm = TRUE) < 2L) {
return(NULL)
}
if(!is_OpenSpecy(fill)) {
fallback <- mean(x$spectra[is.finite(x$spectra)], na.rm = TRUE)
if(!is.finite(fallback)) fallback <- 0
fill <- as_OpenSpecy(
model_axis,
spectra = data.frame(fill = rep.int(fallback, length(model_axis)))
)
}
data <- conform_spec(
x, range = fill$wavenumber, res = NULL, allow_na = TRUE
)
match_spec(
data, library = model, na.rm = TRUE, fill = fill, top_n = top_n
)
}
if(!inherits(library, "openspecy_typed_models")) {
result <- classify_one(library)
if(is.null(result)) {
stop("The selected model range does not overlap the uploaded spectrum.",
call. = FALSE)
}
return(result)
}
predictions <- lapply(names(library), function(type) {
result <- classify_one(library[[type]])
if(is.null(result)) return(NULL)
result$spectrum_type <- type
result$.type_order <- match(type, app_reference_spectrum_types)
result
})
predictions <- Filter(Negate(is.null), predictions)
if(!length(predictions)) {
stop("None of the FTIR, Raman, or NIR model ranges overlap the uploaded spectrum.",
call. = FALSE)
}
candidates <- data.table::rbindlist(predictions, use.names = TRUE, fill = TRUE)
data.table::setorder(candidates, x, -value, .type_order, name, na.last = TRUE)
result <- candidates[, head(.SD, top_n), by = x]
result[, rank := seq_len(.N), by = x]
result[, .type_order := NULL]
data.table::setorder(result, x)
result
}
app_validate_library_type <- function(type) {
if (app_wasm_mode() && !type %in% app_wasm_library_types()) {
stop(
"The WebAssembly app only includes medoid and model libraries. ",
"Requested unsupported library: ", type,
call. = FALSE
)
}
invisible(TRUE)
}
load_app_library <- function(type) {
app_validate_library_type(type)
installed_library <- tryCatch(
load_lib(type),
error = function(e) e
)
if (!inherits(installed_library, "error")) {
return(installed_library)
}
library_path <- app_library_dir()
cached_library <- tryCatch(
load_lib(type, path = library_path),
error = function(e) e
)
if (!inherits(cached_library, "error")) {
return(cached_library)
}
download_result <- tryCatch(
get_lib(type, path = library_path),
error = function(e) e,
warning = function(w) w
)
if (inherits(download_result, c("error", "warning"))) {
stop(
"Unable to load the Open Specy reference library '", type,
"' from the installed package or app cache, and downloading it failed: ",
conditionMessage(download_result),
". Run get_lib(\"", type, "\") before run_app(), or check your ",
"network connection.",
call. = FALSE
)
}
load_lib(type, path = library_path)
}
# Helper to create collapsible footnotes ----
footnote <- function(summary, ...) {
content <- list(...)
has_content <- length(content) && any(vapply(content, function(item) {
text <- trimws(gsub("<[^>]+>", "", paste(as.character(item),
collapse = " ")))
nzchar(text)
}, logical(1)))
if(!has_content) {
stop("Information disclosures require substantive details.",
call. = FALSE)
}
tags$details(
class = "openspecy-info-details",
tags$summary(summary),
tags$div(
class = "openspecy-info-details-body",
lapply(content, tags$p)
)
)
}
# Load all data ----
load_data <- function() {
data("raman_hdpe")
intensity <- if(is.data.frame(raman_hdpe$spectra)) {
raman_hdpe$spectra$intensity
} else {
as.numeric(raman_hdpe$spectra[, 1])
}
testdata <- data.table(wavenumber = raman_hdpe$wavenumber,
intensity = intensity)
# Inject variables into the parent environment
invisible(list2env(as.list(environment()), parent.frame()))
}
# Name keys for human readable column names ----
version <- paste0("Open Specy v", packageVersion("OpenSpecy"))
citation <- HTML(
'Cowger, W., Karapetrova, A., Lincoln, C., Chamas, A., Sherrod, H., Leong, N., Lasdin, K. S.,
Knauss, C., Teofilović, V., Arienzo, M. M., Steinmetz, Z., Primpke, S.,
Darjany, L., Murphy-Hagan, C., Moore, S., Moore, C., Lattin, G.,
Gray, A., Kozloski, R., Bryksa, J., Maurer, B. (2025).
"Open Specy 1.0: Automated (Hyper)spectroscopy for Microplastics."
<i>Analytical Chemistry.</i> doi:
<a href="https://doi.org/10.1021/acs.analchem.5c00962">10.1021/acs.analchem.5c00962</a>.'
)
# Define the custom theme
theme_black_minimal <- function(base_size = 11, base_family = "") {
theme_minimal(base_size = base_size, base_family = base_family) +
theme(
plot.background = element_rect(fill = app_plot_palette$panel,
color = app_plot_palette$axis,
linewidth = 0.6),
panel.background = element_rect(fill = app_plot_palette$panel,
color = NA),
panel.border = element_rect(fill = NA, color = app_plot_palette$axis,
linewidth = 0.5),
panel.grid.major = element_line(color = app_plot_palette$grid,
linewidth = 0.35),
panel.grid.minor = element_blank(),
axis.line = element_line(color = app_plot_palette$axis),
axis.ticks = element_line(color = app_plot_palette$axis),
axis.text = element_text(color = app_plot_palette$text),
axis.title = element_text(color = app_plot_palette$text),
plot.title = element_text(color = app_plot_palette$text, hjust = 0.5),
plot.subtitle = element_text(color = app_plot_palette$text, hjust = 0.5),
plot.caption = element_text(color = app_plot_palette$text),
legend.text = element_text(color = app_plot_palette$text),
legend.title = element_text(color = app_plot_palette$text),
legend.background = element_rect(fill = app_plot_palette$panel,
color = NA),
legend.key = element_rect(fill = app_plot_palette$panel, color = NA),
strip.background = element_rect(fill = app_theme$panel_2,
color = app_plot_palette$axis),
strip.text = element_text(color = app_plot_palette$text)
)
}
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.
if (file.exists("wasm-config.R")) {
source("wasm-config.R", local = TRUE)
}
app_wasm_mode <- function() {
env <- tolower(Sys.getenv("OPENSPECY_SHINY_WASM", ""))
isTRUE(getOption("openspecy.shiny.wasm", FALSE)) ||
env %in% c("1", "true", "yes", "on")
}
# Resolve local-only filesystem controls dynamically so Shinylive's dependency
# scanner does not pull shinyFiles or desktop GUI packages into WebAssembly.
app_shiny_files <- function(name) {
if(app_wasm_mode()) {
stop("Local filesystem controls are unavailable in WebAssembly mode.",
call. = FALSE)
}
getExportedValue("shinyFiles", name)
}
app_local_file_extensions <- function() {
c(
"csv", "asp", "tsv", "spc", "jdx", "dx", "RData", "spa", "0",
"zip", "img", "h5", "txt", "json", "rds", "hdr", "dat",
"jpg", "jpeg", "png"
)
}
app_native_dialog_available <- function(
os_type = .Platform$OS.type,
sysname = unname(Sys.info()[["sysname"]]),
tcltk_available = isTRUE(capabilities("tcltk")) &&
requireNamespace("tcltk", quietly = TRUE)) {
identical(os_type, "windows") ||
(identical(sysname, "Darwin") && isTRUE(tcltk_available))
}
app_choose_local_paths <- function(
chooser = NULL, os_type = .Platform$OS.type,
sysname = unname(Sys.info()[["sysname"]]),
tcltk_available = isTRUE(capabilities("tcltk")) &&
requireNamespace("tcltk", quietly = TRUE)) {
if(is.null(chooser)) {
if(identical(os_type, "windows")) {
chooser <- utils::choose.files
} else if(identical(sysname, "Darwin") && isTRUE(tcltk_available)) {
chooser <- getExportedValue("tcltk", "tk_choose.files")
} else {
stop(
"A native multi-file dialog is unavailable; use Filesystem browser.",
call. = FALSE
)
}
}
patterns <- paste0("*.", app_local_file_extensions(), collapse = ";")
filters <- matrix(
c("Spectral files", patterns, "All files", "*.*"),
ncol = 2L, byrow = TRUE,
dimnames = list(NULL, c("Description", "Extensions"))
)
selected <- chooser(
default = "", caption = "Select OpenSpecy spectral files",
multi = TRUE, filters = filters, index = 1L
)
selected <- as.character(selected)
selected <- selected[!is.na(selected) & nzchar(selected)]
if(!length(selected)) return(character())
normalizePath(selected, winslash = "/", mustWork = TRUE)
}
validate_wasm_package_version <- function() {
if (!app_wasm_mode()) return(invisible(TRUE))
expected <- getOption("openspecy.shiny.wasm.package_version", "")
actual <- as.character(utils::packageVersion("OpenSpecy"))
if (!nzchar(expected) || !identical(actual, expected)) {
commit <- getOption("openspecy.shiny.wasm.package_sha", "unknown")
stop(
"The WebAssembly app loaded OpenSpecy ", actual,
" but its pinned build requires ", expected,
" from commit ", commit, ".",
call. = FALSE
)
}
invisible(TRUE)
}
#remotes::install_github("wincowgerDEV/OpenSpecy-package@vignettes")
# Libraries ----
library(shiny)
library(shinyjs)
library(shinyWidgets)
library(dplyr)
library(plotly)
library(data.table)
library(DT)
library(digest)
#library(curl)
#library(loggit)
library(bs4Dash)
library(ggplot2)
library(reshape2)
library(OpenSpecy)
validate_wasm_package_version()
#library(glmnet)
# Shared, structured explanations for the in-place "What this changes"
# disclosures. Stable topic IDs keep guidance aligned with the controls.
app_guidance_registry <- list(
min_max_normalize = list(
title = "Min-Max Normalize",
controls = "make_rel_decision",
body = c(
"Min-Max Normalize rescales every plotted raw, active, and reference spectrum to a zero-to-one relative-intensity scale after the selected corrections, so flattening or other processing cannot leave the active trace on a different display scale.",
"Turning the owner switch off is a true no-op: uploaded intensity units and scale are retained. This can make absolute intensity differences easier to see, but magnitude may dominate visual comparisons."
)
),
smoothing_derivative = list(
title = "Smoothing / Derivative",
controls = c(
"smooth_decision", "smoother", "derivative_order",
"smoother_window", "derivative_abs"
),
body = c(
"Polynomial chooses the Savitzky-Golay polynomial order (0-5); Wavenumber Window is the smoothing width in cm^-1, where a larger window suppresses more noise but can blur narrow bands.",
"Derivative Order 0 smooths without differentiating; higher orders emphasize spectral shape changes and also amplify noise. Absolute Value folds negative derivative values above zero.",
"When Smoothing / Derivative is off, every child value is ignored. The Derivative identification library expects this switch on with order 1 and Absolute Value on; a deliberate preprocessed upload may still proceed after the Run warning."
)
),
baseline_correction = list(
title = "Baseline Correction",
controls = c(
"baseline_decision", "baseline_method", "baseline", "refit",
"baseline_lambda", "baseline_hwi", "iterations"
),
body = c(
"Modified Polynomial estimates a whole-spectrum baseline; a higher polynomial degree can follow more curvature but can also remove broad real bands. Refit performs one final fit after iterative rejection.",
"Fill Peaks uses a unitless smoothing-penalty setting plus a Local Half-Window measured in sampled wavenumber buckets; larger values produce a smoother or broader baseline estimate. Iterations controls repeated peak suppression.",
"When Baseline Correction is off, all child settings are ignored. The No Baseline identification library expects correction on and no active derivative transform; deliberately preprocessed uploads may still proceed after the Run warning."
)
),
identification_strategy = list(
title = "Identification Strategy",
controls = c(
"identification_active", "id_spec_type", "id_strategy", "lib_type",
"top_n_input", "top_n_per_organization", "filter_lib", "lib_org"
),
body = c(
"Spectrum Type limits candidate references when the measurement type is known; All searches FTIR, Raman, and NIR. Library Type trades reference detail against runtime. Top N limits retained model probabilities too; for spectral libraries, Top N per organization retains that many candidates from every selected organization and turning it off applies Top N globally.",
"Derivative requires absolute first-derivative preprocessing. No Baseline requires baseline correction and no active derivative. A mismatch can make scores scientifically misleading, so Run reports a nonblocking warning with the corrective controls.",
"Turning Identification off skips library/model loading, matching, Top Matches, and material-dependent spatial grouping. Filter Library is also a no-op while its owner switch is off."
)
),
custom_ratios = list(
title = "Custom Ratios",
controls = c(
"quant_ratio_name", "quant_ratio_type", "quant_numerator_area_min",
"quant_numerator_area_max", "quant_denominator_area_min",
"quant_denominator_area_max", "quant_numerator_peak",
"quant_denominator_peak", "quant_ratio_add"
),
body = c(
"Every saved ratio uses the same final processed spectrum shown as the primary Spectra trace; a library-reference overlay is never used as a second quantification pipeline.",
"Area ratio integrates numerator and denominator ranges in cm^-1. Peak ratio compares the nearest sampled intensities at two requested wavenumbers; narrower choices are more sensitive to axis resolution and peak-position uncertainty.",
"For a polyethylene carbonyl-area demonstration, use 1650-1850 cm^-1 over 1420-1500 cm^-1. Interpret any ratio only with a method suitable for the material, instrument, preprocessing, and a meaningful nonzero denominator."
)
)
)
app_guidance_topic <- function(topic) {
if(length(topic) != 1L || is.na(topic) || !nzchar(topic) ||
!topic %in% names(app_guidance_registry)) {
stop("Unknown app guidance topic: ", paste(topic, collapse = ", "),
call. = FALSE)
}
guidance <- app_guidance_registry[[topic]]
if(!is.list(guidance) || !isTruthy(guidance$title) ||
!length(guidance$controls) || !length(guidance$body) ||
any(!nzchar(trimws(guidance$body)))) {
stop("App guidance topic is incomplete: ", topic, call. = FALSE)
}
guidance
}
app_guidance_text <- function(topic) app_guidance_topic(topic)$body
app_tab_switch_ids <- function() {
list(
preprocessing = c(
"make_rel_decision", "smooth_decision", "conform_decision",
"intensity_decision", "baseline_decision", "range_decision",
"co2_decision", "spike_decision", "saturation_decision"
),
identification = c(
"identification_active", "filter_lib"
),
advanced = c(
"cor_threshold_decision", "threshold_decision", "collapse_decision",
"spatial_decision", "simple_metadata", "show_peak_positions",
"load_entire_map", "xy_grid"
)
)
}
app_tab_all_off_values <- function(tab) {
ids <- app_tab_switch_ids()[[tab]]
if(is.null(ids)) stop("Unknown settings tab: ", tab, call. = FALSE)
stats::setNames(rep(FALSE, length(ids)), ids)
}
app_tab_active_states <- function(settings, ratio_definitions,
measurement_definitions) {
switch_ids <- app_tab_switch_ids()
states <- vapply(switch_ids, function(ids) {
any(vapply(ids, function(id) isTRUE(settings[[id]]), logical(1)))
}, logical(1))
c(
states,
quantification = nrow(ratio_definitions) > 0L ||
nrow(measurement_definitions) > 0L
)
}
# Return Run-time compatibility notices without blocking or changing expert
# workflows. Configuration changes alone never call this helper from server.R;
# the Run observer owns presentation of the result.
app_identification_compatibility_warnings <- function(settings) {
if(!is.list(settings) || !isTRUE(settings$identification_active)) {
return(character())
}
strategy <- as.character(settings$id_strategy)[1L]
smooth <- isTRUE(settings$smooth_decision)
derivative <- suppressWarnings(as.integer(settings$derivative_order)[1L])
derivative_active <- smooth && !is.na(derivative) && derivative > 0L
messages <- character()
if(identical(strategy, "deriv") &&
(!smooth || !identical(derivative, 1L) ||
!isTRUE(settings$derivative_abs))) {
messages <- c(messages, paste(
"Derivative library compatibility: turn on Smoothing / Derivative,",
"set Derivative Order to 1, and turn on Absolute Value."
))
}
if(identical(strategy, "nobaseline") &&
(!isTRUE(settings$baseline_decision) || derivative_active)) {
messages <- c(messages, paste(
"No Baseline library compatibility: turn on Baseline Correction and",
"use Derivative Order 0 (or turn Smoothing / Derivative off)."
))
}
if(length(messages)) {
messages <- paste0(
messages,
" If the upload was deliberately preprocessed this way, you may proceed."
)
}
messages
}
app_initial_result_selection <- function(object, pixel_to_unit = NULL) {
if(is.null(object) || is.null(object$spectra) || ncol(object$spectra) < 1L) {
return(list(plot = NA_integer_, pixel = NA_integer_, table = 1L))
}
pixel <- 1L
if(!is.null(pixel_to_unit)) {
mapping <- data.table::as.data.table(pixel_to_unit)
if(all(c("kept", "unit_index", "pixel_index") %in% names(mapping))) {
candidates <- mapping[
kept & !is.na(unit_index) & unit_index == 1L,
pixel_index
]
if(length(candidates) && !is.na(candidates[[1L]])) {
pixel <- as.integer(candidates[[1L]])
}
}
}
list(plot = 1L, pixel = pixel, table = 1L)
}
# Build the full source-pixel projection used when analysis has not supplied a
# particle mapping. Specs stores source identifiers and coordinates separately
# from its compact value matrix, so treating it like an OpenSpecy object drops
# pixel_id and leaves map outputs unable to align after a Run.
app_identity_pixel_mapping <- function(object, eligible = NULL) {
compact <- is_Specs(object)
metadata <- if(compact) {
data.table::as.data.table(specs_metadata(object))
} else data.table::as.data.table(object$metadata)
coordinates <- if(compact) {
data.table::as.data.table(specs_coordinates(object))
} else NULL
ids <- if(compact) {
as.character(coordinates$source_id)
} else colnames(object$spectra)
if(is.null(ids)) ids <- paste0("pixel_", seq_len(nrow(metadata)))
count <- length(ids)
eligible <- if(is.null(eligible)) rep(TRUE, count) else as.logical(eligible)
if(length(eligible) != count) {
stop("Pixel eligibility must align with every source spectrum.",
call. = FALSE)
}
eligible[is.na(eligible)] <- FALSE
x <- if("x" %in% names(metadata)) metadata$x else if(compact &&
"x" %in% names(coordinates)) coordinates$x else seq_len(count) - 1
y <- if("y" %in% names(metadata)) metadata$y else if(compact &&
"y" %in% names(coordinates)) coordinates$y else rep(0, count)
data.table::data.table(
pixel_index = seq_len(count), pixel_id = ids,
source_id = OpenSpecy:::.particle_source_vector(metadata, count),
x = x, y = y, eligible = eligible, material = NA_character_,
region_id = ids, cluster_id = NA_character_, unit_id = ids,
unit_index = ifelse(eligible, seq_len(count), NA_integer_),
area = 1L, kept = eligible,
rejection_reason = ifelse(eligible, NA_character_, "threshold")
)
}
app_first_retained_pixel <- function(mapping) {
mapping <- data.table::as.data.table(mapping)
required <- c("pixel_index", "kept")
if(!all(required %in% names(mapping))) {
stop("Pixel mapping is missing retained-selection columns.", call. = FALSE)
}
pixels <- mapping[kept == TRUE & !is.na(pixel_index), pixel_index]
if(!length(pixels)) return(NA_integer_)
as.integer(pixels[[1L]])
}
app_selected_rank_index <- function(selected_row, row_count) {
row_count <- suppressWarnings(as.integer(row_count)[1L])
if(is.na(row_count) || row_count < 1L) return(NA_integer_)
selected_row <- suppressWarnings(as.integer(selected_row)[1L])
if(is.na(selected_row)) selected_row <- 1L
min(max(1L, selected_row), row_count)
}
app_has_clickable_heatmap <- function(data, spectrum_count) {
!is.null(data) && !identical(data$type, "empty") &&
is.finite(spectrum_count) && spectrum_count > 1L
}
app_download_choices <- function(has_upload, identification,
collapse = FALSE, compact = FALSE) {
tests <- c("Test Data", "Test Map")
metadata <- "User Metadata"
if (!isTRUE(has_upload)) return(c(tests, metadata))
choices <- if (isTRUE(identification)) {
c("Top Matches", "Processed Spectra")
} else {
"Processed Spectra"
}
if (isTRUE(compact)) choices <- c(choices, "Compact Map (RDS)")
if (isTRUE(collapse)) choices <- c(choices, "Thresholded Particles")
c(choices, tests, metadata)
}
app_download_label <- function(selection) {
labels <- c(
"Test Data" = "Download Test Data",
"Test Map" = "Download Test Map",
"Processed Spectra" = "Download Processed Spectra",
"Compact Map (RDS)" = "Download Compact Map (RDS)",
"Top Matches" = "Download Top Matches",
"Thresholded Particles" = "Download Thresholded Particles",
"User Metadata" = "Download User Metadata"
)
if(length(selection) != 1L || is.na(selection) ||
!selection %in% names(labels)) {
return("Download selected")
}
unname(labels[[selection]])
}
app_upload_limit_bytes <- function() {
10 * 1024^3
}
app_max_request_size_bytes <- function() {
app_upload_limit_bytes()
}
app_upload_limit_label <- function() {
"10 GiB"
}
app_upload_guidance <- function() {
paste0(
"The upload ceiling is ", app_upload_limit_label(),
" total. Choose fewer or smaller files and try again."
)
}
app_write_particle_archive <- function(files, destination, root) {
files <- normalizePath(files, winslash = "/", mustWork = TRUE)
root <- normalizePath(root, winslash = "/", mustWork = TRUE)
relative <- substring(files, nchar(root) + 2L)
if(!length(files) || any(!startsWith(files, paste0(root, "/"))) ||
any(!nzchar(relative))) {
stop("Particle archive files must be inside the completed output directory.",
call. = FALSE)
}
zip::zipr(destination, files = files, root = root,
include_directories = FALSE)
invisible(destination)
}
app_validate_upload_size <- function(file_info) {
limit <- app_upload_limit_bytes()
if(is.null(file_info) || (is.data.frame(file_info) && !nrow(file_info))) {
return(list(ok = TRUE, size = 0, limit = limit,
message = app_upload_guidance()))
}
if(!is.data.frame(file_info) || !"size" %in% names(file_info)) {
return(list(
ok = FALSE, size = NA_real_, limit = limit,
message = paste(
"Open Specy could not verify the selected file sizes.",
app_upload_guidance()
)
))
}
sizes <- suppressWarnings(as.numeric(file_info$size))
if(length(sizes) != nrow(file_info) || any(!is.finite(sizes) | sizes < 0)) {
return(list(
ok = FALSE, size = NA_real_, limit = limit,
message = paste(
"Every selected file must report a valid nonnegative size.",
app_upload_guidance()
)
))
}
total <- sum(sizes)
ok <- total <= limit
list(ok = ok, size = total, limit = limit,
message = app_upload_guidance())
}
app_mounted_file_info <- function(value) {
if(is.null(value) || !identical(value$transport, "workerfs")) {
stop("Mounted file metadata is missing its WORKERFS transport marker.",
call. = FALSE)
}
mount_id <- as.character(value$mount_id)
if(length(mount_id) != 1L || !grepl("^[0-9a-f]{32}$", mount_id)) {
stop("Mounted file metadata has an invalid session identifier.",
call. = FALSE)
}
fields <- lapply(c("name", "size", "type", "datapath"), function(field) {
unlist(value[[field]], use.names = FALSE)
})
names(fields) <- c("name", "size", "type", "datapath")
count <- length(fields$name)
if(!count || any(vapply(fields, length, integer(1)) != count)) {
stop("Mounted file metadata columns do not align.", call. = FALSE)
}
names_safe <- nzchar(fields$name) &
!fields$name %in% c(".", "..") &
!grepl("[\\/[:cntrl:]]", fields$name)
if(!all(names_safe) || anyDuplicated(tolower(fields$name))) {
stop("Mounted files require safe, case-insensitively unique names.",
call. = FALSE)
}
prefix <- paste0("/tmp/openspecy-upload-", mount_id, "/")
expected_paths <- paste0(prefix, fields$name)
if(!identical(as.character(fields$datapath), expected_paths)) {
stop("Mounted file paths escaped their session directory.", call. = FALSE)
}
data.frame(
name = as.character(fields$name),
size = as.numeric(fields$size),
type = as.character(fields$type),
datapath = as.character(fields$datapath),
stringsAsFactors = FALSE
)
}
app_native_file_info <- function(value) {
value <- data.frame(value, stringsAsFactors = FALSE)
required <- c("name", "size", "type", "datapath")
if (!nrow(value) || !all(required %in% names(value))) {
stop("Native file selection did not return complete file metadata.",
call. = FALSE)
}
paths <- normalizePath(value$datapath, winslash = "/", mustWork = TRUE)
if (any(file.info(paths)$isdir)) {
stop("Native selection must contain files, not directories.",
call. = FALSE)
}
if (anyDuplicated(tolower(paths))) {
stop("Selected files must be unique.", call. = FALSE)
}
value$datapath <- paths
value$size <- as.numeric(file.info(paths)$size)
value[, required, drop = FALSE]
}
app_direct_file_info <- function(paths) {
paths <- as.character(paths)
paths <- paths[!is.na(paths) & nzchar(paths)]
if(!length(paths)) return(NULL)
app_native_file_info(data.frame(
name = basename(paths), size = as.numeric(file.info(paths)$size),
type = "", datapath = paths, stringsAsFactors = FALSE
))
}
app_local_file_info <- function(value, roots) {
value <- app_native_file_info(value)
paths <- value$datapath
root_paths <- unique(normalizePath(
unname(as.character(roots)), winslash = "/", mustWork = TRUE
))
root_prefixes <- paste0(sub("/+$", "", root_paths), "/")
inside <- vapply(paths, function(path) {
any(path == root_paths | startsWith(path, root_prefixes))
}, logical(1))
if(!all(inside)) {
stop("Local file selection escaped the configured filesystem roots.",
call. = FALSE)
}
value
}
app_local_roots <- function() {
if(identical(.Platform$OS.type, "windows")) {
candidates <- paste0(LETTERS, ":/")
paths <- candidates[dir.exists(candidates)]
names(paths) <- sub(":/$", "", paths)
} else {
paths <- c(root = "/")
}
if(!length(paths)) {
stop("No readable local filesystem roots were found.", call. = FALSE)
}
stats::setNames(
normalizePath(paths, winslash = "/", mustWork = TRUE), names(paths)
)
}
# data.table::fread() memory-maps filename inputs. webR's 32-bit runtime cannot
# mmap a WORKERFS-backed browser File, even when the file itself is tiny. Feed
# direct mounted text through fread's text parser so delimiter/type inference
# and the resulting OpenSpecy format stay the same without the unsupported map.
app_workerfs_fread <- function(file, ...) {
lines <- readLines(file, warn = FALSE)
data.table::fread(text = paste(lines, collapse = "\n"), ...)
}
app_read_uploaded_members <- function(paths, mounted = FALSE,
representation = "OpenSpecy",
background_filter = NULL,
spectral_smooth = FALSE,
sigma = c(1, 1, 1)) {
paths <- as.character(paths)
image_paths <- paths[grepl("\\.(jpg|jpeg|png)$", paths, ignore.case = TRUE)]
spectral_paths <- setdiff(paths, image_paths)
if(!length(spectral_paths)) {
stop("Select a supported spectral file with the visual image.",
call. = FALSE)
}
mounted_text <- isTRUE(mounted) &
grepl("\\.(xyz|csv|tsv|txt)$", paths, ignore.case = TRUE)
read_one <- function(path, use_workerfs_text) {
if(isTRUE(use_workerfs_text)) {
read_text(file = path, method = app_workerfs_fread)
} else if(grepl("\\.(zip|h5)$", path, ignore.case = TRUE)) {
read_any(
file = path, c_spec = FALSE, representation = representation,
background_filter = background_filter,
spectral_smooth = spectral_smooth, sigma = sigma
)
} else {
read_any(file = path, c_spec = FALSE)
}
}
envi_pair <- length(spectral_paths) == 2L &&
any(grepl("\\.(dat|img)$", spectral_paths, ignore.case = TRUE)) &&
any(grepl("\\.hdr$", spectral_paths, ignore.case = TRUE))
attach_envi_image <- function(object) {
if(!envi_pair || !length(image_paths)) return(object)
binary <- spectral_paths[grepl("\\.(dat|img)$", spectral_paths,
ignore.case = TRUE)][[1L]]
stem <- tolower(tools::file_path_sans_ext(basename(binary)))
matching <- image_paths[
tolower(tools::file_path_sans_ext(basename(image_paths))) == stem
]
if(length(matching) != 1L) {
warning(
if(length(matching)) {
"Multiple basename-matched ENVI images were supplied; continuing without an overlay."
} else {
"The ENVI image basename does not match the DAT/IMG file; continuing without an overlay."
}, call. = FALSE
)
return(object)
}
detection <- tryCatch(detect_image_origin(matching[[1L]]),
error = identity)
if(inherits(detection, "error")) {
warning("Could not detect a red map boundary in ",
basename(matching[[1L]]), "; continuing without an overlay.",
call. = FALSE)
return(object)
}
add_visual_image(
object, matching[[1L]], bottom_left = detection$bottom_left,
top_right = detection$top_right,
detection_method = detection$detection_method,
diagnostics = detection$diagnostics
)
}
if(envi_pair && identical(representation, "Specs")) {
return(attach_envi_image(open_specs(spectral_paths)))
}
if(envi_pair) {
return(attach_envi_image(read_any(file = spectral_paths, c_spec = FALSE)))
}
if(length(spectral_paths) > 1L) {
mounted_spectral <- isTRUE(mounted) &
grepl("\\.(xyz|csv|tsv|txt)$", spectral_paths, ignore.case = TRUE)
return(Map(read_one, spectral_paths, mounted_spectral))
}
read_one(spectral_paths[[1L]],
isTRUE(mounted) && grepl("\\.(xyz|csv|tsv|txt)$",
spectral_paths[[1L]], ignore.case = TRUE))
}
app_upload_failure_guidance <- function(elapsed_seconds, mounted = FALSE) {
elapsed <- max(0, suppressWarnings(as.numeric(elapsed_seconds)[[1L]]))
route <- if(isTRUE(mounted)) {
paste(
"The browser mount succeeded, but full in-memory reading or allocation",
"did not. For an ENVI ZIP, try selecting the extracted HDR and DAT",
"files together to avoid ZIP extraction overhead."
)
} else {
paste(
"Local Shiny reads the selected source path directly; confirm the file",
"is still available and readable."
)
}
paste0(
"The read/materialize phase failed after ", sprintf("%.1f", elapsed),
" seconds. ", route,
" Close other memory-heavy tabs or applications before retrying."
)
}
# Vector-safe threshold truth table shared by map projection and direct tests.
# Correlation uses an inclusive minimum (equal passes); signal/noise uses strict
# interior bounds (equal to either bound fails).
app_threshold_rejection_mask <- function(values, enabled, minimum,
maximum = NULL) {
values <- suppressWarnings(as.numeric(values))
if(!isTRUE(enabled)) return(rep(FALSE, length(values)))
minimum <- suppressWarnings(as.numeric(minimum))
if(length(minimum) != 1L || is.na(minimum)) {
stop("A threshold minimum must be one numeric value.", call. = FALSE)
}
if(is.null(maximum)) return(is.na(values) | values < minimum)
maximum <- suppressWarnings(as.numeric(maximum))
if(length(maximum) != 1L || is.na(maximum)) {
stop("A threshold maximum must be one numeric value.", call. = FALSE)
}
is.na(values) | values <= minimum | values >= maximum
}
# Grid-shaped plot data for an ordinary uploaded map's heatmap (Match
# Name/ID/Value, Signal/Noise), matching the same contract.
app_ordinary_heatmap_data <- function(metadata, values, categorical,
legend_title, rejected = NULL,
rejection_reason = NULL,
axis_unit = "pixel") {
rejected <- if(is.null(rejected)) rep(FALSE, length(values)) else {
out <- as.logical(rejected)
if(length(out) != length(values)) {
stop("The heatmap threshold mask does not align with its values.",
call. = FALSE)
}
out[is.na(out)] <- FALSE
out
}
if(is.null(rejection_reason)) {
rejection_reason <- rep("active threshold", length(values))
}
if(length(rejection_reason) != length(values)) {
stop("The heatmap rejection reasons do not align with its values.",
call. = FALSE)
}
rejection_reason <- as.character(rejection_reason)
rejection_reason[!rejected] <- NA_character_
rejected_grid <- OpenSpecy:::.particle_map_grid(
metadata, ifelse(rejected, 1, NA_real_), 1, c(0, 0)
)$z
reason_levels <- unique(rejection_reason[rejected & !is.na(rejection_reason)])
reason_codes <- match(rejection_reason, reason_levels)
reason_grid <- OpenSpecy:::.particle_map_grid(
metadata, reason_codes, 1, c(0, 0)
)$z
reason_grid <- matrix(
ifelse(is.na(reason_grid), NA_character_, reason_levels[reason_grid]),
nrow = nrow(reason_grid), ncol = ncol(reason_grid)
)
if(categorical) {
values <- droplevels(values)
levels <- levels(values)
grid <- OpenSpecy:::.particle_map_grid(metadata, as.integer(values), 1,
c(0, 0))
list(type = "heatmap_categorical", x = grid$x, y = grid$y, z = grid$z,
levels = levels, legend_title = legend_title,
palette = app_category_palette(levels), rejected = rejected_grid,
rejection_reason = reason_grid, axis_unit = axis_unit)
} else {
grid <- OpenSpecy:::.particle_map_grid(metadata, values, 1, c(0, 0))
list(type = "heatmap", x = grid$x, y = grid$y, z = grid$z,
legend_title = legend_title, rejected = rejected_grid,
rejection_reason = reason_grid, axis_unit = axis_unit)
}
}
app_reference_for_query <- function(reference, query, preserve_axis = TRUE) {
if(identical(reference$wavenumber, query$wavenumber)) {
return(reference)
}
conform_spec(
reference, range = query$wavenumber, res = NULL,
# An "all" reference combines the independently ranged FTIR, Raman, and
# NIR libraries. References outside the query's support are deliberately
# NA padded and cor_spec() ignores them; rejecting those NAs here would
# make the complete-library option unusable.
allow_na = anyNA(reference$spectra),
type = if(isTRUE(preserve_axis)) "mean_up" else "roll"
)
}
app_identification_block_progress <- function(
query_count, library_count, block_size, completed_blocks = 0L,
total_blocks = NULL, progress_start = 76, progress_end = 88) {
scalar_count <- function(value, fallback = 0L) {
value <- suppressWarnings(as.integer(value)[1L])
if(is.na(value) || value < 0L) fallback else value
}
query_count <- scalar_count(query_count)
library_count <- scalar_count(library_count)
block_size <- max(1L, scalar_count(block_size, 1L))
if(is.null(total_blocks)) {
total_blocks <- as.integer(max(1L, ceiling(query_count / block_size)))
} else {
total_blocks <- max(1L, scalar_count(total_blocks, 1L))
}
completed_blocks <- min(
total_blocks, scalar_count(completed_blocks)
)
block_fraction <- completed_blocks / total_blocks
block_percent <- as.integer(floor(100 * block_fraction))
list(
message = paste0(
"Identifying spectra (", block_percent, "% of blocks complete)"
),
detail = paste0(
"Completed ", completed_blocks, " of ", total_blocks, " block",
if(total_blocks == 1L) "" else "s", " while comparing ",
format(query_count, big.mark = ","), " ",
if(query_count == 1L) "spectrum" else "spectra", " with ",
format(library_count, big.mark = ","), " references; block size ",
format(block_size, big.mark = ","), "."
),
progress = progress_start +
(progress_end - progress_start) * block_fraction,
completed_blocks = completed_blocks,
total_blocks = total_blocks,
block_percent = block_percent
)
}
app_file_stream_processing_issues <- function(settings,
spatial_smooth = FALSE) {
if(!is.list(settings)) {
stop("Streaming processing settings must be a named list.", call. = FALSE)
}
issues <- character()
if(isTRUE(settings$saturation_decision)) {
issues <- c(issues, "turn off Saturation Correction")
}
if(isTRUE(settings$co2_decision) && isTRUE(settings$co2_automate)) {
issues <- c(issues, "turn off automatic CO2 flattening")
}
if(isTRUE(settings$range_decision) && isTRUE(settings$range_automate)) {
issues <- c(issues, "turn off automatic range restriction")
}
unique(issues)
}
# Raw/Spatial signal/noise never applies Min-Max Normalize. Fully Processed
# deliberately bypasses this helper and uses the complete enabled recipe.
app_snr_processing_settings <- function(settings) {
if(!is.list(settings)) {
stop("Signal/noise processing settings must be a list.", call. = FALSE)
}
settings$make_rel_decision <- FALSE
settings
}
# Raw/Spatial signal thresholding intentionally omits the ordinary baseline,
# spectral smoothing, range, and normalization steps, but intensity units are
# not optional scientific decoration: a selected transmittance/reflectance
# conversion must happen before S/N is interpreted as absorbance-like data.
app_intensity_snr_basis <- function(x, settings) {
if(!inherits(x, "OpenSpecy") || !is.list(settings)) {
stop("Intensity-adjusted S/N requires OpenSpecy data and settings.",
call. = FALSE)
}
if(!isTRUE(settings$intensity_decision)) return(x)
type <- if(is.null(settings$intensity_corr)) "none" else
as.character(settings$intensity_corr)[[1L]]
adjusted <- adj_intens(x, type = type, make_rel = FALSE)
if(!identical(type, "none")) attr(adjusted, "intensity_unit") <- "absorbance"
adjusted
}
app_prepare_correlation_reference <- function(reference) {
if(!inherits(reference, "OpenSpecy")) {
stop("The correlation reference must be OpenSpecy.", call. = FALSE)
}
values <- make_rel(reference$spectra, na.rm = TRUE)
values <- OpenSpecy:::.matrix_mean_replace(values)
list(
wavenumber = reference$wavenumber,
library_id = colnames(reference$spectra),
scaled = OpenSpecy:::.scale_correlation_spectra(values)
)
}
# Match one processed query chunk while bounding both score-matrix dimensions.
# The scaled reference is reusable across file chunks; every library block is
# discarded after updating one global winning score/index per query spectrum.
app_match_prepared_best <- function(query, prepared,
library_block_size = 1000L) {
if(!inherits(query, "OpenSpecy") || !is.list(prepared) ||
!identical(query$wavenumber, prepared$wavenumber)) {
stop("The processed query and prepared reference axes must match.",
call. = FALSE)
}
library_block_size <- suppressWarnings(as.integer(library_block_size)[1L])
if(is.na(library_block_size) || library_block_size < 1L) {
stop("'library_block_size' must be a positive whole number.",
call. = FALSE)
}
library_count <- nrow(prepared$scaled)
if(length(prepared$library_id) != library_count || library_count < 1L) {
stop("The prepared correlation reference is empty or invalid.",
call. = FALSE)
}
query_values <- make_rel(query$spectra, na.rm = TRUE)
query_values <- OpenSpecy:::.matrix_mean_replace(query_values)
scaled_query <- OpenSpecy:::.scale_correlation_spectra(query_values)
query_count <- nrow(scaled_query)
best_value <- rep(NA_real_, query_count)
best_index <- rep(NA_integer_, query_count)
starts <- seq.int(1L, library_count, by = library_block_size)
query_columns <- seq_len(query_count)
for(start in starts) {
rows <- seq.int(
start, min(library_count, start + library_block_size - 1L)
)
scores <- tcrossprod(
prepared$scaled[rows, , drop = FALSE], scaled_query
)
ranked_scores <- scores
ranked_scores[!is.finite(ranked_scores)] <- -Inf
local_index <- max.col(t(ranked_scores), ties.method = "first")
candidate_value <- scores[cbind(local_index, query_columns)]
candidate_index <- rows[local_index]
update <- is.na(best_index) |
(!is.na(candidate_value) &
(is.na(best_value) | candidate_value > best_value))
best_value[update] <- candidate_value[update]
best_index[update] <- candidate_index[update]
rm(
scores, ranked_scores, local_index, candidate_value, candidate_index,
update
)
}
data.table::data.table(
object_id = colnames(query$spectra),
library_id = prepared$library_id[best_index],
match_val = best_value
)
}
app_match_bounded_best <- function(query, reference, block_size = 1000L,
progress = NULL) {
if(!inherits(query, "OpenSpecy") || !inherits(reference, "OpenSpecy") ||
!identical(query$wavenumber, reference$wavenumber)) {
stop("Bounded matching requires OpenSpecy objects on one axis.",
call. = FALSE)
}
block_size <- suppressWarnings(as.integer(block_size)[1L])
if(is.na(block_size) || block_size < 1L) {
stop("'block_size' must be a positive whole number.", call. = FALSE)
}
prepared <- app_prepare_correlation_reference(reference)
chunks <- split(
seq_len(ncol(query$spectra)),
ceiling(seq_len(ncol(query$spectra)) / block_size)
)
result <- vector("list", length(chunks))
for(i in seq_along(chunks)) {
rows <- chunks[[i]]
block <- filter_spec(
query, logic = seq_len(ncol(query$spectra)) %in% rows
)
result[[i]] <- app_match_prepared_best(
block, prepared, library_block_size = block_size
)
if(!is.null(progress)) {
progress(i, length(chunks), sum(lengths(chunks[seq_len(i)])))
}
}
data.table::rbindlist(result, use.names = TRUE)
}
# Stream a FileSpecs query through caller-owned processing and matching
# callbacks. Only one bounded spectral block and one winning match per source
# spectrum survive; full library-by-query correlation matrices are discarded
# by the callback before the next file block is read.
app_stream_filespec_best_matches <- function(
source, eligible, process, identify, chunk_size = 1000L, progress = NULL,
spatial_smooth = FALSE, sigma = c(1, 1, 1)) {
if(!inherits(source, "FileSpecs")) {
stop("Streaming identification requires a FileSpecs source.", call. = FALSE)
}
if(!is.function(process) || !is.function(identify)) {
stop("Streaming identification requires process and identify functions.",
call. = FALSE)
}
if(!is.null(progress) && !is.function(progress)) {
stop("'progress' must be NULL or a function.", call. = FALSE)
}
index <- OpenSpecy:::.filespec_index(source)
if(!is.logical(eligible) || length(eligible) != nrow(index)) {
stop("'eligible' must have one logical value per file-backed spectrum.",
call. = FALSE)
}
eligible[is.na(eligible)] <- FALSE
positions <- which(eligible)
if(!length(positions)) {
return(data.table::data.table(
object_id = character(), library_id = character(), match_val = numeric()
))
}
chunk_size <- OpenSpecy:::.filespec_bounded_chunk_size(
length(OpenSpecy:::.filespec_axis(source)), chunk_size
)
row_chunks <- if(isTRUE(spatial_smooth)) {
col_chunk <- OpenSpecy:::.filespec_column_chunk_id(index, chunk_size)
if(is.null(col_chunk)) {
stop("Spatial smoothing requires a complete rectangular file-backed grid.",
call. = FALSE)
}
split(seq_along(positions), col_chunk[positions])
} else {
split(seq_along(positions), ceiling(seq_along(positions) / chunk_size))
}
object_id <- character(length(positions))
library_id <- character(length(positions))
match_val <- rep(NA_real_, length(positions))
for(i in seq_along(row_chunks)) {
rows <- row_chunks[[i]]
query <- if(isTRUE(spatial_smooth)) {
values <- OpenSpecy:::.filespec_smoothed_values(
source, index, positions[rows], bands = NULL, sigma1 = sigma
)
OpenSpecy:::.filespec_values_to_OpenSpecy(source, values)
} else {
decompress_spec(source, index = positions[rows])
}
processed <- process(query)
if(!inherits(processed, "OpenSpecy")) {
stop("The streaming process callback must return OpenSpecy.",
call. = FALSE)
}
query_ids <- colnames(processed$spectra)
matches <- data.table::as.data.table(identify(processed))
required <- c("object_id", "library_id", "match_val")
if(!all(required %in% names(matches))) {
stop("The streaming match callback returned an invalid match table.",
call. = FALSE)
}
matches[, .stream_order := seq_len(.N)]
data.table::setorderv(
matches, c("object_id", "match_val", ".stream_order"),
c(1L, -1L, 1L), na.last = TRUE
)
best <- matches[!duplicated(object_id)]
aligned <- match(query_ids, best$object_id)
if(length(query_ids) != length(rows) || anyNA(aligned)) {
stop("Streamed match rows do not align with the processed spectra.",
call. = FALSE)
}
object_id[rows] <- query_ids
library_id[rows] <- as.character(best$library_id[aligned])
match_val[rows] <- as.numeric(best$match_val[aligned])
if(!is.null(progress)) {
progress(
completed_blocks = i, total_blocks = length(row_chunks),
completed_spectra = sum(lengths(row_chunks[seq_len(i)])),
total_spectra = length(positions), chunk_size = chunk_size
)
}
rm(query, processed, matches, best)
if(i %% 5L == 0L || i == length(row_chunks)) {
invisible(gc(verbose = FALSE))
}
}
result <- data.table::data.table(
object_id = object_id, library_id = library_id, match_val = match_val
)
attr(result, "chunk_size") <- chunk_size
result
}
# Build the Cluster Buster background from bounded, fully processed query
# chunks. Summing after `process()` is essential: the temporary background must
# inhabit the same processed feature space as matching, not the raw map space.
app_stream_filespec_processed_mean <- function(
source, eligible, process, chunk_size = 1000L, progress = NULL,
spatial_smooth = FALSE, sigma = c(1, 1, 1)) {
if(!inherits(source, "FileSpecs") || !is.function(process)) {
stop("A FileSpecs source and processing callback are required.", call. = FALSE)
}
index <- OpenSpecy:::.filespec_index(source)
if(!is.logical(eligible) || length(eligible) != nrow(index)) {
stop("'eligible' must have one logical value per file-backed spectrum.",
call. = FALSE)
}
eligible[is.na(eligible)] <- FALSE
positions <- which(eligible)
if(!length(positions)) {
stop("Cluster Buster requires at least one retained spectrum.", call. = FALSE)
}
chunk_size <- OpenSpecy:::.filespec_bounded_chunk_size(
length(OpenSpecy:::.filespec_axis(source)), chunk_size
)
chunks <- if(isTRUE(spatial_smooth)) {
column_chunk <- OpenSpecy:::.filespec_column_chunk_id(index, chunk_size)
if(is.null(column_chunk)) {
stop("Spatial smoothing requires a complete rectangular file-backed grid.",
call. = FALSE)
}
split(seq_along(positions), column_chunk[positions])
} else {
split(seq_along(positions), ceiling(seq_along(positions) / chunk_size))
}
total <- NULL
axis <- NULL
preserve_uploaded_axis <- FALSE
count <- 0L
for(i in seq_along(chunks)) {
rows <- chunks[[i]]
query <- if(isTRUE(spatial_smooth)) {
values <- OpenSpecy:::.filespec_smoothed_values(
source, index, positions[rows], bands = NULL, sigma1 = sigma
)
OpenSpecy:::.filespec_values_to_OpenSpecy(source, values)
} else {
decompress_spec(source, index = positions[rows])
}
processed <- process(query)
if(!inherits(processed, "OpenSpecy")) {
stop("The streaming process callback must return OpenSpecy.", call. = FALSE)
}
if(is.null(axis)) {
axis <- processed$wavenumber
preserve_uploaded_axis <- isTRUE(attr(
processed, "preserve_uploaded_axis", exact = TRUE
))
total <- rowSums(processed$spectra)
} else {
if(!identical(axis, processed$wavenumber)) {
stop("Streamed preprocessing produced inconsistent wavenumber axes.",
call. = FALSE)
}
total <- total + rowSums(processed$spectra)
}
count <- count + ncol(processed$spectra)
if(!is.null(progress)) {
progress(
completed_blocks = i, total_blocks = length(chunks),
completed_spectra = sum(lengths(chunks[seq_len(i)])),
total_spectra = length(positions), chunk_size = chunk_size
)
}
rm(query, processed)
}
spectra <- matrix(
total / count, ncol = 1L,
dimnames = list(as.character(axis), "background")
)
result <- as_OpenSpecy(
axis, spectra = spectra,
metadata = data.table::data.table(
col_id = "background", sample_name = "background",
spectrum_identity = "background", material_class = "background",
organization = "Temporary map background"
), compute_file_id = FALSE
)
attr(result, "preserve_uploaded_axis") <- preserve_uploaded_axis
result
}
app_cluster_buster_background <- function(processed) {
if(!inherits(processed, "OpenSpecy") || ncol(processed$spectra) < 1L) {
stop("Cluster Buster requires processed retained spectra.", call. = FALSE)
}
spectra <- matrix(
rowMeans(processed$spectra), ncol = 1L,
dimnames = list(as.character(processed$wavenumber), "background")
)
result <- as_OpenSpecy(
processed$wavenumber, spectra = spectra,
metadata = data.table::data.table(
col_id = "background", sample_name = "background",
spectrum_identity = "background", material_class = "background",
organization = "Temporary map background"
), compute_file_id = FALSE
)
attr(result, "preserve_uploaded_axis") <- isTRUE(attr(
processed, "preserve_uploaded_axis", exact = TRUE
))
result
}
app_append_cluster_buster_background <- function(reference, background) {
if(!inherits(reference, "OpenSpecy") || !inherits(background, "OpenSpecy") ||
ncol(background$spectra) != 1L ||
!identical(reference$wavenumber, background$wavenumber)) {
stop("The reference and one-spectrum background must share an axis.",
call. = FALSE)
}
if("background" %in% colnames(reference$spectra)) {
stop("The selected library already contains a spectrum named 'background'.",
call. = FALSE)
}
result <- reference
result$spectra <- cbind(reference$spectra, background$spectra)
result$metadata <- data.table::rbindlist(
list(
data.table::as.data.table(reference$metadata),
data.table::as.data.table(background$metadata)
), use.names = TRUE, fill = TRUE
)
result$metadata$col_id <- colnames(result$spectra)
result
}
app_cluster_buster_decisions <- function(
matches, pixel_ids, signal_keep, correlation_enabled = FALSE,
minimum = -Inf, background_id = "background") {
matches <- data.table::as.data.table(matches)
required <- c("object_id", "library_id", "match_val")
if(!all(required %in% names(matches))) {
stop("Cluster Buster matches are missing required columns.", call. = FALSE)
}
pixel_ids <- as.character(pixel_ids)
signal_keep <- as.logical(signal_keep)
if(length(pixel_ids) != length(signal_keep) || anyNA(pixel_ids) ||
anyDuplicated(pixel_ids)) {
stop("Cluster Buster pixel identifiers and S/N mask do not align.",
call. = FALSE)
}
signal_keep[is.na(signal_keep)] <- FALSE
index <- match(pixel_ids, as.character(matches$object_id))
winner <- as.character(matches$library_id[index])
score <- as.numeric(matches$match_val[index])
background <- signal_keep & (is.na(winner) | winner == background_id)
correlation <- signal_keep & !background & isTRUE(correlation_enabled) &
(!is.finite(score) | score < as.numeric(minimum)[1L])
keep <- signal_keep & !background & !correlation
reason <- rep(NA_character_, length(pixel_ids))
reason[!signal_keep] <- "signal/noise"
reason[background] <- "background"
reason[correlation] <- "correlation"
data.table::data.table(
pixel_id = pixel_ids, signal_keep = signal_keep,
library_id = winner, match_val = score,
background_rejected = background,
correlation_rejected = correlation, keep = keep,
rejection_reason = reason
)
}
app_rejected_spectrum <- function(wavenumber) {
axis <- as.numeric(wavenumber)
spectra <- matrix(0, nrow = length(axis), ncol = 1L,
dimnames = list(NULL, "No retained particle"))
as_OpenSpecy(
axis, spectra = spectra,
metadata = data.frame(selection = "No retained particle")
)
}
app_standardize_material_class <- function(x) {
values <- as.character(x)
sub("^(ftir|raman|nir)[_-]+", "", values, ignore.case = TRUE)
}
app_pixel_calibration <- function(pixel_size = 1, pixel_unit = "pixel") {
size <- suppressWarnings(as.numeric(pixel_size))
if(length(size) != 1L || is.na(size) || !is.finite(size) || size <= 0) {
stop("Pixel edge length must be one positive finite number.", call. = FALSE)
}
unit <- trimws(as.character(pixel_unit)[1L])
if(is.na(unit) || !nzchar(unit)) unit <- "pixel"
suffix_unit <- gsub("[µμ]", "u", unit)
suffix <- tolower(gsub("[^A-Za-z0-9]+", "_", suffix_unit))
suffix <- gsub("^_+|_+$", "", suffix)
if(!nzchar(suffix)) suffix <- "pixel"
list(
size = size, unit = unit, length_suffix = suffix,
area_suffix = paste0(suffix, "2"),
volume_suffix = paste0(suffix, "3")
)
}
app_source_pixel_calibration <- function(source) {
calibration <- attr(source, "spatial_calibration", exact = TRUE)
candidates <- if(is.list(calibration) && !is.null(calibration$x_origin)) {
list(calibration)
} else if(is.list(calibration)) {
Filter(function(item) is.list(item) && !is.null(item$x_origin), calibration)
} else {
list()
}
if(length(candidates)) {
inferred <- lapply(candidates, function(item) {
steps <- abs(suppressWarnings(as.numeric(c(item$x_step, item$y_step))))
unit <- if(is.null(item$unit) || !length(item$unit)) "" else
trimws(as.character(item$unit)[[1L]])
known_unit <- !is.na(unit) && nzchar(unit) &&
!tolower(unit) %in% c("map unit", "map units", "unknown")
square <- length(steps) == 2L && all(is.finite(steps)) &&
all(steps > 0) && isTRUE(all.equal(
steps[[1L]], steps[[2L]], tolerance = 1e-8
))
if(!known_unit || !square) return(NULL)
list(size = mean(steps), unit = unit)
})
if(any(lengths(inferred) == 0L)) return(NULL)
sizes <- vapply(inferred, `[[`, numeric(1L), "size")
units <- vapply(inferred, `[[`, character(1L), "unit")
consistent_size <- all(vapply(
sizes,
function(value) isTRUE(all.equal(value, sizes[[1L]], tolerance = 1e-8)),
logical(1L)
))
consistent_unit <- length(unique(tolower(units))) == 1L
if(consistent_size && consistent_unit) {
return(app_pixel_calibration(sizes[[1L]], units[[1L]]))
}
return(NULL)
}
# Processed particle RDS files already contain physical x/y values, so their
# unit-bearing metadata contract uses a neutral scale of one on re-upload.
spatial_unit <- attr(source, "openspecy_spatial_unit", exact = TRUE)
if(isTruthy(spatial_unit)) app_pixel_calibration(1, spatial_unit) else NULL
}
app_coordinate_calibration <- function(calibration) {
if(!is.list(calibration) || is.null(calibration$x_origin)) return(NULL)
values <- suppressWarnings(as.numeric(c(
calibration$x_origin, calibration$y_origin,
calibration$x_step, calibration$y_step
)))
if(length(values) != 4L || any(!is.finite(values)) ||
any(values[3:4] == 0)) return(NULL)
unit <- if(isTruthy(calibration$unit)) {
trimws(as.character(calibration$unit)[[1L]])
} else "map unit"
list(
x_origin = values[[1L]], y_origin = values[[2L]],
x_step = values[[3L]], y_step = values[[4L]], unit = unit,
source = if(isTruthy(calibration$source)) {
as.character(calibration$source)[[1L]]
} else "source metadata"
)
}
app_source_coordinate_calibration <- function(source) {
app_coordinate_calibration(
attr(source, "spatial_calibration", exact = TRUE)
)
}
# Particle RDS downloads use unit-bearing metadata names (for example,
# x_pixel/y_pixel or x_um/y_um). Restore the canonical x/y aliases needed by
# the map pipeline when one of those downloads is uploaded again, while
# retaining every reported unit-bearing column unchanged.
app_restore_spatial_coordinates <- function(x) {
if(!is_OpenSpecy(x) || is.null(x$metadata)) return(x)
metadata <- data.table::copy(data.table::as.data.table(x$metadata))
if(all(c("x", "y") %in% names(metadata))) return(x)
coordinate_pair <- function(prefix = "") {
x_prefix <- paste0("^", prefix, "x_")
x_names <- grep(x_prefix, names(metadata), value = TRUE)
if(!length(x_names)) return(NULL)
suffixes <- sub(x_prefix, "", x_names)
y_names <- paste0(prefix, "y_", suffixes)
valid <- y_names %in% names(metadata)
if(!any(valid)) return(NULL)
first <- which(valid)[[1L]]
list(x = x_names[[first]], y = y_names[[first]], unit = suffixes[[first]])
}
pair <- coordinate_pair()
if(is.null(pair)) pair <- coordinate_pair("centroid_")
if(is.null(pair)) return(x)
x_values <- suppressWarnings(as.numeric(metadata[[pair$x]]))
y_values <- suppressWarnings(as.numeric(metadata[[pair$y]]))
if(length(x_values) != nrow(metadata) || length(y_values) != nrow(metadata) ||
!any(is.finite(x_values) & is.finite(y_values))) return(x)
metadata[, `:=`(x = x_values, y = y_values)]
x$metadata <- metadata
if(is.null(attr(x, "openspecy_spatial_unit", exact = TRUE))) {
attr(x, "openspecy_spatial_unit") <- pair$unit
}
x
}
app_calibrate_spatial_metadata <- function(metadata, pixel_size = 1,
pixel_unit = "pixel") {
calibration <- app_pixel_calibration(pixel_size, pixel_unit)
result <- data.table::copy(data.table::as.data.table(metadata))
for(column in intersect(c("x", "y"), names(result))) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size
}
attr(result, "openspecy_spatial_unit") <- calibration$unit
result
}
app_project_source_coordinates <- function(source, metadata,
pixel_size = 1,
pixel_unit = "pixel") {
result <- data.table::copy(data.table::as.data.table(metadata))
if(all(c("stage_x_nm", "stage_y_nm") %in% names(result))) {
stage_x <- suppressWarnings(as.numeric(result$stage_x_nm))
stage_y <- suppressWarnings(as.numeric(result$stage_y_nm))
if(length(stage_x) == nrow(result) && length(stage_y) == nrow(result) &&
all(is.finite(stage_x)) && all(is.finite(stage_y))) {
result[, `:=`(grid_x = x, grid_y = y, x = stage_x, y = stage_y)]
attr(result, "openspecy_spatial_unit") <- "nm"
return(list(metadata = result, unit = "nm", source = "H5 stage"))
}
}
calibration <- app_source_coordinate_calibration(source)
if(!is.null(calibration)) {
result[, `:=`(
grid_x = x, grid_y = y,
x = calibration$x_origin + as.numeric(x) * calibration$x_step,
y = calibration$y_origin + as.numeric(y) * calibration$y_step
)]
unit <- calibration$unit
attr(result, "openspecy_spatial_unit") <- unit
return(list(metadata = result, unit = unit,
source = calibration$source))
}
fallback <- app_calibrate_spatial_metadata(result, pixel_size, pixel_unit)
list(metadata = fallback, unit = attr(fallback, "openspecy_spatial_unit"),
source = "manual pixel calibration")
}
app_registered_visual <- function(source) {
if(is.null(source)) return(NULL)
visual <- if(inherits(source, "FileSpecs") &&
identical(source$source$backend, "h5")) {
tryCatch(OpenSpecy:::.filespec_materialize_visual(source),
error = function(e) NULL)
} else {
tryCatch(visual_image(source), error = function(e) NULL)
}
if(is.null(visual) || is.null(visual$image) ||
is.null(visual$bottom_left) || is.null(visual$top_right)) return(NULL)
image <- tryCatch(OpenSpecy:::.image_rgb_array(visual$image),
error = function(e) NULL)
if(is.null(image)) return(NULL)
rows <- range(round(c(visual$bottom_left[[2L]], visual$top_right[[2L]])))
cols <- range(round(c(visual$bottom_left[[1L]], visual$top_right[[1L]])))
rows <- pmin(pmax(rows, 1L), dim(image)[[1L]])
cols <- pmin(pmax(cols, 1L), dim(image)[[2L]])
if(rows[[1L]] > rows[[2L]] || cols[[1L]] > cols[[2L]]) return(NULL)
cropped <- image[seq.int(rows[[1L]], rows[[2L]]),
seq.int(cols[[1L]], cols[[2L]]), , drop = FALSE]
list(image = cropped, transform = visual$transform,
detection_method = visual$detection_method,
source = visual$source)
}
app_heatmap_cell_range <- function(values) {
values <- sort(unique(as.numeric(values[is.finite(values)])))
if(!length(values)) return(c(0, 1))
if(length(values) == 1L) return(values + c(-0.5, 0.5))
c(
values[[1L]] - (values[[2L]] - values[[1L]]) / 2,
values[[length(values)]] +
(values[[length(values)]] - values[[length(values) - 1L]]) / 2
)
}
app_visual_trace_geometry <- function(x, y, image) {
x_boundary <- app_heatmap_cell_range(x)
y_boundary <- app_heatmap_cell_range(y)
image_rows <- dim(image)[[1L]]
image_cols <- dim(image)[[2L]]
list(
# The detected red-frame pixels are the map boundary, rather than the
# centers of the first and last heatmap cells.
x0 = x_boundary[[1L]],
y0 = y_boundary[[2L]],
dx = diff(x_boundary) / max(image_cols - 1L, 1L),
dy = -diff(y_boundary) / max(image_rows - 1L, 1L),
x_boundary = x_boundary,
y_boundary = y_boundary
)
}
app_visual_layout_image <- function(x, y, image, opacity = 1) {
geometry <- app_visual_trace_geometry(x, y, image)
opacity <- suppressWarnings(as.numeric(opacity))
if(length(opacity) != 1L || !is.finite(opacity)) opacity <- 1
list(
source = plotly:::raster2uri(image),
xref = "x", yref = "y",
x = geometry$x_boundary[[1L]], y = geometry$y_boundary[[2L]],
sizex = diff(geometry$x_boundary), sizey = diff(geometry$y_boundary),
xanchor = "left", yanchor = "top", sizing = "stretch",
opacity = pmin(pmax(opacity, 0), 1), layer = "above"
)
}
app_selection_shape <- function(x, y, select) {
if(is.null(select) || length(select$x) != 1L || length(select$y) != 1L ||
!is.finite(select$x) || !is.finite(select$y)) return(NULL)
x_boundary <- app_heatmap_cell_range(x)
y_boundary <- app_heatmap_cell_range(y)
x_radius <- diff(x_boundary) / max(length(unique(x)), 1L) * 0.4
y_radius <- diff(y_boundary) / max(length(unique(y)), 1L) * 0.4
list(
type = "circle", xref = "x", yref = "y",
x0 = select$x - x_radius, x1 = select$x + x_radius,
y0 = select$y - y_radius, y1 = select$y + y_radius,
fillcolor = "#FFFFFF", opacity = 1,
line = list(color = "#FFFFFF", width = 2), layer = "above"
)
}
app_particle_metadata_units <- function(metadata, pixel_size = 1,
pixel_unit = "pixel",
coordinate_calibration = NULL) {
coordinate_calibration <- app_coordinate_calibration(
coordinate_calibration
)
report_unit <- if(is.null(coordinate_calibration)) {
pixel_unit
} else coordinate_calibration$unit
calibration <- app_pixel_calibration(pixel_size, report_unit)
result <- data.table::copy(data.table::as.data.table(metadata))
x_coordinates <- intersect(c("x", "centroid_x", "first_x", "rand_x"),
names(result))
y_coordinates <- intersect(c("y", "centroid_y", "first_y", "rand_y"),
names(result))
dimensions <- intersect(
c("perimeter", "rectangular_min", "feret_min", "feret_max"),
names(result)
)
coordinates <- c(x_coordinates, y_coordinates)
linear <- c(coordinates, dimensions)
area <- intersect(c("area", "convex_hull_area"), names(result))
if(is.null(coordinate_calibration)) {
for(column in coordinates) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size
}
} else {
for(column in x_coordinates) {
result[[column]] <- coordinate_calibration$x_origin +
as.numeric(result[[column]]) * coordinate_calibration$x_step
}
for(column in y_coordinates) {
result[[column]] <- coordinate_calibration$y_origin +
as.numeric(result[[column]]) * coordinate_calibration$y_step
}
}
for(column in dimensions) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size
}
for(column in area) {
result[[column]] <- as.numeric(result[[column]]) * calibration$size^2
}
if("area" %in% names(result)) {
volume_name <- paste0("volume_", calibration$volume_suffix)
result[[volume_name]] <- sqrt(pmax(result$area, 0))^3
}
if(length(linear)) {
data.table::setnames(
result, linear, paste0(linear, "_", calibration$length_suffix)
)
}
if(length(area)) {
data.table::setnames(
result, area, paste0(area, "_", calibration$area_suffix)
)
}
app_round_reported_metadata(result)
}
app_round_reported_metadata <- function(metadata, digits = 3L) {
result <- data.table::copy(data.table::as.data.table(metadata))
measurement_stems <- c(
"perimeter", "rectangular_min", "feret_min", "feret_max",
"convex_hull_area", "volume"
)
measurement_pattern <- paste0("^(", paste(measurement_stems,
collapse = "|"), ")($|_)")
columns <- unique(c(
grep(measurement_pattern, names(result), value = TRUE),
intersect(c("match_val", "max_cor_val", "signal_to_noise"),
names(result))
))
for(column in columns) {
result[[column]] <- base::signif(as.numeric(result[[column]]), digits)
}
result
}
app_match_value_label <- function(model_library = FALSE) {
if(isTRUE(model_library)) "Probability" else "Correlation"
}
app_signal_metric_label <- function(metric) {
labels <- c(
run_sig_over_noise = "Signal Over Noise",
sig_times_noise = "Signal Times Noise",
log_tot_sig = "Total Signal"
)
metric <- as.character(metric)[1L]
if(is.na(metric) || !metric %in% names(labels)) return("Signal to Noise")
unname(labels[[metric]])
}
app_selection_metadata_display <- function(metadata, simple = TRUE,
particle = FALSE,
library = FALSE,
pixel_size = 1,
pixel_unit = "pixel",
coordinate_calibration = NULL,
match_label = "Correlation",
signal_label = "Signal to Noise") {
coordinate_calibration <- app_coordinate_calibration(
coordinate_calibration
)
report_unit <- if(is.null(coordinate_calibration)) {
pixel_unit
} else coordinate_calibration$unit
calibration <- app_pixel_calibration(pixel_size, report_unit)
result <- app_particle_metadata_units(
metadata, pixel_size, pixel_unit, coordinate_calibration
)
result <- app_round_reported_metadata(result)
if("material_class" %in% names(result)) {
result$material_class <- app_standardize_material_class(
result$material_class
)
}
if(!isTRUE(simple)) return(result)
if(!"match_val" %in% names(result) && "max_cor_val" %in% names(result)) {
result[, match_val := max_cor_val]
}
particle_columns <- if(isTRUE(particle)) c(
paste0("area_", calibration$area_suffix),
paste0("perimeter_", calibration$length_suffix),
paste0("rectangular_min_", calibration$length_suffix),
paste0("feret_min_", calibration$length_suffix),
paste0("feret_max_", calibration$length_suffix),
paste0("convex_hull_area_", calibration$area_suffix),
paste0("volume_", calibration$volume_suffix),
paste0("first_x_", calibration$length_suffix),
paste0("first_y_", calibration$length_suffix)
) else character()
coordinate_columns <- paste0(c("x", "y"), "_", calibration$length_suffix)
coordinate_columns <- intersect(coordinate_columns, names(result))
keep <- intersect(
c("material_class", "match_val",
if(isTRUE(library)) c("spectrum_identity", "organization") else NULL,
"signal_to_noise", particle_columns, "file_name", "col_id",
coordinate_columns),
names(result)
)
result <- result[, keep, with = FALSE]
friendly <- c(
material_class = "Material Class",
match_val = match_label,
spectrum_identity = "Spectrum Identity",
organization = "Organization",
signal_to_noise = signal_label,
file_name = "File Name",
col_id = "Column ID"
)
coordinate_friendly <- ifelse(
startsWith(coordinate_columns, "x_"), "X", "Y"
)
names(coordinate_friendly) <- coordinate_columns
particle_friendly <- c(
paste0("Area (", calibration$unit, "^2)"),
paste0("Perimeter (", calibration$unit, ")"),
paste0("Rectangular Minimum (", calibration$unit, ")"),
paste0("Feret Minimum (", calibration$unit, ")"),
paste0("Feret Maximum (", calibration$unit, ")"),
paste0("Convex Hull Area (", calibration$unit, "^2)"),
paste0("Estimated Volume (", calibration$unit, "^3)"),
paste0("First X (", calibration$unit, ")"),
paste0("First Y (", calibration$unit, ")")
)
names(particle_friendly) <- particle_columns
labels <- c(friendly, particle_friendly, coordinate_friendly)
data.table::setnames(result, keep, unname(labels[keep]))
result
}
app_particle_metadata_fields <- c(
"x", "y", "z", "centroid_x", "centroid_y", "first_x", "first_y",
"area", "perimeter", "rectangular_min", "feret_min", "feret_max",
"convex_hull_area",
"volume", "pixel_index", "region_id", "cluster_id", "unit_id",
"unit_index"
)
app_without_particle_metadata <- function(metadata) {
result <- data.table::copy(data.table::as.data.table(metadata))
drop <- intersect(app_particle_metadata_fields, names(result))
if(length(drop)) result[, (drop) := NULL]
result
}
app_particle_summary_table <- function(object, pixel_size = 1,
pixel_unit = "pixel",
material = NULL) {
calibration <- app_pixel_calibration(pixel_size, pixel_unit)
md <- app_particle_metadata_units(
object$metadata, pixel_size = pixel_size, pixel_unit = pixel_unit
)
if(!nrow(md)) return(data.table::data.table(
material_class = character(), particle_count = integer(),
total_particle_count = integer(), percentage = numeric(),
confidence_level = numeric(), percentage_uncertainty = numeric(),
percentage_ci_lower = numeric(), percentage_ci_upper = numeric(),
total_concentration_rsd = numeric()
))
material <- if(!is.null(material)) {
if(length(material) != nrow(md)) {
stop("Particle summary material classes do not align with particles.",
call. = FALSE)
}
app_standardize_material_class(material)
} else if("material_class" %in% names(md)) {
app_standardize_material_class(md$material_class)
} else rep("unidentified", nrow(md))
material[is.na(material) | !nzchar(material)] <- "unknown"
area_column <- paste0("area_", calibration$area_suffix)
area <- if(area_column %in% names(md)) {
as.numeric(md[[area_column]])
} else rep(1, nrow(md))
result <- data.table::data.table(material_class = material, area = area)[, .(
particle_count = .N,
total_area = sum(area, na.rm = TRUE),
mean_area = mean(area, na.rm = TRUE),
median_area = stats::median(area, na.rm = TRUE)
), by = material_class][order(-particle_count, material_class)]
total_count <- sum(result$particle_count)
percentage <- 100 * result$particle_count / total_count
uncertainty <- material_percentage_uncertainty(total_count, percentage)
result <- cbind(result, data.table::data.table(
total_particle_count = rep(as.integer(total_count), nrow(result)),
percentage = percentage,
confidence_level = rep(0.95, nrow(result)),
percentage_uncertainty = uncertainty,
percentage_ci_lower = pmax(0, percentage - uncertainty),
percentage_ci_upper = pmin(100, percentage + uncertainty),
total_concentration_rsd = rep(total_count^(-1 / 2), nrow(result))
))
data.table::setnames(
result, c("total_area", "mean_area", "median_area"),
paste0(c("total_area_", "mean_area_", "median_area_"),
calibration$area_suffix)
)
result
}
app_particle_size_plot <- function(object, pixel_size = 1,
pixel_unit = "pixel") {
data <- app_particle_size_data(object, pixel_size, pixel_unit)
ggplot2::ggplot(data) +
ggplot2::geom_rect(
ggplot2::aes(
xmin = bin_min, xmax = bin_max, ymin = 0, ymax = count
),
fill = app_plot_palette$primary, color = app_plot_palette$panel
) +
theme_black_minimal(base_size = 15) +
ggplot2::labs(
x = paste0("Nominal Particle Size (", attr(data, "unit"), ")"),
y = "Count"
)
}
app_particle_size_data <- function(object, pixel_size = 1,
pixel_unit = "pixel", bins = 30L) {
calibration <- app_pixel_calibration(pixel_size, pixel_unit)
md <- app_particle_metadata_units(
object$metadata, pixel_size = pixel_size, pixel_unit = pixel_unit
)
area_column <- paste0("area_", calibration$area_suffix)
area <- if(area_column %in% names(md)) as.numeric(md[[area_column]]) else
numeric()
size <- sqrt(area[is.finite(area) & area >= 0])
if(!length(size)) {
result <- data.frame(
bin_min = numeric(), bin_max = numeric(), bin_mid = numeric(),
count = integer()
)
} else if(length(size) == 1L) {
half_width <- if(size[[1L]] == 0) 0.5 else
max(abs(size[[1L]]) * 0.05, sqrt(.Machine$double.eps))
result <- data.frame(
bin_min = size[[1L]] - half_width,
bin_max = size[[1L]] + half_width,
bin_mid = size[[1L]], count = 1L
)
} else {
histogram <- graphics::hist(size, breaks = bins, plot = FALSE,
include.lowest = TRUE, right = TRUE)
result <- data.frame(
bin_min = utils::head(histogram$breaks, -1L),
bin_max = utils::tail(histogram$breaks, -1L),
bin_mid = histogram$mids,
count = as.integer(histogram$counts)
)
}
attr(result, "unit") <- calibration$unit
result
}
app_particle_size_plotly <- function(object, pixel_size = 1,
pixel_unit = "pixel") {
data <- app_particle_size_data(object, pixel_size, pixel_unit)
unit <- attr(data, "unit")
xaxis <- list(title = paste0("Nominal Particle Size (", unit, ")"))
if(nrow(data) == 1L && data$count[[1L]] == 1L) {
padding <- (data$bin_max[[1L]] - data$bin_min[[1L]]) / 2
xaxis$range <- c(data$bin_min[[1L]] - padding,
data$bin_max[[1L]] + padding)
}
plotly::plot_ly(
data,
x = ~bin_mid,
y = ~count,
width = as.numeric(data$bin_max - data$bin_min),
type = "bar",
marker = list(
color = app_plot_palette$primary,
line = list(color = app_plot_palette$panel, width = 1)
),
customdata = ~cbind(bin_min, bin_max),
hovertemplate = paste0(
"Bin: %{customdata[0]:.4g} to %{customdata[1]:.4g} ", unit,
"<br>Count: %{y}<extra></extra>"
)
) |>
plotly::layout(
xaxis = xaxis,
yaxis = list(title = "Count", rangemode = "tozero"),
paper_bgcolor = app_theme$panel,
plot_bgcolor = app_theme$panel,
font = list(color = app_theme$text),
showlegend = FALSE
) |>
plotly::config(displaylogo = FALSE)
}
app_material_summary_data <- function(material, confidence = 0.95) {
values <- app_standardize_material_class(material)
values[is.na(values) | !nzchar(values)] <- "unknown"
counts <- sort(table(values), decreasing = FALSE)
total_count <- sum(counts)
percentage <- 100 * as.numeric(counts) / total_count
uncertainty <- material_percentage_uncertainty(
total_count, percentage, confidence
)
class_data <- data.frame(
material_class = names(counts), count = as.numeric(counts),
percentage = percentage, confidence_level = confidence,
percentage_uncertainty = uncertainty,
percentage_ci_lower = pmax(0, percentage - uncertainty),
percentage_ci_upper = pmin(100, percentage + uncertainty),
total_concentration_rsd = total_count^(-1 / 2),
uncertainty_type = "Material percentage CI",
stringsAsFactors = FALSE
)
class_data$count_uncertainty <-
total_count * class_data$percentage_uncertainty / 100
all_data <- data.frame(
material_class = "All Materials", count = total_count, percentage = 100,
confidence_level = confidence, percentage_uncertainty = NA_real_,
percentage_ci_lower = NA_real_, percentage_ci_upper = NA_real_,
total_concentration_rsd = total_count^(-1 / 2),
uncertainty_type = "Total concentration RSD",
count_uncertainty = sqrt(total_count), stringsAsFactors = FALSE
)
result <- rbind(class_data, all_data)
result$count_lower <- pmax(0, result$count - result$count_uncertainty)
result$count_upper <- result$count + result$count_uncertainty
result
}
app_material_summary_plot <- function(material, palette = NULL) {
data <- app_material_summary_data(material)
values <- data$material_class
if(is.null(palette)) palette <- app_category_palette(values)
missing_levels <- setdiff(unique(values), names(palette))
if(length(missing_levels)) {
palette <- c(palette, app_category_palette(missing_levels))
}
data$material_class <- factor(data$material_class, levels = values)
ggplot2::ggplot(data, ggplot2::aes(y = material_class, x = count,
fill = material_class)) +
ggplot2::geom_col() +
ggplot2::geom_segment(
ggplot2::aes(x = count_lower, xend = count_upper,
y = material_class, yend = material_class),
inherit.aes = FALSE, color = app_theme$text, linewidth = 0.8
) +
ggplot2::scale_fill_manual(
values = palette, na.value = app_theme$muted, drop = FALSE
) +
theme_black_minimal(base_size = 15) +
ggplot2::theme(legend.position = "none") +
ggplot2::labs(x = "Count", y = "Material Class")
}
app_material_summary_plotly <- function(material, palette = NULL) {
data <- app_material_summary_data(material)
if(is.null(palette)) palette <- app_category_palette(data$material_class)
missing_levels <- setdiff(unique(data$material_class), names(palette))
if(length(missing_levels)) {
palette <- c(palette, app_category_palette(missing_levels))
}
colors <- unname(palette[data$material_class])
material_hover <- paste0(
"Material: ", data$material_class,
"<br>Count: ", format(data$count, trim = TRUE),
"<br>Percentage: ", format(signif(data$percentage, 4), trim = TRUE), "%",
ifelse(
is.finite(data$percentage_uncertainty),
paste0(
"<br>", format(100 * data$confidence_level, trim = TRUE),
"% CI: ", format(signif(data$percentage_ci_lower, 4), trim = TRUE),
"% to ", format(signif(data$percentage_ci_upper, 4), trim = TRUE), "%",
"<br>Half-width: ",
format(signif(data$percentage_uncertainty, 4), trim = TRUE),
" percentage points"
),
""
),
"<br>Total concentration RSD: ",
format(signif(data$total_concentration_rsd, 4), trim = TRUE),
"<br>Uncertainty shown: ", data$uncertainty_type
)
plotly::plot_ly(
data,
x = ~count,
y = ~factor(material_class, levels = material_class),
type = "bar", orientation = "h",
marker = list(color = colors),
error_x = list(
type = "data", array = data$count_uncertainty,
symmetric = TRUE, visible = TRUE, color = app_theme$text
),
text = material_hover,
textposition = "none",
hovertemplate = "%{text}<extra></extra>"
) |>
plotly::layout(
xaxis = list(title = "Count", rangemode = "tozero"),
yaxis = list(title = "Material Class"),
paper_bgcolor = app_theme$panel,
plot_bgcolor = app_theme$panel,
font = list(color = app_theme$text), showlegend = FALSE
) |>
plotly::config(displaylogo = FALSE)
}
app_histogram_ggplot <- function(values, thresholds = numeric(), xlab) {
frame <- data.frame(value = as.numeric(values))
frame <- frame[is.finite(frame$value), , drop = FALSE]
plot <- ggplot2::ggplot(frame, ggplot2::aes(x = value)) +
ggplot2::geom_histogram(
bins = 30L, fill = app_plot_palette$primary,
color = app_plot_palette$panel
) +
theme_black_minimal(base_size = 15) +
ggplot2::labs(x = xlab, y = "Count")
if(nrow(frame)) {
data_range <- range(frame$value)
plot <- plot +
ggplot2::scale_x_continuous(expand = c(0, 0)) +
ggplot2::coord_cartesian(xlim = data_range)
for(value in thresholds[is.finite(thresholds)]) {
clamped <- min(max(value, data_range[1L]), data_range[2L])
plot <- plot + ggplot2::geom_vline(
xintercept = clamped, color = app_theme$reference,
linewidth = 0.8, linetype = "dashed"
)
}
}
plot
}
app_heatmap_ggplot <- function(data) {
grid <- expand.grid(x = data$x, y = data$y)
grid$value <- as.vector(data$z)
rejected <- if(is.null(data$rejected)) rep(FALSE, nrow(grid)) else
!is.na(as.vector(data$rejected))
grid$rejected <- rejected
categorical <- identical(data$type, "heatmap_categorical") ||
identical(data$type, "heatmap_binary")
if(categorical) {
levels <- if(identical(data$type, "heatmap_binary")) data$labels else
data$levels
grid$value <- factor(levels[as.integer(grid$value)], levels = levels)
palette <- if(!is.null(data$palette)) data$palette[levels] else
app_category_palette(levels)
plot <- ggplot2::ggplot(grid, ggplot2::aes(x = x, y = y, fill = value)) +
ggplot2::geom_tile() +
ggplot2::scale_fill_manual(values = palette, na.value = app_theme$panel_2,
drop = FALSE)
} else {
plot <- ggplot2::ggplot(grid, ggplot2::aes(x = x, y = y, fill = value)) +
ggplot2::geom_tile() +
ggplot2::scale_fill_gradientn(
colours = vapply(app_heatmap_colorscale, `[[`, "", 2L),
na.value = app_theme$panel_2
)
}
if(any(rejected)) {
plot <- plot + ggplot2::geom_tile(
data = grid[rejected, , drop = FALSE], fill = "black"
)
}
axis_unit <- if(isTruthy(data$axis_unit)) data$axis_unit else "pixel"
plot <- plot + ggplot2::coord_equal() + theme_black_minimal(base_size = 13) +
ggplot2::labs(
x = paste0("X (", axis_unit, ")"),
y = paste0("Y (", axis_unit, ")"), fill = data$legend_title
)
# Particle Unit and Match ID are per-particle identifiers -- essentially
# as many categories as there are particles -- so a legend is never
# useful for them, unlike Material Class's small fixed vocabulary.
if(identical(data$legend_title, "Particle Unit") ||
identical(data$legend_title, "Match ID")) {
plot <- plot + ggplot2::theme(legend.position = "none")
}
plot
}
app_ggplot_legend_grob <- function(plot) {
built <- ggplot2::ggplotGrob(plot)
positions <- which(grepl("^guide-box", built$layout$name))
if(!length(positions)) return(NULL)
for(position in positions) {
candidate <- built$grobs[[position]]
if(inherits(candidate, "gtable") && length(candidate$grobs)) {
return(candidate)
}
}
NULL
}
app_heatmap_export_components <- function(data) {
plot <- app_heatmap_ggplot(data)
list(
heatmap = plot + ggplot2::theme(legend.position = "none"),
legend = app_ggplot_legend_grob(plot)
)
}
app_write_ggplot_png <- function(plot, path, width = 8, height = 6) {
ggplot2::ggsave(
filename = path, plot = plot, width = width, height = height,
units = "in", dpi = 150, bg = app_plot_palette$panel
)
invisible(path)
}
app_write_grob_png <- function(grob, path, width = 4, height = 5) {
grDevices::png(
filename = path, width = width, height = height, units = "in",
res = 150, bg = app_plot_palette$panel
)
on.exit(grDevices::dev.off(), add = TRUE)
grid::grid.newpage()
grid::grid.draw(grob)
invisible(path)
}
app_uploaded_metadata_cache <- function(x, signal_to_noise) {
compact <- is_Specs(x)
spectrum_ids <- if(compact) {
as.character(specs_coordinates(x)$source_id)
} else colnames(x$spectra)
metadata <- if(compact) {
data.table::copy(data.table::as.data.table(specs_metadata(x)))
} else data.table::copy(data.table::as.data.table(x$metadata))
if(compact && !"col_id" %in% names(metadata)) {
metadata[, col_id := spectrum_ids]
}
if(is.null(spectrum_ids) || anyNA(spectrum_ids) || anyDuplicated(spectrum_ids) ||
!"col_id" %in% names(metadata)) {
stop("Uploaded spectra and metadata require unique identifiers.",
call. = FALSE)
}
metadata_ids <- as.character(metadata$col_id)
spectrum_index <- match(metadata_ids, spectrum_ids)
if(nrow(metadata) != length(spectrum_ids) || anyNA(metadata_ids) ||
anyDuplicated(metadata_ids) || anyNA(spectrum_index) ||
length(signal_to_noise) != length(spectrum_ids)) {
stop("Uploaded metadata does not align with the processed spectra.",
call. = FALSE)
}
metadata$signal_to_noise <- signal_to_noise[spectrum_index]
metadata <- metadata[
, !vapply(metadata, OpenSpecy::is_empty_vector, logical(1)), with = FALSE
]
metadata$.openspecy_index <- as.integer(spectrum_index)
metadata$.openspecy_coord_key <- if(all(c("x", "y") %in% names(metadata))) {
paste(metadata$x, metadata$y)
} else {
rep.int(NA_character_, nrow(metadata))
}
data.table::setcolorder(
metadata,
c(".openspecy_index", ".openspecy_coord_key",
setdiff(names(metadata), c(".openspecy_index", ".openspecy_coord_key")))
)
metadata
}
# Metadata columns worth surfacing as a per-pixel "z variable": present, and
# not constant across every row. Excludes duplicated file/instrument-level
# metadata (file_name, organization, fixed acquisition settings, etc.) that
# repeats identically for every pixel and adds no spatial signal.
app_metadata_variable_columns <- function(metadata, exclude = character()) {
candidates <- setdiff(names(metadata), exclude)
keep <- vapply(candidates, function(col) {
values <- metadata[[col]]
length(unique(values[!is.na(values)])) > 1L
}, logical(1))
candidates[keep]
}
# Large sources get x/y/z/col_id plus any other per-pixel "z variable" only
# -- the columns a heatmap could be colored by -- dropping duplicated
# file-level metadata that would otherwise repeat unchanged across a huge
# number of rows. Smaller sources keep every column but move the same set to
# the front, so both cases surface what's spatially informative first.
app_uploaded_metadata_large_threshold <- 100000L
app_uploaded_metadata_display <- function(metadata, large = NULL) {
display <- metadata[
, !names(metadata) %in% c(".openspecy_index", ".openspecy_coord_key"),
with = FALSE
]
display <- app_round_reported_metadata(display)
if(is.null(large)) {
large <- nrow(display) > app_uploaded_metadata_large_threshold
}
front <- intersect(c("x", "y", "z", "col_id"), names(display))
front <- c(front, app_metadata_variable_columns(display, exclude = front))
if(isTRUE(large)) {
return(display[, front, with = FALSE])
}
data.table::setcolorder(display, c(front, setdiff(names(display), front)))
display
}
app_uploaded_metadata_spectrum <- function(metadata, rows_selected) {
row <- suppressWarnings(as.integer(rows_selected))
row <- row[
!is.na(row) & row >= 1L & row <= nrow(metadata)
]
if(length(row) != 1L) return(integer())
as.integer(metadata$.openspecy_index[[row]])
}
app_uploaded_metadata_row <- function(metadata, spectrum_index) {
spectrum_index <- suppressWarnings(as.integer(spectrum_index))
if(length(spectrum_index) != 1L || is.na(spectrum_index)) return(integer())
row <- match(spectrum_index, metadata$.openspecy_index)
if(is.na(row)) integer() else as.integer(row)
}
app_uploaded_metadata_table <- function(metadata, selected = integer(),
simple = TRUE, particle = FALSE,
pixel_size = 1,
pixel_unit = "pixel",
match_label = "Correlation",
signal_label = "Signal to Noise") {
large <- !isTRUE(simple) &&
nrow(metadata) > app_uploaded_metadata_large_threshold
caption <- if(isTRUE(simple)) {
"Uploaded Metadata"
} else if(isTRUE(large)) {
paste0(
"Uploaded Metadata (", format(nrow(metadata), big.mark = ","),
" spectra: showing only x/y/z and other per-pixel columns that vary",
" across spectra; unchanging file-level columns are hidden)"
)
} else {
"Uploaded Metadata"
}
display <- if(isTRUE(simple)) {
app_selection_metadata_display(
metadata, simple = TRUE, particle = particle,
pixel_size = pixel_size, pixel_unit = pixel_unit,
match_label = match_label, signal_label = signal_label
)
} else {
app_uploaded_metadata_display(metadata, large = large)
}
DT::datatable(
display,
escape = TRUE,
options = list(
scrollX = TRUE,
sDom = '<"top">lrt<"bottom">ip',
lengthChange = FALSE,
pageLength = 5
),
rownames = FALSE,
filter = "top",
caption = caption,
style = "bootstrap",
selection = list(mode = "single", selected = selected)
)
}
app_selected_metadata <- function(x, selected_match, signal_to_noise) {
# Downloaded/matched output keeps every column regardless of source size --
# the large-source reduction in app_uploaded_metadata_display() is a
# display-only convenience for the Uploaded Metadata tab.
metadata <- app_uploaded_metadata_display(
app_uploaded_metadata_cache(x, signal_to_noise), large = FALSE
)
selected_match <- data.table::copy(
data.table::as.data.table(selected_match)
)
if("material_class" %in% names(metadata) &&
"material_class" %in% names(selected_match)) {
metadata[, material_class := NULL]
}
result <- metadata[selected_match, on = c(col_id = "object_id")]
result <- result[
, !vapply(result, OpenSpecy::is_empty_vector, logical(1)), with = FALSE
] %>%
dplyr::select(
dplyr::any_of(c(
"file_name", "col_id", "material_class", "spectrum_identity",
"match_val", "signal_to_noise"
)),
dplyr::everything()
)
result
}
app_matches_for_object <- function(matches, object_id) {
matches <- data.table::as.data.table(matches)
object_id <- as.character(object_id)
if(!"object_id" %in% names(matches) || length(object_id) != 1L ||
is.na(object_id)) {
stop("A single valid spectrum identifier is required.", call. = FALSE)
}
selected_rows <- which(as.character(matches[["object_id"]]) == object_id)
data.table::copy(matches[selected_rows])
}
app_map_color_choices <- function(identification_active, model_library,
collapse, availability = NULL,
signal_label = "Signal/Noise") {
choices <- c(
if(isTRUE(identification_active)) "Material Class" else NA_character_,
if(isTRUE(identification_active) && !isTRUE(model_library))
"Match ID" else NA_character_,
if(isTRUE(identification_active)) "Match Value" else NA_character_,
"Signal/Noise",
if(isTRUE(collapse)) "Particle Unit" else NA_character_
)
choices <- choices[!is.na(choices)]
if(!is.null(availability)) {
available <- as.logical(availability[choices])
available[is.na(available)] <- FALSE
choices <- choices[available]
}
labels <- choices
signal_label <- as.character(signal_label)[1L]
if(is.na(signal_label) || !nzchar(trimws(signal_label))) {
signal_label <- "Signal/Noise"
}
labels[choices == "Signal/Noise"] <- signal_label
stats::setNames(choices, labels)
}
# The Top Matches table shows the ranked candidate list for the SELECTED
# spectrum in real-library mode (matches_to_single_result already scoped to
# one spectrum), but AI mode's matches_to_single_result has one prediction
# row per spectrum in the whole dataset instead of ranked candidates, so it
# must be indexed down to the selection first. any_of() drops columns AI
# mode's narrower match_val/material_class shape doesn't have, instead of
# erroring on a literal select() of library-metadata columns that don't
# exist there.
app_top_matches_table <- function(matches_to_single_result, model_library,
selected_index, simple = TRUE,
match_label = app_match_value_label(
model_library
)) {
matches_to_single_result <- data.table::as.data.table(matches_to_single_result)
result <- if(isTRUE(model_library)) {
rows <- if("spectrum_index" %in% names(matches_to_single_result)) {
matches_to_single_result[spectrum_index == selected_index]
} else {
matches_to_single_result[selected_index, ]
}
if("prediction_rank" %in% names(rows)) {
data.table::setorder(rows, prediction_rank)
}
rows %>%
dplyr::select(dplyr::any_of(c(
"prediction_rank", "match_val", "material_class", "spectrum_identity",
"organization", "sample_name"
)))
} else {
matches_to_single_result %>%
dplyr::select("match_val", "material_class", "spectrum_identity",
"organization", "sample_name")
}
result <- data.table::as.data.table(result)
result <- app_round_reported_metadata(result)
if(!isTRUE(simple)) return(result)
result <- app_selection_metadata_display(
result, simple = TRUE, library = TRUE, match_label = match_label
)
columns <- intersect(
c(match_label, "Material Class", "Spectrum Identity", "Organization"),
names(result)
)
result[, columns, with = FALSE]
}
# Resolve the explanatory logistic model from the same compact prediction rows
# that feed Top Matches. Predictions may contain several spectra and several
# type-specific models, so both axes must be selected before interpreting the
# table row number.
app_selected_model_explanation <- function(predictions, library,
selected_index,
selected_row = 1L) {
empty <- list(model = NULL, model_class = NULL)
predictions <- data.table::as.data.table(predictions)
selected_index <- suppressWarnings(as.integer(selected_index)[1L])
if(!nrow(predictions) || is.na(selected_index) || selected_index < 1L) {
return(empty)
}
rows <- if("spectrum_index" %in% names(predictions)) {
predictions[spectrum_index == selected_index]
} else if("x" %in% names(predictions)) {
predictions[x == selected_index]
} else if(selected_index <= nrow(predictions)) {
predictions[selected_index]
} else {
predictions[0L]
}
if(!nrow(rows)) return(empty)
if("prediction_rank" %in% names(rows)) {
data.table::setorder(rows, prediction_rank)
} else if("rank" %in% names(rows)) {
data.table::setorder(rows, rank)
}
selected_row <- suppressWarnings(as.integer(selected_row)[1L])
if(is.na(selected_row) || selected_row < 1L) selected_row <- 1L
selected <- rows[min(selected_row, nrow(rows))]
model <- library
if(inherits(model, "openspecy_typed_models")) {
type_column <- intersect(c("spectrum_type", "type"), names(selected))
if(!length(type_column)) return(empty)
type <- as.character(selected[[type_column[[1L]]]][[1L]])
if(!isTruthy(type) || is.null(model[[type]])) return(empty)
model <- model[[type]]
}
model_type <- if(is.null(model$model_type)) {
"logistic_regression"
} else {
as.character(model$model_type)[1L]
}
class_column <- intersect(
c(".model_class_key", "model_class", "material_class", "name"),
names(selected)
)
if(!identical(model_type, "logistic_regression") || !length(class_column)) {
return(empty)
}
model_class <- as.character(selected[[class_column[[1L]]]][[1L]])
if(is.na(model_class) || !nzchar(model_class)) return(empty)
list(model = model, model_class = model_class)
}
# Project a one-pass pixel Top-N result onto collapsed units without averaging
# incomplete reference coverage into a synthetic correlation. Each retained
# value remains an actual member-pixel correlation and carries its provenance.
app_aggregate_unit_matches <- function(matches, mapping, unit_ids, library_ids,
top_n = 10L, library_groups = NULL) {
matches <- data.table::copy(data.table::as.data.table(matches))
mapping <- data.table::copy(data.table::as.data.table(mapping))
if(!all(c("object_id", "library_id", "match_val") %in% names(matches)) ||
!all(c("pixel_id", "unit_id", "pixel_index", "kept") %in%
names(mapping))) {
stop("Unit-match projection received incomplete matches or mapping.",
call. = FALSE)
}
unit_ids <- as.character(unit_ids)
library_ids <- as.character(library_ids)
if(anyDuplicated(unit_ids) || anyDuplicated(library_ids)) {
stop("Unit and library identifiers must be unique.", call. = FALSE)
}
top_n <- suppressWarnings(as.integer(top_n))
if(length(top_n) != 1L || is.na(top_n) || top_n < 1L) top_n <- 1L
top_n <- min(top_n, length(library_ids))
if(!is.null(library_groups)) {
library_groups <- trimws(as.character(library_groups))
if(length(library_groups) != length(library_ids) || anyNA(library_groups) ||
any(!nzchar(library_groups))) {
stop("Library groups must align with every library identifier.",
call. = FALSE)
}
}
membership <- mapping[
kept & !is.na(unit_id),
.(object_id = pixel_id, unit_id, pixel_index)
]
joined <- merge(
matches, membership, by = "object_id", all = FALSE, sort = FALSE,
allow.cartesian = TRUE
)
if(!nrow(joined)) {
return(data.table::data.table(
object_id = character(), library_id = character(), match_val = numeric(),
source_pixel_id = character()
))
}
joined[, `:=`(
source_pixel_id = object_id,
library_order = match(library_id, library_ids),
unit_order = match(unit_id, unit_ids)
)]
joined[, library_group := if(is.null(library_groups)) {
"__all__"
} else library_groups[library_order]]
if(anyNA(joined$library_order) || anyNA(joined$unit_order)) {
stop("Unit-match projection identifiers do not align.", call. = FALSE)
}
data.table::setorder(
joined, unit_order, -match_val, library_order, pixel_index, na.last = TRUE
)
ranked <- joined[, .SD[1L], by = .(unit_id, library_id)]
data.table::setorder(
ranked, unit_order, -match_val, library_order, pixel_index,
na.last = TRUE
)
ranked[, .rank := seq_len(.N), by = .(unit_id, library_group)]
ranked <- ranked[.rank <= top_n]
ranked[, .(
object_id = unit_id, library_id, match_val, source_pixel_id
)]
}
# Join and format the already-ranked blockwise result used by every app
# identification consumer. No correlation matrix is reconstructed here.
app_top_matches_export_compact <- function(
matches, library_metadata, spectrum_metadata, signal_to_noise,
match_threshold, signal_threshold = c(-Inf, Inf), top_n = 1L,
top_n_by = NULL, simple = TRUE, quant_columns = character(),
match_label = "Correlation", signal_label = "Signal to Noise") {
matches <- data.table::copy(data.table::as.data.table(matches))
required_matches <- c("object_id", "library_id", "match_val")
if(!all(required_matches %in% names(matches)) || !nrow(matches)) {
stop("Top Matches requires a nonempty ranked match table.", call. = FALSE)
}
library_metadata <- data.table::as.data.table(library_metadata)
spectrum_metadata <- data.table::as.data.table(spectrum_metadata)
if(!all(c("sample_name", "material_class") %in%
names(library_metadata))) {
stop("Reference metadata is missing Top Matches identifiers.",
call. = FALSE)
}
if(!all(c("file_name", "col_id") %in% names(spectrum_metadata))) {
stop("Uploaded metadata is missing Top Matches identifiers.",
call. = FALSE)
}
library_ids <- as.character(library_metadata$sample_name)
spectrum_ids <- as.character(spectrum_metadata$col_id)
if(anyDuplicated(library_ids) || anyDuplicated(spectrum_ids)) {
stop("Top Matches identifiers must be unique.", call. = FALSE)
}
if(any(!matches$library_id %in% library_ids) ||
any(!matches$object_id %in% spectrum_ids)) {
stop("Top Matches metadata does not align with the ranked matches.",
call. = FALSE)
}
top_n <- suppressWarnings(as.integer(top_n))
if(length(top_n) != 1L || is.na(top_n) || top_n < 1L) top_n <- 1L
top_n <- min(top_n, length(library_ids))
if(!is.null(top_n_by)) {
if(!is.character(top_n_by) || length(top_n_by) != 1L ||
!top_n_by %in% names(library_metadata)) {
stop("Top Matches grouping column is missing from reference metadata.",
call. = FALSE)
}
groups <- trimws(as.character(library_metadata[[top_n_by]]))
if(anyNA(groups) || any(!nzchar(groups))) {
stop("Top Matches grouping values must be nonblank.", call. = FALSE)
}
matches[, .match_group := groups[match(library_id, library_ids)]]
} else {
matches[, .match_group := "__all__"]
}
matches[, .rank := seq_len(.N), by = .(object_id, .match_group)]
matches <- matches[.rank <= top_n]
matches[, c(".rank", ".match_group") := NULL]
thresholds <- suppressWarnings(as.numeric(signal_threshold))
thresholds <- thresholds[!is.na(thresholds)]
signal_min <- if(length(thresholds)) thresholds[[1L]] else -Inf
signal_max <- if(length(thresholds) > 1L) thresholds[[2L]] else Inf
if(length(signal_to_noise) != length(spectrum_ids)) {
stop("Signal-to-noise values do not align with uploaded spectra.",
call. = FALSE)
}
if(!is.null(names(signal_to_noise)) &&
all(spectrum_ids %in% names(signal_to_noise))) {
signal_to_noise <- signal_to_noise[spectrum_ids]
}
spectrum_details <- data.table::data.table(
col_id = spectrum_ids,
match_threshold = match_threshold,
signal_to_noise = as.numeric(signal_to_noise),
signal_threshold_min = signal_min,
signal_threshold_max = signal_max,
good_signal = is.finite(as.numeric(signal_to_noise)) &
as.numeric(signal_to_noise) > signal_min &
as.numeric(signal_to_noise) < signal_max
)
spectrum_details <- spectrum_details[spectrum_metadata, on = "col_id"]
library_for_join <- data.table::copy(library_metadata)[
, !names(library_metadata) %in% c("col_id", "file_name"), with = FALSE
]
data.table::setnames(
library_for_join, "material_class", ".reference_material_class"
)
if("spectrum_identity" %in% names(library_for_join)) {
data.table::setnames(
library_for_join, "spectrum_identity", ".reference_spectrum_identity"
)
} else {
library_for_join[, .reference_spectrum_identity := NA_character_]
}
result <- matches %>%
dplyr::left_join(library_for_join,
by = c("library_id" = "sample_name")) %>%
dplyr::left_join(spectrum_details,
by = c("object_id" = "col_id")) %>%
dplyr::rename(sample_name = library_id, col_id = object_id) %>%
dplyr::mutate(
good_match_vals = is.finite(match_val) & match_val >= match_threshold,
good_matches = good_match_vals & good_signal,
material_class = ifelse(
good_match_vals & !is.na(.reference_material_class) &
nzchar(.reference_material_class),
.reference_material_class, "unknown"
),
spectrum_identity = .reference_spectrum_identity
) %>%
dplyr::select(-dplyr::starts_with(".reference_")) %>%
data.table::as.data.table()
keep <- !vapply(result, OpenSpecy::is_empty_vector, logical(1)) |
names(result) %in% quant_columns
result <- result[, keep, with = FALSE] %>%
dplyr::select(
dplyr::any_of(c(
"file_name", "col_id", "material_class", "spectrum_identity",
"match_val", "signal_to_noise"
)),
dplyr::everything()
)
result <- app_without_particle_metadata(result)
result <- app_round_reported_metadata(result)
if(isTRUE(simple)) {
result <- app_selection_metadata_display(
result, simple = TRUE, particle = FALSE, library = TRUE,
match_label = match_label, signal_label = signal_label
)
}
data.table::as.data.table(result)
}
app_empty_ratio_definitions <- function() {
data.frame(
id = integer(),
name = character(),
column = character(),
type = character(),
numerator_min = numeric(),
numerator_max = numeric(),
denominator_min = numeric(),
denominator_max = numeric(),
stringsAsFactors = FALSE
)
}
app_empty_measurement_definitions <- function() {
data.frame(
id = integer(),
name = character(),
column = character(),
type = character(),
minimum = numeric(),
maximum = numeric(),
stringsAsFactors = FALSE
)
}
# Input IDs are kept as the exported column names so the settings snapshot is
# readable beside the app source without promising a future import contract.
app_user_metadata_input_ids <- c(
# Preprocessing
"spike_decision", "spike_method", "spike_direction",
"spike_width_threshold", "spike_noise_multiplier",
"spike_interpolation_window", "spike_residual_threshold",
"spike_residual_window",
"saturation_decision", "saturation_mode", "saturation_ceiling",
"saturation_max_loss", "make_rel_decision", "smooth_decision",
"smoother", "derivative_order", "smoother_window", "derivative_abs",
"conform_decision", "conform_selection", "conform_res",
"intensity_decision", "intensity_corr", "baseline_decision",
"baseline_method", "baseline", "refit", "baseline_lambda",
"baseline_hwi", "iterations", "range_decision", "range_automate",
"range_artifact_ratio", "MinRange", "MaxRange", "co2_decision",
"co2_automate", "co2_artifact_ratio", "MinFlat", "MaxFlat",
# Identification
"identification_active", "id_spec_type", "id_strategy", "lib_type",
"top_n_input", "top_n_per_organization", "filter_lib", "lib_org",
# Advanced
"threshold_decision", "signal_basis", "MinSNR", "MaxSNR",
"signal_selection",
"cor_threshold_decision", "MinCor", "spatial_decision", "sigma",
"xy_grid", "load_entire_map", "identify_batch_size",
"collapse_decision", "collapse_type",
"particle_id_strategy",
"particle_pca_components", "particle_cluster_k", "particle_area_threshold",
"pixel_size", "pixel_unit", "simple_metadata", "show_peak_positions",
"peak_count", "visual_overlay", "overlay_transparency",
# Quantification builder
"quant_ratio_name", "quant_ratio_type",
"quant_numerator_area_min", "quant_numerator_area_max",
"quant_denominator_area_min", "quant_denominator_area_max",
"quant_numerator_peak", "quant_denominator_peak",
"quant_measurement_name", "quant_measurement_type",
"quant_measurement_area_min", "quant_measurement_area_max",
"quant_measurement_wavenumber"
)
# These controls change only presentation/export formatting and must remain
# live without marking an otherwise completed scientific analysis stale.
app_live_display_input_ids <- c(
"pixel_size", "pixel_unit", "simple_metadata", "show_peak_positions",
"peak_count", "visual_overlay", "overlay_transparency"
)
app_logical_setting_ids <- c(
"spike_decision", "saturation_decision", "make_rel_decision",
"smooth_decision", "derivative_abs", "conform_decision",
"intensity_decision", "baseline_decision", "refit", "range_decision",
"range_automate", "co2_decision", "co2_automate",
"identification_active", "top_n_per_organization", "filter_lib",
"threshold_decision", "cor_threshold_decision", "spatial_decision",
"xy_grid", "load_entire_map", "collapse_decision", "simple_metadata",
"show_peak_positions", "visual_overlay"
)
app_numeric_setting_ids <- c(
"spike_width_threshold", "spike_noise_multiplier",
"spike_interpolation_window", "spike_residual_threshold",
"spike_residual_window", "saturation_ceiling",
"saturation_max_loss", "derivative_order", "smoother_window",
"conform_res", "baseline", "baseline_lambda", "baseline_hwi",
"iterations", "range_artifact_ratio", "MinRange", "MaxRange",
"co2_artifact_ratio", "MinFlat", "MaxFlat", "top_n_input", "MinSNR",
"MaxSNR", "MinCor", "sigma", "identify_batch_size",
"particle_pca_components", "particle_cluster_k", "particle_area_threshold",
"pixel_size", "peak_count", "overlay_transparency",
"quant_numerator_area_min", "quant_numerator_area_max",
"quant_denominator_area_min", "quant_denominator_area_max",
"quant_numerator_peak", "quant_denominator_peak",
"quant_measurement_area_min", "quant_measurement_area_max",
"quant_measurement_wavenumber"
)
app_saturation_value <- function(mode = "auto", ceiling = NULL) {
mode <- match.arg(mode, c("auto", "threshold"))
if(identical(mode, "auto")) return("auto")
if(!is.numeric(ceiling) || length(ceiling) != 1L ||
!is.finite(ceiling)) {
stop("Enter one finite detector ceiling for threshold saturation mode.",
call. = FALSE)
}
as.numeric(ceiling)
}
app_apply_spectral_corrections <- function(
x,
spike = TRUE,
spike_args = list(),
saturation = "auto",
saturation_args = list()) {
if(!inherits(x, "OpenSpecy")) {
stop("'x' must be an OpenSpecy object", call. = FALSE)
}
if(!is.list(spike_args) || !is.list(saturation_args)) {
stop("Correction arguments must be supplied as lists.", call. = FALSE)
}
current <- x
if(isTRUE(spike)) {
current <- do.call(correct_spike, c(list(x = current), spike_args))
}
if(!is.null(saturation)) {
current <- withCallingHandlers(
do.call(
restrict_range,
c(list(x = current, saturation = saturation, make_rel = FALSE),
saturation_args)
),
warning = function(warning) invokeRestart("muffleWarning")
)
}
attr(current, "app_automatic_correction_state") <- c(
spike = isTRUE(spike), saturation = !is.null(saturation)
)
current
}
app_copy_correction_history <- function(from, to) {
for(name in c(
"automatic_spike", "saturation_restriction",
"app_automatic_correction_state")) {
value <- attr(from, name, exact = TRUE)
if(!is.null(value)) attr(to, name) <- value
}
to
}
app_conform_axis <- function(x, resolution) {
target <- conform_res(x$wavenumber, res = resolution)
diagnostic <- attr(x, "saturation_restriction", exact = TRUE)
excluded <- if(is.list(diagnostic) && isTRUE(diagnostic$applied)) {
diagnostic$excluded_ranges
} else {
NULL
}
if(!is.null(excluded) && nrow(excluded)) {
keep <- rep(TRUE, length(target))
for(i in seq_len(nrow(excluded))) {
keep <- keep & !(target >= excluded$region_min[[i]] &
target <= excluded$region_max[[i]])
}
target <- target[keep]
}
if(length(target) < 3L) {
stop("Correction and conformation left fewer than three wavenumbers.",
call. = FALSE)
}
target
}
# "Mean Up" is a resolution-aware conform strategy, not a fixed conform type:
# the uploaded spectra are only resampled to the requested resolution when
# that target is finer (a smaller cm^-1 step) than what was actually
# uploaded; otherwise the uploaded axis is left alone and the reference
# library is conformed onto it instead (see identify_blockwise's
# preserve_axis), since aggregating real uploaded data down to a coarser
# axis would discard information the library doesn't have to begin with.
app_conform_preserve_axis <- function(uploaded, conform_decision,
conform_selection, conform_res) {
if(!identical(conform_selection, "mean_up")) return(FALSE)
if(!isTRUE(conform_decision)) return(TRUE)
native_res <- spec_res(uploaded)
!is.finite(native_res) || as.numeric(conform_res) >= native_res
}
app_attach_correction_metadata <- function(x) {
x <- as_OpenSpecy(x)
x$metadata <- data.table::copy(x$metadata)
spike <- attr(x, "automatic_spike", exact = TRUE)
if(is.list(spike)) {
x$metadata$spike_correction_applied <- isTRUE(spike$applied)
x$metadata$spike_correction_reason <- as.character(spike$reason)
x$metadata$spike_corrected_region_count <-
nrow(spike$corrected_regions)
}
saturation <- attr(x, "saturation_restriction", exact = TRUE)
if(is.list(saturation)) {
format_ranges <- function(ranges) {
if(is.null(ranges) || !nrow(ranges)) return(NA_character_)
paste0(
format(ranges$region_min, trim = TRUE), "-",
format(ranges$region_max, trim = TRUE),
collapse = " | "
)
}
x$metadata$saturation_restriction_applied <-
isTRUE(saturation$applied)
x$metadata$saturation_restriction_reason <-
as.character(saturation$reason)
x$metadata$saturation_loss_fraction <-
as.numeric(saturation$saturation_loss_fraction)
x$metadata$saturation_proposed_loss_fraction <-
as.numeric(saturation$proposed_saturation_loss_fraction)
x$metadata$saturation_excluded_ranges <-
format_ranges(saturation$excluded_ranges)
x$metadata$saturation_proposed_excluded_ranges <-
format_ranges(saturation$proposed_excluded_ranges)
x$metadata$saturation_detected_spectra <- paste(
saturation$detected_spectra, collapse = " | "
)
}
x
}
app_metadata_scalar <- function(value, separator = " | ") {
if(is.null(value) || !length(value)) return(NA_character_)
if(inherits(value, "POSIXt")) {
value <- format(value, "%Y-%m-%d %H:%M:%S %z")
}
if(is.factor(value)) value <- as.character(value)
if(is.list(value)) value <- unlist(value, recursive = TRUE, use.names = FALSE)
if(!length(value)) return(NA_character_)
if(length(value) == 1L && is.atomic(value)) return(value[[1L]])
paste(as.character(value), collapse = separator)
}
app_saved_ratio_definitions <- function(definitions) {
if(is.null(definitions) || !is.data.frame(definitions) ||
!nrow(definitions)) {
return(NA_character_)
}
required <- names(app_empty_ratio_definitions())
if(!all(required %in% names(definitions))) {
stop("Saved ratio definitions have an unexpected structure.",
call. = FALSE)
}
paste(vapply(seq_len(nrow(definitions)), function(i) {
definition <- definitions[i, required, drop = FALSE]
paste(
paste0("id=", definition$id[[1L]]),
paste0("name=", definition$name[[1L]]),
paste0("column=", definition$column[[1L]]),
paste0("type=", definition$type[[1L]]),
paste0("numerator_min=", definition$numerator_min[[1L]]),
paste0("numerator_max=", definition$numerator_max[[1L]]),
paste0("denominator_min=", definition$denominator_min[[1L]]),
paste0("denominator_max=", definition$denominator_max[[1L]]),
sep = "; "
)
}, character(1)), collapse = " || ")
}
app_saved_measurement_definitions <- function(definitions) {
if(is.null(definitions) || !is.data.frame(definitions) ||
!nrow(definitions)) {
return(NA_character_)
}
required <- names(app_empty_measurement_definitions())
if(!all(required %in% names(definitions))) {
stop("Saved measurement definitions have an unexpected structure.",
call. = FALSE)
}
paste(vapply(seq_len(nrow(definitions)), function(i) {
definition <- definitions[i, required, drop = FALSE]
paste(
paste0("id=", definition$id[[1L]]),
paste0("name=", definition$name[[1L]]),
paste0("column=", definition$column[[1L]]),
paste0("type=", definition$type[[1L]]),
paste0("minimum=", definition$minimum[[1L]]),
paste0("maximum=", definition$maximum[[1L]]),
sep = "; "
)
}, character(1)), collapse = " || ")
}
app_user_metadata_snapshot <- function(settings, definitions, recorded_at,
app_version, session_id,
source = NULL, file_info = NULL,
measurements =
app_empty_measurement_definitions()) {
if(!is.list(settings)) {
stop("App settings must be supplied as a named list.", call. = FALSE)
}
uploaded <- !is.null(source)
spectra_count <- if(uploaded && is_Specs(source)) {
specs_source_count(source)
} else if(uploaded) ncol(source$spectra) else NA_integer_
source_axis <- if(uploaded && inherits(source, "FileSpecs")) {
OpenSpecy:::.filespec_axis(source)
} else if(uploaded && is_Specs(source)) {
source$variables
} else if(uploaded) source$wavenumber else numeric()
wavenumber_count <- if(uploaded) length(source_axis) else NA_integer_
wavenumber_min <- if(uploaded && wavenumber_count) {
min(source_axis, na.rm = TRUE)
} else NA_real_
wavenumber_max <- if(uploaded && wavenumber_count) {
max(source_axis, na.rm = TRUE)
} else NA_real_
data_digest <- if(uploaded) {
digest::digest(source, algo = "md5")
} else NA_character_
file_value <- function(name) {
if(is.null(file_info) || !is.data.frame(file_info) ||
!name %in% names(file_info)) return(NA_character_)
app_metadata_scalar(file_info[[name]])
}
settings <- stats::setNames(lapply(app_user_metadata_input_ids, function(id) {
app_metadata_scalar(settings[[id]])
}), app_user_metadata_input_ids)
snapshot <- c(
list(
metadata_schema_version = 1L,
recorded_at = app_metadata_scalar(recorded_at),
app_version = app_metadata_scalar(app_version),
session_id = app_metadata_scalar(session_id),
data_uploaded = uploaded,
data_file_name = file_value("name"),
data_file_size_bytes = file_value("size"),
data_file_type = file_value("type"),
data_file_last_modified = file_value("lastModified"),
data_digest_md5 = data_digest,
data_spectrum_count = spectra_count,
data_wavenumber_count = wavenumber_count,
data_wavenumber_min = wavenumber_min,
data_wavenumber_max = wavenumber_max
),
settings,
list(
quant_saved_ratio_count = if(is.data.frame(definitions)) {
nrow(definitions)
} else 0L,
quant_saved_ratio_definitions = app_saved_ratio_definitions(definitions),
quant_saved_measurement_count = if(is.data.frame(measurements)) {
nrow(measurements)
} else 0L,
quant_saved_measurement_definitions =
app_saved_measurement_definitions(measurements)
)
)
snapshot <- lapply(snapshot, app_metadata_scalar)
if(any(lengths(snapshot) != 1L)) {
stop("Every user metadata field must contain exactly one value.",
call. = FALSE)
}
snapshot
}
app_parse_saved_definitions <- function(value, template) {
if(length(value) != 1L || is.na(value) || !nzchar(trimws(value))) {
return(template)
}
rows <- strsplit(as.character(value), " \\|\\| ")[[1L]]
required <- names(template)
parsed <- lapply(rows, function(row) {
fields <- strsplit(row, "; ", fixed = TRUE)[[1L]]
pairs <- strsplit(fields, "=", fixed = TRUE)
keys <- vapply(pairs, `[[`, character(1L), 1L)
values <- vapply(pairs, function(x) paste(x[-1L], collapse = "="),
character(1L))
if(anyDuplicated(keys) || !setequal(keys, required)) {
stop("A saved quantification definition has unexpected fields.",
call. = FALSE)
}
stats::setNames(as.list(values[match(required, keys)]), required)
})
out <- data.table::rbindlist(parsed, fill = FALSE)
for(name in required) {
if(is.integer(template[[name]])) {
out[[name]] <- suppressWarnings(as.integer(out[[name]]))
} else if(is.numeric(template[[name]])) {
out[[name]] <- suppressWarnings(as.numeric(out[[name]]))
} else {
out[[name]] <- as.character(out[[name]])
}
if(anyNA(out[[name]])) {
stop("A saved quantification definition contains an invalid '", name,
"' value.", call. = FALSE)
}
}
as.data.frame(out[, required, with = FALSE], stringsAsFactors = FALSE)
}
app_standard_settings_choices <- c(
"Default" = "default",
"MIPPR - Thermo Fisher iN10 MX" = "mippr_in10_mx"
)
app_standard_settings <- function(preset, defaults) {
preset <- match.arg(preset, unname(app_standard_settings_choices))
if(!is.list(defaults) ||
!all(app_user_metadata_input_ids %in% names(defaults))) {
stop("App defaults are not ready; wait for the controls to finish loading.",
call. = FALSE)
}
settings <- defaults[app_user_metadata_input_ids]
if(identical(preset, "mippr_in10_mx")) {
overrides <- list(
spatial_decision = TRUE,
collapse_decision = TRUE,
threshold_decision = TRUE,
signal_selection = "sig_times_noise",
MinSNR = 0.01,
cor_threshold_decision = FALSE,
load_entire_map = TRUE,
id_spec_type = "ftir",
top_n_per_organization = FALSE,
co2_decision = TRUE,
co2_automate = FALSE,
range_decision = TRUE,
range_automate = FALSE,
MinRange = 800,
MaxRange = 3200
)
settings[names(overrides)] <- overrides
}
list(
settings = settings,
ratios = app_empty_ratio_definitions(),
measurements = app_empty_measurement_definitions(),
unknown = character(),
preset = preset
)
}
app_user_metadata_import <- function(snapshot, defaults) {
if(!is.data.frame(snapshot) || nrow(snapshot) != 1L) {
stop("Load Settings requires exactly one CSV data row.", call. = FALSE)
}
if(anyDuplicated(names(snapshot))) {
stop("Load Settings CSV column names must be unique.", call. = FALSE)
}
version <- if("metadata_schema_version" %in% names(snapshot)) {
suppressWarnings(as.integer(snapshot$metadata_schema_version[[1L]]))
} else 1L
if(length(version) != 1L || is.na(version) || version != 1L) {
stop("Unsupported settings metadata schema version: ",
as.character(snapshot$metadata_schema_version[[1L]]), call. = FALSE)
}
if(!is.list(defaults) || !all(app_user_metadata_input_ids %in% names(defaults))) {
stop("App defaults are not ready; wait for the Advanced tab to finish loading.",
call. = FALSE)
}
settings <- defaults[app_user_metadata_input_ids]
present <- intersect(app_user_metadata_input_ids, names(snapshot))
for(id in present) {
raw <- snapshot[[id]][[1L]]
if(length(raw) != 1L || is.na(raw) ||
(is.character(raw) && !nzchar(trimws(raw)))) next
if(id %in% app_logical_setting_ids) {
text <- tolower(trimws(as.character(raw)))
if(!text %in% c("true", "false", "1", "0")) {
stop("Setting '", id, "' must be TRUE or FALSE.", call. = FALSE)
}
settings[[id]] <- text %in% c("true", "1")
} else if(id %in% app_numeric_setting_ids) {
value <- suppressWarnings(as.numeric(raw))
if(length(value) != 1L || !is.finite(value)) {
stop("Setting '", id, "' must be a finite number.", call. = FALSE)
}
settings[[id]] <- value
} else if(identical(id, "lib_org")) {
settings[[id]] <- strsplit(as.character(raw), " \\| ")[[1L]]
} else {
settings[[id]] <- as.character(raw)
}
}
saved_value <- function(name) {
if(name %in% names(snapshot)) snapshot[[name]][[1L]] else NA_character_
}
ratios <- app_parse_saved_definitions(
saved_value("quant_saved_ratio_definitions"),
app_empty_ratio_definitions()
)
measurements <- app_parse_saved_definitions(
saved_value("quant_saved_measurement_definitions"),
app_empty_measurement_definitions()
)
provenance <- c(
"metadata_schema_version", "recorded_at", "app_version", "session_id",
"data_uploaded", "data_file_name", "data_file_size_bytes",
"data_file_type", "data_file_last_modified", "data_digest_md5",
"data_spectrum_count", "data_wavenumber_count", "data_wavenumber_min",
"data_wavenumber_max", "quant_saved_ratio_count",
"quant_saved_ratio_definitions", "quant_saved_measurement_count",
"quant_saved_measurement_definitions"
)
list(
settings = settings, ratios = ratios, measurements = measurements,
unknown = setdiff(names(snapshot), c(app_user_metadata_input_ids,
provenance))
)
}
app_quantification_source_value <- "displayed_processed_spectra"
app_ratio_column_name <- function(name, type) {
if(!is.character(name) || length(name) != 1L || is.na(name) ||
!nzchar(trimws(name))) {
stop("Enter a nonempty ratio name before adding it.", call. = FALSE)
}
type <- match.arg(type, c("area", "peak"))
plain <- iconv(trimws(name), to = "ASCII//TRANSLIT", sub = "")
slug <- tolower(gsub("[^A-Za-z0-9]+", "_", plain))
slug <- gsub("^_+|_+$", "", slug)
if(is.na(slug) || !nzchar(slug)) {
stop("The ratio name must contain at least one letter or number.",
call. = FALSE)
}
paste0(type, "_ratio_", slug)
}
app_add_ratio_definition <- function(definitions, name, type, numerator,
denominator, axis = NULL) {
expected <- names(app_empty_ratio_definitions())
if(!is.data.frame(definitions) || !identical(names(definitions), expected)) {
stop("Ratio definitions have an unexpected structure.", call. = FALSE)
}
type <- match.arg(type, c("area", "peak"))
name <- trimws(name)
column <- app_ratio_column_name(name, type)
if(column %in% definitions$column) {
stop("A ratio with the same metadata name has already been added.",
call. = FALSE)
}
validate_axis <- !is.null(axis)
if(validate_axis) {
axis <- sort(unique(as.numeric(axis)))
axis <- axis[is.finite(axis)]
if(!length(axis)) {
stop("The processed spectrum does not have a valid wavenumber axis.",
call. = FALSE)
}
}
normalize_selection <- function(value, expected_length, label) {
if(!is.numeric(value) || length(value) != expected_length ||
any(!is.finite(value))) {
stop(label, " must contain ", expected_length,
" finite wavenumber value", if(expected_length == 1L) "." else "s.",
call. = FALSE)
}
sort(as.numeric(value))
}
if(identical(type, "area")) {
numerator <- normalize_selection(numerator, 2L, "Numerator range")
denominator <- normalize_selection(denominator, 2L, "Denominator range")
} else {
numerator <- rep(normalize_selection(numerator, 1L, "Numerator point"), 2L)
denominator <- rep(normalize_selection(
denominator, 1L, "Denominator point"
), 2L)
}
values <- c(numerator, denominator)
if(validate_axis &&
any(values < axis[[1L]] | values > axis[[length(axis)]])) {
stop(
"Ratio selections must stay within the displayed processed wavenumber range.",
call. = FALSE
)
}
if(validate_axis && identical(type, "area") &&
(!any(axis >= numerator[[1L]] & axis <= numerator[[2L]]) ||
!any(axis >= denominator[[1L]] & axis <= denominator[[2L]]))) {
stop(
"Each area range must contain at least one displayed processed wavenumber.",
call. = FALSE
)
}
next_id <- if(nrow(definitions)) max(definitions$id) + 1L else 1L
rbind(
definitions,
data.frame(
id = next_id,
name = name,
column = column,
type = type,
numerator_min = numerator[[1L]],
numerator_max = numerator[[2L]],
denominator_min = denominator[[1L]],
denominator_max = denominator[[2L]],
stringsAsFactors = FALSE
)
)
}
app_ratio_definition_label <- function(definition) {
if(identical(definition$type[[1L]], "area")) {
paste0(
definition$name[[1L]], " (area: ",
format(definition$numerator_min[[1L]]), "-",
format(definition$numerator_max[[1L]]), " / ",
format(definition$denominator_min[[1L]]), "-",
format(definition$denominator_max[[1L]]), " cm^-1)"
)
} else {
paste0(
definition$name[[1L]], " (peak: ",
format(definition$numerator_min[[1L]]), " / ",
format(definition$denominator_min[[1L]]), " cm^-1)"
)
}
}
app_quantification_defaults <- function(axis, type = c("area", "peak")) {
type <- match.arg(type)
axis <- sort(unique(as.numeric(axis)))
axis <- axis[is.finite(axis)]
if(length(axis) < 2L) {
stop("Process a spectrum with at least two distinct wavenumbers.",
call. = FALSE)
}
axis_min <- min(axis)
axis_max <- max(axis)
if(axis_min >= axis_max) {
stop("The processed wavenumber range must contain at least two values.",
call. = FALSE)
}
clamp_value <- function(value) {
as.numeric(pmax(axis_min, pmin(axis_max, value)))
}
closest_value <- function(value) {
as.numeric(axis[[which.min(abs(axis - value))]])
}
# Numeric inputs permit exact typed values. Points are resolved to measured
# data by point_intensity() or peak_ratio() when quantification runs.
step <- min(diff(axis)) / 10
if(identical(type, "area")) {
scenario <- c(1650, 1850, 1420, 1500)
if(all(scenario >= axis_min & scenario <= axis_max)) {
numerator <- sort(vapply(scenario[1:2], closest_value, numeric(1)))
denominator <- sort(vapply(
scenario[3:4], closest_value, numeric(1)
))
} else {
selections <- axis[pmax(
1L,
pmin(length(axis), round(c(.60, .78, .24, .42) * length(axis)))
)]
numerator <- sort(clamp_value(selections[1:2]))
denominator <- sort(clamp_value(selections[3:4]))
}
} else {
scenario <- c(1715, 1460)
if(all(scenario >= axis_min & scenario <= axis_max)) {
numerator <- closest_value(scenario[[1L]])
denominator <- closest_value(scenario[[2L]])
} else {
numerator <- clamp_value(
axis[[max(1L, round(.67 * length(axis)))]]
)
denominator <- clamp_value(
axis[[max(1L, round(.33 * length(axis)))]]
)
}
}
list(
min = axis_min,
max = axis_max,
step = step,
numerator = numerator,
denominator = denominator
)
}
# Retained as an internal compatibility alias for saved app tests and sessions;
# the UI now uses numeric inputs, not sliders.
app_ratio_slider_defaults <- app_quantification_defaults
app_measurement_column_name <- function(name, type) {
if(!is.character(name) || length(name) != 1L || is.na(name) ||
!nzchar(trimws(name))) {
stop("Enter a nonempty measurement name before adding it.", call. = FALSE)
}
type <- match.arg(type, c("area", "point"))
plain <- iconv(trimws(name), to = "ASCII//TRANSLIT", sub = "")
slug <- tolower(gsub("[^A-Za-z0-9]+", "_", plain))
slug <- gsub("^_+|_+$", "", slug)
if(is.na(slug) || !nzchar(slug)) {
stop("The measurement name must contain at least one letter or number.",
call. = FALSE)
}
paste0(if(identical(type, "area")) {
"area_under_band_"
} else {
"point_intensity_"
}, slug)
}
app_add_measurement_definition <- function(definitions, name, type, values,
axis = NULL) {
expected <- names(app_empty_measurement_definitions())
if(!is.data.frame(definitions) || !identical(names(definitions), expected)) {
stop("Measurement definitions have an unexpected structure.",
call. = FALSE)
}
type <- match.arg(type, c("area", "point"))
name <- trimws(name)
column <- app_measurement_column_name(name, type)
if(column %in% definitions$column) {
stop("A measurement with the same metadata name has already been added.",
call. = FALSE)
}
validate_axis <- !is.null(axis)
if(validate_axis) {
axis <- sort(unique(as.numeric(axis)))
axis <- axis[is.finite(axis)]
if(!length(axis)) {
stop("The processed spectrum does not have a valid wavenumber axis.",
call. = FALSE)
}
}
expected_length <- if(identical(type, "area")) 2L else 1L
if(!is.numeric(values) || length(values) != expected_length ||
any(!is.finite(values))) {
stop(
if(identical(type, "area")) {
"Measurement area must contain two finite wavenumber values."
} else {
"Measurement point must contain one finite wavenumber value."
},
call. = FALSE
)
}
values <- sort(as.numeric(values))
if(identical(type, "point")) values <- rep(values, 2L)
if(validate_axis &&
any(values < axis[[1L]] | values > axis[[length(axis)]])) {
stop(
"Measurement selections must stay within the displayed processed wavenumber range.",
call. = FALSE
)
}
if(validate_axis && identical(type, "area") &&
!any(axis >= values[[1L]] & axis <= values[[2L]])) {
stop(
"The measurement area must contain at least one displayed processed wavenumber.",
call. = FALSE
)
}
next_id <- if(nrow(definitions)) max(definitions$id) + 1L else 1L
rbind(
definitions,
data.frame(
id = next_id,
name = name,
column = column,
type = type,
minimum = values[[1L]],
maximum = values[[2L]],
stringsAsFactors = FALSE
)
)
}
app_measurement_definition_label <- function(definition) {
if(identical(definition$type[[1L]], "area")) {
paste0(
definition$name[[1L]], " (area: ",
format(definition$minimum[[1L]]), "-",
format(definition$maximum[[1L]]), " cm^-1)"
)
} else {
paste0(
definition$name[[1L]], " (intensity: ",
format(definition$minimum[[1L]]), " cm^-1)"
)
}
}
app_ratio_definitions_text <- function(definitions) {
if(!nrow(definitions)) return(character())
paste(
vapply(seq_len(nrow(definitions)), function(i) {
app_ratio_definition_label(definitions[i, , drop = FALSE])
}, character(1)),
collapse = "; "
)
}
app_measurement_definitions_text <- function(definitions) {
if(!nrow(definitions)) return(character())
paste(
vapply(seq_len(nrow(definitions)), function(i) {
app_measurement_definition_label(definitions[i, , drop = FALSE])
}, character(1)),
collapse = "; "
)
}
app_quantification_definitions_text <- function(ratios, measurements) {
parts <- c(
if(nrow(ratios)) paste0("Ratios: ", app_ratio_definitions_text(ratios)),
if(nrow(measurements)) paste0(
"Measurements: ", app_measurement_definitions_text(measurements)
)
)
paste(parts, collapse = "; ")
}
app_ratio_metadata_columns <- function(
definitions,
measurements = app_empty_measurement_definitions()) {
if(!nrow(definitions) && !nrow(measurements)) return(character())
c("quantification_source", "quantification_definitions",
definitions$column, measurements$column)
}
app_area_ratio <- function(source, numerator, denominator) {
source <- as_OpenSpecy(source)
axis <- source$wavenumber
named_na <- stats::setNames(
rep(NA_real_, ncol(source$spectra)), colnames(source$spectra)
)
complete <- all(c(numerator, denominator) >= min(axis) &
c(numerator, denominator) <= max(axis)) &&
any(axis >= numerator[[1L]] & axis <= numerator[[2L]]) &&
any(axis >= denominator[[1L]] & axis <= denominator[[2L]])
if(!complete) {
warning("The source spectrum does not fully cover this area ratio; returning NA.",
call. = FALSE)
return(named_na)
}
numerator_values <- area_under_band(
source, min = numerator[[1L]], max = numerator[[2L]]
)
denominator_values <- area_under_band(
source, min = denominator[[1L]], max = denominator[[2L]]
)
values <- numerator_values / denominator_values
invalid <- !is.finite(numerator_values) | !is.finite(denominator_values) |
denominator_values == 0 | !is.finite(values)
if(any(invalid)) {
warning("One or more area ratios had a zero or non-finite value; returning NA for those spectra.",
call. = FALSE)
values[invalid] <- NA_real_
}
values
}
app_area_measurement <- function(source, bounds) {
source <- as_OpenSpecy(source)
axis <- source$wavenumber
named_na <- stats::setNames(
rep(NA_real_, ncol(source$spectra)), colnames(source$spectra)
)
complete <- length(bounds) == 2L && all(is.finite(bounds)) &&
all(bounds >= min(axis) & bounds <= max(axis)) &&
any(axis >= bounds[[1L]] & axis <= bounds[[2L]])
if(!complete) {
warning(
"The source spectrum does not fully cover this area measurement; returning NA.",
call. = FALSE
)
return(named_na)
}
area_under_band(source, min = bounds[[1L]], max = bounds[[2L]])
}
app_attach_quantification <- function(
x,
definitions,
measurements = app_empty_measurement_definitions()) {
x <- as_OpenSpecy(x)
if(!nrow(definitions) && !nrow(measurements)) return(x)
x$metadata <- data.table::copy(x$metadata)
x$metadata$quantification_source <- app_quantification_source_value
x$metadata$quantification_definitions <-
app_quantification_definitions_text(definitions, measurements)
for(i in seq_len(nrow(definitions))) {
definition <- definitions[i, , drop = FALSE]
values <- if(identical(definition$type[[1L]], "area")) {
app_area_ratio(
x,
c(definition$numerator_min[[1L]], definition$numerator_max[[1L]]),
c(definition$denominator_min[[1L]], definition$denominator_max[[1L]])
)
} else {
peak_ratio(
x,
numerator = definition$numerator_min[[1L]],
denominator = definition$denominator_min[[1L]],
method = "nearest"
)
}
if(length(values) != nrow(x$metadata)) {
stop("Quantification returned an unexpected number of values for '",
definition$name[[1L]], "'.", call. = FALSE)
}
x$metadata[[definition$column[[1L]]]] <- as.numeric(values)
}
for(i in seq_len(nrow(measurements))) {
definition <- measurements[i, , drop = FALSE]
values <- if(identical(definition$type[[1L]], "area")) {
app_area_measurement(
x,
c(definition$minimum[[1L]], definition$maximum[[1L]])
)
} else {
point_intensity(
x,
wavenumber = definition$minimum[[1L]],
method = "nearest"
)
}
if(length(values) != nrow(x$metadata)) {
stop("Quantification returned an unexpected number of values for '",
definition$name[[1L]], "'.", call. = FALSE)
}
x$metadata[[definition$column[[1L]]]] <- as.numeric(values)
}
x
}
.app_range_assessment <- function(x, check, correction_args = list()) {
check <- match.arg(check, c("co2_region", "high_tail"))
value_or <- function(name, default) {
value <- correction_args[[name]]
if(is.null(value)) default else value
}
artifact_ratio <- value_or("artifact_ratio", 3)
tail_n <- value_or("tail_n", 5L)
co2_region <- if(identical(check, "co2_region")) {
min <- value_or("min", 2200)
max <- value_or("max", 2420)
if(length(min) != 1L || length(max) != 1L) {
stop("automatic CO2 correction requires one flattening range",
call. = FALSE)
}
c(min, max)
} else {
value_or("co2_region", c(2200, 2420))
}
issues <- assess_spec(
x,
checks = check,
artifact_ratio = artifact_ratio,
tail_n = tail_n,
co2_region = co2_region
)
failures <- length(unique(issues$spectrum_index))
total <- ncol(x$spectra)
list(
issues = issues,
failures = failures,
passes = total - failures,
total = total
)
}
.app_range_candidate_preserves_batch <- function(before, candidate) {
if(!inherits(candidate, "OpenSpecy") ||
ncol(candidate$spectra) != ncol(before$spectra) ||
!identical(colnames(candidate$spectra), colnames(before$spectra)) ||
!identical(candidate$metadata, before$metadata)) {
return(FALSE)
}
original_attributes <- attributes(before)
protected <- setdiff(names(original_attributes), c("names", "class"))
all(vapply(protected, function(name) {
identical(attr(candidate, name), original_attributes[[name]])
}, logical(1)))
}
.app_range_diagnostic <- function(step, check, enabled, attempted, accepted,
total, before, after, reason,
message = "",
original_range = c(NA_real_, NA_real_),
applied_range = c(NA_real_, NA_real_)) {
normalize_range <- function(value) {
value <- suppressWarnings(as.numeric(value))
if(length(value) < 2L || any(!is.finite(value[1:2]))) {
return(c(NA_real_, NA_real_))
}
range(value[1:2])
}
original_range <- normalize_range(original_range)
applied_range <- normalize_range(applied_range)
data.frame(
step = step,
check = check,
enabled = enabled,
attempted = attempted,
accepted = accepted,
total_spectra = as.integer(total),
before_passes = as.integer(before),
after_passes = as.integer(after),
reason = reason,
message = message,
original_range_min = original_range[[1L]],
original_range_max = original_range[[2L]],
applied_range_min = applied_range[[1L]],
applied_range_max = applied_range[[2L]],
stringsAsFactors = FALSE
)
}
.app_attempt_range_automation <- function(x, step, correction_args = list()) {
check <- if(identical(step, "flatten_range")) "co2_region" else "high_tail"
if(identical(step, "flatten_range")) {
if(is.null(correction_args$min)) correction_args$min <- 2200
if(is.null(correction_args$max)) correction_args$max <- 2420
}
before <- .app_range_assessment(x, check, correction_args)
if(before$failures == 0L) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, FALSE, FALSE, before$total,
before$passes, before$passes, "no_failures"
)
))
}
correction <- if(identical(step, "flatten_range")) {
flatten_range
} else {
restrict_range
}
correction_args$x <- NULL
correction_args$automate <- TRUE
if(is.null(correction_args$make_rel)) correction_args$make_rel <- FALSE
candidate <- tryCatch(
do.call(correction, c(list(x = x), correction_args)),
error = function(e) e
)
if(inherits(candidate, "error")) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, FALSE, before$total,
before$passes, before$passes, "correction_error",
conditionMessage(candidate)
)
))
}
if(!.app_range_candidate_preserves_batch(x, candidate)) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, FALSE, before$total,
before$passes, before$passes, "invalid_candidate",
"candidate changed spectrum identifiers, metadata, or input attributes"
)
))
}
after <- tryCatch(
.app_range_assessment(candidate, check, correction_args),
error = function(e) e
)
if(inherits(after, "error")) {
return(list(
data = x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, FALSE, before$total,
before$passes, before$passes, "assessment_error",
conditionMessage(after)
)
))
}
accepted <- after$passes > before$passes
correction_detail <- attr(
candidate,
if(identical(step, "flatten_range")) {
"automatic_flatten"
} else {
"automatic_tail"
},
exact = TRUE
)
original_range <- if(is.list(correction_detail) &&
!is.null(correction_detail$original_range)) {
correction_detail$original_range
} else {
range(x$wavenumber, na.rm = TRUE)
}
applied_range <- if(identical(step, "flatten_range")) {
if(is.list(correction_detail) && !is.null(correction_detail$region)) {
correction_detail$region
} else {
c(correction_args$min, correction_args$max)
}
} else if(is.list(correction_detail) &&
!is.null(correction_detail$corrected_range)) {
correction_detail$corrected_range
} else {
range(candidate$wavenumber, na.rm = TRUE)
}
list(
data = if(accepted) candidate else x,
diagnostic = .app_range_diagnostic(
step, check, TRUE, TRUE, accepted, before$total,
before$passes, after$passes,
if(accepted) "improved" else "not_improved",
original_range = original_range,
applied_range = applied_range
)
)
}
app_apply_range_automation <- function(x, flatten = TRUE, restrict = TRUE,
flatten_args = list(),
restrict_args = list()) {
if(!inherits(x, "OpenSpecy")) {
stop("'x' must be an OpenSpecy object", call. = FALSE)
}
current <- x
diagnostics <- list()
steps <- list(
list(name = "flatten_range", check = "co2_region", enabled = flatten,
args = flatten_args),
list(name = "restrict_range", check = "high_tail", enabled = restrict,
args = restrict_args)
)
for(step in steps) {
if(!isTRUE(step$enabled)) {
total <- ncol(current$spectra)
diagnostics[[length(diagnostics) + 1L]] <- .app_range_diagnostic(
step$name, step$check, FALSE, FALSE, FALSE, total,
NA_integer_, NA_integer_, "disabled"
)
next
}
result <- .app_attempt_range_automation(
current, step$name, correction_args = step$args
)
current <- result$data
diagnostics[[length(diagnostics) + 1L]] <- result$diagnostic
}
list(data = current, diagnostics = do.call(rbind, diagnostics))
}
app_theme <- list(
canvas = "#050B14",
panel = "#0B1929",
panel_2 = "#10243A",
border = "#168FC2",
accent = "#38BDF8",
success = "#22C55E",
text = "#E6EDF7",
muted = "#A9B8CB",
grid = "#28536F",
axis = "#6F86A3",
raw = "#CBD5E1",
reference = "#FB7185",
spectrum = "#FFFFFF"
)
app_theme_css <- function(theme = app_theme) {
required <- c(
"canvas", "panel", "panel_2", "border", "accent", "success",
"text", "muted", "grid", "axis", "raw", "spectrum"
)
if(!is.list(theme) || !all(required %in% names(theme))) {
stop("The app theme is missing one or more required color tokens.",
call. = FALSE)
}
values <- unlist(theme[required], use.names = TRUE)
css_names <- gsub("_", "-", names(values), fixed = TRUE)
paste0(
":root {\n",
paste0(" --openspecy-", css_names, ": ", values, ";",
collapse = "\n"),
"\n}\n"
)
}
app_plot_palette <- list(
panel = app_theme$panel,
grid = app_theme$grid,
axis = app_theme$axis,
text = app_theme$text,
primary = app_theme$accent,
raw = app_theme$raw,
peak = "#3B82F6",
reference = app_theme$reference,
spectrum = app_theme$spectrum
)
# Okabe-Ito hues, ordered from cool to warm and lifted away from the very dark
# end of common perceptually uniform scales so every value remains visible on
# the application's navy canvas.
app_heatmap_colorscale <- list(
c(0.00, "#56B4E9"),
c(0.20, "#44B9A8"),
c(0.40, "#009E73"),
c(0.60, "#F0E442"),
c(0.80, "#E69F00"),
c(1.00, "#CC79A7")
)
app_heatmap_legend_layout <- function(title = NULL) {
list(
margin = list(t = 18, r = 24, b = 58, l = 66)
)
}
app_heatmap_legend_model <- function(data, max_categories = 30L) {
title <- if(isTruthy(data$legend_title)) data$legend_title else "Value"
categorical <- identical(data$type, "heatmap_categorical") ||
identical(data$type, "heatmap_binary")
if(categorical) {
levels <- if(identical(data$type, "heatmap_binary")) {
as.character(data$labels)
} else as.character(data$levels)
colors <- if(!is.null(data$palette)) data$palette[levels] else
app_category_palette(levels)[levels]
return(list(
title = title, categorical = TRUE, too_many = length(levels) > max_categories,
levels = levels, colors = unname(colors), range = NULL, ticks = NULL
))
}
values <- as.numeric(data$z)
values <- values[is.finite(values)]
value_range <- if(length(values)) range(values) else c(NA_real_, NA_real_)
ticks <- if(all(is.finite(value_range))) {
if(identical(value_range[[1L]], value_range[[2L]])) {
rep(value_range[[1L]], 5L)
} else {
seq(value_range[[1L]], value_range[[2L]], length.out = 5L)
}
} else numeric()
list(
title = title, categorical = FALSE, too_many = FALSE,
levels = NULL, colors = vapply(app_heatmap_colorscale, `[[`, "", 2L),
range = value_range, ticks = ticks
)
}
app_heatmap_legend_content <- function(model) {
if(isTRUE(model$too_many)) {
return(tags$p(
"More than 30 categories are present, so a categorical legend would not be useful. Use the heatmap hover information to inspect individual pixels."
))
}
if(isTRUE(model$categorical)) {
return(tags$div(
class = "openspecy-modal-legend-grid",
lapply(seq_along(model$levels), function(i) tags$div(
class = "openspecy-modal-legend-item",
tags$span(
`aria-hidden` = "true",
style = paste0(
"display:inline-block;width:1rem;height:1rem;margin-right:.55rem;",
"vertical-align:middle;border:1px solid #d8e2ec;background:",
model$colors[[i]], ";"
)
),
tags$span(model$levels[[i]])
))
))
}
labels <- if(length(model$ticks)) {
format(signif(model$ticks, 3), trim = TRUE)
} else "No finite values"
tags$div(
tags$div(
`aria-hidden` = "true",
style = paste0(
"height:1.25rem;border:1px solid #d8e2ec;background:linear-gradient(90deg,",
paste(model$colors, collapse = ","), ");"
)
),
tags$div(
style = "display:flex;justify-content:space-between;margin-top:.35rem;",
lapply(labels, tags$span)
)
)
}
app_category_colors <- c(
"#56B4E9", "#E69F00", "#009E73", "#F0E442", "#CC79A7",
"#D55E00", "#7FDBFF", "#98D8C8", "#F4A6C1", "#FDD17A"
)
# One canonical color per label, shared by the app heatmap and Summary
# material-class bar chart, and consistent with particle_image()'s package
# static export. Known material-class names
# (R/particle_image.R's .particle_material_palette()) always get their fixed
# color; anything else cycles the app's categorical palette in sorted order.
app_category_palette <- function(values) {
labels <- if(is.factor(values)) {
levels(values)
} else {
sort(unique(as.character(values[!is.na(values)])))
}
if(!length(labels)) return(stats::setNames(character(), character()))
known <- OpenSpecy:::.particle_material_palette()
matched <- labels %in% names(known)
colors <- rep(NA_character_, length(labels))
colors[matched] <- unname(known[labels[matched]])
if(any(!matched)) {
colors[!matched] <- rep(app_category_colors,
length.out = sum(!matched))
}
stats::setNames(colors, labels)
}
app_category_colorscale <- function(values) {
palette <- app_category_palette(values)
count <- length(palette)
if(!count) return(app_heatmap_colorscale)
if(count == 1L) {
return(list(c(0, unname(palette[[1L]])),
c(1, unname(palette[[1L]]))))
}
centers <- seq(0, 1, length.out = count)
edges <- c(0, (centers[-1L] + centers[-count]) / 2, 1)
unlist(lapply(seq_len(count), function(i) {
list(
c(edges[[i]], unname(palette[[i]])),
c(edges[[i + 1L]], unname(palette[[i]]))
)
}), recursive = FALSE)
}
app_quality_checks <- c(
"silent_region", "missing_values", "flat_spectrum",
"negative_intensity", "co2_region", "high_tail", "spike", "saturation"
)
app_automatic_quality_checks <- c(
"spike", "saturation", "co2_region", "high_tail"
)
app_quality_success_description <- function(row) {
if(!is.data.frame(row) || nrow(row) != 1L || !"check" %in% names(row)) {
stop("A success description requires one quality-report row.",
call. = FALSE)
}
check <- as.character(row$check[[1L]])
if("issue" %in% names(row) &&
identical(as.character(row$issue[[1L]]), "Region not in spectrum")) {
return(as.character(row$description[[1L]]))
}
switch(
check,
silent_region = {
region <- if(all(c("region_min", "region_max") %in% names(row)) &&
is.finite(row$region_min[[1L]]) &&
is.finite(row$region_max[[1L]])) {
paste0(
" in ", format(row$region_min[[1L]], trim = TRUE), "-",
format(row$region_max[[1L]], trim = TRUE), " cm^-1"
)
} else " in the configured silent region"
paste0(
"The maximum intensity", region,
" stayed at or below the spectrum-wide high-quantile threshold."
)
},
missing_values =
"No NA, NaN, Inf, or -Inf intensity values were detected.",
flat_spectrum = paste(
"The finite intensity range exceeds the configured flat-spectrum",
"tolerance, so the spectrum is not constant."
),
negative_intensity = paste(
"The minimum finite intensity stayed at or above the allowed negative",
"threshold."
),
co2_region = {
region <- if(all(c("region_min", "region_max") %in% names(row)) &&
is.finite(row$region_min[[1L]]) &&
is.finite(row$region_max[[1L]])) {
paste0(
" in ", format(row$region_min[[1L]], trim = TRUE), "-",
format(row$region_max[[1L]], trim = TRUE), " cm^-1"
)
} else " in the configured CO2 region"
paste0(
"The normalized maximum", region,
" stayed below the artifact ratio threshold relative to the rest",
" of the spectrum."
)
},
high_tail = paste(
"The normalized maximum in the first and last tail points stayed",
"below the artifact ratio threshold relative to the rest of the",
"spectrum."
),
spike = "No isolated single-point spikes were detected.",
low_snr = {
metric <- if("metric" %in% names(row) &&
isTruthy(row$metric[[1L]])) {
as.character(row$metric[[1L]])
} else "signal-to-noise"
paste0(
"The ", metric,
" metric stayed at or above the configured threshold."
)
},
saturation = "No saturated spectral intervals were detected.",
as.character(row$description[[1L]])
)
}
app_mark_absent_quality_regions <- function(report, wavenumber, regions) {
if(is.null(report) || !is.data.frame(report) || !nrow(report)) return(report)
wavenumber <- suppressWarnings(as.numeric(wavenumber))
for(check in intersect(names(regions), unique(as.character(report$check)))) {
region <- suppressWarnings(as.numeric(regions[[check]]))
if(length(region) != 2L || any(!is.finite(region))) next
region <- sort(region)
if(any(wavenumber >= region[[1L]] & wavenumber <= region[[2L]],
na.rm = TRUE)) next
rows <- which(report$check == check)
report$status[rows] <- "pass"
report$issue[rows] <- "Region not in spectrum"
report$description[rows] <- paste0(
"The configured ", gsub("_", " ", check), " (",
region[[1L]], "-", region[[2L]],
" cm^-1) is outside the restricted spectrum, so the check was skipped."
)
report$likely_cause[rows] <- NA_character_
report$potential_fix[rows] <- "No action required."
if("finding_count" %in% names(report)) report$finding_count[rows] <- 0L
}
report
}
app_quality_ui_report <- function(report) {
if(is.null(report) || !is.data.frame(report) || !nrow(report)) return(report)
if(!all(c("status", "test_id", "check") %in% names(report))) {
stop("Quality reports must include 'status', 'test_id', and 'check'.",
call. = FALSE)
}
# assess_spec() returns a data.table. Convert before filtering so helper
# arguments such as `status` cannot be shadowed by same-named columns in
# data.table's non-standard evaluation.
report <- as.data.frame(report, stringsAsFactors = FALSE)
# spike/saturation/co2_region/high_tail (app_automatic_quality_checks)
# used to be filtered out here on the assumption they'd only ever be
# reported via Automatic Corrections Made. They're now also included in
# Warnings/Successes for the viewed spectrum -- independent of whether
# the matching correction is actually applied -- so no longer excluded.
report$status <- ifelse(
report$status %in% c("pass", "success"), "success", "warning"
)
success_rows <- which(report$status == "success")
for(i in success_rows) {
report$description[[i]] <- app_quality_success_description(
report[i, , drop = FALSE]
)
}
report
}
app_quality_status_report <- function(report, status) {
target_status <- match.arg(status, c("warning", "success"))
if(is.null(report) || !is.data.frame(report) || !nrow(report)) {
return(data.frame())
}
report <- app_quality_ui_report(report)
report[
report$status == target_status & !duplicated(report$test_id), ,
drop = FALSE
]
}
app_threshold_quality_report <- function(
spectrum_id,
snr_value = NULL,
snr_threshold = NULL,
signal_metric = "run_sig_over_noise",
correlation_value = NULL,
correlation_threshold = NULL) {
empty <- function() {
data.frame(
status = character(), test_id = character(), check = character(),
description = character(), likely_cause = character(),
potential_fix = character(), metric = character(), value = numeric(),
threshold = numeric(), region_min = numeric(), region_max = numeric(),
stringsAsFactors = FALSE
)
}
if(length(spectrum_id) != 1L || is.na(spectrum_id) ||
!nzchar(as.character(spectrum_id))) {
stop("Threshold quality findings require one spectrum ID.",
call. = FALSE)
}
signal_details <- switch(
match.arg(signal_metric, c(
"run_sig_over_noise", "sig_times_noise", "log_tot_sig"
)),
run_sig_over_noise = list(
label = "Signal-to-noise ratio", metric = "snr"
),
sig_times_noise = list(
label = "Signal times noise", metric = "signal_times_noise"
),
log_tot_sig = list(
label = "Total signal", metric = "total_signal"
)
)
make_row <- function(check, label, metric, observed, threshold,
warning_cause, warning_fix) {
if(is.null(threshold)) return(NULL)
if(!is.numeric(threshold) || length(threshold) != 1L ||
!is.finite(threshold)) {
stop(label, " threshold must be one finite number.", call. = FALSE)
}
if(!is.numeric(observed) || length(observed) != 1L) {
stop(label, " value must be one numeric value.", call. = FALSE)
}
observed <- as.numeric(observed)
threshold <- as.numeric(threshold)
# Infinite SNR is a valid result when signal is positive and estimated
# noise is zero. Compare infinities normally; only missing/NaN values are
# unavailable.
evaluable <- !is.na(observed)
passed <- evaluable && observed > threshold
relation <- if(!evaluable) {
"could not be evaluated against"
} else if(passed) {
"is above"
} else if(observed < threshold) {
"is below"
} else {
"is equal to and does not exceed"
}
observed_text <- if(evaluable) {
format(signif(observed, 5), trim = TRUE)
} else {
"an unavailable value"
}
data.frame(
status = if(passed) "success" else "warning",
test_id = paste("app_threshold", spectrum_id, check, sep = ":"),
check = check,
description = paste(
label, observed_text, relation, "the configured threshold",
paste0(format(signif(threshold, 5), trim = TRUE), ".")
),
likely_cause = if(passed) NA_character_ else if(evaluable) {
warning_cause
} else {
paste(label, "was unavailable for the selected spectrum.")
},
potential_fix = if(passed) "No action required." else warning_fix,
metric = metric,
value = observed,
threshold = threshold,
region_min = NA_real_,
region_max = NA_real_,
stringsAsFactors = FALSE
)
}
rows <- Filter(Negate(is.null), list(
make_row(
"snr_threshold", signal_details$label, signal_details$metric,
snr_value, snr_threshold,
"The selected spectrum has less signal separation than requested.",
paste(
"Review the SNR threshold and acquisition settings; consider",
"recollecting the spectrum if the weak signal is unexpected."
)
),
make_row(
"correlation_threshold", "Correlation", "correlation",
correlation_value, correlation_threshold,
"The selected spectrum's best library match is weaker than requested.",
paste(
"Review the correlation threshold, preprocessing, and candidate",
"matches before interpreting the identification."
)
)
))
if(!length(rows)) return(empty())
do.call(rbind, rows)
}
app_quality_counts <- function(report) {
statuses <- c("warning", "success")
if(is.null(report) || !is.data.frame(report) || !nrow(report)) {
return(stats::setNames(rep.int(0L, length(statuses)), statuses))
}
stats::setNames(
vapply(statuses, function(status) {
nrow(app_quality_status_report(report, status))
}, integer(1)),
statuses
)
}
app_quality_evidence <- function(row) {
parts <- character()
if(length(row$metric) && !is.na(row$metric) && nzchar(row$metric)) {
parts <- c(parts, paste0("Metric: ", row$metric))
}
if(length(row$value) && !is.na(row$value)) {
parts <- c(parts, paste0("Observed: ", signif(row$value, 5)))
}
if(length(row$threshold) && is.finite(row$threshold)) {
parts <- c(parts, paste0("Threshold: ", signif(row$threshold, 5)))
}
if(length(row$candidate_max) && is.finite(row$candidate_max)) {
candidate_label <- if(identical(row$metric, "saturated_interval_count")) {
"Detector ceiling"
} else {
"Candidate maximum"
}
parts <- c(parts, paste0(
candidate_label, ": ", signif(row$candidate_max, 5)
))
}
if(length(row$control_max) && is.finite(row$control_max)) {
parts <- c(parts, paste0(
"Control maximum: ", signif(row$control_max, 5)
))
}
if(length(row$region_min) && length(row$region_max) &&
is.finite(row$region_min) && is.finite(row$region_max)) {
parts <- c(parts, paste0(
"Region: ", format(row$region_min, trim = TRUE), "-",
format(row$region_max, trim = TRUE), " cm^-1"
))
}
if(!length(parts)) "No numeric exception was recorded." else
paste(parts, collapse = "; ")
}
app_quality_modal_content <- function(report, status) {
status <- match.arg(status, c("warning", "success"))
if(is.null(report)) {
return(tags$p("Upload a spectrum to run the quality checks."))
}
if(!is.data.frame(report)) {
stop("Quality modal content requires a data frame or NULL.", call. = FALSE)
}
rows <- app_quality_status_report(report, status)
if(!nrow(rows)) {
return(tags$p(paste0("No ", status, " findings for this spectrum.")))
}
tagList(lapply(seq_len(nrow(rows)), function(i) {
row <- rows[i, , drop = FALSE]
tags$section(
class = paste("openspecy-quality-finding", paste0(
"openspecy-quality-finding-", row$status[[1L]]
)),
`data-quality-status` = row$status[[1L]],
`data-quality-test-id` = row$test_id[[1L]],
tags$h4(gsub("_", " ", row$check[[1L]], fixed = TRUE)),
tags$p(tags$strong("Finding: "), row$description[[1L]]),
tags$p(tags$strong("Evidence: "), app_quality_evidence(row)),
if(identical(status, "warning")) {
tags$p(
tags$strong("Interpretation: "),
ifelse(
is.na(row$likely_cause[[1L]]),
"No likely cause was recorded.",
row$likely_cause[[1L]]
)
)
},
if(identical(status, "warning")) {
tags$p(tags$strong("Action: "), row$potential_fix[[1L]])
}
)
}))
}
app_format_wavenumber_ranges <- function(ranges, maximum = 4L) {
if(is.null(ranges) || !is.data.frame(ranges) || !nrow(ranges) ||
!all(c("region_min", "region_max") %in% names(ranges))) {
return("no recorded wavenumber range")
}
maximum <- suppressWarnings(as.integer(maximum))
if(length(maximum) != 1L || is.na(maximum) || maximum < 1L) maximum <- 4L
ranges <- unique(ranges[, c("region_min", "region_max"), drop = FALSE])
ranges <- ranges[
is.finite(ranges$region_min) & is.finite(ranges$region_max), , drop = FALSE
]
if(!nrow(ranges)) return("no recorded wavenumber range")
labels <- vapply(seq_len(min(nrow(ranges), maximum)), function(i) {
bounds <- sort(c(ranges$region_min[[i]], ranges$region_max[[i]]))
formatted <- format(signif(bounds, 7), trim = TRUE)
if(isTRUE(all.equal(bounds[[1L]], bounds[[2L]]))) {
paste0(formatted[[1L]], " cm^-1")
} else {
paste0(formatted[[1L]], "-", formatted[[2L]], " cm^-1")
}
}, character(1))
if(nrow(ranges) > maximum) {
labels <- c(labels, paste0("and ", nrow(ranges) - maximum, " more"))
}
paste(labels, collapse = ", ")
}
app_automatic_report <- function(
x = NULL,
diagnostics = data.frame(),
enabled = c(spike = FALSE, saturation = FALSE,
flatten = FALSE, tails = FALSE)) {
enabled_names <- c("spike", "saturation", "flatten", "tails")
enabled <- enabled[enabled_names]
enabled[is.na(enabled)] <- FALSE
enabled <- stats::setNames(as.logical(enabled), enabled_names)
recorded_state <- if(is.null(x)) NULL else
attr(x, "app_automatic_correction_state", exact = TRUE)
if(is.logical(recorded_state) &&
all(c("spike", "saturation") %in% names(recorded_state))) {
enabled[c("spike", "saturation")] <-
recorded_state[c("spike", "saturation")]
}
make_row <- function(step, label, is_enabled, applied, outcome, summary) {
data.frame(
step = step,
label = label,
enabled = isTRUE(is_enabled),
applied = isTRUE(applied),
outcome = outcome,
summary = summary,
stringsAsFactors = FALSE
)
}
attr_or_null <- function(name) {
if(is.null(x)) NULL else attr(x, name, exact = TRUE)
}
attr_row <- function(step, label, is_enabled, diagnostic,
applied_summary, clean_summary) {
if(!isTRUE(is_enabled)) {
return(make_row(step, label, FALSE, FALSE, "disabled",
"This automatic correction is disabled."))
}
if(is.null(x)) {
return(make_row(step, label, TRUE, FALSE, "pending",
"Upload spectra to run this automatic check."))
}
if(is.null(diagnostic)) {
return(make_row(step, label, TRUE, FALSE, "not_needed", clean_summary))
}
if(isTRUE(diagnostic$applied)) {
return(make_row(step, label, TRUE, TRUE, "applied",
applied_summary(diagnostic)))
}
rejected <- if(is.data.frame(diagnostic$rejected_regions)) {
diagnostic$rejected_regions
} else data.frame()
rejection_detail <- if(nrow(rejected) && "reason" %in% names(rejected)) {
paste0(
"; across correction passes, safeguards left ", nrow(rejected),
" candidate region",
if(nrow(rejected) == 1L) "" else "s", " unchanged (",
paste(unique(gsub("_", " ", rejected$reason, fixed = TRUE)),
collapse = ", "), ")"
)
} else ""
make_row(
step, label, TRUE, FALSE, "rejected",
paste0(
"A candidate correction was not applied (",
gsub("_", " ", as.character(diagnostic$reason), fixed = TRUE),
rejection_detail, ")."
)
)
}
spike <- attr_or_null("automatic_spike")
saturation <- attr_or_null("saturation_restriction")
rows <- list(
attr_row(
"spike", "Spike correction", enabled[["spike"]], spike,
function(value) {
corrected_count <- nrow(value$corrected_regions)
rejected <- if(is.data.frame(value$rejected_regions)) {
value$rejected_regions
} else data.frame()
remaining <- if(nrow(rejected)) paste0(
" Across correction passes, safeguards left ", nrow(rejected),
" candidate region",
if(nrow(rejected) == 1L) "" else "s", " unchanged (",
paste(unique(gsub("_", " ", rejected$reason, fixed = TRUE)),
collapse = ", "), ")."
) else ""
paste0(
"Corrected ", corrected_count, " spike region",
if(corrected_count == 1L) "" else "s", " across ",
length(value$affected_spectra), " spectrum",
if(length(value$affected_spectra) == 1L) "" else "s", " at ",
app_format_wavenumber_ranges(value$corrected_regions), ".",
remaining
)
},
"No correctable spike regions were detected."
),
attr_row(
"saturation", "Saturation restriction", enabled[["saturation"]],
saturation,
function(value) paste0(
"Removed ", value$excluded_interval_count, " shared saturated range",
if(value$excluded_interval_count == 1L) "" else "s", " at ",
app_format_wavenumber_ranges(value$excluded_ranges), " (",
signif(100 * value$saturation_loss_fraction, 3),
"% of the wavenumber span)."
),
"No shared saturated ranges were detected."
)
)
range_row <- function(step, check, label, is_enabled) {
if(!isTRUE(is_enabled)) {
return(make_row(step, label, FALSE, FALSE, "disabled",
"This automatic correction is disabled."))
}
if(is.null(x)) {
return(make_row(step, label, TRUE, FALSE, "pending",
"Upload spectra to run this automatic check."))
}
row <- if(is.data.frame(diagnostics) && nrow(diagnostics)) {
diagnostics[diagnostics$check == check, , drop = FALSE]
} else data.frame()
if(!nrow(row)) {
return(make_row(step, label, TRUE, FALSE, "not_needed",
"No automatic correction was necessary."))
}
row <- row[nrow(row), , drop = FALSE]
total <- row$total_spectra[[1L]]
before <- total - row$before_passes[[1L]]
after <- total - row$after_passes[[1L]]
comparison <- paste0(
"Problematic spectra: ", before, " of ", total, " before; ",
after, " of ", total, " after the candidate correction."
)
if(isTRUE(row$accepted[[1L]])) {
numeric_field <- function(name) {
if(!name %in% names(row)) return(NA_real_)
suppressWarnings(as.numeric(row[[name]][[1L]]))
}
format_range <- function(minimum, maximum) paste0(
format(signif(minimum, 7), trim = TRUE), "-",
format(signif(maximum, 7), trim = TRUE), " cm^-1"
)
applied_min <- numeric_field("applied_range_min")
applied_max <- numeric_field("applied_range_max")
original_min <- numeric_field("original_range_min")
original_max <- numeric_field("original_range_max")
range_detail <- if(identical(step, "flatten") &&
all(is.finite(c(applied_min, applied_max)))) {
paste0("Flattened ", format_range(applied_min, applied_max), ".")
} else if(identical(step, "tails") &&
all(is.finite(c(
original_min, original_max, applied_min, applied_max
)))) {
paste0(
"Restricted the shared wavenumber axis from ",
format_range(original_min, original_max), " to ",
format_range(applied_min, applied_max), "."
)
} else {
"The corrected range was retained."
}
return(make_row(step, label, TRUE, TRUE, "applied", paste(
range_detail, comparison, "The improved correction was retained."
)))
}
if(identical(row$reason[[1L]], "no_failures")) {
return(make_row(step, label, TRUE, FALSE, "not_needed", paste(
comparison, "No correction was necessary."
)))
}
detail <- if(nzchar(row$message[[1L]])) {
paste0(" ", row$message[[1L]])
} else ""
make_row(step, label, TRUE, FALSE, "rejected", paste0(
comparison, " The candidate was not retained (",
gsub("_", " ", row$reason[[1L]], fixed = TRUE), ").", detail
))
}
rows[[3L]] <- range_row(
"flatten", "co2_region", "CO2 flattening", enabled[["flatten"]]
)
rows[[4L]] <- range_row(
"tails", "high_tail", "High-tail range restriction", enabled[["tails"]]
)
do.call(rbind, rows)
}
app_automatic_modal_content <- function(report) {
if(is.null(report) || !is.data.frame(report) || !nrow(report)) {
return(tags$p("Upload spectra to review automatic corrections."))
}
tagList(lapply(seq_len(nrow(report)), function(i) {
row <- report[i, , drop = FALSE]
tags$section(
class = paste(
"openspecy-quality-finding openspecy-quality-finding-automatic",
paste0("openspecy-automatic-outcome-", row$outcome[[1L]]),
if(isTRUE(row$applied[[1L]])) "openspecy-automatic-applied" else ""
),
tags$h4(row$label[[1L]]),
tags$p(tags$strong("Status: "),
gsub("_", " ", row$outcome[[1L]], fixed = TRUE)),
tags$p(tags$strong("Details: "), row$summary[[1L]])
)
}))
}
app_summary_row <- function(items) {
if(!is.list(items)) {
stop("Summary items must be supplied as a list.", call. = FALSE)
}
items <- Filter(function(item) !is.null(item), items)
count <- length(items)
if(count == 0L) return(NULL)
widths <- rep.int(12L %/% count, count)
remainder <- 12L %% count
if(remainder > 0L) {
widths[seq_len(remainder)] <- widths[seq_len(remainder)] + 1L
}
columns <- Map(
function(item, width) {
shiny::column(width, class = "openspecy-summary-panel", item)
},
items,
widths
)
do.call(
shiny::fluidRow,
c(list(class = "openspecy-summary-grid"), unname(columns))
)
}
# Even color steps across an integer 1..length(colors) domain, for indexed
# (categorical/binary) plotly heatmap traces.
app_indexed_colorscale <- function(colors) {
count <- length(colors)
if (!count) return(list(c(0, app_theme$muted), c(1, app_theme$muted)))
if (count == 1L) return(list(c(0, unname(colors[[1L]])),
c(1, unname(colors[[1L]]))))
centers <- seq(0, 1, length.out = count)
edges <- c(0, (centers[-1L] + centers[-count]) / 2, 1)
unlist(lapply(seq_len(count), function(i) {
list(c(edges[[i]], unname(colors[[i]])),
c(edges[[i + 1L]], unname(colors[[i]])))
}), recursive = FALSE)
}
# Per-cell hover text for a heatmap-family plot-data list. Returns a
# character matrix with the same dims as t(data$z), matching plotly's
# column-major (x-major) layout for a transposed z matrix.
app_heatmap_hover_text <- function(data, legend_title, levels = NULL) {
xs <- data$x
ys <- data$y
axis_unit <- if(isTruthy(data$axis_unit)) data$axis_unit else "pixel"
z_t <- t(data$z)
z_label <- if (!is.null(levels)) {
ifelse(is.na(z_t), NA_character_, levels[z_t])
} else {
ifelse(is.na(z_t), NA_character_, format(signif(z_t, 3), trim = TRUE))
}
value_line <- ifelse(
is.na(z_label), "no data", paste0(legend_title, ": ", z_label)
)
matrix(
paste0("x (", axis_unit, "): ", rep(xs, each = length(ys)),
"<br>y (", axis_unit, "): ",
rep(ys, times = length(xs)), "<br>", value_line),
nrow = length(ys), ncol = length(xs)
)
}
# Render one automate_particle_analysis() plot-data list (see
# R/automate_particle_analysis.R) as a themed, interactive plotly object.
# Uses the shared heatmapA/MyPlotC Plotly theme: a heatmap trace
# (hover-only metadata, no click popover) plus a second, always-present
# plus an optional registered raster in Plotly's explicit above-trace image
# layer. A selected cell is drawn in the still-higher shape layer. `select` is
# the currently selected point's data coordinates (list(x=, y=)) or NULL.
app_particle_plotly <- function(data, source = "heat_plot", select = NULL) {
if (is.null(data) || identical(data$type, "empty")) {
reason <- if (!is.null(data$reason)) data$reason else "no data available"
plot <- plotly::plot_ly(source = source) |>
plotly::layout(
annotations = list(list(
text = reason, showarrow = FALSE, x = 0.5, y = 0.5,
xref = "paper", yref = "paper",
font = list(color = app_plot_palette$text, size = 13)
)),
xaxis = list(visible = FALSE), yaxis = list(visible = FALSE)
) |>
app_style_plotly()
return(plotly::event_register(plot, "plotly_click"))
}
if (identical(data$type, "histogram")) {
finite_values <- data$values[is.finite(data$values)]
data_range <- if (length(finite_values)) range(finite_values) else c(0, 1)
clamped_thresholds <- pmin(
pmax(data$thresholds[is.finite(data$thresholds)], data_range[1L]),
data_range[2L]
)
plot <- plotly::plot_ly(
x = data$values, type = "histogram",
marker = list(color = app_plot_palette$primary), source = source
) |>
plotly::layout(
xaxis = list(title = data$xlab, range = data_range),
yaxis = list(title = "Count"),
shapes = lapply(clamped_thresholds, function(v) list(
type = "line", x0 = v, x1 = v, y0 = 0, y1 = 1, yref = "paper",
line = list(color = app_theme$reference, width = 2, dash = "dash")
))
) |>
app_style_plotly()
return(plot)
}
legend_title <- if (isTruthy(data$legend_title)) data$legend_title else
"Value"
categorical <- data$type %in% c("heatmap_binary", "heatmap_categorical")
levels <- NULL
if (identical(data$type, "heatmap_binary")) {
z <- t(data$z) + 1L
levels <- data$labels
colorscale <- app_indexed_colorscale(
c(app_theme$panel_2, app_theme$accent)
)
} else if (identical(data$type, "heatmap_categorical")) {
z <- t(data$z)
levels <- data$levels
colors <- if (!is.null(data$palette)) data$palette[levels] else
app_category_palette(levels)
colorscale <- app_indexed_colorscale(colors[levels])
} else {
z <- t(data$z)
colorscale <- app_heatmap_colorscale
}
# A continuous z matrix with no finite values (e.g. every pixel currently
# rejected for this metric) leaves Plotly's automatic domain detection
# nothing to work with, which throws "wasn't able to determine range of
# domain" instead of just rendering an empty/fully-masked map.
continuous_range <- if (categorical) {
c(NA_real_, NA_real_)
} else {
finite_z <- z[is.finite(z)]
if (length(finite_z)) {
range(finite_z)
} else {
c(0, 1)
}
}
if (!categorical && continuous_range[[1L]] == continuous_range[[2L]]) {
continuous_range <- continuous_range + c(-0.5, 0.5)
}
hover_text <- app_heatmap_hover_text(data, legend_title, levels)
rejected <- if(is.null(data$rejected)) {
matrix(NA_real_, nrow = nrow(data$z), ncol = ncol(data$z))
} else {
data$rejected
}
rejected_z <- t(ifelse(is.na(rejected) | rejected == 0, NA_real_, 1))
rejected_reason <- if(is.null(data$rejection_reason)) {
matrix("active threshold", nrow = nrow(data$z), ncol = ncol(data$z))
} else {
data$rejection_reason
}
rejected_text <- t(ifelse(
is.na(rejected) | rejected == 0,
NA_character_,
paste0("Rejected: ", rejected_reason)
))
legend_layout <- app_heatmap_legend_layout(legend_title)
axis_unit <- if(isTruthy(data$axis_unit)) data$axis_unit else "pixel"
overlay_opacity <- suppressWarnings(as.numeric(data$overlay_opacity))
if(length(overlay_opacity) != 1L || !is.finite(overlay_opacity)) {
overlay_opacity <- 1
}
overlay_opacity <- pmin(pmax(overlay_opacity, 0), 1)
plot <- plotly::plot_ly(source = source) |>
plotly::add_trace(
x = data$x, y = data$y, z = z, type = "heatmap",
colorscale = colorscale,
zmin = if (categorical) 0.5 else continuous_range[[1L]],
zmax = if (categorical) length(levels) + 0.5 else continuous_range[[2L]],
showscale = FALSE,
hoverinfo = "text", text = hover_text, hoverongaps = FALSE
) |>
plotly::add_trace(
x = data$x, y = data$y, z = rejected_z, type = "heatmap",
colorscale = list(c(0, "#000000"), c(1, "#000000")),
zmin = 0, zmax = 1, showscale = FALSE,
hoverinfo = "text", text = rejected_text, hoverongaps = FALSE,
name = "Rejected"
)
layout_images <- list()
if(!is.null(data$visual_image) && length(dim(data$visual_image)) == 3L) {
image <- pmin(pmax(data$visual_image, 0), 1)
layout_images <- list(app_visual_layout_image(
data$x, data$y, image, overlay_opacity
))
}
selection_shape <- app_selection_shape(data$x, data$y, select)
layout_shapes <- if(is.null(selection_shape)) list() else list(selection_shape)
plot <- plot |>
plotly::layout(
xaxis = list(title = paste0("X (", axis_unit, ")")),
yaxis = list(title = paste0("Y (", axis_unit, ")"),
scaleanchor = "x", scaleratio = 1),
images = layout_images, shapes = layout_shapes,
showlegend = FALSE, margin = legend_layout$margin
) |>
app_style_plotly()
plotly::event_register(plot, "plotly_click")
}
app_style_plotly <- function(plot) {
plotly::layout(
plot,
plot_bgcolor = app_plot_palette$panel,
paper_bgcolor = app_plot_palette$panel,
font = list(color = app_plot_palette$text),
xaxis = list(
gridcolor = app_plot_palette$grid,
zerolinecolor = app_plot_palette$grid,
linecolor = app_plot_palette$axis,
tickcolor = app_plot_palette$axis
),
yaxis = list(
gridcolor = app_plot_palette$grid,
zerolinecolor = app_plot_palette$grid,
linecolor = app_plot_palette$axis,
tickcolor = app_plot_palette$axis
),
hoverlabel = list(
bgcolor = app_theme$panel_2,
bordercolor = app_plot_palette$axis,
font = list(color = app_plot_palette$text)
)
)
}
app_spectrum_legend_layout <- function(plot_width = NULL,
model_overlay = FALSE) {
width <- suppressWarnings(as.numeric(plot_width))
width <- if(length(width)) width[[1L]] else NA_real_
if(!is.finite(width)) width <- 900
compact <- width < 640
list(
legend = list(
orientation = "h", x = 0, xanchor = "left",
y = 1.03, yanchor = "bottom", traceorder = "normal"
),
margin = list(
t = 92,
r = if(isTRUE(model_overlay)) {
if(compact) 92 else 112
} else 24,
b = 64,
l = if(compact) 62 else 72
)
)
}
# Find derivative-zero maxima on exactly one displayed processed spectrum.
# A flat-topped peak is represented by the middle sample of the zero-difference
# plateau bracketed by a positive and then negative first difference.
app_peak_positions <- function(x, top_n = 7L) {
if(!inherits(x, "OpenSpecy") || ncol(x$spectra) != 1L) {
stop("Peak positions require exactly one OpenSpecy spectrum.",
call. = FALSE)
}
top_n <- suppressWarnings(as.integer(top_n))
if(length(top_n) != 1L || is.na(top_n) || top_n < 1L || top_n > 20L) {
stop("'top_n' must be an integer from 1 through 20.", call. = FALSE)
}
y <- as.numeric(x$spectra[, 1L])
wn <- as.numeric(x$wavenumber)
if(length(y) < 3L) return(data.frame(
index = integer(), wavenumber = numeric(), intensity = numeric(),
rank = integer(), label = character()
))
delta <- diff(y)
candidates <- integer()
i <- 1L
while(i < length(delta)) {
if(is.finite(delta[[i]]) && delta[[i]] > 0) {
j <- i + 1L
while(j <= length(delta) && is.finite(delta[[j]]) &&
delta[[j]] == 0) j <- j + 1L
if(j <= length(delta) && is.finite(delta[[j]]) && delta[[j]] < 0) {
candidates <- c(candidates, as.integer(floor((i + 1L + j) / 2L)))
i <- j
}
}
i <- i + 1L
}
candidates <- candidates[
is.finite(y[candidates]) & is.finite(wn[candidates]) &
candidates > 1L & candidates < length(y)
]
if(!length(candidates)) return(data.frame(
index = integer(), wavenumber = numeric(), intensity = numeric(),
rank = integer(), label = character()
))
ordered <- candidates[order(-y[candidates], wn[candidates], candidates,
method = "radix")]
ordered <- head(ordered, top_n)
data.frame(
index = ordered, wavenumber = wn[ordered], intensity = y[ordered],
rank = seq_along(ordered),
label = format(round(wn[ordered], 1L), trim = TRUE, nsmall = 0),
stringsAsFactors = FALSE
)
}
app_spectrum_plot <- function(active, raw = NULL, reference = NULL,
model = NULL, model_class = NULL,
peaks = NULL,
make_rel = FALSE, source = "B",
plot_width = NULL) {
prepare_trace <- function(x, normalize = FALSE) {
if(is.null(x)) return(NULL)
x <- as_OpenSpecy(x)
if(isTRUE(normalize)) x <- OpenSpecy::make_rel(x, na.rm = TRUE)
if(ncol(x$spectra) < 1L) return(NULL)
data.frame(
wavenumber = x$wavenumber,
intensity = as.numeric(as.matrix(x$spectra)[, 1L])
)
}
add_spectrum <- function(plot, values, name, color, width, dash = "solid") {
if(is.null(values)) return(plot)
plotly::add_trace(
plot,
data = values,
x = ~wavenumber,
y = ~intensity,
type = "scatter",
mode = "lines",
name = name,
legendgroup = name,
showlegend = TRUE,
line = list(color = color, width = width, dash = dash),
hovertemplate = paste0(
name, "<br>%{x:.1f} cm<sup>-1</sup><br>",
"%{y:.4g}<extra></extra>"
),
inherit = FALSE
)
}
plot <- plotly::plot_ly(source = source)
has_weight_overlay <- FALSE
if(!is.null(model) && isTruthy(model_class)) {
weights <- tryCatch(
OpenSpecy::model_class_weights(model, model_class),
error = function(error) NULL
)
if(!is.null(weights) && nrow(weights)) {
has_weight_overlay <- TRUE
display_model_class <- app_standardize_material_class(model_class)
limit <- max(abs(weights$weight), na.rm = TRUE)
if(!is.finite(limit) || limit == 0) limit <- 1
plot <- plotly::add_trace(
plot,
x = weights$wavenumber, y = c(0, 1),
z = rbind(weights$weight, weights$weight),
type = "heatmap", yaxis = "y2",
colorscale = list(
c(0, "#d73027"), c(0.5, "#fee08b"), c(1, "#1a9850")
),
zmin = -limit, zmax = limit, zmid = 0, opacity = 0.28,
legendgroup = "logistic_weight", showlegend = FALSE,
showscale = TRUE,
colorbar = list(
title = "Logistic<br>weight", thickness = 12,
x = 1.02, xanchor = "left", xpad = 8,
y = 0.5, yanchor = "middle", len = 0.86
),
hovertemplate = paste0(
"%{x:.1f} cm<sup>-1</sup><br>weight %{z:.4g}<extra>",
display_model_class, "</extra>"
),
inherit = FALSE
)
plot <- plotly::add_trace(
plot,
x = weights$wavenumber[[1L]], y = 2, yaxis = "y2",
type = "scatter", mode = "markers",
name = "Logistic weight", legendgroup = "logistic_weight",
showlegend = TRUE,
marker = list(color = "#1a9850", size = 9, symbol = "square"),
hoverinfo = "skip", inherit = FALSE
)
}
}
plot <- add_spectrum(
plot, prepare_trace(raw, normalize = make_rel), "Raw spectrum",
"rgba(203, 213, 225, 0.24)", 1.2
)
plot <- add_spectrum(
# Normalization is display-only; quantification continues to use the
# canonical processed values even when all plotted traces are rescaled.
plot, prepare_trace(active, normalize = make_rel), "Active spectrum",
app_plot_palette$spectrum, 2.4
)
plot <- add_spectrum(
plot, prepare_trace(reference, normalize = make_rel),
"Identification match",
app_plot_palette$reference, 2.2, "dot"
)
if(!is.null(peaks) && nrow(peaks)) {
plot <- plotly::add_trace(
plot, data = peaks, x = ~wavenumber, y = ~intensity,
type = "scatter", mode = "markers", name = "Peak positions",
marker = list(color = app_plot_palette$peak, size = 8,
line = list(color = app_plot_palette$panel, width = 1)),
hovertemplate = paste0(
"Peak rank %{customdata}<br>%{x:.1f} cm<sup>-1</sup><br>",
"%{y:.4g}<extra></extra>"
),
customdata = ~rank, inherit = FALSE
)
}
legend_layout <- app_spectrum_legend_layout(
plot_width, model_overlay = has_weight_overlay
)
legend <- c(
legend_layout$legend,
list(
bgcolor = "rgba(11, 25, 41, 0.82)",
bordercolor = app_plot_palette$grid,
borderwidth = 1,
font = list(color = app_plot_palette$text),
groupclick = "togglegroup"
)
)
plotly::layout(
plot,
xaxis = list(
title = "wavenumber [cm<sup>-1</sup>]",
autorange = "reversed"
),
yaxis = list(title = "intensity [-]"),
yaxis2 = list(overlaying = "y", range = c(0, 1), visible = FALSE,
fixedrange = TRUE),
legend = legend,
margin = legend_layout$margin
)
}
app_empty_spectrum_plot <- function(
message = "Upload some data to get started."
) {
annotation <- if(isTruthy(message)) list(list(
text = as.character(message)[[1L]], x = 0.5, y = 0.5,
xref = "paper", yref = "paper", showarrow = FALSE,
font = list(color = app_theme$muted, size = 18)
)) else list()
plotly::plot_ly(x = numeric(), y = numeric(),
type = "scatter", mode = "lines") |>
plotly::layout(
xaxis = list(title = "wavenumber [cm<sup>-1</sup>]",
range = c(4000, 400)),
yaxis = list(title = "intensity [-]", range = c(0, 1)),
annotations = annotation
) |>
app_style_plotly()
}
# App metadata ----
metadata_file <- ".openspecy-shiny-metadata.rds"
read_app_metadata <- function(path = metadata_file) {
if (!file.exists(path)) {
return(NULL)
}
tryCatch(readRDS(path), error = function(...) NULL)
}
build_version_display <- function(metadata) {
default_href <- "https://github.com/Moore-Institute-4-Plastic-Pollution-Res/openspecy?tab=readme-ov-file#version-history"
default_text <- paste0("Last Updated: ", format(Sys.Date()))
default_title <- "Click here to view older versions of this app"
if (is.null(metadata)) {
return(list(text = default_text, href = default_href, title = default_title))
}
commit <- metadata$commit
ref <- metadata$ref
owner <- metadata$owner
repo <- metadata$repo
downloaded_time <- metadata$downloaded_at
text <- paste0("App metadata date: ", downloaded_time)
commit_display <- NULL
if (!is.null(commit)) {
commit_display <- substr(commit, 1, min(nchar(commit), 7))
text <- paste0(text, " • Commit ", commit_display)
}
href <- default_href
if (!is.null(owner) && !is.null(repo)) {
href <- sprintf("https://github.com/%s/%s/commits", owner, repo)
if (!is.null(ref)) {
href <- sprintf("%s/%s", href, utils::URLencode(ref, reserved = TRUE))
}
}
title <- default_title
if (!is.null(downloaded_time) || !is.null(commit)) {
parts <- c()
if (!is.null(downloaded_time)) {
parts <- c(parts, paste0("App metadata date ", downloaded_time))
}
if (!is.null(commit)) {
parts <- c(parts, paste0("Commit ", commit))
}
if (length(parts)) {
title <- paste(parts, collapse = " — ")
}
}
list(text = text, href = href, title = title)
}
app_metadata <- read_app_metadata()
app_version_display <- build_version_display(app_metadata)
# The app now ships inside the OpenSpecy package. Override the historical
# remote-download metadata with package release metadata.
build_version_display <- function() {
package_version <- tryCatch(
as.character(utils::packageVersion("OpenSpecy")),
error = function(...) "development"
)
list(
text = paste0("OpenSpecy ", package_version),
href = "https://github.com/wincowgerDEV/OpenSpecy-package/releases",
title = "Click here to view OpenSpecy package releases"
)
}
app_version_display <- build_version_display()
app_library_dir <- function() {
configured <- Sys.getenv("OPENSPECY_SHINY_LIBRARY_PATH", "")
if (!nzchar(configured)) {
configured <- shiny::getShinyOption("library_path", default = "")
}
dir <- if (nzchar(configured) && !identical(configured, "system")) {
configured
} else {
file.path(tools::R_user_dir("OpenSpecy", "cache"),
"reference_libraries")
}
dir.create(dir, recursive = TRUE, showWarnings = FALSE)
dir
}
app_wasm_library_types <- function() {
configured <- getOption("openspecy.shiny.wasm.libraries", character())
if (length(configured)) return(configured)
c("medoid_derivative", "medoid_nobaseline",
"model_derivative", "model_nobaseline")
}
app_library_type_choices <- function() {
if (app_wasm_mode()) {
return(c("Medoid" = "medoid", "Multinomial" = "model"))
}
c("Full" = "full", "Medoid" = "medoid", "Multinomial" = "model")
}
app_reference_spectrum_types <- c("ftir", "raman", "nir")
# New reference artifacts are keyed by spectrum type because their supported
# axes differ. A specific selection takes one member. "all" combines real
# libraries onto their full union axis (with intentional NA padding), while
# model artifacts remain a typed set so each model can use its own axis/fill.
app_select_library_spectrum_type <- function(artifact,
spectrum_type = "all") {
spectrum_type <- match.arg(
spectrum_type, c("all", app_reference_spectrum_types)
)
if(is_OpenSpecy(artifact)) return(artifact)
if(!is.list(artifact)) {
stop("The selected reference artifact has an unsupported structure.",
call. = FALSE)
}
available <- intersect(app_reference_spectrum_types, names(artifact))
if(!length(available)) {
if(all(c("model", "dimension_conversion") %in% names(artifact))) {
# Compatibility for pre-type-split model artifacts. They cannot supply
# NIR, but remain usable until the new typed artifact is installed.
return(artifact)
}
stop("The selected reference artifact has no FTIR, Raman, or NIR member.",
call. = FALSE)
}
if(!identical(spectrum_type, "all")) {
selected <- artifact[[spectrum_type]]
if(is.null(selected)) {
stop("The selected reference artifact has no '", spectrum_type,
"' member.", call. = FALSE)
}
return(selected)
}
typed <- artifact[available]
if(all(vapply(typed, is_OpenSpecy, logical(1)))) {
combined <- c_spec(unname(typed), range = "full", res = 6)
attr(combined, "openspecy_spectrum_types") <- available
return(combined)
}
structure(typed, class = c("openspecy_typed_models", "list"))
}
app_classify_model_library <- function(x, library, top_n = 5L) {
classify_one <- function(model) {
fill <- model$fill
model_axis <- if(is_OpenSpecy(fill)) {
fill$wavenumber
} else {
suppressWarnings(as.numeric(unique(model$all_variables)))
}
model_axis <- model_axis[is.finite(model_axis)]
overlap <- if(length(model_axis)) {
x$wavenumber >= min(model_axis) & x$wavenumber <= max(model_axis)
} else logical()
if(!length(model_axis) || sum(overlap, na.rm = TRUE) < 2L) {
return(NULL)
}
if(!is_OpenSpecy(fill)) {
fallback <- mean(x$spectra[is.finite(x$spectra)], na.rm = TRUE)
if(!is.finite(fallback)) fallback <- 0
fill <- as_OpenSpecy(
model_axis,
spectra = data.frame(fill = rep.int(fallback, length(model_axis)))
)
}
data <- conform_spec(
x, range = fill$wavenumber, res = NULL, allow_na = TRUE
)
match_spec(
data, library = model, na.rm = TRUE, fill = fill, top_n = top_n
)
}
if(!inherits(library, "openspecy_typed_models")) {
result <- classify_one(library)
if(is.null(result)) {
stop("The selected model range does not overlap the uploaded spectrum.",
call. = FALSE)
}
return(result)
}
predictions <- lapply(names(library), function(type) {
result <- classify_one(library[[type]])
if(is.null(result)) return(NULL)
result$spectrum_type <- type
result$.type_order <- match(type, app_reference_spectrum_types)
result
})
predictions <- Filter(Negate(is.null), predictions)
if(!length(predictions)) {
stop("None of the FTIR, Raman, or NIR model ranges overlap the uploaded spectrum.",
call. = FALSE)
}
candidates <- data.table::rbindlist(predictions, use.names = TRUE, fill = TRUE)
data.table::setorder(candidates, x, -value, .type_order, name, na.last = TRUE)
result <- candidates[, head(.SD, top_n), by = x]
result[, rank := seq_len(.N), by = x]
result[, .type_order := NULL]
data.table::setorder(result, x)
result
}
app_validate_library_type <- function(type) {
if (app_wasm_mode() && !type %in% app_wasm_library_types()) {
stop(
"The WebAssembly app only includes medoid and model libraries. ",
"Requested unsupported library: ", type,
call. = FALSE
)
}
invisible(TRUE)
}
load_app_library <- function(type) {
app_validate_library_type(type)
installed_library <- tryCatch(
load_lib(type),
error = function(e) e
)
if (!inherits(installed_library, "error")) {
return(installed_library)
}
library_path <- app_library_dir()
cached_library <- tryCatch(
load_lib(type, path = library_path),
error = function(e) e
)
if (!inherits(cached_library, "error")) {
return(cached_library)
}
download_result <- tryCatch(
get_lib(type, path = library_path),
error = function(e) e,
warning = function(w) w
)
if (inherits(download_result, c("error", "warning"))) {
stop(
"Unable to load the Open Specy reference library '", type,
"' from the installed package or app cache, and downloading it failed: ",
conditionMessage(download_result),
". Run get_lib(\"", type, "\") before run_app(), or check your ",
"network connection.",
call. = FALSE
)
}
load_lib(type, path = library_path)
}
# Helper to create collapsible footnotes ----
footnote <- function(summary, ...) {
content <- list(...)
has_content <- length(content) && any(vapply(content, function(item) {
text <- trimws(gsub("<[^>]+>", "", paste(as.character(item),
collapse = " ")))
nzchar(text)
}, logical(1)))
if(!has_content) {
stop("Information disclosures require substantive details.",
call. = FALSE)
}
tags$details(
class = "openspecy-info-details",
tags$summary(summary),
tags$div(
class = "openspecy-info-details-body",
lapply(content, tags$p)
)
)
}
# Load all data ----
load_data <- function() {
data("raman_hdpe")
intensity <- if(is.data.frame(raman_hdpe$spectra)) {
raman_hdpe$spectra$intensity
} else {
as.numeric(raman_hdpe$spectra[, 1])
}
testdata <- data.table(wavenumber = raman_hdpe$wavenumber,
intensity = intensity)
# Inject variables into the parent environment
invisible(list2env(as.list(environment()), parent.frame()))
}
# Name keys for human readable column names ----
version <- paste0("Open Specy v", packageVersion("OpenSpecy"))
citation <- HTML(
'Cowger, W., Karapetrova, A., Lincoln, C., Chamas, A., Sherrod, H., Leong, N., Lasdin, K. S.,
Knauss, C., Teofilović, V., Arienzo, M. M., Steinmetz, Z., Primpke, S.,
Darjany, L., Murphy-Hagan, C., Moore, S., Moore, C., Lattin, G.,
Gray, A., Kozloski, R., Bryksa, J., Maurer, B. (2025).
"Open Specy 1.0: Automated (Hyper)spectroscopy for Microplastics."
<i>Analytical Chemistry.</i> doi:
<a href="https://doi.org/10.1021/acs.analchem.5c00962">10.1021/acs.analchem.5c00962</a>.'
)
# Define the custom theme
theme_black_minimal <- function(base_size = 11, base_family = "") {
theme_minimal(base_size = base_size, base_family = base_family) +
theme(
plot.background = element_rect(fill = app_plot_palette$panel,
color = app_plot_palette$axis,
linewidth = 0.6),
panel.background = element_rect(fill = app_plot_palette$panel,
color = NA),
panel.border = element_rect(fill = NA, color = app_plot_palette$axis,
linewidth = 0.5),
panel.grid.major = element_line(color = app_plot_palette$grid,
linewidth = 0.35),
panel.grid.minor = element_blank(),
axis.line = element_line(color = app_plot_palette$axis),
axis.ticks = element_line(color = app_plot_palette$axis),
axis.text = element_text(color = app_plot_palette$text),
axis.title = element_text(color = app_plot_palette$text),
plot.title = element_text(color = app_plot_palette$text, hjust = 0.5),
plot.subtitle = element_text(color = app_plot_palette$text, hjust = 0.5),
plot.caption = element_text(color = app_plot_palette$text),
legend.text = element_text(color = app_plot_palette$text),
legend.title = element_text(color = app_plot_palette$text),
legend.background = element_rect(fill = app_plot_palette$panel,
color = NA),
legend.key = element_rect(fill = app_plot_palette$panel, color = NA),
strip.background = element_rect(fill = app_theme$panel_2,
color = app_plot_palette$axis),
strip.text = element_text(color = app_plot_palette$text)
)
}
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.