diff --git a/..Rcheck/00check.log b/..Rcheck/00check.log deleted file mode 100644 index 71f667c..0000000 --- a/..Rcheck/00check.log +++ /dev/null @@ -1,13 +0,0 @@ -* using log directory ‘/home/veit/devel/Bioinformatics/DataAnalysis/ShinyApps/PolySTest/..Rcheck’ -* using R version 4.4.1 (2024-06-14) -* using platform: x86_64-pc-linux-gnu -* R was compiled by - gcc (Ubuntu 13.2.0-23ubuntu4) 13.2.0 - GNU Fortran (Ubuntu 13.2.0-23ubuntu4) 13.2.0 -* running under: Ubuntu 24.04.1 LTS -* using session charset: UTF-8 -* checking for file ‘./DESCRIPTION’ ... ERROR -Required fields missing or empty: - ‘Author’ ‘Maintainer’ -* DONE -Status: 1 ERROR diff --git a/.Rbuildignore b/.Rbuildignore index 91114bf..d77d2a7 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,2 +1,8 @@ ^.*\.Rproj$ ^\.Rproj\.user$ +^\.dockerignore$ +^\.git$ +^\.github$ +^artifacts$ +^Rplots\.pdf$ +^.*\.Rcheck$ diff --git a/.dockerignore b/.dockerignore new file mode 100644 index 0000000..b183fe0 --- /dev/null +++ b/.dockerignore @@ -0,0 +1,11 @@ +.git +.agents +.codex +artifacts +.Rproj.user +.Rhistory +.RData +.Ruserdata +*.Rproj +Rplots.pdf +*.Rcheck diff --git a/.gitignore b/.gitignore index cb64020..77dd1d0 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ .RData .Ruserdata PolySTest.Rproj +/artifacts/ +*.Rcheck/ diff --git a/DESCRIPTION b/DESCRIPTION index 7cd85c4..7141165 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,7 +24,7 @@ Imports: limma (>= 3.61.3), matrixStats (>= 0.57.0), qvalue (>= 2.22.0), - shiny (>= 1.5.0), + shiny (>= 1.8.1), SummarizedExperiment (>= 1.20.0), knitr (>= 1.33), plotly (>= 4.9.4), @@ -34,13 +34,19 @@ Imports: gplots (>= 3.1.1), S4Vectors (>= 0.30.0), parallel (>= 4.1.0), + methods (>= 4.1.0), grDevices (>= 4.1.0), graphics (>= 4.1.0), stats (>= 4.1.0), utils (>= 4.1.0) Suggests: testthat (>= 3.0.0), - BiocStyle + BiocStyle, + mirai, + missBayes, + promises, + rjags +Config/PolySTest/missBayes-commit: cd283693a16336d49e49a4132acc05822f92b2d6 VignetteBuilder: knitr Config/testthat/edition: 3 diff --git a/R/MissBayesAdapter.R b/R/MissBayesAdapter.R new file mode 100644 index 0000000..893621d --- /dev/null +++ b/R/MissBayesAdapter.R @@ -0,0 +1,647 @@ +# Internal adapter functions for the optional MissBayes workflow. +# +# These functions deliberately have no Shiny dependencies. They prepare an +# immutable snapshot, invoke the optional package through an injectable +# function, and normalize its output without changing PolySTest state. + +missbayes_default_settings <- function() { + list( + filter4NAs = FALSE, + threshold = 0, + parallel = FALSE, + n.adapt = 1000L, + burn.in = 500L, + n.iter = 10000L, + n.chains = 2L, + mcmcDiag = TRUE + ) +} + +validate_missbayes_settings <- function(settings = missbayes_default_settings()) { + defaults <- missbayes_default_settings() + if (!is.list(settings) || is.null(names(settings))) { + stop("MissBayes settings must be a named list.") + } + unknown <- setdiff(names(settings), names(defaults)) + if (length(unknown) > 0) { + stop( + "Unknown MissBayes settings: ", + paste(unknown, collapse = ", "), "." + ) + } + settings <- utils::modifyList(defaults, settings) + + if (!identical(settings$filter4NAs, FALSE)) { + stop("MissBayes filter4NAs must be FALSE for normalized row alignment.") + } + if (!identical(settings$threshold, 0) && + !identical(settings$threshold, 0L)) { + stop("MissBayes threshold is fixed at 0 for the initial integration.") + } + if (!identical(settings$parallel, FALSE)) { + stop("MissBayes internal parallel processing must be FALSE.") + } + if (!identical(settings$mcmcDiag, TRUE)) { + stop("MissBayes MCMC diagnostics must be enabled.") + } + + integer_fields <- c("n.adapt", "burn.in", "n.iter", "n.chains") + for (field in integer_fields) { + value <- settings[[field]] + if (length(value) != 1L || is.na(value) || !is.finite(value) || + value <= 0 || value != as.integer(value)) { + stop("MissBayes ", field, " must be a positive integer.") + } + settings[[field]] <- as.integer(value) + } + if (settings$n.chains != 2L) { + stop("MissBayes n.chains is fixed at 2 for the initial integration.") + } + + settings$threshold <- 0 + settings +} + +validate_missbayes_comparison_snapshot <- function(snapshot, + available_conditions) { + conditions <- as.character(available_conditions) + if (length(conditions) < 2L || anyNA(conditions) || + any(!nzchar(conditions)) || anyDuplicated(conditions)) { + stop("Available conditions must be unique, non-empty names.") + } + + if (is.data.frame(snapshot) || is.matrix(snapshot)) { + if (nrow(snapshot) != 1L || ncol(snapshot) != 2L) { + stop("A MissBayes comparison snapshot must contain exactly one pair.") + } + if (!is.null(colnames(snapshot)) && + all(c("reference", "target") %in% colnames(snapshot))) { + reference <- snapshot[1L, "reference"] + target <- snapshot[1L, "target"] + } else { + reference <- snapshot[1L, 1L] + target <- snapshot[1L, 2L] + } + } else if (is.list(snapshot) && + all(c("reference", "target") %in% names(snapshot))) { + reference <- snapshot$reference + target <- snapshot$target + } else { + stop( + "A MissBayes comparison snapshot must supply reference and target." + ) + } + + reference <- as.character(reference) + target <- as.character(target) + if (length(reference) != 1L || length(target) != 1L || + is.na(reference) || is.na(target) || + !nzchar(reference) || !nzchar(target)) { + stop("MissBayes reference and target must be single, non-empty names.") + } + if (identical(reference, target)) { + stop("MissBayes reference and target conditions must differ.") + } + missing_conditions <- setdiff(c(reference, target), conditions) + if (length(missing_conditions) > 0L) { + stop( + "MissBayes comparison contains unknown conditions: ", + paste(missing_conditions, collapse = ", "), "." + ) + } + + list( + reference = reference, + target = target, + name = paste0(target, "_vs_", reference) + ) +} + +.validate_missbayes_probability_cutoff <- function(alpha) { + if (!is.numeric(alpha) || length(alpha) != 1L || is.na(alpha) || + !is.finite(alpha) || alpha < 0 || alpha >= 0.5) { + stop("MissBayes alpha must be a finite value in [0, 0.5).") + } + as.numeric(alpha) +} + +.validate_missbayes_rope_half_width <- function(rope_half_width) { + if (!is.numeric(rope_half_width) || length(rope_half_width) != 1L || + is.na(rope_half_width) || !is.finite(rope_half_width) || + rope_half_width < 0) { + stop("MissBayes ROPE half-width must be a finite non-negative value.") + } + as.numeric(rope_half_width) +} + +.validate_missbayes_seed <- function(seed) { + if (is.null(seed)) { + return(NULL) + } + if (!is.numeric(seed) || length(seed) != 1L || is.na(seed) || + !is.finite(seed) || seed < 0 || seed > .Machine$integer.max || + seed != as.integer(seed)) { + stop("MissBayes seed must be NULL or a non-negative integer.") + } + as.integer(seed) +} + +prepare_missbayes_input <- function(experiment_input, + comparison_snapshot, + paired, + rope_half_width = 0.2, + alpha = 0.05, + seed = NULL, + settings = missbayes_default_settings()) { + if (isTRUE(paired)) { + stop( + "MissBayes does not support paired or blocked designs; ", + "the run is blocked." + ) + } + if (!identical(paired, FALSE)) { + stop("The paired-design flag must be explicitly TRUE or FALSE.") + } + if (!methods::is(experiment_input, "SummarizedExperiment")) { + stop("experiment_input must be a SummarizedExperiment.") + } + + alpha <- .validate_missbayes_probability_cutoff(alpha) + rope_half_width <- + .validate_missbayes_rope_half_width(rope_half_width) + seed <- .validate_missbayes_seed(seed) + settings <- validate_missbayes_settings(settings) + + assay_names <- SummarizedExperiment::assayNames(experiment_input) + if (!("quant" %in% assay_names)) { + stop("experiment_input must contain an assay named 'quant'.") + } + source_values <- SummarizedExperiment::assay(experiment_input, "quant") + if (!is.matrix(source_values) || !is.numeric(source_values)) { + stop("The MissBayes quant assay must be a numeric matrix.") + } + if (is.null(rownames(source_values)) || + anyNA(rownames(source_values)) || + any(!nzchar(rownames(source_values))) || + anyDuplicated(rownames(source_values))) { + stop("MissBayes feature identifiers must be unique and non-empty.") + } + if (is.null(colnames(source_values)) || + anyNA(colnames(source_values)) || + any(!nzchar(colnames(source_values))) || + anyDuplicated(colnames(source_values))) { + stop("MissBayes sample names must be unique and non-empty.") + } + + sample_data <- as.data.frame( + SummarizedExperiment::colData(experiment_input), + stringsAsFactors = FALSE + ) + if (!all(c("Condition", "Replicate") %in% names(sample_data))) { + stop("Sample metadata must contain Condition and Replicate columns.") + } + if (nrow(sample_data) != ncol(source_values)) { + stop("Sample metadata rows must match assay columns.") + } + if (!identical(rownames(sample_data), colnames(source_values))) { + stop("Sample metadata row names must match assay sample names in order.") + } + + experiment_metadata <- S4Vectors::metadata(experiment_input) + if (!all(c("NumCond", "NumReps") %in% names(experiment_metadata))) { + stop("Experiment metadata must contain NumCond and NumReps.") + } + num_conditions <- experiment_metadata$NumCond + num_replicates <- experiment_metadata$NumReps + for (entry in list( + NumCond = num_conditions, + NumReps = num_replicates + )) { + if (length(entry) != 1L || is.na(entry) || !is.finite(entry) || + entry <= 0 || entry != as.integer(entry)) { + stop("NumCond and NumReps must be positive integers.") + } + } + num_conditions <- as.integer(num_conditions) + num_replicates <- as.integer(num_replicates) + expected_samples <- num_conditions * num_replicates + if (ncol(source_values) != expected_samples) { + stop( + "MissBayes expected ", expected_samples, + " samples from NumCond * NumReps, but found ", + ncol(source_values), "." + ) + } + + condition <- as.character(sample_data$Condition) + replicate <- sample_data$Replicate + if (anyNA(condition) || any(!nzchar(condition)) || anyNA(replicate)) { + stop("Condition and Replicate metadata must not be missing or empty.") + } + condition_levels <- unique(condition) + if (length(condition_levels) != num_conditions) { + stop( + "Condition metadata contains ", length(condition_levels), + " groups; NumCond declares ", num_conditions, "." + ) + } + group_counts <- table(factor(condition, levels = condition_levels)) + if (any(group_counts != num_replicates)) { + stop( + "MissBayes requires balanced groups with exactly NumReps samples ", + "per condition." + ) + } + replicate_by_condition <- split(as.character(replicate), condition) + if (any(vapply( + replicate_by_condition, + function(x) length(unique(x)) != num_replicates, + logical(1) + ))) { + stop("Replicate identifiers must be unique within each condition.") + } + replicate_sets <- lapply(replicate_by_condition, function(x) sort(unique(x))) + if (!all(vapply( + replicate_sets, + identical, + logical(1), + replicate_sets[[1L]] + ))) { + stop("Balanced conditions must share the same replicate identifiers.") + } + + comparison <- validate_missbayes_comparison_snapshot( + comparison_snapshot, + condition_levels + ) + + # Construct a guaranteed copy before replacing non-finite values. + values <- matrix( + as.numeric(source_values), + nrow = nrow(source_values), + ncol = ncol(source_values), + dimnames = dimnames(source_values) + ) + values[!is.finite(values)] <- NA_real_ + + all_missing <- rowSums(!is.na(values)) == 0L + sample_order <- order( + match(condition, condition_levels), + replicate, + seq_along(condition) + ) + values <- values[!all_missing, sample_order, drop = FALSE] + ordered_condition <- condition[sample_order] + groups <- factor(ordered_condition, levels = condition_levels) + + contrast <- matrix( + 0, + nrow = length(condition_levels), + ncol = 1L, + dimnames = list(condition_levels, comparison$name) + ) + contrast[comparison$reference, 1L] <- -1 + contrast[comparison$target, 1L] <- 1 + + prepared <- list( + values = values, + groups = groups, + comparison = contrast, + comparison_snapshot = comparison, + feature_ids = rownames(source_values), + estimable_feature_ids = rownames(source_values)[!all_missing], + all_missing_feature_ids = rownames(source_values)[all_missing], + all_missing = unname(all_missing), + sample_order = unname(sample_order), + sample_names = colnames(values), + original_sample_names = colnames(source_values), + original_condition = condition, + ordered_condition = ordered_condition, + rope_half_width = rope_half_width, + rope = c(-rope_half_width, rope_half_width), + alpha = alpha, + seed = seed, + settings = settings, + num_conditions = num_conditions, + num_replicates = num_replicates + ) + class(prepared) <- c("polystest_missbayes_input", "list") + prepared +} + +.empty_missbayes_raw <- function(feature_ids) { + output <- data.frame( + HDI_Low = rep(NA_real_, length(feature_ids)), + HDI_High = rep(NA_real_, length(feature_ids)), + Median = rep(NA_real_, length(feature_ids)), + pLtCompVal = rep(NA_real_, length(feature_ids)), + pLtROPE = rep(NA_real_, length(feature_ids)), + pInROPE = rep(NA_real_, length(feature_ids)), + pGtROPE = rep(NA_real_, length(feature_ids)), + ESS = rep(NA_real_, length(feature_ids)), + MCSE = rep(NA_real_, length(feature_ids)), + max_rhat = rep(NA_real_, length(feature_ids)), + Convergence = rep(NA_character_, length(feature_ids)), + stringsAsFactors = FALSE, + row.names = feature_ids + ) + output +} + +.format_missbayes_feature_ids <- function(ids, limit = 10L) { + ids <- as.character(ids) + if (length(ids) == 0L) { + return("") + } + shown <- utils::head(ids, limit) + suffix <- if (length(ids) > limit) { + paste0(", ... (+", length(ids) - limit, " more)") + } else { + "" + } + paste0(paste(shown, collapse = ", "), suffix) +} + +.stop_missbayes_feature_identity_mismatch <- function(expected_ids, + returned_ids, + returned_rows) { + returned_ids <- as.character(returned_ids) + valid_returned <- !is.na(returned_ids) & nzchar(returned_ids) + valid_ids <- returned_ids[valid_returned] + duplicate_ids <- unique(valid_ids[duplicated(valid_ids)]) + missing_ids <- setdiff(expected_ids, valid_ids) + unexpected_ids <- setdiff(unique(valid_ids), expected_ids) + default_sequential <- + identical(returned_ids, as.character(seq_len(returned_rows))) && + !identical(returned_ids, expected_ids) + + stop( + "MissBayes feature-identity mismatch: submitted ", + length(expected_ids), " feature identifiers but received ", + returned_rows, " rows with ", length(returned_ids), + " row identifiers. Default sequential row names: ", + if (default_sequential) "yes" else "no", ". ", + "Duplicate identifiers: [", + .format_missbayes_feature_ids(duplicate_ids), + "]. Missing submitted identifiers: [", + .format_missbayes_feature_ids(missing_ids), + "]. Unexpected returned identifiers: [", + .format_missbayes_feature_ids(unexpected_ids), + "]. Blank or missing returned identifiers: ", + sum(!valid_returned), ". Positional mapping is not permitted; ", + "the pinned MissBayes contract requires preservation of submitted ", + "feature identifiers." + ) +} + +.extract_missbayes_raw_table <- function(raw_output, prepared) { + comparison_name <- prepared$comparison_snapshot$name + if (is.data.frame(raw_output)) { + raw <- raw_output + } else if (is.list(raw_output)) { + if (comparison_name %in% names(raw_output)) { + raw <- raw_output[[comparison_name]] + } else if (length(raw_output) == 1L) { + raw <- raw_output[[1L]] + } else { + stop("MissBayes output does not contain the selected comparison.") + } + } else { + stop("MissBayes output must be a data frame or a named list of tables.") + } + if (!is.data.frame(raw)) { + stop("The selected MissBayes output must be a data frame.") + } + + expected_ids <- prepared$estimable_feature_ids + returned_ids <- rownames(raw) + identity_matches <- + nrow(raw) == length(expected_ids) && + length(returned_ids) == nrow(raw) && + !anyNA(returned_ids) && + all(nzchar(returned_ids)) && + !anyDuplicated(returned_ids) && + setequal(returned_ids, expected_ids) + if (!identity_matches) { + .stop_missbayes_feature_identity_mismatch( + expected_ids, + returned_ids, + nrow(raw) + ) + } + + # Always map by verified identifiers, even when MissBayes already returned + # the submitted order. This prevents an accidental positional contract. + raw <- raw[match(expected_ids, returned_ids), , drop = FALSE] + raw +} + +normalize_missbayes_output <- function(raw_output, prepared) { + if (!inherits(prepared, "polystest_missbayes_input")) { + stop("prepared must be created by prepare_missbayes_input().") + } + raw <- .extract_missbayes_raw_table(raw_output, prepared) + required <- c( + "HDI_Low", "HDI_High", "Median", "pLtCompVal", + "pLtROPE", "pInROPE", "pGtROPE", "Convergence" + ) + missing_fields <- setdiff(required, names(raw)) + if (length(missing_fields) > 0L) { + stop( + "MissBayes output is missing fields: ", + paste(missing_fields, collapse = ", "), "." + ) + } + optional <- c("ESS", "MCSE", "max_rhat") + for (field in optional) { + if (!(field %in% names(raw))) { + raw[[field]] <- NA_real_ + } + } + + result <- data.frame( + feature_id = prepared$feature_ids, + comparison = prepared$comparison_snapshot$name, + posterior_median_log2_fc = NA_real_, + hdi_95_lower = NA_real_, + hdi_95_upper = NA_real_, + probability_below_rope = NA_real_, + probability_within_rope = NA_real_, + probability_above_rope = NA_real_, + decision = NA_character_, + posterior_error_probability = NA_real_, + directional_local_fdr = NA_real_, + minimum_sign_tail_probability = NA_real_, + ess = NA_real_, + mcse = NA_real_, + rhat_max = NA_real_, + convergence = NA_character_, + fit_status = ifelse( + prepared$all_missing, + "not_estimable", + "fit_failed" + ), + stringsAsFactors = FALSE + ) + + if (nrow(raw) > 0L) { + numeric_fields <- c( + "HDI_Low", "HDI_High", "Median", "pLtCompVal", + "pLtROPE", "pInROPE", "pGtROPE", "ESS", "MCSE", "max_rhat" + ) + for (field in numeric_fields) { + raw[[field]] <- suppressWarnings(as.numeric(raw[[field]])) + } + core_fields <- c( + "HDI_Low", "HDI_High", "Median", "pLtCompVal", + "pLtROPE", "pInROPE", "pGtROPE" + ) + core_values <- as.matrix(raw[, core_fields, drop = FALSE]) + complete_core <- apply(core_values, 1L, function(x) { + all(is.finite(x)) + }) + result_rows <- match(rownames(raw), result$feature_id) + estimated_rows <- result_rows[complete_core] + estimated_raw <- raw[complete_core, , drop = FALSE] + + if (nrow(estimated_raw) > 0L) { + raw_probabilities <- as.matrix(estimated_raw[, c( + "pLtROPE", "pInROPE", "pGtROPE" + ), drop = FALSE]) + if (any(raw_probabilities < 0 | raw_probabilities > 100)) { + stop("MissBayes ROPE probabilities must be percentages in [0, 100].") + } + probabilities <- raw_probabilities / 100 + if (any(abs(rowSums(probabilities) - 1) > 1e-8)) { + stop("MissBayes ROPE probabilities do not sum to 100 percent.") + } + if (any(estimated_raw$pLtCompVal < 0 | + estimated_raw$pLtCompVal > 0.5)) { + stop("MissBayes pLtCompVal must be on its documented [0, 0.5] scale.") + } + + result$posterior_median_log2_fc[estimated_rows] <- + estimated_raw$Median + result$hdi_95_lower[estimated_rows] <- estimated_raw$HDI_Low + result$hdi_95_upper[estimated_rows] <- estimated_raw$HDI_High + result$probability_below_rope[estimated_rows] <- probabilities[, 1L] + result$probability_within_rope[estimated_rows] <- probabilities[, 2L] + result$probability_above_rope[estimated_rows] <- probabilities[, 3L] + result$minimum_sign_tail_probability[estimated_rows] <- + estimated_raw$pLtCompVal + result$ess[estimated_rows] <- estimated_raw$ESS + result$mcse[estimated_rows] <- estimated_raw$MCSE + result$rhat_max[estimated_rows] <- estimated_raw$max_rhat + result$convergence[estimated_rows] <- + as.character(estimated_raw$Convergence) + result$fit_status[estimated_rows] <- "estimated" + result$decision[estimated_rows] <- "uncertain" + + call_boundary <- 1 - prepared$alpha + is_up <- probabilities[, 3L] >= call_boundary + is_down <- probabilities[, 1L] >= call_boundary + is_unchanged <- probabilities[, 2L] >= call_boundary + call_count <- is_up + is_down + is_unchanged + + up_rows <- estimated_rows[is_up & call_count == 1L] + down_rows <- estimated_rows[is_down & call_count == 1L] + unchanged_rows <- + estimated_rows[is_unchanged & call_count == 1L] + + result$decision[up_rows] <- "up" + result$posterior_error_probability[up_rows] <- + 1 - result$probability_above_rope[up_rows] + result$directional_local_fdr[up_rows] <- + result$posterior_error_probability[up_rows] + + result$decision[down_rows] <- "down" + result$posterior_error_probability[down_rows] <- + 1 - result$probability_below_rope[down_rows] + result$directional_local_fdr[down_rows] <- + result$posterior_error_probability[down_rows] + + result$decision[unchanged_rows] <- "practically_unchanged" + result$posterior_error_probability[unchanged_rows] <- + 1 - result$probability_within_rope[unchanged_rows] + result$directional_local_fdr[unchanged_rows] <- NA_real_ + } + } + + directional <- result$decision %in% c("up", "down") + estimated_bayesian_directional_fdr <- if (any(directional)) { + mean(result$posterior_error_probability[directional]) + } else { + NA_real_ + } + estimated <- result$fit_status == "estimated" + convergence <- tolower(trimws(result$convergence)) + summary <- list( + estimated_bayesian_directional_fdr = + estimated_bayesian_directional_fdr, + directional_call_count = sum(directional), + up_count = sum(result$decision == "up", na.rm = TRUE), + down_count = sum(result$decision == "down", na.rm = TRUE), + practically_unchanged_count = + sum(result$decision == "practically_unchanged", na.rm = TRUE), + uncertain_count = sum( + estimated & result$decision == "uncertain", + na.rm = TRUE + ), + not_estimable_count = sum(result$fit_status == "not_estimable"), + fit_failed_count = sum(result$fit_status == "fit_failed"), + poor_convergence_count = sum( + estimated & convergence == "poor", + na.rm = TRUE + ), + moderate_convergence_count = sum( + estimated & convergence == "moderate", + na.rm = TRUE + ) + ) + + output <- list(raw = raw, results = result, summary = summary) + class(output) <- c("polystest_missbayes_result", "list") + output +} + +run_missbayes_model <- function(prepared, analysis_function = NULL) { + if (!inherits(prepared, "polystest_missbayes_input")) { + stop("prepared must be created by prepare_missbayes_input().") + } + if (is.null(analysis_function)) { + if (!requireNamespace("missBayes", quietly = TRUE)) { + stop( + "The optional package 'missBayes' is not installed. ", + "Use the polystest-missbayes-dev image." + ) + } + analysis_function <- getExportedValue("missBayes", "BayesMissingModel") + } + if (!is.function(analysis_function)) { + stop("analysis_function must be a function.") + } + + if (nrow(prepared$values) == 0L) { + raw <- .empty_missbayes_raw(character()) + return(normalize_missbayes_output(raw, prepared)) + } + if (!is.null(prepared$seed)) { + set.seed(prepared$seed) + } + settings <- prepared$settings + raw <- analysis_function( + values = prepared$values, + groups = prepared$groups, + comparisons = prepared$comparison, + filter4NAs = settings$filter4NAs, + threshold = settings$threshold, + parallel = settings$parallel, + ROPE = prepared$rope, + n.adapt = settings$n.adapt, + burn.in = settings$burn.in, + n.iter = settings$n.iter, + n.chains = settings$n.chains, + mcmcDiag = settings$mcmcDiag + ) + normalize_missbayes_output(raw, prepared) +} diff --git a/R/MissBayesPlot.R b/R/MissBayesPlot.R new file mode 100644 index 0000000..8928907 --- /dev/null +++ b/R/MissBayesPlot.R @@ -0,0 +1,806 @@ +# Explicit posterior-refit helpers for the optional MissBayes workflow. +# +# A posterior plot is a separate stochastic fit for one named feature. It uses +# retained table-result metadata and a copied clean experiment snapshot, then +# transfers a worker-local PNG back to Shiny as raw bytes. It never consumes or +# changes the normalized Stage 5 table result. + +.missbayes_stage6_plot_requested_seed <- 20260804L + +missbayes_stage6_plot_seed <- function() { + .missbayes_stage6_plot_requested_seed +} + +.validate_missbayes_plot_counter <- function(value, label) { + if (!is.numeric(value) || length(value) != 1L || is.na(value) || + !is.finite(value) || value < 0 || value > .Machine$integer.max || + value != as.integer(value)) { + stop(label, " must be a non-negative integer.") + } + as.integer(value) +} + +.validate_missbayes_plot_feature_id <- function(feature_id) { + feature_id <- as.character(feature_id) + if (length(feature_id) != 1L || is.na(feature_id) || !nzchar(feature_id)) { + stop("Select exactly one MissBayes feature.") + } + feature_id +} + +missbayes_selected_feature_id <- function(display_table, selected_rows) { + if (!is.numeric(selected_rows) || length(selected_rows) != 1L || + is.na(selected_rows) || !is.finite(selected_rows) || + selected_rows != as.integer(selected_rows)) { + return(NULL) + } + selected_row <- as.integer(selected_rows) + if (!is.data.frame(display_table) || selected_row < 1L || + selected_row > nrow(display_table)) { + return(NULL) + } + id_column <- if ("Feature ID" %in% names(display_table)) { + "Feature ID" + } else if ("feature_id" %in% names(display_table)) { + "feature_id" + } else { + return(NULL) + } + feature_id <- as.character(display_table[[id_column]][[selected_row]]) + if (length(feature_id) != 1L || is.na(feature_id) || !nzchar(feature_id)) { + return(NULL) + } + feature_id +} + +.missbayes_plot_result_metadata <- function(result, available_conditions) { + if (!is.list(result) || !identical(result$status, "success") || + !is.data.frame(result$table)) { + stop("A retained successful MissBayes table result is required.") + } + for (field in c("run_id", "experiment_id")) { + if (is.null(result[[field]])) { + stop("The retained MissBayes result identity is incomplete.") + } + } + run_id <- .validate_missbayes_snapshot_id( + result$run_id, + "Retained MissBayes run_id" + ) + experiment_id <- .validate_missbayes_snapshot_id( + result$experiment_id, + "Retained MissBayes experiment_id" + ) + + if (!all(c("feature_id", "fit_status") %in% names(result$table))) { + stop("The retained MissBayes result lacks feature identity or fit status.") + } + result_ids <- as.character(result$table$feature_id) + if (anyNA(result_ids) || any(!nzchar(result_ids)) || + anyDuplicated(result_ids)) { + stop("The retained MissBayes feature identifiers are not unique.") + } + + comparison <- validate_missbayes_comparison_snapshot( + result$comparison, + available_conditions + ) + if (!is.list(result$comparison) || + !identical(as.character(result$comparison$name), comparison$name)) { + stop("The retained MissBayes comparison identity is inconsistent.") + } + settings <- validate_missbayes_task_settings(result$settings) + if (!is.list(result$metadata) || is.null(result$metadata$rope)) { + stop("The retained MissBayes result does not record its ROPE.") + } + metadata_settings <- settings + metadata_settings$ROPE <- result$metadata$rope + metadata_rope <- validate_missbayes_task_settings(metadata_settings)$ROPE + if (!isTRUE(all.equal( + metadata_rope, + settings$ROPE, + tolerance = sqrt(.Machine$double.eps) + ))) { + stop("The retained MissBayes ROPE metadata is inconsistent.") + } + alpha <- result$metadata$alpha + if (is.null(alpha)) { + alpha <- result$alpha + } + alpha <- validate_missbayes_task_alpha(alpha) + + list( + run_id = run_id, + experiment_id = experiment_id, + comparison = comparison, + settings = settings, + rope = settings$ROPE, + alpha = alpha + ) +} + +.missbayes_plot_eligibility_or_stop <- function( + missbayes_state, + experiment_input, + selected_feature_id +) { + missbayes_state <- .validate_missbayes_state(missbayes_state) + feature_id <- .validate_missbayes_plot_feature_id(selected_feature_id) + if (is.null(missbayes_state$result)) { + stop("Run MissBayes successfully before generating a posterior plot.") + } + if (!methods::is(experiment_input, "SummarizedExperiment") || + !("quant" %in% SummarizedExperiment::assayNames(experiment_input))) { + stop("A clean experiment is required for the posterior refit.") + } + + values <- SummarizedExperiment::assay(experiment_input, "quant") + feature_matches <- which(rownames(values) == feature_id) + if (length(feature_matches) != 1L) { + stop("The selected feature does not map uniquely to the clean experiment.") + } + sample_data <- as.data.frame( + SummarizedExperiment::colData(experiment_input), + stringsAsFactors = FALSE + ) + if (!("Condition" %in% names(sample_data))) { + stop("The clean experiment lacks condition metadata.") + } + available_conditions <- unique(as.character(sample_data$Condition)) + metadata <- .missbayes_plot_result_metadata( + missbayes_state$result, + available_conditions + ) + + result_rows <- which( + as.character(missbayes_state$result$table$feature_id) == feature_id + ) + if (length(result_rows) != 1L) { + stop("The selected feature does not map uniquely to the retained result.") + } + fit_status <- as.character( + missbayes_state$result$table$fit_status[[result_rows]] + ) + if (!identical(fit_status, "estimated")) { + stop( + "Only rows with fit_status == 'estimated' can be refitted for a plot." + ) + } + + stale <- isTRUE(missbayes_state$stale) || + !identical(missbayes_state$status, "success") || + !identical(metadata$experiment_id, missbayes_state$experiment_id) + list( + feature_id = feature_id, + result_row = result_rows, + fit_status = fit_status, + source_result_stale = stale, + result_metadata = metadata + ) +} + +missbayes_plot_eligibility <- function( + missbayes_state, + experiment_input, + selected_feature_id +) { + error <- NULL + details <- tryCatch( + .missbayes_plot_eligibility_or_stop( + missbayes_state, + experiment_input, + selected_feature_id + ), + error = function(condition) { + error <<- condition + NULL + } + ) + if (!is.null(error)) { + return(list( + eligible = FALSE, + reason = missbayes_safe_error_message(error), + feature_id = if (is.null(selected_feature_id)) { + NULL + } else { + as.character(selected_feature_id) + }, + source_result_stale = FALSE, + result_metadata = NULL + )) + } + c(list(eligible = TRUE, reason = NULL), details) +} + +new_missbayes_plot_state <- function(experiment_id = 0L) { + experiment_id <- .validate_missbayes_plot_counter( + experiment_id, + "MissBayes posterior-plot experiment_id" + ) + list( + status = "idle", + error = NULL, + plot = NULL, + feature_id = NULL, + plot_run_id = 0L, + experiment_id = experiment_id, + source_missbayes_run_id = NULL, + source_missbayes_experiment_id = NULL, + comparison = NULL, + rope = NULL, + seed = NULL, + source_result_stale = FALSE, + stale = FALSE + ) +} + +.validate_missbayes_plot_state <- function(state) { + required <- c( + "status", "error", "plot", "feature_id", "plot_run_id", + "experiment_id", "source_missbayes_run_id", + "source_missbayes_experiment_id", "comparison", "rope", "seed", + "source_result_stale", "stale" + ) + if (!is.list(state) || !all(required %in% names(state))) { + stop("MissBayes posterior-plot state is incomplete.") + } + if (length(state$status) != 1L || + !(state$status %in% c("idle", "running", "success", "error"))) { + stop("MissBayes posterior-plot state has an invalid status.") + } + state$plot_run_id <- .validate_missbayes_plot_counter( + state$plot_run_id, + "MissBayes posterior plot_run_id" + ) + state$experiment_id <- .validate_missbayes_plot_counter( + state$experiment_id, + "MissBayes posterior-plot experiment_id" + ) + if (!is.logical(state$stale) || length(state$stale) != 1L || + is.na(state$stale)) { + stop("MissBayes posterior-plot stale must be TRUE or FALSE.") + } + if (!is.logical(state$source_result_stale) || + length(state$source_result_stale) != 1L || + is.na(state$source_result_stale)) { + stop("MissBayes source-result stale must be TRUE or FALSE.") + } + state +} + +missbayes_plot_register_experiment <- function(state, experiment_id) { + state <- .validate_missbayes_plot_state(state) + experiment_id <- .validate_missbayes_plot_counter( + experiment_id, + "MissBayes posterior-plot experiment_id" + ) + state$status <- "idle" + state["error"] <- list(NULL) + state["plot"] <- list(NULL) + state["feature_id"] <- list(NULL) + state$experiment_id <- experiment_id + state["source_missbayes_run_id"] <- list(NULL) + state["source_missbayes_experiment_id"] <- list(NULL) + state["comparison"] <- list(NULL) + state["rope"] <- list(NULL) + state["seed"] <- list(NULL) + state$source_result_stale <- FALSE + state$stale <- FALSE + state +} + +create_missbayes_plot_payload <- function( + snapshot, + feature_id, + settings, + alpha, + requested_seed, + plot_run_id, + source_missbayes_run_id, + source_missbayes_experiment_id, + source_result_stale +) { + snapshot <- validate_missbayes_task_snapshot(snapshot) + feature_id <- .validate_missbayes_plot_feature_id(feature_id) + if (sum(snapshot$feature_ids == feature_id) != 1L) { + stop("The plot feature must map uniquely to its clean snapshot.") + } + settings <- validate_missbayes_task_settings(settings) + alpha <- validate_missbayes_task_alpha(alpha) + requested_seed <- .validate_missbayes_seed(requested_seed) + if (is.null(requested_seed)) { + stop("The MissBayes posterior refit requires an explicit seed.") + } + plot_run_id <- .validate_missbayes_snapshot_id( + plot_run_id, + "MissBayes posterior plot_run_id" + ) + source_missbayes_run_id <- .validate_missbayes_snapshot_id( + source_missbayes_run_id, + "Source MissBayes run_id" + ) + source_missbayes_experiment_id <- .validate_missbayes_snapshot_id( + source_missbayes_experiment_id, + "Source MissBayes experiment_id" + ) + if (!is.logical(source_result_stale) || + length(source_result_stale) != 1L || is.na(source_result_stale)) { + stop("source_result_stale must be TRUE or FALSE.") + } + + payload <- list( + snapshot = snapshot, + feature_id = feature_id, + settings = settings, + alpha = alpha, + requested_seed = requested_seed, + plot_run_id = plot_run_id, + source_missbayes_run_id = source_missbayes_run_id, + source_missbayes_experiment_id = source_missbayes_experiment_id, + source_result_stale = source_result_stale + ) + if (!.missbayes_plain_object(payload)) { + stop("The posterior-refit payload must contain ordinary R objects only.") + } + class(payload) <- c("polystest_missbayes_plot_payload", "list") + payload +} + +missbayes_plot_begin <- function(state, payload) { + state <- .validate_missbayes_plot_state(state) + if (!inherits(payload, "polystest_missbayes_plot_payload")) { + stop("payload must be created by create_missbayes_plot_payload().") + } + if (!identical(payload$snapshot$experiment_id, state$experiment_id)) { + stop("The posterior-refit payload is from a different experiment.") + } + if (payload$plot_run_id <= state$plot_run_id) { + stop("MissBayes posterior plot_run_id must be newer than the current run.") + } + state$status <- "running" + state["error"] <- list(NULL) + state$feature_id <- payload$feature_id + state$plot_run_id <- payload$plot_run_id + state$source_missbayes_run_id <- payload$source_missbayes_run_id + state$source_missbayes_experiment_id <- + payload$source_missbayes_experiment_id + state$comparison <- .copy_missbayes_object(payload$snapshot$comparison) + state$rope <- payload$settings$ROPE + state$seed <- payload$requested_seed + state$source_result_stale <- payload$source_result_stale + state$stale <- !is.null(state$plot) || payload$source_result_stale + state +} + +prepare_missbayes_plot_run <- function( + plot_state, + missbayes_state, + experiment_input, + selected_feature_id, + requested_seed = missbayes_stage6_plot_seed() +) { + plot_state <- .validate_missbayes_plot_state(plot_state) + missbayes_state <- .validate_missbayes_state(missbayes_state) + if (!identical(plot_state$experiment_id, missbayes_state$experiment_id)) { + stop("Posterior-plot and MissBayes experiment identities differ.") + } + if (plot_state$plot_run_id == .Machine$integer.max) { + stop("MissBayes posterior plot_run_id cannot be incremented further.") + } + eligible <- .missbayes_plot_eligibility_or_stop( + missbayes_state, + experiment_input, + selected_feature_id + ) + metadata <- eligible$result_metadata + snapshot <- create_missbayes_snapshot( + experiment_input = experiment_input, + comparison_snapshot = metadata$comparison, + paired = FALSE, + experiment_id = missbayes_state$experiment_id, + run_id = metadata$run_id + ) + payload <- create_missbayes_plot_payload( + snapshot = snapshot, + feature_id = eligible$feature_id, + settings = metadata$settings, + alpha = metadata$alpha, + requested_seed = requested_seed, + plot_run_id = plot_state$plot_run_id + 1L, + source_missbayes_run_id = metadata$run_id, + source_missbayes_experiment_id = metadata$experiment_id, + source_result_stale = eligible$source_result_stale + ) + list( + state = missbayes_plot_begin(plot_state, payload), + payload = payload + ) +} + +validate_missbayes_plotpost_api <- function(plot_function) { + if (!is.function(plot_function)) { + stop("MissBayes plotPost must be a function.") + } + required <- c( + "values", "id", "groups", "contrast", "threshold", "ROPE", + "n.adapt", "burn.in", "n.iter", "n.chains" + ) + missing_arguments <- setdiff(required, names(formals(plot_function))) + if (length(missing_arguments) > 0L) { + stop( + "The pinned MissBayes plotPost API is missing arguments: ", + paste(missing_arguments, collapse = ", "), "." + ) + } + invisible(TRUE) +} + +.capture_missbayes_plot_png <- function( + draw_plot, + tempfile_factory = tempfile +) { + if (!is.function(draw_plot) || !is.function(tempfile_factory)) { + stop("Plot capture requires callable draw and tempfile functions.") + } + plot_file <- tempfile_factory(fileext = ".png") + device_number <- NA_integer_ + on.exit({ + open_devices <- grDevices::dev.list() + if (!is.na(device_number) && device_number %in% open_devices) { + try(grDevices::dev.off(which = device_number), silent = TRUE) + } + if (file.exists(plot_file)) { + unlink(plot_file) + } + }, add = TRUE) + + grDevices::png( + filename = plot_file, + width = 1200L, + height = 800L, + units = "px", + res = 144L + ) + device_number <- grDevices::dev.cur() + draw_plot() + grDevices::dev.off(which = device_number) + device_number <- NA_integer_ + + file_size <- file.info(plot_file)$size + if (length(file_size) != 1L || is.na(file_size) || file_size <= 0) { + stop("MissBayes plotPost did not create a non-empty PNG.") + } + plot_png <- readBin(plot_file, what = "raw", n = as.integer(file_size)) + unlink(plot_file) + list( + plot_png = plot_png, + temporary_file = plot_file, + temporary_file_removed = !file.exists(plot_file) + ) +} + +run_missbayes_plot_task <- function( + payload, + plot_function = NULL, + tempfile_factory = tempfile +) { + if (!inherits(payload, "polystest_missbayes_plot_payload")) { + stop("payload must be created by create_missbayes_plot_payload().") + } + payload <- do.call( + create_missbayes_plot_payload, + unclass(payload) + ) + if (is.null(plot_function)) { + if (!requireNamespace("missBayes", quietly = TRUE)) { + stop("The optional package 'missBayes' is required for plotting.") + } + plot_function <- getExportedValue("missBayes", "plotPost") + } + validate_missbayes_plotpost_api(plot_function) + + started_at <- Sys.time() + adapter_settings <- payload$settings[names(missbayes_default_settings())] + prepared <- prepare_missbayes_input( + experiment_input = .missbayes_snapshot_experiment(payload$snapshot), + comparison_snapshot = payload$snapshot$comparison, + paired = FALSE, + rope_half_width = payload$settings$ROPE[[2L]], + alpha = payload$alpha, + seed = payload$requested_seed, + settings = adapter_settings + ) + if (sum(prepared$estimable_feature_ids == payload$feature_id) != 1L) { + stop("The selected feature is not estimable in the clean experiment.") + } + contrast <- paste( + prepared$comparison_snapshot$target, + prepared$comparison_snapshot$reference, + sep = " - " + ) + set.seed(payload$requested_seed) + captured <- .capture_missbayes_plot_png( + draw_plot = function() { + plot_function( + values = prepared$values, + id = payload$feature_id, + groups = prepared$groups, + contrast = contrast, + threshold = payload$settings$threshold, + compVal = 0, + ROPE = payload$settings$ROPE, + n.adapt = payload$settings$n.adapt, + burn.in = payload$settings$burn.in, + n.iter = payload$settings$n.iter, + n.chains = payload$settings$n.chains, + xlab = paste0( + prepared$comparison_snapshot$target, + " - ", prepared$comparison_snapshot$reference, + " log2 fold change" + ), + main = paste0( + payload$feature_id, ": ", + prepared$comparison_snapshot$name + ) + ) + }, + tempfile_factory = tempfile_factory + ) + completed_at <- Sys.time() + + outcome <- list( + status = "success", + plot_run_id = payload$plot_run_id, + experiment_id = payload$snapshot$experiment_id, + source_missbayes_run_id = payload$source_missbayes_run_id, + source_missbayes_experiment_id = + payload$source_missbayes_experiment_id, + source_result_stale = payload$source_result_stale, + feature_id = payload$feature_id, + comparison = .copy_missbayes_object( + prepared$comparison_snapshot + ), + rope = payload$settings$ROPE, + seed = payload$requested_seed, + plot_png = captured$plot_png, + metadata = list( + fresh_refit = TRUE, + reuses_table_posterior_samples = FALSE, + contrast = contrast, + threshold = payload$settings$threshold, + n.adapt = payload$settings$n.adapt, + burn.in = payload$settings$burn.in, + n.iter = payload$settings$n.iter, + n.chains = payload$settings$n.chains, + missbayes_internal_parallel = FALSE, + missbayes_package_version = .missbayes_package_version("missBayes"), + missbayes_source_revision = .missbayes_source_revision() + ), + runtime = list( + worker_pid = Sys.getpid(), + started_at_utc = format( + started_at, + "%Y-%m-%dT%H:%M:%OS3Z", + tz = "UTC" + ), + completed_at_utc = format( + completed_at, + "%Y-%m-%dT%H:%M:%OS3Z", + tz = "UTC" + ), + elapsed_seconds = as.numeric(difftime( + completed_at, + started_at, + units = "secs" + )), + temporary_file = captured$temporary_file, + temporary_file_removed = captured$temporary_file_removed + ) + ) + class(outcome) <- c("polystest_missbayes_plot_result", "list") + outcome +} + +.missbayes_plot_error_outcome <- function(payload, error) { + outcome <- list( + status = "error", + plot_run_id = payload$plot_run_id, + experiment_id = payload$snapshot$experiment_id, + source_missbayes_run_id = payload$source_missbayes_run_id, + source_missbayes_experiment_id = + payload$source_missbayes_experiment_id, + source_result_stale = payload$source_result_stale, + feature_id = payload$feature_id, + comparison = .copy_missbayes_object(payload$snapshot$comparison), + rope = payload$settings$ROPE, + seed = payload$requested_seed, + error = missbayes_safe_error_message(error) + ) + class(outcome) <- c("polystest_missbayes_plot_error", "list") + outcome +} + +run_missbayes_plot_task_outcome <- function(payload) { + tryCatch( + run_missbayes_plot_task(payload), + error = function(error) .missbayes_plot_error_outcome(payload, error) + ) +} + +.missbayes_plot_outcome_is_current <- function(state, outcome) { + identical(state$status, "running") && + identical(as.integer(outcome$plot_run_id), state$plot_run_id) && + identical(as.integer(outcome$experiment_id), state$experiment_id) +} + +missbayes_accept_plot_outcome <- function(state, outcome) { + state <- .validate_missbayes_plot_state(state) + if (!is.list(outcome) || !all(c( + "status", "plot_run_id", "experiment_id", "feature_id", + "source_missbayes_run_id", "source_missbayes_experiment_id" + ) %in% names(outcome))) { + stop("The MissBayes posterior-refit outcome is incomplete.") + } + if (!.missbayes_plot_outcome_is_current(state, outcome)) { + return(state) + } + if (identical(outcome$status, "success")) { + if (!is.raw(outcome$plot_png) || length(outcome$plot_png) == 0L) { + stop("A successful posterior refit requires non-empty PNG bytes.") + } + state$plot <- .copy_missbayes_object(outcome) + state$status <- "success" + state["error"] <- list(NULL) + state$feature_id <- outcome$feature_id + state$source_missbayes_run_id <- outcome$source_missbayes_run_id + state$source_missbayes_experiment_id <- + outcome$source_missbayes_experiment_id + state$comparison <- .copy_missbayes_object(outcome$comparison) + state$rope <- outcome$rope + state$seed <- outcome$seed + state$source_result_stale <- outcome$source_result_stale + state$stale <- isTRUE(outcome$source_result_stale) + return(state) + } + if (identical(outcome$status, "error")) { + state$status <- "error" + state$error <- missbayes_safe_error_message(outcome$error) + state$stale <- !is.null(state$plot) + return(state) + } + stop("Posterior-refit outcome status must be success or error.") +} + +missbayes_plot_status_view <- function( + state, + selected_feature_id = NULL, + missbayes_state = NULL +) { + state <- .validate_missbayes_plot_state(state) + plot <- state$plot + displayed_feature_id <- if (is.null(plot)) NULL else plot$feature_id + selection_changed <- !is.null(plot) && !is.null(selected_feature_id) && + !identical(as.character(selected_feature_id), displayed_feature_id) + source_changed <- FALSE + source_state_stale <- FALSE + if (!is.null(missbayes_state)) { + missbayes_state <- .validate_missbayes_state(missbayes_state) + source_state_stale <- !identical(missbayes_state$status, "success") || + isTRUE(missbayes_state$stale) + if (!is.null(plot) && !is.null(missbayes_state$result)) { + source_changed <- !identical( + as.integer(plot$source_missbayes_run_id), + as.integer(missbayes_state$result$run_id) + ) || !identical( + as.integer(plot$source_missbayes_experiment_id), + as.integer(missbayes_state$result$experiment_id) + ) + } + } + plot_stale <- !is.null(plot) && ( + isTRUE(state$stale) || isTRUE(plot$source_result_stale) || + selection_changed || source_changed || source_state_stale || + !identical(plot$experiment_id, state$experiment_id) || + !identical(state$status, "success") + ) + + headline <- switch( + state$status, + idle = "No posterior refit has been generated.", + running = "Posterior refit running", + success = "Posterior refit completed.", + error = "Posterior refit failed." + ) + message <- switch( + state$status, + idle = paste( + "Select one estimated row and explicitly generate a new MCMC refit." + ), + running = paste( + "MissBayes is refitting the requested feature in the background;", + "no percentage estimate is available." + ), + success = paste( + "This plot comes from a separate stochastic refit and may differ", + "slightly from the summary table." + ), + error = state$error + ) + list( + status = state$status, + headline = headline, + message = message, + requested_feature_id = state$feature_id, + requested_comparison = state$comparison, + requested_rope = state$rope, + requested_seed = state$seed, + requested_source_stale = state$source_result_stale, + has_plot = !is.null(plot), + plot = plot, + displayed_feature_id = displayed_feature_id, + selection_changed = selection_changed, + plot_stale = plot_stale, + source_changed = source_changed, + source_state_stale = source_state_stale + ) +} + +missbayes_plot_image_response <- function(plot_result, file = tempfile( + fileext = ".png" +)) { + if (!is.list(plot_result) || !is.raw(plot_result$plot_png) || + length(plot_result$plot_png) == 0L) { + stop("A non-empty posterior PNG payload is required.") + } + writeBin(plot_result$plot_png, file) + list( + src = normalizePath(file, winslash = "/", mustWork = TRUE), + contentType = "image/png", + alt = paste0( + "MissBayes posterior refit for ", plot_result$feature_id, + ", ", plot_result$comparison$name + ) + ) +} + +submit_missbayes_plot_task <- function(payload) { + if (!inherits(payload, "polystest_missbayes_plot_payload")) { + stop("payload must be created by create_missbayes_plot_payload().") + } + payload <- do.call( + create_missbayes_plot_payload, + unclass(payload) + ) + runtime <- missbayes_runtime_status() + if (!isTRUE(runtime$initialized)) { + stop("The MissBayes background runtime has not been configured.") + } + + submission_error <- NULL + task <- tryCatch( + mirai::mirai( + PolySTest:::run_missbayes_plot_task_outcome(worker_payload), + worker_payload = payload, + .compute = .missbayes_compute_profile + ), + error = function(error) { + submission_error <<- error + NULL + } + ) + if (is.null(task)) { + return(.missbayes_resolved_promise( + .missbayes_plot_error_outcome(payload, submission_error) + )) + } + + as_promise <- getExportedValue("promises", "as.promise") + then <- getExportedValue("promises", "then") + then( + as_promise(task), + onFulfilled = identity, + onRejected = function(error) { + .missbayes_plot_error_outcome(payload, error) + } + ) +} diff --git a/R/MissBayesState.R b/R/MissBayesState.R new file mode 100644 index 0000000..275fd14 --- /dev/null +++ b/R/MissBayesState.R @@ -0,0 +1,333 @@ +# Internal state and snapshot helpers for the future MissBayes workflow. +# +# These functions deliberately operate on ordinary R objects. Shiny owns the +# reactive containers, but snapshots and state transitions remain independently +# testable and serializable for the later background-execution stage. + +.copy_missbayes_object <- function(object) { + unserialize(serialize(object, NULL, version = 3L)) +} + +clone_missbayes_experiment_input <- function(experiment_input) { + if (!methods::is(experiment_input, "SummarizedExperiment")) { + stop("A clean SummarizedExperiment is required for MissBayes.") + } + .copy_missbayes_object(experiment_input) +} + +.validate_missbayes_snapshot_id <- function(value, label) { + if (!is.numeric(value) || length(value) != 1L || is.na(value) || + !is.finite(value) || value <= 0 || value != as.integer(value)) { + stop(label, " must be a positive integer.") + } + as.integer(value) +} + +.create_missbayes_snapshot_from_parts <- function(quantitative_data, + sample_metadata, + experiment_metadata, + comparison_snapshot, + paired, + experiment_id, + run_id) { + if (isTRUE(paired)) { + stop( + "MissBayes does not support paired designs; the run is blocked." + ) + } + if (!identical(paired, FALSE)) { + stop("The paired-design flag must be explicitly TRUE or FALSE.") + } + if (!is.matrix(quantitative_data) || !is.numeric(quantitative_data)) { + stop("The clean MissBayes quantitative assay must be a numeric matrix.") + } + + feature_ids <- rownames(quantitative_data) + if (is.null(feature_ids) || anyNA(feature_ids) || + any(!nzchar(trimws(feature_ids))) || anyDuplicated(feature_ids)) { + stop("MissBayes feature identifiers must be unique and non-empty.") + } + sample_names <- colnames(quantitative_data) + if (is.null(sample_names) || anyNA(sample_names) || + any(!nzchar(trimws(sample_names))) || anyDuplicated(sample_names)) { + stop("MissBayes sample names must be unique and non-empty.") + } + + if (!is.data.frame(sample_metadata)) { + stop("MissBayes sample metadata must be a data frame.") + } + if (nrow(sample_metadata) != ncol(quantitative_data)) { + stop("Sample metadata rows must match quantitative assay columns.") + } + if (is.null(rownames(sample_metadata)) || + !identical(rownames(sample_metadata), sample_names)) { + stop("Sample metadata row names must match assay sample names in order.") + } + if (!("Condition" %in% names(sample_metadata))) { + stop("Sample metadata must contain a Condition column.") + } + + condition_labels <- as.character(sample_metadata$Condition) + if (length(condition_labels) != ncol(quantitative_data) || + anyNA(condition_labels) || any(!nzchar(trimws(condition_labels)))) { + stop("Conditions must align with assay columns and be non-empty.") + } + available_conditions <- unique(condition_labels) + comparison <- validate_missbayes_comparison_snapshot( + comparison_snapshot, + available_conditions + ) + + replicate_labels <- NULL + if ("Replicate" %in% names(sample_metadata)) { + replicate_labels <- as.character(sample_metadata$Replicate) + if (length(replicate_labels) != ncol(quantitative_data) || + anyNA(replicate_labels) || + any(!nzchar(trimws(replicate_labels)))) { + stop( + "Replicate labels must align with assay columns and be non-empty." + ) + } + } + + experiment_id <- .validate_missbayes_snapshot_id( + experiment_id, + "MissBayes experiment_id" + ) + run_id <- .validate_missbayes_snapshot_id(run_id, "MissBayes run_id") + + values <- matrix( + as.numeric(quantitative_data), + nrow = nrow(quantitative_data), + ncol = ncol(quantitative_data), + dimnames = dimnames(quantitative_data) + ) + metadata_copy <- .copy_missbayes_object(sample_metadata) + experiment_metadata <- .copy_missbayes_object(experiment_metadata) + + snapshot <- list( + quantitative_data = values, + feature_ids = as.character(feature_ids), + sample_names = as.character(sample_names), + sample_metadata = metadata_copy, + condition_labels = condition_labels, + replicate_labels = replicate_labels, + comparison = comparison, + paired = FALSE, + experiment_metadata = experiment_metadata, + experiment_id = experiment_id, + run_id = run_id + ) + class(snapshot) <- c("polystest_missbayes_snapshot", "list") + snapshot +} + +create_missbayes_snapshot <- function(experiment_input, + comparison_snapshot, + paired, + experiment_id, + run_id) { + if (is.null(experiment_input)) { + stop("A clean experiment is required for a MissBayes snapshot.") + } + if (!methods::is(experiment_input, "SummarizedExperiment")) { + stop("MissBayes experiment input must be a SummarizedExperiment.") + } + if (!("quant" %in% SummarizedExperiment::assayNames(experiment_input))) { + stop("MissBayes experiment input must contain an assay named 'quant'.") + } + + quantitative_data <- SummarizedExperiment::assay( + experiment_input, + "quant" + ) + sample_metadata <- as.data.frame( + SummarizedExperiment::colData(experiment_input), + stringsAsFactors = FALSE + ) + experiment_metadata <- S4Vectors::metadata(experiment_input) + + .create_missbayes_snapshot_from_parts( + quantitative_data = quantitative_data, + sample_metadata = sample_metadata, + experiment_metadata = experiment_metadata, + comparison_snapshot = comparison_snapshot, + paired = paired, + experiment_id = experiment_id, + run_id = run_id + ) +} + +new_missbayes_state <- function() { + list( + result = NULL, + status = "idle", + error = NULL, + run_id = 0L, + experiment_id = 0L, + snapshot = NULL, + stale = FALSE + ) +} + +.validate_missbayes_state <- function(state) { + required <- c( + "result", "status", "error", "run_id", "experiment_id", + "snapshot", "stale" + ) + if (!is.list(state) || !all(required %in% names(state))) { + stop("MissBayes state is incomplete.") + } + if (!identical(length(state$status), 1L) || + !(state$status %in% c("idle", "running", "success", "error"))) { + stop("MissBayes state has an invalid status.") + } + for (field in c("run_id", "experiment_id")) { + value <- state[[field]] + if (!is.numeric(value) || length(value) != 1L || is.na(value) || + !is.finite(value) || value < 0 || value != as.integer(value)) { + stop("MissBayes state ", field, " must be a non-negative integer.") + } + } + if (!is.logical(state$stale) || length(state$stale) != 1L || + is.na(state$stale)) { + stop("MissBayes state stale must be TRUE or FALSE.") + } + state$run_id <- as.integer(state$run_id) + state$experiment_id <- as.integer(state$experiment_id) + state +} + +missbayes_register_experiment <- function(state) { + state <- .validate_missbayes_state(state) + if (state$experiment_id == .Machine$integer.max) { + stop("MissBayes experiment_id cannot be incremented further.") + } + state$experiment_id <- state$experiment_id + 1L + state$status <- "idle" + state["error"] <- list(NULL) + state["snapshot"] <- list(NULL) + state$stale <- !is.null(state$result) + state +} + +missbayes_begin_run <- function(state, snapshot) { + state <- .validate_missbayes_state(state) + if (!inherits(snapshot, "polystest_missbayes_snapshot")) { + stop("snapshot must be created by create_missbayes_snapshot().") + } + if (!identical(snapshot$experiment_id, state$experiment_id)) { + stop("MissBayes snapshot experiment_id is not current.") + } + if (snapshot$run_id <= state$run_id) { + stop("MissBayes snapshot run_id must be newer than the current run.") + } + + state$run_id <- snapshot$run_id + state$status <- "running" + state["error"] <- list(NULL) + state$snapshot <- .copy_missbayes_object(snapshot) + state +} + +run_missbayes_mock <- function(snapshot, force_failure = FALSE) { + if (!inherits(snapshot, "polystest_missbayes_snapshot")) { + stop("snapshot must be created by create_missbayes_snapshot().") + } + if (!is.logical(force_failure) || length(force_failure) != 1L || + is.na(force_failure)) { + stop("force_failure must be TRUE or FALSE.") + } + if (force_failure) { + stop("Forced MissBayes mock failure.") + } + + target_columns <- snapshot$condition_labels == snapshot$comparison$target + reference_columns <- + snapshot$condition_labels == snapshot$comparison$reference + target_mean <- rowMeans( + snapshot$quantitative_data[, target_columns, drop = FALSE], + na.rm = TRUE + ) + reference_mean <- rowMeans( + snapshot$quantitative_data[, reference_columns, drop = FALSE], + na.rm = TRUE + ) + mock_effect <- target_mean - reference_mean + mock_effect[!is.finite(mock_effect)] <- NA_real_ + + result <- list( + run_id = snapshot$run_id, + experiment_id = snapshot$experiment_id, + comparison = .copy_missbayes_object(snapshot$comparison), + table = data.frame( + feature_id = snapshot$feature_ids, + mock_effect = unname(mock_effect), + stringsAsFactors = FALSE + ) + ) + class(result) <- c("polystest_missbayes_mock_result", "list") + result +} + +.missbayes_result_is_current <- function(state, run_id, experiment_id) { + identical(state$status, "running") && + identical(as.integer(run_id), state$run_id) && + identical(as.integer(experiment_id), state$experiment_id) +} + +missbayes_accept_success <- function(state, result) { + state <- .validate_missbayes_state(state) + if (!is.list(result) || + !all(c("run_id", "experiment_id") %in% names(result))) { + stop("MissBayes result must contain run_id and experiment_id.") + } + run_id <- .validate_missbayes_snapshot_id( + result$run_id, + "MissBayes result run_id" + ) + experiment_id <- .validate_missbayes_snapshot_id( + result$experiment_id, + "MissBayes result experiment_id" + ) + if (!.missbayes_result_is_current(state, run_id, experiment_id)) { + return(state) + } + + state$result <- .copy_missbayes_object(result) + state$status <- "success" + state["error"] <- list(NULL) + state$stale <- FALSE + state +} + +.missbayes_error_message <- function(error) { + if (inherits(error, "condition")) { + return(conditionMessage(error)) + } + if (is.character(error) && length(error) == 1L && + !is.na(error) && nzchar(error)) { + return(error) + } + stop("MissBayes error must be a condition or a non-empty message.") +} + +missbayes_accept_error <- function(state, run_id, experiment_id, error) { + state <- .validate_missbayes_state(state) + run_id <- .validate_missbayes_snapshot_id( + run_id, + "MissBayes error run_id" + ) + experiment_id <- .validate_missbayes_snapshot_id( + experiment_id, + "MissBayes error experiment_id" + ) + if (!.missbayes_result_is_current(state, run_id, experiment_id)) { + return(state) + } + + state$status <- "error" + state$error <- .missbayes_error_message(error) + state$stale <- !is.null(state$result) + state +} diff --git a/R/MissBayesTask.R b/R/MissBayesTask.R new file mode 100644 index 0000000..a601f4f --- /dev/null +++ b/R/MissBayesTask.R @@ -0,0 +1,602 @@ +# Background execution helpers for the optional MissBayes workflow. +# +# The Shiny process owns runtime setup and state transitions. A mirai daemon +# receives only copied, ordinary-R snapshot/settings values and returns a +# structured outcome carrying the Stage 3 run and experiment identities. + +.missbayes_compute_profile <- "polystest_missbayes" +.missbayes_worker_environment <- "POLYSTEST_MISSBAYES_WORKERS" +.missbayes_stage4_requested_seed <- 20260731L +.missbayes_stage5_default_alpha <- 0.05 + +.missbayes_runtime_state <- new.env(parent = emptyenv()) +.missbayes_runtime_state$initialized <- FALSE +.missbayes_runtime_state$workers <- NULL + +missbayes_stage4_settings <- function() { + list( + filter4NAs = FALSE, + threshold = 0, + ROPE = c(-0.2, 0.2), + n.adapt = 1000L, + burn.in = 500L, + n.iter = 10000L, + n.chains = 2L, + mcmcDiag = TRUE, + parallel = FALSE + ) +} + +missbayes_stage4_seed <- function() { + .missbayes_stage4_requested_seed +} + +missbayes_stage5_default_alpha <- function() { + .missbayes_stage5_default_alpha +} + +validate_missbayes_task_alpha <- function(alpha) { + if (!is.numeric(alpha) || length(alpha) != 1L || is.na(alpha) || + !is.finite(alpha) || alpha <= 0 || alpha >= 0.5) { + stop( + "MissBayes alpha must be a finite value greater than 0 and ", + "less than 0.5." + ) + } + as.numeric(alpha) +} + +validate_missbayes_task_settings <- function(settings) { + fixed <- missbayes_stage4_settings() + if (!is.list(settings) || is.null(names(settings)) || + !setequal(names(settings), names(fixed)) || + length(settings) != length(fixed)) { + stop("Stage 4 MissBayes settings must contain exactly the fixed fields.") + } + settings <- settings[names(fixed)] + + logical_fields <- c("filter4NAs", "mcmcDiag", "parallel") + for (field in logical_fields) { + if (!is.logical(settings[[field]]) || + length(settings[[field]]) != 1L || + is.na(settings[[field]]) || + !identical(settings[[field]], fixed[[field]])) { + stop("Stage 4 MissBayes setting ", field, " is fixed.") + } + } + if (!is.numeric(settings$threshold) || length(settings$threshold) != 1L || + is.na(settings$threshold) || !is.finite(settings$threshold) || + settings$threshold != 0) { + stop("Stage 4 MissBayes threshold is fixed at 0.") + } + if (!is.numeric(settings$ROPE) || length(settings$ROPE) != 2L || + anyNA(settings$ROPE) || any(!is.finite(settings$ROPE)) || + settings$ROPE[[1L]] >= 0 || settings$ROPE[[2L]] <= 0 || + !isTRUE(all.equal( + abs(as.numeric(settings$ROPE[[1L]])), + as.numeric(settings$ROPE[[2L]]), + tolerance = sqrt(.Machine$double.eps) + ))) { + stop( + "MissBayes ROPE must contain two finite values symmetric around ", + "zero, with a negative lower bound and positive upper bound." + ) + } + + integer_fields <- c("n.adapt", "burn.in", "n.iter", "n.chains") + for (field in integer_fields) { + value <- settings[[field]] + if (!is.numeric(value) || length(value) != 1L || is.na(value) || + !is.finite(value) || value != as.integer(value) || + as.integer(value) != fixed[[field]]) { + stop("Stage 4 MissBayes setting ", field, " is fixed.") + } + settings[[field]] <- as.integer(value) + } + + settings$threshold <- 0 + settings$ROPE <- as.numeric(settings$ROPE) + settings +} + +.missbayes_plain_object <- function(object, depth = 0L) { + if (depth > 100L || isS4(object)) { + return(FALSE) + } + object_type <- typeof(object) + if (object_type %in% c( + "closure", "builtin", "special", "environment", "externalptr", + "weakref", "symbol", "language", "promise" + )) { + return(FALSE) + } + attributes_are_plain <- function(value) { + object_attributes <- attributes(value) + is.null(object_attributes) || all(vapply( + unname(object_attributes), + .missbayes_plain_object, + logical(1), + depth = depth + 1L + )) + } + if (is.null(object) || is.atomic(object)) { + return(attributes_are_plain(object)) + } + if (!is.list(object)) { + return(FALSE) + } + values_are_plain <- all(vapply( + object, + .missbayes_plain_object, + logical(1), + depth = depth + 1L + )) + values_are_plain && attributes_are_plain(object) +} + +validate_missbayes_task_snapshot <- function(snapshot) { + required <- c( + "quantitative_data", "feature_ids", "sample_names", + "sample_metadata", "condition_labels", "replicate_labels", + "comparison", "paired", "experiment_metadata", "experiment_id", + "run_id" + ) + if (!inherits(snapshot, "polystest_missbayes_snapshot") || + !all(required %in% names(snapshot))) { + stop("The MissBayes worker requires a validated Stage 3 snapshot.") + } + if (!.missbayes_plain_object(snapshot)) { + stop("The MissBayes worker snapshot must contain ordinary R objects only.") + } + + validated <- .create_missbayes_snapshot_from_parts( + quantitative_data = snapshot$quantitative_data, + sample_metadata = snapshot$sample_metadata, + experiment_metadata = snapshot$experiment_metadata, + comparison_snapshot = snapshot$comparison, + paired = snapshot$paired, + experiment_id = snapshot$experiment_id, + run_id = snapshot$run_id + ) + identity_fields <- c( + "feature_ids", "sample_names", "condition_labels", + "replicate_labels", "comparison", "paired", "experiment_id", + "run_id" + ) + mismatched <- identity_fields[!vapply( + identity_fields, + function(field) identical(snapshot[[field]], validated[[field]]), + logical(1) + )] + if (length(mismatched) > 0L) { + stop( + "The MissBayes worker snapshot has inconsistent fields: ", + paste(mismatched, collapse = ", "), "." + ) + } + validated +} + +create_missbayes_task_payload <- function( + snapshot, + settings = missbayes_stage4_settings(), + requested_seed = missbayes_stage4_seed(), + alpha = missbayes_stage5_default_alpha() +) { + snapshot <- validate_missbayes_task_snapshot(snapshot) + settings <- validate_missbayes_task_settings(settings) + alpha <- validate_missbayes_task_alpha(alpha) + requested_seed <- .validate_missbayes_seed(requested_seed) + if (is.null(requested_seed)) { + stop("Stage 4 MissBayes requires an explicit reproducibility seed.") + } + + payload <- list( + snapshot = snapshot, + settings = settings, + requested_seed = requested_seed, + alpha = alpha + ) + if (!.missbayes_plain_object(payload)) { + stop("The MissBayes task payload must contain ordinary R objects only.") + } + class(payload) <- c("polystest_missbayes_task_payload", "list") + payload +} + +missbayes_prepare_run <- function( + state, + experiment_input, + comparison_snapshot, + paired, + settings = missbayes_stage4_settings(), + requested_seed = missbayes_stage4_seed(), + alpha = missbayes_stage5_default_alpha() +) { + state <- .validate_missbayes_state(state) + if (state$run_id == .Machine$integer.max) { + stop("MissBayes run_id cannot be incremented further.") + } + snapshot <- create_missbayes_snapshot( + experiment_input = experiment_input, + comparison_snapshot = comparison_snapshot, + paired = paired, + experiment_id = state$experiment_id, + run_id = state$run_id + 1L + ) + payload <- create_missbayes_task_payload( + snapshot = snapshot, + settings = settings, + alpha = alpha, + requested_seed = requested_seed + ) + list( + state = missbayes_begin_run(state, snapshot), + payload = payload + ) +} + +.missbayes_snapshot_experiment <- function(snapshot) { + experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = snapshot$quantitative_data), + colData = S4Vectors::DataFrame(snapshot$sample_metadata) + ) + S4Vectors::metadata(experiment) <- snapshot$experiment_metadata + experiment +} + +.missbayes_package_version <- function(package) { + if (!requireNamespace(package, quietly = TRUE)) { + return(NA_character_) + } + as.character(utils::packageVersion(package)) +} + +.missbayes_source_revision <- function() { + installed_revision <- NULL + if (requireNamespace("missBayes", quietly = TRUE)) { + installed_revision <- tryCatch( + utils::packageDescription("missBayes")[["RemoteSha"]], + error = function(error) NULL + ) + } + if (!is.null(installed_revision) && nzchar(installed_revision)) { + return(installed_revision) + } + contract_revision <- tryCatch( + utils::packageDescription("PolySTest")[[ + "Config/PolySTest/missBayes-commit" + ]], + error = function(error) NULL + ) + if (is.null(contract_revision) || !nzchar(contract_revision)) { + return(NA_character_) + } + contract_revision +} + +.missbayes_jags_version <- function() { + if (!requireNamespace("rjags", quietly = TRUE)) { + return(NA_character_) + } + jags_version <- getExportedValue("rjags", "jags.version") + tryCatch( + as.character(jags_version()), + error = function(error) NA_character_ + ) +} + +.missbayes_task_diagnostics <- function(adapter_result) { + status_counts <- table( + factor( + adapter_result$results$fit_status, + levels = c("estimated", "fit_failed", "not_estimable") + ) + ) + list( + raw_fields = names(adapter_result$raw), + raw_row_count = nrow(adapter_result$raw), + result_row_count = nrow(adapter_result$results), + fit_status_counts = as.list(as.integer(status_counts)) |> + stats::setNames(names(status_counts)) + ) +} + +run_missbayes_task <- function( + snapshot, + settings, + requested_seed, + alpha = missbayes_stage5_default_alpha() +) { + snapshot <- validate_missbayes_task_snapshot(snapshot) + settings <- validate_missbayes_task_settings(settings) + alpha <- validate_missbayes_task_alpha(alpha) + requested_seed <- .validate_missbayes_seed(requested_seed) + if (is.null(requested_seed)) { + stop("Stage 4 MissBayes requires an explicit reproducibility seed.") + } + + started_at <- Sys.time() + adapter_settings <- settings[names(missbayes_default_settings())] + prepared <- prepare_missbayes_input( + experiment_input = .missbayes_snapshot_experiment(snapshot), + comparison_snapshot = snapshot$comparison, + paired = snapshot$paired, + rope_half_width = settings$ROPE[[2L]], + alpha = alpha, + seed = requested_seed, + settings = adapter_settings + ) + adapter_result <- run_missbayes_model(prepared) + completed_at <- Sys.time() + + envelope <- list( + status = "success", + run_id = snapshot$run_id, + experiment_id = snapshot$experiment_id, + comparison = .copy_missbayes_object(snapshot$comparison), + table = adapter_result$results, + adapter_summary = adapter_result$summary, + adapter_diagnostics = .missbayes_task_diagnostics(adapter_result), + settings = settings, + alpha = alpha, + metadata = list( + requested_seed = requested_seed, + rope = settings$ROPE, + rope_half_width = settings$ROPE[[2L]], + alpha = alpha, + missbayes_package_version = .missbayes_package_version("missBayes"), + missbayes_source_revision = .missbayes_source_revision(), + r_version = R.version.string, + jags_version = .missbayes_jags_version(), + mcmc_settings = settings[c( + "n.adapt", "burn.in", "n.iter", "n.chains", "mcmcDiag", + "parallel" + )], + reproducibility_scope = paste( + "The requested seed is recorded for this run; reproducibility", + "is not claimed across different software or runtime environments." + ) + ), + runtime = list( + worker_pid = Sys.getpid(), + started_at_utc = format( + started_at, + "%Y-%m-%dT%H:%M:%OS3Z", + tz = "UTC" + ), + completed_at_utc = format( + completed_at, + "%Y-%m-%dT%H:%M:%OS3Z", + tz = "UTC" + ), + elapsed_seconds = as.numeric(difftime( + completed_at, + started_at, + units = "secs" + )) + ) + ) + class(envelope) <- c("polystest_missbayes_task_result", "list") + envelope +} + +missbayes_safe_error_message <- function(error) { + message <- if (inherits(error, "condition")) { + conditionMessage(error) + } else if (is.character(error) && length(error) == 1L && + !is.na(error) && nzchar(error)) { + error + } else { + "MissBayes background execution failed." + } + message <- trimws(gsub("[[:space:]]+", " ", message)) + if (!nzchar(message)) { + message <- "MissBayes background execution failed." + } + if (nchar(message, type = "chars") > 500L) { + message <- paste0(substr(message, 1L, 497L), "...") + } + message +} + +.missbayes_task_error_outcome <- function(snapshot, error) { + comparison <- if (is.list(snapshot$comparison)) { + .copy_missbayes_object(snapshot$comparison) + } else { + NULL + } + outcome <- list( + status = "error", + run_id = .validate_missbayes_snapshot_id( + snapshot$run_id, + "MissBayes worker error run_id" + ), + experiment_id = .validate_missbayes_snapshot_id( + snapshot$experiment_id, + "MissBayes worker error experiment_id" + ), + comparison = comparison, + error = missbayes_safe_error_message(error) + ) + class(outcome) <- c("polystest_missbayes_task_error", "list") + outcome +} + +run_missbayes_task_outcome <- function( + snapshot, + settings, + requested_seed, + alpha = missbayes_stage5_default_alpha() +) { + tryCatch( + run_missbayes_task( + snapshot = snapshot, + settings = settings, + alpha = alpha, + requested_seed = requested_seed + ), + error = function(error) .missbayes_task_error_outcome(snapshot, error) + ) +} + +missbayes_accept_task_outcome <- function(state, outcome) { + if (!is.list(outcome) || + !all(c("status", "run_id", "experiment_id") %in% names(outcome))) { + stop("MissBayes task outcome is incomplete.") + } + if (identical(outcome$status, "success")) { + return(missbayes_accept_success(state, outcome)) + } + if (identical(outcome$status, "error")) { + if (!is.character(outcome$error) || length(outcome$error) != 1L || + is.na(outcome$error) || !nzchar(outcome$error)) { + stop("MissBayes task error outcome requires a clean error message.") + } + return(missbayes_accept_error( + state, + outcome$run_id, + outcome$experiment_id, + outcome$error + )) + } + stop("MissBayes task outcome status must be success or error.") +} + +missbayes_worker_count <- function( + value = Sys.getenv(.missbayes_worker_environment, unset = "") +) { + if (!is.character(value) || length(value) != 1L || is.na(value)) { + return(1L) + } + value <- trimws(value) + if (!grepl("^[1-9][0-9]*$", value)) { + return(1L) + } + parsed <- suppressWarnings(as.numeric(value)) + if (!is.finite(parsed) || parsed > .Machine$integer.max) { + return(1L) + } + as.integer(parsed) +} + +.require_missbayes_background_runtime <- function() { + if (!requireNamespace("mirai", quietly = TRUE)) { + stop( + "The optional package 'mirai' is required for background ", + "MissBayes execution." + ) + } + if (!exists( + "ExtendedTask", + envir = asNamespace("shiny"), + inherits = FALSE + )) { + stop("This Shiny installation does not provide ExtendedTask.") + } + if (!requireNamespace("promises", quietly = TRUE)) { + stop("Shiny's promises dependency is required for background tasks.") + } + invisible(TRUE) +} + +configure_missbayes_runtime <- function( + workers = missbayes_worker_count() +) { + .require_missbayes_background_runtime() + if (!is.numeric(workers) || length(workers) != 1L || is.na(workers) || + !is.finite(workers) || workers <= 0 || + workers != as.integer(workers)) { + stop("MissBayes worker count must be a positive integer.") + } + workers <- as.integer(workers) + if (isTRUE(.missbayes_runtime_state$initialized)) { + return(list( + available = TRUE, + workers = .missbayes_runtime_state$workers, + compute_profile = .missbayes_compute_profile + )) + } + + mirai::daemons( + n = workers, + dispatcher = TRUE, + .compute = .missbayes_compute_profile + ) + .missbayes_runtime_state$workers <- workers + .missbayes_runtime_state$initialized <- TRUE + list( + available = TRUE, + workers = workers, + compute_profile = .missbayes_compute_profile + ) +} + +missbayes_runtime_status <- function() { + list( + initialized = isTRUE(.missbayes_runtime_state$initialized), + workers = .missbayes_runtime_state$workers, + compute_profile = .missbayes_compute_profile, + worker_environment = .missbayes_worker_environment + ) +} + +.missbayes_resolved_promise <- function(value) { + resolve <- getExportedValue("promises", "promise_resolve") + resolve(value) +} + +submit_missbayes_task <- function(payload) { + if (!inherits(payload, "polystest_missbayes_task_payload")) { + stop("payload must be created by create_missbayes_task_payload().") + } + payload <- create_missbayes_task_payload( + snapshot = payload$snapshot, + settings = payload$settings, + alpha = payload$alpha, + requested_seed = payload$requested_seed + ) + runtime <- missbayes_runtime_status() + if (!isTRUE(runtime$initialized)) { + stop("The MissBayes background runtime has not been configured.") + } + + submission_error <- NULL + task <- tryCatch( + mirai::mirai( + PolySTest:::run_missbayes_task_outcome( + snapshot = worker_snapshot, + settings = worker_settings, + alpha = worker_alpha, + requested_seed = worker_seed + ), + worker_snapshot = payload$snapshot, + worker_settings = payload$settings, + worker_alpha = payload$alpha, + worker_seed = payload$requested_seed, + .compute = .missbayes_compute_profile + ), + error = function(error) { + submission_error <<- error + NULL + } + ) + if (is.null(task)) { + return(.missbayes_resolved_promise( + .missbayes_task_error_outcome( + payload$snapshot, + submission_error + ) + )) + } + + as_promise <- getExportedValue("promises", "as.promise") + then <- getExportedValue("promises", "then") + then( + as_promise(task), + onFulfilled = identity, + onRejected = function(error) { + .missbayes_task_error_outcome(payload$snapshot, error) + } + ) +} diff --git a/R/MissBayesUI.R b/R/MissBayesUI.R new file mode 100644 index 0000000..a2c1c13 --- /dev/null +++ b/R/MissBayesUI.R @@ -0,0 +1,377 @@ +# Presentation and export helpers for the Shiny MissBayes workflow. +# +# These helpers operate on ordinary values and completed Stage 4 envelopes. The +# Shiny UI never becomes the durable source for run settings or results. + +missbayes_comparison_choices <- function(all_comparisons) { + if (is.null(all_comparisons) || length(all_comparisons) == 0L) { + return(data.frame( + value = character(), + label = character(), + reference = character(), + target = character(), + stringsAsFactors = FALSE + )) + } + if (!(is.matrix(all_comparisons) || is.data.frame(all_comparisons)) || + ncol(all_comparisons) != 2L || nrow(all_comparisons) < 1L) { + return(data.frame( + value = character(), + label = character(), + reference = character(), + target = character(), + stringsAsFactors = FALSE + )) + } + + reference <- trimws(as.character(all_comparisons[, 1L])) + target <- trimws(as.character(all_comparisons[, 2L])) + valid <- !is.na(reference) & nzchar(reference) & + !is.na(target) & nzchar(target) & reference != target + reference <- reference[valid] + target <- target[valid] + if (length(reference) == 0L) { + return(data.frame( + value = character(), + label = character(), + reference = character(), + target = character(), + stringsAsFactors = FALSE + )) + } + + identity <- paste(reference, target, sep = "\r") + keep <- !duplicated(identity) + reference <- reference[keep] + target <- target[keep] + data.frame( + value = paste0("comparison_", seq_along(reference)), + label = paste0(target, "_vs_", reference), + reference = reference, + target = target, + stringsAsFactors = FALSE + ) +} + +missbayes_resolve_comparison <- function(all_comparisons, selection) { + choices <- missbayes_comparison_choices(all_comparisons) + if (!is.character(selection) || length(selection) != 1L || + is.na(selection) || !nzchar(selection)) { + stop("Select exactly one valid MissBayes comparison.") + } + row <- match(selection, choices$value) + if (is.na(row)) { + stop( + "The selected MissBayes comparison is no longer available. ", + "Select a current comparison and try again." + ) + } + list( + reference = choices$reference[[row]], + target = choices$target[[row]], + name = choices$label[[row]] + ) +} + +validate_missbayes_ui_rope_half_width <- function(value) { + if (!is.numeric(value) || length(value) != 1L || is.na(value) || + !is.finite(value) || value <= 0) { + stop("MissBayes ROPE half-width must be a positive finite value.") + } + as.numeric(value) +} + +validate_missbayes_ui_alpha <- function(value) { + validate_missbayes_task_alpha(value) +} + +missbayes_stage5_run_settings <- function(rope_half_width) { + rope_half_width <- validate_missbayes_ui_rope_half_width(rope_half_width) + settings <- missbayes_stage4_settings() + settings$ROPE <- c(-rope_half_width, rope_half_width) + validate_missbayes_task_settings(settings) +} + +prepare_missbayes_stage5_run <- function( + state, + experiment_input, + all_comparisons, + selection, + paired, + rope_half_width, + alpha, + requested_seed = missbayes_stage4_seed() +) { + if (isTRUE(paired)) { + stop("MissBayes does not support paired designs; the run is blocked.") + } + comparison <- missbayes_resolve_comparison(all_comparisons, selection) + settings <- missbayes_stage5_run_settings(rope_half_width) + alpha <- validate_missbayes_ui_alpha(alpha) + missbayes_prepare_run( + state = state, + experiment_input = experiment_input, + comparison_snapshot = comparison, + paired = paired, + settings = settings, + alpha = alpha, + requested_seed = requested_seed + ) +} + +.missbayes_result_parameters <- function(result) { + if (!is.list(result)) { + stop("A completed MissBayes result is required.") + } + settings <- result$settings + if (!is.list(settings)) { + settings <- missbayes_stage4_settings() + } + metadata <- result$metadata + if (!is.list(metadata)) { + metadata <- list() + } + rope <- metadata$rope + if (is.null(rope)) { + rope <- settings$ROPE + } + rope <- validate_missbayes_task_settings( + utils::modifyList(missbayes_stage4_settings(), list(ROPE = rope)) + )$ROPE + alpha <- metadata$alpha + if (is.null(alpha)) { + alpha <- result$alpha + } + if (is.null(alpha)) { + alpha <- missbayes_stage5_default_alpha() + } + alpha <- validate_missbayes_task_alpha(alpha) + + comparison <- result$comparison + if (!is.list(comparison) || + !all(c("reference", "target", "name") %in% names(comparison))) { + stop("The MissBayes result comparison metadata is incomplete.") + } + list( + comparison = comparison, + rope = rope, + rope_half_width = rope[[2L]], + alpha = alpha, + settings = settings, + metadata = metadata + ) +} + +missbayes_result_summary <- function(result) { + if (!is.list(result) || !is.data.frame(result$table)) { + stop("A completed MissBayes result table is required.") + } + table <- result$table + adapter <- result$adapter_summary + if (!is.list(adapter)) { + adapter <- list() + } + count <- function(name, fallback) { + value <- adapter[[name]] + if (is.null(value)) fallback else as.integer(value) + } + decision <- if ("decision" %in% names(table)) table$decision else NA_character_ + fit_status <- if ("fit_status" %in% names(table)) { + table$fit_status + } else { + rep(NA_character_, nrow(table)) + } + convergence <- if ("convergence" %in% names(table)) { + tolower(trimws(table$convergence)) + } else { + rep(NA_character_, nrow(table)) + } + directional <- decision %in% c("up", "down") + posterior_error <- if ("posterior_error_probability" %in% names(table)) { + table$posterior_error_probability + } else { + rep(NA_real_, nrow(table)) + } + directional_fdr <- adapter$estimated_bayesian_directional_fdr + if (is.null(directional_fdr)) { + directional_fdr <- if (any(directional)) { + mean(posterior_error[directional], na.rm = TRUE) + } else { + NA_real_ + } + } + + list( + estimated_count = sum(fit_status == "estimated", na.rm = TRUE), + not_estimable_count = count( + "not_estimable_count", + sum(fit_status == "not_estimable", na.rm = TRUE) + ), + fit_failed_count = count( + "fit_failed_count", + sum(fit_status == "fit_failed", na.rm = TRUE) + ), + poor_convergence_count = count( + "poor_convergence_count", + sum(fit_status == "estimated" & convergence == "poor", na.rm = TRUE) + ), + moderate_convergence_count = count( + "moderate_convergence_count", + sum( + fit_status == "estimated" & convergence == "moderate", + na.rm = TRUE + ) + ), + up_count = count("up_count", sum(decision == "up", na.rm = TRUE)), + down_count = count("down_count", sum(decision == "down", na.rm = TRUE)), + practically_unchanged_count = count( + "practically_unchanged_count", + sum(decision == "practically_unchanged", na.rm = TRUE) + ), + uncertain_count = count( + "uncertain_count", + sum(fit_status == "estimated" & decision == "uncertain", na.rm = TRUE) + ), + estimated_bayesian_directional_fdr = as.numeric(directional_fdr) + ) +} + +missbayes_status_view <- function(state, active_payload = NULL, + input_error = NULL) { + state <- .validate_missbayes_state(state) + has_result <- !is.null(state$result) + result_is_stale <- has_result && + (!identical(state$status, "success") || isTRUE(state$stale)) + headline <- switch( + state$status, + idle = if (has_result) { + "MissBayes has not been run for the current experiment." + } else { + "MissBayes has not yet been run." + }, + running = "MissBayes analysis is running.", + success = "MissBayes analysis completed successfully.", + error = "MissBayes analysis failed." + ) + message <- switch( + state$status, + idle = "Choose one comparison, a ROPE half-width, and a posterior-error cutoff to begin.", + running = "The model is running in the background; percentage progress is not available.", + success = "The table and CSV contain all original features.", + error = state$error + ) + if (!is.null(input_error)) { + message <- input_error + } + + parameters <- NULL + if (identical(state$status, "running") && is.list(active_payload)) { + parameters <- list( + comparison = active_payload$snapshot$comparison, + rope = active_payload$settings$ROPE, + rope_half_width = active_payload$settings$ROPE[[2L]], + alpha = active_payload$alpha + ) + } else if (has_result) { + parameters <- .missbayes_result_parameters(state$result) + } + list( + status = state$status, + headline = headline, + message = message, + has_result = has_result, + stale = result_is_stale, + parameters = parameters, + summary = if (has_result) missbayes_result_summary(state$result) else NULL + ) +} + +missbayes_display_table <- function(result) { + if (!is.list(result) || !is.data.frame(result$table)) { + stop("A completed MissBayes result table is required.") + } + fields <- c( + feature_id = "Feature ID", + fit_status = "Fit status", + decision = "Decision", + posterior_median_log2_fc = "Median log2FC", + hdi_95_lower = "95% HDI low", + hdi_95_upper = "95% HDI high", + probability_above_rope = "Probability up (above ROPE)", + probability_below_rope = "Probability down (below ROPE)", + probability_within_rope = "Probability within ROPE", + posterior_error_probability = "Posterior error probability", + directional_local_fdr = "Bayesian directional local FDR", + convergence = "Convergence", + ess = "ESS", + mcse = "MCSE", + rhat_max = "Max R-hat", + minimum_sign_tail_probability = + "Minimum sign-tail probability (MissBayes)" + ) + present <- names(fields)[names(fields) %in% names(result$table)] + output <- result$table[, present, drop = FALSE] + names(output) <- unname(fields[present]) + rownames(output) <- NULL + output +} + +.missbayes_export_scalar <- function(value) { + if (is.null(value) || length(value) == 0L) NA else value[[1L]] +} + +missbayes_csv_export <- function(result) { + if (!is.list(result) || !is.data.frame(result$table)) { + stop("A completed MissBayes result table is required.") + } + parameters <- .missbayes_result_parameters(result) + table <- result$table + if ("directional_local_fdr" %in% names(table)) { + names(table)[names(table) == "directional_local_fdr"] <- + "bayesian_directional_local_fdr" + } + settings <- parameters$settings + metadata <- parameters$metadata + rows <- nrow(table) + repeat_value <- function(value) rep(.missbayes_export_scalar(value), rows) + export_metadata <- data.frame( + comparison_identity = repeat_value(parameters$comparison$name), + reference_condition = repeat_value(parameters$comparison$reference), + target_condition = repeat_value(parameters$comparison$target), + rope_lower = repeat_value(parameters$rope[[1L]]), + rope_upper = repeat_value(parameters$rope[[2L]]), + rope_half_width = repeat_value(parameters$rope_half_width), + posterior_error_cutoff_alpha = repeat_value(parameters$alpha), + run_id = repeat_value(result$run_id), + experiment_id = repeat_value(result$experiment_id), + seed = repeat_value(metadata$requested_seed), + missbayes_version = repeat_value(metadata$missbayes_package_version), + r_version = repeat_value(metadata$r_version), + jags_version = repeat_value(metadata$jags_version), + filter4NAs = repeat_value(settings$filter4NAs), + threshold = repeat_value(settings$threshold), + n_adapt = repeat_value(settings$n.adapt), + burn_in = repeat_value(settings$burn.in), + n_iter = repeat_value(settings$n.iter), + n_chains = repeat_value(settings$n.chains), + diagnostics_enabled = repeat_value(settings$mcmcDiag), + worker_missbayes_parallel = repeat_value(settings$parallel), + stringsAsFactors = FALSE + ) + output <- cbind(table, export_metadata, stringsAsFactors = FALSE) + rownames(output) <- NULL + output +} + +missbayes_csv_filename <- function(result, time = Sys.time()) { + parameters <- .missbayes_result_parameters(result) + comparison <- gsub( + "[^A-Za-z0-9._-]+", + "-", + parameters$comparison$name + ) + paste0( + "MissBayes_", comparison, "_", + format(time, "%Y%m%d-%H%M%S", tz = "UTC"), ".csv" + ) +} diff --git a/README.md b/README.md index 8de5551..9f72385 100755 --- a/README.md +++ b/README.md @@ -73,6 +73,84 @@ You can run the image by and access the server through http://localhost:3838 +### Optional MissBayes workflow + +MissBayes is an optional, unpaired-only Bayesian workflow. Ordinary PolySTest +package loading and analysis do not require MissBayes, JAGS, rjags, or mirai; +those dependencies are needed only by a deployment that enables the MissBayes +workflow. Paired or blocked designs are rejected both in the interface and by +the server-side adapter rather than being treated as unpaired data. + +The ROPE control is a half-width on the log2 fold-change scale, so a value of +`0.2` represents the interval `[-0.2, 0.2]`. The posterior-error cutoff must +satisfy `0 < alpha < 0.5`. Results retain every input feature and use these +decision categories: + +- `up` +- `down` +- `practically_unchanged` +- `uncertain` + +The `fit_status` field distinguishes `estimated`, `fit_failed`, and +`not_estimable` rows. The reported Bayesian directional local FDR is a +posterior directional error measure; it is not a Benjamini-Hochberg FDR or a +q-value. A posterior plot is produced only on explicit request and is a fresh +single-feature MCMC refit, not a plot of stored posterior draws from the table +run. + +The Shiny process keeps a clean, copied `experimentInput()` for MissBayes +snapshots. This is deliberately separate from result-bearing `currse()`, which +continues to serve the original PolySTest workflow. MissBayes tasks receive +only plain copied data and settings. A single named mirai pool is created per +Shiny process; each MissBayes fit runs with its own internal `parallel = FALSE`. +Set `POLYSTEST_MISSBAYES_WORKERS` to a positive integer to change the pool size; +missing or invalid values safely fall back to one worker. Repeated submissions +are identified by experiment and run IDs so older completions cannot replace +newer state. + +#### Deployment requirements + +The deployment runtime requires JAGS, rjags, mirai, promises, and Shiny with +`ExtendedTask` (Shiny 1.8.1 or newer). The final Dockerfile deliberately +preserves Shiny 1.10.0 and installs missBayes from the revision recorded in +`Config/PolySTest/missBayes-commit` in `DESCRIPTION`. It also verifies the +installed `RemoteSha`; package installation never fetches unpinned MissBayes +source implicitly. + +Build the release image from the repository root without changing the stable +Dockerfile or stable image tags: + +```sh +docker build -f inst/docker/Dockerfile.missbayes-final \ + --build-arg POLYSTEST_BASE_IMAGE=polystest-stable:latest \ + --build-arg POLYSTEST_SOURCE_REVISION=$(git rev-parse HEAD) \ + -t polystest-missbayes-final:latest . +docker run --rm -p 3838:3838 polystest-missbayes-final:latest +``` + +The installed package and mirai workers use the shared R site library; no +source mount, developer library, or `R_LIBS` override is needed. Requested +seeds and software versions are recorded, but bit-for-bit reproducibility is +not claimed across different R, JAGS, package, operating-system, or hardware +environments. + +#### Maintainer tests + +Run the canonical suite from a writable source checkout: + +```sh +R -q -e "devtools::test(reporter = 'summary')" +``` + +In a runtime containing the optional dependencies, run the three real +contracts explicitly: + +```sh +POLYSTEST_RUN_MISSBAYES_CONTRACT=true Rscript tests/contract/missbayes-contract.R +POLYSTEST_RUN_MISSBAYES_BACKGROUND_CONTRACT=true Rscript tests/contract/missbayes-background-contract.R +POLYSTEST_RUN_MISSBAYES_PLOT_CONTRACT=true Rscript tests/contract/missbayes-plot-contract.R +``` + ## Command-line version You can run PolySTest via the file _runPolySTestCLI.R_. You need to specify a parameter file (yaml) to set parameters and the input file. See _polystest.yml_ for an example and extensive description of the parameters diff --git a/inst/docker/Dockerfile.missbayes-dev b/inst/docker/Dockerfile.missbayes-dev new file mode 100644 index 0000000..867d1d2 --- /dev/null +++ b/inst/docker/Dockerfile.missbayes-dev @@ -0,0 +1,22 @@ +ARG POLYSTEST_BASE_IMAGE=polystest-stable:latest +FROM ${POLYSTEST_BASE_IMAGE} + +LABEL maintainer="Veit Schwaemmle " +LABEL description="Development-only PolySTest image with pinned MissBayes and JAGS" +LABEL org.opencontainers.image.title="polystest-missbayes-dev" +LABEL org.opencontainers.image.missbayes.commit="cd283693a16336d49e49a4132acc05822f92b2d6" + +ENV MISSBAYES_COMMIT=cd283693a16336d49e49a4132acc05822f92b2d6 + +RUN apt-get update \ + && apt-get install -y --no-install-recommends jags libglpk40 \ + && apt-get clean \ + && rm -rf /var/lib/apt/lists/* + +RUN R -q -e "requested <- c('coda', 'rjags', 'mirai', 'MultiAssayExperiment', 'QFeatures', 'scpdata'); BiocManager::install(requested, ask = FALSE, update = FALSE); missing <- requested[!vapply(requested, requireNamespace, quietly = TRUE, FUN.VALUE = logical(1))]; if (length(missing)) stop('Missing development dependencies: ', paste(missing, collapse = ', '))" + +RUN R -q -e "remotes::install_github(paste0('lmcdbd/missBayes@', Sys.getenv('MISSBAYES_COMMIT')), dependencies = FALSE, upgrade = 'never', build_vignettes = FALSE); if (!requireNamespace('missBayes', quietly = TRUE)) stop('missBayes installation failed'); installed <- utils::packageDescription('missBayes')[['RemoteSha']]; if (!identical(installed, Sys.getenv('MISSBAYES_COMMIT'))) stop('Installed missBayes commit mismatch: ', installed)" + +RUN rm -rf /tmp/polystest-missbayes +COPY . /tmp/polystest-missbayes +RUN R -q -e "devtools::install('/tmp/polystest-missbayes', dependencies = FALSE, upgrade = 'never')" diff --git a/inst/docker/Dockerfile.missbayes-final b/inst/docker/Dockerfile.missbayes-final new file mode 100644 index 0000000..8b5fe26 --- /dev/null +++ b/inst/docker/Dockerfile.missbayes-final @@ -0,0 +1,33 @@ +ARG POLYSTEST_BASE_IMAGE=polystest-stable:latest +FROM ${POLYSTEST_BASE_IMAGE} + +ARG MISSBAYES_COMMIT=cd283693a16336d49e49a4132acc05822f92b2d6 +ARG POLYSTEST_SOURCE_REVISION=unknown + +LABEL maintainer="Veit Schwaemmle " +LABEL description="Deployment-ready PolySTest image with pinned MissBayes, JAGS, and background workers" +LABEL org.opencontainers.image.title="polystest-missbayes-final" +LABEL org.opencontainers.image.revision="${POLYSTEST_SOURCE_REVISION}" +LABEL org.opencontainers.image.missbayes.commit="${MISSBAYES_COMMIT}" + +ENV MISSBAYES_COMMIT=${MISSBAYES_COMMIT} \ + POLYSTEST_SOURCE_REVISION=${POLYSTEST_SOURCE_REVISION} + +RUN apt-get update \ + && apt-get install -y --no-install-recommends jags libglpk40 \ + && apt-get clean \ + && rm -rf /var/lib/apt/lists/* + +RUN R -q -e "if (!identical(as.character(utils::packageVersion('shiny')), '1.10.0')) stop('The final image requires Shiny 1.10.0'); requested <- c('coda', 'rjags', 'mirai', 'promises', 'MultiAssayExperiment', 'QFeatures', 'scpdata'); BiocManager::install(requested, lib = '/usr/local/lib/R/site-library', ask = FALSE, update = FALSE); missing <- requested[!vapply(requested, requireNamespace, quietly = TRUE, FUN.VALUE = logical(1))]; if (length(missing)) stop('Missing deployment dependencies: ', paste(missing, collapse = ', '))" + +RUN R -q -e "remotes::install_github(paste0('lmcdbd/missBayes@', Sys.getenv('MISSBAYES_COMMIT')), lib = '/usr/local/lib/R/site-library', dependencies = FALSE, upgrade = 'never', build_vignettes = FALSE); if (!requireNamespace('missBayes', quietly = TRUE)) stop('missBayes installation failed'); installed <- utils::packageDescription('missBayes')[['RemoteSha']]; if (!identical(installed, Sys.getenv('MISSBAYES_COMMIT'))) stop('Installed missBayes commit mismatch: ', installed)" + +RUN rm -rf /tmp/polystest /tmp/polystest-missbayes /tmp/polystest-release \ + && rm -rf /srv/shiny-server/* +COPY . /tmp/polystest-release +COPY inst/shiny/ /srv/shiny-server/ +RUN R -q -e "remotes::install_local('/tmp/polystest-release', lib = '/usr/local/lib/R/site-library', dependencies = FALSE, upgrade = 'never', build_vignettes = FALSE, force = TRUE); if (!identical(as.character(utils::packageVersion('shiny')), '1.10.0')) stop('Shiny version changed during the build'); if (!exists('ExtendedTask', envir = asNamespace('shiny'), inherits = FALSE)) stop('Shiny ExtendedTask is unavailable')" \ + && chmod a+x /tmp/polystest-release/inst/cmdline/* \ + && cp /tmp/polystest-release/inst/cmdline/* /usr/bin/ \ + && printf '%s\n' "${POLYSTEST_SOURCE_REVISION}" > /usr/local/share/polystest-source-revision \ + && rm -rf /tmp/polystest-release /tmp/* /var/tmp/* diff --git a/inst/shiny/server.R b/inst/shiny/server.R index f4cc875..03e82fb 100755 --- a/inst/shiny/server.R +++ b/inst/shiny/server.R @@ -20,11 +20,28 @@ options(java.parameters="-Xss2560k") # for debugging: # options(shiny.reactlog=TRUE) +# One pool is shared by all Shiny sessions in this application process. mirai +# daemons exit automatically when their host process ends; they are not created +# or stopped per session or per invocation. +missBayesRuntime <- tryCatch( + PolySTest:::configure_missbayes_runtime(), + error = function(error) { + message("MissBayes background runtime unavailable: ", conditionMessage(error)) + list( + available = FALSE, + workers = 0L, + compute_profile = NULL, + error = PolySTest:::missbayes_safe_error_message(error) + ) + } +) + shinyServer(function(input, output, clientData, session) { # Reactive values and global variables currdata <- reactiveVal(NULL) # Stores the current data content from file currse <- reactiveVal(NULL) # Stores data in SummarizedExperiment + experimentInput <- reactiveVal(NULL) # Clean experiment for MissBayes snapshots FullReg <- reactiveVal(NULL) # Output table obsadd <- NULL # Placeholder for adding new comparison UI elements actFileName <- NULL # Placeholder for the actual file name for input @@ -40,8 +57,813 @@ shinyServer(function(input, output, clientData, session) { addInfo <- NULL # Additional information from the original table to be re-added after analysis proxy <- NULL # Access to data table heightSize <- reactiveVal(200) # Height of the data table + initialMissBayesState <- PolySTest:::new_missbayes_state() + MissBayes <- reactiveValues( + result = initialMissBayesState$result, + status = initialMissBayesState$status, + error = initialMissBayesState$error, + run_id = initialMissBayesState$run_id, + experiment_id = initialMissBayesState$experiment_id, + snapshot = initialMissBayesState$snapshot, + stale = initialMissBayesState$stale + ) + MissBayesActivePayload <- reactiveVal(NULL) + MissBayesInputError <- reactiveVal(NULL) + MissBayesTask <- if (isTRUE(missBayesRuntime$available)) { + ExtendedTask <- getExportedValue("shiny", "ExtendedTask") + ExtendedTask$new(function(payload) { + PolySTest:::submit_missbayes_task(payload) + }) + } else { + NULL + } + initialMissBayesPlotState <- PolySTest:::new_missbayes_plot_state() + MissBayesPlot <- reactiveValues( + status = initialMissBayesPlotState$status, + error = initialMissBayesPlotState$error, + plot = initialMissBayesPlotState$plot, + feature_id = initialMissBayesPlotState$feature_id, + plot_run_id = initialMissBayesPlotState$plot_run_id, + experiment_id = initialMissBayesPlotState$experiment_id, + source_missbayes_run_id = + initialMissBayesPlotState$source_missbayes_run_id, + source_missbayes_experiment_id = + initialMissBayesPlotState$source_missbayes_experiment_id, + comparison = initialMissBayesPlotState$comparison, + rope = initialMissBayesPlotState$rope, + seed = initialMissBayesPlotState$seed, + source_result_stale = initialMissBayesPlotState$source_result_stale, + stale = initialMissBayesPlotState$stale + ) + MissBayesPlotActivePayload <- reactiveVal(NULL) + MissBayesPlotInputError <- reactiveVal(NULL) + MissBayesPlotTask <- if (isTRUE(missBayesRuntime$available)) { + ExtendedTask <- getExportedValue("shiny", "ExtendedTask") + ExtendedTask$new(function(payload) { + PolySTest:::submit_missbayes_plot_task(payload) + }) + } else { + NULL + } + + getMissBayesState <- function() { + isolate(list( + result = MissBayes$result, + status = MissBayes$status, + error = MissBayes$error, + run_id = MissBayes$run_id, + experiment_id = MissBayes$experiment_id, + snapshot = MissBayes$snapshot, + stale = MissBayes$stale + )) + } + + setMissBayesState <- function(state) { + MissBayes$result <- state$result + MissBayes$status <- state$status + MissBayes$error <- state$error + MissBayes$run_id <- state$run_id + MissBayes$experiment_id <- state$experiment_id + MissBayes$snapshot <- state$snapshot + MissBayes$stale <- state$stale + invisible(state) + } + + getMissBayesPlotState <- function() { + isolate(list( + status = MissBayesPlot$status, + error = MissBayesPlot$error, + plot = MissBayesPlot$plot, + feature_id = MissBayesPlot$feature_id, + plot_run_id = MissBayesPlot$plot_run_id, + experiment_id = MissBayesPlot$experiment_id, + source_missbayes_run_id = MissBayesPlot$source_missbayes_run_id, + source_missbayes_experiment_id = + MissBayesPlot$source_missbayes_experiment_id, + comparison = MissBayesPlot$comparison, + rope = MissBayesPlot$rope, + seed = MissBayesPlot$seed, + source_result_stale = MissBayesPlot$source_result_stale, + stale = MissBayesPlot$stale + )) + } + + setMissBayesPlotState <- function(state) { + MissBayesPlot$status <- state$status + MissBayesPlot$error <- state$error + MissBayesPlot$plot <- state$plot + MissBayesPlot$feature_id <- state$feature_id + MissBayesPlot$plot_run_id <- state$plot_run_id + MissBayesPlot$experiment_id <- state$experiment_id + MissBayesPlot$source_missbayes_run_id <- state$source_missbayes_run_id + MissBayesPlot$source_missbayes_experiment_id <- + state$source_missbayes_experiment_id + MissBayesPlot$comparison <- state$comparison + MissBayesPlot$rope <- state$rope + MissBayesPlot$seed <- state$seed + MissBayesPlot$source_result_stale <- state$source_result_stale + MissBayesPlot$stale <- state$stale + invisible(state) + } + + storeMissBayesExperiment <- function(experiment) { + cleanExperiment <- PolySTest:::clone_missbayes_experiment_input(experiment) + state <- PolySTest:::missbayes_register_experiment(getMissBayesState()) + experimentInput(cleanExperiment) + MissBayesActivePayload(NULL) + MissBayesInputError(NULL) + setMissBayesState(state) + setMissBayesPlotState(PolySTest:::missbayes_plot_register_experiment( + getMissBayesPlotState(), + state$experiment_id + )) + MissBayesPlotActivePayload(NULL) + MissBayesPlotInputError(NULL) + invisible(cleanExperiment) + } + + runMissBayesMock <- function(forceFailure = FALSE) { + state <- getMissBayesState() + snapshot <- PolySTest:::create_missbayes_snapshot( + experiment_input = isolate(experimentInput()), + comparison_snapshot = isolate(Comps$allComps), + paired = isolate(input$is_paired), + experiment_id = state$experiment_id, + run_id = state$run_id + 1L + ) + runningState <- PolySTest:::missbayes_begin_run(state, snapshot) + setMissBayesState(runningState) + + tryCatch({ + result <- PolySTest:::run_missbayes_mock(snapshot, forceFailure) + acceptedState <- PolySTest:::missbayes_accept_success( + getMissBayesState(), + result + ) + setMissBayesState(acceptedState) + }, error = function(error) { + acceptedState <- PolySTest:::missbayes_accept_error( + getMissBayesState(), + snapshot$run_id, + snapshot$experiment_id, + error + ) + setMissBayesState(acceptedState) + }) + + invisible(getMissBayesState()) + } + + submitPreparedMissBayesRun <- function(preparedRun, taskInvoker = NULL) { + if (is.null(taskInvoker) && is.null(MissBayesTask)) { + runtimeError <- missBayesRuntime$error + if (is.null(runtimeError) || !nzchar(runtimeError)) { + runtimeError <- "The MissBayes background runtime is unavailable." + } + stop(runtimeError) + } + MissBayesInputError(NULL) + MissBayesActivePayload(preparedRun$payload) + setMissBayesState(preparedRun$state) + invocationError <- tryCatch({ + if (is.null(taskInvoker)) { + MissBayesTask$invoke(preparedRun$payload) + } else { + taskInvoker(preparedRun$payload) + } + NULL + }, error = identity) + if (inherits(invocationError, "condition")) { + failedState <- PolySTest:::missbayes_accept_error( + getMissBayesState(), + preparedRun$payload$snapshot$run_id, + preparedRun$payload$snapshot$experiment_id, + PolySTest:::missbayes_safe_error_message(invocationError) + ) + setMissBayesState(failedState) + MissBayesActivePayload(NULL) + stop(invocationError) + } + invisible(getMissBayesState()) + } + + runMissBayes <- function( + comparisonSnapshot = isolate(Comps$allComps), + settings = PolySTest:::missbayes_stage4_settings(), + alpha = PolySTest:::missbayes_stage5_default_alpha(), + paired = isolate(input$is_paired), + taskInvoker = NULL + ) { + preparedRun <- PolySTest:::missbayes_prepare_run( + state = getMissBayesState(), + experiment_input = isolate(experimentInput()), + comparison_snapshot = comparisonSnapshot, + paired = paired, + settings = settings, + alpha = alpha, + requested_seed = PolySTest:::missbayes_stage4_seed() + ) + submitPreparedMissBayesRun(preparedRun, taskInvoker) + } + + observe({ + if (is.null(MissBayesTask)) { + return() + } + taskStatus <- MissBayesTask$status() + if (identical(taskStatus, "success")) { + outcome <- MissBayesTask$result() + isolate({ + acceptedState <- PolySTest:::missbayes_accept_task_outcome( + getMissBayesState(), + outcome + ) + setMissBayesState(acceptedState) + if (!identical(acceptedState$status, "running")) { + MissBayesActivePayload(NULL) + } + }) + } else if (identical(taskStatus, "error")) { + error <- tryCatch(MissBayesTask$result(), error = identity) + isolate({ + state <- getMissBayesState() + acceptedState <- PolySTest:::missbayes_accept_error( + state, + state$run_id, + state$experiment_id, + PolySTest:::missbayes_safe_error_message(error) + ) + setMissBayesState(acceptedState) + if (!identical(acceptedState$status, "running")) { + MissBayesActivePayload(NULL) + } + }) + } + }) + + submitPreparedMissBayesPlotRun <- function(preparedRun, taskInvoker = NULL) { + if (is.null(taskInvoker) && is.null(MissBayesPlotTask)) { + runtimeError <- missBayesRuntime$error + if (is.null(runtimeError) || !nzchar(runtimeError)) { + runtimeError <- "The MissBayes background runtime is unavailable." + } + stop(runtimeError) + } + MissBayesPlotInputError(NULL) + MissBayesPlotActivePayload(preparedRun$payload) + setMissBayesPlotState(preparedRun$state) + invocationError <- tryCatch({ + if (is.null(taskInvoker)) { + MissBayesPlotTask$invoke(preparedRun$payload) + } else { + taskInvoker(preparedRun$payload) + } + NULL + }, error = identity) + if (inherits(invocationError, "condition")) { + outcome <- PolySTest:::.missbayes_plot_error_outcome( + preparedRun$payload, + invocationError + ) + setMissBayesPlotState(PolySTest:::missbayes_accept_plot_outcome( + getMissBayesPlotState(), + outcome + )) + MissBayesPlotActivePayload(NULL) + stop(invocationError) + } + invisible(getMissBayesPlotState()) + } + runMissBayesPlot <- function(featureId, taskInvoker = NULL) { + preparedRun <- PolySTest:::prepare_missbayes_plot_run( + plot_state = getMissBayesPlotState(), + missbayes_state = getMissBayesState(), + experiment_input = isolate(experimentInput()), + selected_feature_id = featureId, + requested_seed = PolySTest:::missbayes_stage6_plot_seed() + ) + submitPreparedMissBayesPlotRun(preparedRun, taskInvoker) + } + observe({ + if (is.null(MissBayesPlotTask)) { + return() + } + taskStatus <- MissBayesPlotTask$status() + if (identical(taskStatus, "success")) { + outcome <- MissBayesPlotTask$result() + isolate({ + acceptedState <- PolySTest:::missbayes_accept_plot_outcome( + getMissBayesPlotState(), + outcome + ) + setMissBayesPlotState(acceptedState) + if (!identical(acceptedState$status, "running")) { + MissBayesPlotActivePayload(NULL) + } + }) + } else if (identical(taskStatus, "error")) { + error <- tryCatch(MissBayesPlotTask$result(), error = identity) + isolate({ + payload <- MissBayesPlotActivePayload() + if (!is.null(payload)) { + outcome <- PolySTest:::.missbayes_plot_error_outcome(payload, error) + acceptedState <- PolySTest:::missbayes_accept_plot_outcome( + getMissBayesPlotState(), + outcome + ) + setMissBayesPlotState(acceptedState) + if (!identical(acceptedState$status, "running")) { + MissBayesPlotActivePayload(NULL) + } + } + }) + } + }) + + session$userData$missbayes_stage3 <- list( + state = getMissBayesState, + experiment_input = function() isolate(experimentInput()), + run_mock = runMissBayesMock + ) + session$userData$missbayes_stage4 <- list( + state = getMissBayesState, + experiment_input = function() isolate(experimentInput()), + run = runMissBayes, + task_status = function() { + if (is.null(MissBayesTask)) "unavailable" else MissBayesTask$status() + }, + runtime = missBayesRuntime + ) + + currentMissBayesState <- reactive(list( + result = MissBayes$result, + status = MissBayes$status, + error = MissBayes$error, + run_id = MissBayes$run_id, + experiment_id = MissBayes$experiment_id, + snapshot = MissBayes$snapshot, + stale = MissBayes$stale + )) + + currentMissBayesPlotState <- reactive(list( + status = MissBayesPlot$status, + error = MissBayesPlot$error, + plot = MissBayesPlot$plot, + feature_id = MissBayesPlot$feature_id, + plot_run_id = MissBayesPlot$plot_run_id, + experiment_id = MissBayesPlot$experiment_id, + source_missbayes_run_id = MissBayesPlot$source_missbayes_run_id, + source_missbayes_experiment_id = + MissBayesPlot$source_missbayes_experiment_id, + comparison = MissBayesPlot$comparison, + rope = MissBayesPlot$rope, + seed = MissBayesPlot$seed, + source_result_stale = MissBayesPlot$source_result_stale, + stale = MissBayesPlot$stale + )) + + missBayesComparisonChoices <- reactive({ + PolySTest:::missbayes_comparison_choices(Comps$allComps) + }) + + output$missbayes_comparison_ui <- renderUI({ + choices <- missBayesComparisonChoices() + selector <- selectInput( + "missbayes_comparison", + "Comparison", + choices = stats::setNames(choices$value, choices$label), + selected = if (nrow(choices) > 0L) choices$value[[1L]] else NULL, + selectize = FALSE + ) + if (nrow(choices) == 0L) shinyjs::disabled(selector) else selector + }) + + output$missbayes_comparison_message <- renderUI({ + if (nrow(missBayesComparisonChoices()) == 0L) { + tags$p( + class = "text-warning", + "No valid comparison is available yet. Configure a comparison in ", + "the PolySTest input panel first." + ) + } + }) + + output$missbayes_paired_message <- renderUI({ + if (isTRUE(input$is_paired)) { + tags$div( + class = "alert alert-warning", + role = "alert", + tags$strong("Paired design blocked. "), + "The current MissBayes integration supports unpaired designs only." + ) + } + }) + + output$missbayes_runtime_message <- renderUI({ + if (!isTRUE(missBayesRuntime$available)) { + tags$div( + class = "alert alert-danger", + role = "alert", + tags$strong("Background runtime unavailable. "), + missBayesRuntime$error + ) + } + }) + + observe({ + canRun <- isTRUE(missBayesRuntime$available) && + !isTRUE(input$is_paired) && + !is.null(experimentInput()) && + nrow(missBayesComparisonChoices()) > 0L + shinyjs::toggleState("run_missbayes", condition = canRun) + }) + + runMissBayesFromControls <- function( + selection, + ropeHalfWidth, + alpha, + paired, + taskInvoker = NULL + ) { + preparedRun <- PolySTest:::prepare_missbayes_stage5_run( + state = getMissBayesState(), + experiment_input = isolate(experimentInput()), + all_comparisons = isolate(Comps$allComps), + selection = selection, + paired = paired, + rope_half_width = ropeHalfWidth, + alpha = alpha, + requested_seed = PolySTest:::missbayes_stage4_seed() + ) + submitPreparedMissBayesRun(preparedRun, taskInvoker) + } + + observeEvent(input$run_missbayes, { + tryCatch( + runMissBayesFromControls( + selection = input$missbayes_comparison, + ropeHalfWidth = input$missbayes_rope_half_width, + alpha = input$missbayes_alpha, + paired = input$is_paired + ), + error = function(error) { + message <- PolySTest:::missbayes_safe_error_message(error) + MissBayesInputError(message) + showNotification(message, type = "error", duration = 8) + } + ) + }, ignoreInit = TRUE) + + missBayesStatusView <- reactive({ + PolySTest:::missbayes_status_view( + currentMissBayesState(), + active_payload = MissBayesActivePayload(), + input_error = MissBayesInputError() + ) + }) + + output$missbayes_stale_banner <- renderUI({ + view <- missBayesStatusView() + if (isTRUE(view$stale)) { + tags$div( + class = "alert alert-warning missbayes-stale-banner", + role = "alert", + tags$strong("Previous/stale MissBayes result. "), + "The displayed table and CSV are from an earlier successful run and ", + "do not represent the current successful state." + ) + } + }) + + output$missbayes_status <- renderUI({ + view <- missBayesStatusView() + statusClass <- switch( + view$status, + idle = "info", + running = "warning", + success = "success", + error = "danger" + ) + details <- list() + if (!is.null(view$parameters)) { + details <- list( + tags$dt("Comparison"), + tags$dd(view$parameters$comparison$name), + tags$dt("ROPE"), + tags$dd(paste0( + "[", format(view$parameters$rope[[1L]], trim = TRUE), ", ", + format(view$parameters$rope[[2L]], trim = TRUE), "]" + )), + tags$dt("Posterior-error cutoff"), + tags$dd(format(view$parameters$alpha, trim = TRUE)) + ) + } + if (identical(view$status, "success") && !is.null(MissBayes$result$runtime)) { + details <- c( + details, + list( + tags$dt("Runtime"), + tags$dd(paste0( + format(round(MissBayes$result$runtime$elapsed_seconds, 2), trim = TRUE), + " seconds" + )) + ) + ) + } + summaryTags <- list() + if (!is.null(view$summary)) { + summary <- view$summary + directionalFdr <- summary$estimated_bayesian_directional_fdr + directionalFdr <- if (length(directionalFdr) == 1L && + is.finite(directionalFdr)) { + format(round(directionalFdr, 4), trim = TRUE) + } else { + "Not calculable (no directional calls)" + } + summaryTags <- list( + tags$h5("Result summary"), + tags$dl( + class = "dl-horizontal", + tags$dt("Estimated"), tags$dd(summary$estimated_count), + tags$dt("Not estimable"), tags$dd(summary$not_estimable_count), + tags$dt("Fit failed"), tags$dd(summary$fit_failed_count), + tags$dt("Poor convergence"), tags$dd(summary$poor_convergence_count), + tags$dt("Moderate convergence"), tags$dd(summary$moderate_convergence_count), + tags$dt("Up"), tags$dd(summary$up_count), + tags$dt("Down"), tags$dd(summary$down_count), + tags$dt("Practically unchanged"), + tags$dd(summary$practically_unchanged_count), + tags$dt("Uncertain"), tags$dd(summary$uncertain_count), + tags$dt("Estimated Bayesian directional FDR"), + tags$dd(directionalFdr) + ) + ) + } + tags$div( + class = paste("alert", paste0("alert-", statusClass)), + role = "status", + tags$strong(view$headline), + tags$p(view$message), + if (length(details) > 0L) tags$dl(class = "dl-horizontal", details), + summaryTags + ) + }) + + output$missbayes_results_table <- DT::renderDataTable({ + req(MissBayes$result) + table <- PolySTest:::missbayes_display_table(MissBayes$result) + probabilityColumns <- grep("Probability|directional local FDR", names(table)) + posteriorErrorColumn <- which(names(table) == "Posterior error probability") + probabilityColumns <- unique(c(probabilityColumns, posteriorErrorColumn)) + numericColumns <- which(vapply(table, is.numeric, logical(1))) + widget <- DT::datatable( + table, + rownames = FALSE, + filter = list(position = "top", clear = FALSE), + selection = list(mode = "single", target = "row"), + options = list( + scrollX = TRUE, + autoWidth = TRUE, + pageLength = 10, + lengthMenu = c(5, 10, 25, 50, 100), + order = list() + ), + class = "compact stripe" + ) + if (length(numericColumns) > 0L) { + widget <- DT::formatSignif(widget, numericColumns, digits = 5) + } + if (length(probabilityColumns) > 0L) { + widget <- DT::formatRound(widget, probabilityColumns, digits = 4) + } + widget + }) + + selectedMissBayesFeatureId <- reactive({ + if (is.null(MissBayes$result)) { + return(NULL) + } + PolySTest:::missbayes_selected_feature_id( + PolySTest:::missbayes_display_table(MissBayes$result), + input$missbayes_results_table_rows_selected + ) + }) + + missBayesPlotEligibility <- reactive({ + PolySTest:::missbayes_plot_eligibility( + currentMissBayesState(), + experimentInput(), + selectedMissBayesFeatureId() + ) + }) + + observe({ + eligibility <- missBayesPlotEligibility() + shinyjs::toggleState( + "generate_missbayes_plot", + condition = isTRUE(missBayesRuntime$available) && + isTRUE(eligibility$eligible) + ) + }) + + observeEvent(input$generate_missbayes_plot, { + tryCatch( + runMissBayesPlot(selectedMissBayesFeatureId()), + error = function(error) { + message <- PolySTest:::missbayes_safe_error_message(error) + MissBayesPlotInputError(message) + showNotification(message, type = "error", duration = 8) + } + ) + }, ignoreInit = TRUE) + + missBayesPlotStatusView <- reactive({ + PolySTest:::missbayes_plot_status_view( + currentMissBayesPlotState(), + selected_feature_id = selectedMissBayesFeatureId(), + missbayes_state = currentMissBayesState() + ) + }) + + output$missbayes_plot_selection_status <- renderUI({ + inputError <- MissBayesPlotInputError() + if (!is.null(inputError)) { + return(tags$p(class = "text-danger", inputError)) + } + eligibility <- missBayesPlotEligibility() + if (!isTRUE(eligibility$eligible)) { + return(tags$p(class = "text-muted", eligibility$reason)) + } + if (isTRUE(eligibility$source_result_stale)) { + return(tags$p( + class = "text-warning", + tags$strong(paste0("Selected feature: ", eligibility$feature_id, ". ")), + "This row belongs to the previous/stale MissBayes result. The refit ", + "will use that result's retained comparison and ROPE." + )) + } + tags$p( + class = "text-success", + tags$strong(paste0("Selected feature: ", eligibility$feature_id, ". ")), + "Ready for an explicit posterior refit." + ) + }) + + output$missbayes_plot_status <- renderUI({ + view <- missBayesPlotStatusView() + statusClass <- switch( + view$status, + idle = "info", + running = "warning", + success = "success", + error = "danger" + ) + details <- list() + if (!is.null(view$requested_feature_id)) { + details <- c(details, list( + tags$dt("Requested feature"), tags$dd(view$requested_feature_id) + )) + } + if (!is.null(view$requested_comparison)) { + details <- c(details, list( + tags$dt("Comparison"), + tags$dd(view$requested_comparison$name) + )) + } + if (!is.null(view$requested_rope)) { + details <- c(details, list( + tags$dt("ROPE"), + tags$dd(paste0( + "[", format(view$requested_rope[[1L]], trim = TRUE), ", ", + format(view$requested_rope[[2L]], trim = TRUE), "]" + )) + )) + } + if (!is.null(view$requested_seed)) { + details <- c(details, list( + tags$dt("Refit seed"), tags$dd(view$requested_seed) + )) + } + staleNotice <- NULL + if (isTRUE(view$plot_stale) && isTRUE(view$has_plot)) { + staleNotice <- tags$p( + class = "text-warning", + tags$strong("Previous/stale posterior plot. "), + paste0( + "The displayed image remains identified as feature ", + view$displayed_feature_id, + " and is not relabelled for the current selection." + ) + ) + } + tags$div( + class = paste("alert", paste0("alert-", statusClass)), + role = "status", + tags$strong(view$headline), + tags$p(view$message), + if (length(details) > 0L) tags$dl(class = "dl-horizontal", details), + staleNotice + ) + }) + + output$missbayes_posterior_plot <- renderImage({ + view <- missBayesPlotStatusView() + req(isTRUE(view$has_plot)) + PolySTest:::missbayes_plot_image_response(view$plot) + }, deleteFile = TRUE) + + output$missbayes_download_ui <- renderUI({ + if (!is.null(MissBayes$result)) { + tagList( + downloadButton( + "downloadMissBayesData", + if (isTRUE(missBayesStatusView()$stale)) { + "Download previous/stale MissBayes CSV" + } else { + "Download MissBayes CSV" + }, + style = "background-color:#FFED66" + ) + ) + } + }) + + output$downloadMissBayesData <- downloadHandler( + filename = function() { + req(MissBayes$result) + PolySTest:::missbayes_csv_filename(MissBayes$result) + }, + content = function(file) { + req(MissBayes$result) + utils::write.csv( + PolySTest:::missbayes_csv_export(MissBayes$result), + file, + row.names = FALSE, + na = "" + ) + } + ) + + session$userData$missbayes_stage5 <- list( + state = getMissBayesState, + status_view = function() isolate(missBayesStatusView()), + display_table = function() isolate({ + if (is.null(MissBayes$result)) NULL else + PolySTest:::missbayes_display_table(MissBayes$result) + }), + csv = function() isolate({ + if (is.null(MissBayes$result)) NULL else + PolySTest:::missbayes_csv_export(MissBayes$result) + }), + run_values = function(selection, rope_half_width, alpha, paired = FALSE, + task_invoker = function(payload) invisible(payload)) { + isolate(runMissBayesFromControls( + selection, + rope_half_width, + alpha, + paired, + taskInvoker = task_invoker + )) + }, + set_test_context = function(experiment, comparisons, + polystest_result = NULL) isolate({ + currse(experiment) + FullReg(polystest_result) + Comps$allComps <- comparisons + Comps$compNames <- PolySTest:::missbayes_comparison_choices(comparisons)$label + Comps$num <- nrow(comparisons) + storeMissBayesExperiment(experiment) + }), + polystest_state = function() isolate(list( + currse = currse(), + FullReg = FullReg() + )) + ) + + session$userData$missbayes_stage6 <- list( + state = getMissBayesPlotState, + status_view = function() isolate(missBayesPlotStatusView()), + selected_feature_id = function() isolate(selectedMissBayesFeatureId()), + eligibility = function() isolate(missBayesPlotEligibility()), + run_feature = function(feature_id, + task_invoker = function(payload) invisible(payload)) { + isolate(runMissBayesPlot(feature_id, taskInvoker = task_invoker)) + }, + accept_outcome = function(outcome) isolate({ + accepted <- PolySTest:::missbayes_accept_plot_outcome( + getMissBayesPlotState(), + outcome + ) + setMissBayesPlotState(accepted) + accepted + }), + polystest_state = function() isolate(list( + currse = currse(), + FullReg = FullReg() + )) + ) # Render text outputs output$messages <- renderText("") @@ -378,6 +1200,7 @@ shinyServer(function(input, output, clientData, session) { NumCond = NumCond ) + storeMissBayesExperiment(fulldata) currse(fulldata) currdata(dat) diff --git a/inst/shiny/ui.R b/inst/shiny/ui.R index f2fb14d..6366fd0 100755 --- a/inst/shiny/ui.R +++ b/inst/shiny/ui.R @@ -137,6 +137,106 @@ shinyUI(dashboardPage(skin="blue", downloadButton('downloadData', 'Download results',style="background-color:#FFAAAA"), bsTooltip("downloadData","Download the entire data table with log-ratios and FDRs",trigger="hover")) ,br(),hr()), + box( + title = "MissBayes Bayesian analysis", + status = "warning", + solidHeader = TRUE, + collapsible = TRUE, + collapsed = FALSE, + width = 12, + tags$p( + "MissBayes is an independent Bayesian workflow. ", + "Each background run analyses exactly one comparison ", + "and does not alter PolySTest results or thresholds." + ), + fluidRow( + column( + width = 4, + tags$h4("Run controls"), + uiOutput("missbayes_comparison_ui"), + uiOutput("missbayes_comparison_message"), + numericInput( + "missbayes_rope_half_width", + "ROPE half-width (log2FC)", + value = 0.2, + min = 0.001, + step = 0.05 + ), + numericInput( + "missbayes_alpha", + "Posterior-error / directional local-FDR cutoff", + value = 0.05, + min = 0.001, + max = 0.499, + step = 0.01 + ), + actionButton( + "run_missbayes", + "Run MissBayes", + icon = icon("play"), + style = "background-color:#FFED66" + ), + br(), br(), + uiOutput("missbayes_paired_message"), + uiOutput("missbayes_runtime_message") + ), + column( + width = 3, + tags$h4("Fixed model settings"), + tags$dl( + class = "dl-horizontal", + tags$dt("threshold"), tags$dd("0"), + tags$dt("n.adapt"), tags$dd("1000"), + tags$dt("burn.in"), tags$dd("500"), + tags$dt("n.iter"), tags$dd("10000"), + tags$dt("n.chains"), tags$dd("2"), + tags$dt("diagnostics"), tags$dd("enabled"), + tags$dt("MissBayes parallel"), tags$dd("FALSE") + ) + ), + column( + width = 5, + tags$h4("Run status"), + uiOutput("missbayes_stale_banner"), + uiOutput("missbayes_status"), + uiOutput("missbayes_download_ui") + ) + ), + tags$hr(), + tags$h4("MissBayes results"), + tags$p( + "Probabilities are shown on a 0–1 scale. Failed and ", + "unestimable features remain in the table." + ), + div( + DT::dataTableOutput("missbayes_results_table"), + style = "font-size:100%" + ), + tags$hr(), + tags$h4("MissBayes posterior plot (separate refit)"), + tags$p( + "The plot is generated by refitting the selected ", + "feature and does not reuse the posterior samples ", + "from the table analysis. It uses the same retained ", + "comparison and ROPE, but MCMC is rerun, so results ", + "may differ slightly. This is not a second PolySTest ", + "analysis." + ), + uiOutput("missbayes_plot_selection_status"), + actionButton( + "generate_missbayes_plot", + "Generate posterior plot (new MCMC refit)", + icon = icon("chart-area"), + style = "background-color:#FFED66" + ), + br(), br(), + uiOutput("missbayes_plot_status"), + imageOutput( + "missbayes_posterior_plot", + width = "100%", + height = "auto" + ) + ), # conditionalPanel("$('#dtable_out').hasClass('recalculating')",tags$div('Loading ... ')), box(status="info",solidHeader=T,width=12, column(div(DT::dataTableOutput("stat_table"),style="font-size:100%"),width=12)), diff --git a/inst/shiny/www/Logo.svg b/inst/shiny/www/Logo.svg index 5851169..a2215c0 100755 --- a/inst/shiny/www/Logo.svg +++ b/inst/shiny/www/Logo.svg @@ -17597,7 +17597,6 @@ x="-495.94177" y="-23.202408" /> 0L) { + stop( + "Background contract dependencies missing: ", + paste(missing_packages, collapse = ", ") + ) +} + +feature_count <- 20L +replicate_count <- 3L +feature_ids <- paste0("background_feature_", seq_len(feature_count)) +sample_names <- c("A_1", "B_1", "A_2", "B_2", "A_3", "B_3") +baseline <- seq(18.1, 21.9, length.out = feature_count) +effects <- rep(c(-0.7, -0.35, 0, 0.35, 0.7), length.out = feature_count) +offsets <- c(-0.18, 0.03, 0.15) +values <- matrix( + NA_real_, + nrow = feature_count + 1L, + ncol = length(sample_names), + dimnames = list(c(feature_ids, "background_all_missing"), sample_names) +) +for (index in seq_len(feature_count)) { + values[index, c(1L, 3L, 5L)] <- baseline[index] + offsets + values[index, c(2L, 4L, 6L)] <- + baseline[index] + effects[index] + rev(offsets) +} +values[cbind(c(1L, 2L, 4L, 7L, 11L, 16L), c(1L, 3L, 5L, 2L, 4L, 6L))] <- NA + +sample_data <- S4Vectors::DataFrame( + Condition = rep(c("A", "B"), replicate_count), + Replicate = rep(seq_len(replicate_count), each = 2L), + row.names = sample_names +) +experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data +) +S4Vectors::metadata(experiment) <- list( + NumCond = 2L, + NumReps = replicate_count +) + +state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() +) +prepared <- PolySTest:::missbayes_prepare_run( + state = state, + experiment_input = experiment, + comparison_snapshot = list(reference = "A", target = "B"), + paired = FALSE +) + +runtime <- PolySTest:::configure_missbayes_runtime(workers = 1L) +runtime_again <- PolySTest:::configure_missbayes_runtime(workers = 2L) +if (!identical(runtime_again$workers, 1L)) { + stop("MissBayes runtime was reconfigured instead of reusing its pool.") +} +host_pid <- Sys.getpid() +resolved <- NULL +rejected <- NULL +contract_server <- function(input, output, session) { + task <- shiny::ExtendedTask$new(function(payload) { + PolySTest:::submit_missbayes_task(payload) + }) + shiny::observe({ + task_status <- task$status() + if (identical(task_status, "success")) { + resolved <<- task$result() + } else if (identical(task_status, "error")) { + rejected <<- tryCatch(task$result(), error = identity) + } + }) + session$userData$missbayes_task <- task +} +shiny::testServer(contract_server, { + session$userData$missbayes_task$invoke(prepared$payload) + deadline <- Sys.time() + 600 + while (is.null(resolved) && is.null(rejected) && Sys.time() < deadline) { + later::run_now(timeoutSecs = 0.1) + session$flushReact() + } +}) +if (!is.null(rejected)) { + stop("Background promise rejected: ", conditionMessage(rejected)) +} +if (is.null(resolved)) { + stop("Background MissBayes contract timed out after 600 seconds.") +} +if (!identical(resolved$status, "success")) { + stop("Background MissBayes worker returned error: ", resolved$error) +} +if (identical(resolved$runtime$worker_pid, host_pid)) { + stop("MissBayes executed in the host R process instead of a mirai daemon.") +} +if (!identical( + resolved$settings, + PolySTest:::missbayes_stage4_settings() +)) { + stop("Background MissBayes did not preserve the fixed Stage 4 settings.") +} +if (!identical(resolved$run_id, prepared$payload$snapshot$run_id) || + !identical( + resolved$experiment_id, + prepared$payload$snapshot$experiment_id + )) { + stop("Background result identities changed in transit.") +} +if (nrow(resolved$table) != nrow(values)) { + stop("Background result table did not preserve all feature rows.") +} +expected_revision <- utils::packageDescription("PolySTest")[[ + "Config/PolySTest/missBayes-commit" +]] +if (!identical( + resolved$metadata$missbayes_source_revision, + expected_revision +)) { + stop("Background result did not record the pinned MissBayes revision.") +} +if (!identical( + resolved$table$fit_status[ + resolved$table$feature_id == "background_all_missing" + ], + "not_estimable" +)) { + stop("Background worker did not reinsert the all-missing feature.") +} + +cat( + paste0( + c( + "background_contract_status=PASS", + paste0("host_pid=", host_pid), + paste0("worker_pid=", resolved$runtime$worker_pid), + paste0("workers=", runtime$workers), + paste0("run_id=", resolved$run_id), + paste0("experiment_id=", resolved$experiment_id), + paste0("comparison=", resolved$comparison$name), + paste0("parallel=", resolved$settings$parallel), + paste0("n.iter=", resolved$settings$n.iter), + paste0("requested_seed=", resolved$metadata$requested_seed), + paste0("r_version=", resolved$metadata$r_version), + paste0( + "missbayes_version=", + resolved$metadata$missbayes_package_version + ), + paste0( + "missbayes_source_revision=", + resolved$metadata$missbayes_source_revision + ), + paste0("jags_version=", resolved$metadata$jags_version), + paste0("elapsed_seconds=", resolved$runtime$elapsed_seconds), + paste0("result_rows=", nrow(resolved$table)) + ), + collapse = "\n" + ), + "\n", + sep = "" +) diff --git a/tests/contract/missbayes-contract.R b/tests/contract/missbayes-contract.R new file mode 100644 index 0000000..1f5af35 --- /dev/null +++ b/tests/contract/missbayes-contract.R @@ -0,0 +1,291 @@ +run_contract <- identical( + tolower(Sys.getenv("POLYSTEST_RUN_MISSBAYES_CONTRACT", "false")), + "true" +) +if (!run_contract) { + message( + "MissBayes/JAGS contract skipped. Set ", + "POLYSTEST_RUN_MISSBAYES_CONTRACT=true to run it." + ) + quit(save = "no", status = 0L) +} + +required <- c( + "PolySTest", "missBayes", "rjags", "coda", "limma", + "SummarizedExperiment", "S4Vectors" +) +missing_packages <- required[!vapply( + required, + requireNamespace, + quietly = TRUE, + FUN.VALUE = logical(1) +)] +if (length(missing_packages) > 0L) { + stop("Contract dependencies missing: ", paste(missing_packages, collapse = ", ")) +} + +requested_commit <- "cd283693a16336d49e49a4132acc05822f92b2d6" +installed_description <- utils::packageDescription("missBayes") +installed_commit <- installed_description$RemoteSha +if (is.null(installed_commit) || !identical(installed_commit, requested_commit)) { + stop( + "Installed missBayes commit is '", installed_commit, + "'; expected '", requested_commit, "'." + ) +} + +feature_count <- 20L +replicate_count <- 3L +feature_ids <- paste0("contract_feature_", seq_len(feature_count)) +sample_names <- c("A_1", "B_1", "A_2", "B_2", "A_3", "B_3") +feature_baseline <- seq(18.1, 21.9, length.out = feature_count) +effects <- rep(c(-0.7, -0.35, 0, 0.35, 0.7), length.out = feature_count) +replicate_offsets <- c(-0.18, 0.03, 0.15) + +values <- matrix( + NA_real_, + nrow = feature_count + 1L, + ncol = length(sample_names), + dimnames = list(c(feature_ids, "contract_all_missing"), sample_names) +) +for (i in seq_len(feature_count)) { + values[i, c(1L, 3L, 5L)] <- feature_baseline[i] + replicate_offsets + values[i, c(2L, 4L, 6L)] <- + feature_baseline[i] + effects[i] + rev(replicate_offsets) +} +values[cbind(c(1L, 2L, 4L, 7L, 11L, 16L), c(1L, 3L, 5L, 2L, 4L, 6L))] <- NA + +sample_data <- data.frame( + Condition = rep(c("A", "B"), replicate_count), + Replicate = rep(seq_len(replicate_count), each = 2L), + row.names = sample_names +) +experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data +) +S4Vectors::metadata(experiment) <- list( + NumCond = 2L, + NumReps = replicate_count +) + +requested_seed <- 20260731L +contract_settings <- PolySTest:::missbayes_default_settings() +contract_settings$n.adapt <- 100L +contract_settings$burn.in <- 100L +contract_settings$n.iter <- 250L + +prepared <- PolySTest:::prepare_missbayes_input( + experiment_input = experiment, + comparison_snapshot = list(reference = "A", target = "B"), + paired = FALSE, + rope_half_width = 0.2, + alpha = 0.05, + seed = requested_seed, + settings = contract_settings +) + +api_outputs <- list() +capturing_analysis <- function(...) { + output <- missBayes::BayesMissingModel(...) + api_outputs[[length(api_outputs) + 1L]] <<- output + output +} + +first <- PolySTest:::run_missbayes_model(prepared, capturing_analysis) +second <- PolySTest:::run_missbayes_model(prepared, capturing_analysis) + +first_api_output <- api_outputs[[1L]] +comparison_name <- prepared$comparison_snapshot$name +if (!(comparison_name %in% names(first_api_output)) || + !is.data.frame(first_api_output[[comparison_name]])) { + stop("Pinned MissBayes did not return the selected comparison as a table.") +} +observed_api_row_names <- rownames(first_api_output[[comparison_name]]) +api_row_names_identical_to_submitted <- identical( + observed_api_row_names, + prepared$estimable_feature_ids +) +if (!api_row_names_identical_to_submitted) { + stop( + "Pinned MissBayes feature row-name behavior diverged. Observed: [", + paste(observed_api_row_names, collapse = ", "), + "]; submitted: [", + paste(prepared$estimable_feature_ids, collapse = ", "), "]." + ) +} +api_row_name_behavior <- "preserved_submitted_feature_ids_in_order" + +expected_raw_fields <- c( + "HDI_Low", "HDI_High", "Median", "pLtCompVal", "pLtROPE", + "pInROPE", "pGtROPE", "ESS", "MCSE", "max_rhat", "Convergence" +) +observed_raw_fields <- names(first$raw) +if (!identical(observed_raw_fields, expected_raw_fields)) { + stop( + "MissBayes raw fields diverged. Observed: ", + paste(observed_raw_fields, collapse = ", ") + ) +} +if (!any(first$results$fit_status == "estimated")) { + stop("The contract fit returned no estimable features.") +} +if (!identical( + first$results$fit_status[first$results$feature_id == "contract_all_missing"], + "not_estimable" +)) { + stop("The all-missing feature was not reinserted as not_estimable.") +} +if (any(!is.na( + first$results$decision[first$results$fit_status != "estimated"] +))) { + stop("Non-estimated contract rows received a decision classification.") +} + +expected_uncertain_count <- sum( + first$results$fit_status == "estimated" & + first$results$decision == "uncertain", + na.rm = TRUE +) +expected_poor_convergence_count <- sum( + first$results$fit_status == "estimated" & + tolower(trimws(first$results$convergence)) == "poor", + na.rm = TRUE +) +expected_moderate_convergence_count <- sum( + first$results$fit_status == "estimated" & + tolower(trimws(first$results$convergence)) == "moderate", + na.rm = TRUE +) +if (!identical(first$summary$uncertain_count, expected_uncertain_count) || + !identical( + first$summary$poor_convergence_count, + expected_poor_convergence_count + ) || + !identical( + first$summary$moderate_convergence_count, + expected_moderate_convergence_count + )) { + stop("Contract decision or convergence summary counts are inconsistent.") +} + +identical_raw_repeat <- identical(first$raw, second$raw) +identical_normalized_repeat <- identical(first$results, second$results) +reproducibility_demonstrated <- + identical_raw_repeat && identical_normalized_repeat + +model_files <- c( + truncated_normal = system.file("extdata", "model.txt", package = "missBayes"), + logistic = system.file("extdata", "model_logit.txt", package = "missBayes") +) +if (any(!nzchar(model_files))) { + stop("Installed MissBayes model files were not found through system.file().") +} +model_hashes <- unname(tools::md5sum(model_files)) + +probability_columns <- c( + "probability_below_rope", "probability_within_rope", + "probability_above_rope" +) +probability_values <- unlist(first$results[probability_columns], use.names = FALSE) +probability_values <- probability_values[is.finite(probability_values)] +raw_rope_values <- unlist( + first$raw[c("pLtROPE", "pInROPE", "pGtROPE")], + use.names = FALSE +) +raw_rope_values <- raw_rope_values[is.finite(raw_rope_values)] + +output_lines <- c( + "contract_status=PASS", + paste0("requested_seed=", requested_seed), + paste0("r_version=", R.version.string), + paste0("polystest_version=", as.character(utils::packageVersion("PolySTest"))), + paste0("missbayes_version=", as.character(utils::packageVersion("missBayes"))), + paste0("missbayes_requested_commit=", requested_commit), + paste0("missbayes_installed_commit=", installed_commit), + paste0("rjags_version=", as.character(utils::packageVersion("rjags"))), + paste0("jags_version=", as.character(rjags::jags.version())), + paste0("coda_version=", as.character(utils::packageVersion("coda"))), + paste0("limma_version=", as.character(utils::packageVersion("limma"))), + paste0("model_truncated_normal_path=", model_files[["truncated_normal"]]), + paste0("model_truncated_normal_md5=", model_hashes[[1L]]), + paste0("model_logistic_path=", model_files[["logistic"]]), + paste0("model_logistic_md5=", model_hashes[[2L]]), + paste0("comparison=", prepared$comparison_snapshot$name), + paste0("rope=", paste(prepared$rope, collapse = ",")), + paste0("alpha=", prepared$alpha), + paste0("threshold=", prepared$settings$threshold), + paste0("parallel=", prepared$settings$parallel), + paste0("n.adapt=", prepared$settings$n.adapt), + paste0("burn.in=", prepared$settings$burn.in), + paste0("n.iter=", prepared$settings$n.iter), + paste0("n.chains=", prepared$settings$n.chains), + paste0("mcmcDiag=", prepared$settings$mcmcDiag), + paste0("submitted_feature_count=", nrow(prepared$values)), + paste0("normalized_feature_count=", nrow(first$results)), + paste0("raw_api_row_name_behavior=", api_row_name_behavior), + paste0( + "raw_api_row_names_identical_to_submitted=", + api_row_names_identical_to_submitted + ), + paste0("raw_api_row_name_count=", length(observed_api_row_names)), + paste0("not_estimable_count=", first$summary$not_estimable_count), + paste0("fit_failed_count=", first$summary$fit_failed_count), + paste0( + "poor_convergence_count=", + first$summary$poor_convergence_count + ), + paste0( + "moderate_convergence_count=", + first$summary$moderate_convergence_count + ), + paste0("raw_output_fields=", paste(observed_raw_fields, collapse = ",")), + paste0("normalized_output_fields=", paste(names(first$results), collapse = ",")), + "raw_rope_probability_scale=percent_0_to_100", + paste0( + "raw_rope_probability_observed_range=", + paste(range(raw_rope_values), collapse = ",") + ), + "normalized_rope_probability_scale=probability_0_to_1", + paste0( + "normalized_rope_probability_observed_range=", + paste(range(probability_values), collapse = ",") + ), + "pLtCompVal_scale=probability_0_to_0.5", + paste0( + "pLtCompVal_observed_range=", + paste(range(first$raw$pLtCompVal, na.rm = TRUE), collapse = ",") + ), + paste0( + "estimated_bayesian_directional_fdr=", + first$summary$estimated_bayesian_directional_fdr + ), + paste0("repeat_raw_identical=", identical_raw_repeat), + paste0("repeat_normalized_identical=", identical_normalized_repeat), + paste0( + "deterministic_reproducibility_demonstrated=", + reproducibility_demonstrated + ), + paste0( + "reproducibility_conclusion=", + if (reproducibility_demonstrated) { + "same requested seed produced identical raw and normalized outputs in this contract" + } else { + "same requested seed did not produce identical outputs; determinism is not claimed" + } + ) +) + +cat(paste(output_lines, collapse = "\n"), "\n", sep = "") +output_path <- Sys.getenv("POLYSTEST_CONTRACT_OUTPUT", "") +if (nzchar(output_path)) { + dir.create(dirname(output_path), recursive = TRUE, showWarnings = FALSE) + writeLines(output_lines, output_path, useBytes = TRUE) +} + +if (!reproducibility_demonstrated) { + message( + "Repeat-run contract passed structurally, but deterministic ", + "reproducibility was not demonstrated." + ) +} diff --git a/tests/contract/missbayes-plot-contract.R b/tests/contract/missbayes-plot-contract.R new file mode 100644 index 0000000..75d6411 --- /dev/null +++ b/tests/contract/missbayes-plot-contract.R @@ -0,0 +1,192 @@ +run_contract <- identical( + tolower(Sys.getenv( + "POLYSTEST_RUN_MISSBAYES_PLOT_CONTRACT", + "false" + )), + "true" +) +if (!run_contract) { + message( + "MissBayes posterior-refit contract skipped. Set ", + "POLYSTEST_RUN_MISSBAYES_PLOT_CONTRACT=true to run it." + ) + quit(save = "no", status = 0L) +} + +required <- c( + "PolySTest", "missBayes", "rjags", "mirai", "promises", "later", + "shiny", "SummarizedExperiment", "S4Vectors" +) +missing_packages <- required[!vapply( + required, + requireNamespace, + quietly = TRUE, + FUN.VALUE = logical(1) +)] +if (length(missing_packages) > 0L) { + stop( + "Posterior-refit contract dependencies missing: ", + paste(missing_packages, collapse = ", ") + ) +} + +feature_count <- 20L +replicate_count <- 3L +feature_ids <- paste0("plot_feature_", seq_len(feature_count)) +sample_names <- c("A_1", "B_1", "A_2", "B_2", "A_3", "B_3") +baseline <- seq(18.1, 21.9, length.out = feature_count) +effects <- rep(c(-0.7, -0.35, 0, 0.35, 0.7), length.out = feature_count) +offsets <- c(-0.18, 0.03, 0.15) +values <- matrix( + NA_real_, + nrow = feature_count + 1L, + ncol = length(sample_names), + dimnames = list(c(feature_ids, "plot_all_missing"), sample_names) +) +for (index in seq_len(feature_count)) { + values[index, c(1L, 3L, 5L)] <- baseline[index] + offsets + values[index, c(2L, 4L, 6L)] <- + baseline[index] + effects[index] + rev(offsets) +} +values[cbind(c(1L, 2L, 4L, 7L, 11L, 16L), c(1L, 3L, 5L, 2L, 4L, 6L))] <- NA + +sample_data <- S4Vectors::DataFrame( + Condition = rep(c("A", "B"), replicate_count), + Replicate = rep(seq_len(replicate_count), each = 2L), + row.names = sample_names +) +experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data +) +S4Vectors::metadata(experiment) <- list( + NumCond = 2L, + NumReps = replicate_count +) + +settings <- PolySTest:::missbayes_stage4_settings() +result <- list( + status = "success", + run_id = 1L, + experiment_id = 1L, + comparison = list(reference = "A", target = "B", name = "B_vs_A"), + table = data.frame( + feature_id = c(feature_ids, "plot_all_missing"), + fit_status = c(rep("estimated", feature_count), "not_estimable"), + stringsAsFactors = FALSE + ), + settings = settings, + alpha = PolySTest:::missbayes_stage5_default_alpha(), + metadata = list( + rope = settings$ROPE, + alpha = PolySTest:::missbayes_stage5_default_alpha(), + requested_seed = PolySTest:::missbayes_stage4_seed() + ) +) +missbayes_state <- list( + result = result, + status = "success", + error = NULL, + run_id = 1L, + experiment_id = 1L, + snapshot = NULL, + stale = FALSE +) +prepared <- PolySTest:::prepare_missbayes_plot_run( + plot_state = PolySTest:::new_missbayes_plot_state(1L), + missbayes_state = missbayes_state, + experiment_input = experiment, + selected_feature_id = "plot_feature_3", + requested_seed = PolySTest:::missbayes_stage6_plot_seed() +) + +runtime <- PolySTest:::configure_missbayes_runtime(workers = 1L) +host_pid <- Sys.getpid() +resolved <- NULL +rejected <- NULL +contract_server <- function(input, output, session) { + task <- shiny::ExtendedTask$new(function(payload) { + PolySTest:::submit_missbayes_plot_task(payload) + }) + shiny::observe({ + task_status <- task$status() + if (identical(task_status, "success")) { + resolved <<- task$result() + } else if (identical(task_status, "error")) { + rejected <<- tryCatch(task$result(), error = identity) + } + }) + session$userData$missbayes_plot_task <- task +} +shiny::testServer(contract_server, { + session$userData$missbayes_plot_task$invoke(prepared$payload) + deadline <- Sys.time() + 600 + while (is.null(resolved) && is.null(rejected) && Sys.time() < deadline) { + later::run_now(timeoutSecs = 0.1) + session$flushReact() + } +}) +if (!is.null(rejected)) { + stop("Posterior-refit promise rejected: ", conditionMessage(rejected)) +} +if (is.null(resolved)) { + stop("Posterior-refit contract timed out after 600 seconds.") +} +if (!identical(resolved$status, "success")) { + stop("Posterior-refit worker returned error: ", resolved$error) +} +if (identical(resolved$runtime$worker_pid, host_pid)) { + stop("Posterior refit executed in the host R process.") +} +if (!is.raw(resolved$plot_png) || length(resolved$plot_png) == 0L) { + stop("Posterior-refit worker did not return non-empty PNG bytes.") +} +png_signature <- as.raw(c(137, 80, 78, 71, 13, 10, 26, 10)) +if (!identical(resolved$plot_png[seq_along(png_signature)], png_signature)) { + stop("Posterior-refit worker payload is not a PNG.") +} +if (!identical(resolved$feature_id, "plot_feature_3") || + !identical(resolved$comparison$name, "B_vs_A") || + !identical(resolved$rope, settings$ROPE)) { + stop("Posterior-refit metadata changed in transit.") +} +if (!isTRUE(resolved$runtime$temporary_file_removed) || + file.exists(resolved$runtime$temporary_file)) { + stop("Posterior-refit worker temporary PNG was not removed.") +} +if (!isTRUE(resolved$metadata$fresh_refit) || + isTRUE(resolved$metadata$reuses_table_posterior_samples)) { + stop("Posterior-refit semantics were not recorded correctly.") +} + +cat( + paste0( + c( + "posterior_plot_contract_status=PASS", + paste0("host_pid=", host_pid), + paste0("worker_pid=", resolved$runtime$worker_pid), + paste0("workers=", runtime$workers), + paste0("plot_run_id=", resolved$plot_run_id), + paste0("experiment_id=", resolved$experiment_id), + paste0("source_missbayes_run_id=", resolved$source_missbayes_run_id), + paste0("feature_id=", resolved$feature_id), + paste0("comparison=", resolved$comparison$name), + paste0("rope=", paste(resolved$rope, collapse = ",")), + paste0("seed=", resolved$seed), + paste0("plot_bytes=", length(resolved$plot_png)), + paste0("temporary_file=", resolved$runtime$temporary_file), + paste0( + "temporary_file_removed=", + resolved$runtime$temporary_file_removed + ), + paste0("elapsed_seconds=", resolved$runtime$elapsed_seconds), + paste0( + "missbayes_source_revision=", + resolved$metadata$missbayes_source_revision + ) + ), + collapse = "\n" + ), + "\n", + sep = "" +) diff --git a/tests/testthat/test-general.R b/tests/testthat/test-general.R index 333020f..4299b5c 100644 --- a/tests/testthat/test-general.R +++ b/tests/testthat/test-general.R @@ -43,18 +43,31 @@ test_that("overall test of full workflow", { allComps <- PolySTest:::create_pairwise_comparisons(conditions, 2) + paired_input <- fulldata + unpaired_input <- fulldata + result_name <- "FDR_PolySTest_HF.Rep._vs_TTA.Rep." + # Run paired tests - fulldata <- PolySTest_paired(fulldata, allComps) + paired_result <- PolySTest_paired(paired_input, allComps) + paired_row_data <- rowData(paired_result) - DRFs <- rowData(fulldata)[,"FDR_PolySTest_HF.Rep._vs_TTA.Rep."] < 0.01 - expect_equal(sum(DRFs), 23) - expect_match(rownames(rowData(fulldata))[4], "A7VJC2") + expect_identical(anyDuplicated(colnames(paired_row_data)), 0L) + expect_identical(sum(colnames(paired_row_data) == result_name), 1L) + paired_DRFs <- paired_row_data[, result_name] < 0.01 + expect_equal(sum(paired_DRFs), 23) + expect_match(rownames(paired_row_data)[4], "A7VJC2") # Run unpaired tests - fulldata <- PolySTest_unpaired(fulldata, allComps) - DRFs <- rowData(fulldata)[,"FDR_PolySTest_HF.Rep._vs_TTA.Rep."] < 0.01 - expect_equal(sum(DRFs), 23) - expect_match(rownames(rowData(fulldata))[4], "A7VJC2") + # The previous chained call masked the true unpaired count behind a + # duplicate result-column name from the preceding paired analysis. + unpaired_result <- PolySTest_unpaired(unpaired_input, allComps) + unpaired_row_data <- rowData(unpaired_result) + + expect_identical(anyDuplicated(colnames(unpaired_row_data)), 0L) + expect_identical(sum(colnames(unpaired_row_data) == result_name), 1L) + unpaired_DRFs <- unpaired_row_data[, result_name] < 0.01 + expect_equal(sum(unpaired_DRFs), 34) + expect_match(rownames(unpaired_row_data)[4], "A7VJC2") }) diff --git a/tests/testthat/test-missbayes-adapter.R b/tests/testthat/test-missbayes-adapter.R new file mode 100644 index 0000000..d095e68 --- /dev/null +++ b/tests/testthat/test-missbayes-adapter.R @@ -0,0 +1,404 @@ +make_missbayes_experiment <- function() { + values <- matrix( + c( + 10, 11, 12, 13, 14, 15, + 20, NaN, 22, 23, 24, 25, + 30, 31, Inf, 33, 34, 35, + 40, 41, 42, 43, 44, 45, + 50, 51, 52, 53, 54, 55, + NA, NaN, Inf, -Inf, NA, NA + ), + nrow = 6, + byrow = TRUE, + dimnames = list( + paste0("feature_", 1:6), + c("A_1", "B_1", "A_2", "B_2", "A_3", "B_3") + ) + ) + sample_data <- data.frame( + Condition = rep(c("A", "B"), 3), + Replicate = rep(1:3, each = 2), + row.names = colnames(values) + ) + experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data + ) + S4Vectors::metadata(experiment) <- list(NumCond = 2L, NumReps = 3L) + experiment +} + +make_missbayes_raw <- function() { + data.frame( + HDI_Low = c(0.4, -1.3, -0.1, -0.8, NA), + HDI_High = c(1.4, -0.3, 0.1, 0.9, NA), + Median = c(0.9, -0.8, 0, 0.1, NA), + pLtCompVal = c(0.01, 0.02, 0.45, 0.4, NA), + pLtROPE = c(2, 96, 2, 30, NA), + pInROPE = c(3, 2, 95, 40, NA), + pGtROPE = c(95, 2, 3, 30, NA), + ESS = c(1200, 1100, 900, 150, NA), + MCSE = c(0.01, 0.02, 0.01, 0.1, NA), + max_rhat = c(1.001, 1.005, 1.02, 1.2, NA), + Convergence = c("Strong", "Strong", "Moderate", "Poor", NA), + row.names = paste0("feature_", 1:5) + ) +} + +test_that("initial MissBayes settings are fixed and validated", { + settings <- PolySTest:::missbayes_default_settings() + expect_identical(settings$threshold, 0) + expect_identical(settings$parallel, FALSE) + expect_identical(settings$n.adapt, 1000L) + expect_identical(settings$burn.in, 500L) + expect_identical(settings$n.iter, 10000L) + expect_identical(settings$n.chains, 2L) + expect_identical(settings$mcmcDiag, TRUE) + + expect_error( + PolySTest:::validate_missbayes_settings(list(parallel = TRUE)), + "parallel processing must be FALSE" + ) + expect_error( + PolySTest:::validate_missbayes_settings(list(n.chains = 3L)), + "fixed at 2" + ) +}) + +test_that("comparison snapshots are pure, single and directional", { + snapshot <- list(reference = "A", target = "B") + original <- snapshot + result <- PolySTest:::validate_missbayes_comparison_snapshot( + snapshot, + c("A", "B", "C") + ) + expect_identical(result, list( + reference = "A", + target = "B", + name = "B_vs_A" + )) + expect_identical(snapshot, original) + expect_error( + PolySTest:::validate_missbayes_comparison_snapshot( + matrix(c("A", "B", "A", "C"), nrow = 2, byrow = TRUE), + c("A", "B", "C") + ), + "exactly one pair" + ) + expect_error( + PolySTest:::validate_missbayes_comparison_snapshot( + list(reference = "A", target = "missing"), + c("A", "B") + ), + "unknown conditions" + ) +}) + +test_that("paired designs are blocked rather than downgraded", { + expect_error( + PolySTest:::prepare_missbayes_input( + make_missbayes_experiment(), + list(reference = "A", target = "B"), + paired = TRUE + ), + "does not support paired or blocked designs" + ) +}) + +test_that("preparation copies, cleans and condition-orders the assay", { + experiment <- make_missbayes_experiment() + experiment_before <- experiment + assay_before <- SummarizedExperiment::assay(experiment, "quant") + + prepared <- PolySTest:::prepare_missbayes_input( + experiment, + list(reference = "A", target = "B"), + paired = FALSE, + rope_half_width = 0.25, + alpha = 0.05, + seed = 42L + ) + + expect_identical( + prepared$sample_names, + c("A_1", "A_2", "A_3", "B_1", "B_2", "B_3") + ) + expect_identical( + prepared$sample_names, + prepared$original_sample_names[prepared$sample_order] + ) + expect_identical(as.character(prepared$groups), rep(c("A", "B"), each = 3)) + expect_true(all(is.na(prepared$values[!is.finite(prepared$values)]))) + expect_false(any(is.infinite(prepared$values), na.rm = TRUE)) + expect_identical(prepared$all_missing_feature_ids, "feature_6") + expect_false("feature_6" %in% rownames(prepared$values)) + expect_identical(prepared$rope, c(-0.25, 0.25)) + expect_identical(prepared$comparison[, 1], c(A = -1, B = 1)) + expect_identical(SummarizedExperiment::assay(experiment, "quant"), assay_before) + expect_identical(experiment, experiment_before) +}) + +test_that("balanced groups and expected sample counts are validated", { + experiment <- make_missbayes_experiment() + unbalanced <- experiment[, -1] + expect_error( + PolySTest:::prepare_missbayes_input( + unbalanced, + list(reference = "A", target = "B"), + paired = FALSE + ), + "expected 6 samples" + ) + + duplicated_replicate <- experiment + SummarizedExperiment::colData(duplicated_replicate)$Replicate[3] <- 1 + expect_error( + PolySTest:::prepare_missbayes_input( + duplicated_replicate, + list(reference = "A", target = "B"), + paired = FALSE + ), + "unique within each condition" + ) +}) + +test_that("normalization uses inclusive calls and reinserts unestimable rows", { + prepared <- PolySTest:::prepare_missbayes_input( + make_missbayes_experiment(), + list(reference = "A", target = "B"), + paired = FALSE, + alpha = 0.05 + ) + normalized <- PolySTest:::normalize_missbayes_output( + list(B_vs_A = make_missbayes_raw()), + prepared + ) + result <- normalized$results + + expect_identical( + result$decision, + c( + "up", "down", "practically_unchanged", "uncertain", + NA_character_, NA_character_ + ) + ) + expect_equal(result$posterior_error_probability[1:3], c(0.05, 0.04, 0.05)) + expect_equal(result$directional_local_fdr[1:2], c(0.05, 0.04)) + expect_true(is.na(result$directional_local_fdr[3])) + expect_true(all(is.na(result$posterior_error_probability[4:6]))) + expect_identical( + result$fit_status, + c(rep("estimated", 4), "fit_failed", "not_estimable") + ) + expect_equal( + normalized$summary$estimated_bayesian_directional_fdr, + mean(c(0.05, 0.04)) + ) + expect_identical(normalized$summary$directional_call_count, 2L) + expect_identical(normalized$summary$up_count, 1L) + expect_identical(normalized$summary$down_count, 1L) + expect_identical(normalized$summary$practically_unchanged_count, 1L) + expect_identical(normalized$summary$uncertain_count, 1L) + expect_identical(normalized$summary$not_estimable_count, 1L) + expect_identical(normalized$summary$fit_failed_count, 1L) + expect_identical(normalized$summary$poor_convergence_count, 1L) + expect_identical(normalized$summary$moderate_convergence_count, 1L) + expect_identical( + sum(unlist(normalized$summary[c( + "up_count", "down_count", "practically_unchanged_count", + "uncertain_count" + )], use.names = FALSE)), + sum(result$fit_status == "estimated") + ) + expect_identical( + sum(unlist(normalized$summary[c( + "not_estimable_count", "fit_failed_count" + )], use.names = FALSE)) + sum(result$fit_status == "estimated"), + nrow(result) + ) + expect_equal( + unname(rowSums(result[1:4, c( + "probability_below_rope", + "probability_within_rope", + "probability_above_rope" + )])), + rep(1, 4) + ) + expect_false(any(c("p_value", "q_value", "FDR") %in% names(result))) +}) + +test_that("raw output is reordered only after feature identities match", { + prepared <- PolySTest:::prepare_missbayes_input( + make_missbayes_experiment(), + list(reference = "A", target = "B"), + paired = FALSE + ) + raw <- make_missbayes_raw() + shuffled <- raw[c(3L, 1L, 5L, 2L, 4L), , drop = FALSE] + + normalized <- PolySTest:::normalize_missbayes_output(shuffled, prepared) + + expect_identical(rownames(normalized$raw), prepared$estimable_feature_ids) + expect_identical(normalized$raw$Median, raw$Median) + expect_identical( + normalized$results$posterior_median_log2_fc[1:4], + raw$Median[1:4] + ) +}) + +test_that("raw output rejects wrong and default sequential identifiers", { + prepared <- PolySTest:::prepare_missbayes_input( + make_missbayes_experiment(), + list(reference = "A", target = "B"), + paired = FALSE + ) + wrong <- make_missbayes_raw() + rownames(wrong)[5L] <- "wrong_feature" + expect_error( + PolySTest:::normalize_missbayes_output(wrong, prepared), + paste0( + "feature-identity mismatch.*Missing submitted identifiers: ", + "\\[feature_5\\].*Unexpected returned identifiers: ", + "\\[wrong_feature\\]" + ) + ) + + sequential <- make_missbayes_raw() + rownames(sequential) <- NULL + expect_error( + PolySTest:::normalize_missbayes_output(sequential, prepared), + paste0( + "feature-identity mismatch.*Default sequential row names: yes.*", + "Positional mapping is not permitted" + ) + ) +}) + +test_that("raw output rejects duplicate, blank and incomplete identifiers", { + prepared <- PolySTest:::prepare_missbayes_input( + make_missbayes_experiment(), + list(reference = "A", target = "B"), + paired = FALSE + ) + + duplicated <- make_missbayes_raw() + attr(duplicated, "row.names") <- c( + "feature_1", "feature_1", "feature_3", "feature_4", "feature_5" + ) + expect_error( + PolySTest:::normalize_missbayes_output(duplicated, prepared), + "feature-identity mismatch.*Duplicate identifiers: \\[feature_1\\]" + ) + + blank <- make_missbayes_raw() + attr(blank, "row.names") <- c( + "feature_1", "", "feature_3", "feature_4", "feature_5" + ) + expect_error( + PolySTest:::normalize_missbayes_output(blank, prepared), + "feature-identity mismatch.*Blank or missing returned identifiers: 1" + ) + + incomplete <- make_missbayes_raw()[-5L, , drop = FALSE] + expect_error( + PolySTest:::normalize_missbayes_output(incomplete, prepared), + paste0( + "feature-identity mismatch: submitted 5 feature identifiers ", + "but received 4 rows.*Missing submitted identifiers: ", + "\\[feature_5\\]" + ) + ) +}) + +test_that("output contracts reject invalid scales and missing fields", { + prepared <- PolySTest:::prepare_missbayes_input( + make_missbayes_experiment(), + list(reference = "A", target = "B"), + paired = FALSE + ) + invalid <- make_missbayes_raw() + invalid$pGtROPE[1] <- 94 + expect_error( + PolySTest:::normalize_missbayes_output(invalid, prepared), + "do not sum to 100 percent" + ) + expect_error( + PolySTest:::normalize_missbayes_output( + make_missbayes_raw()[, -1], + prepared + ), + "missing fields: HDI_Low" + ) +}) + +test_that("runner injects exact fixed arguments and requested R seed", { + prepared <- PolySTest:::prepare_missbayes_input( + make_missbayes_experiment(), + list(reference = "A", target = "B"), + paired = FALSE, + seed = 123L + ) + calls <- list() + fake_analysis <- function(values, groups, comparisons, filter4NAs, + threshold, parallel, ROPE, n.adapt, burn.in, + n.iter, n.chains, mcmcDiag) { + calls[[length(calls) + 1L]] <<- list( + values = values, + groups = groups, + comparisons = comparisons, + filter4NAs = filter4NAs, + threshold = threshold, + parallel = parallel, + ROPE = ROPE, + n.adapt = n.adapt, + burn.in = burn.in, + n.iter = n.iter, + n.chains = n.chains, + mcmcDiag = mcmcDiag, + random_value = stats::runif(1) + ) + list(B_vs_A = make_missbayes_raw()) + } + + first <- PolySTest:::run_missbayes_model(prepared, fake_analysis) + second <- PolySTest:::run_missbayes_model(prepared, fake_analysis) + expect_identical(first$results, second$results) + expect_identical(calls[[1]]$random_value, calls[[2]]$random_value) + expect_identical(calls[[1]]$filter4NAs, FALSE) + expect_identical(calls[[1]]$threshold, 0) + expect_identical(calls[[1]]$parallel, FALSE) + expect_identical(calls[[1]]$mcmcDiag, TRUE) + expect_identical(calls[[1]]$ROPE, c(-0.2, 0.2)) + expect_identical(calls[[1]]$n.adapt, 1000L) + expect_identical(calls[[1]]$burn.in, 500L) + expect_identical(calls[[1]]$n.iter, 10000L) + expect_identical(calls[[1]]$n.chains, 2L) +}) + +test_that("adapter operations cannot mutate PolySTest state sentinels", { + experiment_input <- make_missbayes_experiment() + currse <- experiment_input + FullReg <- data.frame(existing_polystest_result = 1:3) + Comps <- list( + allComps = matrix(c("A", "B"), nrow = 1), + compNames = "B_vs_A" + ) + before <- list( + experiment_input = experiment_input, + currse = currse, + FullReg = FullReg, + Comps = Comps + ) + + prepared <- PolySTest:::prepare_missbayes_input( + experiment_input, + list(reference = "A", target = "B"), + paired = FALSE + ) + PolySTest:::normalize_missbayes_output(make_missbayes_raw(), prepared) + + expect_identical(experiment_input, before$experiment_input) + expect_identical(currse, before$currse) + expect_identical(FullReg, before$FullReg) + expect_identical(Comps, before$Comps) +}) diff --git a/tests/testthat/test-missbayes-plot.R b/tests/testthat/test-missbayes-plot.R new file mode 100644 index 0000000..e0fb172 --- /dev/null +++ b/tests/testthat/test-missbayes-plot.R @@ -0,0 +1,463 @@ +make_stage6_experiment <- function() { + values <- matrix( + c( + 10, 20, 11, 21, 12, 22, + 5, 8, 6, 9, 7, 10, + 2, 3, 2.5, 3.5, 3, 4, + 9, 9, 9, 9, 9, 9, + 4, NA, 5, NA, 6, NA, + NA, NA, NA, NA, NA, NA + ), + nrow = 6L, + byrow = TRUE, + dimnames = list( + paste0("feature_", seq_len(6L)), + c("A_1", "B_1", "A_2", "B_2", "A_3", "B_3") + ) + ) + sample_data <- S4Vectors::DataFrame( + Condition = rep(c("A", "B"), 3L), + Replicate = rep(seq_len(3L), each = 2L), + row.names = colnames(values) + ) + experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data + ) + S4Vectors::metadata(experiment) <- list(NumCond = 2L, NumReps = 3L) + experiment +} + +make_stage6_result <- function(run_id = 7L, experiment_id = 1L, + rope_half_width = 0.35) { + settings <- PolySTest:::missbayes_stage4_settings() + settings$ROPE <- c(-rope_half_width, rope_half_width) + list( + status = "success", + run_id = run_id, + experiment_id = experiment_id, + comparison = list(reference = "A", target = "B", name = "B_vs_A"), + table = data.frame( + feature_id = paste0("feature_", seq_len(6L)), + fit_status = c( + "estimated", "estimated", "estimated", "estimated", + "fit_failed", "not_estimable" + ), + decision = c("up", "down", "uncertain", "uncertain", NA, NA), + stringsAsFactors = FALSE + ), + settings = settings, + alpha = 0.05, + metadata = list( + rope = settings$ROPE, + alpha = 0.05, + requested_seed = 20260731L + ) + ) +} + +make_stage6_missbayes_state <- function(status = "success", stale = FALSE, + result = make_stage6_result(), + experiment_id = 1L) { + list( + result = result, + status = status, + error = if (identical(status, "error")) "table rerun failed" else NULL, + run_id = if (is.null(result)) 0L else as.integer(result$run_id), + experiment_id = experiment_id, + snapshot = NULL, + stale = stale + ) +} + +make_stage6_prepared_plot <- function( + plot_state = PolySTest:::new_missbayes_plot_state(1L), + missbayes_state = make_stage6_missbayes_state(), + experiment = make_stage6_experiment(), + feature_id = "feature_2", + seed = 314159L +) { + PolySTest:::prepare_missbayes_plot_run( + plot_state = plot_state, + missbayes_state = missbayes_state, + experiment_input = experiment, + selected_feature_id = feature_id, + requested_seed = seed + ) +} + +make_stage6_fake_plotter <- function(observed = NULL, fail = FALSE) { + force(observed) + force(fail) + function(values, id, groups, contrast, threshold = 0, + cenTend = "median", compVal = 0, ROPE = c(-0.2, 0.2), + n.adapt = 500L, burn.in = 500L, n.iter = 5000L, + n.chains = 2L, credMass = 0.95, HDItextPlace = 0.7, + xlab = NULL, xlim = NULL, yaxt = NULL, ylab = NULL, + main = NULL, cex = NULL, cex.lab = NULL, col = NULL, + border = NULL, showCurve = FALSE, breaks = NULL, ...) { + if (!is.null(observed)) { + observed$values <- values + observed$id <- id + observed$groups <- groups + observed$contrast <- contrast + observed$threshold <- threshold + observed$compVal <- compVal + observed$ROPE <- ROPE + observed$n.adapt <- n.adapt + observed$burn.in <- burn.in + observed$n.iter <- n.iter + observed$n.chains <- n.chains + observed$random_value <- stats::runif(1L) + } + if (isTRUE(fail)) { + stop("forced posterior refit failure") + } + graphics::plot.new() + graphics::plot.window(xlim = c(-1, 1), ylim = c(0, 1)) + graphics::lines(c(-0.5, 0, 0.5), c(0.1, 0.8, 0.1)) + graphics::title(main = main, xlab = xlab) + invisible(NULL) + } +} + +make_stage6_success_outcome <- function(payload, marker = as.raw(1:8)) { + list( + status = "success", + plot_run_id = payload$plot_run_id, + experiment_id = payload$snapshot$experiment_id, + source_missbayes_run_id = payload$source_missbayes_run_id, + source_missbayes_experiment_id = + payload$source_missbayes_experiment_id, + source_result_stale = payload$source_result_stale, + feature_id = payload$feature_id, + comparison = payload$snapshot$comparison, + rope = payload$settings$ROPE, + seed = payload$requested_seed, + plot_png = marker + ) +} + +test_that("plot selection is eligible only for one estimated stable feature", { + experiment <- make_stage6_experiment() + state <- make_stage6_missbayes_state() + + estimated <- PolySTest:::missbayes_plot_eligibility( + state, + experiment, + "feature_3" + ) + expect_true(estimated$eligible) + expect_identical(estimated$feature_id, "feature_3") + + fit_failed <- PolySTest:::missbayes_plot_eligibility( + state, + experiment, + "feature_5" + ) + expect_false(fit_failed$eligible) + expect_match(fit_failed$reason, "fit_status == 'estimated'", fixed = TRUE) + + not_estimable <- PolySTest:::missbayes_plot_eligibility( + state, + experiment, + "feature_6" + ) + expect_false(not_estimable$eligible) + expect_match(not_estimable$reason, "fit_status == 'estimated'", fixed = TRUE) + + no_selection <- PolySTest:::missbayes_plot_eligibility( + state, + experiment, + NULL + ) + expect_false(no_selection$eligible) + expect_match(no_selection$reason, "exactly one") +}) + +test_that("DT sorting and filtering resolve immediately to the stable feature ID", { + displayed_after_sort_and_filter <- data.frame( + "Feature ID" = c("feature_4", "feature_1", "feature_3"), + "Fit status" = rep("estimated", 3L), + check.names = FALSE + ) + feature_id <- PolySTest:::missbayes_selected_feature_id( + displayed_after_sort_and_filter, + 1L + ) + expect_identical(feature_id, "feature_4") + expect_true(PolySTest:::missbayes_plot_eligibility( + make_stage6_missbayes_state(), + make_stage6_experiment(), + feature_id + )$eligible) + expect_null(PolySTest:::missbayes_selected_feature_id( + displayed_after_sort_and_filter, + c(1L, 2L) + )) +}) + +test_that("stale table results retain their own comparison ROPE and alpha", { + result <- make_stage6_result( + run_id = 11L, + experiment_id = 1L, + rope_half_width = 0.4 + ) + state <- make_stage6_missbayes_state( + status = "error", + stale = TRUE, + result = result, + experiment_id = 2L + ) + prepared <- make_stage6_prepared_plot( + plot_state = PolySTest:::new_missbayes_plot_state(2L), + missbayes_state = state, + feature_id = "feature_1" + ) + + current_ui_rope <- 0.9 + expect_identical(current_ui_rope, 0.9) + expect_identical(prepared$payload$settings$ROPE, c(-0.4, 0.4)) + expect_identical(prepared$payload$snapshot$comparison$name, "B_vs_A") + expect_identical(prepared$payload$alpha, 0.05) + expect_true(prepared$payload$source_result_stale) + expect_identical(prepared$payload$source_missbayes_run_id, 11L) + expect_identical(prepared$payload$source_missbayes_experiment_id, 1L) + expect_identical(prepared$payload$snapshot$experiment_id, 2L) +}) + +test_that("plot payload contains only copied clean data and an explicit seed", { + experiment <- make_stage6_experiment() + original <- experiment + prepared <- make_stage6_prepared_plot( + experiment = experiment, + feature_id = "feature_2", + seed = 4242L + ) + payload <- prepared$payload + + expect_s3_class(payload, "polystest_missbayes_plot_payload") + expect_true(PolySTest:::.missbayes_plain_object(payload)) + expect_identical(payload$feature_id, "feature_2") + expect_identical(payload$requested_seed, 4242L) + expect_identical(payload$snapshot$quantitative_data[1L, 1L], 10) + expect_identical(payload$snapshot$comparison, list( + reference = "A", target = "B", name = "B_vs_A" + )) + expect_identical(experiment, original) + expect_silent(unserialize(serialize(payload, NULL, version = 3L))) +}) + +test_that("worker refit uses condition blocks, target-reference and retained settings", { + experiment <- make_stage6_experiment() + original <- experiment + table_result <- make_stage6_result() + table_before <- table_result + prepared <- make_stage6_prepared_plot( + missbayes_state = make_stage6_missbayes_state(result = table_result), + experiment = experiment, + feature_id = "feature_2", + seed = 9876L + ) + observed <- new.env(parent = emptyenv()) + + first <- PolySTest:::run_missbayes_plot_task( + prepared$payload, + plot_function = make_stage6_fake_plotter(observed) + ) + first_random <- observed$random_value + second <- PolySTest:::run_missbayes_plot_task( + prepared$payload, + plot_function = make_stage6_fake_plotter(observed) + ) + + expect_identical(observed$id, "feature_2") + expect_identical(colnames(observed$values), c( + "A_1", "A_2", "A_3", "B_1", "B_2", "B_3" + )) + expect_identical(as.character(observed$groups), rep(c("A", "B"), each = 3L)) + expect_identical(observed$contrast, "B - A") + expect_identical(observed$threshold, 0) + expect_identical(observed$ROPE, c(-0.35, 0.35)) + expect_identical(observed$n.adapt, 1000L) + expect_identical(observed$burn.in, 500L) + expect_identical(observed$n.iter, 10000L) + expect_identical(observed$n.chains, 2L) + expect_identical(first_random, observed$random_value) + expect_true(first$metadata$fresh_refit) + expect_false(first$metadata$reuses_table_posterior_samples) + expect_false(first$metadata$missbayes_internal_parallel) + expect_identical(first$feature_id, "feature_2") + expect_identical(first$comparison$name, "B_vs_A") + expect_identical(first$rope, c(-0.35, 0.35)) + expect_identical(first$seed, 9876L) + expect_gt(length(first$plot_png), 100L) + expect_identical(first$plot_png, second$plot_png) + expect_true(first$runtime$temporary_file_removed) + expect_false(file.exists(first$runtime$temporary_file)) + expect_identical(experiment, original) + expect_identical(table_result, table_before) +}) + +test_that("graphics payload is a PNG and can be materialized for Shiny", { + prepared <- make_stage6_prepared_plot() + outcome <- PolySTest:::run_missbayes_plot_task( + prepared$payload, + plot_function = make_stage6_fake_plotter() + ) + png_signature <- as.raw(c(137, 80, 78, 71, 13, 10, 26, 10)) + expect_identical(outcome$plot_png[seq_along(png_signature)], png_signature) + + image_file <- tempfile(fileext = ".png") + on.exit(unlink(image_file), add = TRUE) + response <- PolySTest:::missbayes_plot_image_response(outcome, image_file) + expect_true(file.exists(response$src)) + expect_gt(file.info(response$src)$size, 100L) + expect_identical(response$contentType, "image/png") + expect_match(response$alt, "feature_2") + expect_match(response$alt, "B_vs_A") +}) + +test_that("plotPost API validation requires the pinned refit controls", { + expect_silent(PolySTest:::validate_missbayes_plotpost_api( + make_stage6_fake_plotter() + )) + expect_error( + PolySTest:::validate_missbayes_plotpost_api(function(values, id) NULL), + "missing arguments" + ) +}) + +test_that("success stores plot feature run and experiment identity", { + prepared <- make_stage6_prepared_plot() + outcome <- make_stage6_success_outcome(prepared$payload) + success <- PolySTest:::missbayes_accept_plot_outcome( + prepared$state, + outcome + ) + + expect_identical(success$status, "success") + expect_identical(success$feature_id, "feature_2") + expect_identical(success$plot_run_id, 1L) + expect_identical(success$experiment_id, 1L) + expect_identical(success$source_missbayes_run_id, 7L) + expect_identical(success$plot$feature_id, "feature_2") + expect_false(success$stale) +}) + +test_that("first failure has no plot and a failed rerun keeps identity honest", { + first <- make_stage6_prepared_plot(feature_id = "feature_1") + first_failure <- PolySTest:::.missbayes_plot_error_outcome( + first$payload, + "first plot failed" + ) + failed <- PolySTest:::missbayes_accept_plot_outcome( + first$state, + first_failure + ) + expect_identical(failed$status, "error") + expect_null(failed$plot) + expect_match(failed$error, "first plot failed") + + successful <- PolySTest:::missbayes_accept_plot_outcome( + first$state, + make_stage6_success_outcome(first$payload) + ) + rerun <- make_stage6_prepared_plot( + plot_state = successful, + feature_id = "feature_2" + ) + rerun_failure <- PolySTest:::.missbayes_plot_error_outcome( + rerun$payload, + "rerun failed" + ) + failed_rerun <- PolySTest:::missbayes_accept_plot_outcome( + rerun$state, + rerun_failure + ) + view <- PolySTest:::missbayes_plot_status_view( + failed_rerun, + selected_feature_id = "feature_2" + ) + expect_identical(failed_rerun$status, "error") + expect_identical(failed_rerun$feature_id, "feature_2") + expect_identical(failed_rerun$plot$feature_id, "feature_1") + expect_identical(view$displayed_feature_id, "feature_1") + expect_true(view$plot_stale) +}) + +test_that("superseded and old-experiment plot completions are ignored", { + old <- make_stage6_prepared_plot(feature_id = "feature_1") + current <- make_stage6_prepared_plot( + plot_state = old$state, + feature_id = "feature_2" + ) + ignored <- PolySTest:::missbayes_accept_plot_outcome( + current$state, + make_stage6_success_outcome(old$payload) + ) + expect_identical(ignored, current$state) + expect_identical(ignored$status, "running") + expect_null(ignored$plot) + + table_state <- PolySTest:::missbayes_register_experiment( + make_stage6_missbayes_state() + ) + plot_state <- PolySTest:::missbayes_plot_register_experiment( + current$state, + table_state$experiment_id + ) + new_experiment <- make_stage6_prepared_plot( + plot_state = plot_state, + missbayes_state = table_state, + feature_id = "feature_1" + ) + ignored_old_experiment <- PolySTest:::missbayes_accept_plot_outcome( + new_experiment$state, + make_stage6_success_outcome(old$payload) + ) + expect_identical(ignored_old_experiment, new_experiment$state) + expect_identical(ignored_old_experiment$experiment_id, 2L) + expect_null(ignored_old_experiment$plot) +}) + +test_that("row selection changes never relabel an existing plot", { + prepared <- make_stage6_prepared_plot(feature_id = "feature_1") + success <- PolySTest:::missbayes_accept_plot_outcome( + prepared$state, + make_stage6_success_outcome(prepared$payload) + ) + same <- PolySTest:::missbayes_plot_status_view( + success, + selected_feature_id = "feature_1" + ) + changed <- PolySTest:::missbayes_plot_status_view( + success, + selected_feature_id = "feature_3" + ) + + expect_false(same$plot_stale) + expect_true(changed$selection_changed) + expect_true(changed$plot_stale) + expect_identical(changed$displayed_feature_id, "feature_1") + expect_identical(changed$plot$feature_id, "feature_1") +}) + +test_that("new experiments invalidate old plots without touching PolySTest data", { + experiment <- make_stage6_experiment() + currse <- experiment + FullReg <- data.frame(existing_polystest_result = 1:3) + before <- list(currse = currse, FullReg = FullReg) + prepared <- make_stage6_prepared_plot(experiment = experiment) + success <- PolySTest:::missbayes_accept_plot_outcome( + prepared$state, + make_stage6_success_outcome(prepared$payload) + ) + invalidated <- PolySTest:::missbayes_plot_register_experiment(success, 2L) + + expect_identical(invalidated$status, "idle") + expect_identical(invalidated$experiment_id, 2L) + expect_null(invalidated$plot) + expect_identical(currse, before$currse) + expect_identical(FullReg, before$FullReg) +}) diff --git a/tests/testthat/test-missbayes-state.R b/tests/testthat/test-missbayes-state.R new file mode 100644 index 0000000..33c46c9 --- /dev/null +++ b/tests/testthat/test-missbayes-state.R @@ -0,0 +1,346 @@ +make_stage3_experiment <- function() { + values <- matrix( + c( + 1, 2, 3, 5, 6, 7, + 2, 3, 4, 4, 5, 6, + NA, 1, 2, NA, 3, 4 + ), + nrow = 3, + byrow = TRUE, + dimnames = list( + paste0("feature_", 1:3), + c("C1_1", "C2_1", "C1_2", "C2_2", "C1_3", "C2_3") + ) + ) + sample_data <- data.frame( + Condition = rep(c("C1", "C2"), 3), + Replicate = rep(1:3, each = 2), + row.names = colnames(values) + ) + experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data + ) + S4Vectors::metadata(experiment) <- list(NumCond = 2L, NumReps = 3L) + experiment +} + +make_stage3_snapshot <- function(state, run_id = state$run_id + 1L) { + PolySTest:::create_missbayes_snapshot( + experiment_input = make_stage3_experiment(), + comparison_snapshot = matrix(c("C1", "C2"), nrow = 1L), + paired = FALSE, + experiment_id = state$experiment_id, + run_id = run_id + ) +} + +test_that("clean experiment storage is independent from result-bearing state", { + source_experiment <- make_stage3_experiment() + clean_experiment <- + PolySTest:::clone_missbayes_experiment_input(source_experiment) + currse <- source_experiment + + SummarizedExperiment::assay(currse, "quant")[1L, 1L] <- 999 + SummarizedExperiment::rowData(currse)$FDR_PolySTest_C2_vs_C1 <- 0.01 + + expect_identical( + SummarizedExperiment::assay(clean_experiment, "quant")[1L, 1L], + 1 + ) + expect_false( + "FDR_PolySTest_C2_vs_C1" %in% + names(SummarizedExperiment::rowData(clean_experiment)) + ) + + snapshot <- PolySTest:::create_missbayes_snapshot( + clean_experiment, + matrix(c("C1", "C2"), nrow = 1L), + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ) + expect_identical(snapshot$quantitative_data[1L, 1L], 1) + expect_false(any(grepl("^FDR", names(snapshot$sample_metadata)))) +}) + +test_that("valid unpaired snapshot is complete, copied and directional", { + experiment <- make_stage3_experiment() + snapshot <- PolySTest:::create_missbayes_snapshot( + experiment, + matrix( + c("C1", "C2"), + nrow = 1L, + dimnames = list(NULL, c("reference", "target")) + ), + paired = FALSE, + experiment_id = 4L, + run_id = 9L + ) + + expect_s3_class(snapshot, "polystest_missbayes_snapshot") + expect_identical(snapshot$feature_ids, paste0("feature_", 1:3)) + expect_identical(snapshot$sample_names, colnames(snapshot$quantitative_data)) + expect_identical(snapshot$condition_labels, rep(c("C1", "C2"), 3)) + expect_identical(snapshot$replicate_labels, rep(as.character(1:3), each = 2)) + expect_identical(snapshot$comparison, list( + reference = "C1", + target = "C2", + name = "C2_vs_C1" + )) + expect_identical(snapshot$paired, FALSE) + expect_identical(snapshot$experiment_id, 4L) + expect_identical(snapshot$run_id, 9L) + + SummarizedExperiment::assay(experiment, "quant")[1L, 1L] <- 999 + expect_identical(snapshot$quantitative_data[1L, 1L], 1) +}) + +test_that("snapshot rejects paired, missing and invalid comparisons", { + experiment <- make_stage3_experiment() + valid_comparison <- matrix(c("C1", "C2"), nrow = 1L) + + expect_error( + PolySTest:::create_missbayes_snapshot( + experiment, + valid_comparison, + paired = TRUE, + experiment_id = 1L, + run_id = 1L + ), + "does not support paired designs" + ) + expect_error( + PolySTest:::create_missbayes_snapshot( + NULL, + valid_comparison, + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "clean experiment is required" + ) + expect_error( + PolySTest:::create_missbayes_snapshot( + experiment, + NULL, + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "must supply reference and target" + ) + expect_error( + PolySTest:::create_missbayes_snapshot( + experiment, + matrix(c("C1", "missing"), nrow = 1L), + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "unknown conditions" + ) + expect_error( + PolySTest:::create_missbayes_snapshot( + experiment, + matrix(c("C1", "C1"), nrow = 1L), + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "must differ" + ) + expect_error( + PolySTest:::create_missbayes_snapshot( + experiment, + matrix(c("C1", "C2", "C2", "C1"), nrow = 2L, byrow = TRUE), + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "exactly one pair" + ) +}) + +test_that("snapshot rejects invalid feature identities and metadata dimensions", { + duplicated <- make_stage3_experiment() + rownames(duplicated) <- c("feature_1", "feature_1", "feature_3") + expect_error( + PolySTest:::create_missbayes_snapshot( + duplicated, + matrix(c("C1", "C2"), nrow = 1L), + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "feature identifiers must be unique" + ) + + experiment <- make_stage3_experiment() + values <- SummarizedExperiment::assay(experiment, "quant") + sample_data <- as.data.frame(SummarizedExperiment::colData(experiment)) + expect_error( + PolySTest:::.create_missbayes_snapshot_from_parts( + quantitative_data = values, + sample_metadata = sample_data[-1L, , drop = FALSE], + experiment_metadata = S4Vectors::metadata(experiment), + comparison_snapshot = matrix(c("C1", "C2"), nrow = 1L), + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "metadata rows must match" + ) + + misaligned <- sample_data + rownames(misaligned) <- rev(rownames(misaligned)) + expect_error( + PolySTest:::.create_missbayes_snapshot_from_parts( + quantitative_data = values, + sample_metadata = misaligned, + experiment_metadata = S4Vectors::metadata(experiment), + comparison_snapshot = matrix(c("C1", "C2"), nrow = 1L), + paired = FALSE, + experiment_id = 1L, + run_id = 1L + ), + "row names must match" + ) +}) + +test_that("MissBayes state moves from idle through running to success", { + state <- PolySTest:::new_missbayes_state() + expect_identical(state$status, "idle") + expect_null(state$result) + expect_false(state$stale) + + state <- PolySTest:::missbayes_register_experiment(state) + snapshot <- make_stage3_snapshot(state) + running <- PolySTest:::missbayes_begin_run(state, snapshot) + expect_identical(running$status, "running") + expect_identical(running$run_id, 1L) + expect_identical(running$experiment_id, 1L) + expect_null(running$error) + + result <- PolySTest:::run_missbayes_mock(snapshot) + success <- PolySTest:::missbayes_accept_success(running, result) + expect_identical(success$status, "success") + expect_identical(success$result$run_id, success$run_id) + expect_identical(success$result$experiment_id, success$experiment_id) + expect_identical(success$result$comparison$name, "C2_vs_C1") + expect_equal(success$result$table$mock_effect, c(4 / 3, 2 / 3, 0)) + expect_null(success$error) + expect_false(success$stale) +}) + +test_that("mock failure without a previous result leaves result NULL", { + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + snapshot <- make_stage3_snapshot(state) + running <- PolySTest:::missbayes_begin_run(state, snapshot) + error <- tryCatch( + PolySTest:::run_missbayes_mock(snapshot, force_failure = TRUE), + error = identity + ) + failed <- PolySTest:::missbayes_accept_error( + running, + snapshot$run_id, + snapshot$experiment_id, + error + ) + + expect_identical(failed$status, "error") + expect_match(failed$error, "Forced MissBayes mock failure") + expect_null(failed$result) + expect_false(failed$stale) +}) + +test_that("failed rerun retains success and later success clears staleness", { + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + first_snapshot <- make_stage3_snapshot(state) + state <- PolySTest:::missbayes_begin_run(state, first_snapshot) + state <- PolySTest:::missbayes_accept_success( + state, + PolySTest:::run_missbayes_mock(first_snapshot) + ) + first_result <- state$result + + failed_snapshot <- make_stage3_snapshot(state) + state <- PolySTest:::missbayes_begin_run(state, failed_snapshot) + state <- PolySTest:::missbayes_accept_error( + state, + failed_snapshot$run_id, + failed_snapshot$experiment_id, + "forced rerun failure" + ) + expect_identical(state$result, first_result) + expect_true(state$stale) + expect_identical(state$status, "error") + + recovery_snapshot <- make_stage3_snapshot(state) + state <- PolySTest:::missbayes_begin_run(state, recovery_snapshot) + state <- PolySTest:::missbayes_accept_success( + state, + PolySTest:::run_missbayes_mock(recovery_snapshot) + ) + expect_identical(state$result$run_id, 3L) + expect_false(state$stale) + expect_identical(state$status, "success") +}) + +test_that("superseded run results are ignored", { + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + old_snapshot <- make_stage3_snapshot(state) + state <- PolySTest:::missbayes_begin_run(state, old_snapshot) + old_result <- PolySTest:::run_missbayes_mock(old_snapshot) + + current_snapshot <- make_stage3_snapshot(state) + current_state <- PolySTest:::missbayes_begin_run(state, current_snapshot) + ignored <- PolySTest:::missbayes_accept_success(current_state, old_result) + + expect_identical(ignored, current_state) + expect_identical(ignored$status, "running") + expect_null(ignored$result) +}) + +test_that("results from an old experiment are ignored", { + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + old_snapshot <- make_stage3_snapshot(state) + old_result <- PolySTest:::run_missbayes_mock(old_snapshot) + + state <- PolySTest:::missbayes_register_experiment(state) + current_snapshot <- make_stage3_snapshot(state) + current_state <- PolySTest:::missbayes_begin_run(state, current_snapshot) + ignored <- PolySTest:::missbayes_accept_success(current_state, old_result) + + expect_identical(ignored, current_state) + expect_identical(ignored$experiment_id, 2L) + expect_null(ignored$result) +}) + +test_that("loading a new experiment retains old result only as stale", { + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + snapshot <- make_stage3_snapshot(state) + state <- PolySTest:::missbayes_begin_run(state, snapshot) + state <- PolySTest:::missbayes_accept_success( + state, + PolySTest:::run_missbayes_mock(snapshot) + ) + result <- state$result + + state <- PolySTest:::missbayes_register_experiment(state) + expect_identical(state$experiment_id, 2L) + expect_identical(state$status, "idle") + expect_identical(state$result, result) + expect_true(state$stale) + expect_null(state$snapshot) +}) diff --git a/tests/testthat/test-missbayes-task.R b/tests/testthat/test-missbayes-task.R new file mode 100644 index 0000000..5ddb8dc --- /dev/null +++ b/tests/testthat/test-missbayes-task.R @@ -0,0 +1,456 @@ +make_stage4_experiment <- function() { + values <- matrix( + c( + 10, 11, 12, 20, 21, 22, + 5, 6, 7, 8, 9, 10, + NA, NA, NA, NA, NA, NA + ), + nrow = 3L, + byrow = TRUE, + dimnames = list( + c("feature_1", "feature_2", "all_missing"), + c("C1_1", "C1_2", "C1_3", "C2_1", "C2_2", "C2_3") + ) + ) + sample_data <- S4Vectors::DataFrame( + Condition = rep(c("C1", "C2"), each = 3L), + Replicate = rep(seq_len(3L), times = 2L), + row.names = colnames(values) + ) + experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data + ) + S4Vectors::metadata(experiment) <- list(NumCond = 2L, NumReps = 3L) + experiment +} + +make_stage4_state <- function() { + PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) +} + +make_stage4_prepared_run <- function(state = make_stage4_state()) { + PolySTest:::missbayes_prepare_run( + state = state, + experiment_input = make_stage4_experiment(), + comparison_snapshot = list(reference = "C1", target = "C2"), + paired = FALSE + ) +} + +make_stage4_success <- function(snapshot, marker = "current") { + list( + status = "success", + run_id = snapshot$run_id, + experiment_id = snapshot$experiment_id, + comparison = snapshot$comparison, + table = data.frame( + feature_id = snapshot$feature_ids, + marker = marker, + stringsAsFactors = FALSE + ) + ) +} + +make_stage4_error <- function(snapshot, message = "worker failed") { + list( + status = "error", + run_id = snapshot$run_id, + experiment_id = snapshot$experiment_id, + comparison = snapshot$comparison, + error = message + ) +} + +mock_stage4_adapter_result <- function() { + list( + raw = data.frame( + HDI_Low = c(-1, -0.5), + row.names = c("feature_1", "feature_2") + ), + results = data.frame( + feature_id = c("feature_1", "feature_2", "all_missing"), + fit_status = c("estimated", "estimated", "not_estimable"), + stringsAsFactors = FALSE + ), + summary = list( + directional_call_count = 1L, + not_estimable_count = 1L + ) + ) +} + +test_that("Stage 4 fixed settings and seed are explicit", { + expect_identical( + PolySTest:::missbayes_stage4_settings(), + list( + filter4NAs = FALSE, + threshold = 0, + ROPE = c(-0.2, 0.2), + n.adapt = 1000L, + burn.in = 500L, + n.iter = 10000L, + n.chains = 2L, + mcmcDiag = TRUE, + parallel = FALSE + ) + ) + expect_identical(PolySTest:::missbayes_stage4_seed(), 20260731L) + expect_identical(PolySTest:::missbayes_stage5_default_alpha(), 0.05) + expect_error( + PolySTest:::validate_missbayes_task_settings( + utils::modifyList( + PolySTest:::missbayes_stage4_settings(), + list(parallel = TRUE) + ) + ), + "parallel is fixed" + ) + expect_identical( + PolySTest:::validate_missbayes_task_settings( + utils::modifyList( + PolySTest:::missbayes_stage4_settings(), + list(ROPE = c(-0.35, 0.35)) + ) + )$ROPE, + c(-0.35, 0.35) + ) +}) + +test_that("worker payload contains only immutable ordinary R objects", { + prepared <- make_stage4_prepared_run() + payload <- prepared$payload + + expect_identical( + names(payload), + c("snapshot", "settings", "requested_seed", "alpha") + ) + expect_true(PolySTest:::.missbayes_plain_object(payload)) + expect_false(isS4(payload$snapshot)) + expect_false(any(vapply(payload, is.function, logical(1)))) + expect_false(any(vapply(payload, is.environment, logical(1)))) + expect_silent(unserialize(serialize(payload, NULL, version = 3L))) +}) + +test_that("worker calls the adapter with exact settings and parallel FALSE", { + prepared <- make_stage4_prepared_run() + observed <- new.env(parent = emptyenv()) + + testthat::local_mocked_bindings( + prepare_missbayes_input = function( + experiment_input, + comparison_snapshot, + paired, + rope_half_width, + alpha, + seed, + settings + ) { + observed$experiment_input <- experiment_input + observed$comparison <- comparison_snapshot + observed$paired <- paired + observed$rope_half_width <- rope_half_width + observed$alpha <- alpha + observed$seed <- seed + observed$settings <- settings + structure( + list(settings = settings), + class = c("polystest_missbayes_input", "list") + ) + }, + run_missbayes_model = function(prepared) { + observed$model_parallel <- prepared$settings$parallel + mock_stage4_adapter_result() + }, + .package = "PolySTest" + ) + + envelope <- PolySTest:::run_missbayes_task( + snapshot = prepared$payload$snapshot, + settings = prepared$payload$settings, + requested_seed = prepared$payload$requested_seed + ) + + expect_false(observed$paired) + expect_identical(observed$rope_half_width, 0.2) + expect_identical(observed$alpha, 0.05) + expect_identical(observed$seed, 20260731L) + expect_identical( + observed$settings, + PolySTest:::missbayes_default_settings() + ) + expect_false(observed$model_parallel) + expect_identical(envelope$settings, prepared$payload$settings) + expect_identical(envelope$alpha, 0.05) +}) + +test_that("non-default ROPE and alpha reach the worker adapter", { + settings <- PolySTest:::missbayes_stage4_settings() + settings$ROPE <- c(-0.35, 0.35) + prepared <- PolySTest:::missbayes_prepare_run( + state = make_stage4_state(), + experiment_input = make_stage4_experiment(), + comparison_snapshot = list(reference = "C1", target = "C2"), + paired = FALSE, + settings = settings, + alpha = 0.1 + ) + observed <- new.env(parent = emptyenv()) + + testthat::local_mocked_bindings( + prepare_missbayes_input = function(..., rope_half_width, alpha) { + observed$rope_half_width <- rope_half_width + observed$alpha <- alpha + structure( + list(settings = PolySTest:::missbayes_default_settings()), + class = c("polystest_missbayes_input", "list") + ) + }, + run_missbayes_model = function(prepared) mock_stage4_adapter_result(), + .package = "PolySTest" + ) + + envelope <- PolySTest:::run_missbayes_task( + snapshot = prepared$payload$snapshot, + settings = prepared$payload$settings, + alpha = prepared$payload$alpha, + requested_seed = prepared$payload$requested_seed + ) + + expect_identical(observed$rope_half_width, 0.35) + expect_identical(observed$alpha, 0.1) + expect_identical(envelope$metadata$rope, c(-0.35, 0.35)) + expect_identical(envelope$metadata$rope_half_width, 0.35) + expect_identical(envelope$metadata$alpha, 0.1) +}) + +test_that("task validation rejects invalid alpha and ROPE", { + for (alpha in c(0, -0.01, 0.5, 0.75, Inf, NA_real_)) { + expect_error( + PolySTest:::validate_missbayes_task_alpha(alpha), + "greater than 0 and less than 0.5" + ) + } + expect_identical(PolySTest:::validate_missbayes_task_alpha(0.1), 0.1) + + invalid_rope <- list( + c(-0.2, 0.3), c(0, 0.2), c(-0.2, 0), c(0.2, -0.2), + c(-Inf, Inf), c(-0.2), c("-0.2", "0.2") + ) + for (rope in invalid_rope) { + settings <- PolySTest:::missbayes_stage4_settings() + settings$ROPE <- rope + expect_error( + PolySTest:::validate_missbayes_task_settings(settings), + "symmetric around zero" + ) + } +}) + +test_that("worker envelope carries identities, diagnostics and runtime metadata", { + prepared <- make_stage4_prepared_run() + testthat::local_mocked_bindings( + prepare_missbayes_input = function(...) { + structure( + list(settings = PolySTest:::missbayes_default_settings()), + class = c("polystest_missbayes_input", "list") + ) + }, + run_missbayes_model = function(prepared) mock_stage4_adapter_result(), + .package = "PolySTest" + ) + + envelope <- PolySTest:::run_missbayes_task( + snapshot = prepared$payload$snapshot, + settings = prepared$payload$settings, + alpha = prepared$payload$alpha, + requested_seed = prepared$payload$requested_seed + ) + + expect_identical(envelope$status, "success") + expect_identical(envelope$run_id, prepared$payload$snapshot$run_id) + expect_identical( + envelope$experiment_id, + prepared$payload$snapshot$experiment_id + ) + expect_identical(envelope$comparison$name, "C2_vs_C1") + expect_s3_class(envelope$table, "data.frame") + expect_identical(envelope$adapter_summary$not_estimable_count, 1L) + expect_identical(envelope$adapter_diagnostics$result_row_count, 3L) + expect_identical(envelope$metadata$requested_seed, 20260731L) + expect_identical(envelope$metadata$rope, c(-0.2, 0.2)) + expect_identical(envelope$metadata$alpha, 0.05) + expect_identical(envelope$metadata$mcmc_settings$parallel, FALSE) + expect_match(envelope$metadata$r_version, "R version") + expect_true(is.numeric(envelope$runtime$elapsed_seconds)) + expect_identical(envelope$runtime$worker_pid, Sys.getpid()) + expect_match(envelope$metadata$reproducibility_scope, "not claimed") +}) + +test_that("successful task completion uses Stage 3 acceptance", { + prepared <- make_stage4_prepared_run() + accepted <- PolySTest:::missbayes_accept_task_outcome( + prepared$state, + make_stage4_success(prepared$payload$snapshot) + ) + + expect_identical(accepted$status, "success") + expect_identical(accepted$result$table$marker, rep("current", 3L)) + expect_null(accepted$error) + expect_false(accepted$stale) +}) + +test_that("failed rerun preserves a successful result and marks it stale", { + first <- make_stage4_prepared_run() + state <- PolySTest:::missbayes_accept_task_outcome( + first$state, + make_stage4_success(first$payload$snapshot, "previous") + ) + previous <- state$result + rerun <- make_stage4_prepared_run(state) + failed <- PolySTest:::missbayes_accept_task_outcome( + rerun$state, + make_stage4_error(rerun$payload$snapshot, "clean failure") + ) + + expect_identical(failed$status, "error") + expect_identical(failed$error, "clean failure") + expect_identical(failed$result, previous) + expect_true(failed$stale) +}) + +test_that("first-run task failure leaves result NULL", { + prepared <- make_stage4_prepared_run() + failed <- PolySTest:::missbayes_accept_task_outcome( + prepared$state, + make_stage4_error(prepared$payload$snapshot) + ) + + expect_identical(failed$status, "error") + expect_null(failed$result) + expect_false(failed$stale) +}) + +test_that("older run completion is ignored", { + old <- make_stage4_prepared_run() + current <- make_stage4_prepared_run(old$state) + ignored <- PolySTest:::missbayes_accept_task_outcome( + current$state, + make_stage4_success(old$payload$snapshot, "old") + ) + + expect_identical(ignored, current$state) + expect_identical(ignored$status, "running") + expect_null(ignored$result) +}) + +test_that("completion from an old experiment is ignored", { + old <- make_stage4_prepared_run() + new_experiment_state <- PolySTest:::missbayes_register_experiment(old$state) + current <- make_stage4_prepared_run(new_experiment_state) + ignored <- PolySTest:::missbayes_accept_task_outcome( + current$state, + make_stage4_success(old$payload$snapshot, "old experiment") + ) + + expect_identical(ignored, current$state) + expect_identical(ignored$experiment_id, 2L) + expect_identical(ignored$status, "running") +}) + +test_that("paired invocation is rejected before task submission", { + submitted <- FALSE + submit <- function(payload) submitted <<- TRUE + + expect_error({ + prepared <- PolySTest:::missbayes_prepare_run( + state = make_stage4_state(), + experiment_input = make_stage4_experiment(), + comparison_snapshot = list(reference = "C1", target = "C2"), + paired = TRUE + ) + submit(prepared$payload) + }, "does not support paired") + expect_false(submitted) +}) + +test_that("malformed comparison snapshot is rejected before submission", { + submitted <- FALSE + submit <- function(payload) submitted <<- TRUE + + expect_error({ + prepared <- PolySTest:::missbayes_prepare_run( + state = make_stage4_state(), + experiment_input = make_stage4_experiment(), + comparison_snapshot = rbind( + c("C1", "C2"), + c("C2", "C1") + ), + paired = FALSE + ) + submit(prepared$payload) + }, "exactly one pair") + expect_false(submitted) +}) + +test_that("worker errors become clean server error state", { + prepared <- make_stage4_prepared_run() + testthat::local_mocked_bindings( + prepare_missbayes_input = function(...) { + structure( + list(settings = PolySTest:::missbayes_default_settings()), + class = c("polystest_missbayes_input", "list") + ) + }, + run_missbayes_model = function(prepared) { + stop("worker\nmodel failed") + }, + .package = "PolySTest" + ) + + outcome <- PolySTest:::run_missbayes_task_outcome( + snapshot = prepared$payload$snapshot, + settings = prepared$payload$settings, + alpha = prepared$payload$alpha, + requested_seed = prepared$payload$requested_seed + ) + failed <- PolySTest:::missbayes_accept_task_outcome( + prepared$state, + outcome + ) + + expect_identical(outcome$status, "error") + expect_identical(outcome$run_id, prepared$state$run_id) + expect_identical(outcome$experiment_id, prepared$state$experiment_id) + expect_identical(failed$status, "error") + expect_identical(failed$error, "worker model failed") + expect_null(failed$result) +}) + +test_that("worker count override validates and falls back safely", { + expect_identical(PolySTest:::missbayes_worker_count(""), 1L) + expect_identical(PolySTest:::missbayes_worker_count("0"), 1L) + expect_identical(PolySTest:::missbayes_worker_count("-2"), 1L) + expect_identical(PolySTest:::missbayes_worker_count("two"), 1L) + expect_identical(PolySTest:::missbayes_worker_count("2.5"), 1L) + expect_identical(PolySTest:::missbayes_worker_count(" 3 "), 3L) +}) + +test_that("task settings reject mutation and malformed plain snapshots", { + prepared <- make_stage4_prepared_run() + malformed <- prepared$payload$snapshot + malformed$condition_labels[[1L]] <- "wrong" + expect_error( + PolySTest:::create_missbayes_task_payload(malformed), + "inconsistent fields" + ) + + non_plain <- prepared$payload$snapshot + non_plain$experiment_metadata$reactive_state <- new.env() + expect_error( + PolySTest:::create_missbayes_task_payload(non_plain), + "ordinary R objects only" + ) +}) diff --git a/tests/testthat/test-missbayes-ui.R b/tests/testthat/test-missbayes-ui.R new file mode 100644 index 0000000..9bf9eef --- /dev/null +++ b/tests/testthat/test-missbayes-ui.R @@ -0,0 +1,347 @@ +make_stage5_experiment <- function() { + values <- matrix( + seq_len(36), + nrow = 6L, + dimnames = list( + paste0("feature_", seq_len(6L)), + c("A_1", "A_2", "A_3", "B_1", "B_2", "B_3") + ) + ) + values[6L, ] <- NA_real_ + sample_data <- S4Vectors::DataFrame( + Condition = rep(c("A", "B"), each = 3L), + Replicate = rep(seq_len(3L), times = 2L), + row.names = colnames(values) + ) + experiment <- SummarizedExperiment::SummarizedExperiment( + assays = list(quant = values), + colData = sample_data + ) + S4Vectors::metadata(experiment) <- list(NumCond = 2L, NumReps = 3L) + experiment +} + +make_stage5_raw <- function() { + data.frame( + HDI_Low = c(0.2, -1.5, -0.1, -0.5, NA), + HDI_High = c(1.5, -0.2, 0.1, 0.5, NA), + Median = c(0.8, -0.9, 0, 0.1, NA), + pLtCompVal = c(0.05, 0.04, 0.49, 0.45, NA), + pLtROPE = c(2, 95, 3, 4, NA), + pInROPE = c(3, 3, 95, 4, NA), + pGtROPE = c(95, 2, 2, 92, NA), + ESS = c(1000, 900, 800, 700, NA), + MCSE = c(0.01, 0.02, 0.01, 0.03, NA), + max_rhat = c(1.01, 1.02, 1, 1.05, NA), + Convergence = c("Good", "Moderate", "Good", "Poor", NA), + row.names = paste0("feature_", seq_len(5L)), + stringsAsFactors = FALSE + ) +} + +make_stage5_adapter_result <- function(rope_half_width = 0.3, alpha = 0.05) { + prepared <- PolySTest:::prepare_missbayes_input( + make_stage5_experiment(), + list(reference = "A", target = "B"), + paired = FALSE, + rope_half_width = rope_half_width, + alpha = alpha, + seed = 20260731L + ) + PolySTest:::normalize_missbayes_output(make_stage5_raw(), prepared) +} + +make_stage5_envelope <- function(run_id = 1L, experiment_id = 1L, + rope_half_width = 0.3, alpha = 0.05) { + adapter <- make_stage5_adapter_result(rope_half_width, alpha) + settings <- PolySTest:::missbayes_stage4_settings() + settings$ROPE <- c(-rope_half_width, rope_half_width) + list( + status = "success", + run_id = run_id, + experiment_id = experiment_id, + comparison = list(reference = "A", target = "B", name = "B_vs_A"), + table = adapter$results, + adapter_summary = adapter$summary, + settings = settings, + alpha = alpha, + metadata = list( + requested_seed = 20260731L, + rope = settings$ROPE, + rope_half_width = rope_half_width, + alpha = alpha, + missbayes_package_version = "0.0.0-test", + r_version = R.version.string, + jags_version = "4.3.2" + ), + runtime = list(elapsed_seconds = 12.5) + ) +} + +make_stage5_running <- function(rope_half_width = 0.3, alpha = 0.1) { + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + PolySTest:::prepare_missbayes_stage5_run( + state = state, + experiment_input = make_stage5_experiment(), + all_comparisons = matrix(c("A", "B"), nrow = 1L), + selection = "comparison_1", + paired = FALSE, + rope_half_width = rope_half_width, + alpha = alpha + ) +} + +test_that("comparison selector preserves target_vs_reference orientation", { + comparisons <- rbind(c("A", "B"), c("A", "C")) + choices <- PolySTest:::missbayes_comparison_choices(comparisons) + + expect_identical(choices$value, c("comparison_1", "comparison_2")) + expect_identical(choices$label, c("B_vs_A", "C_vs_A")) + expect_identical( + PolySTest:::missbayes_resolve_comparison( + comparisons, + "comparison_2" + ), + list(reference = "A", target = "C", name = "C_vs_A") + ) + expect_error( + PolySTest:::missbayes_resolve_comparison(comparisons, "comparison_3"), + "no longer available" + ) + expect_equal( + nrow(PolySTest:::missbayes_comparison_choices(NULL)), + 0L + ) +}) + +test_that("Stage 5 control validation blocks invalid and paired runs", { + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + arguments <- list( + state = state, + experiment_input = make_stage5_experiment(), + all_comparisons = matrix(c("A", "B"), nrow = 1L), + selection = "comparison_1", + paired = FALSE, + rope_half_width = 0.2, + alpha = 0.05 + ) + + expect_error( + do.call( + PolySTest:::prepare_missbayes_stage5_run, + utils::modifyList(arguments, list(paired = TRUE)) + ), + "does not support paired" + ) + for (rope in c(0, -0.2, Inf, NA_real_)) { + expect_error( + do.call( + PolySTest:::prepare_missbayes_stage5_run, + utils::modifyList(arguments, list(rope_half_width = rope)) + ), + "positive finite" + ) + } + for (alpha in c(0, -0.01, 0.5, 0.75, Inf, NA_real_)) { + expect_error( + do.call( + PolySTest:::prepare_missbayes_stage5_run, + utils::modifyList(arguments, list(alpha = alpha)) + ), + "greater than 0 and less than 0.5" + ) + } +}) + +test_that("valid Stage 5 controls reach the Stage 4 immutable invocation path", { + experiment <- make_stage5_experiment() + currse <- experiment + FullReg <- data.frame(existing_polystest_result = seq_len(3L)) + before <- list(currse = currse, FullReg = FullReg) + state <- PolySTest:::missbayes_register_experiment( + PolySTest:::new_missbayes_state() + ) + + prepared <- PolySTest:::prepare_missbayes_stage5_run( + state = state, + experiment_input = experiment, + all_comparisons = matrix(c("A", "B"), nrow = 1L), + selection = "comparison_1", + paired = FALSE, + rope_half_width = 0.3, + alpha = 0.1 + ) + + expect_s3_class(prepared$payload, "polystest_missbayes_task_payload") + expect_identical(prepared$payload$snapshot$comparison$name, "B_vs_A") + expect_identical(prepared$payload$settings$ROPE, c(-0.3, 0.3)) + expect_identical(prepared$payload$alpha, 0.1) + expect_identical(prepared$state$status, "running") + expect_identical(currse, before$currse) + expect_identical(FullReg, before$FullReg) +}) + +test_that("status views cover idle running success and first-run error", { + idle <- PolySTest:::missbayes_status_view( + PolySTest:::new_missbayes_state() + ) + expect_identical(idle$status, "idle") + expect_match(idle$headline, "not yet been run") + expect_false(idle$has_result) + + running <- make_stage5_running() + running_view <- PolySTest:::missbayes_status_view( + running$state, + running$payload + ) + expect_identical(running_view$status, "running") + expect_match(running_view$message, "background") + expect_false(grepl("%", running_view$message, fixed = TRUE)) + expect_identical(running_view$parameters$comparison$name, "B_vs_A") + expect_identical(running_view$parameters$rope, c(-0.3, 0.3)) + expect_identical(running_view$parameters$alpha, 0.1) + + success_state <- PolySTest:::missbayes_accept_success( + running$state, + make_stage5_envelope( + run_id = running$state$run_id, + experiment_id = running$state$experiment_id, + rope_half_width = 0.3, + alpha = 0.1 + ) + ) + success <- PolySTest:::missbayes_status_view(success_state) + expect_identical(success$status, "success") + expect_false(success$stale) + expect_identical(success$summary$estimated_count, 4L) + expect_identical(success$summary$fit_failed_count, 1L) + expect_identical(success$summary$not_estimable_count, 1L) + + first <- make_stage5_running() + failed_state <- PolySTest:::missbayes_accept_error( + first$state, + first$state$run_id, + first$state$experiment_id, + "first run failed" + ) + failed <- PolySTest:::missbayes_status_view(failed_state) + expect_identical(failed$status, "error") + expect_match(failed$message, "first run failed") + expect_false(failed$has_result) + expect_false(failed$stale) +}) + +test_that("failed reruns and new experiments expose retained results as stale", { + first <- make_stage5_running(rope_half_width = 0.3, alpha = 0.1) + success <- PolySTest:::missbayes_accept_success( + first$state, + make_stage5_envelope( + run_id = first$state$run_id, + experiment_id = first$state$experiment_id, + rope_half_width = 0.3, + alpha = 0.1 + ) + ) + rerun <- PolySTest:::prepare_missbayes_stage5_run( + state = success, + experiment_input = make_stage5_experiment(), + all_comparisons = matrix(c("A", "B"), nrow = 1L), + selection = "comparison_1", + paired = FALSE, + rope_half_width = 0.4, + alpha = 0.2 + ) + running_view <- PolySTest:::missbayes_status_view(rerun$state, rerun$payload) + expect_true(running_view$stale) + expect_identical(running_view$parameters$rope, c(-0.4, 0.4)) + + failed_state <- PolySTest:::missbayes_accept_error( + rerun$state, + rerun$state$run_id, + rerun$state$experiment_id, + "rerun failed" + ) + failed <- PolySTest:::missbayes_status_view(failed_state) + expect_true(failed$stale) + expect_true(failed$has_result) + expect_identical(failed$parameters$rope, c(-0.3, 0.3)) + expect_identical(failed$parameters$alpha, 0.1) + + new_experiment <- PolySTest:::missbayes_register_experiment(success) + stale <- PolySTest:::missbayes_status_view(new_experiment) + expect_identical(stale$status, "idle") + expect_true(stale$stale) + expect_match(stale$headline, "current experiment") + expect_identical(stale$parameters$rope, c(-0.3, 0.3)) +}) + +test_that("inclusive classification and directional errors retain adapter semantics", { + result <- make_stage5_adapter_result(alpha = 0.05)$results + + expect_identical( + result$decision, + c( + "up", "down", "practically_unchanged", "uncertain", + NA_character_, NA_character_ + ) + ) + expect_equal(result$posterior_error_probability[1:3], c(0.05, 0.05, 0.05)) + expect_equal(result$directional_local_fdr[1:2], c(0.05, 0.05)) + expect_true(all(is.na(result$directional_local_fdr[3:6]))) + expect_true(all(is.na(result$decision[5:6]))) + expect_identical( + result$fit_status, + c(rep("estimated", 4L), "fit_failed", "not_estimable") + ) +}) + +test_that("results table retains all features, order and normalized probabilities", { + envelope <- make_stage5_envelope() + table <- PolySTest:::missbayes_display_table(envelope) + + expect_equal(nrow(table), 6L) + expect_identical(table[["Feature ID"]], paste0("feature_", seq_len(6L))) + expect_identical( + table[["Fit status"]][5:6], + c("fit_failed", "not_estimable") + ) + probability_columns <- grep("^Probability", names(table), value = TRUE) + expect_true(all(vapply( + table[probability_columns], + function(x) all(is.na(x) | (x >= 0 & x <= 1)), + logical(1) + ))) + expect_true("Bayesian directional local FDR" %in% names(table)) + expect_false(any(c("p_value", "q_value", "FDR") %in% names(table))) +}) + +test_that("CSV exports all rows with per-result metadata and fixed settings", { + envelope <- make_stage5_envelope(rope_half_width = 0.3, alpha = 0.1) + csv <- PolySTest:::missbayes_csv_export(envelope) + + expect_equal(nrow(csv), 6L) + expect_identical(csv$feature_id, paste0("feature_", seq_len(6L))) + expect_true(all(csv$comparison_identity == "B_vs_A")) + expect_true(all(csv$rope_lower == -0.3)) + expect_true(all(csv$rope_upper == 0.3)) + expect_true(all(csv$posterior_error_cutoff_alpha == 0.1)) + expect_true(all(csv$run_id == 1L)) + expect_true(all(csv$experiment_id == 1L)) + expect_true(all(csv$seed == 20260731L)) + expect_true(all(csv$threshold == 0)) + expect_true(all(csv$n_adapt == 1000L)) + expect_true(all(csv$worker_missbayes_parallel == FALSE)) + expect_true("bayesian_directional_local_fdr" %in% names(csv)) + expect_false(any(c("p_value", "q_value", "FDR") %in% names(csv))) + expect_match( + PolySTest:::missbayes_csv_filename( + envelope, + as.POSIXct("2026-08-03 12:34:56", tz = "UTC") + ), + "^MissBayes_B_vs_A_20260803-123456\\.csv$" + ) +})