Updated methods for getting BANC meta data

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: coconatfly
 Type: Package
 Title: Comparative Connectomics of Public and In Progress Drosophila Datasets
-Version: 0.2.4.9000
+Version: 0.2.5.0
 Authors@R:
     c(person(given = "Gregory",
            family = "Jefferis",
@@ -32,11 +32,13 @@ Imports:
     bit64,
     usethis,
     methods,
-    withr
+    withr,
+    memoise
 Suggests: 
     malevnc (> 0.3.1),
     fancr (>= 0.5.0),
     testthat (>= 3.0.0),
+    bancr,
     ComplexHeatmap,
     InteractiveComplexHeatmap,
     arrow,
@@ -52,6 +54,7 @@ Enhances:
 Remotes: 
     flyconnectome/malevnc,
     flyconnectome/fancr,
+    flyconnectome/bancr,
     natverse/fafbseg,
     natverse/nat,
     natverse/nat.templatebrains,

NAMESPACE

@@ -4,6 +4,8 @@ S3method(c,cidlist)
 S3method(print,cidlist)
 export("%>%")
 export(abbreviate_datasets)
+export(banc_meta)
+export(banc_meta_create_cache)
 export(cf_cosine_plot)
 export(cf_ids)
 export(cf_meta)

R/cosine.R

@@ -229,7 +229,9 @@ multi_cosine_matrix <- function(x, partners, nas, group='type') {
 #'   filter(!class %in% c("RN", "uPN")) %>%
 #'   cf_cosine_plot()
 #' }
-cf_cosine_plot <- function(ids=NULL, ..., threshold=5,
+cf_cosine_plot <- function(ids=NULL,
+                           ...,
+                           threshold=5,
                            partners = c("outputs", "inputs"),
                            labRow='{type}_{coconatfly::abbreviate_datasets(dataset)}{side}',
                            group='type',
@@ -248,12 +250,12 @@ cf_cosine_plot <- function(ids=NULL, ..., threshold=5,
     x=ids
     partners=unique(x$partners)
   } else
-    x=multi_connection_table(ids, partners = partners, threshold = threshold, group=group, min_datasets = min_datasets)
+    x=multi_connection_table(ids, partners = partners, threshold = threshold, group=group, min_datasets = min_datasets, ...)
 
   cm <- multi_cosine_matrix(x, partners = partners, group=group, nas=nas)
 
   if(is.character(labRow) && length(labRow)==1 && any(grepl("\\{", labRow))) {
-    tm=cf_meta(colnames(cm), keep.all = keep.all.meta)
+    tm=cf_meta(colnames(cm), keep.all = keep.all.meta, ...)
     labRow <- glue::glue_data(labRow, .x = tm)
   } else if(is.character(labRow)) {
     # user has supplied labels but they are unlikely to be in the correct order
@@ -309,7 +311,8 @@ cf_cosine_plot <- function(ids=NULL, ..., threshold=5,
 multi_connection_table <- function(ids, partners=c("inputs", "outputs"),
                                    threshold=1L, group='type',
                                    check_missing=TRUE,
-                                   min_datasets=Inf
+                                   min_datasets=Inf,
+                                   ...
                                    ) {
   if(isTRUE(group))
     group='type'
@@ -318,7 +321,7 @@ multi_connection_table <- function(ids, partners=c("inputs", "outputs"),
   if(length(partners)>1) {
     l=sapply(partners, simplify = F, function(p)
       multi_connection_table(kk, partners=p, threshold = threshold, group=group,
-                             check_missing=F, min_datasets = min_datasets))
+                             check_missing=F, min_datasets = min_datasets, ...))
     l=dplyr::bind_rows(l)
     if(check_missing) {
       query_keys <- l %>% group_by(partners) %>%

R/ids.R

@@ -189,7 +189,8 @@ cf_ids <- function(
     expand=FALSE,
     keys=FALSE,
     hemibrain=NULL, flywire=NULL, malecns=NULL, manc=NULL, fanc=NULL,
-    opticlobe=NULL, banc=NULL, yakubavnc=NULL, ...) {
+    opticlobe=NULL, banc=NULL, yakubavnc=NULL,
+    ...) {
 
   mc=match.call()
   cand_datasets=setdiff(names(mc), c("query", "datasets", "expand", "keys", ""))

R/meta.R

@@ -220,11 +220,158 @@ fanc_meta <- function(ids=NULL, ...) {
   fancr::with_fanc(fancorbanc_meta(table='neuron_information', ids=ids, ...))
 }
 
-banc_meta <- function(ids=NULL, ...) {
-  ids=banc_ids(ids)
-  fancr::with_banc(fancorbanc_meta(table='cell_info', ids=ids, ...))
-}
+#' Create or refresh cache of BANC meta information
+#'
+#' @description
+#' `banc_meta_create_cache()` builds or refreshes an in-memory cache of BANC metadata
+#' for efficient repeated lookups. You can choose the data source using `use_seatable`.
+#' The main accessor function [banc_meta()] will always use the most recently created cache.
+#'
+#' @details
+#' BANC meta queries can be slow; caching avoids repeated computation/database access.
+#' Whenever labels are updated, simply rerun this function to update the cache.
+#'
+#' @param use_seatable Whether to build BANC meta data from the `codex_annotations` CAVE table
+#' (production) or our internal seatable (development). Both require different types of authenticated
+#' access, for details see `bancr` documentation.
+#' @param return Logical; if `TRUE`, return the cache tibble/invisible.
+#'
+#' @return Invisibly returns the cache (data.frame) if `return=TRUE`; otherwise invisibly `NULL`.
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' #' # Requires authenticated access to BANC CAVE
+#' banc_meta_cache(use_seatable=FALSE)
+#'
+#' banc_meta_create_cache(use_seatable=TRUE) # create cache
+#' ## BANCTABLE_TOKEN must be set, see bancr package
+#' result <- banc_meta() # use cache
+#'
+#' # use cache to quickly make plot
+#' cf_cosine_plot(cf_ids('/type:LAL0(08|09|10|42)', datasets = c("banc", "hemibrain")))
+#' }
+banc_meta_create_cache <- NULL # Placeholder, assigned below
+
+#' Query cached BANC meta data
+#'
+#' @description
+#' Returns results from the in-memory cache, filtered by `ids` if given.
+#' Cache must be created first using [banc_meta_create_cache()].
+#'
+#' @details
+#' `banc_meta()` never queries databases directly.
+#' If `ids` are given, filters the meta table by root_id.
+#'
+#' @param ids Vector of neuron/root IDs to select, or `NULL` for all.
+#' @return tibble/data.frame, possibly filtered by ids.
+#' @export
+#' @seealso [banc_meta_create_cache()]
+#'
+#' @examples
+#' \dontrun{
+#' banc_meta_create_cache() # build the cache
+#' all_meta <- banc_meta()  # retrieve all
+#' }
+banc_meta <- NULL # Placeholder, assigned below
+
+# hidden
+banc_meta <- local({
+  .banc_meta_cache <- NULL
+
+  .refresh_cache <- function(use_seatable=FALSE) {
+    if (use_seatable) {
+      # Read from seatable
+      banc.meta <- bancr::banctable_query(
+        "SELECT root_id, side, cell_type, cell_class, cell_sub_class from banc_meta"
+      )
+      banc.meta %>%
+        dplyr::rename(
+          id = root_id,
+          class = cell_class,
+          type = cell_type,
+          side = side,
+          subclass = cell_sub_class
+        ) %>%
+        dplyr::mutate(id = as.character(id))
+    } else {
+      banc.community.meta <- bancr::banc_cell_info() %>%
+        dplyr::filter(valid == 't') %>%
+        dplyr::arrange(pt_root_id, tag) %>%
+        dplyr::distinct(pt_root_id, tag2, tag, .keep_all = TRUE) %>%
+        dplyr::group_by(pt_root_id, tag2) %>%
+        dplyr::summarise(
+          tag = {
+            if (length(tag) > 1 && any(grepl("?", tag, fixed = TRUE))) {
+              usx = unique(sub("?", "", tag, fixed = TRUE))
+              if (length(usx) < length(tag)) tag = usx
+            }
+            paste0(tag, collapse = ";")
+          },
+          .groups = 'drop'
+        ) %>%
+        tidyr::pivot_wider(
+          id_cols = pt_root_id,
+          names_from = tag2,
+          values_from = tag,
+          values_fill = ""
+        ) %>%
+        dplyr::select(
+          id = pt_root_id,
+          class = `primary class`,
+          type = `neuron identity`,
+          side = `soma side`,
+          subclass = `anterior-posterior projection pattern`
+        ) %>%
+        dplyr::mutate(class = gsub(" ","_", class))
+
+      banc.codex.meta <- bancr::banc_codex_annotations() %>%
+        dplyr::distinct(pt_root_id, .keep_all = TRUE) %>%
+        dplyr::select(
+          id = pt_root_id,
+          class = cell_class,
+          type = cell_type,
+          side = side,
+          subclass = cell_sub_class
+        )
+
+      rbind(
+        banc.codex.meta,
+        banc.community.meta
+      ) %>%
+        dplyr::distinct(id, .keep_all = TRUE) %>%
+        dplyr::mutate(id = as.character(id))
+    }
+  }
+
+  list(
+    create_cache = function(use_seatable=FALSE, return = FALSE) {
+      meta <- .refresh_cache(use_seatable=use_seatable)
+      .banc_meta_cache <<- meta
+      if (return) meta else invisible()
+    },
+    get_meta = function(ids = NULL) {
+      if (is.null(.banc_meta_cache)){
+        warning("No BANC meta cache loaded. Creating with banc_meta_create_cache(use_seatable=FALSE)")
+        banc_meta_create_cache(use_seatable=FALSE)
+      }
+      meta <- .banc_meta_cache
+      if (!is.null(ids)) {
+        ids <- extract_ids(unname(unlist(ids)))
+        ids <- tryCatch(banc_ids(ids), error = function(e) NULL)
+        meta %>% dplyr::filter(id %in% ids)
+      } else {
+        meta
+      }
+    }
+  )
+})
+
+# Exported user-friendly functions
+banc_meta_create_cache <- banc_meta$create_cache
+banc_meta <- banc_meta$get_meta
 
+# now for FANC meta mainly, but could switch back
 fancorbanc_meta <- function(table, ids=NULL, ...) {
   ol_classes=c("centrifugal", "distal medulla", "distal medulla dorsal rim area",
                "lamina intrinsic", "lamina monopolar", "lamina tangential",
@@ -308,51 +455,76 @@ fancorbanc_meta <- function(table, ids=NULL, ...) {
     metadf
 }
 
-banc_ids <- function(ids) {
-  fancorbanc_ids(ids, dataset='banc')
-}
-
-fanc_ids <- function(ids) {
-  fancorbanc_ids(ids, dataset='fanc')
+# hidden
+banc_ids <- function(ids=NULL) {
+  if(is.null(ids)) return(NULL)
+  # extract numeric ids if possible
+  ids <- extract_ids(ids)
+  if(is.character(ids) && length(ids)==1 && !fafbseg:::valid_id(ids)) {
+    # query
+    metadf=banc_meta()
+    if(isTRUE(ids=='all')) return(bancr::banc_ids(metadf$id, integer64 = F))
+    if(isTRUE(ids=='neurons')) {
+      ids <- metadf %>%
+        filter(is.na(class) | class!='glia') %>%
+        pull(id)
+      return(bancr::banc_ids(ids, integer64 = F))
+    }
+    if(isTRUE(substr(ids, 1, 1)=="/"))
+      ids=substr(ids, 2, nchar(ids))
+    else warning("All BANC queries are regex queries. ",
+                 "Use an initial / to suppress this warning!")
+    if(!grepl(":", ids)) ids=paste0("type:", ids)
+    qsplit=stringr::str_match(ids, pattern = '[/]{0,1}(.+):(.+)')
+    field=qsplit[,2]
+    value=qsplit[,3]
+    if(!field %in% colnames(metadf)) {
+      stop(glue("BANC queries only work with these fields: ",
+                paste(colnames(metadf)[-1], collapse = ',')))
+    }
+    ids <- metadf %>%
+      filter(grepl(value, .data[[field]])) %>%
+      pull(id)
+  } else if(length(ids)>0) {
+    # check they are valid for current materialisation
+    bancr::banc_latestid(ids, version = banc_version())
+  }
+  return(bancr::banc_ids(ids, integer64 = F))
 }
 
 #' @importFrom dplyr pull
-fancorbanc_ids <- function(ids, dataset=c("banc", "fanc")) {
+fanc_ids <- function(ids) {
   if(is.null(ids)) return(NULL)
-  dataset=match.arg(dataset)
   # extract numeric ids if possible
   ids <- extract_ids(ids)
   if(is.character(ids) && length(ids)==1 && !fafbseg:::valid_id(ids)) {
     # query
-    metadf=if(dataset=="banc") banc_meta() else fanc_meta()
+    metadf=fanc_meta()
     if(isTRUE(ids=='all')) return(fancr::fanc_ids(metadf$id, integer64 = F))
     if(isTRUE(ids=='neurons')) {
       ids <- metadf %>%
-        filter(is.na(.data$class) | .data$class!='glia') %>%
-        pull(.data$id)
+        filter(is.na(class) | class!='glia') %>%
+        pull(id)
       return(fancr::fanc_ids(ids, integer64 = F))
     }
     if(isTRUE(substr(ids, 1, 1)=="/"))
       ids=substr(ids, 2, nchar(ids))
-    else warning("All FANC/BANC queries are regex queries. ",
+    else warning("All FANC queries are regex queries. ",
               "Use an initial / to suppress this warning!")
     if(!grepl(":", ids)) ids=paste0("type:", ids)
     qsplit=stringr::str_match(ids, pattern = '[/]{0,1}(.+):(.+)')
     field=qsplit[,2]
     value=qsplit[,3]
     if(!field %in% colnames(metadf)) {
-      stop(glue("{dataset} queries only work with these fields: ",
+      stop(glue("FANC queries only work with these fields: ",
            paste(colnames(metadf)[-1], collapse = ',')))
     }
     ids <- metadf %>%
       filter(grepl(value, .data[[field]])) %>%
-      pull(.data$id)
+      pull(id)
   } else if(length(ids)>0) {
     # check they are valid for current materialisation
-    ids <- if(dataset=="banc")
-      fancr::with_banc(fafbseg::flywire_latestid(ids, version = banc_version()))
-    else
-      fancr::with_fanc(fafbseg::flywire_latestid(ids, version = fanc_version()))
+    fancr::with_fanc(fafbseg::flywire_latestid(ids, version = fanc_version()))
   }
   return(fancr::fanc_ids(ids, integer64 = F))
 }

R/partners.R

@@ -188,13 +188,20 @@ cf_partners <- function(ids, threshold=1L, partners=c("inputs", "outputs"),
   tres
 }
 
-.banc_partners <- function(ids, partners, threshold, ...) {
-  # FIXME allow end user to override fanc version
-  tres=fancr::with_banc(fancr::fanc_partner_summary(banc_ids(ids),
+.banc_partners <- function(ids,
+                           partners,
+                           threshold,
+                           version=banc_version(),
+                           ...) {
+  tres=bancr::banc_partner_summary(banc_ids(ids),
                                    partners = partners,
                                    threshold = threshold-1L,
-                                   version=banc_version(), ...))
+                                   version=version,
+                                   ...)
   partner_col=grep("_id", colnames(tres), value = T)
+  for(pc in partner_col){
+    tres[[pc]] <- as.character(tres[[pc]])
+  }
   metadf=banc_meta()
   colnames(metadf)[[1]]=partner_col
   tres=left_join(tres, metadf, by = partner_col)

coconatfly.Rproj

@@ -1,5 +1,4 @@
 Version: 1.0
-ProjectId: 947d153c-3cd6-4655-be24-b4d1718ef499
 
 RestoreWorkspace: Default
 SaveWorkspace: Default