Feature/flywire examples

.github/workflows/R-CMD-check.yaml

@@ -21,6 +21,7 @@ jobs:
       _R_CHECK_TESTS_NLINES_: 0
       NEUPRINT_TOKEN: ${{ secrets.NEUPRINT_TOKEN }}
       CLIO_TOKEN: ${{ secrets.CLIO_TOKEN }}
+      FLYWIRE_PRINCIPLES: IAGREETOTHEFLYWIREPRINCIPLES
 
     steps:
       - uses: actions/checkout@v2
@@ -53,9 +54,15 @@ jobs:
           remotes::install_cran("devtools")
         shell: Rscript {0}
 
-        # - uses: r-lib/actions/setup-r-dependencies@v1
-        # with:
-        #   extra-packages: rcmdcheck
+      - name: Add some R options for later steps
+        run: |
+          cat("\noptions(fafbseg.use_static_celltypes=TRUE)\n", file = "~/.Rprofile", append = TRUE)
+        shell: Rscript {0}
+
+      - name: Download flywire data
+        run: |
+          fafbseg::download_flywire_release_data()
+        shell: Rscript {0}
 
       - uses: r-lib/actions/check-r-package@v2
 

.gitignore

@@ -7,3 +7,4 @@
 samples/
 package-secrets.txt
 docs
+inst/doc

DESCRIPTION

@@ -38,7 +38,11 @@ Suggests:
     ComplexHeatmap,
     InteractiveComplexHeatmap,
     arrow,
-    cli
+    cli,
+    git2r,
+    knitr,
+    rmarkdown,
+    dendroextras
 Remotes: 
     flyconnectome/malevnc,
     flyconnectome/malecns,
@@ -56,3 +60,4 @@ URL: https://github.com/flyconnectome/coconatfly,
 BugReports: https://github.com/flyconnectome/coconatfly/issues
 Config/testthat/edition: 3
 biocViews: Software
+VignetteBuilder: knitr

NAMESPACE

@@ -11,6 +11,7 @@ export(cf_partners)
 export(keys)
 export(keys2df)
 export(keys2list)
+export(multi_connection_table)
 export(triple_cosine_plot)
 import(nat)
 importFrom(dplyr,all_of)

R/cosine.R

