Fix Ratchet() early-exit bookkeeping (A15-04)

NEWS.md

@@ -588,6 +588,15 @@
   state code rather than indexing its count buffers out of bounds.  State
   codes generated by the package are always positive, so no result changes.
 
+- `Ratchet(stopAtScore = )` no longer returns a tree whose independently
+  recomputed score disagrees with its `"score"` attribute.  Its early-exit
+  paths -- meeting the target score during search, or already meeting it on
+  entry -- skipped the bookkeeping that the return value depends on, so the
+  *input* tree could be returned carrying the *improved* score.
+  `returnAll = TRUE` no longer errors ("No trees!?") when the target score is
+  met during search, and `MultiRatchet()` no longer errors when a starting
+  tree already meets `stopAtScore`.
+
 # TreeSearch 2.0.0
 
 ## Breaking changes

R/Ratchet.R

@@ -121,7 +121,15 @@ Ratchet <- function(tree, dataset,
     if (verbosity > 1L) {
       message("*** Target score of ", stopAtScore, " met.")                     # nocov
     }
-    return(tree)
+    tree[["edge"]] <- cbind(edgeList[[1]], edgeList[[2]])
+    attr(tree, "score") <- bestScore
+    return(
+      if (returnAll) {
+        structure(list(tree), class = "multiPhylo")
+      } else {
+        tree
+      }
+    )
   }
   if (is.function(swappers)){
     swappers <- list(swappers)
@@ -167,10 +175,15 @@ Ratchet <- function(tree, dataset,
       if (!is.null(stopAtScore) && candScore < stopAtScore + epsilon) {
         BREAK <- TRUE
         if (verbosity > 1L) {                                                   # nocov start
-          message("  * Target score ", stopAtScore, 
+          message("  * Target score ", stopAtScore,
                   " met; terminating tree search.")
         }                                                                       # nocov end
+        edgeList <- candidate
         bestScore <- candScore
+        if (returnAll) {
+          forest[[i]] <- candidate
+          forestScores[i] <- candScore
+        }
         break
       }
     }

tests/testthat/test-Ratchet.R

@@ -0,0 +1,64 @@
+library("TreeTools", quietly = TRUE)
+
+# Issue #136 (A15-04): Ratchet()'s early-exit paths (stopAtScore= met either
+# before or during search) skipped the bookkeeping that its return value
+# depends on, so the returned tree and its "score" attribute could disagree.
+# The property that must hold on every exit path: a tree's own recomputed
+# TreeLength() must equal its "score" attribute.
+
+trueTree <- ape::read.tree(text = "(((((1,2),3),4),5),6);")
+dataset <- TreeTools::StringToPhyDat("110000 111000 111100", 1:6, byTaxon = FALSE)
+startTree <- TreeTools::RenumberTips(ape::read.tree(
+  text = "(((1, 6), 3), (2, (4, 5)));"), trueTree$tip.label)
+startScore <- TreeLength(startTree, dataset)
+trueScore <- TreeLength(trueTree, dataset)
+preparedData <- PrepareData(dataset)
+
+test_that("Ratchet(stopAtScore=) already met on entry returns a consistent tree", {
+  result <- Ratchet(startTree, preparedData, stopAtScore = startScore,
+                    verbosity = 0)
+  expect_false(is.null(attr(result, "score")))
+  expect_equal(TreeLength(result, dataset), attr(result, "score"))
+  expect_equal(attr(result, "score"), startScore)
+
+  resultAll <- Ratchet(startTree, preparedData, stopAtScore = startScore,
+                       returnAll = TRUE, verbosity = 0)
+  expect_s3_class(resultAll, "multiPhylo")
+  expect_length(resultAll, 1)
+  expect_equal(TreeLength(resultAll[[1]], dataset), attr(resultAll[[1]], "score"))
+})
+
+test_that("Ratchet(stopAtScore=) met mid-search returns a consistent tree", {
+  oldSeed <- if (exists(".Random.seed", .GlobalEnv)) .GlobalEnv[[".Random.seed"]] else NULL
+  on.exit(if (is.null(oldSeed)) rm(".Random.seed", envir = .GlobalEnv) else
+    assign(".Random.seed", oldSeed, envir = .GlobalEnv))
+  set.seed(1)
+
+  result <- Ratchet(startTree, preparedData, stopAtScore = trueScore,
+                    swappers = list(TBRSwap, SPRSwap, NNISwap),
+                    ratchIter = 3, searchHits = 5, verbosity = 0)
+  expect_equal(attr(result, "score"), trueScore)
+  # This is the assertion that failed pre-fix: the tree returned carried the
+  # improved score but was, independently, the untouched input tree.
+  expect_equal(TreeLength(result, dataset), attr(result, "score"))
+
+  resultAll <- Ratchet(startTree, preparedData, stopAtScore = trueScore,
+                       swappers = list(TBRSwap, SPRSwap, NNISwap),
+                       ratchIter = 3, searchHits = 5, returnAll = TRUE,
+                       verbosity = 0)
+  expect_s3_class(resultAll, "multiPhylo")
+  # A stopAtScore hit mid-search can only ever bank the single hitting
+  # candidate: every earlier iteration scored above stopAtScore + suboptimal,
+  # so only the BREAK-path forest slot survives the keepers filter.
+  expect_length(resultAll, 1)
+  expect_equal(TreeLength(resultAll[[1]], dataset), attr(resultAll[[1]], "score"))
+})
+
+test_that("MultiRatchet() survives an already-met stopAtScore", {
+  result <- MultiRatchet(startTree, preparedData, stopAtScore = startScore,
+                         nSearch = 2, verbosity = 0)
+  expect_s3_class(result, "multiPhylo")
+  for (phy in result) {
+    expect_equal(TreeLength(phy, dataset), attr(phy, "score"))
+  }
+})