From 95c66d41e256b6b21156fa461f2275c2ab18b769 Mon Sep 17 00:00:00 2001 From: David Priest Date: Tue, 4 Aug 2026 12:46:00 +0900 Subject: [PATCH] feat: accept a read-only uncompensated SCE for before/after comparison launchGatingApp(sce, uncompensated = other) serves a second SCE as the Original layer so compensation can be checked side by side. It suits workflows that compensate in place to save memory (compCytof2 overwrite = TRUE) and keep the uncompensated values in a separate object: GateLabR previously saw one linear layer and labelled the compensated data "Original", with no way to compare. The accessory is never placed in sce_state. That matters because sce_state is both what is advertised to React and what is assigned to the user's global on every write, including autosave, so anything grafted into it would silently appear in the user's object. .gatelabr_register_assay_resource() already accepts an arbitrary SCE and captures it in the resource closure, so the accessory is served over its own lazy binary endpoint while the primary stays untouched. The guarantee is structural rather than a strip-before-assign convention, and a testServer regression pins it. GateLab loads the first linear counts-role assay as its Original layer and holds exactly two layers, so the accessory descriptor leads the list and the primary's own linear counts yields the counts role to it -- honest here, since supplying an uncompensated accessory asserts the primary is the compensated one. The primary's assay stays advertised and linear, so it remains adoptable as the Compensated layer through the existing path. Validation runs before anything is assigned and refuses rather than coerces: event indices come from the primary's colData and slice the accessory's payload, so a mismatch in cell count, cell order or channels would render a wrong before/after comparison rather than fail. Identical objects warn, since that comparison would show no difference at all. A spillover matrix in metadata() is now looked for on either object, primary first: a workflow that compensates in place often keeps the matrix beside the uncompensated copy. Co-Authored-By: Claude Opus 5 --- NEWS.md | 6 + R/host_bridge.R | 214 ++++++++++++++++-- R/launch.R | 12 +- R/launch_react.R | 34 ++- tests/testthat/test-host-bridge.R | 63 ++++++ tests/testthat/test-uncompensated-accessory.R | 132 +++++++++++ 6 files changed, 439 insertions(+), 22 deletions(-) create mode 100644 tests/testthat/test-uncompensated-accessory.R diff --git a/NEWS.md b/NEWS.md index 5e98a7f..8d93dc1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,12 @@ - `launchGatingApp()` now starts the shared GateLab TypeScript/React interface, and is the single supported entry point. +- `launchGatingApp()` gains `uncompensated =`, an optional read-only SCE holding + the pre-compensation values for the same cells. It is served as the Original + layer so compensation can be checked side by side, and is never modified or + written back; only the primary SCE is saved to. Cell count, cell order and + channels must match exactly or the launch is refused. +- A spillover matrix stored in `metadata()` is now found on either object. - **Breaking:** `launchLegacyGateLabR()` is defunct and the previous GateLabR-specific Shiny interface is no longer reachable; use `launchGatingApp()`. Calling it now signals an error explaining the change. diff --git a/R/host_bridge.R b/R/host_bridge.R index 8348c63..8b87c93 100644 --- a/R/host_bridge.R +++ b/R/host_bridge.R @@ -5,6 +5,9 @@ # payloads that become Float32Array views in GateLab. .gatelabr_dataset_contract_version <- 1L +# Assay id for a read-only uncompensated accessory SCE. Namespaced so it can +# never collide with a real assay name in the primary object. +.gatelabr_accessory_assay_id <- "gatelabr_uncompensated" .gatelabr_workspace_contract_version <- 1L .gatelabr_coldata_contract_version <- 1L .gatelabr_rowdata_contract_version <- 1L @@ -218,7 +221,7 @@ # Describe any pre-compensation GateLabR inferred, so the assumption is stated # rather than silent. NULL when nothing was inferred. -.gatelabr_precompensation_note <- function(sce) { +.gatelabr_precompensation_note <- function(sce, accessory = NULL) { names <- tryCatch(SummarizedExperiment::assayNames(sce), error = function(...) NULL) if (is.null(names)) return(NULL) overrides <- S4Vectors::metadata(sce)$gatelabr_assay_roles @@ -226,7 +229,7 @@ # An explicit role override is the user's decision; never narrate it. if (is.list(overrides) && !is.null(overrides[[name]])) next if (!.gatelabr_assay_name_traits(name)$transformed) next - found <- .gatelabr_transformed_assay_compensation(sce, name) + found <- .gatelabr_transformed_assay_compensation(sce, name, accessory) if (!isTRUE(found$compensated)) next reason <- switch( found$evidence, @@ -267,19 +270,143 @@ # CATALYST and related R pipelines leave the spillover matrix in metadata(). # Finding it both proves compensation happened and supplies the matrix itself, # so a pre-compensated SCE need not be re-derived or hand-declared. -.gatelabr_sce_spillover_matrix <- function(sce) { - md <- S4Vectors::metadata(sce) - for (key in c("spillover", "spillover_matrix", "spilloverMatrix", "sm")) { - value <- md[[key]] - if (is.matrix(value) && is.numeric(value) && nrow(value) > 0L && - ncol(value) > 0L && !is.null(rownames(value)) && - !is.null(colnames(value))) { - return(value) +.gatelabr_sce_spillover_matrix <- function(sce, accessory = NULL) { + # The matrix may live on either object: a workflow that compensates in place + # often keeps the matrix beside the uncompensated copy it started from. + # The primary wins when both carry one. + for (candidate in list(sce, accessory)) { + if (is.null(candidate)) next + md <- S4Vectors::metadata(candidate) + for (key in c("spillover", "spillover_matrix", "spilloverMatrix", "sm")) { + value <- md[[key]] + if (is.matrix(value) && is.numeric(value) && nrow(value) > 0L && + ncol(value) > 0L && !is.null(rownames(value)) && + !is.null(colnames(value))) { + return(value) + } } } NULL } +# Validate an accessory (uncompensated) SCE against the primary before it is +# served alongside it. Event indices are derived from the PRIMARY's colData and +# then used to slice the accessory's payload, so any difference in cell count, +# cell order or channel order would silently produce a wrong before/after +# comparison. Reject rather than coerce: a misaligned comparison that still +# renders is worse than a refusal. +.gatelabr_validate_accessory_sce <- function(sce, accessory, sample_column = NULL) { + if (!methods::is(accessory, "SingleCellExperiment")) { + stop("`uncompensated` must be a SingleCellExperiment.", call. = FALSE) + } + if (ncol(accessory) != ncol(sce)) { + stop( + "`uncompensated` has ", ncol(accessory), " cells but the SCE has ", + ncol(sce), ". They must describe exactly the same cells.", + call. = FALSE + ) + } + if (nrow(accessory) != nrow(sce)) { + stop( + "`uncompensated` has ", nrow(accessory), " channels but the SCE has ", + nrow(sce), ". They must describe exactly the same channels.", + call. = FALSE + ) + } + if (!identical(rownames(accessory), rownames(sce))) { + stop( + "`uncompensated` channels differ from the SCE's, or are in a different ", + "order. Channel identity and order must match exactly.", + call. = FALSE + ) + } + + primary_cells <- colnames(sce) + accessory_cells <- colnames(accessory) + if (!is.null(primary_cells) || !is.null(accessory_cells)) { + if (!identical(primary_cells, accessory_cells)) { + stop( + "`uncompensated` cell names differ from the SCE's, or are in a ", + "different order. Cell identity and order must match exactly.", + call. = FALSE + ) + } + } else { + # Neither object names its cells, so pin the order through the sample + # partition instead — otherwise nothing constrains cell correspondence. + primary_partition <- .gatelabr_sample_partition(sce, sample_column) + accessory_partition <- tryCatch( + .gatelabr_sample_partition(accessory, sample_column), + error = function(...) NULL + ) + if (is.null(accessory_partition) || + !identical(primary_partition$levels, accessory_partition$levels) || + !identical(primary_partition$event_indices, accessory_partition$event_indices)) { + stop( + "`uncompensated` has unnamed cells whose sample grouping does not ", + "match the SCE's. Cell order cannot be verified, so the comparison ", + "would be meaningless.", + call. = FALSE + ) + } + } + + accessory_counts <- .gatelabr_counts_assay_name(accessory) + if (is.null(accessory_counts)) { + stop( + "`uncompensated` has no linear counts assay to compare against. ", + "Its assays are: ", + paste(SummarizedExperiment::assayNames(accessory), collapse = ", "), ".", + call. = FALSE + ) + } + + primary_counts <- .gatelabr_counts_assay_name(sce) + if (!is.null(primary_counts)) { + identical_values <- tryCatch( + .gatelabr_assays_match(sce, primary_counts, accessory, accessory_counts), + error = function(...) NA + ) + if (isTRUE(identical_values)) { + warning( + "`uncompensated` holds the same values as the SCE's `", primary_counts, + "` assay, so the Original/Compensated comparison would show no ", + "difference. Check that the intended uncompensated object was passed.", + call. = FALSE + ) + } + } + + list(counts_assay = accessory_counts) +} + +# Bounded-sample equality between one assay of each of two SCEs. Mirrors the +# sampling used by .gatelabr_transformed_assay_matches_counts(). +.gatelabr_assays_match <- function(sce, assay_name, other, other_assay_name, + tolerance = 1e-9) { + n_events <- ncol(sce) + if (n_events == 0L) return(NA) + index <- if (n_events > 2000L) { + unique(round(seq(1, n_events, length.out = 2000L))) + } else { + seq_len(n_events) + } + left <- tryCatch( + as.matrix(SummarizedExperiment::assay(sce, assay_name)[, index, drop = FALSE]), + error = function(...) NULL + ) + right <- tryCatch( + as.matrix(SummarizedExperiment::assay(other, other_assay_name)[, index, drop = FALSE]), + error = function(...) NULL + ) + if (is.null(left) || is.null(right) || !identical(dim(left), dim(right))) { + return(NA) + } + usable <- is.finite(left) & is.finite(right) + if (!any(usable)) return(NA) + max(abs(left[usable] - right[usable])) <= tolerance +} + .gatelabr_counts_assay_name <- function(sce) { names <- SummarizedExperiment::assayNames(sce) for (name in names) { @@ -331,12 +458,13 @@ # Decide whether a display-space assay already carries compensation, and say # why. Returns compensated (TRUE/FALSE), the evidence used, and the spillover # matrix when the object carries one. -.gatelabr_transformed_assay_compensation <- function(sce, assay_name) { +.gatelabr_transformed_assay_compensation <- function(sce, assay_name, + accessory = NULL) { none <- list(compensated = FALSE, evidence = "none", spillover = NULL, counts_assay = NULL) counts_name <- .gatelabr_counts_assay_name(sce) if (is.null(counts_name) || identical(counts_name, assay_name)) return(none) - spillover <- .gatelabr_sce_spillover_matrix(sce) + spillover <- .gatelabr_sce_spillover_matrix(sce, accessory) matches <- .gatelabr_transformed_assay_matches_counts(sce, assay_name, counts_name) if (isTRUE(matches)) { # Plain transform of the counts assay: not independently compensated, even @@ -578,7 +706,9 @@ dataset_id = "gatelabr-sce", label = dataset_id, sample_column = NULL, - sample_partition = NULL) { + sample_partition = NULL, + accessory = NULL, + accessory_assay = NULL) { if (!methods::is(sce, "SingleCellExperiment")) { stop("sce must be a SingleCellExperiment.", call. = FALSE) } @@ -620,6 +750,39 @@ ) }) + if (!is.null(accessory)) { + # GateLab loads exactly one linear assay as its base ("Original") layer, and + # picks the FIRST descriptor whose role is "counts" in linear space. The + # accessory therefore has to lead the list, and the primary's own linear + # counts must stop claiming that role — which is honest here, since supplying + # an uncompensated accessory asserts the primary is the compensated one. The + # primary's assay stays advertised and linear, so it remains adoptable as the + # Compensated layer. + if (is.null(accessory_assay)) { + accessory_assay <- .gatelabr_counts_assay_name(accessory) + } + if (is.null(accessory_assay)) { + stop("The uncompensated SCE has no linear counts assay.", call. = FALSE) + } + assays <- lapply(assays, function(entry) { + if (identical(entry$role, "counts") && + identical(entry$coordinateSpace, "linear")) { + entry$role <- "compensated" + } + entry + }) + accessory_entry <- list( + id = .gatelabr_accessory_assay_id, + label = "Uncompensated", + role = "counts", + coordinateSpace = "linear", + revision = .gatelabr_assay_revision(accessory, accessory_assay), + encoding = "channel-major-float32-le" + ) + assays <- c(list(accessory_entry), assays) + default_assay <- .gatelabr_accessory_assay_id + } + list( contractVersion = .gatelabr_dataset_contract_version, id = dataset_id, @@ -1713,19 +1876,27 @@ dataset_id = "gatelabr-sce", label = dataset_id, sample_column = NULL, - message_type = "gatelabr-host-manifest") { + message_type = "gatelabr-host-manifest", + accessory = NULL) { if (is.null(session) || !is.function(session$registerDataObj) || !is.function(session$sendCustomMessage)) { stop("session must provide registerDataObj() and sendCustomMessage().", call. = FALSE) } + accessory_assay <- if (is.null(accessory)) { + NULL + } else { + .gatelabr_counts_assay_name(accessory) + } partition <- .gatelabr_sample_partition(sce, sample_column) descriptor <- .gatelabr_sce_dataset_descriptor( sce, dataset_id = dataset_id, label = label, sample_column = sample_column, - sample_partition = partition + sample_partition = partition, + accessory = accessory, + accessory_assay = accessory_assay ) assay_names <- SummarizedExperiment::assayNames(sce) @@ -1750,6 +1921,19 @@ }), assay_names ) + if (!is.null(accessory)) { + # Served straight from the accessory object, which is never placed in + # sce_state and so can never reach the user's global on a writeback. + # Sliced by the PRIMARY's event indices — validated cell-identical. + assay_urls[[.gatelabr_accessory_assay_id]] <- + .gatelabr_register_assay_resource( + session, + paste0(prefix, "-assay-uncompensated"), + accessory, + accessory_assay, + event_indices + ) + } event_url <- .gatelabr_register_event_index_resource( session, paste0(prefix, "-events"), diff --git a/R/launch.R b/R/launch.R index bb3aabb..4483959 100644 --- a/R/launch.R +++ b/R/launch.R @@ -11,13 +11,20 @@ #' omitted, common sample columns such as \code{sample_id} are detected. #' @param port Port for Shiny (default: auto-select). #' @param launch.browser Whether to open a browser window (default: \code{TRUE}). +#' @param uncompensated Optional read-only \code{SingleCellExperiment} holding the +#' pre-compensation values for the same cells, for workflows that compensate in +#' place and keep the original in a separate object. It is served as the +#' Original layer for comparison and is never modified or written back; only +#' \code{sce} is saved to. Cell count, cell order and channels must match +#' exactly or the launch is refused. #' @return Invisibly \code{NULL}; runs the Shiny app (blocking). #' @export launchGatingApp <- function( sce = NULL, sample_column = NULL, port = NULL, - launch.browser = TRUE) { + launch.browser = TRUE, + uncompensated = NULL) { # Forward the caller's own symbol. substitute() resolves in THIS frame, so # without this the callee would only ever see the local parameter name `sce` # and would write every result back to a global called "sce" instead of the @@ -28,7 +35,8 @@ launchGatingApp <- function( sample_column = sample_column, port = port, launch.browser = launch.browser, - sce_name = if (is.symbol(supplied)) deparse(supplied) else "" + sce_name = if (is.symbol(supplied)) deparse(supplied) else "", + uncompensated = uncompensated ) } diff --git a/R/launch_react.R b/R/launch_react.R index d4aa7d5..5e55c98 100644 --- a/R/launch_react.R +++ b/R/launch_react.R @@ -15,6 +15,12 @@ #' the caller passed as \code{sce}. Delegating wrappers must forward the user's #' symbol explicitly, because \code{substitute()} would otherwise resolve to #' the wrapper's own parameter name. +#' @param uncompensated Optional read-only \code{SingleCellExperiment} holding the +#' pre-compensation values for the same cells, for workflows that compensate in +#' place and keep the original in a separate object. It is served as the +#' Original layer for comparison and is never modified or written back; only +#' \code{sce} is saved to. Cell count, cell order and channels must match +#' exactly or the launch is refused. #' @return Invisibly \code{NULL}; runs the Shiny app (blocking). #' @export launchReactGateLab <- function( @@ -22,7 +28,8 @@ launchReactGateLab <- function( sample_column = NULL, port = NULL, launch.browser = TRUE, - sce_name = NULL) { + sce_name = NULL, + uncompensated = NULL) { # Resolve the global-environment name that gates, populations and colData are # written back to. substitute() only sees the CALLER's argument expression, so # a delegating wrapper (launchGatingApp) must forward the user's own symbol — @@ -56,6 +63,17 @@ launchReactGateLab <- function( if (!nzchar(sce_name) || identical(sce_name, "NULL")) sce_name <- "gatelabr_sce" assign(sce_name, sce, envir = .GlobalEnv) } + # Validate the accessory before anything else happens, and never touch it + # again except to read. It is deliberately NOT placed in sce_state, so no + # writeback path can reach it or leak it into the user's primary object. + if (!is.null(uncompensated)) { + .gatelabr_validate_accessory_sce(sce, uncompensated, sample_column) + message( + "GateLabR loaded a read-only uncompensated SCE for comparison. It is ", + "served as the Original layer and is never written to; `", sce_name, + "` remains the only object saved back to." + ) + } # Say it out loud: silent writeback to a guessed name is how work goes missing. message( "GateLabR will save gates, populations and colData back to `", sce_name, @@ -64,7 +82,7 @@ launchReactGateLab <- function( # Likewise for an inferred assay role: the user must know what was assumed # about their data before they gate on it. precompensation <- tryCatch( - .gatelabr_precompensation_note(sce), + .gatelabr_precompensation_note(sce, uncompensated), error = function(cause) { # Never fail a launch over an advisory note, but never swallow it either: # a silent NULL is indistinguishable from "nothing detected", which sends @@ -108,7 +126,8 @@ launchReactGateLab <- function( sce_state = sce_state, sce_name = sce_name, dataset_id = dataset_id, - sample_column = sample_column + sample_column = sample_column, + accessory = uncompensated ) message( @@ -127,11 +146,15 @@ launchReactGateLab <- function( sce_state, sce_name, dataset_id, - sample_column = NULL) { + sample_column = NULL, + accessory = NULL) { force(sce_state) force(sce_name) force(dataset_id) force(sample_column) + # A plain local, deliberately not a reactiveVal: the accessory never changes + # and must never participate in the writeback state. + force(accessory) compensation_jobs <- .gatelabr_new_host_compensation_jobs() function(input, output, session) { @@ -150,7 +173,8 @@ launchReactGateLab <- function( sce_state(), dataset_id = dataset_id, label = sce_name, - sample_column = sample_column + sample_column = sample_column, + accessory = accessory ) }, once = TRUE, ignoreInit = TRUE) shiny::observeEvent(input$gatelabr_host_request, { diff --git a/tests/testthat/test-host-bridge.R b/tests/testthat/test-host-bridge.R index 6d51f21..99d0d86 100644 --- a/tests/testthat/test-host-bridge.R +++ b/tests/testthat/test-host-bridge.R @@ -736,3 +736,66 @@ test_that("host request dispatcher enforces dataset and colData contract identit "different SCE dataset" ) }) + +test_that("a workspace write never leaks the accessory into the user's SCE", { + # The whole design rests on this: sce_state is both what is served to React and + # what is assigned back to the user's global on every write, including autosave. + # The accessory is deliberately kept out of it, so a full write must leave the + # primary's assays and metadata keys exactly as they were. + skip_if_not_installed("shiny") + sce_name <- ".gatelabr_accessory_leak_test_sce" + on.exit( + if (exists(sce_name, envir = .GlobalEnv, inherits = FALSE)) { + rm(list = sce_name, envir = .GlobalEnv) + }, + add = TRUE + ) + + primary <- make_host_bridge_sce() + accessory <- primary + SummarizedExperiment::assay(accessory, "counts") <- + SummarizedExperiment::assay(primary, "counts") / 2 + + before_assays <- SummarizedExperiment::assayNames(primary) + before_metadata <- names(S4Vectors::metadata(primary)) + + sce_state <- shiny::reactiveVal(primary) + server <- GateLabR:::.gatelabr_react_server( + sce_state = sce_state, + sce_name = sce_name, + dataset_id = "test-sce", + accessory = accessory + ) + request <- list( + requestId = "write-1", + operation = "write-workspace", + payload = list( + datasetId = "test-sce", + expectedRevision = 0L, + clientRevision = 7L, + reason = "autosave", + workspaceJson = canonical_host_workspace_json() + ) + ) + + suppressWarnings(shiny::testServer(server, { + session$flushReact() + session$setInputs(gatelabr_host_request = request) + session$flushReact() + })) + + written <- get(sce_name, envir = .GlobalEnv) + expect_identical(SummarizedExperiment::assayNames(written), before_assays) + expect_false("gatelabr_uncompensated" %in% SummarizedExperiment::assayNames(written)) + # Only workspace keys may appear; no accessory bookkeeping. + expect_true(all(before_metadata %in% names(S4Vectors::metadata(written)))) + expect_identical( + SummarizedExperiment::assay(written, "counts"), + SummarizedExperiment::assay(primary, "counts") + ) + # And the accessory itself is untouched. + expect_identical( + SummarizedExperiment::assay(accessory, "counts"), + SummarizedExperiment::assay(primary, "counts") / 2 + ) +}) diff --git a/tests/testthat/test-uncompensated-accessory.R b/tests/testthat/test-uncompensated-accessory.R new file mode 100644 index 0000000..084a723 --- /dev/null +++ b/tests/testthat/test-uncompensated-accessory.R @@ -0,0 +1,132 @@ +skip_if_not_installed("SingleCellExperiment") + +acc_counts <- function(offset = 0, n_cells = 6L) { + matrix( + seq_len(2L * n_cells) + offset, + nrow = 2L, + dimnames = list(c("A", "B"), paste0("cell", seq_len(n_cells))) + ) +} + +acc_sce <- function(counts = acc_counts(), metadata = list(cofactor = 5)) { + SingleCellExperiment::SingleCellExperiment( + assays = list(counts = counts, exprs = asinh(counts / 5)), + colData = S4Vectors::DataFrame( + sample_id = rep(c("s1", "s2"), each = ncol(counts) / 2) + ), + metadata = metadata + ) +} + +test_that("a matching accessory validates and reports its counts assay", { + primary <- acc_sce(acc_counts(offset = 100)) + accessory <- acc_sce() + + result <- GateLabR:::.gatelabr_validate_accessory_sce(primary, accessory) + expect_identical(result$counts_assay, "counts") +}) + +test_that("mismatched cells, channels or order are refused, each by name", { + primary <- acc_sce(acc_counts(offset = 100)) + + expect_error( + GateLabR:::.gatelabr_validate_accessory_sce(primary, acc_sce(acc_counts(n_cells = 4L))), + "same cells" + ) + + wrong_channels <- acc_sce() + rownames(wrong_channels) <- c("A", "Z") + expect_error( + GateLabR:::.gatelabr_validate_accessory_sce(primary, wrong_channels), + "Channel identity and order" + ) + + reordered <- acc_sce() + colnames(reordered) <- rev(colnames(reordered)) + expect_error( + GateLabR:::.gatelabr_validate_accessory_sce(primary, reordered), + "Cell identity and order" + ) + + expect_error( + GateLabR:::.gatelabr_validate_accessory_sce(primary, "not an sce"), + "must be a SingleCellExperiment" + ) +}) + +test_that("an accessory identical to the primary warns rather than silently comparing nothing", { + # Passing the compensated object twice would render a before/after view with no + # difference at all, which reads as 'compensation did nothing'. + primary <- acc_sce() + expect_warning( + GateLabR:::.gatelabr_validate_accessory_sce(primary, acc_sce()), + "same values" + ) +}) + +test_that("the accessory leads the assay list and takes the counts role", { + # GateLab loads the FIRST linear counts-role assay as its Original layer, so + # ordering here decides which data the user sees as 'before'. + primary <- acc_sce(acc_counts(offset = 100)) + accessory <- acc_sce() + + descriptor <- GateLabR:::.gatelabr_sce_dataset_descriptor( + primary, + accessory = accessory + ) + ids <- vapply(descriptor$assays, `[[`, character(1), "id") + roles <- vapply(descriptor$assays, `[[`, character(1), "role") + spaces <- vapply(descriptor$assays, `[[`, character(1), "coordinateSpace") + + expect_identical(ids[[1]], "gatelabr_uncompensated") + expect_identical(roles[[1]], "counts") + expect_identical(spaces[[1]], "linear") + expect_identical(descriptor$defaultAssayId, "gatelabr_uncompensated") + + # The primary's own linear counts must stop claiming the counts role, or it + # would win the first-match race and the 'before' view would be the compensated + # data. It stays linear so it remains adoptable as the Compensated layer. + primary_counts <- which(ids == "counts") + expect_identical(roles[[primary_counts]], "compensated") + expect_identical(spaces[[primary_counts]], "linear") +}) + +test_that("without an accessory the descriptor is unchanged", { + primary <- acc_sce() + descriptor <- GateLabR:::.gatelabr_sce_dataset_descriptor(primary) + + ids <- vapply(descriptor$assays, `[[`, character(1), "id") + roles <- vapply(descriptor$assays, `[[`, character(1), "role") + expect_identical(ids, c("counts", "exprs")) + expect_identical(roles[[which(ids == "counts")]], "counts") + expect_identical(descriptor$defaultAssayId, "counts") + expect_false("gatelabr_uncompensated" %in% ids) +}) + +test_that("the spillover matrix is found on either object, primary first", { + spill <- matrix( + c(1, 0.02, 0.01, 1), + nrow = 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + other <- matrix( + c(1, 0.5, 0.5, 1), + nrow = 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + bare <- acc_sce() + with_spill <- acc_sce(metadata = list(cofactor = 5, spillover = spill)) + with_other <- acc_sce(metadata = list(cofactor = 5, spillover = other)) + + expect_null(GateLabR:::.gatelabr_sce_spillover_matrix(bare)) + # Found on the accessory when the primary has none. + expect_identical( + GateLabR:::.gatelabr_sce_spillover_matrix(bare, with_spill), + spill + ) + # Primary wins when both carry one. + expect_identical( + GateLabR:::.gatelabr_sce_spillover_matrix(with_spill, with_other), + spill + ) +})