diff --git a/DESCRIPTION b/DESCRIPTION index d5b1048..0db9404 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,15 +32,26 @@ Suggests: knitr, rmarkdown, testthat (>= 3.0.0), - tools, - withr + tools VignetteBuilder: knitr Config/testthat/edition: 3 Imports: arrow, + BiocParallel, + dplyr, + glmnet, jsonlite, + Matrix, + parsnip, + recipes, rlang, - tibble + rsample, + tibble, + tidyr, + tune, + withr, + workflows, + yardstick biocViews: Software, Classification, diff --git a/NAMESPACE b/NAMESPACE index a88e391..0d75451 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,4 +1,34 @@ # Generated by roxygen2: do not edit by hand +S3method(print,amr_eligibility) +S3method(print,amr_fit) +S3method(print,amr_matrices) +S3method(print,amr_matrix_plan) S3method(print,amr_orb) +S3method(print,amr_orb_profile) +S3method(print,amr_tasks) +export(assessModelReliability) +export(buildMatrices) +export(eligibleScopes) +export(expandTasks) +export(exportMergedResults) +export(exportNetwork) +export(fitModels) +export(listORBs) +export(modelingModes) +export(planMatrices) +export(profileORB) export(readORB) +export(rescoreFeatures) +export(runFeatureDyadDiscovery) +export(runModelingWorkflow) +export(summarizeFeatureEvidence) +export(topFeaturesPerDrugOrClass) +importFrom(glmnet,glmnet) +importFrom(rlang,.data) +importFrom(stats, + median, + quantile, + sd +) +importFrom(utils,head) diff --git a/R/arg-checks.R b/R/arg-checks.R index 58d00e7..02e968e 100644 --- a/R/arg-checks.R +++ b/R/arg-checks.R @@ -1,15 +1,169 @@ # Argument checks. Each throws `amrml_invalid_argument`. -# Throw an error unless `orb` is an ORB object from readORB(). -.checkArgORB <- function(orb, call = rlang::caller_env()) { - if (!inherits(orb, "amr_orb")) { +# Throw an error unless `value` has class `expected`, as returned by `from`. +.checkArgClass <- function(value, name, expected, from, call = rlang::caller_env()) { + if (!inherits(value, expected)) { .amrAbort( "invalid_argument", c( - "`orb` must be an `amr_orb` from readORB().", - x = paste0("Got class ", class(orb)[[1]], ".") + paste0("`", name, "` must be an `", expected, "` from ", from, "."), + x = paste0("Got class ", class(value)[[1]], ".") ), - observed = list(class = class(orb)), + observed = list(class = class(value)), + call = call + ) + } + + invisible(TRUE) +} + +# Throw an error unless `value` is TRUE or FALSE. +.checkArgFlag <- function(value, name, call = rlang::caller_env()) { + if (!rlang::is_bool(value)) { + .amrAbort("invalid_argument", paste0("`", name, "` must be TRUE or FALSE."), call = call) + } + + invisible(TRUE) +} + +# Throw an error unless `value` is a single finite whole number of at least `min`. +.checkArgCount <- function(value, name, min = 1, call = rlang::caller_env()) { + ok <- is.numeric(value) && length(value) == 1L && is.finite(value) && + value == round(value) && value >= min + + if (!ok) { + .amrAbort( + "invalid_argument", + paste0("`", name, "` must be a single finite whole number of at least ", min, "."), + observed = list(value = value), + call = call + ) + } + + invisible(TRUE) +} + +# Throw an error unless `modes` holds mode IDs from modelingModes(). +.checkArgModes <- function(modes, call = rlang::caller_env()) { + unknown <- if (is.character(modes)) setdiff(modes, .MODES$mode_id) else character() + + if (!is.character(modes) || anyNA(modes) || length(unknown)) { + .amrAbort( + "invalid_argument", + c("`modes` must be mode IDs from modelingModes().", .bullets(unknown)), + observed = list(unknown = unknown), + call = call + ) + } + + invisible(TRUE) +} + +# `path` with symlinks resolved, including when it, or its parents, don't exist yet. The +# part that doesn't exist can't hold a symlink, unless ".." steps back out of it; so ".." +# there is refused. +.resolvePath <- function(path, call = rlang::caller_env()) { + path <- path.expand(path) + missing <- character() + while (!file.exists(path)) { + missing <- c(basename(path), missing) + path <- dirname(path) + } + + if (".." %in% missing) { + .amrAbort( + "invalid_argument", + "`out_dir` can't use \"..\" after a folder that doesn't exist yet.", + call = call + ) + } + do.call(file.path, as.list(c(normalizePath(path), missing[missing != "."]))) +} + +# Throw an error unless `out_dir` is one writable path outside the ORB at `orb_dir`, or in +# its amRml/ folder, and holds no earlier output unless `overwrite` is TRUE. +.checkArgOutDir <- function(out_dir, orb_dir, overwrite, call = rlang::caller_env()) { + if (!rlang::is_string(out_dir) || !nzchar(out_dir)) { + .amrAbort("invalid_argument", "`out_dir` must be a single directory path.", call = call) + } + .checkArgFlag(overwrite, "overwrite", call = call) + + # The nearest folder that exists must be writable, or nothing can be created in it. + existing <- path.expand(out_dir) + while (!file.exists(existing)) { + existing <- dirname(existing) + } + if (!dir.exists(existing) || file.access(existing, mode = 2) != 0) { + .amrAbort( + "invalid_argument", + c("`out_dir` must be a folder you can write to.", x = paste0("Not writable: ", existing)), + observed = list(out_dir = out_dir), + call = call + ) + } + + # Inside the ORB, only a run folder under its amRml/ folder; amRdata's files are read-only. + out <- .resolvePath(out_dir, call = call) + orb <- .resolvePath(orb_dir, call = call) + in_orb <- out == orb || startsWith(out, paste0(orb, "/")) + in_runs <- startsWith(out, paste0(file.path(orb, "amRml"), "/")) + if (in_orb && !in_runs) { + .amrAbort( + "invalid_argument", + c( + "`out_dir` must be outside the ORB, or a run folder in its `amRml/` folder.", + i = paste0("ORB: ", orb) + ), + observed = list(out_dir = out), + call = call + ) + } + + # Every stage's output, so a run never mixes new matrices with earlier results. + outputs <- c( + "eligibility.parquet", "matrices", "matrices.parquet", "tasks.parquet", "results", + "run.json", "merged", "features", "matrix_index.rds", "fit-checkpoints", "workflow.rds" + ) + existing <- file.exists(file.path(out_dir, outputs)) + if (any(existing) && !overwrite) { + .amrAbort( + "invalid_argument", + "`out_dir` already has output; set `overwrite = TRUE` to replace it.", + observed = list(out_dir = out), + call = call + ) + } + + invisible(TRUE) +} + +# Throw an error unless `seeds` is one or more distinct whole numbers. +.checkArgSeeds <- function(seeds, call = rlang::caller_env()) { + ok <- is.numeric(seeds) && length(seeds) > 0 && all(is.finite(seeds)) && + all(seeds == round(seeds)) && !anyDuplicated(seeds) + + if (!ok) { + .amrAbort( + "invalid_argument", + "`seeds` must be one or more distinct whole numbers.", + observed = list(seeds = seeds), + call = call + ) + } + + invisible(TRUE) +} + +# Throw an error unless `labels` is one or both of "real" and "shuffled". +.checkArgLabels <- function(labels, call = rlang::caller_env()) { + ok <- is.character(labels) && length(labels) > 0 && !anyNA(labels) && + all(labels %in% c("real", "shuffled")) && !anyDuplicated(labels) + + if (!ok) { + .amrAbort( + "invalid_argument", + "`labels` must be one or both of \"real\" and \"shuffled\".", + observed = list(labels = labels), call = call ) } diff --git a/R/eligibility.R b/R/eligibility.R new file mode 100644 index 0000000..07ddafc --- /dev/null +++ b/R/eligibility.R @@ -0,0 +1,445 @@ +# Deciding which modes can run on an ORB, and which drugs and classes in each have enough data. + +# Share held out for testing when a mode has no test set; kept in settings for fitting. +.CV_HOLDOUT <- 0.2 +# The columns that identify a scope. +.SCOPE_KEYS <- c("unit", "target", "train_group", "test_group") + + +# Fewest groups a mode needs: leave-one-out needs a held-out group and two to train on. +.groupsNeeded <- function(loo) { + ifelse(loo, 3L, 2L) +} + +# For each mode: whether it can run on this ORB, with the number of groups found. +.modeFeasibility <- function(modes, profile) { + drugs <- profile$phenotypes$target[profile$phenotypes$unit == "drug"] + + n_groups <- vapply(modes$grouping, function(grouping) { + if (grouping == "none") { + NA_integer_ + } else if (grouping == "drug") { + dplyr::n_distinct(drugs) + } else { + dplyr::n_distinct(profile$genomes[[grouping]], na.rm = TRUE) + } + }, integer(1)) + + rule_id <- rep(NA_character_, nrow(modes)) + rule_id[modes$grouping != "none" & n_groups < .groupsNeeded(modes$LOO)] <- "too_few_groups" + rule_id[!modes$supported] <- "mode_not_supported" + + tibble::tibble( + mode_id = modes$mode_id, + feasible = is.na(rule_id), + rule_id = rule_id, + n_groups = unname(n_groups) + ) +} + +# Each phenotype row with its genome's value of `grouping`; rows without one are dropped. +.withGroup <- function(phenotypes, genomes, grouping) { + if (grouping == "none") { + phenotypes$group <- NA_character_ + return(phenotypes) + } + + phenotypes$group <- genomes[[grouping]][match(phenotypes$genome_id, genomes$genome_id)] + phenotypes[!is.na(phenotypes$group), , drop = FALSE] +} + +# A builder's training and test genomes, stacked, with each row's role. +.asMembers <- function(train, test = NULL) { + columns <- c(.SCOPE_KEYS, "genome_id", "phenotype") + members <- dplyr::bind_rows( + tibble::tibble(train[columns], role = "train"), + if (!is.null(test)) tibble::tibble(test[columns], role = "test") + ) + members[c(.SCOPE_KEYS, "role", "genome_id", "phenotype")] +} + +# Internal scopes: each target within each group, trained and tested by cross-validation. +.internalScopes <- function(grouped) { + grouped$train_group <- grouped$group + grouped$test_group <- NA_character_ + .asMembers(grouped) +} + +# Cross scopes: each target, trained on one group and tested on another, both ways round. +.crossScopes <- function(grouped) { + groups <- dplyr::distinct(grouped[c("unit", "target", "group")]) + pairs <- dplyr::inner_join( + groups, groups, + by = c("unit", "target"), suffix = c("_train", "_test"), relationship = "many-to-many" + ) + pairs <- pairs[pairs$group_train != pairs$group_test, , drop = FALSE] + names(pairs) <- c("unit", "target", "train_group", "test_group") + + train <- dplyr::inner_join( + pairs, grouped, + by = c("unit", "target", train_group = "group"), relationship = "many-to-many" + ) + test <- dplyr::inner_join( + pairs, grouped, + by = c("unit", "target", test_group = "group"), relationship = "many-to-many" + ) + .asMembers(train, test) +} + +# Cross-drug scopes: trained on one drug, tested on another's genomes the first never saw. +.crossDrugScopes <- function(phenotypes) { + drugs <- phenotypes[phenotypes$unit == "drug", c("target", "genome_id", "phenotype")] + drug_ids <- unique(drugs$target) + pairs <- expand.grid(train_group = drug_ids, test_group = drug_ids, stringsAsFactors = FALSE) + pairs <- tibble::as_tibble(pairs[pairs$train_group != pairs$test_group, , drop = FALSE]) + pairs$unit <- "drug" + pairs$target <- pairs$train_group + + train <- dplyr::inner_join(pairs, drugs, by = "target", relationship = "many-to-many") + test <- dplyr::inner_join( + pairs, drugs, + by = c(test_group = "target"), relationship = "many-to-many" + ) + test <- dplyr::anti_join(test, drugs, by = c("target", "genome_id")) + .asMembers(train, test) +} + +# Leave-one-out scopes: trained on every other group (`train_group` NA), tested on the held-out one. +.looScopes <- function(grouped) { + held_out <- dplyr::distinct(grouped[c("unit", "target", "group")]) + names(held_out)[[3]] <- "test_group" + held_out$train_group <- NA_character_ + + train <- dplyr::inner_join( + held_out, grouped, + by = c("unit", "target"), relationship = "many-to-many" + ) + train <- train[train$group != train$test_group, , drop = FALSE] + test <- dplyr::inner_join( + held_out, grouped, + by = c("unit", "target", test_group = "group"), relationship = "many-to-many" + ) + .asMembers(train, test) +} + +# Each target tested in fewer of the mode's groups than it needs, with its genome counts in +# them. A target whose genomes all lack a group has none, and is listed too. +.targetsInTooFewGroups <- function(phenotypes, grouped, loo) { + counts <- dplyr::summarise( + dplyr::group_by(grouped, .data$unit, .data$target), + n_groups = dplyr::n_distinct(.data$group), + n_genomes = dplyr::n(), + n_resistant = sum(.data$phenotype == "Resistant"), + n_susceptible = sum(.data$phenotype == "Susceptible"), + .groups = "drop" + ) + targets <- dplyr::left_join( + dplyr::distinct(phenotypes[c("unit", "target")]), counts, + by = c("unit", "target") + ) + columns <- c("n_groups", "n_genomes", "n_resistant", "n_susceptible") + targets[columns] <- lapply(targets[columns], function(n) replace(n, is.na(n), 0L)) + + targets[targets$n_groups < .groupsNeeded(loo), , drop = FALSE] +} + +# A mode's `members`, one row per scope, genome and role; `too_few`, the targets without scopes. +.buildScopes <- function(mode, profile) { + if (mode$grouping == "drug") { + if (!mode$cross_test) { + rlang::abort( + paste0("No scope builder for mode '", mode$mode_id, "'."), + class = c("amrml_internal_error", "amrml_error") + ) + } + return(list(members = .crossDrugScopes(profile$phenotypes), too_few = NULL)) + } + + grouped <- .withGroup(profile$phenotypes, profile$genomes, mode$grouping) + too_few <- NULL + + if (mode$grouping != "none") { + too_few <- .targetsInTooFewGroups(profile$phenotypes, grouped, mode$LOO) + grouped <- dplyr::anti_join(grouped, too_few, by = c("unit", "target")) + } + + members <- if (mode$LOO) { + .looScopes(grouped) + } else if (mode$cross_test) { + .crossScopes(grouped) + } else { + .internalScopes(grouped) + } + + list(members = members, too_few = too_few) +} + +# Per scope, the training and test genome counts. +.scopeCounts <- function(members, has_test) { + counts <- dplyr::summarise( + dplyr::group_by(members, dplyr::across(dplyr::all_of(c(.SCOPE_KEYS, "role")))), + n_genomes = dplyr::n(), + n_resistant = sum(.data$phenotype == "Resistant"), + n_susceptible = sum(.data$phenotype == "Susceptible"), + .groups = "drop" + ) + + sides <- c("n_genomes", "n_resistant", "n_susceptible") + train <- counts[counts$role == "train", c(.SCOPE_KEYS, sides)] + test <- counts[counts$role == "test", c(.SCOPE_KEYS, sides)] + names(test) <- c(.SCOPE_KEYS, paste0("test_", sides)) + scopes <- dplyr::full_join(train, test, by = .SCOPE_KEYS) + + # A cross-drug test set is empty when the training drug saw all the test drug's genomes. + if (has_test) { + test_counts <- paste0("test_", sides) + scopes[test_counts] <- lapply(scopes[test_counts], function(n) replace(n, is.na(n), 0L)) + } + + scopes +} + +# For each class scope, how many of the class's drugs have data among its genomes. +.classDrugCounts <- function(members, profile) { + drugs <- profile$phenotypes[profile$phenotypes$unit == "drug", , drop = FALSE] + drugs <- tibble::tibble( + genome_id = drugs$genome_id, + drug = drugs$target, + class = profile$drug_classes$class[match(drugs$target, profile$drug_classes$drug)] + ) + + tested <- dplyr::inner_join( + members[members$unit == "drug_class", c(.SCOPE_KEYS, "genome_id")], drugs, + by = c(target = "class", "genome_id"), relationship = "many-to-many" + ) + dplyr::summarise( + dplyr::group_by(tested, dplyr::across(dplyr::all_of(.SCOPE_KEYS))), + n_drugs = dplyr::n_distinct(.data$drug), + .groups = "drop" + ) +} + +# Each scope's first failed rule, or NA if it passes them all. +.firstFailedRule <- function(scopes, mode, settings, has_test) { + # A class with data for only one of its drugs is that drug's model again. + duplicate <- scopes$unit == "drug_class" & scopes$n_drugs %in% 1 + + rarer <- pmin(scopes$n_resistant, scopes$n_susceptible) + enough_for_cv <- if (has_test) { + rarer >= settings$n_fold + } else { + rarer * (1 - settings$holdout) >= settings$n_fold + } + test_ok <- !has_test | ( + scopes$test_n_genomes >= settings$min_test_genomes & + pmin(scopes$test_n_resistant, scopes$test_n_susceptible) >= settings$min_test_minority + ) + + # Check the rules in order and keep each scope's first failure. + failed <- list( + duplicate_class = duplicate, + single_phenotype = rarer == 0, + too_few_genomes = scopes$n_genomes < settings$min_genomes, + too_few_for_cv = !enough_for_cv, + test_too_small = !test_ok + ) + rule_id <- rep(NA_character_, nrow(scopes)) + for (rule in names(failed)) { + rule_id[is.na(rule_id) & failed[[rule]]] <- rule + } + + # A stratified model only means something next to another group's, so a target keeps + # its eligible stratified scopes only if at least two of its groups have one. + if (!has_test && mode$grouping != "none") { + eligible <- is.na(rule_id) + n_eligible <- stats::ave(as.integer(eligible), scopes$unit, scopes$target, FUN = sum) + rule_id[eligible & n_eligible < 2] <- "too_few_eligible_groups" + } + + rule_id +} + +# One decision per scope: its genome counts, and the first rule it fails. Targets tested +# in too few groups get one decision each. +.judgeScopes <- function(built, mode, profile, settings) { + counts <- c( + "n_genomes", "n_resistant", "n_susceptible", + "test_n_genomes", "test_n_resistant", "test_n_susceptible" + ) + has_test <- mode$LOO || mode$cross_test + scopes <- .scopeCounts(built$members, has_test) + scopes <- dplyr::left_join(scopes, .classDrugCounts(built$members, profile), by = .SCOPE_KEYS) + scopes$rule_id <- .firstFailedRule(scopes, mode, settings, has_test) + decisions <- scopes[c(.SCOPE_KEYS, counts, "rule_id")] + + too_few <- built$too_few + if (NROW(too_few)) { + too_few[c("train_group", "test_group")] <- NA_character_ + too_few$rule_id <- "too_few_groups_tested" + decisions <- dplyr::bind_rows(decisions, too_few[names(too_few) != "n_groups"]) + } + decisions <- decisions[do.call(order, unname(decisions[.SCOPE_KEYS])), , drop = FALSE] + + tibble::tibble( + mode_id = mode$mode_id, + decisions[c(.SCOPE_KEYS, counts)], + eligible = is.na(decisions$rule_id), + rule_id = decisions$rule_id + ) +} + +#' Decide what can be modeled +#' +#' Compares the modeling modes with a profiled ORB. For each mode, records +#' whether it can run on this ORB at all; for each drug or class in a mode that +#' can, records whether it has enough data to model, or why not. Nothing is +#' built or fitted. +#' +#' @details +#' Counts are of genomes, each with one phenotype. A drug or class needs 2 of a +#' mode's groups (3 for leave-one-out) to get scopes, and a stratified one needs +#' 2 eligible groups. A scope fails, in order, if it's a class with data for only +#' one of its drugs, has one phenotype, has fewer than `min_genomes` genomes, +#' can't fill `n_fold` folds with its rarer phenotype (after a 20% holdout when +#' there's no test set), or has too small a test set. +#' +#' @section Errors: +#' All errors have class `amrml_error`, plus `amrml_invalid_argument`: +#' `profile` is not from [profileORB()], `modes` names an unknown mode, or a +#' threshold is not a finite whole number of at least 1 (2 for `n_fold`). +#' +#' @param profile An `amr_orb_profile` from [profileORB()]. +#' @param modes Mode IDs from [modelingModes()], or `NULL` for all of them. +#' @param min_genomes Fewest genomes a scope needs, before any holdout. +#' @param n_fold Number of cross-validation folds. +#' @param min_test_genomes Fewest genomes a separate test set needs. +#' @param min_test_minority Fewest of the rarer phenotype a test set needs. +#' +#' @return An `amr_eligibility` list: +#' * `profile` and `settings` (the thresholds, and the `holdout` share). +#' * `modes`: per mode, `feasible`, `rule_id`, `n_groups`, and how many +#' scopes it has and how many are eligible (`n_scopes`, `n_eligible`). +#' * `scopes`: per scope, training and test counts (`NA` without a test set), +#' `eligible` and `rule_id`. +#' * `members`: each eligible scope's genomes, by `role` (train or test). +#' +#' @examples +#' \dontrun{ +#' eligibility <- eligibleScopes(profileORB(readORB("path/to/amRdata/output"))) +#' eligibility$scopes +#' } +#' @export +eligibleScopes <- function(profile, + modes = NULL, + min_genomes = 40, + n_fold = 5, + min_test_genomes = 5, + min_test_minority = 2) { + call <- rlang::current_env() + + # Check the arguments. + .checkArgClass(profile, "profile", "amr_orb_profile", "profileORB()", call = call) + .checkArgCount(min_genomes, "min_genomes", call = call) + .checkArgCount(n_fold, "n_fold", min = 2, call = call) + .checkArgCount(min_test_genomes, "min_test_genomes", call = call) + .checkArgCount(min_test_minority, "min_test_minority", call = call) + modes <- modes %||% .MODES$mode_id + .checkArgModes(modes, call = call) + + settings <- list( + min_genomes = min_genomes, + n_fold = n_fold, + min_test_genomes = min_test_genomes, + min_test_minority = min_test_minority, + holdout = .CV_HOLDOUT + ) + + # Decide whether each mode can run on this ORB at all. + selected <- .MODES[.MODES$mode_id %in% modes, , drop = FALSE] + feasibility <- .modeFeasibility(selected, profile) + + # Build and judge the scopes of each mode that can run, keeping the genomes of the + # eligible ones for matrix building. + runnable <- selected[feasibility$feasible, , drop = FALSE] + judged <- lapply(seq_len(nrow(runnable)), function(i) { + mode <- runnable[i, , drop = FALSE] + built <- .buildScopes(mode, profile) + decisions <- .judgeScopes(built, mode, profile, settings) + eligible <- decisions[decisions$eligible, .SCOPE_KEYS] + list( + decisions = decisions, + members = tibble::tibble( + mode_id = mode$mode_id, + dplyr::semi_join(built$members, eligible, by = .SCOPE_KEYS) + ) + ) + }) + scopes <- dplyr::bind_rows(lapply(judged, `[[`, "decisions")) + members <- dplyr::bind_rows(lapply(judged, `[[`, "members")) + + # If no mode ran, return empty tables that still have every column. + if (!length(judged)) { + scopes <- tibble::tibble( + mode_id = character(), unit = character(), target = character(), + train_group = character(), test_group = character(), + n_genomes = integer(), n_resistant = integer(), n_susceptible = integer(), + test_n_genomes = integer(), test_n_resistant = integer(), + test_n_susceptible = integer(), eligible = logical(), rule_id = character() + ) + members <- tibble::tibble( + mode_id = character(), unit = character(), target = character(), + train_group = character(), test_group = character(), + role = character(), genome_id = character(), phenotype = character() + ) + } + + # Each mode's scope counts, so a mode that ran with nothing eligible is visible; NA if not run. + per_mode <- match(scopes$mode_id, feasibility$mode_id) + feasibility$n_scopes <- tabulate(per_mode, nrow(feasibility)) + feasibility$n_eligible <- tabulate(per_mode[scopes$eligible], nrow(feasibility)) + feasibility[!feasibility$feasible, c("n_scopes", "n_eligible")] <- NA_integer_ + + structure( + list( + profile = profile, + settings = settings, + modes = feasibility, + scopes = scopes, + members = members + ), + class = "amr_eligibility" + ) +} + + +#' @export +print.amr_eligibility <- function(x, ...) { + orb <- x$profile$orb + s <- x$settings + + cat("", orb$dataset_id, "-", orb$dataset_label, "\n") + cat( + " settings :", s$min_genomes, "training genomes,", s$n_fold, "folds; test sets", + s$min_test_genomes, "genomes,", s$min_test_minority, "of the rarer phenotype\n" + ) + + labels <- format(x$modes$mode_id) + for (i in seq_len(nrow(x$modes))) { + mode <- x$modes[i, , drop = FALSE] + + if (!mode$feasible) { + cat(" ", labels[[i]], " : not run (", mode$rule_id, ")\n", sep = "") + next + } + + reasons <- table(x$scopes$rule_id[x$scopes$mode_id == mode$mode_id]) + cat( + " ", labels[[i]], " : ", mode$n_eligible, " of ", mode$n_scopes, " eligible", + if (length(reasons)) paste0("; ", paste(names(reasons), reasons, collapse = ", ")), + "\n", + sep = "" + ) + } + + invisible(x) +} diff --git a/R/errors.R b/R/errors.R index b3737ff..83b4393 100644 --- a/R/errors.R +++ b/R/errors.R @@ -1,39 +1,100 @@ # amRml's error codes, and the functions that build and throw its errors. -# `stage` is the pipeline stage; `grain` says whether the error is about the -# whole call or one manifest file. +# `stage` is the pipeline stage; `grain` says what the error is about: the whole call, +# one manifest file, one mode, one scope, one matrix, or one task. .RULES <- tibble::tribble( - ~rule_id, ~stage, ~grain, ~description, + ~rule_id, ~stage, ~grain, + ~description, # General - "invalid_argument", "input", "call", "Wrong type, length or class of argument.", + "invalid_argument", "input", "call", + "Wrong type, length or class of argument.", # Reading the ORB: readORB() # Locating the ORB - "orb_dir_not_found", "orb", "call", "The ORB directory does not exist.", - "manifest_not_found", "orb", "call", "No amRdata manifest in the ORB directory.", + "orb_dir_not_found", "orb", "call", + "The ORB directory does not exist.", + "manifest_not_found", "orb", "call", + "No amRdata manifest in the ORB directory.", + "orb_dir_unreadable", "orb", "call", + "The ORB directory, or the root searched for ORBs, can't be read.", + "no_orbs_found", "orb", "call", + "No usable ORB is registered, so there is none to choose.", # Manifest selection - "manifest_unreadable", "orb", "manifest", "Manifest is not readable JSON.", - "manifest_invalid", "orb", "manifest", "Manifest is not a valid amRdata manifest.", - "orb_not_ready", "orb", "manifest", "No 'ready' amRml_input artifact.", - "producer_run_invalid", "orb", "manifest", "Producer run is missing or failed.", - "orb_no_usable_manifest", "orb", "call", "No manifest declares a usable amRml input.", + "manifest_unreadable", "orb", "manifest", + "Manifest is not readable JSON.", + "manifest_invalid", "orb", "manifest", + "Manifest is not a valid amRdata manifest.", + "orb_not_ready", "orb", "manifest", + "No 'ready' amRml_input artifact.", + "producer_run_invalid", "orb", "manifest", + "Producer run is missing or failed.", + "orb_no_usable_manifest", "orb", "call", + "No manifest declares a usable amRml input.", # Checking the chosen ORB's files - "orb_moved", "orb", "call", "ORB is not where its manifest was written.", - "orb_files_missing", "orb", "call", "Declared files are missing or unreadable.", - "orb_file_changed", "orb", "call", "A declared file's size has changed.", + "orb_moved", "orb", "call", + "ORB is not where its manifest was written.", + "orb_files_missing", "orb", "call", + "Declared files are missing or unreadable.", + "orb_file_changed", "orb", "call", + "A declared file's size has changed.", # Feature tables - "parquet_unreadable", "orb", "call", "A declared parquet could not be read.", - "orb_no_feature_tables", "orb", "call", "No declared parquet is a feature table.", - "orb_duplicate_feature_type", "orb", "call", "Feature tables share a feature ID column.", + "parquet_unreadable", "orb", "call", + "A declared parquet could not be read.", + "orb_no_feature_tables", "orb", "call", + "No declared parquet is a feature table.", + "orb_duplicate_feature_type", "orb", "call", + "Feature tables share a feature ID column.", # Profiling the ORB: profileORB() - "metadata_columns_missing", "profile", "call", "Metadata lacks a column profiling needs.", - "genome_column_inconsistent", "profile", "call", "A genome-level column varies in a genome.", - "no_labelled_genomes", "profile", "call", "No genome with features has a label.", + "metadata_columns_missing", "profile", "call", + "Metadata lacks a column profiling needs.", + "phenotype_conflict", "profile", "call", + "A genome has both phenotypes for a drug.", + "no_labelled_genomes", "profile", "call", + "No genome with features has a phenotype.", + "stratum_inconsistent", "profile", "call", + "A genome has two values for a stratum.", + + # Deciding what can be modeled: eligibleScopes() + # Whether a mode can run on this ORB + "mode_not_supported", "feasibility", "mode", + "The mode can't run yet.", + "too_few_groups", "feasibility", "mode", + "Too few groups in the ORB for the mode.", + + # Whether a drug or class in a mode has enough data + "too_few_groups_tested", "eligibility", "scope", + "The drug or class was tested in too few of the mode's groups.", + "duplicate_class", "eligibility", "scope", + "The class has data for only one of its drugs.", + "single_phenotype", "eligibility", "scope", + "Training genomes have one phenotype only.", + "too_few_genomes", "eligibility", "scope", + "Too few training genomes.", + "too_few_for_cv", "eligibility", "scope", + "Too few of the rarer phenotype for the folds.", + "test_too_small", "eligibility", "scope", + "A test set has too few genomes, or too few of its rarer phenotype.", + "too_few_eligible_groups", "eligibility", "scope", + "Fewer than two of the stratified groups have enough data.", + + # Building matrices: buildMatrices() + "feature_rows_repeated", "matrix", "call", + "A feature table has two rows for one genome and feature.", + "feature_values_invalid", "matrix", "call", + "A feature table has missing or negative values.", + "no_variable_features", "matrix", "matrix", + "No feature varies across the matrix's training genomes.", + + # Fitting models: fitModels() + "fit_failed", "fit", "task", + "Fitting the task's model stopped with an error.", + "metrics_undefined", "fit", "task", + "Some test metrics are undefined, e.g. when one class is predicted for every genome.", ) # Build an error of class `amrml_` without throwing it. `message` is a diff --git a/R/export.R b/R/export.R new file mode 100644 index 0000000..198e0de --- /dev/null +++ b/R/export.R @@ -0,0 +1,197 @@ +# Temporary: a fit's results in old amRml's merged format, until amRml's column names match. + +# Old amRml's performance columns, without and with a separate test set. +.OLD_PERF <- c( + "num_obs", "res_prop", "n_feat", "model", "n_feats_returned", "n_fold", "fit_penalty", + "fit_mixture", "mcc", "nmcc", "spec", "sens", "log2_apop", "f1", "bal_acc", "run_time_sec", + "seed", "date" +) +.OLD_PERF_TEST <- c( + "num_obs_original_ml_input_tibble", "num_obs_test_data", "res_prop_original_ml_input_tibble", + "n_feat", "res_prop_test_data", "model", "n_feats_returned", "n_fold", "fit_penalty", + "fit_mixture", "mcc", "nmcc", "spec", "sens", "log2_apop", "f1", "bal_acc", "run_time_sec", + "seed", "date" +) +.OLD_TOP <- c("Variable", "Importance", "Sign") + +# Each file layout's columns, in old amRml's order; `top = NULL` where old amRml merged no top +# features. `shuffled` and an integer `seed` are ours wherever old amRml had none. +.EXPORT_LAYOUTS <- list( + vanilla = list( + perf = c( + "shuffled", "species", "drug_label", "drug_or_class", "feature_type", "feature_subtype", + .OLD_PERF + ), + top = c( + "shuffled", "species", "drug_label", "drug_or_class", "feature_type", "feature_subtype", + "seed", .OLD_TOP + ) + ), + stratified = list( + perf = c( + .OLD_PERF, "shuffled", "species", "drug_label", "strat_label", "drug_or_class", + "strat_value", "feature_type", "feature_subtype" + ), + top = c( + .OLD_TOP, "shuffled", "species", "drug_label", "strat_label", "drug_or_class", + "strat_value", "feature_type", "feature_subtype", "seed" + ) + ), + cross_drug = list( + perf = c( + .OLD_PERF_TEST, "shuffled", "species", "drug", "test_drug", "feature_type", + "feature_subtype" + ), + top = NULL + ), + cross = list( + perf = c( + .OLD_PERF_TEST, "shuffled", "species", "drug_label", "drug_or_class", "strat_value", + "strat_value_test", "feature_type", "feature_subtype" + ), + top = NULL + ), + loo = list( + perf = c( + .OLD_PERF_TEST, "shuffled", "species", "drug_label", "drug_or_class", + "leaveout_strat_value", "feature_type", "feature_subtype" + ), + top = c( + .OLD_TOP, "shuffled", "species", "drug_label", "drug_or_class", "leaveout_strat_value", + "feature_type", "feature_subtype", "seed" + ) + ) +) + +# Our column behind each old column whose name differs; the rest share their name. +.EXPORT_SOURCES <- c( + drug_label = "unit", drug_or_class = "target", feature_subtype = "encoding", + strat_value = "train_group", strat_value_test = "test_group", + leaveout_strat_value = "test_group", drug = "train_group", test_drug = "test_group", + num_obs_original_ml_input_tibble = "num_obs", num_obs_test_data = "n_test", + res_prop_original_ml_input_tibble = "res_prop", res_prop_test_data = "res_prop_test" +) + + +# Each task's metadata from the tasks and matrix list; `species` comes with the results. +.exportMetadata <- function(fit) { + m <- fit$built$matrices[match(fit$tasks$matrix_id, fit$built$matrices$matrix_id), ] + grouping <- .MODES$grouping[match(m$mode_id, .MODES$mode_id)] + + tibble::tibble( + task_id = fit$tasks$task_id, + mode_id = m$mode_id, + seed = fit$tasks$seed, + shuffled = fit$tasks$labels == "shuffled", + strat_label = ifelse(grouping %in% c("year", "country"), grouping, NA_character_), + unit = m$unit, + target = m$target, + train_group = m$train_group, + test_group = m$test_group, + feature_type = m$feature_type, + encoding = m$encoding + ) +} + +# A mode's layout, chosen by its registry flags. +.exportLayout <- function(mode) { + shape <- if (mode$grouping == "none") { + "vanilla" + } else if (mode$cross_test) { + if (mode$grouping == "drug") "cross_drug" else "cross" + } else if (mode$LOO) { + "loo" + } else { + "stratified" + } + .EXPORT_LAYOUTS[[shape]] +} + +# A mode's file names, from its registry flags as old amRml named them: all_, _, +# cross__ or LOO__. +.exportFiles <- function(mode) { + prefix <- if (mode$grouping == "none") { + "all" + } else if (mode$cross_test) { + paste0("cross_", mode$grouping) + } else if (mode$LOO) { + paste0("LOO_", mode$grouping) + } else { + mode$grouping + } + c(perf = paste0(prefix, "_perf.parquet"), top = paste0(prefix, "_top_features.parquet")) +} + +# One file's rows: results joined to their tasks' metadata, under the layout's column names. +.exportRows <- function(results, metadata, columns) { + rows <- dplyr::inner_join(metadata, results, by = "task_id") + sources <- ifelse(columns %in% names(.EXPORT_SOURCES), .EXPORT_SOURCES[columns], columns) + stats::setNames(rows[sources], columns) +} + +#' Export results in old amRml's merged format +#' +#' Writes a fit's performance and top features as the merged tables old amRml's +#' `mergeMLresults()` produced, one file per mode, with its file names and +#' columns: `all_perf.parquet` and `all_top_features.parquet` for vanilla, +#' `year_perf.parquet`, `cross_drug_perf.parquet`, `LOO_year_perf.parquet` and +#' so on. Metadata comes from the tasks rather than file names, and every file +#' has `shuffled` and an integer `seed`. This export is temporary: it bridges to +#' old amRml's format until amRml's own column names match it. +#' +#' @details +#' Left out: old amRml's `filename`, `train_prop`, `val_prop` and +#' `prop_vi_top_feats` bounds, and this package's added columns (`task_id`, +#' `auprc`), which stay in `results/`. +#' +#' @param fit An `amr_fit` from [fitModels()]. +#' @param overwrite Replace files already in the output folder's `merged/`. +#' +#' @return The written paths, invisibly; the files are in `/merged/`. +#' +#' @section Errors: +#' All errors have class `amrml_error`, plus `amrml_invalid_argument`: `fit` +#' is not from [fitModels()], or `merged/` already has files and `overwrite` is +#' `FALSE`. +#' +#' @examples +#' \dontrun{ +#' exportMergedResults(fitModels(tasks)) +#' } +#' @export +exportMergedResults <- function(fit, overwrite = FALSE) { + call <- rlang::current_env() + .checkArgClass(fit, "fit", "amr_fit", "fitModels()", call = call) + .checkArgFlag(overwrite, "overwrite", call = call) + merged <- file.path(fit$built$out_dir, "merged") + if (length(list.files(merged)) && !overwrite) { + .amrAbort( + "invalid_argument", + "The output folder already has merged results; set `overwrite = TRUE` to replace them.", + observed = list(out_dir = fit$built$out_dir), + call = call + ) + } + + unlink(merged, recursive = TRUE) + dir.create(merged) + metadata <- .exportMetadata(fit) + # The seed comes from the tasks, so top features get it too. + performance <- fit$performance[names(fit$performance) != "seed"] + written <- character() + for (mode_id in intersect(.MODES$mode_id, metadata$mode_id)) { + mode <- .MODES[.MODES$mode_id == mode_id, ] + layout <- .exportLayout(mode) + files <- file.path(merged, .exportFiles(mode)) + mode_metadata <- metadata[metadata$mode_id == mode_id, ] + + arrow::write_parquet(.exportRows(performance, mode_metadata, layout$perf), files[[1]]) + written <- c(written, files[[1]]) + if (!is.null(layout$top)) { + arrow::write_parquet(.exportRows(fit$importance, mode_metadata, layout$top), files[[2]]) + written <- c(written, files[[2]]) + } + } + + invisible(written) +} diff --git a/R/feature-rescoring.R b/R/feature-rescoring.R new file mode 100644 index 0000000..16b9f3f --- /dev/null +++ b/R/feature-rescoring.R @@ -0,0 +1,1344 @@ +# Feature rescoring: features consistently important across seeds, and their dyads. + +# Feature evidence and model reliability scoring + +#' Assess model reliability using real-label and shuffled-label MCC +#' +#' Compare each model's real-label MCC with the shuffled-label MCC from the +#' same seed and with the average shuffled MCC plus one standard deviation (SD) +#' for the same drug, feature type, and encoding. A seed supports the model only +#' when its real-label MCC is positive and exceeds both comparisons. +#' At least two defined shuffled MCC values are needed to calculate the SD. +#' +#' @param all_performance_parquet Path to the merged model-performance Parquet file. +#' @param min_supported_seeds Number of supporting seeds required (default 2). +#' @return List with reliability results by representation and MCC comparisons +#' by seed. Missing MCC values are not replaced with zero. +#' @export +assessModelReliability <- function(all_performance_parquet, + min_supported_seeds = 2L) { + stopifnot(file.exists(all_performance_parquet)) + if (length(min_supported_seeds) != 1L || is.na(min_supported_seeds) || + min_supported_seeds < 1L || min_supported_seeds != as.integer(min_supported_seeds)) + stop("min_supported_seeds must be a positive integer.", call. = FALSE) + + keys <- c("species", "drug_label", "drug_or_class", "feature_type", + "feature_subtype", "seed") + rep_keys <- head(keys, -1L) + perf <- arrow::read_parquet(normalizePath(all_performance_parquet)) + if (!all(c(keys, "shuffled", "mcc") %in% names(perf))) + stop("Performance must contain scope, seed, shuffled and mcc columns.", call. = FALSE) + if (anyNA(perf[c(keys, "shuffled")]) || + !is.logical(perf$shuffled) || + anyDuplicated(perf[c(keys, "shuffled")])) + stop("Performance has missing or duplicate fit identities.", call. = FALSE) + if (any(!is.na(perf$mcc) & + (!is.finite(perf$mcc) | abs(perf$mcc) > 1 + 1e-8))) + stop("Defined MCC must be finite and in [-1, 1].", call. = FALSE) + + # Construct the null reference separately within each representation. + # A single shuffled MCC cannot support an SD estimate (not SD = 0) + shuffled_baseline <- perf |> + dplyr::filter(shuffled) |> + dplyr::group_by(dplyr::across(dplyr::all_of(rep_keys))) |> + dplyr::summarise( + n_shuffled_defined = sum(!is.na(mcc)), + mean_shuffled_mcc = if (n_shuffled_defined >= 2L) mean(mcc, na.rm = TRUE) else NA_real_, + sd_shuffled_mcc = if (n_shuffled_defined >= 2L) stats::sd(mcc, na.rm = TRUE) else NA_real_, + .groups = "drop" + ) |> + dplyr::mutate(shuffled_upper = mean_shuffled_mcc + sd_shuffled_mcc) + + real <- perf |> + dplyr::filter(!shuffled) |> + dplyr::select(dplyr::all_of(keys), mcc_real = mcc) |> + dplyr::mutate(has_real = TRUE) + shuffled <- perf |> + dplyr::filter(shuffled) |> + dplyr::select(dplyr::all_of(keys), mcc_shuffled = mcc) |> + dplyr::mutate(has_shuffled = TRUE) + + paired <- dplyr::full_join(real, shuffled, by = keys) |> + dplyr::left_join(shuffled_baseline, by = rep_keys) |> + dplyr::mutate( + assessable_pair = !is.na(mcc_real) & !is.na(mcc_shuffled) & + !is.na(shuffled_upper), + # Count this seed as supporting the model only if real-label MCC is + # positive and exceeds both its matched shuffled MCC and the shuffled + # average plus one SD. Missing MCC values cannot provide support + above_background = dplyr::coalesce( + assessable_pair & mcc_real > 0 & mcc_real > mcc_shuffled & + mcc_real > shuffled_upper, FALSE + ) + ) + + summary <- paired |> + dplyr::group_by(dplyr::across(dplyr::all_of(rep_keys))) |> + dplyr::summarise( + n_real_fits = sum(!is.na(has_real)), + n_shuffled_fits = sum(!is.na(has_shuffled)), + n_shuffled_defined = dplyr::first(n_shuffled_defined), + mean_shuffled_mcc = dplyr::first(mean_shuffled_mcc), + sd_shuffled_mcc = dplyr::first(sd_shuffled_mcc), + n_paired_assessable = sum(assessable_pair), + n_supported_seeds = sum(above_background), + n_unassessable_real = sum(!is.na(has_real) & is.na(mcc_real)), + .groups = "drop" + ) |> + dplyr::mutate( + evidence_status = dplyr::case_when( + n_supported_seeds >= min_supported_seeds ~ "supported", + n_paired_assessable < min_supported_seeds ~ "insufficient", + n_supported_seeds == 0L ~ "background_like", + TRUE ~ "weak_discrimination" + ), + supported = evidence_status == "supported" + ) + + list(by_representation = summary, by_seed = paired) +} + + +#' Summarize feature importance across successfully fitted seeds +#' +#' Calculate each feature's average normalized importance using only seeds +#' where that feature was available to the model. Include a zero for a feature +#' that was available but not returned by a fitted model. Also record how often +#' the feature belongs to the group accounting for the chosen share of importance. +#' +#' @param scored_top_features Feature importance from successful real-label fits, +#' returned by scoreFeaturesWithinSeed(..., filter_model = FALSE). +#' @param candidate_inventory One row per feature available in each successfully +#' fitted seed, using the same feature identifiers as scored_top_features. +#' Features absent from a seed's candidate list are not counted as zeros. +#' @return Tibble with average normalized importance, counts of eligible and +#' fitted seeds, frequency in the core feature group, and coefficient signs. +#' @export +summarizeFeatureEvidence <- function(scored_top_features, + candidate_inventory) { + keys <- c("species", "drug_label", "drug_or_class", "feature_type", + "feature_subtype", "seed") + feature_keys <- c(keys, "variable") + scope <- c("species", "drug_label", "drug_or_class", "feature_type", + "feature_subtype") + by_feature <- c(scope, "variable") + if (!is.data.frame(scored_top_features) || !is.data.frame(candidate_inventory) || + !all(c(feature_keys, "contribution", "in_core", "sign") %in% names(scored_top_features)) || + !all(feature_keys %in% names(candidate_inventory))) + stop("Expected per-seed coefficients and candidate-by-fitted-seed inventory.", call. = FALSE) + if (!nrow(scored_top_features) || !nrow(candidate_inventory) || + anyNA(scored_top_features[feature_keys]) || anyNA(candidate_inventory[feature_keys]) || + anyDuplicated(scored_top_features[feature_keys]) || + anyDuplicated(candidate_inventory[feature_keys])) + stop("Missing/duplicate candidate or returned-feature identities.", call. = FALSE) + if (any(!is.finite(scored_top_features$contribution) | + scored_top_features$contribution < 0) || + anyNA(scored_top_features$in_core)) + stop("Invalid normalized coefficient evidence.", call. = FALSE) + if (nrow(dplyr::anti_join(scored_top_features, candidate_inventory, + by = feature_keys))) + stop("Returned coefficient is absent from that fitted seed's candidate inventory.", + call. = FALSE) + fitted <- dplyr::distinct(scored_top_features, dplyr::across(dplyr::all_of(keys))) + candidates_fitted <- dplyr::distinct(candidate_inventory, dplyr::across(dplyr::all_of(keys))) + if (nrow(dplyr::anti_join(fitted, candidates_fitted, by = keys)) || + nrow(dplyr::anti_join(candidates_fitted, fitted, by = keys))) + stop("Fitted tasks and candidate-inventory tasks do not match.", call. = FALSE) + + # Within each fitted seed, the normalized importance of the returned + # features must add up to 1. If it does not, the fit cannot be scored reliably + sums <- scored_top_features |> + dplyr::group_by(dplyr::across(dplyr::all_of(keys))) |> + dplyr::summarize(total = sum(contribution), .groups = "drop") + if (any(abs(sums$total - 1) > 1e-7)) + stop("Returned normalized feature importance does not sum to one.", call. = FALSE) + + # Give a feature zero importance when it was available in a fitted seed + # but not returned by the model. Don't include seeds where it was unavailable + filled <- candidate_inventory |> + dplyr::select(dplyr::all_of(feature_keys)) |> + dplyr::left_join( + dplyr::select(scored_top_features, + dplyr::all_of(feature_keys), contribution, in_core, sign), + by = feature_keys + ) |> + dplyr::mutate( + returned = !is.na(contribution), + contribution = dplyr::coalesce(contribution, 0), + in_core = dplyr::coalesce(in_core, FALSE) + ) + n_fitted <- fitted |> + dplyr::count(dplyr::across(dplyr::all_of(scope)), name = "n_fitted_seeds") + result <- filled |> + dplyr::group_by(dplyr::across(dplyr::all_of(by_feature))) |> + dplyr::summarize( + n_eligible_seeds = dplyr::n(), + n_returned_seeds = sum(returned), + n_core_seeds = sum(in_core), + direct_score = mean(contribution), + core_seed_fraction = mean(in_core), + sign_consistent = dplyr::n_distinct(sign[returned]) <= 1L, + sign = if (dplyr::n_distinct(sign[returned]) == 1L) + sign[which(returned)[[1L]]] else NA_character_, + .groups = "drop" + ) |> + dplyr::left_join(n_fitted, by = scope) |> + dplyr::mutate( + # A feature is reproducible when it is in the core group for at least + # two eligible seeds. Keep the counts to distinguish 2 of 2 from 2 of 3 + reproducibly_important = n_core_seeds >= 2L & n_eligible_seeds >= 2L + ) |> + dplyr::group_by(dplyr::across(dplyr::all_of(scope))) |> + dplyr::arrange(dplyr::desc(direct_score), variable, .by_group = TRUE) |> + dplyr::mutate(direct_rank = dplyr::row_number()) |> + dplyr::ungroup() + result +} + + +#' Filter model fits to those passing quality thresholds +#' +#' @param all_performance_parquet The path to the 'all performance parquet' file +#' @param MCC_threshold The minimum non-shuffled MCC required to keep a model fit (default is \code{NULL}, no filtering) +#' @param compare_to_shuffled Logical indicating whether to require the non-shuffled MCC to exceed (outperform) the shuffled-label MCC for the same fit (default is \code{TRUE}). A fit with no shuffled counterpart (\code{shuffled_MCC} is \code{NA} after pivoting) always passes this check regardless. +#' +#' @returns a tibble of model fits (one row per species, drug_label, drug_or_class, seed, feature_type, feature_subtype, model, fit_penalty, fit_mixture) that pass the requested quality thresholds, with \code{nonshuffled_MCC}, \code{shuffled_MCC}, and \code{MCC_diff} columns added. This does not pick a single "best" fit per group; it filters out fits that fail the MCC/shuffled-comparison criteria, so multiple passing fits per group can remain. +#' +#' @keywords internal +#' @examples +#' \dontrun{ +#' filterOptimalModel(all_performance_parquet = "inst/extdata/all_perf.parquet") +#' } +filterOptimalModel <- function(all_performance_parquet, + MCC_threshold = NULL, + compare_to_shuffled = TRUE) + { + stopifnot(file.exists(all_performance_parquet)) + all_perf <- arrow::read_parquet(normalizePath(all_performance_parquet)) + + if (!all(c(TRUE, FALSE) %in% unique(all_perf$shuffled))) { + stop("The 'shuffled' column must contain both TRUE and FALSE values. Run runModelingPipelineIntense() ") + } + + all_perf |> + dplyr::select( + species, drug_label, drug_or_class, + seed, feature_type, feature_subtype, + model, fit_penalty, fit_mixture, + shuffled, mcc + ) |> + tidyr::pivot_wider( + names_from = shuffled, + values_from = mcc, + names_prefix = "shuffled_" + ) |> + dplyr::rename( + nonshuffled_MCC = shuffled_FALSE, + shuffled_MCC = shuffled_TRUE + ) |> + dplyr::filter(!is.na(nonshuffled_MCC)) |> + dplyr::mutate( + MCC_diff = nonshuffled_MCC - shuffled_MCC + ) |> + dplyr::filter( + if (!is.null(MCC_threshold)) (nonshuffled_MCC >= MCC_threshold) else TRUE, + if (compare_to_shuffled) (MCC_diff > 0 | is.na(shuffled_MCC)) else TRUE + ) +} + +#' Score features within each seed +#' +#' @param all_top_features_parquet The path to the Parquet file containing all top features with their importance scores. +#' @param core_contribution_threshold The cumulative-contribution cutoff, in \[0, 1\] (default is \code{0.75}, i.e. 75%), used to flag whether a feature falls within the "core" set of features that jointly account for that share of a seed's total importance. +#' @param exclude_feature_types Feature types to drop before any scoring happens (default is \code{NULL}, i.e. no feature types are excluded and struct is currently included). struct variables are composite IDs (e.g. \code{polA.group_211.group_2176}, three dot-joined gene/domain identifiers) representing a co-occurrence/structural motif rather than a single molecular entity like the other five scales, and its candidate-variable count (tens of thousands per group) dwarfs the other scales by orders of magnitude — pooling it into this rank_score/contribution machinery would compare a compound signal against five primary ones on an incomparable scale. Pass \code{"struct"} here to exclude it once struct is meant to be reserved for post-hoc biological annotation rather than scoring/ranking/thresholding. +#' @param filter_model Logical indicating whether to restrict scoring to (species, drug_label, drug_or_class, feature_type, feature_subtype, seed) groups that have at least one model fit passing \code{filterOptimalModel()}'s MCC/shuffled-comparison quality thresholds (default is \code{TRUE}). The join is not keyed on \code{model}/\code{fit_penalty}/\code{fit_mixture}; this is only safe because there is currently never more than one fit per (species, drug_label, drug_or_class, feature_type, feature_subtype, seed) group. If that assumption changes, this join (and the \code{all_perf} join below) would need a finer-grained key to avoid silently keeping/duplicating rows from multiple fits. +#' @param all_performance_parquet The path to the all performance parquet file. Always required — it is read unconditionally +#' @param MCC_threshold The minimum MCC threshold passed through to \code{filterOptimalModel()} (default is \code{NULL}, no filtering) +#' @param compare_to_shuffled Logical indicating whether to compare the model to shuffled data, passed through to \code{filterOptimalModel()} (default is \code{TRUE}) +#' +#' @returns a tibble of scored top features, one row per feature within each species/drug_label/drug_or_class/feature_type/feature_subtype/seed group, with the following columns added: +#' \itemize{ +#' \item \code{contribution}: the feature's importance divided by the sum of importance across all features in the group. +#' \item \code{feat_return_ratio}: \code{n_feats_returned / n_feat} for the fit that produced this group. This assumes there is never more than one surviving fit per (species, drug_label, drug_or_class, seed, feature_type, feature_subtype) group; if that ever stops being true, this join would need a finer-grained key (\code{all_top_features_parquet} carries no \code{model}/\code{fit_penalty}/\code{fit_mixture} column to join on directly) or the ratio would need to be aggregated across fits before joining, to avoid fanning out and double-counting feature rows. +#' \item \code{rank}: descending rank of \code{contribution} within the group; ties receive the average of the ranks they span. +#' \item \code{n_features}: the number of rows (features) in the group. +#' \item \code{rank_score}: \code{(n_features - rank) / (n_features - 1)}; ranges 0-1 with higher values indicating higher importance (a single-feature group scores 1). +#' \item \code{cum_contrib}: the cumulative sum of \code{contribution} in descending order, with ties broken deterministically by variable identifier. +#' \item \code{in_core}: TRUE for the smallest deterministic prefix reaching the requested cumulative normalized importance; the feature crossing the threshold is INCLUDED. This is a reporting tier, not a multiplicative score. +#' } +#' +#' @keywords internal +#' @examples +#' \dontrun{ +#' scoreFeaturesWithinSeed(all_top_features_parquet = "inst/extdata/all_top_features.parquet", +#' all_performance_parquet = "inst/extdata/all_perf.parquet") +#' } +#' +scoreFeaturesWithinSeed <- function(all_top_features_parquet, + core_contribution_threshold = 0.75, + exclude_feature_types = NULL, + filter_model = TRUE, + all_performance_parquet, + MCC_threshold = NULL, + compare_to_shuffled = TRUE) + { + # check for the all_perf.parquet and all_top_features.parquet files + stopifnot(file.exists(all_top_features_parquet)) + stopifnot(file.exists(all_performance_parquet)) + + all_top_features <- arrow::read_parquet(normalizePath(all_top_features_parquet)) |> + dplyr::filter(!shuffled, !feature_type %in% exclude_feature_types) + + if (filter_model) { + filtered_model <- filterOptimalModel( + normalizePath(all_performance_parquet), + MCC_threshold = MCC_threshold, + compare_to_shuffled = compare_to_shuffled + ) + + all_top_features <- all_top_features |> + dplyr::semi_join( + filtered_model, + by = dplyr::join_by( + species, drug_label, drug_or_class, + feature_type, feature_subtype, seed + ) + ) + } + + all_perf <- arrow::read_parquet(normalizePath(all_performance_parquet)) |> + dplyr::filter(!shuffled) |> + dplyr::select(species, drug_label, drug_or_class, seed, + feature_type, feature_subtype, fit_penalty, fit_mixture, + mcc, n_feat, n_feats_returned) |> + dplyr::mutate( + feat_return_ratio = n_feats_returned / n_feat + ) + + # The threshold must be between 0 and 1; the default of 0.75 means + # that the core feature group must cover at least 75% of total importance + if (length(core_contribution_threshold) != 1L || + !is.finite(core_contribution_threshold) || + core_contribution_threshold < 0 || core_contribution_threshold > 1) + stop("core_contribution_threshold must be in [0, 1].", call. = FALSE) + + # add different layers of scoring to the features within each seed + scored_top_features <- all_top_features |> + dplyr::select( + species, drug_label, drug_or_class, seed, + feature_type, feature_subtype, variable = Variable, + importance = Importance, sign = Sign + ) |> + dplyr::mutate( + variable = dplyr::case_when( + feature_type == "protein" ~ sub("fig.", "fig|", variable, fixed = TRUE), + feature_type == "AMRFinder" ~ sub( + "^X", "", + gsub("\\.NCBIFAM", "", variable) + ), + TRUE ~ variable + ) + ) |> + dplyr::left_join(all_perf, by = dplyr::join_by(species, drug_label, drug_or_class, seed, + feature_type, feature_subtype)) |> + dplyr::group_by( + species, + drug_label, + drug_or_class, + feature_type, + feature_subtype, + seed + ) |> + dplyr::mutate( + contribution = importance / sum(importance, na.rm = TRUE) + ) |> + # Sort features from highest to lowest importance. If two features have + # equal importance, sort by feature ID so the input row order cannot + # change which one enters the core group first + dplyr::arrange(dplyr::desc(contribution), variable, .by_group = TRUE) |> + dplyr::mutate( + rank = rank(dplyr::desc(contribution), ties.method = "average"), + n_features = dplyr::n(), + rank_score = dplyr::if_else( + n_features > 1, + (n_features - rank) / (n_features - 1), + 1 + ), + running_contrib = cumsum(contribution) + ) |> + dplyr::mutate( + cum_contrib = running_contrib, + # Include features until their combined importance reaches the threshold. + # Keep the feature that reaches or exceeds it, but not the ones after it + in_core = core_contribution_threshold > 0 & + (running_contrib - contribution < core_contribution_threshold) + ) |> + dplyr::ungroup() |> + dplyr::select(-running_contrib) + + # If a model has no usable total importance, the relative contribution + # of its features cannot be calculated + if (any(!is.finite(scored_top_features$contribution))) + stop("A fitted model has no valid total coefficient importance.", call. = FALSE) + + return(scored_top_features) +} + +#' Summarize a feature's scoring across seeds +#' +#' Answers "which molecular features are consistently important?" by +#' collapsing the per-seed rows from `scoreFeaturesWithinSeed()` down to one +#' row per feature. +#' +#' @param scored_top_features The tibble of scored top features with their contribution, rank, and rank score within each seed generated from `scoreFeaturesWithinSeed()` +#' +#' @returns a tibble with one row per species/drug_label/drug_or_class/feature_type/feature_subtype/variable, with: +#' \itemize{ +#' \item \code{seed_ratio}: the number of seeds the feature appears in, divided by the total number of distinct \code{seed} values present anywhere in \code{scored_top_features} (a single count computed once for the whole call, not per feature or per group — so this assumes every group was fit with the same set of seeds). +#' \item \code{mean_rank_score}, \code{median_rank_score}: mean/median of \code{rank_score} across seeds; ranges 0-1 with higher values indicating higher importance. +#' \item \code{median_rank}: median of \code{rank} across seeds. (\code{mean_rank} is not currently computed.) +#' \item \code{median_contribution}: median of \code{contribution} across seeds. (\code{mean_contribution} is not currently computed.) +#' \item \code{median_cum_contrib}: median of \code{cum_contrib} across seeds. +#' \item \code{best_rank}: the best (lowest) rank seen across seeds. +#' \item \code{rank_consistent}: TRUE if the feature's rank is identical in every seed. +#' \item \code{rank_score_sd}, \code{rank_score_cv}: standard deviation and coefficient of variation of \code{rank_score} across seeds, i.e. how much the normalized rank_score varies — computed on \code{rank_score} rather than raw rank so it is comparable across groups with different numbers of features. +#' \item \code{in_core_consistent}, \code{in_core}: whether the feature's \code{in_core} flag is identical across every seed; \code{in_core} is that shared value if consistent, else \code{FALSE}. +#' \item \code{sign_consistent}, \code{sign}: whether the feature's \code{sign} is identical across every seed; \code{sign} is that shared value if consistent, else \code{"MIXED"}. +#' } +#' +#' @keywords internal +#' @examples +#' \dontrun{ +#' summariseFeaturesAcrossSeeds(scoreFeaturesWithinSeed(all_top_features.parquet)) +#' } +summariseFeaturesAcrossSeeds <- function(scored_top_features) { + + # find max number of seeds + max_seeds <- scored_top_features |> + dplyr::summarise(n_seeds = dplyr::n_distinct(seed)) |> + dplyr::pull(n_seeds) + + feature_summary <- scored_top_features |> + dplyr::group_by( + species, + drug_label, + drug_or_class, + feature_type, + feature_subtype, + variable + ) |> + dplyr::summarise( + seed_ratio = dplyr::n_distinct(seed) / max_seeds, + + mean_rank_score = mean(rank_score, na.rm = TRUE), + median_rank_score = median(rank_score, na.rm = TRUE), + rank_score_sd = sd(rank_score, na.rm = TRUE), + # coefficient of variation: how large rank_score_sd is relative to mean_rank_score + rank_score_cv = dplyr::if_else( + mean_rank_score != 0, + rank_score_sd / mean_rank_score, + NA_real_ + ), + + median_rank = median(rank, na.rm = TRUE), + best_rank = min(rank, na.rm = TRUE), + rank_consistent = dplyr::n_distinct(rank) == 1, + + median_contribution = median(contribution, na.rm = TRUE), + median_cum_contrib = median(cum_contrib, na.rm = TRUE), + + in_core_consistent = dplyr::n_distinct(in_core) == 1, + in_core = if (in_core_consistent) dplyr::first(in_core) else FALSE, + + sign_consistent = dplyr::n_distinct(sign) == 1, + sign = if (sign_consistent) dplyr::first(sign) else "MIXED", + .groups = "drop" + ) + + return(feature_summary) +} + +#' Build a per-drug top-feature table with cutoffs +#' +#' Runs `scoreFeaturesWithinSeed()` and `summariseFeaturesAcrossSeeds()` on +#' `all_top_features_parquet`, then filters the resulting per-feature summary +#' down to the top features for each drug/class. +#' +#' @inheritParams scoreFeaturesWithinSeed +#' @param rank_score_quantile A value in \[0, 1\] (default is \code{0.95}). Keep only features whose \code{median_rank_score} is at or above this quantile of \code{median_rank_score}, where the quantile is computed separately within each (species, drug_label, drug_or_class) group (with \code{na.rm = TRUE}) — so a feature is compared only against other features from the same drug/class, not against the whole panel. This means a drug/class with weaker or more diffuse signal overall can still contribute its own top features, rather than being crowded out by drugs/classes with stronger or more concentrated signal. As with the other conditions listed below, this is not restricted to rows that already pass them: \code{dplyr::filter()} evaluates every condition passed to a single call against the same original data, so this threshold does not narrow as other conditions are applied +#' @param cv_threshold The maximum allowed coefficient of variation (default is \code{1}). Keep only features with \code{rank_score_cv <= cv_threshold}, i.e. drop features whose rank_score is inconsistent across seeds relative to its mean. A feature present in every seed (\code{seed_ratio == 1}) always passes this check regardless of its \code{rank_score_cv} — including when \code{rank_score_cv} is \code{NA}, which happens whenever a group has only a single seed +#' @param cumulative_contribution_threshold The cumulative-contribution cutoff, in \[0, 1\] (default is \code{0.75}, i.e. 75%). Keep only features with \code{median_cum_contrib <= cumulative_contribution_threshold} +#' @param seed_ratio_threshold If not \code{NULL} (the default), keep only features whose \code{seed_ratio} exactly equals this value +#' @param found_in_both_subtypes Logical indicating whether to additionally restrict to features that survive the filters above in both the binary and counts \code{feature_subtype} (default is \code{FALSE}) +#' @param compare_median_to_sd_rank_score Logical indicating whether to additionally require \code{median_rank_score > rank_score_sd} (default is \code{FALSE}) +#' +#' @returns a tibble of top features for each drug/class: the `summariseFeaturesAcrossSeeds()` output (species, drug label, drug or class, feature type, feature subtype, variable, seed_ratio, mean/median rank score, median rank, median contribution, median cumulative contribution, best rank, rank/sign/in_core consistency flags, sign), filtered in two \code{dplyr::filter()} passes. +#' The first pass keeps rows where all of the following hold, evaluated together against \code{feature_summary} (see \code{rank_score_quantile} for how the last condition is grouped): +#' \itemize{ +#' \item \code{seed_ratio == seed_ratio_threshold}, only applied when \code{seed_ratio_threshold} is not \code{NULL}, +#' \item \code{seed_ratio == 1} OR \code{rank_score_cv <= cv_threshold} (see \code{cv_threshold}), +#' \item \code{in_core} is TRUE, +#' \item \code{sign_consistent} is TRUE (sign is the same in every seed; this does not require the sign to be negative), +#' \item \code{median_cum_contrib <= cumulative_contribution_threshold}, and +#' \item \code{median_rank_score} is at or above the \code{rank_score_quantile} quantile of \code{median_rank_score}, computed separately per (species, drug_label, drug_or_class) group. +#' } +#' Two columns are then added, grouped by (species, drug_label, drug_or_class, feature_type, variable): \code{n_subtype} and \code{subtype_csv}, recording how many/which \code{feature_subtype} values each combination has among the rows that survived the first pass. +#' A second \code{dplyr::filter()} pass then optionally keeps only rows where \code{subtype_csv == "binary,counts"} (when \code{found_in_both_subtypes = TRUE}) and/or \code{median_rank_score > rank_score_sd} (when \code{compare_median_to_sd_rank_score = TRUE}). +#' Every drug/class may not have variables from all feature types. Because the \code{rank_score_quantile} cutoff is now per drug/class rather than global, every drug/class with at least one feature surviving the other conditions will generally contribute something here, rather than potentially being excluded entirely by comparison to stronger-signal drugs/classes elsewhere in the panel. +#' +#' @export +topFeaturesPerDrugOrClass <- function( + all_top_features_parquet, + core_contribution_threshold = 0.75, + exclude_feature_types = NULL, + filter_model = TRUE, + all_performance_parquet, + MCC_threshold = NULL, + compare_to_shuffled = TRUE, + rank_score_quantile = 0.95, + cv_threshold = 1, + cumulative_contribution_threshold = 0.75, + # additional filters + seed_ratio_threshold = NULL, + found_in_both_subtypes = FALSE, + compare_median_to_sd_rank_score = FALSE + ) + { + + scored_features <- scoreFeaturesWithinSeed( + all_top_features_parquet, + core_contribution_threshold = core_contribution_threshold, + exclude_feature_types = exclude_feature_types, + filter_model = filter_model, + all_performance_parquet, + MCC_threshold = MCC_threshold, + compare_to_shuffled = compare_to_shuffled + ) + + feature_summary <- summariseFeaturesAcrossSeeds(scored_features) + + top_filtered_features <- feature_summary |> + dplyr::group_by(species, drug_label, drug_or_class) |> + dplyr::mutate( + rank_score_cutoff = quantile(median_rank_score, rank_score_quantile, na.rm = TRUE) + ) |> + dplyr::ungroup() |> + dplyr::filter( + if (!is.null(seed_ratio_threshold)) seed_ratio == seed_ratio_threshold else TRUE, + seed_ratio == 1 | rank_score_cv <= cv_threshold, # rank_score_cv can be NA if there is only one seed. + in_core, + sign_consistent, + median_cum_contrib <= cumulative_contribution_threshold, + median_rank_score >= rank_score_cutoff + ) |> + dplyr::select(-rank_score_cutoff) |> + dplyr::group_by(species, drug_label, drug_or_class, feature_type, variable) |> + dplyr::mutate( + n_subtype = dplyr::n_distinct(feature_subtype), + subtype_csv = paste(sort(unique(feature_subtype)), collapse = ",") + ) |> + dplyr::ungroup() |> + dplyr::filter( + if (found_in_both_subtypes) (subtype_csv == "binary,counts") else TRUE, + if (compare_median_to_sd_rank_score) (median_rank_score > rank_score_sd) else TRUE + ) + + return(top_filtered_features) +} + +#' Aggregate mapped features to protein dyads +#' +#' Internal helper called on the output of `topFeaturesPerDrugOrClass()`. +#' +#' @param top_filtered_features The tibble of top features for each drug/class generated from `topFeaturesPerDrugOrClass()`. +#' @param dyad_con Open read-only DBI connection exposing virtual +#' `dyad_feature(dyad, feature)` in the ORB DuckDB. +#' @returns a tibble with one row per species/drug_label/drug_or_class/dyad (\code{dyad} is the protein-dyad id), with: +#' \itemize{ +#' \item \code{frequency}: the number of top-feature rows mapped to this dyad. +#' \item \code{n_variables}, \code{variables_csv}: number of, and comma-separated list of, distinct \code{feature} (\code{":"}) values mapped to this dyad. +#' \item \code{n_feature_types}, \code{feature_types_csv}: number of, and comma-separated list of, distinct \code{feature_type_subtype} (\code{":"}) values mapped to this dyad. +#' \item \code{dyad_median_rank_score}: median of \code{median_rank_score} across the top-feature rows mapped to this dyad. +#' \item \code{dyad_median_contribution}: median of \code{median_contribution} across the top-feature rows mapped to this dyad. +#' \item \code{sign_consistent}, \code{sign}: whether \code{sign} is identical across every top-feature row mapped to this dyad; \code{sign} is that shared value if consistent, else \code{"MIXED"}. +#' } +#' +#' @keywords internal +summariseDyads <- function(top_filtered_features, + dyad_con) + { + stopifnot(is.data.frame(top_filtered_features)) + stopifnot(inherits(dyad_con, "DBIConnection")) + + # Query the ORB only for the selected features. Its virtual mapping may + # contain millions of feature-to-dyad links, so avoid loading all of them + selected_features <- top_filtered_features |> + dplyr::mutate( + feature_type = dplyr::case_when( + feature_type == "AMRFinder" ~ "amr", + feature_type == "COG" ~ "cog", + feature_type == "DefenseCas" ~ "defense", + feature_type == "Pfam" ~ "pfam", + TRUE ~ feature_type + ) + ) |> + tidyr::unite("feature", feature_type, variable, sep = ":", remove = FALSE) |> + tidyr::unite("feature_type_subtype", feature_type, feature_subtype, sep = ":", remove = FALSE) + + feature_keys <- unique(selected_features$feature) + if (!length(feature_keys)) { + dyad_feature <- tibble::tibble(dyad = character(), feature = character()) + } else { + # Quote feature IDs safely for SQL and query them in groups of 1,000 + dyad_feature <- dplyr::bind_rows(lapply( + split(feature_keys, ceiling(seq_along(feature_keys) / 1000L)), + function(keys) { + quoted <- as.character(DBI::dbQuoteString(dyad_con, keys)) + DBI::dbGetQuery( + dyad_con, + paste0( + "SELECT DISTINCT dyad, feature FROM dyad_feature WHERE feature IN (", + paste(quoted, collapse = ", "), ")" + ) + ) + } + )) + } + + top_dyads <- selected_features |> + dplyr::left_join(dyad_feature, by = "feature", relationship = "many-to-many") |> + dplyr::filter(!is.na(dyad)) |> + dplyr::select(species, drug_label, drug_or_class, feature_type_subtype, dyad, feature, sign, + median_rank_score, median_contribution, subtype_csv) |> + dplyr::group_by(species, drug_label, drug_or_class, dyad) |> + dplyr::summarise( + frequency = dplyr::n(), + n_variables = dplyr::n_distinct(feature), + variables_csv = paste(sort(unique(feature)), collapse = ","), + n_feature_types = dplyr::n_distinct(feature_type_subtype), + feature_types_csv = paste(sort(unique(feature_type_subtype)), collapse = ","), + dyad_median_rank_score = median(median_rank_score, na.rm = TRUE), + dyad_median_contribution = median(median_contribution, na.rm = TRUE), + sign_consistent = dplyr::n_distinct(sign) == 1, + sign = if (sign_consistent) dplyr::first(sign) else "MIXED", + .groups = "drop" + ) |> + dplyr::arrange(dplyr::desc(dyad_median_rank_score), dplyr::desc(n_feature_types)) + + return(top_dyads) +} + +#' Discover high-performing models, stable features, and protein dyads +#' +#' Runs the model-quality, feature-ranking, and protein-dyad aggregation +#' workflow and organizes the results into question-oriented tables. +#' +#' The returned object can be used to identify: +#' \itemize{ +#' \item model fits with good non-shuffled performance; +#' \item model fits with good separation from shuffled-label models; +#' \item model fits satisfying both performance conditions; +#' \item top features with high seed coverage and median rank score; +#' \item top features with high median contribution; +#' \item top features present across every analyzed seed; +#' \item top features shared across drugs or drug classes; +#' \item top features unique to one drug or drug class; +#' \item high-scoring, shared, and unique protein dyads. +#' } +#' +#' This is a high-level wrapper around \code{filterOptimalModel()}, +#' \code{topFeaturesPerDrugOrClass()}, and \code{summariseDyads()}. +#' +#' @param all_top_features_parquet Path to the Parquet file containing +#' top features and their importance scores. +#' @param all_performance_parquet Path to the Parquet file containing +#' model-performance results. +#' @param dyad_con Open DBI connection to the ORB virtual `dyad_feature` view. +#' +#' @param MCC_threshold Minimum non-shuffled MCC used to define good model +#' performance. Default is \code{0.5}, meaning that only models with a non-shuffled MCC of 0.5 or higher are considered. +#' @param compare_to_shuffled Logical indicating whether the models used for +#' feature selection must outperform their shuffled-label counterparts. +#' Default is \code{TRUE}. +#' +#' @param core_contribution_threshold Cumulative-contribution threshold +#' passed to \code{scoreFeaturesWithinSeed()}. Default is \code{0.9}. +#' @param exclude_feature_types Feature types to exclude before feature +#' scoring. Default is \code{NULL}. +#' @param filter_model Logical indicating whether feature scoring should be +#' restricted to model groups passing the requested model-quality criteria. +#' Default is \code{TRUE}. +#' @param rank_score_quantile Quantile cutoff for median rank score, computed +#' separately within each species/drug-label/drug-or-class group. +#' Default is \code{0.95}. +#' @param cv_threshold Maximum allowed rank-score coefficient of variation. +#' Default is \code{1}. +#' @param cumulative_contribution_threshold Maximum allowed median cumulative +#' contribution. Default is \code{0.75}. +#' @param seed_ratio_threshold Optional exact seed-ratio requirement passed +#' to \code{topFeaturesPerDrugOrClass()}. Default is \code{1}. +#' @param found_in_both_subtypes Logical indicating whether selected features +#' must occur in both binary and counts feature subtypes. +#' Default is \code{FALSE}. +#' @param compare_median_to_sd_rank_score Logical indicating whether selected +#' features must have \code{median_rank_score > rank_score_sd}. +#' Default is \code{FALSE}. +#' +#' @param consistent_seed_ratio Minimum seed ratio used to define a +#' consistently selected feature. Default is \code{0.8}. +#' @param consistent_rank_score Minimum median rank score used to define a +#' consistently highly ranked feature. Default is \code{0.75}. +#' @param high_contribution_quantile Quantile of \code{median_contribution} +#' used to define high-contribution features. It is computed separately +#' within each species/drug-label/drug-or-class group. Default is +#' \code{0.75}. +#' @param high_dyad_score_quantile Quantile of +#' \code{dyad_median_rank_score} used to define high-scoring dyads. It is +#' computed separately within each species/drug-label/drug-or-class group. +#' Default is \code{0.75}. +#' @param min_models_shared Minimum number of distinct drugs or drug classes +#' required for a feature or dyad to be considered shared. +#' Default is \code{2}. +#' +#' @returns An object of class \code{feature_dyad_discovery}, implemented as +#' a named list containing: +#' \itemize{ +#' \item \code{models$good_performance}: fit-level models satisfying +#' \code{MCC_threshold}, without requiring shuffled-model separation. +#' \item \code{models$good_shuffled_separation}: fit-level models whose +#' non-shuffled MCC exceeds the shuffled-label MCC. +#' \item \code{models$qualified}: fit-level models satisfying the model +#' criteria used for feature selection. +#' \item \code{models$summary}: model-level summary across seeds and feature +#' scales. +#' \item \code{features$top}: all selected top features. +#' \item \code{features$consistent}: selected features with high seed ratio +#' and high median rank score. +#' \item \code{features$high_contribution}: selected features with high +#' median contribution. +#' \item \code{features$all_seeds}: selected features present across all +#' analyzed seeds. +#' \item \code{features$shared}: selected features associated with at least +#' \code{min_models_shared} drugs or drug classes. +#' \item \code{features$unique}: selected features associated with exactly +#' one drug or drug class. +#' \item \code{dyads$top}: dyads mapped from the selected top features. +#' \item \code{dyads$high_score}: dyads with high median rank scores. +#' \item \code{dyads$shared}: dyads associated with at least +#' \code{min_models_shared} drugs or drug classes. +#' \item \code{dyads$unique}: dyads associated with exactly one drug or +#' drug class. +#' \item \code{parameters}: parameter values used for the analysis. +#' } +#' +#' @export +runFeatureDyadDiscovery <- function( + all_top_features_parquet, + all_performance_parquet, + dyad_con, + MCC_threshold = 0.5, + compare_to_shuffled = TRUE, + core_contribution_threshold = 0.9, + exclude_feature_types = NULL, + filter_model = TRUE, + rank_score_quantile = 0.95, + cv_threshold = 1, + cumulative_contribution_threshold = 0.75, + seed_ratio_threshold = 1, + found_in_both_subtypes = FALSE, + compare_median_to_sd_rank_score = FALSE, + consistent_seed_ratio = 0.8, + consistent_rank_score = 0.75, + high_contribution_quantile = 0.75, + high_dyad_score_quantile = 0.75, + min_models_shared = 2 +) { + + # ------------------------------------------------------------------------- + # Validate files + # ------------------------------------------------------------------------- + + input_files <- c( + all_top_features_parquet = all_top_features_parquet, + all_performance_parquet = all_performance_parquet + ) + + # Require the ORB virtual mapping + stopifnot(inherits(dyad_con, "DBIConnection")) + + missing_files <- input_files[!file.exists(input_files)] + + if (length(missing_files) > 0) { + stop( + "The following input file(s) do not exist: ", + paste(names(missing_files), collapse = ", ") + ) + } + + # ------------------------------------------------------------------------- + # Validate analysis thresholds + # ------------------------------------------------------------------------- + + unit_interval_parameters <- c( + core_contribution_threshold = core_contribution_threshold, + rank_score_quantile = rank_score_quantile, + cumulative_contribution_threshold = + cumulative_contribution_threshold, + consistent_seed_ratio = consistent_seed_ratio, + consistent_rank_score = consistent_rank_score, + high_contribution_quantile = high_contribution_quantile, + high_dyad_score_quantile = high_dyad_score_quantile + ) + + invalid_parameters <- names(unit_interval_parameters)[ + is.na(unit_interval_parameters) | + unit_interval_parameters < 0 | + unit_interval_parameters > 1 + ] + + if (length(invalid_parameters) > 0) { + stop( + "The following parameter(s) must be between 0 and 1: ", + paste(invalid_parameters, collapse = ", ") + ) + } + + if (!is.null(seed_ratio_threshold)) { + if ( + length(seed_ratio_threshold) != 1 || + is.na(seed_ratio_threshold) || + seed_ratio_threshold < 0 || + seed_ratio_threshold > 1 + ) { + stop( + "seed_ratio_threshold must be NULL or a single value ", + "between 0 and 1." + ) + } + } + + if ( + length(cv_threshold) != 1 || + is.na(cv_threshold) || + cv_threshold < 0 + ) { + stop("cv_threshold must be a single non-negative value.") + } + + if ( + length(min_models_shared) != 1 || + is.na(min_models_shared) || + min_models_shared < 2 || + min_models_shared != as.integer(min_models_shared) + ) { + stop( + "min_models_shared must be a single integer greater than ", + "or equal to 2." + ) + } + + # ------------------------------------------------------------------------- + # 1. Find fits with good absolute performance + # + # This table answers: + # "Which model fits have sufficiently high non-shuffled MCC?" + # ------------------------------------------------------------------------- + + good_performance_models <- filterOptimalModel( + all_performance_parquet = all_performance_parquet, + MCC_threshold = MCC_threshold, + compare_to_shuffled = FALSE + ) + + # ------------------------------------------------------------------------- + # 2. Find fits with good separation from shuffled models + # + # This table answers: + # "Which model fits outperform their shuffled-label counterparts?" + # + # MCC_threshold is deliberately NULL here so that separation can be + # examined independently of absolute MCC. + # ------------------------------------------------------------------------- + + good_shuffled_separation_models <- filterOptimalModel( + all_performance_parquet = all_performance_parquet, + MCC_threshold = NULL, + compare_to_shuffled = TRUE + ) + + # ------------------------------------------------------------------------- + # 3. Find models satisfying the criteria used for feature selection + # + # If compare_to_shuffled is TRUE, these satisfy both the requested + # MCC threshold and shuffled-label comparison. + # ------------------------------------------------------------------------- + + qualified_models <- filterOptimalModel( + all_performance_parquet = all_performance_parquet, + MCC_threshold = MCC_threshold, + compare_to_shuffled = compare_to_shuffled + ) + + if (nrow(qualified_models) == 0) { + stop( + "No model fits passed the requested model-quality criteria." + ) + } + + # Summarize fit-level results to the species/drug or drug-class level. + model_summary <- qualified_models |> + dplyr::group_by( + species, + drug_label, + drug_or_class + ) |> + dplyr::summarise( + n_passing_fits = dplyr::n(), + n_seeds = dplyr::n_distinct(seed), + n_feature_types = dplyr::n_distinct(feature_type), + n_feature_scales = dplyr::n_distinct( + paste(feature_type, feature_subtype, sep = ":") + ), + median_nonshuffled_MCC = median( + nonshuffled_MCC, + na.rm = TRUE + ), + best_nonshuffled_MCC = max( + nonshuffled_MCC, + na.rm = TRUE + ), + median_shuffled_MCC = median( + shuffled_MCC, + na.rm = TRUE + ), + median_MCC_diff = median( + MCC_diff, + na.rm = TRUE + ), + # Named, NA not NULL, so a drug whose shuffled MCCs are all undefined still summarises. + minimum_MCC_diff = if (!is.na(median_MCC_diff)) { + min( + MCC_diff, + na.rm = TRUE + ) + } else { + NA_real_ + }, + maximum_MCC_diff = if (!is.na(median_MCC_diff)) { + max( + MCC_diff, + na.rm = TRUE + ) + } else { + NA_real_ + }, + proportion_outperforming_shuffled = median( + MCC_diff > 0 | is.na(shuffled_MCC), + na.rm = TRUE + ), + .groups = "drop" + ) |> + dplyr::arrange( + dplyr::desc(median_nonshuffled_MCC), + dplyr::desc(median_MCC_diff) + ) + + # ------------------------------------------------------------------------- + # 4. Select top features + # ------------------------------------------------------------------------- + + top_features <- topFeaturesPerDrugOrClass( + all_top_features_parquet = all_top_features_parquet, + core_contribution_threshold = core_contribution_threshold, + exclude_feature_types = exclude_feature_types, + filter_model = filter_model, + all_performance_parquet = all_performance_parquet, + MCC_threshold = MCC_threshold, + compare_to_shuffled = compare_to_shuffled, + rank_score_quantile = rank_score_quantile, + cv_threshold = cv_threshold, + cumulative_contribution_threshold = + cumulative_contribution_threshold, + seed_ratio_threshold = seed_ratio_threshold, + found_in_both_subtypes = found_in_both_subtypes, + compare_median_to_sd_rank_score = + compare_median_to_sd_rank_score + ) + + if (nrow(top_features) == 0) { + stop( + "No features passed the requested feature-selection criteria." + ) + } + + # ------------------------------------------------------------------------- + # 5. Consistently top-ranked features + # + # Answers: + # "Which features have both high seed coverage and high median rank?" + # ------------------------------------------------------------------------- + + consistent_features <- top_features |> + dplyr::filter( + seed_ratio >= consistent_seed_ratio, + median_rank_score >= consistent_rank_score + ) |> + dplyr::arrange( + species, + drug_label, + drug_or_class, + dplyr::desc(seed_ratio), + dplyr::desc(median_rank_score) + ) + + # ------------------------------------------------------------------------- + # 6. High-contribution features + # + # The contribution cutoff is calculated separately for each species and + # drug/drug-class model so each model is evaluated relative to its own + # selected feature set. + # ------------------------------------------------------------------------- + + high_contribution_features <- top_features |> + dplyr::group_by( + species, + drug_label, + drug_or_class + ) |> + dplyr::mutate( + contribution_cutoff = stats::quantile( + median_contribution, + probs = high_contribution_quantile, + na.rm = TRUE + ) + ) |> + dplyr::filter( + median_contribution >= contribution_cutoff + ) |> + dplyr::ungroup() |> + dplyr::select(-contribution_cutoff) |> + dplyr::arrange( + species, + drug_label, + drug_or_class, + dplyr::desc(median_contribution) + ) + + # ------------------------------------------------------------------------- + # 7. Features present across all seeds + # + # near() avoids problems caused by floating-point representation. + # ------------------------------------------------------------------------- + + all_seed_features <- top_features |> + dplyr::filter(dplyr::near(seed_ratio, 1)) |> + dplyr::arrange( + species, + drug_label, + drug_or_class, + dplyr::desc(median_rank_score), + dplyr::desc(median_contribution) + ) + + # ------------------------------------------------------------------------- + # 8. Summarize sharedness of top features + # + # Sharedness is evaluated independently for drugs and drug classes because + # drug_label is part of the grouping. + # + # Feature subtype is not part of the feature identity here. Thus, binary + # and counts representations of the same variable are treated as the same + # molecular feature. + # ------------------------------------------------------------------------- + + feature_sharedness <- top_features |> + dplyr::group_by( + species, + drug_label, + feature_type, + variable + ) |> + dplyr::summarise( + n_drug_or_class = dplyr::n_distinct(drug_or_class), + drug_or_class_csv = paste( + sort(unique(drug_or_class)), + collapse = ", " + ), + maximum_seed_ratio = max( + seed_ratio, + na.rm = TRUE + ), + median_seed_ratio = median( + seed_ratio, + na.rm = TRUE + ), + maximum_rank_score = max( + median_rank_score, + na.rm = TRUE + ), + overall_median_rank_score = median( + median_rank_score, + na.rm = TRUE + ), + overall_median_contribution = median( + median_contribution, + na.rm = TRUE + ), + sign_consistent_across_models = + dplyr::n_distinct(sign) == 1, + sign = if (sign_consistent_across_models) { + dplyr::first(sign) + } else { + "MIXED" + }, + .groups = "drop" + ) + + # ------------------------------------------------------------------------- + # 9. Features shared across drugs or drug classes + # ------------------------------------------------------------------------- + + shared_features <- feature_sharedness |> + dplyr::filter( + n_drug_or_class >= min_models_shared + ) |> + dplyr::arrange( + species, + drug_label, + dplyr::desc(n_drug_or_class), + dplyr::desc(overall_median_rank_score), + dplyr::desc(overall_median_contribution) + ) + + # ------------------------------------------------------------------------- + # 10. Features unique to one drug or drug class + # + # Join back to top_features so the output retains the associated + # drug_or_class and feature-level statistics. + # ------------------------------------------------------------------------- + + unique_feature_ids <- feature_sharedness |> + dplyr::filter(n_drug_or_class == 1) |> + dplyr::select( + species, + drug_label, + feature_type, + variable + ) + + unique_features <- top_features |> + dplyr::semi_join( + unique_feature_ids, + by = c( + "species", + "drug_label", + "feature_type", + "variable" + ) + ) |> + dplyr::arrange( + species, + drug_label, + drug_or_class, + dplyr::desc(median_rank_score), + dplyr::desc(median_contribution) + ) + + # ------------------------------------------------------------------------- + # 11. Aggregate top features to protein dyads + # ------------------------------------------------------------------------- + + top_dyads <- summariseDyads( + top_filtered_features = top_features, + dyad_con = dyad_con + ) + + # ------------------------------------------------------------------------- + # 12. High-scoring dyads + # + # A dyad score is high relative to the other selected dyads for the same + # species and drug/drug-class model. + # ------------------------------------------------------------------------- + + high_score_dyads <- top_dyads |> + dplyr::group_by( + species, + drug_label, + drug_or_class + ) |> + dplyr::mutate( + dyad_score_cutoff = stats::quantile( + dyad_median_rank_score, + probs = high_dyad_score_quantile, + na.rm = TRUE + ) + ) |> + dplyr::filter( + dyad_median_rank_score >= dyad_score_cutoff + ) |> + dplyr::ungroup() |> + dplyr::select(-dyad_score_cutoff) |> + dplyr::arrange( + species, + drug_label, + drug_or_class, + dplyr::desc(dyad_median_rank_score), + dplyr::desc(dyad_median_contribution) + ) + + # ------------------------------------------------------------------------- + # 13. Summarize dyad sharedness + # + # A dyad is identified independently within each species and drug-label + # level. + # ------------------------------------------------------------------------- + + dyad_sharedness <- top_dyads |> + dplyr::group_by( + species, + drug_label, + dyad + ) |> + dplyr::summarise( + n_drug_or_class = dplyr::n_distinct(drug_or_class), + drug_or_class_csv = paste( + sort(unique(drug_or_class)), + collapse = ", " + ), + total_frequency = sum( + frequency, + na.rm = TRUE + ), + n_distinct_variables = dplyr::n_distinct( + unlist(strsplit(variables_csv, ",", fixed = TRUE)) + ), + maximum_dyad_rank_score = max( + dyad_median_rank_score, + na.rm = TRUE + ), + overall_dyad_median_rank_score = median( + dyad_median_rank_score, + na.rm = TRUE + ), + overall_dyad_median_contribution = median( + dyad_median_contribution, + na.rm = TRUE + ), + sign_consistent_across_models = + dplyr::n_distinct(sign) == 1, + sign = if (sign_consistent_across_models) { + dplyr::first(sign) + } else { + "MIXED" + }, + .groups = "drop" + ) + + # ------------------------------------------------------------------------- + # 14. Dyads shared across drugs or drug classes + # ------------------------------------------------------------------------- + + shared_dyads <- dyad_sharedness |> + dplyr::filter( + n_drug_or_class >= min_models_shared + ) |> + dplyr::arrange( + species, + drug_label, + dplyr::desc(n_drug_or_class), + dplyr::desc(overall_dyad_median_rank_score), + dplyr::desc(total_frequency) + ) + + # ------------------------------------------------------------------------- + # 15. Dyads unique to one drug or drug class + # + # Join back to top_dyads to retain the drug/class identity and the + # original dyad statistics. + # ------------------------------------------------------------------------- + + unique_dyad_ids <- dyad_sharedness |> + dplyr::filter(n_drug_or_class == 1) |> + dplyr::select( + species, + drug_label, + dyad + ) + + unique_dyads <- top_dyads |> + dplyr::semi_join( + unique_dyad_ids, + by = c( + "species", + "drug_label", + "dyad" + ) + ) |> + dplyr::arrange( + species, + drug_label, + drug_or_class, + dplyr::desc(dyad_median_rank_score), + dplyr::desc(dyad_median_contribution) + ) + + # ------------------------------------------------------------------------- + # 16. Return an organized analysis object + # ------------------------------------------------------------------------- + + result <- list( + models = list( + good_performance = good_performance_models, + good_shuffled_separation = + good_shuffled_separation_models, + qualified = qualified_models, + summary = model_summary + ), + features = list( + top = top_features, + consistent = consistent_features, + high_contribution = high_contribution_features, + all_seeds = all_seed_features, + sharedness = feature_sharedness, + shared = shared_features, + unique = unique_features + ), + dyads = list( + top = top_dyads, + high_score = high_score_dyads, + sharedness = dyad_sharedness, + shared = shared_dyads, + unique = unique_dyads + ), + parameters = list( + MCC_threshold = MCC_threshold, + compare_to_shuffled = compare_to_shuffled, + core_contribution_threshold = + core_contribution_threshold, + exclude_feature_types = exclude_feature_types, + filter_model = filter_model, + rank_score_quantile = rank_score_quantile, + cv_threshold = cv_threshold, + cumulative_contribution_threshold = + cumulative_contribution_threshold, + seed_ratio_threshold = seed_ratio_threshold, + found_in_both_subtypes = found_in_both_subtypes, + compare_median_to_sd_rank_score = + compare_median_to_sd_rank_score, + consistent_seed_ratio = consistent_seed_ratio, + consistent_rank_score = consistent_rank_score, + high_contribution_quantile = + high_contribution_quantile, + high_dyad_score_quantile = + high_dyad_score_quantile, + min_models_shared = min_models_shared + ) + ) + + class(result) <- c( + "feature_dyad_discovery", + class(result) + ) + + return(result) +} diff --git a/R/fit-execution.R b/R/fit-execution.R new file mode 100644 index 0000000..41594a6 --- /dev/null +++ b/R/fit-execution.R @@ -0,0 +1,382 @@ +# Validate and write resumable fits + +# An explicit worker receives one group and reads its feature stores locally. +.runTaskGroup <- function(job, species, model_dir, save_fits, cache) { + shared_fit <- NULL + outcomes <- vector("list", nrow(job$tasks)) + for (j in seq_len(nrow(job$tasks))) { + task <- job$tasks[j, ] + keep_fit <- nrow(job$tasks) > 1L && is.null(shared_fit) + outcome <- tryCatch( + withr::with_seed( + task$seed, + .fitTask( + task = task, path = job$paths[[j]], + species = species, + rows = job$rows[[j]], columns = job$columns[[j]], + encoding = job$encoding[[j]], cache = cache, + fitted = shared_fit, return_fitted = keep_fit + ), + .rng_kind = "Mersenne-Twister", .rng_normal_kind = "Inversion", + .rng_sample_kind = "Rejection" + ), + error = function(e) list(error = conditionMessage(e)) + ) + if (is.null(outcome[["error"]])) { + if (keep_fit) shared_fit <- outcome$fitted + outcome$fitted <- NULL + if (save_fits) { + .saveFitCheckpoint(outcome$model, file.path(model_dir, paste0(task$task_id, ".rds"))) + } + outcome$model <- NULL + } + outcomes[[j]] <- outcome + } + # Commit the group only after any requested model files have been saved. + .saveFitCheckpoint(outcomes, job$checkpoint) + TRUE +} + +# Only pending groups are sent to workers; no feature matrix is serialized. +.fitGroupJob <- function(group, listed, matrices, index, out_dir, checkpoint) { + positions <- match(listed$matrix_id[group], matrices$matrix_id) + list( + tasks = listed[group, ], + paths = file.path(out_dir, matrices$file[positions]), + rows = index$rows[index$matrix_scopes[positions]], + columns = index$columns[positions], + encoding = matrices$encoding[positions], + checkpoint = checkpoint + ) +} + +# Describe the tasks and matrix files a checkpoint belongs to. Checksums prevent +# completed fits from being mixed with changed training inputs when resuming. +## This is draft functionality, and should be replaced with proper ORB manifest +## logging after verification, but modeling resume functionality is badly needed. +.fitCheckpointManifest <- function(tasks, groups, reuse_fits, save_fits) { + files <- tasks$built$matrices$file[ + match(tasks$tasks$matrix_id, tasks$built$matrices$matrix_id) + ] + inputs <- unique(c("matrix_index.rds", files)) + checksums <- tools::md5sum(file.path(tasks$built$out_dir, inputs)) + names(checksums) <- inputs + if (anyNA(checksums)) { + stop("Cannot read the matrix files needed for checkpoints.", call. = FALSE) + } + list( + version = 2L, + contract = "saved-models", + tasks = tasks$tasks, + matrices = tasks$built$matrices, + groups = groups, + reuse_fits = reuse_fits, + save_fits = save_fits, + species = tasks$built$eligibility$profile$orb$dataset_id, + input_checksums = checksums + ) +} + +# Write one completed task group before its worker finishes. A temporary file +# prevents an interrupted write from appearing as a finished checkpoint. +.saveFitCheckpoint <- function(result, path) { + temporary <- tempfile(".fit-", tmpdir = dirname(path), fileext = ".rds") + on.exit(unlink(temporary), add = TRUE) + saveRDS(result, temporary, compress = FALSE) + if (!file.rename(temporary, path)) { + stop("Could not save fit checkpoint: ", path, call. = FALSE) + } + invisible(path) +} + +# Fail invalid checkpoints rather than treating them as model fits +.readFitCheckpoint <- function(path, task_ids, model_dir, save_fits) { + result <- readRDS(path) + valid <- is.list(result) && length(result) == length(task_ids) + if (valid) for (j in seq_along(task_ids)) { + x <- result[[j]] + failure <- is.list(x) && identical(names(x), "error") && + is.character(x$error) && length(x$error) == 1L && !is.na(x$error) + success <- is.list(x) && + all(c("performance", "importance", "predictions", "undefined") %in% names(x)) && + is.data.frame(x$performance) && is.data.frame(x$importance) && + is.data.frame(x$predictions) && + identical(as.character(x$performance$task_id), task_ids[[j]]) && + all(x$importance$task_id == task_ids[[j]]) && + all(x$predictions$task_id == task_ids[[j]]) && + is.character(x$undefined) && length(x$undefined) == 1L + if (!failure && !success) valid <- FALSE + if (success && save_fits && + !file.exists(file.path(model_dir, paste0(task_ids[[j]], ".rds")))) { + stop("A saved model is missing for checkpoint task: ", task_ids[[j]], call. = FALSE) + } + } + if (!valid) stop("Invalid fitted task checkpoint: ", path, call. = FALSE) + result +} + +# Empty schemas keep failed fits usable +.emptyFitResults <- function() { + list( + performance = tibble::tibble( + task_id = character(), species = character(), num_obs = integer(), res_prop = numeric(), + n_test = integer(), res_prop_test = numeric(), n_feat = integer(), + model = character(), n_feats_returned = integer(), n_fold = integer(), + fit_penalty = numeric(), fit_mixture = numeric(), mcc = numeric(), nmcc = numeric(), + spec = numeric(), sens = numeric(), log2_apop = numeric(), f1 = numeric(), + bal_acc = numeric(), auprc = numeric(), run_time_sec = numeric(), + seed = integer(), date = character() + ), + importance = tibble::tibble( + task_id = character(), species = character(), Variable = character(), + Importance = numeric(), Sign = character() + ), + predictions = tibble::tibble( + task_id = character(), species = character(), genome_id = character(), truth = character(), + predicted = character(), prob_resistant = numeric() + ) + ) +} + +# Restore previous files on failure +.restoreFitResults <- function(staging, out_dir, produced) { + backup <- tempfile(".results-previous-", tmpdir = out_dir) + dir.create(backup) + old_moved <- character() + new_moved <- character() + tryCatch({ + for (name in produced) { + if (file.exists(file.path(out_dir, name))) { + if (!file.rename(file.path(out_dir, name), file.path(backup, name))) { + stop("Could not move previous result: ", name) + } + old_moved <- c(old_moved, name) + } + if (!file.rename(file.path(staging, name), file.path(out_dir, name))) { + stop("Could not install result: ", name) + } + new_moved <- c(new_moved, name) + } + }, error = function(e) { + for (name in rev(new_moved)) unlink(file.path(out_dir, name), recursive = TRUE) + restored <- vapply(rev(old_moved), function(name) { + file.rename(file.path(backup, name), file.path(out_dir, name)) + }, logical(1)) + if (all(restored)) unlink(backup, recursive = TRUE) + stop(conditionMessage(e), if (!all(restored)) paste0( + " Previous results may be recoverable from: ", backup + ), call. = FALSE) + }) + unlink(backup, recursive = TRUE) + invisible(out_dir) +} + +# A completed fit can be reopened to finish an export without refitting +.readCompletedFit <- function(tasks, manifest, call) { + out_dir <- tasks$built$out_dir + path <- file.path(out_dir, "results", "fit-completion.rds") + if (!file.exists(path)) { + .amrAbort("invalid_argument", + "No compatible checkpoints or completed fit were found; cannot resume.", + call = call) + } + receipt <- readRDS(path) + if (!is.list(receipt) || !identical(receipt$manifest, manifest) || + !is.character(receipt$checksums) || !length(receipt$checksums)) { + .amrAbort("invalid_argument", "The completed fit does not match these inputs.", call = call) + } + observed <- tools::md5sum(file.path(out_dir, names(receipt$checksums))) + names(observed) <- names(receipt$checksums) + if (!identical(observed, receipt$checksums)) { + .amrAbort("invalid_argument", "Completed fit outputs are missing or changed; cannot resume.", + call = call) + } + results <- lapply(c("performance", "importance", "predictions"), function(name) { + arrow::read_parquet(file.path(out_dir, "results", paste0(name, ".parquet"))) + }) + names(results) <- c("performance", "importance", "predictions") + structure(c(list(tasks = arrow::read_parquet(file.path(out_dir, "tasks.parquet"))), + results, list(built = tasks$built)), class = "amr_fit") +} + +#' Fit the listed models +#' +#' Fits tasks from [expandTasks()] in parallel with old amRml's method: +#' glmnet logistic regression over 10 penalties and 6 mixtures, tuned by +#' stratified `n_fold` cross-validation and chosen by MCC, then scored on the +#' task's test genomes. +#' +#' @details +#' Cross-drug tasks with exactly matching training inputs reuse one fitted model; +#' set `reuse_fits = FALSE` to disable reuse for comparison. Reused tasks' +#' `run_time_sec` excludes shared training time for follower tasks; the first +#' task in a group includes the training cost. +#' Each completed task group is saved in `fit-checkpoints/` so it can be reused +#' after an interruption. Checkpoints are removed after results are written. +#' Use `resume = TRUE` with the same tasks and output directory to reuse them. +#' Each task runs under its own seed. A task that errors is recorded as +#' `fit_failed`, and one with undefined metrics as `metrics_undefined`; the rest +#' carry on. A shuffled task permutes the training matrix's labels before the +#' split. +#' +#' Completed results can also be reopened with `resume = TRUE` without fitting +#' again. Version 1 checkpoints require the original implementation or a fresh +#' run in another output directory. +#' +#' @param tasks An `amr_tasks` from [expandTasks()]. +#' @param save_fits Save each fitted model to `results/models/.rds`: +#' the fitted workflow (`fit`) and the `features` its predictors `x1`, `x2`, +#' ... stand for. +#' Must match the interrupted run when resuming. +#' @param overwrite Replace results already in the output folder. +#' @param reuse_fits Reuse fitted models among compatible cross-drug tasks. +#' @param resume Reuse saved task groups from an interrupted fit or reopen an +#' unchanged completed fit. The task plan, matrix files and `reuse_fits` +#' setting must match the original run. +#' `save_fits` must also match. +#' +#' @param BPPARAM A `BiocParallelParam`, e.g. `BiocParallel::MulticoreParam(4)`, +#' or `BiocParallel::SerialParam()` to fit one task at a time. +#' @return An `amr_fit` list, also written to the output folder: `tasks` (with +#' `status`, `rule_id` and `message`; `tasks.parquet`), `performance`, +#' `importance` and `predictions` (`results/`), and the `built` matrices. In +#' `importance`, `Sign` "POS" points to Susceptible and "NEG" to Resistant. The +#' run's settings and task counts go to `run.json`. +#' +#' @section Errors: +#' Invalid arguments or incompatible resume inputs raise `amrml_invalid_argument`. +#' File and checkpoint errors stop the run without removing completed checkpoints. +#' +#' @examples +#' \dontrun{ +#' fit <- fitModels(expandTasks(built)) +#' fit$performance +#' } +#' @export +fitModels <- function(tasks, save_fits = TRUE, + BPPARAM = BiocParallel::bpparam(), overwrite = FALSE, + reuse_fits = TRUE, resume = FALSE) { + call <- rlang::current_env() + .checkArgClass(tasks, "tasks", "amr_tasks", "expandTasks()", call = call) + .checkArgClass(BPPARAM, "BPPARAM", "BiocParallelParam", "BiocParallel", call = call) + .checkArgFlag(overwrite, "overwrite", call = call) + .checkArgFlag(reuse_fits, "reuse_fits", call = call) + .checkArgFlag(resume, "resume", call = call) + .checkArgFlag(save_fits, "save_fits", call = call) + if (resume && overwrite) { + .amrAbort("invalid_argument", "`resume` and `overwrite` cannot both be TRUE.", call = call) + } + out_dir <- tasks$built$out_dir + produced <- c("tasks.parquet", "results", "run.json") + if (any(file.exists(file.path(out_dir, produced))) && !overwrite && !resume) { + .amrAbort("invalid_argument", + "The output folder already has results; set `overwrite = TRUE` to replace them.", + observed = list(out_dir = out_dir), call = call) + } + + started <- Sys.time() + species <- tasks$built$eligibility$profile$orb$dataset_id + listed <- tasks$tasks + listed$status <- rep("fitted", nrow(listed)) + listed$rule_id <- rep(NA_character_, nrow(listed)) + listed$message <- rep(NA_character_, nrow(listed)) + index <- readRDS(file.path(out_dir, "matrix_index.rds")) + groups <- if (reuse_fits) { + .fitTaskGroups(listed, tasks$built$matrices, index) + } else { + as.list(seq_len(nrow(listed))) + } + manifest <- .fitCheckpointManifest(tasks, groups, reuse_fits, save_fits) + checkpoint_dir <- file.path(out_dir, "fit-checkpoints") + manifest_path <- file.path(checkpoint_dir, "manifest.rds") + if (resume) { + if (!file.exists(manifest_path)) return(.readCompletedFit(tasks, manifest, call)) + if (!identical(readRDS(manifest_path), manifest)) { + .amrAbort("invalid_argument", + "Saved fits do not match these tasks, settings or matrix files; cannot resume.", + call = call) + } + } else { + if (dir.exists(checkpoint_dir) && !overwrite) { + .amrAbort("invalid_argument", + "Task checkpoints already exist; use `resume = TRUE` to reuse them.", call = call) + } + unlink(checkpoint_dir, recursive = TRUE) + dir.create(checkpoint_dir, recursive = TRUE) + .saveFitCheckpoint(manifest, manifest_path) + } + model_dir <- file.path(checkpoint_dir, "models") + if (save_fits) dir.create(model_dir, showWarnings = FALSE) + group_paths <- file.path(checkpoint_dir, sprintf("group-%06d.rds", seq_along(groups))) + recovered <- which(file.exists(group_paths)) + # Validate recovered groups before scheduling more work. + for (g in recovered) { + .readFitCheckpoint(group_paths[[g]], listed$task_id[groups[[g]]], model_dir, save_fits) + } + pending <- which(!file.exists(group_paths)) + if (resume) message(length(recovered), " task groups recovered; ", + length(pending), " task groups remaining.") + jobs <- lapply(pending, function(g) { + .fitGroupJob(groups[[g]], listed, tasks$built$matrices, index, out_dir, group_paths[[g]]) + }) + # An empty cache is sent once; each worker populates its own copy across groups. + cache <- new.env(parent = emptyenv()) + if (length(jobs)) BiocParallel::bplapply( + jobs, .runTaskGroup, cache = cache, species = species, model_dir = model_dir, save_fits = save_fits, + BPPARAM = BPPARAM + ) + + outcomes <- vector("list", nrow(listed)) + for (g in seq_along(groups)) { + outcomes[groups[[g]]] <- .readFitCheckpoint( + group_paths[[g]], listed$task_id[groups[[g]]], model_dir, save_fits + ) + } + for (i in seq_along(outcomes)) { + outcome <- outcomes[[i]] + if (!is.null(outcome[["error"]])) { + listed$status[[i]] <- "failed" + listed$rule_id[[i]] <- "fit_failed" + listed$message[[i]] <- outcome$error + outcomes[i] <- list(NULL) + } else if (!is.na(outcome$undefined)) { + listed$rule_id[[i]] <- "metrics_undefined" + listed$message[[i]] <- paste("Undefined:", outcome$undefined) + } + } + empty <- .emptyFitResults() + tables <- lapply(names(empty), function(name) { + dplyr::bind_rows(c(list(empty[[name]]), lapply(outcomes, `[[`, name))) + }) + names(tables) <- names(empty) + fit <- structure(c(list(tasks = listed), tables, list(built = tasks$built)), class = "amr_fit") + + staging <- tempfile(".results-building-", tmpdir = out_dir) + dir.create(file.path(staging, "results"), recursive = TRUE) + on.exit(unlink(staging, recursive = TRUE), add = TRUE) + arrow::write_parquet(fit$tasks, file.path(staging, "tasks.parquet")) + for (name in names(empty)) { + arrow::write_parquet(fit[[name]], file.path(staging, "results", paste0(name, ".parquet"))) + } + if (save_fits) { + destination <- file.path(staging, "results", "models") + dir.create(destination) + ids <- listed$task_id[listed$status == "fitted"] + source <- file.path(model_dir, paste0(ids, ".rds")) + if (length(ids) && !all(file.copy(source, destination))) { + stop("Could not stage every saved model; checkpoints were preserved.", call. = FALSE) + } + } + jsonlite::write_json( + .runRecord(tasks, listed, started, save_fits, BPPARAM), + file.path(staging, "run.json"), pretty = TRUE, auto_unbox = TRUE + ) + files <- list.files(staging, recursive = TRUE, full.names = FALSE) + checksums <- tools::md5sum(file.path(staging, files)) + names(checksums) <- files + .saveFitCheckpoint(list(manifest = manifest, checksums = checksums), + file.path(staging, "results", "fit-completion.rds")) + .restoreFitResults(staging, out_dir, produced) + unlink(checkpoint_dir, recursive = TRUE) + fit +} diff --git a/R/fit-models.R b/R/fit-models.R new file mode 100644 index 0000000..69ed3a2 --- /dev/null +++ b/R/fit-models.R @@ -0,0 +1,373 @@ +# Fitting a model for each task, with old amRml's method: glmnet logistic regression, +# tuned by stratified cross-validation and chosen by MCC. + +# The phenotypes, with Resistant first so it is the event yardstick scores. +.PHENOTYPES <- c("Resistant", "Susceptible") +# Setting an initial cutoff for when matrices are treated as sparse in tidymodels +# but we should really benchmark this to see where the right threshold is +.SPARSE_THRESHOLD <- 0.8 + + +# Read one scope from the shared sparse feature store and its index +.readMatrixWide <- function(path, rows, columns, encoding, cache) { + if (!exists(path, envir = cache, inherits = FALSE)) { + assign(path, readRDS(path), envir = cache) + } + store <- get(path, envir = cache, inherits = FALSE) + genome_idx <- match(rows$genome_id, store$genomes) + if (anyNA(genome_idx)) stop("Scope genome is missing from feature store.") + values <- store$values[genome_idx, columns, drop = FALSE] + if (encoding == "binary") { + values@x[] <- as.numeric(values@x > 0) + values <- Matrix::drop0(values) + } + + list( + rows = rows, + features = store$features[columns], + values = values + ) +} + +# Ported from old amRml's shuffleLabels(), with the task's seed: the training matrix's labels +# are permuted before the split. Test rows (cross, leave-one-out) keep their real labels. +.shuffleLabels <- function(rows) { + train <- which(rows$role == "train") + rows$phenotype[train] <- rows$phenotype[train][sample.int(length(train))] + rows +} + +# Training and test rows. A matrix with test rows uses them; otherwise each phenotype keeps +# floor((1 - holdout) x n) genomes for training, as rsample's stratified split does. +# Training rows come grouped by phenotype, in rsample's order: with duplicate features, +# glmnet's coefficients depend on row order. +.splitTask <- function(rows, holdout) { + if (any(rows$role == "test")) { + return(list(train = which(rows$role == "train"), test = which(rows$role == "test"))) + } + + train <- unlist(lapply(split(seq_len(nrow(rows)), rows$phenotype), function(i) { + sort(i[sample.int(length(i), floor((1 - holdout) * length(i)))]) + }), use.names = FALSE) + list(train = train, test = setdiff(seq_len(nrow(rows)), train)) +} + +# Each training row's fold, assigned per phenotype as rsample's stratified folds do, but +# without pooling rare phenotypes (`pool = 0.1`), which can leave a fold without them. +.stratifiedFolds <- function(phenotype, n_fold) { + fold <- integer(length(phenotype)) + for (level in intersect(.PHENOTYPES, phenotype)) { + i <- which(phenotype == level) + fold[i] <- sample(rep_len(seq_len(n_fold), length(i))) + } + fold +} + +# The training data as a data frame: the label, then features renamed x1, x2, ..., so any +# feature ID works in a formula. +.modelData <- function(values, phenotype, sparse = FALSE) { + if (sparse) { + colnames(values) <- paste0("x", seq_len(ncol(values))) + data <- sparsevctrs::coerce_to_sparse_tibble(values) + } else { + data <- as.data.frame(as.matrix(values)) + } + names(data) <- paste0("x", seq_len(ncol(data))) + data$phenotype <- factor(phenotype, levels = .PHENOTYPES) + data +} + +# Ported from old amRml's buildRecipe(): drop constant features, then normalize. +.buildRecipe <- function(data, sparse = FALSE) { + recipe <- recipes::recipe(phenotype ~ ., data = data) |> + recipes::step_zv(recipes::all_predictors()) + if (sparse) { + # step_zv() alone seemingly misses constant nonzero sparse columns, so we're + # filtering these out at prep to resolve those errors + recipe <- recipes::step_rm( + recipe, + tidyselect::where(function(x) { + sparsevctrs::is_sparse_vector(x) && + length(sparsevctrs::sparse_values(x)) == length(x) && + length(unique(sparsevctrs::sparse_values(x))) == 1L + }), + id = "zv_sparse_nonzero" + ) + recipes::step_scale(recipe, recipes::all_predictors()) + } else { + recipes::step_normalize(recipe, recipes::all_predictors()) + } +} + +# Ported from old amRml's buildLRModel(). +.modelSpec <- function() { + parsnip::logistic_reg(penalty = tune::tune(), mixture = tune::tune()) |> + parsnip::set_engine("glmnet") +} + +# Ported from old amRml's buildTuningGrid(): 10 penalties x 6 mixtures. +.tuningGrid <- function() { + penalty_vec <- 10^seq(-4, -1, length.out = 10) + mix_vec <- 0:5 / 5 + tibble::tibble( + penalty = rep(penalty_vec, each = length(mix_vec)), + mixture = rep(mix_vec, length(penalty_vec)) + ) +} + +# Ported from old amRml's tuneGrid(), selectBestModel() and fitBestModel(): tune over +# stratified folds, choose by MCC, and fit on all training rows. +.fitModel <- function(data, n_fold, sparse = FALSE) { + workflow <- workflows::workflow() |> + workflows::add_recipe(.buildRecipe(data, sparse = sparse)) |> + workflows::add_model(.modelSpec()) + + # After the recipe, whose step IDs use random numbers, so the folds match rsample's. + fold <- .stratifiedFolds(data$phenotype, n_fold) + + splits <- lapply(sort(unique(fold)), function(k) { + rsample::make_splits( + list(analysis = which(fold != k), assessment = which(fold == k)), + data = data + ) + }) + resamples <- rsample::manual_rset(splits, ids = paste0("Fold", sort(unique(fold)))) + + tuned <- tune::tune_grid( + workflow, + resamples = resamples, + grid = .tuningGrid(), + metrics = yardstick::metric_set( + yardstick::f_meas, yardstick::pr_auc, yardstick::spec, yardstick::sens, + yardstick::bal_accuracy, yardstick::mcc + ), + control = tune::control_grid(allow_par = FALSE) + ) + best <- tune::select_best(tuned, metric = "mcc") + + list( + fit = parsnip::fit(tune::finalize_workflow(workflow, best), data = data), + penalty = best$penalty, + mixture = best$mixture + ) +} + +# Ported from old amRml's .calculate*() helpers, keeping AUPRC. Resistant is the event. +# Each metric is rounded to 2, and nMCC and log2(AUPRC / prior) use the rounded values. +.taskMetrics <- function(scored) { + estimate <- function(metric, ...) { + round(as.numeric(metric(scored, truth = "phenotype", ...)$.estimate), 2) + } + mcc <- estimate(yardstick::mcc, estimate = ".pred_class") + auprc <- estimate(yardstick::pr_auc, ".pred_Resistant") + + tibble::tibble( + mcc = mcc, + nmcc = round((mcc + 1) / 2, 2), + spec = estimate(yardstick::spec, estimate = ".pred_class"), + sens = estimate(yardstick::sens, estimate = ".pred_class"), + log2_apop = round(log2(auprc / mean(scored$phenotype == "Resistant")), 2), + f1 = estimate(yardstick::f_meas, estimate = ".pred_class"), + bal_acc = estimate(yardstick::bal_accuracy, estimate = ".pred_class"), + auprc = auprc + ) +} + +# Ported from old amRml's .viGlmnet(): the non-zero coefficients at the chosen penalty, on +# normalized features. glmnet models the second level, so "POS" points to Susceptible. +.taskImportance <- function(fit, penalty, features) { + coefs <- stats::coef(parsnip::extract_fit_engine(fit), s = penalty)[, 1] + coefs <- coefs[names(coefs) != "(Intercept)" & coefs != 0] + coefs <- coefs[order(-abs(coefs))] + + tibble::tibble( + Variable = features[as.integer(sub("^x", "", names(coefs)))], + Importance = abs(unname(coefs)), + Sign = as.character(ifelse(unname(coefs) > 0, "POS", "NEG")) + ) +} + +# Cross-test tasks can share a fit when the training inputs exactly match +.fitTaskGroups <- function(listed, matrices, index) { + positions <- match(listed$matrix_id, matrices$matrix_id) + signatures <- vector("list", nrow(listed)) + signature_set <- rep(NA_character_, nrow(listed)) + + for (i in which(matrices$mode_id[positions] == "cross_drug")) { + p <- positions[[i]] + rows <- index$rows[[index$matrix_scopes[[p]]]] + if (!any(rows$role == "test")) next + + train <- rows$role == "train" + signatures[[i]] <- list( + file = matrices$file[[p]], + columns = index$columns[[p]], + encoding = matrices$encoding[[p]], + genome_id = rows$genome_id[train], + phenotype = rows$phenotype[train], + labels = listed$labels[[i]], + seed = listed$seed[[i]], + n_fold = listed$n_fold[[i]], + holdout = listed$holdout[[i]] + ) + # Collect all signature details + signature_set[[i]] <- paste( + signatures[[i]]$file, signatures[[i]]$encoding, + signatures[[i]]$labels, signatures[[i]]$seed, + signatures[[i]]$n_fold, signatures[[i]]$holdout, + length(signatures[[i]]$columns), length(signatures[[i]]$genome_id), + sep = "|" + ) + } + + leader <- seq_len(nrow(listed)) + candidates <- which(!is.na(signature_set)) + for (part in split(candidates, signature_set[candidates])) { + representatives <- integer() + for (i in part) { + found <- representatives[vapply(representatives, function(j) { + identical(signatures[[i]], signatures[[j]]) + }, logical(1))] + if (length(found)) { + leader[[i]] <- found[[1L]] + } else { + representatives <- c(representatives, i) + } + } + } + + split(seq_len(nrow(listed)), factor(leader, levels = unique(leader))) +} + +# One task: shuffle if asked, split, tune, fit, and score on the test genomes. +.fitTask <- function(task, path, species, rows, columns, encoding, cache, + fitted = NULL, return_fitted = FALSE) { + started <- Sys.time() + matrix <- .readMatrixWide(path, rows, columns, encoding, cache) + rows <- matrix$rows + if (task$labels == "shuffled") { + rows <- .shuffleLabels(rows) + } + + split <- .splitTask(rows, task$holdout) + train_values <- matrix$values[split$train, , drop = FALSE] + # Not sure if there's a function to calculate how sparsely populated a matrix + # is, but here finding it by non-zero values over total values in the matrix + # and taking the inverse by subtracting the populated fraction from 1 + sparsity <- 1 - Matrix::nnzero(train_values) / (as.double(nrow(train_values)) * ncol(train_values)) + # Is that fraction greater than or equal to our cutoff? If so, that's sparse + use_sparse <- sparsity >= .SPARSE_THRESHOLD + train <- .modelData(train_values, rows$phenotype[split$train], sparse = use_sparse) + test <- .modelData(matrix$values[split$test, , drop = FALSE], + rows$phenotype[split$test], sparse = use_sparse) + if (is.null(fitted)) fitted <- .fitModel(train, task$n_fold, sparse = use_sparse) + + scored <- parsnip::augment(fitted$fit, test) + metrics <- .taskMetrics(scored) + importance <- .taskImportance(fitted$fit, fitted$penalty, matrix$features) + input <- rows$role == "train" + + performance <- tibble::tibble( + task_id = task$task_id, + species = species, + num_obs = sum(input), + res_prop = round(mean(rows$phenotype[input] == "Resistant"), 2), + n_test = length(split$test), + res_prop_test = round(mean(test$phenotype == "Resistant"), 2), + n_feat = length(matrix$features), + model = "LR", + n_feats_returned = nrow(importance), + n_fold = task$n_fold, + fit_penalty = fitted$penalty, + fit_mixture = fitted$mixture, + metrics, + run_time_sec = round(as.numeric(difftime(Sys.time(), started, units = "secs")), 2), + seed = task$seed, + date = as.character(Sys.Date()) + ) + predictions <- tibble::tibble( + task_id = task$task_id, + species = species, + genome_id = rows$genome_id[split$test], + truth = as.character(scored$phenotype), + predicted = as.character(scored$.pred_class), + prob_resistant = scored$.pred_Resistant + ) + + # Metrics that can't be computed, such as MCC when every test genome gets one prediction. + undefined <- names(metrics)[vapply(metrics, is.na, logical(1))] + if (length(undefined) && dplyr::n_distinct(scored$.pred_class) == 1) { + undefined <- paste0( + toString(undefined), "; every test genome was predicted ", scored$.pred_class[[1]] + ) + } + + result <- list( + performance = performance, + importance = tibble::tibble( + task_id = rep(task$task_id, nrow(importance)), + species = rep(species, nrow(importance)), importance + ), + predictions = predictions, + undefined = if (length(undefined)) toString(undefined) else NA_character_, + # The model's predictors are x1, x2, ...; `features` names them, in that order. + model = list(fit = fitted$fit, features = matrix$features) + ) + if (return_fitted) result$fitted <- fitted + result +} + +# The run's settings and outcome, as written to run.json; vectors stay arrays (I()). +.runRecord <- function(tasks, listed, started, save_fits, BPPARAM) { + eligibility <- tasks$built$eligibility + orb <- eligibility$profile$orb + stamp <- function(time) format(time, "%Y-%m-%d %H:%M:%S") + + list( + amRml_version = as.character(utils::packageVersion("amRml")), + R_version = paste(R.version$major, R.version$minor, sep = "."), + started_at = stamp(started), + finished_at = stamp(Sys.time()), + orb = list( + directory = orb$directory, + dataset_id = orb$dataset_id, + dataset_label = orb$dataset_label, + manifest = basename(orb$manifest_path), + producer_run_id = orb$producer_run_id, + finished_at = orb$finished_at + ), + species = orb$dataset_id, + modes = I(eligibility$modes$mode_id), + eligibility = eligibility$settings, + seeds = I(tasks$settings$seeds), + labels = I(tasks$settings$labels), + save_fits = save_fits, + parallel = list( + backend = class(BPPARAM)[[1]], + workers = BiocParallel::bpnworkers(BPPARAM) + ), + n_tasks = nrow(listed), + n_fitted = sum(listed$status == "fitted"), + n_failed = sum(listed$status == "failed") + ) +} + +#' @export +print.amr_fit <- function(x, ...) { + orb <- x$built$eligibility$profile$orb + t <- x$tasks + modes <- .taskModes(t, x$built$matrices) + by_mode <- split(t, factor(modes, unique(modes))) + counts <- function(rows) { + paste0( + sum(rows$status == "fitted"), " fitted (", sum(rows$rule_id %in% "metrics_undefined"), + " with undefined metrics), ", sum(rows$status == "failed"), " failed" + ) + } + + cat("", orb$dataset_id, "-", orb$dataset_label, "\n") + cat(" in", x$built$out_dir, "\n") + cat(" ", nrow(t), " tasks: ", counts(t), "\n", sep = "") + cat(.modeLines(names(by_mode), vapply(by_mode, counts, character(1))), sep = "\n") + invisible(x) +} diff --git a/R/generate-matrices.R b/R/generate-matrices.R new file mode 100644 index 0000000..c1198c7 --- /dev/null +++ b/R/generate-matrices.R @@ -0,0 +1,384 @@ +# Planning and building the ML input matrices of eligible scopes. + + +# Encodings per feature table: binary, plus counts if any value in the table is above 1. +.encodings <- function(feature_tables) { + has_counts <- vapply(feature_tables$path, function(path) { + values <- arrow::read_parquet(path, col_select = "value", as_data_frame = FALSE)$value + isTRUE(as.vector(max(values, na.rm = TRUE)) > 1) + }, logical(1), USE.NAMES = FALSE) + + tibble::tibble( + feature_type = rep(feature_tables$feature_type, 1L + has_counts), + encoding = unlist(lapply(has_counts, function(counts) c("binary", if (counts) "counts"))) + ) +} + +# Readable, file-safe IDs, numbered because file-safe names can collide; nothing parses them. +.matrixIds <- function(identity) { + parts <- lapply(identity, function(x) ifelse(is.na(x), "-", x)) + names <- gsub("[^A-Za-z0-9._-]", "_", do.call(paste, c(parts, sep = "__"))) + sprintf("%04d__%s", seq_along(names), names) +} + +# A feature table as `genome_id`, `feature_id` and `value`, for the genomes asked for. +.readFeatureTable <- function(path, feature_type, genomes, call) { + columns <- c("genome_id", feature_type, "value") + table <- arrow::read_parquet(path, col_select = dplyr::all_of(columns)) + names(table) <- c("genome_id", "feature_id", "value") + table <- table[table$genome_id %in% genomes, , drop = FALSE] + + # Encoding and the zero-fill treat each value as a count: present, and 0 or more. + if (any(!is.finite(table$value)) || any(table$value < 0)) { + .amrAbort( + "feature_values_invalid", + paste0("The ", feature_type, " table has missing, nonfinite or negative values."), + observed = list(path = path, n_missing = sum(is.na(table$value))), + call = call + ) + } + + if (anyNA(table$genome_id) || anyNA(table$feature_id)) { + .amrAbort("feature_values_invalid", "Feature rows need genome and feature IDs.", call = call) + } + + # One value per genome and feature; duplicated() is slow, so it only runs to name the pairs. + if (dplyr::n_distinct(table$genome_id, table$feature_id) < nrow(table)) { + pairs <- table[duplicated(table[c("genome_id", "feature_id")]), c("genome_id", "feature_id")] + .amrAbort( + "feature_rows_repeated", + c( + paste0("The ", feature_type, " table has more than one row for a genome and feature."), + .bullets(utils::head(paste(pairs$genome_id, pairs$feature_id), 5)) + ), + observed = list(path = path, pairs = pairs), + call = call + ) + } + + table +} + +# A shared sparse feature table, include genome rows without observed features. +# The stored matrix is counts. Binary is derived only when scope needs it +.featureStore <- function(table, genomes) { + features <- sort(unique(table$feature_id), method = "radix") + values <- Matrix::sparseMatrix( + i = match(table$genome_id, genomes), + j = match(table$feature_id, features), + x = as.numeric(table$value), + dims = c(length(genomes), length(features)), + giveCsparse = TRUE + ) + + list( + values = Matrix::drop0(values), + genomes = genomes, + features = features + ) +} + +# Adding indexing ~magic~ to .variableFeatures(), avoids full scan feature table. +# Features vary if present in some, but not all, training genomes, or (for counts) +# has different (positive) counts in every training genome +.variableFeaturesIndexed <- function(store, train_ids, encoding) { + train <- store$values[match(train_ids, store$genomes), , drop = FALSE] + n_present <- Matrix::colSums(train != 0) + variable <- n_present > 0 & n_present < nrow(train) + + if (encoding == "counts") { + # Only fully present columns need a count-variability check + full <- which(n_present == nrow(train)) + p <- train@p + x <- train@x + for (j in full) { + positions <- seq.int(p[[j]] + 1L, p[[j + 1L]]) + variable[[j]] <- any(x[positions] != x[positions[[1L]]]) + } + } + which(variable) +} + +# Scope membership computed just once +.scopeIndex <- function(matrices, members) { + keys <- c("mode_id", .SCOPE_KEYS) + scopes <- dplyr::distinct(matrices[keys]) + scopes$scope_index <- seq_len(nrow(scopes)) + member_scopes <- dplyr::left_join(members, scopes, by = keys)$scope_index + if (anyNA(member_scopes)) stop("A member has no planned scope.") + groups <- split(seq_len(nrow(members)), factor(member_scopes, levels = scopes$scope_index)) + rows <- lapply(groups, function(i) { + selected <- members[i, c("genome_id", "role", "phenotype"), drop = FALSE] + selected[order(selected$genome_id, method = "radix"), , drop = FALSE] + }) + matrix_scopes <- dplyr::left_join(matrices[keys], scopes, by = keys)$scope_index + list(rows = rows, matrix_scopes = matrix_scopes) +} + +# Select feature tables before planning or loading any model matrices. +# Presets use the feature tables present in this ORB; an explicit selection must +# match the ORB exactly so misspelled or unavailable features are not ignored. +.resolveFeatureTypes <- function(feature_types, available, call) { + presets <- list( + quick = c("gene", "protein", "Pfam"), + standard = c("gene", "protein", "Pfam", "COG", "AMRFinder"), + full = c("gene", "protein", "Pfam", "COG", "AMRFinder", "struct", "DefenseCas") + ) + + if (!is.character(feature_types) || !length(feature_types) || + anyNA(feature_types) || any(!nzchar(feature_types))) { + .amrAbort("invalid_argument", "`feature_types` must be a preset or a nonempty character vector.", call = call) + } + + preset <- length(feature_types) == 1L && + tolower(feature_types) %in% names(presets) + selected <- if (preset) presets[[tolower(feature_types)]] else unique(feature_types) + + if (preset) { + selected <- intersect(selected, available) + } else { + missing <- setdiff(selected, available) + if (length(missing)) { + .amrAbort( + "invalid_argument", + paste0("Unknown or unavailable feature type(s): ", paste(missing, collapse = ", "), + ". Available: ", paste(available, collapse = ", ")), + call = call + ) + } + } + + if (!length(selected)) { + .amrAbort("invalid_argument", "The selected feature preset has no tables in this ORB.", call = call) + } + selected +} + +#' Plan the matrices to build +#' +#' Lists every matrix the eligible scopes need, before any is built: one per +#' eligible scope, selected feature type and encoding. Each feature type is +#' encoded as binary, and also as counts when its table has values above 1. +#' Feature types are selected before their tables are scanned or matrices built. +#' +#' @param eligibility An `amr_eligibility` from [eligibleScopes()]. +#' @param modes Mode IDs from [modelingModes()] to plan matrices for, or `NULL` for +#' every mode in `eligibility`. +#' @param feature_types A preset (`"quick"`, `"standard"`, or `"full"`) or an +#' explicit character vector of feature types. Default `"standard"`. +#' Quick uses gene, protein, and Pfam; Standard also includes COG and +#' AMRFinder; Full additionally includes struct and DefenseCas. Presets use +#' only tables present in the ORB. Explicit selections require exact names. +#' +#' @return An `amr_matrix_plan` list: +#' * `eligibility`: the eligibility used, with `members` limited to `modes`. +#' * `matrices`: one row per matrix: `matrix_id`, the scope (`mode_id`, `unit`, +#' `target`, `train_group`, `test_group`), `feature_type`, `encoding`, and +#' the scope's `n_train` and `n_test` genomes (`NA` without a test set). +#' +#' @section Errors: +#' All errors have class `amrml_error`, plus `amrml_invalid_argument` if +#' `eligibility` is not from [eligibleScopes()], `modes` names an unknown mode, +#' or `feature_types` is invalid. +#' +#' @examples +#' \dontrun{ +#' plan <- planMatrices(eligibleScopes(profileORB(readORB("path/to/amRdata/output")))) +#' plan$matrices +#' +#' # Only some modes +#' planMatrices(eligibility, modes = c("vanilla", "loto")) +#' +#' # Quick feature selection +#' planMatrices(eligibility, feature_types = "quick") +#' } +#' @export +planMatrices <- function(eligibility, modes = NULL, feature_types = "standard") { + call <- rlang::current_env() + .checkArgClass(eligibility, "eligibility", "amr_eligibility", "eligibleScopes()", call = call) + if (!is.null(modes)) { + .checkArgModes(modes, call = call) + # Members of the modes left out would have no planned scope when building. + eligibility$members <- eligibility$members[eligibility$members$mode_id %in% modes, , drop = FALSE] + } + + scopes <- eligibility$scopes[eligibility$scopes$eligible, , drop = FALSE] + if (!is.null(modes)) scopes <- scopes[scopes$mode_id %in% modes, , drop = FALSE] + scopes <- tibble::tibble( + scopes[c("mode_id", .SCOPE_KEYS)], + n_train = scopes$n_genomes, + n_test = scopes$test_n_genomes + ) + feature_tables <- eligibility$profile$orb$feature_tables + selected <- .resolveFeatureTypes(feature_types, feature_tables$feature_type, call = call) + feature_tables <- feature_tables[feature_tables$feature_type %in% selected, , drop = FALSE] + encodings <- .encodings(feature_tables) + + keys <- c("mode_id", .SCOPE_KEYS, "feature_type", "encoding") + matrices <- dplyr::cross_join(scopes, encodings) + matrices <- tibble::tibble( + matrix_id = .matrixIds(matrices[keys]), + matrices[c(keys, "n_train", "n_test")] + ) + + structure( + list(eligibility = eligibility, matrices = matrices), + class = "amr_matrix_plan" + ) +} + +#' Build the planned matrices +#' +#' Writes each sparse count matrix per feature type in `features/`. +#' Binary encoding and scope-specific feature selection are indexed without +#' materializing matrices for speed. amRdata's files in the ORB are only read. +#' +#' @param plan An `amr_matrix_plan` from [planMatrices()]. +#' @param out_dir Folder to write to, created if needed. +#' @param overwrite Replace matrices already in `out_dir`. +#' +#' @return An `amr_matrices` list: `eligibility`, `out_dir`, `matrices`, and +#' `storage = "shared_sparse"`. The `file` column points to a shared feature +#' store rather than a scope-specific Parquet file. `matrix_index.rds` records +#' membership rows and selected feature column indices per matrix +#' +#' @section Errors: +#' All errors have class `amrml_error`, plus one of: +#' +#' * `amrml_invalid_argument`: invalid `plan`/`out_dir`, or output exists without overwrite. +#' * `amrml_feature_rows_repeated`: duplicate genome/feature pairs. +#' * `amrml_feature_values_invalid`: missing, nonfinite, or negative feature values. +#' +#' @export +buildMatrices <- function(plan, out_dir = NULL, overwrite = FALSE) { + call <- rlang::current_env() + .checkArgClass(plan, "plan", "amr_matrix_plan", "planMatrices()", call = call) + orb <- plan$eligibility$profile$orb + out_dir <- out_dir %||% .defaultOutDir(orb$directory) + .checkArgOutDir(out_dir, orb$directory, overwrite, call = call) + out_dir <- .resolvePath(out_dir, call = call) + + # Preserve outputs until the new index and feature stores exist + staging <- tempfile(".matrices-building-", tmpdir = out_dir) + dir.create(file.path(staging, "features"), recursive = TRUE) + on.exit(unlink(staging, recursive = TRUE), add = TRUE) + + matrices <- plan$matrices + matrices$status <- "built" + matrices$rule_id <- NA_character_ + matrices$n_features <- NA_integer_ + matrices$file <- NA_character_ + members <- plan$eligibility$members + scopes <- .scopeIndex(matrices, members) + columns <- vector("list", nrow(matrices)) + genomes <- sort(unique(members$genome_id), method = "radix") + + # Construction happens once per feature type + for (j in seq_along(unique(matrices$feature_type))) { + feature_type <- unique(matrices$feature_type)[[j]] + path <- orb$feature_tables$path[orb$feature_tables$feature_type == feature_type] + table <- .readFeatureTable(path, feature_type, genomes, call = call) + store <- .featureStore(table, genomes) + rm(table) + + file <- file.path("features", sprintf("%04d.rds", j)) + saveRDS(store, file.path(staging, file), compress = FALSE) + for (i in which(matrices$feature_type == feature_type)) { + rows <- scopes$rows[[scopes$matrix_scopes[[i]]]] + selected <- .variableFeaturesIndexed(store, + rows$genome_id[rows$role == "train"], + matrices$encoding[[i]] + ) + columns[[i]] <- selected + if (!length(selected)) { + matrices$status[[i]] <- "skipped" + matrices$rule_id[[i]] <- "no_variable_features" + next + } + matrices$n_features[[i]] <- length(selected) + matrices$file[[i]] <- file + } + rm(store) + } + + saveRDS( + list(rows = scopes$rows, matrix_scopes = scopes$matrix_scopes, columns = columns), + file.path(staging, "matrix_index.rds"), compress = FALSE + ) + arrow::write_parquet(matrices, file.path(staging, "matrices.parquet")) + + # Move the previous output + previous <- c("matrices", "features", "matrices.parquet", "matrix_index.rds") + produced <- c("features", "matrices.parquet", "matrix_index.rds") + if (!overwrite && any(file.exists(file.path(out_dir, previous)))) { + .amrAbort("invalid_argument", "Matrix outputs already exist; set `overwrite = TRUE`.", call = call) + } + backup <- tempfile(".matrices-previous-", tmpdir = out_dir) + dir.create(backup) + old_moved <- character() + new_moved <- character() + tryCatch({ + for (name in previous) { + if (file.exists(file.path(out_dir, name))) { + if (!file.rename(file.path(out_dir, name), file.path(backup, name))) { + stop("Could not move previous matrix output: ", name) + } + old_moved <- c(old_moved, name) + } + } + for (name in produced) { + if (!file.rename(file.path(staging, name), file.path(out_dir, name))) { + stop("Could not install new matrix output: ", name) + } + new_moved <- c(new_moved, name) + } + }, error = function(e) { + for (name in rev(new_moved)) unlink(file.path(out_dir, name), recursive = TRUE) + restored <- vapply(rev(old_moved), function(name) { + file.rename(file.path(backup, name), file.path(out_dir, name)) + }, logical(1)) + if (all(restored)) unlink(backup, recursive = TRUE) + stop(conditionMessage(e), if (!all(restored)) paste0( + " Previous outputs may be recoverable from: ", backup + ), call. = FALSE) + }) + unlink(backup, recursive = TRUE) + + structure( + list(eligibility = plan$eligibility, out_dir = out_dir, + matrices = matrices, storage = "shared_sparse"), + class = "amr_matrices" + ) +} + + +# How many of `matrices` were built and skipped. +.builtAndSkipped <- function(matrices) { + paste0(sum(matrices$status == "built"), " built, ", sum(matrices$status == "skipped"), " skipped") +} + +#' @export +print.amr_matrix_plan <- function(x, ...) { + orb <- x$eligibility$profile$orb + m <- x$matrices + n_scopes <- nrow(dplyr::distinct(m[c("mode_id", .SCOPE_KEYS)])) + + cat("", orb$dataset_id, "-", orb$dataset_label, "\n") + cat(" ", nrow(m), " matrices from ", n_scopes, " eligible scopes\n", sep = "") + n <- table(factor(m$mode_id, unique(m$mode_id))) + cat(.modeLines(names(n), sprintf("%d matrices", n)), sep = "\n") + invisible(x) +} + +#' @export +print.amr_matrices <- function(x, ...) { + orb <- x$eligibility$profile$orb + m <- x$matrices + + cat("", orb$dataset_id, "-", orb$dataset_label, "\n") + cat(" in", x$out_dir, "\n") + cat(" ", .builtAndSkipped(m), "\n", sep = "") + by_mode <- split(m, factor(m$mode_id, unique(m$mode_id))) + cat(.modeLines(names(by_mode), vapply(by_mode, .builtAndSkipped, character(1))), sep = "\n") + invisible(x) +} diff --git a/R/globals.R b/R/globals.R index 15f8e98..4249b21 100644 --- a/R/globals.R +++ b/R/globals.R @@ -1,4 +1,41 @@ # Package-level documentation. #' @keywords internal +#' @importFrom rlang .data +#' @importFrom glmnet glmnet +#' @importFrom stats median quantile sd +#' @importFrom utils head "_PACKAGE" + +# Column names used in feature rescoring's dplyr code (R/feature-rescoring.R). +utils::globalVariables(c( + "contribution", "contribution_cutoff", "cum_contrib", "drug_label", "drug_or_class", "dyad", + "dyad_median_contribution", "dyad_median_rank_score", "dyad_score_cutoff", "feature", + "feature_subtype", "feature_type", "feature_type_subtype", "fit_mixture", "fit_penalty", + "frequency", + "importance", "Importance", "in_core", "in_core_consistent", "mcc", "MCC_diff", + "mean_rank_score", "median_contribution", "median_cum_contrib", "median_MCC_diff", + "median_nonshuffled_MCC", "median_rank_score", "model", "n_drug_or_class", "n_feat", + "n_feats_returned", "n_feature_types", "n_features", "n_seeds", "nonshuffled_MCC", + "overall_dyad_median_rank_score", "overall_median_contribution", "overall_median_rank_score", + "rank_score", "rank_score_cutoff", "rank_score_cv", "rank_score_sd", "running_contrib", "seed", + "seed_ratio", "shuffled", "shuffled_FALSE", "shuffled_MCC", "shuffled_TRUE", "Sign", + "sign_consistent", "sign_consistent_across_models", "species", "subtype_csv", + "total_frequency", "variable", "Variable", "variables_csv" +)) + +# Additional columns used by model reliability and network evidence summaries. +utils::globalVariables(c( + "above_background", "annotation_key", "assessable_pair", "direct_score", "encoding", + "evidence_status", "gene_cluster", "gene_representation_supported", "gene_robust75", + "has_real", "has_shuffled", "high_priority", "legacy_key", "matrix_id", "mcc_adjusted", + "mcc_for_reliability", "mcc_real", "mcc_shuffled", "mean_returned_contribution", + "mean_shuffled_mcc", "mode_id", "n_core_seeds", "n_eligible_seeds", "n_fitted_seeds", + "n_missing", "n_paired_assessable", "n_predicted", "n_returned_features", + "n_returned_seeds", "n_shuffled_defined", "n_supported_seeds", "n_true", "node_id", + "pair_reliability_supported", "pair_robust75", "predicted", "priority_under_reliability", + "protein_cluster", "protein_representation_supported", "protein_robust75", + "reproducibly_important", "returned", "returned_nonzero", "sd_shuffled_mcc", + "shuffled_pair_reliability_supported", "shuffled_pair_robust75", "shuffled_upper", "status", + "supported", "target", "task_id", "truth", "unit" +)) diff --git a/R/network.R b/R/network.R new file mode 100644 index 0000000..a099965 --- /dev/null +++ b/R/network.R @@ -0,0 +1,464 @@ +# Build network evidence from completed amRml modeling tasks and the existing ORB. +# These helpers summarize fitted models and connect their features to ORB clusters +# and annotations, without refitting models or modifying the source data. + +# Calculate each returned feature's share of importance within its fitted task. +# Sort features by contribution (and feature ID to break ties), then mark the +# smallest set whose combined importance reaches the requested core threshold. +# Keep all returned features so later steps can compare core and non-core evidence. +.scoreNetworkTasks <- function(importance, metadata, core_threshold) { + stopifnot(core_threshold > 0, core_threshold <= 1) + r <- importance |> + dplyr::inner_join(metadata, by = "task_id", relationship = "many-to-one") + if (anyNA(r[c("Variable", "Importance", "Sign")]) || + any(!is.finite(r$Importance) | r$Importance <= 0) || + anyDuplicated(r[c("task_id", "Variable")])) { + stop("Invalid returned feature importance.", call. = FALSE) + } + r |> + dplyr::group_by(task_id) |> + dplyr::mutate(contribution = Importance / sum(Importance)) |> + dplyr::arrange(dplyr::desc(contribution), Variable, .by_group = TRUE) |> + dplyr::mutate(in_core = dplyr::row_number() <= + which(cumsum(contribution) >= core_threshold - 1e-12)[[1L]]) |> + dplyr::ungroup() +} + +# Prepare gene and protein cluster evidence from the scored model features. +# Both model types use cluster-level predictors, so each feature maps directly +# to its corresponding ORB cluster. Restore the "fig|" prefix in CD-HIT protein +# representative IDs when glmnet has written it as "fig.", and record whether +# each cluster appears in the fixed ORB dyad graph. Do not combine coefficients. +.prepareNetworkNodes <- function(scored, pairs) { + rows <- scored |> + dplyr::filter(feature_type %in% c("gene", "protein")) |> + dplyr::transmute(task_id, unit, target, labels, seed, encoding, feature_type, + node_id = dplyr::if_else(feature_type == "protein", + sub("^fig\\.", "fig|", Variable), Variable), + contribution, in_core, sign = Sign, + n_returned_features = 1L) |> + dplyr::mutate(in_orb_graph = dplyr::if_else(feature_type == "protein", + node_id %in% pairs$protein_cluster, node_id %in% pairs$gene_cluster)) + if (anyDuplicated(rows[c("task_id", "feature_type", "node_id")])) { + stop("Multiple model features map to the same cluster ID within a task.", call. = FALSE) + } + rows +} + +# Summarize how often each cluster or annotation was returned across fitted seeds. +# Record its total and average returned importance and how often it entered the +# core group. Use all successful fitted tasks to count seeds, including those +# where a feature was not returned. These tables cannot distinguish an eligible +# zero coefficient from a feature that was unavailable to the model; the final +# candidate-aware MAGIC score requires a separate candidate inventory. +.summarizeNetworkNodes <- function(rows, fitted) { + groups <- c("unit", "target", "labels", "encoding", "feature_type") + fits <- fitted |> + dplyr::count(dplyr::across(dplyr::all_of(groups)), name = "n_fitted_seeds") + rows |> + dplyr::group_by(dplyr::across(dplyr::all_of(c(groups, "node_id")))) |> + dplyr::summarise( + n_returned_seeds = dplyr::n_distinct(seed), + n_core_seeds = sum(in_core), + total_returned_contribution = sum(contribution), + mean_returned_contribution = mean(contribution), + n_returned_features = sum(n_returned_features), + .groups = "drop" + ) |> + dplyr::left_join(fits, by = groups, relationship = "many-to-one") |> + dplyr::mutate( + # Require core importance in at least two fitted seeds. This measures + # recurrence among returned coefficients, not candidate-aware importance. + reproducibly_important = n_core_seeds >= 2L & n_fitted_seeds >= 2L, + observed_in_fitted_fraction = n_returned_seeds / n_fitted_seeds + ) +} + +# Fetch only the requested cluster or feature mappings from one ORB view. +# Query keys in batches so large annotation tables stay in DuckDB instead of +# being loaded into R. Avoid the virtual dyad_feature relation, which expands +# into a billion features that the cluster network does not need. +.queryNetworkKeys <- function(con, view, column, keys, other) { + if (!length(keys)) return(data.frame()) + pieces <- split(unique(keys), ceiling(seq_along(unique(keys)) / 500L)) + dplyr::bind_rows(lapply(pieces, function(part) { + quoted <- as.character(DBI::dbQuoteString(con, part)) + DBI::dbGetQuery(con, paste0( + "SELECT DISTINCT CAST(", other, " AS VARCHAR) AS value, ", + "CAST(", column, " AS VARCHAR) AS lookup_key FROM ", view, + " WHERE ", column, " IN (", paste(quoted, collapse = ", "), ")" + )) + })) +} + +#' Export MAGIC gene-protein cluster networks for amRviz +#' +#' Build a fixed ORB cluster-pair graph with real and shuffled feature evidence, +#' model reliability, and separate connected functional annotations. Does not +#' refit models. Gene and protein models already use cluster predictors; +#' protein cluster IDs are named by CD-HIT representatives. Functional +#' annotations do not increase either endpoint's feature score. +#' +#' @param run_dir Completed modeling run with tasks.parquet, matrices.parquet, +#' results/performance.parquet, results/importance.parquet, and predictions. +#' @param orb_dir Parquet-backed ORB with cluster dyads, protein_members, and annotation +#' views. Opened read-only. +#' @param out_dir Output directory outside the modeling run and ORB. +#' @param core_threshold Share of returned coefficient importance for the core. +#' @return Invisibly, a list containing the per-target summary and output directory. +#' @details Undefined MCC is provisionally replaced by zero only when the saved +#' predictions show constant class predictions and both true classes in the +#' test set. The raw modeling performance Parquet remains unchanged. Model +#' reliability is assessed by `assessModelReliability()`. Candidate-aware direct +#' feature scores are not approximated from the matrix-wide feature count; +#' node tables here report observed returned-coefficient evidence instead. +#' Writes Parquet evidence tables only. Does not create review or Cytoscape CSVs. +#' @export +exportNetwork <- function(run_dir, orb_dir, out_dir, + core_threshold = 0.75) { + if (length(core_threshold) != 1L || !is.finite(core_threshold) || + core_threshold <= 0 || core_threshold > 1) { + stop("core_threshold must be in (0, 1].", call. = FALSE) + } + run_dir <- normalizePath(run_dir, winslash = "/", mustWork = TRUE) + orb_dir <- normalizePath(orb_dir, winslash = "/", mustWork = TRUE) + out_dir <- normalizePath(out_dir, winslash = "/", mustWork = FALSE) + if (out_dir %in% c(run_dir, orb_dir) || + startsWith(out_dir, paste0(run_dir, "/")) || + startsWith(out_dir, paste0(orb_dir, "/"))) { + stop("Output must be outside the modeling run and ORB.", call. = FALSE) + } + inputs <- c("tasks.parquet", "matrices.parquet", "results/performance.parquet", + "results/importance.parquet", "results/predictions.parquet") + if (!all(file.exists(file.path(run_dir, inputs)))) { + stop("Missing run output: ", paste(inputs[!file.exists(file.path(run_dir, inputs))], + collapse = ", "), call. = FALSE) + } + tasks <- arrow::read_parquet(file.path(run_dir, inputs[[1L]])) + matrices <- arrow::read_parquet(file.path(run_dir, inputs[[2L]])) + performance <- arrow::read_parquet(file.path(run_dir, inputs[[3L]])) + importance <- arrow::read_parquet(file.path(run_dir, inputs[[4L]])) + predictions <- arrow::read_parquet(file.path(run_dir, inputs[[5L]])) + required_tasks <- c("task_id", "matrix_id", "labels", "seed", "status") + required_matrices <- c("matrix_id", "mode_id", "unit", "target", "feature_type", "encoding") + if (!all(required_tasks %in% names(tasks)) || + !all(required_matrices %in% names(matrices)) || + !all(c("task_id", "mcc") %in% names(performance)) || + !all(c("task_id", "Variable", "Importance", "Sign") %in% names(importance)) || + !all(c("task_id", "truth", "predicted") %in% names(predictions)) || + anyDuplicated(tasks$task_id) || anyDuplicated(matrices$matrix_id) || + anyDuplicated(performance$task_id)) { + stop("Missing columns or duplicate identities in modeling output.", call. = FALSE) + } + metadata <- tasks |> + dplyr::filter(status == "fitted", labels %in% c("real", "shuffled")) |> + dplyr::left_join(matrices, by = "matrix_id", relationship = "many-to-one") |> + dplyr::filter(mode_id == "vanilla") |> + dplyr::select(task_id, matrix_id, unit, target, labels, seed, feature_type, encoding) + if (!nrow(metadata) || anyNA(metadata) || + anyDuplicated(metadata[c("unit", "target", "labels", "seed", "feature_type", "encoding")])) { + stop("Expected distinct fitted vanilla tasks with complete scope metadata.", call. = FALSE) + } + if ("seed" %in% names(performance) && + any(metadata$seed != performance$seed[match(metadata$task_id, performance$task_id)], + na.rm = TRUE)) { + stop("Inconsistent fitted-task seeds.", call. = FALSE) + } + performance <- metadata |> + dplyr::inner_join(dplyr::select(performance, -dplyr::any_of("seed")), + by = "task_id", relationship = "one-to-one") + if (nrow(performance) != nrow(metadata)) { + stop("A fitted task has no performance record.", call. = FALSE) + } + + scored <- .scoreNetworkTasks(importance, metadata, core_threshold) + if (dplyr::n_distinct(scored$task_id) != nrow(metadata)) { + stop("A fitted task has no usable returned coefficient importance.", call. = FALSE) + } + if (any(abs((scored |> + dplyr::group_by(task_id) |> + dplyr::summarise(total = sum(contribution), .groups = "drop"))$total - 1) > 1e-7)) { + stop("Normalized contribution is not conserved within fitted tasks.", call. = FALSE) + } + # Keep one record for every successful task when counting fitted seeds. + # A model can fit successfully while returning only a few nonzero features, + # so returned coefficient rows alone cannot tell us how many seeds were fitted. + fitted <- metadata |> + dplyr::select(unit, target, labels, seed, encoding, feature_type) + + audit <- predictions |> + dplyr::group_by(task_id) |> + dplyr::summarise( + n_missing = sum(is.na(truth) | is.na(predicted)), + n_true = dplyr::n_distinct(truth, na.rm = TRUE), + n_predicted = dplyr::n_distinct(predicted, na.rm = TRUE), + .groups = "drop" + ) + performance <- performance |> + dplyr::left_join(audit, by = "task_id", relationship = "one-to-one") |> + dplyr::mutate( + mcc_adjusted = is.na(mcc) & !is.na(n_missing) & n_missing == 0L & + n_true == 2L & n_predicted == 1L, + mcc_for_reliability = dplyr::if_else(mcc_adjusted, 0, mcc) + ) + species <- basename(dirname(orb_dir)) + perf_reliability <- performance |> + dplyr::transmute(species = species, drug_label = unit, + drug_or_class = target, feature_type, + feature_subtype = encoding, seed, + shuffled = labels == "shuffled", mcc = mcc_for_reliability) + reliability <- local({ + path <- tempfile(fileext = ".parquet") + on.exit(unlink(path), add = TRUE) + arrow::write_parquet(perf_reliability, path) + assessModelReliability(path) + }) + representation <- reliability$by_representation |> + dplyr::rename(unit = drug_label, target = drug_or_class, + encoding = feature_subtype) |> + dplyr::select(unit, target, feature_type, encoding, + evidence_status, supported, n_supported_seeds, + n_paired_assessable, n_shuffled_defined) + + # Read the fixed gene-cluster/protein-cluster pairs from the ORB rather than + # rebuilding edges from model results. The ORB views use relative Parquet paths, + # so open the database from its directory and restore the working directory + # and database connection when the query finishes. + orb_results <- local({ + old_wd <- getwd() + on.exit(setwd(old_wd), add = TRUE) + setwd(orb_dir) + databases <- list.files(".", pattern = "_parquet[.]duckdb$") + if (length(databases) != 1L) { + stop("Expected one *_parquet.duckdb ORB database.", call. = FALSE) + } + con <- DBI::dbConnect(duckdb::duckdb(), dbdir = databases[[1L]], read_only = TRUE) + on.exit(DBI::dbDisconnect(con), add = TRUE) + needed <- c("dyads", "protein_members") + if (!all(needed %in% DBI::dbListTables(con))) { + stop("ORB lacks the cluster dyads or protein_members relation.", call. = FALSE) + } + pairs <- DBI::dbGetQuery(con, + "SELECT DISTINCT CAST(gene AS VARCHAR) AS gene_cluster, CAST(protein AS VARCHAR) AS protein_cluster FROM dyads") + if (!nrow(pairs) || anyNA(pairs) || + anyDuplicated(pairs[c("gene_cluster", "protein_cluster")])) { + stop("Invalid ORB cluster-pair graph.", call. = FALSE) + } + # Check that each dyad's protein ID is a known CD-HIT cluster representative. + # Representatives can have "fig|" IDs just like protein members, so the ID + # prefix alone cannot tell us whether the ORB contains the correct dyads. + unknown <- DBI::dbGetQuery(con, + "SELECT COUNT(*) AS n FROM ( + SELECT DISTINCT CAST(protein AS VARCHAR) AS cluster FROM dyads + EXCEPT + SELECT DISTINCT CAST(cluster AS VARCHAR) AS cluster FROM protein_members + )")$n[[1L]] + if (unknown > 0L) { + stop("ORB dyads contain protein IDs absent from CD-HIT cluster representatives (possibly individual protein IDs). Rebuild the ORB cluster dyads.", + call. = FALSE) + } + list(pairs = pairs) + }) + pairs <- orb_results$pairs + cluster_rows <- .prepareNetworkNodes(scored, pairs) + nodes <- .summarizeNetworkNodes(cluster_rows, fitted) |> + dplyr::mutate(evidence_origin = dplyr::if_else( + feature_type == "protein", "direct_protein_cluster_model", "direct_gene_model")) + annotations <- scored |> + dplyr::filter(feature_type %in% c("Pfam", "COG", "AMRFinder", "DefenseCas")) |> + dplyr::transmute(unit, target, labels, seed, encoding, feature_type, + node_id = Variable, contribution, in_core, + n_returned_features = 1L) |> + .summarizeNetworkNodes(fitted) + annotation_evidence <- annotations |> + dplyr::left_join(representation, by = c("unit", "target", "feature_type", "encoding"), + relationship = "many-to-one") + + scopes <- metadata |> + dplyr::distinct(unit, target, labels, encoding) + graph <- dplyr::cross_join(scopes, pairs) + graph$gene_degree <- as.integer(table(pairs$gene_cluster)[graph$gene_cluster]) + graph$protein_degree <- as.integer(table(pairs$protein_cluster)[graph$protein_cluster]) + for (typ in c("gene", "protein")) { + n <- nodes |> + dplyr::filter(feature_type == typ) |> + dplyr::select(unit, target, labels, encoding, node_id, + reproducibly_important, n_core_seeds, n_fitted_seeds, + mean_returned_contribution) + prefix <- if (typ == "gene") "gene" else "protein" + names(n)[names(n) == "node_id"] <- paste0(prefix, "_cluster") + names(n)[names(n) == "reproducibly_important"] <- paste0(prefix, "_robust75") + names(n)[names(n) == "n_core_seeds"] <- paste0(prefix, "_core_seeds") + names(n)[names(n) == "n_fitted_seeds"] <- paste0(prefix, "_fitted_seeds") + names(n)[names(n) == "mean_returned_contribution"] <- paste0(prefix, "_mean_returned_contribution") + graph <- dplyr::left_join(graph, n, + by = c("unit", "target", "labels", "encoding", paste0(prefix, "_cluster")), + relationship = "many-to-one") + col <- paste0(prefix, "_robust75") + graph[[col]] <- dplyr::coalesce(graph[[col]], FALSE) + } + for (typ in c("gene", "protein")) { + rep <- representation |> + dplyr::filter(feature_type == typ) |> + dplyr::select(unit, target, encoding, supported, evidence_status) + names(rep)[names(rep) == "supported"] <- paste0(typ, "_representation_supported") + names(rep)[names(rep) == "evidence_status"] <- paste0(typ, "_representation_status") + graph <- dplyr::left_join(graph, rep, by = c("unit", "target", "encoding"), + relationship = "many-to-one") + } + graph <- graph |> + dplyr::mutate( + gene_representation_supported = dplyr::coalesce(gene_representation_supported, FALSE), + protein_representation_supported = dplyr::coalesce(protein_representation_supported, FALSE), + pair_robust75 = gene_robust75 & protein_robust75, + pair_reliability_supported = gene_representation_supported & protein_representation_supported, + priority_under_reliability = pair_robust75 & pair_reliability_supported, + high_priority = labels == "real" & priority_under_reliability, + protein_evidence_origin = "direct_protein_cluster_model" + ) + background <- graph |> + dplyr::filter(labels == "shuffled") |> + dplyr::select(unit, target, encoding, gene_cluster, protein_cluster, + shuffled_pair_robust75 = pair_robust75, + shuffled_pair_reliability_supported = priority_under_reliability) + real <- graph |> + dplyr::filter(labels == "real") |> + dplyr::left_join(background, + by = c("unit", "target", "encoding", "gene_cluster", "protein_cluster"), + relationship = "one-to-one") |> + dplyr::mutate( + shuffled_pair_robust75 = dplyr::coalesce(shuffled_pair_robust75, FALSE), + shuffled_pair_reliability_supported = dplyr::coalesce(shuffled_pair_reliability_supported, FALSE) + ) + # Find the protein clusters adjacent to reproducibly important gene/protein + # pairs. Include robust real-label pairs even if their models did not pass the + # reliability check, so annotation context remains available for review. + robust_pairs <- real |> + dplyr::filter(pair_robust75) + + # Retrieve ORB annotations for protein clusters connected to robust pairs. + # Keep Pfam, COG, AMRFinder, and DefenseCas links separate from the endpoint + # scores: a cluster with many annotations does not gain extra importance. + neighbor_clusters <- unique(robust_pairs$protein_cluster) + neighbor_links <- local({ + old_wd <- getwd() + on.exit(setwd(old_wd), add = TRUE) + setwd(orb_dir) + db <- list.files(".", pattern = "_parquet[.]duckdb$") + con <- DBI::dbConnect(duckdb::duckdb(), dbdir = db[[1L]], read_only = TRUE) + on.exit(DBI::dbDisconnect(con), add = TRUE) + views <- c(Pfam = "dyad_ann_pfam", COG = "dyad_ann_cog", + AMRFinder = "dyad_ann_amr", DefenseCas = "dyad_ann_defense") + available <- DBI::dbListTables(con) + dplyr::bind_rows(lapply(names(views), function(typ) { + if (!views[[typ]] %in% available) { + warning("Missing ORB annotation view: ", views[[typ]], call. = FALSE) + return(data.frame()) + } + found <- .queryNetworkKeys(con, views[[typ]], "cluster", + neighbor_clusters, "feature") + if (!nrow(found)) return(data.frame()) + data.frame(feature_type = typ, protein_cluster = found$lookup_key, + annotation_key = found$value) + })) + }) + if (!nrow(neighbor_links)) { + neighbor_links <- data.frame(feature_type = character(), protein_cluster = character(), + annotation_key = character()) + } + # Match ORB annotation IDs to model feature IDs without dropping annotations + # that were not returned by a fitted model. Prefer an exact feature-ID match; + # use the older AMRFinder spelling only when an exact match is unavailable. + # Unmatched ORB annotations still provide context, but have no model score. + annotation_ids <- annotation_evidence |> + dplyr::distinct(feature_type, node_id) |> + dplyr::mutate(legacy_key = dplyr::if_else(feature_type == "AMRFinder", + sub("^X", "", gsub("\\.NCBIFAM", "", node_id)), node_id)) + raw_match <- annotation_ids |> + dplyr::transmute(feature_type, annotation_key = node_id, node_id) |> + dplyr::semi_join(neighbor_links, by = c("feature_type", "annotation_key")) + legacy_match <- annotation_ids |> + dplyr::filter(node_id != legacy_key) |> + dplyr::anti_join(raw_match, by = c("feature_type", "node_id")) |> + dplyr::transmute(feature_type, annotation_key = legacy_key, node_id) |> + dplyr::semi_join(neighbor_links, by = c("feature_type", "annotation_key")) + mapping <- dplyr::bind_rows(raw_match, legacy_match) |> + dplyr::distinct() + if (anyDuplicated(mapping[c("feature_type", "annotation_key")])) { + stop("An ORB annotation key matches multiple model feature identities.", call. = FALSE) + } + matched <- neighbor_links |> + dplyr::left_join(mapping, by = c("feature_type", "annotation_key"), + relationship = "many-to-one") |> + dplyr::mutate(node_id = dplyr::coalesce(node_id, annotation_key)) + neighbors <- robust_pairs |> + dplyr::distinct(unit, target, encoding, protein_cluster) |> + dplyr::left_join(matched, by = "protein_cluster", relationship = "many-to-many") |> + dplyr::filter(!is.na(feature_type)) |> + dplyr::cross_join(tibble::tibble(labels = c("real", "shuffled"))) |> + dplyr::left_join(annotation_evidence, + by = c("unit", "target", "encoding", "labels", "feature_type", "node_id"), + relationship = "many-to-one") |> + dplyr::mutate(returned_nonzero = !is.na(n_returned_seeds), + robust75 = dplyr::coalesce(reproducibly_important, FALSE), + annotation_evidence_status = dplyr::if_else(returned_nonzero, + "returned", "not_returned_candidate_unknown")) + + by_target <- real |> + dplyr::group_by(unit, target) |> + dplyr::summarise( + n_fixed_pair_encoding_records = dplyr::n(), + n_real_robust_pair_encoding_records = sum(pair_robust75), + n_high_priority_pair_encoding_records = sum(high_priority), + n_robust_pair_encoding_records_also_shuffled = + sum(pair_robust75 & shuffled_pair_robust75), + n_distinct_real_robust_pairs = dplyr::n_distinct( + gene_cluster[pair_robust75], protein_cluster[pair_robust75]), + n_distinct_high_priority_pairs = dplyr::n_distinct( + gene_cluster[high_priority], protein_cluster[high_priority]), + .groups = "drop" + ) + dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + provenance <- data.frame( + modeling_run = run_dir, + orb_directory = orb_dir, + n_cluster_pairs = nrow(pairs), + n_fitted_tasks = nrow(metadata), + core_threshold = core_threshold, + min_supported_seeds = 2L, + shuffled_reference = "mean_plus_one_sd", + constant_prediction_mcc = "zero_when_both_truth_classes_present" + ) + arrow::write_parquet(provenance, file.path(out_dir, "network_provenance.parquet")) + arrow::write_parquet(scored, file.path(out_dir, "feature_returned_seed_evidence.parquet")) + arrow::write_parquet(nodes, file.path(out_dir, "gene_protein_cluster_node_evidence.parquet")) + arrow::write_parquet(annotation_evidence, file.path(out_dir, "annotation_node_evidence.parquet")) + arrow::write_parquet(graph, file.path(out_dir, "cluster_pair_network_evidence.parquet")) + arrow::write_parquet(neighbors, file.path(out_dir, "cluster_annotation_neighbor_evidence.parquet")) + arrow::write_parquet(reliability$by_representation, file.path(out_dir, "model_reliability.parquet")) + arrow::write_parquet(performance |> + dplyr::select(task_id, unit, target, labels, seed, feature_type, encoding, + mcc, mcc_adjusted, mcc_for_reliability), + file.path(out_dir, "reliability_mcc_audit.parquet")) + protein_ids <- scored |> + dplyr::filter(feature_type == "protein") |> + dplyr::distinct(Variable) |> + dplyr::transmute(model_feature = Variable, + protein_cluster = sub("^fig\\.", "fig|", Variable), + in_orb_graph = protein_cluster %in% pairs$protein_cluster) + arrow::write_parquet(protein_ids, + file.path(out_dir, "protein_cluster_id_crosswalk.parquet")) + if (!any(cluster_rows$feature_type == "gene" & cluster_rows$in_orb_graph) || + !any(cluster_rows$feature_type == "protein" & cluster_rows$in_orb_graph)) { + warning("No matching gene or protein clusters in ORB dyads; check feature ID normalization and ORB version.", + call. = FALSE) + } + arrow::write_parquet(cluster_rows, + file.path(out_dir, "gene_protein_seed_evidence.parquet")) + + message("MAGIC network export: ", nrow(pairs), " fixed cluster pairs; ", + sum(real$high_priority), " high-priority pair/encoding records (", + sum(by_target$n_distinct_high_priority_pairs), " distinct pairs).\n", + "Outputs: ", out_dir) + invisible(list(summary = by_target, out_dir = out_dir)) +} diff --git a/R/orb-profile.R b/R/orb-profile.R new file mode 100644 index 0000000..1425da7 --- /dev/null +++ b/R/orb-profile.R @@ -0,0 +1,321 @@ +# Profiling an amRdata ORB: each genome's phenotypes, and the counts per target. + +# amRdata's metadata.parquet columns that profiling needs, named as they are used here. +.METADATA_COLUMNS <- c( + genome_id = "genome.genome_id", + phenotype = "genome_drug.resistant_phenotype", + drug_abbr = "drug_abbr", + class_abbr = "class_abbr" +) + + +# The metadata as character columns with empty strings as NA. Strata columns get +# their registry names. +.readMetadata <- function(path, call) { + metadata <- arrow::read_parquet(path) + missing_columns <- setdiff(.METADATA_COLUMNS, names(metadata)) + + if (length(missing_columns)) { + .amrAbort( + "metadata_columns_missing", + c("The metadata is missing columns profiling needs.", .bullets(missing_columns)), + observed = list(missing = missing_columns), + call = call + ) + } + + columns <- c(.METADATA_COLUMNS, .STRATA) + columns <- columns[columns %in% names(metadata)] + metadata <- metadata[columns] + names(metadata) <- names(columns) + + # as.character() also drops the unused factor levels of amRdata's year bins. + metadata[] <- lapply(metadata, function(x) { + x <- as.character(x) + x[x %in% ""] <- NA_character_ + x + }) + + metadata +} + +## Deprecated (sorry!) since the sparse matrix representation could now mean genomes +## with no detected features for one scale could be dropped despite being valid. +## An absence of rows would be very rare, but if it happened, would not mean a genome +## had actually failed any sort of processing step. +# The genomes in `metadata` that a feature table lacks, with the feature types lacking them. +#.missingFeatures <- function(metadata, feature_tables) { +# genomes <- unique(metadata$genome_id) +# +# lacking <- lapply(feature_tables$path, function(f) { +# table <- arrow::read_parquet(f, col_select = "genome_id", as_data_frame = FALSE) +# setdiff(genomes, as.vector(unique(table$genome_id))) +# }) +# +# missing <- tibble::tibble( +# genome_id = unlist(lacking), +# feature_type = rep(feature_tables$feature_type, lengths(lacking)) +# ) +# +# dplyr::summarise( +# dplyr::group_by(missing, .data$genome_id), +# missing_from = toString(.data$feature_type) +# ) +#} + +# One row per genome and drug; repeated rows that agree count once. amRdata gives +# each drug one class, from a lookup table. +.drugPhenotypes <- function(metadata, call) { + phenotypes <- dplyr::distinct(metadata[c("genome_id", "drug_abbr", "phenotype")]) + pairs <- phenotypes[c("genome_id", "drug_abbr")] + conflicts <- unique(pairs[duplicated(pairs), , drop = FALSE]) + + if (nrow(conflicts)) { + .amrAbort( + "phenotype_conflict", + c( + "Genomes are recorded as both Resistant and Susceptible for a drug.", + .bullets(paste(conflicts$genome_id, conflicts$drug_abbr)) + ), + observed = list(conflicts = conflicts), + call = call + ) + } + + phenotypes$class_abbr <- metadata$class_abbr[match(phenotypes$drug_abbr, metadata$drug_abbr)] + phenotypes +} + +# One row per genome and drug class: Resistant if any member drug is Resistant, +# otherwise Susceptible. +.classPhenotypes <- function(drug_phenotypes) { + dplyr::summarise( + dplyr::group_by( + drug_phenotypes[!is.na(drug_phenotypes$class_abbr), , drop = FALSE], + .data$genome_id, .data$class_abbr + ), + phenotype = if (any(.data$phenotype == "Resistant")) "Resistant" else "Susceptible", + .groups = "drop" + ) +} + +# One row per genome with its strata, which must have one value per genome. +.genomeTable <- function(metadata, call) { + columns <- setdiff(names(metadata), c("drug_abbr", "class_abbr", "phenotype")) + genomes <- dplyr::distinct(metadata[columns]) + repeated <- unique(genomes$genome_id[duplicated(genomes$genome_id)]) + + if (length(repeated)) { + .amrAbort( + "stratum_inconsistent", + c( + "Strata have more than one value within a genome.", + x = paste0("Genomes: ", toString(repeated)) + ), + observed = list(genomes = repeated), + call = call + ) + } + + genomes[order(genomes$genome_id), , drop = FALSE] +} + +# Counts per target over the whole dataset (stratum NA) and within each observed +# value of each stratum. +.targetCounts <- function(phenotypes, genomes) { + scopes <- dplyr::bind_rows( + tibble::tibble( + genome_id = genomes$genome_id, + stratum = NA_character_, + stratum_value = NA_character_ + ), + lapply(intersect(names(.STRATA), names(genomes)), function(stratum_name) { + values <- genomes[[stratum_name]] + tibble::tibble( + genome_id = genomes$genome_id[!is.na(values)], + stratum = stratum_name, + stratum_value = values[!is.na(values)] + ) + }) + ) + + counts <- dplyr::summarise( + dplyr::group_by( + dplyr::inner_join(phenotypes, scopes, by = "genome_id", relationship = "many-to-many"), + .data$unit, .data$target, .data$stratum, .data$stratum_value + ), + n_genomes = dplyr::n(), + n_resistant = sum(.data$phenotype == "Resistant"), + n_susceptible = sum(.data$phenotype == "Susceptible"), + .groups = "drop" + ) + + dplyr::arrange( + counts, + !is.na(.data$stratum), .data$stratum, .data$stratum_value, .data$unit, .data$target + ) +} + +#' Profile an amRdata ORB +#' +#' Labels each genome Resistant or Susceptible per drug and per drug class, and +#' counts the genomes behind each target, over the whole dataset and within each +#' value of each stratum (year and country). +#' +#' @details +#' A genome is excluded, and listed with the reason, if it has no Resistant or +#' Susceptible row. A class is Resistant if any member drug is, and otherwise +#' Susceptible. Repeated rows for a genome and drug count once if they agree; +#' if they disagree, profiling stops. Missing feature rows represent zeros in +#' sparse feature tables. +#' +#' @section Errors: +#' All errors have class `amrml_error`, plus one of: +#' +#' * `amrml_invalid_argument`: `orb` is not from [readORB()]. +#' * `amrml_metadata_columns_missing`: the metadata lacks a needed column. +#' * `amrml_phenotype_conflict`: a genome is recorded as both Resistant and +#' Susceptible for a drug. +#' * `amrml_no_labelled_genomes`: no genome has a +#' usable phenotype. +#' * `amrml_stratum_inconsistent`: a genome has two values for a stratum. +#' +#' @param orb An `amr_orb` from [readORB()]. +#' +#' @return An `amr_orb_profile` list: +#' * `orb`: the ORB profiled. +#' * `genomes`: each profiled genome and its strata values. +#' * `phenotypes`: each genome's phenotype per `unit` (drug or drug class) and +#' `target`. +#' * `drug_classes`: each profiled drug and its `class`. +#' * `targets`: genome counts per target and stratum value; `stratum` is NA +#' for the whole dataset. +#' * `excluded_genomes`: each excluded genome and its `reason` +#' (`"no_usable_phenotype"`). +#' +#' @examples +#' \dontrun{ +#' profile <- profileORB(readORB("path/to/amRdata/output")) +#' profile$targets +#' } +#' @export +profileORB <- function(orb) { + call <- rlang::current_env() + + # Check the argument is an ORB from readORB(). + .checkArgClass(orb, "orb", "amr_orb", "readORB()", call = call) + + # Read the metadata and keep its Resistant and Susceptible rows. + metadata <- .readMetadata(orb$metadata_parquet, call = call) + usable <- metadata$phenotype %in% c("Resistant", "Susceptible") & + !is.na(metadata$genome_id) & !is.na(metadata$drug_abbr) + no_usable_phenotype <- setdiff(metadata$genome_id, c(NA, metadata$genome_id[usable])) + metadata <- metadata[usable, , drop = FALSE] + + # Each genome's phenotype per drug. + drug_phenotypes <- .drugPhenotypes(metadata, call = call) + + ## No longer needed with the sparse matrix format + #missing <- .missingFeatures(metadata, orb$feature_tables) + #drug_phenotypes <- drug_phenotypes[!drug_phenotypes$genome_id %in% missing$genome_id, ] + + # Record every genome left out, and why. + excluded <- tibble::tibble( + genome_id = no_usable_phenotype, + reason = "no_usable_phenotype" + ) ## Simplifying since we're not dropping genomes based on sparse matrix stuff + excluded <- excluded[order(excluded$genome_id), , drop = FALSE] + reasons <- table(excluded$reason) + reasons <- paste0(names(reasons), ": ", reasons, collapse = ", ") + + if (!nrow(drug_phenotypes)) { + .amrAbort( + "no_labelled_genomes", + c( + "No genome has a usable phenotype.", + i = paste0("Excluded: ", reasons) + ), + observed = list(excluded = excluded), + call = call + ) + } + + if (nrow(excluded)) { + rlang::inform(paste0( + nrow(excluded), " genomes are excluded (", reasons, "); see `$excluded_genomes`." + )) + } + + # Each genome's phenotype per drug class. + class_phenotypes <- .classPhenotypes(drug_phenotypes) + phenotypes <- dplyr::bind_rows( + tibble::tibble( + genome_id = drug_phenotypes$genome_id, + unit = "drug", + target = drug_phenotypes$drug_abbr, + phenotype = drug_phenotypes$phenotype + ), + tibble::tibble( + genome_id = class_phenotypes$genome_id, + unit = "drug_class", + target = class_phenotypes$class_abbr, + phenotype = class_phenotypes$phenotype + ) + ) + + # Each profiled drug's class, so later stages can tell which drugs a class combines. + drug_classes <- dplyr::distinct(tibble::tibble( + drug = drug_phenotypes$drug_abbr, + class = drug_phenotypes$class_abbr + )) + drug_classes <- drug_classes[!is.na(drug_classes$class), , drop = FALSE] + drug_classes <- drug_classes[order(drug_classes$class, drug_classes$drug, method = "radix"), ] + + # Collect the strata of each genome with a phenotype. + profiled <- metadata[metadata$genome_id %in% phenotypes$genome_id, , drop = FALSE] + genomes <- .genomeTable(profiled, call = call) + + # Count genomes per target, over the whole dataset and within each stratum value. + targets <- .targetCounts(phenotypes, genomes) + + structure( + list( + orb = orb, + genomes = genomes, + phenotypes = phenotypes, + drug_classes = drug_classes, + targets = targets, + excluded_genomes = excluded + ), + class = "amr_orb_profile" + ) +} + + +#' @export +print.amr_orb_profile <- function(x, ...) { + whole <- x$targets[is.na(x$targets$stratum), , drop = FALSE] + strata <- vapply(intersect(names(.STRATA), names(x$genomes)), function(s) { + values <- x$genomes[[s]] + paste0( + s, " (values: ", dplyr::n_distinct(values, na.rm = TRUE), + ", missing: ", sum(is.na(values)), ")" + ) + }, character(1)) + + # Wraps "target:resistant/susceptible" items to the console width. + counts <- function(unit) { + rows <- whole[whole$unit == unit, , drop = FALSE] + items <- paste0(rows$target, ":", rows$n_resistant, "/", rows$n_susceptible) + strwrap(paste(items, collapse = ", "), indent = 4, exdent = 4) + } + + cat("", x$orb$dataset_id, "-", x$orb$dataset_label, "\n") + cat(" genomes :", nrow(x$genomes), "profiled,", nrow(x$excluded_genomes), "excluded\n") + cat(" strata :", paste(strata, collapse = "; "), "\n") + cat(" Resistant/Susceptible genomes per drug:\n") + cat(counts("drug"), sep = "\n") + cat(" per drug class:\n") + cat(counts("drug_class"), sep = "\n") + invisible(x) +} diff --git a/R/orb-read.R b/R/orb-read.R index ba76f52..eb3f58f 100644 --- a/R/orb-read.R +++ b/R/orb-read.R @@ -15,9 +15,15 @@ .FEATURE_TABLE_COLUMNS <- c("genome_id", "value") +## An ORB created on Windows causes trouble on Unix systems due to backslash handling +## Little path helper follows +.orbFilePath <- function(path, manifest_path) { + file.path(dirname(manifest_path), basename(chartr("\\", "/", path))) +} + # Tibble of the files the producer run's export stage lists. Manifest fields are # read with `[[`, since `$` also matches a longer name that starts the same way. -.declaredFiles <- function(run) { +.declaredFiles <- function(run, manifest_path) { stage <- Find(function(s) identical(s[["name"]], .AMRDATA_EXPORT_STAGE), run[["stages"]]) if (is.null(stage)) { @@ -38,6 +44,8 @@ )) } + ## Adding path resolution, now with Windows tolerance! + path <- .orbFilePath(path, manifest_path) tibble::tibble( path = path, name = basename(path), @@ -97,8 +105,11 @@ } # The metadata file must be declared, so the file checks cover it. - files <- .declaredFiles(run) - metadata_parquet <- string(artifact[["metadata_parquet"]], "metadata_parquet") + files <- .declaredFiles(run, manifest_path) + metadata_parquet <- .orbFilePath( + string(artifact + [["metadata_parquet"]], "metadata_parquet"), + manifest_path) if (!metadata_parquet %in% files$path) { rlang::abort(paste0( @@ -112,7 +123,7 @@ list( dataset_id = dataset_id, - label = if (length(requested)) paste(requested, collapse = ", ") else dataset_id, + dataset_label = if (length(requested)) paste(requested, collapse = ", ") else dataset_id, directory = string(artifact[["directory"]], "directory"), manifest_path = manifest_path, metadata_parquet = metadata_parquet, @@ -163,25 +174,26 @@ ready[[order(finished, files, decreasing = c(TRUE, FALSE), method = "radix")[[1]]]] } -# Throw an error unless the ORB is where its manifest says, and its files exist -# at their recorded size. -.checkOrbFiles <- function(record, dir, call) { - recorded_dir <- record$directory - - # Check this first, since in a moved ORB every declared file would look missing. - if (!identical(normalizePath(recorded_dir, mustWork = FALSE), dir)) { - .amrAbort( - "orb_moved", - c( - "This ORB is not where its manifest says it was written.", - x = paste0("Manifest records: ", recorded_dir), - i = "amRdata records absolute paths, so a moved or copied ORB can't be read yet." - ), - observed = list(recorded = recorded_dir, actual = dir), - call = call - ) - } - +## Changes in the PR pipe in amRdata mean manifests now record where they are in +## a polite and more portable relative fashion +# Throw an error unless the declared files exist at their recorded size. +.checkOrbFiles <- function(record, call) { +# recorded_dir <- record$directory +# +# # Check this first, since in a moved ORB every declared file would look missing. +# if (!identical(normalizePath(recorded_dir, mustWork = FALSE), dir)) { +# .amrAbort( +# "orb_moved", +# c( +# "This ORB is not where its manifest says it was written.", +# x = paste0("Manifest records: ", recorded_dir), +# i = "amRdata records absolute paths, so a moved or copied ORB can't be read yet." +# ), +# observed = list(recorded = recorded_dir, actual = dir), +# call = call +# ) +# } +## ORBs can traverse time and space now -- deprecating # A file that can't be read is as unusable as a missing one. files <- record$files absent <- files$path[file.access(files$path, mode = 4) != 0] @@ -276,28 +288,198 @@ tables[order(tables$feature_type, method = "radix"), , drop = FALSE] } +# Resource names amRdata registers its dataset manifests under, in the BiocFileCache +# every amR package shares. +.REGISTRY_PATTERN <- "^amR_dataset_manifest_" + +# Paths of the manifests amRdata registered. A cache that can't be opened is reported, not +# fatal, since `root` may still find ORBs. +.registryManifests <- function() { + tryCatch({ + bfc <- BiocFileCache::BiocFileCache(ask = FALSE) + hits <- BiocFileCache::bfcquery(bfc, query = .REGISTRY_PATTERN, field = "rname", exact = FALSE) + as.character(hits$rpath) + }, error = function(e) { + rlang::inform(c("Could not read the amRdata registry.", x = conditionMessage(e))) + character() + }) +} + +# Directories under `root` (and `root` itself) holding a manifest. Folders that can't be +# read are skipped with a warning, so an ORB in one isn't mistaken for absent. +.scanRoot <- function(root, call) { + if (!rlang::is_string(root) || !nzchar(root)) { + .amrAbort("invalid_argument", "`root` must be a single directory path.", call = call) + } + + if (!dir.exists(root)) { + .amrAbort("orb_dir_not_found", c("The root to search does not exist.", x = root), call = call) + } + + root <- normalizePath(root, mustWork = TRUE) + .readable <- function(dirs) file.access(dirs, 4) == 0 & file.access(dirs, 1) == 0 + + if (!.readable(root)) { + .amrAbort("orb_dir_unreadable", c("The root to search can't be read.", x = root), call = call) + } + + dirs <- list.dirs(root, full.names = TRUE, recursive = TRUE) + blocked <- dirs[!.readable(dirs)] + if (length(blocked)) { + rlang::warn(c( + paste0(length(blocked), " folder(s) under `root` can't be read, so ORBs in them are not listed."), + .bullets(utils::head(blocked, 5)) + )) + } + + readable <- setdiff(dirs, blocked) + has_manifest <- vapply(readable, function(dir) { + length(list.files(dir, pattern = .MANIFEST_PATTERN)) > 0L + }, logical(1)) + readable[has_manifest] +} + +# One row for an ORB directory: its newest usable manifest, or why it has none. +.orbRow <- function(dir) { + row <- function(usable, rule_id = NA_character_, dataset_id = NA_character_, + dataset_label = NA_character_, finished_at = NA_character_) { + tibble::tibble( + dataset_id = dataset_id, dataset_label = dataset_label, directory = dir, + finished_at = finished_at, usable = usable, rule_id = rule_id + ) + } + + if (!dir.exists(dir)) return(row(FALSE, "orb_dir_not_found")) + if (file.access(dir, 4) != 0 || file.access(dir, 1) != 0) return(row(FALSE, "orb_dir_unreadable")) + + paths <- list.files(dir, pattern = .MANIFEST_PATTERN, full.names = TRUE) + if (!length(paths)) return(row(FALSE, "manifest_not_found")) + + checked <- lapply(paths, .manifestReadiness) + usable <- !vapply(checked, inherits, logical(1), "amrml_error") + + if (!any(usable)) { + rule_id <- if (length(checked) == 1L) checked[[1]]$rule_id else "orb_no_usable_manifest" + return(row(FALSE, rule_id)) + } + + chosen <- .newestReady(checked[usable]) + row(TRUE, dataset_id = chosen$dataset_id, dataset_label = chosen$dataset_label, + finished_at = chosen$finished_at) +} + +#' List the ORBs available +#' +#' Finds amRdata ORBs the way `runDataProcessing()` finds its datasets: in the +#' BiocFileCache registry amRdata records each dataset's manifest in. If `root` is +#' given, the folders under it are searched too, which also finds ORBs that were +#' never registered. Nothing is read beyond the manifests, so listing is fast; an +#' ORB's parquet files are only checked by [readORB()]. +#' +#' A problem with one ORB is a row with `usable = FALSE` and its `rule_id`, so it +#' doesn't hide the others. A problem with `root` itself is an error, and folders +#' under `root` that can't be read are skipped with a warning. +#' +#' @param root A folder to search for ORBs, recursively, or `NULL` to use the registry +#' only. +#' +#' @return A tibble with one row per ORB directory, usable ones first and newest first: +#' `dataset_id`, `dataset_label`, `directory` (what [readORB()] takes), `finished_at`, +#' `usable`, `rule_id` (why it is not usable, otherwise `NA`) and `source` (`"registry"`, +#' `"root"` or `"both"`). +#' +#' @section Errors: +#' All errors have class `amrml_error`, plus one of: +#' +#' * `amrml_invalid_argument`: `root` is not a single directory path. +#' * `amrml_orb_dir_not_found`: `root` does not exist. +#' * `amrml_orb_dir_unreadable`: `root` can't be read. +#' +#' @examples +#' \dontrun{ +#' listORBs() +#' listORBs("path/to/amRdata/output") +#' } +#' @export +listORBs <- function(root = NULL) { + call <- rlang::current_env() + normalize <- function(x) unique(normalizePath(x, mustWork = FALSE)) + + registered <- normalize(dirname(.registryManifests())) + scanned <- if (is.null(root)) character() else normalize(.scanRoot(root, call)) + dirs <- union(registered, scanned) + + empty <- .orbRow("")[0, ] + orbs <- dplyr::bind_rows(empty, lapply(dirs, .orbRow)) + in_registry <- dirs %in% registered + orbs$source <- ifelse(in_registry, ifelse(dirs %in% scanned, "both", "registry"), "root") + + orbs[order(!orbs$usable, dplyr::desc(orbs$finished_at), orbs$directory, method = "radix"), ] +} + +# The ORB directory to read when `readORB()` gets no path: the registry's only usable +# ORB, or the user's pick from a menu. +.selectORB <- function(call) { + if (!rlang::is_interactive()) { + .amrAbort( + "invalid_argument", + "`path` must be supplied in non-interactive sessions.", + call = call + ) + } + + orbs <- listORBs() + orbs <- orbs[orbs$usable, , drop = FALSE] + + if (!nrow(orbs)) { + .amrAbort( + "no_orbs_found", + c("No usable ORB is registered.", i = "Run amRdata first, or supply `path`."), + call = call + ) + } + + if (nrow(orbs) == 1L) { + rlang::inform(paste0("Using ORB: ", orbs$dataset_label[[1]])) + return(orbs$directory[[1]]) + } + + pick <- utils::menu( + paste0(orbs$dataset_label, " [", orbs$dataset_id, "]"), + title = "Select an ORB to read:" + ) + + if (pick == 0L) { + .amrAbort("invalid_argument", "ORB selection cancelled.", call = call) + } + + orbs$directory[[pick]] +} + #' Read an amRdata ORB #' #' Validates the ORB in `path` and returns an object describing it. #' #' @details #' Uses the manifest whose `amRml_input` is ready and whose producer run -#' finished last, with a message if more than one is ready. The ORB must be -#' where that manifest says, with every declared file present at its recorded -#' size. If it is not, `readORB()` stops with an error; it never falls back to -#' an older manifest, which would read older data. Feature tables are the -#' declared parquet files with the columns `genome_id`, `value` and one feature -#' ID column such as `gene` or `Pfam`. +#' finished last, with a message if more than one is ready. Recorded file +#' paths are resolved by filename within the manifest's directory, so an ORB +#' can be moved between directories and platforms. Every declared file must be +#' present at its recorded size. Otherwise, `readORB()` stops with an error; +#' it never falls back to an older manifest, which would read older data. +#' Feature tables are the declared parquet files with the columns `genome_id`, +#' `value` and one feature ID column such as `gene` or `Pfam`. #' #' @section Errors: #' All errors have class `amrml_error`, plus one of: #' -#' * `amrml_invalid_argument`: `path` is not a single directory path. +#' * `amrml_invalid_argument`: `path` is not a single directory path, or is +#' missing in a non-interactive session. +#' * `amrml_no_orbs_found`: `path` is missing and no usable ORB is registered. #' * `amrml_orb_dir_not_found`: `path` does not exist. #' * `amrml_manifest_not_found`: the directory holds no `manifest_*.json`. #' * `amrml_orb_no_usable_manifest`: no manifest is usable. `observed` holds #' each manifest's error. -#' * `amrml_orb_moved`: the ORB is not where its manifest says it was written. #' * `amrml_orb_files_missing`: declared files are missing or unreadable. #' * `amrml_orb_file_changed`: a declared file's size has changed. #' * `amrml_parquet_unreadable`: a declared parquet cannot be read. @@ -307,9 +489,9 @@ #' #' @param path Character. The ORB directory: the folder amRdata wrote its #' output to, containing `manifest_*.json` (e.g. -#' `data/Staphylococcus_argenteus`), not its parent. +#' `data/Staphylococcus_argenteus/orb`), not its parent. #' -#' @return An `amr_orb` list: `dataset_id`, `label` (what amRdata was asked for, +#' @return An `amr_orb` list: `dataset_id`, `dataset_label` (what amRdata was asked for, #' species names or taxon IDs, otherwise `dataset_id`), `directory`, #' `manifest_path`, `metadata_parquet`, `producer`, `producer_run_id`, #' `finished_at`, `files` (the producer run's declared outputs) and @@ -317,13 +499,16 @@ #' #' @examples #' \dontrun{ -#' orb <- readORB("path/to/amRdata/output") +#' orb <- readORB("path/to/amRdata/output/orb") #' orb$feature_tables #' } #' @export -readORB <- function(path) { +readORB <- function(path = NULL) { call <- rlang::current_env() + # No path: choose from the registered ORBs, as amRdata does for its datasets. + if (is.null(path)) path <- .selectORB(call) + # Check the path is a single existing directory. if (missing(path) || !rlang::is_string(path) || !nzchar(path)) { .amrAbort("invalid_argument", "`path` must be a single ORB directory path.", call = call) @@ -379,8 +564,8 @@ readORB <- function(path) { )) } - # Check the ORB hasn't moved and its files exist at their recorded size. - .checkOrbFiles(chosen, dir, call = call) + # Check that the ORB files exist at their recorded size. + .checkOrbFiles(chosen, call = call) # Find the feature tables among the declared files. feature_tables <- .featureTables(chosen$files, call = call) @@ -395,7 +580,7 @@ readORB <- function(path) { #' @export print.amr_orb <- function(x, ...) { - cat("", x$dataset_id, "-", x$label, "\n") + cat("", x$dataset_id, "-", x$dataset_label, "\n") cat(" directory :", x$directory, "\n") cat(" manifest :", basename(x$manifest_path), "\n") cat(" finished :", x$finished_at, "\n") diff --git a/R/registry.R b/R/registry.R new file mode 100644 index 0000000..6b9140e --- /dev/null +++ b/R/registry.R @@ -0,0 +1,47 @@ +# The registry of what amRml can model: the strata, and the modeling modes. + +# Strata, as amRml names them, and the genome-level amRdata column holding each. +.STRATA <- c(year = "year_bin", country = "country_abbr") + +# The modeling modes of the amRml v1 design. `grouping` is what a mode splits genomes +# by: a stratum, drugs, or nothing. +.MODES <- tibble::tribble( + ~mode_id, ~grouping, ~LOO, ~cross_test, ~supported, + ~description, + "vanilla", "none", FALSE, FALSE, TRUE, + "Each drug or class, with internal cross-validation.", + "stratified_year", "year", FALSE, FALSE, TRUE, + "Each drug or class within each year bin.", + "stratified_country", "country", FALSE, FALSE, TRUE, + "Each drug or class within each country.", + "cross_year", "year", FALSE, TRUE, TRUE, + "Trained on one year bin, tested on another.", + "cross_country", "country", FALSE, TRUE, TRUE, + "Trained on one country, tested on another.", + "cross_drug", "drug", FALSE, TRUE, TRUE, + "Trained on one drug, tested on another drug's other genomes.", + "loto", "year", TRUE, FALSE, TRUE, + "Trained on all year bins but one, tested on the held-out bin.", + "logo", "country", TRUE, FALSE, TRUE, + "Trained on all countries but one, tested on the held-out country.", + "lodo", "drug", TRUE, FALSE, FALSE, + "Trained on all drugs but one, tested on the held-out drug." +) + +#' Modeling modes +#' +#' The kinds of model amRml can build, from the amRml v1 design. `LOO` modes +#' train on every group but one and test on the held-out group; `cross_test` +#' modes train on one group and test on another. Modes with `supported = FALSE` +#' can't run yet. +#' +#' @return A tibble with one row per mode: `mode_id`, `grouping` (`"none"`, +#' `"year"`, `"country"` or `"drug"`), `LOO`, `cross_test`, `supported` and +#' `description`. +#' +#' @examples +#' modelingModes() +#' @export +modelingModes <- function() { + .MODES +} diff --git a/R/rescore.R b/R/rescore.R new file mode 100644 index 0000000..3470648 --- /dev/null +++ b/R/rescore.R @@ -0,0 +1,100 @@ +# Running feature rescoring (R/feature-rescoring.R) on a fit, from its merged results and the ORB. + +#' Rescore features +#' +#' Runs feature rescoring ([runFeatureDyadDiscovery()]) on a fit: its vanilla +#' models' merged results, from [exportMergedResults()], and the ORB's +#' virtual `dyad_feature` relation. Feature rescoring needs real and shuffled +#' labels and several seeds, e.g. +#' from `runModelingWorkflow(orb_dir, modes = "vanilla", seeds = c(31, 79, 51), +#' labels = c("real", "shuffled"))`. +#' +#' @param fit An `amr_fit` from [fitModels()] or [runModelingWorkflow()]. +#' @param ... Feature rescoring's thresholds, passed to [runFeatureDyadDiscovery()]. +#' +#' @return The `feature_dyad_discovery` list from [runFeatureDyadDiscovery()]. +#' +#' @section Errors: +#' Invalid input and missing ORB mappings raise `amrml_invalid_argument`. +#' DuckDB read errors retain their DBI/driver error classes. +#' +#' @examples +#' \dontrun{ +#' fit <- runModelingWorkflow("path/to/ORB", +#' modes = "vanilla", seeds = c(31, 79, 51), labels = c("real", "shuffled") +#' ) +#' rescored <- rescoreFeatures(fit) +#' rescored$features$top +#' } +#' @export +rescoreFeatures <- function(fit, ...) { + call <- rlang::current_env() + .checkArgClass(fit, "fit", "amr_fit", "fitModels()", call = call) + + modes <- .taskModes(fit$tasks, fit$built$matrices) + vanilla <- fit$tasks[modes %in% "vanilla" & fit$tasks$status == "fitted", ] + if (!all(c("real", "shuffled") %in% vanilla$labels)) { + .amrAbort( + "invalid_argument", + c( + "Feature rescoring needs fitted vanilla models with both real and shuffled labels.", + i = paste0( + "Run e.g. `runModelingWorkflow(orb_dir, modes = \"vanilla\", ", + "seeds = c(31, 79, 51), labels = c(\"real\", \"shuffled\"))`." + ) + ), + call = call + ) + } + + # Complete any merged-result export before changing into the ORB directory + merged <- file.path( + fit$built$out_dir, "merged", c("all_perf.parquet", "all_top_features.parquet") + ) + if (!all(file.exists(merged))) { + exportMergedResults(fit, overwrite = TRUE) + } + + # Locate the ORB + orb_files <- fit$built$eligibility$profile$orb$files$path + orb_dirs <- unique(dirname(orb_files)) + orb_databases <- unique(unlist(lapply(orb_dirs, function(dir) { + list.files(dir, pattern = "_parquet[.]duckdb$", full.names = TRUE) + }), use.names = FALSE)) + + if (length(orb_databases) != 1L) { + .amrAbort( + "invalid_argument", + "Expected exactly one Parquet-backed ORB DuckDB with a virtual `dyad_feature` view.", + call = call + ) + } + + # Virtual Parquet paths are relative to the ORB directory; restore caller's + # working directory after database disconnect + previous_wd <- getwd() + on.exit(setwd(previous_wd), add = TRUE) + setwd(dirname(orb_databases[[1L]])) + con <- DBI::dbConnect( + duckdb::duckdb(), + dbdir = basename(orb_databases[[1L]]), + read_only = TRUE + ) + on.exit(DBI::dbDisconnect(con), add = TRUE) + + if (!"dyad_feature" %in% DBI::dbListTables(con) || + !all(c("dyad", "feature") %in% DBI::dbListFields(con, "dyad_feature"))) { + .amrAbort( + "invalid_argument", + "ORB DuckDB must expose the virtual `dyad_feature(dyad, feature)` relation.", + call = call + ) + } + + runFeatureDyadDiscovery( + all_top_features_parquet = merged[[2]], + all_performance_parquet = merged[[1]], + dyad_con = con, + ... + ) +} diff --git a/R/tasks.R b/R/tasks.R new file mode 100644 index 0000000..a50bb53 --- /dev/null +++ b/R/tasks.R @@ -0,0 +1,77 @@ +# Expanding built matrices into the tasks to fit. + +#' List the tasks to fit +#' +#' Lists every model to fit, before any is fitted: one task per built matrix, +#' label kind and seed. Shuffled tasks are the no-signal baseline: asked for, +#' they're added for every model. As in old amRml, their labels are shuffled +#' before the split, so their test genomes differ from their real twin's. More +#' seeds repeat every model with a different split. +#' +#' @param built An `amr_matrices` from [buildMatrices()]. +#' @param seeds Seeds; each gives every model its own split and folds. +#' @param labels `"real"` (the default, as in old amRml's standard run), +#' `"shuffled"`, or both. +#' +#' @return An `amr_tasks` list: +#' * `built`: the built matrices the tasks use. +#' * `settings`: the `seeds` and `labels` asked for. +#' * `tasks`: one row per task: `task_id`, `matrix_id`, `labels`, `seed`, and +#' the `n_fold` and `holdout` from eligibility's settings. +#' +#' @section Errors: +#' All errors have class `amrml_error`, plus `amrml_invalid_argument`: `built` +#' is not from [buildMatrices()], `seeds` are not distinct whole numbers, or +#' `labels` are not `"real"` and/or `"shuffled"`. +#' +#' @examples +#' \dontrun{ +#' tasks <- expandTasks(buildMatrices(plan, "path/to/output"), seeds = c(31, 79, 51)) +#' tasks$tasks +#' } +#' @export +expandTasks <- function(built, seeds = 123L, labels = "real") { + call <- rlang::current_env() + .checkArgClass(built, "built", "amr_matrices", "buildMatrices()", call = call) + .checkArgSeeds(seeds, call = call) + .checkArgLabels(labels, call = call) + + matrix_ids <- built$matrices$matrix_id[built$matrices$status == "built"] + tasks <- expand.grid( + labels = labels, seed = as.integer(seeds), matrix_id = matrix_ids, + stringsAsFactors = FALSE + ) + settings <- built$eligibility$settings + + tasks <- tibble::tibble( + task_id = paste(tasks$matrix_id, tasks$labels, tasks$seed, sep = "__"), + matrix_id = tasks$matrix_id, + labels = tasks$labels, + seed = tasks$seed, + n_fold = as.integer(settings$n_fold), + holdout = settings$holdout + ) + + structure( + list(built = built, settings = list(seeds = as.integer(seeds), labels = labels), tasks = tasks), + class = "amr_tasks" + ) +} + + +#' @export +print.amr_tasks <- function(x, ...) { + orb <- x$built$eligibility$profile$orb + t <- x$tasks + modes <- .taskModes(t, x$built$matrices) + n <- table(factor(modes, unique(modes))) + + cat("", orb$dataset_id, "-", orb$dataset_label, "\n") + cat( + " ", nrow(t), " tasks: ", dplyr::n_distinct(t$matrix_id), " matrices x ", + dplyr::n_distinct(t$labels), " label kinds x ", dplyr::n_distinct(t$seed), " seeds\n", + sep = "" + ) + cat(.modeLines(names(n), sprintf("%d tasks", n)), sep = "\n") + invisible(x) +} diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..e4a90a3 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,18 @@ +# Helpers shared by more than one file. + +# One "mode : label" line per mode, with the modes padded to one width. +.modeLines <- function(modes, labels) { + paste0(" ", format(modes), " : ", labels, recycle0 = TRUE) +} + +# A new run folder in the ORB's amRml/ folder, named by the time, and announced. +.defaultOutDir <- function(orb_dir) { + out_dir <- file.path(orb_dir, "amRml", format(Sys.time(), "%Y-%m-%d_%H%M%S")) + rlang::inform(paste0("Writing to ", out_dir)) + out_dir +} + +# Each task's mode, looked up through its matrix. +.taskModes <- function(tasks, matrices) { + matrices$mode_id[match(tasks$matrix_id, matrices$matrix_id)] +} diff --git a/R/workflow.R b/R/workflow.R new file mode 100644 index 0000000..958fc60 --- /dev/null +++ b/R/workflow.R @@ -0,0 +1,123 @@ +# The single entry point: every stage, from the ORB to fitted models. + +#' Run the modeling workflow +#' +#' Runs every stage on an ORB: [readORB()], [profileORB()], [eligibleScopes()], +#' [planMatrices()], [buildMatrices()], [expandTasks()] and [fitModels()]. Each +#' can also be called on its own. By default every task is fitted on both the real +#' and the shuffled labels; `labels = "real"` skips the shuffled controls. +#' +#' @details +#' Everything goes to `out_dir`: `eligibility.parquet`, `matrices.parquet`, +#' `features/`, `matrix_index.rds`, `workflow.rds`, `tasks.parquet`, `run.json`, +#' `results/` (including `results/models/` when `save_fits = TRUE`), and `merged/` from +#' [exportMergedResults()]. amRdata's files are only read. +#' +#' @param orb_dir An amRdata ORB directory. +#' @param out_dir Folder to write to. By default a new run folder, +#' `/amRml//`. +#' @param modes Mode IDs from [modelingModes()], or `NULL` for all of them. +#' @param feature_types Feature types to model: `"quick"`, `"standard"` (default), +#' `"full"`, or an explicit character vector of ORB feature types. +#' Selected before matrices are planned or built; see [planMatrices()]. +#' @param seeds Passed to [expandTasks()]. +#' @param labels `"real"`, `"shuffled"` or both (the default), passed to +#' [expandTasks()]. +#' @param save_fits Passed to [fitModels()]. Must match when resuming. +#' @param min_genomes,n_fold,min_test_genomes,min_test_minority Passed to +#' [eligibleScopes()]. +#' @param overwrite Replace an earlier run's matrices and results in `out_dir`; +#' if `FALSE`, an `out_dir` holding earlier output is refused. The default run +#' folder is always new. +#' @param resume Resume interrupted model fitting in an existing `out_dir`, +#' using its saved matrices and completed task groups, or reopen unchanged +#' completed results. Supply the same modeling arguments and the exact run +#' folder (e.g. `/amRml//`); `BPPARAM` may be changed. +#' `overwrite` must be `FALSE`. +#' @param BPPARAM Passed to [fitModels()]. May be changed when resuming. +#' @param reuse_fits Passed to [fitModels()]; reuse compatible cross-drug fits. +#' +#' @return The `amr_fit` from [fitModels()]; every earlier stage's result can be +#' reached from it (`$built`, `$built$eligibility`, ...). +#' +#' @section Errors: +#' Errors from any stage, including `amrml_invalid_argument` for mismatched resume +#' settings, propagate to the caller. +#' +#' @examples +#' \dontrun{ +#' fit <- runModelingWorkflow("path/to/amRdata/output", "path/to/output") +#' fit$performance +#' } +#' @export +runModelingWorkflow <- function(orb_dir, + out_dir = NULL, + modes = NULL, + seeds = 123L, + labels = c("real", "shuffled"), + save_fits = TRUE, + BPPARAM = BiocParallel::bpparam(), + min_genomes = 40, + n_fold = 5, + min_test_genomes = 5, + min_test_minority = 2, + overwrite = FALSE, + reuse_fits = TRUE, + feature_types = "standard", + resume = FALSE) { + call <- rlang::current_env() + # Checked first, so a bad value doesn't surface after the matrices are built. + .checkArgSeeds(seeds, call = call) + .checkArgLabels(labels, call = call) + .checkArgFlag(overwrite, "overwrite", call = call) + .checkArgClass(BPPARAM, "BPPARAM", "BiocParallelParam", "BiocParallel", call = call) + .checkArgFlag(reuse_fits, "reuse_fits", call = call) + .checkArgFlag(resume, "resume", call = call) + .checkArgFlag(save_fits, "save_fits", call = call) + if (resume && (is.null(out_dir) || overwrite)) { + .amrAbort("invalid_argument", "Resuming requires `out_dir` and `overwrite = FALSE`.", call = call) + } + + settings <- list( + orb_dir = normalizePath(orb_dir, winslash = "/", mustWork = TRUE), + modes = modes, seeds = as.integer(seeds), labels = labels, + min_genomes = min_genomes, n_fold = n_fold, + min_test_genomes = min_test_genomes, min_test_minority = min_test_minority, + reuse_fits = reuse_fits, feature_types = feature_types, save_fits = save_fits + ) + if (resume) { + snapshot <- file.path(out_dir, "workflow.rds") + if (!file.exists(snapshot)) { + .amrAbort("invalid_argument", "No saved workflow state was found; this run cannot be resumed.", call = call) + } + saved <- readRDS(snapshot) + if (!identical(saved$settings, settings) || + !identical(normalizePath(saved$built$out_dir, winslash = "/", mustWork = TRUE), + normalizePath(out_dir, winslash = "/", mustWork = TRUE))) { + .amrAbort("invalid_argument", "The saved workflow does not match these arguments or output directory.", call = call) + } + built <- saved$built + } else { + orb <- readORB(orb_dir) + out_dir <- out_dir %||% .defaultOutDir(orb$directory) + eligibility <- eligibleScopes( + profileORB(orb), modes = modes, min_genomes = min_genomes, n_fold = n_fold, + min_test_genomes = min_test_genomes, min_test_minority = min_test_minority + ) + built <- buildMatrices(planMatrices(eligibility, feature_types = feature_types), + out_dir, overwrite = overwrite) + out_dir <- built$out_dir + arrow::write_parquet(eligibility$scopes, file.path(out_dir, "eligibility.parquet")) + # Save the original task inputs so an interrupted run can be resumed without + # rebuilding matrices or reassigning its genome splits. + .saveFitCheckpoint(list(settings = settings, built = built), file.path(out_dir, "workflow.rds")) + } + + fit <- fitModels( + expandTasks(built, seeds = seeds, labels = labels), + save_fits = save_fits, + overwrite = overwrite, BPPARAM = BPPARAM, reuse_fits = reuse_fits, resume = resume + ) + exportMergedResults(fit, overwrite = overwrite || resume) + fit +} diff --git a/man/assessModelReliability.Rd b/man/assessModelReliability.Rd new file mode 100644 index 0000000..ca925eb --- /dev/null +++ b/man/assessModelReliability.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{assessModelReliability} +\alias{assessModelReliability} +\title{Assess model reliability using real-label and shuffled-label MCC} +\usage{ +assessModelReliability(all_performance_parquet, min_supported_seeds = 2L) +} +\arguments{ +\item{all_performance_parquet}{Path to the merged model-performance Parquet file.} + +\item{min_supported_seeds}{Number of supporting seeds required (default 2).} +} +\value{ +List with reliability results by representation and MCC comparisons +by seed. Missing MCC values are not replaced with zero. +} +\description{ +Compare each model's real-label MCC with the shuffled-label MCC from the +same seed and with the average shuffled MCC plus one standard deviation (SD) +for the same drug, feature type, and encoding. A seed supports the model only +when its real-label MCC is positive and exceeds both comparisons. +At least two defined shuffled MCC values are needed to calculate the SD. +} diff --git a/man/buildMatrices.Rd b/man/buildMatrices.Rd new file mode 100644 index 0000000..2083a49 --- /dev/null +++ b/man/buildMatrices.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate-matrices.R +\name{buildMatrices} +\alias{buildMatrices} +\title{Build the planned matrices} +\usage{ +buildMatrices(plan, out_dir = NULL, overwrite = FALSE) +} +\arguments{ +\item{plan}{An \code{amr_matrix_plan} from \code{\link[=planMatrices]{planMatrices()}}.} + +\item{out_dir}{Folder to write to, created if needed.} + +\item{overwrite}{Replace matrices already in \code{out_dir}.} +} +\value{ +An \code{amr_matrices} list: \code{eligibility}, \code{out_dir}, \code{matrices}, and +\code{storage = "shared_sparse"}. The \code{file} column points to a shared feature +store rather than a scope-specific Parquet file. \code{matrix_index.rds} records +membership rows and selected feature column indices per matrix +} +\description{ +Writes each sparse count matrix per feature type in \verb{features/}. +Binary encoding and scope-specific feature selection are indexed without +materializing matrices for speed. amRdata's files in the ORB are only read. +} +\section{Errors}{ + +All errors have class \code{amrml_error}, plus one of: +\itemize{ +\item \code{amrml_invalid_argument}: invalid \code{plan}/\code{out_dir}, or output exists without overwrite. +\item \code{amrml_feature_rows_repeated}: duplicate genome/feature pairs. +\item \code{amrml_feature_values_invalid}: missing, nonfinite, or negative feature values. +} +} + diff --git a/man/eligibleScopes.Rd b/man/eligibleScopes.Rd new file mode 100644 index 0000000..ecc53c8 --- /dev/null +++ b/man/eligibleScopes.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/eligibility.R +\name{eligibleScopes} +\alias{eligibleScopes} +\title{Decide what can be modeled} +\usage{ +eligibleScopes( + profile, + modes = NULL, + min_genomes = 40, + n_fold = 5, + min_test_genomes = 5, + min_test_minority = 2 +) +} +\arguments{ +\item{profile}{An \code{amr_orb_profile} from \code{\link[=profileORB]{profileORB()}}.} + +\item{modes}{Mode IDs from \code{\link[=modelingModes]{modelingModes()}}, or \code{NULL} for all of them.} + +\item{min_genomes}{Fewest genomes a scope needs, before any holdout.} + +\item{n_fold}{Number of cross-validation folds.} + +\item{min_test_genomes}{Fewest genomes a separate test set needs.} + +\item{min_test_minority}{Fewest of the rarer phenotype a test set needs.} +} +\value{ +An \code{amr_eligibility} list: +\itemize{ +\item \code{profile} and \code{settings} (the thresholds, and the \code{holdout} share). +\item \code{modes}: per mode, \code{feasible}, \code{rule_id}, \code{n_groups}, and how many +scopes it has and how many are eligible (\code{n_scopes}, \code{n_eligible}). +\item \code{scopes}: per scope, training and test counts (\code{NA} without a test set), +\code{eligible} and \code{rule_id}. +\item \code{members}: each eligible scope's genomes, by \code{role} (train or test). +} +} +\description{ +Compares the modeling modes with a profiled ORB. For each mode, records +whether it can run on this ORB at all; for each drug or class in a mode that +can, records whether it has enough data to model, or why not. Nothing is +built or fitted. +} +\details{ +Counts are of genomes, each with one phenotype. A drug or class needs 2 of a +mode's groups (3 for leave-one-out) to get scopes, and a stratified one needs +2 eligible groups. A scope fails, in order, if it's a class with data for only +one of its drugs, has one phenotype, has fewer than \code{min_genomes} genomes, +can't fill \code{n_fold} folds with its rarer phenotype (after a 20\% holdout when +there's no test set), or has too small a test set. +} +\section{Errors}{ + +All errors have class \code{amrml_error}, plus \code{amrml_invalid_argument}: +\code{profile} is not from \code{\link[=profileORB]{profileORB()}}, \code{modes} names an unknown mode, or a +threshold is not a finite whole number of at least 1 (2 for \code{n_fold}). +} + +\examples{ +\dontrun{ +eligibility <- eligibleScopes(profileORB(readORB("path/to/amRdata/output"))) +eligibility$scopes +} +} diff --git a/man/expandTasks.Rd b/man/expandTasks.Rd new file mode 100644 index 0000000..fcd8bb6 --- /dev/null +++ b/man/expandTasks.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tasks.R +\name{expandTasks} +\alias{expandTasks} +\title{List the tasks to fit} +\usage{ +expandTasks(built, seeds = 123L, labels = "real") +} +\arguments{ +\item{built}{An \code{amr_matrices} from \code{\link[=buildMatrices]{buildMatrices()}}.} + +\item{seeds}{Seeds; each gives every model its own split and folds.} + +\item{labels}{\code{"real"} (the default, as in old amRml's standard run), +\code{"shuffled"}, or both.} +} +\value{ +An \code{amr_tasks} list: +\itemize{ +\item \code{built}: the built matrices the tasks use. +\item \code{settings}: the \code{seeds} and \code{labels} asked for. +\item \code{tasks}: one row per task: \code{task_id}, \code{matrix_id}, \code{labels}, \code{seed}, and +the \code{n_fold} and \code{holdout} from eligibility's settings. +} +} +\description{ +Lists every model to fit, before any is fitted: one task per built matrix, +label kind and seed. Shuffled tasks are the no-signal baseline: asked for, +they're added for every model. As in old amRml, their labels are shuffled +before the split, so their test genomes differ from their real twin's. More +seeds repeat every model with a different split. +} +\section{Errors}{ + +All errors have class \code{amrml_error}, plus \code{amrml_invalid_argument}: \code{built} +is not from \code{\link[=buildMatrices]{buildMatrices()}}, \code{seeds} are not distinct whole numbers, or +\code{labels} are not \code{"real"} and/or \code{"shuffled"}. +} + +\examples{ +\dontrun{ +tasks <- expandTasks(buildMatrices(plan, "path/to/output"), seeds = c(31, 79, 51)) +tasks$tasks +} +} diff --git a/man/exportMergedResults.Rd b/man/exportMergedResults.Rd new file mode 100644 index 0000000..b64384d --- /dev/null +++ b/man/exportMergedResults.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/export.R +\name{exportMergedResults} +\alias{exportMergedResults} +\title{Export results in old amRml's merged format} +\usage{ +exportMergedResults(fit, overwrite = FALSE) +} +\arguments{ +\item{fit}{An \code{amr_fit} from \code{\link[=fitModels]{fitModels()}}.} + +\item{overwrite}{Replace files already in the output folder's \verb{merged/}.} +} +\value{ +The written paths, invisibly; the files are in \verb{/merged/}. +} +\description{ +Writes a fit's performance and top features as the merged tables old amRml's +\code{mergeMLresults()} produced, one file per mode, with its file names and +columns: \code{all_perf.parquet} and \code{all_top_features.parquet} for vanilla, +\code{year_perf.parquet}, \code{cross_drug_perf.parquet}, \code{LOO_year_perf.parquet} and +so on. Metadata comes from the tasks rather than file names, and every file +has \code{shuffled} and an integer \code{seed}. This export is temporary: it bridges to +old amRml's format until amRml's own column names match it. +} +\details{ +Left out: old amRml's \code{filename}, \code{train_prop}, \code{val_prop} and +\code{prop_vi_top_feats} bounds, and this package's added columns (\code{task_id}, +\code{auprc}), which stay in \verb{results/}. +} +\section{Errors}{ + +All errors have class \code{amrml_error}, plus \code{amrml_invalid_argument}: \code{fit} +is not from \code{\link[=fitModels]{fitModels()}}, or \verb{merged/} already has files and \code{overwrite} is +\code{FALSE}. +} + +\examples{ +\dontrun{ +exportMergedResults(fitModels(tasks)) +} +} diff --git a/man/exportNetwork.Rd b/man/exportNetwork.Rd new file mode 100644 index 0000000..c7d2df8 --- /dev/null +++ b/man/exportNetwork.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/network.R +\name{exportNetwork} +\alias{exportNetwork} +\title{Export MAGIC gene-protein cluster networks for amRviz} +\usage{ +exportNetwork(run_dir, orb_dir, out_dir, core_threshold = 0.75) +} +\arguments{ +\item{run_dir}{Completed modeling run with tasks.parquet, matrices.parquet, +results/performance.parquet, results/importance.parquet, and predictions.} + +\item{orb_dir}{Parquet-backed ORB with cluster dyads, protein_members, and annotation +views. Opened read-only.} + +\item{out_dir}{Output directory outside the modeling run and ORB.} + +\item{core_threshold}{Share of returned coefficient importance for the core.} +} +\value{ +Invisibly, a list containing the per-target summary and output directory. +} +\description{ +Build a fixed ORB cluster-pair graph with real and shuffled feature evidence, +model reliability, and separate connected functional annotations. Does not +refit models. Gene and protein models already use cluster predictors; +protein cluster IDs are named by CD-HIT representatives. Functional +annotations do not increase either endpoint's feature score. +} +\details{ +Undefined MCC is provisionally replaced by zero only when the saved +predictions show constant class predictions and both true classes in the +test set. The raw modeling performance Parquet remains unchanged. Model +reliability is assessed by \code{assessModelReliability()}. Candidate-aware direct +feature scores are not approximated from the matrix-wide feature count; +node tables here report observed returned-coefficient evidence instead. +Writes Parquet evidence tables only. Does not create review or Cytoscape CSVs. +} diff --git a/man/filterOptimalModel.Rd b/man/filterOptimalModel.Rd new file mode 100644 index 0000000..50a8227 --- /dev/null +++ b/man/filterOptimalModel.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{filterOptimalModel} +\alias{filterOptimalModel} +\title{Filter model fits to those passing quality thresholds} +\usage{ +filterOptimalModel( + all_performance_parquet, + MCC_threshold = NULL, + compare_to_shuffled = TRUE +) +} +\arguments{ +\item{all_performance_parquet}{The path to the 'all performance parquet' file} + +\item{MCC_threshold}{The minimum non-shuffled MCC required to keep a model fit (default is \code{NULL}, no filtering)} + +\item{compare_to_shuffled}{Logical indicating whether to require the non-shuffled MCC to exceed (outperform) the shuffled-label MCC for the same fit (default is \code{TRUE}). A fit with no shuffled counterpart (\code{shuffled_MCC} is \code{NA} after pivoting) always passes this check regardless.} +} +\value{ +a tibble of model fits (one row per species, drug_label, drug_or_class, seed, feature_type, feature_subtype, model, fit_penalty, fit_mixture) that pass the requested quality thresholds, with \code{nonshuffled_MCC}, \code{shuffled_MCC}, and \code{MCC_diff} columns added. This does not pick a single "best" fit per group; it filters out fits that fail the MCC/shuffled-comparison criteria, so multiple passing fits per group can remain. +} +\description{ +Filter model fits to those passing quality thresholds +} +\examples{ +\dontrun{ +filterOptimalModel(all_performance_parquet = "inst/extdata/all_perf.parquet") +} +} +\keyword{internal} diff --git a/man/fitModels.Rd b/man/fitModels.Rd new file mode 100644 index 0000000..54f451c --- /dev/null +++ b/man/fitModels.Rd @@ -0,0 +1,77 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fit-execution.R +\name{fitModels} +\alias{fitModels} +\title{Fit the listed models} +\usage{ +fitModels( + tasks, + save_fits = TRUE, + BPPARAM = BiocParallel::bpparam(), + overwrite = FALSE, + reuse_fits = TRUE, + resume = FALSE +) +} +\arguments{ +\item{tasks}{An \code{amr_tasks} from \code{\link[=expandTasks]{expandTasks()}}.} + +\item{save_fits}{Save each fitted model to \verb{results/models/.rds}: +the fitted workflow (\code{fit}) and the \code{features} its predictors \code{x1}, \code{x2}, +... stand for. +Must match the interrupted run when resuming.} + +\item{BPPARAM}{A \code{BiocParallelParam}, e.g. \code{BiocParallel::MulticoreParam(4)}, +or \code{BiocParallel::SerialParam()} to fit one task at a time.} + +\item{overwrite}{Replace results already in the output folder.} + +\item{reuse_fits}{Reuse fitted models among compatible cross-drug tasks.} + +\item{resume}{Reuse saved task groups from an interrupted fit or reopen an +unchanged completed fit. The task plan, matrix files and \code{reuse_fits} +setting must match the original run. +\code{save_fits} must also match.} +} +\value{ +An \code{amr_fit} list, also written to the output folder: \code{tasks} (with +\code{status}, \code{rule_id} and \code{message}; \code{tasks.parquet}), \code{performance}, +\code{importance} and \code{predictions} (\verb{results/}), and the \code{built} matrices. In +\code{importance}, \code{Sign} "POS" points to Susceptible and "NEG" to Resistant. The +run's settings and task counts go to \code{run.json}. +} +\description{ +Fits tasks from \code{\link[=expandTasks]{expandTasks()}} in parallel with old amRml's method: +glmnet logistic regression over 10 penalties and 6 mixtures, tuned by +stratified \code{n_fold} cross-validation and chosen by MCC, then scored on the +task's test genomes. +} +\details{ +Cross-drug tasks with exactly matching training inputs reuse one fitted model; +set \code{reuse_fits = FALSE} to disable reuse for comparison. Reused tasks' +\code{run_time_sec} excludes shared training time for follower tasks; the first +task in a group includes the training cost. +Each completed task group is saved in \verb{fit-checkpoints/} so it can be reused +after an interruption. Checkpoints are removed after results are written. +Use \code{resume = TRUE} with the same tasks and output directory to reuse them. +Each task runs under its own seed. A task that errors is recorded as +\code{fit_failed}, and one with undefined metrics as \code{metrics_undefined}; the rest +carry on. A shuffled task permutes the training matrix's labels before the +split. + +Completed results can also be reopened with \code{resume = TRUE} without fitting +again. Version 1 checkpoints require the original implementation or a fresh +run in another output directory. +} +\section{Errors}{ + +Invalid arguments or incompatible resume inputs raise \code{amrml_invalid_argument}. +File and checkpoint errors stop the run without removing completed checkpoints. +} + +\examples{ +\dontrun{ +fit <- fitModels(expandTasks(built)) +fit$performance +} +} diff --git a/man/listORBs.Rd b/man/listORBs.Rd new file mode 100644 index 0000000..81c17e3 --- /dev/null +++ b/man/listORBs.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/orb-read.R +\name{listORBs} +\alias{listORBs} +\title{List the ORBs available} +\usage{ +listORBs(root = NULL) +} +\arguments{ +\item{root}{A folder to search for ORBs, recursively, or \code{NULL} to use the registry +only.} +} +\value{ +A tibble with one row per ORB directory, usable ones first and newest first: +\code{dataset_id}, \code{dataset_label}, \code{directory} (what \code{\link[=readORB]{readORB()}} takes), \code{finished_at}, +\code{usable}, \code{rule_id} (why it is not usable, otherwise \code{NA}) and \code{source} (\code{"registry"}, +\code{"root"} or \code{"both"}). +} +\description{ +Finds amRdata ORBs the way \code{runDataProcessing()} finds its datasets: in the +BiocFileCache registry amRdata records each dataset's manifest in. If \code{root} is +given, the folders under it are searched too, which also finds ORBs that were +never registered. Nothing is read beyond the manifests, so listing is fast; an +ORB's parquet files are only checked by \code{\link[=readORB]{readORB()}}. +} +\details{ +A problem with one ORB is a row with \code{usable = FALSE} and its \code{rule_id}, so it +doesn't hide the others. A problem with \code{root} itself is an error, and folders +under \code{root} that can't be read are skipped with a warning. +} +\section{Errors}{ + +All errors have class \code{amrml_error}, plus one of: +\itemize{ +\item \code{amrml_invalid_argument}: \code{root} is not a single directory path. +\item \code{amrml_orb_dir_not_found}: \code{root} does not exist. +\item \code{amrml_orb_dir_unreadable}: \code{root} can't be read. +} +} + +\examples{ +\dontrun{ +listORBs() +listORBs("path/to/amRdata/output") +} +} diff --git a/man/modelingModes.Rd b/man/modelingModes.Rd new file mode 100644 index 0000000..2cff08d --- /dev/null +++ b/man/modelingModes.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/registry.R +\name{modelingModes} +\alias{modelingModes} +\title{Modeling modes} +\usage{ +modelingModes() +} +\value{ +A tibble with one row per mode: \code{mode_id}, \code{grouping} (\code{"none"}, +\code{"year"}, \code{"country"} or \code{"drug"}), \code{LOO}, \code{cross_test}, \code{supported} and +\code{description}. +} +\description{ +The kinds of model amRml can build, from the amRml v1 design. \code{LOO} modes +train on every group but one and test on the held-out group; \code{cross_test} +modes train on one group and test on another. Modes with \code{supported = FALSE} +can't run yet. +} +\examples{ +modelingModes() +} diff --git a/man/planMatrices.Rd b/man/planMatrices.Rd new file mode 100644 index 0000000..d031a69 --- /dev/null +++ b/man/planMatrices.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate-matrices.R +\name{planMatrices} +\alias{planMatrices} +\title{Plan the matrices to build} +\usage{ +planMatrices(eligibility, modes = NULL, feature_types = "standard") +} +\arguments{ +\item{eligibility}{An \code{amr_eligibility} from \code{\link[=eligibleScopes]{eligibleScopes()}}.} + +\item{modes}{Mode IDs from \code{\link[=modelingModes]{modelingModes()}} to plan matrices for, or \code{NULL} for +every mode in \code{eligibility}.} + +\item{feature_types}{A preset (\code{"quick"}, \code{"standard"}, or \code{"full"}) or an +explicit character vector of feature types. Default \code{"standard"}. +Quick uses gene, protein, and Pfam; Standard also includes COG and +AMRFinder; Full additionally includes struct and DefenseCas. Presets use +only tables present in the ORB. Explicit selections require exact names.} +} +\value{ +An \code{amr_matrix_plan} list: +\itemize{ +\item \code{eligibility}: the eligibility used, with \code{members} limited to \code{modes}. +\item \code{matrices}: one row per matrix: \code{matrix_id}, the scope (\code{mode_id}, \code{unit}, +\code{target}, \code{train_group}, \code{test_group}), \code{feature_type}, \code{encoding}, and +the scope's \code{n_train} and \code{n_test} genomes (\code{NA} without a test set). +} +} +\description{ +Lists every matrix the eligible scopes need, before any is built: one per +eligible scope, selected feature type and encoding. Each feature type is +encoded as binary, and also as counts when its table has values above 1. +Feature types are selected before their tables are scanned or matrices built. +} +\section{Errors}{ + +All errors have class \code{amrml_error}, plus \code{amrml_invalid_argument} if +\code{eligibility} is not from \code{\link[=eligibleScopes]{eligibleScopes()}}, \code{modes} names an unknown mode, +or \code{feature_types} is invalid. +} + +\examples{ +\dontrun{ +plan <- planMatrices(eligibleScopes(profileORB(readORB("path/to/amRdata/output")))) +plan$matrices + +# Only some modes +planMatrices(eligibility, modes = c("vanilla", "loto")) + +# Quick feature selection +planMatrices(eligibility, feature_types = "quick") +} +} diff --git a/man/profileORB.Rd b/man/profileORB.Rd index 9a1b368..fa39240 100644 --- a/man/profileORB.Rd +++ b/man/profileORB.Rd @@ -13,12 +13,14 @@ profileORB(orb) An \code{amr_orb_profile} list: \itemize{ \item \code{orb}: the ORB profiled. -\item \code{genomes}: each profiled genome's strata values and \code{resistant_classes}. -\item \code{labels}: each genome's phenotype per \code{unit} (drug or drug class) and +\item \code{genomes}: each profiled genome and its strata values. +\item \code{phenotypes}: each genome's phenotype per \code{unit} (drug or drug class) and \code{target}. -\item \code{targets}: genome counts per target and stratum value. -\item \code{conflicts}: genome and drug pairs recorded as both phenotypes. -\item \code{excluded_genomes}: genomes missing from a feature table. +\item \code{drug_classes}: each profiled drug and its \code{class}. +\item \code{targets}: genome counts per target and stratum value; \code{stratum} is NA +for the whole dataset. +\item \code{excluded_genomes}: each excluded genome and its \code{reason} +(\code{"no_usable_phenotype"}). } } \description{ @@ -27,9 +29,11 @@ counts the genomes behind each target, over the whole dataset and within each value of each stratum (year and country). } \details{ -Genomes missing from a feature table are excluded and listed. A genome -recorded as both Resistant and Susceptible for a drug is unlabelled for it. -A class is Resistant if any member drug is, and Susceptible if all are. +A genome is excluded, and listed with the reason, if it has no Resistant or +Susceptible row. A class is Resistant if any member drug is, and otherwise +Susceptible. Repeated rows for a genome and drug count once if they agree; +if they disagree, profiling stops. Missing feature rows represent zeros in +sparse feature tables. } \section{Errors}{ @@ -37,10 +41,11 @@ All errors have class \code{amrml_error}, plus one of: \itemize{ \item \code{amrml_invalid_argument}: \code{orb} is not from \code{\link[=readORB]{readORB()}}. \item \code{amrml_metadata_columns_missing}: the metadata lacks a needed column. -\item \code{amrml_genome_column_inconsistent}: a genome has two values for a stratum -or \code{resistant_classes}. -\item \code{amrml_no_labelled_genomes}: no genome in every feature table has a -usable label. +\item \code{amrml_phenotype_conflict}: a genome is recorded as both Resistant and +Susceptible for a drug. +\item \code{amrml_no_labelled_genomes}: no genome has a +usable phenotype. +\item \code{amrml_stratum_inconsistent}: a genome has two values for a stratum. } } diff --git a/man/readORB.Rd b/man/readORB.Rd index 5422cb0..846a82d 100644 --- a/man/readORB.Rd +++ b/man/readORB.Rd @@ -4,15 +4,15 @@ \alias{readORB} \title{Read an amRdata ORB} \usage{ -readORB(path) +readORB(path = NULL) } \arguments{ \item{path}{Character. The ORB directory: the folder amRdata wrote its output to, containing \code{manifest_*.json} (e.g. -\code{data/Staphylococcus_argenteus}), not its parent.} +\code{data/Staphylococcus_argenteus/orb}), not its parent.} } \value{ -An \code{amr_orb} list: \code{dataset_id}, \code{label} (what amRdata was asked for, +An \code{amr_orb} list: \code{dataset_id}, \code{dataset_label} (what amRdata was asked for, species names or taxon IDs, otherwise \code{dataset_id}), \code{directory}, \code{manifest_path}, \code{metadata_parquet}, \code{producer}, \code{producer_run_id}, \code{finished_at}, \code{files} (the producer run's declared outputs) and @@ -23,23 +23,25 @@ Validates the ORB in \code{path} and returns an object describing it. } \details{ Uses the manifest whose \code{amRml_input} is ready and whose producer run -finished last, with a message if more than one is ready. The ORB must be -where that manifest says, with every declared file present at its recorded -size. If it is not, \code{readORB()} stops with an error; it never falls back to -an older manifest, which would read older data. Feature tables are the -declared parquet files with the columns \code{genome_id}, \code{value} and one feature -ID column such as \code{gene} or \code{Pfam}. +finished last, with a message if more than one is ready. Recorded file +paths are resolved by filename within the manifest's directory, so an ORB +can be moved between directories and platforms. Every declared file must be +present at its recorded size. Otherwise, \code{readORB()} stops with an error; +it never falls back to an older manifest, which would read older data. +Feature tables are the declared parquet files with the columns \code{genome_id}, +\code{value} and one feature ID column such as \code{gene} or \code{Pfam}. } \section{Errors}{ All errors have class \code{amrml_error}, plus one of: \itemize{ -\item \code{amrml_invalid_argument}: \code{path} is not a single directory path. +\item \code{amrml_invalid_argument}: \code{path} is not a single directory path, or is +missing in a non-interactive session. +\item \code{amrml_no_orbs_found}: \code{path} is missing and no usable ORB is registered. \item \code{amrml_orb_dir_not_found}: \code{path} does not exist. \item \code{amrml_manifest_not_found}: the directory holds no \code{manifest_*.json}. \item \code{amrml_orb_no_usable_manifest}: no manifest is usable. \code{observed} holds each manifest's error. -\item \code{amrml_orb_moved}: the ORB is not where its manifest says it was written. \item \code{amrml_orb_files_missing}: declared files are missing or unreadable. \item \code{amrml_orb_file_changed}: a declared file's size has changed. \item \code{amrml_parquet_unreadable}: a declared parquet cannot be read. @@ -51,7 +53,7 @@ column. \examples{ \dontrun{ -orb <- readORB("path/to/amRdata/output") +orb <- readORB("path/to/amRdata/output/orb") orb$feature_tables } } diff --git a/man/rescoreFeatures.Rd b/man/rescoreFeatures.Rd new file mode 100644 index 0000000..af31549 --- /dev/null +++ b/man/rescoreFeatures.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rescore.R +\name{rescoreFeatures} +\alias{rescoreFeatures} +\title{Rescore features} +\usage{ +rescoreFeatures(fit, ...) +} +\arguments{ +\item{fit}{An \code{amr_fit} from \code{\link[=fitModels]{fitModels()}} or \code{\link[=runModelingWorkflow]{runModelingWorkflow()}}.} + +\item{...}{Feature rescoring's thresholds, passed to \code{\link[=runFeatureDyadDiscovery]{runFeatureDyadDiscovery()}}.} +} +\value{ +The \code{feature_dyad_discovery} list from \code{\link[=runFeatureDyadDiscovery]{runFeatureDyadDiscovery()}}. +} +\description{ +Runs feature rescoring (\code{\link[=runFeatureDyadDiscovery]{runFeatureDyadDiscovery()}}) on a fit: its vanilla +models' merged results, from \code{\link[=exportMergedResults]{exportMergedResults()}}, and the ORB's +virtual \code{dyad_feature} relation. Feature rescoring needs real and shuffled +labels and several seeds, e.g. +from \code{runModelingWorkflow(orb_dir, modes = "vanilla", seeds = c(31, 79, 51), labels = c("real", "shuffled"))}. +} +\section{Errors}{ + +Invalid input and missing ORB mappings raise \code{amrml_invalid_argument}. +DuckDB read errors retain their DBI/driver error classes. +} + +\examples{ +\dontrun{ +fit <- runModelingWorkflow("path/to/ORB", + modes = "vanilla", seeds = c(31, 79, 51), labels = c("real", "shuffled") +) +rescored <- rescoreFeatures(fit) +rescored$features$top +} +} diff --git a/man/runFeatureDyadDiscovery.Rd b/man/runFeatureDyadDiscovery.Rd new file mode 100644 index 0000000..900ae31 --- /dev/null +++ b/man/runFeatureDyadDiscovery.Rd @@ -0,0 +1,148 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{runFeatureDyadDiscovery} +\alias{runFeatureDyadDiscovery} +\title{Discover high-performing models, stable features, and protein dyads} +\usage{ +runFeatureDyadDiscovery( + all_top_features_parquet, + all_performance_parquet, + dyad_con, + MCC_threshold = 0.5, + compare_to_shuffled = TRUE, + core_contribution_threshold = 0.9, + exclude_feature_types = NULL, + filter_model = TRUE, + rank_score_quantile = 0.95, + cv_threshold = 1, + cumulative_contribution_threshold = 0.75, + seed_ratio_threshold = 1, + found_in_both_subtypes = FALSE, + compare_median_to_sd_rank_score = FALSE, + consistent_seed_ratio = 0.8, + consistent_rank_score = 0.75, + high_contribution_quantile = 0.75, + high_dyad_score_quantile = 0.75, + min_models_shared = 2 +) +} +\arguments{ +\item{all_top_features_parquet}{Path to the Parquet file containing +top features and their importance scores.} + +\item{all_performance_parquet}{Path to the Parquet file containing +model-performance results.} + +\item{dyad_con}{Open DBI connection to the ORB virtual \code{dyad_feature} view.} + +\item{MCC_threshold}{Minimum non-shuffled MCC used to define good model +performance. Default is \code{0.5}, meaning that only models with a non-shuffled MCC of 0.5 or higher are considered.} + +\item{compare_to_shuffled}{Logical indicating whether the models used for +feature selection must outperform their shuffled-label counterparts. +Default is \code{TRUE}.} + +\item{core_contribution_threshold}{Cumulative-contribution threshold +passed to \code{scoreFeaturesWithinSeed()}. Default is \code{0.9}.} + +\item{exclude_feature_types}{Feature types to exclude before feature +scoring. Default is \code{NULL}.} + +\item{filter_model}{Logical indicating whether feature scoring should be +restricted to model groups passing the requested model-quality criteria. +Default is \code{TRUE}.} + +\item{rank_score_quantile}{Quantile cutoff for median rank score, computed +separately within each species/drug-label/drug-or-class group. +Default is \code{0.95}.} + +\item{cv_threshold}{Maximum allowed rank-score coefficient of variation. +Default is \code{1}.} + +\item{cumulative_contribution_threshold}{Maximum allowed median cumulative +contribution. Default is \code{0.75}.} + +\item{seed_ratio_threshold}{Optional exact seed-ratio requirement passed +to \code{topFeaturesPerDrugOrClass()}. Default is \code{1}.} + +\item{found_in_both_subtypes}{Logical indicating whether selected features +must occur in both binary and counts feature subtypes. +Default is \code{FALSE}.} + +\item{compare_median_to_sd_rank_score}{Logical indicating whether selected +features must have \code{median_rank_score > rank_score_sd}. +Default is \code{FALSE}.} + +\item{consistent_seed_ratio}{Minimum seed ratio used to define a +consistently selected feature. Default is \code{0.8}.} + +\item{consistent_rank_score}{Minimum median rank score used to define a +consistently highly ranked feature. Default is \code{0.75}.} + +\item{high_contribution_quantile}{Quantile of \code{median_contribution} +used to define high-contribution features. It is computed separately +within each species/drug-label/drug-or-class group. Default is +\code{0.75}.} + +\item{high_dyad_score_quantile}{Quantile of +\code{dyad_median_rank_score} used to define high-scoring dyads. It is +computed separately within each species/drug-label/drug-or-class group. +Default is \code{0.75}.} + +\item{min_models_shared}{Minimum number of distinct drugs or drug classes +required for a feature or dyad to be considered shared. +Default is \code{2}.} +} +\value{ +An object of class \code{feature_dyad_discovery}, implemented as +a named list containing: +\itemize{ +\item \code{models$good_performance}: fit-level models satisfying +\code{MCC_threshold}, without requiring shuffled-model separation. +\item \code{models$good_shuffled_separation}: fit-level models whose +non-shuffled MCC exceeds the shuffled-label MCC. +\item \code{models$qualified}: fit-level models satisfying the model +criteria used for feature selection. +\item \code{models$summary}: model-level summary across seeds and feature +scales. +\item \code{features$top}: all selected top features. +\item \code{features$consistent}: selected features with high seed ratio +and high median rank score. +\item \code{features$high_contribution}: selected features with high +median contribution. +\item \code{features$all_seeds}: selected features present across all +analyzed seeds. +\item \code{features$shared}: selected features associated with at least +\code{min_models_shared} drugs or drug classes. +\item \code{features$unique}: selected features associated with exactly +one drug or drug class. +\item \code{dyads$top}: dyads mapped from the selected top features. +\item \code{dyads$high_score}: dyads with high median rank scores. +\item \code{dyads$shared}: dyads associated with at least +\code{min_models_shared} drugs or drug classes. +\item \code{dyads$unique}: dyads associated with exactly one drug or +drug class. +\item \code{parameters}: parameter values used for the analysis. +} +} +\description{ +Runs the model-quality, feature-ranking, and protein-dyad aggregation +workflow and organizes the results into question-oriented tables. +} +\details{ +The returned object can be used to identify: +\itemize{ +\item model fits with good non-shuffled performance; +\item model fits with good separation from shuffled-label models; +\item model fits satisfying both performance conditions; +\item top features with high seed coverage and median rank score; +\item top features with high median contribution; +\item top features present across every analyzed seed; +\item top features shared across drugs or drug classes; +\item top features unique to one drug or drug class; +\item high-scoring, shared, and unique protein dyads. +} + +This is a high-level wrapper around \code{filterOptimalModel()}, +\code{topFeaturesPerDrugOrClass()}, and \code{summariseDyads()}. +} diff --git a/man/runModelingWorkflow.Rd b/man/runModelingWorkflow.Rd new file mode 100644 index 0000000..3f2959d --- /dev/null +++ b/man/runModelingWorkflow.Rd @@ -0,0 +1,88 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/workflow.R +\name{runModelingWorkflow} +\alias{runModelingWorkflow} +\title{Run the modeling workflow} +\usage{ +runModelingWorkflow( + orb_dir, + out_dir = NULL, + modes = NULL, + seeds = 123L, + labels = c("real", "shuffled"), + save_fits = TRUE, + BPPARAM = BiocParallel::bpparam(), + min_genomes = 40, + n_fold = 5, + min_test_genomes = 5, + min_test_minority = 2, + overwrite = FALSE, + reuse_fits = TRUE, + feature_types = "standard", + resume = FALSE +) +} +\arguments{ +\item{orb_dir}{An amRdata ORB directory.} + +\item{out_dir}{Folder to write to. By default a new run folder, +\verb{/amRml//}.} + +\item{modes}{Mode IDs from \code{\link[=modelingModes]{modelingModes()}}, or \code{NULL} for all of them.} + +\item{seeds}{Passed to \code{\link[=expandTasks]{expandTasks()}}.} + +\item{labels}{\code{"real"}, \code{"shuffled"} or both (the default), passed to +\code{\link[=expandTasks]{expandTasks()}}.} + +\item{save_fits}{Passed to \code{\link[=fitModels]{fitModels()}}. Must match when resuming.} + +\item{BPPARAM}{Passed to \code{\link[=fitModels]{fitModels()}}. May be changed when resuming.} + +\item{min_genomes, n_fold, min_test_genomes, min_test_minority}{Passed to +\code{\link[=eligibleScopes]{eligibleScopes()}}.} + +\item{overwrite}{Replace an earlier run's matrices and results in \code{out_dir}; +if \code{FALSE}, an \code{out_dir} holding earlier output is refused. The default run +folder is always new.} + +\item{reuse_fits}{Passed to \code{\link[=fitModels]{fitModels()}}; reuse compatible cross-drug fits.} + +\item{feature_types}{Feature types to model: \code{"quick"}, \code{"standard"} (default), +\code{"full"}, or an explicit character vector of ORB feature types. +Selected before matrices are planned or built; see \code{\link[=planMatrices]{planMatrices()}}.} + +\item{resume}{Resume interrupted model fitting in an existing \code{out_dir}, +using its saved matrices and completed task groups, or reopen unchanged +completed results. Supply the same modeling arguments and the exact run +folder (e.g. \verb{/amRml//}); \code{BPPARAM} may be changed. +\code{overwrite} must be \code{FALSE}.} +} +\value{ +The \code{amr_fit} from \code{\link[=fitModels]{fitModels()}}; every earlier stage's result can be +reached from it (\verb{$built}, \verb{$built$eligibility}, ...). +} +\description{ +Runs every stage on an ORB: \code{\link[=readORB]{readORB()}}, \code{\link[=profileORB]{profileORB()}}, \code{\link[=eligibleScopes]{eligibleScopes()}}, +\code{\link[=planMatrices]{planMatrices()}}, \code{\link[=buildMatrices]{buildMatrices()}}, \code{\link[=expandTasks]{expandTasks()}} and \code{\link[=fitModels]{fitModels()}}. Each +can also be called on its own. By default every task is fitted on both the real +and the shuffled labels; \code{labels = "real"} skips the shuffled controls. +} +\details{ +Everything goes to \code{out_dir}: \code{eligibility.parquet}, \code{matrices.parquet}, +\verb{features/}, \code{matrix_index.rds}, \code{workflow.rds}, \code{tasks.parquet}, \code{run.json}, +\verb{results/} (including \verb{results/models/} when \code{save_fits = TRUE}), and \verb{merged/} from +\code{\link[=exportMergedResults]{exportMergedResults()}}. amRdata's files are only read. +} +\section{Errors}{ + +Errors from any stage, including \code{amrml_invalid_argument} for mismatched resume +settings, propagate to the caller. +} + +\examples{ +\dontrun{ +fit <- runModelingWorkflow("path/to/amRdata/output", "path/to/output") +fit$performance +} +} diff --git a/man/scoreFeaturesWithinSeed.Rd b/man/scoreFeaturesWithinSeed.Rd new file mode 100644 index 0000000..62c15d1 --- /dev/null +++ b/man/scoreFeaturesWithinSeed.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{scoreFeaturesWithinSeed} +\alias{scoreFeaturesWithinSeed} +\title{Score features within each seed} +\usage{ +scoreFeaturesWithinSeed( + all_top_features_parquet, + core_contribution_threshold = 0.75, + exclude_feature_types = NULL, + filter_model = TRUE, + all_performance_parquet, + MCC_threshold = NULL, + compare_to_shuffled = TRUE +) +} +\arguments{ +\item{all_top_features_parquet}{The path to the Parquet file containing all top features with their importance scores.} + +\item{core_contribution_threshold}{The cumulative-contribution cutoff, in [0, 1] (default is \code{0.75}, i.e. 75\%), used to flag whether a feature falls within the "core" set of features that jointly account for that share of a seed's total importance.} + +\item{exclude_feature_types}{Feature types to drop before any scoring happens (default is \code{NULL}, i.e. no feature types are excluded and struct is currently included). struct variables are composite IDs (e.g. \code{polA.group_211.group_2176}, three dot-joined gene/domain identifiers) representing a co-occurrence/structural motif rather than a single molecular entity like the other five scales, and its candidate-variable count (tens of thousands per group) dwarfs the other scales by orders of magnitude — pooling it into this rank_score/contribution machinery would compare a compound signal against five primary ones on an incomparable scale. Pass \code{"struct"} here to exclude it once struct is meant to be reserved for post-hoc biological annotation rather than scoring/ranking/thresholding.} + +\item{filter_model}{Logical indicating whether to restrict scoring to (species, drug_label, drug_or_class, feature_type, feature_subtype, seed) groups that have at least one model fit passing \code{filterOptimalModel()}'s MCC/shuffled-comparison quality thresholds (default is \code{TRUE}). The join is not keyed on \code{model}/\code{fit_penalty}/\code{fit_mixture}; this is only safe because there is currently never more than one fit per (species, drug_label, drug_or_class, feature_type, feature_subtype, seed) group. If that assumption changes, this join (and the \code{all_perf} join below) would need a finer-grained key to avoid silently keeping/duplicating rows from multiple fits.} + +\item{all_performance_parquet}{The path to the all performance parquet file. Always required — it is read unconditionally} + +\item{MCC_threshold}{The minimum MCC threshold passed through to \code{filterOptimalModel()} (default is \code{NULL}, no filtering)} + +\item{compare_to_shuffled}{Logical indicating whether to compare the model to shuffled data, passed through to \code{filterOptimalModel()} (default is \code{TRUE})} +} +\value{ +a tibble of scored top features, one row per feature within each species/drug_label/drug_or_class/feature_type/feature_subtype/seed group, with the following columns added: +\itemize{ +\item \code{contribution}: the feature's importance divided by the sum of importance across all features in the group. +\item \code{feat_return_ratio}: \code{n_feats_returned / n_feat} for the fit that produced this group. This assumes there is never more than one surviving fit per (species, drug_label, drug_or_class, seed, feature_type, feature_subtype) group; if that ever stops being true, this join would need a finer-grained key (\code{all_top_features_parquet} carries no \code{model}/\code{fit_penalty}/\code{fit_mixture} column to join on directly) or the ratio would need to be aggregated across fits before joining, to avoid fanning out and double-counting feature rows. +\item \code{rank}: descending rank of \code{contribution} within the group; ties receive the average of the ranks they span. +\item \code{n_features}: the number of rows (features) in the group. +\item \code{rank_score}: \code{(n_features - rank) / (n_features - 1)}; ranges 0-1 with higher values indicating higher importance (a single-feature group scores 1). +\item \code{cum_contrib}: the cumulative sum of \code{contribution} in descending order, with ties broken deterministically by variable identifier. +\item \code{in_core}: TRUE for the smallest deterministic prefix reaching the requested cumulative normalized importance; the feature crossing the threshold is INCLUDED. This is a reporting tier, not a multiplicative score. +} +} +\description{ +Score features within each seed +} +\examples{ +\dontrun{ +scoreFeaturesWithinSeed(all_top_features_parquet = "inst/extdata/all_top_features.parquet", +all_performance_parquet = "inst/extdata/all_perf.parquet") +} + +} +\keyword{internal} diff --git a/man/summariseDyads.Rd b/man/summariseDyads.Rd new file mode 100644 index 0000000..32c92c3 --- /dev/null +++ b/man/summariseDyads.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{summariseDyads} +\alias{summariseDyads} +\title{Aggregate mapped features to protein dyads} +\usage{ +summariseDyads(top_filtered_features, dyad_con) +} +\arguments{ +\item{top_filtered_features}{The tibble of top features for each drug/class generated from \code{topFeaturesPerDrugOrClass()}.} + +\item{dyad_con}{Open read-only DBI connection exposing virtual +\code{dyad_feature(dyad, feature)} in the ORB DuckDB.} +} +\value{ +a tibble with one row per species/drug_label/drug_or_class/dyad (\code{dyad} is the protein-dyad id), with: +\itemize{ +\item \code{frequency}: the number of top-feature rows mapped to this dyad. +\item \code{n_variables}, \code{variables_csv}: number of, and comma-separated list of, distinct \code{feature} (\code{":"}) values mapped to this dyad. +\item \code{n_feature_types}, \code{feature_types_csv}: number of, and comma-separated list of, distinct \code{feature_type_subtype} (\code{":"}) values mapped to this dyad. +\item \code{dyad_median_rank_score}: median of \code{median_rank_score} across the top-feature rows mapped to this dyad. +\item \code{dyad_median_contribution}: median of \code{median_contribution} across the top-feature rows mapped to this dyad. +\item \code{sign_consistent}, \code{sign}: whether \code{sign} is identical across every top-feature row mapped to this dyad; \code{sign} is that shared value if consistent, else \code{"MIXED"}. +} +} +\description{ +Internal helper called on the output of \code{topFeaturesPerDrugOrClass()}. +} +\keyword{internal} diff --git a/man/summariseFeaturesAcrossSeeds.Rd b/man/summariseFeaturesAcrossSeeds.Rd new file mode 100644 index 0000000..ce95abd --- /dev/null +++ b/man/summariseFeaturesAcrossSeeds.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{summariseFeaturesAcrossSeeds} +\alias{summariseFeaturesAcrossSeeds} +\title{Summarize a feature's scoring across seeds} +\usage{ +summariseFeaturesAcrossSeeds(scored_top_features) +} +\arguments{ +\item{scored_top_features}{The tibble of scored top features with their contribution, rank, and rank score within each seed generated from \code{scoreFeaturesWithinSeed()}} +} +\value{ +a tibble with one row per species/drug_label/drug_or_class/feature_type/feature_subtype/variable, with: +\itemize{ +\item \code{seed_ratio}: the number of seeds the feature appears in, divided by the total number of distinct \code{seed} values present anywhere in \code{scored_top_features} (a single count computed once for the whole call, not per feature or per group — so this assumes every group was fit with the same set of seeds). +\item \code{mean_rank_score}, \code{median_rank_score}: mean/median of \code{rank_score} across seeds; ranges 0-1 with higher values indicating higher importance. +\item \code{median_rank}: median of \code{rank} across seeds. (\code{mean_rank} is not currently computed.) +\item \code{median_contribution}: median of \code{contribution} across seeds. (\code{mean_contribution} is not currently computed.) +\item \code{median_cum_contrib}: median of \code{cum_contrib} across seeds. +\item \code{best_rank}: the best (lowest) rank seen across seeds. +\item \code{rank_consistent}: TRUE if the feature's rank is identical in every seed. +\item \code{rank_score_sd}, \code{rank_score_cv}: standard deviation and coefficient of variation of \code{rank_score} across seeds, i.e. how much the normalized rank_score varies — computed on \code{rank_score} rather than raw rank so it is comparable across groups with different numbers of features. +\item \code{in_core_consistent}, \code{in_core}: whether the feature's \code{in_core} flag is identical across every seed; \code{in_core} is that shared value if consistent, else \code{FALSE}. +\item \code{sign_consistent}, \code{sign}: whether the feature's \code{sign} is identical across every seed; \code{sign} is that shared value if consistent, else \code{"MIXED"}. +} +} +\description{ +Answers "which molecular features are consistently important?" by +collapsing the per-seed rows from \code{scoreFeaturesWithinSeed()} down to one +row per feature. +} +\examples{ +\dontrun{ +summariseFeaturesAcrossSeeds(scoreFeaturesWithinSeed(all_top_features.parquet)) +} +} +\keyword{internal} diff --git a/man/summarizeFeatureEvidence.Rd b/man/summarizeFeatureEvidence.Rd new file mode 100644 index 0000000..dd4e450 --- /dev/null +++ b/man/summarizeFeatureEvidence.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{summarizeFeatureEvidence} +\alias{summarizeFeatureEvidence} +\title{Summarize feature importance across successfully fitted seeds} +\usage{ +summarizeFeatureEvidence(scored_top_features, candidate_inventory) +} +\arguments{ +\item{scored_top_features}{Feature importance from successful real-label fits, +returned by scoreFeaturesWithinSeed(..., filter_model = FALSE).} + +\item{candidate_inventory}{One row per feature available in each successfully +fitted seed, using the same feature identifiers as scored_top_features. +Features absent from a seed's candidate list are not counted as zeros.} +} +\value{ +Tibble with average normalized importance, counts of eligible and +fitted seeds, frequency in the core feature group, and coefficient signs. +} +\description{ +Calculate each feature's average normalized importance using only seeds +where that feature was available to the model. Include a zero for a feature +that was available but not returned by a fitted model. Also record how often +the feature belongs to the group accounting for the chosen share of importance. +} diff --git a/man/topFeaturesPerDrugOrClass.Rd b/man/topFeaturesPerDrugOrClass.Rd new file mode 100644 index 0000000..145e195 --- /dev/null +++ b/man/topFeaturesPerDrugOrClass.Rd @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/feature-rescoring.R +\name{topFeaturesPerDrugOrClass} +\alias{topFeaturesPerDrugOrClass} +\title{Build a per-drug top-feature table with cutoffs} +\usage{ +topFeaturesPerDrugOrClass( + all_top_features_parquet, + core_contribution_threshold = 0.75, + exclude_feature_types = NULL, + filter_model = TRUE, + all_performance_parquet, + MCC_threshold = NULL, + compare_to_shuffled = TRUE, + rank_score_quantile = 0.95, + cv_threshold = 1, + cumulative_contribution_threshold = 0.75, + seed_ratio_threshold = NULL, + found_in_both_subtypes = FALSE, + compare_median_to_sd_rank_score = FALSE +) +} +\arguments{ +\item{all_top_features_parquet}{The path to the Parquet file containing all top features with their importance scores.} + +\item{core_contribution_threshold}{The cumulative-contribution cutoff, in [0, 1] (default is \code{0.75}, i.e. 75\%), used to flag whether a feature falls within the "core" set of features that jointly account for that share of a seed's total importance.} + +\item{exclude_feature_types}{Feature types to drop before any scoring happens (default is \code{NULL}, i.e. no feature types are excluded and struct is currently included). struct variables are composite IDs (e.g. \code{polA.group_211.group_2176}, three dot-joined gene/domain identifiers) representing a co-occurrence/structural motif rather than a single molecular entity like the other five scales, and its candidate-variable count (tens of thousands per group) dwarfs the other scales by orders of magnitude — pooling it into this rank_score/contribution machinery would compare a compound signal against five primary ones on an incomparable scale. Pass \code{"struct"} here to exclude it once struct is meant to be reserved for post-hoc biological annotation rather than scoring/ranking/thresholding.} + +\item{filter_model}{Logical indicating whether to restrict scoring to (species, drug_label, drug_or_class, feature_type, feature_subtype, seed) groups that have at least one model fit passing \code{filterOptimalModel()}'s MCC/shuffled-comparison quality thresholds (default is \code{TRUE}). The join is not keyed on \code{model}/\code{fit_penalty}/\code{fit_mixture}; this is only safe because there is currently never more than one fit per (species, drug_label, drug_or_class, feature_type, feature_subtype, seed) group. If that assumption changes, this join (and the \code{all_perf} join below) would need a finer-grained key to avoid silently keeping/duplicating rows from multiple fits.} + +\item{all_performance_parquet}{The path to the all performance parquet file. Always required — it is read unconditionally} + +\item{MCC_threshold}{The minimum MCC threshold passed through to \code{filterOptimalModel()} (default is \code{NULL}, no filtering)} + +\item{compare_to_shuffled}{Logical indicating whether to compare the model to shuffled data, passed through to \code{filterOptimalModel()} (default is \code{TRUE})} + +\item{rank_score_quantile}{A value in [0, 1] (default is \code{0.95}). Keep only features whose \code{median_rank_score} is at or above this quantile of \code{median_rank_score}, where the quantile is computed separately within each (species, drug_label, drug_or_class) group (with \code{na.rm = TRUE}) — so a feature is compared only against other features from the same drug/class, not against the whole panel. This means a drug/class with weaker or more diffuse signal overall can still contribute its own top features, rather than being crowded out by drugs/classes with stronger or more concentrated signal. As with the other conditions listed below, this is not restricted to rows that already pass them: \code{dplyr::filter()} evaluates every condition passed to a single call against the same original data, so this threshold does not narrow as other conditions are applied} + +\item{cv_threshold}{The maximum allowed coefficient of variation (default is \code{1}). Keep only features with \code{rank_score_cv <= cv_threshold}, i.e. drop features whose rank_score is inconsistent across seeds relative to its mean. A feature present in every seed (\code{seed_ratio == 1}) always passes this check regardless of its \code{rank_score_cv} — including when \code{rank_score_cv} is \code{NA}, which happens whenever a group has only a single seed} + +\item{cumulative_contribution_threshold}{The cumulative-contribution cutoff, in [0, 1] (default is \code{0.75}, i.e. 75\%). Keep only features with \code{median_cum_contrib <= cumulative_contribution_threshold}} + +\item{seed_ratio_threshold}{If not \code{NULL} (the default), keep only features whose \code{seed_ratio} exactly equals this value} + +\item{found_in_both_subtypes}{Logical indicating whether to additionally restrict to features that survive the filters above in both the binary and counts \code{feature_subtype} (default is \code{FALSE})} + +\item{compare_median_to_sd_rank_score}{Logical indicating whether to additionally require \code{median_rank_score > rank_score_sd} (default is \code{FALSE})} +} +\value{ +a tibble of top features for each drug/class: the \code{summariseFeaturesAcrossSeeds()} output (species, drug label, drug or class, feature type, feature subtype, variable, seed_ratio, mean/median rank score, median rank, median contribution, median cumulative contribution, best rank, rank/sign/in_core consistency flags, sign), filtered in two \code{dplyr::filter()} passes. +The first pass keeps rows where all of the following hold, evaluated together against \code{feature_summary} (see \code{rank_score_quantile} for how the last condition is grouped): +\itemize{ +\item \code{seed_ratio == seed_ratio_threshold}, only applied when \code{seed_ratio_threshold} is not \code{NULL}, +\item \code{seed_ratio == 1} OR \code{rank_score_cv <= cv_threshold} (see \code{cv_threshold}), +\item \code{in_core} is TRUE, +\item \code{sign_consistent} is TRUE (sign is the same in every seed; this does not require the sign to be negative), +\item \code{median_cum_contrib <= cumulative_contribution_threshold}, and +\item \code{median_rank_score} is at or above the \code{rank_score_quantile} quantile of \code{median_rank_score}, computed separately per (species, drug_label, drug_or_class) group. +} +Two columns are then added, grouped by (species, drug_label, drug_or_class, feature_type, variable): \code{n_subtype} and \code{subtype_csv}, recording how many/which \code{feature_subtype} values each combination has among the rows that survived the first pass. +A second \code{dplyr::filter()} pass then optionally keeps only rows where \code{subtype_csv == "binary,counts"} (when \code{found_in_both_subtypes = TRUE}) and/or \code{median_rank_score > rank_score_sd} (when \code{compare_median_to_sd_rank_score = TRUE}). +Every drug/class may not have variables from all feature types. Because the \code{rank_score_quantile} cutoff is now per drug/class rather than global, every drug/class with at least one feature surviving the other conditions will generally contribute something here, rather than potentially being excluded entirely by comparison to stronger-signal drugs/classes elsewhere in the panel. +} +\description{ +Runs \code{scoreFeaturesWithinSeed()} and \code{summariseFeaturesAcrossSeeds()} on +\code{all_top_features_parquet}, then filters the resulting per-feature summary +down to the top features for each drug/class. +} diff --git a/tests/README.md b/tests/README.md new file mode 100644 index 0000000..83a1555 --- /dev/null +++ b/tests/README.md @@ -0,0 +1,32 @@ +# Tests + +Run `testthat::test_local()`. + +Each file tests one file in `R/`, in the order that code runs: + +| test file | tests | +|---|---| +| `test-errors.R` | `R/errors.R`: the error codes, and building and throwing errors | +| `test-orb-read.R` | `R/orb-read.R`: `readORB()`, from the path argument to the ORB object | +| `test-orb-profile.R` | `R/orb-profile.R` and `R/registry.R`: `profileORB()`, from the argument to the profile object | +| `test-orb-integration.R` | reading and profiling a real ORB (see below) | + +## Fixtures + +`testthat/helper-orb.R` has two main ones: + +- `fxManifest()` returns an amRdata manifest as an R list, without writing + anything. Use it for tests of the manifest record and manifest selection. +- `fxOrb()` writes that manifest plus small Parquet files and an empty DuckDB + file to a temporary directory. Use it for `readORB()` and `profileORB()` + tests. Pass `metadata = fxMetadataRows(...)` to profile specific genomes, + drugs and phenotypes. + + +The data are synthetic and too small for modeling, however. + +## A real ORB + +Set `AMRML_TEST_ORB` to an amRdata output directory to also run +`test-orb-integration.R`, which reads and profiles it and checks that no +top-level file changed. CI doesn't set it, so this is a manual check. diff --git a/tests/S_argenteus.zip b/tests/S_argenteus.zip new file mode 100644 index 0000000..051bfda Binary files /dev/null and b/tests/S_argenteus.zip differ diff --git a/tests/testthat/helper-fit.R b/tests/testthat/helper-fit.R new file mode 100644 index 0000000..7a7b504 --- /dev/null +++ b/tests/testthat/helper-fit.R @@ -0,0 +1,57 @@ +# Fixtures for fitting and checkpoint integration tests. +fxFitTasks <- function(sparse = FALSE, labels = c("real", "shuffled"), + env = parent.frame()) { + out <- withr::local_tempdir("fit-run", .local_envir = env) + dir.create(file.path(out, "features")) + genomes <- sprintf("g%03d", seq_len(40)) + phenotype <- rep(c("Resistant", "Susceptible"), 20) + values <- withr::with_seed(817, { + p <- if (sparse) 24L else 5L + x <- if (sparse) matrix(stats::rbinom(40 * p, 1, 0.025), 40) else + matrix(stats::rpois(40 * p, 3), 40) + x[, 1] <- as.numeric(phenotype == "Resistant") * 3 + x[, 2] <- rep(c(0, 1, 2, 0), 10) + x + }) + store <- list(values = as(Matrix::Matrix(values, sparse = TRUE), "dgCMatrix"), + genomes = genomes, features = paste0("feature", seq_len(ncol(values)))) + saveRDS(store, file.path(out, "features", "0001.rds")) + rows <- lapply(list(33:36, 37:40), function(test) { + i <- c(1:32, test) + tibble::tibble(genome_id = genomes[i], role = c(rep("train", 32), rep("test", 4)), + phenotype = phenotype[i]) + }) + matrices <- tibble::tibble( + matrix_id = c("m1", "m2"), mode_id = "cross_drug", unit = "DRA", target = "drug", + train_group = "DRA", test_group = c("DRB", "DRC"), feature_type = "gene", + encoding = "counts", n_train = 32L, n_test = 4L, status = "built", + rule_id = NA_character_, n_features = ncol(values), file = "features/0001.rds" + ) + saveRDS(list(rows = rows, matrix_scopes = 1:2, + columns = rep(list(seq_len(ncol(values))), 2)), + file.path(out, "matrix_index.rds")) + arrow::write_parquet(matrices, file.path(out, "matrices.parquet")) + orb <- list(directory = "/synthetic-orb", dataset_id = "Tst", + dataset_label = "Synthetic", manifest_path = "/synthetic-orb/manifest.json", + producer_run_id = "fixture", finished_at = "2026-01-01 00:00:00") + eligibility <- list(profile = list(orb = orb), settings = list(n_fold = 2L, holdout = 0.2), + modes = .MODES[.MODES$mode_id == "cross_drug", ]) + built <- structure(list(eligibility = eligibility, out_dir = normalizePath(out), + matrices = matrices, storage = "shared_sparse"), class = "amr_matrices") + expandTasks(built, seeds = 31L, labels = labels) +} + +fxSmallGrid <- function() tibble::tibble(penalty = c(0.01, 0.1), mixture = c(1, 1)) + +fxComparableFit <- function(fit) { + fit$performance$run_time_sec <- NULL + fit[c("tasks", "performance", "importance", "predictions")] +} + +fxFitOptions <- function() { + if ("save_fits" %in% names(formals(fitModels))) list(save_fits = TRUE) else list() +} + +fxRunFit <- function(tasks, ...) { + suppressWarnings(do.call(fitModels, c(list(tasks = tasks), list(...), fxFitOptions()))) +} diff --git a/tests/testthat/helper-orb.R b/tests/testthat/helper-orb.R new file mode 100644 index 0000000..9a56169 --- /dev/null +++ b/tests/testthat/helper-orb.R @@ -0,0 +1,230 @@ +# Test fixtures: synthetic amRdata manifests and ORBs + +fxGenomes <- function() c("g1", "g2", "g3", "g4", "g5") + +# Column names follow amRdata's metadata.parquet. +fxMetadata <- function() { + tibble::tibble( + `genome.genome_id` = rep(fxGenomes(), each = 2), + `genome_drug.antibiotic` = rep(c("antibiotic_a", "antibiotic_b"), 5), + `genome_drug.resistant_phenotype` = rep(c("Resistant", "Susceptible"), 5), + drug_class = "class_x", + drug_abbr = rep(c("DRA", "DRB"), 5), + class_abbr = "CLX", + country_abbr = "CX", + year_bin = "2000-2004", + resistant_classes = "CLX", + num_resistant_classes = 1L + ) +} + +# Metadata with one row per genome and drug; the other columns are recycled. +fxMetadataRows <- function(genome, drug, phenotype, class = "CLX", + country = "CX", year_bin = "2000-2004") { + tibble::tibble( + `genome.genome_id` = genome, + `genome_drug.resistant_phenotype` = phenotype, + drug_abbr = drug, + class_abbr = class, + country_abbr = country, + year_bin = year_bin + ) +} + +# `n_r` Resistant then `n_s` Susceptible genomes for one drug, numbered from `from`. +fxRows <- function(n_r, n_s, drug = "DRA", from = 1, ...) { + genomes <- sprintf("g%03d", from - 1 + seq_len(n_r + n_s)) + fxMetadataRows( + genome = genomes, + drug = drug, + phenotype = rep(c("Resistant", "Susceptible"), c(n_r, n_s)), + ... + ) +} + +# Two drugs on separate genomes. Each has one Resistant and one Susceptible genome in every +# year x country cell, so years and countries split the genomes differently. +fxCrossed <- function() { + cells <- expand.grid( + phenotype = c("Resistant", "Susceptible"), year = c("Y1", "Y2", "Y3"), + country = c("C1", "C2", "C3"), stringsAsFactors = FALSE + ) + oneDrug <- function(drug, class, from) { + fxMetadataRows( + genome = sprintf("g%03d", from - 1 + seq_len(nrow(cells))), + drug = drug, phenotype = cells$phenotype, class = class, + country = cells$country, year_bin = cells$year + ) + } + rbind(oneDrug("DRA", "CLX", 1), oneDrug("DRB", "CLY", 19)) +} + +# weird is a feature table with an odd name; decoy_count is named like one but isn't. +fxDefaultParquets <- function(genomes = fxGenomes()) { + list( + gene_count = tibble::tibble( + genome_id = rep(genomes, each = 2), + gene = rep(c("geneA", "geneB"), times = length(genomes)), + value = seq_len(2 * length(genomes)) %% 3 + ), + weird = tibble::tibble( + genome_id = rep(genomes, each = 2), + widget = rep(c("w1", "w2"), times = length(genomes)), + value = seq_len(2 * length(genomes)) %% 5 + ), + decoy_count = tibble::tibble(genome_id = genomes, a = 1, b = 2, c = 3) + ) +} + +fxManifestName <- function() "manifest_run_fixture.json" + +# A ready ORB in a temporary directory, removed when `env` exits, declaring every file. +fxOrb <- function(env = parent.frame(), + metadata = fxMetadata(), + parquets = fxDefaultParquets(), + artifact_status = "ready", + producer_status = "success") { + dir <- withr::local_tempdir("orb", .local_envir = env) + + metadata_path <- file.path(dir, "metadata.parquet") + arrow::write_parquet(metadata, metadata_path) + + table_paths <- vapply(names(parquets), function(name) { + path <- file.path(dir, paste0(name, ".parquet")) + arrow::write_parquet(parquets[[name]], path) + path + }, character(1), USE.NAMES = FALSE) + + duckdb_path <- file.path(dir, "Tst_parquet.duckdb") + file.create(duckdb_path) + + declared <- c(metadata_path, table_paths, duckdb_path) + manifest <- fxManifest( + dir, + paths = declared, sizes = as.numeric(file.info(declared)$size), + artifact_status = artifact_status, producer_status = producer_status + ) + fxWriteManifest(dir, manifest) + dir +} + +# An amRdata manifest with fixed IDs, timestamps and sizes; its paths need not exist. +fxManifest <- function(dir = "/orb", + paths = file.path(dir, c( + "metadata.parquet", "gene_count.parquet", "Tst_parquet.duckdb" + )), + sizes = c(100, 200, 0), + artifact_status = "ready", + producer_status = "success") { + run_id <- "run_fixture_producer" + metadata_path <- file.path(dir, "metadata.parquet") + duckdb_path <- file.path(dir, "Tst_parquet.duckdb") + + list( + schema_version = 1L, + manifest_type = "amR_dataset", + manifest_id = "manifest_run_fixture", + manifest_created_at = "2026-01-01 00:00:00", + manifest_updated_at = "2026-01-01 00:00:01", + dataset_id = "Tst", + dataset = list( + duckdb = duckdb_path, + selection = list(user_bacs = "Testus fixtus") + ), + artifacts = list( + amRml_input = list( + status = artifact_status, + updated_at = "2026-01-01 00:00:01", + producer = "amRdata", + producer_run_id = run_id, + directory = dir, + parquet_duckdb = duckdb_path, + metadata_parquet = metadata_path + ) + ), + runs = list( + list( + run_id = run_id, + status = producer_status, + started_at = "2026-01-01 00:00:00", + finished_at = "2026-01-01 00:00:01", + stages = list( + list( + name = "clean_metadata_and_export", + status = "success", + outputs = lapply(seq_along(paths), function(i) { + list( + path = paths[[i]], + exists = TRUE, + size_bytes = sizes[[i]], + modified_at = "2026-01-01 00:00:01" + ) + }) + ) + ), + events = list() + ) + ) + ) +} + +fxReadManifest <- function(dir, name = fxManifestName()) { + jsonlite::read_json(file.path(dir, name), simplifyVector = FALSE) +} + +fxWriteManifest <- function(dir, manifest, name = fxManifestName()) { + jsonlite::write_json( + manifest, + file.path(dir, name), + auto_unbox = TRUE, + pretty = TRUE, + null = "null" + ) + invisible(dir) +} + +# Apply `fn` to the parsed manifest and write it back. +fxEditManifest <- function(dir, fn, name = fxManifestName()) { + fxWriteManifest(dir, fn(fxReadManifest(dir, name)), name) +} + +# Re-record declared file sizes, so a changed file doesn't trip the size check. +fxRecordSizes <- function(dir) { + fxEditManifest(dir, function(m) { + outputs <- m$runs[[1]]$stages[[1]]$outputs + m$runs[[1]]$stages[[1]]$outputs <- lapply(outputs, function(o) { + o$size_bytes <- as.numeric(file.info(o$path)$size) + o + }) + m + }) +} + +# Every entry in `dir`, hidden and empty ones included, with each file's checksum. +fxOrbState <- function(dir) { + entries <- sort(list.files(dir, recursive = TRUE, all.files = TRUE, include.dirs = TRUE)) + paths <- file.path(dir, entries) + files <- paths[!dir.exists(paths)] + list(entries = entries, checksums = tools::md5sum(files)) +} + +# An ORB from `metadata`, profiled and judged with `...`. `parquets` defaults to the +# standard feature tables for its genomes. +fxEligibility <- function(metadata = fxMetadata(), ..., parquets = NULL, env = parent.frame()) { + if (is.null(parquets)) { + parquets <- fxDefaultParquets(unique(metadata$genome.genome_id)) + } + orb <- readORB(fxOrb(env = env, metadata = metadata, parquets = parquets)) + eligibleScopes(profileORB(orb), ...) +} + +# A gene table for `n_r` Resistant then `n_s` Susceptible genomes, numbered as fxRows() does. +# geneA marks the Resistant ones; geneB alternates and carries no signal. +fxSignalGenes <- function(n_r, n_s) { + n <- n_r + n_s + tibble::tibble( + genome_id = rep(sprintf("g%03d", seq_len(n)), 2), + gene = rep(c("geneA", "geneB"), each = n), + value = c(rep(1:0, c(n_r, n_s)), rep_len(0:1, n)) + ) +} diff --git a/tests/testthat/test-eligibility.R b/tests/testthat/test-eligibility.R new file mode 100644 index 0000000..5702672 --- /dev/null +++ b/tests/testthat/test-eligibility.R @@ -0,0 +1,420 @@ +# Tests for eligibleScopes(), in the order it decides what can be modelled. + +# Scopes of one mode, without the mode column. +fxScopes <- function(eligibility, mode_id) { + scopes <- eligibility$scopes + scopes[scopes$mode_id == mode_id, -1] +} + +# Genome IDs kept for one eligible scope and role. +fxMemberIds <- function(eligibility, mode_id, target, train_group, test_group, role) { + m <- eligibility$members + keep <- m$mode_id == mode_id & m$target == target & m$role == role & + m$train_group %in% train_group & m$test_group %in% test_group + sort(m$genome_id[keep]) +} + +# The arguments + +test_that("anything that isn't a profile is rejected, naming eligibleScopes()", { + cnd <- rlang::catch_cnd(eligibleScopes(list()), classes = "error") + + expect_s3_class(cnd, "amrml_invalid_argument") + expect_equal(rlang::call_name(cnd$call), "eligibleScopes") +}) + +test_that("unknown modes and thresholds that aren't whole numbers are rejected", { + profile <- profileORB(readORB(fxOrb())) + + expect_error(eligibleScopes(profile, modes = "nope"), class = "amrml_invalid_argument") + expect_error(eligibleScopes(profile, n_fold = 1), class = "amrml_invalid_argument") + expect_error(eligibleScopes(profile, min_genomes = 2.5), class = "amrml_invalid_argument") + expect_error(eligibleScopes(profile, min_genomes = Inf), class = "amrml_invalid_argument") + expect_error(eligibleScopes(profile, modes = list("vanilla")), class = "amrml_invalid_argument") +}) + +# Whether each mode can run + +test_that("a mode that isn't supported yet doesn't run", { + eligibility <- fxEligibility(modes = "lodo") + + expect_equal(eligibility$modes$rule_id, "mode_not_supported") + expect_equal(nrow(eligibility$scopes), 0) +}) + +test_that("grouped modes need 2 groups, and leave-one-out needs 3", { + metadata <- fxRows(2, 2, year_bin = c("Y1", "Y1", "Y2", "Y2")) + eligibility <- fxEligibility(metadata, modes = c("stratified_year", "cross_year", "loto")) + modes <- eligibility$modes + + expect_equal(modes$feasible, c(TRUE, TRUE, FALSE)) + expect_equal(modes$rule_id, c(NA, NA, "too_few_groups")) + expect_equal(modes$n_groups, c(2, 2, 2)) + # Feasible modes can still have no eligible scope: Y1 is all Resistant, Y2 all Susceptible. + expect_equal(modes$n_scopes, c(4, 4, NA)) + expect_equal(modes$n_eligible, c(0, 0, NA)) + + one_drug <- fxEligibility(metadata, modes = "cross_drug")$modes + expect_equal(one_drug$rule_id, "too_few_groups") +}) + +test_that("without a year column, the year modes have no groups", { + metadata <- fxRows(10, 10) + metadata$year_bin <- NULL + modes <- fxEligibility(metadata, modes = c("stratified_year", "cross_year", "loto"))$modes + + expect_equal(modes$rule_id, rep("too_few_groups", 3)) + expect_equal(modes$n_groups, c(0, 0, 0)) +}) + +test_that("every supported mode finds an eligible scope on an ORB with enough data", { + eligibility <- fxEligibility(fxCrossed(), min_genomes = 4, n_fold = 2) + eligible <- eligibility$scopes[eligibility$scopes$eligible & eligibility$scopes$unit == "drug", ] + + expect_setequal(unique(eligible$mode_id), c( + "vanilla", "stratified_year", "stratified_country", "cross_year", "cross_country", + "cross_drug", "loto", "logo" + )) + + modes <- eligibility$modes[eligibility$modes$feasible, ] + scopes <- eligibility$scopes + expect_equal(modes$n_scopes, as.vector(table(scopes$mode_id)[modes$mode_id])) + expect_equal(modes$n_eligible, as.vector(table(scopes$mode_id[scopes$eligible])[modes$mode_id])) +}) + +# Whether each drug or class can run in a mode + +test_that("a drug or class tested in too few of a mode's groups gets one decision, not scopes", { + # DRA is tested in all three years; DRB, in its own class, only in Y1 and Y2. + metadata <- rbind( + fxRows(3, 3, year_bin = rep(c("Y1", "Y2", "Y3"), 2)), + fxRows(2, 2, drug = "DRB", from = 7, class = "CLY", year_bin = c("Y1", "Y2", "Y1", "Y2")) + ) + scopes <- fxScopes(fxEligibility(metadata, modes = "loto"), "loto") + drb <- scopes[scopes$target == "DRB", ] + + expect_equal(nrow(scopes[scopes$target == "DRA", ]), 3) + expect_equal(nrow(drb), 1) + expect_equal(drb$rule_id, "too_few_groups_tested") + expect_equal(drb$n_genomes, 4) + expect_true(is.na(drb$test_group)) +}) + +test_that("a drug tested only on genomes without a group still gets a decision", { + # DRB's genomes have no year, so it is in none of the year modes' groups. + metadata <- rbind( + fxRows(3, 3, year_bin = rep(c("Y1", "Y2"), 3)), + fxRows(2, 2, drug = "DRB", from = 7, class = "CLY", year_bin = NA) + ) + scopes <- fxScopes(fxEligibility(metadata, modes = "stratified_year"), "stratified_year") + drb <- scopes[scopes$target == "DRB", ] + + expect_equal(nrow(drb), 1) + expect_equal(drb$rule_id, "too_few_groups_tested") + expect_equal(drb$n_genomes, 0) +}) + +test_that("a drug tested in one group gets no stratified or cross scope of its own", { + # DRB is tested in Y1 only, so its stratified scope would repeat vanilla. + metadata <- rbind( + fxRows(2, 2, year_bin = c("Y1", "Y2", "Y1", "Y2")), + fxRows(2, 2, drug = "DRB", from = 5, class = "CLY", year_bin = "Y1") + ) + eligibility <- fxEligibility(metadata, modes = c("stratified_year", "cross_year")) + drb <- eligibility$scopes[eligibility$scopes$target == "DRB", ] + + expect_equal(drb$mode_id, c("stratified_year", "cross_year")) + expect_equal(drb$rule_id, rep("too_few_groups_tested", 2)) +}) + +# Scopes without a separate test set + +test_that("vanilla scopes are the profile's whole-dataset counts", { + profile <- profileORB(readORB(fxOrb())) + scopes <- fxScopes(eligibleScopes(profile, modes = "vanilla"), "vanilla") + whole <- profile$targets[is.na(profile$targets$stratum), ] + + expect_equal(scopes$target, whole$target) + expect_equal(scopes$n_genomes, whole$n_genomes) + expect_equal(scopes$n_resistant, whole$n_resistant) + expect_true(all(is.na(scopes$test_n_genomes))) +}) + +test_that("stratified scopes are per value, leaving out genomes without one", { + metadata <- fxRows(2, 2, country = c("CX", "CX", "CY", NA)) + scopes <- fxScopes(fxEligibility(metadata, modes = "stratified_country"), "stratified_country") + drug <- scopes[scopes$unit == "drug", ] + + expect_equal(drug$train_group, c("CX", "CY")) + expect_equal(drug$n_genomes, c(2, 1)) +}) + +# Scopes with a separate test set + +test_that("cross scopes train on one group and test on another, both ways round", { + metadata <- fxRows(2, 3, year_bin = c("Y1", "Y2", "Y1", "Y2", "Y2")) + scopes <- fxScopes(fxEligibility(metadata, modes = "cross_year"), "cross_year") + drug <- scopes[scopes$unit == "drug", ] + + expect_equal(drug$train_group, c("Y1", "Y2")) + expect_equal(drug$test_group, c("Y2", "Y1")) + expect_equal(drug$n_genomes, c(2, 3)) + expect_equal(drug$test_n_genomes, c(3, 2)) + expect_equal(drug$test_n_resistant, c(1, 1)) +}) + +test_that("cross-drug test sets leave out genomes the training drug was trained on", { + # DRA covers g001-g004 and DRB covers g003-g006, so each tests on the other's two others. + metadata <- rbind(fxRows(2, 2), fxRows(2, 2, drug = "DRB", from = 3, class = "CLY")) + scopes <- fxScopes(fxEligibility(metadata, modes = "cross_drug"), "cross_drug") + + expect_equal(scopes$train_group, c("DRA", "DRB")) + expect_equal(scopes$test_group, c("DRB", "DRA")) + expect_equal(scopes$n_genomes, c(4, 4)) + expect_equal(scopes$test_n_genomes, c(2, 2)) +}) + +test_that("a cross-drug test set left empty counts zero genomes and fails the test-set rule", { + # DRB's genomes are all DRA's, so DRA has nothing left to test on. + metadata <- rbind(fxRows(5, 5), fxRows(2, 2, drug = "DRB", class = "CLY")) + eligibility <- fxEligibility(metadata, modes = "cross_drug", min_genomes = 2, n_fold = 2) + scope <- fxScopes(eligibility, "cross_drug") + scope <- scope[scope$train_group == "DRA", ] + + expect_equal(scope$test_n_genomes, 0) + expect_equal(scope$rule_id, "test_too_small") +}) + +test_that("leave-one-out trains on every other group and tests on the held-out one", { + metadata <- fxRows(3, 3, year_bin = c("Y1", "Y2", "Y3", "Y1", "Y2", "Y3")) + scopes <- fxScopes(fxEligibility(metadata, modes = "loto"), "loto") + drug <- scopes[scopes$unit == "drug", ] + + expect_equal(drug$test_group, c("Y1", "Y2", "Y3")) + expect_true(all(is.na(drug$train_group))) + expect_equal(drug$n_genomes, c(4, 4, 4)) + expect_equal(drug$test_n_genomes, c(2, 2, 2)) +}) + +test_that("each grouped mode splits genomes by its own stratum", { + metadata <- fxCrossed() + eligibility <- fxEligibility(metadata, min_genomes = 4, n_fold = 2) + dra <- metadata[metadata$drug_abbr == "DRA", ] + ids <- function(keep) sort(dra$genome.genome_id[keep]) + + expect_equal( + fxMemberIds(eligibility, "stratified_year", "DRA", "Y1", NA, "train"), + ids(dra$year_bin == "Y1") + ) + expect_equal( + fxMemberIds(eligibility, "cross_country", "DRA", "C1", "C2", "train"), + ids(dra$country_abbr == "C1") + ) + expect_equal( + fxMemberIds(eligibility, "cross_country", "DRA", "C1", "C2", "test"), + ids(dra$country_abbr == "C2") + ) + expect_equal( + fxMemberIds(eligibility, "logo", "DRA", NA, "C2", "train"), + ids(dra$country_abbr != "C2") + ) + expect_equal( + fxMemberIds(eligibility, "logo", "DRA", NA, "C2", "test"), + ids(dra$country_abbr == "C2") + ) +}) + +# The rules + +test_that("a class with data for one drug is a duplicate; one with two drugs is not", { + # CLX holds DRA only. CLY holds DRB and DRC on different genomes. CLZ holds DRD and DRE + # on the same genomes with the same labels, so its labels match DRD's but it has two drugs. + metadata <- rbind( + fxRows(3, 3), + fxRows(3, 3, drug = "DRB", class = "CLY"), + fxRows(3, 3, drug = "DRC", from = 7, class = "CLY"), + fxRows(3, 3, drug = "DRD", class = "CLZ"), + fxRows(3, 3, drug = "DRE", class = "CLZ") + ) + scopes <- fxScopes( + fxEligibility(metadata, modes = "vanilla", min_genomes = 2, n_fold = 2), + "vanilla" + ) + classes <- scopes[scopes$unit == "drug_class", ] + + expect_equal(classes$target, c("CLX", "CLY", "CLZ")) + expect_equal(classes$rule_id, c("duplicate_class", NA, NA)) +}) + +test_that("a class's drugs are counted within each scope's genomes", { + # Only DRB has data in Y1, so CLY repeats it there. In Y2, CLY combines DRB and DRC; it + # then fails only because it has no second eligible year. + metadata <- rbind( + fxRows(3, 3, drug = "DRB", class = "CLY", year_bin = "Y1"), + fxRows(3, 3, drug = "DRB", from = 7, class = "CLY", year_bin = "Y2"), + fxRows(3, 3, drug = "DRC", from = 7, class = "CLY", year_bin = "Y2") + ) + scopes <- fxScopes( + fxEligibility(metadata, modes = "stratified_year", min_genomes = 2, n_fold = 2), + "stratified_year" + ) + classes <- scopes[scopes$unit == "drug_class", ] + + expect_equal(classes$train_group, c("Y1", "Y2")) + expect_equal(classes$rule_id, c("duplicate_class", "too_few_eligible_groups")) +}) + +test_that("only the first rule a scope fails is recorded", { + # 3 Resistant genomes: the drug has one phenotype and too few genomes, and the phenotype + # rule comes first. Its class holds one drug, a rule checked before both. + scopes <- fxScopes(fxEligibility(fxRows(3, 0), modes = "vanilla"), "vanilla") + + expect_equal(scopes$rule_id[scopes$unit == "drug"], "single_phenotype") + expect_equal(scopes$rule_id[scopes$unit == "drug_class"], "duplicate_class") +}) + +test_that("a scope with fewer training genomes than min_genomes is skipped", { + scope <- function(min_genomes) { + eligibility <- fxEligibility(fxRows(10, 10), modes = "vanilla", min_genomes = min_genomes, n_fold = 2) + fxScopes(eligibility, "vanilla")[1, ] + } + + expect_equal(scope(21)$rule_id, "too_few_genomes") + expect_true(scope(20)$eligible) +}) + +test_that("the fold check counts the 20% holdout only when there's no test set", { + # Internal: the split keeps floor(0.8 x n) of each phenotype, so 6 Resistant leave 4 for + # 5 folds, too few; 7 leave 5. With 4 folds, 5 Resistant leave exactly 4, enough. + internal <- function(n_r, n_fold = 5) { + eligibility <- fxEligibility(fxRows(n_r, 30), modes = "vanilla", min_genomes = 2, n_fold = n_fold) + fxScopes(eligibility, "vanilla")[1, ] + } + expect_equal(internal(5)$rule_id, "too_few_for_cv") + expect_equal(internal(6)$rule_id, "too_few_for_cv") + expect_true(internal(7)$eligible) + expect_true(internal(5, n_fold = 4)$eligible) + + # Cross: no holdout, so 5 Resistant training genomes are enough for 5 folds; 4 are not. + cross <- function(n_r) { + metadata <- rbind( + fxRows(n_r, 30, year_bin = "Y1"), + fxRows(2, 3, from = 36, year_bin = "Y2") + ) + scopes <- fxScopes(fxEligibility(metadata, modes = "cross_year", min_genomes = 2), "cross_year") + scopes[scopes$unit == "drug" & scopes$train_group == "Y1", ] + } + expect_true(cross(5)$eligible) + expect_equal(cross(4)$rule_id, "too_few_for_cv") +}) + +test_that("a test set needs enough genomes and enough of its rarer phenotype", { + testSetRule <- function(n_r, n_s) { + metadata <- rbind( + fxRows(10, 10, year_bin = "Y1"), + fxRows(n_r, n_s, from = 21, year_bin = "Y2") + ) + scopes <- fxScopes( + fxEligibility(metadata, modes = "cross_year", min_genomes = 2, n_fold = 2), + "cross_year" + ) + scopes$rule_id[scopes$unit == "drug" & scopes$train_group == "Y1"] + } + + # 1 of the rarer phenotype is below 2; 4 genomes are below 5. + expect_equal(testSetRule(1, 4), "test_too_small") + expect_equal(testSetRule(2, 2), "test_too_small") + expect_true(is.na(testSetRule(2, 3))) + + # The same rule for a leave-one-out held-out group: Y3 has 2 genomes. + metadata <- rbind( + fxRows(10, 10, year_bin = "Y1"), + fxRows(10, 10, from = 21, year_bin = "Y2"), + fxRows(1, 1, from = 41, year_bin = "Y3") + ) + scopes <- fxScopes(fxEligibility(metadata, modes = "loto", min_genomes = 2, n_fold = 2), "loto") + drug <- scopes[scopes$unit == "drug", ] + expect_equal(drug$rule_id, c(NA, NA, "test_too_small")) +}) + +test_that("a stratified drug needs at least two groups with enough data", { + # Y1 has enough genomes; Y2 is too small, so Y1 would be the only stratified model. + metadata <- rbind( + fxRows(10, 10, year_bin = "Y1"), + fxRows(1, 1, from = 21, year_bin = "Y2") + ) + scopes <- fxScopes( + fxEligibility(metadata, modes = "stratified_year", min_genomes = 4, n_fold = 2), + "stratified_year" + ) + drug <- scopes[scopes$unit == "drug", ] + + expect_equal(drug$train_group, c("Y1", "Y2")) + expect_equal(drug$rule_id, c("too_few_eligible_groups", "too_few_genomes")) +}) + +# The result + +test_that("the result keeps the profile and settings, and every rule is an error code", { + eligibility <- fxEligibility(n_fold = 3) + rules <- c(eligibility$modes$rule_id, eligibility$scopes$rule_id) + + expect_s3_class(eligibility, "amr_eligibility") + expect_s3_class(eligibility$profile, "amr_orb_profile") + expect_equal(eligibility$settings$n_fold, 3) + expect_equal(eligibility$settings$holdout, 0.2) + expect_true(all(stats::na.omit(rules) %in% .RULES$rule_id)) +}) + +test_that("when no mode runs, scopes and members are empty but keep their columns", { + ran <- fxEligibility(modes = "vanilla") + none <- fxEligibility(modes = "lodo") + + expect_equal(nrow(none$scopes), 0) + expect_equal(nrow(none$members), 0) + expect_identical(none$scopes, ran$scopes[0, ]) + expect_identical(none$members, ran$members[0, ]) +}) + +test_that("the genomes of each eligible scope are kept, with train and test kept apart", { + # Leave-one-out: hold out Y1 for DRA. + crossed <- fxCrossed() + loto <- fxEligibility(crossed, modes = "loto", min_genomes = 4, n_fold = 2) + dra <- crossed[crossed$drug_abbr == "DRA", ] + train <- fxMemberIds(loto, "loto", "DRA", NA, "Y1", "train") + test <- fxMemberIds(loto, "loto", "DRA", NA, "Y1", "test") + + expect_equal(train, sort(dra$genome.genome_id[dra$year_bin != "Y1"])) + expect_equal(test, sort(dra$genome.genome_id[dra$year_bin == "Y1"])) + expect_length(intersect(train, test), 0) + + # Cross-drug: DRA covers g001-g004 and DRB g003-g006, so DRA -> DRB tests on g005 and g006. + metadata <- rbind( + fxRows(2, 2), + fxMetadataRows( + genome = c("g003", "g004", "g005", "g006"), drug = "DRB", class = "CLY", + phenotype = c("Resistant", "Susceptible", "Resistant", "Susceptible") + ) + ) + cross <- fxEligibility( + metadata, + modes = "cross_drug", min_genomes = 2, n_fold = 2, min_test_genomes = 2, min_test_minority = 1 + ) + + expect_equal(fxMemberIds(cross, "cross_drug", "DRA", "DRA", "DRB", "train"), sprintf("g%03d", 1:4)) + expect_equal(fxMemberIds(cross, "cross_drug", "DRA", "DRA", "DRB", "test"), c("g005", "g006")) + # DRB -> DRA would test on g001 and g002, both Resistant, so it fails the test-set rule + # and keeps no genomes. + scopes <- fxScopes(cross, "cross_drug") + expect_equal(scopes$rule_id[scopes$train_group == "DRB"], "test_too_small") + expect_false(any(cross$members$train_group == "DRB")) +}) + +test_that("the print shows each mode's result", { + eligibility <- fxEligibility(modes = c("vanilla", "stratified_year", "lodo")) + + expect_output(print(eligibility), "40 training genomes, 5 folds") + expect_output(print(eligibility), "vanilla +: 0 of 3 eligible") + expect_output(print(eligibility), "stratified_year +: not run \\(too_few_groups\\)") + expect_output(print(eligibility), "lodo +: not run \\(mode_not_supported\\)") +}) diff --git a/tests/testthat/test-errors.R b/tests/testthat/test-errors.R new file mode 100644 index 0000000..700843d --- /dev/null +++ b/tests/testthat/test-errors.R @@ -0,0 +1,44 @@ +# Tests for amRml's error codes and the functions that build and throw errors. + +# The error codes + +test_that(".RULES has unique rule IDs and known stages", { + stages <- c("input", "orb", "profile", "feasibility", "eligibility", "matrix", "fit") + + expect_false(anyDuplicated(.RULES$rule_id) > 0) + expect_true(all(.RULES$stage %in% stages)) +}) + +# Building an error + +test_that(".amrError() builds a classed error with its fields, without throwing", { + expect_silent(cnd <- .amrError( + "orb_moved", + c("Headline.", x = "detail"), + observed = list(recorded = "/a"), + threshold = list(expected = "/b") + )) + + expect_s3_class(cnd, c("amrml_orb_moved", "amrml_error", "rlang_error")) + expect_equal(cnd$rule_id, "orb_moved") + expect_equal(cnd$stage, "orb") + expect_equal(cnd$observed, list(recorded = "/a")) + expect_equal(cnd$threshold, list(expected = "/b")) +}) + +test_that("an unknown rule_id is an internal error", { + expect_error(.amrError("no_such_rule", "x"), class = "amrml_internal_error") + expect_error(.amrError(c("orb_moved", "orb_moved"), "x"), class = "amrml_internal_error") +}) + +# Throwing an error + +test_that(".amrAbort() throws the error and blames the function the user called", { + user_facing <- function() helper(call = rlang::current_env()) + helper <- function(call) .amrAbort("orb_moved", c("Headline.", x = "detail"), call = call) + + cnd <- rlang::catch_cnd(user_facing(), classes = "error") + expect_s3_class(cnd, c("amrml_orb_moved", "amrml_error")) + expect_equal(rlang::call_name(cnd$call), "user_facing") + expect_match(conditionMessage(cnd), "detail") +}) diff --git a/tests/testthat/test-fit-export.R b/tests/testthat/test-fit-export.R new file mode 100644 index 0000000..11dd705 --- /dev/null +++ b/tests/testthat/test-fit-export.R @@ -0,0 +1,101 @@ +test_that("saved models survive resume and reproduce recorded predictions", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + tasks <- fxFitTasks(labels = "real") + install <- .restoreFitResults + local_mocked_bindings(.restoreFitResults = function(...) stop("injected installation failure")) + expect_error(fitModels(tasks, BPPARAM = BiocParallel::SerialParam()), "injected installation") + expect_error(fitModels(tasks, resume = TRUE, save_fits = FALSE, + BPPARAM = BiocParallel::SerialParam()), + class = "amrml_invalid_argument") + local_mocked_bindings(.restoreFitResults = install, + .runTaskGroup = function(...) stop("must not refit")) + fit <- suppressWarnings(fitModels(tasks, resume = TRUE, BPPARAM = BiocParallel::SerialParam())) + expect_true(file.exists(file.path(tasks$built$out_dir, "run.json"))) + expect_true(all(fit$performance$species == "Tst")) + expect_true(all(fit$importance$species == "Tst")) + index <- readRDS(file.path(tasks$built$out_dir, "matrix_index.rds")) + cache <- new.env(parent = emptyenv()) + for (i in seq_len(nrow(fit$tasks))) { + id <- fit$tasks$task_id[[i]] + saved <- readRDS(file.path(tasks$built$out_dir, "results", "models", paste0(id, ".rds"))) + matrix <- .readMatrixWide(file.path(tasks$built$out_dir, "features", "0001.rds"), + index$rows[[i]], index$columns[[i]], "counts", cache) + test <- matrix$rows$role == "test" + data <- .modelData(matrix$values[test, , drop = FALSE], matrix$rows$phenotype[test]) + scored <- parsnip::augment(saved$fit, data) + expect_equal(saved$features, matrix$features) + expect_equal(scored$.pred_Resistant, + fit$predictions$prob_resistant[fit$predictions$task_id == id]) + } +}) + +test_that("save_fits FALSE leaves no saved models and can reopen results", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + tasks <- fxFitTasks(labels = "real") + fit <- suppressWarnings(fitModels(tasks, save_fits = FALSE, + BPPARAM = BiocParallel::SerialParam())) + expect_false(dir.exists(file.path(tasks$built$out_dir, "results", "models"))) + local_mocked_bindings(.runTaskGroup = function(...) stop("must not refit")) + expect_equal(fxComparableFit(fit), + fxComparableFit(fitModels(tasks, save_fits = FALSE, resume = TRUE, + BPPARAM = BiocParallel::SerialParam()))) +}) + +test_that("zero returned coefficients retain the export schema", { + local_mocked_bindings(.tuningGrid = fxSmallGrid, + .taskImportance = function(...) tibble::tibble( + Variable = character(), Importance = numeric(), Sign = character())) + tasks <- fxFitTasks(labels = "real") + tasks$built$matrices$mode_id <- "vanilla" + fit <- suppressWarnings(fitModels(tasks, save_fits = FALSE, + BPPARAM = BiocParallel::SerialParam())) + expect_true(all(fit$tasks$status == "fitted")) + expect_true(all(fit$performance$n_feats_returned == 0L)) + expect_equal(nrow(fit$importance), 0L) + expect_type(fit$importance$species, "character") + expect_no_error(exportMergedResults(fit)) + top <- arrow::read_parquet(file.path(tasks$built$out_dir, "merged", "all_top_features.parquet")) + expect_equal(nrow(top), 0L) + expect_true(all(c("species", "Variable", "Sign") %in% names(top))) +}) + +test_that("workflow resume finishes a failed export without refitting", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + metadata <- fxRows(10, 10) + orb <- fxOrb(metadata = metadata, parquets = list(gene_count = fxSignalGenes(10, 10))) + root <- withr::local_tempdir() + withr::local_dir(root) + args <- list(orb_dir = orb, out_dir = "run", modes = "vanilla", seeds = 31L, + min_genomes = 4, n_fold = 2, save_fits = FALSE, + BPPARAM = BiocParallel::SerialParam()) + exporter <- exportMergedResults + local_mocked_bindings(exportMergedResults = function(...) stop("injected export failure")) + expect_error(suppressWarnings(do.call(runModelingWorkflow, args)), "injected export") + local_mocked_bindings(exportMergedResults = exporter, + .fitModel = function(...) stop("completed models must not refit")) + fit <- do.call(runModelingWorkflow, c(args, list(resume = TRUE))) + expect_true(all(fit$tasks$status == "fitted")) + expect_equal(fit$built$out_dir, normalizePath("run")) + expect_true(all(file.exists(file.path("run", "merged", + c("all_perf.parquet", "all_top_features.parquet"))))) +}) + +test_that("saved sparse workflows reproduce held-out predictions", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + tasks <- fxFitTasks(sparse = TRUE, labels = "real") + fit <- suppressWarnings(fitModels(tasks, BPPARAM = BiocParallel::SerialParam())) + index <- readRDS(file.path(tasks$built$out_dir, "matrix_index.rds")) + for (i in seq_len(nrow(fit$tasks))) { + id <- fit$tasks$task_id[[i]] + saved <- readRDS(file.path(tasks$built$out_dir, "results", "models", paste0(id, ".rds"))) + matrix <- .readMatrixWide(file.path(tasks$built$out_dir, "features", "0001.rds"), + index$rows[[i]], index$columns[[i]], "counts", + new.env(parent = emptyenv())) + test <- matrix$rows$role == "test" + data <- .modelData(matrix$values[test, , drop = FALSE], matrix$rows$phenotype[test], + sparse = TRUE) + scored <- parsnip::augment(saved$fit, data) + expect_equal(scored$.pred_Resistant, + fit$predictions$prob_resistant[fit$predictions$task_id == id]) + } +}) diff --git a/tests/testthat/test-fit-resume.R b/tests/testthat/test-fit-resume.R new file mode 100644 index 0000000..f2bd374 --- /dev/null +++ b/tests/testthat/test-fit-resume.R @@ -0,0 +1,129 @@ +test_that("dense and sparse fits agree across serial, sockets and reuse settings", { + skip_on_cran() + for (sparse in c(FALSE, TRUE)) { + tasks <- fxFitTasks(sparse = sparse) + serial <- fxRunFit(tasks, BPPARAM = BiocParallel::SerialParam()) + sockets <- fxRunFit(tasks, overwrite = TRUE, + BPPARAM = BiocParallel::SnowParam(workers = 2L, tasks = 2L)) + independent <- fxRunFit(tasks, overwrite = TRUE, reuse_fits = FALSE, + BPPARAM = BiocParallel::SerialParam()) + expect_true(all(serial$tasks$status == "fitted")) + expect_equal(fxComparableFit(serial), fxComparableFit(sockets)) + expect_equal(fxComparableFit(serial), fxComparableFit(independent)) + } +}) + +test_that("interrupted installation resumes without fitting completed groups again", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + tasks <- fxFitTasks() + install <- .restoreFitResults + local_mocked_bindings(.restoreFitResults = function(...) stop("injected installation failure")) + expect_error(fxRunFit(tasks, BPPARAM = BiocParallel::SerialParam()), "injected installation") + expect_true(dir.exists(file.path(tasks$built$out_dir, "fit-checkpoints"))) + local_mocked_bindings(.restoreFitResults = install, + .runTaskGroup = function(...) stop("completed groups must not refit")) + resumed <- fxRunFit(tasks, resume = TRUE, BPPARAM = BiocParallel::SerialParam()) + expect_true(all(resumed$tasks$status == "fitted")) + expect_false(dir.exists(file.path(tasks$built$out_dir, "fit-checkpoints"))) + reopened <- fxRunFit(tasks, resume = TRUE, BPPARAM = BiocParallel::SerialParam()) + expect_equal(fxComparableFit(resumed), fxComparableFit(reopened)) +}) + +test_that("resume rejects changed matrices and completed output corruption", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + tasks <- fxFitTasks(labels = "real") + fit <- fxRunFit(tasks, BPPARAM = BiocParallel::SerialParam()) + model_path <- file.path(tasks$built$out_dir, "features", "0001.rds") + original <- readBin(model_path, "raw", n = file.info(model_path)$size) + store <- readRDS(model_path) + store$values[1, 1] <- store$values[1, 1] + 1 + saveRDS(store, model_path) + expect_error(fxRunFit(tasks, resume = TRUE, BPPARAM = BiocParallel::SerialParam()), + class = "amrml_invalid_argument") + writeBin(original, model_path) + writeLines("corrupted", file.path(tasks$built$out_dir, "results", "performance.parquet")) + expect_error(fxRunFit(tasks, resume = TRUE, BPPARAM = BiocParallel::SerialParam()), + class = "amrml_invalid_argument") +}) + +test_that("failed tasks do not discard successful peers", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + tasks <- fxFitTasks(labels = "real") + path <- file.path(tasks$built$out_dir, "matrix_index.rds") + index <- readRDS(path) + index$rows[[2]]$genome_id[[36]] <- "missing-genome" + saveRDS(index, path) + fit <- fxRunFit(tasks, BPPARAM = BiocParallel::SerialParam()) + expect_equal(fit$tasks$status, c("fitted", "failed")) + expect_equal(fit$tasks$rule_id[[2]], "fit_failed") + expect_match(fit$tasks$message[[2]], "missing from feature store") + expect_equal(nrow(fit$performance), 1L) +}) + +test_that("all-failed and empty plans still write typed result tables", { + local_mocked_bindings(.fitModel = function(...) stop("injected model failure")) + tasks <- fxFitTasks(labels = "real") + fit <- fxRunFit(tasks, BPPARAM = BiocParallel::SerialParam()) + expect_true(all(fit$tasks$status == "failed")) + expect_equal(nrow(fit$performance), 0L) + expect_type(fit$importance$Sign, "character") + expect_true(all(c("genome_id", "truth") %in% names(fit$predictions))) + tasks$tasks <- tasks$tasks[0, ] + empty <- fxRunFit(tasks, overwrite = TRUE, BPPARAM = BiocParallel::SerialParam()) + expect_equal(nrow(empty$tasks), 0L) + expect_equal(nrow(empty$performance), 0L) +}) + +test_that("installation rollback restores every previous output", { + out <- withr::local_tempdir() + stage <- withr::local_tempdir() + dir.create(file.path(out, "results")) + writeLines("previous tasks", file.path(out, "tasks.parquet")) + writeLines("previous results", file.path(out, "results", "performance.parquet")) + writeLines("new tasks", file.path(stage, "tasks.parquet")) + before <- tools::md5sum(file.path(out, c("tasks.parquet", "results/performance.parquet"))) + expect_warning(expect_error(.restoreFitResults(stage, out, c("tasks.parquet", "results")), + "Could not install result")) + expect_equal(tools::md5sum(names(before)), before) +}) + +test_that("fit flags are validated before creating checkpoint files", { + tasks <- fxFitTasks() + for (flag in c("resume", "reuse_fits", "overwrite")) { + args <- c(list(tasks = tasks, BPPARAM = BiocParallel::SerialParam()), + stats::setNames(list(NA), flag)) + expect_error(do.call(fitModels, args), class = "amrml_invalid_argument") + } + expect_false(dir.exists(file.path(tasks$built$out_dir, "fit-checkpoints"))) +}) + +test_that("partial workflow artifacts block an accidental fresh run", { + orb <- withr::local_tempdir() + for (artifact in c("features", "matrix_index.rds", "fit-checkpoints", "workflow.rds")) { + out <- withr::local_tempdir() + file.create(file.path(out, artifact)) + expect_error(.checkArgOutDir(out, orb, overwrite = FALSE), + class = "amrml_invalid_argument") + } +}) + +test_that("groups share a worker-local feature-store cache", { + local_mocked_bindings(.tuningGrid = fxSmallGrid) + tasks <- fxFitTasks(labels = "real") + index <- readRDS(file.path(tasks$built$out_dir, "matrix_index.rds")) + paths <- file.path(tasks$built$out_dir, c("group1.rds", "group2.rds")) + cache <- new.env(parent = emptyenv()) + extra <- if ("save_fits" %in% names(formals(.runTaskGroup))) { + list(species = "Tst", model_dir = NULL, save_fits = FALSE) + } else list() + run <- function(i) suppressWarnings(do.call(.runTaskGroup, c(list( + job = .fitGroupJob(i, tasks$tasks, tasks$built$matrices, index, + tasks$built$out_dir, paths[[i]]), cache = cache + ), extra))) + expect_true(run(1L)) + expect_gt(length(cache), 0L) + source <- file.path(tasks$built$out_dir, "features", "0001.rds") + expect_true(file.rename(source, paste0(source, ".moved"))) + expect_true(run(2L)) + expect_null(readRDS(paths[[2]])[[1]]$error) +}) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R new file mode 100644 index 0000000..0312d2c --- /dev/null +++ b/tests/testthat/test-network.R @@ -0,0 +1,156 @@ +testthat::test_that("MAGIC network cores include the crossing feature and conserve importance", { + importance <- tibble::tibble( + task_id = rep("fit1", 4), + Variable = c("g3", "g1", "g4", "g2"), + Importance = c(1, 4, 0.5, 2.5), + Sign = "NEG" + ) + metadata <- tibble::tibble( + task_id = "fit1", unit = "drug", target = "AMP", + labels = "real", seed = 31L, feature_type = "gene", + encoding = "binary" + ) + scored <- .scoreNetworkTasks(importance, metadata, 0.75) + testthat::expect_equal(sum(scored$contribution), 1) + testthat::expect_equal(scored$Variable, c("g1", "g2", "g3", "g4")) + testthat::expect_equal(scored$Variable[scored$in_core], c("g1", "g2")) + testthat::expect_true(sum(scored$contribution[scored$in_core]) >= 0.75) + testthat::expect_error(.scoreNetworkTasks( + dplyr::bind_rows(importance, importance[1, ]), metadata, 0.75), + "Invalid returned") +}) + +testthat::test_that("protein predictors already represent CD-HIT clusters", { + scored <- tibble::tibble( + task_id = rep("fit1", 3), unit = "drug", target = "AMP", + labels = "real", seed = 31L, feature_type = "protein", encoding = "binary", + Variable = c("fig.1.peg.1", "clusterB", "member1"), + contribution = c(.4, .35, .25), in_core = c(TRUE, TRUE, FALSE), + Sign = c("NEG", "NEG", "POS") + ) + pairs <- tibble::tibble(gene_cluster = "g1", + protein_cluster = "fig|1.peg.1") + result <- .prepareNetworkNodes(scored, pairs) + testthat::expect_equal(nrow(result), 3L) + testthat::expect_equal(result$node_id, c("fig|1.peg.1", "clusterB", "member1")) + testthat::expect_equal(result$contribution, c(.4, .35, .25)) + testthat::expect_equal(result$in_core, c(TRUE, TRUE, FALSE)) + testthat::expect_equal(result$in_orb_graph, c(TRUE, FALSE, FALSE)) + testthat::expect_true(all(result$n_returned_features == 1L)) + + duplicate <- dplyr::bind_rows(scored[1, ], scored[1, ]) + duplicate$Variable[[2L]] <- "fig|1.peg.1" + testthat::expect_error(.prepareNetworkNodes(duplicate, pairs), + "same cluster ID") +}) + +testthat::test_that("network recurrence is separate from direct feature scores", { + rows <- tibble::tibble( + task_id = c("fit1", "fit2"), unit = "drug", target = "AMP", + labels = "real", seed = c(31L, 79L), encoding = "binary", + feature_type = "gene", node_id = "g1", in_core = c(TRUE, TRUE), + contribution = c(.4, .2), n_returned_features = 1L + ) + fitted <- tibble::tibble( + unit = "drug", target = "AMP", labels = "real", + encoding = "binary", feature_type = "gene", seed = c(31L, 79L, 51L) + ) + nodes <- .summarizeNetworkNodes(rows, fitted) + testthat::expect_identical(nodes$n_returned_seeds, 2L) + testthat::expect_identical(nodes$n_fitted_seeds, 3L) + testthat::expect_identical(nodes$n_core_seeds, 2L) + testthat::expect_true(nodes$reproducibly_important) + testthat::expect_equal(nodes$mean_returned_contribution, .3) + testthat::expect_false("direct_score" %in% names(nodes)) +}) + +testthat::test_that("task-based ORB network export preserves unsupported and shuffled evidence", { + testthat::skip_if_not_installed("arrow") + testthat::skip_if_not_installed("duckdb") + root <- tempfile("magic-network-test-") + run <- file.path(root, "run") + orb <- file.path(root, "dataset", "orb") + out <- file.path(root, "network") + dir.create(file.path(run, "results"), recursive = TRUE) + dir.create(orb, recursive = TRUE) + on.exit(unlink(root, recursive = TRUE), add = TRUE) + + con <- DBI::dbConnect(duckdb::duckdb(), dbdir = file.path(orb, "fixture_parquet.duckdb")) + DBI::dbWriteTable(con, "dyads", data.frame(gene = "g1", protein = "fig|1.peg.1")) + DBI::dbWriteTable(con, "protein_members", data.frame(member = "member1", cluster = "fig|1.peg.1")) + DBI::dbWriteTable(con, "dyad_ann_pfam", data.frame(cluster = "fig|1.peg.1", feature = "PF.1")) + for (view in c("dyad_ann_cog", "dyad_ann_amr", "dyad_ann_defense")) { + DBI::dbWriteTable(con, view, + data.frame(cluster = character(), feature = character())) + } + DBI::dbDisconnect(con) + + matrices <- tibble::tibble( + matrix_id = c("g", "p", "a"), mode_id = "vanilla", unit = "drug", + target = "AMP", feature_type = c("gene", "protein", "Pfam"), + encoding = "binary" + ) + tasks <- tidyr::crossing(matrix_id = matrices$matrix_id, + labels = c("real", "shuffled"), seed = c(31L, 79L)) |> + dplyr::mutate(task_id = paste(matrix_id, labels, seed, sep = "__"), + status = "fitted") + performance <- tasks |> + dplyr::transmute(task_id, seed, + mcc = dplyr::if_else(labels == "real", 0.8, -0.2)) + importance <- tasks |> + dplyr::left_join(matrices, by = "matrix_id") |> + dplyr::transmute(task_id, + Variable = dplyr::case_when(feature_type == "gene" ~ "g1", + feature_type == "protein" ~ "fig.1.peg.1", + TRUE ~ "PF.1"), + Importance = 1, Sign = "NEG") + predictions <- tidyr::crossing(task_id = tasks$task_id, + genome_id = c("x", "y")) |> + dplyr::mutate(truth = dplyr::if_else(genome_id == "x", "Resistant", "Susceptible"), + predicted = truth) + arrow::write_parquet(matrices, file.path(run, "matrices.parquet")) + arrow::write_parquet(tasks, file.path(run, "tasks.parquet")) + arrow::write_parquet(performance, file.path(run, "results/performance.parquet")) + arrow::write_parquet(importance, file.path(run, "results/importance.parquet")) + arrow::write_parquet(predictions, file.path(run, "results/predictions.parquet")) + + testthat::expect_no_warning(result <- exportNetwork(run, orb, out)) + testthat::expect_equal(result$summary$n_distinct_high_priority_pairs, 1) + provenance <- arrow::read_parquet(file.path(out, "network_provenance.parquet")) + testthat::expect_equal(provenance$n_cluster_pairs, 1) + testthat::expect_equal(provenance$core_threshold, 0.75) + ids <- arrow::read_parquet(file.path(out, "protein_cluster_id_crosswalk.parquet")) + testthat::expect_equal(ids$model_feature, "fig.1.peg.1") + testthat::expect_equal(ids$protein_cluster, "fig|1.peg.1") + testthat::expect_true(ids$in_orb_graph) + cluster_rows <- arrow::read_parquet(file.path(out, "gene_protein_seed_evidence.parquet")) + testthat::expect_true(all(cluster_rows$n_returned_features == 1L)) + testthat::expect_true(all(cluster_rows$node_id[cluster_rows$feature_type == "protein"] == "fig|1.peg.1")) + testthat::expect_false(file.exists(file.path(out, "gene_protein_projected_seed_evidence.parquet"))) + graph <- arrow::read_parquet(file.path(out, "cluster_pair_network_evidence.parquet")) + testthat::expect_equal(nrow(graph), 2) + testthat::expect_true(graph$high_priority[graph$labels == "real"]) + testthat::expect_false(graph$high_priority[graph$labels == "shuffled"]) + testthat::expect_true(all(graph$pair_robust75)) + testthat::expect_true(all(graph$protein_evidence_origin == "direct_protein_cluster_model")) + neighbors <- arrow::read_parquet(file.path(out, "cluster_annotation_neighbor_evidence.parquet")) + testthat::expect_equal(nrow(neighbors), 2) + testthat::expect_true(all(neighbors$returned_nonzero)) + testthat::expect_equal(result$summary$n_high_priority_pair_encoding_records, 1L) + testthat::expect_equal(result$summary$n_distinct_real_robust_pairs, 1L) + testthat::expect_setequal(list.files(out), c( + "network_provenance.parquet", "feature_returned_seed_evidence.parquet", + "gene_protein_cluster_node_evidence.parquet", "annotation_node_evidence.parquet", + "cluster_pair_network_evidence.parquet", "cluster_annotation_neighbor_evidence.parquet", + "model_reliability.parquet", "reliability_mcc_audit.parquet", + "protein_cluster_id_crosswalk.parquet", "gene_protein_seed_evidence.parquet" + )) + con <- DBI::dbConnect(duckdb::duckdb(), dbdir = file.path(orb, "fixture_parquet.duckdb")) + DBI::dbExecute(con, "DELETE FROM dyads") + DBI::dbWriteTable(con, "dyads", data.frame( + gene = c("g1", "g2"), protein = c("member1", "fig|1.peg.2") + ), append = TRUE) + DBI::dbDisconnect(con) + testthat::expect_error(exportNetwork(run, orb, file.path(root, "legacy")), + "individual protein IDs") +}) diff --git a/tests/testthat/test-orb-integration.R b/tests/testthat/test-orb-integration.R new file mode 100644 index 0000000..0cb3777 --- /dev/null +++ b/tests/testthat/test-orb-integration.R @@ -0,0 +1,31 @@ +# Tests for reading and profiling a real amRdata ORB, set by AMRML_TEST_ORB. + +test_that("a real ORB reads and profiles consistently without changing its files", { + path <- Sys.getenv("AMRML_TEST_ORB") + skip_if_not(nzchar(path), "AMRML_TEST_ORB is not set") + expect_true(dir.exists(path), info = "AMRML_TEST_ORB must point to an existing directory") + + # Top-level files only; genomes/ and panaroo_out_* are not read. + entries <- list.files(path, all.files = TRUE, no.. = TRUE) + files <- file.path(path, entries) + files <- files[!dir.exists(files)] + before <- tools::md5sum(files) + + orb <- readORB(path) + profile <- profileORB(orb) + + expect_gt(nrow(orb$files), 0) + expect_gt(nrow(orb$feature_tables), 0) + + targets <- profile$targets + metadata_genomes <- unique(arrow::read_parquet(orb$metadata_parquet)$genome.genome_id) + expect_equal(targets$n_resistant + targets$n_susceptible, targets$n_genomes) + expect_true(all(profile$phenotypes$genome_id %in% profile$genomes$genome_id)) + expect_setequal( + metadata_genomes, + c(profile$genomes$genome_id, profile$excluded_genomes$genome_id) + ) + + expect_equal(list.files(path, all.files = TRUE, no.. = TRUE), entries) + expect_equal(tools::md5sum(files), before) +}) diff --git a/tests/testthat/test-orb-profile.R b/tests/testthat/test-orb-profile.R new file mode 100644 index 0000000..f6bf95d --- /dev/null +++ b/tests/testthat/test-orb-profile.R @@ -0,0 +1,234 @@ +# Tests for profileORB(), in the order it profiles an ORB. + +fxProfile <- function(metadata = fxMetadata(), parquets = fxDefaultParquets(), + env = parent.frame()) { + profileORB(readORB(fxOrb(env = env, metadata = metadata, parquets = parquets))) +} + +# Whole-dataset counts for one target. +fxTarget <- function(profile, unit, target) { + t <- profile$targets + t[t$unit == unit & t$target == target & is.na(t$stratum), , drop = FALSE] +} + +# Parquets whose feature tables cover only `genomes`. +fxParquetsFor <- function(genomes) { + lapply(fxDefaultParquets(), function(x) x[x$genome_id %in% genomes, , drop = FALSE]) +} + +# The argument + +test_that("anything that isn't an ORB is rejected, naming profileORB()", { + cnd <- rlang::catch_cnd(profileORB(list()), classes = "error") + + expect_s3_class(cnd, "amrml_invalid_argument") + expect_equal(rlang::call_name(cnd$call), "profileORB") +}) + +# Reading the metadata + +test_that("metadata without a required column is rejected", { + metadata <- fxMetadata() + metadata$class_abbr <- NULL + + expect_error(fxProfile(metadata), class = "amrml_metadata_columns_missing") +}) + +# Rows that give a genome a phenotype + +test_that("only Resistant and Susceptible rows count; genomes without one are excluded", { + metadata <- fxMetadataRows( + genome = c("g1", "g2", "g3", "g4"), + drug = "DRA", + phenotype = c("Resistant", "Intermediate", "", NA) + ) + expect_message(profile <- fxProfile(metadata), "3 genomes are excluded") + + expect_equal(unique(profile$phenotypes$genome_id), "g1") + expect_equal(profile$excluded_genomes$genome_id, c("g2", "g3", "g4")) + expect_equal(unique(profile$excluded_genomes$reason), "no_usable_phenotype") +}) + +# Drug phenotypes + +test_that("each genome gets its own phenotype per drug", { + metadata <- fxMetadataRows( + genome = c("g1", "g1", "g2", "g2"), + drug = c("DRA", "DRB", "DRA", "DRB"), + phenotype = c("Resistant", "Susceptible", "Susceptible", "Resistant") + ) + profile <- fxProfile(metadata) + drugs <- profile$phenotypes[profile$phenotypes$unit == "drug", ] + + expect_equal(drugs, tibble::tibble( + genome_id = c("g1", "g1", "g2", "g2"), + unit = "drug", + target = c("DRA", "DRB", "DRA", "DRB"), + phenotype = c("Resistant", "Susceptible", "Susceptible", "Resistant") + )) +}) + +test_that("repeated rows for a genome and drug count once if they agree", { + metadata <- fxMetadataRows( + genome = c("g1", "g1", "g2"), + drug = "DRA", + phenotype = c("Resistant", "Resistant", "Susceptible") + ) + profile <- fxProfile(metadata) + + expect_equal(fxTarget(profile, "drug", "DRA")$n_genomes, 2) + expect_equal(fxTarget(profile, "drug", "DRA")$n_resistant, 1) +}) + +test_that("a genome recorded as both Resistant and Susceptible for a drug is an error", { + metadata <- fxMetadataRows( + genome = c("g1", "g1", "g2"), + drug = "DRA", + phenotype = c("Resistant", "Susceptible", "Susceptible") + ) + + err <- expect_error(fxProfile(metadata), class = "amrml_phenotype_conflict") + expect_equal(err$observed$conflicts, tibble::tibble(genome_id = "g1", drug_abbr = "DRA")) +}) + +# Sparse feature tables may omit genomes whose feature values are all zero. + +test_that("genomes absent from a sparse feature table remain profiled", { + parquets <- fxDefaultParquets() + parquets$gene_count <- parquets$gene_count[parquets$gene_count$genome_id != "g5", ] + expect_silent(profile <- fxProfile(parquets = parquets)) + expect_equal(profile$genomes$genome_id, fxGenomes()) + expect_true("g5" %in% profile$phenotypes$genome_id) + expect_equal(nrow(profile$excluded_genomes), 0L) +}) + +test_that("only genomes without a usable phenotype are excluded", { + metadata <- fxMetadataRows( + genome = c("g1", "g2", "g3"), drug = "DRA", + phenotype = c("Resistant", "Intermediate", "Susceptible") + ) + expect_message( + profile <- fxProfile(metadata, fxParquetsFor(c("g1", "g2"))), + "1 genomes are excluded" + ) + expect_equal(profile$genomes$genome_id, c("g1", "g3")) + expect_equal(profile$excluded_genomes$genome_id, "g2") + expect_equal(profile$excluded_genomes$reason, "no_usable_phenotype") +}) + +test_that("an ORB with no genome left to profile is an error that lists the reasons", { + metadata <- fxMetadataRows(genome = "g1", drug = "DRA", phenotype = "Intermediate") + + err <- expect_error(fxProfile(metadata), class = "amrml_no_labelled_genomes") + expect_equal(err$observed$excluded$reason, "no_usable_phenotype") +}) + +# Class phenotypes + +test_that("a class is Resistant if any member drug is, Susceptible only if all are", { + metadata <- fxMetadataRows( + genome = c("g1", "g1", "g2", "g2", "g3"), + drug = c("DRA", "DRB", "DRA", "DRB", "DRA"), + phenotype = c("Resistant", "Susceptible", "Susceptible", "Susceptible", "Susceptible") + ) + profile <- fxProfile(metadata) + classes <- profile$phenotypes[profile$phenotypes$unit == "drug_class", ] + + expect_equal(classes$genome_id, c("g1", "g2", "g3")) + expect_equal(classes$phenotype, c("Resistant", "Susceptible", "Susceptible")) +}) + +test_that("a drug with no class keeps its drug phenotype but adds no class phenotype", { + metadata <- fxMetadataRows( + genome = c("g1", "g1"), + drug = c("DRA", "DRZ"), + phenotype = "Resistant", + class = c("CLX", NA) + ) + profile <- fxProfile(metadata) + + expect_equal(fxTarget(profile, "drug", "DRZ")$n_resistant, 1) + expect_equal(unique(profile$targets$target[profile$targets$unit == "drug_class"]), "CLX") + expect_equal(profile$drug_classes, tibble::tibble(drug = "DRA", class = "CLX")) +}) + +# Genomes and strata + +test_that("a genome with two values for a stratum is rejected", { + metadata <- fxMetadataRows( + genome = c("g1", "g1"), + drug = c("DRA", "DRB"), + phenotype = "Resistant", + country = c("CX", "CY") + ) + + err <- expect_error(fxProfile(metadata), class = "amrml_stratum_inconsistent") + expect_equal(err$observed$genomes, "g1") +}) + +test_that("profiling counts by whatever strata the registry lists", { + local_mocked_bindings(.STRATA = c(.STRATA, host = "genome.host_common_name")) + metadata <- fxMetadataRows(genome = c("g1", "g2"), drug = "DRA", phenotype = "Resistant") + metadata$genome.host_common_name <- c("Human", "Cow") + profile <- fxProfile(metadata) + + by_host <- profile$targets[profile$targets$stratum %in% "host", ] + expect_equal(profile$genomes$host, c("Human", "Cow")) + expect_setequal(by_host$stratum_value, c("Human", "Cow")) +}) + +test_that("a stratum column the metadata lacks is left out, not an error", { + metadata <- fxMetadata() + metadata$year_bin <- NULL + profile <- fxProfile(metadata) + + expect_false("year" %in% names(profile$genomes)) + expect_equal(unique(stats::na.omit(profile$targets$stratum)), "country") +}) + +# Counts + +test_that("strata count observed values; genomes without one count in the whole dataset only", { + metadata <- fxMetadataRows( + genome = c("g1", "g2", "g3", "g4"), + drug = "DRA", + phenotype = "Resistant", + country = c("CX", "CY", NA, ""), + year_bin = factor("2000-2004", levels = c("1995-1999", "2000-2004", "2005-2009")) + ) + profile <- fxProfile(metadata) + targets <- profile$targets + by_country <- targets[targets$stratum %in% "country" & targets$unit == "drug", ] + + expect_type(profile$genomes$year, "character") + expect_equal(unique(targets$stratum_value[targets$stratum %in% "year"]), "2000-2004") + expect_equal(by_country$stratum_value, c("CX", "CY")) + expect_equal(by_country$n_genomes, c(1, 1)) + expect_equal(fxTarget(profile, "drug", "DRA")$n_genomes, 4) +}) + +# The profile object + +test_that("the profile has its parts and prints a summary", { + profile <- fxProfile() + + expect_s3_class(profile, "amr_orb_profile") + expect_named( + profile, + c("orb", "genomes", "phenotypes", "drug_classes", "targets", "excluded_genomes") + ) + expect_output(print(profile), "5 profiled, 0 excluded") + expect_output(print(profile), "country \\(values: 1, missing: 0\\)") + expect_output(print(profile), "DRA:5/0, DRB:0/5") + expect_output(print(profile), "CLX:5/0") +}) + +test_that("profiling does not write to the ORB", { + dir <- fxOrb() + orb <- readORB(dir) + before <- fxOrbState(dir) + + profileORB(orb) + + expect_equal(fxOrbState(dir), before) +}) diff --git a/tests/testthat/test-orb-read.R b/tests/testthat/test-orb-read.R new file mode 100644 index 0000000..671229c --- /dev/null +++ b/tests/testthat/test-orb-read.R @@ -0,0 +1,605 @@ +# Tests for readORB(), in the order it reads an ORB. + +# The path argument + +test_that("readORB() requires a single directory path", { + expect_error(readORB(), class = "amrml_invalid_argument") + expect_error(readORB(c("a", "b")), class = "amrml_invalid_argument") + expect_error(readORB(""), class = "amrml_invalid_argument") +}) + +test_that("readORB() tells a missing directory from one with no manifest", { + expect_error( + readORB(file.path(tempdir(), "definitely-not-here")), + class = "amrml_orb_dir_not_found" + ) + expect_error(readORB(withr::local_tempdir()), class = "amrml_manifest_not_found") +}) + +# Finding manifests + +test_that("only top-level manifest files are found", { + dir <- withr::local_tempdir() + writeLines("42", file.path(dir, "settings.json")) + nested <- file.path(dir, "nested") + dir.create(nested) + fxWriteManifest(nested, fxManifest()) + + expect_error(readORB(dir), class = "amrml_manifest_not_found") +}) + +# The checked record + +test_that("declared files keep each path with its size, and modified_at is optional", { + run <- fxManifest()$runs[[1]] + run$stages[[1]]$outputs[[2]]$modified_at <- NULL + + expect_equal(.declaredFiles(run, "/orb/manifest.json"), tibble::tibble( + path = c("/orb/metadata.parquet", "/orb/gene_count.parquet", "/orb/Tst_parquet.duckdb"), + name = c("metadata.parquet", "gene_count.parquet", "Tst_parquet.duckdb"), + size_bytes = c(100, 200, 0), + modified_at = c("2026-01-01 00:00:01", NA_character_, "2026-01-01 00:00:01") + )) +}) + +test_that("declared file sizes must be non-negative numbers", { + for (size in list("100", Inf, -1)) { + run <- fxManifest()$runs[[1]] + run$stages[[1]]$outputs[[1]]$size_bytes <- size + expect_error(.declaredFiles(run, "/orb/manifest.json"), "invalid path or size", fixed = TRUE) + } +}) + +test_that("the record keeps the fields the reader uses", { + expect_silent(record <- .manifestRecord("/orb/manifest.json", fxManifest())) + + expect_equal(record$manifest_path, "/orb/manifest.json") + expect_equal(record$dataset_id, "Tst") + expect_equal(record$directory, "/orb") + expect_equal(record$metadata_parquet, "/orb/metadata.parquet") + expect_equal(record$producer, "amRdata") + expect_equal(record$producer_run_id, "run_fixture_producer") + expect_equal(record$finished_at, "2026-01-01 00:00:01") +}) + +test_that("the dataset label lists what amRdata was asked for, or the dataset ID", { + manifest <- fxManifest() + manifest$dataset$selection$user_bacs <- list("Species one", "Species two") + expect_equal(.manifestRecord("m.json", manifest)$dataset_label, "Species one, Species two") + + manifest$dataset$selection$user_bacs <- NULL + expect_equal(.manifestRecord("m.json", manifest)$dataset_label, "Tst") +}) + +test_that("the record follows the artifact's producer run and its export stage", { + manifest <- fxManifest() + producer <- manifest$runs[[1]] + other_run <- producer + other_run$run_id <- "unrelated" + other_run$finished_at <- "2030-01-01 00:00:00" + last_run <- other_run + last_run$run_id <- "also_unrelated" + producer$stages <- c( + list(list(name = "before_export", outputs = list())), producer$stages, + list(list(name = "after_export", outputs = list())) + ) + # The producer run and its export stage are neither first nor last. + manifest$runs <- list(other_run, producer, last_run) + + record <- .manifestRecord("m.json", manifest) + expect_equal(record$producer_run_id, "run_fixture_producer") + expect_equal(record$finished_at, "2026-01-01 00:00:01") + expect_equal(record$files$name, c("metadata.parquet", "gene_count.parquet", "Tst_parquet.duckdb")) +}) + +test_that("an unready artifact or failed producer run is returned as an error, not thrown", { + expect_silent(error <- .manifestRecord("m.json", fxManifest(artifact_status = "building"))) + expect_s3_class(error, "amrml_orb_not_ready") + expect_equal(error$observed$status, "building") + + manifest <- fxManifest() + manifest$artifacts <- list() + expect_equal(.manifestRecord("m.json", manifest)$observed$status, "absent") + + expect_silent(error <- .manifestRecord("m.json", fxManifest(producer_status = "failed"))) + expect_s3_class(error, "amrml_producer_run_invalid") + expect_equal(error$observed, list(producer_run_id = "run_fixture_producer", status = "failed")) + + manifest <- fxManifest() + manifest$artifacts$amRml_input$producer_run_id <- "missing_run" + expect_equal(.manifestRecord("m.json", manifest)$observed$status, "missing") +}) + +test_that("the metadata file must be among the declared files", { + manifest <- fxManifest() + manifest$artifacts$amRml_input$metadata_parquet <- "/orb/undeclared.parquet" + + expect_error(.manifestRecord("m.json", manifest), "undeclared.parquet", fixed = TRUE) +}) + +# Checking each manifest + +test_that("unreadable JSON and invalid contents are told apart", { + dir <- withr::local_tempdir() + path <- file.path(dir, fxManifestName()) + + writeLines("{ not json", path) + expect_silent(error <- .manifestReadiness(path)) + expect_s3_class(error, "amrml_manifest_unreadable") + + writeLines("42", path) + expect_silent(error <- .manifestReadiness(path)) + expect_s3_class(error, "amrml_manifest_invalid") +}) + +test_that("a malformed field is recorded as manifest_invalid, naming the field", { + broken <- list( + "amRdata v1" = function(m) { + m$schema_version <- 2L + m + }, + "metadata_parquet" = function(m) { + m$artifacts$amRml_input$metadata_parquet <- NULL + m + }, + "finished_at" = function(m) { + m$runs[[1]]$finished_at <- "invalid" + m + }, + "clean_metadata_and_export" = function(m) { + m$runs[[1]]$stages <- list() + m + }, + # `$` would have matched path_original as path; the field must be named exactly. + "invalid path or size" = function(m) { + output <- m$runs[[1]]$stages[[1]]$outputs[[1]] + names(output)[names(output) == "path"] <- "path_original" + m$runs[[1]]$stages[[1]]$outputs[[1]] <- output + m + } + ) + dir <- withr::local_tempdir() + path <- file.path(dir, fxManifestName()) + + for (reason in names(broken)) { + fxWriteManifest(dir, broken[[reason]](fxManifest())) + expect_silent(error <- .manifestReadiness(path)) + expect_s3_class(error, "amrml_manifest_invalid") + expect_match(error$observed$error, reason, fixed = TRUE) + } + + # A shape the checks don't expect is still manifest_invalid, not an R error. + manifest <- fxManifest() + manifest$artifacts$amRml_input <- 42 + fxWriteManifest(dir, manifest) + expect_s3_class(.manifestReadiness(path), "amrml_manifest_invalid") +}) + +# Choosing the newest manifest + +test_that(".newestReady() picks the latest finish, then the first file name", { + older <- list(manifest_path = "a.json", finished_at = "2026-01-01 00:00:01.5") + newer <- list(manifest_path = "z.json", finished_at = "2026-01-01 00:00:02") + expect_identical(.newestReady(list(older, newer)), newer) + expect_identical(.newestReady(list(newer, older)), newer) + + tied <- list(manifest_path = "b.json", finished_at = "2026-01-01 00:00:02") + expect_identical(.newestReady(list(newer, tied)), tied) + expect_identical(.newestReady(list(tied, newer)), tied) + + # Fractional seconds sort correctly as text. + quarter <- list(manifest_path = "q.json", finished_at = "2026-01-01 00:00:01.25") + expect_identical(.newestReady(list(older, quarter)), older) +}) + +test_that("the newest producer run wins, not the newest file, with a message", { + dir <- fxOrb() + + # An older run in a newer file. + older <- fxReadManifest(dir) + older$runs[[1]]$finished_at <- "2020-01-01 00:00:00" + fxWriteManifest(dir, older, "manifest_run_older.json") + Sys.setFileTime(file.path(dir, "manifest_run_older.json"), Sys.time() + 3600) + + expect_message( + orb <- readORB(dir), + "manifest_run_fixture.json, the newest of 2 ready manifests" + ) + expect_equal(basename(orb$manifest_path), fxManifestName()) + + newer <- fxReadManifest(dir) + newer$runs[[1]]$finished_at <- "2030-01-01 00:00:00" + fxWriteManifest(dir, newer, "manifest_run_newer.json") + + expect_message(orb <- readORB(dir), "newest of 3 ready manifests") + expect_equal(basename(orb$manifest_path), "manifest_run_newer.json") +}) + +test_that("a building manifest beside a ready one does not stop the ready one", { + dir <- fxOrb() + building <- fxReadManifest(dir) + building$artifacts$amRml_input$status <- "building" + fxWriteManifest(dir, building, "manifest_run_failed.json") + + expect_equal(basename(readORB(dir)$manifest_path), fxManifestName()) +}) + +test_that("when no manifest is usable, every manifest's reason is reported", { + dir <- fxOrb(artifact_status = "building") + broken <- fxReadManifest(dir) + broken$artifacts$amRml_input$status <- "ready" + broken$runs[[1]]$finished_at <- "invalid" + fxWriteManifest(dir, broken, "manifest_run_broken.json") + + cnd <- rlang::catch_cnd(readORB(dir), classes = "amrml_error") + expect_s3_class(cnd, "amrml_orb_no_usable_manifest") + expect_s3_class(cnd$observed[[fxManifestName()]], "amrml_orb_not_ready") + expect_s3_class(cnd$observed$manifest_run_broken.json, "amrml_manifest_invalid") + + message <- conditionMessage(cnd) + for (text in c(fxManifestName(), "building", "manifest_run_broken.json", "finished_at")) { + expect_match(message, text, fixed = TRUE) + } +}) + +# Recorded paths may come from another machine or operating system. + +test_that("readORB resolves recorded filenames from different platforms", { + prefixes <- c( + relative = "", + posix = "/old results/orb/", + windows = r"(C:\old results\orb\)", + windows_forward = "C:/old results/orb/", + windows_doubled = r"(C:\\old results\\orb\\)", + unc = r"(\\server\share\old results\orb\)" + ) + + for (prefix in prefixes) { + dir <- fxOrb() + fxEditManifest(dir, function(m) { + m$runs[[1]]$stages[[1]]$outputs <- lapply( + m$runs[[1]]$stages[[1]]$outputs, + function(o) { + o$path <- paste0(prefix, basename(o$path)) + o + } + ) + m$artifacts$amRml_input$directory <- "." + m$artifacts$amRml_input$metadata_parquet <- "metadata.parquet" + m + }) + before <- fxOrbState(dir) + + expect_silent(orb <- readORB(dir)) + expect_equal(orb$metadata_parquet, file.path(normalizePath(dir), "metadata.parquet")) + expect_true(all(dirname(orb$files$path) == normalizePath(dir))) + expect_equal(orb$feature_tables$feature_type, c("gene", "widget")) + expect_equal(fxOrbState(dir), before) + } +}) + +test_that("the metadata artifact also accepts a Windows path", { + dir <- fxOrb() + fxEditManifest(dir, function(m) { + m$artifacts$amRml_input$metadata_parquet <- r"(C:\old results\orb\metadata.parquet)" + m + }) + + expect_silent(orb <- readORB(dir)) + expect_equal(orb$metadata_parquet, file.path(normalizePath(dir), "metadata.parquet")) +}) + +test_that("Windows manifest paths preserve missing-file and size checks", { + dir <- fxOrb() + fxEditManifest(dir, function(m) { + m$runs[[1]]$stages[[1]]$outputs <- lapply( + m$runs[[1]]$stages[[1]]$outputs, + function(o) { + o$path <- paste0(r"(C:\old results\orb\)", basename(o$path)) + o + } + ) + m$artifacts$amRml_input$metadata_parquet <- "metadata.parquet" + m + }) + + path <- file.path(dir, "weird.parquet") + unlink(path) + expect_error(readORB(dir), class = "amrml_orb_files_missing") + + writeLines("changed", path) + error <- rlang::catch_cnd(readORB(dir), classes = "amrml_error") + expect_s3_class(error, "amrml_orb_file_changed") + expect_equal(basename(error$observed$file), "weird.parquet") +}) + +# Checking the ORB's files + +test_that("a moved ORB resolves its files in the new directory without writing", { + dir <- fxOrb() + destination <- file.path(withr::local_tempdir(), "moved orb") + expect_true(file.rename(dir, destination)) + destination <- normalizePath(destination) + before <- fxOrbState(destination) + + expect_silent(orb <- readORB(destination)) + expect_equal(orb$directory, destination) + expect_true(all(dirname(orb$files$path) == destination)) + expect_equal(orb$metadata_parquet, file.path(destination, "metadata.parquet")) + expect_equal(fxOrbState(destination), before) +}) + +test_that("a missing declared file is refused", { + dir <- fxOrb() + unlink(file.path(dir, "weird.parquet")) + + cnd <- rlang::catch_cnd(readORB(dir), classes = "amrml_error") + expect_s3_class(cnd, "amrml_orb_files_missing") + expect_equal(basename(cnd$observed$missing), "weird.parquet") + expect_equal(rlang::call_name(cnd$call), "readORB") +}) + +test_that("an unreadable declared file counts as missing", { + skip_on_os("windows") + skip_if(Sys.info()[["user"]] == "root", "root can read any file") + + dir <- fxOrb() + path <- file.path(dir, "weird.parquet") + Sys.chmod(path, "000") + withr::defer(Sys.chmod(path, "644")) + + cnd <- rlang::catch_cnd(readORB(dir), classes = "amrml_error") + expect_s3_class(cnd, "amrml_orb_files_missing") + expect_equal(basename(cnd$observed$missing), "weird.parquet") +}) + +test_that("the file check reports only files whose size changed, with both sizes", { + dir <- normalizePath(withr::local_tempdir()) + paths <- file.path(dir, c("first", "second", "empty")) + writeBin(charToRaw("abc"), paths[[1]]) + writeBin(charToRaw("12345"), paths[[2]]) + file.create(paths[[3]]) + record <- list(directory = dir, files = tibble::tibble( + path = paths, name = c("first", "second", "empty"), size_bytes = c(3, 5, 0) + )) + expect_no_error(.checkOrbFiles(record, call = NULL)) + + record$files$size_bytes <- c(1, 10, 0) + error <- rlang::catch_cnd(.checkOrbFiles(record, call = NULL), classes = "error") + expect_s3_class(error, "amrml_orb_file_changed") + expect_equal(error$observed, list( + file = paths[1:2], size_bytes = c(1, 10), actual_bytes = c(3, 5) + )) +}) + +test_that("a failed file check never falls back to an older usable manifest", { + dir <- fxOrb() + + # The older manifest doesn't declare weird.parquet, so on its own it reads. + newest <- fxReadManifest(dir) + older <- newest + older$runs[[1]]$finished_at <- "2020-01-01 00:00:00" + older$runs[[1]]$stages[[1]]$outputs <- Filter( + function(o) basename(o$path) != "weird.parquet", older$runs[[1]]$stages[[1]]$outputs + ) + fxWriteManifest(dir, older) + unlink(file.path(dir, "weird.parquet")) + expect_equal(basename(readORB(dir)$manifest_path), fxManifestName()) + + fxWriteManifest(dir, newest, "manifest_run_newer.json") + expect_error( + expect_message(readORB(dir), "newest of 2 ready manifests"), + class = "amrml_orb_files_missing" + ) +}) + +# Feature tables + +test_that("feature tables are found by their columns, whatever their order or file name", { + dir <- withr::local_tempdir() + tables <- list( + a_widget = tibble::tibble(value = 1, widget = "w", genome_id = "g"), + z_gene = tibble::tibble(gene = "a", genome_id = "g", value = 1), + no_genome = tibble::tibble(other = "g", gene = "a", value = 1), + no_value = tibble::tibble(genome_id = "g", gene = "a", other = 1), + extra = tibble::tibble(genome_id = "g", gene = "a", value = 1, extra = 2) + ) + paths <- file.path(dir, paste0(names(tables), ".parquet")) + for (i in seq_along(paths)) { + arrow::write_parquet(tables[[i]], paths[[i]]) + } + files <- tibble::tibble(path = paths, name = basename(paths)) + + expect_equal(.featureTables(files, call = NULL), tibble::tibble( + feature_type = c("gene", "widget"), path = paths[c(2, 1)] + )) +}) + +test_that("feature tables sort the same way in any locale", { + # Tests run in the C locale; in en_US a plain sort puts "gene" before "Pfam". + skip_on_os("windows") + skip_if_not("en_US.UTF-8" %in% system2("locale", "-a", stdout = TRUE)) + withr::local_collate("en_US.UTF-8") + skip_if_not(identical(sort(c("Pfam", "gene")), c("gene", "Pfam"))) + + dir <- withr::local_tempdir() + paths <- file.path(dir, c("gene.parquet", "pfam.parquet")) + arrow::write_parquet(tibble::tibble(genome_id = "g", gene = "a", value = 1), paths[[1]]) + arrow::write_parquet(tibble::tibble(genome_id = "g", Pfam = "a", value = 1), paths[[2]]) + files <- tibble::tibble(path = paths, name = basename(paths)) + + expect_equal(.featureTables(files, call = NULL)$feature_type, c("Pfam", "gene")) +}) + +test_that("undeclared parquet files are ignored", { + dir <- fxOrb() + writeLines("not Parquet", file.path(dir, "undeclared.parquet")) + + orb <- readORB(dir) + expect_equal(orb$feature_tables$feature_type, c("gene", "widget")) + expect_false("undeclared.parquet" %in% orb$files$name) +}) + +test_that("an unreadable declared parquet is an error, not a smaller feature set", { + dir <- fxOrb() + writeLines("this is not parquet", file.path(dir, "weird.parquet")) + fxRecordSizes(dir) + + cnd <- rlang::catch_cnd(readORB(dir), classes = "amrml_error") + expect_s3_class(cnd, "amrml_parquet_unreadable") + expect_equal(basename(cnd$observed$file), "weird.parquet") +}) + +test_that("an ORB with no feature tables is refused", { + dir <- fxOrb(parquets = fxDefaultParquets()["decoy_count"]) + + expect_error(readORB(dir), class = "amrml_orb_no_feature_tables") +}) + +test_that("two feature tables sharing a feature ID column are refused", { + parquets <- fxDefaultParquets() + parquets$gene_again <- parquets$gene_count + dir <- fxOrb(parquets = parquets) + + cnd <- rlang::catch_cnd(readORB(dir), classes = "amrml_error") + expect_s3_class(cnd, "amrml_orb_duplicate_feature_type") + expect_equal(cnd$observed$feature_type, "gene") +}) + +# The ORB object + +test_that("readORB() opens a valid ORB and describes it", { + dir <- fxOrb() + expect_no_message(orb <- readORB(file.path(dir, "."))) + + expect_s3_class(orb, "amr_orb") + expect_setequal(names(orb), c( + "dataset_id", "dataset_label", "directory", "manifest_path", "metadata_parquet", + "producer", "producer_run_id", "finished_at", "files", "feature_tables" + )) + expect_equal(orb$dataset_id, "Tst") + expect_equal(orb$dataset_label, "Testus fixtus") + expect_equal(orb$directory, normalizePath(dir)) + expect_equal(orb$manifest_path, file.path(normalizePath(dir), fxManifestName())) + expect_equal(orb$metadata_parquet, file.path(normalizePath(dir), "metadata.parquet")) + expect_equal(orb$producer, "amRdata") + expect_equal(orb$producer_run_id, "run_fixture_producer") + expect_equal(orb$finished_at, "2026-01-01 00:00:01") + expect_setequal(orb$files$name, c( + "metadata.parquet", "gene_count.parquet", "weird.parquet", + "decoy_count.parquet", "Tst_parquet.duckdb" + )) + expect_equal(orb$feature_tables, tibble::tibble( + feature_type = c("gene", "widget"), + path = file.path(normalizePath(dir), c("gene_count.parquet", "weird.parquet")) + )) +}) + +test_that("readORB() does not write to the ORB", { + dir <- fxOrb() + before <- fxOrbState(dir) + + readORB(dir) + + expect_equal(fxOrbState(dir), before) +}) + +test_that("printing an ORB shows its summary and returns it invisibly", { + orb <- readORB(fxOrb()) + output <- paste(capture.output(result <- withVisible(print(orb))), collapse = "\n") + + for (text in c( + "Tst", "Testus fixtus", orb$directory, fxManifestName(), + "2026-01-01 00:00:01", "5 files", "gene, widget" + )) { + expect_match(output, text, fixed = TRUE) + } + expect_identical(result$value, orb) + expect_false(result$visible) +}) + +# Listing and choosing ORBs + +# Stand in for the amRdata registry with the manifests of `dirs`. +fxRegistry <- function(dirs, env = parent.frame()) { + testthat::local_mocked_bindings( + .registryManifests = function() file.path(dirs, fxManifestName()), + .env = env + ) +} + +test_that("listORBs() lists registered ORBs and those found under root, each once", { + registered <- fxOrb() + root <- withr::local_tempdir() + found <- file.path(root, "data", "Tst", "orb") + dir.create(found, recursive = TRUE) + fxWriteManifest(found, fxReadManifest(registered)) + fxRegistry(c(registered, found)) + + orbs <- listORBs(root) + expect_equal(nrow(orbs), 2L) + expect_true(all(orbs$usable)) + expect_setequal(orbs$directory, normalizePath(c(registered, found))) + expect_equal(orbs$source[orbs$directory == normalizePath(found)], "both") + expect_equal(orbs$source[orbs$directory == normalizePath(registered)], "registry") + + fxRegistry(character()) + expect_equal(listORBs(root)$source, "root") + expect_equal(nrow(listORBs()), 0L) +}) + +test_that("one ORB's problem is a row, not an error", { + good <- fxOrb() + unready <- fxOrb(artifact_status = "building") + gone <- file.path(tempdir(), "no-such-orb") + fxRegistry(c(unready, gone, good)) + + orbs <- listORBs() + expect_equal(orbs$directory[[1]], normalizePath(good)) + expect_equal(orbs$usable, c(TRUE, FALSE, FALSE)) + expect_equal( + orbs$rule_id[match(normalizePath(c(unready, gone), mustWork = FALSE), orbs$directory)], + c("orb_not_ready", "orb_dir_not_found") + ) +}) + +test_that("a bad root is an error and unreadable folders under it are warned about", { + fxRegistry(character()) + expect_error(listORBs(c("a", "b")), class = "amrml_invalid_argument") + expect_error(listORBs(file.path(tempdir(), "no-such-root")), class = "amrml_orb_dir_not_found") + + skip_on_os("windows") + skip_if(identical(Sys.info()[["user"]], "root"), "root ignores permissions") + root <- withr::local_tempdir() + locked <- file.path(root, "locked") + dir.create(locked) + Sys.chmod(locked, "000") + withr::defer(Sys.chmod(locked, "755")) + + expect_warning(listORBs(root), "can't be read") + Sys.chmod(root, "000") + expect_error(listORBs(root), class = "amrml_orb_dir_unreadable") + Sys.chmod(root, "755") +}) + +test_that("readORB() without a path picks from the registry, interactively only", { + one <- fxOrb() + two <- fxOrb() + fxRegistry(one) + withr::local_options(rlang_interactive = TRUE) + + expect_message(orb <- readORB(), "Using ORB") + expect_equal(orb$directory, normalizePath(one)) + + fxRegistry(c(one, two)) + local_mocked_bindings(menu = function(choices, title) 2L, .package = "utils") + expect_equal(readORB()$directory, listORBs()$directory[[2]]) + local_mocked_bindings(menu = function(choices, title) 0L, .package = "utils") + expect_error(readORB(), class = "amrml_invalid_argument") + + fxRegistry(character()) + expect_error(readORB(), class = "amrml_no_orbs_found") + + withr::local_options(rlang_interactive = FALSE) + expect_error(readORB(), class = "amrml_invalid_argument") +}) diff --git a/tests/testthat/test-plan-matrices.R b/tests/testthat/test-plan-matrices.R new file mode 100644 index 0000000..26b59e1 --- /dev/null +++ b/tests/testthat/test-plan-matrices.R @@ -0,0 +1,20 @@ +# Tests for planMatrices() and its `modes` choice. + +test_that("modes keeps the plan and its members to the modes asked for", { + eligibility <- eligibleScopes(profileORB(readORB(fxOrb()))) + planned <- unique(planMatrices(eligibility)$matrices$mode_id) + other <- setdiff(.MODES$mode_id, planned)[[1]] + + kept <- planMatrices(eligibility, modes = planned) + dropped <- planMatrices(eligibility, modes = other) + + expect_equal(kept$matrices, planMatrices(eligibility)$matrices) + expect_equal(nrow(dropped$matrices), 0L) + expect_equal(nrow(dropped$eligibility$members), 0L) +}) + +test_that("unknown modes are rejected", { + eligibility <- eligibleScopes(profileORB(readORB(fxOrb()))) + + expect_error(planMatrices(eligibility, modes = "nope"), class = "amrml_invalid_argument") +}) diff --git a/tests/testthat/test-sparse-matrices.R b/tests/testthat/test-sparse-matrices.R new file mode 100644 index 0000000..ab669c5 --- /dev/null +++ b/tests/testthat/test-sparse-matrices.R @@ -0,0 +1,26 @@ +test_that("sparse storage keeps a labelled genome with no observed features", { + metadata <- fxRows(10, 10) + genes <- fxSignalGenes(10, 10) + genes <- genes[genes$genome_id != "g020", ] + eligibility <- fxEligibility(metadata, modes = "vanilla", min_genomes = 4, + n_fold = 2, parquets = list(gene_count = genes)) + out <- withr::local_tempdir() + built <- buildMatrices(planMatrices(eligibility), out) + store <- readRDS(file.path(built$out_dir, unique(built$matrices$file)[[1]])) + row <- match("g020", store$genomes) + expect_false(is.na(row)) + expect_equal(as.numeric(store$values[row, ]), rep(0, ncol(store$values))) + index <- readRDS(file.path(built$out_dir, "matrix_index.rds")) + expect_true(all(vapply(index$rows, function(rows) "g020" %in% rows$genome_id, logical(1)))) +}) + +test_that("feature presets select available tables and explicit names stay strict", { + eligibility <- fxEligibility(fxRows(4, 4), modes = "vanilla", min_genomes = 4, n_fold = 2) + for (preset in c("quick", "standard", "full")) { + plan <- planMatrices(eligibility, feature_types = preset) + expect_equal(unique(plan$matrices$feature_type), "gene") + } + explicit <- planMatrices(eligibility, feature_types = "widget") + expect_equal(unique(explicit$matrices$feature_type), "widget") + expect_error(planMatrices(eligibility, feature_types = "typo"), class = "amrml_invalid_argument") +})