diff --git a/R/host_bridge.R b/R/host_bridge.R index ac500e7..1be1b96 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,14 @@ 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, + sample_column = sample_column + ), resources = resources, workspace = .gatelabr_host_workspace_envelope( sce, diff --git a/R/launch_react.R b/R/launch_react.R index 3e3e5a3..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,14 +164,20 @@ launchReactGateLab <- function( ) } }) - shiny::observeEvent(input$gatelabr_react_ready, { + + send_manifest <- function(sce = sce_state(), name = active_name()) { .gatelabr_register_host_manifest( session, - sce_state(), - dataset_id = dataset_id, - label = sce_name, - sample_column = sample_column + sce, + dataset_id = if (identical(name, sce_name)) dataset_id else .gatelabr_dataset_id_for(name), + label = name, + sample_column = sample_column, + active_name = 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 +188,48 @@ 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")) { + 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) + 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) && identical(request$operation, "cancel-compensation") && is.list(request$payload) && @@ -179,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 @@ -214,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 ) @@ -228,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 new file mode 100644 index 0000000..13e53b9 --- /dev/null +++ b/R/sce_catalogue.R @@ -0,0 +1,126 @@ +# 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]) +} + +#' 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, sample_column = NULL) { + assays <- tryCatch(SummarizedExperiment::assayNames(sce), error = function(e) character(0)) + 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. 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, 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. + 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), sample_column = sample_column) + }) + 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..8349948 --- /dev/null +++ b/tests/testthat/test-sce-catalogue.R @@ -0,0 +1,99 @@ +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()) + 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") +})