Catalogue the SingleCellExperiments a session can switch between

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,

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,

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
+}