Merge pull request #26 from natverse/feature/cosine-plot-warn-on-drop

R/cosine.R

@@ -281,6 +281,8 @@ cf_cosine_plot <- function(ids=NULL, ..., threshold=5,
 
 
 #' @importFrom dplyr distinct all_of
+#' @param check_missing Whether to report if any query neurons are dropped (due
+#'   to insufficient partner neurons) (default:\code{TRUE}).
 #' @rdname cf_cosine_plot
 #' @export
 #' @return \code{multi_connection_table} returns a connectivity dataframe as
@@ -289,19 +291,46 @@ cf_cosine_plot <- function(ids=NULL, ..., threshold=5,
 #'   are the input or output neurons.
 multi_connection_table <- function(ids, partners=c("inputs", "outputs"),
                                    threshold=1L,
-                                   group='type') {
+                                   group='type', check_missing=TRUE) {
   partners=match.arg(partners, several.ok = T)
   if(length(partners)>1) {
+    kk=keys(ids)
     l=sapply(partners, simplify = F, function(p)
-      multi_connection_table(ids, partners=p, threshold = threshold, group=group))
+      multi_connection_table(kk, partners=p, threshold = threshold, group=group,
+                             check_missing=F))
     l=dplyr::bind_rows(l)
+    if(check_missing) {
+      query_keys <- l %>% group_by(partners) %>%
+        mutate(query=case_when(
+          partners=='inputs' ~ post_key,
+          partners=='outputs' ~ pre_key,
+        )) %>%
+        pull(query)
+      missing_keys=setdiff(unique(kk), query_keys)
+      nmissing=length(missing_keys)
+      if(nmissing>0)
+        warning("Dropping ", nmissing, " keys. Try decreasing threshold!")
+    }
+
     return(l)
   }
-  x <- cf_partners(ids, threshold = threshold, partners = partners)
+  kk=keys(ids)
+  x <- cf_partners(kk, threshold = threshold, partners = partners)
   if(is.character(group))
     x <- match_types(x, group, partners=partners)
   # mark which column was used for the query
   x$partners=partners
+  # check if some incoming ids were dropped
+  if(check_missing) {
+    missing_keys <- if(partners=='inputs') {
+      setdiff(unique(kk), x$post_key)
+    } else {
+      setdiff(unique(kk), x$pre_key)
+    }
+    nmissing=length(missing_keys)
+    if(nmissing>0)
+      warning("Dropping ",nmissing, " keys. Try decreasing threshold!")
+  }
   x
 }
 

R/ids.R

@@ -55,6 +55,9 @@ extract_ids <- function(x) {
 #'
 #' \donttest{
 #' keys(cf_ids(hemibrain=12345, flywire='4611686018427387904'))
+#'
+#' # NB this runs the query for hemibrain type MBON01 and then maps ids -> keys
+#' keys(cf_ids(hemibrain='MBON01'))
 #' }
 #' @rdname keys
 keys <- function(x, idcol='id') {
@@ -63,6 +66,9 @@ keys <- function(x, idcol='id') {
   else if(inherits(x, 'dendrogram'))
     x <- labels(x)
 
+  # expand an id list
+  if(inherits(x, 'cidlist'))
+    x=c(x,NULL)
   if(is.list(x) && !is.data.frame(x)) {
     x=data.frame(id=unlist(x),
                  dataset=rep(abbreviate_datasets(names(x)), lengths(x)))

tests/testthat/test-ids.R

@@ -37,13 +37,15 @@ test_that("key handling works", {
          flywire=as.character(1:5)))
 
   expect_output(print(res), regexp = 'flywire.*hemibrain')
+
+  expect_equal(keys(cf_ids(hemibrain = '/MBON01')), cf_ids(hemibrain = '/MBON01', keys = T))
 })
 
 test_that("fanc/banc ids/metadata", {
   skip_if_not_installed('fancr')
   skip_if_not_installed('reticulate')
   expect_in(
-    cf_ids(fanc='/type:DNa01', expand = TRUE)$fanc,
+    suppressWarnings(cf_ids(fanc='/type:DNa01', expand = TRUE)$fanc),
     fancr::fanc_latestid(c("648518346488820970", "648518346475464576"),
                          version='latest'))