Support for more connectivity similarity metrics

.Rbuildignore

@@ -7,3 +7,5 @@
 ^\.github$
 ^codecov\.yml$
 ^README\.Rmd$
+^samples$
+^\.claude$

.gitignore

@@ -4,3 +4,9 @@
 .Ruserdata
 docs
 inst/doc
+samples/
+tests/testthat/Rplots.pdf
+src/*.o
+src/*.so
+src/*.dll
+src/*.dylib

DESCRIPTION

@@ -13,15 +13,17 @@ Description: Provides data source agnostic utility functions to support
 License: GPL (>= 3)
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.3.2
-Imports: 
+RoxygenNote: 7.3.3
+Imports:
     bit64,
     checkmate,
     glue,
     Matrix (>= 1.5-3),
+    memoise,
+    methods,
     grDevices,
     stats
-Suggests: 
+Suggests:
     covr,
     spelling,
     testthat (>= 3.0.0),
@@ -33,6 +35,8 @@ Suggests:
     rmarkdown,
     dplyr,
     dendroextras
+Enhances: natcpp (>= 0.3.0)
+Remotes: natverse/natcpp@feature/weighted-jaccard
 Language: en-GB
 Config/testthat/edition: 3
 URL: https://github.com/natverse/coconat,

NAMESPACE

@@ -2,15 +2,21 @@
 
 export(add_cluster_info)
 export(colScaleM)
+export(connectivity_similarity)
 export(cosine_sim)
 export(dataset_names)
 export(geomScaleM)
 export(id2char)
+export(jaccard_sim)
 export(partner_summary2adjacency_matrix)
 export(prepare_cosine_matrix)
+export(prepare_similarity_matrix)
 export(register_dataset)
 export(rowScaleM)
+export(sim2dist)
+export(tanimoto_sim)
 importFrom(grDevices,hcl.colors)
+importFrom(methods,as)
 importFrom(stats,as.dist)
 importFrom(stats,hclust)
 importFrom(stats,heatmap)

R/cosine.R

@@ -7,9 +7,13 @@
 #' @param sparse Whether to return a sparse or dense matrix (default dense)
 #' @param transpose When \code{F} (the default) calculates the cosine distance
 #'   between columns. When \code{T} calculates the distance between rows.
+#' @param triangle If \code{TRUE}, return a \code{\link{dist}} object (lower
+#'   triangle only, half memory). Default \code{FALSE}.
+#' @param distance If \code{TRUE}, return distance (\code{1 - similarity})
+#'   instead of similarity. Default \code{FALSE}.
 #'
-#' @return A square matrix, dense unless \code{sparse=TRUE} and \code{x} is
-#'   sparse.
+#' @return A square matrix, or a \code{\link{dist}} object when
+#'   \code{triangle = TRUE}.
 #' @export
 #'
 #' @examples
@@ -24,31 +28,33 @@
 #' kckc.cos=cosine_sim(fam_pnkc2)
 #' pnpn.cos=cosine_sim(fam_pnkc2, transpose=T)
 #' }
-cosine_sim <- function(x, sparse=FALSE, transpose=FALSE) {
+cosine_sim <- function(x, sparse=FALSE, transpose=FALSE,
+                       triangle=FALSE, distance=FALSE) {
   cx=class(x)
   if(!is.matrix(x) && !isTRUE(attr(cx, "package") == "Matrix"))
     stop("I don't recognise that as a matrix!")
   cpx <- if(transpose) Matrix::tcrossprod(x) else Matrix::crossprod(x)
-  cosx=Matrix::cov2cor(cpx)
-  if(sparse) cosx else as.matrix(cosx)
+  sim=Matrix::cov2cor(cpx)
+  sim_to_output(sim, sparse=sparse, triangle=triangle, distance=distance)
 }
 
 
-#' Cosine matrix utility functions
+#' Prepare a similarity matrix from input/output connectivity
 #'
 #' @description These functions are intended for use by package authors rather
-#'   than end users.
+#'   than end users. \code{prepare_cosine_matrix} is an alias for
+#'   \code{prepare_similarity_matrix} retained for backwards compatibility.
 #'
 #' @param x A matrix or a named list of input/output matrices
 #' @param partners Whether to select input or output matrices when both are
 #'   available
-#' @param action Whether to zero out or drop any NA values in the cosine matrix
-#'   (these may be present when some columns have no entries)
+#' @param action Whether to zero out or drop any NA values in the similarity
+#'   matrix (these may be present when some columns have no entries)
 #'
 #' @return A matrix. When both inputs and outputs are used these will be
 #'   weighted by the total number of input and output synapses.
 #' @export
-prepare_cosine_matrix <- function(x, partners=c("inputs", "outputs"), action=c("zero", 'drop')) {
+prepare_similarity_matrix <- function(x, partners=c("inputs", "outputs"), action=c("zero", 'drop')) {
   x <- fix_nas(x, action=action)
   if(is.list(x)) {
     x <- if(length(partners)==2) {
@@ -63,6 +69,13 @@ prepare_cosine_matrix <- function(x, partners=c("inputs", "outputs"), action=c("
   x
 }
 
+#' @rdname prepare_similarity_matrix
+#' @usage prepare_cosine_matrix(x, partners = c("inputs", "outputs"), action = c("zero", "drop"))
+#' @export
+prepare_cosine_matrix <- function(x, partners=c("inputs", "outputs"), action=c("zero", 'drop')) {
+  prepare_similarity_matrix(x, partners=partners, action=action)
+}
+
 fix_nas <- function(x, action=c("zero", 'drop')) {
   action=match.arg(action)
   if(is.list(x)) {

R/heatmap.R

@@ -32,13 +32,14 @@ custom_interactive_heatmap <- function(hm) {
   shiny::shinyApp(ui, server)
 }
 
-# private function to draw a cosine heatmap using either the basic stats::heatmap
-# or InteractiveComplexHeatmap
+# private function to draw a connectivity heatmap using either the basic
+# stats::heatmap or InteractiveComplexHeatmap
 #
 #' @importFrom stats heatmap as.dist hclust
 #' @importFrom grDevices hcl.colors
-cosine_heatmap <- function(x, labRow=rownames(x), interactive=FALSE,
+connectivity_heatmap <- function(x, labRow=rownames(x), interactive=FALSE,
                            heatmap=TRUE, col=hcl.colors(12, "YlOrRd", rev = TRUE),
+                           distfun=function(x) as.dist(1-x),
                            method=c("ward.D", "single", "complete", "average",
                                     "mcquitty", "median", "centroid", "ward.D2"),
                                    ...) {
@@ -57,17 +58,19 @@ cosine_heatmap <- function(x, labRow=rownames(x), interactive=FALSE,
       x,
       row_labels=labRow,
       col=col,
-      cluster_rows=function(x,...) hclust(as.dist(1-x), method=method,...),
-      cluster_columns=function(x,...) hclust(as.dist(1-x), method=method,...),
+      cluster_rows=function(x,...) hclust(distfun(x), method=method,...),
+      cluster_columns=function(x,...) hclust(distfun(x), method=method,...),
       ...
     )
     custom_interactive_heatmap(hm)
   } else if(isTRUE(heatmap)) {
     FUN(x,
-        distfun = function(x) as.dist(1-x),
+        distfun = distfun,
         hclustfun = function(...) hclust(..., method=method),
         symm = T, keep.dendro = T, labRow=labRow, col=col, ...)
   } else {
-    hclust(as.dist(1-x), method = method, ...)
+    hclust(distfun(x), method = method, ...)
   }
 }
+
+cosine_heatmap <- connectivity_heatmap