Merge pull request #172 from natverse/feature/superclass

.gitignore

@@ -7,3 +7,4 @@ samples
 inst/doc
 flywire_skeletons/
 .DS_Store
+*cache/

DESCRIPTION

@@ -94,4 +94,4 @@ Remotes:
 Encoding: UTF-8
 Language: en-GB
 LazyData: true
-RoxygenNote: 7.2.2
+RoxygenNote: 7.2.3

NAMESPACE

@@ -58,6 +58,7 @@ export(flytable_columns)
 export(flytable_list_rows)
 export(flytable_list_selected)
 export(flytable_login)
+export(flytable_meta)
 export(flytable_nrow)
 export(flytable_query)
 export(flytable_set_token)
@@ -143,6 +144,7 @@ importFrom(checkmate,assert_number)
 importFrom(curl,curl_download)
 importFrom(dplyr,.data)
 importFrom(dplyr,across)
+importFrom(dplyr,all_of)
 importFrom(dplyr,arrange)
 importFrom(dplyr,collect)
 importFrom(dplyr,desc)

R/autosyn.R

@@ -631,7 +631,7 @@ flywire_ntpred <- function(x,
 
     x = ntpredictions %>%
       dplyr::inner_join(x, copy = TRUE, by=c("id"="offset")) %>%
-      dplyr::rename(offset=.data$id)
+      dplyr::rename(offset="id")
   }
 
   if(!all(extracols %in% colnames(x))) {
@@ -874,6 +874,7 @@ flywire_neurons_add_synapses <- function(x,
 
 #' @export
 #' @rdname flywire_neurons_add_synapses
+#' @importFrom dplyr all_of
 flywire_neurons_add_synapses.neuron <- function(x,
                                                 connectors = NULL,
                                                 cloudvolume.url=NULL,
@@ -919,7 +920,7 @@ flywire_neurons_add_synapses.neuron <- function(x,
       dplyr::mutate(y = ifelse(.data$prepost, .data$post_y, .data$pre_y)) %>%
       dplyr::mutate(z = ifelse(.data$prepost, .data$post_z, .data$pre_z)) %>%
       dplyr::arrange(.data$offset) %>%
-      dplyr::select(wanted) %>%
+      dplyr::select(all_of(wanted)) %>%
       as.data.frame() ->
       synapses.xyz
     rownames(synapses.xyz) = synapses.xyz$offset

R/flytable.R

@@ -863,12 +863,15 @@ flytable_list_selected <- function(ids=NULL, table='info', fields="*", idfield="
   } else fq
 }
 
-cell_types_memo <- memoise::memoise(function(query="_%", timestamp=NULL,
+cell_types_memo <- memoise::memoise(function(query=NULL, timestamp=NULL,
                                              target='type',
-  fields=c("root_id", "supervoxel_id", "side", "cell_class", "cell_type", "ito_lee_hemilineage", "hemibrain_type", "hemibrain_match", "vfb_id")) {
+  fields=c("root_id", "supervoxel_id", "side", "flow", "super_class", "cell_class", "cell_type", "ito_lee_hemilineage", "hemibrain_type", "hemibrain_match", "vfb_id")) {
+  if(is.null(query))
+    query="_%"
+
   likeline=switch (target,
     type = sprintf('((cell_type LIKE "%s") OR (hemibrain_type LIKE "%s"))',query,query),
-    all = sprintf('((cell_type LIKE "%s") OR (hemibrain_type LIKE "%s") OR (cell_class LIKE "%s"))',query, query, query),
+    all = sprintf('((cell_type LIKE "%s") OR (hemibrain_type LIKE "%s") OR (cell_class LIKE "%s") OR (super_class LIKE "%s"))',query, query, query, query),
     sprintf('(%s LIKE "%s")',target, query)
   )
   fields=paste(fields, collapse = ',')
@@ -945,7 +948,7 @@ cell_types_memo <- memoise::memoise(function(query="_%", timestamp=NULL,
 #' pncands=flytable_cell_types('%PN%', target = 'all')
 #' }
 flytable_cell_types <- function(pattern=NULL, version=NULL, timestamp=NULL,
-  target=c("type", "cell_type", 'hemibrain_type', 'cell_class', 'all'),
+  target=c("type", "cell_type", 'hemibrain_type', 'cell_class', 'super_class', 'all'),
   transfer_hemibrain_type=c("extra", "none", "all"),
   cache=TRUE) {
 
@@ -969,7 +972,16 @@ flytable_cell_types <- function(pattern=NULL, version=NULL, timestamp=NULL,
     pattern=mres[,2]
     side=switch(mres[,3], L='left', R="right", stop("side problem in flytable_cell_types!"))
   }
-
+  if(isTRUE(substr(pattern,1,1)=="/")) {
+    smres=stringr::str_match(pattern, '/([^:]*):(.+)')
+    if(is.na(smres[,1]))
+       stop("Malformed regex query:`", pattern,"`! Should look like `/<field>:<regex`")
+    regex=smres[,3]
+    regex_target=match.arg(smres[,2],
+      c("type", "cell_type", 'hemibrain_type', 'cell_class', 'super_class', 'all'))
+    pattern=NULL
+    target='all'
+  } else regex=NULL
   ct=cell_types_memo(pattern, timestamp=timestamp, target=target)
   if(is.null(ct))
     stop("Error running flytable query likely due to connection timeout (restart R) or syntax error.")
@@ -986,12 +998,23 @@ flytable_cell_types <- function(pattern=NULL, version=NULL, timestamp=NULL,
       toupdate= toupdate & (is.na(ct$cell_type) | nchar(ct$cell_type)==0)
     ct$cell_type[toupdate]=ct$hemibrain_type[toupdate]
   }
+  if(!is.null(regex)) {
+    if(regex_target=='type')
+      regex_target='cell_type'
+    else if(regex_target=='all')
+      stop("target='all' is not supported with regular expressions!")
+    ct=ct[grepl(regex, ct[[regex_target]]), ]
+    # original rownames will only confuse
+    rownames(ct)=NULL
+  }
   ct
 }
 
 
-#' Add flytable cell type information to a dataframe with flywire ids
+#' Fetch flytable cell type information to a dataframe with flywire ids
 #'
+#' @description \code{add_celltype_info} will add information to an existing
+#'   dataframe.
 #' @details the root ids must be in a column called one of \code{"pre_id",
 #'   "post_id", "root_id", "post_pt_root_id", "pre_pt_root_id"}. If you do not
 #'   have exactly one of these columns present then you must specify your
@@ -1053,3 +1076,22 @@ add_celltype_info <- function(x, idcol=NULL, version=NULL, ...) {
   names(byexp)=idcol
   dplyr::left_join(x, ct, by=byexp)
 }
+
+#' @description \code{flytable_meta} will fetch a data.frame of metadata from
+#'   flytable for a given set of identifiers.
+#' @param ids Flywire identifiers/query in any form understood by
+#'   \code{\link{flywire_ids}}
+#' @export
+#' @rdname add_celltype_info
+#' @examples
+#' \donttest{
+#' flytable_meta("class:MBON")
+#' flytable_meta("type:MBON2%")
+#' # the / introduces a regex query (small performance penalty, more flexible)
+#' flytable_meta("/type:MBON2[0-5]")
+#' }
+flytable_meta <- function(ids, version=NULL, ...) {
+  ids=flywire_ids(ids, version = version, ...)
+  df=data.frame(root_id=ids)
+  add_celltype_info(df, version=version, ...)
+}

R/flywire-arrow.R

@@ -181,11 +181,11 @@ flywire_partner_summary2 <- function(ids, partners=c("outputs", "inputs"),
 
   syn2 <- if(by.roi && summarise) {
     # collapse query but leave neuropil info intact
-    syn2 %>% group_by(across(c(partner_col, "neuropil"))) %>%
+    syn2 %>% group_by(across(all_of(c(partner_col, "neuropil")))) %>%
       summarise(weight = sum(weight), n=n_distinct(.data[[query_col]]))
   } else if(!by.roi && summarise) {
     # collapse query and neuropil info
-    syn2 %>% group_by(across(partner_col)) %>%
+    syn2 %>% group_by(across(all_of(partner_col))) %>%
       summarise(weight = sum(weight), n=n_distinct(.data[[query_col]]),
                 top_np = neuropil[1])
   } else if(!by.roi && !summarise) {

R/flywire-urls.R

@@ -215,8 +215,13 @@ flywire_scene <- function(ids=NULL, annotations=NULL, open=FALSE, shorten=FALSE,
 #' # using SQL wild cards
 #' flywire_ids("DA[12]_%PN_L")
 #'
+#' # all sensory neurons
+#' flywire_ids("super:sensory", integer64=TRUE)
+#'
 #' # note that side is defined by soma position (not arbour side)
 #' flywire_ids("class:MBON_R", integer64=TRUE)
+#' # superclass can also have a side specified
+#' flywire_ids("super:motor_R", integer64=TRUE)
 flywire_ids <- function(x, integer64=FALSE, check_latest=FALSE, must_work=FALSE,
                         na_ok=FALSE, unique=FALSE, version=NULL, ...) {
   if(is.data.frame(x)) {
@@ -234,8 +239,8 @@ flywire_ids <- function(x, integer64=FALSE, check_latest=FALSE, must_work=FALSE,
   } else if(is.character(x) && length(x)==1 && !valid_id(x, na.ok = T) && !grepl("http", x)) {
     # looks like a query
     target='type'
-    if(grepl("^[a-z]+:", x)) {
-      okfields=c('cell_type', 'cell_class', 'hemibrain_type', 'class')
+    if(grepl("^[a-z_]+:", x)) {
+      okfields=c('type', 'cell_type', 'cell_class', 'hemibrain_type', 'class', "super_class", "super")
       ul=unlist(strsplit(x, ":", fixed=T))
       if(length(ul)!=2)
         stop("Unable to parse flywire id specification!")
@@ -244,6 +249,8 @@ flywire_ids <- function(x, integer64=FALSE, check_latest=FALSE, must_work=FALSE,
         stop("Unknown field in flywire id specification!")
       if(target=='class')
         target='cell_class'
+      if(target=='super')
+        target='super_class'
       x=ul[2]
     }
     res=flytable_cell_types(pattern=x, target = target, version=version, ...)

tests/testthat/test-flytable.R

@@ -11,6 +11,15 @@ test_that("query works", {
 
   # queries fly table for cell types
   expect_equal(flywire_ids('DL4_adPN_R', version=401), "720575940627708688")
+  expect_equal(flywire_ids('DL4_adPN_R', version=401), "720575940627708688")
+  expect_true(length(flywire_ids('class:MBON', integer64 = T))>90)
+
+  expect_equal(mbon0x <- flytable_cell_types('MBON0%'),
+               flytable_cell_types('/type:MBON0[1-9]'))
+  expect_equal(flytable_meta(mbon0x), mbon0x)
+  expect_true(length(flywire_ids('super:sensory', integer64 = T))>1000)
+  expect_error(flywire_ids('pudding:sensory'))
+
 
   expect_s3_class(df <- flytable_query("select fruit_name, person, _ctime, date_wminute FROM testfruit WHERE nid<=3", limit=3L),
                   'data.frame')