@@ -2,10 +2,8 @@
 # and turning them into a cosine matrix
 multi_cosine_matrix <- function(x, partners, nas, group='type') {
   if(is.data.frame(x)) {
-    if(length(partners)>1)
-      stop("If you provide a data.frame as input you must specify just one of inputs/outputs")
-    x=list(x)
-    names(x)=partners
+    x=split(x, x$partners)
+    partners=names(x)
   }
   # a bit of a shuffle because c(NULL, <integer64>) removes the class
   ids=unique(c(x$outputs$pre_key, x$inputs$post_key))
@@ -37,6 +35,35 @@ multi_cosine_matrix <- function(x, partners, nas, group='type') {
 }
 
 
+#' @importFrom dplyr distinct all_of
+#' @rdname cf_cosine_plot
+#' @export
+#' @return \code{multi_connection_table} returns a connectivity dataframe as
+#'   returned by \code{cf_partners} but with an additional column
+#'   \code{partners} which indicates (for each row) whether the partner neurons
+#'   are the input or output neurons.
+multi_connection_table <- function(ids, partners=c("inputs", "outputs"),
+                                   threshold=1L,
+                                   group='type') {
+  partners=match.arg(partners, several.ok = T)
+  if(length(partners)>1) {
+    l=sapply(partners, simplify = F, function(p)
+      multi_connection_table(ids, partners=p, threshold = threshold, group=group))
+    l=dplyr::bind_rows(l)
+    return(l)
+  }
+  x <- cf_partners(ids, 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
+  x
+}
+
+is.mct <- function(x) {
+  is.data.frame(x) && all(c("pre_id", "post_id", "dataset", "partners") %in% colnames(x))
+}
+
 #' Multi dataset cosine clustering
 #'
 #' @details \code{group=FALSE} only makes sense for single dataset clustering -
@@ -49,7 +76,7 @@ multi_cosine_matrix <- function(x, partners, nas, group='type') {
 #'   \code{group} can be set to other metadata columns such as \code{class} or
 #'   \code{hemilineage}, \code{serial} (serially homologous cell group) if
 #'   available. This can reveal other interesting features of organisation.
-#'
+#' @param ids Either a set of ids \emph{OR} a
 #' @param group The name or the grouping column for partner connectivity
 #'   (defaults to \code{"type"}) or a logical where \code{group=FALSE} means no
 #'   grouping (see details).
@@ -106,7 +133,67 @@ multi_cosine_matrix <- function(x, partners, nas, group='type') {
 #' # look at the results interactively
 #' cf_cosine_plot(cf_ids("/type:LAL.+"), interactive=TRUE)
 #' }
-cf_cosine_plot <- function(ids, ..., threshold=5,
+#'
+#' \donttest{
+#' # Show case examples of using multi_connection_table to allow
+#' # only a subset of partnets to be used for typing
+#' mct=multi_connection_table(cf_ids(hemibrain="/lLN2.+"), partners='in')
+#' cf_cosine_plot(mct)
+#' library(dplyr)
+#' mct2=mct %>% filter(!grepl("PN",type))
+#' cf_cosine_plot(mct2)
+#'
+#' mct3=cf_ids("/type:lLN2.+", datasets=c("hemibrain", "flywire")) %>%
+#'   multi_connection_table(., partners='in') %>%
+#'   mutate(class=case_when(
+#'    grepl("LN", type) ~ "LN",
+#'    grepl("RN", type) ~ "RN",
+#'    grepl("^M.*PN", type) ~ 'mPN',
+#'    grepl("PN", type) ~ 'uPN',
+#'    T ~ 'other'
+#'   )) %>%
+#'   # try merging connectivity for partners that don't have much specificity
+#'   mutate(type=case_when(
+#'   class=="RN" ~ sub("_.+", "", type),
+#'   class=="uPN" ~ 'uPN',
+#'   T ~ type
+#'   ))
+#' \dontrun{
+#' mct3%>%
+#'   # remove RN/uPN connectivity could also use the merged connectivity
+#'   filter(!class %in% c("RN", "uPN")) %>%
+#'   cf_cosine_plot(interactive=TRUE)
+#' }
+#'
+#' # This time focus in on a small number of query neurons
+#' mct3 %>%
+#'   mutate(query_key=ifelse(partners=='outputs', pre_key, post_key)) %>%
+#'   filter(query_key %in% cf_ids('/type:lLN2(T_[bde]|X08)', datasets = c("hemibrain", "flywire"), keys = T)) %>%
+#'   cf_cosine_plot()
+#' }
+#'
+#' # another worked example lLN1 neurons
+#' \donttest{
+#' lLN1=cf_ids("/type:lLN1_.+", datasets=c("hemibrain", "flywire")) %>%
+#'   multi_connection_table(., partners='in') %>%
+#'   mutate(class=case_when(
+#'    grepl("LN", type) ~ "LN",
+#'    grepl("RN", type) ~ "RN",
+#'    grepl("^M.*PN", type) ~ 'mPN',
+#'    grepl("PN", type) ~ 'uPN',
+#'    T ~ 'other'
+#'   )) %>%
+#'   mutate(type=case_when(
+#'   class=="RN" ~ sub("_.+", "", type),
+#'   class=="uPN" ~ 'uPN',
+#'   T ~ type
+#'   ))
+#'
+#' lLN1 %>%
+#'   filter(!class %in% c("RN", "uPN")) %>%
+#'   cf_cosine_plot()
+#' }
+cf_cosine_plot <- function(ids=NULL, ..., threshold=5,
                            partners = c("outputs", "inputs"),
                            labRow='{type}_{coconatfly::abbreviate_datasets(dataset)}{side}',
                            group='type',
@@ -118,7 +205,11 @@ cf_cosine_plot <- function(ids, ..., threshold=5,
                                     "mcquitty", "median", "centroid", "ward.D2")) {
   method=match.arg(method)
   partners=match.arg(partners, several.ok = T)
-  x=multi_connection_table(ids, partners = partners, threshold = threshold, group=group)
+  if(is.mct(ids)) {
+    x=ids
+    partners=unique(x$partners)
+  } else
+    x=multi_connection_table(ids, partners = partners, threshold = threshold, group=group)
 
   cm <- multi_cosine_matrix(x, partners = partners, group=group, nas=nas)
 

R/partners.R

@@ -116,31 +116,6 @@ match_types <- function(x, group, partners="", min_datasets=Inf) {
 }
 
 
-#' @importFrom dplyr distinct all_of
-multi_connection_table <- function(ids, partners=c("inputs", "outputs"),
-                                    threshold=1L, version=NULL,
-                                    group='type') {
-  partners=match.arg(partners, several.ok = T)
-  if(length(partners)>1) {
-    l=sapply(partners, simplify = F, function(p)
-      multi_connection_table(ids, partners=p, threshold = threshold, group=group))
-    return(l)
-  }
-  x <- cf_partners(ids, threshold = threshold, partners = partners)
-  if(is.character(group))
-    x <- match_types(x, group, partners=partners)
-  # now we need to recover query ids; in our current design we don't know this
-  # for certain as we rely on downstream functions to process queries like "DA2_lPN"
-  querycol=ifelse(partners=='inputs', 'post_id', 'pre_id')
-  qx=x %>%
-    select(all_of(querycol), dataset) %>%
-    rename_with(~sub(".+_", "", .x)) %>%
-    # mutate(id=as.character(id)) %>%
-    distinct(id, dataset)
-  attr(x, 'queryids')=qx
-  x
-}
-
 connection_table2queryids <- function(x) {
   if(is.data.frame(x)) {
     qx=attr(x, 'queryids')

tests/testthat/test-triple.R

@@ -1,9 +1,10 @@
 test_that("triple_cosine_plot works", {
   fcdv <- try(fafbseg::flywire_connectome_data_version(), silent = T)
   testthat::skip_if(inherits(fcdv, "try-error"))
+  testthat::skip_on_ci()
 
   expect_s3_class(
-    hc <- triple_cosine_plot('AOTU063', partners = 'o', heatmap = F),
+    hc <- triple_cosine_plot('/type:AOTU063.*', partners = 'o', heatmap = F),
             'hclust')
 
   bl=list(labels = c("hb:800929667", "hb:791039731", "fw:720575940620326253",

vignettes/.gitignore

@@ -0,0 +1,2 @@
+*.html
+*.R