Merge pull request #128 from natverse/feature/connection-table-threshold

Basic implementation and test for connection threshold
natverse · Aug 1, 2020 · bbb4ed3 · bbb4ed3
2 parents 7403d3c + 62945c9
commit bbb4ed3
Show file tree

Hide file tree

Showing 5 changed files with 42 additions and 6 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -39,12 +39,13 @@ Imports:
     bit64,
     stringr,
     tibble,
-    Matrix
+    Matrix,
+    checkmate
 Remotes: 
     natverse/drvid,
     natverse/nat
 Encoding: UTF-8
 Language: en-GB
-RoxygenNote: 7.1.0
+RoxygenNote: 7.1.1
 URL: https://github.com/natverse/neuprintr
 BugReports: https://github.com/natverse/neuprintr/issues
diff --git a/NAMESPACE b/NAMESPACE
@@ -37,6 +37,7 @@ export(neuprint_skeleton_connectivity_matrix)
 export(neuprint_version)
 export(progress_natprogress)
 importFrom(Matrix,sparseMatrix)
+importFrom(checkmate,assert_integer)
 importFrom(drvid,read.neuron.dvid)
 importFrom(httr,parse_url)
 importFrom(memoise,memoise)

diff --git a/R/connectivity.R b/R/connectivity.R
@@ -102,6 +102,9 @@ neuprint_get_adjacency_matrix <- function(bodyids=NULL, inputids=NULL,
 #'   \code{bodyids}
 #' @param by.roi logical, whether or not to break neurons' connectivity down by
 #'   region of interest (ROI)
+#' @param threshold Only return partners >= to an integer value. Default of 1
+#'   returns all partners. This threshold will be applied to the ROI weight when
+#'   the \code{roi} argument is specified, otherwise to the whole neuron.
 #' @param superLevel When \code{by.roi=TRUE}, should we look at low-level ROIs
 #'   (\code{superLevel=FALSE}) or only super-level ROIs
 #'   (\code{superLevel=TRUE}). A super-level ROIs can contain multiple
@@ -170,10 +173,12 @@ neuprint_get_adjacency_matrix <- function(bodyids=NULL, inputids=NULL,
 #'                                by.roi = TRUE, roi = "LH(R)")
 #'
 #' }
+#' @importFrom checkmate assert_integer
 neuprint_connection_table <- function(bodyids,
                                       prepost = c("PRE","POST"),
                                       roi = NULL,
                                       by.roi = FALSE,
+                                      threshold=1L,
                                       superLevel = FALSE,
                                       progress = FALSE,
                                       dataset = NULL,
@@ -185,6 +190,8 @@ neuprint_connection_table <- function(bodyids,
   conn<-neuprint_login(conn)
   bodyids <- neuprint_ids(bodyids, dataset = dataset, conn = conn)
 
+  threshold=assert_integer(as.integer(round(threshold)), lower = 1, len = 1)
+
   nP <- length(bodyids)
   if(is.numeric(chunk)) {
     chunksize=chunk
@@ -211,6 +218,7 @@ neuprint_connection_table <- function(bodyids,
       prepost = prepost,
       roi = roi,
       by.roi = by.roi,
+      threshold = threshold,
       progress = FALSE,
       dataset = dataset, conn = conn, ...),
       error = function(e) {warning(e); NULL})))
@@ -230,12 +238,14 @@ neuprint_connection_table <- function(bodyids,
                          "MATCH (a:`%s`)-[c:ConnectsTo]->(b:`%s`)",
                          "WHERE %s.bodyId=bodyId",
                          "%s",
+                         "%s",
                          "RETURN a.bodyId AS %s, b.bodyId AS %s, c.weight AS weight",
                          "%s"),
                    id2json(bodyids),
                    all_segments.json,
                    all_segments.json,
                    ifelse(prepost=="POST","a","b"),
+                   ifelse(threshold>1, paste("AND c.weight >= ", threshold), ""),
                    ifelse(!is.null(roi)|by.roi,"UNWIND keys(apoc.convert.fromJsonMap(c.roiInfo)) AS k",""),
                    ifelse(prepost=="POST","bodyid","partner"),
                    ifelse(prepost=="POST","partner","bodyid"),
@@ -252,13 +262,18 @@ neuprint_connection_table <- function(bodyids,
   if(!is.null(roi)){
     d <- d[d$roi%in%roi,]
   }
-  if(by.roi&is.null(roi)){
+  if(by.roi && is.null(roi)){
     rois <- neuprint_ROIs(superLevel = superLevel)
     d <- d[d$roi%in%rois,]
   }
   d <-  d[order(d$weight,decreasing=TRUE),]
   rownames(d) <- NULL
-  d[,sort(colnames(d))]
+  d=d[,sort(colnames(d))]
+
+  if(!is.null(roi) && threshold>1)
+    d=d[d$ROIweight>=threshold,]
+
+  d
 }
 
 #' @title Get the common synaptic partners for a set of neurons
@@ -555,7 +570,7 @@ neuprint_get_paths <- function(body_pre, body_post, n, weightT=5, roi=NULL, by.r
     connTable <- dplyr::bind_cols(connTable,roiTable)
   }
 
-  connTable
+  as.data.frame(connTable)
 }
 
 #' @title Get a list of the shortest paths between two neurons
@@ -628,7 +643,7 @@ neuprint_get_shortest_paths <- function(body_pre,body_post,weightT=5,roi=NULL,by
       all_segments=all_segments,
       ...),
       error = function(e) {warning(e); NULL})))
-    return(d)
+    return(as.data.frame(d))
   }
 
   all_segments.json <-  ifelse(all_segments,"Segment","Neuron")

diff --git a/man/neuprint_connection_table.Rd b/man/neuprint_connection_table.Rd
diff --git a/tests/testthat/test-connectivity.R b/tests/testthat/test-connectivity.R
@@ -8,6 +8,11 @@ test_that("neuprint_connection_table works", {
                                          progress = TRUE),
                t1)
 
+  # test that threshold works ok
+  expect_equal(
+    neuprint_connection_table(c(818983130, 1796818119),threshold = 2),
+    subset(t1, weight >= 2))
+
   expect_is(t2 <- neuprint_connection_table(c(818983130, 1796818119),
                                             prepost = "POST",
                                             by.roi = TRUE),
@@ -23,6 +28,15 @@ test_that("neuprint_connection_table works", {
             'data.frame')
   # equivalent so we don't worry about rownames
   expect_equivalent(subset(t2, roi=='LH(R)'), t3)
+  expect_equivalent(
+    neuprint_connection_table(
+      c(818983130, 1796818119),
+      prepost = "POST",
+      roi = "LH(R)",
+      threshold = 3
+    ),
+    subset(t3, ROIweight >= 3)
+  )
 })
 
 test_that("other connectivity functions work", {