Control over VisualizeMatching() (#125)

Co-authored-by: Ammar Aziz <[email protected]>

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: TreeDist
 Type: Package
 Title: Calculate and Map Distances Between Phylogenetic Trees
-Version: 2.8.0.9000
+Version: 2.8.0.9001
 Authors@R: c(person("Martin R.", "Smith",
                     email = "[email protected]", 
                     role = c("aut", "cre", "cph", "prg"), 

NEWS.md

@@ -1,5 +1,7 @@
-# TreeDist 2.8.0.9000 (development)
+# TreeDist 2.8.0.9001 (development)
 
+- `VisualizeMatching()` allows more control over output format, and returns
+  the matching ([#124](https://github.com/ms609/TreeDist/issues/124))
 - `SpectralEigens()` returns correct eigenvalues (smallest was overlooked)
 - `SpectralEigens()` handles values of `nEig` larger than the input
 

R/VisualizeMatching.R

@@ -1,4 +1,4 @@
-#' Visualise a matching
+#' Visualize a matching
 #' 
 #' Depict the splits that are matched between two trees using a specified 
 #' [Generalized Robinson–Foulds](
@@ -23,28 +23,43 @@
 #' @param plainEdges Logical specifying whether to plot edges with a uniform
 #' width and colour (`TRUE`), or whether to draw edge widths according to the
 #' similarity of the associated splits (`FALSE`).
+#' @param edge.cex Character expansion for edge labels.
+#' If `FALSE`, suppress edge labels.
+#' @param value.cex Character expansion for values on edge labels.
+#' If `FALSE`, values are not displayed.
+#' @param edge.frame Character specifying the kind of frame to be printed around
+#' the text of the edge labels.  Choose an abbreviation of `"rect"`, `"circle"`,
+#' or `"none"`.
 #' @param edge.width,edge.color,\dots Additional parameters to send to `Plot()`.
 #' 
-#' @importFrom ape nodelabels edgelabels plot.phylo
-#' @importFrom colorspace qualitative_hcl sequential_hcl
-#' @importFrom graphics par
-#' @importFrom TreeTools as.Splits
+#' @returns `VisualizeMatching()` invisibly returns the matching of splits
+#' between `tree1` and `tree2` (i.e. 
+#' `Func(tree1, tree2, reportMatching = TRUE)`)
 #' 
 #' @examples 
 #' tree1 <- TreeTools::BalancedTree(6)
 #' tree2 <- TreeTools::PectinateTree(6)
 #' 
 #' VisualizeMatching(RobinsonFouldsMatching, tree1, tree2)
-#' VisualizeMatching(SharedPhylogeneticInfo, tree1, tree2, matchZeros = FALSE)
+#' matching <- VisualizeMatching(SharedPhylogeneticInfo, tree1, tree2,
+#'                               matchZeros = FALSE)
+#' attributes(matching)
 #' @template MRS
 #' @encoding UTF-8
+#' @importFrom ape nodelabels edgelabels plot.phylo
+#' @importFrom colorspace qualitative_hcl sequential_hcl
+#' @importFrom graphics par
+#' @importFrom TreeTools as.Splits
 #' @export
-VisualizeMatching <- function(Func, tree1, tree2, setPar = TRUE,
-                              precision = 3L, Plot = plot.phylo,
-                              matchZeros = TRUE, plainEdges = FALSE,
-                              edge.width = 1, edge.color = "black",
-                              ...) {
-
+VisualizeMatching <- function (Func, tree1, tree2, setPar = TRUE,
+                               precision = 3L, Plot = plot.phylo,
+                               matchZeros = TRUE, plainEdges = FALSE,
+                               edge.cex = par("cex"),
+                               value.cex = edge.cex * 0.8,
+                               edge.frame = "rect",
+                               edge.width = 1, edge.color = "black",
+                               ...) 
+{
   splits1 <- as.Splits(tree1)
   edge1 <- tree1[["edge"]]
   child1 <- edge1[, 2]
@@ -64,22 +79,32 @@ VisualizeMatching <- function(Func, tree1, tree2, setPar = TRUE,
   pairScores <- signif(mapply(function(i, j) scores[i, j],
                               seq_along(pairings), pairings), precision)
 
-  adjNo <- c(0.5, -0.2)
-  adjVal <- c(0.5, 1.1)
   faint <- "#aaaaaa"
 
   if (setPar) {
     origPar <- par(mfrow = c(1, 2), mar = rep(0.5, 4))
     on.exit(par(origPar))
   }
 
-  LabelUnpaired <- function(splitEdges, unpaired) {
+  .LabelEdge <- function(label, edges, frame = "n", ...) {
+    if (edge.cex) {
+      edgelabels(text = label, edge = edges, frame = frame,
+                 cex = edge.cex, adj = c(0.5, -0.2), ...)
+    }
+  }
+  .LabelValue <- function(label, edges, frame = "n", ...) {
+    if (value.cex) {
+      edgelabels(text = label, edge = edges, frame = frame,
+                 cex = value.cex, adj = c(0.5, 1.1), ...)
+    }
+  }
+
+  .LabelUnpaired <- function(splitEdges, unpaired) {
     if (any(unpaired)) {
-      #edgelabels(text="\u2012", edge=splitEdges[unpaired],
-      edgelabels(text = expression("-"), edge = splitEdges[unpaired],
-                 frame = "n", col = faint, adj = adjNo)
-      edgelabels(text = "0", edge = splitEdges[unpaired],
-                 frame = "n", col = faint, cex = 0.8, adj = adjVal)
+      .LabelEdge(label = expression("-"), edges = splitEdges[unpaired],
+                 frame = "n", col = faint)
+      .LabelValue(label = "0", edges = splitEdges[unpaired],
+                  frame = "n", col = faint)
     }
   }
 
@@ -162,13 +187,12 @@ VisualizeMatching <- function(Func, tree1, tree2, setPar = TRUE,
   pairedPairScores <- pairScores[paired1]
   pairLabels <- seq_len(sum(paired1))
   if (any(pairLabels)) {
-    edgelabels(text = pairLabels, edge = splitEdges1[paired1],
-               bg = palette, adj = adjNo)
-    edgelabels(text = pairedPairScores, edge = splitEdges1[paired1], 
-               frame = "n", adj = adjVal, cex = 0.8,
-               col = ifelse(pairedPairScores, "black", faint))
+    .LabelEdge(pairLabels, splitEdges1[paired1], frame = edge.frame,
+               bg = palette)
+    .LabelValue(pairedPairScores, splitEdges1[paired1],
+                col = ifelse(pairedPairScores, "black", faint))
   }
-  LabelUnpaired(splitEdges1, !paired1)
+  .LabelUnpaired(splitEdges1, !paired1)
 
 
   paired2 <- seq_along(splitEdges2) %in% pairings[paired1]
@@ -181,14 +205,13 @@ VisualizeMatching <- function(Func, tree1, tree2, setPar = TRUE,
              Normalize(pairedPairScores, na.rm = TRUE), ...)
   }
   if (any(pairLabels)) {
-    edgelabels(text = pairLabels, edge = splitEdges2[pairNames2],
-               bg = palette, adj=adjNo)
-    edgelabels(text = pairedPairScores, edge = splitEdges2[pairNames2], 
-               frame = "n", adj = adjVal, cex = 0.8,
+    .LabelEdge(pairLabels, splitEdges2[pairNames2], frame = edge.frame,
+               bg = palette)
+    .LabelValue(pairedPairScores, splitEdges2[pairNames2],
                col = ifelse(pairedPairScores, "black", faint))
   }
-  LabelUnpaired(splitEdges2, !paired2)
+  .LabelUnpaired(splitEdges2, !paired2)
 
   # Return:
-  invisible()
+  invisible(matching)
 }

R/tree_distance.R

@@ -19,12 +19,14 @@
 #' specified pair scorer. If `reportMatching = TRUE`, attribute also list:
 #' 
 #' - `matching`: which split in `splits2` is optimally matched to each split in 
-#' `split1` (`NA` if not matched);
-#'
-#' - `pairScores`: Calculated scores for each possible matching of each split.
+#'   `split1` (`NA` if not matched);
 #' 
 #' - `matchedSplits`: Textual representation of each match
+#'
+#' - `matchedScores`: Scores for matched split.
 #' 
+#' - `pairScores`: Calculated scores for each possible matching of each split.
+#'
 #' @keywords internal
 #' @template MRS
 #' @encoding UTF-8
@@ -54,7 +56,6 @@ GeneralizedRF <- function(splits1, splits2, nTip, PairScorer,
                                        nTip = nTip, ...)[["score"]]
       }
     }
-    attr(ret, "pairScores") <- pairScores
 
     if (!is.null(attr(splits1, "tip.label"))) {
       matched1 <- !is.na(matching)
@@ -68,6 +69,14 @@ GeneralizedRF <- function(splits1, splits2, nTip, PairScorer,
                          pairScores[matrix(c(matched1, matched2), ncol = 2L)] > 0
                        } else rep(TRUE, length(matched1)))
     }
+
+    attr(ret, "matchedScores") <- vapply(
+      seq_along(matching),
+      function(i) pairScores[i, matching[[i]]],
+      vector(mode(pairScores), 1)
+    )
+
+    attr(ret, "pairScores") <- pairScores
   }
   # Return:
   ret