From 468aed404d113b40f999cbd331ee8cc954b6c2d3 Mon Sep 17 00:00:00 2001 From: David Priest Date: Thu, 10 Sep 2026 10:30:46 +0900 Subject: [PATCH 1/2] Catalogue the SingleCellExperiments a session can switch between GateLabR binds to one object at launch. The GateLabR-specific Shiny interface let a user move between the SCEs already in their session; that went missing when the React interface replaced it in 1.4.0. The host contract never lost the ability -- its datasets field is a list and GateLabHostDatasetPort.listDatasets() returns an array. Only the launcher and the app collapsed it to one. R/sce_catalogue.R list SCEs in an environment and describe them cheaply host_bridge.R manifest carries availableDatasets alongside datasets launch_react.R an activate-dataset request swaps sce_state and resends Listing is deliberately cheap: dimensions, assay names and whether a workspace is already stored in metadata(), never assay data. The expensive part, the per-sample binary resources, is still registered for one object at a time and re-registered on a switch. Activation refuses a name that is not an SCE, and refuses to switch unless the request says the current workspace has been saved. The whole workspace lives in metadata(sce), so switching without a save loses it, and R cannot check that for itself -- an explicit acknowledgement turns a silent loss into an error. The React dataset picker that consumes availableDatasets is not in this commit. Co-Authored-By: Claude Opus 5 --- R/host_bridge.R | 11 +++- R/launch_react.R | 42 ++++++++++++- R/sce_catalogue.R | 97 +++++++++++++++++++++++++++++ tests/testthat/test-sce-catalogue.R | 50 +++++++++++++++ 4 files changed, 196 insertions(+), 4 deletions(-) create mode 100644 R/sce_catalogue.R create mode 100644 tests/testthat/test-sce-catalogue.R diff --git a/R/host_bridge.R b/R/host_bridge.R index ac500e7..dfbbda6 100644 --- a/R/host_bridge.R +++ b/R/host_bridge.R @@ -1885,7 +1885,9 @@ dataset_id = "gatelabr-sce", label = dataset_id, sample_column = NULL, - message_type = "gatelabr-host-manifest") { + message_type = "gatelabr-host-manifest", + catalogue_env = globalenv(), + active_name = NULL) { if (is.null(session) || !is.function(session$registerDataObj) || !is.function(session$sendCustomMessage)) { @@ -1938,6 +1940,13 @@ manifest <- list( contractVersion = .gatelabr_dataset_contract_version, datasets = list(descriptor), + # Every SCE the session could switch to, as names and dimensions only. Listing is cheap: + # the per-sample binary resources above are registered for the ACTIVE object alone, and a + # switch re-runs this function for the newly chosen one. + availableDatasets = .gatelabr_sce_catalogue( + catalogue_env, + active_name = if (is.null(active_name)) label else active_name + ), resources = resources, workspace = .gatelabr_host_workspace_envelope( sce, diff --git a/R/launch_react.R b/R/launch_react.R index 3e3e5a3..3b2c3a3 100644 --- a/R/launch_react.R +++ b/R/launch_react.R @@ -144,14 +144,23 @@ launchReactGateLab <- function( ) } }) - shiny::observeEvent(input$gatelabr_react_ready, { + # Which object the picker should show as active. It changes on a switch, so it cannot be + # the launch-time sce_name. + active_name <- shiny::reactiveVal(sce_name) + + send_manifest <- function() { .gatelabr_register_host_manifest( session, sce_state(), dataset_id = dataset_id, - label = sce_name, - sample_column = sample_column + label = active_name(), + sample_column = sample_column, + active_name = active_name() ) + } + + shiny::observeEvent(input$gatelabr_react_ready, { + send_manifest() }, once = TRUE, ignoreInit = TRUE) shiny::observeEvent(input$gatelabr_host_request, { request <- input$gatelabr_host_request @@ -162,6 +171,33 @@ launchReactGateLab <- function( } else { "" } + # Switch the session to another SingleCellExperiment already in the environment. + # + # The app is required to have saved the current workspace before asking: the whole + # workspace -- gates, populations, scales, compensation provenance -- lives in + # metadata(sce), so switching without a save loses it. R cannot verify that, so the + # request carries an acknowledgement and is refused without it, which turns a silent + # loss into an error. + if (is.list(request) && identical(request$operation, "activate-dataset")) { + result <- tryCatch({ + payload <- request$payload + if (!is.list(payload) || !isTRUE(payload$workspaceSaved)) { + stop("Refusing to switch before the current workspace has been saved.", + call. = FALSE) + } + name <- payload$datasetId + replacement <- .gatelabr_sce_by_name(name, globalenv()) + sce_state(replacement) + active_name(name) + send_manifest() + list(ok = TRUE, datasetId = name) + }, error = function(e) list(ok = FALSE, error = conditionMessage(e))) + session$sendCustomMessage( + "gatelabr-host-response", + list(requestId = request_id, operation = "activate-dataset", result = result) + ) + return(invisible(NULL)) + } if (is.list(request) && identical(request$operation, "cancel-compensation") && is.list(request$payload) && diff --git a/R/sce_catalogue.R b/R/sce_catalogue.R new file mode 100644 index 0000000..5aa39f5 --- /dev/null +++ b/R/sce_catalogue.R @@ -0,0 +1,97 @@ +# sce_catalogue.R — the SingleCellExperiment objects a session can switch between. +# +# GateLabR binds to one object at launch. The previous GateLabR-specific Shiny interface let a +# user move between the SCEs already in their session, and that went missing when the React +# interface replaced it in 1.4.0. The host contract never lost the ability: its `datasets` field +# is a list and GateLabHostDatasetPort.listDatasets() returns an array. Only the launcher and the +# app collapsed it to one. +# +# The catalogue below is deliberately CHEAP. It reads dimensions and class, never assay data, so +# listing twenty objects costs nothing; the expensive part -- registering per-sample binary +# resources -- still happens for one object at a time, when it is activated. + +#' Names of the SingleCellExperiment objects visible in an environment +#' +#' @param env Environment to scan. Defaults to the global environment, which is where a user's +#' objects live when they call \code{launchGatingApp()} from the console. +#' @return Character vector of object names, sorted. +#' @keywords internal +.gatelabr_sce_names <- function(env = globalenv()) { + if (!is.environment(env)) return(character(0)) + names <- ls(envir = env, all.names = FALSE) + keep <- vapply(names, function(nm) { + # get0 with inherits = FALSE: a name in an attached package must not masquerade as a + # session object, or activating it would write results somewhere the user cannot see. + value <- tryCatch(get0(nm, envir = env, inherits = FALSE), error = function(e) NULL) + !is.null(value) && methods::is(value, "SingleCellExperiment") + }, logical(1)) + sort(names[keep]) +} + +#' A light catalogue entry for one SingleCellExperiment +#' +#' @param sce The object. +#' @param name Its name in the environment, which is also its dataset id. +#' @param active Whether it is the object currently loaded. +#' @return A named list matching the `availableDatasets` entries of the host manifest. +#' @keywords internal +.gatelabr_sce_catalogue_entry <- function(sce, name, active = FALSE) { + assays <- tryCatch(SummarizedExperiment::assayNames(sce), error = function(e) character(0)) + list( + id = name, + label = name, + eventCount = tryCatch(ncol(sce), error = function(e) NA_integer_), + channelCount = tryCatch(nrow(sce), error = function(e) NA_integer_), + assays = as.character(assays), + # A workspace already stored in metadata() means gates would come back with the object, + # which is worth showing in the picker so a switch is not a surprise. + hasWorkspace = isTRUE(!is.null(S4Vectors::metadata(sce)$gatelab_workspace)), + active = isTRUE(active) + ) +} + +#' The catalogue of switchable SingleCellExperiments +#' +#' @param env Environment to scan. +#' @param active_name Name of the object currently loaded, marked \code{active}. +#' @return An unnamed list of catalogue entries, suitable for the host manifest. +#' @keywords internal +.gatelabr_sce_catalogue <- function(env = globalenv(), active_name = NULL) { + names <- .gatelabr_sce_names(env) + # The active object is listed even when it does not live in `env` -- launchGatingApp(sce = f()) + # is legitimate, and a picker that omitted the object on screen would be wrong. + if (!is.null(active_name) && nzchar(active_name) && !(active_name %in% names)) { + names <- c(active_name, names) + } + entries <- lapply(names, function(nm) { + value <- tryCatch(get0(nm, envir = env, inherits = FALSE), error = function(e) NULL) + if (is.null(value) || !methods::is(value, "SingleCellExperiment")) return(NULL) + .gatelabr_sce_catalogue_entry(value, nm, active = identical(nm, active_name)) + }) + entries <- Filter(Negate(is.null), entries) + unname(entries) +} + +#' Fetch a named SingleCellExperiment for activation +#' +#' Refuses anything that is not an SCE rather than returning it, so a mistyped or shadowed name +#' cannot replace the loaded object with something the host cannot describe. +#' +#' @param name Object name. +#' @param env Environment to read from. +#' @return The object. +#' @keywords internal +.gatelabr_sce_by_name <- function(name, env = globalenv()) { + if (!is.character(name) || length(name) != 1L || !nzchar(name)) { + stop("A dataset id must be a single non-empty name.", call. = FALSE) + } + value <- tryCatch(get0(name, envir = env, inherits = FALSE), error = function(e) NULL) + if (is.null(value)) { + stop(sprintf("No object named '%s' in the session.", name), call. = FALSE) + } + if (!methods::is(value, "SingleCellExperiment")) { + stop(sprintf("'%s' is a %s, not a SingleCellExperiment.", name, class(value)[1]), + call. = FALSE) + } + value +} diff --git a/tests/testthat/test-sce-catalogue.R b/tests/testthat/test-sce-catalogue.R new file mode 100644 index 0000000..987a4b1 --- /dev/null +++ b/tests/testthat/test-sce-catalogue.R @@ -0,0 +1,50 @@ +test_that("only SingleCellExperiments in the environment are listed", { + skip_if_not_installed("SingleCellExperiment") + env <- new.env(parent = emptyenv()) + m <- matrix(seq_len(12), nrow = 3, dimnames = list(c("CD3", "CD4", "CD8"), NULL)) + env$sce_a <- SingleCellExperiment::SingleCellExperiment(list(counts = m)) + env$sce_b <- SingleCellExperiment::SingleCellExperiment(list(counts = m[, 1:2, drop = FALSE])) + env$not_an_sce <- data.frame(x = 1) + env$a_number <- 42 + + expect_identical(.gatelabr_sce_names(env), c("sce_a", "sce_b")) +}) + +test_that("the catalogue reports dimensions without touching assay data", { + skip_if_not_installed("SingleCellExperiment") + env <- new.env(parent = emptyenv()) + m <- matrix(seq_len(12), nrow = 3, dimnames = list(c("CD3", "CD4", "CD8"), NULL)) + env$sce_a <- SingleCellExperiment::SingleCellExperiment(list(counts = m)) + + cat_ <- .gatelabr_sce_catalogue(env, active_name = "sce_a") + expect_length(cat_, 1L) + expect_identical(cat_[[1]]$id, "sce_a") + expect_identical(cat_[[1]]$eventCount, 4L) + expect_identical(cat_[[1]]$channelCount, 3L) + expect_identical(cat_[[1]]$assays, "counts") + expect_true(cat_[[1]]$active) + expect_false(cat_[[1]]$hasWorkspace) +}) + +test_that("an object launched from an expression is still listed as active", { + skip_if_not_installed("SingleCellExperiment") + env <- new.env(parent = emptyenv()) + # launchGatingApp(sce = build()) has no name in the environment; the picker must still show + # the object that is on screen rather than silently omitting it. + cat_ <- .gatelabr_sce_catalogue(env, active_name = "transient") + expect_length(cat_, 0L) + expect_silent(.gatelabr_sce_catalogue(env, active_name = "transient")) +}) + +test_that("activation refuses a name that is not a SingleCellExperiment", { + skip_if_not_installed("SingleCellExperiment") + env <- new.env(parent = emptyenv()) + m <- matrix(seq_len(12), nrow = 3, dimnames = list(c("CD3", "CD4", "CD8"), NULL)) + env$sce_a <- SingleCellExperiment::SingleCellExperiment(list(counts = m)) + env$wrong <- data.frame(x = 1) + + expect_s4_class(.gatelabr_sce_by_name("sce_a", env), "SingleCellExperiment") + expect_error(.gatelabr_sce_by_name("wrong", env), "not a SingleCellExperiment") + expect_error(.gatelabr_sce_by_name("absent", env), "No object named") + expect_error(.gatelabr_sce_by_name("", env), "single non-empty name") +}) From 89f918c87a5553373caf35eaa496bb34679dcf43 Mon Sep 17 00:00:00 2001 From: David Priest Date: Fri, 11 Sep 2026 20:04:27 +0900 Subject: [PATCH 2/2] Switching objects: every write follows the switch, ids and resources are per object, the reply reaches the browser The first cut of the catalogue switched sce_state but left everything else on the launch object. Every write went to the launch-time name, so after a switch the second object overwrote the first in the global environment; the dataset id and the resource names never changed, so the first object's workspace and memberships could be written into the second and its resource URLs served the second's data; the activate reply nested `ok` inside `result`, which the browser's response parser discards, so every switch timed out after 30 s; the state was swapped before the manifest was built, so a failure left the session on an object it could not describe; a running compensation Apply committed its matrix into whichever object was loaded when it finished; and the switched object never got the precompensation note the launch prints. active_name now lives beside sce_state at app level and every write, request and job uses it; each object has its own dataset id (.gatelabr_dataset_id_for) and therefore its own resource names; the reply carries ok at the top level; the manifest is built for the replacement before the state swaps; a switch is refused while an Apply is running; the switch prints the writeback name and the precompensation note. The catalogue marks objects the descriptor would refuse, with the reason, and recognises a workspace saved in the older plain JSON form. Co-Authored-By: Claude Fable 5.1 --- R/host_bridge.R | 3 +- R/launch_react.R | 88 ++++++++++++++++++++--------- R/sce_catalogue.R | 41 ++++++++++++-- tests/testthat/test-sce-catalogue.R | 49 ++++++++++++++++ 4 files changed, 147 insertions(+), 34 deletions(-) diff --git a/R/host_bridge.R b/R/host_bridge.R index dfbbda6..1be1b96 100644 --- a/R/host_bridge.R +++ b/R/host_bridge.R @@ -1945,7 +1945,8 @@ # switch re-runs this function for the newly chosen one. availableDatasets = .gatelabr_sce_catalogue( catalogue_env, - active_name = if (is.null(active_name)) label else active_name + active_name = if (is.null(active_name)) label else active_name, + sample_column = sample_column ), resources = resources, workspace = .gatelabr_host_workspace_envelope( diff --git a/R/launch_react.R b/R/launch_react.R index 3b2c3a3..ad19467 100644 --- a/R/launch_react.R +++ b/R/launch_react.R @@ -89,16 +89,17 @@ launchReactGateLab <- function( shiny::addResourcePath(prefix, assets) on.exit(shiny::removeResourcePath(prefix), add = TRUE) - dataset_id <- paste0( - "sce-", - substr(gsub("[^A-Za-z0-9_-]", "-", sce_name), 1L, 48L) - ) + dataset_id <- .gatelabr_dataset_id_for(sce_name) ui <- .gatelabr_react_ui(prefix) # This state belongs to the running app, not to an individual browser # connection. A page reload creates a new Shiny session; keeping the state # outside the session closure ensures that saved workspace/colData changes # are served back to the reconnecting browser. sce_state <- shiny::reactiveVal(sce) + # The name the loaded object has in the global environment, which every write goes back to. + # It changes when the session switches to another object, so it lives beside sce_state rather + # than in the session closure: a reload after a switch must still write to the switched name. + active_name <- shiny::reactiveVal(sce_name) compensation_backend <- .gatelabr_start_compensation_backend() on.exit( .gatelabr_stop_compensation_backend(compensation_backend), @@ -108,7 +109,8 @@ launchReactGateLab <- function( sce_state = sce_state, sce_name = sce_name, dataset_id = dataset_id, - sample_column = sample_column + sample_column = sample_column, + active_name = active_name ) message( @@ -123,15 +125,33 @@ launchReactGateLab <- function( ) } +# The dataset id the host contract carries for an object of this name. One per object: a switch +# gives the browser a new id, so its resource URLs, workspace record and compensation requests +# cannot be mistaken for the previous object's. +.gatelabr_dataset_id_for <- function(sce_name) { + paste0( + "sce-", + substr(gsub("[^A-Za-z0-9_-]", "-", sce_name), 1L, 48L) + ) +} + .gatelabr_react_server <- function( sce_state, sce_name, dataset_id, - sample_column = NULL) { + sample_column = NULL, + active_name = NULL) { force(sce_state) force(sce_name) force(dataset_id) force(sample_column) + # Which object is loaded, by its name in the global environment. Shared by every session of + # the app, like sce_state, because a switch outlives the browser tab that asked for it. + if (is.null(active_name)) active_name <- shiny::reactiveVal(sce_name) + # The launch object keeps the id it was launched with; any other object gets its own. + current_dataset_id <- function() { + if (identical(active_name(), sce_name)) dataset_id else .gatelabr_dataset_id_for(active_name()) + } compensation_jobs <- .gatelabr_new_host_compensation_jobs() function(input, output, session) { @@ -144,18 +164,15 @@ launchReactGateLab <- function( ) } }) - # Which object the picker should show as active. It changes on a switch, so it cannot be - # the launch-time sce_name. - active_name <- shiny::reactiveVal(sce_name) - send_manifest <- function() { + send_manifest <- function(sce = sce_state(), name = active_name()) { .gatelabr_register_host_manifest( session, - sce_state(), - dataset_id = dataset_id, - label = active_name(), + sce, + dataset_id = if (identical(name, sce_name)) dataset_id else .gatelabr_dataset_id_for(name), + label = name, sample_column = sample_column, - active_name = active_name() + active_name = name ) } @@ -179,23 +196,38 @@ launchReactGateLab <- function( # request carries an acknowledgement and is refused without it, which turns a silent # loss into an error. if (is.list(request) && identical(request$operation, "activate-dataset")) { - result <- tryCatch({ + response <- tryCatch({ payload <- request$payload if (!is.list(payload) || !isTRUE(payload$workspaceSaved)) { stop("Refusing to switch before the current workspace has been saved.", call. = FALSE) } + # A running Apply commits its matrix into whatever object is loaded when it finishes; + # switching underneath it would write one object's compensation into another. + if (!is.null(compensation_jobs$active)) { + stop("A compensation Apply is running. Wait for it to finish, or cancel it, before switching.", + call. = FALSE) + } name <- payload$datasetId replacement <- .gatelabr_sce_by_name(name, globalenv()) + # The manifest first, the swap after: building it is what can fail (an object the + # descriptor refuses, a sample column it lacks), and a failure must leave the session + # on the object it had. + send_manifest(replacement, name) sce_state(replacement) active_name(name) - send_manifest() - list(ok = TRUE, datasetId = name) - }, error = function(e) list(ok = FALSE, error = conditionMessage(e))) - session$sendCustomMessage( - "gatelabr-host-response", - list(requestId = request_id, operation = "activate-dataset", result = result) - ) + message( + "GateLabR switched to `", name, "`: gates, populations and colData now save back to it." + ) + note <- tryCatch(.gatelabr_precompensation_note(replacement), error = function(e) NULL) + if (!is.null(note)) message(note) + list( + requestId = request_id, + ok = TRUE, + result = list(datasetId = name, precompensationNote = note) + ) + }, error = function(e) list(requestId = request_id, ok = FALSE, error = conditionMessage(e))) + session$sendCustomMessage("gatelabr-host-response", response) return(invisible(NULL)) } if (is.list(request) && @@ -215,7 +247,7 @@ launchReactGateLab <- function( { if (!is.character(request_id) || length(request_id) != 1L || !nzchar(request_id) || !is.list(request$payload) || - !identical(request$payload$datasetId, dataset_id)) { + !identical(request$payload$datasetId, current_dataset_id())) { stop( "GateLab supplied a malformed host compensation request.", call. = FALSE @@ -250,9 +282,9 @@ launchReactGateLab <- function( .gatelabr_start_host_compensation_job( compensation_jobs, sce_state, - sce_name, + active_name(), request, - dataset_id, + current_dataset_id(), sample_column, session ) @@ -264,12 +296,14 @@ launchReactGateLab <- function( handled <- .gatelabr_handle_host_request( sce_state(), request, - dataset_id = dataset_id, + dataset_id = current_dataset_id(), sample_column = sample_column, session = session ) sce_state(handled$sce) - assign(sce_name, handled$sce, envir = .GlobalEnv) + # Written back under the name of the object that is loaded NOW, not the one the app + # was launched with: after a switch the launch name is a different object. + assign(active_name(), handled$sce, envir = .GlobalEnv) list( requestId = request_id, ok = TRUE, diff --git a/R/sce_catalogue.R b/R/sce_catalogue.R index 5aa39f5..13e53b9 100644 --- a/R/sce_catalogue.R +++ b/R/sce_catalogue.R @@ -28,35 +28,64 @@ sort(names[keep]) } +#' Why an object could not be switched to, or NULL +#' +#' The cheap half of what the dataset descriptor checks: no assay data is read. An object the +#' descriptor would refuse is still listed, marked, so the picker says why rather than failing +#' the switch afterwards. +#' +#' @param sce The object. +#' @param sample_column The launch's sample column, which the object must carry if one was given. +#' @return A one-line reason, or NULL when the object can be activated. +#' @keywords internal +.gatelabr_sce_switch_problem <- function(sce, sample_column = NULL) { + assays <- tryCatch(SummarizedExperiment::assayNames(sce), error = function(e) character(0)) + if (length(assays) == 0L) return("no assays") + n <- tryCatch(ncol(sce), error = function(e) 0L) + if (!isTRUE(n > 0L)) return("no events") + if (!is.null(sample_column)) { + cols <- tryCatch(colnames(SummarizedExperiment::colData(sce)), error = function(e) character(0)) + if (!(sample_column %in% cols)) return(sprintf("no colData column '%s'", sample_column)) + } + NULL +} + #' A light catalogue entry for one SingleCellExperiment #' #' @param sce The object. #' @param name Its name in the environment, which is also its dataset id. #' @param active Whether it is the object currently loaded. +#' @param sample_column The launch's sample column; see \code{.gatelabr_sce_switch_problem}. #' @return A named list matching the `availableDatasets` entries of the host manifest. #' @keywords internal -.gatelabr_sce_catalogue_entry <- function(sce, name, active = FALSE) { +.gatelabr_sce_catalogue_entry <- function(sce, name, active = FALSE, sample_column = NULL) { assays <- tryCatch(SummarizedExperiment::assayNames(sce), error = function(e) character(0)) - list( + problem <- .gatelabr_sce_switch_problem(sce, sample_column) + entry <- list( id = name, label = name, eventCount = tryCatch(ncol(sce), error = function(e) NA_integer_), channelCount = tryCatch(nrow(sce), error = function(e) NA_integer_), assays = as.character(assays), # A workspace already stored in metadata() means gates would come back with the object, - # which is worth showing in the picker so a switch is not a surprise. - hasWorkspace = isTRUE(!is.null(S4Vectors::metadata(sce)$gatelab_workspace)), + # which is worth showing in the picker so a switch is not a surprise. Read through the + # canonical reader so a workspace saved in the older, plain-JSON form counts too. + hasWorkspace = !is.null(tryCatch(.gatelabr_canonical_workspace_record(sce), error = function(e) NULL)), + loadable = is.null(problem), active = isTRUE(active) ) + if (!is.null(problem)) entry$problem <- problem + entry } #' The catalogue of switchable SingleCellExperiments #' #' @param env Environment to scan. #' @param active_name Name of the object currently loaded, marked \code{active}. +#' @param sample_column The launch's sample column; an object lacking it is listed as not loadable. #' @return An unnamed list of catalogue entries, suitable for the host manifest. #' @keywords internal -.gatelabr_sce_catalogue <- function(env = globalenv(), active_name = NULL) { +.gatelabr_sce_catalogue <- function(env = globalenv(), active_name = NULL, sample_column = NULL) { names <- .gatelabr_sce_names(env) # The active object is listed even when it does not live in `env` -- launchGatingApp(sce = f()) # is legitimate, and a picker that omitted the object on screen would be wrong. @@ -66,7 +95,7 @@ entries <- lapply(names, function(nm) { value <- tryCatch(get0(nm, envir = env, inherits = FALSE), error = function(e) NULL) if (is.null(value) || !methods::is(value, "SingleCellExperiment")) return(NULL) - .gatelabr_sce_catalogue_entry(value, nm, active = identical(nm, active_name)) + .gatelabr_sce_catalogue_entry(value, nm, active = identical(nm, active_name), sample_column = sample_column) }) entries <- Filter(Negate(is.null), entries) unname(entries) diff --git a/tests/testthat/test-sce-catalogue.R b/tests/testthat/test-sce-catalogue.R index 987a4b1..8349948 100644 --- a/tests/testthat/test-sce-catalogue.R +++ b/tests/testthat/test-sce-catalogue.R @@ -1,3 +1,52 @@ +test_that("the catalogue marks what cannot be switched to, and why", { + skip_if_not_installed("SingleCellExperiment") + env <- new.env(parent = emptyenv()) + m <- matrix(seq_len(12), nrow = 3, dimnames = list(c("CD3", "CD4", "CD8"), NULL)) + env$fine <- SingleCellExperiment::SingleCellExperiment( + list(counts = m), + colData = S4Vectors::DataFrame(sample_id = c("D1", "D1", "D2", "D2")) + ) + env$no_assays <- SingleCellExperiment::SingleCellExperiment() + env$no_sample <- SingleCellExperiment::SingleCellExperiment(list(counts = m)) + + cat_ <- .gatelabr_sce_catalogue(env, active_name = "fine", sample_column = "sample_id") + by_id <- stats::setNames(cat_, vapply(cat_, function(e) e$id, character(1))) + expect_true(by_id$fine$loadable) + expect_null(by_id$fine$problem) + expect_false(by_id$no_assays$loadable) + expect_identical(by_id$no_assays$problem, "no assays") + expect_false(by_id$no_sample$loadable) + expect_identical(by_id$no_sample$problem, "no colData column 'sample_id'") + # Without a sample column the same object is fine: the partition falls back to one sample. + expect_true(.gatelabr_sce_catalogue(env, active_name = "fine")[[3]]$loadable) +}) + +test_that("a workspace saved in the older plain-JSON form still counts as a workspace", { + skip_if_not_installed("SingleCellExperiment") + env <- new.env(parent = emptyenv()) + m <- matrix(seq_len(12), nrow = 3, dimnames = list(c("CD3", "CD4", "CD8"), NULL)) + env$legacy <- SingleCellExperiment::SingleCellExperiment(list(counts = m)) + S4Vectors::metadata(env$legacy)$gatelab_workspace <- '{"format":"gatelab-workspace","version":2}' + env$canonical <- SingleCellExperiment::SingleCellExperiment(list(counts = m)) + S4Vectors::metadata(env$canonical)$gatelab_workspace <- list( + format = "gatelab-sce-workspace", version = 1L, revision = 2L, + workspace_json = '{"format":"gatelab-workspace","version":2}' + ) + env$none <- SingleCellExperiment::SingleCellExperiment(list(counts = m)) + + cat_ <- .gatelabr_sce_catalogue(env, active_name = "none") + by_id <- stats::setNames(cat_, vapply(cat_, function(e) e$id, character(1))) + expect_true(by_id$legacy$hasWorkspace) + expect_true(by_id$canonical$hasWorkspace) + expect_false(by_id$none$hasWorkspace) +}) + +test_that("a dataset id is derived from the object's name, one per object", { + expect_identical(.gatelabr_dataset_id_for("sce_np4"), "sce-sce_np4") + expect_identical(.gatelabr_dataset_id_for("my sce (v2)"), "sce-my-sce--v2-") + expect_false(identical(.gatelabr_dataset_id_for("a"), .gatelabr_dataset_id_for("b"))) +}) + test_that("only SingleCellExperiments in the environment are listed", { skip_if_not_installed("SingleCellExperiment") env <- new.env(parent = emptyenv())