From 1f82c438289363951fc81974963ddc1ee5be9125 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 08:06:26 +0100 Subject: [PATCH 01/28] importFrom imports --- NAMESPACE | 2 ++ R/MaximizeParsimony.R | 9 +++++---- R/mpl_morphy_objects.R | 1 + 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 500757eee..f067b902e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -113,7 +113,9 @@ export(mpl_set_parsim_t) export(mpl_translate_error) export(mpl_update_lower_root) export(mpl_update_tip) +importFrom(Rcpp,compileAttributes) importFrom(Rdpack,reprompt) +importFrom(Rogue,ColByStability) importFrom(TreeDist,ClusteringEntropy) importFrom(TreeDist,ClusteringInfo) importFrom(TreeDist,ClusteringInfoDistance) diff --git a/R/MaximizeParsimony.R b/R/MaximizeParsimony.R index a88321a9c..059593e44 100644 --- a/R/MaximizeParsimony.R +++ b/R/MaximizeParsimony.R @@ -832,13 +832,14 @@ Resample <- function (dataset, tree, method = 'jack', #' Launch tree search graphical user interface #' #' @rdname MaximizeParsimony -#' @importFrom shiny runApp -#' @importFrom shinyjs useShinyjs -#' @importFrom TreeDist ClusteringInfoDistance -#' @importFrom protoclust protoclust #' @importFrom cluster pam silhouette #' @importFrom future future #' @importFrom promises future_promise +#' @importFrom protoclust protoclust +#' @importFrom Rogue ColByStability +#' @importFrom shiny runApp +#' @importFrom shinyjs useShinyjs +#' @importFrom TreeDist ClusteringInfoDistance #' @export EasyTrees <- function () {#nocov start shiny::runApp(system.file('Parsimony', package = 'TreeSearch')) diff --git a/R/mpl_morphy_objects.R b/R/mpl_morphy_objects.R index 60004550d..ac193f646 100644 --- a/R/mpl_morphy_objects.R +++ b/R/mpl_morphy_objects.R @@ -8,6 +8,7 @@ #' @author Martin R. Smith #' @method summary morphyPtr #' @family Morphy API functions +#' @importFrom Rcpp compileAttributes #' @export summary.morphyPtr <- function (object, ...) { ans <- list() From 040751584c37e30eeff499ce43948a77997dd26b Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 08:16:31 +0100 Subject: [PATCH 02/28] v1.0.1 --- DESCRIPTION | 2 +- NEWS.md | 11 +++++++- codemeta.json | 77 +++++++++++++++++++-------------------------------- 3 files changed, 39 insertions(+), 51 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 12358ff83..2c8b65151 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: TreeSearch Title: Phylogenetic Tree Search Using Custom Optimality Criteria -Version: 1.0.0 +Version: 1.0.1 Authors@R: c(person("Martin R.", 'Smith', email="martin.smith@durham.ac.uk", role=c("aut", "cre", "cph"), diff --git a/NEWS.md b/NEWS.md index 096334763..1e3f460f7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# TreeSearch 1.0.1 + +- Memory management in RANDOMTREESCORE +- Corrections to metadata + # TreeSearch 1.0.0 ## New functions @@ -29,22 +34,25 @@ - Improved command line interface for search progress messaging ## Deprecations - - Remove redundant internal function `LogisticPoints()` + # TreeSearch 0.4.3 - Update tests for compatibility with 'TreeTools' v1.1.0 - Improve memory and pointer handling + # TreeSearch 0.4.2 - Update tests for compatibility with 'TreeTools' v1.1.0 + # TreeSearch 0.4.1 - Compatibility with 'TreeTools' v1.0.0 + # TreeSearch 0.4.0 ## New features @@ -80,6 +88,7 @@ - Check whether input tree is bifurcating before attempting rearrangements, to avoid crashes on unsupported input + # TreeSearch 0.3.0 ## New features diff --git a/codemeta.json b/codemeta.json index 4f9ad28c8..8cc7843c6 100644 --- a/codemeta.json +++ b/codemeta.json @@ -1,21 +1,14 @@ { - "@context": [ - "https://doi.org/10.5063/schema/codemeta-2.0", - "http://schema.org" - ], + "@context": "https://doi.org/10.5063/schema/codemeta-2.0", "@type": "SoftwareSourceCode", "identifier": "TreeSearch", - "description": "Search for phylogenetic trees that are optimal using a\n user-defined criterion.\n Contains a \"shiny\" user interface for interactive tree search and exploration\n of results, including character visualization, rogue taxon detection,\n tree space mapping, and cluster consensus trees.\n Handles inapplicable data using the algorithm of Brazeau, Guillerme and\n Smith (2019) using the \"Morphy\" library.\n Implements Profile Parsimony (Faith and Trueman, 2001) \n , and Successive Approximations (Farris, 1969) \n .", + "description": "Search for phylogenetic trees that are optimal using a user-defined criterion. Contains a \"shiny\" user interface for interactive tree search and exploration of results, including character visualization, rogue taxon detection, tree space mapping, and cluster consensus trees. Handles inapplicable data using the algorithm of Brazeau, Guillerme and Smith (2019) using the \"Morphy\" library. Implements Profile Parsimony (Faith and Trueman, 2001) , and Successive Approximations (Farris, 1969) .", "name": "TreeSearch: Phylogenetic Tree Search Using Custom Optimality Criteria", "codeRepository": "https://github.com/ms609/TreeSearch/", - "relatedLink": [ - "https://ms609.github.io/TreeSearch", - "https://CRAN.R-project.org/package=TreeSearch", - "https://ms609.github.io/TreeSearch/" - ], + "relatedLink": "https://ms609.github.io/TreeSearch/", "issueTracker": "https://github.com/ms609/TreeSearch/issues/", "license": "https://spdx.org/licenses/GPL-3.0", - "version": "1.0.0", + "version": "1.0.1", "programmingLanguage": { "@type": "ComputerLanguage", "name": "R", @@ -37,7 +30,6 @@ "@id": "https://orcid.org/0000-0001-5660-1727" } ], - "contributor": {}, "copyrightHolder": [ { "@type": "Person", @@ -53,7 +45,6 @@ "@id": "https://orcid.org/0000-0002-0650-1282" } ], - "funder": {}, "maintainer": [ { "@type": "Person", @@ -126,14 +117,14 @@ "sameAs": "https://CRAN.R-project.org/package=vdiffr" } ], - "softwareRequirements": [ - { + "softwareRequirements": { + "1": { "@type": "SoftwareApplication", "identifier": "R", "name": "R", "version": ">= 3.5.0" }, - { + "2": { "@type": "SoftwareApplication", "identifier": "ape", "name": "ape", @@ -146,7 +137,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=ape" }, - { + "3": { "@type": "SoftwareApplication", "identifier": "cli", "name": "cli", @@ -159,7 +150,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=cli" }, - { + "4": { "@type": "SoftwareApplication", "identifier": "cluster", "name": "cluster", @@ -171,7 +162,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=cluster" }, - { + "5": { "@type": "SoftwareApplication", "identifier": "fastmatch", "name": "fastmatch", @@ -184,7 +175,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=fastmatch" }, - { + "6": { "@type": "SoftwareApplication", "identifier": "future", "name": "future", @@ -196,7 +187,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=future" }, - { + "7": { "@type": "SoftwareApplication", "identifier": "phangorn", "name": "phangorn", @@ -209,7 +200,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=phangorn" }, - { + "8": { "@type": "SoftwareApplication", "identifier": "promises", "name": "promises", @@ -221,7 +212,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=promises" }, - { + "9": { "@type": "SoftwareApplication", "identifier": "protoclust", "name": "protoclust", @@ -233,7 +224,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=protoclust" }, - { + "10": { "@type": "SoftwareApplication", "identifier": "Rcpp", "name": "Rcpp", @@ -245,7 +236,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=Rcpp" }, - { + "11": { "@type": "SoftwareApplication", "identifier": "Rdpack", "name": "Rdpack", @@ -258,7 +249,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=Rdpack" }, - { + "12": { "@type": "SoftwareApplication", "identifier": "Rogue", "name": "Rogue", @@ -271,7 +262,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=Rogue" }, - { + "13": { "@type": "SoftwareApplication", "identifier": "shiny", "name": "shiny", @@ -283,7 +274,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=shiny" }, - { + "14": { "@type": "SoftwareApplication", "identifier": "shinyjs", "name": "shinyjs", @@ -295,12 +286,12 @@ }, "sameAs": "https://CRAN.R-project.org/package=shinyjs" }, - { + "15": { "@type": "SoftwareApplication", "identifier": "stats", "name": "stats" }, - { + "16": { "@type": "SoftwareApplication", "identifier": "TreeDist", "name": "TreeDist", @@ -313,7 +304,7 @@ }, "sameAs": "https://CRAN.R-project.org/package=TreeDist" }, - { + "17": { "@type": "SoftwareApplication", "identifier": "TreeTools", "name": "TreeTools", @@ -325,21 +316,10 @@ "url": "https://cran.r-project.org" }, "sameAs": "https://CRAN.R-project.org/package=TreeTools" - } - ], - "releaseNotes": "https://github.com/ms609/TreeSearch/blob/master/NEWS.md", - "readme": "https://github.com/ms609/TreeSearch/blob/master/README.md", - "contIntegration": ["https://travis-ci.org/ms609/TreeSearch", "https://codecov.io/gh/ms609/TreeSearch"], - "developmentStatus": "http://www.repostatus.org/#active", - "keywords": [ - "tree-search", - "phangorn", - "phylogenetics", - "morphological-analysis", - "research-tool", - "bioinformatics", - "r-package" - ], + }, + "SystemRequirements": "C++14" + }, + "fileSize": "2143.071KB", "citation": [ { "@type": "SoftwareSourceCode", @@ -408,10 +388,9 @@ ], "name": "TreeSearch: phylogenetic tree search using custom optimality criteria", "identifier": "10.5281/zenodo.1042590", - "description": "R package version ", + "description": "R package version 1.0.1", "@id": "https://doi.org/10.5281/zenodo.1042590", "sameAs": "https://doi.org/10.5281/zenodo.1042590" } - ], - "fileSize": "2141.39KB" + ] } From 9948639e99855c8ba341e4d319247ee7d3d6a09a Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 08:33:51 +0100 Subject: [PATCH 03/28] RandomTreeScore() on small trees --- R/RandomTreeScore.R | 9 ++++-- src/build_postorder.h | 7 ++++- tests/testthat/test-RandomTreeScore.R | 41 +++++++++++++++------------ 3 files changed, 36 insertions(+), 21 deletions(-) diff --git a/R/RandomTreeScore.R b/R/RandomTreeScore.R index 139908d14..200d50fc5 100644 --- a/R/RandomTreeScore.R +++ b/R/RandomTreeScore.R @@ -19,8 +19,13 @@ #' @export RandomTreeScore <- function (morphyObj) { nTip <- mpl_get_numtaxa(morphyObj) - # Return: - .Call('RANDOM_TREE_SCORE', as.integer(nTip), morphyObj) + if (nTip < 2) { + # Return: + 0L + } else { + # Return: + .Call('RANDOM_TREE_SCORE', as.integer(nTip), morphyObj) + } } #' Random postorder tree diff --git a/src/build_postorder.h b/src/build_postorder.h index 95f40eb55..d4e8bc651 100644 --- a/src/build_postorder.h +++ b/src/build_postorder.h @@ -1,5 +1,4 @@ #include -#include #include "RMorphy.h" /* Random number generator from http://www.cse.yorku.ca/~oz/marsaglia-rng.html @@ -132,6 +131,9 @@ void random_tree(int *parent_of, int *left, int *right, const int *n_tip) { extern SEXP RANDOM_TREE(SEXP ntip) { const int n_tip = INTEGER(ntip)[0]; + if (n_tip < 2) { + Rf_error("n_tip must be at least two"); + } SEXP RESULT = PROTECT(allocVector(VECSXP, 3)), PARENT_OF = PROTECT(allocVector(INTSXP, n_tip + n_tip - 1)), LEFT = PROTECT(allocVector(INTSXP, n_tip - 1)), @@ -152,6 +154,9 @@ extern SEXP RANDOM_TREE(SEXP ntip) { extern SEXP RANDOM_TREE_SCORE(SEXP ntip, SEXP MorphyHandl) { const int n_tip = INTEGER(ntip)[0]; + if (n_tip < 2) { + Rf_error("n_tip must be at least two"); + } Morphy handl = R_ExternalPtrAddr(MorphyHandl); SEXP RESULT = PROTECT(allocVector(INTSXP, 1)); int *score, diff --git a/tests/testthat/test-RandomTreeScore.R b/tests/testthat/test-RandomTreeScore.R index 576732d46..96498300b 100644 --- a/tests/testthat/test-RandomTreeScore.R +++ b/tests/testthat/test-RandomTreeScore.R @@ -1,38 +1,43 @@ -test_that("Errors are handled", { - tokens <- matrix(c( - 0, '-', '-', 1, 1, 2, - 0, '-', '-', 0, 0, 0), byrow = TRUE, nrow = 2L, - dimnames = list(letters[1:2], NULL)) - pd <- TreeTools::MatrixToPhyDat(tokens) - morphyObj <- PhyDat2Morphy(pd) - expect_equal(3, RandomTreeScore(morphyObj)) - morphyObj <- UnloadMorphy(morphyObj) - +test_that("RandomMorphyTree() errors are handled", { expect_error(RandomMorphyTree(-1)) expect_error(RandomMorphyTree(0)) expect_error(RandomMorphyTree(1)) - }) -test_that("Random tree score on small trees", { +test_that("Two tip 'random' tree", { + expect_equal(RandomMorphyTree(2), list(c(2, 2, 2), 0, 1)) +}) + +test_that("RandomTreeScore() on small trees", { mo <- mpl_new_Morphy() expect_equal(0L, RandomTreeScore(mo)) mpl_delete_Morphy(mo) - tokens <- matrix(c( 0, '-', '-', 1, 1, 2, 0, '-', '-', 1, 1, 2, 0, '-', '-', 0, 0, 0), byrow = TRUE, nrow = 3L, dimnames = list(letters[1:3], NULL)) + + # One leaf + pd <- TreeTools::MatrixToPhyDat(tokens[1, , drop = FALSE]) + morphyObj <- PhyDat2Morphy(pd) + expect_equal(mpl_get_numtaxa(morphyObj), 1L) + expect_equal(0, RandomTreeScore(morphyObj)) + morphyObj <- UnloadMorphy(morphyObj) + + # Two leaves + pd <- TreeTools::MatrixToPhyDat(tokens[2:3, , drop = FALSE]) + morphyObj <- PhyDat2Morphy(pd) + expect_equal(mpl_get_numtaxa(morphyObj), 2L) + expect_equal(RandomTreeScore(morphyObj), 3L) + morphyObj <- UnloadMorphy(morphyObj) + + # Three leaves pd <- TreeTools::MatrixToPhyDat(tokens) morphyObj <- PhyDat2Morphy(pd) - expect_equal(3, RandomTreeScore(morphyObj)) + expect_equal(RandomTreeScore(morphyObj), 3L) morphyObj <- UnloadMorphy(morphyObj) }) - -test_that("Two tip 'random' tree", { - expect_equal(list(c(2, 2, 2), 0, 1), RandomMorphyTree(2)) -}) From e9e733cbc430e4f1db0b4f934e23aacee70312ee Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:18:17 +0100 Subject: [PATCH 04/28] Skip --- tests/testthat/test-RandomTreeScore.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-RandomTreeScore.R b/tests/testthat/test-RandomTreeScore.R index 96498300b..4dded7dbb 100644 --- a/tests/testthat/test-RandomTreeScore.R +++ b/tests/testthat/test-RandomTreeScore.R @@ -1,15 +1,17 @@ test_that("RandomMorphyTree() errors are handled", { + skip_if(TRUE) expect_error(RandomMorphyTree(-1)) expect_error(RandomMorphyTree(0)) expect_error(RandomMorphyTree(1)) }) test_that("Two tip 'random' tree", { + skip_if(TRUE) expect_equal(RandomMorphyTree(2), list(c(2, 2, 2), 0, 1)) }) test_that("RandomTreeScore() on small trees", { - + skip_if(TRUE) mo <- mpl_new_Morphy() expect_equal(0L, RandomTreeScore(mo)) mpl_delete_Morphy(mo) From 7db7c147a2bad6f22683065580fb0a2f652981c1 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:26:58 +0100 Subject: [PATCH 05/28] Skip SPR errors --- tests/testthat/test-rearrange.cpp.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index 29109c39f..036d6fe7b 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -8,6 +8,7 @@ test_that("TBR errors", { }) test_that("SPR errors", { + skip_if(TRUE) tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) expect_equal(0, length(expect_warning(all_spr(tr$edge, -1)))) expect_equal(0, length(expect_warning(all_spr(tr$edge, 1)))) From bfa2c71e0ba2f849cf59154694a7877901b4e5a3 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:42:15 +0100 Subject: [PATCH 06/28] dputs --- tests/testthat/test-rearrange.cpp.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index 036d6fe7b..1ec912298 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -66,11 +66,13 @@ test_that("SPR fails gracefully", { }) test_that("SPR works", { + dput(" - SPR1 ") t2 <- as.phylo(518, 7) # (t1, ((t2, t3), ((t4, t5), (t6, t7)))) expect_equal(8, length(all_spr(t2$edge, 2))) tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) + dput(" - SPR Single tip ") # Move single tip expect_equal(8, length(all_spr(tr$edge, 12))) expect_equal(8, length(all_spr(tr$edge, 11))) @@ -80,15 +82,18 @@ test_that("SPR works", { expect_equal(8, length(all_spr(tr$edge, 3))) expect_equal(8, length(all_spr(tr$edge, 2))) + dput(" - SPR Cherry ") # Move cherry expect_equal(6, length(all_spr(tr$edge, 9))) expect_equal(6, length(all_spr(tr$edge, 5))) expect_equal(12, length(all_spr(tr$edge, c(9, 5)))) + dput(" - SPR Bush ") # Move more expect_equal(0, length(unique(all_spr(tr$edge, 4)))) expect_equal(4, length(unique(all_spr(tr$edge, 8)))) + dput(" - SPR All ") # All moves expect_equal(7*8 + 2*6 + 4, length(all_spr(tr$edge, integer(0)))) uniqueMoves <- length(unique(all_spr(tr$edge, integer(0)))) @@ -96,6 +101,7 @@ test_that("SPR works", { uniqueMoves) expect_equal(uniqueMoves, length(SPRMoves(tr))) + dput(" - SPR Clear ") tr <- Preorder(root(TreeTools::BalancedTree(14), 't1', resolve.root = TRUE)) tr$edge desc <- TreeTools::CladeSizes(tr) @@ -121,6 +127,7 @@ test_that("SPR works", { expect_equal(SPRMoves(tr)[[54]]$edge, SPRMoves(tr$edge)[[54]]) }) +# TODO Restore or delete if (FALSE) test_that("SPR works", { testTree <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) plot(testTree); nodelabels(); edgelabels() From 9ea805de20cf0c85d7e71a927fb4a1b916ad8f69 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:43:00 +0100 Subject: [PATCH 07/28] Only tests --- .github/workflows/gcc-ASAN.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.github/workflows/gcc-ASAN.yml b/.github/workflows/gcc-ASAN.yml index 5cc83dfbf..d74522ee7 100644 --- a/.github/workflows/gcc-ASAN.yml +++ b/.github/workflows/gcc-ASAN.yml @@ -33,8 +33,6 @@ jobs: matrix: config: - {test: 'tests'} - - {test: 'examples'} - - {test: 'vignettes'} env: R_REMOTES_NO_ERRORS_FROM_WARNINGS: true From 2162305b60d45c167a96de19a7bc2727d83230d8 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:43:19 +0100 Subject: [PATCH 08/28] Squashed commit of the following: commit 7bb024e78192526c9265c71c5b1fb93a079b35a9 Author: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu Sep 23 12:26:05 2021 +0100 Use Rf_error / warnings --- src/rearrange.cpp | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/rearrange.cpp b/src/rearrange.cpp index 8895d65eb..30a7dbc28 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -335,13 +335,13 @@ List all_spr (const IntegerMatrix edge, root_node = n_tip + 1 ; if (n_edge < 5) { - throw std::invalid_argument("No SPR rearrangements possible on a tree with < 5 edges"); + Rf_error("No SPR rearrangements possible on a tree with < 5 edges"); } if (edge(0, 0) != root_node) { - throw std::invalid_argument("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); + Rf_error("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); } if (edge(1, 0) != root_node) { - throw std::invalid_argument("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); + Rf_error("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); } IntegerVector break_seq; @@ -383,17 +383,16 @@ List all_spr (const IntegerMatrix edge, List ret = List::create(); - Function warning("warning"); // Let's go. for (int16 i = break_seq.length(); i--; ) { IntegerMatrix two_bits = clone(edge); if (break_seq[i] > n_edge) { - warning("Ignoring SPR break locations that exceed number of edges in tree.\n"); + Rf_warning("Ignoring SPR break locations that exceed number of edges in tree.\n"); continue; } if (break_seq[i] < 2) { - warning("Ignoring break locations < 2"); + Rf_warning("Ignoring break locations < 2"); continue; } const int16 @@ -526,17 +525,16 @@ List all_tbr (const IntegerMatrix edge, List ret = List::create(); - Function warning("warning"); // Let's go. for (int16 i = break_seq.length(); i--; ) { IntegerMatrix two_bits = clone(edge); if (break_seq[i] > n_edge) { - warning("Ignoring TBR break locations that exceed number of edges in tree.\n"); + Rf_warning("Ignoring TBR break locations that exceed number of edges in tree.\n"); continue; } if (break_seq[i] < 2) { - warning("Ignoring break locations < 2"); + Rf_warning("Ignoring break locations < 2"); continue; } const int16 From aaab6a54c8a30d126618952bb707e818e439640c Mon Sep 17 00:00:00 2001 From: "Martin R. Smith" <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:51:21 +0100 Subject: [PATCH 09/28] Rcout << "\n\n Running all_spr()"; --- src/rearrange.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/rearrange.cpp b/src/rearrange.cpp index 8895d65eb..774c28ff1 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -9,7 +9,6 @@ typedef int_fast16_t int16; const int16 UNDEFINED = -1; // Assumptions: -// * Tree is bifurcating and rooted on a tip; root node is labelled with n_tip + 1 // [[Rcpp::export]] IntegerMatrix nni(const IntegerMatrix edge, const IntegerVector randomEdge, @@ -327,6 +326,7 @@ inline void fuse_and_add (const IntegerMatrix& tree_bits, List& ret, // [[Rcpp::export]] List all_spr (const IntegerMatrix edge, const IntegerVector break_order) { + Rcout << "\n\n Running all_spr()"; const int16 n_edge = edge.nrow(), n_internal = n_edge / 2, From d47b5cbd8243890991d4f6a24e64279b54c73906 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:55:23 +0100 Subject: [PATCH 10/28] clone pre_edge_nod --- src/rearrange.cpp | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/rearrange.cpp b/src/rearrange.cpp index 30a7dbc28..56e2bb5dc 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -313,12 +313,10 @@ inline void fuse_and_add (const IntegerMatrix& tree_bits, List& ret, const int16* graft_edge, const int16* break_edge, const int16* spare_edge, const int16* spare_node) { IntegerMatrix new_tree = clone(tree_bits); - new_tree(*spare_edge, 1) = tree_bits(*graft_edge, 1); new_tree(*graft_edge, 1) = *spare_node; new_tree(*break_edge, 0) = *spare_node; - new_tree = TreeTools::preorder_edges_and_nodes(new_tree(_, 0), new_tree(_, 1)); - ret.push_back(new_tree); + ret.push_back(clone(TreeTools::preorder_edges_and_nodes(new_tree(_, 0), new_tree(_, 1)))); } From 6f2622ebccf28c763e693953d4c2b3f30d301d5e Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 12:55:35 +0100 Subject: [PATCH 11/28] Delete other tests --- tests/testthat/test-AdditionTree.R | 48 ---- tests/testthat/test-Concordance.R | 121 --------- tests/testthat/test-CustomSearch.R | 133 ---------- tests/testthat/test-Jackknife.R | 46 ---- tests/testthat/test-MaximizeParsimony.R | 139 ----------- tests/testthat/test-NNI.R | 25 -- tests/testthat/test-PlotCharacter.R | 125 ---------- tests/testthat/test-RMorphy.R | 25 -- tests/testthat/test-RandomTreeScore.R | 45 ---- tests/testthat/test-TreeSearch_utilities.R | 6 - tests/testthat/test-data_manipulation.R | 133 ---------- tests/testthat/test-iw-scoring.R | 78 ------ tests/testthat/test-mpl_morphy_objects.R | 37 --- tests/testthat/test-pp-fitch.R | 92 ------- tests/testthat/test-pp-info_extra_step.R | 95 -------- tests/testthat/test-pp-random-tree.R | 141 ----------- tests/testthat/test-tree_length.R | 270 --------------------- tests/testthat/test-zzz-tree-rearrange.R | 270 --------------------- 18 files changed, 1829 deletions(-) delete mode 100644 tests/testthat/test-AdditionTree.R delete mode 100644 tests/testthat/test-Concordance.R delete mode 100644 tests/testthat/test-CustomSearch.R delete mode 100644 tests/testthat/test-Jackknife.R delete mode 100644 tests/testthat/test-MaximizeParsimony.R delete mode 100644 tests/testthat/test-NNI.R delete mode 100644 tests/testthat/test-PlotCharacter.R delete mode 100644 tests/testthat/test-RMorphy.R delete mode 100644 tests/testthat/test-RandomTreeScore.R delete mode 100644 tests/testthat/test-TreeSearch_utilities.R delete mode 100644 tests/testthat/test-data_manipulation.R delete mode 100644 tests/testthat/test-iw-scoring.R delete mode 100644 tests/testthat/test-mpl_morphy_objects.R delete mode 100644 tests/testthat/test-pp-fitch.R delete mode 100644 tests/testthat/test-pp-info_extra_step.R delete mode 100644 tests/testthat/test-pp-random-tree.R delete mode 100644 tests/testthat/test-tree_length.R delete mode 100644 tests/testthat/test-zzz-tree-rearrange.R diff --git a/tests/testthat/test-AdditionTree.R b/tests/testthat/test-AdditionTree.R deleted file mode 100644 index d08724c26..000000000 --- a/tests/testthat/test-AdditionTree.R +++ /dev/null @@ -1,48 +0,0 @@ -test_that("Addition tree is more parsimonious", { - data('Lobo', package = 'TreeTools') - L10 <- Lobo.phy[1:10] - seq10 <- names(L10) - Score <- function (tr, k) TreeLength(tr, Lobo.phy, concavity = k) - - set.seed(1) # ensure consistent addition sequence - eq <- AdditionTree(Lobo.phy) - kx <- AdditionTree(L10, sequence = seq10, concavity = 10) - pr <- AdditionTree(L10, sequence = 1:10, concavity = 'pr') - nj <- TreeTools::NJTree(Lobo.phy) - nj10 <- TreeTools::KeepTip(nj, 1:10) - - expect_lt(TreeLength(eq, Lobo.phy), TreeLength(nj, Lobo.phy)) - expect_lt(Score(kx, 10), Score(nj10, 10)) - expect_lt(Score(pr, 'pr'), Score(nj10, 'pr')) -}) - -test_that("Addition tree obeys constraints", { - dataset <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 1, - 0, 1, 1, 0, 0, 1), ncol = 2, - dimnames = list(letters[1:6], NULL))) - constraint <- MatrixToPhyDat(c(a = 0, b = 0, c = 0, d = 0, e = 1, f = 1)) - expect_true(as.Splits(c(F, F, F, F, T, T), letters[1:6]) %in% - as.Splits(AdditionTree(dataset, constraint = constraint), - letters[1:6])) - - cdef <- letters[3:6] - subtree <- TreeTools::KeepTip( - AdditionTree(dataset, constraint = constraint[3:6], seq = letters[1:6]), - cdef) - expect_equal(ape::read.tree(text = '(c, d, (e, f));'), - TreeTools::UnrootTree(subtree)) -}) - -test_that("AdditionTree() handles edge cases", { - library('TreeTools') - dataset <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 1, - 0, 1, 1, 0, 0, 1), ncol = 2, - dimnames = list(letters[1:6], NULL))) - expect_equal(PectinateTree(letters[1:3]), AdditionTree(dataset[1:3])) - expect_equal(UnrootTree(PectinateTree(c('a', 'd', 'b', 'c'))), - UnrootTree(AdditionTree(dataset[1:4], conc = 'pr'))) - # All trees have equal score - expect_equal(5, NTip(AdditionTree(dataset[-4]))) -}) \ No newline at end of file diff --git a/tests/testthat/test-Concordance.R b/tests/testthat/test-Concordance.R deleted file mode 100644 index 1a8168c68..000000000 --- a/tests/testthat/test-Concordance.R +++ /dev/null @@ -1,121 +0,0 @@ -library("TreeTools", quietly = TRUE) - -test_that("QuartetConcordance() works", { - tree <- BalancedTree(8) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, 0, 0, 1, 1, 1, 1, 0, - 0, 1, 0, 1, 0, 1, 0, 1, 0, - 0, 0, 0, 1, 0, 1, 1, 1, 0, - 0, 0, 0, 0, 1, 1, 2, 2, 0, - 0, 0, 1, 1, 2, 2, 3, 3, 0, - 0, 1, 2, 3, 0, 1, 2, 3, 0), 9, - dimnames = list(paste0('t', 1:9), NULL)) - dat <- MatrixToPhyDat(mataset) - expect_equal(unname(QuartetConcordance(tree, dat[, 1])), rep(1, 5)) - # plot(tree); nodelabels(); - expect_equal(QuartetConcordance(tree, dat[, 2]), - c('11' = 0, '12' = 0, '13' = 1/9, '14' = 0, '15' = 0)) - - allQuartets <- combn(8, 4) - for (charI in seq_len(ncol(mataset))) { - qc <- QuartetConcordance(tree, dat[, charI]) - for (splitI in seq_along(splits)) { - split <- splits[[splitI]] - logiSplit <- as.logical(split) - case <- apply(allQuartets, 2, function (q) { - qSplit <- logiSplit[q] - qChar <- mataset[q, charI] - if (identical(unique(table(qSplit)), 2L) && - identical(unique(table(qChar)), 2L)) { - tbl <- table(qSplit, qChar) - tab <- paste0(sort(tbl[tbl > 0]), collapse = '') - switch(tab, - '1111' = FALSE, - '112' = NA, - '13' = NA, - '22' = TRUE, - "4" = NA, - stop(q, ": ", tab) - ) - } else { - NA - } - }) - expect_equal(sum(case, na.rm = TRUE) / sum(!is.na(case)), - unname(qc[as.character(names(split))])) - } - } - - expect_equal(QuartetConcordance(tree, dat[, c(1:4, 6)]), - c('11' = ( 6 + 0 + 6 + 2) / ( 6 + 9 + 6 + 2 + 1), - '12' = ( 6 + 0 + 0 + 2) / ( 6 + 9 + 9 + 2 + 1), - '13' = (36 + 2 + 9 + 12) / (36 + 18 + 18 + 12 + 6), - '14' = ( 6 + 0 + 0 + 7) / ( 6 + 9 + 9 + 7 + 1), - '15' = ( 6 + 0 + 6 + 7) / ( 6 + 9 + 6 + 7 + 1)) - ) -}) - -test_that("QuartetConcordance() handles ambiguity", { - tree <- BalancedTree(12) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, '{01}', 0, 0, '{01}', 1, 1, '-', 1, 1, '-', - 0, 1, '?', 0, 1, '?', 0, 1, '(01)', 0, 1, '(01)', - 0, 0, '?', 0, 1, '(12)', 0, 1, '(12)', 1, 1, '(12)', - 0, 0, '?', 0, 0, '?', 1, 1, '?', 2, 2, '?', - 0, 0, '?', 0, 0, '?', 0, 0, '-', 0, 0, '-', - rep('?', 12), - 0, 1, '?', 2, 3, '?', 0, 1, '-', 2, 3, '-'), 12, - dimnames = list(paste0('t', 1:12), NULL)) - dat <- MatrixToPhyDat(mataset) - - expect_equal(unname(QuartetConcordance(tree, dat)[c('16', '18', '19', '21', '23')]), - unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) - expect_equal(unname(QuartetConcordance(tree, dat)[c('15', '17', '19', '20', '22')]), - unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) -}) - -test_that("QuartetConcordance() handles incomplete data", { - tree <- BalancedTree(8) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, 0, 0, 0, 0, 0, 1, - rep('?', 8)), 8, - dimnames = list(paste0('t', 1:8), NULL)) - dat <- MatrixToPhyDat(mataset) - - expect_equal(unname(QuartetConcordance(tree, dat)), rep(NA_real_, 5)) -}) - -dataset <- congreveLamsdellMatrices[[10]][, 1] -tree <- TreeTools::NJTree(dataset) - -ConcordantInformation(tree, dataset)['noise'] -TreeLength(tree, dataset, concavity = 'prof') - -test_that("ConcordantInformation() works", { - data(congreveLamsdellMatrices) - dat <- congreveLamsdellMatrices[[10]] - tree <- TreeTools::NJTree(dat) - - ci <- ConcordantInformation(tree, dat) - expect_equal(expect_warning(Evaluate(tree, dat)), ci) - expect_equal(TreeLength(tree, dat, concavity = 'prof'), - unname(ci['noise'])) - expect_equal(Log2Unrooted(22), unname(ci['treeInformation'])) - expect_equal(sum(apply(PhyDatToMatrix(dat), 2, CharacterInformation)), - unname(ci['informationContent'])) - - dataset <- MatrixToPhyDat(cbind(setNames(c(rep(1, 11), 2:5), paste0('t', 1:15)))) - tree <- TreeTools::PectinateTree(length(dataset)) - expect_error(ConcordantInformation(tree, dataset)) - # expect_equal(0, unname(ci['signal'])) - # expect_equal(0, unname(ci['noise'])) - - dataset <- MatrixToPhyDat(c(a = 1, b = 2, c = 1, d = 2, e = 3, f = 3)) - tree <- TreeTools::PectinateTree(dataset) - ci <- expect_warning(ConcordantInformation(tree, dataset)) - expect_equal(c(signal = log2(3)), ci['signal']) - expect_equal(c(noise = log2(3)), ci['noise']) - expect_equal(c(ignored = CharacterInformation(c(0,0,1,1,2,2)) - - log2(3) - log2(3)), ci['ignored']) - -}) diff --git a/tests/testthat/test-CustomSearch.R b/tests/testthat/test-CustomSearch.R deleted file mode 100644 index acf36b8bf..000000000 --- a/tests/testthat/test-CustomSearch.R +++ /dev/null @@ -1,133 +0,0 @@ -context("TreeSearch.R") -library("TreeTools", quietly = TRUE) -comb11 <- PectinateTree(letters[1:11]) -unrooted11 <- UnrootTree(comb11) -data11 <- cbind(upper.tri(matrix(FALSE, 11, 11))[, 3:10], - lower.tri(matrix(FALSE, 11, 11))[, 2:9]) -rownames(data11) <- letters[1:11] -phy11 <- phangorn::phyDat(data11, type = 'USER', levels = c(FALSE, TRUE)) -RootySwappers <- list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap) - -test_that("Tree can be found", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(1) - random11 <- as.phylo(17905853L, 11, letters[1:11]) - expect_error(TreeSearch(unrooted11, dataset = phy11)) - expect_equal(comb11, TreeSearch(random11, dataset = phy11, maxIter = 200, - EdgeSwapper = RootedTBRSwap, verbosity = 0L)) - expect_equal(comb11, TreeSearch(random11, phy11, maxIter = 400, - EdgeSwapper = RootedSPRSwap, verbosity = 0L)) - someOtherTree <- as.phylo(29235922L, 11, letters[1:11]) - expect_equal(comb11, TreeSearch(someOtherTree, phy11, maxIter = 200, - EdgeSwapper = RootedNNISwap, verbosity = 0)) - expect_equal(comb11, Ratchet(random11, phy11, searchIter = 10, searchHits = 5, - swappers = RootySwappers, ratchHits = 3, - verbosity = 0)) - - expect_false(all.equal(comb11, TreeSearch(random11, dataset = phy11, - maxIter = 1000, - stopAtPlateau = 1, verbosity = 0))) - - expect_true(all.equal( - MaximizeParsimony(phy11, tree = CollapseNode(random11, 13))[[1]], - comb11 - )) - expect_true(all.equal( - MaximizeParsimony(phy11, tree = random11, verbosity = 0L)[[1]], - comb11 - )) - expect_true(all.equal( - MaximizeParsimony(phy11, random11, ratchIter = 0, verbosity = 0L)[[1]], - comb11 - )) - - # Interestingly, a good example of a case with multiple optima that require - # ratchet to move between - iw <- MaximizeParsimony(phy11, random11, ratchIter = 1, tbrIter = 5, - concavity = 10, verbosity = 0L)[[1]] - expect_equal(comb11, iw) -# TODO: Sectorial Search not working yet! -# expect_equal(SectorialSearch(RandomTree(phy11, 'a'), phy11, verbosity = -1), comb11) -}) - -test_that("Tree search finds shortest tree", { - true_tree <- ape::read.tree(text = "(((((1,2),3),4),5),6);") - malformed_tree <- ape::read.tree(text = "((((1,2),3),4),5,6);") - dataset <- TreeTools::StringToPhyDat('110000 111000 111100', 1:6, byTaxon = FALSE) - expect_error(TreeSearch(malformed_tree, dataset)) - start_tree <- TreeTools::RenumberTips(ape::read.tree( - text = "(((1, 6), 3), (2, (4, 5)));"), true_tree$tip.label) - expect_equal(TreeLength(start_tree, dataset), 6) - morphyObj <- PhyDat2Morphy(dataset) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = NNISwap, - verbosity = 0), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = SPRSwap, - verbosity = -1), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = TBRSwap, - verbosity = -1), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedNNISwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedSPRSwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedTBRSwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - ratchetScore <- attr(Ratchet(start_tree, dataset, - swappers = list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap), - ratchIter = 3, searchHits = 5, verbosity = 0), 'score') - expect_equal(3, TreeLength(true_tree, dataset), ratchetScore) -}) - - -test_that("Profile parsimony works in tree search", { - random11 <- as.phylo(17905853L, 11, letters[1:11]) # Rooted on 'a' - - # Use more iterations than necessary locally, as RNG may differ on other - # platforms. - expect_equal(comb11, - MaximizeParsimony(phy11, c(random11, random11), # multiPhylo - ratchIter = 1, tbrIter = 2, maxHits = 10, - concavity = 'profile', verbosity = 0)[[1]]) - - - sillyData <- lapply(1:22, function (i) c(rep(0, i - 1), rep(1, 22 - i), - rep(1, 22 - i), rep(0, i - 1)))#, sample(2, 20, replace = TRUE)-1)) - names(sillyData) <- as.character(1:22) - dataset <- TreeTools::PhyDat(sillyData) - readyData <- PrepareDataProfile(dataset) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - rTree <- randomTree <- RandomTree(dataset, '1') - expect_lte(TreeLength(rTree, readyData), TreeLength(rTree, dataset)) - expect_equal(90, TreeLength(referenceTree, dataset), TreeLength(referenceTree, readyData)) - expect_gt(TreeLength(rTree, readyData, 'profile'), - TreeLength(referenceTree, readyData, 'profile')) - - quickTS <- TreeSearch(rTree, dataset, TreeScorer = MorphyLength, EdgeSwapper = RootedNNISwap, - maxIter = 1600, maxHits = 40, verbosity = 0) - expect_equal(42L, attr(quickTS, 'score')) - - quickFitch <- Ratchet(rTree, dataset, TreeScorer = MorphyLength, suboptimal = 2, - swappers = RootySwappers, ratchHits = 3, searchHits = 15, - searchIter = 100, ratchIter = 500, - verbosity = 0L) - expect_equal(42, attr(quickFitch, 'score')) - - -}) - -test_that("Ratchet fails gracefully", { - expect_error(Ratchet(unrooted11, data11)) -}) diff --git a/tests/testthat/test-Jackknife.R b/tests/testthat/test-Jackknife.R deleted file mode 100644 index e6b1f56e1..000000000 --- a/tests/testthat/test-Jackknife.R +++ /dev/null @@ -1,46 +0,0 @@ -context('Jackknife.R') - -test_that("Jackknife supports are correct", { - true_tree <- ape::read.tree(text = "((((((A,B),C),D),E),F),out);") - start_tree <- ape::read.tree(text = "(((((A,D),B),E),(C,F)),out);") - dataset <- TreeTools::StringToPhyDat('1100000 1110000 1111000 1111100 1100000 1110000 1111000 1111100 1001000', - 1:7, byTaxon = FALSE) - names(dataset) <- c(LETTERS[1:6], 'out') - - expect_error(Jackknife(unroot(true_tree), dataset)) - expect_error(Jackknife(start_tree, dataset, resampleFreq = 0)) - expect_error(Jackknife(start_tree, dataset, resampleFreq = 9/10)) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - strict <- TreeSearch(start_tree, dataset, verbosity = 0) - expect_equal(1, length(unique(list(true_tree), list(start_tree)))) # Right tree found - jackTrees <- Jackknife(strict, dataset, resampleFreq = 4/7, searchIter = 24L, - searchHits = 7L, EdgeSwapper=RootedTBRSwap, - jackIter = 20L, verbosity = 0L) - - # Note: one cause of failure could be a change in characters sampled, due to randomness - expect_true(length(unique(jackTrees)) > 2L) -}) - -test_that("Jackknife ouputs good for node.labels", { - library('TreeTools', quietly = TRUE) # for as.phylo - - # jackTrees will usually be generated with Jackknife(), but for simplicity: - jackTrees <- as.phylo(1:100, 8) - - tree <- as.phylo(0, 8) - expect_equal(c('', '', '0.13', '0.08', '0.14', '1', '1'), - JackLabels(tree, jackTrees, plot = FALSE)) - - tree <- RootTree(as.phylo(0, 8), c('t1', 't4')) - expect_equal(c('', '0.08', '0.13', '', '0.14', '1', '1'), - JackLabels(tree, jackTrees, plot = FALSE)) - - skip_if_not_installed('vdiffr') - vdiffr::expect_doppelganger('plot-jackknife', function() { - expect_equal(as.double(JackLabels(tree, jackTrees, plot = FALSE)[-c(1, 4)]), - unname(JackLabels(tree, jackTrees))) - }) -}) diff --git a/tests/testthat/test-MaximizeParsimony.R b/tests/testthat/test-MaximizeParsimony.R deleted file mode 100644 index c17017156..000000000 --- a/tests/testthat/test-MaximizeParsimony.R +++ /dev/null @@ -1,139 +0,0 @@ -library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) - -test_that("Profile fails gracefully", { - dataset <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 3, f = 3)) - expect_warning(PrepareDataProfile(dataset)) - expect_warning(MaximizeParsimony(dataset, concavity = 'pr')) -}) - -test_that("Constraints work", { - constraint <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 0, f = 0)) - characters <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 0, - 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - set.seed(0) - ewResults <- MaximizeParsimony(characters, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint) - expect_equal(PectinateTree(letters[1:6]), ewResults[[1]]) - expect_equal(c(seed = 0, start = 1, final = 0), - attr(ewResults, 'firstHit')) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, concavity = 'p', - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)[[1]]) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, concavity = 10, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)[[1]]) - # Start tree not consistent with constraint - dataset <- characters - tree <- PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, - PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')), - ratchIter = 0, constraint = constraint)[[1]]) - - - dataset <- MatrixToPhyDat(matrix(c(0, 0, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:7], NULL))) - constraint <- MatrixToPhyDat(matrix(c(0, 0, 1, '?', 1, 1, - 1, 1, 1, 1, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - cons <- consensus(MaximizeParsimony(dataset, constraint = constraint)) - expect_true(as.Splits(as.logical(c(0, 0, 1, 1, 1)), letters[c(1:3, 5:6)]) %in% - as.Splits(DropTip(cons, c('d', 'g')))) - - expect_true(as.Splits(as.logical(c(0, 0, 0, 0, 1, 1)), letters[1:6]) %in% - as.Splits(DropTip(cons, 'g'))) - -}) - -test_that("Inconsistent constraints fail", { - constraint <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 0, - 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - expect_error(MaximizeParsimony(constraint, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)) -}) - -test_that("MaximizeParsimony() times out", { - data('congreveLamsdellMatrices', package = 'TreeSearch') - dataset <- congreveLamsdellMatrices[[42]] - startTime <- Sys.time() - MaximizeParsimony(dataset, ratchIter = 10000, tbrIter = 1, maxHits = 1, - maxTime = 0) - expect_gt(as.difftime(5, units = 'secs'), Sys.time() - startTime) -}) - -test_that("Mismatched tree/dataset handled with warnings", { - treeAf <- read.tree(text = "(a, (b, (c, (d, (e, f)))));") - treeBg <- read.tree(text = "(g, (b, (c, (d, (e, f)))));") - datAf <- StringToPhyDat('110000 110000 111100 111000', - letters[1:6], byTaxon = FALSE) - datAe <- StringToPhyDat('11000 11000 11110 11100', - letters[1:5], byTaxon = FALSE) - datAg <- StringToPhyDat('1100000 1100000 1111000 1110000', - letters[1:7], byTaxon = FALSE) - - QP <- function (...) MaximizeParsimony(..., ratchIter = 0, maxHits = 1, - verbosity = 0) - - expect_equal(5, NTip(expect_warning(QP(datAf, treeBg)))) - expect_equal(5, NTip(expect_warning(QP(datAe, treeAf)))) - expect_equal(6, NTip(expect_warning(QP(datAg, treeAf)))) - expect_equal(5, NTip(expect_warning(QP(datAf, treeBg, constraint = datAe)))) - expect_equal(6, NTip(QP(datAf, treeAf, constraint = datAe))) - expect_equal(6, NTip(expect_warning(QP(datAf, treeAf, constraint = datAg)))) -}) - -test_that("Root retained if not 1", { - tr <- RootTree(BalancedTree(8), 't5') - dataset <- StringToPhyDat('11000000 11100000 11110000 11111000', - paste0('t', 1:8), byTaxon = FALSE) - - mpt <- MaximizeParsimony(dataset, tr) - expect_equal(5, mpt[[1]]$edge[14, 2]) -}) - -test_that("Resample() fails and works", { - expect_error(Resample(0)) - dataset <- MatrixToPhyDat(rbind( - a = c(0, 0, 0, 0, 0, 0), - b = c(0, 0, 0, 0, 0, 0), - c = c(1, 1, 0, 0, 0, 1), - d = c(1, 1, 0, 0, 1, 0), - e = c(1, 1, 1, 1, 1, 1), - f = c(1, 1, 1, 1, 1, 1))) - - expect_error(Resample(dataset, method = 'ERROR')) - expect_error(Resample(dataset, proportion = 0)) - expect_error(Resample(dataset, proportion = 6 / 7)) - - nRep <- 42L # Arbitrary number to balance runtime vs false +ves & -ves - bal <- as.Splits(BalancedTree(dataset)) - - skip_if_not_installed("TreeTools", "1.4.5.9003") # postorder / as.Splits order - jackTrees <- replicate(nRep, Resample(dataset, NJTree(dataset), verbosity = 0L)) - jackSplits <- as.Splits(unlist(jackTrees, recursive = FALSE)) - jackSupport <- rowSums(vapply(jackSplits, function (sp) in.Splits(bal, sp), - logical(3))) - # This test could be replaced with a more statistically robust alternative! - expect_equal(c(1, 1/2, 0) * sum(vapply(jackTrees, length, 1L)), jackSupport, - tolerance = 0.2) - - bootTrees <- replicate(nRep, Resample(dataset, method = 'bootstrap', - verbosity = 0)) - #bootSupport <- rowSums(vapply(lapply(bootTrees, `[[`, 1), - bootSupport <- rowSums(vapply(unlist(bootTrees, recursive = FALSE), - function (tr) in.Splits(bal, as.Splits(tr)), - logical(3))) - # This test could be replaced with a more statistically robust alternative! - expect_equal(c(1, 1/2, 0) * sum(vapply(bootTrees, length, 1L)), bootSupport, - tolerance = 0.2) - -}) diff --git a/tests/testthat/test-NNI.R b/tests/testthat/test-NNI.R deleted file mode 100644 index 573493fad..000000000 --- a/tests/testthat/test-NNI.R +++ /dev/null @@ -1,25 +0,0 @@ -test_that("Errors fail gracefully", { - expect_error(nni(TreeTools::BalancedTree(2)$edge, 0, 0)) -}) - -test_that("cNNI()", { - tr <- Preorder(root(TreeTools::BalancedTree(letters[1:7]), 'a', resolve.root = TRUE)) - expect_equal(ape::read.tree(text="(a,(b,((c,d),((e,g),f))));"), - cNNI(tr, 0, 1)) # Edge '9' - expect_equal(ape::read.tree(text="(a,(b,((c,d),((f,g),e))));"), - cNNI(tr, 0, 0)) # Edge '9' - expect_equal(cNNI(tr, 0, 1), cNNI(tr, 4, 1)) - expect_equal(ape::read.tree(text="(a, (b, (g, ((c, d), (e, f)))));"), # Edge 8 - cNNI(tr, 1, 1)) - expect_equal(cNNI(tr, 1, 1), cNNI(tr, 1, 3)) - expect_equal(ape::read.tree(text="(a, (b, ((e, f), ((c, d), g))));"), # Edge 8 - cNNI(tr, 1, 2)) - expect_equal(cNNI(tr, 1, 2), cNNI(tr, 1, 0)) - expect_equal(ape::read.tree(text="(a, (b, (d, (c, (g, (e, f))))));"), # Edge 5 - cNNI(tr, 2, 1)) - expect_equal(ape::read.tree(text="(a, ((b, (c, d)), ((e, f), g)));"), # Edge 4 - cNNI(tr, 3, 1)) - suppressWarnings(RNGversion('3.5.0')) - set.seed(0) # sample.int gives 4, 1 - expect_equal(cNNI(tr, 0, 1), cNNI(tr)) -}) \ No newline at end of file diff --git a/tests/testthat/test-PlotCharacter.R b/tests/testthat/test-PlotCharacter.R deleted file mode 100644 index b2498c296..000000000 --- a/tests/testthat/test-PlotCharacter.R +++ /dev/null @@ -1,125 +0,0 @@ -test_that("PlotCharacter()", { - - skip_if_not_installed("TreeTools", "1.5.0") # Changes plotting order - Character <- function (str, plot = FALSE, ...) { - tree <- ape::read.tree(text = - "((((((a, b), c), d), e), f), (g, (h, (i, (j, (k, l))))));") - dataset <- TreeTools::StringToPhyDat(str, tips = tree) - PlotCharacter(tree, dataset, - edge.width = 3, plot = plot, ...) - } - - expect_equal(structure(c(FALSE, FALSE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, - TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, - TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, - TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - TRUE, FALSE, FALSE, FALSE, TRUE, TRUE), .Dim = c(23L, 5L), .Dimnames = list( - NULL, c("-", "0", "1", "2", "3"))), - Character("23--1??--032", updateTips = TRUE)) - - skip_if_not_installed('vdiffr') - skip_if_not_installed("ape", "5.5.2") # Node colours - - Test <- if (interactive()) { - function (str) invisible(Character(str, plot = TRUE)) - } else { - function (str) { - vdiffr::expect_doppelganger( - paste0('PlotChar_', - gsub('?', 'Q', - gsub('(', 'd', - gsub(')', 'b', - gsub('-', 'I', str, - fixed = TRUE), fixed = TRUE), fixed = TRUE), fixed = TRUE)), - function() Character(str, plot = TRUE)) - } - } - - Test("23--1??--032") - Test("23--1??(-0)-(01)32") - Test("23??1????032") - Test("11--????--11") - Test("000011????00") - Test("????????????") - Test("-------?????") - Test("------------") - Test("1234(45)AACGTTT") - - # From TGuillerme testing suite: - Test("11-------100") - Test("1100----1100") - Test("000011110000") - Test("1---1111---1") - Test("----1111---1") - Test("01----010101") - Test("01---1010101") - Test("1??--??--100") - Test("21--3??--032") - Test("11--1??--111") - Test("11--1000001-") - Test("01------0101") - Test("110--?---100") - Test("210--100--21") - Test("????----1???") - Test("23--1----032") - Test("1----1----1-") - Test("-1-1-1--1-1-") - - Test("--------0101") - Test("10101-----01") - Test("011--?--0011") - Test("110--??--100") - Test("21--1----012") - Test("11----111111") - Test("210210------") - Test("----1111----") - Test("230--??1--32") - Test("023--??1--32") - Test("023-???1--32") - Test("23--1?1--023") - Test("----1010----") - Test("------11---1") - Test("10----11---1") - Test("320--??3--21") -}) - -test_that("Edge cases work", { - tree <- ape::read.tree(text = '(a, (b, ((c, d), (e, f))));') - dataset <- TreeTools::StringToPhyDat('-01100', tips = tree) - if (interactive()) { - PlotCharacter(tree, dataset) - } else { - expect_equal(c('-' = FALSE, '0' = TRUE, '1' = FALSE), - PlotCharacter(tree, dataset, plot = FALSE)[9, ]) - } - - tree <- ape::read.tree(text = '(a, (b, (c, (d, (e, f)))));') - dataset <- TreeTools::StringToPhyDat('--0101', tips = tree) - if (interactive()) { - PlotCharacter(tree, dataset) - } else { - expect_equal(cbind('-' = c(1, 1, 0, 0, 0), - '0' = c(0, 0, 1, 1, 1), - '1' = c(0, 0, 1, 1, 1)), - 1 * PlotCharacter(tree, dataset, plot = FALSE)[7:11, ]) - } -}) - -test_that("Out-of-sequence works", { - skip_if_not_installed('vdiffr') - skip_if_not_installed("ape", "5.5.2") # Node colours - vdiffr::expect_doppelganger('PlotChar_out-of-sequence', - function () { - PlotCharacter(ape::read.tree(text = '(a, (b, (c, d)));'), - TreeTools::StringToPhyDat('1342', tips = c('a', 'c', 'd', 'b')) - ) - }) -}) \ No newline at end of file diff --git a/tests/testthat/test-RMorphy.R b/tests/testthat/test-RMorphy.R deleted file mode 100644 index 9533338b8..000000000 --- a/tests/testthat/test-RMorphy.R +++ /dev/null @@ -1,25 +0,0 @@ -context("RMorphy.C[++]") - -test_that("NULL pointers don't cause crash", { - ptr <- mpl_new_Morphy() - expect_equal(0, mpl_delete_Morphy(ptr)) - expect_true(is.na(mpl_delete_Morphy(ptr))) -}) - -test_that("Pointers survive garbage collection", { - ptr <- mpl_new_Morphy() - gc() - expect_equal(0, mpl_delete_Morphy(ptr)) -}) - -test_that("preorder_morphy()", { - library('TreeTools', quietly = TRUE) - tree <- Preorder(RootTree(BalancedTree(6), 1)) - dat <- MatrixToPhyDat(matrix(c(0, 1, 0, 1, 0, 1, - 0, 0, 0, 1, 1, 1), byrow = FALSE, 6, - dimnames = list(TipLabels(6), NULL))) - morphyObj <- PhyDat2Morphy(dat) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - tree$edge - 1 - expect_equal(4L, preorder_morphy(tree$edge, morphyObj)) -}) diff --git a/tests/testthat/test-RandomTreeScore.R b/tests/testthat/test-RandomTreeScore.R deleted file mode 100644 index 4dded7dbb..000000000 --- a/tests/testthat/test-RandomTreeScore.R +++ /dev/null @@ -1,45 +0,0 @@ -test_that("RandomMorphyTree() errors are handled", { - skip_if(TRUE) - expect_error(RandomMorphyTree(-1)) - expect_error(RandomMorphyTree(0)) - expect_error(RandomMorphyTree(1)) -}) - -test_that("Two tip 'random' tree", { - skip_if(TRUE) - expect_equal(RandomMorphyTree(2), list(c(2, 2, 2), 0, 1)) -}) - -test_that("RandomTreeScore() on small trees", { - skip_if(TRUE) - mo <- mpl_new_Morphy() - expect_equal(0L, RandomTreeScore(mo)) - mpl_delete_Morphy(mo) - - tokens <- matrix(c( - 0, '-', '-', 1, 1, 2, - 0, '-', '-', 1, 1, 2, - 0, '-', '-', 0, 0, 0), byrow = TRUE, nrow = 3L, - dimnames = list(letters[1:3], NULL)) - - # One leaf - pd <- TreeTools::MatrixToPhyDat(tokens[1, , drop = FALSE]) - morphyObj <- PhyDat2Morphy(pd) - expect_equal(mpl_get_numtaxa(morphyObj), 1L) - expect_equal(0, RandomTreeScore(morphyObj)) - morphyObj <- UnloadMorphy(morphyObj) - - # Two leaves - pd <- TreeTools::MatrixToPhyDat(tokens[2:3, , drop = FALSE]) - morphyObj <- PhyDat2Morphy(pd) - expect_equal(mpl_get_numtaxa(morphyObj), 2L) - expect_equal(RandomTreeScore(morphyObj), 3L) - morphyObj <- UnloadMorphy(morphyObj) - - # Three leaves - pd <- TreeTools::MatrixToPhyDat(tokens) - morphyObj <- PhyDat2Morphy(pd) - expect_equal(RandomTreeScore(morphyObj), 3L) - morphyObj <- UnloadMorphy(morphyObj) - -}) diff --git a/tests/testthat/test-TreeSearch_utilities.R b/tests/testthat/test-TreeSearch_utilities.R deleted file mode 100644 index 872a23cba..000000000 --- a/tests/testthat/test-TreeSearch_utilities.R +++ /dev/null @@ -1,6 +0,0 @@ -test_that("EmptyDataset()", { - tree <- TreeTools::PectinateTree(8) - ret <- EmptyPhyDat(tree) - expect_equal(TipLabels(tree), names(ret)) - expect_true(inherits(ret, 'phyDat')) -}) diff --git a/tests/testthat/test-data_manipulation.R b/tests/testthat/test-data_manipulation.R deleted file mode 100644 index fbdcf28f2..000000000 --- a/tests/testthat/test-data_manipulation.R +++ /dev/null @@ -1,133 +0,0 @@ -context("data_manipulation.R") - -test_that("Deprecation", { - expect_equal(MinimumLength(1:3), expect_warning(MinimumSteps(1:3))) -}) - -test_that("Minimum step counts are correctly calculated", { - expect_equal(1, MinimumLength(1:3)) - expect_equal(1, MinimumLength(c(1:3, 5))) - expect_equal(0, MinimumLength(c(6, 7, 14))) - expect_equal(1, MinimumLength(0:3)) # 0 representing the inapplicable token - - # ++++, .++., ..++ - expect_equal(0, MinimumLength(c(2046, 384, 1152))) - - # ++++, +..., .++., ..++ - expect_equal(1, MinimumLength(c(15, 8, 6, 3))) - - # ++++++, +....., .++..., .+.+.., ...++. - expect_equal(2, MinimumLength(c(63, 32, 24, 20, 6))) - - dudDat <- TreeTools::StringToPhyDat('----{-,1}22', letters[1:7]) - expect_equal('----<-,1>22', TreeTools::PhyDatToString(dudDat, '>', ',')) - expect_equal(0, attr(PrepareDataIW(dudDat), 'min.length')) - - dudTwo <- TreeTools::StringToPhyDat('{-1}{-2}{-3}2233', letters[1:7]) - expect_equal('{-1}{-2}{-3}2233', TreeTools::PhyDatToString(PrepareDataIW(dudTwo))) - - tr <- ape::read.tree(text='(((a, b), c), (d, (e, ((f, g), (h, (i, (j, k)))))));') - expect_equal(CharacterLength(tr, compress = TRUE, - TreeTools::StringToPhyDat('11---22--33', letters[1:11])), - MinimumLength(c(0, 0, 0, 0, 0, 0, 2, 2, 4, 4, 8, 8))) - - # 04, 14, 24, 34, 05, 16, 27, 38, 9A - # In this case, chosing the most common state (4) means that we have to choose 567&8 too - # 012&3 is a better solution - # We also have to choose one of 9 or A, but it doesn't matter which. - expect_equal(4, MinimumLength(c( - 2^0 + 2^4, - 2^1 + 2^4, - 2^2 + 2^4, - 2^3 + 2^4, - 2^0 + 2^5, - 2^1 + 2^6, - 2^2 + 2^7, - 2^3 + 2^8, - 2^9 + 2^10 - ))) - - data('inapplicable.datasets') - expect_equal(c(1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1, - 1, 2, 1, 1, 4, 3, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 4, 1, - 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), - MinimumLength(inapplicable.phyData[[4]], compress = TRUE)) - -}) - -test_that("PrepareDataProfile() handles empty matrices", { - dat <- TreeTools::MatrixToPhyDat(matrix(c(0, 1, rep('?', 5)), - dimnames = list(letters[1:7], NULL))) - expectation <- dat[0] - attr(expectation, 'info.amounts') <- numeric(0) - expect_equal(expectation, PrepareDataProfile(dat)) -}) - -test_that("PrepareDataProfile()", { - - # Easy one - mtx <- cbind(c('0', '0', 1,1,1,1), - c(0,0,1,1,1,1),# again - c(0,0,0,1,1,'?')) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - phy1 <- TreeTools::MatrixToPhyDat(mtx) - expect_equivalent(phy1, PrepareDataProfile(phy1)) - expect_equal(attributes(phy1), attributes(PrepareDataProfile(phy1))[1:10]) - - # Easy one - mtx <- cbind(c('0', '0', 1,1,1,1), - c(1,1,0,0,0,0),# flipped - c(0,0,0,1,1,'{012}')) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - phy2 <- TreeTools::MatrixToPhyDat(mtx) - expect_equivalent(phy1, PrepareDataProfile(phy2)) - expect_equal(attributes(PrepareDataProfile(phy1)), - attributes(PrepareDataProfile(phy2))) - - - mtx <- cbind(c('0', '0', 1,1,1, '2', '2', 3,3,3,3), - c('?', '?', 1,1,1, '?', '?', 0,0,0,0), - c(0,0,1,1,1,2,2,3,3,3,3),# again - c(rep('?', 5), '2', '2', 0,0,0,0), - c('?', '?', 1,1,1, 1,1, 0,0,0,0), - c('0', '1', rep('?', 9)) - ) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - dataset <- TreeTools::MatrixToPhyDat(mtx) - - q <- '?' - decomposed <- matrix(c(0,0,q,q,q,q,q,1,1,1,1, - q,q,0,0,0,q,q,1,1,1,1, - q,q,q,q,q,0,0,1,1,1,1, - - q,q,0,0,0,q,q,1,1,1,1, - - 0,0,q,q,q,q,q,1,1,1,1, - q,q,0,0,0,q,q,1,1,1,1, - q,q,q,q,q,0,0,1,1,1,1, - - q,q,q,q,q,0,0,1,1,1,1, - q,q,0,0,0,0,0,1,1,1,1), - ncol = 9, dimnames = list(letters[1:11], NULL)) - - - expect_warning(pd <- PrepareDataProfile(dataset)) - expect_equal(decomposed, PhyDatToMatrix(pd)) - expect_equal(c(1, 2, 3, 2, 1, 2, 3, 3, 4), attr(pd, 'index')) - expect_equal(c(2, 3, 3, 1), attr(pd, 'weight')) - - dataset2 <- TreeTools::MatrixToPhyDat(mtx[!mtx[, 1] %in% c(0, 2), ]) - expect_equal(attr(PrepareDataProfile(dataset2), 'info.amounts'), - attr(pd, 'info.amounts')[1:3, 2, drop = FALSE]) - - - data('Lobo', package = "TreeTools") - expect_warning(prep <- PrepareDataProfile(Lobo.phy)) - expect_equal(c(17, attr(prep, 'nr')), - dim(attr(prep, 'info.amounts'))) - - -}) diff --git a/tests/testthat/test-iw-scoring.R b/tests/testthat/test-iw-scoring.R deleted file mode 100644 index d829751ef..000000000 --- a/tests/testthat/test-iw-scoring.R +++ /dev/null @@ -1,78 +0,0 @@ -test_that("IW Scoring", { - library('TreeTools', quietly = TRUE, warn.conflicts = FALSE) - data('Lobo', package = 'TreeTools') - dataset <- Lobo.phy - - #dataset <- ReadAsPhyDat('c:/research/r/hyoliths/mbank_X24932_6-19-2018_744.nex') - tree <- NJTree(dataset) - - - .IWScore <- function (edge, morphyObjs, weight, minLength, concavity) { - steps <- preorder_morphy_by_char(edge, morphyObjs) - homoplasies <- steps - minLength - fit <- homoplasies / (homoplasies + concavity) - sum(fit * weight) - } - - concavity <- 4.5 - epsilon <- sqrt(.Machine$double.eps) - - - tree <- Preorder(RenumberTips(tree, names(dataset))) - nTip <- NTip(tree) - edge <- tree$edge - - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - startWeights <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) - - nLevel <- length(at$level) - nChar <- at$nr - nTip <- length(dataset) - cont <- at$contrast - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) colnames(cont)[x][1]), - '?') - inappLevel <- at$levels == '-' - - if (any(inappLevel)) { - # TODO this is a workaround until MinimumLength can handle {-, 1} - cont[cont[, inappLevel] > 0, ] <- 0 - ambiguousToken <- at$allLevels == '?' - cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 - } - - # Perhaps replace with previous code: - # inappLevel <- which(at$levels == "-") - # cont[, inappLevel] <- 0 - - powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) - tmp <- as.integer(cont %*% powersOf2) - unlisted <- unlist(dataset, use.names = FALSE) - binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) - minLength <- apply(binaryMatrix, 1, MinimumLength) - - tokenMatrix <- matrix(simpleCont[unlisted], nChar, nTip, byrow = FALSE) - charInfo <- apply(tokenMatrix, 1, CharacterInformation) - needsInapp <- rowSums(tokenMatrix == '-') > 2 - inappSlowdown <- 3L # A guess - rawPriority <- charInfo / ifelse(needsInapp, inappSlowdown, 1) - priority <- startWeights * rawPriority - informative <- needsInapp | charInfo > 0 - # Will work from end of sequence to start. - charSeq <- seq_along(charInfo)[informative][order(priority[informative])] - 1L - - - weight <- startWeights - - expect_equal(.IWScore(edge, morphyObjects, weight, minLength, concavity), - morphy_iw(edge, morphyObjects, weight, minLength, charSeq, - concavity, Inf)) - - expect_equal(Inf, morphy_iw(edge, morphyObjects, weight, minLength, charSeq, - concavity, 0)) - -}) \ No newline at end of file diff --git a/tests/testthat/test-mpl_morphy_objects.R b/tests/testthat/test-mpl_morphy_objects.R deleted file mode 100644 index 038e6ef62..000000000 --- a/tests/testthat/test-mpl_morphy_objects.R +++ /dev/null @@ -1,37 +0,0 @@ -test_that("PhyDat2Morphy() errors", { - expect_error(PhyDat2Morphy(NA)) -}) - -test_that("UnloadMorphy() errors", { - expect_error(UnloadMorphy(NA)) -}) - -test_that("GapHandler()", { - expect_error(GapHandler(0)) - tokens <- matrix(c('-', '-', 0, 0), byrow = TRUE, nrow = 4L, - dimnames = list(letters[1:4], NULL)) - pd <- TreeTools::MatrixToPhyDat(tokens) - - morphyObj <- PhyDat2Morphy(pd) - expect_equal(0, RandomTreeScore(morphyObj)) - expect_equal("Inapplicable", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- PhyDat2Morphy(pd, 'ambigu') - expect_equal(0, RandomTreeScore(morphyObj)) - expect_equal("Missing data", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- PhyDat2Morphy(pd, 'eXt') - expect_lt(0, RandomTreeScore(morphyObj)) - expect_equal("Extra state", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- SingleCharMorphy('-0-0', 'eXt') - expect_lt(0, RandomTreeScore(morphyObj)) - expect_equal("Extra state", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - expect_error(SingleCharMorphy('-0-0', 'ERROR')) - expect_error(GapHandler(morphyObj)) -}) diff --git a/tests/testthat/test-pp-fitch.R b/tests/testthat/test-pp-fitch.R deleted file mode 100644 index dec536272..000000000 --- a/tests/testthat/test-pp-fitch.R +++ /dev/null @@ -1,92 +0,0 @@ -context("pp_exact") - -# TODO this test was recovered from a stash and requires updating -- -# or may be obselete. -test_that("Profile score correct for small trees", { - library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) - tree <- as.phylo(200, 9) - - mataset <- matrix(c( - 1, 1, 1, 1, 0, 0, 0, 0, 0, # 3 steps - 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps - 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps again [duplicated] - 0, 1, 0, 0, 0, 0, 0, 1, 1, # 1 step - 2, 1, 1, 1, 1, 1, 1, 1, 1),# 1 step; non-informative - nrow = 9, dimnames = list(paste0('t', 1:9), NULL)) - - - dataset <- MatrixToPhyDat(mataset) - - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - weight <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) - - nLevel <- length(at$level) - nChar <- at$nr - cont <- at$contrast - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) at$levels[x][1]), - '?') - inappLevel <- at$levels == '-' - - unlisted <- unlist(dataset, use.names = FALSE) - charSeq <- seq_len(nChar) - 1L - - tokenMatrix <- matrix(simpleCont[unlisted], nChar, 9, byrow = FALSE) - profileTables <- apply(tokenMatrix, 1, table) - if (inherits(profileTables, 'matrix')) { - profileTables <- lapply(seq_len(ncol(profileTables)), function (i) profileTables[, i]) - } - data('profiles', package = 'TreeSearch') - profileCost <- lapply(profileTables, function (x) { - x <- sort(x[x > 1]) - n <- length(x) - prof <- switch(n, - 0, - profiles[[sum(x)]][[n]][[x[1] - 1L]] - ) - }) - profileExtra <- lapply(profileCost, function (x) x - x[1]) - fixedCost <- -sum(vapply(profileCost, `[[`, 1, 1) * weight) - maxScore <- sum(Log2Unrooted(vapply(profileTables, sum, 1))) - pad <- function (x, len) { - ret <- double(len) - ret[seq_along(x)] <- x - ret - } - profiles <- vapply(profileExtra, pad, double(4), 4) - - TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, - charSeq, profiles, Inf) - - PP <- function (costs) { - TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, - charSeq, costs, Inf) - } - - - # Use integer-step profile tables - extraSteps <- matrix(1:4, 4, 4) - expect_equal(TreeLength(tree, dataset), PP(costs = extraSteps)) - expect_equal(3 + 2 + 2 + 1 + 1, - TreeLength(tree, dataset)) -}) - - -test_that("Profile score can be calculated from real data", { - data(referenceTree) - data(congreveLamsdellMatrices) - tree <- referenceTree - dataset <- PrepareDataProfile(congreveLamsdellMatrices[[1]]) - expect_equal(TreeLength(tree, dataset), - sum(CharacterLength(tree, dataset, compress = TRUE) * - attr(dataset, 'weight'))) - score <- TreeLength(tree, dataset, 'profile') - - # Check score hasn't materially changed: - # 511.732 is "previous value"; not manually checked. - expect_equal(511.732, score, tolerance = 0.01) -}) diff --git a/tests/testthat/test-pp-info_extra_step.R b/tests/testthat/test-pp-info_extra_step.R deleted file mode 100644 index 4a34e6550..000000000 --- a/tests/testthat/test-pp-info_extra_step.R +++ /dev/null @@ -1,95 +0,0 @@ -context("pp_info_extra_step.R") -library("TreeSearch", quietly = TRUE) - -test_that("Bad input safely handled", { - expect_equal(0, WithOneExtraStep(1)) - expect_error(WithOneExtraStep(2, 2, 2)) - - expect_equal(0, Carter1(5, 6, 4)) - expect_equal(-Inf, LogCarter1(5, 6, 4)) - expect_equal(-Inf, Log2Carter1(5, 6, 4)) -}) - -test_that("StepInformation() works", { - expect_equal(c(`0` = 0), StepInformation(rep(3L, 10), ambiguousTokens = 3)) - expect_equal(c(`0` = 0), StepInformation(c(4L, rep(3L, 10)), 3)) - expect_true(all(is.finite(StepInformation(rep.int(1:3, times = c(139, 45, 41)), - ambiguousTokens = 3)))) - expect_true(all(is.finite(StepInformation( - char = rep.int(1:2, times = c(600, 600)))))) -}) - -test_that("Carter1() matches profile counts", { - data("profiles", package = "TreeSearch") - Test <- function (a, b) { - n <- sum(a, b) - counted <- 2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]] * NUnrooted(n) - m <- as.integer(names(counted)) - for (mi in m) { - expect_equal(log2(Carter1(mi, a, b)), Log2Carter1(mi, b, a)) - expect_equal(log(Carter1(mi, a, b)), LogCarter1(mi, b, a)) - } - expect_equivalent(counted, - cumsum(vapply(m, Carter1, a = a, b = b, double(1)))) - } - - Test(2, 4) - Test(2, 5) - Test(2, 6) - Test(2, 7) - Test(2, 8) - - Test(3, 4) - Test(3, 5) - Test(3, 6) - Test(3, 7) - - Test(4, 4) - Test(4, 5) - Test(4, 6) - - Test(5, 4) - Test(5, 5) - -}) - -test_that("WithOneExtraStep() input format", { - expect_equal(WithOneExtraStep(7, 5), WithOneExtraStep(c(5, 7))) -}) - -test_that("WithOneExtraStep()", { - library("TreeTools", quietly = TRUE) - data("profiles", package = "TreeSearch") - Test <- function (a, b) { - n <- sum(a, b) - expect_equivalent(2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]][2] * NUnrooted(n), - NUnrootedMult(c(a, b)) + WithOneExtraStep(c(a, b))) - } - - Test(4, 2) - Test(3, 3) - Test(8, 2) - Test(4, 3) - Test(7, 3) - Test(6, 4) - Test(5, 5) - - expect_equal(NUnrooted(6) / NUnrooted(5) * WithOneExtraStep(2:3), - WithOneExtraStep(1:3)) - expect_equal(NUnrooted(10) / NUnrooted(5) * WithOneExtraStep(2:3), - WithOneExtraStep(2:3, rep(1, 5))) -}) - -test_that(".LogCumSumExp()", { - Test <- function (x) { - naive <- log(cumsum(exp(x))) - if (all(is.finite(naive))) { - expect_equal(naive, .LogCumSumExp(x)) - } else { - expect_true(all(is.finite(.LogCumSumExp(x)))) - } - } - Test(log(c(1:5, 5:1))) - Test(c(10, 700, 100)) - Test(c(10, 7000, 100)) -}) \ No newline at end of file diff --git a/tests/testthat/test-pp-random-tree.R b/tests/testthat/test-pp-random-tree.R deleted file mode 100644 index 38f4cbbd7..000000000 --- a/tests/testthat/test-pp-random-tree.R +++ /dev/null @@ -1,141 +0,0 @@ -# NB: RandomTreeScore uses C's RNG, so no point in setting seed. -MorphyAction <- function (Action) expect_equal("ERR_NO_ERROR", mpl_translate_error(Action)) -MorphyWith <- function (char) { - nTip <- nchar(char) - 1L - morphyObj <- mpl_new_Morphy() - MorphyAction(mpl_init_Morphy(nTip, 1, morphyObj)) - MorphyAction(mpl_attach_rawdata(char, morphyObj)) - MorphyAction(mpl_set_num_internal_nodes(nTip - 1L, morphyObj)) - MorphyAction(mpl_set_parsim_t(1, 'FITCH', morphyObj)) - MorphyAction(mpl_set_charac_weight(1, 1, morphyObj)) - MorphyAction(mpl_apply_tipdata(morphyObj)) - class(morphyObj) <- 'morphyPtr' - morphyObj -} - - -context("pp: Tree randomness") -test_that("four-tip trees are randomly distributed", { - nTrees <- 36000 - stringency <- 0.005 # low numbers mean you'll rarely fail by chance - nTip <- 4 - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, 1/(nTip - 1)) - rTrees <- vapply(logical(nTrees), function (XX) - unlist(RandomMorphyTree(nTip)), integer((nTip * 4) - 3)) - expect_true(all(rTrees[1 + (seq_len(nTip - 1)), ] %in% nTip + seq_len(nTip - 2))) - expect_lt(expectedBounds[1], sum(rTrees[2, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[2, ] == 5)) - expect_lt(expectedBounds[1], sum(rTrees[3, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[3, ] == 5)) - expect_lt(expectedBounds[1], sum(rTrees[4, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[4, ] == 5)) - - expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] > expectedBounds[1])) - expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] < expectedBounds[2])) - - expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] < nTrees - expectedBounds[1])) - expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] > nTrees - expectedBounds[2])) -}) - -test_that("four-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - nTrees <- 6000 - stringency <- 0.005 - nTip <- 4 - - morphyObj <- MorphyWith('0011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - NUnrooted(nTip - 1L) / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - expect_lt(expectedBounds[1], sum(scores==1)) - expect_gt(expectedBounds[2], sum(scores==1)) -}) - -test_that("five-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - nTrees <- 6000 - stringency <- 0.005 - nTip <- 5 - morphyObj <- MorphyWith('00011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - NUnrooted(nTip - 1) / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - expect_equal(2L, max(scores)) - expect_lt(expectedBounds[1], sum(scores == 1)) - expect_gt(expectedBounds[2], sum(scores == 1)) -}) - - -test_that("six-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - nTrees <- 6000 - stringency <- 0.005 - nTip <- 6 - - morphyObj <- MorphyWith('000011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - NUnrooted(5) / NUnrooted(6)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - morphyObj <- UnloadMorphy(morphyObj) - - expect_true(max(scores) == 2) - expect_lt(expectedBounds[1], sum(scores==1)) - expect_gt(expectedBounds[2], sum(scores==1)) - - morphyObj <- MorphyWith('001122;') - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - 7 / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), - integer(1)) - morphyObj <- UnloadMorphy(morphyObj) - - expect_true(all(scores %in% 2:4)) - expect_lt(expectedBounds[1], sum(scores == 2)) - expect_gt(expectedBounds[2], sum(scores == 2)) - - morphyObj <- MorphyWith('000111;') - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - 3 * 3 / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - # unloaded on exit; don't unload twice || morphyObj <- UnloadMorphy(morphyObj) - - expect_true(max(scores) == 3) - expect_lt(expectedBounds[1], sum(scores == 1)) - expect_gt(expectedBounds[2], sum(scores == 1)) - -}) - -test_that("twelve-tip trees are randomly scored", { - nTrees <- 12000 # 12000 seems to throw false +ve too often? - stringency <- 0.01 # increased from 0.005 to avoid false +ves - nTip <- 12 - morphyObj <- MorphyWith('000000011111;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - NUnrooted(7) * (2 * 7 - 3) * - NUnrooted(5) * (2 * 5 - 3) / NUnrooted(nTip)) - - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), - integer(1L)) - # table(scores) - - expect_equal(5L, max(scores)) - nScoring1 <- sum(scores == 1) - expect_lt(expectedBounds[1], nScoring1) - expect_gt(expectedBounds[2], nScoring1) -}) diff --git a/tests/testthat/test-tree_length.R b/tests/testthat/test-tree_length.R deleted file mode 100644 index d3df7bab3..000000000 --- a/tests/testthat/test-tree_length.R +++ /dev/null @@ -1,270 +0,0 @@ -## Test cases designed by Thomas Guillerme - -test_that("Failures are graceful", { - library("TreeTools", quietly = TRUE) - data('inapplicable.datasets') - dat <- inapplicable.phyData[[1]] - unrooted <- RandomTree(dat, root = FALSE) - expect_error(TreeLength(unrooted, dat)) - - mo <- PhyDat2Morphy(dat) - on.exit(mo <- UnloadMorphy(mo)) - - sparse <- DropTip(RandomTree(dat, root = FALSE), 10) - expect_error(MorphyTreeLength(sparse, mo)) - expect_error(MorphyTreeLength(sparse, NA)) - - expect_error(MorphyLength(sparse$edge[, 1], sparse$edge[, 2], mo, nTaxa = 0)) - expect_error(MorphyLength(sparse$edge[, 1], sparse$edge[, 2], dat)) - - expect_null(TreeLength(NULL)) -}) - -test_that("Deprecations throw warning", { - data('inapplicable.datasets') - dat <- inapplicable.phyData[[1]] - tree <- TreeTools::RandomTree(dat, root = TRUE) - expect_equal(TreeLength(tree, dat), - expect_warning(Fitch(tree, dat))) - expect_equal(CharacterLength(tree, dat, compress = TRUE), - expect_warning(FitchSteps(tree, dat))) - -}) - -test_that("Morphy generates correct lengths", { - ## Tree - tree <- ape::read.tree(text = "((((((1,2),3),4),5),6),(7,(8,(9,(10,(11,12))))));") - relabel <- ape::read.tree(text = "((6,(5,(4,(3,(2,1))))),(7,(8,(9,(10,(11,12))))));") - trees <- list(tree, relabel) - characters <- c("23--1??--032", # 0, expect score = 5 - "1---1111---1", # 1, expect score = 2 - "1100----1100", # 2, expect score = 3 - "11-------100", # 3, expect score = 2 - "----1111---1", # 4, expect score = 1 - "01----010101", # 5, expect score = 5 - "01---1010101", # 6, expect score = 5 - "1??--??--100", # 7, expect score = 2 - "21--3??--032", # 8, expect score = 5 - "11--1??--111", # 9, expect score = 2 - "11--1000001-", # 10, expect score = 2 - "01------0101", # 11, expect score = 4 - "110--?---100", # 12, expect score = 3 - "11--1??--111", # 13, expect score = 2 - "210--100--21", # 14, expect score = 5 - "????----1???", # 15, expect score = 0 - "23--1----032", # 16, expect score = 5 - "1----1----1-", # 17, expect score = 2 - "-1-1-1--1-1-", # 18, expect score = 4 - "23--1??--032", # 19, expect score = 5 - "--------0101", # 20, expect score = 2 - "10101-----01", # 21, expect score = 4 - "011--?--0011", # 22, expect score = 3 - "110--??--100", # 23, expect score = 3 - "11--1000001-", # 24, expect score = 2 - "21--1----012", # 25, expect score = 5 - "11----111111", # 26, expect score = 1 - "10101-----01", # 27, expect score = 4 - "210210------", # 28, expect score = 4 - "----1111----", # 29, expect score = 0 - "230--??1--32", # 30, expect score = 5 - "023--??1--32", # 31, expect score = 5 - "023-???1--32", # 32, expect score = 4 - "23--1?1--023", # 33, expect score = 5 - "----1010----", # 34, expect score = 2 - "------11---1", # 35, expect score = 1 - "10----11---1", # 36, expect score = 3 - "320--??3--21", # 37, expect score = 5 - "000011110000" # 38, expect score = 2 - ) - ## Results - expected_results <- c(5, 2, 3, 2, 1, 5, 5, 2, 5, 2, 2, 4, 3, 2, 5, 0, 5, 2, - 4, 5, 2, 4, 3, 3, 2, 5, 1, 4, 4, 0, 5, 5, 4, 5, 2, 1, - 3, 5, 2) - expected_minLength <- c(3, 0, 1, 1, 0, 1, 1, 1, 3, 0, 1, 1, 1, 0, 2, 0, 3, 0, - 0, 3, 1, 1, 1, 1, 1, 2, 0, 1, 2, 0, 3, 3, 3, 3, 1, 0, - 1, 3, 1) - expected_homoplasies <- expected_results - expected_minLength - - ##plot(tree); nodelabels(12:22); tiplabels(0:11) - ## Run the tests - for(test in seq_along(characters)) { - morphyObj <- SingleCharMorphy(characters[test]) - tree_length <- MorphyTreeLength(tree, morphyObj) - morphyObj <- UnloadMorphy(morphyObj) - #if (tree_length != expected_results[test]) message("Test case", test - 1, characters[test], "unequal: Morphy calcluates", - # tree_length, "instead of", expected_results[test],"\n") - expect_equal(tree_length, expected_results[test]) - } - - ## Test combined matrix - bigPhy <- TreeTools::StringToPhyDat(paste0(characters, collapse = '\n'), - tree$tip.label, - byTaxon = FALSE) - profPhy <- TreeTools::StringToPhyDat(paste0(characters[-c(15, 29, 34)], - collapse = '\n'), - tree$tip.label, - byTaxon = FALSE) - expect_identical(characters, - TreeTools::PhyToString(bigPhy, byTaxon = FALSE, - concatenate = FALSE)) - expect_identical(paste0(collapse = '', - vapply(characters, substr, start = 0, stop = 1, - character(1))), - substr(TreeTools::PhyToString(bigPhy, ps = ';', - useIndex = TRUE, - byTaxon = TRUE, - concatenate = TRUE), - start = 0, stop = length(characters))) - - morphyObj <- PhyDat2Morphy(bigPhy) - moSummary <- summary(morphyObj) - expect_equal(c(length(bigPhy), attr(bigPhy, 'nr'), length(bigPhy) - 1), - c(moSummary$nTax, moSummary$nChar, moSummary$nInternal)) - tree_length <- MorphyTreeLength(tree, morphyObj) - morphyObj <- UnloadMorphy(morphyObj) - - expect_equal('0123', moSummary$allStates) - expect_equal(tree_length, sum(expected_results)) - expect_equal(tree_length, TreeLength(tree, bigPhy)) - expect_equal(tree_length, TreeLength(relabel, bigPhy)) - expect_equal(rep(tree_length, 2), TreeLength(trees, bigPhy)) - - expected_fit <- expected_homoplasies / (expected_homoplasies + 6) - tree_score_iw <- TreeLength(tree, bigPhy, concavity = 6) - expect_equal(sum(expected_fit), tree_score_iw) - expect_equal(tree_score_iw, TreeLength(relabel, bigPhy, concavity = 6)) - expect_equal(vapply(trees, TreeLength, double(1), bigPhy, concavity = 6), - TreeLength(trees, bigPhy, concavity = 6)) - - expect_equal(vapply(trees, TreeLength, double(1), profPhy, concavity = 'p'), - TreeLength(trees, profPhy, concavity = 'profile')) - - - ## Run the bigger tree tests - bigTree <- ape::read.tree( - text = "((1,2),((3,(4,5)),(6,(7,(8,(9,(10,((11,(12,(13,(14,15)))),(16,(17,(18,(19,20))))))))))));") - bigChars <- c("11111---111---11---1") - ## Results - expected_results <- c(3) - - ## Run the tests - for(test in 1:length(bigChars)) { - phy <- TreeTools::StringToPhyDat(bigChars[test], bigTree$tip.label) - # Presently a good test to confirm that PhyDat2Morphy works with single-character phys - morphyObj <- PhyDat2Morphy(phy) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - tree_length <- MorphyTreeLength(bigTree, morphyObj) - - expect_equal(tree_length, expected_results[test]) - } -}) - -test_that("(random) lists of trees are scored", { - data("congreveLamsdellMatrices", package = 'TreeSearch') - mat <- congreveLamsdellMatrices[[42]] - - # Expected values calculated from 100k samples - expect_gt(t.test(TreeLength(100, mat), mu = 318.5877)$p.val, 0.001) - expect_gt(t.test(TreeLength(100, mat, 10L), mu = 17.16911)$p.val, 0.001) - expect_gt(t.test(TreeLength(100, mat, 'profile'), mu = 830.0585)$p.val, 0.001) -}) - -test_that("TreeLength() handles subsetted trees", { - data('inapplicable.datasets') - dat <- inapplicable.phyData[[1]] - t8 <- as.phylo(1:4, 8, tipLabels = names(dat)[1:8]) - expect_equal(4, length(TreeLength(t8, dat))) -}) - -test_that("Profile scoring is reported correctly", { - data('congreveLamsdellMatrices') - dataset <- congreveLamsdellMatrices[[42]] - prepDataset <- PrepareDataProfile(dataset) - tree <- NJTree(prepDataset) - edge <- Preorder(tree)$edge - at <- attributes(prepDataset) - profiles <- attr(prepDataset, 'info.amounts') - charSeq <- seq_along(prepDataset[[1]]) - 1L - - characters <- PhyToString(prepDataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - startWeights <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1)), - add = TRUE) - - expect_equal(TreeLength(tree, dataset, 'profile'), - TreeLength(tree, prepDataset, 'profile')) - expect_equal(TreeLength(tree, dataset, 'profile'), - morphy_profile(edge, morphyObjects, startWeights, charSeq, - profiles, Inf)) -}) - -test_that("CharacterLength() fails gracefully", { - expect_error(CharacterLength(as.phylo(1, 8), 1)) - - data('inapplicable.datasets') - dataset <- inapplicable.phyData[[12]] - # Unlabelled leaves - expect_error(CharacterLength(structure(list(), class = 'phylo'), dataset)) - - # Missing leaves - expect_error(CharacterLength(as.phylo(1, 4), dataset)) - tMinus1 <- as.phylo(1, 42, tipLabels = names(dataset)[-1]) - expect_equal(CharacterLength(tMinus1, dataset[-1]), - CharacterLength(tMinus1, dataset)) - expect_error(CharacterLength(as.phylo(1, 43), dataset)) - tPlus1 <- as.phylo(1, 44, tipLabels = c('extra', names(dataset))) - expect_equal(CharacterLength(DropTip(tPlus1, 'extra'), dataset), - CharacterLength(tPlus1, dataset)) - expect_error(CharacterLength(as.phylo(1:2, 43, tipLabels = names(dataset)), - dataset)) - # no error: - CharacterLength(as.phylo(1, 43, tipLabels = names(dataset)), dataset) - - expect_equal(c(53, 59, 6), - as.numeric(table(CharacterLength(NJTree(dataset[1:4, ]), - dataset[1:4], compress = TRUE)))) - -}) - -test_that("Character compression works", { - data('inapplicable.datasets') - dataset <- inapplicable.phyData[[12]] - tree <- TreeTools::NJTree(dataset) - expect_equal(137, length(CharacterLength(tree, dataset))) - expect_equal(137, length(MinimumLength(dataset))) - expect_equal(137, length(Consistency(dataset, tree))) - expect_equal(118, length(CharacterLength(tree, dataset, compress = TRUE))) - expect_equal(118, length(MinimumLength(dataset, compress = TRUE))) - expect_equal(118, length(Consistency(dataset, tree, compress = TRUE))) -}) - -test_that("X_MorphyLength", { - dataset <- congreveLamsdellMatrices[[42]] - morphyObj <- PhyDat2Morphy(dataset) - on.exit(UnloadMorphy(morphyObj)) - nTaxa <- mpl_get_numtaxa(morphyObj) - - tree <- NJTree(dataset) - edgeList <- Postorder(Preorder(tree$edge)) - parent <- edgeList[, 1] - child <- edgeList[, 2] - - maxNode <- nTaxa + mpl_get_num_internal_nodes(morphyObj) - rootNode <- nTaxa + 1L - allNodes <- rootNode:maxNode - - parentOf <- parent[match(seq_len(maxNode), child)] - parentOf[rootNode] <- rootNode # Root node's parent is a dummy node - leftChild <- child[length(parent) + 1L - match(allNodes, rev(parent))] - rightChild <- child[match(allNodes, parent)] - - expected <- MorphyLength(parent, child, morphyObj) - - expect_equal(expected, - C_MorphyLength(parentOf, leftChild, rightChild, morphyObj)) - expect_equal(expected, - GetMorphyLength(parentOf - 1, leftChild - 1, rightChild - 1, - morphyObj)) -}) diff --git a/tests/testthat/test-zzz-tree-rearrange.R b/tests/testthat/test-zzz-tree-rearrange.R deleted file mode 100644 index 442ff3a74..000000000 --- a/tests/testthat/test-zzz-tree-rearrange.R +++ /dev/null @@ -1,270 +0,0 @@ -library("TreeTools") - -context("Tree rearrangements") -tree5a <- read.tree(text = '(a, (b, (c, (d, e))));') -tree5b <- read.tree(text = '((a, b), (c, (d, e)));') -tree6 <- Preorder(read.tree(text = "((a, (b, (c, d))), (e, f));")) -tree6b <- Preorder(read.tree(text = "((a, (b, c)), (d, (e, f)));")) -tree8 <- read.tree(text = "(((a, (b, (c, d))), (e, f)), (g, h));") -tree11 <- read.tree(text = "((((a, b), (c, d)), e), ((f, (g, (h, i))), (j, k)));") -attr(tree5a, 'order') <- attr(tree5b, 'order') <- attr(tree8, 'order') <- attr(tree11, 'order') <- 'preorder' - -test_that("Malformed trees don't crash anything", { - treeDoubleNode <- read.tree(text = "((((((1,2)),3),4),5),6);") - treePolytomy <- read.tree(text = "((((1,2,3),4),5),6);") - treeDoublyPoly <- read.tree(text = "(((((1,2,3)),4),5),6);") - - expect_error(NNI(treeDoubleNode)) - expect_error(NNI(treePolytomy)) - expect_error(NNI(treeDoublyPoly)) - - expect_error(SPR(treeDoubleNode)) - expect_error(SPR(treePolytomy)) - expect_error(SPR(treeDoublyPoly)) - - expect_error(TBR(treeDoubleNode)) - expect_error(TBR(treePolytomy)) - expect_error(TBR(treeDoublyPoly)) - -}) - -test_that("NNI works", { - trComb <- read.tree(text = "(((((1,2),3),4),5),6);") - edge <- trComb$edge - Test <- function (e, r, e1, e2) { - edge1 <- edge - edge1[c(e1, e2), 2] <- edge1[c(e2, e1), 2] - edge1 <- do.call(cbind, RenumberEdges(edge1[, 1], edge1[, 2])) - expect_equal(edge1, nni(trComb$edge, e, r)) - } - Test(0, 0, 5, 7) - Test(0, 2, 5, 7) - Test(3, 0, 5, 7) # Option 0 == option 3. - Test(0, 1, 6, 7) - Test(1, 0, 4, 8) - Test(1, 1, 7, 8) - Test(2, 0, 3, 9) - Test(2, 1, 8, 9) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - nniComb <- NNI(trComb) - expect_equal(nniComb$tip.label, trComb$tip.label) - expect_equal(nniComb$Nnode, trComb$Nnode) - expect_equal(nniComb, read.tree(text = "(((((3,2),1),4),5),6);")) -}) - - -test_that("SPR works", { - testTree <- Preorder(root(BalancedTree(7), 1, resolve.root = TRUE)) - edge <- testTree$edge - expect_equal(spr(edge, 66), cSPR(testTree, 66)$edge) - - Test <- function (m, p1, r1) { - test.tr <- testTree - test.tr$edge <- spr(edge, m) - - oldWay <- SortTree(root(SPR(testTree, p1, r1), 't1', resolve.root = TRUE)) - expect_equal(oldWay, SortTree(test.tr)) - } - Test(0, 1, 5) - Test(64, 1, 5) # Modulo 64! - Test(1, 1, 6) - Test(2, 1, 7) - Test(3, 1, 8) - Test(4, 1, 9) - Test(5, 1, 10) - Test(6, 1, 11) - Test(7, 1, 12) - - Test(8 , 3, 5) - Test(9 , 3, 6) - Test(10, 3, 7) - Test(11, 3, 8) - Test(12, 3, 9) - Test(13, 3, 10) - Test(14, 3, 11) - Test(15, 3, 12) - - Test(16, 5, 3) - Test(17, 5, 9) - Test(18, 5, 10) - Test(19, 5, 11) - Test(20, 5, 12) - - Test(28, 7, 3) - Test(29, 7, 4) - Test(30, 7, 8) - Test(31, 7, 9) - Test(32, 7, 10) - Test(33, 7, 11) - Test(34, 7, 12) - - Test(35, 8, 3) - Test(36, 8, 6) - Test(37, 8, 7) - Test(38, 9, 3) - Test(39, 9, 4) - Test(40, 9, 5) - Test(41, 9, 6) - Test(42, 9, 7) - Test(43, 10, 3) - Test(44, 10, 4) - Test(45, 10, 5) - Test(46, 10, 6) - Test(47, 10, 7) - Test(48, 10, 8) - Test(49, 10, 12) - Test(50, 11, 3) - Test(51, 11, 4) - Test(52, 11, 5) - Test(53, 11, 6) - Test(54, 11, 7) - Test(55, 11, 8) - Test(56, 11, 12) - Test(57, 12, 3) - Test(58, 12, 4) - Test(59, 12, 5) - Test(60, 12, 6) - Test(61, 12, 7) - Test(62, 12, 10) - Test(63, 12, 11) -}) - -test_that("TBR can swap over root", { - expect_equal(TBR(tree5a, 1, c(7, 1)), read.tree(text = '(a, (d, (e, (c, b))));')) - expect_equal(TBR(tree5a, 2, c(5, 1)), read.tree(text = '(a, (c, (b, (d, e))));')) - expect_equal(TBR(tree5b, 1, c(7, 1)), read.tree(text = '((a, b), (d, (c, e)));')) - expect_equal(TBR(tree5b, 4, c(7, 1)), read.tree(text = '((a, b), (d, (c, e)));')) -}) - -test_that("TBR works", { - tree <- tree8 - ### expect_equal(TBR(tree, 3, 1 ), read.tree(text = "((a, ((b, (c, d)), (e, f))), (g, h));")) - ### expect_warning(expect_identical(TBR(tree, 3, 2), tree)) - ### expect_warning(expect_identical(TBR(tree, 3, 3), tree)) - ### expect_warning(expect_identical(TBR(tree, 3, 4), tree)) - ### expect_warning(expect_identical(TBR(tree, 3, 44), tree)) - ### expect_equal(TBR(tree, 3, 5 ), read.tree(text = "((((a, b), (c, d)), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 6 ), read.tree(text = "(((b, (a, (c, d))), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 7 ), read.tree(text = "(((b, ((a, c), d)), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 8 ), read.tree(text = "(((b, (c, (a, d))), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 9 ), read.tree(text = "(((b, (c, d)), (a, (e, f))), (g, h));")) - ### expect_equal(TBR(tree, 3, 10), read.tree(text = "(((b, (c, d)), ((a, e), f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 11), read.tree(text = "(((b, (c, d)), (e, (a, f))), (g, h));")) - ### expect_equal(TBR(tree, 3, 12), read.tree(text = "(((b, (c, d)), (e, f)), (a, (g, h)));")) - ### expect_equal(TBR(tree, 3, 13), read.tree(text = "(((b, (c, d)), (e, f)), ((g, a), h));")) - ### expect_equal(TBR(tree, 3, 14), read.tree(text = "(((b, (c, d)), (e, f)), (g, (a, h)));")) - - tree <- tree8 - expect_equal(TBR(tree, 6, c(1 , 6)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) - expect_equal(TBR(tree, 6, c(1 , 7)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) - expect_equal(TBR(tree, 6, c(1 , 8)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) - expect_equal(TBR(tree, 6, c(2 , 6)), TBR(tree, 6, c(2 , 7))) - expect_equal(TBR(tree, 6, c(2 , 6)), TBR(tree, 6, c(2 , 8))) - expect_equal(TBR(tree, 6, c(2 , 6)), read.tree(text = "((((a, b), (c, d)), (e, f)), (g, h));")) - expect_equal(TBR(tree, 6, c(3 , 6)), read.tree(text = "(((((c, d), a), b), (e, f)), (g, h));")) - expect_warning(expect_identical(TBR(tree, 6, c(4 , 6)), tree)) - expect_warning(expect_identical(TBR(tree, 8, c(6 , 8)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(5 , 6)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(6 , 6)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(6 , 7)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(6 , 8)), tree)) - expect_equal(TBR(tree, 6, c(9 , 6)), read.tree(text = "(((a, b), ((c, d), (e, f))), (g, h));")) - expect_equal(TBR(tree, 6, c(10, 6)), read.tree(text = "(((a, b), (((c, d), e), f)), (g, h));")) - expect_equal(TBR(tree, 6, c(11, 6)), read.tree(text = "(((a, b), (((c, d), f), e)), (g, h));")) - expect_equal(TBR(tree, 6, c(12, 6)), read.tree(text = "(((a, b), (e, f)), ((c, d), (g, h)));")) - expect_equal(TBR(tree, 6, c(13, 6)), read.tree(text = "(((a, b), (e, f)), (((c, d), g), h));")) - expect_equal(TBR(tree, 6, c(14, 6)), read.tree(text = "(((a, b), (e, f)), (((c, d), h), g));")) - expect_warning(expect_identical(TBR(tree, 6, c(6, 15)), tree)) - - expect_equal(TBR(tree, 4, c(1, 5)), read.tree(text = "(((a, (e, f)), (b, (c, d))), (g, h));")) - expect_equal(TBR(tree, 4, c(1, 6)), read.tree(text = "(((a, (e, f)), (b, (c, d))), (g, h));")) - expect_equal(TBR(tree, 4, c(1, 7)), read.tree(text = "(((a, (e, f)), (c, (b, d))), (g, h));")) - expect_equal(TBR(tree, 4, c(1, 8)), read.tree(text = "(((a, (e, f)), (d, (b, c))), (g, h));")) - - tree <- tree11 - tree$edge.length = rep.int(1, 20) - expect_equal(TBR(tree11, 11, c(8, 17)), read.tree(text = '((j, k), (e, ((a, b), (c, (d, (i, (h, (g, f))))))));')) - expect_equal(TBR(tree11, 11, c(2, 11)), read.tree(text = '((j, k), (e, (((a, b), (c, d)), (f, (g, (i, h))))));')) - expect_warning(TBR(tree11, 10, c(2, 11))) - expect_equal(TBR(tree11, 10, c(3, 11)), read.tree(text = '(e, ((c, d), ((a, b), ((j, k), (f, (g, (h, i)))))));')) - -}) - -test_that("RootedTBR fails", { - # tree8 <- read.tree(text = "(((a, (b, (c, d))), (e, f)), (g, h));") - # tree11 <- read.tree(text = "((((a, b), (c, d)), e), ((f, (g, (h, i))), (j, k)));") - - expect_equal(TBR(tree8, 4, c(3, 7)), RootedTBR(tree8, 4, c(3, 7))) - expect_equal(TBR(tree8, 4, c(1, 5)), RootedTBR(tree8, 4, c(1, 5))) - expect_warning(RootedTBR(tree5a, edgeToBreak = 1)) - expect_warning(RootedTBR(tree5a, edgeToBreak = 2)) - expect_equal(RootedTBR(tree5a, edgeToBreak = 3, mergeEdges=6), read.tree(text = '(a, (c, (b, (d, e))));')) - expect_silent(replicate(100, RootedTBR(tree5a))) - expect_warning(RootedTBR(tree8, 4, c(13, 6))) - expect_warning(RootedTBR(read.tree(text = '((a, b), (c, d));'))) -}) - -test_that("RootedSPR fails", { - expect_warning(RootedSPR(read.tree(text = '((a, b), (c, d));'))) - expect_warning(RootedSPR(tree8, edgeToBreak=1)) - expect_warning(RootedSPR(tree8, edgeToBreak=13)) - expect_warning(RootedSPR(tree8, edgeToBreak=14)) - warnTree1 <- read.tree(text = '((a, (b, (c, d))), (e, (f, (g, h))));') - warnTree2 <- read.tree(text = '((a, (b, (c, d))), (((e, f), g), h));') - attr(warnTree1, 'order') <- attr(warnTree2, 'order') <- 'preorder' - expect_warning(RootedSPR(warnTree1, 3)) - expect_warning(RootedSPR(warnTree1, 10)) - expect_warning(RootedSPR(warnTree2, 9)) - expect_warning(RootedSPR(warnTree2, 8)) -}) - -test_that("SPR is special case of TBR", { - expect_equal(SPR(tree11, 3, 9), TBR(tree11, 3, c(3, 9))) - expect_equal(SPR(tree11, 12, 9), TBR(tree11, 12, c(12, 9))) - expect_equal(root(SPR(tree11, 1, 14), letters[1:5], resolve.root=TRUE), TBR(tree11, 1, c(1, 14))) - expect_error(SPR(tree11, 1, 6)) -}) - -#' @author Martin R. Smith -CheckTreeSanity <- function (tree) { - nTip <- length(tree$tip.label) - nNode <- tree$Nnode - edge <- tree$edge - parent <- edge[, 1] - child <- edge[, 2] - aok <- TRUE - expect_true(all(parent > nTip), - info=paste0("Parent nodes on edge(s) ", paste(which(parent <= nTip), collapse=', '), - " are tips (nTip = ", nTip, ')') - ) - expect_equal(min(parent), nTip + 1, - info=paste0("Root is numbered ", min(parent), "; expecting ", nTip + 1) - ) - expect_false(min(parent) %in% child, - info=paste0("Root node (", min(parent), ") is child of edge ", paste0(which(min(parent) == child), collapse=', ')) - ) - expect_true(all(seq_len(nTip) %in% child)) # No missing tips - expect_equal(max(parent), nTip + nNode) - tips <- child <= nTip - expect_equal(sum(tips), nTip) - expect_true(all(child[!tips] > parent[!tips]), info="Parent nodes must be > child nodes") -} - -suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 -set.seed(0) -small_tree <- rtree(8) -large_tree <- rtree(80) -test_that("NNI trees conform to phylo expectations", { - for (i in 1:60) CheckTreeSanity(small_tree <- NNI(small_tree)) - for (i in 1:250) CheckTreeSanity(large_tree <- NNI(large_tree)) -}) -test_that("SPR trees conform to phylo expectations", { - for (i in 1:60) CheckTreeSanity(small_tree <- SPR(small_tree)) - for (i in 1:250) CheckTreeSanity(large_tree <- SPR(large_tree)) -}) -test_that("TBR trees conform to phylo expectations", { - for (i in 1:60) CheckTreeSanity(small_tree <- TBR(small_tree)) - for (i in 1:250) CheckTreeSanity(large_tree <- TBR(large_tree)) -}) From 10c422b81842ff4f35f69ba4233eb8578bc63851 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 13:12:21 +0100 Subject: [PATCH 12/28] Squashed commit of the following: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit commit 66f83cf79e3cf0e18b8c2701077005a998078897 Author: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu Sep 23 13:09:39 2021 +0100 Create RcppExports.R commit ebc5be3e897e37dab98b808259a8a118df442537 Author: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu Sep 23 13:08:20 2021 +0100 & commit 6cdc823659b5f2d72a1271aee149135f8a5cb1ca Author: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu Sep 23 13:06:41 2021 +0100 fuse_and_add(ret) → ret.push_back(fuse) commit 00a13511c27ae3ef0beba779cf9e83799b8dab28 Author: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu Sep 23 12:51:34 2021 +0100 push_back a clone commit 7bb024e78192526c9265c71c5b1fb93a079b35a9 Author: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu Sep 23 12:26:05 2021 +0100 Use Rf_error / warnings --- src/rearrange.cpp | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/rearrange.cpp b/src/rearrange.cpp index da29b7ab5..c43d052af 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -308,14 +308,14 @@ inline int16 edge_above(const int16 vert, unique_ptr &parent_edge) { return parent_edge[vert - 1]; } -inline void fuse_and_add (const IntegerMatrix& tree_bits, List& ret, +inline IntegerMatrix fuse(const IntegerMatrix& tree_bits, const int16* graft_edge, const int16* break_edge, const int16* spare_edge, const int16* spare_node) { IntegerMatrix new_tree = clone(tree_bits); new_tree(*spare_edge, 1) = tree_bits(*graft_edge, 1); new_tree(*graft_edge, 1) = *spare_node; new_tree(*break_edge, 0) = *spare_node; - ret.push_back(clone(TreeTools::preorder_edges_and_nodes(new_tree(_, 0), new_tree(_, 1)))); + return TreeTools::preorder_edges_and_nodes(new_tree(_, 0), new_tree(_, 1)); } @@ -461,8 +461,8 @@ List all_spr (const IntegerMatrix edge, } else if (graft_edge == edge_above(break_parent, parent_edge)) { continue; } - fuse_and_add(two_bits, ret, &graft_edge, &break_edge, &spare_edge, - &spare_node); + ret.push_back(fuse(two_bits, &graft_edge, &break_edge, &spare_edge, + &spare_node)); if (graft_edge < 0) break; // TODO REMOVE } } @@ -570,8 +570,8 @@ List all_tbr (const IntegerMatrix edge, } else if (graft_edge == edge_above(break_parent, parent_edge)) { continue; } - fuse_and_add(two_bits, ret, &graft_edge, &break_edge, &spare_edge, - &spare_node); + ret.push_back(fuse(two_bits, &graft_edge, &break_edge, &spare_edge, + &spare_node)); } } else { List rooty_bits = List::create(); @@ -614,12 +614,12 @@ List all_tbr (const IntegerMatrix edge, } for (List::iterator j = rooty_bits.begin(); j != rooty_bits.end(); j++) { IntegerMatrix rooty_bit = *j; - fuse_and_add(rooty_bit, ret, &graft_edge, &break_edge, &spare_edge, - &spare_node); + ret.push_back(fuse(rooty_bit, &graft_edge, &break_edge, &spare_edge, + &spare_node)); } if (graft_edge != edge_above(break_parent, parent_edge)) { - fuse_and_add(two_bits, ret, &graft_edge, &break_edge, &spare_edge, - &spare_node); + ret.push_back(fuse(two_bits, &graft_edge, &break_edge, &spare_edge, + &spare_node)); } } } From 8fa22de0386b3e8107505589c9abdc9c400ca4ea Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 13:13:05 +0100 Subject: [PATCH 13/28] dput errors --- tests/testthat/test-rearrange.cpp.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index 1ec912298..d7b647f86 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -8,11 +8,14 @@ test_that("TBR errors", { }) test_that("SPR errors", { - skip_if(TRUE) + dput("SPR ERRorS") tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) expect_equal(0, length(expect_warning(all_spr(tr$edge, -1)))) + dput("SPR ERRor 1") expect_equal(0, length(expect_warning(all_spr(tr$edge, 1)))) + dput("SPR ERRor 2") expect_equal(0, length(expect_warning(all_spr(tr$edge, 111)))) + dput("SPR ERRor 3 - Completed.") }) test_that("TBR working", { From 3868ff19f5f16df63f8fc14829eb54c8f7ff4731 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 13:22:12 +0100 Subject: [PATCH 14/28] Revert "Delete other tests" This reverts commit 6f2622ebccf28c763e693953d4c2b3f30d301d5e. --- tests/testthat/test-AdditionTree.R | 48 ++++ tests/testthat/test-Concordance.R | 121 +++++++++ tests/testthat/test-CustomSearch.R | 133 ++++++++++ tests/testthat/test-Jackknife.R | 46 ++++ tests/testthat/test-MaximizeParsimony.R | 139 +++++++++++ tests/testthat/test-NNI.R | 25 ++ tests/testthat/test-PlotCharacter.R | 125 ++++++++++ tests/testthat/test-RMorphy.R | 25 ++ tests/testthat/test-RandomTreeScore.R | 45 ++++ tests/testthat/test-TreeSearch_utilities.R | 6 + tests/testthat/test-data_manipulation.R | 133 ++++++++++ tests/testthat/test-iw-scoring.R | 78 ++++++ tests/testthat/test-mpl_morphy_objects.R | 37 +++ tests/testthat/test-pp-fitch.R | 92 +++++++ tests/testthat/test-pp-info_extra_step.R | 95 ++++++++ tests/testthat/test-pp-random-tree.R | 141 +++++++++++ tests/testthat/test-tree_length.R | 270 +++++++++++++++++++++ tests/testthat/test-zzz-tree-rearrange.R | 270 +++++++++++++++++++++ 18 files changed, 1829 insertions(+) create mode 100644 tests/testthat/test-AdditionTree.R create mode 100644 tests/testthat/test-Concordance.R create mode 100644 tests/testthat/test-CustomSearch.R create mode 100644 tests/testthat/test-Jackknife.R create mode 100644 tests/testthat/test-MaximizeParsimony.R create mode 100644 tests/testthat/test-NNI.R create mode 100644 tests/testthat/test-PlotCharacter.R create mode 100644 tests/testthat/test-RMorphy.R create mode 100644 tests/testthat/test-RandomTreeScore.R create mode 100644 tests/testthat/test-TreeSearch_utilities.R create mode 100644 tests/testthat/test-data_manipulation.R create mode 100644 tests/testthat/test-iw-scoring.R create mode 100644 tests/testthat/test-mpl_morphy_objects.R create mode 100644 tests/testthat/test-pp-fitch.R create mode 100644 tests/testthat/test-pp-info_extra_step.R create mode 100644 tests/testthat/test-pp-random-tree.R create mode 100644 tests/testthat/test-tree_length.R create mode 100644 tests/testthat/test-zzz-tree-rearrange.R diff --git a/tests/testthat/test-AdditionTree.R b/tests/testthat/test-AdditionTree.R new file mode 100644 index 000000000..d08724c26 --- /dev/null +++ b/tests/testthat/test-AdditionTree.R @@ -0,0 +1,48 @@ +test_that("Addition tree is more parsimonious", { + data('Lobo', package = 'TreeTools') + L10 <- Lobo.phy[1:10] + seq10 <- names(L10) + Score <- function (tr, k) TreeLength(tr, Lobo.phy, concavity = k) + + set.seed(1) # ensure consistent addition sequence + eq <- AdditionTree(Lobo.phy) + kx <- AdditionTree(L10, sequence = seq10, concavity = 10) + pr <- AdditionTree(L10, sequence = 1:10, concavity = 'pr') + nj <- TreeTools::NJTree(Lobo.phy) + nj10 <- TreeTools::KeepTip(nj, 1:10) + + expect_lt(TreeLength(eq, Lobo.phy), TreeLength(nj, Lobo.phy)) + expect_lt(Score(kx, 10), Score(nj10, 10)) + expect_lt(Score(pr, 'pr'), Score(nj10, 'pr')) +}) + +test_that("Addition tree obeys constraints", { + dataset <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 1, + 0, 1, 1, 0, 0, 1), ncol = 2, + dimnames = list(letters[1:6], NULL))) + constraint <- MatrixToPhyDat(c(a = 0, b = 0, c = 0, d = 0, e = 1, f = 1)) + expect_true(as.Splits(c(F, F, F, F, T, T), letters[1:6]) %in% + as.Splits(AdditionTree(dataset, constraint = constraint), + letters[1:6])) + + cdef <- letters[3:6] + subtree <- TreeTools::KeepTip( + AdditionTree(dataset, constraint = constraint[3:6], seq = letters[1:6]), + cdef) + expect_equal(ape::read.tree(text = '(c, d, (e, f));'), + TreeTools::UnrootTree(subtree)) +}) + +test_that("AdditionTree() handles edge cases", { + library('TreeTools') + dataset <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 1, + 0, 1, 1, 0, 0, 1), ncol = 2, + dimnames = list(letters[1:6], NULL))) + expect_equal(PectinateTree(letters[1:3]), AdditionTree(dataset[1:3])) + expect_equal(UnrootTree(PectinateTree(c('a', 'd', 'b', 'c'))), + UnrootTree(AdditionTree(dataset[1:4], conc = 'pr'))) + # All trees have equal score + expect_equal(5, NTip(AdditionTree(dataset[-4]))) +}) \ No newline at end of file diff --git a/tests/testthat/test-Concordance.R b/tests/testthat/test-Concordance.R new file mode 100644 index 000000000..1a8168c68 --- /dev/null +++ b/tests/testthat/test-Concordance.R @@ -0,0 +1,121 @@ +library("TreeTools", quietly = TRUE) + +test_that("QuartetConcordance() works", { + tree <- BalancedTree(8) + splits <- as.Splits(tree) + mataset <- matrix(c(0, 0, 0, 0, 1, 1, 1, 1, 0, + 0, 1, 0, 1, 0, 1, 0, 1, 0, + 0, 0, 0, 1, 0, 1, 1, 1, 0, + 0, 0, 0, 0, 1, 1, 2, 2, 0, + 0, 0, 1, 1, 2, 2, 3, 3, 0, + 0, 1, 2, 3, 0, 1, 2, 3, 0), 9, + dimnames = list(paste0('t', 1:9), NULL)) + dat <- MatrixToPhyDat(mataset) + expect_equal(unname(QuartetConcordance(tree, dat[, 1])), rep(1, 5)) + # plot(tree); nodelabels(); + expect_equal(QuartetConcordance(tree, dat[, 2]), + c('11' = 0, '12' = 0, '13' = 1/9, '14' = 0, '15' = 0)) + + allQuartets <- combn(8, 4) + for (charI in seq_len(ncol(mataset))) { + qc <- QuartetConcordance(tree, dat[, charI]) + for (splitI in seq_along(splits)) { + split <- splits[[splitI]] + logiSplit <- as.logical(split) + case <- apply(allQuartets, 2, function (q) { + qSplit <- logiSplit[q] + qChar <- mataset[q, charI] + if (identical(unique(table(qSplit)), 2L) && + identical(unique(table(qChar)), 2L)) { + tbl <- table(qSplit, qChar) + tab <- paste0(sort(tbl[tbl > 0]), collapse = '') + switch(tab, + '1111' = FALSE, + '112' = NA, + '13' = NA, + '22' = TRUE, + "4" = NA, + stop(q, ": ", tab) + ) + } else { + NA + } + }) + expect_equal(sum(case, na.rm = TRUE) / sum(!is.na(case)), + unname(qc[as.character(names(split))])) + } + } + + expect_equal(QuartetConcordance(tree, dat[, c(1:4, 6)]), + c('11' = ( 6 + 0 + 6 + 2) / ( 6 + 9 + 6 + 2 + 1), + '12' = ( 6 + 0 + 0 + 2) / ( 6 + 9 + 9 + 2 + 1), + '13' = (36 + 2 + 9 + 12) / (36 + 18 + 18 + 12 + 6), + '14' = ( 6 + 0 + 0 + 7) / ( 6 + 9 + 9 + 7 + 1), + '15' = ( 6 + 0 + 6 + 7) / ( 6 + 9 + 6 + 7 + 1)) + ) +}) + +test_that("QuartetConcordance() handles ambiguity", { + tree <- BalancedTree(12) + splits <- as.Splits(tree) + mataset <- matrix(c(0, 0, '{01}', 0, 0, '{01}', 1, 1, '-', 1, 1, '-', + 0, 1, '?', 0, 1, '?', 0, 1, '(01)', 0, 1, '(01)', + 0, 0, '?', 0, 1, '(12)', 0, 1, '(12)', 1, 1, '(12)', + 0, 0, '?', 0, 0, '?', 1, 1, '?', 2, 2, '?', + 0, 0, '?', 0, 0, '?', 0, 0, '-', 0, 0, '-', + rep('?', 12), + 0, 1, '?', 2, 3, '?', 0, 1, '-', 2, 3, '-'), 12, + dimnames = list(paste0('t', 1:12), NULL)) + dat <- MatrixToPhyDat(mataset) + + expect_equal(unname(QuartetConcordance(tree, dat)[c('16', '18', '19', '21', '23')]), + unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) + expect_equal(unname(QuartetConcordance(tree, dat)[c('15', '17', '19', '20', '22')]), + unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) +}) + +test_that("QuartetConcordance() handles incomplete data", { + tree <- BalancedTree(8) + splits <- as.Splits(tree) + mataset <- matrix(c(0, 0, 0, 0, 0, 0, 0, 1, + rep('?', 8)), 8, + dimnames = list(paste0('t', 1:8), NULL)) + dat <- MatrixToPhyDat(mataset) + + expect_equal(unname(QuartetConcordance(tree, dat)), rep(NA_real_, 5)) +}) + +dataset <- congreveLamsdellMatrices[[10]][, 1] +tree <- TreeTools::NJTree(dataset) + +ConcordantInformation(tree, dataset)['noise'] +TreeLength(tree, dataset, concavity = 'prof') + +test_that("ConcordantInformation() works", { + data(congreveLamsdellMatrices) + dat <- congreveLamsdellMatrices[[10]] + tree <- TreeTools::NJTree(dat) + + ci <- ConcordantInformation(tree, dat) + expect_equal(expect_warning(Evaluate(tree, dat)), ci) + expect_equal(TreeLength(tree, dat, concavity = 'prof'), + unname(ci['noise'])) + expect_equal(Log2Unrooted(22), unname(ci['treeInformation'])) + expect_equal(sum(apply(PhyDatToMatrix(dat), 2, CharacterInformation)), + unname(ci['informationContent'])) + + dataset <- MatrixToPhyDat(cbind(setNames(c(rep(1, 11), 2:5), paste0('t', 1:15)))) + tree <- TreeTools::PectinateTree(length(dataset)) + expect_error(ConcordantInformation(tree, dataset)) + # expect_equal(0, unname(ci['signal'])) + # expect_equal(0, unname(ci['noise'])) + + dataset <- MatrixToPhyDat(c(a = 1, b = 2, c = 1, d = 2, e = 3, f = 3)) + tree <- TreeTools::PectinateTree(dataset) + ci <- expect_warning(ConcordantInformation(tree, dataset)) + expect_equal(c(signal = log2(3)), ci['signal']) + expect_equal(c(noise = log2(3)), ci['noise']) + expect_equal(c(ignored = CharacterInformation(c(0,0,1,1,2,2)) - + log2(3) - log2(3)), ci['ignored']) + +}) diff --git a/tests/testthat/test-CustomSearch.R b/tests/testthat/test-CustomSearch.R new file mode 100644 index 000000000..acf36b8bf --- /dev/null +++ b/tests/testthat/test-CustomSearch.R @@ -0,0 +1,133 @@ +context("TreeSearch.R") +library("TreeTools", quietly = TRUE) +comb11 <- PectinateTree(letters[1:11]) +unrooted11 <- UnrootTree(comb11) +data11 <- cbind(upper.tri(matrix(FALSE, 11, 11))[, 3:10], + lower.tri(matrix(FALSE, 11, 11))[, 2:9]) +rownames(data11) <- letters[1:11] +phy11 <- phangorn::phyDat(data11, type = 'USER', levels = c(FALSE, TRUE)) +RootySwappers <- list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap) + +test_that("Tree can be found", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(1) + random11 <- as.phylo(17905853L, 11, letters[1:11]) + expect_error(TreeSearch(unrooted11, dataset = phy11)) + expect_equal(comb11, TreeSearch(random11, dataset = phy11, maxIter = 200, + EdgeSwapper = RootedTBRSwap, verbosity = 0L)) + expect_equal(comb11, TreeSearch(random11, phy11, maxIter = 400, + EdgeSwapper = RootedSPRSwap, verbosity = 0L)) + someOtherTree <- as.phylo(29235922L, 11, letters[1:11]) + expect_equal(comb11, TreeSearch(someOtherTree, phy11, maxIter = 200, + EdgeSwapper = RootedNNISwap, verbosity = 0)) + expect_equal(comb11, Ratchet(random11, phy11, searchIter = 10, searchHits = 5, + swappers = RootySwappers, ratchHits = 3, + verbosity = 0)) + + expect_false(all.equal(comb11, TreeSearch(random11, dataset = phy11, + maxIter = 1000, + stopAtPlateau = 1, verbosity = 0))) + + expect_true(all.equal( + MaximizeParsimony(phy11, tree = CollapseNode(random11, 13))[[1]], + comb11 + )) + expect_true(all.equal( + MaximizeParsimony(phy11, tree = random11, verbosity = 0L)[[1]], + comb11 + )) + expect_true(all.equal( + MaximizeParsimony(phy11, random11, ratchIter = 0, verbosity = 0L)[[1]], + comb11 + )) + + # Interestingly, a good example of a case with multiple optima that require + # ratchet to move between + iw <- MaximizeParsimony(phy11, random11, ratchIter = 1, tbrIter = 5, + concavity = 10, verbosity = 0L)[[1]] + expect_equal(comb11, iw) +# TODO: Sectorial Search not working yet! +# expect_equal(SectorialSearch(RandomTree(phy11, 'a'), phy11, verbosity = -1), comb11) +}) + +test_that("Tree search finds shortest tree", { + true_tree <- ape::read.tree(text = "(((((1,2),3),4),5),6);") + malformed_tree <- ape::read.tree(text = "((((1,2),3),4),5,6);") + dataset <- TreeTools::StringToPhyDat('110000 111000 111100', 1:6, byTaxon = FALSE) + expect_error(TreeSearch(malformed_tree, dataset)) + start_tree <- TreeTools::RenumberTips(ape::read.tree( + text = "(((1, 6), 3), (2, (4, 5)));"), true_tree$tip.label) + expect_equal(TreeLength(start_tree, dataset), 6) + morphyObj <- PhyDat2Morphy(dataset) + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + + expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = NNISwap, + verbosity = 0), 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = SPRSwap, + verbosity = -1), 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = TBRSwap, + verbosity = -1), 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, + EdgeSwapper = RootedNNISwap, verbosity = -1), + 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, + EdgeSwapper = RootedSPRSwap, verbosity = -1), + 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, + EdgeSwapper = RootedTBRSwap, verbosity = -1), + 'score'), + TreeLength(true_tree, dataset)) + ratchetScore <- attr(Ratchet(start_tree, dataset, + swappers = list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap), + ratchIter = 3, searchHits = 5, verbosity = 0), 'score') + expect_equal(3, TreeLength(true_tree, dataset), ratchetScore) +}) + + +test_that("Profile parsimony works in tree search", { + random11 <- as.phylo(17905853L, 11, letters[1:11]) # Rooted on 'a' + + # Use more iterations than necessary locally, as RNG may differ on other + # platforms. + expect_equal(comb11, + MaximizeParsimony(phy11, c(random11, random11), # multiPhylo + ratchIter = 1, tbrIter = 2, maxHits = 10, + concavity = 'profile', verbosity = 0)[[1]]) + + + sillyData <- lapply(1:22, function (i) c(rep(0, i - 1), rep(1, 22 - i), + rep(1, 22 - i), rep(0, i - 1)))#, sample(2, 20, replace = TRUE)-1)) + names(sillyData) <- as.character(1:22) + dataset <- TreeTools::PhyDat(sillyData) + readyData <- PrepareDataProfile(dataset) + + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + rTree <- randomTree <- RandomTree(dataset, '1') + expect_lte(TreeLength(rTree, readyData), TreeLength(rTree, dataset)) + expect_equal(90, TreeLength(referenceTree, dataset), TreeLength(referenceTree, readyData)) + expect_gt(TreeLength(rTree, readyData, 'profile'), + TreeLength(referenceTree, readyData, 'profile')) + + quickTS <- TreeSearch(rTree, dataset, TreeScorer = MorphyLength, EdgeSwapper = RootedNNISwap, + maxIter = 1600, maxHits = 40, verbosity = 0) + expect_equal(42L, attr(quickTS, 'score')) + + quickFitch <- Ratchet(rTree, dataset, TreeScorer = MorphyLength, suboptimal = 2, + swappers = RootySwappers, ratchHits = 3, searchHits = 15, + searchIter = 100, ratchIter = 500, + verbosity = 0L) + expect_equal(42, attr(quickFitch, 'score')) + + +}) + +test_that("Ratchet fails gracefully", { + expect_error(Ratchet(unrooted11, data11)) +}) diff --git a/tests/testthat/test-Jackknife.R b/tests/testthat/test-Jackknife.R new file mode 100644 index 000000000..e6b1f56e1 --- /dev/null +++ b/tests/testthat/test-Jackknife.R @@ -0,0 +1,46 @@ +context('Jackknife.R') + +test_that("Jackknife supports are correct", { + true_tree <- ape::read.tree(text = "((((((A,B),C),D),E),F),out);") + start_tree <- ape::read.tree(text = "(((((A,D),B),E),(C,F)),out);") + dataset <- TreeTools::StringToPhyDat('1100000 1110000 1111000 1111100 1100000 1110000 1111000 1111100 1001000', + 1:7, byTaxon = FALSE) + names(dataset) <- c(LETTERS[1:6], 'out') + + expect_error(Jackknife(unroot(true_tree), dataset)) + expect_error(Jackknife(start_tree, dataset, resampleFreq = 0)) + expect_error(Jackknife(start_tree, dataset, resampleFreq = 9/10)) + + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + strict <- TreeSearch(start_tree, dataset, verbosity = 0) + expect_equal(1, length(unique(list(true_tree), list(start_tree)))) # Right tree found + jackTrees <- Jackknife(strict, dataset, resampleFreq = 4/7, searchIter = 24L, + searchHits = 7L, EdgeSwapper=RootedTBRSwap, + jackIter = 20L, verbosity = 0L) + + # Note: one cause of failure could be a change in characters sampled, due to randomness + expect_true(length(unique(jackTrees)) > 2L) +}) + +test_that("Jackknife ouputs good for node.labels", { + library('TreeTools', quietly = TRUE) # for as.phylo + + # jackTrees will usually be generated with Jackknife(), but for simplicity: + jackTrees <- as.phylo(1:100, 8) + + tree <- as.phylo(0, 8) + expect_equal(c('', '', '0.13', '0.08', '0.14', '1', '1'), + JackLabels(tree, jackTrees, plot = FALSE)) + + tree <- RootTree(as.phylo(0, 8), c('t1', 't4')) + expect_equal(c('', '0.08', '0.13', '', '0.14', '1', '1'), + JackLabels(tree, jackTrees, plot = FALSE)) + + skip_if_not_installed('vdiffr') + vdiffr::expect_doppelganger('plot-jackknife', function() { + expect_equal(as.double(JackLabels(tree, jackTrees, plot = FALSE)[-c(1, 4)]), + unname(JackLabels(tree, jackTrees))) + }) +}) diff --git a/tests/testthat/test-MaximizeParsimony.R b/tests/testthat/test-MaximizeParsimony.R new file mode 100644 index 000000000..c17017156 --- /dev/null +++ b/tests/testthat/test-MaximizeParsimony.R @@ -0,0 +1,139 @@ +library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) + +test_that("Profile fails gracefully", { + dataset <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 3, f = 3)) + expect_warning(PrepareDataProfile(dataset)) + expect_warning(MaximizeParsimony(dataset, concavity = 'pr')) +}) + +test_that("Constraints work", { + constraint <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 0, f = 0)) + characters <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 0, + 1, 1, 1, 0, 0, 0), ncol = 2, + dimnames = list(letters[1:6], NULL))) + set.seed(0) + ewResults <- MaximizeParsimony(characters, + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint) + expect_equal(PectinateTree(letters[1:6]), ewResults[[1]]) + expect_equal(c(seed = 0, start = 1, final = 0), + attr(ewResults, 'firstHit')) + expect_equal(PectinateTree(letters[1:6]), + MaximizeParsimony(characters, concavity = 'p', + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint)[[1]]) + expect_equal(PectinateTree(letters[1:6]), + MaximizeParsimony(characters, concavity = 10, + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint)[[1]]) + # Start tree not consistent with constraint + dataset <- characters + tree <- PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')) + expect_equal(PectinateTree(letters[1:6]), + MaximizeParsimony(characters, + PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')), + ratchIter = 0, constraint = constraint)[[1]]) + + + dataset <- MatrixToPhyDat(matrix(c(0, 0, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 0, 0), ncol = 2, + dimnames = list(letters[1:7], NULL))) + constraint <- MatrixToPhyDat(matrix(c(0, 0, 1, '?', 1, 1, + 1, 1, 1, 1, 0, 0), ncol = 2, + dimnames = list(letters[1:6], NULL))) + cons <- consensus(MaximizeParsimony(dataset, constraint = constraint)) + expect_true(as.Splits(as.logical(c(0, 0, 1, 1, 1)), letters[c(1:3, 5:6)]) %in% + as.Splits(DropTip(cons, c('d', 'g')))) + + expect_true(as.Splits(as.logical(c(0, 0, 0, 0, 1, 1)), letters[1:6]) %in% + as.Splits(DropTip(cons, 'g'))) + +}) + +test_that("Inconsistent constraints fail", { + constraint <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 0, + 1, 1, 1, 0, 0, 0), ncol = 2, + dimnames = list(letters[1:6], NULL))) + expect_error(MaximizeParsimony(constraint, + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint)) +}) + +test_that("MaximizeParsimony() times out", { + data('congreveLamsdellMatrices', package = 'TreeSearch') + dataset <- congreveLamsdellMatrices[[42]] + startTime <- Sys.time() + MaximizeParsimony(dataset, ratchIter = 10000, tbrIter = 1, maxHits = 1, + maxTime = 0) + expect_gt(as.difftime(5, units = 'secs'), Sys.time() - startTime) +}) + +test_that("Mismatched tree/dataset handled with warnings", { + treeAf <- read.tree(text = "(a, (b, (c, (d, (e, f)))));") + treeBg <- read.tree(text = "(g, (b, (c, (d, (e, f)))));") + datAf <- StringToPhyDat('110000 110000 111100 111000', + letters[1:6], byTaxon = FALSE) + datAe <- StringToPhyDat('11000 11000 11110 11100', + letters[1:5], byTaxon = FALSE) + datAg <- StringToPhyDat('1100000 1100000 1111000 1110000', + letters[1:7], byTaxon = FALSE) + + QP <- function (...) MaximizeParsimony(..., ratchIter = 0, maxHits = 1, + verbosity = 0) + + expect_equal(5, NTip(expect_warning(QP(datAf, treeBg)))) + expect_equal(5, NTip(expect_warning(QP(datAe, treeAf)))) + expect_equal(6, NTip(expect_warning(QP(datAg, treeAf)))) + expect_equal(5, NTip(expect_warning(QP(datAf, treeBg, constraint = datAe)))) + expect_equal(6, NTip(QP(datAf, treeAf, constraint = datAe))) + expect_equal(6, NTip(expect_warning(QP(datAf, treeAf, constraint = datAg)))) +}) + +test_that("Root retained if not 1", { + tr <- RootTree(BalancedTree(8), 't5') + dataset <- StringToPhyDat('11000000 11100000 11110000 11111000', + paste0('t', 1:8), byTaxon = FALSE) + + mpt <- MaximizeParsimony(dataset, tr) + expect_equal(5, mpt[[1]]$edge[14, 2]) +}) + +test_that("Resample() fails and works", { + expect_error(Resample(0)) + dataset <- MatrixToPhyDat(rbind( + a = c(0, 0, 0, 0, 0, 0), + b = c(0, 0, 0, 0, 0, 0), + c = c(1, 1, 0, 0, 0, 1), + d = c(1, 1, 0, 0, 1, 0), + e = c(1, 1, 1, 1, 1, 1), + f = c(1, 1, 1, 1, 1, 1))) + + expect_error(Resample(dataset, method = 'ERROR')) + expect_error(Resample(dataset, proportion = 0)) + expect_error(Resample(dataset, proportion = 6 / 7)) + + nRep <- 42L # Arbitrary number to balance runtime vs false +ves & -ves + bal <- as.Splits(BalancedTree(dataset)) + + skip_if_not_installed("TreeTools", "1.4.5.9003") # postorder / as.Splits order + jackTrees <- replicate(nRep, Resample(dataset, NJTree(dataset), verbosity = 0L)) + jackSplits <- as.Splits(unlist(jackTrees, recursive = FALSE)) + jackSupport <- rowSums(vapply(jackSplits, function (sp) in.Splits(bal, sp), + logical(3))) + # This test could be replaced with a more statistically robust alternative! + expect_equal(c(1, 1/2, 0) * sum(vapply(jackTrees, length, 1L)), jackSupport, + tolerance = 0.2) + + bootTrees <- replicate(nRep, Resample(dataset, method = 'bootstrap', + verbosity = 0)) + #bootSupport <- rowSums(vapply(lapply(bootTrees, `[[`, 1), + bootSupport <- rowSums(vapply(unlist(bootTrees, recursive = FALSE), + function (tr) in.Splits(bal, as.Splits(tr)), + logical(3))) + # This test could be replaced with a more statistically robust alternative! + expect_equal(c(1, 1/2, 0) * sum(vapply(bootTrees, length, 1L)), bootSupport, + tolerance = 0.2) + +}) diff --git a/tests/testthat/test-NNI.R b/tests/testthat/test-NNI.R new file mode 100644 index 000000000..573493fad --- /dev/null +++ b/tests/testthat/test-NNI.R @@ -0,0 +1,25 @@ +test_that("Errors fail gracefully", { + expect_error(nni(TreeTools::BalancedTree(2)$edge, 0, 0)) +}) + +test_that("cNNI()", { + tr <- Preorder(root(TreeTools::BalancedTree(letters[1:7]), 'a', resolve.root = TRUE)) + expect_equal(ape::read.tree(text="(a,(b,((c,d),((e,g),f))));"), + cNNI(tr, 0, 1)) # Edge '9' + expect_equal(ape::read.tree(text="(a,(b,((c,d),((f,g),e))));"), + cNNI(tr, 0, 0)) # Edge '9' + expect_equal(cNNI(tr, 0, 1), cNNI(tr, 4, 1)) + expect_equal(ape::read.tree(text="(a, (b, (g, ((c, d), (e, f)))));"), # Edge 8 + cNNI(tr, 1, 1)) + expect_equal(cNNI(tr, 1, 1), cNNI(tr, 1, 3)) + expect_equal(ape::read.tree(text="(a, (b, ((e, f), ((c, d), g))));"), # Edge 8 + cNNI(tr, 1, 2)) + expect_equal(cNNI(tr, 1, 2), cNNI(tr, 1, 0)) + expect_equal(ape::read.tree(text="(a, (b, (d, (c, (g, (e, f))))));"), # Edge 5 + cNNI(tr, 2, 1)) + expect_equal(ape::read.tree(text="(a, ((b, (c, d)), ((e, f), g)));"), # Edge 4 + cNNI(tr, 3, 1)) + suppressWarnings(RNGversion('3.5.0')) + set.seed(0) # sample.int gives 4, 1 + expect_equal(cNNI(tr, 0, 1), cNNI(tr)) +}) \ No newline at end of file diff --git a/tests/testthat/test-PlotCharacter.R b/tests/testthat/test-PlotCharacter.R new file mode 100644 index 000000000..b2498c296 --- /dev/null +++ b/tests/testthat/test-PlotCharacter.R @@ -0,0 +1,125 @@ +test_that("PlotCharacter()", { + + skip_if_not_installed("TreeTools", "1.5.0") # Changes plotting order + Character <- function (str, plot = FALSE, ...) { + tree <- ape::read.tree(text = + "((((((a, b), c), d), e), f), (g, (h, (i, (j, (k, l))))));") + dataset <- TreeTools::StringToPhyDat(str, tips = tree) + PlotCharacter(tree, dataset, + edge.width = 3, plot = plot, ...) + } + + expect_equal(structure(c(FALSE, FALSE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, + TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, + TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, + FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, + FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, + TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + TRUE, FALSE, FALSE, FALSE, TRUE, TRUE), .Dim = c(23L, 5L), .Dimnames = list( + NULL, c("-", "0", "1", "2", "3"))), + Character("23--1??--032", updateTips = TRUE)) + + skip_if_not_installed('vdiffr') + skip_if_not_installed("ape", "5.5.2") # Node colours + + Test <- if (interactive()) { + function (str) invisible(Character(str, plot = TRUE)) + } else { + function (str) { + vdiffr::expect_doppelganger( + paste0('PlotChar_', + gsub('?', 'Q', + gsub('(', 'd', + gsub(')', 'b', + gsub('-', 'I', str, + fixed = TRUE), fixed = TRUE), fixed = TRUE), fixed = TRUE)), + function() Character(str, plot = TRUE)) + } + } + + Test("23--1??--032") + Test("23--1??(-0)-(01)32") + Test("23??1????032") + Test("11--????--11") + Test("000011????00") + Test("????????????") + Test("-------?????") + Test("------------") + Test("1234(45)AACGTTT") + + # From TGuillerme testing suite: + Test("11-------100") + Test("1100----1100") + Test("000011110000") + Test("1---1111---1") + Test("----1111---1") + Test("01----010101") + Test("01---1010101") + Test("1??--??--100") + Test("21--3??--032") + Test("11--1??--111") + Test("11--1000001-") + Test("01------0101") + Test("110--?---100") + Test("210--100--21") + Test("????----1???") + Test("23--1----032") + Test("1----1----1-") + Test("-1-1-1--1-1-") + + Test("--------0101") + Test("10101-----01") + Test("011--?--0011") + Test("110--??--100") + Test("21--1----012") + Test("11----111111") + Test("210210------") + Test("----1111----") + Test("230--??1--32") + Test("023--??1--32") + Test("023-???1--32") + Test("23--1?1--023") + Test("----1010----") + Test("------11---1") + Test("10----11---1") + Test("320--??3--21") +}) + +test_that("Edge cases work", { + tree <- ape::read.tree(text = '(a, (b, ((c, d), (e, f))));') + dataset <- TreeTools::StringToPhyDat('-01100', tips = tree) + if (interactive()) { + PlotCharacter(tree, dataset) + } else { + expect_equal(c('-' = FALSE, '0' = TRUE, '1' = FALSE), + PlotCharacter(tree, dataset, plot = FALSE)[9, ]) + } + + tree <- ape::read.tree(text = '(a, (b, (c, (d, (e, f)))));') + dataset <- TreeTools::StringToPhyDat('--0101', tips = tree) + if (interactive()) { + PlotCharacter(tree, dataset) + } else { + expect_equal(cbind('-' = c(1, 1, 0, 0, 0), + '0' = c(0, 0, 1, 1, 1), + '1' = c(0, 0, 1, 1, 1)), + 1 * PlotCharacter(tree, dataset, plot = FALSE)[7:11, ]) + } +}) + +test_that("Out-of-sequence works", { + skip_if_not_installed('vdiffr') + skip_if_not_installed("ape", "5.5.2") # Node colours + vdiffr::expect_doppelganger('PlotChar_out-of-sequence', + function () { + PlotCharacter(ape::read.tree(text = '(a, (b, (c, d)));'), + TreeTools::StringToPhyDat('1342', tips = c('a', 'c', 'd', 'b')) + ) + }) +}) \ No newline at end of file diff --git a/tests/testthat/test-RMorphy.R b/tests/testthat/test-RMorphy.R new file mode 100644 index 000000000..9533338b8 --- /dev/null +++ b/tests/testthat/test-RMorphy.R @@ -0,0 +1,25 @@ +context("RMorphy.C[++]") + +test_that("NULL pointers don't cause crash", { + ptr <- mpl_new_Morphy() + expect_equal(0, mpl_delete_Morphy(ptr)) + expect_true(is.na(mpl_delete_Morphy(ptr))) +}) + +test_that("Pointers survive garbage collection", { + ptr <- mpl_new_Morphy() + gc() + expect_equal(0, mpl_delete_Morphy(ptr)) +}) + +test_that("preorder_morphy()", { + library('TreeTools', quietly = TRUE) + tree <- Preorder(RootTree(BalancedTree(6), 1)) + dat <- MatrixToPhyDat(matrix(c(0, 1, 0, 1, 0, 1, + 0, 0, 0, 1, 1, 1), byrow = FALSE, 6, + dimnames = list(TipLabels(6), NULL))) + morphyObj <- PhyDat2Morphy(dat) + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + tree$edge - 1 + expect_equal(4L, preorder_morphy(tree$edge, morphyObj)) +}) diff --git a/tests/testthat/test-RandomTreeScore.R b/tests/testthat/test-RandomTreeScore.R new file mode 100644 index 000000000..4dded7dbb --- /dev/null +++ b/tests/testthat/test-RandomTreeScore.R @@ -0,0 +1,45 @@ +test_that("RandomMorphyTree() errors are handled", { + skip_if(TRUE) + expect_error(RandomMorphyTree(-1)) + expect_error(RandomMorphyTree(0)) + expect_error(RandomMorphyTree(1)) +}) + +test_that("Two tip 'random' tree", { + skip_if(TRUE) + expect_equal(RandomMorphyTree(2), list(c(2, 2, 2), 0, 1)) +}) + +test_that("RandomTreeScore() on small trees", { + skip_if(TRUE) + mo <- mpl_new_Morphy() + expect_equal(0L, RandomTreeScore(mo)) + mpl_delete_Morphy(mo) + + tokens <- matrix(c( + 0, '-', '-', 1, 1, 2, + 0, '-', '-', 1, 1, 2, + 0, '-', '-', 0, 0, 0), byrow = TRUE, nrow = 3L, + dimnames = list(letters[1:3], NULL)) + + # One leaf + pd <- TreeTools::MatrixToPhyDat(tokens[1, , drop = FALSE]) + morphyObj <- PhyDat2Morphy(pd) + expect_equal(mpl_get_numtaxa(morphyObj), 1L) + expect_equal(0, RandomTreeScore(morphyObj)) + morphyObj <- UnloadMorphy(morphyObj) + + # Two leaves + pd <- TreeTools::MatrixToPhyDat(tokens[2:3, , drop = FALSE]) + morphyObj <- PhyDat2Morphy(pd) + expect_equal(mpl_get_numtaxa(morphyObj), 2L) + expect_equal(RandomTreeScore(morphyObj), 3L) + morphyObj <- UnloadMorphy(morphyObj) + + # Three leaves + pd <- TreeTools::MatrixToPhyDat(tokens) + morphyObj <- PhyDat2Morphy(pd) + expect_equal(RandomTreeScore(morphyObj), 3L) + morphyObj <- UnloadMorphy(morphyObj) + +}) diff --git a/tests/testthat/test-TreeSearch_utilities.R b/tests/testthat/test-TreeSearch_utilities.R new file mode 100644 index 000000000..872a23cba --- /dev/null +++ b/tests/testthat/test-TreeSearch_utilities.R @@ -0,0 +1,6 @@ +test_that("EmptyDataset()", { + tree <- TreeTools::PectinateTree(8) + ret <- EmptyPhyDat(tree) + expect_equal(TipLabels(tree), names(ret)) + expect_true(inherits(ret, 'phyDat')) +}) diff --git a/tests/testthat/test-data_manipulation.R b/tests/testthat/test-data_manipulation.R new file mode 100644 index 000000000..fbdcf28f2 --- /dev/null +++ b/tests/testthat/test-data_manipulation.R @@ -0,0 +1,133 @@ +context("data_manipulation.R") + +test_that("Deprecation", { + expect_equal(MinimumLength(1:3), expect_warning(MinimumSteps(1:3))) +}) + +test_that("Minimum step counts are correctly calculated", { + expect_equal(1, MinimumLength(1:3)) + expect_equal(1, MinimumLength(c(1:3, 5))) + expect_equal(0, MinimumLength(c(6, 7, 14))) + expect_equal(1, MinimumLength(0:3)) # 0 representing the inapplicable token + + # ++++, .++., ..++ + expect_equal(0, MinimumLength(c(2046, 384, 1152))) + + # ++++, +..., .++., ..++ + expect_equal(1, MinimumLength(c(15, 8, 6, 3))) + + # ++++++, +....., .++..., .+.+.., ...++. + expect_equal(2, MinimumLength(c(63, 32, 24, 20, 6))) + + dudDat <- TreeTools::StringToPhyDat('----{-,1}22', letters[1:7]) + expect_equal('----<-,1>22', TreeTools::PhyDatToString(dudDat, '>', ',')) + expect_equal(0, attr(PrepareDataIW(dudDat), 'min.length')) + + dudTwo <- TreeTools::StringToPhyDat('{-1}{-2}{-3}2233', letters[1:7]) + expect_equal('{-1}{-2}{-3}2233', TreeTools::PhyDatToString(PrepareDataIW(dudTwo))) + + tr <- ape::read.tree(text='(((a, b), c), (d, (e, ((f, g), (h, (i, (j, k)))))));') + expect_equal(CharacterLength(tr, compress = TRUE, + TreeTools::StringToPhyDat('11---22--33', letters[1:11])), + MinimumLength(c(0, 0, 0, 0, 0, 0, 2, 2, 4, 4, 8, 8))) + + # 04, 14, 24, 34, 05, 16, 27, 38, 9A + # In this case, chosing the most common state (4) means that we have to choose 567&8 too + # 012&3 is a better solution + # We also have to choose one of 9 or A, but it doesn't matter which. + expect_equal(4, MinimumLength(c( + 2^0 + 2^4, + 2^1 + 2^4, + 2^2 + 2^4, + 2^3 + 2^4, + 2^0 + 2^5, + 2^1 + 2^6, + 2^2 + 2^7, + 2^3 + 2^8, + 2^9 + 2^10 + ))) + + data('inapplicable.datasets') + expect_equal(c(1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1, + 1, 2, 1, 1, 4, 3, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 4, 1, + 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), + MinimumLength(inapplicable.phyData[[4]], compress = TRUE)) + +}) + +test_that("PrepareDataProfile() handles empty matrices", { + dat <- TreeTools::MatrixToPhyDat(matrix(c(0, 1, rep('?', 5)), + dimnames = list(letters[1:7], NULL))) + expectation <- dat[0] + attr(expectation, 'info.amounts') <- numeric(0) + expect_equal(expectation, PrepareDataProfile(dat)) +}) + +test_that("PrepareDataProfile()", { + + # Easy one + mtx <- cbind(c('0', '0', 1,1,1,1), + c(0,0,1,1,1,1),# again + c(0,0,0,1,1,'?')) + rownames(mtx) <- letters[seq_len(nrow(mtx))] + phy1 <- TreeTools::MatrixToPhyDat(mtx) + expect_equivalent(phy1, PrepareDataProfile(phy1)) + expect_equal(attributes(phy1), attributes(PrepareDataProfile(phy1))[1:10]) + + # Easy one + mtx <- cbind(c('0', '0', 1,1,1,1), + c(1,1,0,0,0,0),# flipped + c(0,0,0,1,1,'{012}')) + rownames(mtx) <- letters[seq_len(nrow(mtx))] + phy2 <- TreeTools::MatrixToPhyDat(mtx) + expect_equivalent(phy1, PrepareDataProfile(phy2)) + expect_equal(attributes(PrepareDataProfile(phy1)), + attributes(PrepareDataProfile(phy2))) + + + mtx <- cbind(c('0', '0', 1,1,1, '2', '2', 3,3,3,3), + c('?', '?', 1,1,1, '?', '?', 0,0,0,0), + c(0,0,1,1,1,2,2,3,3,3,3),# again + c(rep('?', 5), '2', '2', 0,0,0,0), + c('?', '?', 1,1,1, 1,1, 0,0,0,0), + c('0', '1', rep('?', 9)) + ) + rownames(mtx) <- letters[seq_len(nrow(mtx))] + dataset <- TreeTools::MatrixToPhyDat(mtx) + + q <- '?' + decomposed <- matrix(c(0,0,q,q,q,q,q,1,1,1,1, + q,q,0,0,0,q,q,1,1,1,1, + q,q,q,q,q,0,0,1,1,1,1, + + q,q,0,0,0,q,q,1,1,1,1, + + 0,0,q,q,q,q,q,1,1,1,1, + q,q,0,0,0,q,q,1,1,1,1, + q,q,q,q,q,0,0,1,1,1,1, + + q,q,q,q,q,0,0,1,1,1,1, + q,q,0,0,0,0,0,1,1,1,1), + ncol = 9, dimnames = list(letters[1:11], NULL)) + + + expect_warning(pd <- PrepareDataProfile(dataset)) + expect_equal(decomposed, PhyDatToMatrix(pd)) + expect_equal(c(1, 2, 3, 2, 1, 2, 3, 3, 4), attr(pd, 'index')) + expect_equal(c(2, 3, 3, 1), attr(pd, 'weight')) + + dataset2 <- TreeTools::MatrixToPhyDat(mtx[!mtx[, 1] %in% c(0, 2), ]) + expect_equal(attr(PrepareDataProfile(dataset2), 'info.amounts'), + attr(pd, 'info.amounts')[1:3, 2, drop = FALSE]) + + + data('Lobo', package = "TreeTools") + expect_warning(prep <- PrepareDataProfile(Lobo.phy)) + expect_equal(c(17, attr(prep, 'nr')), + dim(attr(prep, 'info.amounts'))) + + +}) diff --git a/tests/testthat/test-iw-scoring.R b/tests/testthat/test-iw-scoring.R new file mode 100644 index 000000000..d829751ef --- /dev/null +++ b/tests/testthat/test-iw-scoring.R @@ -0,0 +1,78 @@ +test_that("IW Scoring", { + library('TreeTools', quietly = TRUE, warn.conflicts = FALSE) + data('Lobo', package = 'TreeTools') + dataset <- Lobo.phy + + #dataset <- ReadAsPhyDat('c:/research/r/hyoliths/mbank_X24932_6-19-2018_744.nex') + tree <- NJTree(dataset) + + + .IWScore <- function (edge, morphyObjs, weight, minLength, concavity) { + steps <- preorder_morphy_by_char(edge, morphyObjs) + homoplasies <- steps - minLength + fit <- homoplasies / (homoplasies + concavity) + sum(fit * weight) + } + + concavity <- 4.5 + epsilon <- sqrt(.Machine$double.eps) + + + tree <- Preorder(RenumberTips(tree, names(dataset))) + nTip <- NTip(tree) + edge <- tree$edge + + at <- attributes(dataset) + characters <- PhyToString(dataset, ps = '', useIndex = FALSE, + byTaxon = FALSE, concatenate = FALSE) + startWeights <- at$weight + morphyObjects <- lapply(characters, SingleCharMorphy) + on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) + + nLevel <- length(at$level) + nChar <- at$nr + nTip <- length(dataset) + cont <- at$contrast + simpleCont <- ifelse(rowSums(cont) == 1, + apply(cont != 0, 1, function (x) colnames(cont)[x][1]), + '?') + inappLevel <- at$levels == '-' + + if (any(inappLevel)) { + # TODO this is a workaround until MinimumLength can handle {-, 1} + cont[cont[, inappLevel] > 0, ] <- 0 + ambiguousToken <- at$allLevels == '?' + cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 + } + + # Perhaps replace with previous code: + # inappLevel <- which(at$levels == "-") + # cont[, inappLevel] <- 0 + + powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) + tmp <- as.integer(cont %*% powersOf2) + unlisted <- unlist(dataset, use.names = FALSE) + binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) + minLength <- apply(binaryMatrix, 1, MinimumLength) + + tokenMatrix <- matrix(simpleCont[unlisted], nChar, nTip, byrow = FALSE) + charInfo <- apply(tokenMatrix, 1, CharacterInformation) + needsInapp <- rowSums(tokenMatrix == '-') > 2 + inappSlowdown <- 3L # A guess + rawPriority <- charInfo / ifelse(needsInapp, inappSlowdown, 1) + priority <- startWeights * rawPriority + informative <- needsInapp | charInfo > 0 + # Will work from end of sequence to start. + charSeq <- seq_along(charInfo)[informative][order(priority[informative])] - 1L + + + weight <- startWeights + + expect_equal(.IWScore(edge, morphyObjects, weight, minLength, concavity), + morphy_iw(edge, morphyObjects, weight, minLength, charSeq, + concavity, Inf)) + + expect_equal(Inf, morphy_iw(edge, morphyObjects, weight, minLength, charSeq, + concavity, 0)) + +}) \ No newline at end of file diff --git a/tests/testthat/test-mpl_morphy_objects.R b/tests/testthat/test-mpl_morphy_objects.R new file mode 100644 index 000000000..038e6ef62 --- /dev/null +++ b/tests/testthat/test-mpl_morphy_objects.R @@ -0,0 +1,37 @@ +test_that("PhyDat2Morphy() errors", { + expect_error(PhyDat2Morphy(NA)) +}) + +test_that("UnloadMorphy() errors", { + expect_error(UnloadMorphy(NA)) +}) + +test_that("GapHandler()", { + expect_error(GapHandler(0)) + tokens <- matrix(c('-', '-', 0, 0), byrow = TRUE, nrow = 4L, + dimnames = list(letters[1:4], NULL)) + pd <- TreeTools::MatrixToPhyDat(tokens) + + morphyObj <- PhyDat2Morphy(pd) + expect_equal(0, RandomTreeScore(morphyObj)) + expect_equal("Inapplicable", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + morphyObj <- PhyDat2Morphy(pd, 'ambigu') + expect_equal(0, RandomTreeScore(morphyObj)) + expect_equal("Missing data", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + morphyObj <- PhyDat2Morphy(pd, 'eXt') + expect_lt(0, RandomTreeScore(morphyObj)) + expect_equal("Extra state", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + morphyObj <- SingleCharMorphy('-0-0', 'eXt') + expect_lt(0, RandomTreeScore(morphyObj)) + expect_equal("Extra state", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + expect_error(SingleCharMorphy('-0-0', 'ERROR')) + expect_error(GapHandler(morphyObj)) +}) diff --git a/tests/testthat/test-pp-fitch.R b/tests/testthat/test-pp-fitch.R new file mode 100644 index 000000000..dec536272 --- /dev/null +++ b/tests/testthat/test-pp-fitch.R @@ -0,0 +1,92 @@ +context("pp_exact") + +# TODO this test was recovered from a stash and requires updating -- +# or may be obselete. +test_that("Profile score correct for small trees", { + library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) + tree <- as.phylo(200, 9) + + mataset <- matrix(c( + 1, 1, 1, 1, 0, 0, 0, 0, 0, # 3 steps + 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps + 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps again [duplicated] + 0, 1, 0, 0, 0, 0, 0, 1, 1, # 1 step + 2, 1, 1, 1, 1, 1, 1, 1, 1),# 1 step; non-informative + nrow = 9, dimnames = list(paste0('t', 1:9), NULL)) + + + dataset <- MatrixToPhyDat(mataset) + + at <- attributes(dataset) + characters <- PhyToString(dataset, ps = '', useIndex = FALSE, + byTaxon = FALSE, concatenate = FALSE) + weight <- at$weight + morphyObjects <- lapply(characters, SingleCharMorphy) + on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) + + nLevel <- length(at$level) + nChar <- at$nr + cont <- at$contrast + simpleCont <- ifelse(rowSums(cont) == 1, + apply(cont != 0, 1, function (x) at$levels[x][1]), + '?') + inappLevel <- at$levels == '-' + + unlisted <- unlist(dataset, use.names = FALSE) + charSeq <- seq_len(nChar) - 1L + + tokenMatrix <- matrix(simpleCont[unlisted], nChar, 9, byrow = FALSE) + profileTables <- apply(tokenMatrix, 1, table) + if (inherits(profileTables, 'matrix')) { + profileTables <- lapply(seq_len(ncol(profileTables)), function (i) profileTables[, i]) + } + data('profiles', package = 'TreeSearch') + profileCost <- lapply(profileTables, function (x) { + x <- sort(x[x > 1]) + n <- length(x) + prof <- switch(n, + 0, + profiles[[sum(x)]][[n]][[x[1] - 1L]] + ) + }) + profileExtra <- lapply(profileCost, function (x) x - x[1]) + fixedCost <- -sum(vapply(profileCost, `[[`, 1, 1) * weight) + maxScore <- sum(Log2Unrooted(vapply(profileTables, sum, 1))) + pad <- function (x, len) { + ret <- double(len) + ret[seq_along(x)] <- x + ret + } + profiles <- vapply(profileExtra, pad, double(4), 4) + + TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, + charSeq, profiles, Inf) + + PP <- function (costs) { + TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, + charSeq, costs, Inf) + } + + + # Use integer-step profile tables + extraSteps <- matrix(1:4, 4, 4) + expect_equal(TreeLength(tree, dataset), PP(costs = extraSteps)) + expect_equal(3 + 2 + 2 + 1 + 1, + TreeLength(tree, dataset)) +}) + + +test_that("Profile score can be calculated from real data", { + data(referenceTree) + data(congreveLamsdellMatrices) + tree <- referenceTree + dataset <- PrepareDataProfile(congreveLamsdellMatrices[[1]]) + expect_equal(TreeLength(tree, dataset), + sum(CharacterLength(tree, dataset, compress = TRUE) * + attr(dataset, 'weight'))) + score <- TreeLength(tree, dataset, 'profile') + + # Check score hasn't materially changed: + # 511.732 is "previous value"; not manually checked. + expect_equal(511.732, score, tolerance = 0.01) +}) diff --git a/tests/testthat/test-pp-info_extra_step.R b/tests/testthat/test-pp-info_extra_step.R new file mode 100644 index 000000000..4a34e6550 --- /dev/null +++ b/tests/testthat/test-pp-info_extra_step.R @@ -0,0 +1,95 @@ +context("pp_info_extra_step.R") +library("TreeSearch", quietly = TRUE) + +test_that("Bad input safely handled", { + expect_equal(0, WithOneExtraStep(1)) + expect_error(WithOneExtraStep(2, 2, 2)) + + expect_equal(0, Carter1(5, 6, 4)) + expect_equal(-Inf, LogCarter1(5, 6, 4)) + expect_equal(-Inf, Log2Carter1(5, 6, 4)) +}) + +test_that("StepInformation() works", { + expect_equal(c(`0` = 0), StepInformation(rep(3L, 10), ambiguousTokens = 3)) + expect_equal(c(`0` = 0), StepInformation(c(4L, rep(3L, 10)), 3)) + expect_true(all(is.finite(StepInformation(rep.int(1:3, times = c(139, 45, 41)), + ambiguousTokens = 3)))) + expect_true(all(is.finite(StepInformation( + char = rep.int(1:2, times = c(600, 600)))))) +}) + +test_that("Carter1() matches profile counts", { + data("profiles", package = "TreeSearch") + Test <- function (a, b) { + n <- sum(a, b) + counted <- 2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]] * NUnrooted(n) + m <- as.integer(names(counted)) + for (mi in m) { + expect_equal(log2(Carter1(mi, a, b)), Log2Carter1(mi, b, a)) + expect_equal(log(Carter1(mi, a, b)), LogCarter1(mi, b, a)) + } + expect_equivalent(counted, + cumsum(vapply(m, Carter1, a = a, b = b, double(1)))) + } + + Test(2, 4) + Test(2, 5) + Test(2, 6) + Test(2, 7) + Test(2, 8) + + Test(3, 4) + Test(3, 5) + Test(3, 6) + Test(3, 7) + + Test(4, 4) + Test(4, 5) + Test(4, 6) + + Test(5, 4) + Test(5, 5) + +}) + +test_that("WithOneExtraStep() input format", { + expect_equal(WithOneExtraStep(7, 5), WithOneExtraStep(c(5, 7))) +}) + +test_that("WithOneExtraStep()", { + library("TreeTools", quietly = TRUE) + data("profiles", package = "TreeSearch") + Test <- function (a, b) { + n <- sum(a, b) + expect_equivalent(2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]][2] * NUnrooted(n), + NUnrootedMult(c(a, b)) + WithOneExtraStep(c(a, b))) + } + + Test(4, 2) + Test(3, 3) + Test(8, 2) + Test(4, 3) + Test(7, 3) + Test(6, 4) + Test(5, 5) + + expect_equal(NUnrooted(6) / NUnrooted(5) * WithOneExtraStep(2:3), + WithOneExtraStep(1:3)) + expect_equal(NUnrooted(10) / NUnrooted(5) * WithOneExtraStep(2:3), + WithOneExtraStep(2:3, rep(1, 5))) +}) + +test_that(".LogCumSumExp()", { + Test <- function (x) { + naive <- log(cumsum(exp(x))) + if (all(is.finite(naive))) { + expect_equal(naive, .LogCumSumExp(x)) + } else { + expect_true(all(is.finite(.LogCumSumExp(x)))) + } + } + Test(log(c(1:5, 5:1))) + Test(c(10, 700, 100)) + Test(c(10, 7000, 100)) +}) \ No newline at end of file diff --git a/tests/testthat/test-pp-random-tree.R b/tests/testthat/test-pp-random-tree.R new file mode 100644 index 000000000..38f4cbbd7 --- /dev/null +++ b/tests/testthat/test-pp-random-tree.R @@ -0,0 +1,141 @@ +# NB: RandomTreeScore uses C's RNG, so no point in setting seed. +MorphyAction <- function (Action) expect_equal("ERR_NO_ERROR", mpl_translate_error(Action)) +MorphyWith <- function (char) { + nTip <- nchar(char) - 1L + morphyObj <- mpl_new_Morphy() + MorphyAction(mpl_init_Morphy(nTip, 1, morphyObj)) + MorphyAction(mpl_attach_rawdata(char, morphyObj)) + MorphyAction(mpl_set_num_internal_nodes(nTip - 1L, morphyObj)) + MorphyAction(mpl_set_parsim_t(1, 'FITCH', morphyObj)) + MorphyAction(mpl_set_charac_weight(1, 1, morphyObj)) + MorphyAction(mpl_apply_tipdata(morphyObj)) + class(morphyObj) <- 'morphyPtr' + morphyObj +} + + +context("pp: Tree randomness") +test_that("four-tip trees are randomly distributed", { + nTrees <- 36000 + stringency <- 0.005 # low numbers mean you'll rarely fail by chance + nTip <- 4 + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, 1/(nTip - 1)) + rTrees <- vapply(logical(nTrees), function (XX) + unlist(RandomMorphyTree(nTip)), integer((nTip * 4) - 3)) + expect_true(all(rTrees[1 + (seq_len(nTip - 1)), ] %in% nTip + seq_len(nTip - 2))) + expect_lt(expectedBounds[1], sum(rTrees[2, ] == 5)) + expect_gt(expectedBounds[2], sum(rTrees[2, ] == 5)) + expect_lt(expectedBounds[1], sum(rTrees[3, ] == 5)) + expect_gt(expectedBounds[2], sum(rTrees[3, ] == 5)) + expect_lt(expectedBounds[1], sum(rTrees[4, ] == 5)) + expect_gt(expectedBounds[2], sum(rTrees[4, ] == 5)) + + expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] > expectedBounds[1])) + expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] < expectedBounds[2])) + + expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] < nTrees - expectedBounds[1])) + expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] > nTrees - expectedBounds[2])) +}) + +test_that("four-tip trees are randomly scored", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + nTrees <- 6000 + stringency <- 0.005 + nTip <- 4 + + morphyObj <- MorphyWith('0011;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + + expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, + NUnrooted(nTip - 1L) / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + expect_lt(expectedBounds[1], sum(scores==1)) + expect_gt(expectedBounds[2], sum(scores==1)) +}) + +test_that("five-tip trees are randomly scored", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + nTrees <- 6000 + stringency <- 0.005 + nTip <- 5 + morphyObj <- MorphyWith('00011;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, + NUnrooted(nTip - 1) / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + expect_equal(2L, max(scores)) + expect_lt(expectedBounds[1], sum(scores == 1)) + expect_gt(expectedBounds[2], sum(scores == 1)) +}) + + +test_that("six-tip trees are randomly scored", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + nTrees <- 6000 + stringency <- 0.005 + nTip <- 6 + + morphyObj <- MorphyWith('000011;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, + NUnrooted(5) / NUnrooted(6)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + morphyObj <- UnloadMorphy(morphyObj) + + expect_true(max(scores) == 2) + expect_lt(expectedBounds[1], sum(scores==1)) + expect_gt(expectedBounds[2], sum(scores==1)) + + morphyObj <- MorphyWith('001122;') + expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, + 7 / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), + integer(1)) + morphyObj <- UnloadMorphy(morphyObj) + + expect_true(all(scores %in% 2:4)) + expect_lt(expectedBounds[1], sum(scores == 2)) + expect_gt(expectedBounds[2], sum(scores == 2)) + + morphyObj <- MorphyWith('000111;') + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, + 3 * 3 / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + # unloaded on exit; don't unload twice || morphyObj <- UnloadMorphy(morphyObj) + + expect_true(max(scores) == 3) + expect_lt(expectedBounds[1], sum(scores == 1)) + expect_gt(expectedBounds[2], sum(scores == 1)) + +}) + +test_that("twelve-tip trees are randomly scored", { + nTrees <- 12000 # 12000 seems to throw false +ve too often? + stringency <- 0.01 # increased from 0.005 to avoid false +ves + nTip <- 12 + morphyObj <- MorphyWith('000000011111;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, + NUnrooted(7) * (2 * 7 - 3) * + NUnrooted(5) * (2 * 5 - 3) / NUnrooted(nTip)) + + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), + integer(1L)) + # table(scores) + + expect_equal(5L, max(scores)) + nScoring1 <- sum(scores == 1) + expect_lt(expectedBounds[1], nScoring1) + expect_gt(expectedBounds[2], nScoring1) +}) diff --git a/tests/testthat/test-tree_length.R b/tests/testthat/test-tree_length.R new file mode 100644 index 000000000..d3df7bab3 --- /dev/null +++ b/tests/testthat/test-tree_length.R @@ -0,0 +1,270 @@ +## Test cases designed by Thomas Guillerme + +test_that("Failures are graceful", { + library("TreeTools", quietly = TRUE) + data('inapplicable.datasets') + dat <- inapplicable.phyData[[1]] + unrooted <- RandomTree(dat, root = FALSE) + expect_error(TreeLength(unrooted, dat)) + + mo <- PhyDat2Morphy(dat) + on.exit(mo <- UnloadMorphy(mo)) + + sparse <- DropTip(RandomTree(dat, root = FALSE), 10) + expect_error(MorphyTreeLength(sparse, mo)) + expect_error(MorphyTreeLength(sparse, NA)) + + expect_error(MorphyLength(sparse$edge[, 1], sparse$edge[, 2], mo, nTaxa = 0)) + expect_error(MorphyLength(sparse$edge[, 1], sparse$edge[, 2], dat)) + + expect_null(TreeLength(NULL)) +}) + +test_that("Deprecations throw warning", { + data('inapplicable.datasets') + dat <- inapplicable.phyData[[1]] + tree <- TreeTools::RandomTree(dat, root = TRUE) + expect_equal(TreeLength(tree, dat), + expect_warning(Fitch(tree, dat))) + expect_equal(CharacterLength(tree, dat, compress = TRUE), + expect_warning(FitchSteps(tree, dat))) + +}) + +test_that("Morphy generates correct lengths", { + ## Tree + tree <- ape::read.tree(text = "((((((1,2),3),4),5),6),(7,(8,(9,(10,(11,12))))));") + relabel <- ape::read.tree(text = "((6,(5,(4,(3,(2,1))))),(7,(8,(9,(10,(11,12))))));") + trees <- list(tree, relabel) + characters <- c("23--1??--032", # 0, expect score = 5 + "1---1111---1", # 1, expect score = 2 + "1100----1100", # 2, expect score = 3 + "11-------100", # 3, expect score = 2 + "----1111---1", # 4, expect score = 1 + "01----010101", # 5, expect score = 5 + "01---1010101", # 6, expect score = 5 + "1??--??--100", # 7, expect score = 2 + "21--3??--032", # 8, expect score = 5 + "11--1??--111", # 9, expect score = 2 + "11--1000001-", # 10, expect score = 2 + "01------0101", # 11, expect score = 4 + "110--?---100", # 12, expect score = 3 + "11--1??--111", # 13, expect score = 2 + "210--100--21", # 14, expect score = 5 + "????----1???", # 15, expect score = 0 + "23--1----032", # 16, expect score = 5 + "1----1----1-", # 17, expect score = 2 + "-1-1-1--1-1-", # 18, expect score = 4 + "23--1??--032", # 19, expect score = 5 + "--------0101", # 20, expect score = 2 + "10101-----01", # 21, expect score = 4 + "011--?--0011", # 22, expect score = 3 + "110--??--100", # 23, expect score = 3 + "11--1000001-", # 24, expect score = 2 + "21--1----012", # 25, expect score = 5 + "11----111111", # 26, expect score = 1 + "10101-----01", # 27, expect score = 4 + "210210------", # 28, expect score = 4 + "----1111----", # 29, expect score = 0 + "230--??1--32", # 30, expect score = 5 + "023--??1--32", # 31, expect score = 5 + "023-???1--32", # 32, expect score = 4 + "23--1?1--023", # 33, expect score = 5 + "----1010----", # 34, expect score = 2 + "------11---1", # 35, expect score = 1 + "10----11---1", # 36, expect score = 3 + "320--??3--21", # 37, expect score = 5 + "000011110000" # 38, expect score = 2 + ) + ## Results + expected_results <- c(5, 2, 3, 2, 1, 5, 5, 2, 5, 2, 2, 4, 3, 2, 5, 0, 5, 2, + 4, 5, 2, 4, 3, 3, 2, 5, 1, 4, 4, 0, 5, 5, 4, 5, 2, 1, + 3, 5, 2) + expected_minLength <- c(3, 0, 1, 1, 0, 1, 1, 1, 3, 0, 1, 1, 1, 0, 2, 0, 3, 0, + 0, 3, 1, 1, 1, 1, 1, 2, 0, 1, 2, 0, 3, 3, 3, 3, 1, 0, + 1, 3, 1) + expected_homoplasies <- expected_results - expected_minLength + + ##plot(tree); nodelabels(12:22); tiplabels(0:11) + ## Run the tests + for(test in seq_along(characters)) { + morphyObj <- SingleCharMorphy(characters[test]) + tree_length <- MorphyTreeLength(tree, morphyObj) + morphyObj <- UnloadMorphy(morphyObj) + #if (tree_length != expected_results[test]) message("Test case", test - 1, characters[test], "unequal: Morphy calcluates", + # tree_length, "instead of", expected_results[test],"\n") + expect_equal(tree_length, expected_results[test]) + } + + ## Test combined matrix + bigPhy <- TreeTools::StringToPhyDat(paste0(characters, collapse = '\n'), + tree$tip.label, + byTaxon = FALSE) + profPhy <- TreeTools::StringToPhyDat(paste0(characters[-c(15, 29, 34)], + collapse = '\n'), + tree$tip.label, + byTaxon = FALSE) + expect_identical(characters, + TreeTools::PhyToString(bigPhy, byTaxon = FALSE, + concatenate = FALSE)) + expect_identical(paste0(collapse = '', + vapply(characters, substr, start = 0, stop = 1, + character(1))), + substr(TreeTools::PhyToString(bigPhy, ps = ';', + useIndex = TRUE, + byTaxon = TRUE, + concatenate = TRUE), + start = 0, stop = length(characters))) + + morphyObj <- PhyDat2Morphy(bigPhy) + moSummary <- summary(morphyObj) + expect_equal(c(length(bigPhy), attr(bigPhy, 'nr'), length(bigPhy) - 1), + c(moSummary$nTax, moSummary$nChar, moSummary$nInternal)) + tree_length <- MorphyTreeLength(tree, morphyObj) + morphyObj <- UnloadMorphy(morphyObj) + + expect_equal('0123', moSummary$allStates) + expect_equal(tree_length, sum(expected_results)) + expect_equal(tree_length, TreeLength(tree, bigPhy)) + expect_equal(tree_length, TreeLength(relabel, bigPhy)) + expect_equal(rep(tree_length, 2), TreeLength(trees, bigPhy)) + + expected_fit <- expected_homoplasies / (expected_homoplasies + 6) + tree_score_iw <- TreeLength(tree, bigPhy, concavity = 6) + expect_equal(sum(expected_fit), tree_score_iw) + expect_equal(tree_score_iw, TreeLength(relabel, bigPhy, concavity = 6)) + expect_equal(vapply(trees, TreeLength, double(1), bigPhy, concavity = 6), + TreeLength(trees, bigPhy, concavity = 6)) + + expect_equal(vapply(trees, TreeLength, double(1), profPhy, concavity = 'p'), + TreeLength(trees, profPhy, concavity = 'profile')) + + + ## Run the bigger tree tests + bigTree <- ape::read.tree( + text = "((1,2),((3,(4,5)),(6,(7,(8,(9,(10,((11,(12,(13,(14,15)))),(16,(17,(18,(19,20))))))))))));") + bigChars <- c("11111---111---11---1") + ## Results + expected_results <- c(3) + + ## Run the tests + for(test in 1:length(bigChars)) { + phy <- TreeTools::StringToPhyDat(bigChars[test], bigTree$tip.label) + # Presently a good test to confirm that PhyDat2Morphy works with single-character phys + morphyObj <- PhyDat2Morphy(phy) + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + tree_length <- MorphyTreeLength(bigTree, morphyObj) + + expect_equal(tree_length, expected_results[test]) + } +}) + +test_that("(random) lists of trees are scored", { + data("congreveLamsdellMatrices", package = 'TreeSearch') + mat <- congreveLamsdellMatrices[[42]] + + # Expected values calculated from 100k samples + expect_gt(t.test(TreeLength(100, mat), mu = 318.5877)$p.val, 0.001) + expect_gt(t.test(TreeLength(100, mat, 10L), mu = 17.16911)$p.val, 0.001) + expect_gt(t.test(TreeLength(100, mat, 'profile'), mu = 830.0585)$p.val, 0.001) +}) + +test_that("TreeLength() handles subsetted trees", { + data('inapplicable.datasets') + dat <- inapplicable.phyData[[1]] + t8 <- as.phylo(1:4, 8, tipLabels = names(dat)[1:8]) + expect_equal(4, length(TreeLength(t8, dat))) +}) + +test_that("Profile scoring is reported correctly", { + data('congreveLamsdellMatrices') + dataset <- congreveLamsdellMatrices[[42]] + prepDataset <- PrepareDataProfile(dataset) + tree <- NJTree(prepDataset) + edge <- Preorder(tree)$edge + at <- attributes(prepDataset) + profiles <- attr(prepDataset, 'info.amounts') + charSeq <- seq_along(prepDataset[[1]]) - 1L + + characters <- PhyToString(prepDataset, ps = '', useIndex = FALSE, + byTaxon = FALSE, concatenate = FALSE) + startWeights <- at$weight + morphyObjects <- lapply(characters, SingleCharMorphy) + on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1)), + add = TRUE) + + expect_equal(TreeLength(tree, dataset, 'profile'), + TreeLength(tree, prepDataset, 'profile')) + expect_equal(TreeLength(tree, dataset, 'profile'), + morphy_profile(edge, morphyObjects, startWeights, charSeq, + profiles, Inf)) +}) + +test_that("CharacterLength() fails gracefully", { + expect_error(CharacterLength(as.phylo(1, 8), 1)) + + data('inapplicable.datasets') + dataset <- inapplicable.phyData[[12]] + # Unlabelled leaves + expect_error(CharacterLength(structure(list(), class = 'phylo'), dataset)) + + # Missing leaves + expect_error(CharacterLength(as.phylo(1, 4), dataset)) + tMinus1 <- as.phylo(1, 42, tipLabels = names(dataset)[-1]) + expect_equal(CharacterLength(tMinus1, dataset[-1]), + CharacterLength(tMinus1, dataset)) + expect_error(CharacterLength(as.phylo(1, 43), dataset)) + tPlus1 <- as.phylo(1, 44, tipLabels = c('extra', names(dataset))) + expect_equal(CharacterLength(DropTip(tPlus1, 'extra'), dataset), + CharacterLength(tPlus1, dataset)) + expect_error(CharacterLength(as.phylo(1:2, 43, tipLabels = names(dataset)), + dataset)) + # no error: + CharacterLength(as.phylo(1, 43, tipLabels = names(dataset)), dataset) + + expect_equal(c(53, 59, 6), + as.numeric(table(CharacterLength(NJTree(dataset[1:4, ]), + dataset[1:4], compress = TRUE)))) + +}) + +test_that("Character compression works", { + data('inapplicable.datasets') + dataset <- inapplicable.phyData[[12]] + tree <- TreeTools::NJTree(dataset) + expect_equal(137, length(CharacterLength(tree, dataset))) + expect_equal(137, length(MinimumLength(dataset))) + expect_equal(137, length(Consistency(dataset, tree))) + expect_equal(118, length(CharacterLength(tree, dataset, compress = TRUE))) + expect_equal(118, length(MinimumLength(dataset, compress = TRUE))) + expect_equal(118, length(Consistency(dataset, tree, compress = TRUE))) +}) + +test_that("X_MorphyLength", { + dataset <- congreveLamsdellMatrices[[42]] + morphyObj <- PhyDat2Morphy(dataset) + on.exit(UnloadMorphy(morphyObj)) + nTaxa <- mpl_get_numtaxa(morphyObj) + + tree <- NJTree(dataset) + edgeList <- Postorder(Preorder(tree$edge)) + parent <- edgeList[, 1] + child <- edgeList[, 2] + + maxNode <- nTaxa + mpl_get_num_internal_nodes(morphyObj) + rootNode <- nTaxa + 1L + allNodes <- rootNode:maxNode + + parentOf <- parent[match(seq_len(maxNode), child)] + parentOf[rootNode] <- rootNode # Root node's parent is a dummy node + leftChild <- child[length(parent) + 1L - match(allNodes, rev(parent))] + rightChild <- child[match(allNodes, parent)] + + expected <- MorphyLength(parent, child, morphyObj) + + expect_equal(expected, + C_MorphyLength(parentOf, leftChild, rightChild, morphyObj)) + expect_equal(expected, + GetMorphyLength(parentOf - 1, leftChild - 1, rightChild - 1, + morphyObj)) +}) diff --git a/tests/testthat/test-zzz-tree-rearrange.R b/tests/testthat/test-zzz-tree-rearrange.R new file mode 100644 index 000000000..442ff3a74 --- /dev/null +++ b/tests/testthat/test-zzz-tree-rearrange.R @@ -0,0 +1,270 @@ +library("TreeTools") + +context("Tree rearrangements") +tree5a <- read.tree(text = '(a, (b, (c, (d, e))));') +tree5b <- read.tree(text = '((a, b), (c, (d, e)));') +tree6 <- Preorder(read.tree(text = "((a, (b, (c, d))), (e, f));")) +tree6b <- Preorder(read.tree(text = "((a, (b, c)), (d, (e, f)));")) +tree8 <- read.tree(text = "(((a, (b, (c, d))), (e, f)), (g, h));") +tree11 <- read.tree(text = "((((a, b), (c, d)), e), ((f, (g, (h, i))), (j, k)));") +attr(tree5a, 'order') <- attr(tree5b, 'order') <- attr(tree8, 'order') <- attr(tree11, 'order') <- 'preorder' + +test_that("Malformed trees don't crash anything", { + treeDoubleNode <- read.tree(text = "((((((1,2)),3),4),5),6);") + treePolytomy <- read.tree(text = "((((1,2,3),4),5),6);") + treeDoublyPoly <- read.tree(text = "(((((1,2,3)),4),5),6);") + + expect_error(NNI(treeDoubleNode)) + expect_error(NNI(treePolytomy)) + expect_error(NNI(treeDoublyPoly)) + + expect_error(SPR(treeDoubleNode)) + expect_error(SPR(treePolytomy)) + expect_error(SPR(treeDoublyPoly)) + + expect_error(TBR(treeDoubleNode)) + expect_error(TBR(treePolytomy)) + expect_error(TBR(treeDoublyPoly)) + +}) + +test_that("NNI works", { + trComb <- read.tree(text = "(((((1,2),3),4),5),6);") + edge <- trComb$edge + Test <- function (e, r, e1, e2) { + edge1 <- edge + edge1[c(e1, e2), 2] <- edge1[c(e2, e1), 2] + edge1 <- do.call(cbind, RenumberEdges(edge1[, 1], edge1[, 2])) + expect_equal(edge1, nni(trComb$edge, e, r)) + } + Test(0, 0, 5, 7) + Test(0, 2, 5, 7) + Test(3, 0, 5, 7) # Option 0 == option 3. + Test(0, 1, 6, 7) + Test(1, 0, 4, 8) + Test(1, 1, 7, 8) + Test(2, 0, 3, 9) + Test(2, 1, 8, 9) + + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + nniComb <- NNI(trComb) + expect_equal(nniComb$tip.label, trComb$tip.label) + expect_equal(nniComb$Nnode, trComb$Nnode) + expect_equal(nniComb, read.tree(text = "(((((3,2),1),4),5),6);")) +}) + + +test_that("SPR works", { + testTree <- Preorder(root(BalancedTree(7), 1, resolve.root = TRUE)) + edge <- testTree$edge + expect_equal(spr(edge, 66), cSPR(testTree, 66)$edge) + + Test <- function (m, p1, r1) { + test.tr <- testTree + test.tr$edge <- spr(edge, m) + + oldWay <- SortTree(root(SPR(testTree, p1, r1), 't1', resolve.root = TRUE)) + expect_equal(oldWay, SortTree(test.tr)) + } + Test(0, 1, 5) + Test(64, 1, 5) # Modulo 64! + Test(1, 1, 6) + Test(2, 1, 7) + Test(3, 1, 8) + Test(4, 1, 9) + Test(5, 1, 10) + Test(6, 1, 11) + Test(7, 1, 12) + + Test(8 , 3, 5) + Test(9 , 3, 6) + Test(10, 3, 7) + Test(11, 3, 8) + Test(12, 3, 9) + Test(13, 3, 10) + Test(14, 3, 11) + Test(15, 3, 12) + + Test(16, 5, 3) + Test(17, 5, 9) + Test(18, 5, 10) + Test(19, 5, 11) + Test(20, 5, 12) + + Test(28, 7, 3) + Test(29, 7, 4) + Test(30, 7, 8) + Test(31, 7, 9) + Test(32, 7, 10) + Test(33, 7, 11) + Test(34, 7, 12) + + Test(35, 8, 3) + Test(36, 8, 6) + Test(37, 8, 7) + Test(38, 9, 3) + Test(39, 9, 4) + Test(40, 9, 5) + Test(41, 9, 6) + Test(42, 9, 7) + Test(43, 10, 3) + Test(44, 10, 4) + Test(45, 10, 5) + Test(46, 10, 6) + Test(47, 10, 7) + Test(48, 10, 8) + Test(49, 10, 12) + Test(50, 11, 3) + Test(51, 11, 4) + Test(52, 11, 5) + Test(53, 11, 6) + Test(54, 11, 7) + Test(55, 11, 8) + Test(56, 11, 12) + Test(57, 12, 3) + Test(58, 12, 4) + Test(59, 12, 5) + Test(60, 12, 6) + Test(61, 12, 7) + Test(62, 12, 10) + Test(63, 12, 11) +}) + +test_that("TBR can swap over root", { + expect_equal(TBR(tree5a, 1, c(7, 1)), read.tree(text = '(a, (d, (e, (c, b))));')) + expect_equal(TBR(tree5a, 2, c(5, 1)), read.tree(text = '(a, (c, (b, (d, e))));')) + expect_equal(TBR(tree5b, 1, c(7, 1)), read.tree(text = '((a, b), (d, (c, e)));')) + expect_equal(TBR(tree5b, 4, c(7, 1)), read.tree(text = '((a, b), (d, (c, e)));')) +}) + +test_that("TBR works", { + tree <- tree8 + ### expect_equal(TBR(tree, 3, 1 ), read.tree(text = "((a, ((b, (c, d)), (e, f))), (g, h));")) + ### expect_warning(expect_identical(TBR(tree, 3, 2), tree)) + ### expect_warning(expect_identical(TBR(tree, 3, 3), tree)) + ### expect_warning(expect_identical(TBR(tree, 3, 4), tree)) + ### expect_warning(expect_identical(TBR(tree, 3, 44), tree)) + ### expect_equal(TBR(tree, 3, 5 ), read.tree(text = "((((a, b), (c, d)), (e, f)), (g, h));")) + ### expect_equal(TBR(tree, 3, 6 ), read.tree(text = "(((b, (a, (c, d))), (e, f)), (g, h));")) + ### expect_equal(TBR(tree, 3, 7 ), read.tree(text = "(((b, ((a, c), d)), (e, f)), (g, h));")) + ### expect_equal(TBR(tree, 3, 8 ), read.tree(text = "(((b, (c, (a, d))), (e, f)), (g, h));")) + ### expect_equal(TBR(tree, 3, 9 ), read.tree(text = "(((b, (c, d)), (a, (e, f))), (g, h));")) + ### expect_equal(TBR(tree, 3, 10), read.tree(text = "(((b, (c, d)), ((a, e), f)), (g, h));")) + ### expect_equal(TBR(tree, 3, 11), read.tree(text = "(((b, (c, d)), (e, (a, f))), (g, h));")) + ### expect_equal(TBR(tree, 3, 12), read.tree(text = "(((b, (c, d)), (e, f)), (a, (g, h)));")) + ### expect_equal(TBR(tree, 3, 13), read.tree(text = "(((b, (c, d)), (e, f)), ((g, a), h));")) + ### expect_equal(TBR(tree, 3, 14), read.tree(text = "(((b, (c, d)), (e, f)), (g, (a, h)));")) + + tree <- tree8 + expect_equal(TBR(tree, 6, c(1 , 6)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) + expect_equal(TBR(tree, 6, c(1 , 7)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) + expect_equal(TBR(tree, 6, c(1 , 8)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) + expect_equal(TBR(tree, 6, c(2 , 6)), TBR(tree, 6, c(2 , 7))) + expect_equal(TBR(tree, 6, c(2 , 6)), TBR(tree, 6, c(2 , 8))) + expect_equal(TBR(tree, 6, c(2 , 6)), read.tree(text = "((((a, b), (c, d)), (e, f)), (g, h));")) + expect_equal(TBR(tree, 6, c(3 , 6)), read.tree(text = "(((((c, d), a), b), (e, f)), (g, h));")) + expect_warning(expect_identical(TBR(tree, 6, c(4 , 6)), tree)) + expect_warning(expect_identical(TBR(tree, 8, c(6 , 8)), tree)) + expect_warning(expect_identical(TBR(tree, 6, c(5 , 6)), tree)) + expect_warning(expect_identical(TBR(tree, 6, c(6 , 6)), tree)) + expect_warning(expect_identical(TBR(tree, 6, c(6 , 7)), tree)) + expect_warning(expect_identical(TBR(tree, 6, c(6 , 8)), tree)) + expect_equal(TBR(tree, 6, c(9 , 6)), read.tree(text = "(((a, b), ((c, d), (e, f))), (g, h));")) + expect_equal(TBR(tree, 6, c(10, 6)), read.tree(text = "(((a, b), (((c, d), e), f)), (g, h));")) + expect_equal(TBR(tree, 6, c(11, 6)), read.tree(text = "(((a, b), (((c, d), f), e)), (g, h));")) + expect_equal(TBR(tree, 6, c(12, 6)), read.tree(text = "(((a, b), (e, f)), ((c, d), (g, h)));")) + expect_equal(TBR(tree, 6, c(13, 6)), read.tree(text = "(((a, b), (e, f)), (((c, d), g), h));")) + expect_equal(TBR(tree, 6, c(14, 6)), read.tree(text = "(((a, b), (e, f)), (((c, d), h), g));")) + expect_warning(expect_identical(TBR(tree, 6, c(6, 15)), tree)) + + expect_equal(TBR(tree, 4, c(1, 5)), read.tree(text = "(((a, (e, f)), (b, (c, d))), (g, h));")) + expect_equal(TBR(tree, 4, c(1, 6)), read.tree(text = "(((a, (e, f)), (b, (c, d))), (g, h));")) + expect_equal(TBR(tree, 4, c(1, 7)), read.tree(text = "(((a, (e, f)), (c, (b, d))), (g, h));")) + expect_equal(TBR(tree, 4, c(1, 8)), read.tree(text = "(((a, (e, f)), (d, (b, c))), (g, h));")) + + tree <- tree11 + tree$edge.length = rep.int(1, 20) + expect_equal(TBR(tree11, 11, c(8, 17)), read.tree(text = '((j, k), (e, ((a, b), (c, (d, (i, (h, (g, f))))))));')) + expect_equal(TBR(tree11, 11, c(2, 11)), read.tree(text = '((j, k), (e, (((a, b), (c, d)), (f, (g, (i, h))))));')) + expect_warning(TBR(tree11, 10, c(2, 11))) + expect_equal(TBR(tree11, 10, c(3, 11)), read.tree(text = '(e, ((c, d), ((a, b), ((j, k), (f, (g, (h, i)))))));')) + +}) + +test_that("RootedTBR fails", { + # tree8 <- read.tree(text = "(((a, (b, (c, d))), (e, f)), (g, h));") + # tree11 <- read.tree(text = "((((a, b), (c, d)), e), ((f, (g, (h, i))), (j, k)));") + + expect_equal(TBR(tree8, 4, c(3, 7)), RootedTBR(tree8, 4, c(3, 7))) + expect_equal(TBR(tree8, 4, c(1, 5)), RootedTBR(tree8, 4, c(1, 5))) + expect_warning(RootedTBR(tree5a, edgeToBreak = 1)) + expect_warning(RootedTBR(tree5a, edgeToBreak = 2)) + expect_equal(RootedTBR(tree5a, edgeToBreak = 3, mergeEdges=6), read.tree(text = '(a, (c, (b, (d, e))));')) + expect_silent(replicate(100, RootedTBR(tree5a))) + expect_warning(RootedTBR(tree8, 4, c(13, 6))) + expect_warning(RootedTBR(read.tree(text = '((a, b), (c, d));'))) +}) + +test_that("RootedSPR fails", { + expect_warning(RootedSPR(read.tree(text = '((a, b), (c, d));'))) + expect_warning(RootedSPR(tree8, edgeToBreak=1)) + expect_warning(RootedSPR(tree8, edgeToBreak=13)) + expect_warning(RootedSPR(tree8, edgeToBreak=14)) + warnTree1 <- read.tree(text = '((a, (b, (c, d))), (e, (f, (g, h))));') + warnTree2 <- read.tree(text = '((a, (b, (c, d))), (((e, f), g), h));') + attr(warnTree1, 'order') <- attr(warnTree2, 'order') <- 'preorder' + expect_warning(RootedSPR(warnTree1, 3)) + expect_warning(RootedSPR(warnTree1, 10)) + expect_warning(RootedSPR(warnTree2, 9)) + expect_warning(RootedSPR(warnTree2, 8)) +}) + +test_that("SPR is special case of TBR", { + expect_equal(SPR(tree11, 3, 9), TBR(tree11, 3, c(3, 9))) + expect_equal(SPR(tree11, 12, 9), TBR(tree11, 12, c(12, 9))) + expect_equal(root(SPR(tree11, 1, 14), letters[1:5], resolve.root=TRUE), TBR(tree11, 1, c(1, 14))) + expect_error(SPR(tree11, 1, 6)) +}) + +#' @author Martin R. Smith +CheckTreeSanity <- function (tree) { + nTip <- length(tree$tip.label) + nNode <- tree$Nnode + edge <- tree$edge + parent <- edge[, 1] + child <- edge[, 2] + aok <- TRUE + expect_true(all(parent > nTip), + info=paste0("Parent nodes on edge(s) ", paste(which(parent <= nTip), collapse=', '), + " are tips (nTip = ", nTip, ')') + ) + expect_equal(min(parent), nTip + 1, + info=paste0("Root is numbered ", min(parent), "; expecting ", nTip + 1) + ) + expect_false(min(parent) %in% child, + info=paste0("Root node (", min(parent), ") is child of edge ", paste0(which(min(parent) == child), collapse=', ')) + ) + expect_true(all(seq_len(nTip) %in% child)) # No missing tips + expect_equal(max(parent), nTip + nNode) + tips <- child <= nTip + expect_equal(sum(tips), nTip) + expect_true(all(child[!tips] > parent[!tips]), info="Parent nodes must be > child nodes") +} + +suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 +set.seed(0) +small_tree <- rtree(8) +large_tree <- rtree(80) +test_that("NNI trees conform to phylo expectations", { + for (i in 1:60) CheckTreeSanity(small_tree <- NNI(small_tree)) + for (i in 1:250) CheckTreeSanity(large_tree <- NNI(large_tree)) +}) +test_that("SPR trees conform to phylo expectations", { + for (i in 1:60) CheckTreeSanity(small_tree <- SPR(small_tree)) + for (i in 1:250) CheckTreeSanity(large_tree <- SPR(large_tree)) +}) +test_that("TBR trees conform to phylo expectations", { + for (i in 1:60) CheckTreeSanity(small_tree <- TBR(small_tree)) + for (i in 1:250) CheckTreeSanity(large_tree <- TBR(large_tree)) +}) From 1da0dbcd8506390ba823ad058278f104cd428f46 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 13:22:41 +0100 Subject: [PATCH 15/28] Delete only some tests --- tests/testthat/test-AdditionTree.R | 48 -------- tests/testthat/test-Concordance.R | 121 ------------------- tests/testthat/test-CustomSearch.R | 133 --------------------- tests/testthat/test-Jackknife.R | 46 -------- tests/testthat/test-MaximizeParsimony.R | 139 ---------------------- tests/testthat/test-NNI.R | 25 ---- tests/testthat/test-PlotCharacter.R | 125 -------------------- tests/testthat/test-data_manipulation.R | 133 --------------------- tests/testthat/test-iw-scoring.R | 78 ------------- tests/testthat/test-mpl_morphy_objects.R | 37 ------ tests/testthat/test-pp-fitch.R | 92 --------------- tests/testthat/test-pp-info_extra_step.R | 95 --------------- tests/testthat/test-pp-random-tree.R | 141 ----------------------- tests/testthat/test-rearrange.cpp.R | 1 - 14 files changed, 1214 deletions(-) delete mode 100644 tests/testthat/test-AdditionTree.R delete mode 100644 tests/testthat/test-Concordance.R delete mode 100644 tests/testthat/test-CustomSearch.R delete mode 100644 tests/testthat/test-Jackknife.R delete mode 100644 tests/testthat/test-MaximizeParsimony.R delete mode 100644 tests/testthat/test-NNI.R delete mode 100644 tests/testthat/test-PlotCharacter.R delete mode 100644 tests/testthat/test-data_manipulation.R delete mode 100644 tests/testthat/test-iw-scoring.R delete mode 100644 tests/testthat/test-mpl_morphy_objects.R delete mode 100644 tests/testthat/test-pp-fitch.R delete mode 100644 tests/testthat/test-pp-info_extra_step.R delete mode 100644 tests/testthat/test-pp-random-tree.R diff --git a/tests/testthat/test-AdditionTree.R b/tests/testthat/test-AdditionTree.R deleted file mode 100644 index d08724c26..000000000 --- a/tests/testthat/test-AdditionTree.R +++ /dev/null @@ -1,48 +0,0 @@ -test_that("Addition tree is more parsimonious", { - data('Lobo', package = 'TreeTools') - L10 <- Lobo.phy[1:10] - seq10 <- names(L10) - Score <- function (tr, k) TreeLength(tr, Lobo.phy, concavity = k) - - set.seed(1) # ensure consistent addition sequence - eq <- AdditionTree(Lobo.phy) - kx <- AdditionTree(L10, sequence = seq10, concavity = 10) - pr <- AdditionTree(L10, sequence = 1:10, concavity = 'pr') - nj <- TreeTools::NJTree(Lobo.phy) - nj10 <- TreeTools::KeepTip(nj, 1:10) - - expect_lt(TreeLength(eq, Lobo.phy), TreeLength(nj, Lobo.phy)) - expect_lt(Score(kx, 10), Score(nj10, 10)) - expect_lt(Score(pr, 'pr'), Score(nj10, 'pr')) -}) - -test_that("Addition tree obeys constraints", { - dataset <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 1, - 0, 1, 1, 0, 0, 1), ncol = 2, - dimnames = list(letters[1:6], NULL))) - constraint <- MatrixToPhyDat(c(a = 0, b = 0, c = 0, d = 0, e = 1, f = 1)) - expect_true(as.Splits(c(F, F, F, F, T, T), letters[1:6]) %in% - as.Splits(AdditionTree(dataset, constraint = constraint), - letters[1:6])) - - cdef <- letters[3:6] - subtree <- TreeTools::KeepTip( - AdditionTree(dataset, constraint = constraint[3:6], seq = letters[1:6]), - cdef) - expect_equal(ape::read.tree(text = '(c, d, (e, f));'), - TreeTools::UnrootTree(subtree)) -}) - -test_that("AdditionTree() handles edge cases", { - library('TreeTools') - dataset <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 1, - 0, 1, 1, 0, 0, 1), ncol = 2, - dimnames = list(letters[1:6], NULL))) - expect_equal(PectinateTree(letters[1:3]), AdditionTree(dataset[1:3])) - expect_equal(UnrootTree(PectinateTree(c('a', 'd', 'b', 'c'))), - UnrootTree(AdditionTree(dataset[1:4], conc = 'pr'))) - # All trees have equal score - expect_equal(5, NTip(AdditionTree(dataset[-4]))) -}) \ No newline at end of file diff --git a/tests/testthat/test-Concordance.R b/tests/testthat/test-Concordance.R deleted file mode 100644 index 1a8168c68..000000000 --- a/tests/testthat/test-Concordance.R +++ /dev/null @@ -1,121 +0,0 @@ -library("TreeTools", quietly = TRUE) - -test_that("QuartetConcordance() works", { - tree <- BalancedTree(8) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, 0, 0, 1, 1, 1, 1, 0, - 0, 1, 0, 1, 0, 1, 0, 1, 0, - 0, 0, 0, 1, 0, 1, 1, 1, 0, - 0, 0, 0, 0, 1, 1, 2, 2, 0, - 0, 0, 1, 1, 2, 2, 3, 3, 0, - 0, 1, 2, 3, 0, 1, 2, 3, 0), 9, - dimnames = list(paste0('t', 1:9), NULL)) - dat <- MatrixToPhyDat(mataset) - expect_equal(unname(QuartetConcordance(tree, dat[, 1])), rep(1, 5)) - # plot(tree); nodelabels(); - expect_equal(QuartetConcordance(tree, dat[, 2]), - c('11' = 0, '12' = 0, '13' = 1/9, '14' = 0, '15' = 0)) - - allQuartets <- combn(8, 4) - for (charI in seq_len(ncol(mataset))) { - qc <- QuartetConcordance(tree, dat[, charI]) - for (splitI in seq_along(splits)) { - split <- splits[[splitI]] - logiSplit <- as.logical(split) - case <- apply(allQuartets, 2, function (q) { - qSplit <- logiSplit[q] - qChar <- mataset[q, charI] - if (identical(unique(table(qSplit)), 2L) && - identical(unique(table(qChar)), 2L)) { - tbl <- table(qSplit, qChar) - tab <- paste0(sort(tbl[tbl > 0]), collapse = '') - switch(tab, - '1111' = FALSE, - '112' = NA, - '13' = NA, - '22' = TRUE, - "4" = NA, - stop(q, ": ", tab) - ) - } else { - NA - } - }) - expect_equal(sum(case, na.rm = TRUE) / sum(!is.na(case)), - unname(qc[as.character(names(split))])) - } - } - - expect_equal(QuartetConcordance(tree, dat[, c(1:4, 6)]), - c('11' = ( 6 + 0 + 6 + 2) / ( 6 + 9 + 6 + 2 + 1), - '12' = ( 6 + 0 + 0 + 2) / ( 6 + 9 + 9 + 2 + 1), - '13' = (36 + 2 + 9 + 12) / (36 + 18 + 18 + 12 + 6), - '14' = ( 6 + 0 + 0 + 7) / ( 6 + 9 + 9 + 7 + 1), - '15' = ( 6 + 0 + 6 + 7) / ( 6 + 9 + 6 + 7 + 1)) - ) -}) - -test_that("QuartetConcordance() handles ambiguity", { - tree <- BalancedTree(12) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, '{01}', 0, 0, '{01}', 1, 1, '-', 1, 1, '-', - 0, 1, '?', 0, 1, '?', 0, 1, '(01)', 0, 1, '(01)', - 0, 0, '?', 0, 1, '(12)', 0, 1, '(12)', 1, 1, '(12)', - 0, 0, '?', 0, 0, '?', 1, 1, '?', 2, 2, '?', - 0, 0, '?', 0, 0, '?', 0, 0, '-', 0, 0, '-', - rep('?', 12), - 0, 1, '?', 2, 3, '?', 0, 1, '-', 2, 3, '-'), 12, - dimnames = list(paste0('t', 1:12), NULL)) - dat <- MatrixToPhyDat(mataset) - - expect_equal(unname(QuartetConcordance(tree, dat)[c('16', '18', '19', '21', '23')]), - unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) - expect_equal(unname(QuartetConcordance(tree, dat)[c('15', '17', '19', '20', '22')]), - unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) -}) - -test_that("QuartetConcordance() handles incomplete data", { - tree <- BalancedTree(8) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, 0, 0, 0, 0, 0, 1, - rep('?', 8)), 8, - dimnames = list(paste0('t', 1:8), NULL)) - dat <- MatrixToPhyDat(mataset) - - expect_equal(unname(QuartetConcordance(tree, dat)), rep(NA_real_, 5)) -}) - -dataset <- congreveLamsdellMatrices[[10]][, 1] -tree <- TreeTools::NJTree(dataset) - -ConcordantInformation(tree, dataset)['noise'] -TreeLength(tree, dataset, concavity = 'prof') - -test_that("ConcordantInformation() works", { - data(congreveLamsdellMatrices) - dat <- congreveLamsdellMatrices[[10]] - tree <- TreeTools::NJTree(dat) - - ci <- ConcordantInformation(tree, dat) - expect_equal(expect_warning(Evaluate(tree, dat)), ci) - expect_equal(TreeLength(tree, dat, concavity = 'prof'), - unname(ci['noise'])) - expect_equal(Log2Unrooted(22), unname(ci['treeInformation'])) - expect_equal(sum(apply(PhyDatToMatrix(dat), 2, CharacterInformation)), - unname(ci['informationContent'])) - - dataset <- MatrixToPhyDat(cbind(setNames(c(rep(1, 11), 2:5), paste0('t', 1:15)))) - tree <- TreeTools::PectinateTree(length(dataset)) - expect_error(ConcordantInformation(tree, dataset)) - # expect_equal(0, unname(ci['signal'])) - # expect_equal(0, unname(ci['noise'])) - - dataset <- MatrixToPhyDat(c(a = 1, b = 2, c = 1, d = 2, e = 3, f = 3)) - tree <- TreeTools::PectinateTree(dataset) - ci <- expect_warning(ConcordantInformation(tree, dataset)) - expect_equal(c(signal = log2(3)), ci['signal']) - expect_equal(c(noise = log2(3)), ci['noise']) - expect_equal(c(ignored = CharacterInformation(c(0,0,1,1,2,2)) - - log2(3) - log2(3)), ci['ignored']) - -}) diff --git a/tests/testthat/test-CustomSearch.R b/tests/testthat/test-CustomSearch.R deleted file mode 100644 index acf36b8bf..000000000 --- a/tests/testthat/test-CustomSearch.R +++ /dev/null @@ -1,133 +0,0 @@ -context("TreeSearch.R") -library("TreeTools", quietly = TRUE) -comb11 <- PectinateTree(letters[1:11]) -unrooted11 <- UnrootTree(comb11) -data11 <- cbind(upper.tri(matrix(FALSE, 11, 11))[, 3:10], - lower.tri(matrix(FALSE, 11, 11))[, 2:9]) -rownames(data11) <- letters[1:11] -phy11 <- phangorn::phyDat(data11, type = 'USER', levels = c(FALSE, TRUE)) -RootySwappers <- list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap) - -test_that("Tree can be found", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(1) - random11 <- as.phylo(17905853L, 11, letters[1:11]) - expect_error(TreeSearch(unrooted11, dataset = phy11)) - expect_equal(comb11, TreeSearch(random11, dataset = phy11, maxIter = 200, - EdgeSwapper = RootedTBRSwap, verbosity = 0L)) - expect_equal(comb11, TreeSearch(random11, phy11, maxIter = 400, - EdgeSwapper = RootedSPRSwap, verbosity = 0L)) - someOtherTree <- as.phylo(29235922L, 11, letters[1:11]) - expect_equal(comb11, TreeSearch(someOtherTree, phy11, maxIter = 200, - EdgeSwapper = RootedNNISwap, verbosity = 0)) - expect_equal(comb11, Ratchet(random11, phy11, searchIter = 10, searchHits = 5, - swappers = RootySwappers, ratchHits = 3, - verbosity = 0)) - - expect_false(all.equal(comb11, TreeSearch(random11, dataset = phy11, - maxIter = 1000, - stopAtPlateau = 1, verbosity = 0))) - - expect_true(all.equal( - MaximizeParsimony(phy11, tree = CollapseNode(random11, 13))[[1]], - comb11 - )) - expect_true(all.equal( - MaximizeParsimony(phy11, tree = random11, verbosity = 0L)[[1]], - comb11 - )) - expect_true(all.equal( - MaximizeParsimony(phy11, random11, ratchIter = 0, verbosity = 0L)[[1]], - comb11 - )) - - # Interestingly, a good example of a case with multiple optima that require - # ratchet to move between - iw <- MaximizeParsimony(phy11, random11, ratchIter = 1, tbrIter = 5, - concavity = 10, verbosity = 0L)[[1]] - expect_equal(comb11, iw) -# TODO: Sectorial Search not working yet! -# expect_equal(SectorialSearch(RandomTree(phy11, 'a'), phy11, verbosity = -1), comb11) -}) - -test_that("Tree search finds shortest tree", { - true_tree <- ape::read.tree(text = "(((((1,2),3),4),5),6);") - malformed_tree <- ape::read.tree(text = "((((1,2),3),4),5,6);") - dataset <- TreeTools::StringToPhyDat('110000 111000 111100', 1:6, byTaxon = FALSE) - expect_error(TreeSearch(malformed_tree, dataset)) - start_tree <- TreeTools::RenumberTips(ape::read.tree( - text = "(((1, 6), 3), (2, (4, 5)));"), true_tree$tip.label) - expect_equal(TreeLength(start_tree, dataset), 6) - morphyObj <- PhyDat2Morphy(dataset) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = NNISwap, - verbosity = 0), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = SPRSwap, - verbosity = -1), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = TBRSwap, - verbosity = -1), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedNNISwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedSPRSwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedTBRSwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - ratchetScore <- attr(Ratchet(start_tree, dataset, - swappers = list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap), - ratchIter = 3, searchHits = 5, verbosity = 0), 'score') - expect_equal(3, TreeLength(true_tree, dataset), ratchetScore) -}) - - -test_that("Profile parsimony works in tree search", { - random11 <- as.phylo(17905853L, 11, letters[1:11]) # Rooted on 'a' - - # Use more iterations than necessary locally, as RNG may differ on other - # platforms. - expect_equal(comb11, - MaximizeParsimony(phy11, c(random11, random11), # multiPhylo - ratchIter = 1, tbrIter = 2, maxHits = 10, - concavity = 'profile', verbosity = 0)[[1]]) - - - sillyData <- lapply(1:22, function (i) c(rep(0, i - 1), rep(1, 22 - i), - rep(1, 22 - i), rep(0, i - 1)))#, sample(2, 20, replace = TRUE)-1)) - names(sillyData) <- as.character(1:22) - dataset <- TreeTools::PhyDat(sillyData) - readyData <- PrepareDataProfile(dataset) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - rTree <- randomTree <- RandomTree(dataset, '1') - expect_lte(TreeLength(rTree, readyData), TreeLength(rTree, dataset)) - expect_equal(90, TreeLength(referenceTree, dataset), TreeLength(referenceTree, readyData)) - expect_gt(TreeLength(rTree, readyData, 'profile'), - TreeLength(referenceTree, readyData, 'profile')) - - quickTS <- TreeSearch(rTree, dataset, TreeScorer = MorphyLength, EdgeSwapper = RootedNNISwap, - maxIter = 1600, maxHits = 40, verbosity = 0) - expect_equal(42L, attr(quickTS, 'score')) - - quickFitch <- Ratchet(rTree, dataset, TreeScorer = MorphyLength, suboptimal = 2, - swappers = RootySwappers, ratchHits = 3, searchHits = 15, - searchIter = 100, ratchIter = 500, - verbosity = 0L) - expect_equal(42, attr(quickFitch, 'score')) - - -}) - -test_that("Ratchet fails gracefully", { - expect_error(Ratchet(unrooted11, data11)) -}) diff --git a/tests/testthat/test-Jackknife.R b/tests/testthat/test-Jackknife.R deleted file mode 100644 index e6b1f56e1..000000000 --- a/tests/testthat/test-Jackknife.R +++ /dev/null @@ -1,46 +0,0 @@ -context('Jackknife.R') - -test_that("Jackknife supports are correct", { - true_tree <- ape::read.tree(text = "((((((A,B),C),D),E),F),out);") - start_tree <- ape::read.tree(text = "(((((A,D),B),E),(C,F)),out);") - dataset <- TreeTools::StringToPhyDat('1100000 1110000 1111000 1111100 1100000 1110000 1111000 1111100 1001000', - 1:7, byTaxon = FALSE) - names(dataset) <- c(LETTERS[1:6], 'out') - - expect_error(Jackknife(unroot(true_tree), dataset)) - expect_error(Jackknife(start_tree, dataset, resampleFreq = 0)) - expect_error(Jackknife(start_tree, dataset, resampleFreq = 9/10)) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - strict <- TreeSearch(start_tree, dataset, verbosity = 0) - expect_equal(1, length(unique(list(true_tree), list(start_tree)))) # Right tree found - jackTrees <- Jackknife(strict, dataset, resampleFreq = 4/7, searchIter = 24L, - searchHits = 7L, EdgeSwapper=RootedTBRSwap, - jackIter = 20L, verbosity = 0L) - - # Note: one cause of failure could be a change in characters sampled, due to randomness - expect_true(length(unique(jackTrees)) > 2L) -}) - -test_that("Jackknife ouputs good for node.labels", { - library('TreeTools', quietly = TRUE) # for as.phylo - - # jackTrees will usually be generated with Jackknife(), but for simplicity: - jackTrees <- as.phylo(1:100, 8) - - tree <- as.phylo(0, 8) - expect_equal(c('', '', '0.13', '0.08', '0.14', '1', '1'), - JackLabels(tree, jackTrees, plot = FALSE)) - - tree <- RootTree(as.phylo(0, 8), c('t1', 't4')) - expect_equal(c('', '0.08', '0.13', '', '0.14', '1', '1'), - JackLabels(tree, jackTrees, plot = FALSE)) - - skip_if_not_installed('vdiffr') - vdiffr::expect_doppelganger('plot-jackknife', function() { - expect_equal(as.double(JackLabels(tree, jackTrees, plot = FALSE)[-c(1, 4)]), - unname(JackLabels(tree, jackTrees))) - }) -}) diff --git a/tests/testthat/test-MaximizeParsimony.R b/tests/testthat/test-MaximizeParsimony.R deleted file mode 100644 index c17017156..000000000 --- a/tests/testthat/test-MaximizeParsimony.R +++ /dev/null @@ -1,139 +0,0 @@ -library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) - -test_that("Profile fails gracefully", { - dataset <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 3, f = 3)) - expect_warning(PrepareDataProfile(dataset)) - expect_warning(MaximizeParsimony(dataset, concavity = 'pr')) -}) - -test_that("Constraints work", { - constraint <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 0, f = 0)) - characters <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 0, - 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - set.seed(0) - ewResults <- MaximizeParsimony(characters, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint) - expect_equal(PectinateTree(letters[1:6]), ewResults[[1]]) - expect_equal(c(seed = 0, start = 1, final = 0), - attr(ewResults, 'firstHit')) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, concavity = 'p', - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)[[1]]) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, concavity = 10, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)[[1]]) - # Start tree not consistent with constraint - dataset <- characters - tree <- PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, - PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')), - ratchIter = 0, constraint = constraint)[[1]]) - - - dataset <- MatrixToPhyDat(matrix(c(0, 0, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:7], NULL))) - constraint <- MatrixToPhyDat(matrix(c(0, 0, 1, '?', 1, 1, - 1, 1, 1, 1, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - cons <- consensus(MaximizeParsimony(dataset, constraint = constraint)) - expect_true(as.Splits(as.logical(c(0, 0, 1, 1, 1)), letters[c(1:3, 5:6)]) %in% - as.Splits(DropTip(cons, c('d', 'g')))) - - expect_true(as.Splits(as.logical(c(0, 0, 0, 0, 1, 1)), letters[1:6]) %in% - as.Splits(DropTip(cons, 'g'))) - -}) - -test_that("Inconsistent constraints fail", { - constraint <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 0, - 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - expect_error(MaximizeParsimony(constraint, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)) -}) - -test_that("MaximizeParsimony() times out", { - data('congreveLamsdellMatrices', package = 'TreeSearch') - dataset <- congreveLamsdellMatrices[[42]] - startTime <- Sys.time() - MaximizeParsimony(dataset, ratchIter = 10000, tbrIter = 1, maxHits = 1, - maxTime = 0) - expect_gt(as.difftime(5, units = 'secs'), Sys.time() - startTime) -}) - -test_that("Mismatched tree/dataset handled with warnings", { - treeAf <- read.tree(text = "(a, (b, (c, (d, (e, f)))));") - treeBg <- read.tree(text = "(g, (b, (c, (d, (e, f)))));") - datAf <- StringToPhyDat('110000 110000 111100 111000', - letters[1:6], byTaxon = FALSE) - datAe <- StringToPhyDat('11000 11000 11110 11100', - letters[1:5], byTaxon = FALSE) - datAg <- StringToPhyDat('1100000 1100000 1111000 1110000', - letters[1:7], byTaxon = FALSE) - - QP <- function (...) MaximizeParsimony(..., ratchIter = 0, maxHits = 1, - verbosity = 0) - - expect_equal(5, NTip(expect_warning(QP(datAf, treeBg)))) - expect_equal(5, NTip(expect_warning(QP(datAe, treeAf)))) - expect_equal(6, NTip(expect_warning(QP(datAg, treeAf)))) - expect_equal(5, NTip(expect_warning(QP(datAf, treeBg, constraint = datAe)))) - expect_equal(6, NTip(QP(datAf, treeAf, constraint = datAe))) - expect_equal(6, NTip(expect_warning(QP(datAf, treeAf, constraint = datAg)))) -}) - -test_that("Root retained if not 1", { - tr <- RootTree(BalancedTree(8), 't5') - dataset <- StringToPhyDat('11000000 11100000 11110000 11111000', - paste0('t', 1:8), byTaxon = FALSE) - - mpt <- MaximizeParsimony(dataset, tr) - expect_equal(5, mpt[[1]]$edge[14, 2]) -}) - -test_that("Resample() fails and works", { - expect_error(Resample(0)) - dataset <- MatrixToPhyDat(rbind( - a = c(0, 0, 0, 0, 0, 0), - b = c(0, 0, 0, 0, 0, 0), - c = c(1, 1, 0, 0, 0, 1), - d = c(1, 1, 0, 0, 1, 0), - e = c(1, 1, 1, 1, 1, 1), - f = c(1, 1, 1, 1, 1, 1))) - - expect_error(Resample(dataset, method = 'ERROR')) - expect_error(Resample(dataset, proportion = 0)) - expect_error(Resample(dataset, proportion = 6 / 7)) - - nRep <- 42L # Arbitrary number to balance runtime vs false +ves & -ves - bal <- as.Splits(BalancedTree(dataset)) - - skip_if_not_installed("TreeTools", "1.4.5.9003") # postorder / as.Splits order - jackTrees <- replicate(nRep, Resample(dataset, NJTree(dataset), verbosity = 0L)) - jackSplits <- as.Splits(unlist(jackTrees, recursive = FALSE)) - jackSupport <- rowSums(vapply(jackSplits, function (sp) in.Splits(bal, sp), - logical(3))) - # This test could be replaced with a more statistically robust alternative! - expect_equal(c(1, 1/2, 0) * sum(vapply(jackTrees, length, 1L)), jackSupport, - tolerance = 0.2) - - bootTrees <- replicate(nRep, Resample(dataset, method = 'bootstrap', - verbosity = 0)) - #bootSupport <- rowSums(vapply(lapply(bootTrees, `[[`, 1), - bootSupport <- rowSums(vapply(unlist(bootTrees, recursive = FALSE), - function (tr) in.Splits(bal, as.Splits(tr)), - logical(3))) - # This test could be replaced with a more statistically robust alternative! - expect_equal(c(1, 1/2, 0) * sum(vapply(bootTrees, length, 1L)), bootSupport, - tolerance = 0.2) - -}) diff --git a/tests/testthat/test-NNI.R b/tests/testthat/test-NNI.R deleted file mode 100644 index 573493fad..000000000 --- a/tests/testthat/test-NNI.R +++ /dev/null @@ -1,25 +0,0 @@ -test_that("Errors fail gracefully", { - expect_error(nni(TreeTools::BalancedTree(2)$edge, 0, 0)) -}) - -test_that("cNNI()", { - tr <- Preorder(root(TreeTools::BalancedTree(letters[1:7]), 'a', resolve.root = TRUE)) - expect_equal(ape::read.tree(text="(a,(b,((c,d),((e,g),f))));"), - cNNI(tr, 0, 1)) # Edge '9' - expect_equal(ape::read.tree(text="(a,(b,((c,d),((f,g),e))));"), - cNNI(tr, 0, 0)) # Edge '9' - expect_equal(cNNI(tr, 0, 1), cNNI(tr, 4, 1)) - expect_equal(ape::read.tree(text="(a, (b, (g, ((c, d), (e, f)))));"), # Edge 8 - cNNI(tr, 1, 1)) - expect_equal(cNNI(tr, 1, 1), cNNI(tr, 1, 3)) - expect_equal(ape::read.tree(text="(a, (b, ((e, f), ((c, d), g))));"), # Edge 8 - cNNI(tr, 1, 2)) - expect_equal(cNNI(tr, 1, 2), cNNI(tr, 1, 0)) - expect_equal(ape::read.tree(text="(a, (b, (d, (c, (g, (e, f))))));"), # Edge 5 - cNNI(tr, 2, 1)) - expect_equal(ape::read.tree(text="(a, ((b, (c, d)), ((e, f), g)));"), # Edge 4 - cNNI(tr, 3, 1)) - suppressWarnings(RNGversion('3.5.0')) - set.seed(0) # sample.int gives 4, 1 - expect_equal(cNNI(tr, 0, 1), cNNI(tr)) -}) \ No newline at end of file diff --git a/tests/testthat/test-PlotCharacter.R b/tests/testthat/test-PlotCharacter.R deleted file mode 100644 index b2498c296..000000000 --- a/tests/testthat/test-PlotCharacter.R +++ /dev/null @@ -1,125 +0,0 @@ -test_that("PlotCharacter()", { - - skip_if_not_installed("TreeTools", "1.5.0") # Changes plotting order - Character <- function (str, plot = FALSE, ...) { - tree <- ape::read.tree(text = - "((((((a, b), c), d), e), f), (g, (h, (i, (j, (k, l))))));") - dataset <- TreeTools::StringToPhyDat(str, tips = tree) - PlotCharacter(tree, dataset, - edge.width = 3, plot = plot, ...) - } - - expect_equal(structure(c(FALSE, FALSE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, - TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, - TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, - TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - TRUE, FALSE, FALSE, FALSE, TRUE, TRUE), .Dim = c(23L, 5L), .Dimnames = list( - NULL, c("-", "0", "1", "2", "3"))), - Character("23--1??--032", updateTips = TRUE)) - - skip_if_not_installed('vdiffr') - skip_if_not_installed("ape", "5.5.2") # Node colours - - Test <- if (interactive()) { - function (str) invisible(Character(str, plot = TRUE)) - } else { - function (str) { - vdiffr::expect_doppelganger( - paste0('PlotChar_', - gsub('?', 'Q', - gsub('(', 'd', - gsub(')', 'b', - gsub('-', 'I', str, - fixed = TRUE), fixed = TRUE), fixed = TRUE), fixed = TRUE)), - function() Character(str, plot = TRUE)) - } - } - - Test("23--1??--032") - Test("23--1??(-0)-(01)32") - Test("23??1????032") - Test("11--????--11") - Test("000011????00") - Test("????????????") - Test("-------?????") - Test("------------") - Test("1234(45)AACGTTT") - - # From TGuillerme testing suite: - Test("11-------100") - Test("1100----1100") - Test("000011110000") - Test("1---1111---1") - Test("----1111---1") - Test("01----010101") - Test("01---1010101") - Test("1??--??--100") - Test("21--3??--032") - Test("11--1??--111") - Test("11--1000001-") - Test("01------0101") - Test("110--?---100") - Test("210--100--21") - Test("????----1???") - Test("23--1----032") - Test("1----1----1-") - Test("-1-1-1--1-1-") - - Test("--------0101") - Test("10101-----01") - Test("011--?--0011") - Test("110--??--100") - Test("21--1----012") - Test("11----111111") - Test("210210------") - Test("----1111----") - Test("230--??1--32") - Test("023--??1--32") - Test("023-???1--32") - Test("23--1?1--023") - Test("----1010----") - Test("------11---1") - Test("10----11---1") - Test("320--??3--21") -}) - -test_that("Edge cases work", { - tree <- ape::read.tree(text = '(a, (b, ((c, d), (e, f))));') - dataset <- TreeTools::StringToPhyDat('-01100', tips = tree) - if (interactive()) { - PlotCharacter(tree, dataset) - } else { - expect_equal(c('-' = FALSE, '0' = TRUE, '1' = FALSE), - PlotCharacter(tree, dataset, plot = FALSE)[9, ]) - } - - tree <- ape::read.tree(text = '(a, (b, (c, (d, (e, f)))));') - dataset <- TreeTools::StringToPhyDat('--0101', tips = tree) - if (interactive()) { - PlotCharacter(tree, dataset) - } else { - expect_equal(cbind('-' = c(1, 1, 0, 0, 0), - '0' = c(0, 0, 1, 1, 1), - '1' = c(0, 0, 1, 1, 1)), - 1 * PlotCharacter(tree, dataset, plot = FALSE)[7:11, ]) - } -}) - -test_that("Out-of-sequence works", { - skip_if_not_installed('vdiffr') - skip_if_not_installed("ape", "5.5.2") # Node colours - vdiffr::expect_doppelganger('PlotChar_out-of-sequence', - function () { - PlotCharacter(ape::read.tree(text = '(a, (b, (c, d)));'), - TreeTools::StringToPhyDat('1342', tips = c('a', 'c', 'd', 'b')) - ) - }) -}) \ No newline at end of file diff --git a/tests/testthat/test-data_manipulation.R b/tests/testthat/test-data_manipulation.R deleted file mode 100644 index fbdcf28f2..000000000 --- a/tests/testthat/test-data_manipulation.R +++ /dev/null @@ -1,133 +0,0 @@ -context("data_manipulation.R") - -test_that("Deprecation", { - expect_equal(MinimumLength(1:3), expect_warning(MinimumSteps(1:3))) -}) - -test_that("Minimum step counts are correctly calculated", { - expect_equal(1, MinimumLength(1:3)) - expect_equal(1, MinimumLength(c(1:3, 5))) - expect_equal(0, MinimumLength(c(6, 7, 14))) - expect_equal(1, MinimumLength(0:3)) # 0 representing the inapplicable token - - # ++++, .++., ..++ - expect_equal(0, MinimumLength(c(2046, 384, 1152))) - - # ++++, +..., .++., ..++ - expect_equal(1, MinimumLength(c(15, 8, 6, 3))) - - # ++++++, +....., .++..., .+.+.., ...++. - expect_equal(2, MinimumLength(c(63, 32, 24, 20, 6))) - - dudDat <- TreeTools::StringToPhyDat('----{-,1}22', letters[1:7]) - expect_equal('----<-,1>22', TreeTools::PhyDatToString(dudDat, '>', ',')) - expect_equal(0, attr(PrepareDataIW(dudDat), 'min.length')) - - dudTwo <- TreeTools::StringToPhyDat('{-1}{-2}{-3}2233', letters[1:7]) - expect_equal('{-1}{-2}{-3}2233', TreeTools::PhyDatToString(PrepareDataIW(dudTwo))) - - tr <- ape::read.tree(text='(((a, b), c), (d, (e, ((f, g), (h, (i, (j, k)))))));') - expect_equal(CharacterLength(tr, compress = TRUE, - TreeTools::StringToPhyDat('11---22--33', letters[1:11])), - MinimumLength(c(0, 0, 0, 0, 0, 0, 2, 2, 4, 4, 8, 8))) - - # 04, 14, 24, 34, 05, 16, 27, 38, 9A - # In this case, chosing the most common state (4) means that we have to choose 567&8 too - # 012&3 is a better solution - # We also have to choose one of 9 or A, but it doesn't matter which. - expect_equal(4, MinimumLength(c( - 2^0 + 2^4, - 2^1 + 2^4, - 2^2 + 2^4, - 2^3 + 2^4, - 2^0 + 2^5, - 2^1 + 2^6, - 2^2 + 2^7, - 2^3 + 2^8, - 2^9 + 2^10 - ))) - - data('inapplicable.datasets') - expect_equal(c(1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1, - 1, 2, 1, 1, 4, 3, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 4, 1, - 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), - MinimumLength(inapplicable.phyData[[4]], compress = TRUE)) - -}) - -test_that("PrepareDataProfile() handles empty matrices", { - dat <- TreeTools::MatrixToPhyDat(matrix(c(0, 1, rep('?', 5)), - dimnames = list(letters[1:7], NULL))) - expectation <- dat[0] - attr(expectation, 'info.amounts') <- numeric(0) - expect_equal(expectation, PrepareDataProfile(dat)) -}) - -test_that("PrepareDataProfile()", { - - # Easy one - mtx <- cbind(c('0', '0', 1,1,1,1), - c(0,0,1,1,1,1),# again - c(0,0,0,1,1,'?')) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - phy1 <- TreeTools::MatrixToPhyDat(mtx) - expect_equivalent(phy1, PrepareDataProfile(phy1)) - expect_equal(attributes(phy1), attributes(PrepareDataProfile(phy1))[1:10]) - - # Easy one - mtx <- cbind(c('0', '0', 1,1,1,1), - c(1,1,0,0,0,0),# flipped - c(0,0,0,1,1,'{012}')) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - phy2 <- TreeTools::MatrixToPhyDat(mtx) - expect_equivalent(phy1, PrepareDataProfile(phy2)) - expect_equal(attributes(PrepareDataProfile(phy1)), - attributes(PrepareDataProfile(phy2))) - - - mtx <- cbind(c('0', '0', 1,1,1, '2', '2', 3,3,3,3), - c('?', '?', 1,1,1, '?', '?', 0,0,0,0), - c(0,0,1,1,1,2,2,3,3,3,3),# again - c(rep('?', 5), '2', '2', 0,0,0,0), - c('?', '?', 1,1,1, 1,1, 0,0,0,0), - c('0', '1', rep('?', 9)) - ) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - dataset <- TreeTools::MatrixToPhyDat(mtx) - - q <- '?' - decomposed <- matrix(c(0,0,q,q,q,q,q,1,1,1,1, - q,q,0,0,0,q,q,1,1,1,1, - q,q,q,q,q,0,0,1,1,1,1, - - q,q,0,0,0,q,q,1,1,1,1, - - 0,0,q,q,q,q,q,1,1,1,1, - q,q,0,0,0,q,q,1,1,1,1, - q,q,q,q,q,0,0,1,1,1,1, - - q,q,q,q,q,0,0,1,1,1,1, - q,q,0,0,0,0,0,1,1,1,1), - ncol = 9, dimnames = list(letters[1:11], NULL)) - - - expect_warning(pd <- PrepareDataProfile(dataset)) - expect_equal(decomposed, PhyDatToMatrix(pd)) - expect_equal(c(1, 2, 3, 2, 1, 2, 3, 3, 4), attr(pd, 'index')) - expect_equal(c(2, 3, 3, 1), attr(pd, 'weight')) - - dataset2 <- TreeTools::MatrixToPhyDat(mtx[!mtx[, 1] %in% c(0, 2), ]) - expect_equal(attr(PrepareDataProfile(dataset2), 'info.amounts'), - attr(pd, 'info.amounts')[1:3, 2, drop = FALSE]) - - - data('Lobo', package = "TreeTools") - expect_warning(prep <- PrepareDataProfile(Lobo.phy)) - expect_equal(c(17, attr(prep, 'nr')), - dim(attr(prep, 'info.amounts'))) - - -}) diff --git a/tests/testthat/test-iw-scoring.R b/tests/testthat/test-iw-scoring.R deleted file mode 100644 index d829751ef..000000000 --- a/tests/testthat/test-iw-scoring.R +++ /dev/null @@ -1,78 +0,0 @@ -test_that("IW Scoring", { - library('TreeTools', quietly = TRUE, warn.conflicts = FALSE) - data('Lobo', package = 'TreeTools') - dataset <- Lobo.phy - - #dataset <- ReadAsPhyDat('c:/research/r/hyoliths/mbank_X24932_6-19-2018_744.nex') - tree <- NJTree(dataset) - - - .IWScore <- function (edge, morphyObjs, weight, minLength, concavity) { - steps <- preorder_morphy_by_char(edge, morphyObjs) - homoplasies <- steps - minLength - fit <- homoplasies / (homoplasies + concavity) - sum(fit * weight) - } - - concavity <- 4.5 - epsilon <- sqrt(.Machine$double.eps) - - - tree <- Preorder(RenumberTips(tree, names(dataset))) - nTip <- NTip(tree) - edge <- tree$edge - - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - startWeights <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) - - nLevel <- length(at$level) - nChar <- at$nr - nTip <- length(dataset) - cont <- at$contrast - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) colnames(cont)[x][1]), - '?') - inappLevel <- at$levels == '-' - - if (any(inappLevel)) { - # TODO this is a workaround until MinimumLength can handle {-, 1} - cont[cont[, inappLevel] > 0, ] <- 0 - ambiguousToken <- at$allLevels == '?' - cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 - } - - # Perhaps replace with previous code: - # inappLevel <- which(at$levels == "-") - # cont[, inappLevel] <- 0 - - powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) - tmp <- as.integer(cont %*% powersOf2) - unlisted <- unlist(dataset, use.names = FALSE) - binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) - minLength <- apply(binaryMatrix, 1, MinimumLength) - - tokenMatrix <- matrix(simpleCont[unlisted], nChar, nTip, byrow = FALSE) - charInfo <- apply(tokenMatrix, 1, CharacterInformation) - needsInapp <- rowSums(tokenMatrix == '-') > 2 - inappSlowdown <- 3L # A guess - rawPriority <- charInfo / ifelse(needsInapp, inappSlowdown, 1) - priority <- startWeights * rawPriority - informative <- needsInapp | charInfo > 0 - # Will work from end of sequence to start. - charSeq <- seq_along(charInfo)[informative][order(priority[informative])] - 1L - - - weight <- startWeights - - expect_equal(.IWScore(edge, morphyObjects, weight, minLength, concavity), - morphy_iw(edge, morphyObjects, weight, minLength, charSeq, - concavity, Inf)) - - expect_equal(Inf, morphy_iw(edge, morphyObjects, weight, minLength, charSeq, - concavity, 0)) - -}) \ No newline at end of file diff --git a/tests/testthat/test-mpl_morphy_objects.R b/tests/testthat/test-mpl_morphy_objects.R deleted file mode 100644 index 038e6ef62..000000000 --- a/tests/testthat/test-mpl_morphy_objects.R +++ /dev/null @@ -1,37 +0,0 @@ -test_that("PhyDat2Morphy() errors", { - expect_error(PhyDat2Morphy(NA)) -}) - -test_that("UnloadMorphy() errors", { - expect_error(UnloadMorphy(NA)) -}) - -test_that("GapHandler()", { - expect_error(GapHandler(0)) - tokens <- matrix(c('-', '-', 0, 0), byrow = TRUE, nrow = 4L, - dimnames = list(letters[1:4], NULL)) - pd <- TreeTools::MatrixToPhyDat(tokens) - - morphyObj <- PhyDat2Morphy(pd) - expect_equal(0, RandomTreeScore(morphyObj)) - expect_equal("Inapplicable", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- PhyDat2Morphy(pd, 'ambigu') - expect_equal(0, RandomTreeScore(morphyObj)) - expect_equal("Missing data", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- PhyDat2Morphy(pd, 'eXt') - expect_lt(0, RandomTreeScore(morphyObj)) - expect_equal("Extra state", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- SingleCharMorphy('-0-0', 'eXt') - expect_lt(0, RandomTreeScore(morphyObj)) - expect_equal("Extra state", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - expect_error(SingleCharMorphy('-0-0', 'ERROR')) - expect_error(GapHandler(morphyObj)) -}) diff --git a/tests/testthat/test-pp-fitch.R b/tests/testthat/test-pp-fitch.R deleted file mode 100644 index dec536272..000000000 --- a/tests/testthat/test-pp-fitch.R +++ /dev/null @@ -1,92 +0,0 @@ -context("pp_exact") - -# TODO this test was recovered from a stash and requires updating -- -# or may be obselete. -test_that("Profile score correct for small trees", { - library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) - tree <- as.phylo(200, 9) - - mataset <- matrix(c( - 1, 1, 1, 1, 0, 0, 0, 0, 0, # 3 steps - 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps - 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps again [duplicated] - 0, 1, 0, 0, 0, 0, 0, 1, 1, # 1 step - 2, 1, 1, 1, 1, 1, 1, 1, 1),# 1 step; non-informative - nrow = 9, dimnames = list(paste0('t', 1:9), NULL)) - - - dataset <- MatrixToPhyDat(mataset) - - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - weight <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) - - nLevel <- length(at$level) - nChar <- at$nr - cont <- at$contrast - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) at$levels[x][1]), - '?') - inappLevel <- at$levels == '-' - - unlisted <- unlist(dataset, use.names = FALSE) - charSeq <- seq_len(nChar) - 1L - - tokenMatrix <- matrix(simpleCont[unlisted], nChar, 9, byrow = FALSE) - profileTables <- apply(tokenMatrix, 1, table) - if (inherits(profileTables, 'matrix')) { - profileTables <- lapply(seq_len(ncol(profileTables)), function (i) profileTables[, i]) - } - data('profiles', package = 'TreeSearch') - profileCost <- lapply(profileTables, function (x) { - x <- sort(x[x > 1]) - n <- length(x) - prof <- switch(n, - 0, - profiles[[sum(x)]][[n]][[x[1] - 1L]] - ) - }) - profileExtra <- lapply(profileCost, function (x) x - x[1]) - fixedCost <- -sum(vapply(profileCost, `[[`, 1, 1) * weight) - maxScore <- sum(Log2Unrooted(vapply(profileTables, sum, 1))) - pad <- function (x, len) { - ret <- double(len) - ret[seq_along(x)] <- x - ret - } - profiles <- vapply(profileExtra, pad, double(4), 4) - - TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, - charSeq, profiles, Inf) - - PP <- function (costs) { - TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, - charSeq, costs, Inf) - } - - - # Use integer-step profile tables - extraSteps <- matrix(1:4, 4, 4) - expect_equal(TreeLength(tree, dataset), PP(costs = extraSteps)) - expect_equal(3 + 2 + 2 + 1 + 1, - TreeLength(tree, dataset)) -}) - - -test_that("Profile score can be calculated from real data", { - data(referenceTree) - data(congreveLamsdellMatrices) - tree <- referenceTree - dataset <- PrepareDataProfile(congreveLamsdellMatrices[[1]]) - expect_equal(TreeLength(tree, dataset), - sum(CharacterLength(tree, dataset, compress = TRUE) * - attr(dataset, 'weight'))) - score <- TreeLength(tree, dataset, 'profile') - - # Check score hasn't materially changed: - # 511.732 is "previous value"; not manually checked. - expect_equal(511.732, score, tolerance = 0.01) -}) diff --git a/tests/testthat/test-pp-info_extra_step.R b/tests/testthat/test-pp-info_extra_step.R deleted file mode 100644 index 4a34e6550..000000000 --- a/tests/testthat/test-pp-info_extra_step.R +++ /dev/null @@ -1,95 +0,0 @@ -context("pp_info_extra_step.R") -library("TreeSearch", quietly = TRUE) - -test_that("Bad input safely handled", { - expect_equal(0, WithOneExtraStep(1)) - expect_error(WithOneExtraStep(2, 2, 2)) - - expect_equal(0, Carter1(5, 6, 4)) - expect_equal(-Inf, LogCarter1(5, 6, 4)) - expect_equal(-Inf, Log2Carter1(5, 6, 4)) -}) - -test_that("StepInformation() works", { - expect_equal(c(`0` = 0), StepInformation(rep(3L, 10), ambiguousTokens = 3)) - expect_equal(c(`0` = 0), StepInformation(c(4L, rep(3L, 10)), 3)) - expect_true(all(is.finite(StepInformation(rep.int(1:3, times = c(139, 45, 41)), - ambiguousTokens = 3)))) - expect_true(all(is.finite(StepInformation( - char = rep.int(1:2, times = c(600, 600)))))) -}) - -test_that("Carter1() matches profile counts", { - data("profiles", package = "TreeSearch") - Test <- function (a, b) { - n <- sum(a, b) - counted <- 2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]] * NUnrooted(n) - m <- as.integer(names(counted)) - for (mi in m) { - expect_equal(log2(Carter1(mi, a, b)), Log2Carter1(mi, b, a)) - expect_equal(log(Carter1(mi, a, b)), LogCarter1(mi, b, a)) - } - expect_equivalent(counted, - cumsum(vapply(m, Carter1, a = a, b = b, double(1)))) - } - - Test(2, 4) - Test(2, 5) - Test(2, 6) - Test(2, 7) - Test(2, 8) - - Test(3, 4) - Test(3, 5) - Test(3, 6) - Test(3, 7) - - Test(4, 4) - Test(4, 5) - Test(4, 6) - - Test(5, 4) - Test(5, 5) - -}) - -test_that("WithOneExtraStep() input format", { - expect_equal(WithOneExtraStep(7, 5), WithOneExtraStep(c(5, 7))) -}) - -test_that("WithOneExtraStep()", { - library("TreeTools", quietly = TRUE) - data("profiles", package = "TreeSearch") - Test <- function (a, b) { - n <- sum(a, b) - expect_equivalent(2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]][2] * NUnrooted(n), - NUnrootedMult(c(a, b)) + WithOneExtraStep(c(a, b))) - } - - Test(4, 2) - Test(3, 3) - Test(8, 2) - Test(4, 3) - Test(7, 3) - Test(6, 4) - Test(5, 5) - - expect_equal(NUnrooted(6) / NUnrooted(5) * WithOneExtraStep(2:3), - WithOneExtraStep(1:3)) - expect_equal(NUnrooted(10) / NUnrooted(5) * WithOneExtraStep(2:3), - WithOneExtraStep(2:3, rep(1, 5))) -}) - -test_that(".LogCumSumExp()", { - Test <- function (x) { - naive <- log(cumsum(exp(x))) - if (all(is.finite(naive))) { - expect_equal(naive, .LogCumSumExp(x)) - } else { - expect_true(all(is.finite(.LogCumSumExp(x)))) - } - } - Test(log(c(1:5, 5:1))) - Test(c(10, 700, 100)) - Test(c(10, 7000, 100)) -}) \ No newline at end of file diff --git a/tests/testthat/test-pp-random-tree.R b/tests/testthat/test-pp-random-tree.R deleted file mode 100644 index 38f4cbbd7..000000000 --- a/tests/testthat/test-pp-random-tree.R +++ /dev/null @@ -1,141 +0,0 @@ -# NB: RandomTreeScore uses C's RNG, so no point in setting seed. -MorphyAction <- function (Action) expect_equal("ERR_NO_ERROR", mpl_translate_error(Action)) -MorphyWith <- function (char) { - nTip <- nchar(char) - 1L - morphyObj <- mpl_new_Morphy() - MorphyAction(mpl_init_Morphy(nTip, 1, morphyObj)) - MorphyAction(mpl_attach_rawdata(char, morphyObj)) - MorphyAction(mpl_set_num_internal_nodes(nTip - 1L, morphyObj)) - MorphyAction(mpl_set_parsim_t(1, 'FITCH', morphyObj)) - MorphyAction(mpl_set_charac_weight(1, 1, morphyObj)) - MorphyAction(mpl_apply_tipdata(morphyObj)) - class(morphyObj) <- 'morphyPtr' - morphyObj -} - - -context("pp: Tree randomness") -test_that("four-tip trees are randomly distributed", { - nTrees <- 36000 - stringency <- 0.005 # low numbers mean you'll rarely fail by chance - nTip <- 4 - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, 1/(nTip - 1)) - rTrees <- vapply(logical(nTrees), function (XX) - unlist(RandomMorphyTree(nTip)), integer((nTip * 4) - 3)) - expect_true(all(rTrees[1 + (seq_len(nTip - 1)), ] %in% nTip + seq_len(nTip - 2))) - expect_lt(expectedBounds[1], sum(rTrees[2, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[2, ] == 5)) - expect_lt(expectedBounds[1], sum(rTrees[3, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[3, ] == 5)) - expect_lt(expectedBounds[1], sum(rTrees[4, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[4, ] == 5)) - - expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] > expectedBounds[1])) - expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] < expectedBounds[2])) - - expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] < nTrees - expectedBounds[1])) - expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] > nTrees - expectedBounds[2])) -}) - -test_that("four-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - nTrees <- 6000 - stringency <- 0.005 - nTip <- 4 - - morphyObj <- MorphyWith('0011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - NUnrooted(nTip - 1L) / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - expect_lt(expectedBounds[1], sum(scores==1)) - expect_gt(expectedBounds[2], sum(scores==1)) -}) - -test_that("five-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - nTrees <- 6000 - stringency <- 0.005 - nTip <- 5 - morphyObj <- MorphyWith('00011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - NUnrooted(nTip - 1) / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - expect_equal(2L, max(scores)) - expect_lt(expectedBounds[1], sum(scores == 1)) - expect_gt(expectedBounds[2], sum(scores == 1)) -}) - - -test_that("six-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - nTrees <- 6000 - stringency <- 0.005 - nTip <- 6 - - morphyObj <- MorphyWith('000011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - NUnrooted(5) / NUnrooted(6)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - morphyObj <- UnloadMorphy(morphyObj) - - expect_true(max(scores) == 2) - expect_lt(expectedBounds[1], sum(scores==1)) - expect_gt(expectedBounds[2], sum(scores==1)) - - morphyObj <- MorphyWith('001122;') - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - 7 / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), - integer(1)) - morphyObj <- UnloadMorphy(morphyObj) - - expect_true(all(scores %in% 2:4)) - expect_lt(expectedBounds[1], sum(scores == 2)) - expect_gt(expectedBounds[2], sum(scores == 2)) - - morphyObj <- MorphyWith('000111;') - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - 3 * 3 / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - # unloaded on exit; don't unload twice || morphyObj <- UnloadMorphy(morphyObj) - - expect_true(max(scores) == 3) - expect_lt(expectedBounds[1], sum(scores == 1)) - expect_gt(expectedBounds[2], sum(scores == 1)) - -}) - -test_that("twelve-tip trees are randomly scored", { - nTrees <- 12000 # 12000 seems to throw false +ve too often? - stringency <- 0.01 # increased from 0.005 to avoid false +ves - nTip <- 12 - morphyObj <- MorphyWith('000000011111;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - NUnrooted(7) * (2 * 7 - 3) * - NUnrooted(5) * (2 * 5 - 3) / NUnrooted(nTip)) - - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), - integer(1L)) - # table(scores) - - expect_equal(5L, max(scores)) - nScoring1 <- sum(scores == 1) - expect_lt(expectedBounds[1], nScoring1) - expect_gt(expectedBounds[2], nScoring1) -}) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index d7b647f86..129c51337 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -168,5 +168,4 @@ if (FALSE) test_that("SPR works", { Test(14, 3, 11) Test(15, 3, 12) - }) \ No newline at end of file From 06097bf44346cec440cdc418f61618153ce9f7cf Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 13:34:47 +0100 Subject: [PATCH 16/28] Revert "Delete only some tests" This reverts commit 1da0dbcd8506390ba823ad058278f104cd428f46. --- tests/testthat/test-AdditionTree.R | 48 ++++++++ tests/testthat/test-Concordance.R | 121 +++++++++++++++++++ tests/testthat/test-CustomSearch.R | 133 +++++++++++++++++++++ tests/testthat/test-Jackknife.R | 46 ++++++++ tests/testthat/test-MaximizeParsimony.R | 139 ++++++++++++++++++++++ tests/testthat/test-NNI.R | 25 ++++ tests/testthat/test-PlotCharacter.R | 125 ++++++++++++++++++++ tests/testthat/test-data_manipulation.R | 133 +++++++++++++++++++++ tests/testthat/test-iw-scoring.R | 78 +++++++++++++ tests/testthat/test-mpl_morphy_objects.R | 37 ++++++ tests/testthat/test-pp-fitch.R | 92 +++++++++++++++ tests/testthat/test-pp-info_extra_step.R | 95 +++++++++++++++ tests/testthat/test-pp-random-tree.R | 141 +++++++++++++++++++++++ tests/testthat/test-rearrange.cpp.R | 1 + 14 files changed, 1214 insertions(+) create mode 100644 tests/testthat/test-AdditionTree.R create mode 100644 tests/testthat/test-Concordance.R create mode 100644 tests/testthat/test-CustomSearch.R create mode 100644 tests/testthat/test-Jackknife.R create mode 100644 tests/testthat/test-MaximizeParsimony.R create mode 100644 tests/testthat/test-NNI.R create mode 100644 tests/testthat/test-PlotCharacter.R create mode 100644 tests/testthat/test-data_manipulation.R create mode 100644 tests/testthat/test-iw-scoring.R create mode 100644 tests/testthat/test-mpl_morphy_objects.R create mode 100644 tests/testthat/test-pp-fitch.R create mode 100644 tests/testthat/test-pp-info_extra_step.R create mode 100644 tests/testthat/test-pp-random-tree.R diff --git a/tests/testthat/test-AdditionTree.R b/tests/testthat/test-AdditionTree.R new file mode 100644 index 000000000..d08724c26 --- /dev/null +++ b/tests/testthat/test-AdditionTree.R @@ -0,0 +1,48 @@ +test_that("Addition tree is more parsimonious", { + data('Lobo', package = 'TreeTools') + L10 <- Lobo.phy[1:10] + seq10 <- names(L10) + Score <- function (tr, k) TreeLength(tr, Lobo.phy, concavity = k) + + set.seed(1) # ensure consistent addition sequence + eq <- AdditionTree(Lobo.phy) + kx <- AdditionTree(L10, sequence = seq10, concavity = 10) + pr <- AdditionTree(L10, sequence = 1:10, concavity = 'pr') + nj <- TreeTools::NJTree(Lobo.phy) + nj10 <- TreeTools::KeepTip(nj, 1:10) + + expect_lt(TreeLength(eq, Lobo.phy), TreeLength(nj, Lobo.phy)) + expect_lt(Score(kx, 10), Score(nj10, 10)) + expect_lt(Score(pr, 'pr'), Score(nj10, 'pr')) +}) + +test_that("Addition tree obeys constraints", { + dataset <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 1, + 0, 1, 1, 0, 0, 1), ncol = 2, + dimnames = list(letters[1:6], NULL))) + constraint <- MatrixToPhyDat(c(a = 0, b = 0, c = 0, d = 0, e = 1, f = 1)) + expect_true(as.Splits(c(F, F, F, F, T, T), letters[1:6]) %in% + as.Splits(AdditionTree(dataset, constraint = constraint), + letters[1:6])) + + cdef <- letters[3:6] + subtree <- TreeTools::KeepTip( + AdditionTree(dataset, constraint = constraint[3:6], seq = letters[1:6]), + cdef) + expect_equal(ape::read.tree(text = '(c, d, (e, f));'), + TreeTools::UnrootTree(subtree)) +}) + +test_that("AdditionTree() handles edge cases", { + library('TreeTools') + dataset <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 1, + 0, 1, 1, 0, 0, 1), ncol = 2, + dimnames = list(letters[1:6], NULL))) + expect_equal(PectinateTree(letters[1:3]), AdditionTree(dataset[1:3])) + expect_equal(UnrootTree(PectinateTree(c('a', 'd', 'b', 'c'))), + UnrootTree(AdditionTree(dataset[1:4], conc = 'pr'))) + # All trees have equal score + expect_equal(5, NTip(AdditionTree(dataset[-4]))) +}) \ No newline at end of file diff --git a/tests/testthat/test-Concordance.R b/tests/testthat/test-Concordance.R new file mode 100644 index 000000000..1a8168c68 --- /dev/null +++ b/tests/testthat/test-Concordance.R @@ -0,0 +1,121 @@ +library("TreeTools", quietly = TRUE) + +test_that("QuartetConcordance() works", { + tree <- BalancedTree(8) + splits <- as.Splits(tree) + mataset <- matrix(c(0, 0, 0, 0, 1, 1, 1, 1, 0, + 0, 1, 0, 1, 0, 1, 0, 1, 0, + 0, 0, 0, 1, 0, 1, 1, 1, 0, + 0, 0, 0, 0, 1, 1, 2, 2, 0, + 0, 0, 1, 1, 2, 2, 3, 3, 0, + 0, 1, 2, 3, 0, 1, 2, 3, 0), 9, + dimnames = list(paste0('t', 1:9), NULL)) + dat <- MatrixToPhyDat(mataset) + expect_equal(unname(QuartetConcordance(tree, dat[, 1])), rep(1, 5)) + # plot(tree); nodelabels(); + expect_equal(QuartetConcordance(tree, dat[, 2]), + c('11' = 0, '12' = 0, '13' = 1/9, '14' = 0, '15' = 0)) + + allQuartets <- combn(8, 4) + for (charI in seq_len(ncol(mataset))) { + qc <- QuartetConcordance(tree, dat[, charI]) + for (splitI in seq_along(splits)) { + split <- splits[[splitI]] + logiSplit <- as.logical(split) + case <- apply(allQuartets, 2, function (q) { + qSplit <- logiSplit[q] + qChar <- mataset[q, charI] + if (identical(unique(table(qSplit)), 2L) && + identical(unique(table(qChar)), 2L)) { + tbl <- table(qSplit, qChar) + tab <- paste0(sort(tbl[tbl > 0]), collapse = '') + switch(tab, + '1111' = FALSE, + '112' = NA, + '13' = NA, + '22' = TRUE, + "4" = NA, + stop(q, ": ", tab) + ) + } else { + NA + } + }) + expect_equal(sum(case, na.rm = TRUE) / sum(!is.na(case)), + unname(qc[as.character(names(split))])) + } + } + + expect_equal(QuartetConcordance(tree, dat[, c(1:4, 6)]), + c('11' = ( 6 + 0 + 6 + 2) / ( 6 + 9 + 6 + 2 + 1), + '12' = ( 6 + 0 + 0 + 2) / ( 6 + 9 + 9 + 2 + 1), + '13' = (36 + 2 + 9 + 12) / (36 + 18 + 18 + 12 + 6), + '14' = ( 6 + 0 + 0 + 7) / ( 6 + 9 + 9 + 7 + 1), + '15' = ( 6 + 0 + 6 + 7) / ( 6 + 9 + 6 + 7 + 1)) + ) +}) + +test_that("QuartetConcordance() handles ambiguity", { + tree <- BalancedTree(12) + splits <- as.Splits(tree) + mataset <- matrix(c(0, 0, '{01}', 0, 0, '{01}', 1, 1, '-', 1, 1, '-', + 0, 1, '?', 0, 1, '?', 0, 1, '(01)', 0, 1, '(01)', + 0, 0, '?', 0, 1, '(12)', 0, 1, '(12)', 1, 1, '(12)', + 0, 0, '?', 0, 0, '?', 1, 1, '?', 2, 2, '?', + 0, 0, '?', 0, 0, '?', 0, 0, '-', 0, 0, '-', + rep('?', 12), + 0, 1, '?', 2, 3, '?', 0, 1, '-', 2, 3, '-'), 12, + dimnames = list(paste0('t', 1:12), NULL)) + dat <- MatrixToPhyDat(mataset) + + expect_equal(unname(QuartetConcordance(tree, dat)[c('16', '18', '19', '21', '23')]), + unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) + expect_equal(unname(QuartetConcordance(tree, dat)[c('15', '17', '19', '20', '22')]), + unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) +}) + +test_that("QuartetConcordance() handles incomplete data", { + tree <- BalancedTree(8) + splits <- as.Splits(tree) + mataset <- matrix(c(0, 0, 0, 0, 0, 0, 0, 1, + rep('?', 8)), 8, + dimnames = list(paste0('t', 1:8), NULL)) + dat <- MatrixToPhyDat(mataset) + + expect_equal(unname(QuartetConcordance(tree, dat)), rep(NA_real_, 5)) +}) + +dataset <- congreveLamsdellMatrices[[10]][, 1] +tree <- TreeTools::NJTree(dataset) + +ConcordantInformation(tree, dataset)['noise'] +TreeLength(tree, dataset, concavity = 'prof') + +test_that("ConcordantInformation() works", { + data(congreveLamsdellMatrices) + dat <- congreveLamsdellMatrices[[10]] + tree <- TreeTools::NJTree(dat) + + ci <- ConcordantInformation(tree, dat) + expect_equal(expect_warning(Evaluate(tree, dat)), ci) + expect_equal(TreeLength(tree, dat, concavity = 'prof'), + unname(ci['noise'])) + expect_equal(Log2Unrooted(22), unname(ci['treeInformation'])) + expect_equal(sum(apply(PhyDatToMatrix(dat), 2, CharacterInformation)), + unname(ci['informationContent'])) + + dataset <- MatrixToPhyDat(cbind(setNames(c(rep(1, 11), 2:5), paste0('t', 1:15)))) + tree <- TreeTools::PectinateTree(length(dataset)) + expect_error(ConcordantInformation(tree, dataset)) + # expect_equal(0, unname(ci['signal'])) + # expect_equal(0, unname(ci['noise'])) + + dataset <- MatrixToPhyDat(c(a = 1, b = 2, c = 1, d = 2, e = 3, f = 3)) + tree <- TreeTools::PectinateTree(dataset) + ci <- expect_warning(ConcordantInformation(tree, dataset)) + expect_equal(c(signal = log2(3)), ci['signal']) + expect_equal(c(noise = log2(3)), ci['noise']) + expect_equal(c(ignored = CharacterInformation(c(0,0,1,1,2,2)) - + log2(3) - log2(3)), ci['ignored']) + +}) diff --git a/tests/testthat/test-CustomSearch.R b/tests/testthat/test-CustomSearch.R new file mode 100644 index 000000000..acf36b8bf --- /dev/null +++ b/tests/testthat/test-CustomSearch.R @@ -0,0 +1,133 @@ +context("TreeSearch.R") +library("TreeTools", quietly = TRUE) +comb11 <- PectinateTree(letters[1:11]) +unrooted11 <- UnrootTree(comb11) +data11 <- cbind(upper.tri(matrix(FALSE, 11, 11))[, 3:10], + lower.tri(matrix(FALSE, 11, 11))[, 2:9]) +rownames(data11) <- letters[1:11] +phy11 <- phangorn::phyDat(data11, type = 'USER', levels = c(FALSE, TRUE)) +RootySwappers <- list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap) + +test_that("Tree can be found", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(1) + random11 <- as.phylo(17905853L, 11, letters[1:11]) + expect_error(TreeSearch(unrooted11, dataset = phy11)) + expect_equal(comb11, TreeSearch(random11, dataset = phy11, maxIter = 200, + EdgeSwapper = RootedTBRSwap, verbosity = 0L)) + expect_equal(comb11, TreeSearch(random11, phy11, maxIter = 400, + EdgeSwapper = RootedSPRSwap, verbosity = 0L)) + someOtherTree <- as.phylo(29235922L, 11, letters[1:11]) + expect_equal(comb11, TreeSearch(someOtherTree, phy11, maxIter = 200, + EdgeSwapper = RootedNNISwap, verbosity = 0)) + expect_equal(comb11, Ratchet(random11, phy11, searchIter = 10, searchHits = 5, + swappers = RootySwappers, ratchHits = 3, + verbosity = 0)) + + expect_false(all.equal(comb11, TreeSearch(random11, dataset = phy11, + maxIter = 1000, + stopAtPlateau = 1, verbosity = 0))) + + expect_true(all.equal( + MaximizeParsimony(phy11, tree = CollapseNode(random11, 13))[[1]], + comb11 + )) + expect_true(all.equal( + MaximizeParsimony(phy11, tree = random11, verbosity = 0L)[[1]], + comb11 + )) + expect_true(all.equal( + MaximizeParsimony(phy11, random11, ratchIter = 0, verbosity = 0L)[[1]], + comb11 + )) + + # Interestingly, a good example of a case with multiple optima that require + # ratchet to move between + iw <- MaximizeParsimony(phy11, random11, ratchIter = 1, tbrIter = 5, + concavity = 10, verbosity = 0L)[[1]] + expect_equal(comb11, iw) +# TODO: Sectorial Search not working yet! +# expect_equal(SectorialSearch(RandomTree(phy11, 'a'), phy11, verbosity = -1), comb11) +}) + +test_that("Tree search finds shortest tree", { + true_tree <- ape::read.tree(text = "(((((1,2),3),4),5),6);") + malformed_tree <- ape::read.tree(text = "((((1,2),3),4),5,6);") + dataset <- TreeTools::StringToPhyDat('110000 111000 111100', 1:6, byTaxon = FALSE) + expect_error(TreeSearch(malformed_tree, dataset)) + start_tree <- TreeTools::RenumberTips(ape::read.tree( + text = "(((1, 6), 3), (2, (4, 5)));"), true_tree$tip.label) + expect_equal(TreeLength(start_tree, dataset), 6) + morphyObj <- PhyDat2Morphy(dataset) + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + + expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = NNISwap, + verbosity = 0), 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = SPRSwap, + verbosity = -1), 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = TBRSwap, + verbosity = -1), 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, + EdgeSwapper = RootedNNISwap, verbosity = -1), + 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, + EdgeSwapper = RootedSPRSwap, verbosity = -1), + 'score'), + TreeLength(true_tree, dataset)) + expect_equal(3, attr(TreeSearch(start_tree, dataset, + EdgeSwapper = RootedTBRSwap, verbosity = -1), + 'score'), + TreeLength(true_tree, dataset)) + ratchetScore <- attr(Ratchet(start_tree, dataset, + swappers = list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap), + ratchIter = 3, searchHits = 5, verbosity = 0), 'score') + expect_equal(3, TreeLength(true_tree, dataset), ratchetScore) +}) + + +test_that("Profile parsimony works in tree search", { + random11 <- as.phylo(17905853L, 11, letters[1:11]) # Rooted on 'a' + + # Use more iterations than necessary locally, as RNG may differ on other + # platforms. + expect_equal(comb11, + MaximizeParsimony(phy11, c(random11, random11), # multiPhylo + ratchIter = 1, tbrIter = 2, maxHits = 10, + concavity = 'profile', verbosity = 0)[[1]]) + + + sillyData <- lapply(1:22, function (i) c(rep(0, i - 1), rep(1, 22 - i), + rep(1, 22 - i), rep(0, i - 1)))#, sample(2, 20, replace = TRUE)-1)) + names(sillyData) <- as.character(1:22) + dataset <- TreeTools::PhyDat(sillyData) + readyData <- PrepareDataProfile(dataset) + + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + rTree <- randomTree <- RandomTree(dataset, '1') + expect_lte(TreeLength(rTree, readyData), TreeLength(rTree, dataset)) + expect_equal(90, TreeLength(referenceTree, dataset), TreeLength(referenceTree, readyData)) + expect_gt(TreeLength(rTree, readyData, 'profile'), + TreeLength(referenceTree, readyData, 'profile')) + + quickTS <- TreeSearch(rTree, dataset, TreeScorer = MorphyLength, EdgeSwapper = RootedNNISwap, + maxIter = 1600, maxHits = 40, verbosity = 0) + expect_equal(42L, attr(quickTS, 'score')) + + quickFitch <- Ratchet(rTree, dataset, TreeScorer = MorphyLength, suboptimal = 2, + swappers = RootySwappers, ratchHits = 3, searchHits = 15, + searchIter = 100, ratchIter = 500, + verbosity = 0L) + expect_equal(42, attr(quickFitch, 'score')) + + +}) + +test_that("Ratchet fails gracefully", { + expect_error(Ratchet(unrooted11, data11)) +}) diff --git a/tests/testthat/test-Jackknife.R b/tests/testthat/test-Jackknife.R new file mode 100644 index 000000000..e6b1f56e1 --- /dev/null +++ b/tests/testthat/test-Jackknife.R @@ -0,0 +1,46 @@ +context('Jackknife.R') + +test_that("Jackknife supports are correct", { + true_tree <- ape::read.tree(text = "((((((A,B),C),D),E),F),out);") + start_tree <- ape::read.tree(text = "(((((A,D),B),E),(C,F)),out);") + dataset <- TreeTools::StringToPhyDat('1100000 1110000 1111000 1111100 1100000 1110000 1111000 1111100 1001000', + 1:7, byTaxon = FALSE) + names(dataset) <- c(LETTERS[1:6], 'out') + + expect_error(Jackknife(unroot(true_tree), dataset)) + expect_error(Jackknife(start_tree, dataset, resampleFreq = 0)) + expect_error(Jackknife(start_tree, dataset, resampleFreq = 9/10)) + + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + strict <- TreeSearch(start_tree, dataset, verbosity = 0) + expect_equal(1, length(unique(list(true_tree), list(start_tree)))) # Right tree found + jackTrees <- Jackknife(strict, dataset, resampleFreq = 4/7, searchIter = 24L, + searchHits = 7L, EdgeSwapper=RootedTBRSwap, + jackIter = 20L, verbosity = 0L) + + # Note: one cause of failure could be a change in characters sampled, due to randomness + expect_true(length(unique(jackTrees)) > 2L) +}) + +test_that("Jackknife ouputs good for node.labels", { + library('TreeTools', quietly = TRUE) # for as.phylo + + # jackTrees will usually be generated with Jackknife(), but for simplicity: + jackTrees <- as.phylo(1:100, 8) + + tree <- as.phylo(0, 8) + expect_equal(c('', '', '0.13', '0.08', '0.14', '1', '1'), + JackLabels(tree, jackTrees, plot = FALSE)) + + tree <- RootTree(as.phylo(0, 8), c('t1', 't4')) + expect_equal(c('', '0.08', '0.13', '', '0.14', '1', '1'), + JackLabels(tree, jackTrees, plot = FALSE)) + + skip_if_not_installed('vdiffr') + vdiffr::expect_doppelganger('plot-jackknife', function() { + expect_equal(as.double(JackLabels(tree, jackTrees, plot = FALSE)[-c(1, 4)]), + unname(JackLabels(tree, jackTrees))) + }) +}) diff --git a/tests/testthat/test-MaximizeParsimony.R b/tests/testthat/test-MaximizeParsimony.R new file mode 100644 index 000000000..c17017156 --- /dev/null +++ b/tests/testthat/test-MaximizeParsimony.R @@ -0,0 +1,139 @@ +library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) + +test_that("Profile fails gracefully", { + dataset <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 3, f = 3)) + expect_warning(PrepareDataProfile(dataset)) + expect_warning(MaximizeParsimony(dataset, concavity = 'pr')) +}) + +test_that("Constraints work", { + constraint <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 0, f = 0)) + characters <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 0, + 1, 1, 1, 0, 0, 0), ncol = 2, + dimnames = list(letters[1:6], NULL))) + set.seed(0) + ewResults <- MaximizeParsimony(characters, + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint) + expect_equal(PectinateTree(letters[1:6]), ewResults[[1]]) + expect_equal(c(seed = 0, start = 1, final = 0), + attr(ewResults, 'firstHit')) + expect_equal(PectinateTree(letters[1:6]), + MaximizeParsimony(characters, concavity = 'p', + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint)[[1]]) + expect_equal(PectinateTree(letters[1:6]), + MaximizeParsimony(characters, concavity = 10, + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint)[[1]]) + # Start tree not consistent with constraint + dataset <- characters + tree <- PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')) + expect_equal(PectinateTree(letters[1:6]), + MaximizeParsimony(characters, + PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')), + ratchIter = 0, constraint = constraint)[[1]]) + + + dataset <- MatrixToPhyDat(matrix(c(0, 0, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 0, 0, 0), ncol = 2, + dimnames = list(letters[1:7], NULL))) + constraint <- MatrixToPhyDat(matrix(c(0, 0, 1, '?', 1, 1, + 1, 1, 1, 1, 0, 0), ncol = 2, + dimnames = list(letters[1:6], NULL))) + cons <- consensus(MaximizeParsimony(dataset, constraint = constraint)) + expect_true(as.Splits(as.logical(c(0, 0, 1, 1, 1)), letters[c(1:3, 5:6)]) %in% + as.Splits(DropTip(cons, c('d', 'g')))) + + expect_true(as.Splits(as.logical(c(0, 0, 0, 0, 1, 1)), letters[1:6]) %in% + as.Splits(DropTip(cons, 'g'))) + +}) + +test_that("Inconsistent constraints fail", { + constraint <- MatrixToPhyDat(matrix( + c(0, 1, 1, 1, 0, 0, + 1, 1, 1, 0, 0, 0), ncol = 2, + dimnames = list(letters[1:6], NULL))) + expect_error(MaximizeParsimony(constraint, + PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), + ratchIter = 0, constraint = constraint)) +}) + +test_that("MaximizeParsimony() times out", { + data('congreveLamsdellMatrices', package = 'TreeSearch') + dataset <- congreveLamsdellMatrices[[42]] + startTime <- Sys.time() + MaximizeParsimony(dataset, ratchIter = 10000, tbrIter = 1, maxHits = 1, + maxTime = 0) + expect_gt(as.difftime(5, units = 'secs'), Sys.time() - startTime) +}) + +test_that("Mismatched tree/dataset handled with warnings", { + treeAf <- read.tree(text = "(a, (b, (c, (d, (e, f)))));") + treeBg <- read.tree(text = "(g, (b, (c, (d, (e, f)))));") + datAf <- StringToPhyDat('110000 110000 111100 111000', + letters[1:6], byTaxon = FALSE) + datAe <- StringToPhyDat('11000 11000 11110 11100', + letters[1:5], byTaxon = FALSE) + datAg <- StringToPhyDat('1100000 1100000 1111000 1110000', + letters[1:7], byTaxon = FALSE) + + QP <- function (...) MaximizeParsimony(..., ratchIter = 0, maxHits = 1, + verbosity = 0) + + expect_equal(5, NTip(expect_warning(QP(datAf, treeBg)))) + expect_equal(5, NTip(expect_warning(QP(datAe, treeAf)))) + expect_equal(6, NTip(expect_warning(QP(datAg, treeAf)))) + expect_equal(5, NTip(expect_warning(QP(datAf, treeBg, constraint = datAe)))) + expect_equal(6, NTip(QP(datAf, treeAf, constraint = datAe))) + expect_equal(6, NTip(expect_warning(QP(datAf, treeAf, constraint = datAg)))) +}) + +test_that("Root retained if not 1", { + tr <- RootTree(BalancedTree(8), 't5') + dataset <- StringToPhyDat('11000000 11100000 11110000 11111000', + paste0('t', 1:8), byTaxon = FALSE) + + mpt <- MaximizeParsimony(dataset, tr) + expect_equal(5, mpt[[1]]$edge[14, 2]) +}) + +test_that("Resample() fails and works", { + expect_error(Resample(0)) + dataset <- MatrixToPhyDat(rbind( + a = c(0, 0, 0, 0, 0, 0), + b = c(0, 0, 0, 0, 0, 0), + c = c(1, 1, 0, 0, 0, 1), + d = c(1, 1, 0, 0, 1, 0), + e = c(1, 1, 1, 1, 1, 1), + f = c(1, 1, 1, 1, 1, 1))) + + expect_error(Resample(dataset, method = 'ERROR')) + expect_error(Resample(dataset, proportion = 0)) + expect_error(Resample(dataset, proportion = 6 / 7)) + + nRep <- 42L # Arbitrary number to balance runtime vs false +ves & -ves + bal <- as.Splits(BalancedTree(dataset)) + + skip_if_not_installed("TreeTools", "1.4.5.9003") # postorder / as.Splits order + jackTrees <- replicate(nRep, Resample(dataset, NJTree(dataset), verbosity = 0L)) + jackSplits <- as.Splits(unlist(jackTrees, recursive = FALSE)) + jackSupport <- rowSums(vapply(jackSplits, function (sp) in.Splits(bal, sp), + logical(3))) + # This test could be replaced with a more statistically robust alternative! + expect_equal(c(1, 1/2, 0) * sum(vapply(jackTrees, length, 1L)), jackSupport, + tolerance = 0.2) + + bootTrees <- replicate(nRep, Resample(dataset, method = 'bootstrap', + verbosity = 0)) + #bootSupport <- rowSums(vapply(lapply(bootTrees, `[[`, 1), + bootSupport <- rowSums(vapply(unlist(bootTrees, recursive = FALSE), + function (tr) in.Splits(bal, as.Splits(tr)), + logical(3))) + # This test could be replaced with a more statistically robust alternative! + expect_equal(c(1, 1/2, 0) * sum(vapply(bootTrees, length, 1L)), bootSupport, + tolerance = 0.2) + +}) diff --git a/tests/testthat/test-NNI.R b/tests/testthat/test-NNI.R new file mode 100644 index 000000000..573493fad --- /dev/null +++ b/tests/testthat/test-NNI.R @@ -0,0 +1,25 @@ +test_that("Errors fail gracefully", { + expect_error(nni(TreeTools::BalancedTree(2)$edge, 0, 0)) +}) + +test_that("cNNI()", { + tr <- Preorder(root(TreeTools::BalancedTree(letters[1:7]), 'a', resolve.root = TRUE)) + expect_equal(ape::read.tree(text="(a,(b,((c,d),((e,g),f))));"), + cNNI(tr, 0, 1)) # Edge '9' + expect_equal(ape::read.tree(text="(a,(b,((c,d),((f,g),e))));"), + cNNI(tr, 0, 0)) # Edge '9' + expect_equal(cNNI(tr, 0, 1), cNNI(tr, 4, 1)) + expect_equal(ape::read.tree(text="(a, (b, (g, ((c, d), (e, f)))));"), # Edge 8 + cNNI(tr, 1, 1)) + expect_equal(cNNI(tr, 1, 1), cNNI(tr, 1, 3)) + expect_equal(ape::read.tree(text="(a, (b, ((e, f), ((c, d), g))));"), # Edge 8 + cNNI(tr, 1, 2)) + expect_equal(cNNI(tr, 1, 2), cNNI(tr, 1, 0)) + expect_equal(ape::read.tree(text="(a, (b, (d, (c, (g, (e, f))))));"), # Edge 5 + cNNI(tr, 2, 1)) + expect_equal(ape::read.tree(text="(a, ((b, (c, d)), ((e, f), g)));"), # Edge 4 + cNNI(tr, 3, 1)) + suppressWarnings(RNGversion('3.5.0')) + set.seed(0) # sample.int gives 4, 1 + expect_equal(cNNI(tr, 0, 1), cNNI(tr)) +}) \ No newline at end of file diff --git a/tests/testthat/test-PlotCharacter.R b/tests/testthat/test-PlotCharacter.R new file mode 100644 index 000000000..b2498c296 --- /dev/null +++ b/tests/testthat/test-PlotCharacter.R @@ -0,0 +1,125 @@ +test_that("PlotCharacter()", { + + skip_if_not_installed("TreeTools", "1.5.0") # Changes plotting order + Character <- function (str, plot = FALSE, ...) { + tree <- ape::read.tree(text = + "((((((a, b), c), d), e), f), (g, (h, (i, (j, (k, l))))));") + dataset <- TreeTools::StringToPhyDat(str, tips = tree) + PlotCharacter(tree, dataset, + edge.width = 3, plot = plot, ...) + } + + expect_equal(structure(c(FALSE, FALSE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, + TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, + TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, + FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, + FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, + FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, + TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, + TRUE, FALSE, FALSE, FALSE, TRUE, TRUE), .Dim = c(23L, 5L), .Dimnames = list( + NULL, c("-", "0", "1", "2", "3"))), + Character("23--1??--032", updateTips = TRUE)) + + skip_if_not_installed('vdiffr') + skip_if_not_installed("ape", "5.5.2") # Node colours + + Test <- if (interactive()) { + function (str) invisible(Character(str, plot = TRUE)) + } else { + function (str) { + vdiffr::expect_doppelganger( + paste0('PlotChar_', + gsub('?', 'Q', + gsub('(', 'd', + gsub(')', 'b', + gsub('-', 'I', str, + fixed = TRUE), fixed = TRUE), fixed = TRUE), fixed = TRUE)), + function() Character(str, plot = TRUE)) + } + } + + Test("23--1??--032") + Test("23--1??(-0)-(01)32") + Test("23??1????032") + Test("11--????--11") + Test("000011????00") + Test("????????????") + Test("-------?????") + Test("------------") + Test("1234(45)AACGTTT") + + # From TGuillerme testing suite: + Test("11-------100") + Test("1100----1100") + Test("000011110000") + Test("1---1111---1") + Test("----1111---1") + Test("01----010101") + Test("01---1010101") + Test("1??--??--100") + Test("21--3??--032") + Test("11--1??--111") + Test("11--1000001-") + Test("01------0101") + Test("110--?---100") + Test("210--100--21") + Test("????----1???") + Test("23--1----032") + Test("1----1----1-") + Test("-1-1-1--1-1-") + + Test("--------0101") + Test("10101-----01") + Test("011--?--0011") + Test("110--??--100") + Test("21--1----012") + Test("11----111111") + Test("210210------") + Test("----1111----") + Test("230--??1--32") + Test("023--??1--32") + Test("023-???1--32") + Test("23--1?1--023") + Test("----1010----") + Test("------11---1") + Test("10----11---1") + Test("320--??3--21") +}) + +test_that("Edge cases work", { + tree <- ape::read.tree(text = '(a, (b, ((c, d), (e, f))));') + dataset <- TreeTools::StringToPhyDat('-01100', tips = tree) + if (interactive()) { + PlotCharacter(tree, dataset) + } else { + expect_equal(c('-' = FALSE, '0' = TRUE, '1' = FALSE), + PlotCharacter(tree, dataset, plot = FALSE)[9, ]) + } + + tree <- ape::read.tree(text = '(a, (b, (c, (d, (e, f)))));') + dataset <- TreeTools::StringToPhyDat('--0101', tips = tree) + if (interactive()) { + PlotCharacter(tree, dataset) + } else { + expect_equal(cbind('-' = c(1, 1, 0, 0, 0), + '0' = c(0, 0, 1, 1, 1), + '1' = c(0, 0, 1, 1, 1)), + 1 * PlotCharacter(tree, dataset, plot = FALSE)[7:11, ]) + } +}) + +test_that("Out-of-sequence works", { + skip_if_not_installed('vdiffr') + skip_if_not_installed("ape", "5.5.2") # Node colours + vdiffr::expect_doppelganger('PlotChar_out-of-sequence', + function () { + PlotCharacter(ape::read.tree(text = '(a, (b, (c, d)));'), + TreeTools::StringToPhyDat('1342', tips = c('a', 'c', 'd', 'b')) + ) + }) +}) \ No newline at end of file diff --git a/tests/testthat/test-data_manipulation.R b/tests/testthat/test-data_manipulation.R new file mode 100644 index 000000000..fbdcf28f2 --- /dev/null +++ b/tests/testthat/test-data_manipulation.R @@ -0,0 +1,133 @@ +context("data_manipulation.R") + +test_that("Deprecation", { + expect_equal(MinimumLength(1:3), expect_warning(MinimumSteps(1:3))) +}) + +test_that("Minimum step counts are correctly calculated", { + expect_equal(1, MinimumLength(1:3)) + expect_equal(1, MinimumLength(c(1:3, 5))) + expect_equal(0, MinimumLength(c(6, 7, 14))) + expect_equal(1, MinimumLength(0:3)) # 0 representing the inapplicable token + + # ++++, .++., ..++ + expect_equal(0, MinimumLength(c(2046, 384, 1152))) + + # ++++, +..., .++., ..++ + expect_equal(1, MinimumLength(c(15, 8, 6, 3))) + + # ++++++, +....., .++..., .+.+.., ...++. + expect_equal(2, MinimumLength(c(63, 32, 24, 20, 6))) + + dudDat <- TreeTools::StringToPhyDat('----{-,1}22', letters[1:7]) + expect_equal('----<-,1>22', TreeTools::PhyDatToString(dudDat, '>', ',')) + expect_equal(0, attr(PrepareDataIW(dudDat), 'min.length')) + + dudTwo <- TreeTools::StringToPhyDat('{-1}{-2}{-3}2233', letters[1:7]) + expect_equal('{-1}{-2}{-3}2233', TreeTools::PhyDatToString(PrepareDataIW(dudTwo))) + + tr <- ape::read.tree(text='(((a, b), c), (d, (e, ((f, g), (h, (i, (j, k)))))));') + expect_equal(CharacterLength(tr, compress = TRUE, + TreeTools::StringToPhyDat('11---22--33', letters[1:11])), + MinimumLength(c(0, 0, 0, 0, 0, 0, 2, 2, 4, 4, 8, 8))) + + # 04, 14, 24, 34, 05, 16, 27, 38, 9A + # In this case, chosing the most common state (4) means that we have to choose 567&8 too + # 012&3 is a better solution + # We also have to choose one of 9 or A, but it doesn't matter which. + expect_equal(4, MinimumLength(c( + 2^0 + 2^4, + 2^1 + 2^4, + 2^2 + 2^4, + 2^3 + 2^4, + 2^0 + 2^5, + 2^1 + 2^6, + 2^2 + 2^7, + 2^3 + 2^8, + 2^9 + 2^10 + ))) + + data('inapplicable.datasets') + expect_equal(c(1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1, + 1, 2, 1, 1, 4, 3, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 4, 1, + 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), + MinimumLength(inapplicable.phyData[[4]], compress = TRUE)) + +}) + +test_that("PrepareDataProfile() handles empty matrices", { + dat <- TreeTools::MatrixToPhyDat(matrix(c(0, 1, rep('?', 5)), + dimnames = list(letters[1:7], NULL))) + expectation <- dat[0] + attr(expectation, 'info.amounts') <- numeric(0) + expect_equal(expectation, PrepareDataProfile(dat)) +}) + +test_that("PrepareDataProfile()", { + + # Easy one + mtx <- cbind(c('0', '0', 1,1,1,1), + c(0,0,1,1,1,1),# again + c(0,0,0,1,1,'?')) + rownames(mtx) <- letters[seq_len(nrow(mtx))] + phy1 <- TreeTools::MatrixToPhyDat(mtx) + expect_equivalent(phy1, PrepareDataProfile(phy1)) + expect_equal(attributes(phy1), attributes(PrepareDataProfile(phy1))[1:10]) + + # Easy one + mtx <- cbind(c('0', '0', 1,1,1,1), + c(1,1,0,0,0,0),# flipped + c(0,0,0,1,1,'{012}')) + rownames(mtx) <- letters[seq_len(nrow(mtx))] + phy2 <- TreeTools::MatrixToPhyDat(mtx) + expect_equivalent(phy1, PrepareDataProfile(phy2)) + expect_equal(attributes(PrepareDataProfile(phy1)), + attributes(PrepareDataProfile(phy2))) + + + mtx <- cbind(c('0', '0', 1,1,1, '2', '2', 3,3,3,3), + c('?', '?', 1,1,1, '?', '?', 0,0,0,0), + c(0,0,1,1,1,2,2,3,3,3,3),# again + c(rep('?', 5), '2', '2', 0,0,0,0), + c('?', '?', 1,1,1, 1,1, 0,0,0,0), + c('0', '1', rep('?', 9)) + ) + rownames(mtx) <- letters[seq_len(nrow(mtx))] + dataset <- TreeTools::MatrixToPhyDat(mtx) + + q <- '?' + decomposed <- matrix(c(0,0,q,q,q,q,q,1,1,1,1, + q,q,0,0,0,q,q,1,1,1,1, + q,q,q,q,q,0,0,1,1,1,1, + + q,q,0,0,0,q,q,1,1,1,1, + + 0,0,q,q,q,q,q,1,1,1,1, + q,q,0,0,0,q,q,1,1,1,1, + q,q,q,q,q,0,0,1,1,1,1, + + q,q,q,q,q,0,0,1,1,1,1, + q,q,0,0,0,0,0,1,1,1,1), + ncol = 9, dimnames = list(letters[1:11], NULL)) + + + expect_warning(pd <- PrepareDataProfile(dataset)) + expect_equal(decomposed, PhyDatToMatrix(pd)) + expect_equal(c(1, 2, 3, 2, 1, 2, 3, 3, 4), attr(pd, 'index')) + expect_equal(c(2, 3, 3, 1), attr(pd, 'weight')) + + dataset2 <- TreeTools::MatrixToPhyDat(mtx[!mtx[, 1] %in% c(0, 2), ]) + expect_equal(attr(PrepareDataProfile(dataset2), 'info.amounts'), + attr(pd, 'info.amounts')[1:3, 2, drop = FALSE]) + + + data('Lobo', package = "TreeTools") + expect_warning(prep <- PrepareDataProfile(Lobo.phy)) + expect_equal(c(17, attr(prep, 'nr')), + dim(attr(prep, 'info.amounts'))) + + +}) diff --git a/tests/testthat/test-iw-scoring.R b/tests/testthat/test-iw-scoring.R new file mode 100644 index 000000000..d829751ef --- /dev/null +++ b/tests/testthat/test-iw-scoring.R @@ -0,0 +1,78 @@ +test_that("IW Scoring", { + library('TreeTools', quietly = TRUE, warn.conflicts = FALSE) + data('Lobo', package = 'TreeTools') + dataset <- Lobo.phy + + #dataset <- ReadAsPhyDat('c:/research/r/hyoliths/mbank_X24932_6-19-2018_744.nex') + tree <- NJTree(dataset) + + + .IWScore <- function (edge, morphyObjs, weight, minLength, concavity) { + steps <- preorder_morphy_by_char(edge, morphyObjs) + homoplasies <- steps - minLength + fit <- homoplasies / (homoplasies + concavity) + sum(fit * weight) + } + + concavity <- 4.5 + epsilon <- sqrt(.Machine$double.eps) + + + tree <- Preorder(RenumberTips(tree, names(dataset))) + nTip <- NTip(tree) + edge <- tree$edge + + at <- attributes(dataset) + characters <- PhyToString(dataset, ps = '', useIndex = FALSE, + byTaxon = FALSE, concatenate = FALSE) + startWeights <- at$weight + morphyObjects <- lapply(characters, SingleCharMorphy) + on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) + + nLevel <- length(at$level) + nChar <- at$nr + nTip <- length(dataset) + cont <- at$contrast + simpleCont <- ifelse(rowSums(cont) == 1, + apply(cont != 0, 1, function (x) colnames(cont)[x][1]), + '?') + inappLevel <- at$levels == '-' + + if (any(inappLevel)) { + # TODO this is a workaround until MinimumLength can handle {-, 1} + cont[cont[, inappLevel] > 0, ] <- 0 + ambiguousToken <- at$allLevels == '?' + cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 + } + + # Perhaps replace with previous code: + # inappLevel <- which(at$levels == "-") + # cont[, inappLevel] <- 0 + + powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) + tmp <- as.integer(cont %*% powersOf2) + unlisted <- unlist(dataset, use.names = FALSE) + binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) + minLength <- apply(binaryMatrix, 1, MinimumLength) + + tokenMatrix <- matrix(simpleCont[unlisted], nChar, nTip, byrow = FALSE) + charInfo <- apply(tokenMatrix, 1, CharacterInformation) + needsInapp <- rowSums(tokenMatrix == '-') > 2 + inappSlowdown <- 3L # A guess + rawPriority <- charInfo / ifelse(needsInapp, inappSlowdown, 1) + priority <- startWeights * rawPriority + informative <- needsInapp | charInfo > 0 + # Will work from end of sequence to start. + charSeq <- seq_along(charInfo)[informative][order(priority[informative])] - 1L + + + weight <- startWeights + + expect_equal(.IWScore(edge, morphyObjects, weight, minLength, concavity), + morphy_iw(edge, morphyObjects, weight, minLength, charSeq, + concavity, Inf)) + + expect_equal(Inf, morphy_iw(edge, morphyObjects, weight, minLength, charSeq, + concavity, 0)) + +}) \ No newline at end of file diff --git a/tests/testthat/test-mpl_morphy_objects.R b/tests/testthat/test-mpl_morphy_objects.R new file mode 100644 index 000000000..038e6ef62 --- /dev/null +++ b/tests/testthat/test-mpl_morphy_objects.R @@ -0,0 +1,37 @@ +test_that("PhyDat2Morphy() errors", { + expect_error(PhyDat2Morphy(NA)) +}) + +test_that("UnloadMorphy() errors", { + expect_error(UnloadMorphy(NA)) +}) + +test_that("GapHandler()", { + expect_error(GapHandler(0)) + tokens <- matrix(c('-', '-', 0, 0), byrow = TRUE, nrow = 4L, + dimnames = list(letters[1:4], NULL)) + pd <- TreeTools::MatrixToPhyDat(tokens) + + morphyObj <- PhyDat2Morphy(pd) + expect_equal(0, RandomTreeScore(morphyObj)) + expect_equal("Inapplicable", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + morphyObj <- PhyDat2Morphy(pd, 'ambigu') + expect_equal(0, RandomTreeScore(morphyObj)) + expect_equal("Missing data", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + morphyObj <- PhyDat2Morphy(pd, 'eXt') + expect_lt(0, RandomTreeScore(morphyObj)) + expect_equal("Extra state", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + morphyObj <- SingleCharMorphy('-0-0', 'eXt') + expect_lt(0, RandomTreeScore(morphyObj)) + expect_equal("Extra state", GapHandler(morphyObj)) + UnloadMorphy(morphyObj) + + expect_error(SingleCharMorphy('-0-0', 'ERROR')) + expect_error(GapHandler(morphyObj)) +}) diff --git a/tests/testthat/test-pp-fitch.R b/tests/testthat/test-pp-fitch.R new file mode 100644 index 000000000..dec536272 --- /dev/null +++ b/tests/testthat/test-pp-fitch.R @@ -0,0 +1,92 @@ +context("pp_exact") + +# TODO this test was recovered from a stash and requires updating -- +# or may be obselete. +test_that("Profile score correct for small trees", { + library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) + tree <- as.phylo(200, 9) + + mataset <- matrix(c( + 1, 1, 1, 1, 0, 0, 0, 0, 0, # 3 steps + 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps + 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps again [duplicated] + 0, 1, 0, 0, 0, 0, 0, 1, 1, # 1 step + 2, 1, 1, 1, 1, 1, 1, 1, 1),# 1 step; non-informative + nrow = 9, dimnames = list(paste0('t', 1:9), NULL)) + + + dataset <- MatrixToPhyDat(mataset) + + at <- attributes(dataset) + characters <- PhyToString(dataset, ps = '', useIndex = FALSE, + byTaxon = FALSE, concatenate = FALSE) + weight <- at$weight + morphyObjects <- lapply(characters, SingleCharMorphy) + on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) + + nLevel <- length(at$level) + nChar <- at$nr + cont <- at$contrast + simpleCont <- ifelse(rowSums(cont) == 1, + apply(cont != 0, 1, function (x) at$levels[x][1]), + '?') + inappLevel <- at$levels == '-' + + unlisted <- unlist(dataset, use.names = FALSE) + charSeq <- seq_len(nChar) - 1L + + tokenMatrix <- matrix(simpleCont[unlisted], nChar, 9, byrow = FALSE) + profileTables <- apply(tokenMatrix, 1, table) + if (inherits(profileTables, 'matrix')) { + profileTables <- lapply(seq_len(ncol(profileTables)), function (i) profileTables[, i]) + } + data('profiles', package = 'TreeSearch') + profileCost <- lapply(profileTables, function (x) { + x <- sort(x[x > 1]) + n <- length(x) + prof <- switch(n, + 0, + profiles[[sum(x)]][[n]][[x[1] - 1L]] + ) + }) + profileExtra <- lapply(profileCost, function (x) x - x[1]) + fixedCost <- -sum(vapply(profileCost, `[[`, 1, 1) * weight) + maxScore <- sum(Log2Unrooted(vapply(profileTables, sum, 1))) + pad <- function (x, len) { + ret <- double(len) + ret[seq_along(x)] <- x + ret + } + profiles <- vapply(profileExtra, pad, double(4), 4) + + TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, + charSeq, profiles, Inf) + + PP <- function (costs) { + TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, + charSeq, costs, Inf) + } + + + # Use integer-step profile tables + extraSteps <- matrix(1:4, 4, 4) + expect_equal(TreeLength(tree, dataset), PP(costs = extraSteps)) + expect_equal(3 + 2 + 2 + 1 + 1, + TreeLength(tree, dataset)) +}) + + +test_that("Profile score can be calculated from real data", { + data(referenceTree) + data(congreveLamsdellMatrices) + tree <- referenceTree + dataset <- PrepareDataProfile(congreveLamsdellMatrices[[1]]) + expect_equal(TreeLength(tree, dataset), + sum(CharacterLength(tree, dataset, compress = TRUE) * + attr(dataset, 'weight'))) + score <- TreeLength(tree, dataset, 'profile') + + # Check score hasn't materially changed: + # 511.732 is "previous value"; not manually checked. + expect_equal(511.732, score, tolerance = 0.01) +}) diff --git a/tests/testthat/test-pp-info_extra_step.R b/tests/testthat/test-pp-info_extra_step.R new file mode 100644 index 000000000..4a34e6550 --- /dev/null +++ b/tests/testthat/test-pp-info_extra_step.R @@ -0,0 +1,95 @@ +context("pp_info_extra_step.R") +library("TreeSearch", quietly = TRUE) + +test_that("Bad input safely handled", { + expect_equal(0, WithOneExtraStep(1)) + expect_error(WithOneExtraStep(2, 2, 2)) + + expect_equal(0, Carter1(5, 6, 4)) + expect_equal(-Inf, LogCarter1(5, 6, 4)) + expect_equal(-Inf, Log2Carter1(5, 6, 4)) +}) + +test_that("StepInformation() works", { + expect_equal(c(`0` = 0), StepInformation(rep(3L, 10), ambiguousTokens = 3)) + expect_equal(c(`0` = 0), StepInformation(c(4L, rep(3L, 10)), 3)) + expect_true(all(is.finite(StepInformation(rep.int(1:3, times = c(139, 45, 41)), + ambiguousTokens = 3)))) + expect_true(all(is.finite(StepInformation( + char = rep.int(1:2, times = c(600, 600)))))) +}) + +test_that("Carter1() matches profile counts", { + data("profiles", package = "TreeSearch") + Test <- function (a, b) { + n <- sum(a, b) + counted <- 2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]] * NUnrooted(n) + m <- as.integer(names(counted)) + for (mi in m) { + expect_equal(log2(Carter1(mi, a, b)), Log2Carter1(mi, b, a)) + expect_equal(log(Carter1(mi, a, b)), LogCarter1(mi, b, a)) + } + expect_equivalent(counted, + cumsum(vapply(m, Carter1, a = a, b = b, double(1)))) + } + + Test(2, 4) + Test(2, 5) + Test(2, 6) + Test(2, 7) + Test(2, 8) + + Test(3, 4) + Test(3, 5) + Test(3, 6) + Test(3, 7) + + Test(4, 4) + Test(4, 5) + Test(4, 6) + + Test(5, 4) + Test(5, 5) + +}) + +test_that("WithOneExtraStep() input format", { + expect_equal(WithOneExtraStep(7, 5), WithOneExtraStep(c(5, 7))) +}) + +test_that("WithOneExtraStep()", { + library("TreeTools", quietly = TRUE) + data("profiles", package = "TreeSearch") + Test <- function (a, b) { + n <- sum(a, b) + expect_equivalent(2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]][2] * NUnrooted(n), + NUnrootedMult(c(a, b)) + WithOneExtraStep(c(a, b))) + } + + Test(4, 2) + Test(3, 3) + Test(8, 2) + Test(4, 3) + Test(7, 3) + Test(6, 4) + Test(5, 5) + + expect_equal(NUnrooted(6) / NUnrooted(5) * WithOneExtraStep(2:3), + WithOneExtraStep(1:3)) + expect_equal(NUnrooted(10) / NUnrooted(5) * WithOneExtraStep(2:3), + WithOneExtraStep(2:3, rep(1, 5))) +}) + +test_that(".LogCumSumExp()", { + Test <- function (x) { + naive <- log(cumsum(exp(x))) + if (all(is.finite(naive))) { + expect_equal(naive, .LogCumSumExp(x)) + } else { + expect_true(all(is.finite(.LogCumSumExp(x)))) + } + } + Test(log(c(1:5, 5:1))) + Test(c(10, 700, 100)) + Test(c(10, 7000, 100)) +}) \ No newline at end of file diff --git a/tests/testthat/test-pp-random-tree.R b/tests/testthat/test-pp-random-tree.R new file mode 100644 index 000000000..38f4cbbd7 --- /dev/null +++ b/tests/testthat/test-pp-random-tree.R @@ -0,0 +1,141 @@ +# NB: RandomTreeScore uses C's RNG, so no point in setting seed. +MorphyAction <- function (Action) expect_equal("ERR_NO_ERROR", mpl_translate_error(Action)) +MorphyWith <- function (char) { + nTip <- nchar(char) - 1L + morphyObj <- mpl_new_Morphy() + MorphyAction(mpl_init_Morphy(nTip, 1, morphyObj)) + MorphyAction(mpl_attach_rawdata(char, morphyObj)) + MorphyAction(mpl_set_num_internal_nodes(nTip - 1L, morphyObj)) + MorphyAction(mpl_set_parsim_t(1, 'FITCH', morphyObj)) + MorphyAction(mpl_set_charac_weight(1, 1, morphyObj)) + MorphyAction(mpl_apply_tipdata(morphyObj)) + class(morphyObj) <- 'morphyPtr' + morphyObj +} + + +context("pp: Tree randomness") +test_that("four-tip trees are randomly distributed", { + nTrees <- 36000 + stringency <- 0.005 # low numbers mean you'll rarely fail by chance + nTip <- 4 + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, 1/(nTip - 1)) + rTrees <- vapply(logical(nTrees), function (XX) + unlist(RandomMorphyTree(nTip)), integer((nTip * 4) - 3)) + expect_true(all(rTrees[1 + (seq_len(nTip - 1)), ] %in% nTip + seq_len(nTip - 2))) + expect_lt(expectedBounds[1], sum(rTrees[2, ] == 5)) + expect_gt(expectedBounds[2], sum(rTrees[2, ] == 5)) + expect_lt(expectedBounds[1], sum(rTrees[3, ] == 5)) + expect_gt(expectedBounds[2], sum(rTrees[3, ] == 5)) + expect_lt(expectedBounds[1], sum(rTrees[4, ] == 5)) + expect_gt(expectedBounds[2], sum(rTrees[4, ] == 5)) + + expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] > expectedBounds[1])) + expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] < expectedBounds[2])) + + expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] < nTrees - expectedBounds[1])) + expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] > nTrees - expectedBounds[2])) +}) + +test_that("four-tip trees are randomly scored", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + nTrees <- 6000 + stringency <- 0.005 + nTip <- 4 + + morphyObj <- MorphyWith('0011;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + + expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, + NUnrooted(nTip - 1L) / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + expect_lt(expectedBounds[1], sum(scores==1)) + expect_gt(expectedBounds[2], sum(scores==1)) +}) + +test_that("five-tip trees are randomly scored", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + nTrees <- 6000 + stringency <- 0.005 + nTip <- 5 + morphyObj <- MorphyWith('00011;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, + NUnrooted(nTip - 1) / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + expect_equal(2L, max(scores)) + expect_lt(expectedBounds[1], sum(scores == 1)) + expect_gt(expectedBounds[2], sum(scores == 1)) +}) + + +test_that("six-tip trees are randomly scored", { + suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 + set.seed(0) + + nTrees <- 6000 + stringency <- 0.005 + nTip <- 6 + + morphyObj <- MorphyWith('000011;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, + NUnrooted(5) / NUnrooted(6)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + morphyObj <- UnloadMorphy(morphyObj) + + expect_true(max(scores) == 2) + expect_lt(expectedBounds[1], sum(scores==1)) + expect_gt(expectedBounds[2], sum(scores==1)) + + morphyObj <- MorphyWith('001122;') + expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, + 7 / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), + integer(1)) + morphyObj <- UnloadMorphy(morphyObj) + + expect_true(all(scores %in% 2:4)) + expect_lt(expectedBounds[1], sum(scores == 2)) + expect_gt(expectedBounds[2], sum(scores == 2)) + + morphyObj <- MorphyWith('000111;') + expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, + 3 * 3 / NUnrooted(nTip)) + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), integer(1)) + # unloaded on exit; don't unload twice || morphyObj <- UnloadMorphy(morphyObj) + + expect_true(max(scores) == 3) + expect_lt(expectedBounds[1], sum(scores == 1)) + expect_gt(expectedBounds[2], sum(scores == 1)) + +}) + +test_that("twelve-tip trees are randomly scored", { + nTrees <- 12000 # 12000 seems to throw false +ve too often? + stringency <- 0.01 # increased from 0.005 to avoid false +ves + nTip <- 12 + morphyObj <- MorphyWith('000000011111;') + on.exit(morphyObj <- UnloadMorphy(morphyObj)) + expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, + NUnrooted(7) * (2 * 7 - 3) * + NUnrooted(5) * (2 * 5 - 3) / NUnrooted(nTip)) + + scores <- vapply(logical(nTrees), + function (XX) RandomTreeScore(morphyObj), + integer(1L)) + # table(scores) + + expect_equal(5L, max(scores)) + nScoring1 <- sum(scores == 1) + expect_lt(expectedBounds[1], nScoring1) + expect_gt(expectedBounds[2], nScoring1) +}) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index 129c51337..d7b647f86 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -168,4 +168,5 @@ if (FALSE) test_that("SPR works", { Test(14, 3, 11) Test(15, 3, 12) + }) \ No newline at end of file From ea12be218e17c40f2f2267fe66d56926b072bd85 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 15:45:13 +0100 Subject: [PATCH 17/28] With Grace --- tests/testthat/test-rearrange.cpp.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index d7b647f86..06bb1612b 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -19,6 +19,7 @@ test_that("SPR errors", { }) test_that("TBR working", { + skip_if(TRUE) tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) # Move single tip @@ -63,9 +64,13 @@ test_that("TBR working", { }) test_that("SPR fails gracefully", { + dput("SPR Grace 1") expect_error(all_spr(as.phylo(1, 3)$edge, integer(0))) + dput("SPR Grace 2") expect_error(all_spr(Postorder(as.phylo(1, 6))$edge, integer(0))) + dput("SPR Grace 3") expect_error(all_spr(SortTree(as.phylo(1, 6))$edge, integer(0))) + dput("SPR Grace Completed.") }) test_that("SPR works", { From 75f910be82cee35147a54e4fac03914fc5c14406 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 15:58:26 +0100 Subject: [PATCH 18/28] Only by grace? --- src/rearrange.cpp | 1 + tests/testthat/test-rearrange.cpp.R | 4 +--- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/rearrange.cpp b/src/rearrange.cpp index c43d052af..10cf7472a 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -341,6 +341,7 @@ List all_spr (const IntegerMatrix edge, if (edge(1, 0) != root_node) { Rf_error("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); } + Rcout << "\n\nall_spr Continuing;\n\n"; IntegerVector break_seq; if (break_order.length()) { diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index 06bb1612b..fc25af9d5 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -8,12 +8,9 @@ test_that("TBR errors", { }) test_that("SPR errors", { - dput("SPR ERRorS") tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) expect_equal(0, length(expect_warning(all_spr(tr$edge, -1)))) - dput("SPR ERRor 1") expect_equal(0, length(expect_warning(all_spr(tr$edge, 1)))) - dput("SPR ERRor 2") expect_equal(0, length(expect_warning(all_spr(tr$edge, 111)))) dput("SPR ERRor 3 - Completed.") }) @@ -64,6 +61,7 @@ test_that("TBR working", { }) test_that("SPR fails gracefully", { + #skip_if(TRUE) dput("SPR Grace 1") expect_error(all_spr(as.phylo(1, 3)$edge, integer(0))) dput("SPR Grace 2") From d4d352f4f3275c4001f6c9914917682e765fccec Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Thu, 23 Sep 2021 16:09:57 +0100 Subject: [PATCH 19/28] Only by grace? --- tests/testthat/test-rearrange.cpp.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index fc25af9d5..a8c4a760d 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -61,7 +61,7 @@ test_that("TBR working", { }) test_that("SPR fails gracefully", { - #skip_if(TRUE) + skip_if(TRUE) dput("SPR Grace 1") expect_error(all_spr(as.phylo(1, 3)$edge, integer(0))) dput("SPR Grace 2") From 295ca30e93ccb68546b3bcd0ac66863411f783b1 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 09:05:49 +0100 Subject: [PATCH 20/28] MRE --- R/RcppExports.R | 4 + src/RcppExports.cpp | 11 + src/rearrange.cpp | 6 + .../_snaps/Jackknife/plot-jackknife.svg | 73 ----- .../PlotCharacter/plotchar-000011110000.svg | 120 -------- .../PlotCharacter/plotchar-000011qqqq00.svg | 120 -------- .../PlotCharacter/plotchar-011iiqii0011.svg | 120 -------- .../PlotCharacter/plotchar-01iii1010101.svg | 120 -------- .../PlotCharacter/plotchar-01iiii010101.svg | 120 -------- .../PlotCharacter/plotchar-01iiiiii0101.svg | 120 -------- .../PlotCharacter/plotchar-023iiqq1ii32.svg | 120 -------- .../PlotCharacter/plotchar-023iqqq1ii32.svg | 120 -------- .../PlotCharacter/plotchar-10101iiiii01.svg | 120 -------- .../PlotCharacter/plotchar-10iiii11iii1.svg | 120 -------- .../PlotCharacter/plotchar-1100iiii1100.svg | 120 -------- .../PlotCharacter/plotchar-110iiqiii100.svg | 120 -------- .../PlotCharacter/plotchar-110iiqqii100.svg | 120 -------- .../PlotCharacter/plotchar-11ii1000001i.svg | 120 -------- .../PlotCharacter/plotchar-11ii1qqii111.svg | 120 -------- .../PlotCharacter/plotchar-11iiii111111.svg | 120 -------- .../PlotCharacter/plotchar-11iiiiiii100.svg | 120 -------- .../PlotCharacter/plotchar-11iiqqqqii11.svg | 120 -------- .../plotchar-1234d45baacgttt.svg | 120 -------- .../PlotCharacter/plotchar-1iii1111iii1.svg | 120 -------- .../PlotCharacter/plotchar-1iiii1iiii1i.svg | 120 -------- .../PlotCharacter/plotchar-1qqiiqqii100.svg | 120 -------- .../PlotCharacter/plotchar-210210iiiiii.svg | 120 -------- .../PlotCharacter/plotchar-210ii100ii21.svg | 120 -------- .../PlotCharacter/plotchar-21ii1iiii012.svg | 120 -------- .../PlotCharacter/plotchar-21ii3qqii032.svg | 120 -------- .../PlotCharacter/plotchar-230iiqq1ii32.svg | 120 -------- .../PlotCharacter/plotchar-23ii1iiii032.svg | 120 -------- .../PlotCharacter/plotchar-23ii1q1ii023.svg | 120 -------- .../plotchar-23ii1qqdi0bid01b32.svg | 120 -------- .../PlotCharacter/plotchar-23ii1qqii032.svg | 120 -------- .../PlotCharacter/plotchar-23qq1qqqq032.svg | 120 -------- .../PlotCharacter/plotchar-320iiqq3ii21.svg | 120 -------- .../PlotCharacter/plotchar-i1i1i1ii1i1i.svg | 120 -------- .../PlotCharacter/plotchar-iiii1010iiii.svg | 120 -------- .../PlotCharacter/plotchar-iiii1111iii1.svg | 120 -------- .../PlotCharacter/plotchar-iiii1111iiii.svg | 120 -------- .../PlotCharacter/plotchar-iiiiii11iii1.svg | 120 -------- .../PlotCharacter/plotchar-iiiiiiii0101.svg | 120 -------- .../PlotCharacter/plotchar-iiiiiiiiiiii.svg | 120 -------- .../PlotCharacter/plotchar-iiiiiiiqqqqq.svg | 120 -------- .../plotchar-out-of-sequence.svg | 56 ---- .../PlotCharacter/plotchar-qqqqiiii1qqq.svg | 120 -------- .../PlotCharacter/plotchar-qqqqqqqqqqqq.svg | 120 -------- tests/testthat/test-AdditionTree.R | 48 ---- tests/testthat/test-Concordance.R | 121 -------- tests/testthat/test-CustomSearch.R | 133 --------- tests/testthat/test-Jackknife.R | 46 --- tests/testthat/test-MaximizeParsimony.R | 139 --------- tests/testthat/test-NNI.R | 25 -- tests/testthat/test-PlotCharacter.R | 125 -------- tests/testthat/test-RMorphy.R | 25 -- tests/testthat/test-RandomTreeScore.R | 45 --- tests/testthat/test-TreeSearch_utilities.R | 6 - tests/testthat/test-data_manipulation.R | 133 --------- tests/testthat/test-iw-scoring.R | 78 ----- tests/testthat/test-mpl_morphy_objects.R | 37 --- tests/testthat/test-pp-fitch.R | 92 ------ tests/testthat/test-pp-info_extra_step.R | 95 ------ tests/testthat/test-pp-random-tree.R | 141 --------- tests/testthat/test-rearrange.cpp.R | 174 +---------- tests/testthat/test-tree_length.R | 270 ------------------ tests/testthat/test-zzz-tree-rearrange.R | 270 ------------------ 67 files changed, 22 insertions(+), 7291 deletions(-) delete mode 100644 tests/testthat/_snaps/Jackknife/plot-jackknife.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-000011110000.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-000011qqqq00.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-011iiqii0011.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-01iii1010101.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-01iiii010101.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-01iiiiii0101.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-023iiqq1ii32.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-023iqqq1ii32.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-10101iiiii01.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-10iiii11iii1.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-1100iiii1100.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-110iiqiii100.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-110iiqqii100.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-11ii1000001i.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-11ii1qqii111.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-11iiii111111.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-11iiiiiii100.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-11iiqqqqii11.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-1234d45baacgttt.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-1iii1111iii1.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-1iiii1iiii1i.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-1qqiiqqii100.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-210210iiiiii.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-210ii100ii21.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-21ii1iiii012.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-21ii3qqii032.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-230iiqq1ii32.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-23ii1iiii032.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-23ii1q1ii023.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqdi0bid01b32.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqii032.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-23qq1qqqq032.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-320iiqq3ii21.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-i1i1i1ii1i1i.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-iiii1010iiii.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iii1.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iiii.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-iiiiii11iii1.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiii0101.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiiiiii.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiqqqqq.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-out-of-sequence.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-qqqqiiii1qqq.svg delete mode 100644 tests/testthat/_snaps/PlotCharacter/plotchar-qqqqqqqqqqqq.svg delete mode 100644 tests/testthat/test-AdditionTree.R delete mode 100644 tests/testthat/test-Concordance.R delete mode 100644 tests/testthat/test-CustomSearch.R delete mode 100644 tests/testthat/test-Jackknife.R delete mode 100644 tests/testthat/test-MaximizeParsimony.R delete mode 100644 tests/testthat/test-NNI.R delete mode 100644 tests/testthat/test-PlotCharacter.R delete mode 100644 tests/testthat/test-RMorphy.R delete mode 100644 tests/testthat/test-RandomTreeScore.R delete mode 100644 tests/testthat/test-TreeSearch_utilities.R delete mode 100644 tests/testthat/test-data_manipulation.R delete mode 100644 tests/testthat/test-iw-scoring.R delete mode 100644 tests/testthat/test-mpl_morphy_objects.R delete mode 100644 tests/testthat/test-pp-fitch.R delete mode 100644 tests/testthat/test-pp-info_extra_step.R delete mode 100644 tests/testthat/test-pp-random-tree.R delete mode 100644 tests/testthat/test-tree_length.R delete mode 100644 tests/testthat/test-zzz-tree-rearrange.R diff --git a/R/RcppExports.R b/R/RcppExports.R index 33cb4a90f..e02c37edd 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -33,6 +33,10 @@ tbr <- function(edge, move) { .Call(`_TreeSearch_tbr`, edge, move) } +asan_error <- function(x) { + .Call(`_TreeSearch_asan_error`, x) +} + all_spr <- function(edge, break_order) { .Call(`_TreeSearch_all_spr`, edge, break_order) } diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index bbb5c9868..e50fd2323 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -115,6 +115,17 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// asan_error +List asan_error(const IntegerMatrix x); +RcppExport SEXP _TreeSearch_asan_error(SEXP xSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const IntegerMatrix >::type x(xSEXP); + rcpp_result_gen = Rcpp::wrap(asan_error(x)); + return rcpp_result_gen; +END_RCPP +} // all_spr List all_spr(const IntegerMatrix edge, const IntegerVector break_order); RcppExport SEXP _TreeSearch_all_spr(SEXP edgeSEXP, SEXP break_orderSEXP) { diff --git a/src/rearrange.cpp b/src/rearrange.cpp index 10cf7472a..321c712c4 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -319,6 +319,12 @@ inline IntegerMatrix fuse(const IntegerMatrix& tree_bits, } + +// [[Rcpp::export]] +List asan_error (const IntegerMatrix x) { + Rf_error("Oh dear."); +} + // Assumptions: // * Tree is bifurcating, in preorder; first two edges have root as parent. // [[Rcpp::export]] diff --git a/tests/testthat/_snaps/Jackknife/plot-jackknife.svg b/tests/testthat/_snaps/Jackknife/plot-jackknife.svg deleted file mode 100644 index 381c69744..000000000 --- a/tests/testthat/_snaps/Jackknife/plot-jackknife.svg +++ /dev/null @@ -1,73 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -t1 -t2 -t3 -t4 -t5 -t6 -t7 -t8 - - - 0.08 - - - 0.13 - - - 0.14 - - - 1 - - - 1 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-000011110000.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-000011110000.svg deleted file mode 100644 index c5df5ddd8..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-000011110000.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -0 -0 -0 -1 -1 -1 -1 -0 -0 -0 -0 -1 -1 -1 -0 -0 -0 -1 -1 -0 -0 -0 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-000011qqqq00.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-000011qqqq00.svg deleted file mode 100644 index ffc81b548..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-000011qqqq00.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -0 -0 -0 -1 -1 -? -? -? -? -0 -0 -? -? -? -0 -0 -0 -? -? -? -? -0 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-011iiqii0011.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-011iiqii0011.svg deleted file mode 100644 index 272ec3955..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-011iiqii0011.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -1 -1 -- -- -? -- -- -0 -0 -1 -1 -- -- -- -- -1 -1 -- -- -0 -0 -1 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-01iii1010101.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-01iii1010101.svg deleted file mode 100644 index bf1915ed4..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-01iii1010101.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -1 -- -- -- -1 -0 -1 -0 -1 -0 -1 -1 -1 -- -- -- -? -1 -1 -1 -1 -1 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-01iiii010101.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-01iiii010101.svg deleted file mode 100644 index b2ca1e8c6..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-01iiii010101.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -1 -- -- -- -- -0 -1 -0 -1 -0 -1 -? -- -- -- -- -? -? -? -? -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-01iiiiii0101.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-01iiiiii0101.svg deleted file mode 100644 index d1ebdd57d..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-01iiiiii0101.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -1 -- -- -- -- -- -- -0 -1 -0 -1 -- -- -- -- -- -? -- -- -? -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-023iiqq1ii32.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-023iiqq1ii32.svg deleted file mode 100644 index e040e6c60..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-023iiqq1ii32.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -2 -3 -- -- -? -? -1 -- -- -3 -2 -- -- -- -- -023 -023 -- -- -- -- -23 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-023iqqq1ii32.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-023iqqq1ii32.svg deleted file mode 100644 index 454ba3621..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-023iqqq1ii32.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -0 -2 -3 -- -? -? -? -1 -- -- -3 -2 -23 -23 -23 -23 -23 -023 -23 -23 -23 -23 -23 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-10101iiiii01.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-10101iiiii01.svg deleted file mode 100644 index 378d58cc8..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-10101iiiii01.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -0 -1 -0 -1 -- -- -- -- -- -0 -1 -- -- -1 -1 -1 -1 -- -- -- -- -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-10iiii11iii1.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-10iiii11iii1.svg deleted file mode 100644 index 7d354f092..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-10iiii11iii1.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -0 -- -- -- -- -1 -1 -- -- -- -1 -1 -- -- -- -- -? -1 -1 -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-1100iiii1100.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-1100iiii1100.svg deleted file mode 100644 index bea691179..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-1100iiii1100.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -0 -0 -- -- -- -- -1 -1 -0 -0 -- -- -- -0 -0 -1 -- -- -1 -1 -0 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-110iiqiii100.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-110iiqiii100.svg deleted file mode 100644 index 3ca823c5c..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-110iiqiii100.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -0 -- -- -? -- -- -- -1 -0 -0 -- -- -- -- -? -1 -- -- -- -? -0 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-110iiqqii100.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-110iiqqii100.svg deleted file mode 100644 index 22a905def..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-110iiqqii100.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -0 -- -- -? -? -- -- -1 -0 -0 -- -- -- -- -? -1 -- -- -- -? -0 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-11ii1000001i.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-11ii1000001i.svg deleted file mode 100644 index 145dbaa14..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-11ii1000001i.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -- -- -1 -0 -0 -0 -0 -0 -1 -- -0 -0 -1 -1 -1 -1 -0 -0 -0 -0 -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-11ii1qqii111.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-11ii1qqii111.svg deleted file mode 100644 index 6f6a408ff..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-11ii1qqii111.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -- -- -1 -? -? -- -- -1 -1 -1 -- -- -- -- -- -1 -- -- -- -1 -1 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-11iiii111111.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-11iiii111111.svg deleted file mode 100644 index 8f1d5a227..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-11iiii111111.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -- -- -- -- -1 -1 -1 -1 -1 -1 -1 -- -- -- -- -1 -1 -1 -1 -1 -1 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-11iiiiiii100.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-11iiiiiii100.svg deleted file mode 100644 index 359ddcfad..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-11iiiiiii100.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -- -- -- -- -- -- -- -1 -0 -0 -- -- -- -- -- -1 -- -- -- -? -0 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-11iiqqqqii11.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-11iiqqqqii11.svg deleted file mode 100644 index 1aadf2145..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-11iiqqqqii11.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -1 -- -- -? -? -? -? -- -- -1 -1 -- -- -- -- -- -1 -- -- -- -- -1 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-1234d45baacgttt.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-1234d45baacgttt.svg deleted file mode 100644 index 9fc21085f..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-1234d45baacgttt.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -2 -3 -4 -45 -A -A -C -G -T -T -T -A -A -4 -4 -1234 -1234 -A -ACGT -ACGT -T -T - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-1iii1111iii1.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-1iii1111iii1.svg deleted file mode 100644 index e941a3576..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-1iii1111iii1.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -- -- -- -1 -1 -1 -1 -- -- -- -1 -1 -1 -1 -- -- -- -1 -1 -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-1iiii1iiii1i.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-1iiii1iiii1i.svg deleted file mode 100644 index 774547591..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-1iiii1iiii1i.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -- -- -- -- -1 -- -- -- -- -1 -- -- -- -- -- -- -- -- -- -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-1qqiiqqii100.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-1qqiiqqii100.svg deleted file mode 100644 index 8c96259a7..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-1qqiiqqii100.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -1 -? -? -- -- -? -? -- -- -1 -0 -0 -- -- -- -- -1 -1 -- -- -- -? -0 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-210210iiiiii.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-210210iiiiii.svg deleted file mode 100644 index a583e4a05..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-210210iiiiii.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -1 -0 -2 -1 -0 -- -- -- -- -- -- -? -? -? -? -? -? -- -- -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-210ii100ii21.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-210ii100ii21.svg deleted file mode 100644 index f643582df..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-210ii100ii21.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -1 -0 -- -- -1 -0 -0 -- -- -2 -1 -01 -01 -01 -01 -01 -? -01 -01 -? -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-21ii1iiii012.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-21ii1iiii012.svg deleted file mode 100644 index f571193e7..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-21ii1iiii012.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -1 -- -- -1 -- -- -- -- -0 -1 -2 -- -- -- -- -- -12 -- -- -- -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-21ii3qqii032.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-21ii3qqii032.svg deleted file mode 100644 index fe1611e30..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-21ii3qqii032.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -1 -- -- -3 -? -? -- -- -0 -3 -2 -- -- -- -- -- -12 -- -- -- -023 -023 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-230iiqq1ii32.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-230iiqq1ii32.svg deleted file mode 100644 index 592405fc4..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-230iiqq1ii32.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -3 -0 -- -- -? -? -1 -- -- -3 -2 -- -- -- -- -023 -023 -- -- -- -- -23 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1iiii032.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1iiii032.svg deleted file mode 100644 index bc8cb552d..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1iiii032.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -3 -- -- -1 -- -- -- -- -0 -3 -2 -- -- -- -- -- -23 -- -- -- -023 -023 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1q1ii023.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1q1ii023.svg deleted file mode 100644 index f4d9d02c1..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1q1ii023.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -3 -- -- -1 -? -1 -- -- -0 -2 -3 -123 -123 -123 -123 -123 -123 -123 -? -? -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqdi0bid01b32.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqdi0bid01b32.svg deleted file mode 100644 index 1f19605e6..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqdi0bid01b32.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -3 -- -- -1 -? -? --0 -- -01 -3 -2 -? -? -? -? -? -? -? -? -? -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqii032.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqii032.svg deleted file mode 100644 index 827721605..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-23ii1qqii032.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -3 -- -- -1 -? -? -- -- -0 -3 -2 -- -- -- -- -- -23 -- -- -- -023 -023 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-23qq1qqqq032.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-23qq1qqqq032.svg deleted file mode 100644 index 6d956c051..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-23qq1qqqq032.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -2 -3 -? -? -1 -? -? -? -? -0 -3 -2 -23 -23 -23 -23 -23 -23 -23 -23 -23 -23 -23 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-320iiqq3ii21.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-320iiqq3ii21.svg deleted file mode 100644 index af1ff55cf..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-320iiqq3ii21.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -3 -2 -0 -- -- -? -? -3 -- -- -2 -1 -- -- -- -- -023 -023 -- -- -- -- -12 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-i1i1i1ii1i1i.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-i1i1i1ii1i1i.svg deleted file mode 100644 index 8cb8b8b0b..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-i1i1i1ii1i1i.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -1 -- -1 -- -1 -- -- -1 -- -1 -- -- -- -- -- -- -- -- -- -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1010iiii.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1010iiii.svg deleted file mode 100644 index fbdb92bb5..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1010iiii.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- -1 -0 -1 -0 -- -- -- -- -? -? -? -- -- -- -? -? -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iii1.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iii1.svg deleted file mode 100644 index 2ea98d245..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iii1.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- -1 -1 -1 -1 -- -- -- -1 -1 -1 -1 -- -- -- -1 -1 -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iiii.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iiii.svg deleted file mode 100644 index 77be77dfc..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-iiii1111iiii.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- -1 -1 -1 -1 -- -- -- -- -1 -1 -1 -- -- -- -1 -1 -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiii11iii1.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiii11iii1.svg deleted file mode 100644 index 5bfbde6aa..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiii11iii1.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- -- -- -1 -1 -- -- -- -1 -1 -- -- -- -- -- -1 -1 -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiii0101.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiii0101.svg deleted file mode 100644 index 4d4719501..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiii0101.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- -- -- -- -- -0 -1 -0 -1 -- -- -- -- -- -- -- -- -? -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiiiiii.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiiiiii.svg deleted file mode 100644 index 51dac620b..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiiiiii.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiqqqqq.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiqqqqq.svg deleted file mode 100644 index 51dac620b..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-iiiiiiiqqqqq.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-out-of-sequence.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-out-of-sequence.svg deleted file mode 100644 index 255819200..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-out-of-sequence.svg +++ /dev/null @@ -1,56 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d - - - - - - - -1 -2 -3 -4 -? -? -? - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-qqqqiiii1qqq.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-qqqqiiii1qqq.svg deleted file mode 100644 index 5d86ead7d..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-qqqqiiii1qqq.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -? -? -? -? -- -- -- -- -1 -? -? -? -- -- -- -- -- -- -- -- -1 -1 -1 - - diff --git a/tests/testthat/_snaps/PlotCharacter/plotchar-qqqqqqqqqqqq.svg b/tests/testthat/_snaps/PlotCharacter/plotchar-qqqqqqqqqqqq.svg deleted file mode 100644 index 54344772d..000000000 --- a/tests/testthat/_snaps/PlotCharacter/plotchar-qqqqqqqqqqqq.svg +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -a -b -c -d -e -f -g -h -i -j -k -l - - - - - - - - - - - - - - - - - - - - - - - -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? -? - - diff --git a/tests/testthat/test-AdditionTree.R b/tests/testthat/test-AdditionTree.R deleted file mode 100644 index d08724c26..000000000 --- a/tests/testthat/test-AdditionTree.R +++ /dev/null @@ -1,48 +0,0 @@ -test_that("Addition tree is more parsimonious", { - data('Lobo', package = 'TreeTools') - L10 <- Lobo.phy[1:10] - seq10 <- names(L10) - Score <- function (tr, k) TreeLength(tr, Lobo.phy, concavity = k) - - set.seed(1) # ensure consistent addition sequence - eq <- AdditionTree(Lobo.phy) - kx <- AdditionTree(L10, sequence = seq10, concavity = 10) - pr <- AdditionTree(L10, sequence = 1:10, concavity = 'pr') - nj <- TreeTools::NJTree(Lobo.phy) - nj10 <- TreeTools::KeepTip(nj, 1:10) - - expect_lt(TreeLength(eq, Lobo.phy), TreeLength(nj, Lobo.phy)) - expect_lt(Score(kx, 10), Score(nj10, 10)) - expect_lt(Score(pr, 'pr'), Score(nj10, 'pr')) -}) - -test_that("Addition tree obeys constraints", { - dataset <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 1, - 0, 1, 1, 0, 0, 1), ncol = 2, - dimnames = list(letters[1:6], NULL))) - constraint <- MatrixToPhyDat(c(a = 0, b = 0, c = 0, d = 0, e = 1, f = 1)) - expect_true(as.Splits(c(F, F, F, F, T, T), letters[1:6]) %in% - as.Splits(AdditionTree(dataset, constraint = constraint), - letters[1:6])) - - cdef <- letters[3:6] - subtree <- TreeTools::KeepTip( - AdditionTree(dataset, constraint = constraint[3:6], seq = letters[1:6]), - cdef) - expect_equal(ape::read.tree(text = '(c, d, (e, f));'), - TreeTools::UnrootTree(subtree)) -}) - -test_that("AdditionTree() handles edge cases", { - library('TreeTools') - dataset <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 1, - 0, 1, 1, 0, 0, 1), ncol = 2, - dimnames = list(letters[1:6], NULL))) - expect_equal(PectinateTree(letters[1:3]), AdditionTree(dataset[1:3])) - expect_equal(UnrootTree(PectinateTree(c('a', 'd', 'b', 'c'))), - UnrootTree(AdditionTree(dataset[1:4], conc = 'pr'))) - # All trees have equal score - expect_equal(5, NTip(AdditionTree(dataset[-4]))) -}) \ No newline at end of file diff --git a/tests/testthat/test-Concordance.R b/tests/testthat/test-Concordance.R deleted file mode 100644 index 1a8168c68..000000000 --- a/tests/testthat/test-Concordance.R +++ /dev/null @@ -1,121 +0,0 @@ -library("TreeTools", quietly = TRUE) - -test_that("QuartetConcordance() works", { - tree <- BalancedTree(8) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, 0, 0, 1, 1, 1, 1, 0, - 0, 1, 0, 1, 0, 1, 0, 1, 0, - 0, 0, 0, 1, 0, 1, 1, 1, 0, - 0, 0, 0, 0, 1, 1, 2, 2, 0, - 0, 0, 1, 1, 2, 2, 3, 3, 0, - 0, 1, 2, 3, 0, 1, 2, 3, 0), 9, - dimnames = list(paste0('t', 1:9), NULL)) - dat <- MatrixToPhyDat(mataset) - expect_equal(unname(QuartetConcordance(tree, dat[, 1])), rep(1, 5)) - # plot(tree); nodelabels(); - expect_equal(QuartetConcordance(tree, dat[, 2]), - c('11' = 0, '12' = 0, '13' = 1/9, '14' = 0, '15' = 0)) - - allQuartets <- combn(8, 4) - for (charI in seq_len(ncol(mataset))) { - qc <- QuartetConcordance(tree, dat[, charI]) - for (splitI in seq_along(splits)) { - split <- splits[[splitI]] - logiSplit <- as.logical(split) - case <- apply(allQuartets, 2, function (q) { - qSplit <- logiSplit[q] - qChar <- mataset[q, charI] - if (identical(unique(table(qSplit)), 2L) && - identical(unique(table(qChar)), 2L)) { - tbl <- table(qSplit, qChar) - tab <- paste0(sort(tbl[tbl > 0]), collapse = '') - switch(tab, - '1111' = FALSE, - '112' = NA, - '13' = NA, - '22' = TRUE, - "4" = NA, - stop(q, ": ", tab) - ) - } else { - NA - } - }) - expect_equal(sum(case, na.rm = TRUE) / sum(!is.na(case)), - unname(qc[as.character(names(split))])) - } - } - - expect_equal(QuartetConcordance(tree, dat[, c(1:4, 6)]), - c('11' = ( 6 + 0 + 6 + 2) / ( 6 + 9 + 6 + 2 + 1), - '12' = ( 6 + 0 + 0 + 2) / ( 6 + 9 + 9 + 2 + 1), - '13' = (36 + 2 + 9 + 12) / (36 + 18 + 18 + 12 + 6), - '14' = ( 6 + 0 + 0 + 7) / ( 6 + 9 + 9 + 7 + 1), - '15' = ( 6 + 0 + 6 + 7) / ( 6 + 9 + 6 + 7 + 1)) - ) -}) - -test_that("QuartetConcordance() handles ambiguity", { - tree <- BalancedTree(12) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, '{01}', 0, 0, '{01}', 1, 1, '-', 1, 1, '-', - 0, 1, '?', 0, 1, '?', 0, 1, '(01)', 0, 1, '(01)', - 0, 0, '?', 0, 1, '(12)', 0, 1, '(12)', 1, 1, '(12)', - 0, 0, '?', 0, 0, '?', 1, 1, '?', 2, 2, '?', - 0, 0, '?', 0, 0, '?', 0, 0, '-', 0, 0, '-', - rep('?', 12), - 0, 1, '?', 2, 3, '?', 0, 1, '-', 2, 3, '-'), 12, - dimnames = list(paste0('t', 1:12), NULL)) - dat <- MatrixToPhyDat(mataset) - - expect_equal(unname(QuartetConcordance(tree, dat)[c('16', '18', '19', '21', '23')]), - unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) - expect_equal(unname(QuartetConcordance(tree, dat)[c('15', '17', '19', '20', '22')]), - unname(QuartetConcordance(DropTip(tree, paste0('t', 3 * 1:4)), dat))) -}) - -test_that("QuartetConcordance() handles incomplete data", { - tree <- BalancedTree(8) - splits <- as.Splits(tree) - mataset <- matrix(c(0, 0, 0, 0, 0, 0, 0, 1, - rep('?', 8)), 8, - dimnames = list(paste0('t', 1:8), NULL)) - dat <- MatrixToPhyDat(mataset) - - expect_equal(unname(QuartetConcordance(tree, dat)), rep(NA_real_, 5)) -}) - -dataset <- congreveLamsdellMatrices[[10]][, 1] -tree <- TreeTools::NJTree(dataset) - -ConcordantInformation(tree, dataset)['noise'] -TreeLength(tree, dataset, concavity = 'prof') - -test_that("ConcordantInformation() works", { - data(congreveLamsdellMatrices) - dat <- congreveLamsdellMatrices[[10]] - tree <- TreeTools::NJTree(dat) - - ci <- ConcordantInformation(tree, dat) - expect_equal(expect_warning(Evaluate(tree, dat)), ci) - expect_equal(TreeLength(tree, dat, concavity = 'prof'), - unname(ci['noise'])) - expect_equal(Log2Unrooted(22), unname(ci['treeInformation'])) - expect_equal(sum(apply(PhyDatToMatrix(dat), 2, CharacterInformation)), - unname(ci['informationContent'])) - - dataset <- MatrixToPhyDat(cbind(setNames(c(rep(1, 11), 2:5), paste0('t', 1:15)))) - tree <- TreeTools::PectinateTree(length(dataset)) - expect_error(ConcordantInformation(tree, dataset)) - # expect_equal(0, unname(ci['signal'])) - # expect_equal(0, unname(ci['noise'])) - - dataset <- MatrixToPhyDat(c(a = 1, b = 2, c = 1, d = 2, e = 3, f = 3)) - tree <- TreeTools::PectinateTree(dataset) - ci <- expect_warning(ConcordantInformation(tree, dataset)) - expect_equal(c(signal = log2(3)), ci['signal']) - expect_equal(c(noise = log2(3)), ci['noise']) - expect_equal(c(ignored = CharacterInformation(c(0,0,1,1,2,2)) - - log2(3) - log2(3)), ci['ignored']) - -}) diff --git a/tests/testthat/test-CustomSearch.R b/tests/testthat/test-CustomSearch.R deleted file mode 100644 index acf36b8bf..000000000 --- a/tests/testthat/test-CustomSearch.R +++ /dev/null @@ -1,133 +0,0 @@ -context("TreeSearch.R") -library("TreeTools", quietly = TRUE) -comb11 <- PectinateTree(letters[1:11]) -unrooted11 <- UnrootTree(comb11) -data11 <- cbind(upper.tri(matrix(FALSE, 11, 11))[, 3:10], - lower.tri(matrix(FALSE, 11, 11))[, 2:9]) -rownames(data11) <- letters[1:11] -phy11 <- phangorn::phyDat(data11, type = 'USER', levels = c(FALSE, TRUE)) -RootySwappers <- list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap) - -test_that("Tree can be found", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(1) - random11 <- as.phylo(17905853L, 11, letters[1:11]) - expect_error(TreeSearch(unrooted11, dataset = phy11)) - expect_equal(comb11, TreeSearch(random11, dataset = phy11, maxIter = 200, - EdgeSwapper = RootedTBRSwap, verbosity = 0L)) - expect_equal(comb11, TreeSearch(random11, phy11, maxIter = 400, - EdgeSwapper = RootedSPRSwap, verbosity = 0L)) - someOtherTree <- as.phylo(29235922L, 11, letters[1:11]) - expect_equal(comb11, TreeSearch(someOtherTree, phy11, maxIter = 200, - EdgeSwapper = RootedNNISwap, verbosity = 0)) - expect_equal(comb11, Ratchet(random11, phy11, searchIter = 10, searchHits = 5, - swappers = RootySwappers, ratchHits = 3, - verbosity = 0)) - - expect_false(all.equal(comb11, TreeSearch(random11, dataset = phy11, - maxIter = 1000, - stopAtPlateau = 1, verbosity = 0))) - - expect_true(all.equal( - MaximizeParsimony(phy11, tree = CollapseNode(random11, 13))[[1]], - comb11 - )) - expect_true(all.equal( - MaximizeParsimony(phy11, tree = random11, verbosity = 0L)[[1]], - comb11 - )) - expect_true(all.equal( - MaximizeParsimony(phy11, random11, ratchIter = 0, verbosity = 0L)[[1]], - comb11 - )) - - # Interestingly, a good example of a case with multiple optima that require - # ratchet to move between - iw <- MaximizeParsimony(phy11, random11, ratchIter = 1, tbrIter = 5, - concavity = 10, verbosity = 0L)[[1]] - expect_equal(comb11, iw) -# TODO: Sectorial Search not working yet! -# expect_equal(SectorialSearch(RandomTree(phy11, 'a'), phy11, verbosity = -1), comb11) -}) - -test_that("Tree search finds shortest tree", { - true_tree <- ape::read.tree(text = "(((((1,2),3),4),5),6);") - malformed_tree <- ape::read.tree(text = "((((1,2),3),4),5,6);") - dataset <- TreeTools::StringToPhyDat('110000 111000 111100', 1:6, byTaxon = FALSE) - expect_error(TreeSearch(malformed_tree, dataset)) - start_tree <- TreeTools::RenumberTips(ape::read.tree( - text = "(((1, 6), 3), (2, (4, 5)));"), true_tree$tip.label) - expect_equal(TreeLength(start_tree, dataset), 6) - morphyObj <- PhyDat2Morphy(dataset) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = NNISwap, - verbosity = 0), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = SPRSwap, - verbosity = -1), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, EdgeSwapper = TBRSwap, - verbosity = -1), 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedNNISwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedSPRSwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - expect_equal(3, attr(TreeSearch(start_tree, dataset, - EdgeSwapper = RootedTBRSwap, verbosity = -1), - 'score'), - TreeLength(true_tree, dataset)) - ratchetScore <- attr(Ratchet(start_tree, dataset, - swappers = list(RootedTBRSwap, RootedSPRSwap, RootedNNISwap), - ratchIter = 3, searchHits = 5, verbosity = 0), 'score') - expect_equal(3, TreeLength(true_tree, dataset), ratchetScore) -}) - - -test_that("Profile parsimony works in tree search", { - random11 <- as.phylo(17905853L, 11, letters[1:11]) # Rooted on 'a' - - # Use more iterations than necessary locally, as RNG may differ on other - # platforms. - expect_equal(comb11, - MaximizeParsimony(phy11, c(random11, random11), # multiPhylo - ratchIter = 1, tbrIter = 2, maxHits = 10, - concavity = 'profile', verbosity = 0)[[1]]) - - - sillyData <- lapply(1:22, function (i) c(rep(0, i - 1), rep(1, 22 - i), - rep(1, 22 - i), rep(0, i - 1)))#, sample(2, 20, replace = TRUE)-1)) - names(sillyData) <- as.character(1:22) - dataset <- TreeTools::PhyDat(sillyData) - readyData <- PrepareDataProfile(dataset) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - rTree <- randomTree <- RandomTree(dataset, '1') - expect_lte(TreeLength(rTree, readyData), TreeLength(rTree, dataset)) - expect_equal(90, TreeLength(referenceTree, dataset), TreeLength(referenceTree, readyData)) - expect_gt(TreeLength(rTree, readyData, 'profile'), - TreeLength(referenceTree, readyData, 'profile')) - - quickTS <- TreeSearch(rTree, dataset, TreeScorer = MorphyLength, EdgeSwapper = RootedNNISwap, - maxIter = 1600, maxHits = 40, verbosity = 0) - expect_equal(42L, attr(quickTS, 'score')) - - quickFitch <- Ratchet(rTree, dataset, TreeScorer = MorphyLength, suboptimal = 2, - swappers = RootySwappers, ratchHits = 3, searchHits = 15, - searchIter = 100, ratchIter = 500, - verbosity = 0L) - expect_equal(42, attr(quickFitch, 'score')) - - -}) - -test_that("Ratchet fails gracefully", { - expect_error(Ratchet(unrooted11, data11)) -}) diff --git a/tests/testthat/test-Jackknife.R b/tests/testthat/test-Jackknife.R deleted file mode 100644 index e6b1f56e1..000000000 --- a/tests/testthat/test-Jackknife.R +++ /dev/null @@ -1,46 +0,0 @@ -context('Jackknife.R') - -test_that("Jackknife supports are correct", { - true_tree <- ape::read.tree(text = "((((((A,B),C),D),E),F),out);") - start_tree <- ape::read.tree(text = "(((((A,D),B),E),(C,F)),out);") - dataset <- TreeTools::StringToPhyDat('1100000 1110000 1111000 1111100 1100000 1110000 1111000 1111100 1001000', - 1:7, byTaxon = FALSE) - names(dataset) <- c(LETTERS[1:6], 'out') - - expect_error(Jackknife(unroot(true_tree), dataset)) - expect_error(Jackknife(start_tree, dataset, resampleFreq = 0)) - expect_error(Jackknife(start_tree, dataset, resampleFreq = 9/10)) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - strict <- TreeSearch(start_tree, dataset, verbosity = 0) - expect_equal(1, length(unique(list(true_tree), list(start_tree)))) # Right tree found - jackTrees <- Jackknife(strict, dataset, resampleFreq = 4/7, searchIter = 24L, - searchHits = 7L, EdgeSwapper=RootedTBRSwap, - jackIter = 20L, verbosity = 0L) - - # Note: one cause of failure could be a change in characters sampled, due to randomness - expect_true(length(unique(jackTrees)) > 2L) -}) - -test_that("Jackknife ouputs good for node.labels", { - library('TreeTools', quietly = TRUE) # for as.phylo - - # jackTrees will usually be generated with Jackknife(), but for simplicity: - jackTrees <- as.phylo(1:100, 8) - - tree <- as.phylo(0, 8) - expect_equal(c('', '', '0.13', '0.08', '0.14', '1', '1'), - JackLabels(tree, jackTrees, plot = FALSE)) - - tree <- RootTree(as.phylo(0, 8), c('t1', 't4')) - expect_equal(c('', '0.08', '0.13', '', '0.14', '1', '1'), - JackLabels(tree, jackTrees, plot = FALSE)) - - skip_if_not_installed('vdiffr') - vdiffr::expect_doppelganger('plot-jackknife', function() { - expect_equal(as.double(JackLabels(tree, jackTrees, plot = FALSE)[-c(1, 4)]), - unname(JackLabels(tree, jackTrees))) - }) -}) diff --git a/tests/testthat/test-MaximizeParsimony.R b/tests/testthat/test-MaximizeParsimony.R deleted file mode 100644 index c17017156..000000000 --- a/tests/testthat/test-MaximizeParsimony.R +++ /dev/null @@ -1,139 +0,0 @@ -library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) - -test_that("Profile fails gracefully", { - dataset <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 3, f = 3)) - expect_warning(PrepareDataProfile(dataset)) - expect_warning(MaximizeParsimony(dataset, concavity = 'pr')) -}) - -test_that("Constraints work", { - constraint <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 0, f = 0)) - characters <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 0, - 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - set.seed(0) - ewResults <- MaximizeParsimony(characters, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint) - expect_equal(PectinateTree(letters[1:6]), ewResults[[1]]) - expect_equal(c(seed = 0, start = 1, final = 0), - attr(ewResults, 'firstHit')) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, concavity = 'p', - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)[[1]]) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, concavity = 10, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)[[1]]) - # Start tree not consistent with constraint - dataset <- characters - tree <- PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')) - expect_equal(PectinateTree(letters[1:6]), - MaximizeParsimony(characters, - PectinateTree(c('a', 'c', 'f', 'd', 'e', 'b')), - ratchIter = 0, constraint = constraint)[[1]]) - - - dataset <- MatrixToPhyDat(matrix(c(0, 0, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:7], NULL))) - constraint <- MatrixToPhyDat(matrix(c(0, 0, 1, '?', 1, 1, - 1, 1, 1, 1, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - cons <- consensus(MaximizeParsimony(dataset, constraint = constraint)) - expect_true(as.Splits(as.logical(c(0, 0, 1, 1, 1)), letters[c(1:3, 5:6)]) %in% - as.Splits(DropTip(cons, c('d', 'g')))) - - expect_true(as.Splits(as.logical(c(0, 0, 0, 0, 1, 1)), letters[1:6]) %in% - as.Splits(DropTip(cons, 'g'))) - -}) - -test_that("Inconsistent constraints fail", { - constraint <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 0, - 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) - expect_error(MaximizeParsimony(constraint, - PectinateTree(c('a', 'b', 'f', 'd', 'e', 'c')), - ratchIter = 0, constraint = constraint)) -}) - -test_that("MaximizeParsimony() times out", { - data('congreveLamsdellMatrices', package = 'TreeSearch') - dataset <- congreveLamsdellMatrices[[42]] - startTime <- Sys.time() - MaximizeParsimony(dataset, ratchIter = 10000, tbrIter = 1, maxHits = 1, - maxTime = 0) - expect_gt(as.difftime(5, units = 'secs'), Sys.time() - startTime) -}) - -test_that("Mismatched tree/dataset handled with warnings", { - treeAf <- read.tree(text = "(a, (b, (c, (d, (e, f)))));") - treeBg <- read.tree(text = "(g, (b, (c, (d, (e, f)))));") - datAf <- StringToPhyDat('110000 110000 111100 111000', - letters[1:6], byTaxon = FALSE) - datAe <- StringToPhyDat('11000 11000 11110 11100', - letters[1:5], byTaxon = FALSE) - datAg <- StringToPhyDat('1100000 1100000 1111000 1110000', - letters[1:7], byTaxon = FALSE) - - QP <- function (...) MaximizeParsimony(..., ratchIter = 0, maxHits = 1, - verbosity = 0) - - expect_equal(5, NTip(expect_warning(QP(datAf, treeBg)))) - expect_equal(5, NTip(expect_warning(QP(datAe, treeAf)))) - expect_equal(6, NTip(expect_warning(QP(datAg, treeAf)))) - expect_equal(5, NTip(expect_warning(QP(datAf, treeBg, constraint = datAe)))) - expect_equal(6, NTip(QP(datAf, treeAf, constraint = datAe))) - expect_equal(6, NTip(expect_warning(QP(datAf, treeAf, constraint = datAg)))) -}) - -test_that("Root retained if not 1", { - tr <- RootTree(BalancedTree(8), 't5') - dataset <- StringToPhyDat('11000000 11100000 11110000 11111000', - paste0('t', 1:8), byTaxon = FALSE) - - mpt <- MaximizeParsimony(dataset, tr) - expect_equal(5, mpt[[1]]$edge[14, 2]) -}) - -test_that("Resample() fails and works", { - expect_error(Resample(0)) - dataset <- MatrixToPhyDat(rbind( - a = c(0, 0, 0, 0, 0, 0), - b = c(0, 0, 0, 0, 0, 0), - c = c(1, 1, 0, 0, 0, 1), - d = c(1, 1, 0, 0, 1, 0), - e = c(1, 1, 1, 1, 1, 1), - f = c(1, 1, 1, 1, 1, 1))) - - expect_error(Resample(dataset, method = 'ERROR')) - expect_error(Resample(dataset, proportion = 0)) - expect_error(Resample(dataset, proportion = 6 / 7)) - - nRep <- 42L # Arbitrary number to balance runtime vs false +ves & -ves - bal <- as.Splits(BalancedTree(dataset)) - - skip_if_not_installed("TreeTools", "1.4.5.9003") # postorder / as.Splits order - jackTrees <- replicate(nRep, Resample(dataset, NJTree(dataset), verbosity = 0L)) - jackSplits <- as.Splits(unlist(jackTrees, recursive = FALSE)) - jackSupport <- rowSums(vapply(jackSplits, function (sp) in.Splits(bal, sp), - logical(3))) - # This test could be replaced with a more statistically robust alternative! - expect_equal(c(1, 1/2, 0) * sum(vapply(jackTrees, length, 1L)), jackSupport, - tolerance = 0.2) - - bootTrees <- replicate(nRep, Resample(dataset, method = 'bootstrap', - verbosity = 0)) - #bootSupport <- rowSums(vapply(lapply(bootTrees, `[[`, 1), - bootSupport <- rowSums(vapply(unlist(bootTrees, recursive = FALSE), - function (tr) in.Splits(bal, as.Splits(tr)), - logical(3))) - # This test could be replaced with a more statistically robust alternative! - expect_equal(c(1, 1/2, 0) * sum(vapply(bootTrees, length, 1L)), bootSupport, - tolerance = 0.2) - -}) diff --git a/tests/testthat/test-NNI.R b/tests/testthat/test-NNI.R deleted file mode 100644 index 573493fad..000000000 --- a/tests/testthat/test-NNI.R +++ /dev/null @@ -1,25 +0,0 @@ -test_that("Errors fail gracefully", { - expect_error(nni(TreeTools::BalancedTree(2)$edge, 0, 0)) -}) - -test_that("cNNI()", { - tr <- Preorder(root(TreeTools::BalancedTree(letters[1:7]), 'a', resolve.root = TRUE)) - expect_equal(ape::read.tree(text="(a,(b,((c,d),((e,g),f))));"), - cNNI(tr, 0, 1)) # Edge '9' - expect_equal(ape::read.tree(text="(a,(b,((c,d),((f,g),e))));"), - cNNI(tr, 0, 0)) # Edge '9' - expect_equal(cNNI(tr, 0, 1), cNNI(tr, 4, 1)) - expect_equal(ape::read.tree(text="(a, (b, (g, ((c, d), (e, f)))));"), # Edge 8 - cNNI(tr, 1, 1)) - expect_equal(cNNI(tr, 1, 1), cNNI(tr, 1, 3)) - expect_equal(ape::read.tree(text="(a, (b, ((e, f), ((c, d), g))));"), # Edge 8 - cNNI(tr, 1, 2)) - expect_equal(cNNI(tr, 1, 2), cNNI(tr, 1, 0)) - expect_equal(ape::read.tree(text="(a, (b, (d, (c, (g, (e, f))))));"), # Edge 5 - cNNI(tr, 2, 1)) - expect_equal(ape::read.tree(text="(a, ((b, (c, d)), ((e, f), g)));"), # Edge 4 - cNNI(tr, 3, 1)) - suppressWarnings(RNGversion('3.5.0')) - set.seed(0) # sample.int gives 4, 1 - expect_equal(cNNI(tr, 0, 1), cNNI(tr)) -}) \ No newline at end of file diff --git a/tests/testthat/test-PlotCharacter.R b/tests/testthat/test-PlotCharacter.R deleted file mode 100644 index b2498c296..000000000 --- a/tests/testthat/test-PlotCharacter.R +++ /dev/null @@ -1,125 +0,0 @@ -test_that("PlotCharacter()", { - - skip_if_not_installed("TreeTools", "1.5.0") # Changes plotting order - Character <- function (str, plot = FALSE, ...) { - tree <- ape::read.tree(text = - "((((((a, b), c), d), e), f), (g, (h, (i, (j, (k, l))))));") - dataset <- TreeTools::StringToPhyDat(str, tips = tree) - PlotCharacter(tree, dataset, - edge.width = 3, plot = plot, ...) - } - - expect_equal(structure(c(FALSE, FALSE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, - TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, - TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, - FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, - FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, - TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, - TRUE, FALSE, FALSE, FALSE, TRUE, TRUE), .Dim = c(23L, 5L), .Dimnames = list( - NULL, c("-", "0", "1", "2", "3"))), - Character("23--1??--032", updateTips = TRUE)) - - skip_if_not_installed('vdiffr') - skip_if_not_installed("ape", "5.5.2") # Node colours - - Test <- if (interactive()) { - function (str) invisible(Character(str, plot = TRUE)) - } else { - function (str) { - vdiffr::expect_doppelganger( - paste0('PlotChar_', - gsub('?', 'Q', - gsub('(', 'd', - gsub(')', 'b', - gsub('-', 'I', str, - fixed = TRUE), fixed = TRUE), fixed = TRUE), fixed = TRUE)), - function() Character(str, plot = TRUE)) - } - } - - Test("23--1??--032") - Test("23--1??(-0)-(01)32") - Test("23??1????032") - Test("11--????--11") - Test("000011????00") - Test("????????????") - Test("-------?????") - Test("------------") - Test("1234(45)AACGTTT") - - # From TGuillerme testing suite: - Test("11-------100") - Test("1100----1100") - Test("000011110000") - Test("1---1111---1") - Test("----1111---1") - Test("01----010101") - Test("01---1010101") - Test("1??--??--100") - Test("21--3??--032") - Test("11--1??--111") - Test("11--1000001-") - Test("01------0101") - Test("110--?---100") - Test("210--100--21") - Test("????----1???") - Test("23--1----032") - Test("1----1----1-") - Test("-1-1-1--1-1-") - - Test("--------0101") - Test("10101-----01") - Test("011--?--0011") - Test("110--??--100") - Test("21--1----012") - Test("11----111111") - Test("210210------") - Test("----1111----") - Test("230--??1--32") - Test("023--??1--32") - Test("023-???1--32") - Test("23--1?1--023") - Test("----1010----") - Test("------11---1") - Test("10----11---1") - Test("320--??3--21") -}) - -test_that("Edge cases work", { - tree <- ape::read.tree(text = '(a, (b, ((c, d), (e, f))));') - dataset <- TreeTools::StringToPhyDat('-01100', tips = tree) - if (interactive()) { - PlotCharacter(tree, dataset) - } else { - expect_equal(c('-' = FALSE, '0' = TRUE, '1' = FALSE), - PlotCharacter(tree, dataset, plot = FALSE)[9, ]) - } - - tree <- ape::read.tree(text = '(a, (b, (c, (d, (e, f)))));') - dataset <- TreeTools::StringToPhyDat('--0101', tips = tree) - if (interactive()) { - PlotCharacter(tree, dataset) - } else { - expect_equal(cbind('-' = c(1, 1, 0, 0, 0), - '0' = c(0, 0, 1, 1, 1), - '1' = c(0, 0, 1, 1, 1)), - 1 * PlotCharacter(tree, dataset, plot = FALSE)[7:11, ]) - } -}) - -test_that("Out-of-sequence works", { - skip_if_not_installed('vdiffr') - skip_if_not_installed("ape", "5.5.2") # Node colours - vdiffr::expect_doppelganger('PlotChar_out-of-sequence', - function () { - PlotCharacter(ape::read.tree(text = '(a, (b, (c, d)));'), - TreeTools::StringToPhyDat('1342', tips = c('a', 'c', 'd', 'b')) - ) - }) -}) \ No newline at end of file diff --git a/tests/testthat/test-RMorphy.R b/tests/testthat/test-RMorphy.R deleted file mode 100644 index 9533338b8..000000000 --- a/tests/testthat/test-RMorphy.R +++ /dev/null @@ -1,25 +0,0 @@ -context("RMorphy.C[++]") - -test_that("NULL pointers don't cause crash", { - ptr <- mpl_new_Morphy() - expect_equal(0, mpl_delete_Morphy(ptr)) - expect_true(is.na(mpl_delete_Morphy(ptr))) -}) - -test_that("Pointers survive garbage collection", { - ptr <- mpl_new_Morphy() - gc() - expect_equal(0, mpl_delete_Morphy(ptr)) -}) - -test_that("preorder_morphy()", { - library('TreeTools', quietly = TRUE) - tree <- Preorder(RootTree(BalancedTree(6), 1)) - dat <- MatrixToPhyDat(matrix(c(0, 1, 0, 1, 0, 1, - 0, 0, 0, 1, 1, 1), byrow = FALSE, 6, - dimnames = list(TipLabels(6), NULL))) - morphyObj <- PhyDat2Morphy(dat) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - tree$edge - 1 - expect_equal(4L, preorder_morphy(tree$edge, morphyObj)) -}) diff --git a/tests/testthat/test-RandomTreeScore.R b/tests/testthat/test-RandomTreeScore.R deleted file mode 100644 index 4dded7dbb..000000000 --- a/tests/testthat/test-RandomTreeScore.R +++ /dev/null @@ -1,45 +0,0 @@ -test_that("RandomMorphyTree() errors are handled", { - skip_if(TRUE) - expect_error(RandomMorphyTree(-1)) - expect_error(RandomMorphyTree(0)) - expect_error(RandomMorphyTree(1)) -}) - -test_that("Two tip 'random' tree", { - skip_if(TRUE) - expect_equal(RandomMorphyTree(2), list(c(2, 2, 2), 0, 1)) -}) - -test_that("RandomTreeScore() on small trees", { - skip_if(TRUE) - mo <- mpl_new_Morphy() - expect_equal(0L, RandomTreeScore(mo)) - mpl_delete_Morphy(mo) - - tokens <- matrix(c( - 0, '-', '-', 1, 1, 2, - 0, '-', '-', 1, 1, 2, - 0, '-', '-', 0, 0, 0), byrow = TRUE, nrow = 3L, - dimnames = list(letters[1:3], NULL)) - - # One leaf - pd <- TreeTools::MatrixToPhyDat(tokens[1, , drop = FALSE]) - morphyObj <- PhyDat2Morphy(pd) - expect_equal(mpl_get_numtaxa(morphyObj), 1L) - expect_equal(0, RandomTreeScore(morphyObj)) - morphyObj <- UnloadMorphy(morphyObj) - - # Two leaves - pd <- TreeTools::MatrixToPhyDat(tokens[2:3, , drop = FALSE]) - morphyObj <- PhyDat2Morphy(pd) - expect_equal(mpl_get_numtaxa(morphyObj), 2L) - expect_equal(RandomTreeScore(morphyObj), 3L) - morphyObj <- UnloadMorphy(morphyObj) - - # Three leaves - pd <- TreeTools::MatrixToPhyDat(tokens) - morphyObj <- PhyDat2Morphy(pd) - expect_equal(RandomTreeScore(morphyObj), 3L) - morphyObj <- UnloadMorphy(morphyObj) - -}) diff --git a/tests/testthat/test-TreeSearch_utilities.R b/tests/testthat/test-TreeSearch_utilities.R deleted file mode 100644 index 872a23cba..000000000 --- a/tests/testthat/test-TreeSearch_utilities.R +++ /dev/null @@ -1,6 +0,0 @@ -test_that("EmptyDataset()", { - tree <- TreeTools::PectinateTree(8) - ret <- EmptyPhyDat(tree) - expect_equal(TipLabels(tree), names(ret)) - expect_true(inherits(ret, 'phyDat')) -}) diff --git a/tests/testthat/test-data_manipulation.R b/tests/testthat/test-data_manipulation.R deleted file mode 100644 index fbdcf28f2..000000000 --- a/tests/testthat/test-data_manipulation.R +++ /dev/null @@ -1,133 +0,0 @@ -context("data_manipulation.R") - -test_that("Deprecation", { - expect_equal(MinimumLength(1:3), expect_warning(MinimumSteps(1:3))) -}) - -test_that("Minimum step counts are correctly calculated", { - expect_equal(1, MinimumLength(1:3)) - expect_equal(1, MinimumLength(c(1:3, 5))) - expect_equal(0, MinimumLength(c(6, 7, 14))) - expect_equal(1, MinimumLength(0:3)) # 0 representing the inapplicable token - - # ++++, .++., ..++ - expect_equal(0, MinimumLength(c(2046, 384, 1152))) - - # ++++, +..., .++., ..++ - expect_equal(1, MinimumLength(c(15, 8, 6, 3))) - - # ++++++, +....., .++..., .+.+.., ...++. - expect_equal(2, MinimumLength(c(63, 32, 24, 20, 6))) - - dudDat <- TreeTools::StringToPhyDat('----{-,1}22', letters[1:7]) - expect_equal('----<-,1>22', TreeTools::PhyDatToString(dudDat, '>', ',')) - expect_equal(0, attr(PrepareDataIW(dudDat), 'min.length')) - - dudTwo <- TreeTools::StringToPhyDat('{-1}{-2}{-3}2233', letters[1:7]) - expect_equal('{-1}{-2}{-3}2233', TreeTools::PhyDatToString(PrepareDataIW(dudTwo))) - - tr <- ape::read.tree(text='(((a, b), c), (d, (e, ((f, g), (h, (i, (j, k)))))));') - expect_equal(CharacterLength(tr, compress = TRUE, - TreeTools::StringToPhyDat('11---22--33', letters[1:11])), - MinimumLength(c(0, 0, 0, 0, 0, 0, 2, 2, 4, 4, 8, 8))) - - # 04, 14, 24, 34, 05, 16, 27, 38, 9A - # In this case, chosing the most common state (4) means that we have to choose 567&8 too - # 012&3 is a better solution - # We also have to choose one of 9 or A, but it doesn't matter which. - expect_equal(4, MinimumLength(c( - 2^0 + 2^4, - 2^1 + 2^4, - 2^2 + 2^4, - 2^3 + 2^4, - 2^0 + 2^5, - 2^1 + 2^6, - 2^2 + 2^7, - 2^3 + 2^8, - 2^9 + 2^10 - ))) - - data('inapplicable.datasets') - expect_equal(c(1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1, - 1, 2, 1, 1, 4, 3, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 4, 1, - 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), - MinimumLength(inapplicable.phyData[[4]], compress = TRUE)) - -}) - -test_that("PrepareDataProfile() handles empty matrices", { - dat <- TreeTools::MatrixToPhyDat(matrix(c(0, 1, rep('?', 5)), - dimnames = list(letters[1:7], NULL))) - expectation <- dat[0] - attr(expectation, 'info.amounts') <- numeric(0) - expect_equal(expectation, PrepareDataProfile(dat)) -}) - -test_that("PrepareDataProfile()", { - - # Easy one - mtx <- cbind(c('0', '0', 1,1,1,1), - c(0,0,1,1,1,1),# again - c(0,0,0,1,1,'?')) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - phy1 <- TreeTools::MatrixToPhyDat(mtx) - expect_equivalent(phy1, PrepareDataProfile(phy1)) - expect_equal(attributes(phy1), attributes(PrepareDataProfile(phy1))[1:10]) - - # Easy one - mtx <- cbind(c('0', '0', 1,1,1,1), - c(1,1,0,0,0,0),# flipped - c(0,0,0,1,1,'{012}')) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - phy2 <- TreeTools::MatrixToPhyDat(mtx) - expect_equivalent(phy1, PrepareDataProfile(phy2)) - expect_equal(attributes(PrepareDataProfile(phy1)), - attributes(PrepareDataProfile(phy2))) - - - mtx <- cbind(c('0', '0', 1,1,1, '2', '2', 3,3,3,3), - c('?', '?', 1,1,1, '?', '?', 0,0,0,0), - c(0,0,1,1,1,2,2,3,3,3,3),# again - c(rep('?', 5), '2', '2', 0,0,0,0), - c('?', '?', 1,1,1, 1,1, 0,0,0,0), - c('0', '1', rep('?', 9)) - ) - rownames(mtx) <- letters[seq_len(nrow(mtx))] - dataset <- TreeTools::MatrixToPhyDat(mtx) - - q <- '?' - decomposed <- matrix(c(0,0,q,q,q,q,q,1,1,1,1, - q,q,0,0,0,q,q,1,1,1,1, - q,q,q,q,q,0,0,1,1,1,1, - - q,q,0,0,0,q,q,1,1,1,1, - - 0,0,q,q,q,q,q,1,1,1,1, - q,q,0,0,0,q,q,1,1,1,1, - q,q,q,q,q,0,0,1,1,1,1, - - q,q,q,q,q,0,0,1,1,1,1, - q,q,0,0,0,0,0,1,1,1,1), - ncol = 9, dimnames = list(letters[1:11], NULL)) - - - expect_warning(pd <- PrepareDataProfile(dataset)) - expect_equal(decomposed, PhyDatToMatrix(pd)) - expect_equal(c(1, 2, 3, 2, 1, 2, 3, 3, 4), attr(pd, 'index')) - expect_equal(c(2, 3, 3, 1), attr(pd, 'weight')) - - dataset2 <- TreeTools::MatrixToPhyDat(mtx[!mtx[, 1] %in% c(0, 2), ]) - expect_equal(attr(PrepareDataProfile(dataset2), 'info.amounts'), - attr(pd, 'info.amounts')[1:3, 2, drop = FALSE]) - - - data('Lobo', package = "TreeTools") - expect_warning(prep <- PrepareDataProfile(Lobo.phy)) - expect_equal(c(17, attr(prep, 'nr')), - dim(attr(prep, 'info.amounts'))) - - -}) diff --git a/tests/testthat/test-iw-scoring.R b/tests/testthat/test-iw-scoring.R deleted file mode 100644 index d829751ef..000000000 --- a/tests/testthat/test-iw-scoring.R +++ /dev/null @@ -1,78 +0,0 @@ -test_that("IW Scoring", { - library('TreeTools', quietly = TRUE, warn.conflicts = FALSE) - data('Lobo', package = 'TreeTools') - dataset <- Lobo.phy - - #dataset <- ReadAsPhyDat('c:/research/r/hyoliths/mbank_X24932_6-19-2018_744.nex') - tree <- NJTree(dataset) - - - .IWScore <- function (edge, morphyObjs, weight, minLength, concavity) { - steps <- preorder_morphy_by_char(edge, morphyObjs) - homoplasies <- steps - minLength - fit <- homoplasies / (homoplasies + concavity) - sum(fit * weight) - } - - concavity <- 4.5 - epsilon <- sqrt(.Machine$double.eps) - - - tree <- Preorder(RenumberTips(tree, names(dataset))) - nTip <- NTip(tree) - edge <- tree$edge - - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - startWeights <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) - - nLevel <- length(at$level) - nChar <- at$nr - nTip <- length(dataset) - cont <- at$contrast - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) colnames(cont)[x][1]), - '?') - inappLevel <- at$levels == '-' - - if (any(inappLevel)) { - # TODO this is a workaround until MinimumLength can handle {-, 1} - cont[cont[, inappLevel] > 0, ] <- 0 - ambiguousToken <- at$allLevels == '?' - cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 - } - - # Perhaps replace with previous code: - # inappLevel <- which(at$levels == "-") - # cont[, inappLevel] <- 0 - - powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) - tmp <- as.integer(cont %*% powersOf2) - unlisted <- unlist(dataset, use.names = FALSE) - binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) - minLength <- apply(binaryMatrix, 1, MinimumLength) - - tokenMatrix <- matrix(simpleCont[unlisted], nChar, nTip, byrow = FALSE) - charInfo <- apply(tokenMatrix, 1, CharacterInformation) - needsInapp <- rowSums(tokenMatrix == '-') > 2 - inappSlowdown <- 3L # A guess - rawPriority <- charInfo / ifelse(needsInapp, inappSlowdown, 1) - priority <- startWeights * rawPriority - informative <- needsInapp | charInfo > 0 - # Will work from end of sequence to start. - charSeq <- seq_along(charInfo)[informative][order(priority[informative])] - 1L - - - weight <- startWeights - - expect_equal(.IWScore(edge, morphyObjects, weight, minLength, concavity), - morphy_iw(edge, morphyObjects, weight, minLength, charSeq, - concavity, Inf)) - - expect_equal(Inf, morphy_iw(edge, morphyObjects, weight, minLength, charSeq, - concavity, 0)) - -}) \ No newline at end of file diff --git a/tests/testthat/test-mpl_morphy_objects.R b/tests/testthat/test-mpl_morphy_objects.R deleted file mode 100644 index 038e6ef62..000000000 --- a/tests/testthat/test-mpl_morphy_objects.R +++ /dev/null @@ -1,37 +0,0 @@ -test_that("PhyDat2Morphy() errors", { - expect_error(PhyDat2Morphy(NA)) -}) - -test_that("UnloadMorphy() errors", { - expect_error(UnloadMorphy(NA)) -}) - -test_that("GapHandler()", { - expect_error(GapHandler(0)) - tokens <- matrix(c('-', '-', 0, 0), byrow = TRUE, nrow = 4L, - dimnames = list(letters[1:4], NULL)) - pd <- TreeTools::MatrixToPhyDat(tokens) - - morphyObj <- PhyDat2Morphy(pd) - expect_equal(0, RandomTreeScore(morphyObj)) - expect_equal("Inapplicable", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- PhyDat2Morphy(pd, 'ambigu') - expect_equal(0, RandomTreeScore(morphyObj)) - expect_equal("Missing data", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- PhyDat2Morphy(pd, 'eXt') - expect_lt(0, RandomTreeScore(morphyObj)) - expect_equal("Extra state", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - morphyObj <- SingleCharMorphy('-0-0', 'eXt') - expect_lt(0, RandomTreeScore(morphyObj)) - expect_equal("Extra state", GapHandler(morphyObj)) - UnloadMorphy(morphyObj) - - expect_error(SingleCharMorphy('-0-0', 'ERROR')) - expect_error(GapHandler(morphyObj)) -}) diff --git a/tests/testthat/test-pp-fitch.R b/tests/testthat/test-pp-fitch.R deleted file mode 100644 index dec536272..000000000 --- a/tests/testthat/test-pp-fitch.R +++ /dev/null @@ -1,92 +0,0 @@ -context("pp_exact") - -# TODO this test was recovered from a stash and requires updating -- -# or may be obselete. -test_that("Profile score correct for small trees", { - library("TreeTools", quietly = TRUE, warn.conflicts = FALSE) - tree <- as.phylo(200, 9) - - mataset <- matrix(c( - 1, 1, 1, 1, 0, 0, 0, 0, 0, # 3 steps - 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps - 1, 0, 0, 1, 0, 0, 1, 0, 0, # 2 steps again [duplicated] - 0, 1, 0, 0, 0, 0, 0, 1, 1, # 1 step - 2, 1, 1, 1, 1, 1, 1, 1, 1),# 1 step; non-informative - nrow = 9, dimnames = list(paste0('t', 1:9), NULL)) - - - dataset <- MatrixToPhyDat(mataset) - - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - weight <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) - - nLevel <- length(at$level) - nChar <- at$nr - cont <- at$contrast - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) at$levels[x][1]), - '?') - inappLevel <- at$levels == '-' - - unlisted <- unlist(dataset, use.names = FALSE) - charSeq <- seq_len(nChar) - 1L - - tokenMatrix <- matrix(simpleCont[unlisted], nChar, 9, byrow = FALSE) - profileTables <- apply(tokenMatrix, 1, table) - if (inherits(profileTables, 'matrix')) { - profileTables <- lapply(seq_len(ncol(profileTables)), function (i) profileTables[, i]) - } - data('profiles', package = 'TreeSearch') - profileCost <- lapply(profileTables, function (x) { - x <- sort(x[x > 1]) - n <- length(x) - prof <- switch(n, - 0, - profiles[[sum(x)]][[n]][[x[1] - 1L]] - ) - }) - profileExtra <- lapply(profileCost, function (x) x - x[1]) - fixedCost <- -sum(vapply(profileCost, `[[`, 1, 1) * weight) - maxScore <- sum(Log2Unrooted(vapply(profileTables, sum, 1))) - pad <- function (x, len) { - ret <- double(len) - ret[seq_along(x)] <- x - ret - } - profiles <- vapply(profileExtra, pad, double(4), 4) - - TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, - charSeq, profiles, Inf) - - PP <- function (costs) { - TreeSearch:::morphy_profile(tree$edge, morphyObjects, weight, - charSeq, costs, Inf) - } - - - # Use integer-step profile tables - extraSteps <- matrix(1:4, 4, 4) - expect_equal(TreeLength(tree, dataset), PP(costs = extraSteps)) - expect_equal(3 + 2 + 2 + 1 + 1, - TreeLength(tree, dataset)) -}) - - -test_that("Profile score can be calculated from real data", { - data(referenceTree) - data(congreveLamsdellMatrices) - tree <- referenceTree - dataset <- PrepareDataProfile(congreveLamsdellMatrices[[1]]) - expect_equal(TreeLength(tree, dataset), - sum(CharacterLength(tree, dataset, compress = TRUE) * - attr(dataset, 'weight'))) - score <- TreeLength(tree, dataset, 'profile') - - # Check score hasn't materially changed: - # 511.732 is "previous value"; not manually checked. - expect_equal(511.732, score, tolerance = 0.01) -}) diff --git a/tests/testthat/test-pp-info_extra_step.R b/tests/testthat/test-pp-info_extra_step.R deleted file mode 100644 index 4a34e6550..000000000 --- a/tests/testthat/test-pp-info_extra_step.R +++ /dev/null @@ -1,95 +0,0 @@ -context("pp_info_extra_step.R") -library("TreeSearch", quietly = TRUE) - -test_that("Bad input safely handled", { - expect_equal(0, WithOneExtraStep(1)) - expect_error(WithOneExtraStep(2, 2, 2)) - - expect_equal(0, Carter1(5, 6, 4)) - expect_equal(-Inf, LogCarter1(5, 6, 4)) - expect_equal(-Inf, Log2Carter1(5, 6, 4)) -}) - -test_that("StepInformation() works", { - expect_equal(c(`0` = 0), StepInformation(rep(3L, 10), ambiguousTokens = 3)) - expect_equal(c(`0` = 0), StepInformation(c(4L, rep(3L, 10)), 3)) - expect_true(all(is.finite(StepInformation(rep.int(1:3, times = c(139, 45, 41)), - ambiguousTokens = 3)))) - expect_true(all(is.finite(StepInformation( - char = rep.int(1:2, times = c(600, 600)))))) -}) - -test_that("Carter1() matches profile counts", { - data("profiles", package = "TreeSearch") - Test <- function (a, b) { - n <- sum(a, b) - counted <- 2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]] * NUnrooted(n) - m <- as.integer(names(counted)) - for (mi in m) { - expect_equal(log2(Carter1(mi, a, b)), Log2Carter1(mi, b, a)) - expect_equal(log(Carter1(mi, a, b)), LogCarter1(mi, b, a)) - } - expect_equivalent(counted, - cumsum(vapply(m, Carter1, a = a, b = b, double(1)))) - } - - Test(2, 4) - Test(2, 5) - Test(2, 6) - Test(2, 7) - Test(2, 8) - - Test(3, 4) - Test(3, 5) - Test(3, 6) - Test(3, 7) - - Test(4, 4) - Test(4, 5) - Test(4, 6) - - Test(5, 4) - Test(5, 5) - -}) - -test_that("WithOneExtraStep() input format", { - expect_equal(WithOneExtraStep(7, 5), WithOneExtraStep(c(5, 7))) -}) - -test_that("WithOneExtraStep()", { - library("TreeTools", quietly = TRUE) - data("profiles", package = "TreeSearch") - Test <- function (a, b) { - n <- sum(a, b) - expect_equivalent(2 ^ profiles[[n]][[2]][[n - max(a, b) - 1]][2] * NUnrooted(n), - NUnrootedMult(c(a, b)) + WithOneExtraStep(c(a, b))) - } - - Test(4, 2) - Test(3, 3) - Test(8, 2) - Test(4, 3) - Test(7, 3) - Test(6, 4) - Test(5, 5) - - expect_equal(NUnrooted(6) / NUnrooted(5) * WithOneExtraStep(2:3), - WithOneExtraStep(1:3)) - expect_equal(NUnrooted(10) / NUnrooted(5) * WithOneExtraStep(2:3), - WithOneExtraStep(2:3, rep(1, 5))) -}) - -test_that(".LogCumSumExp()", { - Test <- function (x) { - naive <- log(cumsum(exp(x))) - if (all(is.finite(naive))) { - expect_equal(naive, .LogCumSumExp(x)) - } else { - expect_true(all(is.finite(.LogCumSumExp(x)))) - } - } - Test(log(c(1:5, 5:1))) - Test(c(10, 700, 100)) - Test(c(10, 7000, 100)) -}) \ No newline at end of file diff --git a/tests/testthat/test-pp-random-tree.R b/tests/testthat/test-pp-random-tree.R deleted file mode 100644 index 38f4cbbd7..000000000 --- a/tests/testthat/test-pp-random-tree.R +++ /dev/null @@ -1,141 +0,0 @@ -# NB: RandomTreeScore uses C's RNG, so no point in setting seed. -MorphyAction <- function (Action) expect_equal("ERR_NO_ERROR", mpl_translate_error(Action)) -MorphyWith <- function (char) { - nTip <- nchar(char) - 1L - morphyObj <- mpl_new_Morphy() - MorphyAction(mpl_init_Morphy(nTip, 1, morphyObj)) - MorphyAction(mpl_attach_rawdata(char, morphyObj)) - MorphyAction(mpl_set_num_internal_nodes(nTip - 1L, morphyObj)) - MorphyAction(mpl_set_parsim_t(1, 'FITCH', morphyObj)) - MorphyAction(mpl_set_charac_weight(1, 1, morphyObj)) - MorphyAction(mpl_apply_tipdata(morphyObj)) - class(morphyObj) <- 'morphyPtr' - morphyObj -} - - -context("pp: Tree randomness") -test_that("four-tip trees are randomly distributed", { - nTrees <- 36000 - stringency <- 0.005 # low numbers mean you'll rarely fail by chance - nTip <- 4 - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, 1/(nTip - 1)) - rTrees <- vapply(logical(nTrees), function (XX) - unlist(RandomMorphyTree(nTip)), integer((nTip * 4) - 3)) - expect_true(all(rTrees[1 + (seq_len(nTip - 1)), ] %in% nTip + seq_len(nTip - 2))) - expect_lt(expectedBounds[1], sum(rTrees[2, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[2, ] == 5)) - expect_lt(expectedBounds[1], sum(rTrees[3, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[3, ] == 5)) - expect_lt(expectedBounds[1], sum(rTrees[4, ] == 5)) - expect_gt(expectedBounds[2], sum(rTrees[4, ] == 5)) - - expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] > expectedBounds[1])) - expect_true(all(table(rTrees[c(9, 12), ])[seq_len(nTip - 1)] < expectedBounds[2])) - - expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] < nTrees - expectedBounds[1])) - expect_true(all(table(rTrees[c(10, 13), ])[seq_len(nTip - 1)] > nTrees - expectedBounds[2])) -}) - -test_that("four-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - nTrees <- 6000 - stringency <- 0.005 - nTip <- 4 - - morphyObj <- MorphyWith('0011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - NUnrooted(nTip - 1L) / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - expect_lt(expectedBounds[1], sum(scores==1)) - expect_gt(expectedBounds[2], sum(scores==1)) -}) - -test_that("five-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - nTrees <- 6000 - stringency <- 0.005 - nTip <- 5 - morphyObj <- MorphyWith('00011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - NUnrooted(nTip - 1) / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - expect_equal(2L, max(scores)) - expect_lt(expectedBounds[1], sum(scores == 1)) - expect_gt(expectedBounds[2], sum(scores == 1)) -}) - - -test_that("six-tip trees are randomly scored", { - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - - nTrees <- 6000 - stringency <- 0.005 - nTip <- 6 - - morphyObj <- MorphyWith('000011;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - NUnrooted(5) / NUnrooted(6)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - morphyObj <- UnloadMorphy(morphyObj) - - expect_true(max(scores) == 2) - expect_lt(expectedBounds[1], sum(scores==1)) - expect_gt(expectedBounds[2], sum(scores==1)) - - morphyObj <- MorphyWith('001122;') - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - 7 / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), - integer(1)) - morphyObj <- UnloadMorphy(morphyObj) - - expect_true(all(scores %in% 2:4)) - expect_lt(expectedBounds[1], sum(scores == 2)) - expect_gt(expectedBounds[2], sum(scores == 2)) - - morphyObj <- MorphyWith('000111;') - expectedBounds <- qbinom(c(stringency, 1-stringency), nTrees, - 3 * 3 / NUnrooted(nTip)) - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), integer(1)) - # unloaded on exit; don't unload twice || morphyObj <- UnloadMorphy(morphyObj) - - expect_true(max(scores) == 3) - expect_lt(expectedBounds[1], sum(scores == 1)) - expect_gt(expectedBounds[2], sum(scores == 1)) - -}) - -test_that("twelve-tip trees are randomly scored", { - nTrees <- 12000 # 12000 seems to throw false +ve too often? - stringency <- 0.01 # increased from 0.005 to avoid false +ves - nTip <- 12 - morphyObj <- MorphyWith('000000011111;') - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - expectedBounds <- qbinom(c(stringency, 1 - stringency), nTrees, - NUnrooted(7) * (2 * 7 - 3) * - NUnrooted(5) * (2 * 5 - 3) / NUnrooted(nTip)) - - scores <- vapply(logical(nTrees), - function (XX) RandomTreeScore(morphyObj), - integer(1L)) - # table(scores) - - expect_equal(5L, max(scores)) - nScoring1 <- sum(scores == 1) - expect_lt(expectedBounds[1], nScoring1) - expect_gt(expectedBounds[2], nScoring1) -}) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index a8c4a760d..b0e26ae79 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -1,175 +1,3 @@ -library("TreeTools") - -test_that("TBR errors", { - tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) - expect_equal(0, length(expect_warning(all_tbr(tr$edge, -1)))) - expect_equal(0, length(expect_warning(all_tbr(tr$edge, 1)))) - expect_equal(0, length(expect_warning(all_tbr(tr$edge, 111)))) -}) - test_that("SPR errors", { - tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) - expect_equal(0, length(expect_warning(all_spr(tr$edge, -1)))) - expect_equal(0, length(expect_warning(all_spr(tr$edge, 1)))) - expect_equal(0, length(expect_warning(all_spr(tr$edge, 111)))) - dput("SPR ERRor 3 - Completed.") -}) - -test_that("TBR working", { - skip_if(TRUE) - tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) - - # Move single tip - expect_equal(8, length(x <- all_tbr(tr$edge, 12))) - expect_equal(8, length(x <- all_tbr(tr$edge, 11))) - expect_equal(8, length(x <- all_tbr(tr$edge, 10))) - expect_equal(8, length(x <- all_tbr(tr$edge, 7))) - expect_equal(8, length(x <- all_tbr(tr$edge, 6))) - expect_equal(8, length(x <- all_tbr(tr$edge, 3))) - - # Move cherry - expect_equal(6, length(x <- all_tbr(tr$edge, 9))) - expect_equal(6, length(x <- all_tbr(tr$edge, 5))) - expect_equal(6, length(TBRMoves(tr, 5))) - - # Move more - expect_equal(6, length(unique(x <- all_tbr(tr$edge, 4)))) - expect_equal(3 * 4 + 2, length(unique(x <- all_tbr(tr$edge, 8)))) - - # All moves - expect_equal(6*8 + 12+ 6 + 14, length(x <- all_tbr(tr$edge, integer(0)))) - expect_equal(58, length(unique(x <- all_tbr(tr$edge, integer(0))))) # 58 not formally calculated - expect_equal(58, length(TBRMoves(tr))) - - tr <- Preorder(root(TreeTools::BalancedTree(14), 't1', resolve.root = TRUE)) - desc <- TreeTools::CladeSizes(tr) - - external <- c(3, 6, 7, 11, 12, 13, 17, 18, 20, 21, 24:26) - # Move single - for (leaf in external) { - expect_equal(22, length(x <- all_tbr(tr$edge, leaf))) - } - - Test <- function (edge) { - nDesc <- desc[tr$edge[edge, 2]] - expected <- (2 * nDesc - 3) * (22 - (2 * nDesc - 3)) - 1 - expect_equal(expected, length(all_tbr(tr$edge, edge))) - } - for (internal in which(!1:26 %in% external)[-(1:2)]) { - Test(internal) - } -}) - -test_that("SPR fails gracefully", { - skip_if(TRUE) - dput("SPR Grace 1") - expect_error(all_spr(as.phylo(1, 3)$edge, integer(0))) - dput("SPR Grace 2") - expect_error(all_spr(Postorder(as.phylo(1, 6))$edge, integer(0))) - dput("SPR Grace 3") - expect_error(all_spr(SortTree(as.phylo(1, 6))$edge, integer(0))) - dput("SPR Grace Completed.") -}) - -test_that("SPR works", { - dput(" - SPR1 ") - t2 <- as.phylo(518, 7) # (t1, ((t2, t3), ((t4, t5), (t6, t7)))) - expect_equal(8, length(all_spr(t2$edge, 2))) - - tr <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) - - dput(" - SPR Single tip ") - # Move single tip - expect_equal(8, length(all_spr(tr$edge, 12))) - expect_equal(8, length(all_spr(tr$edge, 11))) - expect_equal(8, length(all_spr(tr$edge, 10))) - expect_equal(8, length(all_spr(tr$edge, 7))) - expect_equal(8, length(all_spr(tr$edge, 6))) - expect_equal(8, length(all_spr(tr$edge, 3))) - expect_equal(8, length(all_spr(tr$edge, 2))) - - dput(" - SPR Cherry ") - # Move cherry - expect_equal(6, length(all_spr(tr$edge, 9))) - expect_equal(6, length(all_spr(tr$edge, 5))) - expect_equal(12, length(all_spr(tr$edge, c(9, 5)))) - - dput(" - SPR Bush ") - # Move more - expect_equal(0, length(unique(all_spr(tr$edge, 4)))) - expect_equal(4, length(unique(all_spr(tr$edge, 8)))) - - dput(" - SPR All ") - # All moves - expect_equal(7*8 + 2*6 + 4, length(all_spr(tr$edge, integer(0)))) - uniqueMoves <- length(unique(all_spr(tr$edge, integer(0)))) - expect_equal(54, # Not formally calculated - uniqueMoves) - expect_equal(uniqueMoves, length(SPRMoves(tr))) - - dput(" - SPR Clear ") - tr <- Preorder(root(TreeTools::BalancedTree(14), 't1', resolve.root = TRUE)) - tr$edge - desc <- TreeTools::CladeSizes(tr) - - external <- c(3, 6, 7, 11, 12, 13, 17, 18, 20, 21, 24:26) - # Move single - for (leaf in external) { - expect_equal(22, length(x <- all_spr(tr$edge, leaf))) - } - - Test <- function (edge) { - nDesc <- desc[tr$edge[edge, 2]] - expected <- (22 - (2 * nDesc - 3)) - 1 - expect_equal(expected, length(all_spr(tr$edge, edge))) - } - for (internal in which(!1:26 %in% external)[-(1:2)]) { - Test(internal) - } - - expect_equal(SPRMoves(tr)[[428]]$edge, SPRMoves(tr$edge)[[428]]) - - tr <- BalancedTree(7) - expect_equal(SPRMoves(tr)[[54]]$edge, SPRMoves(tr$edge)[[54]]) -}) - -# TODO Restore or delete -if (FALSE) test_that("SPR works", { - testTree <- Preorder(root(TreeTools::BalancedTree(7), 't1', resolve.root = TRUE)) - plot(testTree); nodelabels(); edgelabels() - edge <- testTree$edge - - t2 <- testTree - #t2$edge = root_on_node(edge, 11) - plot(t2) - - 1L + tbr_moves(edge) - - Test <- function (m, p1, r1) { - test.tr <- testTree - test.tr$edge <- spr(edge, m) - plot(test.tr) - - oldWay <- SortTree(root(SPR(testTree, p1, r1), 't1', resolve.root = TRUE)) - expect_equal(oldWay, SortTree(test.tr)) - } - Test(0, 1, 5) - Test(1, 1, 6) - Test(2, 1, 7) - Test(3, 1, 8) - Test(4, 1, 9) - Test(5, 1, 10) - Test(6, 1, 11) - Test(7, 1, 12) - - Test(8 , 3, 5) - Test(9 , 3, 6) - Test(10, 3, 7) - Test(11, 3, 8) - Test(12, 3, 9) - Test(13, 3, 10) - Test(14, 3, 11) - Test(15, 3, 12) - - + asan_error(matrix(9, 1, 1)) }) \ No newline at end of file diff --git a/tests/testthat/test-tree_length.R b/tests/testthat/test-tree_length.R deleted file mode 100644 index d3df7bab3..000000000 --- a/tests/testthat/test-tree_length.R +++ /dev/null @@ -1,270 +0,0 @@ -## Test cases designed by Thomas Guillerme - -test_that("Failures are graceful", { - library("TreeTools", quietly = TRUE) - data('inapplicable.datasets') - dat <- inapplicable.phyData[[1]] - unrooted <- RandomTree(dat, root = FALSE) - expect_error(TreeLength(unrooted, dat)) - - mo <- PhyDat2Morphy(dat) - on.exit(mo <- UnloadMorphy(mo)) - - sparse <- DropTip(RandomTree(dat, root = FALSE), 10) - expect_error(MorphyTreeLength(sparse, mo)) - expect_error(MorphyTreeLength(sparse, NA)) - - expect_error(MorphyLength(sparse$edge[, 1], sparse$edge[, 2], mo, nTaxa = 0)) - expect_error(MorphyLength(sparse$edge[, 1], sparse$edge[, 2], dat)) - - expect_null(TreeLength(NULL)) -}) - -test_that("Deprecations throw warning", { - data('inapplicable.datasets') - dat <- inapplicable.phyData[[1]] - tree <- TreeTools::RandomTree(dat, root = TRUE) - expect_equal(TreeLength(tree, dat), - expect_warning(Fitch(tree, dat))) - expect_equal(CharacterLength(tree, dat, compress = TRUE), - expect_warning(FitchSteps(tree, dat))) - -}) - -test_that("Morphy generates correct lengths", { - ## Tree - tree <- ape::read.tree(text = "((((((1,2),3),4),5),6),(7,(8,(9,(10,(11,12))))));") - relabel <- ape::read.tree(text = "((6,(5,(4,(3,(2,1))))),(7,(8,(9,(10,(11,12))))));") - trees <- list(tree, relabel) - characters <- c("23--1??--032", # 0, expect score = 5 - "1---1111---1", # 1, expect score = 2 - "1100----1100", # 2, expect score = 3 - "11-------100", # 3, expect score = 2 - "----1111---1", # 4, expect score = 1 - "01----010101", # 5, expect score = 5 - "01---1010101", # 6, expect score = 5 - "1??--??--100", # 7, expect score = 2 - "21--3??--032", # 8, expect score = 5 - "11--1??--111", # 9, expect score = 2 - "11--1000001-", # 10, expect score = 2 - "01------0101", # 11, expect score = 4 - "110--?---100", # 12, expect score = 3 - "11--1??--111", # 13, expect score = 2 - "210--100--21", # 14, expect score = 5 - "????----1???", # 15, expect score = 0 - "23--1----032", # 16, expect score = 5 - "1----1----1-", # 17, expect score = 2 - "-1-1-1--1-1-", # 18, expect score = 4 - "23--1??--032", # 19, expect score = 5 - "--------0101", # 20, expect score = 2 - "10101-----01", # 21, expect score = 4 - "011--?--0011", # 22, expect score = 3 - "110--??--100", # 23, expect score = 3 - "11--1000001-", # 24, expect score = 2 - "21--1----012", # 25, expect score = 5 - "11----111111", # 26, expect score = 1 - "10101-----01", # 27, expect score = 4 - "210210------", # 28, expect score = 4 - "----1111----", # 29, expect score = 0 - "230--??1--32", # 30, expect score = 5 - "023--??1--32", # 31, expect score = 5 - "023-???1--32", # 32, expect score = 4 - "23--1?1--023", # 33, expect score = 5 - "----1010----", # 34, expect score = 2 - "------11---1", # 35, expect score = 1 - "10----11---1", # 36, expect score = 3 - "320--??3--21", # 37, expect score = 5 - "000011110000" # 38, expect score = 2 - ) - ## Results - expected_results <- c(5, 2, 3, 2, 1, 5, 5, 2, 5, 2, 2, 4, 3, 2, 5, 0, 5, 2, - 4, 5, 2, 4, 3, 3, 2, 5, 1, 4, 4, 0, 5, 5, 4, 5, 2, 1, - 3, 5, 2) - expected_minLength <- c(3, 0, 1, 1, 0, 1, 1, 1, 3, 0, 1, 1, 1, 0, 2, 0, 3, 0, - 0, 3, 1, 1, 1, 1, 1, 2, 0, 1, 2, 0, 3, 3, 3, 3, 1, 0, - 1, 3, 1) - expected_homoplasies <- expected_results - expected_minLength - - ##plot(tree); nodelabels(12:22); tiplabels(0:11) - ## Run the tests - for(test in seq_along(characters)) { - morphyObj <- SingleCharMorphy(characters[test]) - tree_length <- MorphyTreeLength(tree, morphyObj) - morphyObj <- UnloadMorphy(morphyObj) - #if (tree_length != expected_results[test]) message("Test case", test - 1, characters[test], "unequal: Morphy calcluates", - # tree_length, "instead of", expected_results[test],"\n") - expect_equal(tree_length, expected_results[test]) - } - - ## Test combined matrix - bigPhy <- TreeTools::StringToPhyDat(paste0(characters, collapse = '\n'), - tree$tip.label, - byTaxon = FALSE) - profPhy <- TreeTools::StringToPhyDat(paste0(characters[-c(15, 29, 34)], - collapse = '\n'), - tree$tip.label, - byTaxon = FALSE) - expect_identical(characters, - TreeTools::PhyToString(bigPhy, byTaxon = FALSE, - concatenate = FALSE)) - expect_identical(paste0(collapse = '', - vapply(characters, substr, start = 0, stop = 1, - character(1))), - substr(TreeTools::PhyToString(bigPhy, ps = ';', - useIndex = TRUE, - byTaxon = TRUE, - concatenate = TRUE), - start = 0, stop = length(characters))) - - morphyObj <- PhyDat2Morphy(bigPhy) - moSummary <- summary(morphyObj) - expect_equal(c(length(bigPhy), attr(bigPhy, 'nr'), length(bigPhy) - 1), - c(moSummary$nTax, moSummary$nChar, moSummary$nInternal)) - tree_length <- MorphyTreeLength(tree, morphyObj) - morphyObj <- UnloadMorphy(morphyObj) - - expect_equal('0123', moSummary$allStates) - expect_equal(tree_length, sum(expected_results)) - expect_equal(tree_length, TreeLength(tree, bigPhy)) - expect_equal(tree_length, TreeLength(relabel, bigPhy)) - expect_equal(rep(tree_length, 2), TreeLength(trees, bigPhy)) - - expected_fit <- expected_homoplasies / (expected_homoplasies + 6) - tree_score_iw <- TreeLength(tree, bigPhy, concavity = 6) - expect_equal(sum(expected_fit), tree_score_iw) - expect_equal(tree_score_iw, TreeLength(relabel, bigPhy, concavity = 6)) - expect_equal(vapply(trees, TreeLength, double(1), bigPhy, concavity = 6), - TreeLength(trees, bigPhy, concavity = 6)) - - expect_equal(vapply(trees, TreeLength, double(1), profPhy, concavity = 'p'), - TreeLength(trees, profPhy, concavity = 'profile')) - - - ## Run the bigger tree tests - bigTree <- ape::read.tree( - text = "((1,2),((3,(4,5)),(6,(7,(8,(9,(10,((11,(12,(13,(14,15)))),(16,(17,(18,(19,20))))))))))));") - bigChars <- c("11111---111---11---1") - ## Results - expected_results <- c(3) - - ## Run the tests - for(test in 1:length(bigChars)) { - phy <- TreeTools::StringToPhyDat(bigChars[test], bigTree$tip.label) - # Presently a good test to confirm that PhyDat2Morphy works with single-character phys - morphyObj <- PhyDat2Morphy(phy) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - tree_length <- MorphyTreeLength(bigTree, morphyObj) - - expect_equal(tree_length, expected_results[test]) - } -}) - -test_that("(random) lists of trees are scored", { - data("congreveLamsdellMatrices", package = 'TreeSearch') - mat <- congreveLamsdellMatrices[[42]] - - # Expected values calculated from 100k samples - expect_gt(t.test(TreeLength(100, mat), mu = 318.5877)$p.val, 0.001) - expect_gt(t.test(TreeLength(100, mat, 10L), mu = 17.16911)$p.val, 0.001) - expect_gt(t.test(TreeLength(100, mat, 'profile'), mu = 830.0585)$p.val, 0.001) -}) - -test_that("TreeLength() handles subsetted trees", { - data('inapplicable.datasets') - dat <- inapplicable.phyData[[1]] - t8 <- as.phylo(1:4, 8, tipLabels = names(dat)[1:8]) - expect_equal(4, length(TreeLength(t8, dat))) -}) - -test_that("Profile scoring is reported correctly", { - data('congreveLamsdellMatrices') - dataset <- congreveLamsdellMatrices[[42]] - prepDataset <- PrepareDataProfile(dataset) - tree <- NJTree(prepDataset) - edge <- Preorder(tree)$edge - at <- attributes(prepDataset) - profiles <- attr(prepDataset, 'info.amounts') - charSeq <- seq_along(prepDataset[[1]]) - 1L - - characters <- PhyToString(prepDataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - startWeights <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1)), - add = TRUE) - - expect_equal(TreeLength(tree, dataset, 'profile'), - TreeLength(tree, prepDataset, 'profile')) - expect_equal(TreeLength(tree, dataset, 'profile'), - morphy_profile(edge, morphyObjects, startWeights, charSeq, - profiles, Inf)) -}) - -test_that("CharacterLength() fails gracefully", { - expect_error(CharacterLength(as.phylo(1, 8), 1)) - - data('inapplicable.datasets') - dataset <- inapplicable.phyData[[12]] - # Unlabelled leaves - expect_error(CharacterLength(structure(list(), class = 'phylo'), dataset)) - - # Missing leaves - expect_error(CharacterLength(as.phylo(1, 4), dataset)) - tMinus1 <- as.phylo(1, 42, tipLabels = names(dataset)[-1]) - expect_equal(CharacterLength(tMinus1, dataset[-1]), - CharacterLength(tMinus1, dataset)) - expect_error(CharacterLength(as.phylo(1, 43), dataset)) - tPlus1 <- as.phylo(1, 44, tipLabels = c('extra', names(dataset))) - expect_equal(CharacterLength(DropTip(tPlus1, 'extra'), dataset), - CharacterLength(tPlus1, dataset)) - expect_error(CharacterLength(as.phylo(1:2, 43, tipLabels = names(dataset)), - dataset)) - # no error: - CharacterLength(as.phylo(1, 43, tipLabels = names(dataset)), dataset) - - expect_equal(c(53, 59, 6), - as.numeric(table(CharacterLength(NJTree(dataset[1:4, ]), - dataset[1:4], compress = TRUE)))) - -}) - -test_that("Character compression works", { - data('inapplicable.datasets') - dataset <- inapplicable.phyData[[12]] - tree <- TreeTools::NJTree(dataset) - expect_equal(137, length(CharacterLength(tree, dataset))) - expect_equal(137, length(MinimumLength(dataset))) - expect_equal(137, length(Consistency(dataset, tree))) - expect_equal(118, length(CharacterLength(tree, dataset, compress = TRUE))) - expect_equal(118, length(MinimumLength(dataset, compress = TRUE))) - expect_equal(118, length(Consistency(dataset, tree, compress = TRUE))) -}) - -test_that("X_MorphyLength", { - dataset <- congreveLamsdellMatrices[[42]] - morphyObj <- PhyDat2Morphy(dataset) - on.exit(UnloadMorphy(morphyObj)) - nTaxa <- mpl_get_numtaxa(morphyObj) - - tree <- NJTree(dataset) - edgeList <- Postorder(Preorder(tree$edge)) - parent <- edgeList[, 1] - child <- edgeList[, 2] - - maxNode <- nTaxa + mpl_get_num_internal_nodes(morphyObj) - rootNode <- nTaxa + 1L - allNodes <- rootNode:maxNode - - parentOf <- parent[match(seq_len(maxNode), child)] - parentOf[rootNode] <- rootNode # Root node's parent is a dummy node - leftChild <- child[length(parent) + 1L - match(allNodes, rev(parent))] - rightChild <- child[match(allNodes, parent)] - - expected <- MorphyLength(parent, child, morphyObj) - - expect_equal(expected, - C_MorphyLength(parentOf, leftChild, rightChild, morphyObj)) - expect_equal(expected, - GetMorphyLength(parentOf - 1, leftChild - 1, rightChild - 1, - morphyObj)) -}) diff --git a/tests/testthat/test-zzz-tree-rearrange.R b/tests/testthat/test-zzz-tree-rearrange.R deleted file mode 100644 index 442ff3a74..000000000 --- a/tests/testthat/test-zzz-tree-rearrange.R +++ /dev/null @@ -1,270 +0,0 @@ -library("TreeTools") - -context("Tree rearrangements") -tree5a <- read.tree(text = '(a, (b, (c, (d, e))));') -tree5b <- read.tree(text = '((a, b), (c, (d, e)));') -tree6 <- Preorder(read.tree(text = "((a, (b, (c, d))), (e, f));")) -tree6b <- Preorder(read.tree(text = "((a, (b, c)), (d, (e, f)));")) -tree8 <- read.tree(text = "(((a, (b, (c, d))), (e, f)), (g, h));") -tree11 <- read.tree(text = "((((a, b), (c, d)), e), ((f, (g, (h, i))), (j, k)));") -attr(tree5a, 'order') <- attr(tree5b, 'order') <- attr(tree8, 'order') <- attr(tree11, 'order') <- 'preorder' - -test_that("Malformed trees don't crash anything", { - treeDoubleNode <- read.tree(text = "((((((1,2)),3),4),5),6);") - treePolytomy <- read.tree(text = "((((1,2,3),4),5),6);") - treeDoublyPoly <- read.tree(text = "(((((1,2,3)),4),5),6);") - - expect_error(NNI(treeDoubleNode)) - expect_error(NNI(treePolytomy)) - expect_error(NNI(treeDoublyPoly)) - - expect_error(SPR(treeDoubleNode)) - expect_error(SPR(treePolytomy)) - expect_error(SPR(treeDoublyPoly)) - - expect_error(TBR(treeDoubleNode)) - expect_error(TBR(treePolytomy)) - expect_error(TBR(treeDoublyPoly)) - -}) - -test_that("NNI works", { - trComb <- read.tree(text = "(((((1,2),3),4),5),6);") - edge <- trComb$edge - Test <- function (e, r, e1, e2) { - edge1 <- edge - edge1[c(e1, e2), 2] <- edge1[c(e2, e1), 2] - edge1 <- do.call(cbind, RenumberEdges(edge1[, 1], edge1[, 2])) - expect_equal(edge1, nni(trComb$edge, e, r)) - } - Test(0, 0, 5, 7) - Test(0, 2, 5, 7) - Test(3, 0, 5, 7) # Option 0 == option 3. - Test(0, 1, 6, 7) - Test(1, 0, 4, 8) - Test(1, 1, 7, 8) - Test(2, 0, 3, 9) - Test(2, 1, 8, 9) - - suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 - set.seed(0) - nniComb <- NNI(trComb) - expect_equal(nniComb$tip.label, trComb$tip.label) - expect_equal(nniComb$Nnode, trComb$Nnode) - expect_equal(nniComb, read.tree(text = "(((((3,2),1),4),5),6);")) -}) - - -test_that("SPR works", { - testTree <- Preorder(root(BalancedTree(7), 1, resolve.root = TRUE)) - edge <- testTree$edge - expect_equal(spr(edge, 66), cSPR(testTree, 66)$edge) - - Test <- function (m, p1, r1) { - test.tr <- testTree - test.tr$edge <- spr(edge, m) - - oldWay <- SortTree(root(SPR(testTree, p1, r1), 't1', resolve.root = TRUE)) - expect_equal(oldWay, SortTree(test.tr)) - } - Test(0, 1, 5) - Test(64, 1, 5) # Modulo 64! - Test(1, 1, 6) - Test(2, 1, 7) - Test(3, 1, 8) - Test(4, 1, 9) - Test(5, 1, 10) - Test(6, 1, 11) - Test(7, 1, 12) - - Test(8 , 3, 5) - Test(9 , 3, 6) - Test(10, 3, 7) - Test(11, 3, 8) - Test(12, 3, 9) - Test(13, 3, 10) - Test(14, 3, 11) - Test(15, 3, 12) - - Test(16, 5, 3) - Test(17, 5, 9) - Test(18, 5, 10) - Test(19, 5, 11) - Test(20, 5, 12) - - Test(28, 7, 3) - Test(29, 7, 4) - Test(30, 7, 8) - Test(31, 7, 9) - Test(32, 7, 10) - Test(33, 7, 11) - Test(34, 7, 12) - - Test(35, 8, 3) - Test(36, 8, 6) - Test(37, 8, 7) - Test(38, 9, 3) - Test(39, 9, 4) - Test(40, 9, 5) - Test(41, 9, 6) - Test(42, 9, 7) - Test(43, 10, 3) - Test(44, 10, 4) - Test(45, 10, 5) - Test(46, 10, 6) - Test(47, 10, 7) - Test(48, 10, 8) - Test(49, 10, 12) - Test(50, 11, 3) - Test(51, 11, 4) - Test(52, 11, 5) - Test(53, 11, 6) - Test(54, 11, 7) - Test(55, 11, 8) - Test(56, 11, 12) - Test(57, 12, 3) - Test(58, 12, 4) - Test(59, 12, 5) - Test(60, 12, 6) - Test(61, 12, 7) - Test(62, 12, 10) - Test(63, 12, 11) -}) - -test_that("TBR can swap over root", { - expect_equal(TBR(tree5a, 1, c(7, 1)), read.tree(text = '(a, (d, (e, (c, b))));')) - expect_equal(TBR(tree5a, 2, c(5, 1)), read.tree(text = '(a, (c, (b, (d, e))));')) - expect_equal(TBR(tree5b, 1, c(7, 1)), read.tree(text = '((a, b), (d, (c, e)));')) - expect_equal(TBR(tree5b, 4, c(7, 1)), read.tree(text = '((a, b), (d, (c, e)));')) -}) - -test_that("TBR works", { - tree <- tree8 - ### expect_equal(TBR(tree, 3, 1 ), read.tree(text = "((a, ((b, (c, d)), (e, f))), (g, h));")) - ### expect_warning(expect_identical(TBR(tree, 3, 2), tree)) - ### expect_warning(expect_identical(TBR(tree, 3, 3), tree)) - ### expect_warning(expect_identical(TBR(tree, 3, 4), tree)) - ### expect_warning(expect_identical(TBR(tree, 3, 44), tree)) - ### expect_equal(TBR(tree, 3, 5 ), read.tree(text = "((((a, b), (c, d)), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 6 ), read.tree(text = "(((b, (a, (c, d))), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 7 ), read.tree(text = "(((b, ((a, c), d)), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 8 ), read.tree(text = "(((b, (c, (a, d))), (e, f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 9 ), read.tree(text = "(((b, (c, d)), (a, (e, f))), (g, h));")) - ### expect_equal(TBR(tree, 3, 10), read.tree(text = "(((b, (c, d)), ((a, e), f)), (g, h));")) - ### expect_equal(TBR(tree, 3, 11), read.tree(text = "(((b, (c, d)), (e, (a, f))), (g, h));")) - ### expect_equal(TBR(tree, 3, 12), read.tree(text = "(((b, (c, d)), (e, f)), (a, (g, h)));")) - ### expect_equal(TBR(tree, 3, 13), read.tree(text = "(((b, (c, d)), (e, f)), ((g, a), h));")) - ### expect_equal(TBR(tree, 3, 14), read.tree(text = "(((b, (c, d)), (e, f)), (g, (a, h)));")) - - tree <- tree8 - expect_equal(TBR(tree, 6, c(1 , 6)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) - expect_equal(TBR(tree, 6, c(1 , 7)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) - expect_equal(TBR(tree, 6, c(1 , 8)), read.tree(text = "((((a, b), (e, f)), (c, d)), (g, h));")) - expect_equal(TBR(tree, 6, c(2 , 6)), TBR(tree, 6, c(2 , 7))) - expect_equal(TBR(tree, 6, c(2 , 6)), TBR(tree, 6, c(2 , 8))) - expect_equal(TBR(tree, 6, c(2 , 6)), read.tree(text = "((((a, b), (c, d)), (e, f)), (g, h));")) - expect_equal(TBR(tree, 6, c(3 , 6)), read.tree(text = "(((((c, d), a), b), (e, f)), (g, h));")) - expect_warning(expect_identical(TBR(tree, 6, c(4 , 6)), tree)) - expect_warning(expect_identical(TBR(tree, 8, c(6 , 8)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(5 , 6)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(6 , 6)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(6 , 7)), tree)) - expect_warning(expect_identical(TBR(tree, 6, c(6 , 8)), tree)) - expect_equal(TBR(tree, 6, c(9 , 6)), read.tree(text = "(((a, b), ((c, d), (e, f))), (g, h));")) - expect_equal(TBR(tree, 6, c(10, 6)), read.tree(text = "(((a, b), (((c, d), e), f)), (g, h));")) - expect_equal(TBR(tree, 6, c(11, 6)), read.tree(text = "(((a, b), (((c, d), f), e)), (g, h));")) - expect_equal(TBR(tree, 6, c(12, 6)), read.tree(text = "(((a, b), (e, f)), ((c, d), (g, h)));")) - expect_equal(TBR(tree, 6, c(13, 6)), read.tree(text = "(((a, b), (e, f)), (((c, d), g), h));")) - expect_equal(TBR(tree, 6, c(14, 6)), read.tree(text = "(((a, b), (e, f)), (((c, d), h), g));")) - expect_warning(expect_identical(TBR(tree, 6, c(6, 15)), tree)) - - expect_equal(TBR(tree, 4, c(1, 5)), read.tree(text = "(((a, (e, f)), (b, (c, d))), (g, h));")) - expect_equal(TBR(tree, 4, c(1, 6)), read.tree(text = "(((a, (e, f)), (b, (c, d))), (g, h));")) - expect_equal(TBR(tree, 4, c(1, 7)), read.tree(text = "(((a, (e, f)), (c, (b, d))), (g, h));")) - expect_equal(TBR(tree, 4, c(1, 8)), read.tree(text = "(((a, (e, f)), (d, (b, c))), (g, h));")) - - tree <- tree11 - tree$edge.length = rep.int(1, 20) - expect_equal(TBR(tree11, 11, c(8, 17)), read.tree(text = '((j, k), (e, ((a, b), (c, (d, (i, (h, (g, f))))))));')) - expect_equal(TBR(tree11, 11, c(2, 11)), read.tree(text = '((j, k), (e, (((a, b), (c, d)), (f, (g, (i, h))))));')) - expect_warning(TBR(tree11, 10, c(2, 11))) - expect_equal(TBR(tree11, 10, c(3, 11)), read.tree(text = '(e, ((c, d), ((a, b), ((j, k), (f, (g, (h, i)))))));')) - -}) - -test_that("RootedTBR fails", { - # tree8 <- read.tree(text = "(((a, (b, (c, d))), (e, f)), (g, h));") - # tree11 <- read.tree(text = "((((a, b), (c, d)), e), ((f, (g, (h, i))), (j, k)));") - - expect_equal(TBR(tree8, 4, c(3, 7)), RootedTBR(tree8, 4, c(3, 7))) - expect_equal(TBR(tree8, 4, c(1, 5)), RootedTBR(tree8, 4, c(1, 5))) - expect_warning(RootedTBR(tree5a, edgeToBreak = 1)) - expect_warning(RootedTBR(tree5a, edgeToBreak = 2)) - expect_equal(RootedTBR(tree5a, edgeToBreak = 3, mergeEdges=6), read.tree(text = '(a, (c, (b, (d, e))));')) - expect_silent(replicate(100, RootedTBR(tree5a))) - expect_warning(RootedTBR(tree8, 4, c(13, 6))) - expect_warning(RootedTBR(read.tree(text = '((a, b), (c, d));'))) -}) - -test_that("RootedSPR fails", { - expect_warning(RootedSPR(read.tree(text = '((a, b), (c, d));'))) - expect_warning(RootedSPR(tree8, edgeToBreak=1)) - expect_warning(RootedSPR(tree8, edgeToBreak=13)) - expect_warning(RootedSPR(tree8, edgeToBreak=14)) - warnTree1 <- read.tree(text = '((a, (b, (c, d))), (e, (f, (g, h))));') - warnTree2 <- read.tree(text = '((a, (b, (c, d))), (((e, f), g), h));') - attr(warnTree1, 'order') <- attr(warnTree2, 'order') <- 'preorder' - expect_warning(RootedSPR(warnTree1, 3)) - expect_warning(RootedSPR(warnTree1, 10)) - expect_warning(RootedSPR(warnTree2, 9)) - expect_warning(RootedSPR(warnTree2, 8)) -}) - -test_that("SPR is special case of TBR", { - expect_equal(SPR(tree11, 3, 9), TBR(tree11, 3, c(3, 9))) - expect_equal(SPR(tree11, 12, 9), TBR(tree11, 12, c(12, 9))) - expect_equal(root(SPR(tree11, 1, 14), letters[1:5], resolve.root=TRUE), TBR(tree11, 1, c(1, 14))) - expect_error(SPR(tree11, 1, 6)) -}) - -#' @author Martin R. Smith -CheckTreeSanity <- function (tree) { - nTip <- length(tree$tip.label) - nNode <- tree$Nnode - edge <- tree$edge - parent <- edge[, 1] - child <- edge[, 2] - aok <- TRUE - expect_true(all(parent > nTip), - info=paste0("Parent nodes on edge(s) ", paste(which(parent <= nTip), collapse=', '), - " are tips (nTip = ", nTip, ')') - ) - expect_equal(min(parent), nTip + 1, - info=paste0("Root is numbered ", min(parent), "; expecting ", nTip + 1) - ) - expect_false(min(parent) %in% child, - info=paste0("Root node (", min(parent), ") is child of edge ", paste0(which(min(parent) == child), collapse=', ')) - ) - expect_true(all(seq_len(nTip) %in% child)) # No missing tips - expect_equal(max(parent), nTip + nNode) - tips <- child <= nTip - expect_equal(sum(tips), nTip) - expect_true(all(child[!tips] > parent[!tips]), info="Parent nodes must be > child nodes") -} - -suppressWarnings(RNGversion("3.5.0")) # Until we can require R3.6.0 -set.seed(0) -small_tree <- rtree(8) -large_tree <- rtree(80) -test_that("NNI trees conform to phylo expectations", { - for (i in 1:60) CheckTreeSanity(small_tree <- NNI(small_tree)) - for (i in 1:250) CheckTreeSanity(large_tree <- NNI(large_tree)) -}) -test_that("SPR trees conform to phylo expectations", { - for (i in 1:60) CheckTreeSanity(small_tree <- SPR(small_tree)) - for (i in 1:250) CheckTreeSanity(large_tree <- SPR(large_tree)) -}) -test_that("TBR trees conform to phylo expectations", { - for (i in 1:60) CheckTreeSanity(small_tree <- TBR(small_tree)) - for (i in 1:250) CheckTreeSanity(large_tree <- TBR(large_tree)) -}) From fdae4c4bf4672ce1430a543ee115501628eccb13 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 09:07:06 +0100 Subject: [PATCH 21/28] return --- src/rearrange.cpp | 1 + 1 file changed, 1 insertion(+) diff --git a/src/rearrange.cpp b/src/rearrange.cpp index 321c712c4..9d7a81415 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -323,6 +323,7 @@ inline IntegerMatrix fuse(const IntegerMatrix& tree_bits, // [[Rcpp::export]] List asan_error (const IntegerMatrix x) { Rf_error("Oh dear."); + return List::create(); } // Assumptions: From d7be9ca187533f45e7de89da592ecd1eab0a000f Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 09:32:09 +0100 Subject: [PATCH 22/28] Minimize example --- NAMESPACE | 193 ----- R/AdditionTree.R | 95 --- R/Bootstrap.R | 53 -- R/Concordance.R | 371 --------- R/CustomSearch.R | 183 ----- R/IWScore.R | 14 - R/ImposeConstraint.R | 0 R/Jackknife.R | 146 ---- R/MaximizeParsimony.R | 855 -------------------- R/NNI.R | 236 ------ R/PlotCharacter.R | 401 ---------- R/RandomTreeScore.R | 53 -- R/Ratchet.R | 276 ------- R/RcppExports.R | 40 - R/ReleaseQuestions.R | 15 - R/SPR.R | 392 ---------- R/Sectorial.R | 260 ------- R/SuccessiveApproximations.R | 143 ---- R/TBR.R | 403 ---------- R/TreeSearch_utilities.R | 13 - R/ci-ri.R | 37 - R/data_manipulation.R | 392 ---------- R/mpl_morphy_objects.R | 276 ------- R/mpl_morphyex.R | 505 ------------ R/mpl_visualise.R | 130 ---- R/pp_info_extra_step.r | 297 ------- R/tree_length.R | 358 --------- R/tree_rearrangement.R | 114 --- R/zzz.R | 28 +- man/AdditionTree.Rd | 46 -- man/AllSPR.Rd | 37 - man/Carter1.Rd | 45 -- man/CharacterLength.Rd | 59 -- man/ConcordantInformation.Rd | 56 -- man/Consistency.Rd | 44 -- man/DoubleNNI.Rd | 30 - man/GapHandler.Rd | 65 -- man/JackLabels.Rd | 67 -- man/Jackknife.Rd | 94 --- man/MaximizeParsimony.Rd | 256 ------ man/MinimumLength.Rd | 82 -- man/MorphyErrorCheck.Rd | 49 -- man/MorphyTreeLength.Rd | 85 -- man/MorphyWeights.Rd | 85 -- man/NNI.Rd | 117 --- man/PhyDat2Morphy.Rd | 73 -- man/PlotCharacter.Rd | 89 --- man/PrepareDataProfile.Rd | 69 -- man/RandomMorphyTree.Rd | 29 - man/RandomTreeScore.Rd | 32 - man/Ratchet.Rd | 220 ------ man/RearrangeEdges.Rd | 79 -- man/SPR.Rd | 115 --- man/SingleCharMorphy.Rd | 65 -- man/SiteConcordance.Rd | 78 -- man/StepInformation.Rd | 47 -- man/StopUnlessBifurcating.Rd | 23 - man/Suboptimality.Rd | 20 - man/SuccessiveApproximations.Rd | 70 -- man/TBR.Rd | 111 --- man/TBRWarning.Rd | 38 - man/TreeLength.Rd | 87 --- man/TreeSearch.Rd | 150 ---- man/UnloadMorphy.Rd | 60 -- man/WithOneExtraStep.Rd | 18 - man/cSPR.Rd | 32 - man/dot-CombineResults.Rd | 34 - man/dot-GapHandler.Rd | 19 - man/dot-UniqueExceptHits.Rd | 15 - man/is.morphyPtr.Rd | 57 -- man/mpl_apply_tipdata.Rd | 58 -- man/mpl_attach_rawdata.Rd | 60 -- man/mpl_attach_symbols.Rd | 64 -- man/mpl_delete_Morphy.Rd | 56 -- man/mpl_delete_rawdata.Rd | 56 -- man/mpl_first_down_recon.Rd | 67 -- man/mpl_first_up_recon.Rd | 69 -- man/mpl_get_charac_weight.Rd | 58 -- man/mpl_get_gaphandl.Rd | 55 -- man/mpl_get_num_charac.Rd | 55 -- man/mpl_get_num_internal_nodes.Rd | 57 -- man/mpl_get_numtaxa.Rd | 55 -- man/mpl_get_symbols.Rd | 58 -- man/mpl_init_Morphy.Rd | 61 -- man/mpl_new_Morphy.Rd | 59 -- man/mpl_second_down_recon.Rd | 70 -- man/mpl_second_up_recon.Rd | 70 -- man/mpl_set_charac_weight.Rd | 59 -- man/mpl_set_num_internal_nodes.Rd | 59 -- man/mpl_set_parsim_t.Rd | 62 -- man/mpl_translate_error.Rd | 59 -- man/mpl_update_lower_root.Rd | 65 -- man/mpl_update_tip.Rd | 70 -- man/profiles.Rd | 6 - man/summary.morphyPtr.Rd | 56 -- src/RMorphy.c | 351 --------- src/RMorphy.h | 36 - src/RMorphyUtils.c | 40 - src/RMorphyUtils.h | 9 - src/RcppExports.cpp | 137 +--- src/TreeSearch-init.c | 71 -- src/build_postorder.h | 184 ----- src/fitch.c | 1052 ------------------------- src/fitch.h | 51 -- src/morphy.c | 1126 --------------------------- src/morphy.h | 63 -- src/morphy_score.cpp | 226 ------ src/morphydefs.h | 213 ----- src/mpl.c | 1038 ------------------------ src/mpl.h | 827 -------------------- src/mplerror.h | 54 -- src/rearrange.cpp | 628 --------------- src/statedata.c | 738 ------------------ src/statedata.h | 51 -- src/wagner.c | 121 --- src/wagner.h | 19 - tests/testthat/test-rearrange.cpp.R | 2 +- 117 files changed, 11 insertions(+), 17616 deletions(-) delete mode 100644 R/AdditionTree.R delete mode 100644 R/Bootstrap.R delete mode 100644 R/Concordance.R delete mode 100644 R/CustomSearch.R delete mode 100644 R/IWScore.R delete mode 100644 R/ImposeConstraint.R delete mode 100644 R/Jackknife.R delete mode 100644 R/MaximizeParsimony.R delete mode 100644 R/NNI.R delete mode 100644 R/PlotCharacter.R delete mode 100644 R/RandomTreeScore.R delete mode 100644 R/Ratchet.R delete mode 100644 R/ReleaseQuestions.R delete mode 100644 R/SPR.R delete mode 100644 R/Sectorial.R delete mode 100644 R/SuccessiveApproximations.R delete mode 100644 R/TBR.R delete mode 100644 R/TreeSearch_utilities.R delete mode 100644 R/ci-ri.R delete mode 100644 R/data_manipulation.R delete mode 100644 R/mpl_morphy_objects.R delete mode 100644 R/mpl_morphyex.R delete mode 100644 R/mpl_visualise.R delete mode 100644 R/pp_info_extra_step.r delete mode 100644 R/tree_length.R delete mode 100644 R/tree_rearrangement.R delete mode 100644 man/AdditionTree.Rd delete mode 100644 man/AllSPR.Rd delete mode 100644 man/Carter1.Rd delete mode 100644 man/CharacterLength.Rd delete mode 100644 man/ConcordantInformation.Rd delete mode 100644 man/Consistency.Rd delete mode 100644 man/DoubleNNI.Rd delete mode 100644 man/GapHandler.Rd delete mode 100644 man/JackLabels.Rd delete mode 100644 man/Jackknife.Rd delete mode 100644 man/MaximizeParsimony.Rd delete mode 100644 man/MinimumLength.Rd delete mode 100644 man/MorphyErrorCheck.Rd delete mode 100644 man/MorphyTreeLength.Rd delete mode 100644 man/MorphyWeights.Rd delete mode 100644 man/NNI.Rd delete mode 100644 man/PhyDat2Morphy.Rd delete mode 100644 man/PlotCharacter.Rd delete mode 100644 man/PrepareDataProfile.Rd delete mode 100644 man/RandomMorphyTree.Rd delete mode 100644 man/RandomTreeScore.Rd delete mode 100644 man/Ratchet.Rd delete mode 100644 man/RearrangeEdges.Rd delete mode 100644 man/SPR.Rd delete mode 100644 man/SingleCharMorphy.Rd delete mode 100644 man/SiteConcordance.Rd delete mode 100644 man/StepInformation.Rd delete mode 100644 man/StopUnlessBifurcating.Rd delete mode 100644 man/Suboptimality.Rd delete mode 100644 man/SuccessiveApproximations.Rd delete mode 100644 man/TBR.Rd delete mode 100644 man/TBRWarning.Rd delete mode 100644 man/TreeLength.Rd delete mode 100644 man/TreeSearch.Rd delete mode 100644 man/UnloadMorphy.Rd delete mode 100644 man/WithOneExtraStep.Rd delete mode 100644 man/cSPR.Rd delete mode 100644 man/dot-CombineResults.Rd delete mode 100644 man/dot-GapHandler.Rd delete mode 100644 man/dot-UniqueExceptHits.Rd delete mode 100644 man/is.morphyPtr.Rd delete mode 100644 man/mpl_apply_tipdata.Rd delete mode 100644 man/mpl_attach_rawdata.Rd delete mode 100644 man/mpl_attach_symbols.Rd delete mode 100644 man/mpl_delete_Morphy.Rd delete mode 100644 man/mpl_delete_rawdata.Rd delete mode 100644 man/mpl_first_down_recon.Rd delete mode 100644 man/mpl_first_up_recon.Rd delete mode 100644 man/mpl_get_charac_weight.Rd delete mode 100644 man/mpl_get_gaphandl.Rd delete mode 100644 man/mpl_get_num_charac.Rd delete mode 100644 man/mpl_get_num_internal_nodes.Rd delete mode 100644 man/mpl_get_numtaxa.Rd delete mode 100644 man/mpl_get_symbols.Rd delete mode 100644 man/mpl_init_Morphy.Rd delete mode 100644 man/mpl_new_Morphy.Rd delete mode 100644 man/mpl_second_down_recon.Rd delete mode 100644 man/mpl_second_up_recon.Rd delete mode 100644 man/mpl_set_charac_weight.Rd delete mode 100644 man/mpl_set_num_internal_nodes.Rd delete mode 100644 man/mpl_set_parsim_t.Rd delete mode 100644 man/mpl_translate_error.Rd delete mode 100644 man/mpl_update_lower_root.Rd delete mode 100644 man/mpl_update_tip.Rd delete mode 100644 man/summary.morphyPtr.Rd delete mode 100644 src/RMorphy.c delete mode 100644 src/RMorphy.h delete mode 100644 src/RMorphyUtils.c delete mode 100644 src/RMorphyUtils.h delete mode 100644 src/TreeSearch-init.c delete mode 100644 src/build_postorder.h delete mode 100644 src/fitch.c delete mode 100644 src/fitch.h delete mode 100644 src/morphy.c delete mode 100644 src/morphy.h delete mode 100644 src/morphy_score.cpp delete mode 100644 src/morphydefs.h delete mode 100644 src/mpl.c delete mode 100644 src/mpl.h delete mode 100644 src/mplerror.h delete mode 100644 src/statedata.c delete mode 100644 src/statedata.h delete mode 100644 src/wagner.c delete mode 100644 src/wagner.h diff --git a/NAMESPACE b/NAMESPACE index f067b902e..17bed8b09 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,196 +1,3 @@ # Generated by roxygen2: do not edit by hand -S3method(MinimumLength,numeric) -S3method(MinimumLength,phyDat) -S3method(SPRMoves,matrix) -S3method(SPRMoves,phylo) -S3method(TBRMoves,matrix) -S3method(TBRMoves,phylo) -S3method(TreeLength,"NULL") -S3method(TreeLength,list) -S3method(TreeLength,multiPhylo) -S3method(TreeLength,numeric) -S3method(TreeLength,phylo) -S3method(summary,morphyPtr) -export(.UniqueExceptHits) -export(AdditionTree) -export(C_MorphyLength) -export(Carter1) -export(CharacterLength) -export(ClusteringConcordance) -export(ConcordantInfo) -export(ConcordantInformation) -export(Consistency) -export(DoNothing) -export(EasyTrees) -export(EasyTreesy) -export(EdgeListSearch) -export(EmptyPhyDat) -export(Evaluate) -export(Fitch) -export(FitchSteps) -export(GapHandler) -export(GetMorphyLength) -export(IWScore) -export(IWTreeSearch) -export(JackLabels) -export(Jackknife) -export(Log2Carter1) -export(LogCarter1) -export(MaximizeParsimony) -export(MinimumLength) -export(MorphyBootstrap) -export(MorphyErrorCheck) -export(MorphyLength) -export(MorphyTreeLength) -export(MorphyWeights) -export(MultiRatchet) -export(MutualClusteringConcordance) -export(NNI) -export(NNISwap) -export(PhyDat2Morphy) -export(PhylogeneticConcordance) -export(PlotCharacter) -export(PrepareDataIW) -export(PrepareDataProfile) -export(QuartetConcordance) -export(RandomMorphyTree) -export(RandomTreeScore) -export(Ratchet) -export(RatchetConsensus) -export(RearrangeEdges) -export(Resample) -export(RootedNNI) -export(RootedNNISwap) -export(RootedSPR) -export(RootedSPRSwap) -export(RootedTBR) -export(RootedTBRSwap) -export(SPR) -export(SPRMoves) -export(SPRSwap) -export(SPRWarning) -export(SetMorphyWeights) -export(SharedPhylogeneticConcordance) -export(SingleCharMorphy) -export(StepInformation) -export(StopUnlessBifurcating) -export(Suboptimality) -export(SuccessiveApproximations) -export(SuccessiveWeights) -export(TBR) -export(TBRMoves) -export(TBRSwap) -export(TBRWarning) -export(TreeLength) -export(TreeSearch) -export(UnloadMorphy) -export(WithOneExtraStep) -export(cNNI) -export(cSPR) -export(is.morphyPtr) -export(mpl_apply_tipdata) -export(mpl_attach_rawdata) -export(mpl_attach_symbols) -export(mpl_delete_Morphy) -export(mpl_delete_rawdata) -export(mpl_first_down_recon) -export(mpl_first_up_recon) -export(mpl_get_charac_weight) -export(mpl_get_gaphandl) -export(mpl_get_num_charac) -export(mpl_get_num_internal_nodes) -export(mpl_get_numtaxa) -export(mpl_get_symbols) -export(mpl_init_Morphy) -export(mpl_new_Morphy) -export(mpl_second_down_recon) -export(mpl_second_up_recon) -export(mpl_set_charac_weight) -export(mpl_set_gaphandl) -export(mpl_set_num_internal_nodes) -export(mpl_set_parsim_t) -export(mpl_translate_error) -export(mpl_update_lower_root) -export(mpl_update_tip) -importFrom(Rcpp,compileAttributes) -importFrom(Rdpack,reprompt) -importFrom(Rogue,ColByStability) -importFrom(TreeDist,ClusteringEntropy) -importFrom(TreeDist,ClusteringInfo) -importFrom(TreeDist,ClusteringInfoDistance) -importFrom(TreeDist,Entropy) -importFrom(TreeDist,MutualClusteringInfo) -importFrom(TreeDist,SharedPhylogeneticInfo) -importFrom(TreeTools,AddTipEverywhere) -importFrom(TreeTools,AddUnconstrained) -importFrom(TreeTools,CharacterInformation) -importFrom(TreeTools,CladisticInfo) -importFrom(TreeTools,CompatibleSplits) -importFrom(TreeTools,ConstrainedNJ) -importFrom(TreeTools,DescendantEdges) -importFrom(TreeTools,DoubleFactorial) -importFrom(TreeTools,DropTip) -importFrom(TreeTools,EdgeAncestry) -importFrom(TreeTools,ImposeConstraint) -importFrom(TreeTools,KeepTip) -importFrom(TreeTools,Log2DoubleFactorial) -importFrom(TreeTools,Log2Unrooted) -importFrom(TreeTools,Log2UnrootedMult) -importFrom(TreeTools,LogDoubleFactorial) -importFrom(TreeTools,MakeTreeBinary) -importFrom(TreeTools,MatrixToPhyDat) -importFrom(TreeTools,NRooted) -importFrom(TreeTools,NTip) -importFrom(TreeTools,NUnrooted) -importFrom(TreeTools,NUnrootedMult) -importFrom(TreeTools,NonDuplicateRoot) -importFrom(TreeTools,PectinateTree) -importFrom(TreeTools,PhyDatToMatrix) -importFrom(TreeTools,PhyToString) -importFrom(TreeTools,Postorder) -importFrom(TreeTools,Preorder) -importFrom(TreeTools,RandomTree) -importFrom(TreeTools,Renumber) -importFrom(TreeTools,RenumberEdges) -importFrom(TreeTools,RenumberTips) -importFrom(TreeTools,RenumberTree) -importFrom(TreeTools,RootTree) -importFrom(TreeTools,SampleOne) -importFrom(TreeTools,SplitFrequency) -importFrom(TreeTools,Subsplit) -importFrom(TreeTools,SupportColour) -importFrom(TreeTools,TipLabels) -importFrom(TreeTools,TreeIsRooted) -importFrom(TreeTools,as.Splits) -importFrom(TreeTools,as.multiPhylo) -importFrom(ape,consensus) -importFrom(ape,keep.tip) -importFrom(ape,nodelabels) -importFrom(ape,plot.phylo) -importFrom(ape,root) -importFrom(cli,cli_alert) -importFrom(cli,cli_alert_danger) -importFrom(cli,cli_alert_info) -importFrom(cli,cli_alert_success) -importFrom(cli,cli_alert_warning) -importFrom(cli,cli_h1) -importFrom(cli,cli_progress_bar) -importFrom(cli,cli_progress_done) -importFrom(cli,cli_progress_update) -importFrom(cluster,pam) -importFrom(cluster,silhouette) -importFrom(fastmatch,"%fin%") -importFrom(fastmatch,fmatch) -importFrom(future,future) -importFrom(graphics,par) -importFrom(phangorn,Descendants) -importFrom(phangorn,phyDat) -importFrom(promises,future_promise) -importFrom(protoclust,protoclust) -importFrom(shiny,runApp) -importFrom(shinyjs,useShinyjs) -importFrom(stats,runif) -importFrom(stats,setNames) -importFrom(utils,combn) useDynLib(TreeSearch, .registration = TRUE) diff --git a/R/AdditionTree.R b/R/AdditionTree.R deleted file mode 100644 index 32d4f200c..000000000 --- a/R/AdditionTree.R +++ /dev/null @@ -1,95 +0,0 @@ -#' Addition tree -#' -#' Generates a starting tree by adding each taxon in turn to the most -#' parsimonious location. -#' -#' @inheritParams MaximizeParsimony -#' @param sequence Character or numeric vector listing sequence in which to add -#' taxa. Randomized if not provided. -#' @examples -#' data('Lobo', package = 'TreeTools') -#' AdditionTree(Lobo.phy, concavity = 10) -#' @template MRS -#' @return `AdditionTree()` returns a tree of class `phylo`, rooted on -#' `sequence[1]`. -#' @importFrom TreeTools AddUnconstrained AddTipEverywhere PectinateTree -#' @importFrom cli cli_progress_bar cli_progress_update -#' @family tree generation functions -#' @export -AdditionTree <- function (dataset, concavity = Inf, constraint, sequence) { - # Initialize missing parameters - taxa <- names(dataset) - if (missing(sequence)) { - sequence <- taxa[1] - } else if (is.numeric(sequence)) { - sequence <- taxa[sequence] - } - nTaxa <- length(taxa) - if (length(taxa) < 4) { - return(PectinateTree(taxa)) - } - unlisted <- setdiff(taxa, sequence) - if (length(unlisted) > 0) { - sequence <- c(sequence, sample(unlisted)) - } - if (!missing(constraint)) { - constraint <- AddUnconstrained(constraint, taxa) - } - # PrepareDataXXX attributes only valid for full dataset - attr(dataset, 'info.amounts') <- NULL - attr(dataset, 'min.length') <- NULL - attr(dataset, 'informative') <- NULL - - # Starting tree, rooted on first element in sequence - tree <- PectinateTree(sequence[1:3]) - - cli_progress_bar('Addition tree', total = sum(2 * (4:nTaxa) - 5)) - for (addition in sequence[4:nTaxa]) { - candidates <- AddTipEverywhere(tree, addition) - nCands <- length(candidates) - - theseTaxa <- candidates[[1]]$tip.label - theseData <- .Recompress(dataset[theseTaxa]) - if (is.finite(concavity)) { - theseData <- PrepareDataIW(theseData) - } else if (is.character(concavity)) { - theseData <- suppressMessages(PrepareDataProfile(theseData)) - } - - if (!missing(constraint)) { - thisConstr <- constraint[theseTaxa] - morphyConstr <- PhyDat2Morphy(thisConstr) - # Calculate constraint minimum score - constraintLength <- sum(MinimumLength(thisConstr, compress = TRUE) * - attr(thisConstr, 'weight')) - - .Forbidden <- function (edges) { - preorder_morphy(edges, morphyConstr) != constraintLength - } - - - candidates <- candidates[!vapply(lapply(candidates, `[[`, 'edge'), - .Forbidden, logical(1))] - UnloadMorphy(morphyConstr) - } - - # Score remaining candidates - if (length(theseData)) { - scores <- TreeLength(candidates, theseData, concavity) - minScore <- which.min(scores) - nMin <- length(minScore) - if (nMin > 1) { - minScore <- minScore[sample.int(nMin, 1)] - } - tree <- candidates[[minScore]] - } else { - tree <- sample(candidates, 1)[[1]] - } - cli_progress_update(nCands) - } - tree -} - -.Recompress <- function (dataset) { - MatrixToPhyDat(PhyDatToMatrix(dataset)) -} diff --git a/R/Bootstrap.R b/R/Bootstrap.R deleted file mode 100644 index 5f1723272..000000000 --- a/R/Bootstrap.R +++ /dev/null @@ -1,53 +0,0 @@ -#' @template edgeListParam -#' @template morphyObjParam -#' @template EdgeSwapperParam -#' @param maxIter Numeric specifying maximum number of iterations to perform in -#' tree search. -#' @param maxHits Numeric specifying maximum number of hits to accomplish in -#' tree search. -#' @template stopAtPeakParam -#' @template stopAtPlateauParam -#' @template verbosityParam -#' @param \dots further parameters to send to `TreeScorer()` -#' -#' @return `MorphyBootstrap()` returns a tree that is optimal under a random -#' sampling of the original characters. -#' -#' @rdname Ratchet -#' @export -MorphyBootstrap <- function (edgeList, morphyObj, EdgeSwapper = NNISwap, - maxIter, maxHits, verbosity = 1L, - stopAtPeak = FALSE, stopAtPlateau=0L, ...) { - startWeights <- MorphyWeights(morphyObj)['exact', ] - eachChar <- seq_along(startWeights) - deindexedChars <- rep.int(eachChar, startWeights) - resampling <- tabulate(sample(deindexedChars, replace = TRUE), - length(startWeights)) - errors <- vapply(eachChar, function (i) - mpl_set_charac_weight(i, resampling[i], morphyObj), integer(1)) - - if (any(errors)) { # nocov start - stop ("Error resampling morphy object: ", - mpl_translate_error(unique(errors[errors < 0L]))) - } - if (mpl_apply_tipdata(morphyObj) -> error) { - stop("Error applying tip data: ", mpl_translate_error(error)) - } # nocov end - - res <- EdgeListSearch(edgeList[1:2], morphyObj, EdgeSwapper = EdgeSwapper, - maxIter = maxIter, maxHits = maxHits, - stopAtPeak = stopAtPeak, stopAtPlateau = stopAtPlateau, - verbosity = verbosity - 1L, ...) - errors <- vapply(eachChar, function (i) - mpl_set_charac_weight(i, startWeights[i], morphyObj), integer(1)) - if (any(errors)) { # nocov start - stop ("Error resampling morphy object: ", - mpl_translate_error(unique(errors[errors < 0L]))) - } - if (mpl_apply_tipdata(morphyObj) -> error) { - stop("Error applying tip data: ", mpl_translate_error(error)) - } # nocov end - - # Return: - res[1:2] -} diff --git a/R/Concordance.R b/R/Concordance.R deleted file mode 100644 index a32d9d9e5..000000000 --- a/R/Concordance.R +++ /dev/null @@ -1,371 +0,0 @@ -#' Calculate site concordance factor -#' -#' The site concordance factor \insertCite{Minh2020}{TreeSearch} is a measure -#' of the strength of support that the dataset presents for a given split in a -#' tree. -#' -#' `QuartetConcordance()` is the proportion of quartets (sets of four leaves) -#' that are decisive for a split which are also concordant with it. -#' For example, a quartet with the characters `0 0 0 1` is not decisive, as -#' all relationships between those leaves are equally parsimonious. -#' But a quartet with characters `0 0 1 1` is decisive, and is concordant -#' with any tree that groups the first two leaves together to the exclusion -#' of the second. -#' -# `ClusteringConcordance()` and `PhylogeneticConcordance()` respectively report -# the proportion of clustering information and phylogenetic information -# \insertCite{@as defined in @Vinh2010, @SmithDist}{TreeDist} within a dataset -# that is reflected in each split. -# These give smaller values because a split may be compatible with a character -# without being identical to it. -#TODO More thought / explanation needed. -#' -#TODO Finally, `ProfileConcordance()` (to follow) -#' -#' NOTE: These functions are under development, and may be incompletely tested -#' or change without notice. -#' Complete documentation and discussion will follow soon. -#' -#' @template treeParam -#' @template datasetParam -#' -#' -#' -#' @references -#' \insertAllCited{} -#' -#' @examples -#' data('congreveLamsdellMatrices', package = 'TreeSearch') -#' dataset <- congreveLamsdellMatrices[[1]][, 1:20] -#' tree <- referenceTree -#' qc <- QuartetConcordance(tree, dataset) -#' cc <- ClusteringConcordance(tree, dataset) -#' pc <- PhylogeneticConcordance(tree, dataset) -#' spc <- SharedPhylogeneticConcordance(tree, dataset) -#' mcc <- MutualClusteringConcordance(tree, dataset) -#' -#' oPar <- par(mar = rep(0, 4), cex = 0.8) -#' plot(tree) -#' TreeTools::LabelSplits(tree, signif(qc, 3)) -#' TreeTools::LabelSplits(tree, signif(cc, 3)) -#' TreeTools::LabelSplits(tree, signif(pc, 3)) -#' par(oPar) -#' -#' pairs(cbind(qc, cc, pc, spc, mcc)) -#' @template MRS -#' @importFrom ape keep.tip -#' @importFrom cli cli_progress_bar cli_progress_update -#' @importFrom utils combn -#' @importFrom TreeTools as.Splits PhyDatToMatrix TipLabels -#' @name SiteConcordance -#' @family split support functions -#' @export -QuartetConcordance <- function (tree, dataset) { - dataset <- dataset[tree$tip.label] - splits <- as.Splits(tree, dataset) - logiSplits <- vapply(seq_along(splits), function (i) as.logical(splits[[i]]), - logical(NTip(dataset))) - - characters <- .TMP_PhyDatToMatrix(dataset, ambigNA = TRUE) - - cli_progress_bar(name = 'Quartet concordance', total = dim(logiSplits)[2]) - setNames(apply(logiSplits, 2, function (split) { - cli_progress_update(1, .envir = parent.frame(2)) - quarts <- rowSums(apply(characters, 2, function (char) { - tab <- table(split, char) - nCol <- dim(tab)[2] - if (nCol > 1L) { - concordant <- sum(vapply(seq_len(nCol), function (i) { - inBinI <- tab[1, i] - iChoices <- choose(inBinI, 2) - sum(vapply(seq_len(nCol)[-i], function (j) { - inBinJ <- tab[2, j] - iChoices * choose(inBinJ, 2) - }, 1)) - }, 1)) - discordant <- sum(apply(combn(nCol, 2), 2, function (ij) prod(tab[, ij]))) - decisive <- concordant + discordant - c(concordant, decisive) - } else { - c(0L, 0L) - } - })) - ifelse(is.nan(quarts[2]), NA_real_, quarts[1] / quarts[2]) - }), names(splits)) -} - -#TODO duplicates TreeTools v1.5.1+ PhyDatToMatrix; replace when can require -.TMP_PhyDatToMatrix <- function (dataset, ambigNA = TRUE, inappNA = TRUE) { - at <- attributes(dataset) - allLevels <- as.character(at$allLevels) - if (inappNA) { - allLevels[allLevels == '-'] <- NA_character_ - } - if (ambigNA) { - allLevels[rowSums(at$contrast) != 1L] <- NA_character_ - } - matrix(allLevels[unlist(dataset, recursive = FALSE, use.names = FALSE)], - ncol = at$nr, byrow = TRUE, dimnames = list(at$names, NULL) - )[, at$index, drop = FALSE] -} - -#' @importFrom TreeDist Entropy -.Entropy <- function (...) { - Entropy (c(...) / sum(...)) -} - -#' @rdname SiteConcordance -#' @importFrom TreeTools Subsplit -#' @importFrom stats setNames -#' @export -ClusteringConcordance <- function (tree, dataset) { - dataset <- dataset[tree$tip.label] - splits <- as.logical(as.Splits(tree)) - - at <- attributes(dataset) - cont <- at$contrast - if ('-' %in% colnames(cont)) { - cont[cont[, '-'] > 0, ] <- 1 - } - ambiguous <- rowSums(cont) != 1 - - mat <- matrix(unlist(dataset), length(dataset), byrow = TRUE) - mat[mat %in% which(ambiguous)] <- NA - mat <- apply(mat, 2, function (x) { - uniques <- table(x) == 1 - x[x %in% names(uniques[uniques])] <- NA - x - }) - - h <- apply(mat, 2, function (char) { - aChar <- !is.na(char) - ch <- char[aChar] - hChar <- .Entropy(table(ch)) - h <- apply(splits[, aChar], 1, function (spl) { - c(hSpl = .Entropy(table(spl)), hJoint = .Entropy(table(ch, spl))) - }) - - cbind(hSum = hChar + h['hSpl', ], joint = h['hJoint', ]) - }) - - splitI <- seq_len(dim(splits)[1]) - both <- rowSums(h[splitI, at$index]) - joint <- rowSums(h[-splitI, at$index]) - mi <- both - joint - - # Return: - setNames(mi / joint, rownames(splits)) -} - -#' @rdname SiteConcordance -#' @importFrom TreeTools as.multiPhylo CladisticInfo CompatibleSplits -#' @export -PhylogeneticConcordance <- function (tree, dataset) { - dataset <- dataset[tree$tip.label] - splits <- as.Splits(tree) - characters <- as.multiPhylo(dataset) - - blankRet <- matrix(0, length(splits), 2, - dimnames = list(names(splits), - c('concordant', 'possible'))) - - support <- rowSums(vapply(characters, function (char) { - ret <- blankRet - if (NTip(char) > 3L) { - thinned <- Subsplit(splits, TipLabels(char)) - compatible <- CompatibleSplits(thinned, char) - if (length(compatible)) { - ci <- CladisticInfo(thinned) - ret[names(thinned), 'concordant'] <- ci * apply(compatible, 1, all) - ret[names(thinned), 'possible'] <- ci - } - } - # Return: - ret - }, blankRet), dims = 2) - - # Return: - support[, 1] / support[, 2] -} - -#' @rdname SiteConcordance -#' @importFrom TreeDist ClusteringEntropy MutualClusteringInfo -#' @export -MutualClusteringConcordance <- function (tree, dataset) { - dataset <- dataset[tree$tip.label] - splits <- as.multiPhylo(as.Splits(tree)) - characters <- as.multiPhylo(dataset) - - support <- rowSums(vapply(characters, function (char) { - trimmed <- lapply(splits, keep.tip, TipLabels(char)) - cbind(mi = MutualClusteringInfo(char, trimmed), - possible = ClusteringEntropy(trimmed)) - }, matrix(NA_real_, length(splits), 2)), dims = 2) - - # Return: - support[, 1] / support[, 2] -} - -#' @rdname SiteConcordance -#' @importFrom TreeTools as.multiPhylo -#' @importFrom TreeDist ClusteringInfo SharedPhylogeneticInfo -#' @export -SharedPhylogeneticConcordance <- function (tree, dataset) { - dataset <- dataset[tree$tip.label] - splits <- as.multiPhylo(as.Splits(tree)) - characters <- as.multiPhylo(dataset) - - support <- rowSums(vapply(characters, function (char) { - trimmed <- lapply(splits, keep.tip, TipLabels(char)) - cbind(mi = SharedPhylogeneticInfo(char, trimmed), - possible = ClusteringInfo(trimmed)) - }, matrix(NA_real_, length(splits), 2)), dims = 2) - - # Return: - support[, 1] / support[, 2] -} - -#' Evaluate the concordance of information between a tree and a dataset -#' -#' Details the amount of information in a phylogenetic dataset that is -#' consistent with a specified phylogenetic tree, and the signal:noise -#' ratio of the character matrix implied if the tree is true. -#' -#' Presently restricted to datasets whose characters contain a maximum of -#' two parsimony-informative states. -#' -#' @return `ConcordantInformation()` returns a named vector with elements: -#' -#' - `informationContent`: cladistic information content of `dataset` -#' - `signal`, `noise`: amount of cladistic information that represents -#' phylogenetic signal and noise, according to `tree` -#' - `signalToNoise`: the implied signal:noise ratio of `dataset` -#' - `treeInformation`: the cladistic information content of a bifurcating tree -#' on `dataset`; this is the minimum amount of information necessary to resolve -#' a bifurcating tree, assuming no duplicate information or noise -#' - `matrixToTree`: the ratio of the cladistic information content of the -#' matrix to the cladistic information content of the tree, a measure of the -#' redundancy of the matrix -#' - `ignored`: information content of characters whose signal and noise could -#' not be calculated (too many states) and so are not included in the totals -#' above. -#' -#' @template treeParam -#' @template datasetParam -#' @examples -#' data(congreveLamsdellMatrices) -#' myMatrix <- congreveLamsdellMatrices[[10]] -#' ConcordantInformation(TreeTools::NJTree(myMatrix), myMatrix) -#' @template MRS -#' @importFrom TreeTools Log2UnrootedMult Log2Unrooted -#' @export -ConcordantInformation <- function (tree, dataset) { - dataset <- dataset[tree$tip.label] - originalInfo <- sum(apply(PhyDatToMatrix(dataset), 2, CharacterInformation)) - dataset <- PrepareDataProfile(dataset) - - extraSteps <- CharacterLength(tree, dataset, compress = TRUE) - - MinimumLength(dataset, compress = TRUE) - chars <- matrix(unlist(dataset), attr(dataset, 'nr')) - ambiguousToken <- which(attr(dataset, 'allLevels') == "?") - asSplits <- apply(chars, 1, function (x) { - ret <- table(x) - if (length(ambiguousToken) != 0) { - ret[names(ret) != ambiguousToken] - } else { - ret - } - }) - if (is.matrix(asSplits)) { - asSplits <- lapply(seq_len(dim(asSplits)[2]), function(i) asSplits[, i]) - } - ic <- vapply(asSplits, function (split) - Log2Unrooted(sum(split)) - Log2UnrootedMult(split), - double(1)) - - infoLosses <- apply(chars, 1, StepInformation, - ambiguousToken = ambiguousToken) # , drop = FALSE - if (is.matrix(infoLosses)) { - infoLosses <- lapply(seq_len(dim(infoLosses)[2]), - function (i) infoLosses[, i]) - } - - signal <- vapply(seq_along(extraSteps), function (i) { - infoLosses[[i]][extraSteps[i] + 1L] - }, double(1)) - noise <- ic - signal - noise[noise < sqrt(.Machine$double.eps)] <- 0 - - - index <- attr(dataset, 'index') - if (any(is.na(signal))) { - na <- is.na(signal) - icA <- ic - icA[na] <- 0 - totalInfo <- sum(ic[index]) - kept <- sum(icA[index]) - discarded <- totalInfo - kept - warning("Could not calculate signal for characters ", - paste0(match(which(na), index), collapse = ', '), - '; discarded ', signif(discarded), " bits from totals.") - totalNoise <- sum(noise[index], na.rm = TRUE) - totalSignal <- sum(signal[index], na.rm = TRUE) - signalNoise <- totalSignal / totalNoise - - infoNeeded <- Log2Unrooted(length(dataset)) - infoOverkill <- totalInfo / infoNeeded - - message('`dataset` contains ', - signif(totalInfo), ' bits (after discarding ', - signif(discarded), '), of which ', - signif(totalSignal), ' signal, ', - signif(totalNoise), ' noise, ', - signif(infoNeeded), ' needed. ', - 'S:N = ', signif(signalNoise), "\n") - - } else { - totalInfo <- sum(ic[index]) - totalNoise <- sum(noise[index]) - totalSignal <- sum(signal[index]) - signalNoise <- totalSignal / totalNoise - discarded = 0 - - infoNeeded <- Log2Unrooted(length(dataset)) - infoOverkill <- totalInfo / infoNeeded - discarded <- originalInfo - totalInfo - if (discarded < sqrt(.Machine$double.eps)) discarded <- 0 - - message('dataset contains ', - signif(totalInfo), ' bits', - if (totalInfo != originalInfo) { - paste0(' (after discarding ', signif(originalInfo - totalInfo), - ' bits)') - }, ', of which ', - signif(totalSignal), ' signal, ', - signif(totalNoise), ' noise, ', - signif(infoNeeded), ' needed. ', - 'S:N = ', signif(signalNoise), "\n") - } - - # Return: - c(informationContent = totalInfo, - signal = totalSignal, - noise = totalNoise, - signalToNoise = signalNoise, - - treeInformation = infoNeeded, - matrixToTree = infoOverkill, - ignored = discarded - ) -} - -#' @rdname ConcordantInformation -#' @export -Evaluate <- function (tree, dataset) { - .Deprecated('ConcordantInformation()') - ConcordantInformation(tree, dataset) -} - -#' @rdname ConcordantInformation -#' @export -ConcordantInfo <- ConcordantInformation \ No newline at end of file diff --git a/R/CustomSearch.R b/R/CustomSearch.R deleted file mode 100644 index 3ec03001c..000000000 --- a/R/CustomSearch.R +++ /dev/null @@ -1,183 +0,0 @@ -#' @describeIn TreeSearch Tree search from edge lists -#' @template edgeListParam -#' @template dataForFunction -#' @keywords internal -#' @export -EdgeListSearch <- function (edgeList, dataset, - TreeScorer = MorphyLength, - EdgeSwapper = RootedTBRSwap, - maxIter = 100, maxHits = 20, - bestScore = NULL, stopAtScore = NULL, - stopAtPeak = FALSE, stopAtPlateau = 0L, - verbosity = 1L, ...) { - epsilon <- 1e-07 - - if (is.null(bestScore)) { - if (length(edgeList) < 3L) { - bestScore <- TreeScorer(edgeList[[1]], edgeList[[2]], dataset, ...) - } else { - bestScore <- edgeList[[3]] - } - } - if (verbosity > 0L) { - message(" - Performing tree search. Initial score: ", bestScore) #nocov - } - if (!is.null(stopAtScore) && bestScore < stopAtScore + epsilon) { - if (verbosity > 0L) { #nocov start - message(" - Aborting tree search as tree score ", bestScore, - " already below target of ", stopAtScore) - } #nocov end - edgeList[[3]] <- bestScore - return(edgeList) - } - hits <- 0L - unimprovedSince <- 0L - - for (iter in 1:maxIter) { - candidateLists <- RearrangeEdges(edgeList[[1]], edgeList[[2]], - dataset = dataset, - TreeScorer = TreeScorer, - EdgeSwapper = EdgeSwapper, - hits = hits, iter = iter, - verbosity = verbosity, ...) - scoreThisIteration <- candidateLists[[3]] - hits <- candidateLists[[4]] - - if (scoreThisIteration < bestScore + epsilon) { - if (scoreThisIteration + epsilon < bestScore) unimprovedSince <- -1L - bestScore <- scoreThisIteration - edgeList <- candidateLists - if (!is.null(stopAtScore) && bestScore < stopAtScore + epsilon) { - return(edgeList) - } - } else if (stopAtPeak && scoreThisIteration > bestScore + epsilon) { - if (verbosity > 1L) { #nocov start - message(" ! Iteration ", iter, - " - No TBR rearrangement improves score. ", - scoreThisIteration, " doesn't beat ", bestScore) - } #nocov end - break - } - unimprovedSince <- unimprovedSince + 1L - if (stopAtPlateau > 0L) { - if (verbosity > 2L && unimprovedSince > 0L) { - message(" Last improvement ", unimprovedSince, " iterations ago.") - } - if (unimprovedSince >= stopAtPlateau) { - if (verbosity > 1L) message(" - Terminating search, as score has ", - "not improved over past ", - unimprovedSince, " searches.") - break - } - } - - if (hits >= maxHits) { - if (verbosity > 1L) { #nocov start - message(" - Terminating search; hit best score ", hits, " times.") - } #nocov end - break - } - } - if (verbosity > 0L) { #nocov start - message(" - Final score ", bestScore, " found ", hits, " times after ", - iter, " rearrangements.", if (verbosity > 1L) '\n' else '') - } #nocov end - - edgeList[3:4] <- c(bestScore, hits) - - # Return: - edgeList -} - -#' Search for most parsimonious trees -#' -#' Run standard search algorithms (\acronym{NNI}, \acronym{SPR} or \acronym{TBR}) -#' to search for a more parsimonious tree. -#' -#' For detailed documentation of the 'TreeSearch' package, including full -#' instructions for loading phylogenetic data into R and initiating and -#' configuring tree search, see the -#' [package documentation](https://ms609.github.io/TreeSearch/). -#' -#' @param tree A fully-resolved starting tree in \code{\link{phylo}} format, -#' with the desired outgroup. -#' Edge lengths are not supported and will be removed. -#' @template datasetParam -#' @template EdgeSwapperParam -#' @param maxIter Numeric specifying maximum number of iterations to perform -#' before abandoning the search. -#' @param maxHits Numeric specifying maximum times to hit the best pscore -#' before abandoning the search. -#' @template stopAtPeakParam -#' @template stopAtPlateauParam -#' -#' @template InitializeDataParam -#' @template CleanUpDataParam -#' @template treeScorerParam -#' -#' @template verbosityParam -#' @template treeScorerDots -#' -#' @return -#' `TreeSearch()` returns a tree, with an attribute `pscore` conveying its -#' parsimony score. -#' #' Note that the parsimony score will be inherited from the tree's -#' attributes, which is only valid if it was generated using the same -#' `data` that is passed here. -#' -#' -#' @seealso -#' \itemize{ -#' \item \code{\link{Fitch}}, calculates parsimony score; -#' \item \code{\link{RootedNNI}}, conducts tree rearrangements; -#' \item \code{\link{Ratchet}}, alternative heuristic, useful to escape local -#' optima. -#' } -#' -#' @examples -#' data('Lobo', package='TreeTools') -#' njtree <- TreeTools::NJTree(Lobo.phy) -#' -#' ## Only run examples in interactive R sessions -#' if (interactive()) { -#' TreeSearch(njtree, Lobo.phy, maxIter = 20, EdgeSwapper = NNISwap) -#' TreeSearch(njtree, Lobo.phy, maxIter = 20, EdgeSwapper = RootedSPRSwap) -#' TreeSearch(njtree, Lobo.phy, maxIter = 20, EdgeSwapper = TBRSwap) -#' } -#' @template MRS -#' @family custom search functions -#' @importFrom TreeTools RenumberTips -#' @export -TreeSearch <- function (tree, dataset, - InitializeData = PhyDat2Morphy, - CleanUpData = UnloadMorphy, - TreeScorer = MorphyLength, - EdgeSwapper = RootedTBRSwap, - maxIter = 100L, maxHits = 20L, - stopAtPeak = FALSE, stopAtPlateau = 0L, - verbosity = 1L, ...) { - # initialize tree and data - if (dim(tree$edge)[1] != 2 * tree$Nnode) { - stop("tree must be bifurcating; try rooting with ape::root") - } - tree <- RenumberTips(tree, names(dataset)) - edgeList <- tree$edge - edgeList <- RenumberEdges(edgeList[, 1], edgeList[, 2]) - - initializedData <- InitializeData(dataset) - on.exit(initializedData <- CleanUpData(initializedData)) - - bestScore <- attr(tree, 'score') - edgeList <- EdgeListSearch(edgeList, initializedData, TreeScorer = TreeScorer, - EdgeSwapper = EdgeSwapper, maxIter = maxIter, - maxHits = maxHits, stopAtPeak = stopAtPeak, - stopAtPlateau = stopAtPlateau, - verbosity = verbosity, ...) - - tree$edge <- cbind(edgeList[[1]], edgeList[[2]]) - attr(tree, 'score') <- edgeList[[3]] - attr(tree, 'hits') <- edgeList[[4]] - - # Return: - tree -} diff --git a/R/IWScore.R b/R/IWScore.R deleted file mode 100644 index 156eb025a..000000000 --- a/R/IWScore.R +++ /dev/null @@ -1,14 +0,0 @@ -#' @template pointlessDots -#' @rdname TreeLength -#' @export -IWScore <- function (tree, dataset, concavity = 10L, ...) { - .Deprecated('TreeLength') - TreeLength(tree, dataset, concavity) -} - -#' @rdname TreeSearch -#' @export -IWTreeSearch <- function (...) { - .Deprecated("MaximizeParsimony") # Retained as template, for now. - message("See also the vignette 'custom optimality criteria'") -} diff --git a/R/ImposeConstraint.R b/R/ImposeConstraint.R deleted file mode 100644 index e69de29bb..000000000 diff --git a/R/Jackknife.R b/R/Jackknife.R deleted file mode 100644 index f172171ff..000000000 --- a/R/Jackknife.R +++ /dev/null @@ -1,146 +0,0 @@ -#' Jackknife resampling -#' -#' Resample trees using Jackknife resampling, i.e. removing a subset of -#' characters. -#' -#' The function assumes -#' that `InitializeData()` will return a morphy object; if this doesn't hold -#' for you, post a [GitHub issue](https://github.com/ms609/TreeSearch/issues/new/) -#' or e-mail the maintainer. -#' -#' @inheritParams Ratchet -#' @template EdgeSwapperParam -#' @param resampleFreq Double between 0 and 1 stating proportion of characters -#' to resample. -#' @param jackIter Integer specifying number of jackknife iterations to conduct. -#' @return `Jackknife()` returns a list of trees recovered after jackknife -#' iterations. -#' @author Martin R. Smith -#' @importFrom TreeTools RenumberEdges RenumberTips -#' @seealso -#' - [`JackLabels()`]: Label nodes of a tree with jackknife supports. -#' @family split support functions -#' @family custom search functions -#' @export -Jackknife <- function (tree, dataset, resampleFreq = 2/3, - InitializeData = PhyDat2Morphy, - CleanUpData = UnloadMorphy, - TreeScorer = MorphyLength, - EdgeSwapper = TBRSwap, - jackIter = 5000L, - searchIter = 4000L, searchHits = 42L, - verbosity = 1L, ...) { - # initialize tree and data - if (dim(tree$edge)[1] != 2 * tree$Nnode) { - stop("tree must be bifurcating; try rooting with ape::root") - } - tree <- RenumberTips(tree, names(dataset)) - edgeList <- tree$edge - edgeList <- RenumberEdges(edgeList[, 1], edgeList[, 2]) - - morphyObj <- InitializeData(dataset) - on.exit(morphyObj <- CleanUpData(morphyObj)) - - startWeights <- MorphyWeights(morphyObj)['exact', ] - eachChar <- seq_along(startWeights) - deindexedChars <- rep.int(eachChar, startWeights) - charsToKeep <- ceiling(resampleFreq * length(deindexedChars)) - if (charsToKeep < 1L) { - stop("resampleFreq of ", resampleFreq, " is too low; can't keep 0 of ", - length(deindexedChars), " characters.") - } else if (charsToKeep >= length(deindexedChars)) { - stop("resampleFreq of ", resampleFreq, " is too high; can't keep all ", - length(deindexedChars), " characters.") - } - if (verbosity > 10L) { #nocov start - message(" * Beginning search:") - } #nocov end - - # Conduct jackIter replicates: - jackEdges <- vapply(seq_len(jackIter), function (x) { - if (verbosity > 0L) { #nocov start - message(" * Jackknife iteration ", x, "/", jackIter) - } #nocov end - resampling <- tabulate(sample(deindexedChars, charsToKeep, replace = FALSE), - nbins = length(startWeights)) - errors <- vapply(eachChar, function (i) - mpl_set_charac_weight(i, resampling[i], morphyObj), integer(1)) - if (any(errors)) { #nocov start - stop ("Error resampling morphy object: ", - mpl_translate_error(unique(errors[errors < 0L]))) - } - if (mpl_apply_tipdata(morphyObj) -> error) { - stop("Error applying tip data: ", mpl_translate_error(error)) - } #nocov end - res <- EdgeListSearch(edgeList[1:2], morphyObj, EdgeSwapper = EdgeSwapper, - maxIter = searchIter, maxHits = searchHits, - verbosity = verbosity - 1L, ...) - res[1:2] - }, edgeList) - - jackTrees <- structure(apply(jackEdges, 2, function(edgeList) { - ret <- tree - ret$edge <- cbind(edgeList[[1]], edgeList[[2]]) - ret - }), class = 'multiPhylo') -} - - -#' Label nodes with jackknife support values -#' -#' @template treeParam -#' @param jackTrees A list or `multiPhylo` object containing trees generated -#' by [`Jackknife()`]. -#' @param add Logical specifying whether to add the labels to an existing -#' plot. -#' @param adj,col,frame,pos,\dots Parameters to pass to `nodelabels()`. -#' @param plot Logical specifying whether to plot results; if `FALSE`, -#' returns blank labels for nodes near the root that do not correspond to a -#' unique split. -#' -#' @return A named vector specifying the proportion of jackknife trees -#' consistent with each node in `tree`, as plotted. -#' If `plot = FALSE`, blank entries are included corresponding to nodes -#' that do not require labelling; the return value is in the value required -#' by `phylo$node.label`. -#' -#' @examples -#' library('TreeTools', quietly = TRUE) # for as.phylo -#' -#' # jackTrees will usually be generated with Jackknife(), but for simplicity: -#' jackTrees <- as.phylo(1:100, 8) -#' -#' tree <- as.phylo(0, 8) -#' JackLabels(tree, jackTrees) -#' -#' tree$node.label <- JackLabels(tree, jackTrees, plot = FALSE) -#' @template MRS -#' @importFrom ape nodelabels -#' @importFrom TreeTools SplitFrequency SupportColour -#' @seealso [`Jackknife()`]: Generate trees by jackknife resampling -#' @family split support functions -#' @export -JackLabels <- function (tree, jackTrees, - plot = TRUE, - add = FALSE, - adj = 0, col = NULL, frame = 'none', pos = 2L, - ...) { - jackSupport <- SplitFrequency(tree, jackTrees) / length(jackTrees) - - if (plot) { - if (!add) plot(tree) - if (is.null(col)) col <- SupportColour(jackSupport) - ape::nodelabels(paste('\n\n', signif(jackSupport, 2)), - node = as.integer(names(jackSupport)), - adj = adj, col = col, pos = pos, frame = frame, ...) - - # Return: - jackSupport - } else { - ret <- character(tree$Nnode) - ret[as.integer(names(jackSupport)) - NTip(tree)] <- jackSupport - - # Return: - ret - } -} diff --git a/R/MaximizeParsimony.R b/R/MaximizeParsimony.R deleted file mode 100644 index 059593e44..000000000 --- a/R/MaximizeParsimony.R +++ /dev/null @@ -1,855 +0,0 @@ -#' Find most parsimonious trees -#' -#' Search for most parsimonious trees using the parsimony ratchet and -#' \acronym{TBR} rearrangements, treating inapplicable data as such using the -#' algorithm of \insertCite{Brazeau2019;textual}{TreeSearch}. -#' -#' Tree search will be conducted from a specified or automatically-generated -#' starting tree in order to find a tree with an optimal parsimony score, -#' under implied or equal weights, treating inapplicable characters as such -#' in order to avoid the artefacts of the standard Fitch algorithm -#' \insertCite{@see @Maddison1993; @Brazeau2019}{TreeSearch}. -#' The tree scoring implementation uses the MorphyLib C library -#' \insertCite{Brazeau2017}{TreeSearch}. -#' -#' Tree search commences with `ratchIter` iterations of the parsimony ratchet -#' \insertCite{Nixon1999}{TreeSearch}, which bootstraps the input dataset -#' in order to escape local optima. -#' A final round of tree bisection and reconnection (\acronym{TBR}) -#' is conducted to broaden the sampling of trees. -#' -#' This function can be called using the R command line / terminal, or through -#' the 'shiny' graphical user interface app (type `EasyTrees()` to launch). -#' -#' -#' For detailed documentation of the 'TreeSearch' package, including full -#' instructions for loading phylogenetic data into R and initiating and -#' configuring tree search, see the -#' [package documentation](https://ms609.github.io/TreeSearch/). -#' -#' -#' -#' @template datasetParam -#' @param tree (optional) A bifurcating tree of class \code{\link{phylo}}, -#' containing only the tips listed in `dataset`, from which the search -#' should begin. -#' If unspecified, an [addition tree][AdditionTree()] will be generated from -#' `dataset`, respecting any supplied `constraint`. -#' Edge lengths are not supported and will be deleted. -#' @param ratchIter Numeric specifying number of iterations of the -#' parsimony ratchet \insertCite{Nixon1999}{TreeSearch} to conduct. -#' @param tbrIter Numeric specifying the maximum number of \acronym{TBR} -#' break points to evaluate before concluding each search. -#' The counter is reset to zero each time tree score improves. -#' The counter is reset to zero each time tree score improves. -#' One 'iteration' comprises breaking a single branch and evaluating all -#' possible reconnections. -#' @param startIter Numeric: an initial round of tree search with -#' `startIter` × `tbrIter` \acronym{TBR} break points is conducted in -#' order to locate a local optimum before beginning ratchet searches. -#' @param finalIter Numeric: a final round of tree search will evaluate -#' `finalIter` × `tbrIter` \acronym{TBR} break points, in order to -#' sample the final optimal neighbourhood more intensely. -#' @param maxHits Numeric specifying the maximum times that an optimal -#' parsimony score may be hit before concluding a ratchet iteration or final -#' search concluded. -#' @param maxTime Numeric: after `maxTime` minutes, stop tree search at the -#' next opportunity. -#' @param quickHits Numeric: iterations on subsampled datasets -#' will retain `quickHits` × `maxHits` trees with the best score. -#' @param concavity Numeric specifying concavity constant for implied step -#' weighting; set as `Inf` for equal step weights (which is a bad idea; see -#' \insertCite{Smith2019;textual}{TreeSearch}). -#' @param tolerance Numeric specifying degree of suboptimality to tolerate -#' before rejecting a tree. The default, `sqrt(.Machine$double.eps)`, retains -#' trees that may be equally parsimonious but for rounding errors. -#' Setting to larger values will include trees suboptimal by up to `tolerance` -#' in search results, which may improve the accuracy of the consensus tree -#' (at the expense of resolution) \insertCite{Smith2019}{TreeSearch}. -#' @param constraint An object of class `phyDat`; returned trees will be -#' perfectly compatible with each character in `constraint`. -#' See [`ImposeConstraint()`] and -#' [vignette](https://ms609.github.io/TreeSearch/articles/inapplicable.html) -#' for further examples. -#' @param verbosity Integer specifying level of messaging; higher values give -#' more detailed commentary on search progress. Set to `0` to run silently. -#' @param \dots Additional parameters to `MaximizeParsimony()`. -#' -#' @return `MaximizeParsimony()` returns a list of trees with class -#' `multiPhylo`. This lists all trees found during each search step that -#' are within `tolerance` of the optimal score, listed in the sequence that -#' they were first visited; it may contain more than `maxHits` elements. -#' Note that the default search parameters may need to be increased in order for -#' these trees to be the globally optimal trees; examine the messages printed -#' during tree search to evaluate whether the optimal score has stabilized. -#' -#' The return value has the attribute `newTrees`, a named integer vector listing -#' the number of optimal trees visited for the first time in each stage of -#' the tree search. -#' -#' @examples -#' ## Only run examples in interactive R sessions -#' if (interactive()) { -#' # launch 'shiny' point-and-click interface -#' EasyTrees() -#' -#' # Here too, use the "continue search" function to ensure that tree score -#' # has stabilized and a global optimum has been found -#' } -#' -#' -#' # Load data for analysis in R -#' library('TreeTools') -#' data('congreveLamsdellMatrices', package = 'TreeSearch') -#' dataset <- congreveLamsdellMatrices[[42]] -#' -#' # A very quick run for demonstration purposes -#' trees <- MaximizeParsimony(dataset, ratchIter = 0, startIter = 0, -#' tbrIter = 1, maxHits = 4, maxTime = 1/100, -#' concavity = 10, verbosity = 4) -#' -#' # In actual use, be sure to check that the score has converged on a global -#' # optimum, conducting additional iterations and runs as necessary. -#' -#' if (interactive()) { -#' # Jackknife resampling -#' nReplicates <- 10 -#' jackTrees <- replicate(nReplicates, -#' #c() ensures that each replicate returns a list of trees -#' c(Resample(dataset, trees, ratchIter = 0, tbrIter = 2, startIter = 1, -#' maxHits = 5, maxTime = 1 / 10, -#' concavity = 10, verbosity = 0)) -#' ) -#' -#' # In a serious analysis, more replicates would be conducted, and each -#' # search would undergo more iterations. -#' -#' # Now we must decide what to do with the multiple optimal trees from -#' # each replicate. -#' -#' # Treat each tree equally -#' JackLabels(ape::consensus(trees), unlist(jackTrees, recursive = FALSE)) -#' -#' # Take the strict consensus of all trees for each replicate -#' JackLabels(ape::consensus(trees), lapply(jackTrees, ape::consensus)) -#' -#' # Take a single tree from each replicate (the first; order's irrelevant) -#' JackLabels(ape::consensus(trees), lapply(jackTrees, `[[`, 1)) -#' } -#' -#' # Tree search with a constraint -#' constraint <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 0, f = 0)) -#' characters <- MatrixToPhyDat(matrix( -#' c(0, 1, 1, 1, 0, 0, -#' 1, 1, 1, 0, 0, 0), ncol = 2, -#' dimnames = list(letters[1:6], NULL))) -#' MaximizeParsimony(characters, constraint = constraint, verbosity = 0) -#' -#' @template MRS -#' -#' @importFrom cli cli_alert cli_alert_danger cli_alert_info cli_alert_success cli_alert_warning -#' cli_h1 -#' cli_progress_bar cli_progress_done cli_progress_update -#' @importFrom fastmatch fmatch -#' @importFrom phangorn Descendants -#' @importFrom stats runif -#' @importFrom TreeTools -#' AddUnconstrained -#' CharacterInformation -#' ConstrainedNJ -#' DropTip -#' ImposeConstraint -#' MakeTreeBinary -#' NTip -#' @references -#' \insertAllCited{} -#' @seealso -#' Tree search _via_ graphical user interface: [`EasyTrees()`] -#' -#' @encoding UTF-8 -#' @export -MaximizeParsimony <- function (dataset, tree, - ratchIter = 6L, - tbrIter = 2L, - startIter = 2L, finalIter = 1L, - maxHits = NTip(dataset) * 1.8, - maxTime = 60, - quickHits = 1 / 3, - concavity = Inf, - tolerance = sqrt(.Machine$double.eps), - constraint, - verbosity = 3L) { - - ### User messaging functions ### - .Message <- function (level, ...) { - if (level < verbosity) { - cli_alert(paste0(...)) - } - } - .Heading <- function (text, ...) { - if (0 < verbosity) { - cli_h1(text) - cli_alert(paste0(...)) - } - } - .Info <- function (level, ...) { - if (level < verbosity) { - cli_alert_info(paste0(...)) - } - } - .Success <- function (level, ...) { - if (level < verbosity) { - cli_alert_success(paste0(...)) - } - } - - ### Tree score functions ### - .EWScore <- function (edge, morphyObj, ...) { - preorder_morphy(edge, morphyObj) - } - - .IWScore <- function (edge, morphyObjs, weight, charSeq, concavity, - minLength, target = Inf) { - morphy_iw(edge, morphyObjs, weight, minLength, charSeq, - concavity, target + epsilon) - } - - # Must have same order of parameters as .IWScore, even though minLength unused - .ProfileScore <- function (edge, morphyObjs, weight, charSeq, profiles, - minLength, target = Inf) { - morphy_profile(edge, morphyObjs, weight, charSeq, profiles, - target + epsilon) - } - - .Score <- function (edge) { - if (length(dim(edge)) == 3L) { - edge <- edge[, , 1] - } - if (profile) { - .ProfileScore(edge, morphyObjects, startWeights, charSeq, profiles) - } else if (iw) { - .IWScore(edge, morphyObjects, startWeights, charSeq, concavity, minLength) - } else { - preorder_morphy(edge, morphyObj) - } - } - - ### Tree search functions ### - .TBRSearch <- function (Score, name, - edge, morphyObjs, weight, - tbrIter, maxHits, - minLength = NULL, charSeq = NULL, concavity = NULL) { - - iter <- 0L - nHits <- 1L - hold <- array(NA, dim = c(dim(edge), max(maxHits * 1.1, maxHits + 10L))) - maxHits <- ceiling(maxHits) - hold[, , 1] <- edge - bestScore <- Score(edge, morphyObjs, weight, charSeq, concavity, minLength) - bestPlusEps <- bestScore + epsilon - cli_progress_bar(name, total = maxHits, - auto_terminate = FALSE, - clear = verbosity < 3L, - format_done = paste0(" - TBR rearrangement at depth {iter}", - " found score {signif(bestScore)}", - " {nHits} time{?s}.")) - - while (iter < tbrIter) { - iter <- iter + 1L - optTbr <- sample(3:(nTip * 2 - 2)) - .Message(4L, "New TBR iteration (depth ", iter, - ", score ", signif(bestScore), ")") - cli_progress_update(set = 0, total = length(optTbr)) - - for (brk in optTbr) { - cli_progress_update(1, status = paste0('D', iter, ", score ", - signif(bestScore), ", hit ", - nHits, ".")) - .Message(7L, "Break ", brk) - moves <- TBRMoves(edge, brk) - improvedScore <- FALSE - nMoves <- length(moves) - moveList <- sample.int(nMoves) - for (i in seq_along(moveList)) { - move <- moves[[moveList[i]]] - if (.Forbidden(move)) { - .Message(10L, "Skipping prohibited topology") - next - } - moveScore <- Score(move, morphyObjs, weight, charSeq, concavity, - minLength, bestPlusEps) - if (moveScore < bestPlusEps) { - edge <- move - if (moveScore < bestScore) { - improvedScore <- TRUE - iter <- 0L - bestScore <- moveScore - bestPlusEps <- bestScore + epsilon - nHits <- 1L - hold[, , 1] <- edge - .Message(5L, "New best score ", signif(bestScore), - " at break ", fmatch(brk, optTbr), "/", length(optTbr)) - break - } else { - .Message(6L, "Best score ", signif(bestScore), - " hit again (", nHits, "/", ceiling(maxHits), ")") - nHits <- nHits + 1L - hold[, , nHits] <- edge - if (nHits >= maxHits) break - } - } - if (improvedScore && runif(1) < (i / nMoves) ^ 2) break - } - if (nHits >= maxHits) break - pNextTbr <- (fmatch(brk, optTbr) / length(optTbr)) ^ 2 - if (improvedScore && runif(1) < pNextTbr) break - } - if (nHits >= maxHits) break - } - cli_progress_done() - - # Return: - unique(hold[, , seq_len(nHits), drop = FALSE], MARGIN = 3L) - - } - - - .Search <- function (name = 'TBR search', .edge = edge, .hits = searchHits, - .weight = startWeights) { - if (length(dim(.edge)) == 3L) { - .edge <- .edge[, , 1] - } - if (profile) { - .TBRSearch(.ProfileScore, name, edge = .edge, morphyObjects, - tbrIter = searchIter, maxHits = .hits, - weight = .weight, minLength = minLength, charSeq = charSeq, - concavity = profiles) - - } else if (iw) { - .TBRSearch(.IWScore, name, edge = .edge, morphyObjects, - tbrIter = searchIter, maxHits = .hits, - weight = .weight, minLength = minLength, charSeq = charSeq, - concavity = concavity) - } else { - .TBRSearch(.EWScore, name, edge = .edge, morphyObj, - tbrIter = searchIter, maxHits = .hits) - } - } - - .Timeout <- function () { - if (Sys.time() > stopTime) { - .Info(1L, "Stopping search at ", Sys.time(), ": ", maxTime, - " minutes have elapsed.", - " Best score was ", signif(.Score(bestEdges[, , 1])), '.', - if (maxTime == 60) "\nIncrease `maxTime` for longer runs.") - return (TRUE) - } - - FALSE - } - - .ReturnValue <- function (bestEdges) { - if (verbosity > 0L) { - cli_alert_success(paste0(Sys.time(), - ": Tree search terminated with score {.strong ", - "{signif(.Score(bestEdges[, , 1]))}}")) - } - structure(lapply(seq_len(dim(bestEdges)[3]), function (i) { - tr <- tree - tr$edge <- bestEdges[, , i] - if (any(is.na(outgroup))) { - tr - } else { - RootTree(tr, outgroup) - } - }), - firstHit = attr(bestEdges, 'firstHit'), - class = 'multiPhylo') - } - - - # Define constants - epsilon <- tolerance - pNextTbr <- 0.33 - profile <- .UseProfile(concavity) - iw <- is.finite(concavity) - constrained <- !missing(constraint) - startTime <- Sys.time() - stopTime <- startTime + as.difftime(maxTime, units = 'mins') - - # Initialize tree - if (missing(tree)) { - tree <- AdditionTree(dataset, constraint = constraint, - concavity = concavity) - } else if (inherits(tree, 'multiPhylo')) { - .Info(2L, "Starting search from {.var tree[[1]]}") - tree <- tree[[1]] - } - if (dim(tree$edge)[1] != 2 * tree$Nnode) { - cli_alert_warning("`tree` is not bifurcating; collapsing polytomies at random") - tree <- MakeTreeBinary(tree) - if (dim(tree$edge)[1] != 2 * tree$Nnode) { - cli_alert_warning("Rooting `tree` on first leaf") - tree <- RootTree(tree, 1) - } - if (dim(tree$edge)[1] != 2 * tree$Nnode) { - stop("Could not make `tree` binary.") - } - } - - # Check tree labels matches dataset - leaves <- tree$tip.label - taxa <- names(dataset) - treeOnly <- setdiff(leaves, taxa) - datOnly <- setdiff(taxa, leaves) - if (length(treeOnly)) { - cli_alert_warning("Ignoring taxa on tree missing in dataset:\n ", - paste0(treeOnly, collapse = ', '), "\n") - warning("Ignored taxa on tree missing in dataset:\n ", - paste0(treeOnly, collapse = ', ')) - tree <- DropTip(tree, treeOnly) - } - if (length(datOnly)) { - cli_alert_warning("Ignoring taxa in dataset missing on tree:\n ", - paste0(datOnly, collapse = ', '), "\n") - warning("Ignored taxa in dataset missing on tree:\n ", - paste0(datOnly, collapse = ', ')) - dataset <- dataset[-fmatch(datOnly, taxa)] - } - if (constrained) { - consTaxa <- names(constraint) - treeOnly <- setdiff(tree$tip.label, consTaxa) - if (length(treeOnly)) { - constraint <- AddUnconstrained(constraint, treeOnly) - } - consOnly <- setdiff(consTaxa, tree$tip.label) - if (length(consOnly)) { - cli_alert_warning("Ignoring taxa in constraint missing on tree:\n ", - paste0(consOnly, collapse = ', '), "\n") - warning("Ignored taxa in constraint missing on tree:\n ", - paste0(consOnly, collapse = ', ')) - constraint <- constraint[-fmatch(consOnly, consTaxa)] - } - constraint <- constraint[names(dataset)] - } - - - tree <- Preorder(RenumberTips(tree, names(dataset))) - nTip <- NTip(tree) - edge <- tree$edge - - # Initialize constraints - if (constrained) { - morphyConstr <- PhyDat2Morphy(constraint) - on.exit(morphyConstr <- UnloadMorphy(morphyConstr), add = TRUE) - constraintWeight <- attr(constraint, 'weight') - if (any(constraintWeight > 1)) { - cli_alert_warning("Some constraints are exact duplicates.") - } - # Calculate constraint minimum score - constraintLength <- sum(MinimumLength(constraint, compress = TRUE) * - constraintWeight) - - .Forbidden <- function (edges) { - preorder_morphy(edges, morphyConstr) != constraintLength - } - - # Check that starting tree is consistent with constraints - if (.Forbidden(edge)) { - cli_alert_warning("Modifying `tree` to match `constraint`...") - outgroup <- Descendants(tree, edge[1, 2], type = 'tips')[[1]] - tree <- RootTree(ImposeConstraint(tree, constraint), outgroup) - # RootTree leaves `tree` in preorder - edge <- tree$edge - if (.Forbidden(edge)) { - stop("Could not reconcile starting tree with `constraint`. ", - "Are all constraints compatible?") - } - } - - cli_alert_success(paste0("Initialized ", length(constraintWeight), - " distinct constraints.")) - - } else { - .Forbidden <- function (edges) FALSE - } - - - if (edge[1, 2] > nTip) { - outgroup <- Descendants(tree, edge[1, 2], type = 'tips')[[1]] - if (length(outgroup) > nTip / 2L) { - outgroup <- seq_len(nTip)[-outgroup] - } - tree <- RootTree(tree, 1) - edge <- tree$edge - } else { - outgroup <- NA - } - - # Initialize data - if (profile) { - dataset <- PrepareDataProfile(dataset) - originalLevels <- attr(dataset, 'levels') - if ('-' %fin% originalLevels) { - #TODO Fixing this will require updating the counts table cleverly - # Or we could use approximate info amounts, e.g. by treating '-' as - # an extra token - cli_alert_info(paste0("Inapplicable tokens '-' treated as ambiguous '?' ", - "for profile parsimony")) - cont <- attr(dataset, 'contrast') - cont[cont[, '-'] != 0, ] <- 1 - attr(dataset, 'contrast') <- cont[, colnames(cont) != '-'] - attr(dataset, 'levels') <- originalLevels[originalLevels != '-'] - } - profiles <- attr(dataset, 'info.amounts') - } - if (iw || profile) { - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - startWeights <- at$weight - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1)), - add = TRUE) - - nLevel <- length(at$level) - nChar <- at$nr - nTip <- length(dataset) - cont <- at$contrast - if (is.null(colnames(cont))) colnames(cont) <- as.character(at$levels) - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) colnames(cont)[x][1]), - '?') - } - if (iw) { - inappLevel <- at$levels == '-' - - if (any(inappLevel)) { - # TODO this is a workaround until MinimumLength can handle {-, 1} - cont[cont[, inappLevel] > 0, ] <- 0 - ambiguousToken <- at$allLevels == '?' - cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 - } - - # Perhaps replace with previous code: - # inappLevel <- which(at$levels == "-") - # cont[, inappLevel] <- 0 - } - - if (iw || profile) { - powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) - tmp <- as.integer(cont %*% powersOf2) - unlisted <- unlist(dataset, use.names = FALSE) - binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) - minLength <- apply(binaryMatrix, 1, MinimumLength) - - tokenMatrix <- matrix(simpleCont[unlisted], nChar, nTip, byrow = FALSE) - charInfo <- apply(tokenMatrix, 1, CharacterInformation) - needsInapp <- rowSums(tokenMatrix == '-') > 2 - inappSlowdown <- 3L # A guess - # Crude estimate of score added per unit processing time - rawPriority <- charInfo / ifelse(needsInapp, inappSlowdown, 1) - priority <- startWeights * rawPriority - informative <- needsInapp | charInfo > 0 - # Will work from end of sequence to start. - charSeq <- seq_along(charInfo)[informative][order(priority[informative])] - 1L - } else { - morphyObj <- PhyDat2Morphy(dataset) - on.exit(morphyObj <- UnloadMorphy(morphyObj), add = TRUE) - startWeights <- unlist(MorphyWeights(morphyObj)[1, ]) # exact == approx - } - - # Initialize variables and prepare search - - nHits <- 1L - tbrStart <- startIter > 0 - tbrEnd <- finalIter > 0 - bestEdges <- edge - bestScore <- .Score(edge) - dim(bestEdges) <- c(dim(bestEdges), 1) - nStages <- sum(tbrStart, ratchIter, tbrEnd) - attr(bestEdges, 'firstHit') <- c('seed' = 1, - setNames(double(nStages), - c(if(tbrStart) 'start', - if (ratchIter > 0) paste0('ratch', seq_len(ratchIter)), - if(tbrEnd) 'final'))) - - - - - - # Find a local optimum - - if (tbrStart) { - searchIter <- tbrIter * startIter - searchHits <- maxHits - - .Heading("Find local optimum", - " TBR depth ", as.integer(searchIter), - "; keeping max ", as.integer(searchHits), - " trees; k = ", concavity, ".") - .Info(1L, Sys.time(), ": Score to beat: ", signif(bestScore)) - - newEdges <- .Search('TBR search 1') - - newBestScore <- .Score(newEdges) - scoreImproved <- newBestScore + epsilon < bestScore - bestEdges <- if (scoreImproved) { - .ReplaceResults(bestEdges, newEdges, 2) - } else { - .CombineResults(bestEdges, newEdges, 2) - } - if (.Timeout()) { - return(.ReturnValue(bestEdges)) # nocov - } - edge <- bestEdges[, , 1L] - } - - searchIter <- tbrIter - searchHits <- maxHits * quickHits - bestScore <- .Score(edge) - bestPlusEps <- bestScore + epsilon - - if (ratchIter > 0L) { - - .Heading("Escape local optimum", "{ratchIter} ratchet iterations; ", - "TBR depth {ceiling(searchIter)}; ", - "max. {ceiling(searchHits)} hits; ", - "k = {concavity}.") - cli_alert("{Sys.time()}: Score to beat: {.strong {signif(bestScore)}}") - - iter <- 0L - while (iter < ratchIter) { - iter <- iter + 1L - .Message(1L, "Ratchet iteration {iter} @ ", - "{format(Sys.time(), '%H:%M:%S')}", - "; score to beat: {.strong {signif(bestScore)} }") - verbosity <- verbosity - 1L - eachChar <- seq_along(startWeights) - deindexedChars <- rep.int(eachChar, startWeights) - resampling <- tabulate(sample(deindexedChars, replace = TRUE), - length(startWeights)) - if (profile || iw) { - priority <- resampling * rawPriority - sampled <- informative & resampling > 0 - ratchSeq <- seq_along(charInfo)[sampled][order(priority[sampled])] - 1L - ratchetTrees <- .Search('Bootstrapped search', .weight = resampling) - } else { - errors <- vapply(eachChar, function (i) - mpl_set_charac_weight(i, resampling[i], morphyObj), integer(1)) - if (any(errors)) { # nocov start - stop ("Error resampling morphy object: ", - mpl_translate_error(unique(errors[errors < 0L]))) - } - if (mpl_apply_tipdata(morphyObj) -> error) { - stop("Error applying tip data: ", mpl_translate_error(error)) - } # nocov end - - ratchetTrees <- .Search('Bootstrapped search') - - errors <- vapply(eachChar, function (i) - mpl_set_charac_weight(i, startWeights[i], morphyObj), integer(1)) - if (any(errors)) stop ("Error resampling morphy object: ", - mpl_translate_error(unique(errors[errors < 0L]))) - if (mpl_apply_tipdata(morphyObj) -> error) { - stop("Error applying tip data: ", mpl_translate_error(error)) - } - } - if (.Timeout()) { - return(.ReturnValue(bestEdges)) # nocov - } - - verbosity <- verbosity + 1L - ratchetStart <- ratchetTrees[, , sample.int(dim(ratchetTrees)[3], 1)] - - ratchetImproved <- .Search('TBR search', .edge = ratchetStart, - .hits = maxHits) - ratchetScore <- .Score(ratchetImproved[, , 1]) - - if (ratchetScore < bestPlusEps) { - if (ratchetScore + epsilon < bestScore) { - .Success(2L, "{.strong New best score}: {signif(ratchetScore)}") - bestScore <- ratchetScore - bestPlusEps <- bestScore + epsilon - bestEdges <- .ReplaceResults(bestEdges, ratchetImproved, - 1 + tbrStart + iter) - edge <- ratchetImproved[, , sample.int(dim(ratchetImproved)[3], 1)] - } else { - .Info(3L, "Hit best score {.strong {signif(bestScore)}} again") - - edge <- ratchetImproved[, , sample.int(dim(ratchetImproved)[3], 1)] - bestEdges <- .CombineResults(bestEdges, ratchetImproved, - 1 + tbrStart + iter) - } - } else { - if (3L < verbosity) { - cli_alert_danger("Did not hit best score {signif(bestScore)}") - } - } - if (.Timeout()) { - return(.ReturnValue(bestEdges)) # nocov - } - } - } - - # Branch breaking - if (tbrEnd) { - searchIter <- tbrIter * finalIter - searchHits <- maxHits - - .Heading("Sample local optimum", - "TBR depth {searchIter}; keeping {searchHits}", - " trees; k = {concavity}") - .Info(1L, Sys.time(), ": Score: ", signif(bestScore)) - finalEdges <- .Search('Final search') - newBestScore <- .Score(finalEdges[, , 1]) - improved <- newBestScore + epsilon < bestScore - bestEdges <- if (improved) { - .ReplaceResults(bestEdges, finalEdges, 1 + tbrStart + ratchIter + 1) - } else { - .CombineResults(bestEdges, finalEdges, 1 + tbrStart + ratchIter + 1) - } - } - - # Return: - .ReturnValue(bestEdges) -} - -#' Combine two edge matrices -#' -#' @param x,y 3D arrays, each slice containing an edge matrix from a tree -#' of class `phylo`. -#' @return A single 3D array containing each unique edge matrix from (`x` and) -#' `y`, with a `firstHit` attribute as documented in [`MaximizeParsimony()`]. -#' @template MRS -#' @keywords internal -.CombineResults <- function (x, y, stage) { - xDim <- dim(x) - if (length(xDim) == 2L) { - xDim <- c(xDim, 1L) - } - - res <- unique(array(c(x, y), dim = xDim + c(0, 0, dim(y)[3])), MARGIN = 3L) - firstHit <- attr(x, 'firstHit') - firstHit[stage] <- dim(res)[3] - xDim[3] - attr(res, 'firstHit') <- firstHit - - # Return: - res -} - -#' @rdname dot-CombineResults -#' @param old old array of edge matrices with `firstHit` attribute. -#' @param new new array of edge matrices. -#' @param stage Integer specifying element of `firstHit` in which new hits -#' should be recorded. -#' @keywords internal -.ReplaceResults <- function (old, new, stage) { - hit <- attr(old, 'firstHit') - hit[] <- 0 - hit[stage] <- dim(new)[3] - structure(new, 'firstHit' = hit) -} - -#' @rdname MaximizeParsimony -#' -#' @param method Unambiguous abbreviation of `jackknife` or `bootstrap` -#' specifying how to resample characters. Note that jackknife is considered -#' to give more meaningful results. -#' -#' @param proportion Numeric between 0 and 1 specifying what proportion of -#' characters to retain under jackknife resampling. -#' -#' @section Resampling: -#' Note that bootstrap support is a measure of the amount of data supporting -#' a split, rather than the amount of confidence that should be afforded the -#' grouping. -#' "Bootstrap support of 100% is not enough, the tree must also be correct" -#' \insertCite{Phillips2004}{TreeSearch}. -#' See discussion in \insertCite{Egan2006;textual}{TreeSearch}; -#' \insertCite{Wagele2009;textual}{TreeSearch}; -#' \insertCite{Simmons2011}{TreeSearch}; -#' \insertCite{Kumar2012;textual}{TreeSearch}. -#' -#' For a discussion of suitable search parameters in resampling estimates, see -#' \insertCite{Muller2005;textual}{TreeSearch}. -#' The user should decide whether to start each resampling -#' from the optimal tree (which may be quicker, but result in overestimated -#' support values as searches get stuck in local optima close to the -#' optimal tree) or a random tree (which may take longer as more rearrangements -#' are necessary to find an optimal tree on each iteration). -#' -#' For other ways to estimate clade concordance, see [`SiteConcordance()`]. -#' -#' @return `Resample()` returns a `multiPhylo` object containing a list of -#' trees obtained by tree search using a resampled version of `dataset`. -#' @family split support functions -#' @encoding UTF-8 -#' @export -Resample <- function (dataset, tree, method = 'jack', - proportion = 2/3, - ratchIter = 1L, tbrIter = 8L, finalIter = 3L, - maxHits = 12L, concavity = Inf, - tolerance = sqrt(.Machine$double.eps), - constraint, - verbosity = 2L, - ...) { - if (!inherits(dataset, 'phyDat')) { - stop("`dataset` must be of class `phyDat`.") - } - index <- attr(dataset, 'index') - kept <- switch(pmatch(tolower(method), c('jackknife', 'bootstrap')), - { - nKept <- ceiling(proportion * length(index)) - if (nKept < 1L) { - stop("No characters retained. `proportion` must be positive.") - } - if (nKept == length(index)) { - stop("`proportion` too high; no characters deleted.") - } - sample(index, nKept) - }, { - sample(index, length(index), replace = TRUE) - }) - if (is.null(kept)) { - stop("`method` must be either 'jackknife' or 'bootstrap'.") - } - - attr(dataset, 'index') <- kept - attr(dataset, 'weight') <- vapply(seq_len(attr(dataset, 'nr')), - function (x) sum(kept == x), - integer(1)) - - MaximizeParsimony(dataset, tree = tree, - ratchIter = ratchIter, tbrIter = tbrIter, - finalIter = finalIter, - maxHits = maxHits, - concavity = concavity, - tolerance = tolerance, constraint = constraint, - verbosity = verbosity, ...) -} - -#' Launch tree search graphical user interface -#' -#' @rdname MaximizeParsimony -#' @importFrom cluster pam silhouette -#' @importFrom future future -#' @importFrom promises future_promise -#' @importFrom protoclust protoclust -#' @importFrom Rogue ColByStability -#' @importFrom shiny runApp -#' @importFrom shinyjs useShinyjs -#' @importFrom TreeDist ClusteringInfoDistance -#' @export -EasyTrees <- function () {#nocov start - shiny::runApp(system.file('Parsimony', package = 'TreeSearch')) -} - -#' @rdname MaximizeParsimony -#' @export -EasyTreesy <- EasyTrees -#nocov end - -.UseProfile <- function (concavity) { - pmatch(tolower(concavity), "profile", -1L) == 1L -} diff --git a/R/NNI.R b/R/NNI.R deleted file mode 100644 index a05b12ec5..000000000 --- a/R/NNI.R +++ /dev/null @@ -1,236 +0,0 @@ -#' Nearest neighbour interchange (NNI) -#' -#' `NNI()`performs a single iteration of the nearest-neighbour interchange -#' algorithm; `RootedNNI()` retains the position of the root. -#' These functions are based on equivalents in the '\pkg{phangorn}' package. -#' `cNNI()` is an equivalent function coded in C, that runs much faster. -#' -#' Branch lengths are not supported. -#' -#' -#' -#' All nodes in a tree must be bifurcating; [ape::collapse.singles()] and -#' [ape::multi2di()] may help. -#' -#' @param tree A tree of class `phylo`. -#' For `cNNI()`, this must be a binary tree rooted on a single leaf, whose root -#' node is the lowest numbered internal node. -#' @template treeParam -#' @param edgeToBreak In (`Rooted`)`NNI()`, an optional integer specifying the -#' index of an edge to bisect/prune, generated randomly if not specified. -#' If \code{-1}, a complete list of all trees one step from the input tree -#' will be returned. -#' In `cNNI()`, an integer from zero to `nEdge(tree) - nTip(tree) - 2`, -#' specifying which internal edge to break. -#' -#' @return Returns a tree with class \code{phylo} (if \code{returnAll = FALSE}) or -#' a set of trees, with class \code{multiPhylo} (if \code{returnAll = TRUE}). -#' -#' @references -#' The algorithm is summarized in -#' \insertRef{Felsenstein2004}{TreeSearch} -#' -#' -#' @examples -#' tree <- TreeTools::BalancedTree(8) -#' # A random rearrangement -#' NNI(tree) -#' cNNI(tree) -#' -#' # All trees one NNI rearrangement away -#' NNI(tree, edgeToBreak = -1) -#' -#' # Manual random sampling -#' cNNI(tree, sample.int(14 - 8 - 1, 1), sample.int(2, 1)) -#' -#' # A specified rearrangement -#' cNNI(tree, 0, 0) -#' -#' # If a tree may not be binary, collapse nodes with -#' tree <- TreeTools::MakeTreeBinary(tree) -#' -#' # If a tree may be improperly rooted, use -#' tree <- TreeTools::RootTree(tree, 1) -#' -#' # If a tree may exhibit unusual node ordering, this can be addressed with -#' tree <- TreeTools::Preorder(tree) -#' @template MRS -#' -#' @family tree rearrangement functions -#' @export -NNI <- function (tree, edgeToBreak = NULL) { - edge <- tree$edge - parent <- edge[, 1] - StopUnlessBifurcating(parent) - if (!is.null(edgeToBreak) && edgeToBreak == -1) { - child <- edge[, 2] - nTips <- (length(parent) / 2L) + 1L - samplable <- child > nTips - # newEdges <- vapply(which(samplable), DoubleNNI, parent=parent, child=child, list(matrix(0L, nEdge, 2), matrix(0L, nEdge, 2))) - newEdges <- unlist(lapply(which(samplable), DoubleNNI, - parent = parent, child = child), recursive = FALSE) # Quicker than vapply, surprisingly - newTrees <- structure(lapply(newEdges, function (edges) {tree$edge <- edges; tree}), # Quicker than vapply, surprisingly - class = 'multiPhylo') - # Return: - newTrees - } else { - newEdge <- NNISwap(parent, edge[, 2], edgeToBreak = edgeToBreak) - tree$edge <- cbind(newEdge[[1]], newEdge[[2]]) - - # Return: - tree - } -} - - -#' @param whichSwitch Integer from zero to one, specifying which way to re-build -#' the broken internal edge. -#' -#' @return `cNNI()` returns a tree of class `phylo`, rooted on the same leaf, -#' on which the specified rearrangement has been conducted. -#' @rdname NNI -#' @importFrom TreeTools NTip -#' @export -cNNI <- function (tree, edgeToBreak = NULL, whichSwitch = NULL) { - edge <- tree$edge - if (is.null(edgeToBreak)) edgeToBreak <- sample.int(dim(edge)[1] - NTip(tree) - 1L, 1L) - if (is.null(whichSwitch)) whichSwitch <- sample.int(2L, 1L) - tree$edge <- nni(edge, edgeToBreak, whichSwitch) - - # Return: - tree -} - -#' @describeIn NNI faster version that takes and returns parent and child parameters -#' @template treeParent -#' @template treeChild -#' @param nTips (optional) Number of tips. -#' @return `NNISwap()` returns a list containing two elements, corresponding in -#' turn to the rearranged parent and child parameters. -#' @importFrom TreeTools SampleOne -#' @export -NNISwap <- function (parent, child, nTips = (length(parent) / 2L) + 1L, - edgeToBreak = NULL) { - rootNode <- nTips + 1L - samplable <- child > nTips - if (!any(samplable)) stop("Not enough edges to allow NNI rearrangement") - - if (is.null(edgeToBreak)) { - edgeToBreak <- SampleOne(which(samplable)) - } else if (!samplable[edgeToBreak]) { - stop("edgeToBreak must be an internal edge") - } - - if (is.na(edgeToBreak)) stop("Cannot find a valid rearrangement") - - end1 <- parent[edgeToBreak] - end2 <- child[edgeToBreak] - ind1 <- which(parent == end1) - ind1 <- ind1[ind1 != edgeToBreak][1] - ind2 <- which(parent == end2)[sample.int(2L, 1L, useHash = FALSE)] - - newInd <- c(ind2, ind1) - oldInd <- c(ind1, ind2) - childSwap <- child[newInd] - child[oldInd] <- childSwap - RenumberEdges(parent, child) -} - -## TODO use RenumberList -#' Double NNI -#' -#' Returns the edge parameter of the two trees consistent with the speficied \acronym{NNI} rearrangement -#' -#' @template treeParent -#' @template treeChild -#' @template edgeToBreakParam -#' -#' @return the \code{tree$edge} parameter of the two trees consistent with the specified rearrangement -#' -#' @keywords internal -#' @importFrom TreeTools RenumberTree -#' @author Martin R. Smith -#' -DoubleNNI <- function (parent, child, edgeToBreak) { - end1 <- parent[edgeToBreak] - end2 <- child[edgeToBreak] - ind1 <- which(parent == end1) - ind1 <- ind1[ind1 != edgeToBreak][1] - ind2.3 <- which(parent == end2) - ind2 <- ind2.3[1] - ind3 <- ind2.3[2] - - newInd <- c(ind2, ind1) - oldInd <- c(ind1, ind2) - child2 <- child - childSwap <- child[newInd] - child2[oldInd] <- childSwap - - newInd <- c(ind3, ind1) - oldInd <- c(ind1, ind3) - childSwap <- child[newInd] - child[oldInd] <- childSwap - - nEdge <- length(parent) - - # Return: - list(RenumberTree(parent, child), RenumberTree(parent, child2)) -} - -#' Rooted NNI -#' @describeIn NNI Perform \acronym{NNI} rearrangement, retaining position of root -#' @export -RootedNNI <- function (tree, edgeToBreak=NULL) { - edge <- tree$edge - if (!is.null(edgeToBreak) && edgeToBreak == -1) { - parent <- edge[, 1] - child <- edge[, 2] - nTips <- (length(parent) / 2L) + 1L - rootNode <- nTips + 1L - samplable <- parent != rootNode & child > nTips - newEdges <- unlist(lapply(which(samplable), DoubleNNI, - parent = parent, child = child), - recursive = FALSE) # Quicker than vapply, surprisingly - newTrees <- lapply(newEdges, function (edges) {tree$edge <- edges; tree}) # Quicker than vapply, surprisingly - - # Return: - newTrees - } else { - newEdge <- RootedNNISwap(edge[, 1], edge[, 2], edgeToBreak=edgeToBreak) - tree$edge <- cbind(newEdge[[1]], newEdge[[2]]) - - # Return: - tree - } -} - -#' @describeIn NNI faster version that takes and returns parent and child parameters -#' @return a list containing two elements, corresponding in turn to the rearranged parent and child parameters -#' @export -RootedNNISwap <- function (parent, child, nTips = (length(parent) / 2L) + 1L, - edgeToBreak = NULL) { - rootNode <- nTips + 1L - - samplable <- parent != rootNode & child > nTips - - if (is.null(edgeToBreak)) { - edgeToBreak <- SampleOne(which(samplable)) - } else if (!samplable[edgeToBreak]) { - stop("edgeToBreak cannot include a tip or the root node") - } - - if (is.na(edgeToBreak)) stop("Cannot find a valid rearrangement") - - end1 <- parent[edgeToBreak] - end2 <- child[edgeToBreak] - ind1 <- which(parent == end1) - ind1 <- ind1[ind1 != edgeToBreak][1] - ind2 <- which(parent == end2)[sample.int(2L, 1L, useHash=FALSE)] - - newInd <- c(ind2, ind1) - oldInd <- c(ind1, ind2) - - child_swap <- child[newInd] - child[oldInd] <- child_swap - RenumberEdges(parent, child) -} diff --git a/R/PlotCharacter.R b/R/PlotCharacter.R deleted file mode 100644 index 6c40db83f..000000000 --- a/R/PlotCharacter.R +++ /dev/null @@ -1,401 +0,0 @@ -#' Plot the distribution of a character on a tree -#' -#' Reconstructs the distribution of a character on a tree topology using the -#' modified Fitch algorithm presented in -#' \insertCite{Brazeau2019;textual}{TreeSearch}. -#' -#TODO November 2021: REMOVE next para -#' Correct colouration of internal nodes requires "ape" version 5.5.2. -#' Until this is available on CRAN (expected in winter 2021), download it -#' using `devtools::install_github('emmanuelparadis/ape')`. -#' -#' @template treeParam -#' @template datasetParam -#' @param char Index of character to plot. -#' @param updateTips Logical; if `FALSE`, tips will be labelled with their -#' original state in `dataset`. -#' @param plot Logical specifying whether to plot the output. -#' @param tokenCol Palette specifying colours to associate with each token in -#' turn, in the sequence listed in `attr(dataset, 'levels')`. -#' @param ambigCol,ambigLty,inappCol,inappLty,plainLty Colours and line types -#' to apply to ambiguous, inapplicable and applicable tokens. See the `lty` -#' [graphical parameter] for details of line styles. Overrides `tokenCol`. -#' @param tipOffset Numeric: how much to offset tips from their labels. -#' @param unitEdge Logical: Should all edges be plotted with a unit length? -#' @param \dots Further arguments to pass to `plot.phylo()`. -#' -#' @return `PlotCharacter()` returns a matrix in which each row corresponds -#' to a numbered tip or node of `tree`, and each column corresponds to a -#' token; the tokens that might parsimoniously be present at each point -#' on a tree are denoted with `TRUE`. -#' -#' @references -#' \insertAllCited{} -#' @examples -#' # Set up plotting area -#' oPar <- par(mar = rep(0, 4)) -#' -#' tree <- ape::read.tree(text = -#' "((((((a, b), c), d), e), f), (g, (h, (i, (j, (k, l))))));") -#' ## A character with inapplicable data -#' dataset <- TreeTools::StringToPhyDat("23--1??--032", tips = tree) -#' PlotCharacter(tree, dataset) -#' -#' # Character from a real dataset -#' data("Lobo", package = "TreeTools") -#' dataset <- Lobo.phy -#' tree <- TreeTools::NJTree(dataset) -#' PlotCharacter(tree, dataset, 14) -#' par(oPar) -#' @template MRS -#' @importFrom ape plot.phylo nodelabels -#' @importFrom graphics par -#' @importFrom TreeTools Postorder -#' @export -PlotCharacter <- function (tree, dataset, char = 1L, - updateTips = FALSE, - plot = TRUE, - - tokenCol = NULL, - ambigCol = 'grey', - inappCol = 'lightgrey', - - ambigLty = 'dotted', - inappLty = 'dashed', - plainLty = par('lty'), - - tipOffset = 1, - unitEdge = FALSE, - ...) { - - # Reconcile labels - datasetTaxa <- names(dataset) - treeTaxa <- tree$tip.label - if(!all(treeTaxa %fin% datasetTaxa)) { - stop("Taxa in tree missing from dataset:\n ", - paste0(setdiff(treeTaxa, datasetTaxa), collapse = ', ')) - } - dataset <- dataset[treeTaxa] - - # Read tree - tree <- Postorder(tree) - nNode <- tree$Nnode - nTip <- NTip(tree) - edge <- tree$edge - parent <- edge[, 1] - child <- edge[, 2] - left <- integer(nNode + nTip) - right <- left - parentOf <- integer(nNode + nTip) - for (e in seq_len(dim(edge)[1])) { - pa <- parent[e] - ch <- child[e] - parentOf[ch] <- pa - if (right[pa]) { - left[pa] <- ch - } else { - right[pa] <- ch - } - } - postOrderNodes <- unique(parent) - preOrderNodes <- rev(postOrderNodes) - rootNode <- preOrderNodes[1] - parentOf[rootNode] <- rootNode - tips <- seq_len(nTip) - - # Read states - if (!inherits(dataset, 'phylo')) { - dataset <- MatrixToPhyDat(dataset) - } - character <- dataset[, char] - contrast <- attr(character, 'contrast') == 1 - levels <- colnames(contrast) - inputState <- contrast[as.integer(character), , drop = FALSE] - state <- rbind(inputState, matrix(NA, nNode, dim(contrast)[2])) - - if (is.na(match('-', levels))) { - # Standard Fitch - for (n in postOrderNodes) { - lState <- state[left[n], ] - rState <- state[right[n], ] - common <- lState & rState - if (any(common)) { - state[n, ] <- common - } else { - state[n, ] <- lState | rState - # Also add to score - } - } - - for (n in preOrderNodes) { - nState <- state[n, ] - aState <- state[parentOf[n], ] - lState <- state[left[n], ] - rState <- state[right[n], ] - inherited <- nState & aState - if (all(inherited == aState)) { - state[n, ] <- inherited - } else if (any(lState & rState)) { - state[n, ] <- nState | (aState & (lState | rState)) - } else { - state[n, ] <- aState | nState - } - } - - for (n in tips) { - nState <- state[n, ] - aState <- state[parentOf[n], ] - common <- aState & nState - if (any(common)) { - state[n, ] <- common - } - } - - } else { - # Inapplicable Fitch, Brazeau, Guillerme & Smith 2019 - inappLevel <- levels == '-' - appLevels <- !inappLevel - - # First downpass - for (n in postOrderNodes) { - lState <- state[left[n], ] - rState <- state[right[n], ] - common <- lState & rState - if (any(common)) { # 2 - # If the token in common is only the inapplicable token, - # and both descendants have an applicable token - if (all(common == inappLevel) && - any(lState[appLevels]) && - any(rState[appLevels]) - ) { - # Set the node’s state to be the union of the descendants’ states - state[n, ] <- lState | rState - } else { - # set the node’s state to be the token in common between both descendants - state[n, ] <- common - } - } else { # 3 - # If both descendants have an applicable token - if (any(lState[appLevels]) && any(rState[appLevels])) { - # set the node’s state to be the union of both descendants’ states - # without the inapplicable token - state[n, ] <- (lState | rState) & appLevels - } else { - # set the node’s state to be the union of its descendants’ states - state[n, ] <- lState | rState - } - } - # message ("DP1: Set node ", n, " to: ", paste0(levels[state[n, ]], collapse = '')) - } - - # First uppass - for (n in preOrderNodes) { - nState <- state[n, ] - aState <- if (n == rootNode && !all(state[n, ] == inappLevel)) { - state[n, ] & appLevels - } else { - state[parentOf[n], ] - } - - lState <- state[left[n], ] - rState <- state[right[n], ] - # 1. If the node has the inapplicable token - if (any(nState[inappLevel])) { - # 2. If the node also has an applicable token - if (any(nState[appLevels])) { - # 3. If the node’s ancestor has the inapplicable token - if (any(aState[inappLevel])) { - # set the node’s state to be the inapplicable token only - state[n, ] <- inappLevel - } else { - # remove the inapplicable token from the current node’s state - state[n, ] <- nState & appLevels - } - } else { - # 4. If the node’s ancestor has the inapplicable token - if (any(aState[inappLevel])) { - # set the node’s state to be the inapplicable token only - } else { - # 5. If any of the descendants have an applicable token - if (any(lState[appLevels]) || any(rState[appLevels])) { - # set the node’s state to be the union of the applicable states - # of its descendants - state[n, ] <- (lState | rState) & appLevels - } else { - # set the node’s state to be the inapplicable token only - state[n, ] <- inappLevel - } - } - } - } - # message ("UP1: Set node ", n, " to: ", paste0(levels[state[n, ]], collapse = '')) - } - for (n in tips) { - nState <- state[n, ] - aState <- state[parentOf[n], ] - # 6. If the unvisited tip includes both inapplicable and applicable tokens - if (any(nState[inappLevel]) && any(nState[appLevels])) { - # 7. If the current node has only the inapplicable token - if (all(aState == inappLevel)) { - # set the tip’s state to the inapplicable token only - state[n, ] <- inappLevel - } else { - # remove the inapplicable token from the tip’s state - state[n, ] <- nState & appLevels - } - } - # message ("UP1: Set tip ", n, " to: ", paste0(levels[state[n, ]], collapse = '')) - } - - # Second downpass - for (n in postOrderNodes) { - nState <- state[n, ] - lState <- state[left[n], ] - rState <- state[right[n], ] - # If the node had an applicable token in the first uppass - if (any(nState[appLevels])) { - # 3. If there is any token in common between both descendants - common <- lState & rState - if (any(common)) { - # 4. If the tokens in common are applicable - if (any(common[appLevels])) { - # set the node’s state to be the tokens held in common, - # without the inapplicable token - state[n, ] <- common & appLevels - } else { - # set the node’s state to be the inapplicable token - state[n, ] <- inappLevel - } - } else { - # 5. Set the node’s state to be the union of the states of both - # descendants (if present) without the inapplicable token - state[n, ] <- (lState | rState) & appLevels - } - } - # message ("DP2: Set node ", n, " to: ", paste0(levels[state[n, ]], collapse = '')) - } - - # Second uppass - for (n in preOrderNodes) { - nState <- state[n, ] - aState <- state[parentOf[n], ] - lState <- state[left[n], ] - rState <- state[right[n], ] - # 1. If the node has any applicable token - if (any(nState[appLevels])) { - # 2. If the node’s ancestor has any applicable token - if (any(aState[appLevels])) { - #2A [ADDED IN ERRATUM?] - common <- aState & nState - if (any(common) && all(common == aState)) { - state[n, ] <- aState - } else - # 3. If the node’s state is NOT the same as its ancestor’s - # if (any(nState != aState)) - { - # 4. If there is any token in common between the node’s descendants - common <- lState & rState - if (any(common)) { - # 5. Add to the current node’s state any token in common between - # its ancestor and *either of* its descendants - state[n, ] <- nState | (aState & (lState | rState)) - } else { - # 6. If the states of the node’s descendants both contain the - # inapplicable token - if (any(lState[inappLevel]) && any(rState[inappLevel])) { - # 7. If there is any token in common between either of the - # node’s descendants and its ancestor - if (any(lState & aState) || any(rState & aState)) { - # set the node’s state to be its ancestor’s state - state[n, ] <- aState - } else { - # set the current node’s state to be all applicable tokens - # common to both its descendants and ancestor - state[n, ] <- appLevels & common & aState - } - } else { - # 8. Add to the node’s state the tokens of its ancestor - state[n, ] <- nState | aState - } - } - } - } - } - # message ("UP2: Set node ", n, " to: ", paste0(levels[state[n, ]], collapse = '')) - } - - for (n in tips) { - nState <- state[n, ] - aState <- state[parentOf[n], ] - common <- aState & nState - if (any(common)) { - state[n, ] <- common - # message ("UP2: Set tip ", n, " to: ", paste0(levels[state[n, ]], collapse = '')) - } - } - } - - if (!updateTips) { - state[seq_len(nTip), ] <- inputState - } - - hasToken <- if (length(setdiff(colnames(state), '-')) > 1L) { - as.logical(rowSums(!state[, colnames(state) != '-', drop = FALSE])) - } else { - !logical(nrow(state)) - } - anywhere <- as.logical(colSums(state[hasToken, , drop = FALSE])) - slimState <- state[, anywhere, drop = FALSE] - if (plot) { - tokens <- colnames(slimState) - if (is.null(tokenCol)) { - tokenCol <- tokens - tokenCol[tokens != '-'] <- c("#00bfc6", - "#ffd46f", - "#ffbcc5", - "#c8a500", - "#ffcaf5", - "#d5fb8d", - "#e082b4", - "#25ffd3", - "#a6aaff", - "#e6f3cc", - "#67c4ff", - "#9ba75c", - "#60b17f")[seq_along(setdiff(tokens, '-'))] - tokenCol[tokens == '-'] <- inappCol - } - nodeStyle <- apply(slimState, 1, function (tkn) { - if (length(tkn) == 0) { - c(col = ambigCol, lty = ambigLty) - } else if (sum(tkn) > 1L) { - c(col = ambigCol, lty = ambigLty) - } else { - c(col = tokenCol[tkn], - lty = ifelse(tokens[tkn] == '-', inappLty, plainLty)) - } - }) - if (unitEdge) { - tree$edge.length <- rep_len(1, dim(tree$edge)[1]) - } - plot.phylo(tree, - node.color = nodeStyle['col', , drop = FALSE], - node.lty = nodeStyle['lty', , drop = FALSE], - label.offset = tipOffset, - ...) - - NodeText <- function (n) { - if (length(n) == 0 || ( - sum(n) > 1L && all(n[anywhere & names(n) != '-']))) { - '?' - } else { - paste0(levels[n], collapse = '') - } - } - nodelabels(apply(state, 1, NodeText), - seq_len(nTip + nNode), bg = nodeStyle['col', , drop = FALSE]) - } - - # Return: - slimState -} diff --git a/R/RandomTreeScore.R b/R/RandomTreeScore.R deleted file mode 100644 index 200d50fc5..000000000 --- a/R/RandomTreeScore.R +++ /dev/null @@ -1,53 +0,0 @@ -#' Parsimony score of random postorder tree -#' -#' @template morphyObjParam -#' -#' @return `RandomTreeScore()` returns the parsimony score of a random tree -#' for the given Morphy object. -#' @examples -#' tokens <- matrix(c( -#' 0, '-', '-', 1, 1, 2, -#' 0, 1, 0, 1, 2, 2, -#' 0, '-', '-', 0, 0, 0), byrow = TRUE, nrow = 3L, -#' dimnames = list(letters[1:3], NULL)) -#' pd <- TreeTools::MatrixToPhyDat(tokens) -#' morphyObj <- PhyDat2Morphy(pd) -#' -#' RandomTreeScore(morphyObj) -#' -#' morphyObj <- UnloadMorphy(morphyObj) -#' @export -RandomTreeScore <- function (morphyObj) { - nTip <- mpl_get_numtaxa(morphyObj) - if (nTip < 2) { - # Return: - 0L - } else { - # Return: - .Call('RANDOM_TREE_SCORE', as.integer(nTip), morphyObj) - } -} - -#' Random postorder tree -#' -#' @param nTip Integer specifying the number of tips to include in the tree -#' (minimum 2). -#' -#' @return A list with three elements, each a vector of integers, respectively -#' containing: -#' -#' - The parent of each tip and node, in order -#' -#' - The left child of each node -#' -#' - The right child of each node. -#' -#' @family tree generation functions -#' @export -RandomMorphyTree <- function (nTip) { - if (nTip < 2) { - stop("nTip < 2 not implemented: a tip is not a tree.") - } - # Return: - .Call('RANDOM_TREE', as.integer(nTip)) -} diff --git a/R/Ratchet.R b/R/Ratchet.R deleted file mode 100644 index e25ec9ef0..000000000 --- a/R/Ratchet.R +++ /dev/null @@ -1,276 +0,0 @@ -#' Parsimony Ratchet -#' -#' `Ratchet()` uses the parsimony ratchet \insertCite{Nixon1999}{TreeSearch} -#' to search for a more parsimonious tree using custom optimality criteria. -#' -#' For usage pointers, see the -#' [vignette](https://ms609.github.io/TreeSearch/articles/custom.html). -#' -#' @template treeParam -#' @param dataset a dataset in the format required by `TreeScorer()`. -#' @template InitializeDataParam -#' @template CleanUpDataParam -#' @template treeScorerParam -#' @param Bootstrapper Function to perform bootstrapped rearrangements of tree. -#' First arguments will be an `edgeList` and a dataset, initialized using -#' `InitializeData()`. Should return a rearranged `edgeList`. -#' @template swappersParam -#' @param BootstrapSwapper Function such as \code{\link{RootedNNISwap}} to use -#' to rearrange trees within `Bootstrapper()`. -#' @param returnAll Set to \code{TRUE} to report all MPTs encountered during the -#' search, perhaps to analyse consensus. -#' @param ratchIter Stop when this many ratchet iterations have been performed. -#' @param ratchHits Stop when this many ratchet iterations have found the same -#' best score. -#' @param searchIter Integer specifying maximum rearrangements to perform on each bootstrap or -#' ratchet iteration. -#' To override this value for a single swapper function, set e.g. -#' `attr(SwapperFunction, 'searchIter') <- 99` -#' @param searchHits Integer specifying maximum times to hit best score before terminating a tree -#' search within a ratchet iteration. -#' To override this value for a single swapper function, set e.g. -#' `attr(SwapperFunction, 'searchHits') <- 99` -#' @param bootstrapIter Integer specifying maximum rearrangements to perform on each bootstrap -#' iteration (default: `searchIter`). -#' @param bootstrapHits Integer specifying maximum times to hit best score on each bootstrap -#' iteration (default: `searchHits`). -#' @template stopAtScoreParam -#' @template stopAtPeakParam -#' @template stopAtPlateauParam -#' @template verbosityParam -#' @param suboptimal retain trees that are suboptimal by this score. -#' Defaults to a small value that will counter rounding errors. -#' @template treeScorerDots -#' -#' @return `Ratchet()` returns a tree modified by parsimony ratchet iterations. -#' -#' @references -#' \insertAllCited{} -#' -#' @examples -#' data('Lobo', package = 'TreeTools') -#' njtree <- TreeTools::NJTree(Lobo.phy) -#' # Increase value of ratchIter and searchHits to do a proper search -#' quickResult <- Ratchet(njtree, Lobo.phy, ratchIter = 2, searchHits = 3) -#' -#' # Plot result (legibly) -#' oldPar <- par(mar = rep(0, 4), cex = 0.75) -#' plot(quickResult) -#' par(oldPar) -#' @template MRS -#' -#' @seealso -#' - Adapted from \code{\link[phangorn:parsimony]{pratchet()}} in the -#' \pkg{phangorn} package. -#' -#' @family custom search functions -#' @importFrom TreeTools RenumberEdges RenumberTips -#' @export -Ratchet <- function (tree, dataset, - InitializeData = PhyDat2Morphy, - CleanUpData = UnloadMorphy, - TreeScorer = MorphyLength, - Bootstrapper = MorphyBootstrap, - swappers = list(TBRSwap, SPRSwap, NNISwap), - BootstrapSwapper = if (is.list(swappers)) - swappers[[length(swappers)]] else swappers, - returnAll = FALSE, stopAtScore = NULL, - stopAtPeak = FALSE, stopAtPlateau = 0L, - ratchIter = 100, ratchHits = 10, - searchIter = 4000, searchHits = 42, - bootstrapIter = searchIter, bootstrapHits = searchHits, - verbosity = 1L, - suboptimal = sqrt(.Machine$double.eps), ...) { - epsilon <- 1e-08 - hits <- 0L - # initialize tree and data - if (dim(tree$edge)[1] != 2 * tree$Nnode) stop("tree must be bifurcating; try rooting with ape::root") - tree <- RenumberTips(tree, names(dataset)) - edgeList <- tree$edge - edgeList <- RenumberEdges(edgeList[, 1], edgeList[, 2]) - - initializedData <- InitializeData(dataset) - on.exit(initializedData <- CleanUpData(initializedData)) - - bestScore <- TreeScorer(edgeList[[1]], edgeList[[2]], initializedData, ...) - - if (verbosity > 0L) { - message("* Beginning Parsimony Ratchet, with initial score ", bestScore, # nocov - if (!is.null(stopAtScore)) "; will stop at score ", stopAtScore) # nocov - } - if (!is.null(stopAtScore) && bestScore < stopAtScore + epsilon) { - if (verbosity > 1L) { - message("*** Target score of ", stopAtScore, " met.") # nocov - } - return(tree) - } - if (class(swappers) == 'function') swappers <- list(swappers) - - if (returnAll) { - nullForest <- vector('list', ratchIter) - forest <- nullForest - forestScores <- rep.int(NA, ratchIter) - } - - iterationsWithBestScore <- 0 - BREAK <- FALSE - for (i in 1:ratchIter) { - if (verbosity > 1L) { # nocov start - message("\n* Ratchet iteration ", i, '.') - if (verbosity > 2L) { - message(" - Generating new candidate tree by bootstrapping dataset.") - } - } # nocov end - candidate <- Bootstrapper(edgeList, initializedData, - maxIter = bootstrapIter, maxHits = bootstrapHits, - verbosity = verbosity - 2L, - EdgeSwapper = BootstrapSwapper, - stopAtPeak = stopAtPeak, - stopAtPlateau = stopAtPlateau, ...) - candScore <- 1e+08 - - if (verbosity > 2L) message(" - Rearranging from new candidate tree:") - for (EdgeSwapper in swappers) { - at <- attributes(EdgeSwapper) - Argument <- function (arg) if (!is.null(at[[arg]])) at[[arg]] else get(arg) - candidate <- EdgeListSearch(candidate, dataset = initializedData, - TreeScorer = TreeScorer, - EdgeSwapper = EdgeSwapper, - maxIter = Argument("searchIter"), - stopAtScore = Argument("stopAtScore"), - stopAtPeak = Argument("stopAtPeak"), - stopAtPlateau = Argument("stopAtPlateau"), - maxHits = Argument("searchHits"), - verbosity = verbosity - 2L, ...) - candScore <- candidate[[3]] - if (!is.null(stopAtScore) && candScore < stopAtScore + epsilon) { - BREAK <- TRUE - if (verbosity > 1L) { # nocov start - message(" * Target score ", stopAtScore, - " met; terminating tree search.") - } # nocov end - bestScore <- candScore - break - } - } - if (BREAK) { - break - } - - if (verbosity > 2L) { - message(" - Rearranged candidate tree scored ", candScore) # nocov - } - if (returnAll && candScore < (bestScore + suboptimal)) { # Worth saving this tree in forest - forest[[i]] <- candidate - forestScores[i] <- candScore - } - if ((candScore + epsilon) < bestScore) { - # New 'best' tree - edgeList <- candidate - bestScore <- candScore - iterationsWithBestScore <- 1L - } else if (bestScore + epsilon > candScore) { # i.e. best == cand, allowing for floating point error - iterationsWithBestScore <- iterationsWithBestScore + 1L - edgeList <- candidate - } - if (verbosity > 1L) { # nocov start - message("* Best score after ", i, "/", ratchIter, - " ratchet iterations: ", signif(bestScore), " (hit ", - iterationsWithBestScore, "/", ratchHits, ")\n") - } # nocov end - if ((!is.null(stopAtScore) && bestScore < stopAtScore + epsilon) - || (iterationsWithBestScore >= ratchHits)) { - break - } - } # end for - - if (verbosity > 0L) { - message("Completed parsimony ratchet after ", i, " iterations with score ", - bestScore, "\n") - } - - if (returnAll) { - keepers <- !is.na(forestScores) & forestScores < bestScore + suboptimal - forestScores <- forestScores[keepers] - forest <- forest[keepers] - if (verbosity > 1L) { - message("\n - Keeping ", sum(keepers), - " trees from iterations numbered:\n ", which(keepers)) - } - if (length(forest) > 1) { - forest[] <- lapply(forest, function (phy) { - x <- tree - x$edge <- cbind(phy[[1]], phy[[2]]) - attr(x, 'score') <- phy[[3]] - # Return to lapply: - x}) - ret <- unique(forest) - if (verbosity > 1L) { - message(" - Removing duplicates leaves ", length(ret), " unique trees") - } - uniqueScores <- vapply(ret, attr, double(1), 'score') - } else if (length(forest) == 1) { - ret <- tree - newEdge <- forest[[1]] - ret$edge <- cbind(newEdge[[1]], newEdge[[2]]) - uniqueScores <- newEdge[[3]] - } else { - stop("\nNo trees!? Is suboptimal set to a sensible (positive) value?") - } - if (verbosity > 0L) { # nocov start - message('\nFound ', sum(uniqueScores == min(uniqueScores)), - ' unique MPTs and ', - length(ret) - sum(uniqueScores == min(uniqueScores)), - ' suboptimal trees.\n') - } # nocov end - # Return: - ret - } else { - tree$edge <- cbind(edgeList[[1]], edgeList[[2]]) - attr(tree, 'score') <- bestScore - # Return: - tree - } -} - -#' Unique trees (ignoring 'hits' attribute) -#' @author Martin R. Smith -#' @keywords internal -#' @export -.UniqueExceptHits <- function (trees) { - unique(lapply(trees, function(tree) { - attr(tree, 'hits') <- NULL - tree - })) -} - -#' @rdname Ratchet -#' @return `MultiRatchet()` returns a list of optimal trees -#' produced by `nSearch` -#' ratchet searches, from which a consensus tree can be generated using -#' [`ape::consensus()`] or [`TreeTools::ConsensusWithout()`]. -#' @param nSearch Number of Ratchet searches to conduct -#' (for `RatchetConsensus()`) -#' @export -MultiRatchet <- function (tree, dataset, ratchHits=10, - searchIter=500, searchHits=20, verbosity=0L, - swappers=list(RootedNNISwap), nSearch=10, - stopAtScore=NULL, ...) { - trees <- lapply(seq_len(nSearch), function (i) { - if (verbosity > 1L) message("\nRatchet search ", i, '/', nSearch, ':') - Ratchet(tree, dataset, ratchIter = 1, ratchHits = 0L, - searchIter = searchIter, searchHits = searchHits, - verbosity = verbosity, swappers = swappers, - stopAtScore = stopAtScore, ...) - }) - scores <- vapply(trees, function (x) attr(x, 'score'), double(1)) - trees <- .UniqueExceptHits(trees[scores == min(scores)]) - message("Found ", length(trees), ' unique trees from ', nSearch, ' searches.') - - # Return: - structure(trees, class = 'multiPhylo') -} - -#' @describeIn Ratchet deprecated alias for `MultiRatchet()` -#' @export -RatchetConsensus <- MultiRatchet diff --git a/R/RcppExports.R b/R/RcppExports.R index e02c37edd..f35811d22 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,47 +1,7 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -preorder_morphy <- function(edge, MorphyHandl) { - .Call(`_TreeSearch_preorder_morphy`, edge, MorphyHandl) -} - -preorder_morphy_by_char <- function(edge, MorphyHandls) { - .Call(`_TreeSearch_preorder_morphy_by_char`, edge, MorphyHandls) -} - -morphy_iw <- function(edge, MorphyHandls, weight, minScore, sequence, concavity, target) { - .Call(`_TreeSearch_morphy_iw`, edge, MorphyHandls, weight, minScore, sequence, concavity, target) -} - -morphy_profile <- function(edge, MorphyHandls, weight, sequence, profiles, target) { - .Call(`_TreeSearch_morphy_profile`, edge, MorphyHandls, weight, sequence, profiles, target) -} - -nni <- function(edge, randomEdge, whichSwitch) { - .Call(`_TreeSearch_nni`, edge, randomEdge, whichSwitch) -} - -spr_moves <- function(edge) { - .Call(`_TreeSearch_spr_moves`, edge) -} - -spr <- function(edge, move) { - .Call(`_TreeSearch_spr`, edge, move) -} - -tbr <- function(edge, move) { - .Call(`_TreeSearch_tbr`, edge, move) -} - asan_error <- function(x) { .Call(`_TreeSearch_asan_error`, x) } -all_spr <- function(edge, break_order) { - .Call(`_TreeSearch_all_spr`, edge, break_order) -} - -all_tbr <- function(edge, break_order) { - .Call(`_TreeSearch_all_tbr`, edge, break_order) -} - diff --git a/R/ReleaseQuestions.R b/R/ReleaseQuestions.R deleted file mode 100644 index 5c56f2f96..000000000 --- a/R/ReleaseQuestions.R +++ /dev/null @@ -1,15 +0,0 @@ -release_questions <- function() { - c( - "Is the code free of #TODOs?", - "Have you updated REFERENCES.bib with a citation to the published study?", - "Have you updated inst/CITATION with a citation to the published study?", - "Have you updated the version number in inst/CITATION, NEWS and DESCRIPTION?" - ) -} - -# Additional tests: -# -# check_win_devel(); check_rhub() -# revdepcheck::revdep_check() -# build_vignettes() -# \ No newline at end of file diff --git a/R/SPR.R b/R/SPR.R deleted file mode 100644 index e5ba8cf3f..000000000 --- a/R/SPR.R +++ /dev/null @@ -1,392 +0,0 @@ -#' @describeIn TBRWarning for SPR rearrangements -#' @keywords internal -#' @export -SPRWarning <- function (parent, child, error) { - warning ("No SPR operation performed.\n > ", error) - - # Return: - list(parent, child) -} - -#' Subtree pruning and rearrangement (SPR) -#' -#' Perform one \acronym{SPR} rearrangement on a tree -#' -#' Equivalent to `kSPR` in the `phangorn` package, but faster. -#' Note that rearrangements that only change the position of the root WILL be returned by -#' \code{SPR}. If the position of the root is irrelevant (as in Fitch parsimony, for example) -#' then this function will occasionally return a functionally equivalent topology. -#' \code{RootIrrelevantSPR} will search tree space more efficiently in these cases. -#' Branch lengths are not (yet) supported. -#' -#' All nodes in a tree must be bifurcating; [ape::collapse.singles] and -#' [ape::multi2di] may help. -#' -#' @template treeParam -#' @param edgeToBreak the index of an edge to bisect, generated randomly if not specified. -#' @param mergeEdge the index of an edge on which to merge the broken edge. -#' @return This function returns a tree in \code{phyDat} format that has undergone one \acronym{SPR} iteration. -#' -#' @references The \acronym{SPR} algorithm is summarized in -#' \insertRef{Felsenstein2004}{TreeSearch} -#' -#' @author Martin R. Smith -#' -#' @seealso -#' - [`RootedSPR()`]: useful when the position of the root node should be retained. -#' @family tree rearrangement functions -#' -#' @examples{ -#' tree <- ape::rtree(20, br=FALSE) -#' SPR(tree) -#' } -#' @importFrom ape root -#' @importFrom TreeTools Preorder NonDuplicateRoot -#' @export -SPR <- function(tree, edgeToBreak = NULL, mergeEdge = NULL) { - if (is.null(treeOrder <- attr(tree, 'order')) || treeOrder != 'preorder') { - tree <- Preorder(tree) - } - edge <- tree$edge - parent <- edge[, 1] - StopUnlessBifurcating(parent) - if (!is.null(edgeToBreak) && edgeToBreak == -1) { - child <- edge[, 2] - nEdge <- length(parent) - stop('Negative edgeToBreak not yet supported; on TODO list for next release') - notDuplicateRoot <- NonDuplicateRoot(parent, child, nEdge) - # Return: - unique(unlist(lapply(which(notDuplicateRoot), AllSPR, - parent=parent, child=child, nEdge=nEdge, notDuplicateRoot=notDuplicateRoot), - recursive=FALSE)) # TODO the fact that we need to use `unique` indicates that - # we're being inefficient here. - } else { - newEdge <- SPRSwap(parent, edge[, 2], edgeToBreak = edgeToBreak, - mergeEdge = mergeEdge) - tree$edge <- cbind(newEdge[[1]], newEdge[[2]]) - # Return: - tree - } -} - -#' @rdname SPR -#' @return `TBRMoves()` returns a list of all trees one SPR move away from -#' `tree`, with edges and nodes in preorder, rooted on the first-labelled tip. -#' @export -SPRMoves <- function (tree, edgeToBreak = integer(0)) UseMethod('SPRMoves') - -#' @rdname SPR -#' @importFrom TreeTools Preorder RootTree -#' @export -SPRMoves.phylo <- function (tree, edgeToBreak = integer(0)) { - tree <- Preorder(RootTree(tree, tree$tip.label[1])) - edges <- unique(.all_spr(tree$edge, edgeToBreak)) - structure(lapply(edges, function (edg) { - tree$edge <- edg - tree - }), class = 'multiPhylo', tip.label = tree$tip.label) -} - -#' error checking for all_spr -.all_spr <- function (edge, break_order) { - nEdge <- dim(edge)[1] - if (nEdge < 5) { - stop("No SPR rearrangements possible on a tree with < 5 edges"); - } - nInternal <- floor(nEdge / 2) - nTip <- nInternal + 1L - rootNode <- nTip + 1L - - if (edge[1] != rootNode) { - stop("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); - } - if (edge[2] != rootNode) { - stop("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); - } - # Return: - all_spr(edge, break_order) -} - -#' @rdname SPR -#' @export -SPRMoves.matrix <- function (tree, edgeToBreak = integer(0)) { - tree <- Preorder(RootTree(tree, 1)) - unique(.all_spr(tree, edgeToBreak)) -} - -## TODO Do edges need to be pre-ordered before coming here? -#' @describeIn SPR faster version that takes and returns parent and child parameters -#' @template treeParent -#' @template treeChild -#' @template treeNEdgeOptional -#' @param nNode (optional) Number of nodes. -#' @return a list containing two elements, corresponding in turn to the -#' rearranged parent and child parameters -#' @importFrom TreeTools DescendantEdges NonDuplicateRoot -#' @export -SPRSwap <- function (parent, child, nEdge = length(parent), nNode = nEdge / 2L, - edgeToBreak = NULL, mergeEdge = NULL) { - - if (nEdge < 5) return (list(parent, child)) #TODO we need to re-root this tree... - - notDuplicateRoot <- NonDuplicateRoot(parent, child, nEdge) - - if (is.null(edgeToBreak)) { - # Pick an edge at random - edgeToBreak <- SampleOne(which(notDuplicateRoot), len=nEdge - 1L) - } else if (edgeToBreak > nEdge) { - return(SPRWarning(parent, child, "edgeToBreak > nEdge")) - } else if (edgeToBreak < 1) { - return(SPRWarning(parent, child, "edgeToBreak < 1")) - } - # Breaking a single edge - brokenEdge <- seq_along(parent) == edgeToBreak - brokenEdge.parentNode <- parent[edgeToBreak] - brokenEdge.childNode <- child[edgeToBreak] - - edgesCutAdrift <- DescendantEdges(edgeToBreak, parent, child, nEdge) - edgesOnAdriftSegment <- edgesCutAdrift | brokenEdge - - brokenEdgeParent <- child == brokenEdge.parentNode - brokenEdgeSister <- parent == brokenEdge.parentNode & !brokenEdge - brokenEdgeDaughters <- parent == brokenEdge.childNode - nearBrokenEdge <- brokenEdge | brokenEdgeSister | brokenEdgeParent | brokenEdgeDaughters - if (breakingRootEdge <- !any(brokenEdgeParent)) { - # Edge to break is the Root Node. - brokenRootDaughters <- parent == child[brokenEdgeSister] - nearBrokenEdge <- nearBrokenEdge | brokenRootDaughters - } - - if (!is.null(mergeEdge)) { # Quick sanity checks - if (mergeEdge > nEdge) return(SPRWarning(parent, child, "mergeEdge value > number of edges")) - if (length(mergeEdge) != 1) - return(SPRWarning(parent, child, paste0("mergeEdge value ", paste(mergeEdge, collapse='|'), - " invalid; must be NULL or a vector of length 1\n"))) - if(nearBrokenEdge[mergeEdge]) return(SPRWarning(parent, child, "Selected mergeEdge will not change tree topology.")) - if(DescendantEdges(edgeToBreak, parent, child, nEdge)[mergeEdge]) stop("mergeEdge is within pruned subtree") - } else { - mergeEdge <- which(!nearBrokenEdge & !edgesOnAdriftSegment & notDuplicateRoot) - nCandidates <- length(mergeEdge) - #####Assert(nCandidates > 0) - if (nCandidates > 1) mergeEdge <- SampleOne(mergeEdge, len=nCandidates) - } - - if (breakingRootEdge) { - parent[brokenRootDaughters] <- brokenEdge.parentNode - spareNode <- child[brokenEdgeSister] - child [brokenEdgeSister] <- child[mergeEdge] - parent[brokenEdge | brokenEdgeSister] <- spareNode - child[mergeEdge] <- spareNode - } else { - parent[brokenEdgeSister] <- parent[brokenEdgeParent] - parent[brokenEdgeParent] <- parent[mergeEdge] - parent[mergeEdge] <- brokenEdge.parentNode - } - - #####Assert(identical(unique(table(parent)), 2L)) - #####Assert(identical(unique(table(child)), 1L)) - return (RenumberEdges(parent, child)) -} - - -#' `cSPR()` expects a tree rooted on a single tip. -#' @template treeParam -#' @param whichMove Integer specifying which SPR move index to perform. -#' @examples -#' tree <- TreeTools::BalancedTree(8) -#' -#' # Tree must be rooted on leaf -#' tree <- TreeTools::RootTree(tree, 1) -#' -#' # Random rearrangement -#' cSPR(tree) -#' -#' # Specific rearrangement -#' cSPR(tree, 9) -#' @template MRS -#' @importFrom TreeTools NTip -#' @export -cSPR <- function (tree, whichMove = NULL) { - edge <- tree$edge - if (is.null(whichMove)) whichMove <- sample.int(2147483647L, 1L) - tree$edge <- spr(edge, whichMove) - - # Return: - tree -} - - -#' All SPR trees -#' -#' @template treeParent -#' @template treeChild -#' @template treeNEdge -#' @param notDuplicateRoot logical vector of length `nEdge`, specifying for each -#' edge whether it is the second edge leading to the root (in which case -#' its breaking will be equivalent to breaking the other root edge... -#' except insofar as it moves the position of the root.) -#' @template edgeToBreakParam -#' -#' @return `AllSPR()` returns a list of edge matrices for all trees one SPR -#' rearrangement from the starting tree -#' -#' @author Martin R. Smith -#' -AllSPR <- function (parent, child, nEdge, notDuplicateRoot, edgeToBreak) { - - brokenEdge <- seq_along(parent) == edgeToBreak - brokenEdge.parentNode <- parent[edgeToBreak] - brokenEdge.childNode <- child[edgeToBreak] - - edgesCutAdrift <- DescendantEdges(edgeToBreak, parent, child, nEdge) - edgesOnAdriftSegment <- edgesCutAdrift | brokenEdge - - brokenEdgeParent <- child == brokenEdge.parentNode - brokenEdgeSister <- parent == brokenEdge.parentNode & !brokenEdge - brokenEdgeDaughters <- parent == brokenEdge.childNode - nearBrokenEdge <- brokenEdge | brokenEdgeSister | brokenEdgeParent | - brokenEdgeDaughters - if (breakingRootEdge <- !any(brokenEdgeParent)) { - # Edge to break is the Root Node. - brokenRootDaughters <- parent == child[brokenEdgeSister] - nearBrokenEdge <- nearBrokenEdge | brokenRootDaughters - } - - mergeEdges <- which(!nearBrokenEdge & !edgesOnAdriftSegment & - notDuplicateRoot) - nCandidates <- length(mergeEdges) - - if (breakingRootEdge) { - newEdges <- lapply(mergeEdges, function (mergeEdge) { - newParent <- parent - newChild <- child - newParent[brokenRootDaughters] <- brokenEdge.parentNode - newChild [brokenEdgeSister] <- child[mergeEdge] - newParent[brokenEdge | brokenEdgeSister] <- child[brokenEdgeSister] - newChild[mergeEdge] <- child[brokenEdgeSister] - # Return: - RenumberTree(newParent, newChild) - }) # lapply faster than vapply - } else { - newEdges <- lapply(mergeEdges, function (mergeEdge) { - newParent <- parent - newParent[brokenEdgeSister] <- parent[brokenEdgeParent] - newParent[brokenEdgeParent] <- newParent[mergeEdge] - newParent[mergeEdge] <- brokenEdge.parentNode - # Return: - RenumberTree(newParent, child) - }) # lapply faster than vapply - } - # Return: - lapply(newEdges, function (newEdge) {tree$edge <- newEdge; tree}) -} - -#' Rooted SPR -#' @describeIn SPR Perform \acronym{SPR} rearrangement, retaining position of root -#' @importFrom TreeTools Preorder -#' @export -RootedSPR <- function(tree, edgeToBreak = NULL, mergeEdge = NULL) { - if (is.null(treeOrder <- attr(tree, 'order')) || treeOrder != 'preorder') { - tree <- Preorder(tree) - } - edge <- tree$edge - newEdge <- RootedSPRSwap(edge[, 1], edge[, 2], edgeToBreak = edgeToBreak, - mergeEdge = mergeEdge) - tree$edge <- cbind(newEdge[[1]], newEdge[[2]]) - return (tree) -} - -## TODO Do edges need to be pre-ordered before coming here? -#' @describeIn SPR faster version that takes and returns parent and child parameters -#' @return a list containing two elements, corresponding in turn to the rearranged parent and child parameters -#' @importFrom TreeTools NonDuplicateRoot -#' @export -RootedSPRSwap <- function (parent, child, nEdge = length(parent), nNode = nEdge / 2L, - edgeToBreak=NULL, mergeEdge=NULL) { - - if (nEdge < 5) return (SPRWarning(parent, child, "Too few tips to rearrange.")) - - rootNode <- parent[1] - rootEdges <- parent == rootNode - breakable <- !logical(nEdge) & !rootEdges - - - if (!is.null(edgeToBreak) && edgeToBreak == -1) { - notDuplicateRoot <- NonDuplicateRoot(parent, child, nEdge) - return(unique(unlist(lapply(which(breakable), AllSPR, - parent=parent, child=child, nEdge=nEdge, notDuplicateRoot=notDuplicateRoot), - recursive=FALSE))) # TODO the fact that we need to use `unique` indicates that - # we're being inefficient here. - } - - rightSide <- DescendantEdges(1, parent, child, nEdge) - leftSide <- !rightSide - nEdgeRight <- which(rootEdges)[2] - 1 - nEdgeLeft <- nEdge - nEdgeRight - if (nEdgeRight < 4) { - if (nEdgeLeft < 4) return(SPRWarning(parent, child, "No rearrangement possible with this root position.")) - - breakable <- breakable & !rightSide - rightHalfOfLeftSide <- DescendantEdges(nEdgeRight + 2L, parent, child, nEdge) - leftHalfOfLeftSide <- leftSide & !rightHalfOfLeftSide & !rootEdges - if (sum(rightHalfOfLeftSide) == 1) breakable[nEdgeRight + 3] <- FALSE - if (sum( leftHalfOfLeftSide) == 1) breakable[nEdgeRight + 2] <- FALSE - } else { - if (nEdgeLeft < 4) { - breakable <- breakable & rightSide - } else { - rightHalfOfLeftSide <- DescendantEdges(nEdgeRight + 2L , parent, child, nEdge) - leftHalfOfLeftSide <- leftSide & !rightHalfOfLeftSide & !rootEdges - if (sum(rightHalfOfLeftSide) == 1) breakable[nEdgeRight + 3] <- FALSE - if (sum( leftHalfOfLeftSide) == 1) breakable[nEdgeRight + 2] <- FALSE - } - rightHalfOfRightSide <- DescendantEdges(2L , parent, child, nEdge) - leftHalfOfRightSide <- rightSide & !rightHalfOfRightSide & !rootEdges - if (sum(rightHalfOfRightSide) == 1) breakable[3] <- FALSE - if (sum( leftHalfOfRightSide) == 1) breakable[2] <- FALSE - } - - if (is.null(edgeToBreak)) { - # Pick an edge at random - edgeToBreak <- SampleOne(which(breakable)) - } else { - if (!breakable[edgeToBreak]) return(SPRWarning(parent, child, paste("Nowhere to regraft if pruning on edge", edgeToBreak))) - if (edgeToBreak > nEdge) return(SPRWarning(parent, child, "edgeToBreak > nEdge")) - if (edgeToBreak < 1) return(SPRWarning(parent, child, "edgeToBreak < 1")) - } - brokenEdge <- seq_along(parent) == edgeToBreak - brokenEdge.parentNode <- parent[edgeToBreak] - brokenEdge.childNode <- child[edgeToBreak] - - edgesCutAdrift <- DescendantEdges(edgeToBreak, parent, child, nEdge) - edgesOnAdriftSegment <- edgesCutAdrift | brokenEdge - - brokenEdgeParent <- child == brokenEdge.parentNode - brokenEdgeSister <- parent == brokenEdge.parentNode & !brokenEdge - brokenEdgeDaughters <- parent == brokenEdge.childNode - nearBrokenEdge <- brokenEdge | brokenEdgeSister | brokenEdgeParent | brokenEdgeDaughters - - if (!is.null(mergeEdge)) { # Quick sanity checks - if (mergeEdge > nEdge) return(SPRWarning(parent, child, "mergeEdge value > number of edges")) - if (length(mergeEdge) != 1) - return(SPRWarning(parent, child, paste0("mergeEdge value ", paste(mergeEdge, collapse='|'), - " invalid; must be NULL or a vector of length 1\n"))) - if(nearBrokenEdge[mergeEdge]) return(SPRWarning(parent, child, "Selected mergeEdge will not change tree topology.")) - if(DescendantEdges(edgeToBreak, parent, child, nEdge)[mergeEdge]) stop("mergeEdge is within pruned subtree") - } else { - edgesOnThisSide <- if (rightSide[edgeToBreak]) rightSide else leftSide - mergeEdge <- which(edgesOnThisSide & !nearBrokenEdge & !edgesOnAdriftSegment) - nCandidates <- length(mergeEdge) - if (nCandidates > 1) mergeEdge <- SampleOne(mergeEdge, len=nCandidates) - } - - parent[brokenEdgeSister] <- parent[brokenEdgeParent] - parent[brokenEdgeParent] <- parent[mergeEdge] - parent[mergeEdge] <- brokenEdge.parentNode - - #####Assert(identical(unique(table(parent)), 2L)) - #####Assert(identical(unique(table(child)), 1L)) - - # Return: - RenumberEdges(parent, child) -} \ No newline at end of file diff --git a/R/Sectorial.R b/R/Sectorial.R deleted file mode 100644 index 8f6c9c1bd..000000000 --- a/R/Sectorial.R +++ /dev/null @@ -1,260 +0,0 @@ - -########Sectorial <- function (tree, dataset, TreeScorer = TODO, sectRearrangements=list(RootedNNI), -######## searchRearrangements=list(RootedNNI, RootedTBR, RootedNNI), -######## maxHits=c(30, 40, 60), maxIter=2000, verbosity=3, ...) { -######## best.score <- attr(tree, 'score') -######## if (is.null(treeOrder <- attr(tree, 'order')) || treeOrder != 'preorder') tree <- Preorder(tree) -######## -######## tree <- RenumberTips(tree, names(dataset)) -######## if (length(best.score) == 0) best.score <- TreeScorer(tree, dataset, ...) -######## sect <- DoSectorial(tree, dataset, verbosity=verbosity-1, maxit=30, -######## maxIter=max(maxIter), maxHits=15, smallestSector=6, -######## largestSector=dim(tree$edge)[1]*0.25, Rearrangements=sectRearrangements) -######## for (i in seq_along(sectRearrangements)) { -######## iters <- if (length(maxIter) <= i) maxIter[[i]] else min(maxIter) -######## hits <- if (length(maxHits) <= i) maxHits[[i]] else min(maxHits) -######## sect <- TreeSearch(sect, dataset, TreeScorer, sectRearrangements[[i]], maxIter=iters, -######## maxHits=hits, verbosity=verbosity-1) -######## } -######## if (attr(sect, 'score') <= best.score) { -######## return (sect) -######## } else return (tree) -########} -######## -#########' Sector Data -#########' Check that chosen sector contains parsimony-informative data -#########' -#########' The function simply checks that some characters have more than one state. -#########' It's crude, but the cost of a false positive is low. -#########' -#########' @param dataset the dataset to subsample -#########' @param tips character vector listing tips that exist in the sector -#########' -#########' @keywords internal -#########' @export -########SectorHasData <- function (dataset, tips) { -######## if (class(dataset) =='phyDat') { -######## levs <- attr(dataset, 'levels') -######## contrast <- attr(dataset, 'contrast') -######## index <- as.integer(contrast %*% 2L ^ (seq_along(attr(dataset, 'levels')) - 1)) -######## characters <- vapply(dataset, function (X) index[X], integer(attr(dataset, 'nr'))) -######## } else if (names(dataset)) { -######## characters <- vapply(dataset, c, integer(length(dataset[[1]]))) -######## } else if(rownames(dataset)) { -######## characters <- t(dataset) -######## } else characters <- dataset -######## tokens <- apply(characters[, tips], 2, function (x) length(unique(x))) -######## return (any(tokens > 1)) -########} -######## -#######' Sectorial Search with inapplicable data -#######' -#######' \code{DoSectorial} is called by Sectorial -#######' -#######' @template preorderTreeParam -#######' @param dataset a dataset in the format expected by \code{TreeScorer} -#######' @param TreeScorer a function that will score a tree topology -#######' @param maxSectIter maximum number of sectorial iterations to perform -#######' @param maxIter maximum number of iterations to perform in tree rearrangement functions -#######' @param maxImprovements maximum number of times to find an optimal score before ending sectorial search -#######' @param Rearrangements a list of tree rearrangement functions that retain the root of the tree -#######' (e.g. \code{list(RootedSPR)}) -#######' @param smallestSector integer giving size of smallest sector to rearrange -#######' @param largestSector integer giving size of largest sector to rearrange (rounded down if non-integral) -#######' @template verbosityParam -#######' @template treeScorerDots -#######' -#######' @return a tree of class \code{phylo} with a \code{TreeScorer} score as good or better than that of \code{tree} -#######' -#######' @author Martin R. Smith -#######' @importFrom ape root -#######' @export -######MorphySectorial <- function (parent, child, dataset, TreeScorer = MorphyLength, maxSectIter=100, -###### maxIter=500, maxImprovements=5, smallestSector=4, largestSector=1e+06, -###### Rearrangements=list(RootedNNI), verbosity=0, ...) { -###### if (verbosity >= 0) message(' - Sectorial search: optimizing sectors of', smallestSector, 'to', floor(largestSector), 'tips') -###### nEdge <- length(parent) -###### nTip <- (nEdge / 2) + 1 -###### nonRootNodes <- (nTip + 2):(nEdge + 1) -###### -###### epsilon <- 1e-08 -###### improvements <- 1 -###### -###### NodeChildren <- function (parent, child) { -###### result <- integer(nEdge + 1L) -###### result[1:nTip] <- 1 -###### edgeCounted <- child <= nTip -###### while (any(!counted)) { -###### -###### result[!counted] <- result[!counted] + -###### -###### } -###### } -###### for (i in seq_len(maxSectIter)) { -###### -###### nodeLengths <- CladeSizes(tree, nonRootNodes) -###### candidateNodes <- nonRootNodes[nodeLengths >= smallestSector & nodeLengths <= largestSector] -###### if (verbosity >= 0) message("\n - Iteration ", i, "- attempting sectorial search on node ") -###### repeat { -###### sector <- sample(candidateNodes, 1) -###### candidate <- Subtree(tree, sector) -###### crownTips <- candidate$tip.label -###### sectorSize <- length(crownTips) -###### message(sector, 'size', sectorSize, '...') -###### -###### if (SectorHasData(dataset, crownTips)) break else message('unsuitable (no dataset); trying') -###### -###### candidateNodes <- candidateNodes[-match(sector, candidateNodes)] -###### if (length(candidateNodes == 0)) stop('No selectable sectors contain parsimony information! Either "largestSector" is close to "smallestSector" or your dataset is short of parsimony information.') -###### } -###### if (verbosity >= 0) message(' Sector OK.') -###### -###### crown <- root(AddTip(crown, 0, 'SECTOR_ROOT'), length(crown$tip.label) + 1, resolve.root=TRUE) -###### initialScore <- TreeScorer(candidate, dataset, ...) -###### attr(candidate, 'score') <- initialScore -###### -###### if (verbosity >= 0) message("\n - Rearranging sector", sector) -###### for (Rearrange in Rearrangements) { -###### candidate <- TreeSearch(candidate, dataset, TreeScorer, Rearrange, -###### verbosity=verbosity-1, maxIter=maxIter, ...) -###### } -###### candidateScore <- attr(candidate, 'score') -###### -###### if((candidateScore + epsilon) < initialScore) { -###### improvements <- improvements + 1 -###### -###### subtree.labels <- crownTips -###### subtree.nTips <- sectorSize -###### subtree.edge <- candidate$edge -###### subtree.parent <- subtree.edge[, 1] -###### subtree.child <- subtree.edge[, 2] -###### -###### isTip <- subtree.child <= subtree.nTips -###### subtree.child[isTip] <- match(crownTips[subtree.child[isTip]], tipOrder) -###### nodeAdjust <- sector - (subtree.nTips + 1) -###### -###### subtree.child[!isTip] <- subtree.child[!isTip] + nodeAdjust -###### edges <- which(tree$edge[, 2] == sector) + seq_along(subtree.parent) -###### tree$edge[edges, 1] <- subtree.parent + nodeAdjust -###### tree$edge[edges, 2] <- subtree.child -###### -###### if (verbosity > 0) message(' : improved local pscore, updated tree') -###### } else if (verbosity > 0) message (' : no improvement to local pscore') -###### if (improvements == maxImprovements) break() -###### } # for -###### if (verbosity >= 0) -###### message ("\nCompleted sectorial rearrangements.\n") -###### attr(tree, 'score') <- NULL -###### attr(tree, 'hits') <- NULL -###### # Return: -###### tree -######} # DoSectorial -###### -#######' Sectorial Search -#######' -#######' \code{SectorialSearch} performs a sectorial search on a tree. -#######' -#######' A sectorial search detaches a random part of the tree, performs rearrangments -#######' on this subtree, then reattaches it to the main tree (Goloboff, 1999). -#######' The improvement to local \var{score} hopefully (but not necessarily) improves -#######' the overall \var{score}. -#######' -#######' \code{SectorialSearch} then uses this tree as a starting point for a series -#######' of tree rearrangements, by default using NNI, SPR and TBR swappers. -#######' It returns the new tree, unless the starting tree had a better score, -#######' in which case the starting tree is returned. -#######' -#######'' -#######' @template treeParam -#######' @param dataset a dataset in the format required by `TreeScorer()`. -#######' @template InitializeDataParam -#######' @template CleanUpDataParam -#######' @template treeScorerParam -#########' @param Bootstrapper Function to perform bootstrapped rearrangements of tree. -#########' First arguments will be an edgeList and a dataset, initialized using \code{InitializeData} -#########' Should return a rearranged edgeList. -#######' @template swappersParam -#######' @param SectorialSwapper Function such as \code{\link{RootedNNISwap}} to use -#######' to rearrange sector. -#######' @param sectIter stop sectorial search when this many rearrangements have been performed. -#######' @param sectHits stop sectorial search when this many rearrangements have -#######' found the same best score. -#######' @param searchIter maximum rearrangements for subsequent search on whole tree. -#######' @param searchHits maximum times to hit best score before terminating whole-tree search. -#######' @template verbosityParam -#######' @template treeScorerDots -#######' -#######' @return a rooted tree of class \code{phylo}. -#######' -#######' @references \insertRef{Goloboff1999}{TreeSearch} -#######' -#######' @author Martin R. Smith -#######' -#######' @seealso \code{\link{TreeSearch}} -#######' @seealso \code{\link{MorphyRatchet}} -#######' -#######' @examples -#######' data('Lobo', package='TreeTools') -#######' njtree <- TreeTools::NJTree(Lobo.phy) -#######' -#######' \dontrun{ -#######' SectorialSearch(njtree, Lobo.phy, maxIter=20, EdgeSwapper=NNISwap, -#######' ratchIter=1, maxIter=50, largest.sector=7)} # Will be time-consuming } -#######' -#######' @keywords tree -#######' @export -######SectorialSearch <- function (tree, dataset, -###### InitializeData = PhyDat2Morphy, -###### CleanUpData = UnloadMorphy, -###### TreeScorer = MorphyLength, -###### Bootstrapper = MorphyBootstrap, -###### swappers = list(TBRSwap, SPRSwap, NNISwap), -###### SectorialSwapper = swappers[[length(swappers)]], -###### returnAll=FALSE, stopAtScore=NULL, -###### sectIter=400L, sectHits=20L, -###### searchIter=sectIter * 5L, searchHits=sectHits * 2L, -###### verbosity=1L, ...) { -###### epsilon <- 1e-08 -###### hits <- 0L -###### # initialize tree and data -###### if (dim(tree$edge)[1] != 2 * tree$Nnode) stop("tree must be bifurcating; try rooting with ape::root") -###### tree <- RenumberTips(tree, names(dataset)) -###### edgeList <- tree$edge -###### edgeList <- RenumberEdges(edgeList[, 1], edgeList[, 2]) -###### -###### initializedData <- InitializeData(dataset) -###### on.exit(initializedData <- CleanUpData(initializedData)) -###### -###### bestScore <- if (is.null(attr(tree, 'score'))) { -###### TreeScorer(edgeList[[1]], edgeList[[2]], initializedData, ...) -###### } else { -###### attr(tree, 'score') -###### } -###### -###### if (verbosity > 0L) message("\n* Beginning Sectorial Search, with initial score", bestScore) -###### if (!is.null(stopAtScore) && bestScore < stopAtScore + epsilon) return(tree) -###### -###### -###### # Rearrange a sector of the tree: -###### sect <- MorphySectorial(edgeList[[1]], edgelist[[2]], morphyObj, verbosity=verbosity-1, ratchIter=30, -###### maxIter=maxIter, maxHits=15, smallest.sector=6, -###### largest.sector=length(edgeList[[1]]) * 0.25, rearrangements=rearrangements) -###### -###### if (class(swappers) == 'function') swappers <- list(swappers) -###### # Now use sectorially rearranged tree as starting point for conventional search -###### edgeList <- EdgeListSearch(edgeList, initializedData, TreeScorer=TreeScorer, -###### EdgeSwapper=swappers, maxIter = maxIter, -###### maxHits = maxHits, verbosity = verbosity - 1L) -###### -###### if (edgeList[[3]] <= bestScore) { -###### sect$edge <- cbind(edgeList[[1]], edgeList[[2]]) -###### attr(sect, 'score') <- edgeList[[3]] -###### attr(sect, 'hits') <- edgeList[[4]] -###### # Return: -###### sect -###### } else { -###### # Return: -###### tree -###### } -######} -###### diff --git a/R/SuccessiveApproximations.R b/R/SuccessiveApproximations.R deleted file mode 100644 index 4a38f5a2b..000000000 --- a/R/SuccessiveApproximations.R +++ /dev/null @@ -1,143 +0,0 @@ -#' Tree search using successive approximations -#' -#' Searches for a tree that is optimal under the Successive Approximations -#' criterion \insertCite{Farris1969}{TreeSearch}. -#' -#' @template treeParam -#' @template datasetParam -#' @param outgroup if not NULL, taxa on which the tree should be rooted -#' @param k Constant for successive approximations, see Farris 1969 p. 379 -#' @param maxSuccIter maximum iterations of successive approximation -#' @param ratchetHits maximum hits for parsimony ratchet -#' @param searchHits maximum hits in tree search -#' @param searchIter maximum iterations in tree search -#' @param ratchetIter maximum iterations of parsimony ratchet -#' @template verbosityParam -#' @param suboptimal retain trees that are this proportion less optimal than the optimal tree -#' -#' @return `SuccessiveApproximations()` returns a list of class `multiPhylo` -#' containing optimal (and slightly suboptimal, if suboptimal > 0) trees. -#' -#' @references -#' \insertAllCited{} -#' -#' @importFrom ape consensus root -#' @family custom search functions -#' @export -SuccessiveApproximations <- function (tree, dataset, outgroup = NULL, k = 3, - maxSuccIter = 20, ratchetHits = 100, - searchHits = 50, searchIter = 500, - ratchetIter = 5000, verbosity = 0, - suboptimal = 0.1) { - - if (k < 1) stop ('k should be at least 1, see Farris 1969 p.379') - attr(dataset, 'sa.weights') <- rep.int(1, length(attr(dataset, 'weight'))) - collectSuboptimal <- suboptimal > 0 - - max.node <- max(tree$edge[, 1]) - n.tip <- length(tree$tip.label) - n.node <- max.node - n.tip - bests <- vector('list', maxSuccIter + 1L) - bestsConsensus <- vector('list', maxSuccIter + 1L) - best <- bests[[1]] <- bestsConsensus[[1]] <- root(tree, outgroup, resolve.root=TRUE) - for (i in seq_len(maxSuccIter) + 1L) { - if (verbosity > 0) message('\nSuccessive Approximations Iteration ', i - 1L) - attr(best, 'score') <- NULL - if (suboptimal > 0) { - suboptimalSearch <- suboptimal * sum(attr(dataset, 'sa.weights') * - attr(dataset, 'weight')) - } - trees <- Ratchet(best, dataset, TreeScorer = SuccessiveWeights, - all = collectSuboptimal, - suboptimal = suboptimalSearch, - rearrangements = 'NNI', - ratchetHits=ratchetHits, searchHits = searchHits, - searchIter = searchIter, ratchetIter = ratchetIter, - outgroup = outgroup, verbosity = verbosity - 1) - trees <- unique(trees) - bests[[i]] <- trees - suboptimality <- Suboptimality(trees) - bestsConsensus[[i]] <- consensus(trees[suboptimality == 0]) - if (all.equal(bestsConsensus[[i]], bestsConsensus[[i - 1]])) { - return(bests[2:i]) - } - best <- trees[suboptimality == 0][[1]] - l.i <- CharacterLength(best, dataset, compress = TRUE) - p.i <- l.i / (n.node - 1) - w.i <- ((p.i)^-k) - 1 - attr(dataset, 'sa.weights') <- w.i - } - message('Stability not reached.') - - # Return: - structure(bests, class = 'multiPhylo') -} - -#' Tree suboptimality -#' -#' How suboptimal is a tree? -#' -#' @param trees list of trees, to include an optimal tree -#' @param proprtional logical stating whether to normalise results to lowest score -#' @return a vector listing, for each tree, how much their score differs from the optimal (lowest) score. -#' @keywords internal -#' @export -Suboptimality <- function (trees, proportional = FALSE) { - scores <- vapply(trees, attr, double(1), 'score') - - # Return: - if (proportional) { - (scores - min(scores)) / min(scores) - } else { - scores - min(scores) - } -} - -#' @rdname SuccessiveApproximations -#' @return `SuccessiveWeights()` returns the score of a tree, given the -#' weighting instructions specified in the attributes of the dataset. -#' -#' @keywords internal -#' @export -SuccessiveWeights <- function(tree, dataset) { - # Data - if (inherits(dataset, 'phyDat')) dataset <- PrepareDataSA(dataset) - if (!inherits(dataset, 'saDat')) { - stop('Invalid data type; prepare data with PhyDat() or PrepareDataSA().') - } - at <- attributes(dataset) - weight <- at$weight - sa.weights <- at$sa.weights - if (is.null(sa.weights)) sa.weights <- rep.int(1, length(weight)) - steps <- CharacterLength(tree, dataset, compress = TRUE) - - # Return: - sum(steps * sa.weights * weight) -} - -PrepareDataSA <- function (dataset) { -# Written with reference to phangorn:::prepareDataFitch - at <- attributes(dataset) - nam <- at$names - nLevel <- length(at$level) - nChar <- at$nr - cont <- attr(dataset, "contrast") - nTip <- length(dataset) - - at$names <- NULL - powers.of.2 <- 2L ^ c(0L:(nLevel - 1L)) - tmp <- cont %*% powers.of.2 - tmp <- as.integer(tmp) - dataset <- unlist(dataset, FALSE, FALSE) - ret <- tmp[dataset] - ret <- as.integer(ret) - attributes(ret) <- at - inappLevel <- which(at$levels == "-") - attr(ret, 'dim') <- c(nChar, nTip) - applicableTokens <- setdiff(powers.of.2, 2 ^ (inappLevel - 1)) - attr(ret, 'split.sizes') <- t(apply(ret, 1, function(x) vapply(applicableTokens, function (y) sum(x == y), integer(1)))) - dimnames(ret) <- list(NULL, nam) - attr(ret, 'bootstrap') <- list('split.sizes', 'sa.weights') - class(ret) <- 'saDat' - ret -} \ No newline at end of file diff --git a/R/TBR.R b/R/TBR.R deleted file mode 100644 index a71063bc3..000000000 --- a/R/TBR.R +++ /dev/null @@ -1,403 +0,0 @@ -#' TBR Warning -#' Print a warning and return given tree -#' -#' @param tree tree to return -#' @param error error message to report -#' -#' @return the tree specified in tree -#' @examples -#' suppressWarnings(TBRWarning(0, 0, 'Message text')) # will trigger warning -#' -#' -#' @author Martin R. Smith -#' @keywords internal -#' @export -TBRWarning <- function (parent, child, error) { - warning ("No TBR operation performed.\n > ", error) - # Return: - list(parent, child) -} - -#' Tree bisection and reconnection (TBR) -#' -#' \code{TBR} performs a single random \acronym{TBR} iteration. -#' -#' Branch lengths are not (yet) supported. -#' -#' All nodes in a tree must be bifurcating; [ape::collapse.singles] and -#' [ape::multi2di] may help. -#' -#' -#' @param tree A bifurcating tree of class \code{\link{phylo}}, with all nodes resolved; -#' @template edgeToBreakParam -#' @template mergeEdgesParam -#' -#' @return This function returns a tree in \code{phyDat} format that has undergone one \acronym{TBR} iteration. -#' @references The \acronym{TBR} algorithm is summarized in -#' \insertRef{Felsenstein2004}{TreeSearch} -#' -#' -#' @author Martin R. Smith -#' -#' @seealso [`RootedTBR()`]: useful when the position of the root node should be retained. -#' @family tree rearrangement functions -#' -#' @examples{ -#' library('ape') -#' tree <- rtree(20, br=NULL) -#' TBR(tree) -#' } -#' @importFrom ape root -#' @importFrom TreeTools DescendantEdges Preorder -#' @export -TBR <- function(tree, edgeToBreak = NULL, mergeEdges = NULL) { - if (is.null(treeOrder <- attr(tree, 'order')) || treeOrder != 'preorder') { - tree <- Preorder(tree) - if (!is.null(edgeToBreak)) { - warning("Edge numbering modified as tree not in preorder; - edgeToBreak and mergeEdges ignored.") - edgeToBreak <- mergeEdges <- NULL - } - } - - edge <- tree$edge - StopUnlessBifurcating(edge[, 1]) - newEdge <- TBRSwap(edge[, 1], edge[, 2], edgeToBreak = edgeToBreak, - mergeEdges = mergeEdges) - tree$edge <- cbind(newEdge[[1]], newEdge[[2]]) - tree -} - -#' @rdname TBR -#' @return `TBRMoves()` returns a `multiPhylo` object listing all trees one -#' \acronym{TBR} move away from `tree`, with edges and nodes in preorder, -#' rooted on the first-labelled tip. -#' @export -TBRMoves <- function (tree, edgeToBreak = integer(0)) UseMethod('TBRMoves') - -#' @rdname TBR -#' @importFrom TreeTools Preorder RootTree -#' @export -TBRMoves.phylo <- function (tree, edgeToBreak = integer(0)) { - tree <- Preorder(RootTree(tree, 1)) - edges <- unique(all_tbr(tree$edge, edgeToBreak)) - structure(lapply(edges, function (edg) { - tree$edge <- edg - tree - }), class = 'multiPhylo', tip.label = tree$tip.label) -} - -#' @rdname TBR -#' @export -TBRMoves.matrix <- function (tree, edgeToBreak = integer(0)) { - tree <- Preorder(RootTree(tree, 1)) - allMoves <- all_tbr(tree, edgeToBreak) - unique(allMoves) -} - -## TODO Do edges need to be pre-ordered before coming here? -#' @describeIn TBR faster version that takes and returns parent and child -#' parameters -#' @template treeParent -#' @template treeChild -#' @param nEdge (optional) Number of edges. -#' @return a list containing two elements, corresponding in turn to the -#' rearranged parent and child parameters -#' -#' @importFrom TreeTools EdgeAncestry -#' @export -TBRSwap <- function(parent, child, nEdge = length(parent), - edgeToBreak = NULL, - mergeEdges = NULL) { - if (nEdge < 5) return (list(parent, child)) #TODO do we need to re-root this tree? - - # Pick an edge at random - allEdges <- seq_len(nEdge - 1L) + 1L # Only include one root edge - not1 <- !logical(nEdge) - not1[1] <- FALSE - if (is.null(edgeToBreak)) { - edgeToBreak <- SampleOne(allEdges, len=nEdge - 1L) - } else { - if (edgeToBreak > nEdge) return(TBRWarning(parent, child, "edgeToBreak > nEdge")) - if (edgeToBreak < 1) return(TBRWarning(parent, child, "edgeToBreak < 1")) - if (edgeToBreak == 1) edgeToBreak <- which(parent == parent[1])[-1] # Use other side of root - } - brokenEdge <- seq_along(parent) == edgeToBreak - brokenEdge.parentNode <- parent[edgeToBreak] - brokenEdge.childNode <- child[edgeToBreak] - - if (!is.null(mergeEdges)) { # Quick sanity checks - if (any(mergeEdges > nEdge)) return(TBRWarning(parent, child, "mergeEdges value > number of edges")) - if (length(mergeEdges) > 2 || length(mergeEdges) == 0) - return(TBRWarning(parent, child, paste0("mergeEdges value ", paste(mergeEdges, collapse='|'), - " invalid; must be NULL or a vector of length 1 or 2\n "))) - if (length(mergeEdges) == 2 && mergeEdges[1] == mergeEdges[2]) - return(TBRWarning(parent, child, "mergeEdges values must differ")) - } - - edgesCutAdrift <- DescendantEdges(edgeToBreak, parent, child, nEdge) - edgesRemaining <- !edgesCutAdrift & !brokenEdge - - brokenEdgeParent <- child == brokenEdge.parentNode - brokenEdgeSister <- parent == brokenEdge.parentNode & !brokenEdge - brokenEdgeDaughters <- parent == brokenEdge.childNode - nearBrokenEdge <- brokenEdge | brokenEdgeSister | brokenEdgeParent | brokenEdgeDaughters - if (breakingRootEdge <- !any(brokenEdgeParent)) { - # Edge to break is the Root Node. - brokenRootDaughters <- parent == child[brokenEdgeSister] - nearBrokenEdge <- nearBrokenEdge | brokenRootDaughters - } - - if (is.null(mergeEdges)) { - candidateEdges <- which(!nearBrokenEdge & not1) - nCandidates <- length(candidateEdges) - if (nCandidates > 1) mergeEdges <- SampleOne(candidateEdges, len=nCandidates) else mergeEdges <- candidateEdges - } - if (length(mergeEdges) == 1) { - if (edgesCutAdrift[mergeEdges]) { - adriftReconnectionEdge <- mergeEdges - if (nearBrokenEdge[mergeEdges]) { - samplable <- which(!edgesCutAdrift & !nearBrokenEdge & not1) - } else { - samplable <- which(!edgesCutAdrift & not1) - if (all(edgesCutAdrift == not1) && breakingRootEdge) samplable <- 1 - } - nSamplable <- length(samplable) - if (nSamplable == 0) return(TBRWarning(parent, child, "No reconnection site would modify the tree; check mergeEdge")) - rootedReconnectionEdge <- if (nSamplable == 1) samplable else SampleOne(samplable, len=nSamplable) - #### message(" - Selected rooted Reconnection Edge: ", rootedReconnectionEdge, "\n") #### DEBUGGING AID - } else { - rootedReconnectionEdge <- mergeEdges - if (nearBrokenEdge[mergeEdges]) { - samplable <- which(edgesCutAdrift & !nearBrokenEdge & not1) - } else { - samplable <- which(edgesCutAdrift & not1) - } - nSamplable <- length(samplable) - if (nSamplable == 0) return(TBRWarning(parent, child, "No reconnection site would modify the tree; check mergeEdge")) - adriftReconnectionEdge <- if (nSamplable == 1) samplable else SampleOne(samplable) - #### message(" - Selected adrift Reconnection Edge: ", adriftReconnectionEdge, "\n") #### DEBUGGING AID - } - } else { - whichAdrift <- edgesCutAdrift[mergeEdges] - if (sum(whichAdrift) != 1) return(TBRWarning(parent, child, paste("Invalid edges selected to merge:", mergeEdges[1], mergeEdges[2]))) - adriftReconnectionEdge <- mergeEdges[whichAdrift] - rootedReconnectionEdge <- mergeEdges[!whichAdrift] - } - if(nearBrokenEdge[rootedReconnectionEdge] && nearBrokenEdge[adriftReconnectionEdge]) - return(TBRWarning(parent, child, "Selected mergeEdges will not change tree topology.")) - #### edgelabels(edge = edgeToBreak, bg='orange', cex=1.8) #### DEBUGGING AID - #### edgelabels(edge=adriftReconnectionEdge, bg='cyan') #### DEBUGGING AID - #### edgelabels(edge=rootedReconnectionEdge, bg='magenta') #### DEBUGGING AID - - if (!nearBrokenEdge[adriftReconnectionEdge]) { - edgesToInvert <- EdgeAncestry(adriftReconnectionEdge, parent, child, stopAt = edgeToBreak) & !brokenEdge - #### which(edgesToInvert) - if (any(edgesToInvert)) { - tmp <- parent[edgesToInvert] - parent[edgesToInvert] <- child[edgesToInvert] - child[edgesToInvert] <- tmp - } - reconnectionSideEdges <- edgesToInvert - reconnectionSideEdges[adriftReconnectionEdge] <- TRUE - - repurposedDaughterEdge <- brokenEdgeDaughters & reconnectionSideEdges - spareDaughterEdge <- brokenEdgeDaughters & !reconnectionSideEdges - #########Assert(identical(sum(repurposedDaughterEdge), sum(spareDaughterEdge), 1)) - #### which(repurposedDaughterEdge) - #### which(spareDaughterEdge) - child[repurposedDaughterEdge] <- child[spareDaughterEdge] - child[spareDaughterEdge] <- parent[adriftReconnectionEdge] - #########Assert(parent[spareDaughterEdge] == brokenEdge.childNode) - parent[adriftReconnectionEdge] <- brokenEdge.childNode - } - if (!nearBrokenEdge[rootedReconnectionEdge]) { - if (breakingRootEdge) { - parent[brokenRootDaughters] <- brokenEdge.parentNode - spareNode <- child[brokenEdgeSister] - child [brokenEdgeSister] <- child[rootedReconnectionEdge] - parent[brokenEdge | brokenEdgeSister] <- spareNode - child[rootedReconnectionEdge] <- spareNode - } else { - parent[brokenEdgeSister] <- parent[brokenEdgeParent] - parent[brokenEdgeParent] <- parent[rootedReconnectionEdge] - parent[rootedReconnectionEdge] <- brokenEdge.parentNode - } - } - - #########Assert(identical(unique(table(parent)), 2L)) - #########Assert(identical(unique(table(child)), 1L)) - return (RenumberEdges(parent, child)) -} - -#' Rooted TBR -#' @describeIn TBR Perform \acronym{TBR} rearrangement, retaining position of root -#' @importFrom TreeTools Preorder -#' @export -RootedTBR <- function(tree, edgeToBreak = NULL, mergeEdges = NULL) { - if (is.null(treeOrder <- attr(tree, 'order')) || treeOrder != 'preorder') { - tree <- Preorder(tree) - } - edge <- tree$edge - edgeList <- RootedTBRSwap(edge[, 1], edge[, 2], - edgeToBreak=edgeToBreak, mergeEdges=mergeEdges) - tree$edge <- cbind(edgeList[[1]], edgeList[[2]]) - tree -} - -#' @describeIn TBR faster version that takes and returns parent and child parameters -#' @importFrom TreeTools EdgeAncestry -#' @export -RootedTBRSwap <- function (parent, child, nEdge=length(parent), - edgeToBreak = NULL, mergeEdges = NULL) { - if (nEdge < 5) return (TBRWarning(parent, child, 'Fewer than 4 tips')) - nTips <- (nEdge / 2L) + 1L - rootNode <- parent[1] - rootEdges <- parent == rootNode - rightTree <- DescendantEdges(1, parent, child, nEdge) - selectableEdges <- !rootEdges - if (sum( rightTree) < 4) { - selectableEdges[ rightTree] <- FALSE - } else if (sum( rightTree) < 6) { - rightChild <- child[1] - rightGrandchildEdges <- parent==rightChild - rightGrandchildren <- child[rightGrandchildEdges] - rightGrandchildrenTips <- rightGrandchildren <= nTips - selectableEdges[which(rightGrandchildEdges)[!rightGrandchildrenTips]] <- FALSE - } - if (sum(!rightTree) < 4) { - selectableEdges[!rightTree] <- FALSE - } else if (sum(!rightTree) < 6) { - leftChild <- child[rootEdges][2] - leftGrandchildEdges <- parent==leftChild - leftGrandchildren <- child[ leftGrandchildEdges] - leftGrandchildrenTips <- leftGrandchildren <= nTips - selectableEdges[which( leftGrandchildEdges)[! leftGrandchildrenTips]] <- FALSE - } - - if (!any(selectableEdges)) return(TBRWarning(parent, child, 'No opportunity to rearrange tree due to root position')) - - if (is.null(edgeToBreak)) { - edgeToBreak <- SampleOne(which(selectableEdges)) # Pick an edge at random - } else { - if (edgeToBreak > nEdge) return(TBRWarning(parent, child, "edgeToBreak > nEdge")) - if (edgeToBreak < 1) return(TBRWarning(parent, child, "edgeToBreak < 1")) - if (rootEdges[edgeToBreak]) return(TBRWarning(parent, child, "RootedTBR cannot break root edge; try TBR")) - if (!selectableEdges[edgeToBreak]) return(TBRWarning(parent, child, paste("Breaking edge", edgeToBreak, - "does not allow a changing reconnection"))) - } - repeat { - edgeInRight <- rightTree[edgeToBreak] - subtreeWithRoot <- if (edgeInRight) rightTree else !rightTree - subtreeEdges <- !rootEdges & subtreeWithRoot - if (sum(edgesCutAdrift <- DescendantEdges(edgeToBreak, parent, child, nEdge)) > 2) break; - if (sum(subtreeEdges, -edgesCutAdrift) > 2) break; # the edge itself, and somewheres else - # TODO check that all expected selections are valid - selectableEdges[edgeToBreak] <- FALSE - ###Assert(any(selectableEdges)) - edgeToBreak <- SampleOne(which(selectableEdges)) - } - brokenEdge <- seq_along(parent) == edgeToBreak - brokenEdge.parentNode <- parent[edgeToBreak] - brokenEdge.childNode <- child[edgeToBreak] - - edgesRemaining <- !edgesCutAdrift & subtreeEdges - edgesOnAdriftSegment <- edgesCutAdrift | brokenEdge - - if (!is.null(mergeEdges)) { # Quick sanity checks - if (any(mergeEdges > nEdge)) return(TBRWarning(parent, child, "mergeEdges value > number of edges")) - if (length(mergeEdges) > 2 || length(mergeEdges) == 0) - return(TBRWarning(parent, child, paste0("mergeEdges value ", paste(mergeEdges, collapse='|'), - " invalid; must be NULL or a vector of length 1 or 2\n "))) - if (length(mergeEdges) == 2 && mergeEdges[1] == mergeEdges[2]) - return(TBRWarning(parent, child, "mergeEdges values must differ")) - if (!all(subtreeWithRoot[mergeEdges])) return(TBRWarning(parent, child, paste("mergeEdges", - mergeEdges[1], mergeEdges[2], "not on same side of root as edgeToBreak", edgeToBreak))) - } - - brokenEdgeParent <- child == brokenEdge.parentNode - brokenEdgeSister <- parent == brokenEdge.parentNode & !brokenEdge - - brokenEdgeDaughters <- parent == brokenEdge.childNode - nearBrokenEdge <- brokenEdgeSister | brokenEdgeParent | brokenEdgeDaughters | brokenEdge - ###Assert(any(brokenEdgeParent)) - - if (is.null(mergeEdges)) { - mergeEdges <- which(subtreeEdges & !nearBrokenEdge) - nCandidates <- length(mergeEdges) - if (nCandidates > 1) mergeEdges <- SampleOne(mergeEdges, len=nCandidates) - } - if (length(mergeEdges) == 0) { - return(TBRWarning(parent, child, paste("Breaking edge", edgeToBreak, "does not allow any new reconnections whilst preserving root position."))) - } - if (length(mergeEdges) == 1) { - if (edgesOnAdriftSegment[mergeEdges]) { - adriftReconnectionEdge <- mergeEdges - if (nearBrokenEdge[mergeEdges]) { - samplable <- which(subtreeEdges & !edgesOnAdriftSegment & !nearBrokenEdge) - } else { - samplable <- which(subtreeEdges & !edgesOnAdriftSegment) - ###Assert(length(samplable) > 0) - } - nSamplable <- length(samplable) - if (nSamplable == 0) return(TBRWarning(parent, child, "No reconnection site would modify the tree; check mergeEdge")) - rootedReconnectionEdge <- if (nSamplable == 1) samplable else SampleOne(samplable, len=nSamplable) - #### message(" - Selected rooted Reconnection Edge: ", rootedReconnectionEdge, "\n") #### DEBUGGING AID - } else { - rootedReconnectionEdge <- mergeEdges - if (nearBrokenEdge[mergeEdges]) { - samplable <- which(subtreeEdges & edgesOnAdriftSegment & !nearBrokenEdge) - } else { - samplable <- which(subtreeEdges & edgesOnAdriftSegment) - } - nSamplable <- length(samplable) - if (nSamplable == 0) return(TBRWarning(parent, child, "No reconnection site would modify the tree; check mergeEdge")) - adriftReconnectionEdge <- if (nSamplable == 1) samplable else SampleOne(samplable, len=nSamplable) - #### message(" - Selected adrift Reconnection Edge: ", adriftReconnectionEdge, "\n") #### DEBUGGING AID - } - } else { - whichAdrift <- edgesOnAdriftSegment[mergeEdges] - if (sum(whichAdrift) != 1) return(TBRWarning(parent, child, paste("Invalid edges selected to merge:", - mergeEdges[1], mergeEdges[2], " - etb= ", edgeToBreak))) - adriftReconnectionEdge <- mergeEdges[whichAdrift] - rootedReconnectionEdge <- mergeEdges[!whichAdrift] - } - if(nearBrokenEdge[rootedReconnectionEdge] && nearBrokenEdge[adriftReconnectionEdge]) - return(TBRWarning(parent, child, "Selected mergeEdges will not change tree topology.")) - #### edgelabels(edge = edgeToBreak, bg='orange', cex=1.8) #### DEBUGGING AID - #### edgelabels(edge=adriftReconnectionEdge, bg='cyan') #### DEBUGGING AID - #### edgelabels(edge=rootedReconnectionEdge, bg='magenta') #### DEBUGGING AID - - ###Assert(edgesOnAdriftSegment[adriftReconnectionEdge]) - ###Assert(!edgesOnAdriftSegment[rootedReconnectionEdge]) - - if (!nearBrokenEdge[adriftReconnectionEdge]) { - edgesToInvert <- EdgeAncestry(adriftReconnectionEdge, parent, child, stopAt = edgeToBreak) & !brokenEdge - if (any(edgesToInvert)) { - tmp <- parent[edgesToInvert] - parent[edgesToInvert] <- child[edgesToInvert] - child[edgesToInvert] <- tmp - } - reconnectionSideEdges <- edgesToInvert - reconnectionSideEdges[adriftReconnectionEdge] <- TRUE - - repurposedDaughterEdge <- brokenEdgeDaughters & reconnectionSideEdges - spareDaughterEdge <- brokenEdgeDaughters & !reconnectionSideEdges - ###Assert(identical(sum(repurposedDaughterEdge), sum(spareDaughterEdge), 1)) - #### which(repurposedDaughterEdge) - #### which(spareDaughterEdge) - child[repurposedDaughterEdge] <- child[spareDaughterEdge] - child[spareDaughterEdge] <- parent[adriftReconnectionEdge] - ###Assert(parent[spareDaughterEdge] == brokenEdge.childNode) - parent[adriftReconnectionEdge] <- child[edgeToBreak] - } - if (!nearBrokenEdge[rootedReconnectionEdge]) { - parent[brokenEdgeSister] <- parent[brokenEdgeParent] - parent[brokenEdgeParent] <- parent[rootedReconnectionEdge] - parent[rootedReconnectionEdge] <- brokenEdge.parentNode - } - - ###Assert(identical(unique(table(parent)), 2L)) - ###Assert(identical(unique(table(child)), 1L)) - return (RenumberEdges(parent, child)) -} \ No newline at end of file diff --git a/R/TreeSearch_utilities.R b/R/TreeSearch_utilities.R deleted file mode 100644 index cb33cd153..000000000 --- a/R/TreeSearch_utilities.R +++ /dev/null @@ -1,13 +0,0 @@ -#' @rdname TreeSearch -#' @return `EmptyPhyDat()` returns a `phyDat` object comprising a single -#' null character, coded with state zero for every leaf in `tree`. -#' @importFrom TreeTools MatrixToPhyDat NTip TipLabels -#' @export -EmptyPhyDat <- function (tree) { - mat <- matrix(0, NTip(tree), 1, dimnames = list(TipLabels(tree), NULL)) - MatrixToPhyDat(mat) -} - -#' @rdname TreeSearch -#' @export -DoNothing <- function (...) {} diff --git a/R/ci-ri.R b/R/ci-ri.R deleted file mode 100644 index c086f52e2..000000000 --- a/R/ci-ri.R +++ /dev/null @@ -1,37 +0,0 @@ -#' Consistency / retention 'indices' -#' -#' `Consistency()` calculates the so-called consistency and retention 'indices' -#' for each character in a dataset, given a bifurcating tree. -#' Although there is not a straightforward interpretation of these indices, -#' they are sometimes taken as an indicator of the fit of a character to a -#' tree. Values correlate with the number of species sampled and the -#' distribution of taxa between character states, so are not strictly comparable -#' between characters in which these factors differ. -#' -#' #TODO: Retention index not yet implemented. -#' -#' @template datasetParam -#' @template treeParam -#' @template compressParam -#' -#' @return `Consistency()` returns a named vector specifying the -#' consistency index (`ci`), -#' retention index (`ri`), and rescaled consistency index (`rc`). -#' -#' @examples -#' data(inapplicable.datasets) -#' dataset <- inapplicable.phyData[[4]] -#' Consistency(dataset, TreeTools::NJTree(dataset)) -#' @template MRS -#' @export -Consistency <- function (dataset, tree, compress = FALSE) { - ci <- MinimumLength(dataset, compress = TRUE) / - CharacterLength(tree, dataset, compress = TRUE) - - # Return: - if (compress) { - ci - } else { - ci[attr(dataset, 'index')] - } -} \ No newline at end of file diff --git a/R/data_manipulation.R b/R/data_manipulation.R deleted file mode 100644 index 21eea24ac..000000000 --- a/R/data_manipulation.R +++ /dev/null @@ -1,392 +0,0 @@ -#' Prepare data for Profile Parsimony -#' -#' Calculates profiles for each character in a dataset. Will also simplify -#' characters, with a warning, where they are too complex for the present -#' implementation of profile parsimony: -#' - inapplicable tokens will be replaced with the ambiguous token -#' (i.e. `-` \ifelse{html}{\out{→}}{\eqn{\rightarrow}{-->}} `?`); -#' - Ambiguous tokens will be treated as fully ambiguous -#' (i.e. `{02}` \ifelse{html}{\out{→}}{\eqn{\rightarrow}{-->}} `?`) -#' - Where more than two states are informative (i.e. unambiguously present in -#' more than two taxa), states beyond the two most informative will be -#' ignored. -#TODO can do something more complex like first two to one TS, second two to another -#' -#' @param dataset dataset of class \code{phyDat} -#' -#' @return An object of class `phyDat`, with additional attributes. -#' `PrepareDataProfile` adds the attributes: -#' -#' - `info.amounts`: details the information represented by each -#' character when subject to N additional steps. -#' -#' - `informative`: logical specifying which characters contain any -#' phylogenetic information. -#' -#' - `bootstrap`: The character vector -#' \code{c('info.amounts', 'split.sizes')}, indicating attributes to sample -#' when bootstrapping the dataset (e.g. in Ratchet searches). -#' -#' `PrepareDataIW` adds the attribute: -#' -#' - \code{min.length}: The minimum number of steps that must be present in each -#' transformation series. -#' @examples -#' data('congreveLamsdellMatrices') -#' dataset <- congreveLamsdellMatrices[[42]] -#' PrepareDataProfile(dataset) -#' @author Martin R. Smith; written with reference to -#' `phangorn:::prepareDataFitch()` -#' @importFrom cli cli_alert cli_alert_warning -#' @family profile parsimony functions -#' @encoding UTF-8 -#' @export -PrepareDataProfile <- function (dataset) { - if ('info.amounts' %fin% names(attributes(dataset))) { - # Already prepared - return(dataset) - } - at <- attributes(dataset) - nLevel <- length(at$level) - cont <- attr(dataset, "contrast") - nTip <- length(dataset) - index <- at$index - allLevels <- as.character(at$allLevels) - - contSums <- rowSums(cont) - qmLevel <- which(contSums == ncol(cont)) - - if (length(qmLevel) == 0) { - attr(dataset, "contrast") <- rbind(attr(dataset, "contrast"), 1) - attr(dataset, "allLevels") <- c(attr(dataset, "allLevels"), '{?}') - qmLevel <- length(allLevels) + 1L - } - - ambigs <- which(contSums > 1L & contSums < ncol(cont)) - inappLevel <- which(colnames(cont) == '-') - if (length(inappLevel) != 0L) { - cli_alert("Inapplicable tokens treated as ambiguous for profile parsimony") - inappLevel <- which(apply(unname(cont), 1, identical, - as.double(colnames(cont) == '-'))) - dataset[] <- lapply(dataset, function (i) { - i[i %fin% inappLevel] <- qmLevel - i - }) - } - - if (length(ambigs) != 0L) { - # Message unnecessary until multiple informative states are supported - # message("Ambiguous tokens ", paste(at$allLevels[ambigs], collapse = ', '), - # " converted to '?'") - dataset[] <- lapply(dataset, function (i) { - i[i %fin% ambigs] <- qmLevel - i - }) - } - - mataset <- matrix(unlist(dataset, recursive = FALSE, use.names = FALSE), - max(index)) - - .RemoveExtraTokens <- function (char, ambiguousTokens) { - unambig <- char[!char %fin% ambiguousTokens] - if (length(unambig) == 0) { - return(matrix(nrow = length(char), ncol = 0)) - } - split <- table(unambig) - ranking <- order(order(split, decreasing = TRUE)) - ignored <- ranking > 2L - if (any(split[ignored] > 1L)) { - warningMsg <- "Can handle max. 2 informative tokens. Dropping others." - if (interactive()) { - cli_alert_warning(warningMsg) # nocov - } else { - warning(warningMsg) - } - } - if (length(ambiguousTokens) == 0) { - stop("No ambiguous token available for replacement") - } - tokens <- names(split) - most <- tokens[which.min(ranking)] - vapply(setdiff(names(split)[split > 1], most), function (kept) { - simplified <- char - simplified[!simplified %fin% c(most, kept)] <- ambiguousTokens[1] - simplified - }, char) - } - - decomposed <- lapply(seq_along(mataset[, 1]), function (i) - .RemoveExtraTokens(mataset[i, ], ambiguousTokens = qmLevel)) - nChar <- vapply(decomposed, dim, c(0, 0))[2, ] - if (sum(nChar) == 0) { - cli_alert("No informative characters in `dataset`.") - attr(dataset, 'info.amounts') <- double(0) - return(dataset[0]) - } - newIndex <- seq_len(sum(nChar)) - oldIndex <- rep.int(seq_along(nChar), nChar) - index <- unlist(lapply(index, function (i) { - newIndex[oldIndex == i] - })) - - mataset <- unname(do.call(cbind, decomposed)) - - NON_AMBIG <- 1:2 - AMBIG <- max(NON_AMBIG) + 1L - .Recompress <- function (char, ambiguousTokens) { - tokens <- unique(char) - nonAmbig <- setdiff(tokens, ambiguousTokens) - stopifnot(length(nonAmbig) == 2L) - #available <- setdiff(seq_along(c(nonAmbig, ambiguousTokens)), ambiguousTokens) - - cipher <- seq_len(max(tokens)) - cipher[nonAmbig] <- NON_AMBIG # available[seq_along(nonAmbig)] - cipher[ambiguousTokens] <- AMBIG - - # Return: - cipher[char] - } - if (length(mataset) == 0) { - cli_alert("No informative characters in `dataset`.") - attr(dataset, 'info.amounts') <- double(0) - return(dataset[0]) - } - mataset <- apply(mataset, 2, .Recompress, qmLevel) - dupCols <- duplicated(t(mataset)) - kept <- which(!dupCols) - copies <- lapply(kept, function (i) { - i + which(apply(mataset[, -seq_len(i), drop = FALSE], 2, identical, mataset[, i])) - }) - firstOccurrence <- seq_len(dim(mataset)[2]) - for (i in seq_along(copies)) { - firstOccurrence[copies[[i]]] <- kept[i] - } - - cipher <- seq_len(max(kept)) - cipher[kept] <- order(kept) - index <- cipher[firstOccurrence][index] - - mataset <- mataset[, !dupCols, drop = FALSE] - dataset[] <- lapply(seq_len(length(dataset)), function (i) mataset[i, ]) - - - #TODO when require R4.1: replace with - # info <- apply(mataset, 1, StepInformation, - # ambiguousTokens = c(qmLevel, inappLevel), - # simplify = FALSE) - info <- lapply(seq_along(mataset[1, ]), function (i) - StepInformation(mataset[, i], ambiguousTokens = AMBIG)) - - - maxSteps <- max(vapply(info, - function (i) max(as.integer(names(i))), - integer(1))) - info <- vapply(info, - function (x) { - ret <- setNames(double(maxSteps), seq_len(maxSteps)) - x <- x[setdiff(names(x), '0')] - if (length(x)) { - ret[names(x)] <- max(x) - x - } - ret - }, double(maxSteps)) - if (is.null(dim(info))) { - dim(info) <- c(1L, length(info)) - } - attr(dataset, 'index') <- index - weight <- as.integer(table(index)) - attr(dataset, 'weight') <- weight - attr(dataset, 'nr') <- length(weight) - attr(dataset, 'info.amounts') <- info - attr(dataset, 'informative') <- colSums(info) > 0 - lvls <- c('0', '1') - attr(dataset, 'levels') <- lvls - attr(dataset, 'allLevels') <- c(lvls, '?') - attr(dataset, 'contrast') <- matrix(c(1,0,1,0,1,1), length(lvls) + 1L, length(lvls), - dimnames = list(NULL, lvls)) - attr(dataset, 'nc') <- length(lvls) - - if (!any(attr(dataset, 'bootstrap') == 'info.amounts')) { - attr(dataset, 'bootstrap') <- c(attr(dataset, 'bootstrap'), 'info.amounts') - } - - dataset -} - - -#' @describeIn PrepareDataProfile Prepare data for implied weighting -#' @export -PrepareDataIW <- function (dataset) { - at <- attributes(dataset) - nLevel <- length(at$level) - nChar <- at$nr - nTip <- length(dataset) - cont <- at$contrast - inappLevel <- at$levels == '-' - - if (any(inappLevel)) { - # TODO this is a workaround until MinimumLength can handle {-, 1} - cont[cont[, inappLevel] > 0, ] <- 0 - ambiguousToken <- at$allLevels == '?' - cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 - } - - # Perhaps replace with previous code: - # inappLevel <- which(at$levels == "-") - # cont[, inappLevel] <- 0 - - - powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) - tmp <- as.integer(cont %*% powersOf2) - unlisted <- unlist(dataset, use.names = FALSE) - binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) - - attr(dataset, 'min.length') <- apply(binaryMatrix, 1, MinimumLength, - compress = TRUE) - - # Return: - dataset -} - -#' Minimum length -#' -#' The smallest length that a character can obtain on any tree. -#' -#' -#' @param x An object of class `phyDat`, -#' or an integer vector listing the tokens that may be present at each -#' tip along a single character, with each token represented as a binary digit; -#' e.g. a value of 11 ( = 2^0 + 2^1 + 2^3) means that -#' the tip may have tokens 0, 1 or 3. -#' -#' Inapplicable tokens should be denoted with the integer `0` (not 2^0). -#' -#' Tokens that are ambiguous for an inapplicable and an applicable -#' state are not presently supported; for an approximate value, denote such -#' ambiguity with the integer `0`. -#' @template compressParam -#' -#' @return `MinimumLength()` returns a vector of integers specifying the -#' minimum number of steps that each character must contain. -#' -#' @examples -#' data('inapplicable.datasets') -#' myPhyDat <- inapplicable.phyData[[4]] -#' MinimumLength(myPhyDat) -#' MinimumLength(myPhyDat, compress = TRUE) -#' -#' -#' class(myPhyDat) # phyDat object -#' # load your own data with -#' # my.PhyDat <- as.phyDat(read.nexus.data('filepath')) -#' # or Windows users can select a file interactively using: -#' # my.PhyDat <- as.phyDat(read.nexus.data(choose.files())) -#' -#' # Convert list of character codings to an array -#' myData <- vapply(myPhyDat, I, myPhyDat[[1]]) -#' -#' # Convert phyDat's representation of states to binary -#' myContrast <- attr(myPhyDat, 'contrast') -#' tokens <- colnames(myContrast) -#' binaryContrast <- integer(length(tokens)) -#' tokenApplicable <- tokens != '-' -#' binaryContrast[tokenApplicable] <- 2 ^ (seq_len(sum(tokenApplicable)) - 1) -#' binaryValues <- apply(myContrast, 1, -#' function (row) sum(binaryContrast[as.logical(row)])) -#' myStates <- matrix(binaryValues[myData], nrow = nrow(myData), -#' ncol = ncol(myData), dimnames = dimnames(myData)) -#' -#' # Finally, work out minimum steps -#' apply(myStates, 1, MinimumLength) -#' @template MRS -#' @family tree scoring -#' @export -MinimumLength <- function (x, compress = FALSE) UseMethod('MinimumLength') - -#' @rdname MinimumLength -#' @export -MinimumLength.phyDat <- function (x, compress = FALSE) { - - at <- attributes(x) - nLevel <- length(at$level) - nChar <- at$nr - nTip <- length(x) - cont <- at$contrast - if (is.null(colnames(cont))) { - colnames(cont) <- as.character(at$levels) - } - simpleCont <- ifelse(rowSums(cont) == 1, - apply(cont != 0, 1, function (x) colnames(cont)[x][1]), - '?') - inappLevel <- at$levels == '-' - - if (any(inappLevel)) { - # TODO this is a workaround until MinimumLength.numeric can handle {-, 1} - cont[cont[, inappLevel] > 0, ] <- 0 - ambiguousToken <- at$allLevels == '?' - cont[ambiguousToken, ] <- colSums(cont[!ambiguousToken, ]) > 0 - } - - powersOf2 <- 2L ^ c(0L, seq_len(nLevel - 1L)) - tmp <- as.integer(cont %*% powersOf2) - unlisted <- unlist(x, use.names = FALSE) - binaryMatrix <- matrix(tmp[unlisted], nChar, nTip, byrow = FALSE) - - ret <- apply(binaryMatrix, 1, MinimumLength) - - # Return: - if (compress) { - ret - } else { - ret[attr(x, 'index')] - } -} - -#' @rdname MinimumLength -#' @export -MinimumLength.numeric <- function (x, compress = NA) { - - uniqueStates <- unique(x[x > 0]) - if (length(uniqueStates) < 2) return (0) - tokens <- vapply(uniqueStates, intToBits, raw(32)) != 00 - tokens <- tokens[apply(tokens, 1, any), ] - - lastDim <- dim(tokens) - tokensUsed <- 0 - - repeat { - tokens <- tokens[!duplicated(tokens), , drop = FALSE] - unambiguous <- colSums(tokens) == 1 - tokenNecessary <- apply(tokens[, unambiguous, drop = FALSE], 1, any) - statesRemaining <- !unambiguous - statesRemaining[statesRemaining] <- colSums( - tokens[tokenNecessary, statesRemaining, drop = FALSE]) == 0 - tokensUsed <- tokensUsed + sum(tokenNecessary) - - if (!any(statesRemaining)) { - # Return: - return (tokensUsed - 1L) - } - - tokens <- tokens[!tokenNecessary, statesRemaining, drop = FALSE] - if (identical(dim(tokens), lastDim)) { - occurrences <- rowSums(tokens) - unnecessary <- occurrences == 1 - if (any(unnecessary)) { - tokens <- tokens[!unnecessary, , drop = FALSE] - } else { - squish <- which.max(occurrences) - tokensUsed <- tokensUsed + 1L - tokens <- tokens[, tokens[!squish], drop = FALSE] - } - } - lastDim <- dim(tokens) - } -} - -#' @rdname MinimumLength -MinimumSteps <- function(x) { - .Deprecated("MinimumLength", - msg = 'Renamed to `MinimumLength()` and recoded to better support inapplicable tokens') - MinimumLength(x, compress = TRUE) -} diff --git a/R/mpl_morphy_objects.R b/R/mpl_morphy_objects.R deleted file mode 100644 index ac193f646..000000000 --- a/R/mpl_morphy_objects.R +++ /dev/null @@ -1,276 +0,0 @@ -#' Details the attributes of a morphy object -#' -#' @param object A Morphy object -#' @param \dots any other parameters... -#' -#' @return A list detailing the number of taxa, internal nodes, and characters and their weights. -#' -#' @author Martin R. Smith -#' @method summary morphyPtr -#' @family Morphy API functions -#' @importFrom Rcpp compileAttributes -#' @export -summary.morphyPtr <- function (object, ...) { - ans <- list() - class(ans) <- "summary.morphyPtr" - nTax <- mpl_get_numtaxa(object) - nChar <- mpl_get_num_charac(object) - charWeights <- MorphyWeights(object) - - ans$nTax <- nTax - ans$nChar <- nChar - ans$nInternal <- mpl_get_num_internal_nodes(object) - ans$charWeights <- charWeights - ans$allStates <- mpl_get_symbols(object) - # Return: - ans -} - -#' Set and get the character weightings associated with a Morphy object. -#' -#' `MorphyWeights()` details the approximate and exact weights associated with -#' characters in a `Morphy` object; `SetMorphyWeights()` edits them. -#' -#' @template morphyObjParam -#' @return `MorphyWeights()` returns a data frame with two named rows and -#' one column per character pattern: -#' row 1, `approx`, is a list of integers specifying the approximate (integral) -#' weights used by MorphyLib; -#' row 2, `exact`, is a list of numerics specifying the exact weights specified -#' by the user. -#' -#' @examples -#' tokens <- matrix(c( -#' 0, 0, 0, 1, 1, 2, -#' 0, 0, 0, 0, 0, 0), byrow = TRUE, nrow = 2L, -#' dimnames = list(letters[1:2], NULL)) -#' pd <- TreeTools::MatrixToPhyDat(tokens) -#' morphyObj <- PhyDat2Morphy(pd) -#' MorphyWeights(morphyObj) -#' if (SetMorphyWeights(c(1, 1.5, 2/3), morphyObj) != 0L) message("Errored") -#' MorphyWeights(morphyObj) -#' morphyObj <- UnloadMorphy(morphyObj) -#' @template MRS -#' @family Morphy API functions -#' @export -MorphyWeights <- function (morphyObj) { - vapply(seq_len(mpl_get_num_charac(morphyObj)), mpl_get_charac_weight, - list('approx' = 0L, 'exact' = 0), morphyobj = morphyObj) -} - -#' @rdname MorphyWeights -#' @param weight A vector listing the new weights to be applied to each character -#' @param checkInput Whether to sanity-check input data before applying. -#' Defaults to `TRUE` to protect the user from crashes. -#' -#' @return `SetMorphyWeights()` returns the Morphy error code generated when -#' applying `weight`. -#' @export -SetMorphyWeights <- function (weight, morphyObj, checkInput = TRUE) { - if (checkInput) if (length(weight) != mpl_get_num_charac(morphyObj)) { - stop("Number of weights not equal to number of character entries.") - } - errors <- vapply(seq_along(weight), - function (i) mpl_set_charac_weight(i, weight[i], morphyObj), - integer(1)) - if(any(errors != 0)) warning("Morphy Error encountered: ", - mpl_translate_error(errors[errors < 0])) - mpl_apply_tipdata(morphyObj) -} - -#' Read how a Morphy Object handles the inapplicable token -#' -#' Gaps represented by the inapplicable token can be treated as 'missing data', -#' i.e. as equivalent to the ambiguous token `?`; as an extra state, equivalent -#' to other states such as `0` or `1`; or as 'inapplicable data' using the -#' algorithm of Brazeau, Guillerme and Smith (2019). -#' -#' @template morphyObjParam -#' -#' @return `GapHandler()` returns a character string stating how -#' gaps are handled by `morphyObj`. -#' @examples -#' morphyObj <- SingleCharMorphy('-0-0', 'Extra') -#' GapHandler(morphyObj) -#' morphyObj <- UnloadMorphy(morphyObj) -#' @family Morphy API functions -#' @template MRS -#' @export -GapHandler <- function (morphyObj) { - if (!is.morphyPtr(morphyObj)) { - stop("`morphyObj` is not a valid Morphy object") - } - - ret <- c('Inapplicable', 'Missing data', 'Extra state', 'Unspecified') # 4 = GAP_MAX - handler <- mpl_get_gaphandl(morphyObj) - if (handler < 0L) { - stop("Morphy object error: ", mpl_translate_error(handler)) - } - # Return: - ret[1L + handler] -} - -#' Initialize a Morphy object from a `phyDat` object -#' -#' Creates a new Morphy object with the same size and characters as the -#' `phyDat` object. -#' Once finished with the object, it should be destroyed using -#' [`UnloadMorphy()`] to free the allocated memory. -#' -#' -#' @param phy An object of class \code{\link{phyDat}}. -#' @template gapParam -#' @return `PhyDat2Morphy()` returns a pointer to an initialized Morphy object. -#' -#' @examples -#' data('Lobo', package='TreeTools') -#' morphyObj <- PhyDat2Morphy(Lobo.phy) -#' # Set object to be destroyed at end of session or closure of function -#' # on.exit(morphyObj <- UnloadMorphy(morphyObj), add = TRUE) -#' -#' # Do something with pointer -#' # .... -#' -#' # Or, instead of on.exit, manually destroy morphy object and free memory: -#' morphyObj <- UnloadMorphy(morphyObj) -#' @template MRS -#' @family Morphy API functions -#' @importFrom phangorn phyDat -#' @importFrom TreeTools PhyToString -#' @export -PhyDat2Morphy <- function (phy, gap = 'inapplicable') { - - if (!inherits(phy, 'phyDat')) { - stop('Invalid data type ', class(phy), '; should be phyDat.') - } - - morphyObj <- structure(mpl_new_Morphy(), class = 'morphyPtr') - nTax <- length(phy) - weight <- attr(phy, 'weight') - nChar <- attr(phy, 'nr') - - if (mpl_init_Morphy(nTax, nChar, morphyObj) -> error) { - stop("Error ", mpl_translate_error(error), " in mpl_init_Morphy") #nocov - } - if (mpl_set_gaphandl(.GapHandler(gap), morphyObj) -> error) { - stop("Error ", mpl_translate_error(error), " in mpl_set_gaphandl") #nocov - } - if (mpl_attach_rawdata(PhyToString(phy, ps=';', useIndex = FALSE, - byTaxon = TRUE, concatenate = TRUE), - morphyObj) -> error) { - stop("Error ", mpl_translate_error(error), " in mpl_attach_rawdata") #nocov - } - if (mpl_set_num_internal_nodes(nTax - 1L, morphyObj) -> error) { # One is the 'dummy root' - stop("Error ", mpl_translate_error(error), " in mpl_set_num_internal_nodes") - } - if (any(vapply(seq_len(nChar), - function (i) mpl_set_parsim_t(i, 'FITCH', morphyObj), - NA_integer_) -> error)) { - stop("Error ", mpl_translate_error(min(error)), "in mpl_set_parsim_t") #nocov - } - if (any(vapply(seq_len(nChar), - function (i) mpl_set_charac_weight(i, weight[i], morphyObj), - NA_integer_) -> error)) { - stop("Error ", mpl_translate_error(min(error)), "in mpl_set_charac_weight") #nocov - } - if (mpl_apply_tipdata(morphyObj) -> error) { - stop("Error ", mpl_translate_error(error), "in mpl_apply_tipdata") #nocov - } - # Return: - morphyObj -} - -#' Translate a gap treatment into a string in the format expected by Morphy -#' @param gap Character vector: how should gaps be handled? -#' @return Character string that can be translated into a gap handling strategy -#' by Morphy. -#' @keywords internal -.GapHandler <- function (gap) { - handler <- pmatch(tolower(gap), - c('inapplicable', 'missing', 'ambiguous', 'extra state')) - if (is.na(handler)) { - stop("`treatment` must be an abbreviation of 'inapplicable', ", - "'missing' or 'extra state'") - } - - # Return: - switch(handler, 'inapplicable', 'missing', 'missing', 'newstate') -} - -#' Check for error whilst modifying Morphy object -#' @param action action to perform -#' -#' @family Morphy API functions -#' @keywords internal -#' @export -MorphyErrorCheck <- function (action) { - if (action -> error) { - stop("Morphy object encountered error ", mpl_translate_error(error), "\n") - } -} - -#' Morphy object from single character -#' -#' @param char State of each character at each tip in turn, in a format that will be converted -#' to a character string by \code{\link{paste0}(char, ';', collapse='')}. -#' @template gapParam -#' -#' @return A pointer to an object of class `morphyObj`. -#' Don't forget to unload it when you've finished with it. -#' -#' @examples -#' morphyObj <- SingleCharMorphy('-0-0', gap = 'Extra') -#' RandomTreeScore(morphyObj) -#' morphyObj <- UnloadMorphy(morphyObj) -#' @template MRS -#' @family Morphy API functions -#' @export -SingleCharMorphy <- function (char, gap = 'inapp') { - char <- paste0(c(char, ';'), collapse = '') - entries <- gregexpr("\\{[^\\{]+\\}|\\([^\\()]+\\)|[^;]", char) - nTip <- length(entries[[1]]) - morphyObj <- mpl_new_Morphy() - MorphyErrorCheck(mpl_init_Morphy(nTip, 1, morphyObj)) - MorphyErrorCheck(mpl_set_gaphandl(.GapHandler(gap), morphyObj)) - MorphyErrorCheck(mpl_attach_rawdata(char, morphyObj)) - MorphyErrorCheck(mpl_set_num_internal_nodes(nTip - 1L, morphyObj)) - MorphyErrorCheck(mpl_set_parsim_t(1, 'FITCH', morphyObj)) - MorphyErrorCheck(mpl_set_charac_weight(1, 1, morphyObj)) - MorphyErrorCheck(mpl_apply_tipdata(morphyObj)) - class(morphyObj) <- 'morphyPtr' - morphyObj -} - -#' Is an object a valid Morphy object? -#' @template morphyObjParam -#' @return `is.morphyPtr()` returns `TRUE` if `morphyObj` is a valid morphy -#' pointer, `FALSE` otherwise. -#' @template MRS -#' @family Morphy API functions -#' @export -is.morphyPtr <- function (morphyObj) { - inherits(morphyObj, 'morphyPtr') -} - -#' Destroy a Morphy object -#' -#' Destroys a previously-created Morphy object. -#' -#' Best practice is to call `morphyObj <- UnloadMorphy(morphyObj)` -#' Failure to do so will cause a crash if `UnloadMorphy()` is called on an -#' object that has already been destroyed -#' -#' @template morphyObjParam -#' @return Morphy error code, decipherable using \code{\link{mpl_translate_error}} -#' @author Martin R. Smith -#' @family Morphy API functions -#' @export -UnloadMorphy <- function (morphyObj) { - if (!is.morphyPtr(morphyObj)) { - stop ("Object is not a valid pointer; cannot destroy.") - } - if (mpl_delete_Morphy(morphyObj) -> error) { - stop("Error ", mpl_translate_error(error), "in mpl_delete_Morphy") #nocov - } - return (error) -} diff --git a/R/mpl_morphyex.R b/R/mpl_morphyex.R deleted file mode 100644 index 277738911..000000000 --- a/R/mpl_morphyex.R +++ /dev/null @@ -1,505 +0,0 @@ -#' Converts a numeric error code to human-readable format -#' -#' @param errorCode Non-positive integer to be converted -#' -#' @return A character string corresponding to the provided error code -#' -#' @examples mpl_translate_error(-1) # "ERR_INVALID_SYMBOL" -#' -#' @author Martin R. Smith -#' @family Morphy API functions -#' @keywords internal -#' @export - -mpl_translate_error <- function (errorCode) { - mplErrorCodes <- rev(c( - "ERR_EX_DATA_CONF", - "ERR_OUT_OF_BOUNDS", - "ERR_CASE_NOT_IMPL", - "ERR_UNKNOWN_CHTYPE", - "ERR_SYMBOL_MISMATCH", - "ERR_MATCHING_PARENTHS", - "ERR_ATTEMPT_OVERWRITE", - "ERR_NO_DIMENSIONS", - "ERR_DIMENS_UNDER", - "ERR_DIMENS_OVER", - "ERR_NO_DATA", - "ERR_BAD_MALLOC", - "ERR_BAD_PARAM", - "ERR_UNEXP_NULLPTR", - "ERR_INVALID_SYMBOL", - "ERR_NO_ERROR")) - return (mplErrorCodes[1-errorCode]) -} - -#' Creates a new instance of a Morphy object -#' -#' Creates a new empty Morphy object. All fields are unpopulated -#' and uninitialised. -#' -#' -#' @return A void pointer to the Morphy instance. NULL if unsuccessful. -#' -#' @examples morphyObj <- mpl_new_Morphy() # Create new object -#' ## Do some stuff ... ## -#' mpl_delete_Morphy(morphyObj) # Delete when done -#' -#' @author Martin Brazeau -#' @useDynLib TreeSearch, .registration = TRUE -#' @keywords internal -#' @family Morphy API functions -#' @export -mpl_new_Morphy <- function() { - .Call("_R_wrap_mpl_new_Morphy") -} - -#' Destroys an instance of a Morphy object. -#' -#' Destroys an instance of the Morphy object, calling all -#' destructor for internal object completely returning the memory to the system. -#' -#' @param morphyobj A Morphy object to be destroyed. -#' -#' @return A Morphy error code. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_delete_Morphy <- function(morphyobj) { - .Call("_R_wrap_mpl_delete_Morphy", morphyobj) -} - - -#' Get / set gap handler from a Morphy object. -#' -#' 0 = inapplicable; 1 = missing; 2 = extra -#' -#' @return `mpl_get_gaphandl()` returns an integer corresponding to the gap -#' handling approach. -#' -#' -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_get_gaphandl <- function (morphyobj) { - .Call("_R_wrap_mpl_get_gaphandl", morphyobj) -} -#' @rdname mpl_get_gaphandl -#' @keywords internal -#' @return `mpl_set_gaphandl()` returns a Morphy error code. -#' @export -mpl_set_gaphandl <- function (handl, morphyobj) { - .Call("_R_wrap_mpl_set_gaphandl", handl, morphyobj) -} - -#' Sets up the dimensions of the dataset. -#' -#' Provides initial dimensions for the dataset, which will -#' constrain any input matrix supplied to Morphy. -#' -#' @param morphyobj An instance of the Morphy object. -#' @param ntax The number of taxa (or tips/terminals). -#' @param nchar The number of characters (i.e. transformation series) in the -#' data set. -#' -#' @return Morphy error code. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_init_Morphy <- function(numtaxa, numchars, morphyobj) { - .Call("_R_wrap_mpl_init_Morphy", as.integer(numtaxa), as.integer(numchars), - morphyobj) -} - -#' Retrieve the number of taxa (rows) in the dataset. -#' -#' Retrieves the number of taxa (rows) in the dataset. -#' -#' @param morphyobj An instance of the Morphy object. -#' -#' @return The number of taxa if success, otherwise an error code. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_get_numtaxa <- function(morphyobj) { - .Call("_R_wrap_mpl_get_numtaxa", morphyobj) -} - -#' Set the weight of a character in the dataset -#' -#' Sets the weight of a character in the dataset. -#' -#' @param charID Number of the character (i.e. first character is number 1) -#' @param weight Weight to assign -#' @param morphyobj An instance of the Morphy object. -#' -#' @return An error code. -#' -#' @author Martin R. Smith -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_set_charac_weight <- function (charID, weight, morphyobj) { - .Call('_R_wrap_mpl_set_charac_weight', as.integer(charID - 1L), - as.numeric(weight), morphyobj) -} - -#' Retrieve the weight of a character in the dataset -#' -#' Gets the weights of a character in the dataset. -#' -#' @param charID Number of the character (i.e. first character is number 1) -#' @param morphyobj An instance of the Morphy object. -#' -#' @return A list, detailing (item 1) the exact weight of the character; (item 2) the integer -#' approximation used by Morphy. -#' -#' @author Martin R. Smith -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_get_charac_weight <- function (charID, morphyobj) { - .Call('_R_wrap_mpl_get_charac_weight', as.integer(charID) - 1L, morphyobj) -} - -#' Retrieve the number of character (columns) in the dataset. -#' -#' Retrieves the number of character (columns) in the dataset. -#' -#' @param morphyobj An instance of the Morphy object. -#' -#' @return The number of internal nodes. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_get_num_charac <- function(morphyobj) { - .Call("_R_wrap_mpl_get_num_charac", morphyobj) -} - -#' Attach a caller-specified list of symbols. -#' -#' Allows the caller to specify a list of symbols in the data matrix, -#' otherwise, the symbols list used by Morphy will be extracted from the matrix. -#' The symbols list must match the symbols provided in the matrix. When Morphy -#' extracts symbols from the matrix, their ordering is alphanumeric, according to -#' their ASCII codes (i.e. "+0123...ABCD...abcd..."). Loading a user-specified -#' symbols list will override this ordering. Symbols loaded in either the list or -#' the matrix must be valid Morphy character state symbols as defined in the -#' statedata.h header file. The list must end with a semicolon. -#' -#' @param symbols A C-style (i.e. NULL-terminated) string of valid state symbols. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return Morphy error code. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_attach_symbols <- function(symbols, morphyobj) { - .Call("_R_wrap_mpl_attach_symbols", symbols, morphyobj) -} - -#' Attach raw character state data (i.e. tip data). -#' -#' Attaches a raw data character state matrix in the form of a C-style -#' (i.e. NULL-terminated) string. This can be the matrix block extracted from a -#' Nexus file or an `xread` table format. -#' The matrix should contain no leaf labels. -#' -#' @param rawmatrix C-style string corresponding to the tip data for each taxon in turn. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return Morphy error code. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_attach_rawdata <- function(rawdata, morphyobj) { - .Call("_R_wrap_mpl_attach_rawdata", rawdata, morphyobj) -} - -#' Retrieves the current list of symbols. -#' -#' Returns a pointer to the string of character state symbols -#' currently being used by Morphy (i.e. either the list of symbols extracted -#' from the matrix, or the caller-specified values). -#' -#' @param morphyobj An instance of the Morphy object. -#' -#' @return A C-style (null-terminated) string of the character state symbols -#' being used. NULL if failure. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export - -mpl_get_symbols <- function(morphyobj) { - .Call("_R_wrap_mpl_get_symbols", morphyobj) -} - -#' Sets a character's parsimony function type -#' -#' Set the parsimony function type to one defined in the -#' morphydefs.h header file. Setting the character to type NONE_T will also -#' cause it to be excluded from any further calculations. -#' -#' @param char_id The number of the character (transformation series) as defined -#' in the input matrix. The first character is numbered 1 (one). -#' @param tname The parsimony function type as defined in morphydefs.h -#' @param morphyobj An instance of the Morphy object. -#' -#' @return A Morphy error code. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_set_parsim_t <- function(char_id, tname = "typename", morphyobj) { - .Call("_R_wrap_mpl_set_parsim_t", as.integer(char_id - 1L), tname, morphyobj) -} - -#' Sets the number of internal nodes in the dataset -#' -#' This specifies the number of internal nodes over which -#' reconstruction sets need to be made. It is up to the caller to ensure the -#' correct number of nodes and the relationships between them. -#' -#' @param nnodes The desired number of internal nodes. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return A Morphy error code. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_set_num_internal_nodes <- function(numnodes, morphyobj) { - .Call("_R_wrap_mpl_set_num_internal_nodes", as.integer(numnodes), morphyobj) -} - -#' Gets the number of internal nodal reconstruction sets being used by -#' MorphyLib. -#' -#' Gets the number of internal nodal reconstruction sets being used -#' by MorphyLib. -#' -#' @param morphyobj An instance of the Morphy object. -#' -#' @return The number of internal nodes. -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export - -mpl_get_num_internal_nodes <- function(morphyobj) { - .Call("_R_wrap_mpl_get_num_internal_nodes", morphyobj) -} - -#' Commits parameters prior to nodal set calculations. -#' -#' Once the caller is satisfied with the setup of types, weights, -#' and partitioning, this function must be called, thereby committing the -#' parameters until any changes are made. If no character types have been -#' assigned, the function will fail with an error code. -#' -#' @param morphyobj An instance of the Morphy object. -#' -#' @return A Morphy error code. -#' @family Morphy API functions -#' -#' @author Martin Brazeau -#' @keywords internal -#' @export -mpl_apply_tipdata <- function(morphyobj) { - .Call("_R_wrap_mpl_apply_tipdata", morphyobj) -} - -#' Reconstructs the first (downpass) nodal reconstructions -#' -#' Reconstructs the preliminary nodal set for all characters for a -#' particular node. This function is called over a postorder sequence of internal -#' nodes where left and right descendants are known. -#' Because this function needs to be fairly high-performance, it does not do much -#' checking for parameter validity, thus unsafe usage of this function might not -#' be caught. It is up to calling functions to ensure that the appropriate -#' parameters have been set before use. -#' -#' @param node_id The index of the node being reconstructed. -#' @param left_id The index of the left descendant. -#' @param right_id The index of the right descendant. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return The integral parsimony length (right now) -#' -#' @author Martin Brazeau -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_first_down_recon <- function(node_id, left_id, right_id, morphyobj) { - .Call("_R_wrap_mpl_first_down_recon", as.integer(node_id), as.integer(left_id), as.integer(right_id), morphyobj) -} - -#' Deletes the caller-input data. -#' -#' Deletes all of the user-input data and restores all parameters -#' to their original values, except for the dimensions of the matrix. -#' -#' @param morphyobj An instance of the Morphy object. -#' -#' @return Morphy error code. -#' -#' @author Thomas Guillerme -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_delete_rawdata <- function(morphyobj) { - .Call("_R_wrap_mpl_delete_rawdata", morphyobj) -} - -#' Reconstructs the second (uppass) nodal reconstructions. -#' -#' Reconstructs second-pass nodal sets. For normal (all-applicable) -#' characters, this is the final pass. This function is called over a preorder -#' sequence of nodes where left, right, and ancestral nodes are known. -#' Because this function needs to be fairly high-performance, it does not do much -#' checking for parameter validity, thus unsafe usage of this function might not -#' be caught. It is up to calling functions to ensure that the appropriate -#' parameters have been set before use. -#' -#' @param node_id The index of the node being reconstructed. -#' @param left_id The index of the left descendant. -#' @param right_id The index of the right descendant. -#' @param anc_id The index of the immediate ancestor of the node. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return A null value (for now). -#' -#' @author Thomas Guillerme -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_first_up_recon <- function(node_id, left_id, right_id, anc_id, morphyobj) { - .Call("_R_wrap_mpl_first_up_recon", as.integer(node_id), as.integer(left_id), - as.integer(right_id), as.integer(anc_id), morphyobj) -} - -#' Performs the second nodal reconstructions for characters with -#' inapplicability. -#' -#' Updates the nodal sets that had ambiguous unions with the -#' inapplicable state and calculates steps involving applicable states after -#' the update. -#' Because this function needs to be fairly high-performance, it does not do much -#' checking for parameter validity, thus unsafe usage of this function might not -#' be caught. It is up to calling functions to ensure that the appropriate -#' parameters have been set before use. -#' -#' @param node_id The index of the node being reconstructed. -#' @param left_id The index of the left descendant. -#' @param right_id The index of the right descendant. -#' @param anc_id The index of the immediate ancestor of the node. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return The integral parsimony length (right now) -#' -#' @author Thomas Guillerme -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_second_down_recon <- function(node_id, left_id, right_id, morphyobj) { - .Call("_R_wrap_mpl_second_down_recon", as.integer(node_id), as.integer(left_id), - as.integer(right_id), morphyobj) -} - -#' Finalises the ancestral state reconstructions for characters with -#' inapplicable values. -#' -#' Finalises the nodal sets for any characters that may have involved -#' the inapplicable token and counts excess regions of applicability at nodes -#' having at least two descendant subtrees that possess any applicable characters. -#' Because this function needs to be fairly high-performance, it does not do much -#' checking for parameter validity, thus unsafe usage of this function might not -#' be caught. It is up to calling functions to ensure that the appropriate -#' parameters have been set before use. -#' -#' @param node_id The index of the node being reconstructed. -#' @param left_id The index of the left descendant. -#' @param right_id The index of the right descendant. -#' @param anc_id The index of the immediate ancestor of the node. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return The integral parsimony length (right now) -#' -#' @author Thomas Guillerme -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_second_up_recon <- function(node_id, left_id, right_id, anc_id, morphyobj) { - .Call("_R_wrap_mpl_second_up_recon", as.integer(node_id), as.integer(left_id), - as.integer(right_id), as.integer(anc_id), morphyobj) -} - -#' Initial update of tip values following uppass reconstruction. -#' -#' Ambiguous terminal state sets need to be resolved after the first uppass -#' based on descendant state values in order for local reoptimisation procedures -#' to be accurate and for inapplicable step counting to proceed accurately. This -#' function calls updaters for the records of states active on the subtrees, -#' thereby allowing the second downpass to accurately reconstruct subtree state -#' activity. -#' Because this function needs to be fairly high-performance, it does not do much -#' checking for parameter validity, thus unsafe usage of this function might not -#' be caught. It is up to calling functions to ensure that the appropriate -#' parameters have been set before use. -#' -#' @param tip_id The index of the tip being updated. -#' @param anc_id The index of the tip's immediate ancestor. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return The integral parsimony length (right now) -#' -#' @seealso A null value (for now). -#' -#' @author Thomas Guillerme -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_update_tip <- function(tip_id, anc_id, morphyobj) { - .Call("_R_wrap_mpl_update_tip", as.integer(tip_id), as.integer(anc_id), morphyobj) -} - -#' Updates the nodal sets for a lower ('dummy') root node -#' -#' If trees are rooted, then Morphy uppass functions -#' require a lower or 'dummy' root in order to function properly. This -#' function should be called to set the nodal state sets to the dummy -#' root. The nodal set will be equal to the set of the root node, unless -#' there is an ambiguous union of applicable and gap tokens when gaps are -#' treated as in applicable. In which case, the set union is resolved in -#' favour of any applicable tokens in the set. -#' -#' @param l_root_id The index of the lower root. -#' @param root_id The index of the upper root node. -#' @param morphyobj An instance of the Morphy object. -#' -#' @return A Morphy error code. -#' -#' @author Thomas Guillerme -#' @family Morphy API functions -#' @keywords internal -#' @export -mpl_update_lower_root <- function(l_root_id, root_id, morphyobj) { - .Call("_R_wrap_mpl_update_lower_root", as.integer(l_root_id), as.integer(root_id), - morphyobj) -} diff --git a/R/mpl_visualise.R b/R/mpl_visualise.R deleted file mode 100644 index 29d445d8d..000000000 --- a/R/mpl_visualise.R +++ /dev/null @@ -1,130 +0,0 @@ -### #' Visualize Inheritance -### #' -### #' \code{VisualiseInheritance} does something useful -### #' -### #' @param PARAM is a parameter you should send to it -### #' -### #' @examples -### #' to_do <- TRUE -### #' -### #' @return This function returns : -### #' -### #' @author Martin R. Smith -### #' -### #' @importFrom graphics par plot -### #' @export -### VisualiseInheritance <- VisualizeInheritance <- VisIn <- function (tree, data, char.no, plot.fun=plot) { -### par(mfrow=c(1,2), mar=rep(0.5,4)) -### VisualizeCharacter(tree, data, char.no, plot.fun) -### } -### #' VisualiseCharacter -### #' -### #' Visualize optimization for a character -### #' -### #' @description Determine and depict the possible states for a character on a tree under the most parsimonious conditions -### #' @usage VisualiseCharacter(tree, dataset, char.no, plot.fun = plot) -### #' -### #' @param tree a fully-resolved tree in \code{\link{phylo}} format, with the desired outgroup; edge lengths are not supported and will be deleted; -### #' @template datasetParam -### #' @param char.no number of the character to be displayed; -### #' @param plot.fun a function that plots a tree, \code{\link{plot}} by default. -### #' -### #' @return The function plots a cladogram, annotating each node with the values that could occur there at the lowest parsimony score. -### #' Nodes highlighed in red potentially (but do not necessarily) contribute to tree length. -### #' -### #' @author Martin R. Smith -### #' -### #' @examples{ -### #' data('SigSut') -### #' outgroup <- c('Lingula', 'Mickwitzia', 'Neocrania') -### #' njtree <- root(nj(dist.hamming(SigSut.phy)), outgroup, resolve.root=TRUE) -### #' njtree$edge.length <- NULL; njtree<-SetOutgroup(njtree, outgroup) -### #' VisualiseCharacter(njtree, SigSut.phy, 5, function(x) {plot(x); edgelabels();}) -### #' } -### #' @keywords tree -### #' @aliases VisualiseCharacter -### #' @aliases VisualiseChar -### #' @aliases VisualizeCharacter -### #' @aliases VisualizeChar -### #' -### #' @importFrom ape .PlotPhyloEnv tiplabels nodelabels -### #' @importFrom graphics text -### #' @export -### VisualizeCharacter <- VisualiseCharacter <- VisualiseChar <- VisualizeChar <- -### function (tree, dataset, char.no, plot.fun = plot) { -### if (class(dataset) == 'phyDat') dataset <- MorphyDat(dataset) -### if (class(dataset) != 'morphyDat') stop('Invalid dataset type in VizualizeCharacter.') -### warning("#TODO: Update to use new morphyDat dataset objects") -### at <- attributes(dataset) -### if (char.no > at$nr || char.no < 1) stop(paste0("char.no must be between 1 and ", at$nr, ' (', sum(at$weight), 'TS, ', at$nr, ' unique)')) -### char.dat <- dataset[char.no,] -### char.index <- at$index[char.no] -### if (is.null(at$order) || at$order != "postorder") tree <- Postorder(tree) -### tree.edge <- tree$edge -### parent <- tree.edge[,1] -### child <- tree.edge[,2] -### tip.label <- tree$tip.label -### nEdge <- length(parent) -### nTip <- length(tip.label) -### nNode <- nTip - 1 -### maxNode <- nNode + nTip -### inapp <- at$inapp.level -### tips <- seq(nTip) -### nodes <- nTip + seq(nNode) -### parentof <- parent[match((nTip + 2L):maxNode, child )] # Exclude the root, which has no parent -### childof <- child [c(match(nodes, parent), length(parent) + 1L - match(nodes, rev(parent)))] -### if (any(is.na(char.dat[tip.label]))) stop("Tree's tip labels could not all be found in dataset matrix") -### -### plot.fun(tree) -### ret <- .Call("FITCHINAPP", char.dat[tip.label], as.integer(1), as.integer(parent), as.integer(child), as.integer(parentof), as.integer(childof), as.integer(nEdge), as.integer(nNode), as.double(1), as.integer(maxNode), as.integer(nTip), as.integer(inapp), PACKAGE='inapplicable') -### downpass.states <- ret[[3]] -### down.scorers <- ret[[4]] -### inapp.nodes <- ret[[5]] > 0 -### -### down.change <- sapply(nodes, function(n) { -### children <- child[parent==n] -### return (down.scorers[n] != down.scorers[children[1]] + down.scorers[children[2]]) -### }) -### text(1,1,paste0('Char ', char.no, ' - TS', paste(which(at$index == char.no), collapse=', '), ': +', ret[[1]]), pos=4, cex=0.8) -### -### -### tipcols = c('#fafafa', '#fafafa', '#fafabb', '#ffbbbb', '#bbffbb', '#bbbbff', '#bbbbff', '#bbffbb', '#ffbbbb', '#bbddff', '#ffbbdd') -### names(tipcols) <- c(NA, max(downpass.states[1,]), max(downpass.states[1,])-inapp, 2^(0:7)) -### tipcols[as.character(inapp)] <- '#999999' -### tipcols <- rev(tipcols) -### bgcols <- tipcols[as.character(downpass.states[1,tips])] -### bgcols[is.na(bgcols)] <- '#ffffbb' -### tiplabels(PossibleTokens(at$levels, downpass.states[1,tips]), adj=c(0.3,0.5), bg=bgcols, col='#000088', cex=0.85) -### nodelabels(PossibleTokens(at$levels, downpass.states[1,nodes]), adj=rep(1.25,2), bg=tipcols[as.character(downpass.states[1,nodes])], font=ifelse(down.change, 2, 1) , col=ifelse(down.change, '#cc3333', '#880000cc'), cex=ifelse(down.change,1,0.6)) -### -### nodelabels(ifelse(inapp.nodes[nodes], '+', '-'), adj=c(1.25,-0.75), col=ifelse(inapp.nodes[nodes], '#008800', '#880000'), frame='none') -### } -### #' TITLE GOES HERE -### #' -### #' \code{FUNCTIONNAME} does something useful -### #' -### #' @param PARAM is a parameter you should send to it -### #' -### #' @examples -### #' to_do <- TRUE -### #' -### #' @return This function returns : -### #' -### #' @author Martin R. Smith -### #' @export -### PossibleTokens <- function (lvls, number) { -### nTokens <- length(lvls) -### nNumber <- length(number) -### output <- function (x) {paste0(x, collapse='')} -### if (nNumber == 1) { -### if (number == 2^nTokens - 1) return('?') -### which.levels <- rep(FALSE, nTokens) -### binary <- AsBinary(number) -### which.levels[seq_along(binary)] <- binary -### return (output(lvls[as.logical(which.levels)])) -### } -### which.levels <- matrix(FALSE, nNumber, nTokens) -### binary <- AsBinary(number) -### which.levels[,seq_along(binary[1,])] <- as.logical(binary) -### apply(which.levels, 1, function(x) {if (all(x)) return ('?') else y <- x; y[lvls=='-']<-TRUE; if (nTokens > 4 && all(y)) return ('+') else return (output(lvls[x]))}) -### } \ No newline at end of file diff --git a/R/pp_info_extra_step.r b/R/pp_info_extra_step.r deleted file mode 100644 index 7af94859d..000000000 --- a/R/pp_info_extra_step.r +++ /dev/null @@ -1,297 +0,0 @@ -#' Information content of a character known to contain _e_ steps -#' -#' `StepInformation()` calculates the phylogenetic information content of a -#' character `char` when _e_ extra steps are present, for all possible -#' values of _e_. -#' -#' Calculates the number of trees consistent with the character having -#' _e_ extra steps, where _e_ ranges from its minimum possible value -#' (i.e. number of different tokens minus one) to its maximum. -#' -#' @param char Vector of tokens listing states for the character in question. -#' @param ambiguousTokens Vector specifying which tokens, if any, correspond to -#' the ambiguous token (`?`). -#' -#' @return `StepInformation()` returns a numeric vector detailing the amount -#' of phylogenetic information (in bits) associated with the character when -#' 0, 1, 2… extra steps are present. The vector is named with the -#' total number of steps associated with each entry in the vector: for example, -#' a character with three observed tokens must exhibit two steps, so the first -#' entry (zero extra steps) is named `2` (two steps observed). -#' -#' @examples -#' character <- rep(c(0:3, '?', '-'), c(8, 5, 1, 1, 2, 2)) -#' StepInformation(character) -#' @template MRS -#' @importFrom fastmatch %fin% -#' @importFrom stats setNames -#' @importFrom TreeTools Log2Unrooted -#' @family profile parsimony functions -#' @export -StepInformation <- function (char, ambiguousTokens = c('-', '?')) { - NIL <- c('0' = 0) - char <- char[!char %fin% ambiguousTokens] - if (length(char) == 0) { - return(NIL) - } - split <- sort(as.integer(table(char)), decreasing = TRUE) - singletons <- split == 1L - nSingletons <- sum(singletons) - nInformative <- sum(split) - nSingletons - minSteps <- length(split) - 1L - if (minSteps == 0L) { - return(NIL) - } - - split <- split[!singletons] - if (length(split) < 2L) { - return(setNames(0, minSteps)) - } - - if (length(split) > 2L) { - warning("Ignored least informative tokens where more than two informative ", - "tokens present.") - ranked <- order(order(split, decreasing = TRUE)) - split <- split[ranked < 3] - } - - logProfile <- vapply(seq_len(split[2]), LogCarter1, double(1), - split[1], split[2]) - ret <- setNames(Log2Unrooted(sum(split[1:2])) - - (.LogCumSumExp(logProfile) / log(2)), - seq_len(split[2]) + sum(singletons)) - ret[ret < sqrt(.Machine$double.eps)] <- 0 # Floating point error inevitable - - # Return: - ret -} - -# Adapted from https://rpubs.com/FJRubio/LSE -.LogCumSumExp <- function (x) { - n <- length(x) - Lk <- c(x[1], double(n - 1L)) - for (k in 1L + seq_len(n - 1L)) { - Lk[k] <- Lk[k - 1] - Lk[k] <- max(x[k], Lk[k]) + log1p(exp(-abs(x[k] - Lk[k]))) - } - - # Return: - Lk -} - -#' Number of trees with _m_ additional steps -#' -#' Calculate the number of trees with _m_ extra steps under Fitch parsimony -#' where _a_ leaves are labelled with one state, and _b_ leaves labelled with -#' a second state. -#' -#' Implementation of theorem 1 from \insertCite{Carter1990;textual}{TreeTools} -#' -#' @param m Number of steps -#' @param a,b Number of leaves labelled `0` and `1`. -#' -#' @references -#' \insertAllCited{} -#' -#' See also: -#' -#' \insertRef{Steel1993}{TreeSearch} -#' -#' \insertRef{Steel1995}{TreeSearch} -#' -#' (\insertRef{Steel1996}{TreeSearch}) -#' @importFrom TreeTools LogDoubleFactorial -#' @family profile parsimony functions -#' @export -Carter1 <- function (m, a, b) { - n <- a + b - twoN <- n + n - twoM <- m + m - N <- function (n, m) { - if (n < m) 0 else { - nMinusM <- n - m - factorial(n + nMinusM - 1L) / prod( - factorial(nMinusM), - factorial(m - 1L), - 2 ^ (nMinusM)) - } - } - prod( - (twoN - twoM - m), - N(a, m), - N(b, m), - exp(lfactorial(m - 1L) + - LogDoubleFactorial(twoN - 5L) - - LogDoubleFactorial(twoN - twoM - 1L)) - ) -} - -#' @rdname Carter1 -#' @export -#' @importFrom TreeTools Log2DoubleFactorial -Log2Carter1 <- function (m, a, b) { - n <- a + b - twoN <- n + n - twoM <- m + m - Log2N <- function (n, m) { - if (n < m) -Inf else { - nMinusM <- n - m - (lfactorial(n + nMinusM - 1L) - - lfactorial(nMinusM) - - lfactorial(m - 1L)) / log(2) - nMinusM - } - } - sum( - log2(twoN - twoM - m), - (lfactorial(m - 1L) / log(2)), - Log2DoubleFactorial(twoN - 5L), - Log2N(a, m), - Log2N(b, m) - ) - Log2DoubleFactorial(twoN - twoM - 1L) -} - -#' @rdname Carter1 -#' @export -#' @importFrom TreeTools LogDoubleFactorial -LogCarter1 <- function (m, a, b) { - n <- a + b - twoN <- n + n - twoM <- m + m - LogN <- function (n, m) { - if (n < m) -Inf else { - nMinusM <- n - m - (lfactorial(n + nMinusM - 1L) - - lfactorial(nMinusM) - - lfactorial(m - 1L)) - (nMinusM * log(2)) - } - } - sum( - log(twoN - twoM - m), - lfactorial(m - 1L), - LogDoubleFactorial(twoN - 5L), - LogN(a, m), - LogN(b, m) - ) - LogDoubleFactorial(twoN - twoM - 1L) -} - -# TODO: Replace the below with an advanced version of Maddison & Slakey 1991, -# or use the results of Carter et al. 1990; Steel 1993 to estimate +0 & +1 steps, -# and approximate the rest. - -## @importFrom TreeTools Log2UnrootedMult -# Old_IC_Approx <- function() { -# -# nIter <- min(maxIter, round(iter)) -# if (nIter == maxIter) { -# warning ("Will truncate number of iterations at maxIter = ", maxIter) -# } -# n01ExtraSteps <- nOneExtraStep + nNoExtraSteps -# analyticIC <- Log2Unrooted(sum(split)) - setNames(c( -# Log2UnrootedMult(split), log2(n01ExtraSteps)), -# minSteps + 0:1) -# analyticP <- 2 ^ -analyticIC[2] -# -# if (warn) { -# message(' Token count ', split, " = ", -# signif(analyticIc0, ceiling(log10(maxIter))), -# ' bits @ 0 extra steps. \n Simulating ', nIter, -# ' trees to estimate cost of further steps.') -# # message(c(round(analyticIc0, 3), 'bits @ 0 extra steps;', round(analyticIc1, 3), -# # '@ 1; attempting', nIter, 'iterations.\n')) -# } -# -# morphyObj <- SingleCharMorphy(rep(seq_along(split) - 1L, split)) -# on.exit(morphyObj <- UnloadMorphy(morphyObj)) -# steps <- vapply(rep(nInformative, nIter), RandomTreeScore, -# integer(1), morphyObj) + nSingletons -# -# tabSteps <- table(steps[steps > (minSteps - nSingletons + 1)]) # Quicker than table(steps)[-1] -# -# approxP <- tabSteps / sum(tabSteps) * (1 - analyticP) -# approxSE <- sqrt(approxP * (1 - approxP) / nIter) -# cumP <- cumsum(c(analyticP, approxP))[-1] -# -# approxIC <- -log2(cumP) -# icLB <- -log2(cumP - approxSE) -# icError <- icLB - approxIC -# if (warn || max(icError) > tolerance) { -# message(" Approx. std. error < ", signif(max(icError) * 1.01, 2)) -# } -# } - - -#' Number of trees with one extra step -#' @param \dots Vector or series of integers specifying the number of leaves -#' bearing each distinct non-ambiguous token. -#' @importFrom TreeTools NRooted NUnrooted -#' @examples -#' WithOneExtraStep(1, 2, 3) -#' @importFrom TreeTools NUnrootedMult DoubleFactorial -#' @export -WithOneExtraStep <- function (...) { - splits <- c(...) - # Ignore singletons, which can be added at the end... - singletonSplits <- splits == 1 - splits <- sort(splits[!singletonSplits], decreasing = TRUE) - nSplits <- length(splits) - if (nSplits < 2) return (0) - if (nSplits == 2) { - prod( - # Zone 0; Zone 1 will be added at Root - NRooted(splits[1]), - sum( - vapply(seq_len(splits[2] - 1L), function (beforeStep) { - NRooted(beforeStep) * # Zone 1 will sit at root of Zone 0 - sum( - # Case 1: Zone 1 & 2 not adjacent - (splits[1] + splits[1] - 4L) * # Edges not touching Zone 1 - DoubleFactorial(splits[2] + splits[2] - 4L) / - DoubleFactorial(beforeStep + beforeStep - 2L), - # Case 2: Zone 1 & Zone 2 adjacent - 2 * # Two edges adjacent to Zone 1 - DoubleFactorial(splits[2] + splits[2] - 1L) / - DoubleFactorial(beforeStep + beforeStep + 1L) - ) - }, double(1)) - - ), - # Add singleton splits - (2 * (sum(splits) + seq_len(sum(singletonSplits))) - 5) - ) - - } else { - - stop("Not implemented.") - # nocov start - # TODO test splits <- 2 2 4 - sum(vapply(seq_along(splits), function (omit) { - backboneSplits <- splits[-omit] - omitted.tips <- splits[omit] - backbone.tips <- sum(backboneSplits) - backbones <- NUnrootedMult(backboneSplits) - backbone.edges <- max(0L, 2L * backbone.tips - 3L) - attachTwoRegions <- backbone.edges * (backbone.edges - 1L) - - - prod( # omitted tips form two separate regions - backbones, - attachTwoRegions, - sum( - # TODO would be quicker to calculate just first half; special case: - # omitted.tips %% 2 - vapply(seq_len(omitted.tips - 1), function (first.group) { - # For each way of splitsting up the omitted tips, e.g. 1|16, 2|15, 3|14, etc - choose(omitted.tips, first.group) * - NRooted(first.group) * NRooted(omitted.tips - first.group) - }, double(1)) - ) / 2) + - prod( - # paraphyletic. Worry: This is equivalent to splitting gp. 0 - # Double count: (0, 0, (0, (1, (0, 1)) - ) - - }, double(1)) - ) - # nocov end - } -} diff --git a/R/tree_length.R b/R/tree_length.R deleted file mode 100644 index b01d89207..000000000 --- a/R/tree_length.R +++ /dev/null @@ -1,358 +0,0 @@ -#' Calculate the parsimony score of a tree given a dataset -#' -#' `TreeLength()` uses the Morphy library \insertCite{Brazeau2017}{TreeSearch} -#' to calculate a parsimony score for a tree, handling inapplicable data -#' according to the algorithm of \insertCite{Brazeau2019;textual}{TreeSearch}. -#' Tree scoring can employ implied weights \insertCite{Goloboff1993}{TreeSearch} -#' or profile parsimony \insertCite{Faith2001}{TreeSearch}. -#' -#' @param tree A tree of class `phylo`, a list thereof (optionally of class -#' `multiPhylo`), or an integer -- in which case `tree` random trees will be -#' uniformly sampled. -#' @template datasetParam -#' @template concavityParam -#' -#' @return `TreeLength()` returns a numeric vector containing the score for -#' each tree. -#' -#' @examples -#' data("inapplicable.datasets") -#' tree <- TreeTools::BalancedTree(inapplicable.phyData[[1]]) -#' TreeLength(tree, inapplicable.phyData[[1]]) -#' TreeLength(tree, inapplicable.phyData[[1]], concavity = 10) -#' TreeLength(tree, inapplicable.phyData[[1]], concavity = 'profile') -#' TreeLength(5, inapplicable.phyData[[1]]) -#' @seealso -#' - Conduct tree search using [`MaximizeParsimony()`] (command line), -#' [`EasyTrees()`] (graphical user interface), or [`TreeSearch()`] -#' (custom optimality criteria). -#' -#' - See score for each character: [`CharacterLength()`]. -#' @family tree scoring -#' -#' @references -#' \insertAllCited{} -#' @author Martin R. Smith (using Morphy C library, by Martin Brazeau) -#' @importFrom fastmatch %fin% -#' @importFrom phangorn phyDat -#' @importFrom TreeTools Renumber RenumberTips TreeIsRooted -#' @export -TreeLength <- function (tree, dataset, concavity = Inf) UseMethod('TreeLength') - -#' @rdname TreeLength -#' @export -TreeLength.phylo <- function (tree, dataset, concavity = Inf) { - if (length(tree$tip.label) < length(dataset)) { - dataset <- .Recompress(dataset[tree$tip.label]) - } - if (is.finite(concavity)) { - if (!('min.length' %fin% names(attributes(dataset)))) { - dataset <- PrepareDataIW(dataset) - } - at <- attributes(dataset) - nChar <- at$nr # strictly, transformation series patterns; these'll be upweighted later - weight <- at$weight - steps <- CharacterLength(tree, dataset, compress = TRUE) - minLength <- at$min.length - homoplasies <- steps - minLength - - # This check was once triggered - possibly fixed but remains - # under investigation... - if (any(homoplasies < 0)) { #nocov start - stop("Minimum steps have been miscalculated.\n", - " Please report this bug at:\n", - " https://github.com/ms609/TreeSearch/issues/new\n\n", - " See above for full tree: ", dput(tree)) - } #nocov end - fit <- homoplasies / (homoplasies + concavity) - # Return: - sum(fit * weight) - - } else if (.UseProfile(concavity)) { - dataset <- PrepareDataProfile(dataset) - steps <- CharacterLength(tree, dataset, compress = TRUE) - info <- attr(dataset, 'info.amounts') - - # Return: - sum(vapply(which(steps > 0), function (i) info[steps[i], i], - double(1)) * attr(dataset, 'weight')[steps > 0]) - } else { - tree <- RenumberTips(Renumber(tree), names(dataset)) - if (!TreeIsRooted(tree)) stop("`tree` must be rooted; try RootTree(tree)") - morphyObj <- PhyDat2Morphy(dataset) - on.exit(morphyObj <- UnloadMorphy(morphyObj)) - MorphyTreeLength(tree, morphyObj) - } -} - - -#' @rdname TreeLength -#' @importFrom TreeTools RandomTree -#' @export -#TODO could be cleverer still and allow TreeLength.edge -TreeLength.numeric <- function (tree, dataset, concavity = Inf) { - TreeLength(lapply(!logical(tree), RandomTree, tips = dataset), - dataset = dataset, concavity = concavity) -} - -#' @rdname TreeLength -#' @export -TreeLength.list <- function (tree, dataset, concavity = Inf) { - # Define constants - iw <- is.finite(concavity) - profile <- .UseProfile(concavity) - - nTip <- NTip(tree) - if (length(unique(nTip)) > 1L) { - stop("All trees must bear the same leaves.") - } - nTip <- nTip[1] - if (nTip < length(dataset)) { - dataset <- .Recompress(dataset[TipLabels(tree[[1]])]) - } - - tree[] <- RenumberTips(tree, dataset) - edges <- vapply(tree, `[[`, tree[[1]]$edge, 'edge') - - # Initialize data - if (profile) { - dataset <- PrepareDataProfile(dataset) - profiles <- attr(dataset, 'info.amounts') - } - if (iw || profile) { - at <- attributes(dataset) - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, - byTaxon = FALSE, concatenate = FALSE) - weight <- at$weight - informative <- at$informative - charSeq <- seq_along(characters) - 1L - - # Save time by dropping uninformative characters - if (!is.null(informative)) charSeq <- charSeq[informative] - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1)), - add = TRUE) - } else { - morphyObj <- PhyDat2Morphy(dataset) - on.exit(morphyObj <- UnloadMorphy(morphyObj), add = TRUE) - weight <- unlist(MorphyWeights(morphyObj)[1, ]) # exact == approx - } - - # Return: - if (iw) { - minLength <- at$min.length - if (is.null(minLength)) { - minLength <- attr(PrepareDataIW(dataset), 'min.length') - } - apply(edges, 3, morphy_iw, morphyObjects, weight, minLength, charSeq, - concavity, Inf) - } else if (profile) { - apply(edges, 3, morphy_profile, morphyObjects, weight, charSeq, profiles, - Inf) - } else { - apply(edges, 3, preorder_morphy, morphyObj) - } -} - - -#' @rdname TreeLength -#' @export -TreeLength.multiPhylo <- TreeLength.list - -#' @export -TreeLength.NULL <- function (tree, dataset, concavity = Inf) NULL - -#' @rdname TreeLength -#' @export -Fitch <- function (tree, dataset) { - .Deprecated('TreeLength') - TreeLength(tree, dataset, Inf) -} - - - -#' Character length -#' -#' Homoplasy length of each character in a dataset on a specified tree. -#' -#' @template treeParam -#' @template datasetParam -#' @template compressParam -#' -#' @return `CharacterLength()` returns a vector listing the contribution of each -#' character to tree score, according to the algorithm of -#' \insertCite{Brazeau2018;textual}{TreeTools}. -#' -#' @examples -#' data('inapplicable.datasets') -#' dataset <- inapplicable.phyData[[12]] -#' tree <- TreeTools::NJTree(dataset) -#' CharacterLength(tree, dataset) -#' CharacterLength(tree, dataset, compress = TRUE) -#' @template MRS -#' @family tree scoring -#' @references -#' \insertAllCited{} -#' @importFrom cli cli_alert -#' @importFrom TreeTools KeepTip Renumber RenumberTips -#' @export -CharacterLength <- function (tree, dataset, compress = FALSE) { - if (!inherits(dataset, 'phyDat')) { - stop("Dataset must be of class phyDat, not ", class(dataset), '.') - } - if (!inherits(tree, 'phylo')) { - stop("Tree must be of class phylo, not ", class(tree), '.') - } - if (is.null(tree$tip.label)) { - stop("Tree has no labels") - } - - if (length(tree$tip.label) < length(dataset)) { - if (all(tree$tip.label %in% names(dataset))) { - cli_alert(paste0( - paste0(setdiff(names(dataset), tree$tip.label), collapse = ', '), - " not in tree")) - dataset <- dataset[intersect(names(dataset), tree$tip.label)] - } else { - stop("Tree tips ", - paste(setdiff(tree$tip.label, names(dataset)), collapse = ', '), - " not found in dataset.") - } - } - if (length(tree$tip.label) > length(dataset)) { - cli_alert(paste0( - paste0(setdiff(tree$tip.label, names(dataset)), collapse = ', '), - " not in `dataset`")) - - tree <- KeepTip(tree, names(dataset)) - } - tree <- RenumberTips(Renumber(tree), names(dataset)) - - ret <- FastCharacterLength(tree, dataset) - # Return: - if (compress) { - ret - } else { - ret[attr(dataset, 'index')] - } - -} - -#' @rdname CharacterLength -#' @export -FitchSteps <- function (tree, dataset) { - .Deprecated("CharacterLength") - CharacterLength(tree, dataset, compress = TRUE) -} - -#' @describeIn CharacterLength Do not perform checks. Use with care: may cause -#' erroneous results or software crash if variables are in the incorrect format. -FastCharacterLength <- function (tree, dataset) { - characters <- PhyToString(dataset, ps = '', useIndex = FALSE, byTaxon = FALSE, - concatenate = FALSE) - morphyObjects <- lapply(characters, SingleCharMorphy) - on.exit(morphyObjects <- vapply(morphyObjects, UnloadMorphy, integer(1))) - - # Return: - vapply(morphyObjects, MorphyTreeLength, tree = tree, integer(1)) -} - -#' Calculate parsimony score from Morphy object -#' -#' This function must be passed a valid Morphy object, or R may crash. -#' For most users, the function [`TreeLength()`] will be more appropriate. -#' -#' @template labelledTreeParam -#' @template morphyObjParam -#' -#' @return `MorphyTreeLength()` returns the length of the tree, -#' after applying weighting. -#' -#' @seealso PhyDat2Morphy -#' -#' @family tree scoring -#' @author Martin R. Smith -#' @keywords internal -#' @export -MorphyTreeLength <- function (tree, morphyObj) { - if (!is.morphyPtr(morphyObj)) { - stop("`morphyObj` must be a valid morphy pointer") - } - nTaxa <- mpl_get_numtaxa(morphyObj) - if (nTaxa != length(tree$tip.label)) { - stop ("Number of taxa in morphy object (", nTaxa, - ") not equal to number of tips in tree") - } - treeOrder <- attr(tree, 'order') - inPostorder <- (!is.null(treeOrder) && treeOrder == "postorder") - treeEdge <- tree$edge - - # Return: - MorphyLength(treeEdge[, 1], treeEdge[, 2], morphyObj, inPostorder, nTaxa) -} - -#' @describeIn MorphyTreeLength Faster function that requires internal tree -#' parameters. Node numbering must increase monotonically away from root. -#' @template treeParent -#' @template treeChild -#' @author Martin R. Smith -#' @keywords internal -#' @importFrom TreeTools Postorder Preorder -#' @importFrom fastmatch fmatch -#' @export -MorphyLength <- function (parent, child, morphyObj, inPostorder = FALSE, - nTaxa = mpl_get_numtaxa(morphyObj)) { - if (!inPostorder) { - edgeList <- Postorder(Preorder(cbind(parent, child))) - parent <- edgeList[, 1] - child <- edgeList[, 2] - } - if (!inherits(morphyObj, 'morphyPtr')) { - stop("morphyObj must be a morphy pointer. See ?LoadMorphy().") - } - if (nTaxa < 1L) { - # Run this test after we're sure that morphyObj is a morphyPtr, or lazy - # evaluation of nTaxa will cause a crash. - stop("Error: ", mpl_translate_error(nTaxa)) - } - - maxNode <- nTaxa + mpl_get_num_internal_nodes(morphyObj) - rootNode <- nTaxa + 1L - allNodes <- rootNode:maxNode - - parentOf <- parent[fmatch(seq_len(maxNode), child)] - parentOf[rootNode] <- rootNode # Root node's parent is a dummy node - leftChild <- child[length(parent) + 1L - fmatch(allNodes, rev(parent))] - rightChild <- child[fmatch(allNodes, parent)] - - # Return: - .Call('MORPHYLENGTH', as.integer(parentOf - 1L), as.integer(leftChild - 1L), - as.integer(rightChild - 1L), morphyObj) -} - -#' @describeIn MorphyTreeLength Fastest function that requires internal tree parameters -#' @template parentOfParam -#' @template leftChildParam -#' @template rightChildParam -#' @family tree scoring -#' @author Martin R. Smith -#' @keywords internal -#' @export -GetMorphyLength <- function (parentOf, leftChild, rightChild, morphyObj) { - # Return: - .Call('MORPHYLENGTH', as.integer(parentOf), as.integer(leftChild), - as.integer(rightChild), morphyObj) -} - -#' @describeIn MorphyTreeLength Direct call to C function. Use with caution. -#' @param parentOf For each node, numbered in postorder, the number of its parent node. -#' @param leftChild For each internal node, numbered in postorder, the number of its left -#' child node or tip. -#' @param rightChild For each internal node, numbered in postorder, the number of its right -#' child node or tip. -#' @keywords internal -#' @export -C_MorphyLength <- function (parentOf, leftChild, rightChild, morphyObj) { - .Call('MORPHYLENGTH', as.integer(parentOf - 1L), as.integer(leftChild - 1L), - as.integer(rightChild - 1L), morphyObj) -} diff --git a/R/tree_rearrangement.R b/R/tree_rearrangement.R deleted file mode 100644 index bcfe750b0..000000000 --- a/R/tree_rearrangement.R +++ /dev/null @@ -1,114 +0,0 @@ -#' Rearrange edges of a phylogenetic tree -#' -#' `RearrangeEdges()` performs the specified edge rearrangement on a matrix -#' that corresponds to the edges of a phylogenetic tree, returning the score of -#' the new tree. -#' Will generally be called from within a tree search function. -#' -#' @details `RearrangeTree()` performs one tree rearrangement of a -#' specified type, and returns the score of the tree (with the given dataset). -#' It also reports the number of times that this score was hit in the -#' current function call. -#' -#' @template treeParent -#' @template treeChild -#' @param dataset Third argument to pass to \code{TreeScorer}. -#' @template treeScorerParam -#' @param scoreToBeat Double giving score of input tree. -#' @param hits Integer giving number of times the input tree has already been hit. -#' @template EdgeSwapperParam -## @param minScore trees longer than \code{minScore}, probably the score of the best previously known tree, -## will be discarded; -## @param returnSingle returns all trees if `FALSE` or a randomly selected tree if `TRUE`. -#' @param iter iteration number of calling function, for reporting to user only. -#' @template verbosityParam -#' @template treeScorerDots -#' -#' @author Martin R. Smith -#' -#' @template returnEdgeList -#' -#' @examples -#' data('Lobo', package='TreeTools') -#' tree <- TreeTools::NJTree(Lobo.phy) -#' edge <- tree$edge -#' parent <- edge[, 1] -#' child <- edge[, 2] -#' dataset <- PhyDat2Morphy(Lobo.phy) -#' RearrangeEdges(parent, child, dataset, EdgeSwapper = RootedNNISwap) -#' # Remember to free memory: -#' dataset <- UnloadMorphy(dataset) -#' @export -RearrangeEdges <- function (parent, child, dataset, TreeScorer = MorphyLength, - EdgeSwapper, - scoreToBeat = TreeScorer(parent, child, dataset, ...), - iter = '?', hits = 0L, verbosity = 0L, ...) { - eps <- .Machine$double.eps ^ 0.5 - rearrangedEdges <- EdgeSwapper(parent, child) - if (is.list(rearrangedEdges[[1]])) { - # Then we've been sent a list of possible trees - candidateScores <- vapply(rearrangedEdges, function (edges) { - TreeScorer(edges[[1]], edges[[2]], dataset, ...) - } , double(1)) - candidateScore <- min(candidateScores) - best <- candidateScores == candidateScore - nBest <- sum(best) - if (candidateScore > (scoreToBeat + eps)) { - if (verbosity > 3L) { # nocov start - message(" . Iteration ", iter, - ' - Rearranged tree score ', candidateScore, - " > target ", scoreToBeat) - } # nocov end - } else if (candidateScore + eps > scoreToBeat) { # i.e. scores are equal - hits <- hits + nBest - if (verbosity > 2L) { # nocov start - message(" - Iteration ", iter, " - Best score ", scoreToBeat, - " found again ", nBest, " times; now found ", hits, " times.") - } # nocov end - } else { - hits <- nBest - if (verbosity > 1L) { # nocov start - message(" * Iteration ", iter, " - New best score ", candidateScore, - " found on ", hits, " trees.") - } # nocov end - } - rearrangedEdges <- rearrangedEdges[[SampleOne(which(best), nBest)]] - } else { - candidateScore <- TreeScorer(rearrangedEdges[[1]], rearrangedEdges[[2]], dataset, ...) - if (candidateScore > (scoreToBeat + eps)) { - if (verbosity > 3L) { # nocov start - message(" . Iteration ", iter, ' - Rearranged tree score ', - signif(candidateScore, 6), " > target ", signif(scoreToBeat, 6)) - } # nocov end - } else if (candidateScore + eps > scoreToBeat) { # i.e. scores are equal - hits <- hits + 1L - if (verbosity > 2L) { # nocov start - message(" - Iteration ", iter, " - Best score ", - signif(scoreToBeat, 6), " hit ", hits, " times.") - } # nocov end - } else { - hits <- 1L - if (verbosity > 1L) { # nocov start - message(" * Iteration ", iter, " - New best score ", - signif(candidateScore, 6), " found on ", hits, " trees.") - } # nocov end - } - } - rearrangedEdges[3:4] <- c(candidateScore, hits) - # Return: - rearrangedEdges -} - -#' Check that all nodes in a tree are bifurcating. -#' -#' @template treeParent -#' -#' @return Returns `NULL`, but will `stop` with an error message if a tree -#' does not appear to be bifurcating. -#' -#' @author Martin R. Smith -#' @keywords internal -#' @export -StopUnlessBifurcating <- function (parent) { - if (!all(table(parent) == 2L)) stop ("Tree must be bifurcating; try collapse.singles or multi2di.") -} diff --git a/R/zzz.R b/R/zzz.R index 13a501c0f..a42e8c9e8 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,31 +1,5 @@ # Suppress "NOTE: Nothing imported from Rdpack": -#' @importFrom Rdpack reprompt +#' @useDynLib TreeSearch, .registration = TRUE .onUnload <- function (libpath) { library.dynam.unload("TreeSearch", libpath) } - -## Reminders when releasing for CRAN -release_questions <- function() { - c( - "Is the code free of #TODOs?", - "Have you cleared GitHub issues for this release milestone?", - "Have you checked the Vignettes for sanity?" - ) -} - - -# Additional checks: -# -# codemetar::write_codemeta() -# -# spell_check() -# pkgdown::build_reference_index() -# -# run_examples() -# build_vignettes() -# -# devtools::check_win_devel(); rhub::check_for_cran() -# -# -# tools::resaveRdaFiles('R', compress='auto') - is default bzip2 the optimal? -# tools::checkRdaFiles('R') - set optimal compression in `data-raw` diff --git a/man/AdditionTree.Rd b/man/AdditionTree.Rd deleted file mode 100644 index 7c670f9e1..000000000 --- a/man/AdditionTree.Rd +++ /dev/null @@ -1,46 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AdditionTree.R -\name{AdditionTree} -\alias{AdditionTree} -\title{Addition tree} -\usage{ -AdditionTree(dataset, concavity = Inf, constraint, sequence) -} -\arguments{ -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{concavity}{Numeric specifying concavity constant for implied step -weighting; set as \code{Inf} for equal step weights (which is a bad idea; see -\insertCite{Smith2019;textual}{TreeSearch}).} - -\item{constraint}{An object of class \code{phyDat}; returned trees will be -perfectly compatible with each character in \code{constraint}. -See \code{\link[=ImposeConstraint]{ImposeConstraint()}} and -\href{https://ms609.github.io/TreeSearch/articles/inapplicable.html}{vignette} -for further examples.} - -\item{sequence}{Character or numeric vector listing sequence in which to add -taxa. Randomized if not provided.} -} -\value{ -\code{AdditionTree()} returns a tree of class \code{phylo}, rooted on -\code{sequence[1]}. -} -\description{ -Generates a starting tree by adding each taxon in turn to the most -parsimonious location. -} -\examples{ -data('Lobo', package = 'TreeTools') -AdditionTree(Lobo.phy, concavity = 10) -} -\seealso{ -Other tree generation functions: -\code{\link{RandomMorphyTree}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{tree generation functions} diff --git a/man/AllSPR.Rd b/man/AllSPR.Rd deleted file mode 100644 index cbc891ca1..000000000 --- a/man/AllSPR.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SPR.R -\name{AllSPR} -\alias{AllSPR} -\title{All SPR trees} -\usage{ -AllSPR(parent, child, nEdge, notDuplicateRoot, edgeToBreak) -} -\arguments{ -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} - -\item{child}{Integer vector corresponding to the second column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 2]}.} - -\item{nEdge}{integer specifying the number of edges of a tree of class \code{\link{phylo}}, i.e. \code{dim(tree$edge)[1]}} - -\item{notDuplicateRoot}{logical vector of length \code{nEdge}, specifying for each -edge whether it is the second edge leading to the root (in which case -its breaking will be equivalent to breaking the other root edge... -except insofar as it moves the position of the root.)} - -\item{edgeToBreak}{(optional) integer specifying the index of an edge to bisect/prune, -generated randomly if not specified. -Alternatively, set to \code{-1} to return a complete list -of all trees one step from the input tree.} -} -\value{ -\code{AllSPR()} returns a list of edge matrices for all trees one SPR -rearrangement from the starting tree -} -\description{ -All SPR trees -} -\author{ -Martin R. Smith -} diff --git a/man/Carter1.Rd b/man/Carter1.Rd deleted file mode 100644 index 811f28b0d..000000000 --- a/man/Carter1.Rd +++ /dev/null @@ -1,45 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pp_info_extra_step.r -\name{Carter1} -\alias{Carter1} -\alias{Log2Carter1} -\alias{LogCarter1} -\title{Number of trees with \emph{m} additional steps} -\usage{ -Carter1(m, a, b) - -Log2Carter1(m, a, b) - -LogCarter1(m, a, b) -} -\arguments{ -\item{m}{Number of steps} - -\item{a, b}{Number of leaves labelled \code{0} and \code{1}.} -} -\description{ -Calculate the number of trees with \emph{m} extra steps under Fitch parsimony -where \emph{a} leaves are labelled with one state, and \emph{b} leaves labelled with -a second state. -} -\details{ -Implementation of theorem 1 from \insertCite{Carter1990;textual}{TreeTools} -} -\references{ -\insertAllCited{} - -See also: - -\insertRef{Steel1993}{TreeSearch} - -\insertRef{Steel1995}{TreeSearch} - -(\insertRef{Steel1996}{TreeSearch}) -} -\seealso{ -Other profile parsimony functions: -\code{\link{PrepareDataProfile}()}, -\code{\link{StepInformation}()}, -\code{\link{profiles}} -} -\concept{profile parsimony functions} diff --git a/man/CharacterLength.Rd b/man/CharacterLength.Rd deleted file mode 100644 index 2007dfb51..000000000 --- a/man/CharacterLength.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tree_length.R -\name{CharacterLength} -\alias{CharacterLength} -\alias{FitchSteps} -\alias{FastCharacterLength} -\title{Character length} -\usage{ -CharacterLength(tree, dataset, compress = FALSE) - -FitchSteps(tree, dataset) - -FastCharacterLength(tree, dataset) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{compress}{Logical specifying whether to retain the compression of a -\code{phyDat} object or to return a vector specifying to each individual -character, decompressed using the dataset's \code{index} attribute.} -} -\value{ -\code{CharacterLength()} returns a vector listing the contribution of each -character to tree score, according to the algorithm of -\insertCite{Brazeau2018;textual}{TreeTools}. -} -\description{ -Homoplasy length of each character in a dataset on a specified tree. -} -\section{Functions}{ -\itemize{ -\item \code{FastCharacterLength}: Do not perform checks. Use with care: may cause -erroneous results or software crash if variables are in the incorrect format. -}} - -\examples{ -data('inapplicable.datasets') -dataset <- inapplicable.phyData[[12]] -tree <- TreeTools::NJTree(dataset) -CharacterLength(tree, dataset) -CharacterLength(tree, dataset, compress = TRUE) -} -\references{ -\insertAllCited{} -} -\seealso{ -Other tree scoring: -\code{\link{IWScore}()}, -\code{\link{MinimumLength}()}, -\code{\link{MorphyTreeLength}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{tree scoring} diff --git a/man/ConcordantInformation.Rd b/man/ConcordantInformation.Rd deleted file mode 100644 index da0a59e3d..000000000 --- a/man/ConcordantInformation.Rd +++ /dev/null @@ -1,56 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Concordance.R -\name{ConcordantInformation} -\alias{ConcordantInformation} -\alias{Evaluate} -\alias{ConcordantInfo} -\title{Evaluate the concordance of information between a tree and a dataset} -\usage{ -ConcordantInformation(tree, dataset) - -Evaluate(tree, dataset) - -ConcordantInfo(tree, dataset) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} -} -\value{ -\code{ConcordantInformation()} returns a named vector with elements: -\itemize{ -\item \code{informationContent}: cladistic information content of \code{dataset} -\item \code{signal}, \code{noise}: amount of cladistic information that represents -phylogenetic signal and noise, according to \code{tree} -\item \code{signalToNoise}: the implied signal:noise ratio of \code{dataset} -\item \code{treeInformation}: the cladistic information content of a bifurcating tree -on \code{dataset}; this is the minimum amount of information necessary to resolve -a bifurcating tree, assuming no duplicate information or noise -\item \code{matrixToTree}: the ratio of the cladistic information content of the -matrix to the cladistic information content of the tree, a measure of the -redundancy of the matrix -\item \code{ignored}: information content of characters whose signal and noise could -not be calculated (too many states) and so are not included in the totals -above. -} -} -\description{ -Details the amount of information in a phylogenetic dataset that is -consistent with a specified phylogenetic tree, and the signal:noise -ratio of the character matrix implied if the tree is true. -} -\details{ -Presently restricted to datasets whose characters contain a maximum of -two parsimony-informative states. -} -\examples{ -data(congreveLamsdellMatrices) -myMatrix <- congreveLamsdellMatrices[[10]] -ConcordantInformation(TreeTools::NJTree(myMatrix), myMatrix) -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} diff --git a/man/Consistency.Rd b/man/Consistency.Rd deleted file mode 100644 index 4e90d34b4..000000000 --- a/man/Consistency.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ci-ri.R -\name{Consistency} -\alias{Consistency} -\title{Consistency / retention 'indices'} -\usage{ -Consistency(dataset, tree, compress = FALSE) -} -\arguments{ -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{compress}{Logical specifying whether to retain the compression of a -\code{phyDat} object or to return a vector specifying to each individual -character, decompressed using the dataset's \code{index} attribute.} -} -\value{ -\code{Consistency()} returns a named vector specifying the -consistency index (\code{ci}), -retention index (\code{ri}), and rescaled consistency index (\code{rc}). -} -\description{ -\code{Consistency()} calculates the so-called consistency and retention 'indices' -for each character in a dataset, given a bifurcating tree. -Although there is not a straightforward interpretation of these indices, -they are sometimes taken as an indicator of the fit of a character to a -tree. Values correlate with the number of species sampled and the -distribution of taxa between character states, so are not strictly comparable -between characters in which these factors differ. -} -\details{ -#TODO: Retention index not yet implemented. -} -\examples{ -data(inapplicable.datasets) -dataset <- inapplicable.phyData[[4]] -Consistency(dataset, TreeTools::NJTree(dataset)) -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} diff --git a/man/DoubleNNI.Rd b/man/DoubleNNI.Rd deleted file mode 100644 index 4bfbefe36..000000000 --- a/man/DoubleNNI.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/NNI.R -\name{DoubleNNI} -\alias{DoubleNNI} -\title{Double NNI} -\usage{ -DoubleNNI(parent, child, edgeToBreak) -} -\arguments{ -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} - -\item{child}{Integer vector corresponding to the second column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 2]}.} - -\item{edgeToBreak}{(optional) integer specifying the index of an edge to bisect/prune, -generated randomly if not specified. -Alternatively, set to \code{-1} to return a complete list -of all trees one step from the input tree.} -} -\value{ -the \code{tree$edge} parameter of the two trees consistent with the specified rearrangement -} -\description{ -Returns the edge parameter of the two trees consistent with the speficied \acronym{NNI} rearrangement -} -\author{ -Martin R. Smith -} -\keyword{internal} diff --git a/man/GapHandler.Rd b/man/GapHandler.Rd deleted file mode 100644 index ae45f81a3..000000000 --- a/man/GapHandler.Rd +++ /dev/null @@ -1,65 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{GapHandler} -\alias{GapHandler} -\title{Read how a Morphy Object handles the inapplicable token} -\usage{ -GapHandler(morphyObj) -} -\arguments{ -\item{morphyObj}{Object of class \code{morphy}, perhaps created with -\code{\link[=PhyDat2Morphy]{PhyDat2Morphy()}}.} -} -\value{ -\code{GapHandler()} returns a character string stating how -gaps are handled by \code{morphyObj}. -} -\description{ -Gaps represented by the inapplicable token can be treated as 'missing data', -i.e. as equivalent to the ambiguous token \verb{?}; as an extra state, equivalent -to other states such as \code{0} or \code{1}; or as 'inapplicable data' using the -algorithm of Brazeau, Guillerme and Smith (2019). -} -\examples{ -morphyObj <- SingleCharMorphy('-0-0', 'Extra') -GapHandler(morphyObj) -morphyObj <- UnloadMorphy(morphyObj) -} -\seealso{ -Other Morphy API functions: -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{Morphy API functions} diff --git a/man/JackLabels.Rd b/man/JackLabels.Rd deleted file mode 100644 index a06bc173e..000000000 --- a/man/JackLabels.Rd +++ /dev/null @@ -1,67 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Jackknife.R -\name{JackLabels} -\alias{JackLabels} -\title{Label nodes with jackknife support values} -\usage{ -JackLabels( - tree, - jackTrees, - plot = TRUE, - add = FALSE, - adj = 0, - col = NULL, - frame = "none", - pos = 2L, - ... -) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{jackTrees}{A list or \code{multiPhylo} object containing trees generated -by \code{\link[=Jackknife]{Jackknife()}}.} - -\item{plot}{Logical specifying whether to plot results; if \code{FALSE}, -returns blank labels for nodes near the root that do not correspond to a -unique split.} - -\item{add}{Logical specifying whether to add the labels to an existing -plot.} - -\item{adj, col, frame, pos, \dots}{Parameters to pass to \code{nodelabels()}.} -} -\value{ -A named vector specifying the proportion of jackknife trees -consistent with each node in \code{tree}, as plotted. -If \code{plot = FALSE}, blank entries are included corresponding to nodes -that do not require labelling; the return value is in the value required -by \code{phylo$node.label}. -} -\description{ -Label nodes with jackknife support values -} -\examples{ -library('TreeTools', quietly = TRUE) # for as.phylo - -# jackTrees will usually be generated with Jackknife(), but for simplicity: -jackTrees <- as.phylo(1:100, 8) - -tree <- as.phylo(0, 8) -JackLabels(tree, jackTrees) - -tree$node.label <- JackLabels(tree, jackTrees, plot = FALSE) -} -\seealso{ -\code{\link[=Jackknife]{Jackknife()}}: Generate trees by jackknife resampling - -Other split support functions: -\code{\link{Jackknife}()}, -\code{\link{MaximizeParsimony}()}, -\code{\link{SiteConcordance}} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{split support functions} diff --git a/man/Jackknife.Rd b/man/Jackknife.Rd deleted file mode 100644 index dc4c052f0..000000000 --- a/man/Jackknife.Rd +++ /dev/null @@ -1,94 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Jackknife.R -\name{Jackknife} -\alias{Jackknife} -\title{Jackknife resampling} -\usage{ -Jackknife( - tree, - dataset, - resampleFreq = 2/3, - InitializeData = PhyDat2Morphy, - CleanUpData = UnloadMorphy, - TreeScorer = MorphyLength, - EdgeSwapper = TBRSwap, - jackIter = 5000L, - searchIter = 4000L, - searchHits = 42L, - verbosity = 1L, - ... -) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{dataset}{a dataset in the format required by \code{TreeScorer()}.} - -\item{resampleFreq}{Double between 0 and 1 stating proportion of characters -to resample.} - -\item{InitializeData}{Function that sets up data object to prepare for tree search. -The function will be passed the \code{dataset} parameter. -Its return value will be passed to \code{TreeScorer()} and \code{CleanUpData()}.} - -\item{CleanUpData}{Function to destroy data object on function exit. -The function will be passed the value returned by \code{InitializeData()}.} - -\item{TreeScorer}{function to score a given tree. -The function will be passed three parameters, corresponding to the -\code{parent} and \code{child} entries of a tree's edge list, and a dataset.} - -\item{EdgeSwapper}{a function that rearranges a parent and child vector, -and returns a list with modified vectors; for example \code{\link[=SPRSwap]{SPRSwap()}}.} - -\item{jackIter}{Integer specifying number of jackknife iterations to conduct.} - -\item{searchIter}{Integer specifying maximum rearrangements to perform on each bootstrap or -ratchet iteration. -To override this value for a single swapper function, set e.g. -\code{attr(SwapperFunction, 'searchIter') <- 99}} - -\item{searchHits}{Integer specifying maximum times to hit best score before terminating a tree -search within a ratchet iteration. -To override this value for a single swapper function, set e.g. -\code{attr(SwapperFunction, 'searchHits') <- 99}} - -\item{verbosity}{Numeric specifying level of detail to display in console: -larger numbers provide more verbose feedback to the user.} - -\item{...}{further arguments to pass to \code{TreeScorer()}, e.g. \verb{dataset = }.} -} -\value{ -\code{Jackknife()} returns a list of trees recovered after jackknife -iterations. -} -\description{ -Resample trees using Jackknife resampling, i.e. removing a subset of -characters. -} -\details{ -The function assumes -that \code{InitializeData()} will return a morphy object; if this doesn't hold -for you, post a \href{https://github.com/ms609/TreeSearch/issues/new/}{GitHub issue} -or e-mail the maintainer. -} -\seealso{ -\itemize{ -\item \code{\link[=JackLabels]{JackLabels()}}: Label nodes of a tree with jackknife supports. -} - -Other split support functions: -\code{\link{JackLabels}()}, -\code{\link{MaximizeParsimony}()}, -\code{\link{SiteConcordance}} - -Other custom search functions: -\code{\link{EdgeListSearch}()}, -\code{\link{MorphyBootstrap}()}, -\code{\link{SuccessiveApproximations}()} -} -\author{ -Martin R. Smith -} -\concept{custom search functions} -\concept{split support functions} diff --git a/man/MaximizeParsimony.Rd b/man/MaximizeParsimony.Rd deleted file mode 100644 index 490bac88e..000000000 --- a/man/MaximizeParsimony.Rd +++ /dev/null @@ -1,256 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/MaximizeParsimony.R -\encoding{UTF-8} -\name{MaximizeParsimony} -\alias{MaximizeParsimony} -\alias{Resample} -\alias{EasyTrees} -\alias{EasyTreesy} -\title{Find most parsimonious trees} -\usage{ -MaximizeParsimony( - dataset, - tree, - ratchIter = 6L, - tbrIter = 2L, - startIter = 2L, - finalIter = 1L, - maxHits = NTip(dataset) * 1.8, - maxTime = 60, - quickHits = 1/3, - concavity = Inf, - tolerance = sqrt(.Machine$double.eps), - constraint, - verbosity = 3L -) - -Resample( - dataset, - tree, - method = "jack", - proportion = 2/3, - ratchIter = 1L, - tbrIter = 8L, - finalIter = 3L, - maxHits = 12L, - concavity = Inf, - tolerance = sqrt(.Machine$double.eps), - constraint, - verbosity = 2L, - ... -) - -EasyTrees() - -EasyTreesy() -} -\arguments{ -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{tree}{(optional) A bifurcating tree of class \code{\link{phylo}}, -containing only the tips listed in \code{dataset}, from which the search -should begin. -If unspecified, an \link[=AdditionTree]{addition tree} will be generated from -\code{dataset}, respecting any supplied \code{constraint}. -Edge lengths are not supported and will be deleted.} - -\item{ratchIter}{Numeric specifying number of iterations of the -parsimony ratchet \insertCite{Nixon1999}{TreeSearch} to conduct.} - -\item{tbrIter}{Numeric specifying the maximum number of \acronym{TBR} -break points to evaluate before concluding each search. -The counter is reset to zero each time tree score improves. -The counter is reset to zero each time tree score improves. -One 'iteration' comprises breaking a single branch and evaluating all -possible reconnections.} - -\item{startIter}{Numeric: an initial round of tree search with -\code{startIter} × \code{tbrIter} \acronym{TBR} break points is conducted in -order to locate a local optimum before beginning ratchet searches.} - -\item{finalIter}{Numeric: a final round of tree search will evaluate -\code{finalIter} × \code{tbrIter} \acronym{TBR} break points, in order to -sample the final optimal neighbourhood more intensely.} - -\item{maxHits}{Numeric specifying the maximum times that an optimal -parsimony score may be hit before concluding a ratchet iteration or final -search concluded.} - -\item{maxTime}{Numeric: after \code{maxTime} minutes, stop tree search at the -next opportunity.} - -\item{quickHits}{Numeric: iterations on subsampled datasets -will retain \code{quickHits} × \code{maxHits} trees with the best score.} - -\item{concavity}{Numeric specifying concavity constant for implied step -weighting; set as \code{Inf} for equal step weights (which is a bad idea; see -\insertCite{Smith2019;textual}{TreeSearch}).} - -\item{tolerance}{Numeric specifying degree of suboptimality to tolerate -before rejecting a tree. The default, \code{sqrt(.Machine$double.eps)}, retains -trees that may be equally parsimonious but for rounding errors. -Setting to larger values will include trees suboptimal by up to \code{tolerance} -in search results, which may improve the accuracy of the consensus tree -(at the expense of resolution) \insertCite{Smith2019}{TreeSearch}.} - -\item{constraint}{An object of class \code{phyDat}; returned trees will be -perfectly compatible with each character in \code{constraint}. -See \code{\link[=ImposeConstraint]{ImposeConstraint()}} and -\href{https://ms609.github.io/TreeSearch/articles/inapplicable.html}{vignette} -for further examples.} - -\item{verbosity}{Integer specifying level of messaging; higher values give -more detailed commentary on search progress. Set to \code{0} to run silently.} - -\item{method}{Unambiguous abbreviation of \code{jackknife} or \code{bootstrap} -specifying how to resample characters. Note that jackknife is considered -to give more meaningful results.} - -\item{proportion}{Numeric between 0 and 1 specifying what proportion of -characters to retain under jackknife resampling.} - -\item{\dots}{Additional parameters to \code{MaximizeParsimony()}.} -} -\value{ -\code{MaximizeParsimony()} returns a list of trees with class -\code{multiPhylo}. This lists all trees found during each search step that -are within \code{tolerance} of the optimal score, listed in the sequence that -they were first visited; it may contain more than \code{maxHits} elements. -Note that the default search parameters may need to be increased in order for -these trees to be the globally optimal trees; examine the messages printed -during tree search to evaluate whether the optimal score has stabilized. - -The return value has the attribute \code{newTrees}, a named integer vector listing -the number of optimal trees visited for the first time in each stage of -the tree search. - -\code{Resample()} returns a \code{multiPhylo} object containing a list of -trees obtained by tree search using a resampled version of \code{dataset}. -} -\description{ -Search for most parsimonious trees using the parsimony ratchet and -\acronym{TBR} rearrangements, treating inapplicable data as such using the -algorithm of \insertCite{Brazeau2019;textual}{TreeSearch}. - -Tree search will be conducted from a specified or automatically-generated -starting tree in order to find a tree with an optimal parsimony score, -under implied or equal weights, treating inapplicable characters as such -in order to avoid the artefacts of the standard Fitch algorithm -\insertCite{@see @Maddison1993; @Brazeau2019}{TreeSearch}. -The tree scoring implementation uses the MorphyLib C library -\insertCite{Brazeau2017}{TreeSearch}. -} -\details{ -Tree search commences with \code{ratchIter} iterations of the parsimony ratchet -\insertCite{Nixon1999}{TreeSearch}, which bootstraps the input dataset -in order to escape local optima. -A final round of tree bisection and reconnection (\acronym{TBR}) -is conducted to broaden the sampling of trees. - -This function can be called using the R command line / terminal, or through -the 'shiny' graphical user interface app (type \code{EasyTrees()} to launch). - -For detailed documentation of the 'TreeSearch' package, including full -instructions for loading phylogenetic data into R and initiating and -configuring tree search, see the -\href{https://ms609.github.io/TreeSearch/}{package documentation}. -} -\section{Resampling}{ - -Note that bootstrap support is a measure of the amount of data supporting -a split, rather than the amount of confidence that should be afforded the -grouping. -"Bootstrap support of 100\% is not enough, the tree must also be correct" -\insertCite{Phillips2004}{TreeSearch}. -See discussion in \insertCite{Egan2006;textual}{TreeSearch}; -\insertCite{Wagele2009;textual}{TreeSearch}; -\insertCite{Simmons2011}{TreeSearch}; -\insertCite{Kumar2012;textual}{TreeSearch}. - -For a discussion of suitable search parameters in resampling estimates, see -\insertCite{Muller2005;textual}{TreeSearch}. -The user should decide whether to start each resampling -from the optimal tree (which may be quicker, but result in overestimated -support values as searches get stuck in local optima close to the -optimal tree) or a random tree (which may take longer as more rearrangements -are necessary to find an optimal tree on each iteration). - -For other ways to estimate clade concordance, see \code{\link[=SiteConcordance]{SiteConcordance()}}. -} - -\examples{ -## Only run examples in interactive R sessions -if (interactive()) { - # launch 'shiny' point-and-click interface - EasyTrees() - - # Here too, use the "continue search" function to ensure that tree score - # has stabilized and a global optimum has been found -} - - -# Load data for analysis in R -library('TreeTools') -data('congreveLamsdellMatrices', package = 'TreeSearch') -dataset <- congreveLamsdellMatrices[[42]] - -# A very quick run for demonstration purposes -trees <- MaximizeParsimony(dataset, ratchIter = 0, startIter = 0, - tbrIter = 1, maxHits = 4, maxTime = 1/100, - concavity = 10, verbosity = 4) - -# In actual use, be sure to check that the score has converged on a global -# optimum, conducting additional iterations and runs as necessary. - -if (interactive()) { -# Jackknife resampling -nReplicates <- 10 -jackTrees <- replicate(nReplicates, - #c() ensures that each replicate returns a list of trees - c(Resample(dataset, trees, ratchIter = 0, tbrIter = 2, startIter = 1, - maxHits = 5, maxTime = 1 / 10, - concavity = 10, verbosity = 0)) - ) - -# In a serious analysis, more replicates would be conducted, and each -# search would undergo more iterations. - -# Now we must decide what to do with the multiple optimal trees from -# each replicate. - -# Treat each tree equally -JackLabels(ape::consensus(trees), unlist(jackTrees, recursive = FALSE)) - -# Take the strict consensus of all trees for each replicate -JackLabels(ape::consensus(trees), lapply(jackTrees, ape::consensus)) - -# Take a single tree from each replicate (the first; order's irrelevant) -JackLabels(ape::consensus(trees), lapply(jackTrees, `[[`, 1)) -} - -# Tree search with a constraint -constraint <- MatrixToPhyDat(c(a = 1, b = 1, c = 0, d = 0, e = 0, f = 0)) -characters <- MatrixToPhyDat(matrix( - c(0, 1, 1, 1, 0, 0, - 1, 1, 1, 0, 0, 0), ncol = 2, - dimnames = list(letters[1:6], NULL))) -MaximizeParsimony(characters, constraint = constraint, verbosity = 0) - -} -\references{ -\insertAllCited{} -} -\seealso{ -Tree search \emph{via} graphical user interface: \code{\link[=EasyTrees]{EasyTrees()}} - -Other split support functions: -\code{\link{JackLabels}()}, -\code{\link{Jackknife}()}, -\code{\link{SiteConcordance}} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{split support functions} diff --git a/man/MinimumLength.Rd b/man/MinimumLength.Rd deleted file mode 100644 index 1911a33a9..000000000 --- a/man/MinimumLength.Rd +++ /dev/null @@ -1,82 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_manipulation.R -\name{MinimumLength} -\alias{MinimumLength} -\alias{MinimumLength.phyDat} -\alias{MinimumLength.numeric} -\alias{MinimumSteps} -\title{Minimum length} -\usage{ -MinimumLength(x, compress = FALSE) - -\method{MinimumLength}{phyDat}(x, compress = FALSE) - -\method{MinimumLength}{numeric}(x, compress = NA) - -MinimumSteps(x) -} -\arguments{ -\item{x}{An object of class \code{phyDat}, -or an integer vector listing the tokens that may be present at each -tip along a single character, with each token represented as a binary digit; -e.g. a value of 11 ( = 2^0 + 2^1 + 2^3) means that -the tip may have tokens 0, 1 or 3. - -Inapplicable tokens should be denoted with the integer \code{0} (not 2^0). - -Tokens that are ambiguous for an inapplicable and an applicable -state are not presently supported; for an approximate value, denote such -ambiguity with the integer \code{0}.} - -\item{compress}{Logical specifying whether to retain the compression of a -\code{phyDat} object or to return a vector specifying to each individual -character, decompressed using the dataset's \code{index} attribute.} -} -\value{ -\code{MinimumLength()} returns a vector of integers specifying the -minimum number of steps that each character must contain. -} -\description{ -The smallest length that a character can obtain on any tree. -} -\examples{ -data('inapplicable.datasets') -myPhyDat <- inapplicable.phyData[[4]] -MinimumLength(myPhyDat) -MinimumLength(myPhyDat, compress = TRUE) - - -class(myPhyDat) # phyDat object -# load your own data with -# my.PhyDat <- as.phyDat(read.nexus.data('filepath')) -# or Windows users can select a file interactively using: -# my.PhyDat <- as.phyDat(read.nexus.data(choose.files())) - -# Convert list of character codings to an array -myData <- vapply(myPhyDat, I, myPhyDat[[1]]) - -# Convert phyDat's representation of states to binary -myContrast <- attr(myPhyDat, 'contrast') -tokens <- colnames(myContrast) -binaryContrast <- integer(length(tokens)) -tokenApplicable <- tokens != '-' -binaryContrast[tokenApplicable] <- 2 ^ (seq_len(sum(tokenApplicable)) - 1) -binaryValues <- apply(myContrast, 1, - function (row) sum(binaryContrast[as.logical(row)])) -myStates <- matrix(binaryValues[myData], nrow = nrow(myData), - ncol = ncol(myData), dimnames = dimnames(myData)) - -# Finally, work out minimum steps -apply(myStates, 1, MinimumLength) -} -\seealso{ -Other tree scoring: -\code{\link{CharacterLength}()}, -\code{\link{IWScore}()}, -\code{\link{MorphyTreeLength}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{tree scoring} diff --git a/man/MorphyErrorCheck.Rd b/man/MorphyErrorCheck.Rd deleted file mode 100644 index db700da7b..000000000 --- a/man/MorphyErrorCheck.Rd +++ /dev/null @@ -1,49 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{MorphyErrorCheck} -\alias{MorphyErrorCheck} -\title{Check for error whilst modifying Morphy object} -\usage{ -MorphyErrorCheck(action) -} -\arguments{ -\item{action}{action to perform} -} -\description{ -Check for error whilst modifying Morphy object -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/MorphyTreeLength.Rd b/man/MorphyTreeLength.Rd deleted file mode 100644 index 4082bdac7..000000000 --- a/man/MorphyTreeLength.Rd +++ /dev/null @@ -1,85 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tree_length.R -\name{MorphyTreeLength} -\alias{MorphyTreeLength} -\alias{MorphyLength} -\alias{GetMorphyLength} -\alias{C_MorphyLength} -\title{Calculate parsimony score from Morphy object} -\usage{ -MorphyTreeLength(tree, morphyObj) - -MorphyLength( - parent, - child, - morphyObj, - inPostorder = FALSE, - nTaxa = mpl_get_numtaxa(morphyObj) -) - -GetMorphyLength(parentOf, leftChild, rightChild, morphyObj) - -C_MorphyLength(parentOf, leftChild, rightChild, morphyObj) -} -\arguments{ -\item{tree}{A tree of class \code{\link[ape:read.tree]{phylo}}, with tip labels in the order generated by -\code{\link{RenumberTips}}, i.e. corresponding to the sequence of taxa -in the corresponding Morphy object.} - -\item{morphyObj}{Object of class \code{morphy}, perhaps created with -\code{\link[=PhyDat2Morphy]{PhyDat2Morphy()}}.} - -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} - -\item{child}{Integer vector corresponding to the second column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 2]}.} - -\item{parentOf}{For each node, numbered in postorder, the number of its parent node.} - -\item{leftChild}{For each internal node, numbered in postorder, the number of its left -child node or tip.} - -\item{rightChild}{For each internal node, numbered in postorder, the number of its right -child node or tip.} -} -\value{ -\code{MorphyTreeLength()} returns the length of the tree, -after applying weighting. -} -\description{ -This function must be passed a valid Morphy object, or R may crash. -For most users, the function \code{\link[=TreeLength]{TreeLength()}} will be more appropriate. -} -\section{Functions}{ -\itemize{ -\item \code{MorphyLength}: Faster function that requires internal tree -parameters. Node numbering must increase monotonically away from root. - -\item \code{GetMorphyLength}: Fastest function that requires internal tree parameters - -\item \code{C_MorphyLength}: Direct call to C function. Use with caution. -}} - -\seealso{ -PhyDat2Morphy - -Other tree scoring: -\code{\link{CharacterLength}()}, -\code{\link{IWScore}()}, -\code{\link{MinimumLength}()} - -Other tree scoring: -\code{\link{CharacterLength}()}, -\code{\link{IWScore}()}, -\code{\link{MinimumLength}()} -} -\author{ -Martin R. Smith - -Martin R. Smith - -Martin R. Smith -} -\concept{tree scoring} -\keyword{internal} diff --git a/man/MorphyWeights.Rd b/man/MorphyWeights.Rd deleted file mode 100644 index 58a0b17b4..000000000 --- a/man/MorphyWeights.Rd +++ /dev/null @@ -1,85 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{MorphyWeights} -\alias{MorphyWeights} -\alias{SetMorphyWeights} -\title{Set and get the character weightings associated with a Morphy object.} -\usage{ -MorphyWeights(morphyObj) - -SetMorphyWeights(weight, morphyObj, checkInput = TRUE) -} -\arguments{ -\item{morphyObj}{Object of class \code{morphy}, perhaps created with -\code{\link[=PhyDat2Morphy]{PhyDat2Morphy()}}.} - -\item{weight}{A vector listing the new weights to be applied to each character} - -\item{checkInput}{Whether to sanity-check input data before applying. -Defaults to \code{TRUE} to protect the user from crashes.} -} -\value{ -\code{MorphyWeights()} returns a data frame with two named rows and -one column per character pattern: -row 1, \code{approx}, is a list of integers specifying the approximate (integral) -weights used by MorphyLib; -row 2, \code{exact}, is a list of numerics specifying the exact weights specified -by the user. - -\code{SetMorphyWeights()} returns the Morphy error code generated when -applying \code{weight}. -} -\description{ -\code{MorphyWeights()} details the approximate and exact weights associated with -characters in a \code{Morphy} object; \code{SetMorphyWeights()} edits them. -} -\examples{ -tokens <- matrix(c( - 0, 0, 0, 1, 1, 2, - 0, 0, 0, 0, 0, 0), byrow = TRUE, nrow = 2L, - dimnames = list(letters[1:2], NULL)) -pd <- TreeTools::MatrixToPhyDat(tokens) -morphyObj <- PhyDat2Morphy(pd) -MorphyWeights(morphyObj) -if (SetMorphyWeights(c(1, 1.5, 2/3), morphyObj) != 0L) message("Errored") -MorphyWeights(morphyObj) -morphyObj <- UnloadMorphy(morphyObj) -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{Morphy API functions} diff --git a/man/NNI.Rd b/man/NNI.Rd deleted file mode 100644 index 1c8a0ab6c..000000000 --- a/man/NNI.Rd +++ /dev/null @@ -1,117 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/NNI.R -\name{NNI} -\alias{NNI} -\alias{cNNI} -\alias{NNISwap} -\alias{RootedNNI} -\alias{RootedNNISwap} -\title{Nearest neighbour interchange (NNI)} -\usage{ -NNI(tree, edgeToBreak = NULL) - -cNNI(tree, edgeToBreak = NULL, whichSwitch = NULL) - -NNISwap(parent, child, nTips = (length(parent)/2L) + 1L, edgeToBreak = NULL) - -RootedNNI(tree, edgeToBreak = NULL) - -RootedNNISwap( - parent, - child, - nTips = (length(parent)/2L) + 1L, - edgeToBreak = NULL -) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{edgeToBreak}{In (\code{Rooted})\code{NNI()}, an optional integer specifying the -index of an edge to bisect/prune, generated randomly if not specified. -If \code{-1}, a complete list of all trees one step from the input tree -will be returned. -In \code{cNNI()}, an integer from zero to \code{nEdge(tree) - nTip(tree) - 2}, -specifying which internal edge to break.} - -\item{whichSwitch}{Integer from zero to one, specifying which way to re-build -the broken internal edge.} - -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} - -\item{child}{Integer vector corresponding to the second column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 2]}.} - -\item{nTips}{(optional) Number of tips.} -} -\value{ -Returns a tree with class \code{phylo} (if \code{returnAll = FALSE}) or -a set of trees, with class \code{multiPhylo} (if \code{returnAll = TRUE}). - -\code{cNNI()} returns a tree of class \code{phylo}, rooted on the same leaf, -on which the specified rearrangement has been conducted. - -\code{NNISwap()} returns a list containing two elements, corresponding in -turn to the rearranged parent and child parameters. - -a list containing two elements, corresponding in turn to the rearranged parent and child parameters -} -\description{ -\code{NNI()}performs a single iteration of the nearest-neighbour interchange -algorithm; \code{RootedNNI()} retains the position of the root. -These functions are based on equivalents in the '\pkg{phangorn}' package. -\code{cNNI()} is an equivalent function coded in C, that runs much faster. -} -\details{ -Branch lengths are not supported. - -All nodes in a tree must be bifurcating; \code{\link[ape:collapse.singles]{ape::collapse.singles()}} and -\code{\link[ape:multi2di]{ape::multi2di()}} may help. -} -\section{Functions}{ -\itemize{ -\item \code{NNISwap}: faster version that takes and returns parent and child parameters - -\item \code{RootedNNI}: Perform \acronym{NNI} rearrangement, retaining position of root - -\item \code{RootedNNISwap}: faster version that takes and returns parent and child parameters -}} - -\examples{ -tree <- TreeTools::BalancedTree(8) -# A random rearrangement -NNI(tree) -cNNI(tree) - -# All trees one NNI rearrangement away -NNI(tree, edgeToBreak = -1) - -# Manual random sampling -cNNI(tree, sample.int(14 - 8 - 1, 1), sample.int(2, 1)) - -# A specified rearrangement -cNNI(tree, 0, 0) - -# If a tree may not be binary, collapse nodes with -tree <- TreeTools::MakeTreeBinary(tree) - -# If a tree may be improperly rooted, use -tree <- TreeTools::RootTree(tree, 1) - -# If a tree may exhibit unusual node ordering, this can be addressed with -tree <- TreeTools::Preorder(tree) -} -\references{ -The algorithm is summarized in -\insertRef{Felsenstein2004}{TreeSearch} -} -\seealso{ -Other tree rearrangement functions: -\code{\link{SPR}()}, -\code{\link{TBR}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{tree rearrangement functions} diff --git a/man/PhyDat2Morphy.Rd b/man/PhyDat2Morphy.Rd deleted file mode 100644 index fc1e72260..000000000 --- a/man/PhyDat2Morphy.Rd +++ /dev/null @@ -1,73 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{PhyDat2Morphy} -\alias{PhyDat2Morphy} -\title{Initialize a Morphy object from a \code{phyDat} object} -\usage{ -PhyDat2Morphy(phy, gap = "inapplicable") -} -\arguments{ -\item{phy}{An object of class \code{\link{phyDat}}.} - -\item{gap}{An unambiguous abbreviation of \code{inapplicable}, \code{ambiguous} -(= \code{missing}), or \verb{extra state}, specifying how gaps will be handled.} -} -\value{ -\code{PhyDat2Morphy()} returns a pointer to an initialized Morphy object. -} -\description{ -Creates a new Morphy object with the same size and characters as the -\code{phyDat} object. -Once finished with the object, it should be destroyed using -\code{\link[=UnloadMorphy]{UnloadMorphy()}} to free the allocated memory. -} -\examples{ -data('Lobo', package='TreeTools') -morphyObj <- PhyDat2Morphy(Lobo.phy) -# Set object to be destroyed at end of session or closure of function -# on.exit(morphyObj <- UnloadMorphy(morphyObj), add = TRUE) - -# Do something with pointer -# .... - -# Or, instead of on.exit, manually destroy morphy object and free memory: -morphyObj <- UnloadMorphy(morphyObj) -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{Morphy API functions} diff --git a/man/PlotCharacter.Rd b/man/PlotCharacter.Rd deleted file mode 100644 index 9552ee77b..000000000 --- a/man/PlotCharacter.Rd +++ /dev/null @@ -1,89 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/PlotCharacter.R -\name{PlotCharacter} -\alias{PlotCharacter} -\title{Plot the distribution of a character on a tree} -\usage{ -PlotCharacter( - tree, - dataset, - char = 1L, - updateTips = FALSE, - plot = TRUE, - tokenCol = NULL, - ambigCol = "grey", - inappCol = "lightgrey", - ambigLty = "dotted", - inappLty = "dashed", - plainLty = par("lty"), - tipOffset = 1, - unitEdge = FALSE, - ... -) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{char}{Index of character to plot.} - -\item{updateTips}{Logical; if \code{FALSE}, tips will be labelled with their -original state in \code{dataset}.} - -\item{plot}{Logical specifying whether to plot the output.} - -\item{tokenCol}{Palette specifying colours to associate with each token in -turn, in the sequence listed in \code{attr(dataset, 'levels')}.} - -\item{ambigCol, ambigLty, inappCol, inappLty, plainLty}{Colours and line types -to apply to ambiguous, inapplicable and applicable tokens. See the \code{lty} -\link{graphical parameter} for details of line styles. Overrides \code{tokenCol}.} - -\item{tipOffset}{Numeric: how much to offset tips from their labels.} - -\item{unitEdge}{Logical: Should all edges be plotted with a unit length?} - -\item{\dots}{Further arguments to pass to \code{plot.phylo()}.} -} -\value{ -\code{PlotCharacter()} returns a matrix in which each row corresponds -to a numbered tip or node of \code{tree}, and each column corresponds to a -token; the tokens that might parsimoniously be present at each point -on a tree are denoted with \code{TRUE}. -} -\description{ -Reconstructs the distribution of a character on a tree topology using the -modified Fitch algorithm presented in -\insertCite{Brazeau2019;textual}{TreeSearch}. -} -\details{ -Correct colouration of internal nodes requires "ape" version 5.5.2. -Until this is available on CRAN (expected in winter 2021), download it -using \code{devtools::install_github('emmanuelparadis/ape')}. -} -\examples{ -# Set up plotting area -oPar <- par(mar = rep(0, 4)) - -tree <- ape::read.tree(text = - "((((((a, b), c), d), e), f), (g, (h, (i, (j, (k, l))))));") -## A character with inapplicable data -dataset <- TreeTools::StringToPhyDat("23--1??--032", tips = tree) -PlotCharacter(tree, dataset) - -# Character from a real dataset -data("Lobo", package = "TreeTools") -dataset <- Lobo.phy -tree <- TreeTools::NJTree(dataset) -PlotCharacter(tree, dataset, 14) -par(oPar) -} -\references{ -\insertAllCited{} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} diff --git a/man/PrepareDataProfile.Rd b/man/PrepareDataProfile.Rd deleted file mode 100644 index cc19d9d68..000000000 --- a/man/PrepareDataProfile.Rd +++ /dev/null @@ -1,69 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_manipulation.R -\encoding{UTF-8} -\name{PrepareDataProfile} -\alias{PrepareDataProfile} -\alias{PrepareDataIW} -\title{Prepare data for Profile Parsimony} -\usage{ -PrepareDataProfile(dataset) - -PrepareDataIW(dataset) -} -\arguments{ -\item{dataset}{dataset of class \code{phyDat}} -} -\value{ -An object of class \code{phyDat}, with additional attributes. -\code{PrepareDataProfile} adds the attributes: -\itemize{ -\item \code{info.amounts}: details the information represented by each -character when subject to N additional steps. -\item \code{informative}: logical specifying which characters contain any -phylogenetic information. -\item \code{bootstrap}: The character vector -\code{c('info.amounts', 'split.sizes')}, indicating attributes to sample -when bootstrapping the dataset (e.g. in Ratchet searches). -} - -\code{PrepareDataIW} adds the attribute: -\itemize{ -\item \code{min.length}: The minimum number of steps that must be present in each -transformation series. -} -} -\description{ -Calculates profiles for each character in a dataset. Will also simplify -characters, with a warning, where they are too complex for the present -implementation of profile parsimony: -\itemize{ -\item inapplicable tokens will be replaced with the ambiguous token -(i.e. \code{-} \ifelse{html}{\out{→}}{\eqn{\rightarrow}{-->}} \verb{?}); -\item Ambiguous tokens will be treated as fully ambiguous -(i.e. \code{{02}} \ifelse{html}{\out{→}}{\eqn{\rightarrow}{-->}} \verb{?}) -\item Where more than two states are informative (i.e. unambiguously present in -more than two taxa), states beyond the two most informative will be -ignored. -} -} -\section{Functions}{ -\itemize{ -\item \code{PrepareDataIW}: Prepare data for implied weighting -}} - -\examples{ -data('congreveLamsdellMatrices') -dataset <- congreveLamsdellMatrices[[42]] -PrepareDataProfile(dataset) -} -\seealso{ -Other profile parsimony functions: -\code{\link{Carter1}()}, -\code{\link{StepInformation}()}, -\code{\link{profiles}} -} -\author{ -Martin R. Smith; written with reference to -\code{phangorn:::prepareDataFitch()} -} -\concept{profile parsimony functions} diff --git a/man/RandomMorphyTree.Rd b/man/RandomMorphyTree.Rd deleted file mode 100644 index 1c43f9f6d..000000000 --- a/man/RandomMorphyTree.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/RandomTreeScore.R -\name{RandomMorphyTree} -\alias{RandomMorphyTree} -\title{Random postorder tree} -\usage{ -RandomMorphyTree(nTip) -} -\arguments{ -\item{nTip}{Integer specifying the number of tips to include in the tree -(minimum 2).} -} -\value{ -A list with three elements, each a vector of integers, respectively -containing: -\itemize{ -\item The parent of each tip and node, in order -\item The left child of each node -\item The right child of each node. -} -} -\description{ -Random postorder tree -} -\seealso{ -Other tree generation functions: -\code{\link{AdditionTree}()} -} -\concept{tree generation functions} diff --git a/man/RandomTreeScore.Rd b/man/RandomTreeScore.Rd deleted file mode 100644 index c07125917..000000000 --- a/man/RandomTreeScore.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/RandomTreeScore.R -\name{RandomTreeScore} -\alias{RandomTreeScore} -\title{Parsimony score of random postorder tree} -\usage{ -RandomTreeScore(morphyObj) -} -\arguments{ -\item{morphyObj}{Object of class \code{morphy}, perhaps created with -\code{\link[=PhyDat2Morphy]{PhyDat2Morphy()}}.} -} -\value{ -\code{RandomTreeScore()} returns the parsimony score of a random tree -for the given Morphy object. -} -\description{ -Parsimony score of random postorder tree -} -\examples{ -tokens <- matrix(c( - 0, '-', '-', 1, 1, 2, - 0, 1, 0, 1, 2, 2, - 0, '-', '-', 0, 0, 0), byrow = TRUE, nrow = 3L, - dimnames = list(letters[1:3], NULL)) -pd <- TreeTools::MatrixToPhyDat(tokens) -morphyObj <- PhyDat2Morphy(pd) - -RandomTreeScore(morphyObj) - -morphyObj <- UnloadMorphy(morphyObj) -} diff --git a/man/Ratchet.Rd b/man/Ratchet.Rd deleted file mode 100644 index 3c4289ee0..000000000 --- a/man/Ratchet.Rd +++ /dev/null @@ -1,220 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Bootstrap.R, R/Ratchet.R -\name{MorphyBootstrap} -\alias{MorphyBootstrap} -\alias{Ratchet} -\alias{MultiRatchet} -\alias{RatchetConsensus} -\title{Parsimony Ratchet} -\usage{ -MorphyBootstrap( - edgeList, - morphyObj, - EdgeSwapper = NNISwap, - maxIter, - maxHits, - verbosity = 1L, - stopAtPeak = FALSE, - stopAtPlateau = 0L, - ... -) - -Ratchet( - tree, - dataset, - InitializeData = PhyDat2Morphy, - CleanUpData = UnloadMorphy, - TreeScorer = MorphyLength, - Bootstrapper = MorphyBootstrap, - swappers = list(TBRSwap, SPRSwap, NNISwap), - BootstrapSwapper = if (is.list(swappers)) swappers[[length(swappers)]] else swappers, - returnAll = FALSE, - stopAtScore = NULL, - stopAtPeak = FALSE, - stopAtPlateau = 0L, - ratchIter = 100, - ratchHits = 10, - searchIter = 4000, - searchHits = 42, - bootstrapIter = searchIter, - bootstrapHits = searchHits, - verbosity = 1L, - suboptimal = sqrt(.Machine$double.eps), - ... -) - -MultiRatchet( - tree, - dataset, - ratchHits = 10, - searchIter = 500, - searchHits = 20, - verbosity = 0L, - swappers = list(RootedNNISwap), - nSearch = 10, - stopAtScore = NULL, - ... -) - -RatchetConsensus( - tree, - dataset, - ratchHits = 10, - searchIter = 500, - searchHits = 20, - verbosity = 0L, - swappers = list(RootedNNISwap), - nSearch = 10, - stopAtScore = NULL, - ... -) -} -\arguments{ -\item{edgeList}{a list containing the following: -- vector of integers corresponding to the parent of each edge in turn -- vector of integers corresponding to the child of each edge in turn -- (optionally) score of the tree -- (optionally, if score provided) number of times this score has been hit} - -\item{morphyObj}{Object of class \code{morphy}, perhaps created with -\code{\link[=PhyDat2Morphy]{PhyDat2Morphy()}}.} - -\item{EdgeSwapper}{a function that rearranges a parent and child vector, -and returns a list with modified vectors; for example \code{\link[=SPRSwap]{SPRSwap()}}.} - -\item{maxIter}{Numeric specifying maximum number of iterations to perform in -tree search.} - -\item{maxHits}{Numeric specifying maximum number of hits to accomplish in -tree search.} - -\item{verbosity}{Numeric specifying level of detail to display in console: -larger numbers provide more verbose feedback to the user.} - -\item{stopAtPeak}{Logical specifying whether to terminate search once a -subsequent iteration recovers a sub-optimal score. -Will be overridden if a passed function has an attribute \code{stopAtPeak} set by -\code{attr(FunctionName, 'stopAtPeak') <- TRUE}.} - -\item{stopAtPlateau}{Integer. If > 0, tree search will terminate if the score -has not improved after \code{stopAtPlateau} iterations. -Will be overridden if a passed function has an attribute \code{stopAtPlateau} set -by \code{attr(FunctionName, 'stopAtPlateau') <- TRUE}.} - -\item{\dots}{further arguments to pass to \code{TreeScorer()}, e.g. \verb{dataset = }.} - -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{dataset}{a dataset in the format required by \code{TreeScorer()}.} - -\item{InitializeData}{Function that sets up data object to prepare for tree search. -The function will be passed the \code{dataset} parameter. -Its return value will be passed to \code{TreeScorer()} and \code{CleanUpData()}.} - -\item{CleanUpData}{Function to destroy data object on function exit. -The function will be passed the value returned by \code{InitializeData()}.} - -\item{TreeScorer}{function to score a given tree. -The function will be passed three parameters, corresponding to the -\code{parent} and \code{child} entries of a tree's edge list, and a dataset.} - -\item{Bootstrapper}{Function to perform bootstrapped rearrangements of tree. -First arguments will be an \code{edgeList} and a dataset, initialized using -\code{InitializeData()}. Should return a rearranged \code{edgeList}.} - -\item{swappers}{A list of functions to use to conduct edge rearrangement during tree search. -Provide functions like \code{\link{NNISwap}} to shuffle root position, -or \code{\link{RootedTBRSwap}} if the position of the root should be retained. -You may wish to use extreme swappers (such as \acronym{TBR}) early in the list, -and a more subtle rearranger (such as \acronym{NNI}) later in the list to make -incremental tinkerings once an almost-optimal tree has been found.} - -\item{BootstrapSwapper}{Function such as \code{\link{RootedNNISwap}} to use -to rearrange trees within \code{Bootstrapper()}.} - -\item{returnAll}{Set to \code{TRUE} to report all MPTs encountered during the -search, perhaps to analyse consensus.} - -\item{stopAtScore}{stop search as soon as this score is hit or beaten.} - -\item{ratchIter}{Stop when this many ratchet iterations have been performed.} - -\item{ratchHits}{Stop when this many ratchet iterations have found the same -best score.} - -\item{searchIter}{Integer specifying maximum rearrangements to perform on each bootstrap or -ratchet iteration. -To override this value for a single swapper function, set e.g. -\code{attr(SwapperFunction, 'searchIter') <- 99}} - -\item{searchHits}{Integer specifying maximum times to hit best score before terminating a tree -search within a ratchet iteration. -To override this value for a single swapper function, set e.g. -\code{attr(SwapperFunction, 'searchHits') <- 99}} - -\item{bootstrapIter}{Integer specifying maximum rearrangements to perform on each bootstrap -iteration (default: \code{searchIter}).} - -\item{bootstrapHits}{Integer specifying maximum times to hit best score on each bootstrap -iteration (default: \code{searchHits}).} - -\item{suboptimal}{retain trees that are suboptimal by this score. -Defaults to a small value that will counter rounding errors.} - -\item{nSearch}{Number of Ratchet searches to conduct -(for \code{RatchetConsensus()})} -} -\value{ -\code{MorphyBootstrap()} returns a tree that is optimal under a random -sampling of the original characters. - -\code{Ratchet()} returns a tree modified by parsimony ratchet iterations. - -\code{MultiRatchet()} returns a list of optimal trees -produced by \code{nSearch} -ratchet searches, from which a consensus tree can be generated using -\code{\link[ape:consensus]{ape::consensus()}} or \code{\link[TreeTools:ConsensusWithout]{TreeTools::ConsensusWithout()}}. -} -\description{ -\code{Ratchet()} uses the parsimony ratchet \insertCite{Nixon1999}{TreeSearch} -to search for a more parsimonious tree using custom optimality criteria. -} -\details{ -For usage pointers, see the -\href{https://ms609.github.io/TreeSearch/articles/custom.html}{vignette}. -} -\section{Functions}{ -\itemize{ -\item \code{RatchetConsensus}: deprecated alias for \code{MultiRatchet()} -}} - -\examples{ -data('Lobo', package = 'TreeTools') -njtree <- TreeTools::NJTree(Lobo.phy) -# Increase value of ratchIter and searchHits to do a proper search -quickResult <- Ratchet(njtree, Lobo.phy, ratchIter = 2, searchHits = 3) - -# Plot result (legibly) -oldPar <- par(mar = rep(0, 4), cex = 0.75) -plot(quickResult) -par(oldPar) -} -\references{ -\insertAllCited{} -} -\seealso{ -\itemize{ -\item Adapted from \code{\link[phangorn:parsimony]{pratchet()}} in the -\pkg{phangorn} package. -} - -Other custom search functions: -\code{\link{EdgeListSearch}()}, -\code{\link{Jackknife}()}, -\code{\link{SuccessiveApproximations}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{custom search functions} diff --git a/man/RearrangeEdges.Rd b/man/RearrangeEdges.Rd deleted file mode 100644 index d98993853..000000000 --- a/man/RearrangeEdges.Rd +++ /dev/null @@ -1,79 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tree_rearrangement.R -\name{RearrangeEdges} -\alias{RearrangeEdges} -\title{Rearrange edges of a phylogenetic tree} -\usage{ -RearrangeEdges( - parent, - child, - dataset, - TreeScorer = MorphyLength, - EdgeSwapper, - scoreToBeat = TreeScorer(parent, child, dataset, ...), - iter = "?", - hits = 0L, - verbosity = 0L, - ... -) -} -\arguments{ -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} - -\item{child}{Integer vector corresponding to the second column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 2]}.} - -\item{dataset}{Third argument to pass to \code{TreeScorer}.} - -\item{TreeScorer}{function to score a given tree. -The function will be passed three parameters, corresponding to the -\code{parent} and \code{child} entries of a tree's edge list, and a dataset.} - -\item{EdgeSwapper}{a function that rearranges a parent and child vector, -and returns a list with modified vectors; for example \code{\link[=SPRSwap]{SPRSwap()}}.} - -\item{scoreToBeat}{Double giving score of input tree.} - -\item{iter}{iteration number of calling function, for reporting to user only.} - -\item{hits}{Integer giving number of times the input tree has already been hit.} - -\item{verbosity}{Numeric specifying level of detail to display in console: -larger numbers provide more verbose feedback to the user.} - -\item{\dots}{further arguments to pass to \code{TreeScorer()}, e.g. \verb{dataset = }.} -} -\value{ -This function returns a list with two to four elements, corresponding to a binary tree: -- 1. Integer vector listing the parent node of each edge; -- 2. Integer vector listing the child node of each edge; -- 3. Score of the tree; -- 4. Number of times that score has been hit. -} -\description{ -\code{RearrangeEdges()} performs the specified edge rearrangement on a matrix -that corresponds to the edges of a phylogenetic tree, returning the score of -the new tree. -Will generally be called from within a tree search function. -} -\details{ -\code{RearrangeTree()} performs one tree rearrangement of a -specified type, and returns the score of the tree (with the given dataset). -It also reports the number of times that this score was hit in the -current function call. -} -\examples{ -data('Lobo', package='TreeTools') -tree <- TreeTools::NJTree(Lobo.phy) -edge <- tree$edge -parent <- edge[, 1] -child <- edge[, 2] -dataset <- PhyDat2Morphy(Lobo.phy) -RearrangeEdges(parent, child, dataset, EdgeSwapper = RootedNNISwap) -# Remember to free memory: -dataset <- UnloadMorphy(dataset) -} -\author{ -Martin R. Smith -} diff --git a/man/SPR.Rd b/man/SPR.Rd deleted file mode 100644 index cb034f9f1..000000000 --- a/man/SPR.Rd +++ /dev/null @@ -1,115 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SPR.R -\name{SPR} -\alias{SPR} -\alias{SPRMoves} -\alias{SPRMoves.phylo} -\alias{SPRMoves.matrix} -\alias{SPRSwap} -\alias{RootedSPR} -\alias{RootedSPRSwap} -\title{Subtree pruning and rearrangement (SPR)} -\usage{ -SPR(tree, edgeToBreak = NULL, mergeEdge = NULL) - -SPRMoves(tree, edgeToBreak = integer(0)) - -\method{SPRMoves}{phylo}(tree, edgeToBreak = integer(0)) - -\method{SPRMoves}{matrix}(tree, edgeToBreak = integer(0)) - -SPRSwap( - parent, - child, - nEdge = length(parent), - nNode = nEdge/2L, - edgeToBreak = NULL, - mergeEdge = NULL -) - -RootedSPR(tree, edgeToBreak = NULL, mergeEdge = NULL) - -RootedSPRSwap( - parent, - child, - nEdge = length(parent), - nNode = nEdge/2L, - edgeToBreak = NULL, - mergeEdge = NULL -) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{edgeToBreak}{the index of an edge to bisect, generated randomly if not specified.} - -\item{mergeEdge}{the index of an edge on which to merge the broken edge.} - -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} - -\item{child}{Integer vector corresponding to the second column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 2]}.} - -\item{nEdge}{(optional) integer specifying the number of edges of a tree of -class \code{\link{phylo}}, i.e. \code{dim(tree$edge)[1]}} - -\item{nNode}{(optional) Number of nodes.} -} -\value{ -This function returns a tree in \code{phyDat} format that has undergone one \acronym{SPR} iteration. - -\code{TBRMoves()} returns a list of all trees one SPR move away from -\code{tree}, with edges and nodes in preorder, rooted on the first-labelled tip. - -a list containing two elements, corresponding in turn to the -rearranged parent and child parameters - -a list containing two elements, corresponding in turn to the rearranged parent and child parameters -} -\description{ -Perform one \acronym{SPR} rearrangement on a tree -} -\details{ -Equivalent to \code{kSPR} in the \code{phangorn} package, but faster. -Note that rearrangements that only change the position of the root WILL be returned by -\code{SPR}. If the position of the root is irrelevant (as in Fitch parsimony, for example) -then this function will occasionally return a functionally equivalent topology. -\code{RootIrrelevantSPR} will search tree space more efficiently in these cases. -Branch lengths are not (yet) supported. - -All nodes in a tree must be bifurcating; \link[ape:collapse.singles]{ape::collapse.singles} and -\link[ape:multi2di]{ape::multi2di} may help. -} -\section{Functions}{ -\itemize{ -\item \code{SPRSwap}: faster version that takes and returns parent and child parameters - -\item \code{RootedSPR}: Perform \acronym{SPR} rearrangement, retaining position of root - -\item \code{RootedSPRSwap}: faster version that takes and returns parent and child parameters -}} - -\examples{ -{ -tree <- ape::rtree(20, br=FALSE) -SPR(tree) -} -} -\references{ -The \acronym{SPR} algorithm is summarized in -\insertRef{Felsenstein2004}{TreeSearch} -} -\seealso{ -\itemize{ -\item \code{\link[=RootedSPR]{RootedSPR()}}: useful when the position of the root node should be retained. -} - -Other tree rearrangement functions: -\code{\link{NNI}()}, -\code{\link{TBR}()} -} -\author{ -Martin R. Smith -} -\concept{tree rearrangement functions} diff --git a/man/SingleCharMorphy.Rd b/man/SingleCharMorphy.Rd deleted file mode 100644 index 13b885275..000000000 --- a/man/SingleCharMorphy.Rd +++ /dev/null @@ -1,65 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{SingleCharMorphy} -\alias{SingleCharMorphy} -\title{Morphy object from single character} -\usage{ -SingleCharMorphy(char, gap = "inapp") -} -\arguments{ -\item{char}{State of each character at each tip in turn, in a format that will be converted -to a character string by \code{\link{paste0}(char, ';', collapse='')}.} - -\item{gap}{An unambiguous abbreviation of \code{inapplicable}, \code{ambiguous} -(= \code{missing}), or \verb{extra state}, specifying how gaps will be handled.} -} -\value{ -A pointer to an object of class \code{morphyObj}. -Don't forget to unload it when you've finished with it. -} -\description{ -Morphy object from single character -} -\examples{ -morphyObj <- SingleCharMorphy('-0-0', gap = 'Extra') -RandomTreeScore(morphyObj) -morphyObj <- UnloadMorphy(morphyObj) -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{Morphy API functions} diff --git a/man/SiteConcordance.Rd b/man/SiteConcordance.Rd deleted file mode 100644 index f6c68fc33..000000000 --- a/man/SiteConcordance.Rd +++ /dev/null @@ -1,78 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Concordance.R -\name{SiteConcordance} -\alias{SiteConcordance} -\alias{QuartetConcordance} -\alias{ClusteringConcordance} -\alias{PhylogeneticConcordance} -\alias{MutualClusteringConcordance} -\alias{SharedPhylogeneticConcordance} -\title{Calculate site concordance factor} -\usage{ -QuartetConcordance(tree, dataset) - -ClusteringConcordance(tree, dataset) - -PhylogeneticConcordance(tree, dataset) - -MutualClusteringConcordance(tree, dataset) - -SharedPhylogeneticConcordance(tree, dataset) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} -} -\description{ -The site concordance factor \insertCite{Minh2020}{TreeSearch} is a measure -of the strength of support that the dataset presents for a given split in a -tree. -} -\details{ -\code{QuartetConcordance()} is the proportion of quartets (sets of four leaves) -that are decisive for a split which are also concordant with it. -For example, a quartet with the characters \verb{0 0 0 1} is not decisive, as -all relationships between those leaves are equally parsimonious. -But a quartet with characters \verb{0 0 1 1} is decisive, and is concordant -with any tree that groups the first two leaves together to the exclusion -of the second. - -NOTE: These functions are under development, and may be incompletely tested -or change without notice. -Complete documentation and discussion will follow soon. -} -\examples{ -data('congreveLamsdellMatrices', package = 'TreeSearch') -dataset <- congreveLamsdellMatrices[[1]][, 1:20] -tree <- referenceTree -qc <- QuartetConcordance(tree, dataset) -cc <- ClusteringConcordance(tree, dataset) -pc <- PhylogeneticConcordance(tree, dataset) -spc <- SharedPhylogeneticConcordance(tree, dataset) -mcc <- MutualClusteringConcordance(tree, dataset) - -oPar <- par(mar = rep(0, 4), cex = 0.8) -plot(tree) -TreeTools::LabelSplits(tree, signif(qc, 3)) -TreeTools::LabelSplits(tree, signif(cc, 3)) -TreeTools::LabelSplits(tree, signif(pc, 3)) -par(oPar) - -pairs(cbind(qc, cc, pc, spc, mcc)) -} -\references{ -\insertAllCited{} -} -\seealso{ -Other split support functions: -\code{\link{JackLabels}()}, -\code{\link{Jackknife}()}, -\code{\link{MaximizeParsimony}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{split support functions} diff --git a/man/StepInformation.Rd b/man/StepInformation.Rd deleted file mode 100644 index 735f6f91d..000000000 --- a/man/StepInformation.Rd +++ /dev/null @@ -1,47 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pp_info_extra_step.r -\name{StepInformation} -\alias{StepInformation} -\title{Information content of a character known to contain \emph{e} steps} -\usage{ -StepInformation(char, ambiguousTokens = c("-", "?")) -} -\arguments{ -\item{char}{Vector of tokens listing states for the character in question.} - -\item{ambiguousTokens}{Vector specifying which tokens, if any, correspond to -the ambiguous token (\verb{?}).} -} -\value{ -\code{StepInformation()} returns a numeric vector detailing the amount -of phylogenetic information (in bits) associated with the character when -0, 1, 2… extra steps are present. The vector is named with the -total number of steps associated with each entry in the vector: for example, -a character with three observed tokens must exhibit two steps, so the first -entry (zero extra steps) is named \code{2} (two steps observed). -} -\description{ -\code{StepInformation()} calculates the phylogenetic information content of a -character \code{char} when \emph{e} extra steps are present, for all possible -values of \emph{e}. -} -\details{ -Calculates the number of trees consistent with the character having -\emph{e} extra steps, where \emph{e} ranges from its minimum possible value -(i.e. number of different tokens minus one) to its maximum. -} -\examples{ -character <- rep(c(0:3, '?', '-'), c(8, 5, 1, 1, 2, 2)) -StepInformation(character) -} -\seealso{ -Other profile parsimony functions: -\code{\link{Carter1}()}, -\code{\link{PrepareDataProfile}()}, -\code{\link{profiles}} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{profile parsimony functions} diff --git a/man/StopUnlessBifurcating.Rd b/man/StopUnlessBifurcating.Rd deleted file mode 100644 index 5130c7627..000000000 --- a/man/StopUnlessBifurcating.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tree_rearrangement.R -\name{StopUnlessBifurcating} -\alias{StopUnlessBifurcating} -\title{Check that all nodes in a tree are bifurcating.} -\usage{ -StopUnlessBifurcating(parent) -} -\arguments{ -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} -} -\value{ -Returns \code{NULL}, but will \code{stop} with an error message if a tree -does not appear to be bifurcating. -} -\description{ -Check that all nodes in a tree are bifurcating. -} -\author{ -Martin R. Smith -} -\keyword{internal} diff --git a/man/Suboptimality.Rd b/man/Suboptimality.Rd deleted file mode 100644 index 99286680c..000000000 --- a/man/Suboptimality.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SuccessiveApproximations.R -\name{Suboptimality} -\alias{Suboptimality} -\title{Tree suboptimality} -\usage{ -Suboptimality(trees, proportional = FALSE) -} -\arguments{ -\item{trees}{list of trees, to include an optimal tree} - -\item{proprtional}{logical stating whether to normalise results to lowest score} -} -\value{ -a vector listing, for each tree, how much their score differs from the optimal (lowest) score. -} -\description{ -How suboptimal is a tree? -} -\keyword{internal} diff --git a/man/SuccessiveApproximations.Rd b/man/SuccessiveApproximations.Rd deleted file mode 100644 index a857bfa8a..000000000 --- a/man/SuccessiveApproximations.Rd +++ /dev/null @@ -1,70 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SuccessiveApproximations.R -\name{SuccessiveApproximations} -\alias{SuccessiveApproximations} -\alias{SuccessiveWeights} -\title{Tree search using successive approximations} -\usage{ -SuccessiveApproximations( - tree, - dataset, - outgroup = NULL, - k = 3, - maxSuccIter = 20, - ratchetHits = 100, - searchHits = 50, - searchIter = 500, - ratchetIter = 5000, - verbosity = 0, - suboptimal = 0.1 -) - -SuccessiveWeights(tree, dataset) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{outgroup}{if not NULL, taxa on which the tree should be rooted} - -\item{k}{Constant for successive approximations, see Farris 1969 p. 379} - -\item{maxSuccIter}{maximum iterations of successive approximation} - -\item{ratchetHits}{maximum hits for parsimony ratchet} - -\item{searchHits}{maximum hits in tree search} - -\item{searchIter}{maximum iterations in tree search} - -\item{ratchetIter}{maximum iterations of parsimony ratchet} - -\item{verbosity}{Numeric specifying level of detail to display in console: -larger numbers provide more verbose feedback to the user.} - -\item{suboptimal}{retain trees that are this proportion less optimal than the optimal tree} -} -\value{ -\code{SuccessiveApproximations()} returns a list of class \code{multiPhylo} -containing optimal (and slightly suboptimal, if suboptimal > 0) trees. - -\code{SuccessiveWeights()} returns the score of a tree, given the -weighting instructions specified in the attributes of the dataset. -} -\description{ -Searches for a tree that is optimal under the Successive Approximations -criterion \insertCite{Farris1969}{TreeSearch}. -} -\references{ -\insertAllCited{} -} -\seealso{ -Other custom search functions: -\code{\link{EdgeListSearch}()}, -\code{\link{Jackknife}()}, -\code{\link{MorphyBootstrap}()} -} -\concept{custom search functions} -\keyword{internal} diff --git a/man/TBR.Rd b/man/TBR.Rd deleted file mode 100644 index af7494513..000000000 --- a/man/TBR.Rd +++ /dev/null @@ -1,111 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/TBR.R -\name{TBR} -\alias{TBR} -\alias{TBRMoves} -\alias{TBRMoves.phylo} -\alias{TBRMoves.matrix} -\alias{TBRSwap} -\alias{RootedTBR} -\alias{RootedTBRSwap} -\title{Tree bisection and reconnection (TBR)} -\usage{ -TBR(tree, edgeToBreak = NULL, mergeEdges = NULL) - -TBRMoves(tree, edgeToBreak = integer(0)) - -\method{TBRMoves}{phylo}(tree, edgeToBreak = integer(0)) - -\method{TBRMoves}{matrix}(tree, edgeToBreak = integer(0)) - -TBRSwap( - parent, - child, - nEdge = length(parent), - edgeToBreak = NULL, - mergeEdges = NULL -) - -RootedTBR(tree, edgeToBreak = NULL, mergeEdges = NULL) - -RootedTBRSwap( - parent, - child, - nEdge = length(parent), - edgeToBreak = NULL, - mergeEdges = NULL -) -} -\arguments{ -\item{tree}{A bifurcating tree of class \code{\link{phylo}}, with all nodes resolved;} - -\item{edgeToBreak}{(optional) integer specifying the index of an edge to bisect/prune, -generated randomly if not specified. -Alternatively, set to \code{-1} to return a complete list -of all trees one step from the input tree.} - -\item{mergeEdges}{(optional) vector of length 1 or 2, listing edge(s) to be joined: -In SPR, this is where the pruned subtree will be reconnected. -In TBR, these edges will be reconnected (so must be on opposite -sides of \code{edgeToBreak}); if only a single edge is specified, -the second will be chosen at random} - -\item{parent}{Integer vector corresponding to the first column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 1]}.} - -\item{child}{Integer vector corresponding to the second column of the edge -matrix of a tree of class \code{\link{phylo}}, i.e. \code{tree$edge[, 2]}.} - -\item{nEdge}{(optional) Number of edges.} -} -\value{ -This function returns a tree in \code{phyDat} format that has undergone one \acronym{TBR} iteration. - -\code{TBRMoves()} returns a \code{multiPhylo} object listing all trees one -\acronym{TBR} move away from \code{tree}, with edges and nodes in preorder, -rooted on the first-labelled tip. - -a list containing two elements, corresponding in turn to the -rearranged parent and child parameters -} -\description{ -\code{TBR} performs a single random \acronym{TBR} iteration. -} -\details{ -Branch lengths are not (yet) supported. - -All nodes in a tree must be bifurcating; \link[ape:collapse.singles]{ape::collapse.singles} and -\link[ape:multi2di]{ape::multi2di} may help. -} -\section{Functions}{ -\itemize{ -\item \code{TBRSwap}: faster version that takes and returns parent and child -parameters - -\item \code{RootedTBR}: Perform \acronym{TBR} rearrangement, retaining position of root - -\item \code{RootedTBRSwap}: faster version that takes and returns parent and child parameters -}} - -\examples{ -{ -library('ape') -tree <- rtree(20, br=NULL) -TBR(tree) -} -} -\references{ -The \acronym{TBR} algorithm is summarized in -\insertRef{Felsenstein2004}{TreeSearch} -} -\seealso{ -\code{\link[=RootedTBR]{RootedTBR()}}: useful when the position of the root node should be retained. - -Other tree rearrangement functions: -\code{\link{NNI}()}, -\code{\link{SPR}()} -} -\author{ -Martin R. Smith -} -\concept{tree rearrangement functions} diff --git a/man/TBRWarning.Rd b/man/TBRWarning.Rd deleted file mode 100644 index bc9423229..000000000 --- a/man/TBRWarning.Rd +++ /dev/null @@ -1,38 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SPR.R, R/TBR.R -\name{SPRWarning} -\alias{SPRWarning} -\alias{TBRWarning} -\title{TBR Warning -Print a warning and return given tree} -\usage{ -SPRWarning(parent, child, error) - -TBRWarning(parent, child, error) -} -\arguments{ -\item{error}{error message to report} - -\item{tree}{tree to return} -} -\value{ -the tree specified in tree -} -\description{ -TBR Warning -Print a warning and return given tree -} -\section{Functions}{ -\itemize{ -\item \code{SPRWarning}: for SPR rearrangements -}} - -\examples{ -suppressWarnings(TBRWarning(0, 0, 'Message text')) # will trigger warning - - -} -\author{ -Martin R. Smith -} -\keyword{internal} diff --git a/man/TreeLength.Rd b/man/TreeLength.Rd deleted file mode 100644 index a115277fa..000000000 --- a/man/TreeLength.Rd +++ /dev/null @@ -1,87 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/IWScore.R, R/tree_length.R -\name{IWScore} -\alias{IWScore} -\alias{TreeLength} -\alias{TreeLength.phylo} -\alias{TreeLength.numeric} -\alias{TreeLength.list} -\alias{TreeLength.multiPhylo} -\alias{Fitch} -\title{Calculate the parsimony score of a tree given a dataset} -\usage{ -IWScore(tree, dataset, concavity = 10L, ...) - -TreeLength(tree, dataset, concavity = Inf) - -\method{TreeLength}{phylo}(tree, dataset, concavity = Inf) - -\method{TreeLength}{numeric}(tree, dataset, concavity = Inf) - -\method{TreeLength}{list}(tree, dataset, concavity = Inf) - -\method{TreeLength}{multiPhylo}(tree, dataset, concavity = Inf) - -Fitch(tree, dataset) -} -\arguments{ -\item{tree}{A tree of class \code{phylo}, a list thereof (optionally of class -\code{multiPhylo}), or an integer -- in which case \code{tree} random trees will be -uniformly sampled.} - -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{concavity}{Determines the degree to which extra steps beyond the first -are penalized. Specify a numeric value to use implied weighting -\insertCite{Goloboff1993}{TreeSearch}; \code{concavity} specifies \emph{k} in -\emph{k} / \emph{e} + \emph{k}. A value of 10 is recommended; -TNT sets a default of 3, but this is too low in some circumstances -\insertCite{Goloboff2018,Smith2019}{TreeSearch}. -Better still explore the sensitivity of results under a range of -concavity values, e.g. \code{k = 2 ^ (1:7)}. -Specify \code{Inf} to weight each additional step equally. -Specify \code{'profile'} to employ profile parsimony \insertCite{Faith2001}{TreeSearch}.} - -\item{\dots}{unused; allows additional parameters specified within \dots to be -received by the function without throwing an error.} -} -\value{ -\code{TreeLength()} returns a numeric vector containing the score for -each tree. -} -\description{ -\code{TreeLength()} uses the Morphy library \insertCite{Brazeau2017}{TreeSearch} -to calculate a parsimony score for a tree, handling inapplicable data -according to the algorithm of \insertCite{Brazeau2019;textual}{TreeSearch}. -Tree scoring can employ implied weights \insertCite{Goloboff1993}{TreeSearch} -or profile parsimony \insertCite{Faith2001}{TreeSearch}. -} -\examples{ -data("inapplicable.datasets") -tree <- TreeTools::BalancedTree(inapplicable.phyData[[1]]) -TreeLength(tree, inapplicable.phyData[[1]]) -TreeLength(tree, inapplicable.phyData[[1]], concavity = 10) -TreeLength(tree, inapplicable.phyData[[1]], concavity = 'profile') -TreeLength(5, inapplicable.phyData[[1]]) -} -\references{ -\insertAllCited{} -} -\seealso{ -\itemize{ -\item Conduct tree search using \code{\link[=MaximizeParsimony]{MaximizeParsimony()}} (command line), -\code{\link[=EasyTrees]{EasyTrees()}} (graphical user interface), or \code{\link[=TreeSearch]{TreeSearch()}} -(custom optimality criteria). -\item See score for each character: \code{\link[=CharacterLength]{CharacterLength()}}. -} - -Other tree scoring: -\code{\link{CharacterLength}()}, -\code{\link{MinimumLength}()}, -\code{\link{MorphyTreeLength}()} -} -\author{ -Martin R. Smith (using Morphy C library, by Martin Brazeau) -} -\concept{tree scoring} diff --git a/man/TreeSearch.Rd b/man/TreeSearch.Rd deleted file mode 100644 index 4fcc12a07..000000000 --- a/man/TreeSearch.Rd +++ /dev/null @@ -1,150 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/CustomSearch.R, R/IWScore.R, -% R/TreeSearch_utilities.R -\name{EdgeListSearch} -\alias{EdgeListSearch} -\alias{TreeSearch} -\alias{IWTreeSearch} -\alias{EmptyPhyDat} -\alias{DoNothing} -\title{Search for most parsimonious trees} -\usage{ -EdgeListSearch( - edgeList, - dataset, - TreeScorer = MorphyLength, - EdgeSwapper = RootedTBRSwap, - maxIter = 100, - maxHits = 20, - bestScore = NULL, - stopAtScore = NULL, - stopAtPeak = FALSE, - stopAtPlateau = 0L, - verbosity = 1L, - ... -) - -TreeSearch( - tree, - dataset, - InitializeData = PhyDat2Morphy, - CleanUpData = UnloadMorphy, - TreeScorer = MorphyLength, - EdgeSwapper = RootedTBRSwap, - maxIter = 100L, - maxHits = 20L, - stopAtPeak = FALSE, - stopAtPlateau = 0L, - verbosity = 1L, - ... -) - -IWTreeSearch(...) - -EmptyPhyDat(tree) - -DoNothing(...) -} -\arguments{ -\item{edgeList}{a list containing the following: -- vector of integers corresponding to the parent of each edge in turn -- vector of integers corresponding to the child of each edge in turn -- (optionally) score of the tree -- (optionally, if score provided) number of times this score has been hit} - -\item{dataset}{A phylogenetic data matrix of class \code{\link[phangorn]{phyDat}}, -whose names correspond to the labels of any accompanying tree.} - -\item{TreeScorer}{function to score a given tree. -The function will be passed three parameters, corresponding to the -\code{parent} and \code{child} entries of a tree's edge list, and a dataset.} - -\item{EdgeSwapper}{a function that rearranges a parent and child vector, -and returns a list with modified vectors; for example \code{\link[=SPRSwap]{SPRSwap()}}.} - -\item{maxIter}{Numeric specifying maximum number of iterations to perform -before abandoning the search.} - -\item{maxHits}{Numeric specifying maximum times to hit the best pscore -before abandoning the search.} - -\item{stopAtPeak}{Logical specifying whether to terminate search once a -subsequent iteration recovers a sub-optimal score. -Will be overridden if a passed function has an attribute \code{stopAtPeak} set by -\code{attr(FunctionName, 'stopAtPeak') <- TRUE}.} - -\item{stopAtPlateau}{Integer. If > 0, tree search will terminate if the score -has not improved after \code{stopAtPlateau} iterations. -Will be overridden if a passed function has an attribute \code{stopAtPlateau} set -by \code{attr(FunctionName, 'stopAtPlateau') <- TRUE}.} - -\item{verbosity}{Numeric specifying level of detail to display in console: -larger numbers provide more verbose feedback to the user.} - -\item{\dots}{further arguments to pass to \code{TreeScorer()}, e.g. \verb{dataset = }.} - -\item{tree}{A fully-resolved starting tree in \code{\link{phylo}} format, -with the desired outgroup. -Edge lengths are not supported and will be removed.} - -\item{InitializeData}{Function that sets up data object to prepare for tree search. -The function will be passed the \code{dataset} parameter. -Its return value will be passed to \code{TreeScorer()} and \code{CleanUpData()}.} - -\item{CleanUpData}{Function to destroy data object on function exit. -The function will be passed the value returned by \code{InitializeData()}.} -} -\value{ -\code{TreeSearch()} returns a tree, with an attribute \code{pscore} conveying its -parsimony score. -#' Note that the parsimony score will be inherited from the tree's -attributes, which is only valid if it was generated using the same -\code{data} that is passed here. - -\code{EmptyPhyDat()} returns a \code{phyDat} object comprising a single -null character, coded with state zero for every leaf in \code{tree}. -} -\description{ -Run standard search algorithms (\acronym{NNI}, \acronym{SPR} or \acronym{TBR}) -to search for a more parsimonious tree. - -For detailed documentation of the 'TreeSearch' package, including full -instructions for loading phylogenetic data into R and initiating and -configuring tree search, see the -\href{https://ms609.github.io/TreeSearch/}{package documentation}. -} -\section{Functions}{ -\itemize{ -\item \code{EdgeListSearch}: Tree search from edge lists -}} - -\examples{ -data('Lobo', package='TreeTools') -njtree <- TreeTools::NJTree(Lobo.phy) - -## Only run examples in interactive R sessions -if (interactive()) { - TreeSearch(njtree, Lobo.phy, maxIter = 20, EdgeSwapper = NNISwap) - TreeSearch(njtree, Lobo.phy, maxIter = 20, EdgeSwapper = RootedSPRSwap) - TreeSearch(njtree, Lobo.phy, maxIter = 20, EdgeSwapper = TBRSwap) -} -} -\seealso{ -\itemize{ -\item \code{\link{Fitch}}, calculates parsimony score; -\item \code{\link{RootedNNI}}, conducts tree rearrangements; -\item \code{\link{Ratchet}}, alternative heuristic, useful to escape local -optima. -} - -Other custom search functions: -\code{\link{Jackknife}()}, -\code{\link{MorphyBootstrap}()}, -\code{\link{SuccessiveApproximations}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{custom search functions} -\keyword{internal} diff --git a/man/UnloadMorphy.Rd b/man/UnloadMorphy.Rd deleted file mode 100644 index 9930907f9..000000000 --- a/man/UnloadMorphy.Rd +++ /dev/null @@ -1,60 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{UnloadMorphy} -\alias{UnloadMorphy} -\title{Destroy a Morphy object} -\usage{ -UnloadMorphy(morphyObj) -} -\arguments{ -\item{morphyObj}{Object of class \code{morphy}, perhaps created with -\code{\link[=PhyDat2Morphy]{PhyDat2Morphy()}}.} -} -\value{ -Morphy error code, decipherable using \code{\link{mpl_translate_error}} -} -\description{ -Destroys a previously-created Morphy object. -} -\details{ -Best practice is to call \code{morphyObj <- UnloadMorphy(morphyObj)} -Failure to do so will cause a crash if \code{UnloadMorphy()} is called on an -object that has already been destroyed -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin R. Smith -} -\concept{Morphy API functions} diff --git a/man/WithOneExtraStep.Rd b/man/WithOneExtraStep.Rd deleted file mode 100644 index c5137cd34..000000000 --- a/man/WithOneExtraStep.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pp_info_extra_step.r -\name{WithOneExtraStep} -\alias{WithOneExtraStep} -\title{Number of trees with one extra step} -\usage{ -WithOneExtraStep(...) -} -\arguments{ -\item{\dots}{Vector or series of integers specifying the number of leaves -bearing each distinct non-ambiguous token.} -} -\description{ -Number of trees with one extra step -} -\examples{ -WithOneExtraStep(1, 2, 3) -} diff --git a/man/cSPR.Rd b/man/cSPR.Rd deleted file mode 100644 index b0467e389..000000000 --- a/man/cSPR.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SPR.R -\name{cSPR} -\alias{cSPR} -\title{\code{cSPR()} expects a tree rooted on a single tip.} -\usage{ -cSPR(tree, whichMove = NULL) -} -\arguments{ -\item{tree}{A tree of class \code{\link{phylo}}.} - -\item{whichMove}{Integer specifying which SPR move index to perform.} -} -\description{ -\code{cSPR()} expects a tree rooted on a single tip. -} -\examples{ -tree <- TreeTools::BalancedTree(8) - -# Tree must be rooted on leaf -tree <- TreeTools::RootTree(tree, 1) - -# Random rearrangement -cSPR(tree) - -# Specific rearrangement -cSPR(tree, 9) -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} diff --git a/man/dot-CombineResults.Rd b/man/dot-CombineResults.Rd deleted file mode 100644 index 3e16ba8fb..000000000 --- a/man/dot-CombineResults.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/MaximizeParsimony.R -\name{.CombineResults} -\alias{.CombineResults} -\alias{.ReplaceResults} -\title{Combine two edge matrices} -\usage{ -.CombineResults(x, y, stage) - -.ReplaceResults(old, new, stage) -} -\arguments{ -\item{x, y}{3D arrays, each slice containing an edge matrix from a tree -of class \code{phylo}.} - -\item{stage}{Integer specifying element of \code{firstHit} in which new hits -should be recorded.} - -\item{old}{old array of edge matrices with \code{firstHit} attribute.} - -\item{new}{new array of edge matrices.} -} -\value{ -A single 3D array containing each unique edge matrix from (\code{x} and) -\code{y}, with a \code{firstHit} attribute as documented in \code{\link[=MaximizeParsimony]{MaximizeParsimony()}}. -} -\description{ -Combine two edge matrices -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\keyword{internal} diff --git a/man/dot-GapHandler.Rd b/man/dot-GapHandler.Rd deleted file mode 100644 index 71c2e38a1..000000000 --- a/man/dot-GapHandler.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{.GapHandler} -\alias{.GapHandler} -\title{Translate a gap treatment into a string in the format expected by Morphy} -\usage{ -.GapHandler(gap) -} -\arguments{ -\item{gap}{Character vector: how should gaps be handled?} -} -\value{ -Character string that can be translated into a gap handling strategy -by Morphy. -} -\description{ -Translate a gap treatment into a string in the format expected by Morphy -} -\keyword{internal} diff --git a/man/dot-UniqueExceptHits.Rd b/man/dot-UniqueExceptHits.Rd deleted file mode 100644 index 96815c389..000000000 --- a/man/dot-UniqueExceptHits.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Ratchet.R -\name{.UniqueExceptHits} -\alias{.UniqueExceptHits} -\title{Unique trees (ignoring 'hits' attribute)} -\usage{ -.UniqueExceptHits(trees) -} -\description{ -Unique trees (ignoring 'hits' attribute) -} -\author{ -Martin R. Smith -} -\keyword{internal} diff --git a/man/is.morphyPtr.Rd b/man/is.morphyPtr.Rd deleted file mode 100644 index 2e6240ad5..000000000 --- a/man/is.morphyPtr.Rd +++ /dev/null @@ -1,57 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{is.morphyPtr} -\alias{is.morphyPtr} -\title{Is an object a valid Morphy object?} -\usage{ -is.morphyPtr(morphyObj) -} -\arguments{ -\item{morphyObj}{Object of class \code{morphy}, perhaps created with -\code{\link[=PhyDat2Morphy]{PhyDat2Morphy()}}.} -} -\value{ -\code{is.morphyPtr()} returns \code{TRUE} if \code{morphyObj} is a valid morphy -pointer, \code{FALSE} otherwise. -} -\description{ -Is an object a valid Morphy object? -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -\href{https://smithlabdurham.github.io/}{Martin R. Smith} -(\href{mailto:martin.smith@durham.ac.uk}{martin.smith@durham.ac.uk}) -} -\concept{Morphy API functions} diff --git a/man/mpl_apply_tipdata.Rd b/man/mpl_apply_tipdata.Rd deleted file mode 100644 index 6cf9eeffe..000000000 --- a/man/mpl_apply_tipdata.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_apply_tipdata} -\alias{mpl_apply_tipdata} -\title{Commits parameters prior to nodal set calculations.} -\usage{ -mpl_apply_tipdata(morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -A Morphy error code. -} -\description{ -Once the caller is satisfied with the setup of types, weights, -and partitioning, this function must be called, thereby committing the -parameters until any changes are made. If no character types have been -assigned, the function will fail with an error code. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_attach_rawdata.Rd b/man/mpl_attach_rawdata.Rd deleted file mode 100644 index 9262a169b..000000000 --- a/man/mpl_attach_rawdata.Rd +++ /dev/null @@ -1,60 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_attach_rawdata} -\alias{mpl_attach_rawdata} -\title{Attach raw character state data (i.e. tip data).} -\usage{ -mpl_attach_rawdata(rawdata, morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} - -\item{rawmatrix}{C-style string corresponding to the tip data for each taxon in turn.} -} -\value{ -Morphy error code. -} -\description{ -Attaches a raw data character state matrix in the form of a C-style -(i.e. NULL-terminated) string. This can be the matrix block extracted from a -Nexus file or an \code{xread} table format. -The matrix should contain no leaf labels. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_attach_symbols.Rd b/man/mpl_attach_symbols.Rd deleted file mode 100644 index 27e2f0189..000000000 --- a/man/mpl_attach_symbols.Rd +++ /dev/null @@ -1,64 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_attach_symbols} -\alias{mpl_attach_symbols} -\title{Attach a caller-specified list of symbols.} -\usage{ -mpl_attach_symbols(symbols, morphyobj) -} -\arguments{ -\item{symbols}{A C-style (i.e. NULL-terminated) string of valid state symbols.} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -Morphy error code. -} -\description{ -Allows the caller to specify a list of symbols in the data matrix, -otherwise, the symbols list used by Morphy will be extracted from the matrix. -The symbols list must match the symbols provided in the matrix. When Morphy -extracts symbols from the matrix, their ordering is alphanumeric, according to -their ASCII codes (i.e. "+0123...ABCD...abcd..."). Loading a user-specified -symbols list will override this ordering. Symbols loaded in either the list or -the matrix must be valid Morphy character state symbols as defined in the -statedata.h header file. The list must end with a semicolon. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_delete_Morphy.Rd b/man/mpl_delete_Morphy.Rd deleted file mode 100644 index 3c53d1af3..000000000 --- a/man/mpl_delete_Morphy.Rd +++ /dev/null @@ -1,56 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_delete_Morphy} -\alias{mpl_delete_Morphy} -\title{Destroys an instance of a Morphy object.} -\usage{ -mpl_delete_Morphy(morphyobj) -} -\arguments{ -\item{morphyobj}{A Morphy object to be destroyed.} -} -\value{ -A Morphy error code. -} -\description{ -Destroys an instance of the Morphy object, calling all -destructor for internal object completely returning the memory to the system. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_delete_rawdata.Rd b/man/mpl_delete_rawdata.Rd deleted file mode 100644 index 78b9067f0..000000000 --- a/man/mpl_delete_rawdata.Rd +++ /dev/null @@ -1,56 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_delete_rawdata} -\alias{mpl_delete_rawdata} -\title{Deletes the caller-input data.} -\usage{ -mpl_delete_rawdata(morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -Morphy error code. -} -\description{ -Deletes all of the user-input data and restores all parameters -to their original values, except for the dimensions of the matrix. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Thomas Guillerme -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_first_down_recon.Rd b/man/mpl_first_down_recon.Rd deleted file mode 100644 index e1cc2f9f6..000000000 --- a/man/mpl_first_down_recon.Rd +++ /dev/null @@ -1,67 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_first_down_recon} -\alias{mpl_first_down_recon} -\title{Reconstructs the first (downpass) nodal reconstructions} -\usage{ -mpl_first_down_recon(node_id, left_id, right_id, morphyobj) -} -\arguments{ -\item{node_id}{The index of the node being reconstructed.} - -\item{left_id}{The index of the left descendant.} - -\item{right_id}{The index of the right descendant.} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -The integral parsimony length (right now) -} -\description{ -Reconstructs the preliminary nodal set for all characters for a -particular node. This function is called over a postorder sequence of internal -nodes where left and right descendants are known. -Because this function needs to be fairly high-performance, it does not do much -checking for parameter validity, thus unsafe usage of this function might not -be caught. It is up to calling functions to ensure that the appropriate -parameters have been set before use. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_first_up_recon.Rd b/man/mpl_first_up_recon.Rd deleted file mode 100644 index ddf87ae73..000000000 --- a/man/mpl_first_up_recon.Rd +++ /dev/null @@ -1,69 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_first_up_recon} -\alias{mpl_first_up_recon} -\title{Reconstructs the second (uppass) nodal reconstructions.} -\usage{ -mpl_first_up_recon(node_id, left_id, right_id, anc_id, morphyobj) -} -\arguments{ -\item{node_id}{The index of the node being reconstructed.} - -\item{left_id}{The index of the left descendant.} - -\item{right_id}{The index of the right descendant.} - -\item{anc_id}{The index of the immediate ancestor of the node.} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -A null value (for now). -} -\description{ -Reconstructs second-pass nodal sets. For normal (all-applicable) -characters, this is the final pass. This function is called over a preorder -sequence of nodes where left, right, and ancestral nodes are known. -Because this function needs to be fairly high-performance, it does not do much -checking for parameter validity, thus unsafe usage of this function might not -be caught. It is up to calling functions to ensure that the appropriate -parameters have been set before use. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Thomas Guillerme -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_get_charac_weight.Rd b/man/mpl_get_charac_weight.Rd deleted file mode 100644 index 12f0e4f42..000000000 --- a/man/mpl_get_charac_weight.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_get_charac_weight} -\alias{mpl_get_charac_weight} -\title{Retrieve the weight of a character in the dataset} -\usage{ -mpl_get_charac_weight(charID, morphyobj) -} -\arguments{ -\item{charID}{Number of the character (i.e. first character is number 1)} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -A list, detailing (item 1) the exact weight of the character; (item 2) the integer -approximation used by Morphy. -} -\description{ -Gets the weights of a character in the dataset. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin R. Smith -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_get_gaphandl.Rd b/man/mpl_get_gaphandl.Rd deleted file mode 100644 index 573235c27..000000000 --- a/man/mpl_get_gaphandl.Rd +++ /dev/null @@ -1,55 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_get_gaphandl} -\alias{mpl_get_gaphandl} -\alias{mpl_set_gaphandl} -\title{Get / set gap handler from a Morphy object.} -\usage{ -mpl_get_gaphandl(morphyobj) - -mpl_set_gaphandl(handl, morphyobj) -} -\value{ -\code{mpl_get_gaphandl()} returns an integer corresponding to the gap -handling approach. - -\code{mpl_set_gaphandl()} returns a Morphy error code. -} -\description{ -0 = inapplicable; 1 = missing; 2 = extra -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_get_num_charac.Rd b/man/mpl_get_num_charac.Rd deleted file mode 100644 index e6f80dfb3..000000000 --- a/man/mpl_get_num_charac.Rd +++ /dev/null @@ -1,55 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_get_num_charac} -\alias{mpl_get_num_charac} -\title{Retrieve the number of character (columns) in the dataset.} -\usage{ -mpl_get_num_charac(morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -The number of internal nodes. -} -\description{ -Retrieves the number of character (columns) in the dataset. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_get_num_internal_nodes.Rd b/man/mpl_get_num_internal_nodes.Rd deleted file mode 100644 index 262a73c4f..000000000 --- a/man/mpl_get_num_internal_nodes.Rd +++ /dev/null @@ -1,57 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_get_num_internal_nodes} -\alias{mpl_get_num_internal_nodes} -\title{Gets the number of internal nodal reconstruction sets being used by -MorphyLib.} -\usage{ -mpl_get_num_internal_nodes(morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -The number of internal nodes. -} -\description{ -Gets the number of internal nodal reconstruction sets being used -by MorphyLib. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_get_numtaxa.Rd b/man/mpl_get_numtaxa.Rd deleted file mode 100644 index 02055189a..000000000 --- a/man/mpl_get_numtaxa.Rd +++ /dev/null @@ -1,55 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_get_numtaxa} -\alias{mpl_get_numtaxa} -\title{Retrieve the number of taxa (rows) in the dataset.} -\usage{ -mpl_get_numtaxa(morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -The number of taxa if success, otherwise an error code. -} -\description{ -Retrieves the number of taxa (rows) in the dataset. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_get_symbols.Rd b/man/mpl_get_symbols.Rd deleted file mode 100644 index 41f87af06..000000000 --- a/man/mpl_get_symbols.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_get_symbols} -\alias{mpl_get_symbols} -\title{Retrieves the current list of symbols.} -\usage{ -mpl_get_symbols(morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -A C-style (null-terminated) string of the character state symbols -being used. NULL if failure. -} -\description{ -Returns a pointer to the string of character state symbols -currently being used by Morphy (i.e. either the list of symbols extracted -from the matrix, or the caller-specified values). -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_init_Morphy.Rd b/man/mpl_init_Morphy.Rd deleted file mode 100644 index 487023b9a..000000000 --- a/man/mpl_init_Morphy.Rd +++ /dev/null @@ -1,61 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_init_Morphy} -\alias{mpl_init_Morphy} -\title{Sets up the dimensions of the dataset.} -\usage{ -mpl_init_Morphy(numtaxa, numchars, morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} - -\item{ntax}{The number of taxa (or tips/terminals).} - -\item{nchar}{The number of characters (i.e. transformation series) in the -data set.} -} -\value{ -Morphy error code. -} -\description{ -Provides initial dimensions for the dataset, which will -constrain any input matrix supplied to Morphy. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_new_Morphy.Rd b/man/mpl_new_Morphy.Rd deleted file mode 100644 index c0e94fb11..000000000 --- a/man/mpl_new_Morphy.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_new_Morphy} -\alias{mpl_new_Morphy} -\title{Creates a new instance of a Morphy object} -\usage{ -mpl_new_Morphy() -} -\value{ -A void pointer to the Morphy instance. NULL if unsuccessful. -} -\description{ -Creates a new empty Morphy object. All fields are unpopulated -and uninitialised. -} -\examples{ -morphyObj <- mpl_new_Morphy() # Create new object -## Do some stuff ... ## -mpl_delete_Morphy(morphyObj) # Delete when done - -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_second_down_recon.Rd b/man/mpl_second_down_recon.Rd deleted file mode 100644 index 9f160677c..000000000 --- a/man/mpl_second_down_recon.Rd +++ /dev/null @@ -1,70 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_second_down_recon} -\alias{mpl_second_down_recon} -\title{Performs the second nodal reconstructions for characters with -inapplicability.} -\usage{ -mpl_second_down_recon(node_id, left_id, right_id, morphyobj) -} -\arguments{ -\item{node_id}{The index of the node being reconstructed.} - -\item{left_id}{The index of the left descendant.} - -\item{right_id}{The index of the right descendant.} - -\item{morphyobj}{An instance of the Morphy object.} - -\item{anc_id}{The index of the immediate ancestor of the node.} -} -\value{ -The integral parsimony length (right now) -} -\description{ -Updates the nodal sets that had ambiguous unions with the -inapplicable state and calculates steps involving applicable states after -the update. -Because this function needs to be fairly high-performance, it does not do much -checking for parameter validity, thus unsafe usage of this function might not -be caught. It is up to calling functions to ensure that the appropriate -parameters have been set before use. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Thomas Guillerme -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_second_up_recon.Rd b/man/mpl_second_up_recon.Rd deleted file mode 100644 index 0310d59cb..000000000 --- a/man/mpl_second_up_recon.Rd +++ /dev/null @@ -1,70 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_second_up_recon} -\alias{mpl_second_up_recon} -\title{Finalises the ancestral state reconstructions for characters with -inapplicable values.} -\usage{ -mpl_second_up_recon(node_id, left_id, right_id, anc_id, morphyobj) -} -\arguments{ -\item{node_id}{The index of the node being reconstructed.} - -\item{left_id}{The index of the left descendant.} - -\item{right_id}{The index of the right descendant.} - -\item{anc_id}{The index of the immediate ancestor of the node.} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -The integral parsimony length (right now) -} -\description{ -Finalises the nodal sets for any characters that may have involved -the inapplicable token and counts excess regions of applicability at nodes -having at least two descendant subtrees that possess any applicable characters. -Because this function needs to be fairly high-performance, it does not do much -checking for parameter validity, thus unsafe usage of this function might not -be caught. It is up to calling functions to ensure that the appropriate -parameters have been set before use. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Thomas Guillerme -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_set_charac_weight.Rd b/man/mpl_set_charac_weight.Rd deleted file mode 100644 index 3c936c6f1..000000000 --- a/man/mpl_set_charac_weight.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_set_charac_weight} -\alias{mpl_set_charac_weight} -\title{Set the weight of a character in the dataset} -\usage{ -mpl_set_charac_weight(charID, weight, morphyobj) -} -\arguments{ -\item{charID}{Number of the character (i.e. first character is number 1)} - -\item{weight}{Weight to assign} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -An error code. -} -\description{ -Sets the weight of a character in the dataset. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin R. Smith -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_set_num_internal_nodes.Rd b/man/mpl_set_num_internal_nodes.Rd deleted file mode 100644 index 800effe8e..000000000 --- a/man/mpl_set_num_internal_nodes.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_set_num_internal_nodes} -\alias{mpl_set_num_internal_nodes} -\title{Sets the number of internal nodes in the dataset} -\usage{ -mpl_set_num_internal_nodes(numnodes, morphyobj) -} -\arguments{ -\item{morphyobj}{An instance of the Morphy object.} - -\item{nnodes}{The desired number of internal nodes.} -} -\value{ -A Morphy error code. -} -\description{ -This specifies the number of internal nodes over which -reconstruction sets need to be made. It is up to the caller to ensure the -correct number of nodes and the relationships between them. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_set_parsim_t.Rd b/man/mpl_set_parsim_t.Rd deleted file mode 100644 index 6251ba55d..000000000 --- a/man/mpl_set_parsim_t.Rd +++ /dev/null @@ -1,62 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_set_parsim_t} -\alias{mpl_set_parsim_t} -\title{Sets a character's parsimony function type} -\usage{ -mpl_set_parsim_t(char_id, tname = "typename", morphyobj) -} -\arguments{ -\item{char_id}{The number of the character (transformation series) as defined -in the input matrix. The first character is numbered 1 (one).} - -\item{tname}{The parsimony function type as defined in morphydefs.h} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -A Morphy error code. -} -\description{ -Set the parsimony function type to one defined in the -morphydefs.h header file. Setting the character to type NONE_T will also -cause it to be excluded from any further calculations. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin Brazeau -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_translate_error.Rd b/man/mpl_translate_error.Rd deleted file mode 100644 index 5445f6f25..000000000 --- a/man/mpl_translate_error.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_translate_error} -\alias{mpl_translate_error} -\title{Converts a numeric error code to human-readable format} -\usage{ -mpl_translate_error(errorCode) -} -\arguments{ -\item{errorCode}{Non-positive integer to be converted} -} -\value{ -A character string corresponding to the provided error code -} -\description{ -Converts a numeric error code to human-readable format -} -\examples{ -mpl_translate_error(-1) # "ERR_INVALID_SYMBOL" - -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Martin R. Smith -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_update_lower_root.Rd b/man/mpl_update_lower_root.Rd deleted file mode 100644 index ceb24461a..000000000 --- a/man/mpl_update_lower_root.Rd +++ /dev/null @@ -1,65 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_update_lower_root} -\alias{mpl_update_lower_root} -\title{Updates the nodal sets for a lower ('dummy') root node} -\usage{ -mpl_update_lower_root(l_root_id, root_id, morphyobj) -} -\arguments{ -\item{l_root_id}{The index of the lower root.} - -\item{root_id}{The index of the upper root node.} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -A Morphy error code. -} -\description{ -If trees are rooted, then Morphy uppass functions -require a lower or 'dummy' root in order to function properly. This -function should be called to set the nodal state sets to the dummy -root. The nodal set will be equal to the set of the root node, unless -there is an ambiguous union of applicable and gap tokens when gaps are -treated as in applicable. In which case, the set union is resolved in -favour of any applicable tokens in the set. -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_tip}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Thomas Guillerme -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/mpl_update_tip.Rd b/man/mpl_update_tip.Rd deleted file mode 100644 index 2e4145f27..000000000 --- a/man/mpl_update_tip.Rd +++ /dev/null @@ -1,70 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphyex.R -\name{mpl_update_tip} -\alias{mpl_update_tip} -\title{Initial update of tip values following uppass reconstruction.} -\usage{ -mpl_update_tip(tip_id, anc_id, morphyobj) -} -\arguments{ -\item{tip_id}{The index of the tip being updated.} - -\item{anc_id}{The index of the tip's immediate ancestor.} - -\item{morphyobj}{An instance of the Morphy object.} -} -\value{ -The integral parsimony length (right now) -} -\description{ -Ambiguous terminal state sets need to be resolved after the first uppass -based on descendant state values in order for local reoptimisation procedures -to be accurate and for inapplicable step counting to proceed accurately. This -function calls updaters for the records of states active on the subtrees, -thereby allowing the second downpass to accurately reconstruct subtree state -activity. -Because this function needs to be fairly high-performance, it does not do much -checking for parameter validity, thus unsafe usage of this function might not -be caught. It is up to calling functions to ensure that the appropriate -parameters have been set before use. -} -\seealso{ -A null value (for now). - -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{summary.morphyPtr}()} -} -\author{ -Thomas Guillerme -} -\concept{Morphy API functions} -\keyword{internal} diff --git a/man/profiles.Rd b/man/profiles.Rd index b0f3c1a27..bcd3f1791 100644 --- a/man/profiles.Rd +++ b/man/profiles.Rd @@ -26,11 +26,5 @@ profile3.5 <- profiles[[8]][[2]][[3]] # Number of trees with _s_ or fewer steps on that character TreeTools::NUnrooted(8) * 2 ^ profile3.5 } -\seealso{ -Other profile parsimony functions: -\code{\link{Carter1}()}, -\code{\link{PrepareDataProfile}()}, -\code{\link{StepInformation}()} -} \concept{profile parsimony functions} \keyword{datasets} diff --git a/man/summary.morphyPtr.Rd b/man/summary.morphyPtr.Rd deleted file mode 100644 index 2cd34950d..000000000 --- a/man/summary.morphyPtr.Rd +++ /dev/null @@ -1,56 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpl_morphy_objects.R -\name{summary.morphyPtr} -\alias{summary.morphyPtr} -\title{Details the attributes of a morphy object} -\usage{ -\method{summary}{morphyPtr}(object, ...) -} -\arguments{ -\item{object}{A Morphy object} - -\item{\dots}{any other parameters...} -} -\value{ -A list detailing the number of taxa, internal nodes, and characters and their weights. -} -\description{ -Details the attributes of a morphy object -} -\seealso{ -Other Morphy API functions: -\code{\link{GapHandler}()}, -\code{\link{MorphyErrorCheck}()}, -\code{\link{MorphyWeights}()}, -\code{\link{PhyDat2Morphy}()}, -\code{\link{SingleCharMorphy}()}, -\code{\link{UnloadMorphy}()}, -\code{\link{is.morphyPtr}()}, -\code{\link{mpl_apply_tipdata}()}, -\code{\link{mpl_attach_rawdata}()}, -\code{\link{mpl_attach_symbols}()}, -\code{\link{mpl_delete_Morphy}()}, -\code{\link{mpl_delete_rawdata}()}, -\code{\link{mpl_first_down_recon}()}, -\code{\link{mpl_first_up_recon}()}, -\code{\link{mpl_get_charac_weight}()}, -\code{\link{mpl_get_gaphandl}()}, -\code{\link{mpl_get_num_charac}()}, -\code{\link{mpl_get_num_internal_nodes}()}, -\code{\link{mpl_get_numtaxa}()}, -\code{\link{mpl_get_symbols}()}, -\code{\link{mpl_init_Morphy}()}, -\code{\link{mpl_new_Morphy}()}, -\code{\link{mpl_second_down_recon}()}, -\code{\link{mpl_second_up_recon}()}, -\code{\link{mpl_set_charac_weight}()}, -\code{\link{mpl_set_num_internal_nodes}()}, -\code{\link{mpl_set_parsim_t}()}, -\code{\link{mpl_translate_error}()}, -\code{\link{mpl_update_lower_root}()}, -\code{\link{mpl_update_tip}()} -} -\author{ -Martin R. Smith -} -\concept{Morphy API functions} diff --git a/src/RMorphy.c b/src/RMorphy.c deleted file mode 100644 index 297e62e6d..000000000 --- a/src/RMorphy.c +++ /dev/null @@ -1,351 +0,0 @@ -#ifdef HAVE_CONFIG_H -# include -#endif - -#include -#include -#include -#include "mpl.h" -#include "RMorphyUtils.h" -#include "RMorphy.h" - -SEXP _R_wrap_mpl_new_Morphy(void) { - Morphy new_Morphy = mpl_new_Morphy(); - SEXP result = PROTECT(R_MakeExternalPtr(new_Morphy, R_NilValue, R_NilValue)); - R_PreserveObject(result); - R_RegisterCFinalizerEx(result, _finalize_Morphy, TRUE); - UNPROTECT(1); - - return result; -} - -void _finalize_Morphy (SEXP MorphyHandl) { - Morphy handl = R_ExternalPtrAddr(MorphyHandl); - if (handl == NULL) return; - mpl_delete_Morphy(handl); - R_ClearExternalPtr(MorphyHandl); - R_ReleaseObject(MorphyHandl); -} - -SEXP _R_wrap_mpl_delete_Morphy(SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - Morphy handl = R_ExternalPtrAddr(MorphyHandl); - if (handl == NULL) { - INTEGER(Rret)[0] = NA_INTEGER; - } else { - INTEGER(Rret)[0] = mpl_delete_Morphy(handl); - R_ReleaseObject(MorphyHandl); - R_ClearExternalPtr(MorphyHandl); - } - UNPROTECT(1); - - return Rret; -} - -SEXP _R_wrap_mpl_init_Morphy(SEXP Rntax, SEXP Rnchar, SEXP MorphHandl) { - int ret = 0; - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - Morphy handl = R_ExternalPtrAddr(MorphHandl); - int ntax = INTEGER(Rntax)[0]; - int nchar = INTEGER(Rnchar)[0]; - - ret = mpl_init_Morphy(ntax, nchar, handl); - - INTEGER(Rret)[0] = ret; - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_get_numtaxa(SEXP MorphHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = mpl_get_numtaxa(R_ExternalPtrAddr(MorphHandl)); - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_get_num_charac(SEXP MorphHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = mpl_get_num_charac(R_ExternalPtrAddr(MorphHandl)); - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_attach_symbols(SEXP Rsymbols, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - int Mret = 0; - const char *Msymbols = CHAR(asChar(Rsymbols)); - - Mret = mpl_attach_symbols(Msymbols, R_ExternalPtrAddr(MorphyHandl)); - INTEGER(Rret)[0] = Mret; - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_get_symbols(SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(STRSXP, 1)); - - char* symbols = mpl_get_symbols(R_ExternalPtrAddr(MorphyHandl)); - - Rret = mkString(symbols); - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_attach_rawdata(SEXP Rmatrix, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - int Mret = 0; - const char *Mmatrix = CHAR(asChar(Rmatrix)); - - Mret = mpl_attach_rawdata(Mmatrix, R_ExternalPtrAddr(MorphyHandl)); - - INTEGER(Rret)[0] = Mret; - UNPROTECT(1); - - return Rret; -} - -SEXP _R_wrap_mpl_delete_rawdata(SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - Morphy handl = R_ExternalPtrAddr(MorphyHandl); - int ret = 0; - - ret = mpl_delete_rawdata(handl); - - INTEGER(Rret)[0] = ret; - UNPROTECT(1); - - return Rret; -} - -SEXP _R_wrap_mpl_set_parsim_t(SEXP RcharID, SEXP Rchtype, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - MPLchtype chtype; - int Mret = 0; - - const char* chtypename = CHAR(asChar(Rchtype)); - - chtype = _R_mpl_str2chtype(chtypename); - Mret = mpl_set_parsim_t(INTEGER(RcharID)[0], chtype, - R_ExternalPtrAddr(MorphyHandl)); - - INTEGER(Rret)[0] = Mret; - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_set_gaphandl(SEXP Rgaptype, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - MPLgap_t gaptype; - int Mret = 0; - - const char* gaptypename = CHAR(asChar(Rgaptype)); - - gaptype = _R_mpl_str2gaptype(gaptypename); - Mret = mpl_set_gaphandl(gaptype, R_ExternalPtrAddr(MorphyHandl)); - - INTEGER(Rret)[0] = Mret; - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_get_gaphandl(SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - int Mret = 0; - - Mret = mpl_query_gaphandl(R_ExternalPtrAddr(MorphyHandl)); - - INTEGER(Rret)[0] = Mret; - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_set_num_internal_nodes(SEXP Rnnodes, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = mpl_set_num_internal_nodes - (INTEGER(Rnnodes)[0], - R_ExternalPtrAddr(MorphyHandl)); - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_get_num_internal_nodes(SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = mpl_get_num_internal_nodes - (R_ExternalPtrAddr(MorphyHandl)); - - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_apply_tipdata(SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = mpl_apply_tipdata(R_ExternalPtrAddr(MorphyHandl)); - - UNPROTECT(1); - return Rret; -} - - -SEXP _R_wrap_mpl_set_charac_weight(SEXP RcharID, SEXP Rweight, - SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - INTEGER(Rret)[0] = mpl_set_charac_weight(INTEGER(RcharID)[0], REAL(Rweight)[0], - R_ExternalPtrAddr(MorphyHandl)); - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_get_charac_weight(SEXP RcharID, SEXP MorphyHandl) { - SEXP Rret, Wapprox, Wexact; - PROTECT(Rret = allocVector(VECSXP, 2)); - PROTECT(Wapprox = allocVector(INTSXP, 1)); - PROTECT(Wexact = allocVector(REALSXP, 1)); - - INTEGER(Wapprox)[0] = mpl_get_charac_weight(REAL(Wexact), INTEGER(RcharID)[0], - R_ExternalPtrAddr(MorphyHandl)); - SET_VECTOR_ELT(Rret, 0, Wapprox); - SET_VECTOR_ELT(Rret, 1, Wexact); - UNPROTECT(3); - return Rret; -} - -SEXP _R_wrap_mpl_first_down_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, - SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = - mpl_first_down_recon(INTEGER(Rnode_id)[0], INTEGER(Rleft_id)[0], - INTEGER(Rright_id)[0], - R_ExternalPtrAddr(MorphyHandl)); - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_first_up_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, - SEXP Ranc_id, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = - mpl_first_up_recon(INTEGER(Rnode_id)[0], INTEGER(Rleft_id)[0], - INTEGER(Rright_id)[0], INTEGER(Ranc_id)[0], - R_ExternalPtrAddr(MorphyHandl)); - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_second_down_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, - SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = - mpl_second_down_recon(INTEGER(Rnode_id)[0], INTEGER(Rleft_id)[0], - INTEGER(Rright_id)[0], - R_ExternalPtrAddr(MorphyHandl)); - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_second_up_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, - SEXP Ranc_id, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = - mpl_second_up_recon(INTEGER(Rnode_id)[0], INTEGER(Rleft_id)[0], - INTEGER(Rright_id)[0], INTEGER(Ranc_id)[0], - R_ExternalPtrAddr(MorphyHandl)); - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_update_tip(SEXP tip_id, SEXP anc_id, SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = - mpl_update_tip(INTEGER(tip_id)[0], INTEGER(anc_id)[0], - R_ExternalPtrAddr(MorphyHandl)); - UNPROTECT(1); - return Rret; -} - -SEXP _R_wrap_mpl_update_lower_root(SEXP lower_id, SEXP upper_id, - SEXP MorphyHandl) { - SEXP Rret = PROTECT(allocVector(INTSXP, 1)); - - INTEGER(Rret)[0] = - mpl_update_lower_root(INTEGER(lower_id)[0], INTEGER(upper_id)[0], - R_ExternalPtrAddr(MorphyHandl)); - UNPROTECT(1); - return Rret; -} - -void morphy_length (const int *ancestor, const int *left, const int *right, - Morphy handl, int *score) { - int i; - const int n_taxa = mpl_get_numtaxa(handl); - const int n_internal = mpl_get_num_internal_nodes(handl); - const int root_node = n_taxa; - const int max_node = n_taxa + n_internal; - - for (i = max_node - 1; i >= n_taxa; i--) { /* First Downpass */ - *score += mpl_first_down_recon(i, left[i - n_taxa], right[i - n_taxa], - handl); - } - /* We could use a spare internal node with index = max_node as a dummy root node. - * Instead: just pass the root node as its own ancestor. */ - mpl_update_lower_root(root_node, root_node, handl); - - for (i = root_node; i != max_node; i++) { /* First uppass: internal nodes */ - *score += mpl_first_up_recon(i, left[i - n_taxa], right[i - n_taxa], - ancestor[i], handl); - } - for (i = 0; i != n_taxa; i++) { /* First uppass: update tips */ - mpl_update_tip(i, ancestor[i], handl); - } - - for (i = max_node - 1; i >= n_taxa; i--) { /* Second Downpass */ - *score += mpl_second_down_recon(i, left[i - n_taxa], right[i - n_taxa], - handl); - } - -} - -SEXP MORPHYLENGTH(SEXP R_ancestors, SEXP R_left, SEXP R_right, SEXP MorphyHandl) { - Morphy handl = R_ExternalPtrAddr(MorphyHandl); - /* R_descendants and R_ancestors have already had one subtracted to convert - * them to an index */ - const int - /* INTEGER gives pointer to first element of an R vector*/ - *ancestor = INTEGER(R_ancestors), - *left = INTEGER(R_left), - *right = INTEGER(R_right) - ; - - /* Declare and protect result, to return to R */ - SEXP Rres = PROTECT(allocVector(INTSXP, 1)); - - /* Initialize return variables */ - int *score; - score = INTEGER(Rres); - *score = 0; - morphy_length(ancestor, left, right, handl, score); /* Updates score */ - - UNPROTECT(1); - return Rres; -} diff --git a/src/RMorphy.h b/src/RMorphy.h deleted file mode 100644 index 44738f78a..000000000 --- a/src/RMorphy.h +++ /dev/null @@ -1,36 +0,0 @@ -#ifdef HAVE_CONFIG_H -# include -#endif - -#include -#include -#include -#include "mpl.h" -#include "RMorphyUtils.h" - -SEXP _R_wrap_mpl_new_Morphy(void); -void _finalize_Morphy(SEXP MorphyHandl); -SEXP _R_wrap_mpl_delete_Morphy(SEXP MorphyHandl); -SEXP _R_wrap_mpl_init_Morphy(SEXP Rntax, SEXP Rnchar, SEXP MorphHandl); -SEXP _R_wrap_mpl_get_numtaxa(SEXP MorphHandl); -SEXP _R_wrap_mpl_get_num_charac(SEXP MorphHandl); -SEXP _R_wrap_mpl_attach_symbols(SEXP Rsymbols, SEXP MorphyHandl); -SEXP _R_wrap_mpl_get_symbols(SEXP MorphyHandl); -SEXP _R_wrap_mpl_attach_rawdata(SEXP Rmatrix, SEXP MorphyHandl); -SEXP _R_wrap_mpl_delete_rawdata(SEXP MorphyHandl); -SEXP _R_wrap_mpl_set_parsim_t(SEXP RcharID, SEXP Rchtype, SEXP MorphyHandl); -SEXP _R_wrap_mpl_get_gaphandl(SEXP MorphyHandl); -SEXP _R_wrap_mpl_set_gaphandl(SEXP Rgaptype, SEXP MorphyHandl); -SEXP _R_wrap_mpl_set_num_internal_nodes(SEXP Rnnodes, SEXP MorphyHandl); -SEXP _R_wrap_mpl_get_num_internal_nodes(SEXP MorphyHandl); -SEXP _R_wrap_mpl_apply_tipdata(SEXP MorphyHandl); -SEXP _R_wrap_mpl_set_charac_weight(SEXP RcharID, SEXP Rweight, SEXP MorphyHandl); -SEXP _R_wrap_mpl_get_charac_weight(SEXP RcharID, SEXP MorphyHandl); -SEXP _R_wrap_mpl_first_down_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, SEXP MorphyHandl); -SEXP _R_wrap_mpl_first_up_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, SEXP Ranc_id, SEXP MorphyHandl); -SEXP _R_wrap_mpl_second_down_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, SEXP MorphyHandl); -SEXP _R_wrap_mpl_second_up_recon(SEXP Rnode_id, SEXP Rleft_id, SEXP Rright_id, SEXP Ranc_id, SEXP MorphyHandl); -SEXP _R_wrap_mpl_update_tip(SEXP tip_id, SEXP anc_id, SEXP MorphyHandl); -SEXP _R_wrap_mpl_update_lower_root(SEXP lower_id, SEXP upper_id, SEXP MorphyHandl); -void morphy_length(const int *ancestor, const int *left, const int *right, Morphy handl, int *score); -SEXP MORPHYLENGTH(SEXP R_ancestors, SEXP R_left, SEXP R_right, SEXP MorphyHandl); \ No newline at end of file diff --git a/src/RMorphyUtils.c b/src/RMorphyUtils.c deleted file mode 100644 index 0c3994136..000000000 --- a/src/RMorphyUtils.c +++ /dev/null @@ -1,40 +0,0 @@ -#include "mpl.h" -#include "RMorphyUtils.h" - -MPLchtype _R_mpl_str2chtype(const char *chtypename) -{ - - if(!strcasecmp(chtypename, "fitch")){ - return FITCH_T; - } - else if(!strcasecmp(chtypename, "wagner")){ - return WAGNER_T; - } - else if(!strcasecmp(chtypename, "dollo")){ - return DOLLO_T; - } - else if(!strcasecmp(chtypename, "irreversible")){ - return IRREVERSIBLE_T; - } - else if(!strcasecmp(chtypename, "user")){ - return USERTYPE_T; - } - - return MAX_CTYPE; -} - -MPLgap_t _R_mpl_str2gaptype(const char *chtypename) -{ - - if(!strcasecmp(chtypename, "inapplicable")){ - return GAP_INAPPLIC; - } - else if(!strcasecmp(chtypename, "missing")){ - return GAP_MISSING; - } - else if(!strcasecmp(chtypename, "newstate")){ - return GAP_NEWSTATE; - } - - return GAP_MAX; -} diff --git a/src/RMorphyUtils.h b/src/RMorphyUtils.h deleted file mode 100644 index 0e0f10f85..000000000 --- a/src/RMorphyUtils.h +++ /dev/null @@ -1,9 +0,0 @@ -#include -#include "mpl.h" - -#if defined (_WIN32) || defined(_WIN64) || defined(_WINDOWS) -#define strcasecmp _stricmp -#endif - -MPLchtype _R_mpl_str2chtype(const char *chtypename); -MPLgap_t _R_mpl_str2gaptype(const char *chtypename); diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index e50fd2323..006fd5894 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -10,111 +10,6 @@ Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif -// preorder_morphy -int preorder_morphy(IntegerMatrix edge, SEXP MorphyHandl); -RcppExport SEXP _TreeSearch_preorder_morphy(SEXP edgeSEXP, SEXP MorphyHandlSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< SEXP >::type MorphyHandl(MorphyHandlSEXP); - rcpp_result_gen = Rcpp::wrap(preorder_morphy(edge, MorphyHandl)); - return rcpp_result_gen; -END_RCPP -} -// preorder_morphy_by_char -IntegerVector preorder_morphy_by_char(IntegerMatrix edge, List MorphyHandls); -RcppExport SEXP _TreeSearch_preorder_morphy_by_char(SEXP edgeSEXP, SEXP MorphyHandlsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< List >::type MorphyHandls(MorphyHandlsSEXP); - rcpp_result_gen = Rcpp::wrap(preorder_morphy_by_char(edge, MorphyHandls)); - return rcpp_result_gen; -END_RCPP -} -// morphy_iw -double morphy_iw(IntegerMatrix edge, List MorphyHandls, NumericVector weight, IntegerVector minScore, IntegerVector sequence, NumericVector concavity, NumericVector target); -RcppExport SEXP _TreeSearch_morphy_iw(SEXP edgeSEXP, SEXP MorphyHandlsSEXP, SEXP weightSEXP, SEXP minScoreSEXP, SEXP sequenceSEXP, SEXP concavitySEXP, SEXP targetSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< List >::type MorphyHandls(MorphyHandlsSEXP); - Rcpp::traits::input_parameter< NumericVector >::type weight(weightSEXP); - Rcpp::traits::input_parameter< IntegerVector >::type minScore(minScoreSEXP); - Rcpp::traits::input_parameter< IntegerVector >::type sequence(sequenceSEXP); - Rcpp::traits::input_parameter< NumericVector >::type concavity(concavitySEXP); - Rcpp::traits::input_parameter< NumericVector >::type target(targetSEXP); - rcpp_result_gen = Rcpp::wrap(morphy_iw(edge, MorphyHandls, weight, minScore, sequence, concavity, target)); - return rcpp_result_gen; -END_RCPP -} -// morphy_profile -double morphy_profile(IntegerMatrix edge, List MorphyHandls, NumericVector weight, IntegerVector sequence, NumericMatrix profiles, NumericVector target); -RcppExport SEXP _TreeSearch_morphy_profile(SEXP edgeSEXP, SEXP MorphyHandlsSEXP, SEXP weightSEXP, SEXP sequenceSEXP, SEXP profilesSEXP, SEXP targetSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< List >::type MorphyHandls(MorphyHandlsSEXP); - Rcpp::traits::input_parameter< NumericVector >::type weight(weightSEXP); - Rcpp::traits::input_parameter< IntegerVector >::type sequence(sequenceSEXP); - Rcpp::traits::input_parameter< NumericMatrix >::type profiles(profilesSEXP); - Rcpp::traits::input_parameter< NumericVector >::type target(targetSEXP); - rcpp_result_gen = Rcpp::wrap(morphy_profile(edge, MorphyHandls, weight, sequence, profiles, target)); - return rcpp_result_gen; -END_RCPP -} -// nni -IntegerMatrix nni(const IntegerMatrix edge, const IntegerVector randomEdge, const IntegerVector whichSwitch); -RcppExport SEXP _TreeSearch_nni(SEXP edgeSEXP, SEXP randomEdgeSEXP, SEXP whichSwitchSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< const IntegerVector >::type randomEdge(randomEdgeSEXP); - Rcpp::traits::input_parameter< const IntegerVector >::type whichSwitch(whichSwitchSEXP); - rcpp_result_gen = Rcpp::wrap(nni(edge, randomEdge, whichSwitch)); - return rcpp_result_gen; -END_RCPP -} -// spr_moves -IntegerMatrix spr_moves(const IntegerMatrix edge); -RcppExport SEXP _TreeSearch_spr_moves(SEXP edgeSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); - rcpp_result_gen = Rcpp::wrap(spr_moves(edge)); - return rcpp_result_gen; -END_RCPP -} -// spr -IntegerMatrix spr(const IntegerMatrix edge, const IntegerVector move); -RcppExport SEXP _TreeSearch_spr(SEXP edgeSEXP, SEXP moveSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< const IntegerVector >::type move(moveSEXP); - rcpp_result_gen = Rcpp::wrap(spr(edge, move)); - return rcpp_result_gen; -END_RCPP -} -// tbr -IntegerMatrix tbr(const IntegerMatrix edge, const IntegerVector move); -RcppExport SEXP _TreeSearch_tbr(SEXP edgeSEXP, SEXP moveSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< const IntegerVector >::type move(moveSEXP); - rcpp_result_gen = Rcpp::wrap(tbr(edge, move)); - return rcpp_result_gen; -END_RCPP -} // asan_error List asan_error(const IntegerMatrix x); RcppExport SEXP _TreeSearch_asan_error(SEXP xSEXP) { @@ -126,27 +21,13 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// all_spr -List all_spr(const IntegerMatrix edge, const IntegerVector break_order); -RcppExport SEXP _TreeSearch_all_spr(SEXP edgeSEXP, SEXP break_orderSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< const IntegerVector >::type break_order(break_orderSEXP); - rcpp_result_gen = Rcpp::wrap(all_spr(edge, break_order)); - return rcpp_result_gen; -END_RCPP -} -// all_tbr -List all_tbr(const IntegerMatrix edge, const IntegerVector break_order); -RcppExport SEXP _TreeSearch_all_tbr(SEXP edgeSEXP, SEXP break_orderSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); - Rcpp::traits::input_parameter< const IntegerVector >::type break_order(break_orderSEXP); - rcpp_result_gen = Rcpp::wrap(all_tbr(edge, break_order)); - return rcpp_result_gen; -END_RCPP + +static const R_CallMethodDef CallEntries[] = { + {"_TreeSearch_asan_error", (DL_FUNC) &_TreeSearch_asan_error, 1}, + {NULL, NULL, 0} +}; + +RcppExport void R_init_TreeSearch(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); } diff --git a/src/TreeSearch-init.c b/src/TreeSearch-init.c deleted file mode 100644 index 3912ed3a8..000000000 --- a/src/TreeSearch-init.c +++ /dev/null @@ -1,71 +0,0 @@ -#define USE_RINTERNALS - -#include -#include -#include -#include /* for NULL */ -#include - -#include "mpl.h" -#include "RMorphyUtils.h" -#include "RMorphy.h" -#include "build_postorder.h" - -extern SEXP _TreeSearch_nni(SEXP, SEXP, SEXP); -extern SEXP _TreeSearch_spr(SEXP, SEXP); -extern SEXP _TreeSearch_spr_moves(SEXP); -extern SEXP _TreeSearch_tbr(SEXP, SEXP); -// extern SEXP _TreeSearch_tbr_moves(SEXP); -extern SEXP _TreeSearch_all_spr(SEXP, SEXP); -extern SEXP _TreeSearch_all_tbr(SEXP, SEXP); -extern SEXP _TreeSearch_preorder_morphy(SEXP, SEXP); -extern SEXP _TreeSearch_preorder_morphy_by_char(SEXP, SEXP); -extern SEXP _TreeSearch_morphy_iw(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); -extern SEXP _TreeSearch_morphy_profile(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); - -static const R_CallMethodDef callMethods[] = { - {"_R_wrap_mpl_new_Morphy", (DL_FUNC) &_R_wrap_mpl_new_Morphy, 0}, - {"_R_wrap_mpl_delete_Morphy", (DL_FUNC) &_R_wrap_mpl_delete_Morphy, 1}, - {"_R_wrap_mpl_init_Morphy", (DL_FUNC) &_R_wrap_mpl_init_Morphy, 3}, - {"_R_wrap_mpl_get_numtaxa", (DL_FUNC) &_R_wrap_mpl_get_numtaxa, 1}, - {"_R_wrap_mpl_get_num_charac", (DL_FUNC) &_R_wrap_mpl_get_num_charac, 1}, - {"_R_wrap_mpl_attach_symbols", (DL_FUNC) &_R_wrap_mpl_attach_symbols, 2}, - {"_R_wrap_mpl_get_symbols", (DL_FUNC) &_R_wrap_mpl_get_symbols, 1}, - {"_R_wrap_mpl_attach_rawdata", (DL_FUNC) &_R_wrap_mpl_attach_rawdata, 2}, - {"_R_wrap_mpl_delete_rawdata", (DL_FUNC) &_R_wrap_mpl_delete_rawdata, 1}, - {"_R_wrap_mpl_set_parsim_t", (DL_FUNC) &_R_wrap_mpl_set_parsim_t, 3}, - {"_R_wrap_mpl_get_gaphandl", (DL_FUNC) &_R_wrap_mpl_get_gaphandl, 1}, - {"_R_wrap_mpl_set_gaphandl", (DL_FUNC) &_R_wrap_mpl_set_gaphandl, 2}, - {"_R_wrap_mpl_set_num_internal_nodes", (DL_FUNC) &_R_wrap_mpl_set_num_internal_nodes, 2}, - {"_R_wrap_mpl_get_num_internal_nodes", (DL_FUNC) &_R_wrap_mpl_get_num_internal_nodes, 1}, - {"_R_wrap_mpl_apply_tipdata", (DL_FUNC) &_R_wrap_mpl_apply_tipdata, 1}, - {"_R_wrap_mpl_set_charac_weight", (DL_FUNC) &_R_wrap_mpl_set_charac_weight, 3}, - {"_R_wrap_mpl_get_charac_weight", (DL_FUNC) &_R_wrap_mpl_get_charac_weight, 2}, - {"_R_wrap_mpl_first_down_recon", (DL_FUNC) &_R_wrap_mpl_first_down_recon, 4}, - {"_R_wrap_mpl_first_up_recon", (DL_FUNC) &_R_wrap_mpl_first_up_recon, 5}, - {"_R_wrap_mpl_second_down_recon", (DL_FUNC) &_R_wrap_mpl_second_down_recon, 4}, - {"_R_wrap_mpl_second_up_recon", (DL_FUNC) &_R_wrap_mpl_second_up_recon, 5}, - {"_R_wrap_mpl_update_tip", (DL_FUNC) &_R_wrap_mpl_update_tip, 3}, - {"_R_wrap_mpl_update_lower_root", (DL_FUNC) &_R_wrap_mpl_update_lower_root, 3}, - {"_TreeSearch_nni", (DL_FUNC) &_TreeSearch_nni, 3}, - {"_TreeSearch_spr", (DL_FUNC) &_TreeSearch_spr, 2}, - {"_TreeSearch_all_spr", (DL_FUNC) &_TreeSearch_all_spr, 2}, - {"_TreeSearch_spr_moves", (DL_FUNC) &_TreeSearch_spr_moves, 1}, - {"_TreeSearch_tbr", (DL_FUNC) &_TreeSearch_tbr, 2}, - {"_TreeSearch_all_tbr", (DL_FUNC) &_TreeSearch_all_tbr, 2}, -// {"_TreeSearch_tbr_moves", (DL_FUNC) &_TreeSearch_tbr_moves, 1}, - {"_TreeSearch_preorder_morphy", (DL_FUNC) &_TreeSearch_preorder_morphy, 2}, - {"_TreeSearch_preorder_morphy_by_char", (DL_FUNC) &_TreeSearch_preorder_morphy_by_char, 2}, - {"_TreeSearch_morphy_iw", (DL_FUNC) &_TreeSearch_morphy_iw, 7}, - {"_TreeSearch_morphy_profile", (DL_FUNC) &_TreeSearch_morphy_profile, 6}, - {"MORPHYLENGTH", (DL_FUNC) &MORPHYLENGTH, 4}, - {"RANDOM_TREE", (DL_FUNC) &RANDOM_TREE, 1}, - {"RANDOM_TREE_SCORE", (DL_FUNC) &RANDOM_TREE_SCORE, 2}, - {NULL, NULL, 0} -}; - -void R_init_TreeSearch(DllInfo *dll) { - R_registerRoutines(dll, NULL, callMethods, NULL, NULL); - R_useDynamicSymbols(dll, FALSE); - R_forceSymbols(dll, TRUE); -} diff --git a/src/build_postorder.h b/src/build_postorder.h deleted file mode 100644 index d4e8bc651..000000000 --- a/src/build_postorder.h +++ /dev/null @@ -1,184 +0,0 @@ -#include -#include "RMorphy.h" - -/* Random number generator from http://www.cse.yorku.ca/~oz/marsaglia-rng.html -/ 1+random_int%10 generates an integer from 1 to 10 [MWC renamed to random_int] -*/ -#define znew (z = 36969 * (z & 65535) + (z >> 16)) -#define wnew (w = 18000 * (w & 65535) + (w >> 16)) -#define random_int ((znew << 16) + wnew) - -/* Global static variables: */ -static unsigned long z = 362436069, w = 521288629; -/* Use random seeds to reset z and w*/ - -void insert_tip_below (const int *new_tip, - const int *add_below, const int *new_node, - int *parent_of, int *left, int *right - ) { - const int old_parent = parent_of[*add_below]; - if (left[old_parent] == *add_below) { - left[old_parent] = *new_node; - } else { - /* The same, but on the right */ - right[old_parent] = *new_node; - } - parent_of[*new_node] = old_parent; - - left[*new_node] = *new_tip; - parent_of[*new_tip] = *new_node; - - right[*new_node] = *add_below; - parent_of[*add_below] = *new_node; -} - -/* parent_of, left and right have been initialized with a two-taxon tree with tips 0 & 1 - *left and right point n_tip _before_ left and right, so we don't need to subtract n_tip each time - *We arbitrarily choose to root our tree on tip 0, so never add to that edge or the - *"dummy" root edge. - */ -void build_tree(int *parent_of, int *left, int *right, const int *n_tip) { - int tip_to_add, add_below, new_node; - for (tip_to_add = 3; tip_to_add < *n_tip; tip_to_add++) { - new_node = tip_to_add + *n_tip - 1; - add_below = 1 + random_int % (tip_to_add + tip_to_add - 3); /* +1 to avoid edge 0 */ - if (add_below < tip_to_add) { /* Adding below a tip */ - insert_tip_below(&tip_to_add, &add_below, &new_node, parent_of, left, right); - } else { /* Adding below an existing node */ - add_below += *n_tip - tip_to_add + 1; /* +1 so we never touch dummy root edge */ - insert_tip_below(&tip_to_add, &add_below, &new_node, parent_of, left, right); - } - } -} - -void move_to_node(const int *old_node_id, int *new_parent, int *new_left, int *new_right, - const int *old_parent, const int *old_left, const int *old_right, - int *next_label, const int *n_tip) { - const int new_node_id = *next_label; - if (old_right[*old_node_id] > *n_tip) { - new_right[new_node_id] = ++(*next_label); - new_parent[*next_label] = new_node_id; - move_to_node(&old_right[*old_node_id], new_parent, new_left, new_right, - old_parent, old_left, old_right, - next_label, n_tip); - } else if (new_node_id != *old_node_id) { /* Otherwise no change */ - new_parent[old_right[*old_node_id]] = new_node_id; - new_right[new_node_id] = old_right[*old_node_id]; - } - if (old_left[*old_node_id] > *n_tip) { - new_left[new_node_id] = ++(*next_label); - new_parent[*next_label] = new_node_id; - move_to_node(&old_left[*old_node_id], new_parent, new_left, new_right, - old_parent, old_left, old_right, - next_label, n_tip); - } else if (new_node_id != *old_node_id) { /* Otherwise no change */ - new_parent[old_left[*old_node_id]] = new_node_id; - new_left[new_node_id] = old_left[*old_node_id]; - } -} - -void renumber_postorder(int *parent_of, int *left, int *right, const int *n_tip) { - int *old_parent = malloc((*n_tip + *n_tip - 1) * sizeof(int)), - *left_array = malloc((*n_tip - 1) * sizeof(int)), - *right_array = malloc((*n_tip - 1) * sizeof(int)), - *old_left = left_array - *n_tip, - *old_right = right_array - *n_tip, - next_label = *n_tip, - i; - for (i = 0; i < *n_tip; i++) { - old_parent[i] = parent_of[i]; - } - for (i = *n_tip; i < (*n_tip + *n_tip - 1); i++) { - old_parent[i] = parent_of[i]; - old_left [i] = left[i]; - old_right [i] = right[i]; - } - - move_to_node(n_tip, parent_of, left, right, - old_parent, old_left, old_right, &next_label, n_tip); - - free(right_array); - free(left_array); - free(old_parent); -} - -void random_tree(int *parent_of, int *left, int *right, const int *n_tip) { - if (*n_tip < 3) { - /* Initialize with 2-tip tree */ - parent_of[0] = *n_tip; - parent_of[1] = *n_tip; - parent_of[*n_tip] = *n_tip; /* Root is its own parent */ - left[0] = 0; - right[0] = 1; - } else { - /* Initialize with 3-tip tree, arbitrarily rooted on tip 0 */ - parent_of[0] = *n_tip; - parent_of[1] = *n_tip + 1; - parent_of[2] = *n_tip + 1; - parent_of[*n_tip] = *n_tip; /* Root is its own parent */ - parent_of[*n_tip + 1] = *n_tip; - left[0] = 0; - left[1] = 1; - right[0] = *n_tip + 1; - right[1] = 2; - } - if (*n_tip > 3) { - build_tree(parent_of, left - *n_tip, right - *n_tip, n_tip); - renumber_postorder(parent_of, left - *n_tip, right - *n_tip, n_tip); - } -} - - -extern SEXP RANDOM_TREE(SEXP ntip) { - const int n_tip = INTEGER(ntip)[0]; - if (n_tip < 2) { - Rf_error("n_tip must be at least two"); - } - SEXP RESULT = PROTECT(allocVector(VECSXP, 3)), - PARENT_OF = PROTECT(allocVector(INTSXP, n_tip + n_tip - 1)), - LEFT = PROTECT(allocVector(INTSXP, n_tip - 1)), - RIGHT = PROTECT(allocVector(INTSXP, n_tip - 1)); - - int *parent_of = INTEGER(PARENT_OF), - *right = INTEGER(RIGHT), - *left = INTEGER(LEFT); - - random_tree(parent_of, left, right, &n_tip); - - SET_VECTOR_ELT(RESULT, 0, PARENT_OF); - SET_VECTOR_ELT(RESULT, 1, LEFT); - SET_VECTOR_ELT(RESULT, 2, RIGHT); - UNPROTECT(4); - return(RESULT); -} - -extern SEXP RANDOM_TREE_SCORE(SEXP ntip, SEXP MorphyHandl) { - const int n_tip = INTEGER(ntip)[0]; - if (n_tip < 2) { - Rf_error("n_tip must be at least two"); - } - Morphy handl = R_ExternalPtrAddr(MorphyHandl); - SEXP RESULT = PROTECT(allocVector(INTSXP, 1)); - int *score, - *parent_of = calloc(n_tip + n_tip - 1 , sizeof(int)), - *left = calloc(n_tip - 1 , sizeof(int)), - *right = calloc(n_tip - 1 , sizeof(int)); - - score = INTEGER(RESULT); - *score = 0; - if (n_tip < 2) { - INTEGER(RESULT)[0] = 0; - UNPROTECT(1); - return(RESULT); - } - - - random_tree(parent_of, left, right, &n_tip); - morphy_length(parent_of, left, right, handl, score); - - free(parent_of); - free(left); - free(right); - UNPROTECT(1); - return(RESULT); -} diff --git a/src/fitch.c b/src/fitch.c deleted file mode 100644 index 1e3d4bedf..000000000 --- a/src/fitch.c +++ /dev/null @@ -1,1052 +0,0 @@ -/* -// fitch.c -// MorPhy2 -// -// Created by mbrazeau on 02/05/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ -#include "mpl.h" -#include "morphydefs.h" -#include "morphy.h" -#include "mplerror.h" -#include "fitch.h" -#include "statedata.h" - -int mpl_fitch_downpass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int steps = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* n = nset->downpass1; - - unsigned long* weights = part->intwts; - - for (i = 0; i < nchars; ++i) { - j = indices[i]; - - n[j] = left[j] & right[j]; - - if (n[j] == 0) { - n[j] = left[j] | right[j]; - steps += weights[i]; - } - } - - return steps; -} - - -int mpl_fitch_uppass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part) -{ - int i = 0; - int j = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* npre = nset->downpass1; - MPLstate* nfin = nset->uppass1; - MPLstate* anc = ancset->uppass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - nfin[j] = anc[j] & npre[j]; - - if (nfin[j] != anc[j]) { - - if (left[j] & right[j]) { - nfin[j] = (npre[j] | (anc[j] & (left[j] | right[j]))); - } - else { - nfin[j] = npre[j] | anc[j]; - } - } - } - - return 0; -} - - -int mpl_fitch_local_reopt - (MPLndsets* srcset, MPLndsets* tgt1set, MPLndsets* tgt2set, MPLpartition* part, - int maxlen, bool domaxlen) -{ - - int i = 0; - int j = 0; - int steps = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* tgt1 = tgt1set->uppass1; - MPLstate* tgt2 = tgt2set->uppass1; - MPLstate* src = srcset->downpass1; - - unsigned long* weights = part->intwts; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (!(src[j] & (tgt1[j] | tgt2[j]))) { - - steps += weights[i]; - - if (steps > maxlen && domaxlen == true) - { - return steps; - } - } - } - - return steps; -} - - -int mpl_NA_fitch_first_downpass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - int i = 0; - int j = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* n = nset->downpass1; - MPLstate* nt = nset->temp_downpass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - nset->changes[j] = false; - - n[j] = (left[j] & right[j]); - - if (n[j] == 0) { - n[j] = (left[j] | right[j]); - - if ((left[j] & ISAPPLIC) && (right[j] & ISAPPLIC)) { - n[j] = n[j] & ISAPPLIC; - } - } - else { - if (n[j] == NA) { - if ((left[j] & ISAPPLIC) && (right[j] & ISAPPLIC)) { - n[j] = (left[j] | right[j]); - } - } - } - - nt[j] = n[j]; - } - - return 0; -} - -int mpl_nadown1_simpl - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - int i = 0; - int j = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* n = nset->downpass1; - MPLstate* nt = nset->temp_downpass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (left[j] & ISAPPLIC && right[j] & ISAPPLIC) { - n[j] = (left[j] | right[j]) & ISAPPLIC; - } - else { - n[j] = (left[j] & right[j]); - if (n[j] != NA) { - n[j] = (left[j] | right[j]); - } - } - - nt[j] = n[j]; - } - - return 0; -} - - -int mpl_nadown2_simpl - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int steps = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass2; - MPLstate* right = rset->downpass2; - MPLstate* setstat = nset->uppass1; - MPLstate* npre = nset->downpass2; - MPLstate temp = 0; - unsigned long* weights = part->intwts; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - - if (setstat[j] != NA) { - if ((temp = (left[j] & right[j]) & ISAPPLIC)) { - npre[j] = temp; - } - else { - npre[j] = (left[j] | right[j]); - if (left[j] & ISAPPLIC && right[j] & ISAPPLIC) { - if (!(npre[j] & NA)) { - steps += weights[j]; - } - } - } - } - else { - npre[j] = NA; - } - -#ifdef DEBUG - assert(npre[j]); -#endif - } - - return 0; -} - - -int mpl_NA_fitch_first_update_downpass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - /*------------------------------------------------------------------------* - | This function is for doing a partial downpass when proposing a | - | subtree reinsertion during branchswapping. Its purpose is to | - | (partially) correct any character state sets that are affected by | - | the proposed reinsertion. It is nearly identical to its original- | - | pass counterpart except that it does not overwrite the temp state | - | storage. | - *------------------------------------------------------------------------*/ - int i = 0; - int j = 0; - const int* indices = part->update_NA_indices; - int nchars = part->nNAtoupdate; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* n = nset->downpass1; - MPLstate* ntemp = nset->temp_downpass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - n[j] = (left[j] & right[j]); - - if (n[j] == 0) { - n[j] = (left[j] | right[j]); - - if ((left[j] & ISAPPLIC) && (right[j] & ISAPPLIC)) { - n[j] = n[j] & ISAPPLIC; - } - } - else { - if (n[j] == NA) { - if ((left[j] & ISAPPLIC) && (right[j] & ISAPPLIC)) { - n[j] = (left[j] | right[j]); - } - } - } - - if (n[j] != ntemp[j]) { - nset->updated = true; - } - - } - - return 0; -} - - -int mpl_NA_fitch_first_uppass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part) -{ - int i = 0; - int j = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* npre = nset->downpass1; - MPLstate* nifin = nset->uppass1; - MPLstate* anc = ancset->uppass1; - MPLstate* nfint = nset->temp_uppass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (npre[j] & NA) { - if (npre[j] & ISAPPLIC) { - if (anc[j] == NA) { - nifin[j] = NA; - } - else { - nifin[j] = npre[j] & ISAPPLIC; - } - } - else { - if (anc[j] == NA) { - nifin[j] = NA; - } - else { - if ((left[j] | right[j]) & ISAPPLIC) { - nifin[j] = ((left[j] | right[j]) & ISAPPLIC); - } - else { - nifin[j] = NA; - } - } - } - } - else { - nifin[j] = npre[j]; - } - - nfint[j] = nifin[j]; - -#ifdef DEBUG - assert(nifin[j]); -#endif - } - - return 0; -} - -int mpl_naupp1_simpl - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part) -{ - int i = 0; - int j = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* npre = nset->downpass1; - MPLstate* nifin = nset->uppass1; - MPLstate* anc = ancset->uppass1; - MPLstate* nfint = nset->temp_uppass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (anc[j] == NA && npre[j] & NA) { - nifin[j] = NA; - } - else { - nifin[j] = nifin[j] & ISAPPLIC; - } - nfint[j] = nifin[j]; - } - - return 0; -} - - -int mpl_NA_fitch_first_update_uppass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part) -{ - /*------------------------------------------------------------------------* - | This function is for doing a partial uppsass when proposing a subtree | - | reinsertion during branchswapping. Its purpose is to (partially) | - | correct any character state sets that are affected by the proposed | - | reinsertion. | - *------------------------------------------------------------------------*/ - int i = 0; - int j = 0; - const int* indices = part->update_NA_indices; - int nchars = part->nNAtoupdate; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* npre = nset->downpass1; - MPLstate* nifin = nset->uppass1; - MPLstate* anc = ancset->uppass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (npre[j] & NA) { - if (npre[j] & ISAPPLIC) { - if (anc[j] == NA) { - nifin[j] = NA; - } - else { - nifin[j] = npre[j] & ISAPPLIC; - } - } - else { - if (anc[j] == NA) { - nifin[j] = NA; - } - else { - if ((left[j] | right[j]) & ISAPPLIC) { - nifin[j] = ((left[j] | right[j]) & ISAPPLIC); - } - else { - nifin[j] = NA; - } - } - } - } - else { - nifin[j] = npre[j]; - } - -#ifdef DEBUG - assert(nifin[j]); -#endif - } - - return 0; -} - - -int mpl_NA_fitch_second_downpass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int steps = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass2; - MPLstate* right = rset->downpass2; - MPLstate* nifin = nset->uppass1; - MPLstate* npre = nset->downpass2; - MPLstate* npret = nset->temp_downpass2; - MPLstate* stacts = nset->subtree_actives; - MPLstate* tstatcs = nset->temp_subtr_actives; - MPLstate* lacts = lset->subtree_actives; - MPLstate* racts = rset->subtree_actives; - MPLstate temp = 0; - unsigned long* weights = part->intwts; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - nset->changes[j] = false; - - if (nifin[j] & ISAPPLIC) { - if ((temp = (left[j] & right[j]))) { - if (temp & ISAPPLIC) { - npre[j] = temp & ISAPPLIC; - } else { - npre[j] = temp; - } - } - else { - npre[j] = (left[j] | right[j]) & ISAPPLIC; - - if (left[j] & ISAPPLIC && right[j] & ISAPPLIC) { - steps += weights[i]; - nset->changes[j] = true; - } else if (lacts[j] && racts[j]) { - steps += weights[i]; - nset->changes[j] = true; - } - } - } - else { - npre[j] = nifin[j]; - - if (lacts[j] && racts[j]) { - steps += weights[i]; - nset->changes[j] = true; - } - } - - /* Store the states active on this subtree */ - stacts[j] = (lacts[j] | racts[j]) & ISAPPLIC; - - npret[j] = npre[j]; - tstatcs[j] = stacts[j]; - - } - - return steps; -} - - -int mpl_NA_fitch_second_update_downpass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - /*------------------------------------------------------------------------* - | This function is for doing a partial downpass when proposing a | - | subtree reinsertion during branchswapping. Its purpose is to | - | (partially) correct any character state sets that are affected by | - | the proposed reinsertion. It is nearly identical to its original- | - | pass counterpart except that it does not overwrite the temp state | - | storage. | - *------------------------------------------------------------------------*/ - int i = 0; - int j = 0; - int steps = 0; - const int* indices = part->update_NA_indices; - int nchars = part->nNAtoupdate; - MPLstate* left = lset->downpass2; - MPLstate* right = rset->downpass2; - MPLstate* nifin = nset->uppass1; - MPLstate* npre = nset->downpass2; - const MPLstate* npret = nset->temp_downpass2; - MPLstate* stacts = nset->subtree_actives; - MPLstate* lacts = lset->subtree_actives; - MPLstate* racts = rset->subtree_actives; - MPLstate temp = 0; - unsigned long* weights = part->intwts; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (nifin[j] & ISAPPLIC) { - if ((temp = (left[j] & right[j]))) { - if (temp & ISAPPLIC) { - npre[j] = temp & ISAPPLIC; - } else { - npre[j] = temp; - } - } - else { - npre[j] = (left[j] | right[j]) & ISAPPLIC; - - if (left[j] & ISAPPLIC && right[j] & ISAPPLIC) { - steps += weights[i]; - } else if (lacts[j] && racts[j]) { - steps += weights[i]; - } - } - } - else { - npre[j] = nifin[j]; - } - - stacts[j] = (lacts[j] | racts[j]) & ISAPPLIC; - - /* Flag as updated if current set is different from previous */ - if (npre[j] != npret[j]) { - nset->updated = true; - } - -#ifdef DEBUG - assert(npre[j]); -#endif - } - - return steps; -} - - -int mpl_NA_fitch_second_uppass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part) -{ - int i = 0; - int j = 0; - int steps = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass2; - MPLstate* right = rset->downpass2; - MPLstate* npre = nset->downpass2; - MPLstate* nfin = nset->uppass2; - MPLstate* nfint = nset->temp_uppass2; - MPLstate* anc = ancset->uppass2; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (npre[j] & ISAPPLIC) { - if (anc[j] & ISAPPLIC) { - if ((anc[j] & npre[j]) == anc[j]) { - nfin[j] = anc[j] & npre[j]; - } else { - if (left[j] & right[j]) { - nfin[j] = (npre[j] | (anc[j] & (left[j] | right[j]))); - } - else { - if ((left[j] | right[j]) & NA) { - if ((left[j] | right[j]) & anc[j]) { - nfin[j] = anc[j]; - } else { - nfin[j] = (left[j] | right[j] | anc[j]) & ISAPPLIC; - } - } else { - nfin[j] = npre[j] | anc[j]; - } - } - } - } - else { - nfin[j] = npre[j]; - } - } - else { - nfin[j] = npre[j]; - } - - nfint[j] = nfin[j]; -#ifdef DEBUG - assert(nfin[j]); -#endif -} - - return steps; -} - - -int mpl_NA_fitch_second_update_uppass - (MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part) -{ - /*------------------------------------------------------------------------* - | This function is for doing a partial uppsass when proposing a subtree | - | reinsertion during branchswapping. Its purpose is to (partially) | - | correct any character state sets that are affected by the proposed | - | reinsertion. | - *------------------------------------------------------------------------*/ - int i = 0; - int j = 0; - int steps = 0; - int step_recall = 0; - const int* indices = part->update_NA_indices; - int nchars = part->nNAtoupdate; - MPLstate* left = lset->downpass2; - MPLstate* right = rset->downpass2; - MPLstate* npre = nset->downpass2; - MPLstate* nfin = nset->uppass2; - MPLstate* nfint = nset->temp_uppass2; - MPLstate* anc = ancset->uppass2; - MPLstate* lacts = lset->subtree_actives; - MPLstate* racts = rset->subtree_actives; - unsigned long* weights = part->intwts; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (npre[j] & ISAPPLIC) { - if (anc[j] & ISAPPLIC) { - if ((anc[j] & npre[j]) == anc[j]) { - nfin[j] = anc[j] & npre[j]; - } else { - if (left[j] & right[j]) { - nfin[j] = (npre[j] | (anc[j] & (left[j] | right[j]))); - } - else { - if ((left[j] | right[j]) & NA) { - if ((left[j] | right[j]) & anc[j]) { - nfin[j] = anc[j]; - } else { - nfin[j] = (left[j] | right[j] | anc[j]) & ISAPPLIC; - } - } else { - nfin[j] = npre[j] | anc[j]; - } - } - } - } - else { - nfin[j] = npre[j]; - } - } - else { - nfin[j] = npre[j]; - - if (lacts[j] && racts[j]) { - steps += weights[i]; - } - } - - if (nfint[j] != nfin[j]) { - nset->updated = true; - } - - if (nset->changes[j] == true) { - step_recall += weights[i]; - } - - -#ifdef DEBUG - assert(nfin[j]); -#endif - } - - nset->steps_to_recall += step_recall; - - return steps; -} - - -int mpl_fitch_NA_local_reopt - (MPLndsets* srcset, MPLndsets* tgt1set, MPLndsets* tgt2set, MPLpartition* part, - int maxlen, bool domaxlen) -{ - - part->ntoupdate = 0; - - int i = 0; - int j = 0; - int need_update = 0; - int steps = 0; - const int* indices = part->charindices; - int nchars = part->ncharsinpart; - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - part->update_NA_indices[need_update] = j; - ++need_update; - - } - - part->nNAtoupdate = need_update; - - return steps; -} - - -int mpl_fitch_tip_update(MPLndsets* tset, MPLndsets* ancset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - - MPLstate* tprelim = tset->downpass1; - MPLstate* tfinal = tset->uppass1; - MPLstate* ttfinal = tset->temp_uppass1; - MPLstate* astates = ancset->uppass1; - - for (i = 0; i < nchars; ++i) { - j = indices[i]; - if (tprelim[j] & astates[j]) { - tfinal[j] = tprelim[j] & astates[j]; - } - else { - tfinal[j] = tprelim[j]; - } - ttfinal[j] = tfinal[j]; - } - return 0; -} - -int mpl_fitch_one_branch - (MPLndsets* tipanc, MPLndsets* node, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* tipset = tipanc->downpass1; - MPLstate* tipfin = tipanc->uppass1; - MPLstate* ndset = node->downpass1; - MPLstate temp = 0; - unsigned long* weights = part->intwts; - int length = 0; - - for (i = 0; i < nchars; ++i) { - j = indices[i]; - - temp = tipset[j] & ndset[j]; - - if (temp == 0) { - tipfin[j] = tipset[j]; - length += weights[i]; - node->uppass1[j] = ndset[j]; - } - else { - tipfin[j] = temp; - node->uppass1[j] = temp; - } - } - - return length; -} - - -int mpl_fitch_NA_first_one_branch - (MPLndsets* tipanc, MPLndsets* node, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* tipset = tipanc->downpass1; - MPLstate* tipifin = tipanc->uppass1; - MPLstate* ndset = node->downpass1; - MPLstate temp = 0; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - tipanc->changes[j] = false; - temp = tipset[j] & ndset[j]; - - if (temp != 0) { - tipifin[j] = temp; - node->uppass1[j] = temp; - } - } - - return 0; -} - -int mpl_fitch_NA_second_one_branch - (MPLndsets* tipanc, MPLndsets* node, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* tipset = tipanc->downpass1; - MPLstate* tipifin = tipanc->uppass1; - MPLstate* ndset = node->downpass2; - MPLstate* ndacts = node->subtree_actives; - MPLstate temp = 0; - unsigned long* weights = part->intwts; - int length = 0; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - temp = tipset[j] & ndset[j]; - - if (temp == 0) { - if (tipset[j] & ISAPPLIC) { - if (ndset[j] & ISAPPLIC) { - length += weights[i]; - tipanc->changes[j] = true; - } - else { - if (ndacts[j]) { - length += weights[i]; - tipanc->changes[j] = true; - } - } - } - - tipifin[j] = tipset[j]; - } - else { - tipifin[j] = temp; - } - - tipanc->temp_downpass1[j] = tipanc->downpass1[j]; - tipanc->temp_uppass1[j] = tipanc->uppass1[j]; - tipanc->temp_downpass2[j] = tipanc->downpass2[j]; - tipanc->temp_uppass2[j] = tipanc->uppass2[j]; - } - - return length; -} - -int mpl_fitch_NA_second_one_branch_recalc - (MPLndsets* tipanc, MPLndsets* node, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* tipset = tipanc->downpass1; - MPLstate* tipifin = tipanc->uppass1; - MPLstate* ndset = node->downpass2; - MPLstate* ndacts = node->subtree_actives; - MPLstate temp = 0; - unsigned long* weights = part->intwts; - unsigned long step_recall = 0; - int length = 0; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - temp = tipset[j] & ndset[j]; - - if (temp == 0) { - if (tipset[j] & ISAPPLIC) { - if (ndset[j] & ISAPPLIC) { - length += weights[i]; - } - else { - if (ndacts[j]) { - length += weights[i]; - } - } - } - - tipifin[j] = tipset[j]; - } - else { - tipifin[j] = temp; - } - - if (tipanc->changes[j] == true) { - step_recall += weights[i]; - } - } - - tipanc->steps_to_recall += step_recall; - - return length; -} - - -int mpl_fitch_NA_tip_update - (MPLndsets* tset, MPLndsets* ancset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - - MPLstate* tpass1 = tset->downpass1; - MPLstate* tpass2 = tset->uppass1; - MPLstate* tpass3 = tset->downpass2; - MPLstate* ttpass1 = tset->temp_downpass1; - MPLstate* ttpass2 = tset->temp_uppass1; - MPLstate* ttpass3 = tset->temp_downpass2; - MPLstate* astates = ancset->uppass1; - MPLstate* stacts = tset->subtree_actives; - MPLstate* tstatcs = tset->temp_subtr_actives; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (tpass1[j] & astates[j]) { - stacts[j] = (tpass1[j] & astates[j] & ISAPPLIC); - } - else { - stacts[j] |= tpass1[j] & ISAPPLIC; - } - - tpass2[j] = tpass1[j]; - - if (tpass2[j] & astates[j]) { - if (astates[j] & ISAPPLIC) { - tpass2[j] &= ISAPPLIC; - } - } - - tpass3[j] = tpass2[j]; - - ttpass1[j] = tpass1[j]; - ttpass2[j] = tpass2[j]; - ttpass3[j] = tpass3[j]; - tstatcs[j] = stacts[j]; -#ifdef DEBUG - assert(tpass3[j]); - assert(tpass2[j]); -#endif - } - - return 0; -} - - -int mpl_fitch_NA_tip_recalc_update - (MPLndsets* tset, MPLndsets* ancset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - - MPLstate* tpass1 = tset->downpass1; - MPLstate* tpass2 = tset->uppass1; - MPLstate* tpass3 = tset->downpass2; - MPLstate* astates = ancset->uppass1; - MPLstate* stacts = tset->subtree_actives; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (tpass1[j] & astates[j]) { - stacts[j] = (tpass1[j] & astates[j] & ISAPPLIC); - } - else { - stacts[j] |= tpass1[j] & ISAPPLIC; - } - - tpass2[j] = tpass1[j]; - - if (tpass2[j] & astates[j]) { - if (astates[j] & ISAPPLIC) { - tpass2[j] &= ISAPPLIC; - } - } - - tpass3[j] = tpass2[j]; - -#ifdef DEBUG - assert(tpass3[j]); - assert(tpass2[j]); -#endif - } - - return 0; -} - - -int mpl_fitch_NA_tip_finalize - (MPLndsets* tset, MPLndsets* ancset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* tpass1 = tset->downpass1; - MPLstate* tfinal = tset->uppass2; - MPLstate* ttfinal = tset->temp_uppass2; - MPLstate* astates = ancset->uppass2; - MPLstate* stacts = tset->subtree_actives; - MPLstate* tstacts = tset->temp_subtr_actives; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (tpass1[j] & astates[j]) { - tfinal[j] = tpass1[j] & astates[j]; - } - else { - tfinal[j] = tpass1[j]; - } - ttfinal[j] = tfinal[j]; - tstacts[j] = stacts[j]; - } - - return 0; -} diff --git a/src/fitch.h b/src/fitch.h deleted file mode 100644 index 87d1dbc47..000000000 --- a/src/fitch.h +++ /dev/null @@ -1,51 +0,0 @@ -/* -// fitch.h -// MorPhy2 -// -// Created by mbrazeau on 02/05/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ - -#ifndef fitch_h -#define fitch_h - -int mpl_fitch_downpass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part); - -int mpl_fitch_uppass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, MPLpartition* part); - -int mpl_fitch_local_reopt(MPLndsets* srcset, MPLndsets* tgt1set, MPLndsets* tgt2set, MPLpartition* part, int maxlen, bool domaxlen); - -int mpl_NA_fitch_first_downpass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part); - -int mpl_NA_fitch_first_update_downpass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part); - -int mpl_NA_fitch_first_uppass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, MPLpartition* part); - -int mpl_NA_fitch_first_update_uppass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, MPLpartition* part); - -int mpl_NA_fitch_second_downpass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part); - -int mpl_NA_fitch_second_update_downpass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part); - -int mpl_NA_fitch_second_uppass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, MPLpartition* part); - -int mpl_NA_fitch_second_update_uppass(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, MPLpartition* part); - -int mpl_fitch_NA_local_reopt (MPLndsets* srcset, MPLndsets* tgt1set, MPLndsets* tgt2set, MPLpartition* part, int maxlen, bool domaxlen); - -int mpl_fitch_tip_update(MPLndsets* tset, MPLndsets* ancset, MPLpartition* part); - -int mpl_fitch_one_branch(MPLndsets* tipanc, MPLndsets* node, MPLpartition* part); - -int mpl_fitch_NA_first_one_branch(MPLndsets* tipanc, MPLndsets* node, MPLpartition* part); - -int mpl_fitch_NA_second_one_branch(MPLndsets* tipanc, MPLndsets* node, MPLpartition* part); - -int mpl_fitch_NA_second_one_branch_recalc(MPLndsets* tipanc, MPLndsets* node, MPLpartition* part); - -int mpl_fitch_NA_tip_update(MPLndsets* tset, MPLndsets* ancset, MPLpartition* part); - -int mpl_fitch_NA_tip_recalc_update(MPLndsets* tset, MPLndsets* ancset, MPLpartition* part); - -int mpl_fitch_NA_tip_finalize(MPLndsets* tset, MPLndsets* ancset, MPLpartition* part); -#endif /* fitch_h */ diff --git a/src/morphy.c b/src/morphy.c deleted file mode 100644 index ea70e3097..000000000 --- a/src/morphy.c +++ /dev/null @@ -1,1126 +0,0 @@ -/* -// morphy.c -// MorPhy2 -// -// Created by mbrazeau on 23/04/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ -#include "mpl.h" -#include "morphydefs.h" -#include "morphy.h" -#include "mplerror.h" -#include "statedata.h" -#include "fitch.h" -#include "wagner.h" - -void *mpl_alloc(size_t size, int setval) -{ - void *ret = malloc(size); - if (ret) { - memset(ret, setval, size); - } - return ret; -} - - -Morphyp mpl_new_Morphy_t(void) -{ - Morphyp new = (Morphyp)calloc(1, sizeof(Morphy_t)); - - mpl_set_gaphandl(GAP_INAPPLIC, (Morphy)new); - new->symbols.gap = DEFAULTGAP; - new->symbols.missing = DEFAULTMISSING; - new->nthreads = 1; - new->usrwtbase = 0; - new->wtbase = 1; - - return new; -} - - -/*void* mpl_get_from_matrix -(const int row, - const int col, - const int ncol, - const size_t size, - const void* data) -{ - return (void*)(data + (row * ncol * size + (size * col))); -}*/ - - -int mpl_get_gaphandl(Morphyp handl) -{ - assert(handl); - return handl->gaphandl; -} - - -int mpl_set_num_charac(const int nchar, Morphyp m) -{ - if (!m) { - return ERR_BAD_PARAM; - } - - m->numcharacters = nchar; - - return ERR_NO_ERROR; -} - - -int mpl_set_numtaxa(const int ntax, Morphyp m) -{ - if (!m) { - return ERR_BAD_PARAM; - } - - m->numtaxa = ntax; - - return ERR_NO_ERROR; -} - - -int mpl_check_data_loaded(Morphyp m) -{ - if (m->char_t_matrix) { - return 1; - } - - return 0; -} - - -char mpl_get_gap_symbol(Morphyp handl) -{ - return handl->symbols.gap; -} - -void mpl_flt_rational_approx -(unsigned long *a, unsigned long *b, const double fval) -{ - /* Using David Eppstein's method - http://www.ics.uci.edu/~eppstein/numth/frap.c*/ - - - long m[2][2]; - long ai; - long maxden = 100; - double x = fval; - - m[0][0] = m[1][1] = 1; - m[0][1] = m[1][0] = 0; - - while (m[1][0] * (ai = (long)x) + m[1][1] <= maxden) { - long t; - t = m[0][0] * ai + m[0][1]; - m[0][1] = m[0][0]; - m[0][0] = t; - t = m[1][0] * ai + m[1][1]; - m[1][1] = m[1][0]; - m[1][0] = t; - if (x == (double)ai) { - break; - } - x = 1 /(x - (double) ai); - if (x > (double)INT_MAX) { - break; - } - } - - *a = m[0][0]; - *b = m[1][0]; -} - - -bool mpl_almost_equal(double a, double b) -{ - double diff = fabs(a - b); - double largest = 0.0; - - a = fabs(a); - b = fabs(b); - - largest = (b > a) ? b : a; - - if (diff <= largest * MPL_EPSILON) { - return true; - } - - return false; -} - -/*! - @brief Checks whether or not a value corresponds to a real number or is whole - @discussion Should be used only to check values from external calling functions - that are not expected to be the product of a calculation (i.e. are a user- - supplied value, such as an input weight). - @param n The value to be tested. - @return A true/false value: true if value is fractional, false if value is - whole. - */ -bool mpl_isreal(const double n) -{ - assert(!(n > (double)LONG_MAX)); - long i = (long)n; - if (n == (double)i) { - return false; - } - return true; -} - - -int mpl_change_weight_base(const unsigned long wtbase, Morphyp handl) -{ - if (handl->usrwtbase) { - return 1; - } - - handl->wtbase = wtbase; - - return 0; -} - -static inline unsigned long mpl_greatest_common_denom -(unsigned long a, unsigned long b) -{ - unsigned long t = 0; - while (b) { - t = b; - b = a % b; - a = t; - } - - return a; -} - -unsigned long mpl_least_common_multiple(unsigned long a, unsigned long b) -{ - return (a * b) / mpl_greatest_common_denom(a, b); -} - -void mpl_set_new_weight_public -(const double wt, const int char_id, Morphyp handl) -{ - bool wtisreal = mpl_isreal(wt); - - - if (wtisreal) { - - if (!mpl_isreal(handl->charinfo[char_id].realweight) || - handl->charinfo[char_id].realweight == 0.0) - { - ++handl->numrealwts; - } - } - else { - - if (mpl_isreal(handl->charinfo[char_id].realweight)) { - --handl->numrealwts; - } - } - - handl->charinfo[char_id].realweight = wt; -} - -void mpl_scale_all_intweights(Morphyp handl) -{ - int i = 0; - int nchar = mpl_get_num_charac((Morphy)handl); - - - if (!handl->numrealwts) { - if (handl->usrwtbase != 0) { - handl->wtbase = handl->usrwtbase; - } else { - handl->wtbase = DEFAULTWTBASE; - } - } - - for (i = 0; i < nchar; ++i) { - mpl_flt_rational_approx(&handl->charinfo[i].intwt, - &handl->charinfo[i].basewt, - handl->charinfo[i].realweight); - } - - for (i = 0; i < nchar; ++i) { - handl->wtbase = mpl_least_common_multiple(handl->wtbase, - handl->charinfo[i].basewt); - } - - for (i = 0; i < nchar; ++i) { - handl->charinfo[i].intwt *= (handl->wtbase / handl->charinfo[i].basewt); - handl->charinfo[i].basewt = handl->wtbase; - } - -} - -void mpl_assign_fitch_fxns(MPLpartition* part) -{ - assert(part); - - if (part->isNAtype) { - part->inappdownfxn = mpl_NA_fitch_second_downpass; - part->inappupfxn = mpl_NA_fitch_second_uppass; - part->prelimfxn = mpl_NA_fitch_first_downpass; - part->finalfxn = mpl_NA_fitch_first_uppass; - part->tipupdate = mpl_fitch_NA_tip_update; - part->tipfinalize = mpl_fitch_NA_tip_finalize; - part->tiproot = mpl_fitch_NA_first_one_branch; - part->tiprootfinal = mpl_fitch_NA_second_one_branch; - part->loclfxn = mpl_fitch_NA_local_reopt; - part->downrecalc1 = mpl_NA_fitch_first_update_downpass; - part->uprecalc1 = mpl_NA_fitch_first_update_uppass; - part->inappdownrecalc2 = mpl_NA_fitch_second_update_downpass; - part->inapuprecalc2 = mpl_NA_fitch_second_update_uppass; - part->tipupdaterecalc = mpl_fitch_NA_tip_recalc_update; - part->tiprootrecalc = mpl_fitch_NA_first_one_branch; - part->tiprootupdaterecalc = mpl_fitch_NA_second_one_branch_recalc; - } - else { - part->prelimfxn = mpl_fitch_downpass; - part->finalfxn = mpl_fitch_uppass; - part->tipupdate = mpl_fitch_tip_update; - part->tiproot = mpl_fitch_one_branch; - part->tipfinalize = NULL; - part->inappdownfxn = NULL; - part->inappupfxn = NULL; - part->loclfxn = mpl_fitch_local_reopt; - part->downrecalc1 = NULL; - part->uprecalc1 = NULL; - part->inappdownrecalc2 = NULL; - part->inapuprecalc2 = NULL; - } -} - -void mpl_assign_wagner_fxns(MPLpartition* part) -{ - assert(part); - - part->prelimfxn = mpl_wagner_downpass; - part->finalfxn = mpl_wagner_uppass; - part->tipupdate = mpl_wagner_tip_update; - part->tipfinalize = NULL; - part->inappdownfxn = NULL; - part->inappupfxn = NULL; - part->loclfxn = NULL; - -} - - - -int mpl_fetch_parsim_fxn_setter -(void(**pars_assign)(MPLpartition*), MPLchtype chtype) -{ - int err = ERR_NO_ERROR; - - switch (chtype) { - case FITCH_T: - if (pars_assign) { - *pars_assign = mpl_assign_fitch_fxns; - } - break; - case WAGNER_T: - if (pars_assign) { - *pars_assign = mpl_assign_wagner_fxns; - } - break; - - - default: - err = ERR_CASE_NOT_IMPL; - break; - } - - return err; -} - - -int mpl_assign_partition_fxns(MPLpartition* part) -{ - assert(part); - int err = ERR_NO_ERROR; - - void (*pars_assign)(MPLpartition*) = NULL; - - err = mpl_fetch_parsim_fxn_setter(&pars_assign, part->chtype); - - if (!err && pars_assign) { - pars_assign(part); - } - - return err; -} - - -int mpl_extend_intarray(int** array, size_t size) -{ - int* temp = (int*)realloc(*array, size); - if (!temp) { - return ERR_BAD_MALLOC; - } - - *array = temp; - - return ERR_NO_ERROR; -} - - -int mpl_part_push_index(int newint, MPLpartition* part) -{ - int err = ERR_NO_ERROR; - - if (part->ncharsinpart < part->maxnchars) { - part->charindices[part->ncharsinpart] = newint; - ++part->ncharsinpart; - } - else { - err = mpl_extend_intarray(&part->charindices, - (part->maxnchars + 1) * sizeof(int)); - if (!err) { - part->charindices[part->ncharsinpart] = newint; - ++part->ncharsinpart; - ++part->maxnchars; - } - } - - return err; -} - - -int mpl_part_remove_index(int index, MPLpartition* part) -{ - if (!part->ncharsinpart) { - return 1; - } - - --part->ncharsinpart; - assert(part->ncharsinpart >= 0); - - int i = 0; - for (i = 0; i < part->ncharsinpart; ++i) { - part->charindices[i] = part->charindices[i + 1]; - } - part->charindices[i] = MPLCHARMAX; - - return 0; -} - - -int mpl_delete_partition(MPLpartition* part) -{ - int err = ERR_UNEXP_NULLPTR; - - if (part) { - - if (part->charindices) { - free(part->charindices); - part->charindices = NULL; - } - if (part->intwts) { - free(part->intwts); - part->intwts = NULL; - } - part->maxnchars = 0; - part->ncharsinpart = 0; - part->chtype = NONE_T; - part->tipupdate = NULL; - part->tipfinalize = NULL; - part->inappdownfxn = NULL; - part->inappupfxn = NULL; - part->prelimfxn = NULL; - part->finalfxn = NULL; - part->next = NULL; - free(part); - err = ERR_NO_ERROR; - } - - return err; -} - -int mpl_delete_all_partitions(Morphyp handl) -{ - assert(handl); - - int i = 0; - - if (handl->numparts) { - - mpl_delete_all_update_buffers(handl); /* MS addition, 2021-02-01 */ - MPLpartition* p = handl->partstack; - MPLpartition* q = NULL; - while (p) { - q = p->next; - mpl_delete_partition(p); - p = q; - } - - for (i = 0; i < handl->numparts; ++i) { - handl->partitions[i] = NULL; - } - free(handl->partitions); - handl->partitions = NULL; - - return ERR_NO_ERROR; - } - return ERR_UNEXP_NULLPTR; -} - - -MPLpartition* mpl_new_partition(const MPLchtype chtype, const bool hasNA) -{ - assert(chtype); - - MPLpartition *new = (MPLpartition*)calloc(1, sizeof(MPLpartition)); - - if (!new) { - return NULL; - } - - new->chtype = chtype; - new->isNAtype = hasNA; - - new->charindices = (int*)calloc(1, sizeof(int)); - if (!new->charindices) { - free(new); - return NULL; - } - - new->maxnchars = 1; - new->ncharsinpart = 0; - - mpl_assign_partition_fxns(new); - - return new; -} - - -int mpl_count_gaps_in_columns(Morphyp handl) -{ - int i = 0; - int j = 0; - char gap = mpl_get_gap_symbol(handl); - int numchar = mpl_get_num_charac((Morphy)handl); - int numtax = mpl_get_numtaxa((Morphy)handl); - MPLmatrix* matrix = mpl_get_mpl_matrix(handl); - MPLcharinfo* chinfo = handl->charinfo; - int numna = 0; - - for (i = 0; i < numchar; ++i) { - chinfo[i].ninapplics = 0; - for (j = 0; j < numtax; ++j) { - - MPLcell* cell = &matrix->cells[j * numchar + i]; - - if (strchr(cell->asstr, gap)) { - ++chinfo[i].ninapplics; - } - - if (chinfo[i].ninapplics > NACUTOFF) { - ++numna; - break; - } - } - } - - return numna; -} - - -int mpl_compare_partition_with_char_info -(const MPLcharinfo *chinfo, const MPLpartition* part, const MPLgap_t gaphandl) -{ - int ret = 0; - - if (chinfo->chtype != part->chtype) { - ++ret; - } - - if (gaphandl == GAP_INAPPLIC) { - if (chinfo->ninapplics <= NACUTOFF) { - if (part->isNAtype) { - ++ret; - } - } - else { - if (!part->isNAtype) { - ++ret; - } - } - } - - return ret; -} - - -/*! - @brief Searches the partition list for a partition matching the supplied info - @discussion Traverses a linked list of partitions, looking for a partition - matching the supplied information. If this function returns NULL, then the - supplied info does not match a character in the list. A new partition will - need to be created. - @param chinfo MPLchtype providing data on a character in the matrix. - @param part A data partition; should be the first partition in the list. - @return A pointer to the partition corresponding to the supplied character - information. - */ -MPLpartition* mpl_search_partitions -(MPLcharinfo *chinfo, MPLpartition* part, MPLgap_t gaphandl) -{ - assert(chinfo); - MPLpartition* p = part; - - while (p) { - if (!mpl_compare_partition_with_char_info(chinfo, p, gaphandl)) { - return p; - } - p = p->next; - } - - return p; -} - - -int mpl_compare_partitions(const void* ptr1, const void* ptr2) -{ - MPLpartition* part1 = *(MPLpartition**)ptr1; - MPLpartition* part2 = *(MPLpartition**)ptr2; - - int ret; - MPLchtype cdiff = NONE_T; - - cdiff = part1->chtype - part2->chtype; - ret = (int)cdiff; - - if (!cdiff) { - if (part2->isNAtype) { - ret = 1; - } - else { - ret = 0; - } - } - - return ret; -} - - -int mpl_put_partitions_in_handle(MPLpartition* first, Morphyp handl) -{ - assert(handl); - if (!handl->numparts) { - return ERR_NO_DATA; - } - handl->partitions = (MPLpartition**)calloc(handl->numparts, - sizeof(MPLpartition*)); - if (!handl->partitions) { - return ERR_BAD_MALLOC; - } - - int i = 0; - MPLpartition* p = first; - while (p) { - handl->partitions[i] = p; - ++i; - p = p->next; - } - assert(i == handl->numparts); - - qsort(handl->partitions, handl->numparts, sizeof(MPLpartition*), mpl_compare_partitions); - handl->partstack = first; - - return ERR_NO_ERROR; -} - - -void mpl_delete_all_update_buffers(Morphyp handl) -{ - /* Erases all the update buffers */ - int i = 0; - for (i = 0; i < handl->numparts; ++i) { - MPLpartition* p = handl->partitions[i]; - if (p->update_indices) { - free(p->update_indices); - p->update_indices = NULL; - } - if (p->update_NA_indices) { - free(p->update_NA_indices); - p->update_NA_indices = NULL; - } - } -} - - -int mpl_allocate_update_buffers(Morphyp handl) -{ - /* Allocates memory for an array of indices needed update on the tree */ - int i = 0; - for (i = 0; i < handl->numparts; ++i) { - MPLpartition* p = handl->partitions[i]; - p->update_indices = (int*)calloc(p->ncharsinpart, sizeof(int)); - if (!p->update_indices) { - mpl_delete_all_update_buffers(handl); - return ERR_BAD_MALLOC; - } - p->update_NA_indices = (int*)calloc(p->ncharsinpart, sizeof(int)); - if (!p->update_NA_indices) { - mpl_delete_all_update_buffers(handl); - return ERR_BAD_MALLOC; - } - - p->ntoupdate = 0; - p->nNAtoupdate = 0; - } - - return ERR_NO_ERROR; -} - -int mpl_setup_partitions(Morphyp handl) -{ - assert(handl); - - int err = ERR_NO_ERROR; - - int i = 0; - int nchar = mpl_get_num_charac((Morphyp)handl); - - MPLcharinfo* chinfo = NULL; - MPLpartition* first = NULL; - MPLpartition* last = NULL; - MPLpartition* p = NULL; - int numparts = 0; - - if (handl->partitions) { - mpl_delete_all_partitions(handl); - } - - for (i = 0; i < nchar; ++i) { - chinfo = &handl->charinfo[i]; - - p = mpl_search_partitions(chinfo, first, mpl_get_gaphandl(handl)); - - if (p) { - mpl_part_push_index(i, p); - } - else { - bool hasNA = false; - if (handl->gaphandl == GAP_INAPPLIC) { - if (chinfo->ninapplics > NACUTOFF) { - hasNA = true; - } - } - p = mpl_new_partition(chinfo->chtype, hasNA); - mpl_part_push_index(i, p); - if (!first) { - first = p; - last = p; - } - else { - last->next = p; - last = p; - } - - ++numparts; - } - } - - handl->numparts = numparts; - err = mpl_put_partitions_in_handle(first, handl); - mpl_allocate_update_buffers(handl); - - return err; -} - - -int mpl_get_numparts(Morphyp handl) -{ - return handl->numparts; -} - - -void mpl_delete_nodal_strings(const int nchars, MPLndsets* set) -{ - int i = 0; - - for (i = 0; i < nchars; ++i) { - if (set->downp1str) { - free(set->downp1str[i]); - set->downp1str[i] = NULL; - } - if (set->upp1str) { - free(set->upp1str[i]); - set->upp1str[i] = NULL; - } - if (set->downp2str) { - free(set->downp2str[i]); - set->downp2str[i] = NULL; - } - if (set->upp2str) { - free(set->upp2str[i]); - set->upp2str[i] = NULL; - } - } -} - - -int mpl_allocate_stset_stringptrs(const int nchars, MPLndsets* set) -{ - if (!set->downp1str) { - set->downp1str = (char**)calloc(nchars, sizeof(char*)); - if (!set->downp1str) { - mpl_delete_nodal_strings(nchars, set); - return ERR_BAD_MALLOC; - } - } - - if (!set->upp1str) { - set->upp1str = (char**)calloc(nchars, sizeof(char*)); - if (!set->upp1str) { - mpl_delete_nodal_strings(nchars, set); - return ERR_BAD_MALLOC; - } - } - - if (!set->downp2str) { - set->downp2str = (char**)calloc(nchars, sizeof(char*)); - if (!set->downp2str) { - mpl_delete_nodal_strings(nchars, set); - return ERR_BAD_MALLOC; - } - } - - if (!set->upp2str) { - set->upp2str = (char**)calloc(nchars, sizeof(char*)); - if (!set->upp2str) { - mpl_delete_nodal_strings(nchars, set); - return ERR_BAD_MALLOC; - } - } - - - return ERR_NO_ERROR; -} - - -MPLndsets* mpl_alloc_stateset(int numchars) -{ - MPLndsets* new = (MPLndsets*)calloc(1, sizeof(MPLndsets)); - if (!new) { - return NULL; - } - - new->downpass1 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->downpass1) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->uppass1 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->uppass1) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->downpass2 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->downpass1) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->uppass2 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->uppass2) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->subtree_actives = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->subtree_actives) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->temp_subtr_actives = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->temp_subtr_actives) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->temp_downpass1 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->temp_downpass1) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->temp_uppass1 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->temp_uppass1) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->temp_downpass2 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->temp_downpass1) { - mpl_free_stateset(numchars, new); - return NULL; - } - - new->temp_uppass2 = (MPLstate*)calloc(numchars, sizeof(MPLstate)); - if (!new->temp_uppass2) { - mpl_free_stateset(numchars, new); - return NULL; - } - new->changes = (bool*)calloc(numchars, sizeof(bool)); - if (!new->changes) { - mpl_free_stateset(numchars, new); - return NULL; - } - mpl_allocate_stset_stringptrs(numchars, new); - - return new; -} - - -void mpl_free_stateset(const int nchars, MPLndsets* statesets) -{ - if (!statesets) { - return; - } - if (statesets->downpass1) { - free(statesets->downpass1); - statesets->downpass1 = NULL; - } - if (statesets->uppass1) { - free(statesets->uppass1); - statesets->uppass1 = NULL; - } - if (statesets->downpass2) { - free(statesets->downpass2); - statesets->downpass2 = NULL; - } - if (statesets->uppass2) { - free(statesets->uppass2); - statesets->uppass2 = NULL; - } - if (statesets->subtree_actives) { - free(statesets->subtree_actives); - statesets->subtree_actives = NULL; - } - if (statesets->temp_subtr_actives) { - free(statesets->temp_subtr_actives); - statesets->temp_subtr_actives = NULL; - } - if (statesets->temp_downpass1) { - free(statesets->temp_downpass1); - statesets->temp_downpass1 = NULL; - } - if (statesets->temp_uppass1) { - free(statesets->temp_uppass1); - statesets->temp_uppass1 = NULL; - } - if (statesets->temp_downpass2) { - free(statesets->temp_downpass2); - statesets->temp_downpass2 = NULL; - } - if (statesets->temp_uppass2) { - free(statesets->temp_uppass2); - statesets->temp_uppass2 = NULL; - } - if (statesets->changes) { - free(statesets->changes); - statesets->changes = NULL; - } - - mpl_delete_nodal_strings(nchars, statesets); - - if (statesets->downp1str) { - free(statesets->downp1str); - statesets->downp1str = NULL; - } - if (statesets->upp1str) { - free(statesets->upp1str); - statesets->upp1str = NULL; - } - if (statesets->downp2str) { - free(statesets->downp2str); - statesets->downp2str = NULL; - } - if (statesets->upp2str) { - free(statesets->upp2str); - statesets->upp2str = NULL; - } - - free(statesets); -} - - -int mpl_setup_statesets(Morphyp handl) -{ - MPL_ERR_T err = ERR_NO_ERROR; - - int numnodes = handl->numnodes; - - if (handl->statesets) { - return 1; - } - - handl->statesets = (MPLndsets**)calloc(numnodes, sizeof(MPLndsets*)); - - if (!handl->statesets) { - return ERR_BAD_MALLOC; - } - - int i = 0; - int nchars = mpl_get_num_charac((Morphyp)handl); - - for (i = 0; i < numnodes; ++i) { - if (!(handl->statesets[i] = mpl_alloc_stateset(nchars))) { - err = ERR_BAD_MALLOC; - mpl_destroy_statesets(handl); - break; - } - } - - return err; -} - - -int mpl_destroy_statesets(Morphyp handl) -{ - int i = 0; - int numnodes = handl->numnodes; - - if (handl->statesets) { - - for (i = 0; i < numnodes; ++i) { - mpl_free_stateset(mpl_get_num_charac((Morphy)handl), handl->statesets[i]); - } - - free(handl->statesets); - handl->statesets = NULL; - } - - return ERR_NO_ERROR; -} - - -int mpl_copy_data_into_tips(Morphyp handl) -{ - int i = 0; - int j = 0; - int ntax = mpl_get_numtaxa((Morphy)handl); - int nchar = mpl_get_num_charac((Morphy)handl); - MPLndsets** nsets = handl->statesets; - - for (i = 0; i < ntax; ++i) { - for (j = 0; j < nchar; ++j) { - nsets[i]->downpass1[j] = - handl->inmatrix.cells[i * nchar + j].asint; - nsets[i]->uppass1[j] = nsets[i]->downpass1[j]; - nsets[i]->uppass2[j] = nsets[i]->downpass1[j]; - nsets[i]->downpass2[j] = nsets[i]->downpass1[j]; - } - } - - return ERR_NO_ERROR; -} - -int mpl_assign_intwts_to_partitions(Morphyp handl) -{ - int i = 0; - int j = 0; - int numparts = mpl_get_numparts(handl); - - if (!numparts) { - return ERR_NO_DATA; - } - - for (i = 0; i < numparts; ++i) { - - if (handl->partitions[i]->intwts) { - free(handl->partitions[i]->intwts); - handl->partitions[i]->intwts = NULL; - } - - handl->partitions[i]->intwts = (unsigned long*)calloc - (handl->partitions[i]->ncharsinpart, - sizeof(unsigned long)); - - for (j = 0; j < handl->partitions[i]->ncharsinpart; ++j) { - int charindex = handl->partitions[i]->charindices[j]; - handl->partitions[i]->intwts[j] = handl->charinfo[charindex].intwt; - } - } - - return 0; -} - -int mpl_update_root(MPLndsets* lower, MPLndsets* upper, MPLpartition* part) -{ - int i = 0; - int j = 0; - int nchar = part->ncharsinpart; - int *indices = part->charindices; - - - for (i = 0; i < nchar; ++i) { - j = indices[i]; - lower->downpass1[j] = upper->downpass1[j]; - lower->uppass1[j] = upper->downpass1[j]; - } - - return 0; -} - - -int mpl_update_NA_root(MPLndsets* lower, MPLndsets* upper, MPLpartition* part) -{ - int i = 0; - int j = 0; - int nchar = part->ncharsinpart; - int *indices = part->charindices; - - for (i = 0; i < nchar; ++i) { - j = indices[i]; - - if (upper->downpass1[j] & ISAPPLIC) { - lower->downpass1[j] = upper->downpass1[j] & ISAPPLIC; - } - else { - lower->downpass1[j] = NA; - } - - lower->uppass2[j] = upper->downpass2[j]; - lower->downpass1[j] = lower->downpass1[j]; - lower->uppass1[j] = lower->downpass1[j]; - - lower->temp_downpass1[j] = lower->downpass1[j]; - lower->temp_uppass1[j] = lower->uppass1[j]; - lower->temp_downpass2[j] = lower->downpass2[j]; - lower->temp_uppass2[j] = lower->uppass2[j]; - } - - return 0; -} - -int mpl_update_NA_root_recalculation(MPLndsets* lower, MPLndsets* upper, MPLpartition* part) -{ - int i = 0; - int j = 0; - int nchar = part->nNAtoupdate; - int *indices = part->update_NA_indices; - - for (i = 0; i < nchar; ++i) { - j = indices[i]; - - if (upper->downpass1[j] & ISAPPLIC) { - lower->downpass1[j] = upper->downpass1[j] & ISAPPLIC; - } - else { - lower->downpass1[j] = NA; - } - - lower->uppass2[j] = upper->downpass2[j]; - lower->downpass1[j] = lower->downpass1[j]; - lower->uppass1[j] = lower->downpass1[j]; - } - - return 0; -} diff --git a/src/morphy.h b/src/morphy.h deleted file mode 100644 index 0eb19d775..000000000 --- a/src/morphy.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * morphy.h - * MorPhy2 - * - * Created by mbrazeau on 23/04/2017. - * Copyright © 2017 brazeaulab. All rights reserved. - */ - -#ifndef morphy_h -#define morphy_h - -#ifdef DEBUG -#include -#define dbg_printf(...) printf(__VA_ARGS__) -#else -#define dbg_printf(...) -#endif - -#include -#include -#include -#include -#include - -/* Function prototypes */ - -Morphyp mpl_new_Morphy_t(void); -int mpl_set_numtaxa(const int ntax, Morphyp m); -int mpl_set_num_charac(const int ncharac, Morphyp m); -int mpl_get_gaphandl(Morphyp handl); -int mpl_check_data_loaded(Morphyp m); -char mpl_get_gap_symbol(Morphyp handl); -bool mpl_almost_equal(double a, double b); -bool mpl_isreal(const double n); -void mpl_set_new_weight_public(const double wt, const int char_id, Morphyp handl); -void mpl_scale_all_intweights(Morphyp handl); -MPLchtype* mpl_get_charac_types(Morphyp handl); -int mpl_assign_partition_fxns(MPLpartition* part); -int mpl_fetch_parsim_fxn_setter (void(**pars_assign)(MPLpartition*), MPLchtype chtype); -int mpl_extend_intarray(int** array, size_t size); -int mpl_part_push_index(int newint, MPLpartition* part); -int mpl_part_remove_index(int index, MPLpartition* part); -int mpl_delete_partition(MPLpartition* part); -MPLpartition* mpl_new_partition(const MPLchtype chtype, const bool hasNA); -int mpl_count_gaps_in_columns(Morphyp handl); -int mpl_put_partitions_in_handle(MPLpartition* first, Morphyp handl); -void mpl_delete_all_update_buffers(Morphyp handl); -int mpl_allocate_update_buffers(Morphyp handl); -int mpl_setup_partitions(Morphyp handle); -int mpl_get_numparts(Morphyp handl); -MPLndsets* mpl_alloc_stateset(int numchars); -void mpl_free_stateset(const int nchars, MPLndsets* statesets); -int mpl_delete_all_partitions(Morphyp handl); -int mpl_allocate_stset_stringptrs(const int nchars, MPLndsets* set); -int mpl_setup_statesets(Morphyp handl); -int mpl_destroy_statesets(Morphyp handl); -int mpl_copy_data_into_tips(Morphyp handl); -int mpl_assign_intwts_to_partitions(Morphyp handl); -int mpl_update_root(MPLndsets* lower, MPLndsets* upper, MPLpartition* part); -int mpl_update_NA_root(MPLndsets* lower, MPLndsets* upper, MPLpartition* part); -int mpl_update_NA_root_recalculation(MPLndsets* lower, MPLndsets* upper, MPLpartition* part); - -#endif /* morphy_h */ diff --git a/src/morphy_score.cpp b/src/morphy_score.cpp deleted file mode 100644 index 945f070e3..000000000 --- a/src/morphy_score.cpp +++ /dev/null @@ -1,226 +0,0 @@ -#include -#include // for assert - -extern "C" { -#include "mpl.h" -#include "RMorphy.h" -} - -using namespace Rcpp; - -// [[Rcpp::export]] -int preorder_morphy(IntegerMatrix edge, SEXP MorphyHandl) { - Morphy handl = R_ExternalPtrAddr(MorphyHandl); - const int - n_tip = mpl_get_numtaxa(handl), - n_internal = mpl_get_num_internal_nodes(handl), - n_vertex = n_tip + n_internal, - root_node = n_tip - ; - - IntegerVector parent_of(n_vertex); - IntegerVector left_child(n_internal); - IntegerVector right_child(n_internal); - - for (int i = edge.nrow(); i--; ) { - const int - parent = edge(i, 0) - 1, - child = edge(i, 1) - 1 - ; - parent_of[child] = parent; - if (right_child[parent - n_tip]) { - left_child[parent - n_tip] = child; - } else { - right_child[parent - n_tip] = child; - } - } - parent_of[root_node] = root_node; - - const int - /* INTEGER gives pointer to first element of an R vector */ - *ancestor = parent_of.begin(), - *left = left_child.begin(), - *right = right_child.begin() - ; - - /* Initialize return variables */ - int score = 0; - morphy_length(ancestor, left, right, handl, &score); /* Updates score */ - return score; -} - -// [[Rcpp::export]] -IntegerVector preorder_morphy_by_char(IntegerMatrix edge, List MorphyHandls) { - Morphy handl = R_ExternalPtrAddr(MorphyHandls[0]); - const int - n_tip = mpl_get_numtaxa(handl), - n_internal = mpl_get_num_internal_nodes(handl), - n_vertex = n_tip + n_internal, - root_node = n_tip - ; - - IntegerVector parent_of(n_vertex); - IntegerVector left_child(n_internal); - IntegerVector right_child(n_internal); - - for (int i = edge.nrow(); i--; ) { - const int - parent = edge(i, 0) - 1, - child = edge(i, 1) - 1 - ; - parent_of[child] = parent; - if (right_child[parent - n_tip]) { - left_child[parent - n_tip] = child; - } else { - right_child[parent - n_tip] = child; - } - } - parent_of[root_node] = root_node; - - const int - /* INTEGER gives pointer to first element of an R vector */ - *ancestor = parent_of.begin(), - *left = left_child.begin(), - *right = right_child.begin() - ; - - - /* Initialize return variables */ - IntegerVector ret (MorphyHandls.length()); - for (int i = MorphyHandls.length(); i--; ) { - int score = 0; - Morphy handl = R_ExternalPtrAddr(MorphyHandls[i]); - morphy_length(ancestor, left, right, handl, &score); /* Updates score */ - ret[i] = score; - } - return ret; -} - -// [[Rcpp::export]] -double morphy_iw(IntegerMatrix edge, - List MorphyHandls, - NumericVector weight, - IntegerVector minScore, - IntegerVector sequence, - NumericVector concavity, - NumericVector target) { - const double - k = concavity[0], - target_score = target[0] - ; - Morphy handl = R_ExternalPtrAddr(MorphyHandls[0]); - const int - n_tip = mpl_get_numtaxa(handl), - n_internal = mpl_get_num_internal_nodes(handl), - n_vertex = n_tip + n_internal, - root_node = n_tip - ; - - IntegerVector parent_of(n_vertex); - IntegerVector left_child(n_internal); - IntegerVector right_child(n_internal); - - for (int i = edge.nrow(); i--; ) { - const int - parent = edge(i, 0) - 1, - child = edge(i, 1) - 1 - ; - parent_of[child] = parent; - if (right_child[parent - n_tip]) { - left_child[parent - n_tip] = child; - } else { - right_child[parent - n_tip] = child; - } - } - parent_of[root_node] = root_node; - - const int - /* INTEGER gives pointer to first element of an R vector */ - *ancestor = parent_of.begin(), - *left = left_child.begin(), - *right = right_child.begin() - ; - - - double ret = 0; - for (int index = sequence.length(); index--; ) { - const int - i = sequence[index], - weight_i = weight[i] - ; - if (weight_i) { - Morphy handl = R_ExternalPtrAddr(MorphyHandls[i]); - int e = -minScore[i]; - morphy_length(ancestor, left, right, handl, &e); /* Updates e */ - ret += weight_i * e / (k + e); - if (ret > target_score) return R_PosInf; - } - } - return ret; -} - - -// NOTE: All characters must be informative. -// [[Rcpp::export]] -double morphy_profile(IntegerMatrix edge, - List MorphyHandls, - NumericVector weight, - IntegerVector sequence, - NumericMatrix profiles, - NumericVector target) { - Morphy handl = R_ExternalPtrAddr(MorphyHandls[0]); - const int - n_tip = mpl_get_numtaxa(handl), - n_internal = mpl_get_num_internal_nodes(handl), - n_vertex = n_tip + n_internal, - root_node = n_tip - ; - const double - target_score = target[0] - ; - - IntegerVector parent_of(n_vertex); - IntegerVector left_child(n_internal); - IntegerVector right_child(n_internal); - - for (int i = edge.nrow(); i--; ) { - const int - parent = edge(i, 0) - 1, - child = edge(i, 1) - 1 - ; - parent_of[child] = parent; - if (right_child[parent - n_tip]) { - left_child[parent - n_tip] = child; - } else { - right_child[parent - n_tip] = child; - } - } - parent_of[root_node] = root_node; - - const int - /* INTEGER gives pointer to first element of an R vector */ - *ancestor = parent_of.begin(), - *left = left_child.begin(), - *right = right_child.begin() - ; - - - double ret = 0; - for (int index = sequence.length(); index--; ) { - const int - i = sequence[index], - weight_i = weight[i] - ; - if (weight_i) { - Morphy handl = R_ExternalPtrAddr(MorphyHandls[i]); - int e = -1; - morphy_length(ancestor, left, right, handl, &e); /* Updates e */ - if (e > -1) { // In case invariant sites have not been zero-weighted - assert(e < profiles.nrow()); - ret += weight_i * profiles(e, i); - } - if (ret > target_score) return R_PosInf; - } - } - return ret; -} diff --git a/src/morphydefs.h b/src/morphydefs.h deleted file mode 100644 index 61446b3b3..000000000 --- a/src/morphydefs.h +++ /dev/null @@ -1,213 +0,0 @@ -/* -// morphydefs.h -// MorPhy2 -// -// Created by mbrazeau on 07/05/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ - -#ifndef morphydefs_h -#define morphydefs_h - -#ifdef __cplusplus -extern "C" { -#endif - -#include -#include - - - typedef double Mflt; -#define MPL_EPSILON DBL_EPSILON - - typedef unsigned int MPLstate; - -#define NA ((MPLstate)1) -#define MISSING ((MPLstate)~0) -#define ISAPPLIC (((MPLstate)~0)^NA) -#define UNKNOWN ISAPPLIC -#define MAXSTATES (CHAR_BIT * sizeof(MPLstate)) -#define DEFAULTGAP '-' -#define DEFAULTMISSING '?' -#define DEFAULTUNKNOWN '+' -#define DEFAULCHARTYPE FITCH_T -#define DEFAULTWTBASE 1 -#define NACUTOFF 2 -#define MPLCHARMAX INT_MAX -#define USRWTMIN 0.00001 /*! Minimum fractional weight a caller can ask - for when setting weights. Anything less than -this will be considered 0. */ -#define MPLWTMIN (MPL_EPSILON * 10) /*! Safest (for me!) if calculations -steer pretty clear of epsilon */ - -typedef struct MPLndsets MPLndsets; -typedef struct MPLpartition MPLpartition; - -typedef int (*MPLdownfxn) - (MPLndsets* lset, - MPLndsets* rset, - MPLndsets* nset, - MPLpartition* part); - -typedef int (*MPLupfxn) - (MPLndsets* lset, - MPLndsets* rset, - MPLndsets* nset, - MPLndsets* ancset, - MPLpartition* part); - -typedef int (*MPLtipfxn) - (MPLndsets* tset, - MPLndsets* ancset, - MPLpartition* part); - -typedef int (*MPLloclfxn) - (MPLndsets* srcset, - MPLndsets* topnod, - MPLndsets* botnod, - MPLpartition* part, - int cutoff, - bool usemax); - - -typedef struct { - MPLstate asint; - char* asstr; -} MPLcell; - - -typedef struct MPLcharinfo MPLcharinfo; -struct MPLcharinfo { - - int charindex; - int ninapplics; - - MPLchtype chtype; - double realweight; - unsigned long basewt; - unsigned long intwt; - Mflt fltwt; - Mflt CIndex; - Mflt RCIndex; - Mflt HIndex; - Mflt RetIndex; - -}; - - -typedef struct { - int maxchars; - int nupdate; - int* indices; -} MPLcupdate; - - -struct MPLpartition { - - MPLchtype chtype; /*!< The optimality type used for this partition. */ - bool isNAtype; /*!< This character should be treated as having inapplicable data. */ - int maxnchars; - int ncharsinpart; - int* charindices; - unsigned long nchanges; /*!< Number of state changes in this partition. */ - int ntoupdate; - int* update_indices; - int nNAtoupdate; - int* update_NA_indices; - bool usingfltwt; - unsigned long* intwts; - Mflt* fltwts; - MPLtipfxn tipupdate; - MPLtipfxn tipfinalize; - MPLtipfxn tiproot; /*!< For the function that adds length at the base of an unrooted tree. */ - MPLtipfxn tiprootfinal; - MPLtipfxn tipupdaterecalc; - MPLtipfxn tipfinalrecalc; - MPLtipfxn tiprootrecalc; - MPLtipfxn tiprootupdaterecalc; - MPLdownfxn inappdownfxn; - MPLdownfxn inappdownrecalc2; - MPLupfxn inappupfxn; - MPLupfxn inapuprecalc2; - MPLdownfxn prelimfxn; - MPLdownfxn downrecalc1; - MPLupfxn finalfxn; - MPLupfxn uprecalc1; - MPLloclfxn loclfxn; - MPLpartition* next; - -}; - - -struct MPLndsets { - - bool updated; - int steps_to_recall; - MPLstate* downpass1; - MPLstate* uppass1; - MPLstate* downpass2; - MPLstate* uppass2; - MPLstate* subtree_actives; - MPLstate* temp_subtr_actives; - MPLstate* temp_downpass1; - MPLstate* temp_uppass1; - MPLstate* temp_downpass2; - MPLstate* temp_uppass2; - bool* changes; - char** downp1str; - char** downp2str; - char** upp1str; - char** upp2str; - -}; - - -typedef struct mpl_matrix_s { - int ncells; - MPLcell* cells; -} MPLmatrix; - - -typedef struct symbols_s { - int numstates; - char* statesymbols; - char* symbolsinmatrix; - MPLstate* packed; - char gap; - char missing; -} MPLsymbols; - - -/*! \struct*/ -typedef struct Morphy_t { - - int numtaxa; - int numcharacters; - int numrealwts; - MPLcharinfo* charinfo; - unsigned long usrwtbase; - unsigned long wtbase; - int numparts; - MPLpartition* partstack; - MPLpartition** partitions; - MPLsymbols symbols; - MPLgap_t gaphandl; - union { - int asint; - Mflt asfloat; - } score; - MPLmatrix inmatrix; - char* char_t_matrix; - int numnodes; - int* nodesequence; - int nthreads; - MPLndsets** statesets; - -} Morphy_t, *Morphyp; - - -#ifdef __cplusplus -} -#endif - -#endif /* morphydefs_h */ diff --git a/src/mpl.c b/src/mpl.c deleted file mode 100644 index af0a16423..000000000 --- a/src/mpl.c +++ /dev/null @@ -1,1038 +0,0 @@ -/* -* mpl.c -* MorPhy2 -* -* Created by mbrazeau on 04/05/2017. -* Copyright © 2017 brazeaulab. All rights reserved. -*/ - -#include "mpl.h" -#include "morphydefs.h" -#include "morphy.h" -#include "mplerror.h" -#include "statedata.h" - -/* TODO: This is temporary */ -#include "fitch.h" - -Morphy mpl_new_Morphy(void) -{ - Morphyp new = mpl_new_Morphy_t(); - - return (Morphy)new; -} - - -int mpl_delete_Morphy(Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - Morphyp m1 = (Morphyp)m; - - free(m1->char_t_matrix); - m1->char_t_matrix = NULL; - mpl_delete_mpl_matrix(&m1->inmatrix); - mpl_destroy_symbolset(m1); - mpl_delete_charac_info(m1); - mpl_delete_all_update_buffers(m1); /* MS addition, 2021-01-30 */ - mpl_delete_all_partitions(m1); - mpl_destroy_statesets(m1); - free(m1); - - return ERR_NO_ERROR; -} - - -int mpl_init_Morphy(const int ntax, const int nchar, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - if (!ntax || !nchar) { - return ERR_NO_DIMENSIONS; - } - - int ret = ERR_NO_ERROR; - Morphyp mi = (Morphyp)m; - - if (ntax != mpl_get_numtaxa(m)) { - if (mpl_check_data_loaded(mi)) { - return ERR_EX_DATA_CONF; - } - } - - if (nchar != mpl_get_num_charac(m)) { - if (mpl_check_data_loaded(mi)) { - return ERR_EX_DATA_CONF; - } - } - - ret = mpl_set_numtaxa(ntax, mi); - if (ret) { - return ret; - } - - ret = mpl_set_num_internal_nodes(ntax, mi); - if (ret) { - return ret; - } - - ret = mpl_set_num_charac(nchar, mi); - if (ret) { - return ret; - } - - /* TODO: Revise this? */ - mpl_init_charac_info(mi); - - return ret; -} - - -int mpl_get_numtaxa(Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - return ((Morphyp)m)->numtaxa; -} - - -int mpl_get_num_charac(Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - return ((Morphyp)m)->numcharacters; -} - - -int mpl_set_num_internal_nodes(const int nnodes, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - int ntax = 0; - if (!(ntax = mpl_get_numtaxa(m))) { - return ERR_NO_DIMENSIONS; - } - - ((Morphyp)m)->numnodes = nnodes + ntax; - - return ERR_NO_ERROR; -} - - -int mpl_get_num_internal_nodes(Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - return (((Morphyp)m)->numnodes - mpl_get_numtaxa(m)); -} - -int mpl_attach_symbols(const char *symbols, Morphy m) -{ - if (!symbols || !m) { - return ERR_BAD_PARAM; - } - - int isdataloaded = mpl_check_data_loaded((Morphyp)m); - - int i = 0; - int len = 0; - - while(isalnum(symbols[i])) { - ++len; - ++i; - }; - ++len; - - char* symbsnospaces = (char*)calloc(len, sizeof(char)); - - int j = 0; - for (i = 0; symbols[i]; ++i) { - if (isalnum(symbols[i])) { - symbsnospaces[j] = symbols[i]; - ++j; - } - } - symbsnospaces[j] = '\0'; - - if (isdataloaded) { - char* matrixsymbs = mpl_query_symbols_from_matrix((Morphyp)m); - assert(matrixsymbs); - - if (mpl_compare_symbol_lists(symbsnospaces, matrixsymbs)) { - free(symbsnospaces); - return ERR_SYMBOL_MISMATCH; - } - } - - ((Morphyp)m)->symbols.statesymbols = symbsnospaces; - - return ERR_NO_ERROR; -} - - -char* mpl_get_symbols(Morphy m) -{ - - Morphyp mi = (Morphyp)m; - - return mi->symbols.statesymbols; -} - - -int mpl_attach_rawdata(const char* rawmatrix, Morphy m) -{ - if (!rawmatrix || !m) { - return ERR_BAD_PARAM; - } - - if (!mpl_get_numtaxa(m) || !mpl_get_num_charac(m)) { - return ERR_NO_DIMENSIONS; - } - - Morphyp m1 = (Morphyp)m; - if (mpl_check_data_loaded(m1)) { - return ERR_EX_DATA_CONF; - } - mpl_copy_raw_matrix(rawmatrix, m1); - - /* Check validity of preprocessed matrix */ - MPL_ERR_T err = ERR_NO_ERROR; - err = mpl_check_nexus_matrix_dimensions(mpl_get_preprocessed_matrix(m1), - mpl_get_numtaxa(m1), - mpl_get_num_charac(m1)); - - if (err) { - mpl_delete_rawdata(m1); - return err; - } - - err = mpl_preproc_rawdata((Morphyp)m); - - return err; -} - - -int mpl_delete_rawdata(Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - Morphyp mp = (Morphyp)m; - - /* TODO: This must reset all matrix dependencies */ - if (mp->char_t_matrix) { - free(mp->char_t_matrix); - mp->char_t_matrix = NULL; - mpl_delete_mpl_matrix(mpl_get_mpl_matrix((Morphyp)m)); - mpl_delete_all_partitions((Morphyp)m); - - } - return ERR_NO_ERROR; -} - - -int mpl_apply_tipdata(Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp mi = (Morphyp)m; - - /* Create dictionary and convert */ - mpl_create_state_dictionary(mi); - mpl_convert_cells(mi); - - /* TODO: Check for existing partitions; */ - /* Call here */ - - /* Setup the partitions */ - mpl_setup_partitions(mi); - mpl_scale_all_intweights(mi); - mpl_assign_intwts_to_partitions(mi); - - /* Create all the internal data memory */ - mpl_setup_statesets(mi); - - /* Apply the data to the tips */ - mpl_copy_data_into_tips(mi); - - return ERR_NO_ERROR; -} - - -int mpl_set_charac_weight(const int charID, const double weight, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - if (!mpl_get_num_charac(m)) { - return ERR_NO_DIMENSIONS; - } - - if (charID >= mpl_get_num_charac(m)) { - return ERR_OUT_OF_BOUNDS; - } - - Morphyp mi = (Morphyp)m; - mpl_set_new_weight_public(weight, charID, mi); - - return ERR_NO_ERROR; -} - - -unsigned long mpl_get_charac_weight -(double* weight, const int char_id, const Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - if (char_id >= mpl_get_num_charac(m)) { - return ERR_OUT_OF_BOUNDS; - } - - Morphyp mi = (Morphyp)m; - - *weight = (double) mi->charinfo[char_id].intwt/mi->charinfo[char_id].basewt; - - return mi->charinfo[char_id].intwt; -} - - -int mpl_set_parsim_t(const int charID, const MPLchtype chtype, Morphy m) -{ - if (!m) { - return ERR_BAD_PARAM; - } - - MPL_ERR_T err = ERR_NO_ERROR; - - if (chtype >= MAX_CTYPE) { - return ERR_UNKNOWN_CHTYPE; - } - - if (charID >= mpl_get_num_charac(m)) { - return ERR_OUT_OF_BOUNDS; - } - - if ((err = mpl_fetch_parsim_fxn_setter(NULL, chtype))) { - return err; - } - - Morphyp handl = (Morphyp)m; - handl->charinfo[charID].chtype = chtype; - - if (chtype == NONE_T) { - handl->charinfo[charID].realweight = 0.0; - } - else { - handl->charinfo[charID].realweight = handl->wtbase; - } - - return ERR_NO_ERROR; -} - - -int mpl_set_gaphandl(const MPLgap_t gaptype, Morphy m) -{ - if (!m) { - return ERR_BAD_PARAM; - } - - Morphyp mp = (Morphyp)m; - mp->gaphandl = gaptype; - return ERR_NO_ERROR; -} - - -int mpl_query_gaphandl(Morphy m) -{ - if (!m) { - return ERR_BAD_PARAM; - } - - return mpl_get_gaphandl((Morphyp)m); -} - - -int mpl_first_down_recon -(const int node_id, const int left_id, const int right_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLdownfxn downfxn = NULL; - - nstates->updated = false; - - for (i = 0; i < numparts; ++i) { - downfxn = handl->partitions[i]->prelimfxn; - res += downfxn(lstates, rstates, nstates, handl->partitions[i]); - } - - return res; -} - - -int mpl_first_up_recon -(const int node_id, const int left_id, const int right_id, const int anc_id, - Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - MPLndsets* astates = handl->statesets[anc_id]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLupfxn upfxn = NULL; - - nstates->updated = false; - - for (i = 0; i < numparts; ++i) { - upfxn = handl->partitions[i]->finalfxn; - res += upfxn(lstates, rstates, nstates, astates, handl->partitions[i]); - } - - return res; -} - - -int mpl_second_down_recon -(const int node_id, const int left_id, const int right_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLdownfxn downfxn = NULL; - - nstates->updated = false; - - for (i = 0; i < numparts; ++i) { - downfxn = handl->partitions[i]->inappdownfxn; - if (downfxn) { - res += downfxn(lstates, rstates, nstates, handl->partitions[i]); - } - downfxn = NULL; - } - - return res; -} - - -int mpl_second_up_recon -(const int node_id, const int left_id, const int right_id, const int anc_id, - Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - MPLndsets* astates = handl->statesets[anc_id]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLupfxn upfxn = NULL; - - nstates->updated = false; - - for (i = 0; i < numparts; ++i) { - upfxn = handl->partitions[i]->inappupfxn; - if (upfxn) { - res += upfxn(lstates, rstates, nstates, astates, - handl->partitions[i]); - } - } - - return res; -} - -int mpl_update_tip(const int tip_id, const int anc_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* tipset = handl->statesets[tip_id]; - MPLndsets* ancset = handl->statesets[anc_id]; - - int i = 0; - int numparts = mpl_get_numparts(handl); - MPLtipfxn tipfxn = NULL; - - tipset->updated = false; - - for (i = 0; i < numparts; ++i) { - tipfxn = handl->partitions[i]->tipupdate; - tipfxn(tipset, ancset, handl->partitions[i]); - } - - - return ERR_NO_ERROR; -} - - -int mpl_finalize_tip(const int tip_id, const int anc_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* tipset = handl->statesets[tip_id]; - MPLndsets* ancset = handl->statesets[anc_id]; - - int i = 0; - int numparts = mpl_get_numparts(handl); - MPLtipfxn tipfxn = NULL; - - tipset->updated = false; - - for (i = 0; i < numparts; ++i) { - tipfxn = handl->partitions[i]->tipfinalize; - if (tipfxn) { - tipfxn(tipset, ancset, handl->partitions[i]); - } - } - - - return ERR_NO_ERROR; -} - - -int mpl_update_lower_root(const int l_root_id, const int root_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* lower = handl->statesets[l_root_id]; - MPLndsets* upper = handl->statesets[root_id]; - MPLpartition** parts = handl->partitions; - - int i = 0; - int numparts = mpl_get_numparts(handl); - - for (i = 0; i < numparts; ++i) { - if (!parts[i]->isNAtype) { - mpl_update_root(lower, upper, parts[i]); - } else { - mpl_update_NA_root(lower, upper, parts[i]); - } - } - - return ERR_NO_ERROR; -} - -int mpl_do_tiproot(const int tip_id, const int node_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* lower = handl->statesets[tip_id]; - MPLndsets* upper = handl->statesets[node_id]; - MPLpartition** parts = handl->partitions; - - MPLtipfxn tiprootfxn = NULL; - int i = 0; - int numparts = mpl_get_numparts(handl); - int res = 0; - - lower->updated = false; - - for (i = 0; i < numparts; ++i) { - - tiprootfxn = parts[i]->tiproot; - res += tiprootfxn(lower, upper, parts[i]); - } - - return res; -} - - -int mpl_finalize_tiproot(const int tip_id, const int node_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* lower = handl->statesets[tip_id]; - MPLndsets* upper = handl->statesets[node_id]; - MPLpartition** parts = handl->partitions; - - MPLtipfxn tiprootfxn = NULL; - int i = 0; - int numparts = mpl_get_numparts(handl); - int res = 0; - - lower->updated = false; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - tiprootfxn = parts[i]->tiprootfinal; - res += tiprootfxn(lower, upper, parts[i]); - } - } - - return res; -} - -int mpl_na_tiproot_recalculation(const int tip_id, const int node_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* lower = handl->statesets[tip_id]; - MPLndsets* upper = handl->statesets[node_id]; - MPLpartition** parts = handl->partitions; - - MPLtipfxn tiprootfxn = NULL; - int i = 0; - int numparts = mpl_get_numparts(handl); - int res = 0; - - lower->updated = false; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - tiprootfxn = parts[i]->tiprootrecalc; - res += tiprootfxn(lower, upper, parts[i]); - } - } - - return res; -} - -int mpl_na_tiproot_final_recalculation -(const int tip_id, const int node_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* lower = handl->statesets[tip_id]; - MPLndsets* upper = handl->statesets[node_id]; - MPLpartition** parts = handl->partitions; - - MPLtipfxn tiprootfxn = NULL; - int i = 0; - int numparts = mpl_get_numparts(handl); - int res = 0; - - lower->updated = false; - - lower->steps_to_recall = 0; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - tiprootfxn = parts[i]->tiprootupdaterecalc; - res += tiprootfxn(lower, upper, parts[i]); - } - } - - return res; -} - -int mpl_na_first_down_recalculation -(const int node_id, const int left_id, const int right_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - - int i = 0; - int numparts = mpl_get_numparts(handl); - MPLdownfxn downfxn = NULL; - - nstates->updated = false; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - downfxn = handl->partitions[i]->downrecalc1; - downfxn(lstates, rstates, nstates, handl->partitions[i]); - } - } - - return ERR_NO_ERROR; -} - - -int mpl_na_first_up_recalculation -(const int node_id, const int left_id, const int right_id, const int anc_id, - Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - MPLndsets* astates = handl->statesets[anc_id]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLupfxn upfxn = NULL; - - nstates->updated = false; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - upfxn = handl->partitions[i]->uprecalc1; - upfxn(lstates, rstates, nstates, astates, handl->partitions[i]); - } - } - - return res; -} - - -int mpl_na_second_down_recalculation -(const int node_id, const int left_id, const int right_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLdownfxn downfxn = NULL; - - nstates->updated = false; - nstates->steps_to_recall = 0; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - downfxn = handl->partitions[i]->inappdownrecalc2; - res += downfxn(lstates, rstates, nstates, handl->partitions[i]); - } - } - - return res; -} - - -int mpl_na_second_up_recalculation -(const int node_id, const int left_id, const int right_id, const int anc_id, - Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* nstates = handl->statesets[node_id]; - MPLndsets* lstates = handl->statesets[left_id]; - MPLndsets* rstates = handl->statesets[right_id]; - MPLndsets* astates = handl->statesets[anc_id]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLupfxn upfxn = NULL; - - nstates->updated = false; - nstates->steps_to_recall = 0; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - upfxn = handl->partitions[i]->inapuprecalc2; - res += upfxn(lstates, rstates, nstates, astates, handl->partitions[i]); - } - } - - return res; -} - - -int mpl_lower_root_recalculation(const int l_root_id, const int root_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* lower = handl->statesets[l_root_id]; - MPLndsets* upper = handl->statesets[root_id]; - MPLpartition** parts = handl->partitions; - - int i = 0; - int numparts = mpl_get_numparts(handl); - - for (i = 0; i < numparts; ++i) { - if (parts[i]->isNAtype) { - mpl_update_NA_root_recalculation(lower, upper, parts[i]); - } - } - - return ERR_NO_ERROR; -} - - -int mpl_na_update_tip(const int tip_id, const int anc_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* tipset = handl->statesets[tip_id]; - MPLndsets* ancset = handl->statesets[anc_id]; - - int i = 0; - int numparts = mpl_get_numparts(handl); - MPLtipfxn tipfxn = NULL; - - tipset->updated = false; - - for (i = 0; i < numparts; ++i) { - if (handl->partitions[i]->isNAtype == true) { - tipfxn = handl->partitions[i]->tipupdaterecalc; - tipfxn(tipset, ancset, handl->partitions[i]); - } - } - - - return ERR_NO_ERROR; -} - -int mpl_get_step_recall(const int node_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - - int ret = handl->statesets[node_id]->steps_to_recall; - handl->statesets[node_id]->steps_to_recall = 0; - - return ret; - -} - -int mpl_get_insertcost -(const int srcID, const int tgt1ID, const int tgt2ID, const bool max, - const int cutoff, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp handl = (Morphyp)m; - MPLndsets* srcset = handl->statesets[srcID]; - MPLndsets* tgt1set = handl->statesets[tgt1ID]; - MPLndsets* tgt2set = handl->statesets[tgt2ID]; - - int i = 0; - int res = 0; - int numparts = mpl_get_numparts(handl); - MPLloclfxn loclfxn = NULL; - - for (i = 0; i < numparts; ++i) { - handl->partitions[i]->nNAtoupdate = 0; - loclfxn = handl->partitions[i]->loclfxn; - res += loclfxn(srcset, tgt1set, tgt2set, handl->partitions[i], cutoff, max); - loclfxn = NULL; - } - - return res; -} - - -int mpl_check_reopt_inapplics(Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp mi = (Morphyp)m; - int n = 0; - int i = 0; - for (i = 0; i < mi->numparts; ++i) { - if (mi->partitions[i]->isNAtype == true) { - n += mi->partitions[i]->nNAtoupdate; - } - } - - return n; -} - -bool mpl_check_updated(const int node_id, Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp mi = (Morphyp)m; - - return mi->statesets[node_id]->updated; -} - -int mpl_restore_original_sets(const int node_id, Morphy m) -{ - if (m == NULL) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp mi = (Morphyp)m; - int i = 0; - int k = 0; - - for (i = 0; i < mi->numparts; ++i) { - if (mi->partitions[i]->isNAtype) { - - /* Set any flags or temp variables back to defaults */ - mi->statesets[node_id]->updated = false; - mi->statesets[node_id]->steps_to_recall = 0; - - /* Restore the original sets */ - for (k = 0; k < mi->partitions[i]->ncharsinpart; ++k) { - - int j = 0; - j = mi->partitions[i]->charindices[k]; - - mi->statesets[node_id]->downpass1[j] - = mi->statesets[node_id]->temp_downpass1[j]; - mi->statesets[node_id]->uppass1[j] - = mi->statesets[node_id]->temp_uppass1[j]; - mi->statesets[node_id]->downpass2[j] - = mi->statesets[node_id]->temp_downpass2[j]; - mi->statesets[node_id]->uppass2[j] - = mi->statesets[node_id]->temp_uppass2[j]; - mi->statesets[node_id]->subtree_actives[j] - = mi->statesets[node_id]->temp_subtr_actives[j]; - } - } - } - - return ERR_NO_ERROR; -} - - -unsigned int mpl_get_packed_states -(const int nodeID, const int character, const int passnum, const Morphy m) -{ - if (!m) { - return ERR_UNEXP_NULLPTR; - } - - Morphyp mi = (Morphyp)m; - - if (passnum == 1) { - return (int)mi->statesets[nodeID]->downpass1[character]; - } - else if (passnum == 2) { - return (int)mi->statesets[nodeID]->uppass1[character]; - } - else if (passnum == 3) { - return (int)mi->statesets[nodeID]->downpass2[character]; - } - else if (passnum == 4) { - return (int)mi->statesets[nodeID]->uppass2[character]; - } - - return ERR_BAD_PARAM; -} - -const char* mpl_get_stateset -(const int nodeID, const int character, const int passnum, Morphy m) -{ - MPLstate result = mpl_get_packed_states(nodeID, character, passnum, m); - char* ret = mpl_translate_state2char(result, (Morphyp)m); - - Morphyp mi = (Morphyp)m; - - - mpl_allocate_stset_stringptrs(mpl_get_num_charac(m), mi->statesets[nodeID]); - - if (passnum == 1) { - if (mi->statesets[nodeID]->downp1str[character]) { - free(mi->statesets[nodeID]->downp1str[character]); - } - mi->statesets[nodeID]->downp1str[character] = ret; - } - else if (passnum == 2) { - if (mi->statesets[nodeID]->upp1str[character]) { - free(mi->statesets[nodeID]->upp1str[character]); - } - mi->statesets[nodeID]->upp1str[character] = ret; - } - else if (passnum == 3) { - if (mi->statesets[nodeID]->downp2str[character]) { - free(mi->statesets[nodeID]->downp2str[character]); - } - mi->statesets[nodeID]->downp2str[character] = ret; - } - else if (passnum == 4) { - if (mi->statesets[nodeID]->upp2str[character]) { - free(mi->statesets[nodeID]->upp2str[character]); - } - mi->statesets[nodeID]->upp2str[character] = ret; - } - - return ret; -} diff --git a/src/mpl.h b/src/mpl.h deleted file mode 100644 index dac0d153d..000000000 --- a/src/mpl.h +++ /dev/null @@ -1,827 +0,0 @@ - /*! - @file mpl.h - - @brief Defines the Morphy Phylogenetic Library API: a library for phylogenetic - computation accommodating morphological character hierarchies. - - Copyright (C) 2017 Martin D. Brazeau - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - - @discussion This header includes all the externally exported definitions and - function prototypes. A calling program creates an instance of a Morphy object - and interacts with its elements through the functions described in this - interface. The Morphy object contains no tree objects, but requires a - pre-specified list of indices (integers) corresponding to the node indices in - the calling program. Morphy will not keep track of the relationships between - the nodes, and it is up to the caller to keep track of these. Each character - *must* be assigned a type, and Morphy will make no default assumptions. Once - one or more characters are assigned a function type (which creates internal - partitions), and a postorder list of nodes is known, then the library functions - can be called to reconstruct state sets and deliver length estimates for each - node. - - Morphy will provide functions for local reoptimisation, partial reoptimisation - and optimisation of subtrees. - - */ - -#ifndef mpl_h -#define mpl_h - - -#ifdef __cplusplus - extern "C" { -#endif /*__cplusplus */ - -#include -#include "mplerror.h" - -typedef void* Morphy; - -typedef enum { - - NONE_T = 0, - FITCH_T = 1, - WAGNER_T = 2, - DOLLO_T = 3, - IRREVERSIBLE_T = 4, - USERTYPE_T = 5, - - MAX_CTYPE - -} MPLchtype; - -typedef enum { - - GAP_INAPPLIC, - GAP_MISSING, - GAP_NEWSTATE, - - GAP_MAX - -} MPLgap_t; - - /* Public functions */ - - /*! - - @brief Creates a new instance of a Morphy object - - @discussion Creates a new empty Morphy object. All fields are unpopulated and - uninitialised. - - @return A void pointer to the Morphy instance. NULL if unsuccessful. - - */ -Morphy mpl_new_Morphy - - (void); - - - /*! - - @brief Destroys an instance of a Morphy object. - - @discussion Destroys an instance of the Morphy object, calling all destructors - for internal object completely returning the memory to the system. - - @param m A Morphy object to be destroyed. - - @return A Morphy error code. - - */ -int mpl_delete_Morphy - - (Morphy m); - - -/*! - - @brief Sets up the dimensions of the dataset. - - @discussion Provides initial dimensions for the dataset, which will constrain - any input matrix supplied to Morphy. - - @param ntax The number of taxa (or tips/terminals). - - @param nchar The number of characters (i.e. transformation series) in the - data set. - - @param m An instance of the Morphy object. - - @return Morphy error code. - - */ -int mpl_init_Morphy - - (const int ntax, - const int nchar, - Morphy m); - - -/*! - - @brief Retrieve the number of taxa (rows) in the dataset. - - @discussion Retrieves the number of taxa (rows) in the dataset. - - @param m An instance of the Morphy object. - - @return The number of taxa if success, otherwise an error code. - - */ -int mpl_get_numtaxa - - (Morphy m); - - -/*! - - @brief Retrieve the number of taxa (rows) in the dataset. - - @discussion Retrieves the number of taxa (rows) in the dataset. - - @param m An instance of the Morphy object. - - @return The number of taxa if success, otherwise an error code. - - */ -int mpl_get_num_charac - - (Morphy m); - - -/*! - - @brief Sets the number of internal nodes in the dataset - - @discussion This specifies the number of internal nodes over which - reconstruction sets need to be made. It is up to the caller to ensure the - correct number of nodes and the relationships between them. - - @param nnodes The desired number of internal nodes. - - @param m An instance of the Morphy object - - @return A Morphy error code. - -*/ -int mpl_set_num_internal_nodes - - (const int nnodes, - Morphy m); - -/*! - - @brief Gets the number of internal nodal reconstruction sets being used by - MorphyLib. - - @discussion Gets the number of internal nodal reconstruction sets being used by - MorphyLib. - - @param m An instance of the Morphy object. - - @return The number of internal nodes. - -*/ -int mpl_get_num_internal_nodes - - (Morphy m); - -/*! - - @brief Attach a caller-specified list of symbols. - - @discussion Allows the caller to specify a list of symbols in the data matrix, - otherwise, the symbols list used by Morphy will be extracted from the matrix. - The symbols list must match the symbols provided in the matrix. When Morphy - extracts symbols from the matrix, their ordering is alphanumeric, according to - their ASCII codes (i.e. "+0123...ABCD...abcd..."). Loading a user-specified - symbols list will override this ordering. Symbols loaded in either the list or - the matrix must be valid Morphy character state symbols as defined in the - statedata.h header file. - - @param symbols A C-style (i.e. NULL-terminated) string of valid state symbols. - - @param m An instance of the Morphy object. - - @return Morphy error code. - - */ -int mpl_attach_symbols - - (const char* symbols, - Morphy m); - - -/*! - - @brief Retrieves the current list of symbols. - - @discussion Returns a pointer to the string of character state symbols - currently being used by Morphy (i.e. either the list of symbols extracted - from the matrix, or the caller-specified values). - - @param m An instance of the Morphy object. - - @return A C-style (null-terminated) string of the character state symbols being - used. NULL if failure. - - */ -char* mpl_get_symbols - - (const Morphy m); - - -/*! - - @brief Attach raw character state data (i.e. tip data). - - - @discussion Attaches a raw data character state matrix in the form of a C-style - (i.e. NULL-terminated string). This can be the matrix block extracted from a - Nexus file or an xread table format. The matrix should contain no terminal or - tip labels. - - @param rawmatrix C-style string corresponding to the tip data. - - @param m An instance of the Morphy object. - - @return Morphy error code. - - */ -int mpl_attach_rawdata - - (const char* rawmatrix, - Morphy m); - - -/*! - - @brief Deletes the caller-input data - - @discussion Deletes all of the user-input data and restores all parameters to - their original values, except for the dimensions of the matrix. - - @param m An instance of the Morphy object. - - @return Morphy error code. -*/ -int mpl_delete_rawdata - - (Morphy m); - - -int mpl_set_gap_symbol - - (const char gapsymb, - Morphy m); - - -int mpl_set_missing_symbol - - (const char missymb, - Morphy m); - - -/*! - - @brief Commits parameters prior to nodal set calculations. - - @discussion Once the caller is satisfied with the setup of types, weights, and - partitioning, this function must be called, thereby committing the parameters - until any changes are made. If no character types have been assigned, the - function will fail with an error code. - - @param m An instance of the Morphy object. - - @return A Morphy error code. -*/ -int mpl_apply_tipdata - - (Morphy m); - - -int mpl_incl_charac - - (const int charID, - Morphy m); - - -int mpl_excl_charac - - (const int charID, - Morphy m); - - -/*! - - @brief Sets the weight for a specified character. - - @discussion Sets a weight for a specified character. The function takes a - floating point value. However, in the current implementation, fractional values - will be interpreted and estimated using an approximation of the rational - factors. In the current version, MorphyLib uses this method to circumvent any - floating point calculations that aren't absolutely necessary. - - @param charID The index of the character to be weighted. - - @param weight The weight requested for the character. - - @param m An instance of the Morphy object. - - @return A Morphy error code. - - */ -int mpl_set_charac_weight - - (const int charID, - const double weight, - Morphy m); - -/* TODO: Document */ -unsigned long mpl_get_charac_weight - - (double* weight, - const int char_id, - const Morphy m); - -/*! - - @brief Sets a character's parsimony function type - - @discussion Set the parsimony function type to one defined in the morphydefs.h - header file. Setting the character to type NONE_T will also cause it to be - excluded from any further calculations. - - @param charID The index of the character (transformation series) as defined in - the input matrix. - - @param chtype The parsimony function type as defined in morphydefs.h - - @param m An instance of the Morphy object. - - @return A Morphy error code. - - */ -int mpl_set_parsim_t - - (const int charID, - const MPLchtype chtype, - Morphy m); - - -/*! - - @brief Tells MorphyLib how to treat the gap symbol. - - @discussion The caller can specify the type of gap handling to use before the - tipdata are applied. The options are documented in the morphydefs.h header file - but include at least GAP_INAPPLIC, GAP_MISSING, and GAP_NEWSTATE to specify - inapplicable, missing, or new state values respectively. These values are - applied to all characters for which they are appropriate. - - @param gaptype The type of gap treatment to be applied (documented in - morphydefs.h). - - @param m An instance of the Morphy object. - - @return A Morphy error code. - -*/ -int mpl_set_gaphandl - - (const MPLgap_t gaptype, - Morphy m); - -/*! - - @brief Returns the type of gap handling method currently in effect. - - @discussion Returns the type of gap handling method currently in effect. The - methods are defined in the morphydefs.h file. - - @param m An instance of the Morphy object. - - @return A Morphy error code. - -*/ -int mpl_query_gaphandl - - (Morphy m); - - -/*! - - @brief Reconstructs the first (downpass) nodal reconstructions - - @discussion Reconstructs the preliminary nodal set for all characters for a - particular node. This function is called over a postorder sequence of internal - nodes where left and right descendants are known. - - Because this function needs to be fairly high-performance, it does not do much - checking for parameter validity, thus unsafe usage of this function might not - be caught. It is up to calling functions to ensure that the appropriate - parameters have been set before use. - - @param node_id The index of the node being reconstructed. - - @param left_id The index of the left descendant. - - @param right_id The index of the right descendant. - - @param m An instance of the Morphy object. - - @return The integral parsimony length (right now) - - */ -int mpl_first_down_recon - - (const int node_id, - const int left_id, - const int right_id, - Morphy m); - - -/*! - - @brief Reconstructs the second (uppass) nodal reconstructions. - - @discussion Reconstructs second-pass nodal sets. For normal (all-applicable) - characters, this is the final pass. This function is called over a preorder - sequence of nodes where left, right, and ancestral nodes are known. - - Because this function needs to be fairly high-performance, it does not do much - checking for parameter validity, thus unsafe usage of this function might not - be caught. It is up to calling functions to ensure that the appropriate - parameters have been set before use. - - @param node_id The index of the node being reconstructed. - - @param left_id The index of the left descendant. - - @param right_id The index of the right descendant. - - @param anc_id The index of the immediate ancestor of the node. - - @param m An instance of the Morphy object. - - @return A null value (for now). - */ -int mpl_first_up_recon - (const int node_id, - const int left_id, - const int right_id, - const int anc_id, - Morphy m); - - -/*! - - @brief Performs the second nodal reconstructions for characters with - inapplicability. - - @discussion Updates the nodal sets that had ambiguous unions with the - inapplicable state and calculates steps involving applicable states after - the update. - - Because this function needs to be fairly high-performance, it does not do much - checking for parameter validity, thus unsafe usage of this function might not - be caught. It is up to calling functions to ensure that the appropriate - parameters have been set before use. - - @param node_id The index of the node being reconstructed. - - @param left_id The index of the left descendant. - - @param right_id The index of the right descendant. - - @param m An instance of the Morphy object. - - @return The integral parsimony length (right now) - */ -int mpl_second_down_recon - - (const int node_id, - const int left_id, - const int right_id, - Morphy m); - - -/*! - - @brief Finalises the ancestral state reconstructions for characters with - inapplicable values. - - @discussion Finalises the nodal sets for any characters that may have involved - the inapplicable token and counts excess regions of applicability at nodes - having at least two descendant subtrees that possess any applicable characters. - - Because this function needs to be fairly high-performance, it does not do much - checking for parameter validity, thus unsafe usage of this function might not - be caught. It is up to calling functions to ensure that the appropriate - parameters have been set before use. - - @param node_id The index of the node being reconstructed. - - @param left_id The index of the left descendant. - - @param right_id The index of the right descendant. - - @param anc_id The index of the immediate ancestor of the node. - - @param m An instance of the Morphy object. - - @return The integral parsimony length (for now) - */ -int mpl_second_up_recon - - (const int node_id, - const int left_id, - const int right_id, - const int anc_id, - Morphy m); - - -/*! - - @brief Initial update of tip values following uppass reconstruction - - @discussion Polymorphic terminal state sets need to be resolved after the - uppass based on descendant state values in order for local reoptimisation - procedures to be accurate and for inapplicable step counting to proceed - accurately. This function calls updaters for the records of states active on - the subtrees, thereby allowing the second downpass to accurately reconstruct - subtree state activity. Missing values are left as-is in characters with - inapplicability, otherwise, final ancestral state reconstructions may be - inaccurate. - - Because this function needs to be fairly high-performance, it does not do much - checking for parameter validity, thus unsafe usage of this function might not - be caught. It is up to calling functions to ensure that the appropriate - parameters have been set before use. - - @param tip_id The index of the tip being updated. - - @param anc_id The index of the tip's immediate ancestor. - - @param m An instance of the Morphy object. - - @return A null value (for now). - */ -int mpl_update_tip - - (const int tip_id, - const int anc_id, - Morphy m); - -/*! - - @brief Finalizes ambiguous or missing values in the tips. - - @discussion Ambiguous terminal state sets need to be resolved after the uppass - based on descendant state values in order for local reoptimisation procedures - to be accurate and for inapplicable step counting to proceed accurately. This - function calls updaters for the records of states active on the subtrees, - thereby allowing local reoptimization functions to accurately predict length - increases when a subtree is added near a tip. - - Because this function needs to be fairly high-performance, it does not do much - checking for parameter validity, thus unsafe usage of this function might not - be caught. It is up to calling functions to ensure that the appropriate - parameters have been set before use. - - @param tip_id The index of the tip being updated. - - @param anc_id The index of the tip's immediate ancestor. - - @param m An instance of the Morphy object. - - @return A null value (for now). - */ -int mpl_finalize_tip - - (const int tip_id, - const int anc_id, - Morphy m); - -/*! - @brief Used to update a root-like tip in an unrooted tree and length added. - - @discussion If using an unrooted tree structure, a tip is commonly used as an - entry point for traversals on the tree. This tip is jointed either as an extra - descendant or the ancestor of the calculation root node in the tree. In these - circumstances, a binary traversal on the tree will not give complete - reconstructions or length counts for the tree. This function is called at the - end of the optimization process and is required for the complete tree length of - an unrooted tree. This function will update the state sets of both nodes - reciprocally. - - @param tip_id An index corresponding to the tip number being updated. - - @param node_id An index of the tip's neighboring internal node. - - @param m An instance of the Morphylib object. - - @return The weighted number of steps (positive) or a negative number - corresponding to a morphylib error code. - */ - -int mpl_do_tiproot - - (const int tip_id, - const int node_id, - Morphy m); - -int mpl_finalize_tiproot - - (const int tip_id, - const int node_id, - Morphy m); -/*! - - @brief Updates the nodal sets for a lower ('dummy') root node - - @discussion If trees are rooted, then Morphy uppass functions - require a lower or 'dummy' root in order to function properly. This - function should be called to set the nodal state sets to the dummy - root. The nodal set will be equal to the set of the root node, unless - there is an ambiguous union of applicable and gap tokens when gaps are - treated as in applicable. In which case, the set union is resolved in - favour of any applicable tokens in the set. - - @param l_root_id The index of the lower root. - - @param root_id The index of the upper root node. - - @return A Morphy error code. - - */ -int mpl_update_lower_root - - (const int l_root_id, - const int root_id, - Morphy m); - - -int mpl_na_first_down_recalculation - - (const int node_id, - const int left_id, - const int right_id, - Morphy m); - - -int mpl_na_first_up_recalculation - - (const int node_id, - const int left_id, - const int right_id, - const int anc_id, - Morphy m); - - -/* Returns number of steps to add */ -int mpl_na_second_down_recalculation - - (const int node_id, - const int left_id, - const int right_id, - Morphy m); - -/* Returns number of steps to add */ -int mpl_na_second_up_recalculation - - (const int node_id, - const int left_id, - const int right_id, - const int anc_id, - Morphy m); - -int mpl_lower_root_recalculation - - (const int l_root_id, - const int root_id, - Morphy m); - -int mpl_na_tiproot_recalculation - - (const int tip_id, - const int node_id, - Morphy m); - -int mpl_na_tiproot_final_recalculation - - (const int tip_id, - const int node_id, - Morphy m); - -int mpl_get_insertcost - - (const int srcID, - const int tgt1ID, - const int tgt2ID, - const bool max, - const int cutoff, - Morphy m); - -int mpl_na_update_tip - - (const int tip_id, - const int anc_id, - Morphy m); - - -int mpl_get_step_recall - - (const int node_id, - Morphy m); - - -/* Indicates whether or not partitions with inapplicable characters need partial - reoptimisation on the target subtree. SHOULD RETURN: Number of characters - needing partial reoptimisation on the subtree. */ -int mpl_check_reopt_inapplics - - (Morphy m); - -bool mpl_check_updated - - (const int node_id, - Morphy m); - -/*! - - @brief Restores original state sets at a node. - - @discussion This function restores the state sets in the tree to the ones - calculated using the initial fullpass optimizations (first, and second down and - up functions). It is used after partial reoptimization of a tree and if the - client program needs to restore the state sets to their original values before - continuing to evaluate proposed insertions. - @param node_id The index value of the node having its state sets restored. - - @param m An instance of the morphylib object. - - @return 0 if success, a morphylib error code if there has been an error. - - */ -int mpl_restore_original_sets - - (const int node_id, - Morphy m); -/*! - - @brief Returns the state set for a character at a given node as set bits in an - unsigned integer. - - @discussion If the caller requires the internal state representation of a nodal - set used by MorphyLib, this function can be called to retrieve it. The caller - needs to specify the node index, the character number, and the pass number - (1-based, because these are not indices in a C array). - - @param nodeID The index of the node set required. - - @param character The character number to be queried. - - @param passnum The traversal iteration corresponding to the set required. These - range from 1 to 4 and represent first downpass, first uppass, second downpass - and second uppass respectively. - - @return An unsigned integer with bits set corresponding to values used by - MorphyLib. - - */ -unsigned -int mpl_get_packed_states - - (const int nodeID, - const int character, - const int passnum, - Morphy m); - - -const char* mpl_get_stateset - - (const int nodeID, - const int character, - const int passnum, - Morphy m); - -#ifdef __cplusplus -} -#endif /*__cplusplus */ - -#endif /* mpl_h */ diff --git a/src/mplerror.h b/src/mplerror.h deleted file mode 100644 index fa28d3315..000000000 --- a/src/mplerror.h +++ /dev/null @@ -1,54 +0,0 @@ -/*! - @file mplerror.h - @brief Error codes and descriptions for MorphyLib. - */ - -#ifndef mplerror_h -#define mplerror_h - -/*! - @typedef MPL_ERR_T - @brief List of error codes. Each error is a negative value. - @discussion These error codes are returned by library interface functions (and - used by some internal functions) to report errors back to the caller. - */ -typedef enum { - - ERR_EX_DATA_CONF = -15, /*! Input conflicts with existing dataset */ - ERR_OUT_OF_BOUNDS = -14, /*! Attempt to index out of bounds of an - array */ - - ERR_CASE_NOT_IMPL = -13, /*! Case not implemented. */ - - ERR_UNKNOWN_CHTYPE = -12, /*! Character type is unknown. It either - exceeds the list of character types or - a user type matrix has not yet been - supplied. */ - - ERR_SYMBOL_MISMATCH = -11, /*! Symbols list and matrix have a mismatch - (i.e. symbol not found).*/ - ERR_MATCHING_PARENTHS = -10, /*! Data input has unexpected non-matching - parentheses.*/ - ERR_ATTEMPT_OVERWRITE = -9, /*! Caller attempted to overwrite a loaded - dataset.*/ - ERR_NO_DIMENSIONS = -8, /*! Function requires pre-specified - dimensions to function properly.*/ - ERR_DIMENS_UNDER = -7, /*! Supplied dimensions underestimate size - of dataset.*/ - ERR_DIMENS_OVER = -6, /*! Supplied dimensions overestimate size of - dataset.*/ - ERR_NO_DATA = -5, /*! No dataset supplied.*/ - - ERR_BAD_MALLOC = -4, /*! Memory allocation failure.*/ - - ERR_BAD_PARAM = -3, /*! Unexpected parameter value passed to - function.*/ - ERR_UNEXP_NULLPTR = -2, /*! Unexpected NULL pointer passed to - function.*/ - ERR_INVALID_SYMBOL = -1, /*! Symbol in dataset or symbol list is not - allowed by Morphy.*/ - ERR_NO_ERROR = 0 /*! No error. Everything went OK.*/ - -} MPL_ERR_T; - -#endif /* mplerror_h */ diff --git a/src/rearrange.cpp b/src/rearrange.cpp index 9d7a81415..db7bc26f3 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -1,638 +1,10 @@ #include -// [ [Rcpp::depends(TreeTools)]] #include -#include /* for unique_ptr */ using namespace std; using namespace Rcpp; -typedef int_fast16_t int16; -const int16 UNDEFINED = -1; - -// Assumptions: -// [[Rcpp::export]] -IntegerMatrix nni(const IntegerMatrix edge, - const IntegerVector randomEdge, - const IntegerVector whichSwitch) { - const int16 n_edge = edge.nrow(), - chosen_edge = randomEdge[0], - chosen_switch = whichSwitch[0] % 2, - n_tip = (n_edge / 2) + 1; - - int16 n_samplable = 0; - std::unique_ptr samplable = std::make_unique(n_edge); - for (int16 i = n_edge; --i; ) { - if (edge(i, 1) > n_tip && edge(i, 0) != n_tip + 1) { - samplable[n_samplable++] = i; - } - } - if (!n_samplable) { - throw std::length_error("Not enough edges to allow NNI rearrangement"); - } - - const int16 - edge_to_break = samplable[chosen_edge % n_samplable], - end1 = edge(edge_to_break, 0), - end2 = edge(edge_to_break, 1); - int16 - ind1 = UNDEFINED, - ind2 = UNDEFINED; - - for (int16 i = n_edge; i--; ) { - if (i != edge_to_break && edge(i, 0) == end1) { - ind1 = i; - break; - } - } - - for (int16 i = n_edge; i--; ) { - if (edge(i, 0) == end2) { - if (ind2 != UNDEFINED || chosen_switch) { - ind2 = i; - break; - } else { - ind2 = i; - } - } - } - - IntegerMatrix ret = clone(edge); - ret(ind1, 1) = edge(ind2, 1); - ret(ind2, 1) = edge(ind1, 1); - - return TreeTools::preorder_edges_and_nodes(ret(_, 0), ret(_, 1)); -} - -// edge must be in preorder -// [[Rcpp::export]] -IntegerMatrix spr_moves(const IntegerMatrix edge) { - const int16 - n_edge = edge.nrow(), - n_node = n_edge / 2, - n_tip = n_node + 1, - root_node = n_tip + 1, - second_root_child = root_node + 1 - ; - if (n_edge < 5) return IntegerMatrix(0, 0); - if (edge(0, 0) != root_node) throw std::invalid_argument("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); - if (edge(1, 0) != root_node) throw std::invalid_argument("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); - - - std::unique_ptr - prune = std::make_unique((n_edge - 1) * (n_edge - 3)), - graft = std::make_unique((n_edge - 1) * (n_edge - 3)), - above = std::make_unique((n_edge - 1) * (n_edge - 3)), - bside = std::make_unique((n_edge - 1) * (n_edge - 3)) - ; - int16 n_moves = 0, root_daughter_2 = 0; - - // Root edge first - for (int16 i = 3; i != n_edge; i++) { - if (edge(i, 0) == second_root_child) { - //Rcout << "Root daughter edges are 3 and " << (1+i) << "\n"; - root_daughter_2 = i; - } else { - //Rcout << "\n _ Logging graft option, 1 -> " << (i + 1) << "\n"; - prune[n_moves] = 0; - graft[n_moves] = i; - ++n_moves; - } - } - - for (int16 i = 0; i != n_moves; i++) { - above[i] = -1; - bside[i] = root_daughter_2; - } - - for (int16 prune_candidate = 2; prune_candidate != n_edge; prune_candidate++) { - const int16 - prune_parent = edge(prune_candidate, 0), - first_prune_move = n_moves; - ; - int16 edge_above = 0, edge_beside = 0, i = 0; - bool adrift = false; - - if (edge(1, 1) == prune_parent) edge_above = 1; - for (i = 2; i != n_edge; i++) { - if (edge(i, 1) == prune_parent) { - //Rcout << "\n - Edge above broken is " << (1 + i); - edge_above = i; - continue; - } - if (i == prune_candidate) { - if (edge(i, 1) <= n_tip) { - ++i; - break; - } - //Rcout << "\n - We're adrift! " << (1 + i); - adrift = true; - continue; - } - if (adrift) { - if (edge(i, 0) == prune_parent) { - //Rcout << "\n ... Back to shore! " << (1 + i); - break; // Now we know that all remaining edges will be potential merge sites - } - //Rcout << "\n ... Still adrift! " << (1 + i); - } else { - if (edge(i, 0) == prune_parent) { - //Rcout << "\n - Edge beside broken = " << (1 + i); - edge_beside = i; - } else { - prune[n_moves] = prune_candidate; - graft[n_moves] = i; - ++n_moves; - } - } - } - if (!edge_beside) { - //Rcout << "\n - Oo Err. Edge beside broken = " << (1 + i); - edge_beside = i++; - } - if (i != n_edge + 1) while (i != n_edge) { - prune[n_moves] = prune_candidate; - graft[n_moves] = i; - ++n_moves; - ++i; - } - for (int16 j = first_prune_move; j != n_moves; j++) { - above[j] = edge_above; - bside[j] = edge_beside; - } - } - - IntegerMatrix ret(n_moves, 4); - for (int16 i = n_moves; i--; ) { - ret(i, 0) = prune[i]; - ret(i, 1) = graft[i]; - ret(i, 2) = above[i]; - ret(i, 3) = bside[i]; - } - return (ret); -} - - -// Assumptions: -// * Tree is bifurcating, in preorder; first two edges have root as parent. -// [[Rcpp::export]] -IntegerMatrix spr (const IntegerMatrix edge, - const IntegerVector move) { - const IntegerMatrix move_list = spr_moves(edge); - const int16 - n_edge = edge.nrow(), - n_node = n_edge / 2, - n_tip = n_node + 1, - root_node = n_tip + 1, - move_id = move[0] % move_list.nrow(), - prune_edge = move_list(move_id, 0), - graft_edge = move_list(move_id, 1), - broken_edge_parent = edge(prune_edge, 0) - ; - - if (n_edge < 5) throw std::invalid_argument("No SPR rearrangements possible on a tree with < 5 edges"); - if (edge(0, 0) != root_node) throw std::invalid_argument("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); - if (edge(1, 0) != root_node) throw std::invalid_argument("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); - - IntegerMatrix ret = clone(edge); - - if (prune_edge) { // We are breaking a non-root edge - const int16 - edge_above = move_list(move_id, 2), - edge_beside = move_list(move_id, 3) - ; - - ret(edge_beside, 0) = edge(edge_above, 0); - ret(edge_above, 0) = edge(graft_edge, 0); - ret(graft_edge, 0) = broken_edge_parent; - } else { // We are breaking the root edge - ret(2, 0) = broken_edge_parent; - ret(move_list(move_id, 3), 0) = broken_edge_parent; - - //child [brokenEdgeSister] <- child[mergeEdge] - ret(1, 1) = edge(graft_edge, 1); - //parent[brokenEdge | brokenEdgeSister] <- spareNode - const int spare_node = edge(1, 1); - ret(0, 0) = spare_node; - ret(1, 0) = spare_node; - // child[mergeEdge] <- spareNode - ret(graft_edge, 1) = spare_node; - } - ret = TreeTools::preorder_edges_and_nodes(ret(_, 0), ret(_, 1)); - return TreeTools::root_binary(ret, 1); -} - -// Assumptions: -// * Tree is bifurcating, in preorder; first two edges have root as parent. -// #TODO once working: [[Rcpp::export]] // Also add to TreeSearch-init.c -IntegerMatrix tbr_moves(const IntegerMatrix edge) { - const int16 - n_edge = edge.nrow(), - n_node = n_edge / 2, - n_tip = n_node + 1, - root_node = n_tip + 1, - second_root_child = root_node + 1 - ; - if (n_edge < 5) throw std::invalid_argument("No TBR rearrangements possible on a tree with < 5 edges"); - if (edge(0, 0) != root_node) throw std::invalid_argument("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); - if (edge(1, 0) != root_node) throw std::invalid_argument("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); - - std::unique_ptr - n_edges_above = std::make_unique(n_edge), - probibited_parent = std::make_unique(n_edge), - probibited_sibling = std::make_unique(n_edge), - prune = std::make_unique((n_edge - 1) * (n_edge - 3)), - graft = std::make_unique((n_edge - 1) * (n_edge - 3)), - above = std::make_unique((n_edge - 1) * (n_edge - 3)), - bside = std::make_unique((n_edge - 1) * (n_edge - 3)) - ; - int16 n_moves = 0, root_daughter_2 = 0; - - // Root edge first - for (int16 i = 3; i != n_edge; i++) { - if (edge(i, 0) == second_root_child) { - //Rcout << "Root daughter edges are 3 and " << (1+i) << "\n"; - root_daughter_2 = i; - } else { - //Rcout << "\n _ Logging graft option, 1 -> " << (i + 1) << "\n"; - prune[n_moves] = 0; - graft[n_moves] = i; - ++n_moves; - } - } - - for (int16 i = 0; i != n_moves; i++) { - above[i] = -1; - bside[i] = root_daughter_2; - } - - for (int16 bisect = 1; bisect != n_edge; bisect++) { - - } - - IntegerMatrix ret(n_moves, 4); - for (int16 i = n_moves; i--; ) { - ret(i, 0) = prune[i]; - ret(i, 1) = graft[i]; - ret(i, 2) = above[i]; - ret(i, 3) = bside[i]; - } - return (ret); -} - -// [[Rcpp::export]] -IntegerMatrix tbr (const IntegerMatrix edge, - const IntegerVector move) { - const IntegerMatrix move_list = tbr_moves(edge); - // Actually do TBR move - return IntegerMatrix(0, 0); -} - -inline void set_child(unique_ptr &side, const int16 parent, - const int16 value, const int16 n_tip) { - side[parent - 1 - n_tip] = value; -} - -inline int16 get_child(unique_ptr &side, const int16 parent, const int16 n_tip) { - return side[parent - 1 - n_tip]; -} - -inline int16 count_children(unique_ptr &n_children, const int16 vert) { - return n_children[vert - 1]; -} - -inline void add_children(unique_ptr &n_children, - const int16 parent, const int16 child) { - n_children[parent - 1] += n_children[child - 1]; -} - -inline int16 edge_above(const int16 vert, unique_ptr &parent_edge) { - return parent_edge[vert - 1]; -} - -inline IntegerMatrix fuse(const IntegerMatrix& tree_bits, - const int16* graft_edge, const int16* break_edge, - const int16* spare_edge, const int16* spare_node) { - IntegerMatrix new_tree = clone(tree_bits); - new_tree(*spare_edge, 1) = tree_bits(*graft_edge, 1); - new_tree(*graft_edge, 1) = *spare_node; - new_tree(*break_edge, 0) = *spare_node; - return TreeTools::preorder_edges_and_nodes(new_tree(_, 0), new_tree(_, 1)); -} - - - // [[Rcpp::export]] List asan_error (const IntegerMatrix x) { Rf_error("Oh dear."); return List::create(); } - -// Assumptions: -// * Tree is bifurcating, in preorder; first two edges have root as parent. -// [[Rcpp::export]] -List all_spr (const IntegerMatrix edge, - const IntegerVector break_order) { - Rcout << "\n\n Running all_spr()"; - const int16 - n_edge = edge.nrow(), - n_internal = n_edge / 2, - n_tip = n_internal + 1, - n_vert = n_internal + n_tip, - root_node = n_tip + 1 - ; - if (n_edge < 5) { - Rf_error("No SPR rearrangements possible on a tree with < 5 edges"); - } - if (edge(0, 0) != root_node) { - Rf_error("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); - } - if (edge(1, 0) != root_node) { - Rf_error("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); - } - Rcout << "\n\nall_spr Continuing;\n\n"; - - IntegerVector break_seq; - if (break_order.length()) { - break_seq = clone(break_order); - } else { - IntegerVector tmp (n_edge - 1); - break_seq = tmp; - for (int16 i = n_edge - 1; i--; ) { - break_seq[i] = i + 2; - } - } - - unique_ptr n_children = make_unique(n_vert); - // if both internal, left_node < right_node - unique_ptr left_node = make_unique(n_internal); - unique_ptr right_node = make_unique(n_internal); - // left_edge is plotted on top with ape::plot.phylo - unique_ptr left_edge = make_unique(n_internal); - unique_ptr right_edge = make_unique(n_internal); - unique_ptr parent_edge = make_unique(n_vert); - for (int16 i = n_tip; i--; ) { - n_children[i] = 1; - } - - for (int16 i = n_edge; i--; ) { - const int parent = edge(i, 0); - const int child = edge(i, 1); - add_children(n_children, parent, child); - parent_edge[child - 1] = i; - if (get_child(left_node, parent, n_tip)) { - set_child(right_node, parent, child, n_tip); - set_child(right_edge, parent, i, n_tip); - } else { - set_child(left_node, parent, child, n_tip); - set_child(left_edge, parent, i, n_tip); - } - } - - - List ret = List::create(); - - // Let's go. - for (int16 i = break_seq.length(); i--; ) { - IntegerMatrix two_bits = clone(edge); - if (break_seq[i] > n_edge) { - Rf_warning("Ignoring SPR break locations that exceed number of edges in tree.\n"); - continue; - } - if (break_seq[i] < 2) { - Rf_warning("Ignoring break locations < 2"); - continue; - } - const int16 - break_edge = break_seq[i] - 1, - break_parent = edge(break_edge, 0), - break_child = edge(break_edge, 1), - spare_node = break_parent, - - fragment_root = break_child, - fragment_leaves = count_children(n_children, break_child), - fragment_edges = fragment_leaves + fragment_leaves - 1, - fragment_min_edge = break_edge, - fragment_max_edge = break_edge + fragment_edges - 1 - ; - const bool broken_on_left = get_child(left_edge, break_parent, n_tip) == break_edge; - const int16 - spare_edge = broken_on_left ? - get_child(right_edge, break_parent, n_tip) : - get_child(left_edge, break_parent, n_tip) - ; - - two_bits(edge_above(break_parent, parent_edge), 1) = broken_on_left ? - get_child(right_node, break_parent, n_tip) : - get_child(left_node, break_parent, n_tip); - if (break_edge == 1) { - const int16 - fragment_base_right = 2, - fragment_base_left = get_child(left_edge, fragment_root, n_tip); - ; - - for (int16 insertion_point = fragment_min_edge + 2; - insertion_point != fragment_max_edge + 1; insertion_point++) { - if (insertion_point == fragment_base_left) { - continue; - } - - int16 invert_next = insertion_point; - IntegerMatrix rerooted = clone(two_bits); - - rerooted(invert_next, 0) = break_child; // Borrow fragment-root node id - rerooted(invert_next, 1) = two_bits(invert_next, 0); - - do { - invert_next = edge_above(two_bits(invert_next, 0), parent_edge); - rerooted(invert_next, 0) = two_bits(invert_next, 1); - rerooted(invert_next, 1) = two_bits(invert_next, 0); - } while (two_bits(invert_next, 0) != fragment_root); - - const bool new_root_on_right = invert_next == fragment_base_right; - const int16 repurposed_edge = new_root_on_right ? - fragment_base_left : - fragment_base_right; - rerooted(invert_next, 1) = two_bits(repurposed_edge, 1); - rerooted(repurposed_edge, 1) = two_bits(insertion_point, 1); - rerooted = TreeTools::preorder_edges_and_nodes(rerooted(_, 0), rerooted(_, 1)); - ret.push_back(rerooted); - } - } else { - for (int16 graft_edge = n_edge - 1; graft_edge; graft_edge--) { - if (graft_edge == fragment_max_edge) { - graft_edge = fragment_min_edge; - continue; - } else if (broken_on_left && graft_edge == get_child(right_edge, break_parent, n_tip)) { - graft_edge = edge_above(break_parent, parent_edge); - continue; - } else if (graft_edge == spare_edge) { - continue; - } else if (graft_edge == edge_above(break_parent, parent_edge)) { - continue; - } - ret.push_back(fuse(two_bits, &graft_edge, &break_edge, &spare_edge, - &spare_node)); - if (graft_edge < 0) break; // TODO REMOVE - } - } - } - return ret; -} - -// Assumptions: -// * Tree is bifurcating, in preorder; first two edges have root as parent. -// [[Rcpp::export]] -List all_tbr (const IntegerMatrix edge, - const IntegerVector break_order) { - const int16 - n_edge = edge.nrow(), - n_internal = n_edge / 2, - n_tip = n_internal + 1, - n_vert = n_internal + n_tip, - root_node = n_tip + 1 - ; - if (n_edge < 5) throw std::invalid_argument("No TBR rearrangements possible on a tree with < 5 edges"); - if (edge(0, 0) != root_node) throw std::invalid_argument("edge[1,] must connect root to leaf. Try Preorder(root(tree))."); - if (edge(1, 0) != root_node) throw std::invalid_argument("edge[2,] must connect root to leaf. Try Preorder(root(tree))."); - - IntegerVector break_seq; - if (break_order.length()) { - break_seq = clone(break_order); - } else { - IntegerVector tmp (n_edge - 2); - break_seq = tmp; - for (int16 i = n_edge - 2; i--; ) { - break_seq[i] = i + 3; - } - } - - unique_ptr n_children = make_unique(n_vert); - unique_ptr left_node = make_unique(n_internal); - unique_ptr right_node = make_unique(n_internal); - unique_ptr left_edge = make_unique(n_internal); - unique_ptr right_edge = make_unique(n_internal); - unique_ptr parent_edge = make_unique(n_vert); - for (int16 i = n_tip; i--; ) { - n_children[i] = 1; - } - - for (int16 i = n_edge; i--; ) { - const int parent = edge(i, 0); - const int child = edge(i, 1); - add_children(n_children, parent, child); - parent_edge[child - 1] = i; - if (get_child(left_node, parent, n_tip)) { - set_child(right_node, parent, child, n_tip); - set_child(right_edge, parent, i, n_tip); - } else { - set_child(left_node, parent, child, n_tip); - set_child(left_edge, parent, i, n_tip); - } - } - - - List ret = List::create(); - - // Let's go. - for (int16 i = break_seq.length(); i--; ) { - IntegerMatrix two_bits = clone(edge); - if (break_seq[i] > n_edge) { - Rf_warning("Ignoring TBR break locations that exceed number of edges in tree.\n"); - continue; - } - if (break_seq[i] < 2) { - Rf_warning("Ignoring break locations < 2"); - continue; - } - const int16 - break_edge = break_seq[i] - 1, - break_parent = edge(break_edge, 0), - break_child = edge(break_edge, 1), - spare_node = break_parent, - - fragment_root = break_child, - fragment_leaves = count_children(n_children, break_child), - fragment_edges = fragment_leaves + fragment_leaves - 1, - fragment_min_edge = break_edge, - fragment_max_edge = break_edge + fragment_edges - 1 - ; - const bool broken_on_left = get_child(left_edge, break_parent, n_tip) == break_edge; - const int16 - spare_edge = broken_on_left ? - get_child(right_edge, break_parent, n_tip) : - get_child(left_edge, break_parent, n_tip) - ; - - two_bits(edge_above(break_parent, parent_edge), 1) = broken_on_left ? - get_child(right_node, break_parent, n_tip) : - get_child(left_node, break_parent, n_tip); - if (fragment_leaves < 3) { - for (int16 graft_edge = n_edge - 1; graft_edge; graft_edge--) { - if (graft_edge == fragment_max_edge) { - graft_edge = fragment_min_edge; - continue; - } else if (broken_on_left && graft_edge == get_child(right_edge, break_parent, n_tip)) { - graft_edge = edge_above(break_parent, parent_edge); - continue; - } else if (graft_edge == spare_edge) { - continue; - } else if (graft_edge == edge_above(break_parent, parent_edge)) { - continue; - } - ret.push_back(fuse(two_bits, &graft_edge, &break_edge, &spare_edge, - &spare_node)); - } - } else { - List rooty_bits = List::create(); - const int16 - fragment_base_right = break_edge + 1, - fragment_base_left = get_child(left_edge, fragment_root, n_tip); - ; - - for (int16 new_fragment_root = fragment_min_edge + 2; - new_fragment_root != fragment_max_edge + 1; new_fragment_root++) { - if (new_fragment_root == fragment_base_left) { - continue; - } - - int16 invert_next = new_fragment_root; - IntegerMatrix rerooted = clone(two_bits); - - rerooted(invert_next, 0) = break_child; // Borrow fragment-root node id - rerooted(invert_next, 1) = two_bits(invert_next, 0); - - do { - invert_next = edge_above(two_bits(invert_next, 0), parent_edge); - rerooted(invert_next, 0) = two_bits(invert_next, 1); - rerooted(invert_next, 1) = two_bits(invert_next, 0); - } while (two_bits(invert_next, 0) != fragment_root); - - const bool new_root_on_right = invert_next == fragment_base_right; - const int16 repurposed_edge = new_root_on_right ? - fragment_base_left : fragment_base_right; - rerooted(invert_next, 1) = two_bits(repurposed_edge, 1); - rerooted(repurposed_edge, 1) = two_bits(new_fragment_root, 1); - rooty_bits.push_back(rerooted); - } - for (int16 graft_edge = n_edge - 1; graft_edge; graft_edge--) { - if (graft_edge == fragment_max_edge) { - graft_edge = fragment_min_edge; - continue; - } else if (graft_edge == spare_edge) { - continue; - } - for (List::iterator j = rooty_bits.begin(); j != rooty_bits.end(); j++) { - IntegerMatrix rooty_bit = *j; - ret.push_back(fuse(rooty_bit, &graft_edge, &break_edge, &spare_edge, - &spare_node)); - } - if (graft_edge != edge_above(break_parent, parent_edge)) { - ret.push_back(fuse(two_bits, &graft_edge, &break_edge, &spare_edge, - &spare_node)); - } - } - } - - - } - return ret; -} diff --git a/src/statedata.c b/src/statedata.c deleted file mode 100644 index 85f8652a9..000000000 --- a/src/statedata.c +++ /dev/null @@ -1,738 +0,0 @@ -/* -// statedata.c -// MorPhy2 -// -// Created by mbrazeau on 26/04/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ -#include "mpl.h" -#include "morphydefs.h" -#include "morphy.h" -#include "mplerror.h" -#include "statedata.h" - -char* mpl_skip_closure(const char *closure, const char openc, const char closec) -{ - if (*closure != openc) { - return (char*)ERR_BAD_PARAM; - } - char *ret = (char*)closure; - - do { - ++ret; - if (*ret == closec) { - return ret; - } - } while (*ret); - - return NULL; -} - - -int compare_char_t_states(const void *ptr1, const void *ptr2) -{ - return *(char*)ptr1 - *(char*)ptr2; -} - - -int mpl_compare_symbol_lists(const char* sym1, const char* sym2) -{ - int i = 0; - - for (i = 0; sym1[i]; ++i) { - if (!strchr(sym2, sym1[i])) { - if (!isspace(sym1[i])) { - return 1; - } - } - } - - for (i = 0; sym2[i]; ++i) { - if (!strchr(sym1, sym2[i])) { - if (!isspace(sym2[i])) { - return 1; - } - } - } - - return 0; -} - - -int mpl_assign_symbol_list_from_matrix -(const char *symbs, MPLsymbols* symlist) -{ - assert(symbs && symlist); - - int nsymbs = (int)strlen(symbs); - - ++nsymbs; - symlist->symbolsinmatrix = (char*)calloc(nsymbs, sizeof(char)); - - if (!symlist->symbolsinmatrix) { - return ERR_BAD_MALLOC; - } - - strcpy(symlist->symbolsinmatrix, symbs); - - return ERR_NO_ERROR; -} - - -char *mpl_query_symbols_from_matrix(Morphyp m) -{ - return m->symbols.symbolsinmatrix; -} - - -int mpl_get_states_from_rawdata(Morphyp handl) -{ - - assert(handl); - - int count = 0; - char *rawmatrix = handl->char_t_matrix; - char *current = NULL; - int listmax = MAXSTATES + 1; // +1 for terminal null. - char* statesymbols = (char*)calloc(listmax, sizeof(char));//[listmax]; -// int dbg_loopcount = 0; - - statesymbols[0] = '\0'; - current = rawmatrix; - - do { - if (strchr(VALIDSYMB, *current)) { - - if (strchr(VALID_NEXMAT_PUNC, *current)) { - ++current; - } - if (!strchr(statesymbols, *current) && - strchr(VALID_STATESYMB, *current)) { - // Put in list - statesymbols[count] = *current; - ++count; - statesymbols[count] = '\0'; - } - } - else { - return ERR_INVALID_SYMBOL; - } - - ++current; - - } while (*current); - - // Sort alphanumerically - qsort(statesymbols, strlen(statesymbols), sizeof(char), - compare_char_t_states); - - int numstates = (int)strlen(statesymbols); - mpl_set_numsymbols(numstates, handl); - mpl_assign_symbol_list_from_matrix(statesymbols, &handl->symbols); - free(statesymbols); - return count-1; -} - - -int mpl_set_numsymbols(int numsymb, Morphyp handl) -{ - assert(handl); - handl->symbols.numstates = numsymb; - return ERR_NO_ERROR; -} - - -int mpl_get_numsymbols(Morphyp handl) -{ - assert(handl); - return handl->symbols.numstates; -} - - -int mpl_create_state_dictionary(Morphyp handl) -{ - int i = 0; - int gappush = 0; - int numsymbs = handl->symbols.numstates; - mpl_get_symbols((Morphy)handl); - - if (!handl->symbols.packed) { - - handl->symbols.packed = (MPLstate*)calloc(handl->symbols.numstates, - sizeof(MPLstate)); - if (!handl->symbols.packed) { - return ERR_BAD_MALLOC; - } - } - - if (handl->gaphandl == GAP_INAPPLIC || handl->gaphandl == GAP_NEWSTATE) { - gappush = 1; - } - - for (i = 0; i < numsymbs; ++i) { - handl->symbols.packed[i] = 1 << (i + gappush); - } - - return ERR_NO_ERROR; -} - - -MPLstate mpl_convert_gap_symbol(Morphyp handl, bool over_cutoff) -{ - if (handl->gaphandl == GAP_INAPPLIC) { - if (over_cutoff) { - return NA; - } - else { - return MISSING; - } - } - else if (handl->gaphandl == GAP_NEWSTATE) { - return (MPLstate)1; - } - else if (handl->gaphandl == GAP_MISSING) { - return MISSING; - } - - return ERR_NO_DATA; -} - - -MPLstate mpl_convert_char_to_MPLstate(const char* celldata, Morphyp handl) -{ - int i = 0; - MPLstate result = 0; - - do { - i = 0; - do { - if (*celldata == handl->symbols.statesymbols[i]) { - result |= handl->symbols.packed[i]; - } - ++i; - } while (handl->symbols.statesymbols[i]); - ++celldata; - } while (*celldata); - - return result; -} - -// TODO: Call this function during the 'apply data' routine. -int mpl_convert_cells(Morphyp handl) -{ - - int i = 0; - int j = 0; - int ncols = mpl_get_num_charac((Morphy)handl); - int nrows = mpl_get_numtaxa((Morphy)handl); - MPLmatrix *inmatrix = &handl->inmatrix; - MPLcharinfo* chinfo = handl->charinfo; - MPLcell *cell; - - if (handl->gaphandl == GAP_INAPPLIC) { - mpl_count_gaps_in_columns(handl); - } - - char *celldata = NULL; - - for (i = 0; i < ncols; ++i) { - - for (j = 0; j < nrows; ++j) { - - cell = &inmatrix->cells[j * ncols + i]; - celldata = cell->asstr; - - if (*celldata == handl->symbols.gap) { - - bool over_cutoff = false; - - if (chinfo[i].ninapplics > NACUTOFF) { - over_cutoff = true; - } - - cell->asint = mpl_convert_gap_symbol(handl, over_cutoff); - } - else if (*celldata == handl->symbols.missing) { - cell->asint = MISSING; - } - else { - cell->asint = mpl_convert_char_to_MPLstate(celldata, handl); - } - - } - - } - - return ERR_NO_ERROR; -} - - -void mpl_destroy_symbolset(Morphyp m) -{ - assert(m); - if (m->symbols.statesymbols) { - if (m->symbols.statesymbols == m->symbols.symbolsinmatrix) { - free(m->symbols.statesymbols); - m->symbols.statesymbols = NULL; - m->symbols.symbolsinmatrix = NULL; - } - else { - free(m->symbols.statesymbols); - m->symbols.statesymbols = NULL; - if (m->symbols.symbolsinmatrix) { - free(m->symbols.symbolsinmatrix); - m->symbols.symbolsinmatrix = NULL; - } - } - } - if (m->symbols.packed) { - free(m->symbols.packed); - m->symbols.packed = NULL; - } -} - - -bool mpl_is_valid_matrix_symbol(const char c) -{ - if (strchr(VALID_STATESYMB, c)) { - return true; - } - else if (strchr(VALID_WILDCAR, c)) { - return true; - } - else if (strchr(VALID_NEXMAT_PUNC, c)) { - return true; - } - - return false; -} - - -unsigned long mpl_get_valid_matrix_length(const char* rawmatrix) -{ - unsigned long len = 0; - char* matptr = (char*)rawmatrix; - - do { - if (mpl_is_valid_matrix_symbol(*matptr)) { - ++len; - } - else if (*matptr == '[') { - matptr = mpl_skip_closure(matptr, '[', ']'); - assert(matptr != NULL); - } - ++matptr; - } while (*matptr); - - return len; -} - - -void mpl_copy_valid_matrix_data(char *copy, const char* rawmatrix) -{ - int i = 0; - char* matptr = (char*)rawmatrix; - - do { - if (mpl_is_valid_matrix_symbol(*matptr)) { - copy[i] = *matptr; - ++i; - } - else if (*matptr == '[') { - matptr = mpl_skip_closure(matptr, '[', ']'); - assert(matptr != NULL); - } - ++matptr; - } while (*matptr); - - copy[i-1] = '\0'; -} - - -// Copy the raw matrix, take out whitespace and comments -int mpl_copy_raw_matrix(const char* rawmatrix, Morphyp handl) -{ - unsigned long len = mpl_get_valid_matrix_length(rawmatrix); - - char *matcpy = (char*)calloc(len + 1, sizeof(char)); - - if (!matcpy) { - return ERR_BAD_MALLOC; - } - mpl_copy_valid_matrix_data(matcpy, rawmatrix); - handl->char_t_matrix = matcpy; - return ERR_NO_ERROR; -} - - -int mpl_check_nexus_matrix_dimensions -(char *preproc_matrix, int input_num_taxa, int input_num_chars) -{ - /* An input matrix should not have inline taxon names. This function - * scans each row of the input matrix to determine whether or not the - * number of places in the row corresponds to input number of - * of characters. If the number exceeds the expected number of data - * columns (num_input_chars), then it is inferred that taxon names or - * other extraneous info are included in the matrix. */ - - char* current = NULL; - int matrix_size = 0; - int expected_size = 0; - - expected_size = input_num_chars * input_num_taxa; - - current = preproc_matrix; - assert(current); - - do { - if (strchr(VALID_STATESYMB, *current) - || strchr(VALID_WILDCAR, *current)) { - ++matrix_size; - } - else if (*current == '(' || *current == '{') { - - char* err = 0; - - if (*current == '(') { - err = mpl_skip_closure(current, '(', ')'); - } - else { - err = mpl_skip_closure(current, '{', '}'); - } - if (*err <= 0) { - return ERR_MATCHING_PARENTHS; - } - - current = err; - assert(current != NULL); - ++matrix_size; - } - - ++current; - } while (*current); - - if (matrix_size > expected_size) { - return ERR_DIMENS_UNDER; - } - else if (matrix_size < expected_size) { - return ERR_DIMENS_OVER; - } - - return ERR_NO_ERROR; -} - - -char* mpl_get_preprocessed_matrix(Morphyp handl) -{ - assert(handl); - return handl->char_t_matrix; -} - - -MPLstate mpl_gap_value(Morphyp handl) -{ - switch (mpl_get_gaphandl(handl)) { - case GAP_INAPPLIC: - return NA; - case GAP_MISSING: - return MISSING; - case GAP_NEWSTATE: - return (MPLstate)1; - case GAP_MAX: - return -1; - default: - break; - } - - return -2; -} - -int mpl_init_inmatrix(Morphyp handl) -{ - assert(handl); - MPLmatrix* mat = &handl->inmatrix; - int ntaxa = mpl_get_numtaxa((Morphyp)handl); - int nchar = mpl_get_num_charac((Morphyp)handl); - int nstates = mpl_get_numsymbols(handl); - -// mat->chtypes = (MPLchtype*)calloc(nchar, sizeof(MPLchtype)); -// if (!mat->chtypes) { -// return ERR_BAD_MALLOC; -// } -// -// mat->intweights = (int*)calloc(nchar, sizeof(int)); -// if (!mat->intweights) { -// mpl_delete_mpl_matrix(mat); -// return ERR_BAD_MALLOC; -// } -// -// mat->fltweights = (Mflt*)calloc(nchar, sizeof(Mflt)); -// if (!mat->fltweights) { -// mpl_delete_mpl_matrix(mat); -// return ERR_BAD_MALLOC; -// } - - mat->cells = (MPLcell*)calloc(ntaxa * nchar, sizeof(MPLcell)); - if (!mat->cells) { - mpl_delete_mpl_matrix(mat); - return ERR_BAD_MALLOC; - } - - mat->ncells = ntaxa * nchar; - int i = 0; - - for (i = 0; i < mat->ncells; ++i) { - // MS: Consider case where nstates = 0 and we place a null in asstr[1]. - mat->cells[i].asstr = (char*)calloc((nstates ? nstates + 1 : 2), sizeof(char)); - if (!mat->cells[i].asstr) { - int j = 0; - for (j = 0; j < i; ++j) { - free(mat->cells[i].asstr); - mat->cells[i].asstr = NULL; - } - mpl_delete_mpl_matrix(mat); - return ERR_BAD_MALLOC; - } - } - - return ERR_NO_ERROR; -} - - -int mpl_delete_mpl_matrix(MPLmatrix* m) -{ - if (!m) { - return ERR_BAD_PARAM; - } - - int i = 0; - - if (m->cells) { - for (i = 0; i < m->ncells; ++i) { - if (m->cells[i].asstr) { - free(m->cells[i].asstr); - m->cells[i].asstr = NULL; - } - } - free(m->cells); - m->cells = NULL; - } - -// if (m->chtypes) { -// free(m->chtypes); -// m->chtypes = NULL; -// } -// -// if (m->fltweights) { -// free(m->fltweights); -// m->fltweights = NULL; -// } -// -// if (m->intweights) { -// free(m->intweights); -// m->intweights = NULL; -// } - - return ERR_NO_ERROR; -} - - -MPLmatrix* mpl_get_mpl_matrix(Morphyp m) -{ - return &m->inmatrix; -} - - -int mpl_set_gap_push(Morphyp handl) -{ - MPLgap_t gt = mpl_get_gaphandl(handl); - - if (gt == GAP_INAPPLIC || gt == GAP_NEWSTATE) { - return 1; - } - else if (gt == GAP_MISSING) { - return 0; - } - - return -1; -} - - -int mpl_get_uncorrected_shift_value(char symb, Morphyp handl) -{ - // Gets the raw shift value as determined by the order in the symbols list - assert(symb != DEFAULTGAP && symb != DEFAULTMISSING); - int shift = 0; - char* symbols = mpl_get_symbols((Morphy)handl); - - while (*symbols != symb && *symbols) { - ++symbols; - ++shift; - } - - return shift; -} - - -void mpl_use_symbols_from_matrix(Morphyp handl) -{ - handl->symbols.statesymbols = handl->symbols.symbolsinmatrix; -} - - -int mpl_write_input_rawchars_to_cells(Morphyp handl) -{ - assert(handl); - int i = 0; - int j = 0; -// int rows = mpl_get_numtaxa((Morphyp)handl); -// int cols = mpl_get_num_charac((Morphyp)handl); -// int length = rows * cols; - - char* prpdata = mpl_get_preprocessed_matrix(handl); - - while (*prpdata) { - - if (!strchr(VALID_NEXMAT_PUNC, *prpdata)) { - handl->inmatrix.cells[i].asstr[0] = *prpdata; - handl->inmatrix.cells[i].asstr[1] = '\0'; - } - else { - if (*prpdata == '(') { - j = 0; - ++prpdata; - do { - - handl->inmatrix.cells[i].asstr[j] = *prpdata; - ++j; - ++prpdata; - } while (*prpdata != ')'); - handl->inmatrix.cells[i].asstr[j] = '\0'; - } - - if (*prpdata == '{') { - j = 0; - ++prpdata; - do { - handl->inmatrix.cells[i].asstr[j] = *prpdata; - ++j; - ++prpdata; - } while (*prpdata != '}'); - handl->inmatrix.cells[i].asstr[j] = '\0'; - } - if (*prpdata == ';') { - break; - } - } - - ++i; - ++prpdata; - }; - - //prpdata = mpl_get_preprocessed_matrix(handl); - - return ERR_NO_ERROR; -} - -// TODO: Rename this. -int mpl_preproc_rawdata(Morphyp handl) -{ - int ret = ERR_NO_ERROR; - - mpl_get_states_from_rawdata(handl); - - // If no symbols supplied by the user - if (!mpl_get_symbols((Morphy)handl)) { - // Assign internal symbols to list - mpl_use_symbols_from_matrix(handl); - } - else { - - char *frommatrix = mpl_query_symbols_from_matrix(handl); - char *user = mpl_get_symbols((Morphyp)handl); - - if (mpl_compare_symbol_lists(frommatrix, user)) { - return ERR_SYMBOL_MISMATCH; - } - } - - mpl_init_inmatrix(handl); - - // Now safe to write characters into cells. - mpl_write_input_rawchars_to_cells(handl); - - return ret; -} - -// TODO: This probably needs to be more memory-safe -char *mpl_translate_state2char(MPLstate cstates, Morphyp handl) -{ - int i = 0; - int shift = 0; - int gapshift = 0; - - MPLgap_t gaphandl = mpl_query_gaphandl((Morphyp)handl); - if (gaphandl == GAP_INAPPLIC || gaphandl == GAP_NEWSTATE) { - gapshift = 1; - } - char *res = calloc(MAXSTATES+1, sizeof(char)); - if (!res) { - return NULL; - } - char* symbols = mpl_get_symbols((Morphy)handl); - - if (cstates < (MISSING-NA)) { - while (cstates) { - if (1 & cstates) { - if (shift == 0 && gapshift) { - res[i] = mpl_get_gap_symbol(handl); - } - else { - res[i] = symbols[shift - gapshift]; - } - ++i; - } - cstates = cstates >> 1; - ++shift; - } - } - else { - res[0] = '?'; - } - - return res; -} - -int mpl_init_charac_info(Morphyp handl) -{ - int nchar = mpl_get_num_charac((Morphy)handl); - - if (handl->charinfo) { - free(handl->charinfo); - } - - handl->charinfo = (MPLcharinfo*)calloc(nchar, sizeof(MPLcharinfo)); - if (!handl->charinfo) { - return ERR_BAD_MALLOC; - } - - int i = 0; - for (i = 0; i < nchar; ++i) { - handl->charinfo[i].charindex = i; - handl->charinfo[i].chtype = DEFAULCHARTYPE; - handl->charinfo[i].realweight = 1.0; - handl->charinfo[i].basewt = 1; - handl->charinfo[i].intwt = 1; - } - - return ERR_NO_ERROR; -} - -void mpl_delete_charac_info(Morphyp handl) -{ - assert(handl); - if (!handl->charinfo) { - return; - } - free(handl->charinfo); -} diff --git a/src/statedata.h b/src/statedata.h deleted file mode 100644 index e274f16af..000000000 --- a/src/statedata.h +++ /dev/null @@ -1,51 +0,0 @@ -/* -// statedata.h -// MorPhy2 -// -// Created by mbrazeau on 26/04/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ - -#ifndef statedata_h -#define statedata_h - -#include -#include -#include -#include - - -#define VALID_NEXMAT_PUNC "{}();" -#define VALID_XREAD_MATPUNC "[];" -#define VALID_WILDCAR "-?" -#define VALID_STATESYMB "+0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" -#define VALID_WS "\n\t " -#define VALIDSYMB VALID_NEXMAT_PUNC VALID_XREAD_MATPUNC VALID_WILDCAR \ - VALID_STATESYMB VALID_WS - - -/* Function prototypes */ -int mpl_init_symbolset(Morphyp m); -int mpl_set_numsymbols(int numsymb, Morphyp handl); -int mpl_get_numsymbols(Morphyp handl); -void mpl_destroy_symbolset(Morphyp m); -char* mpl_skip_closure(const char *closure, const char openc, const char closec); -int mpl_compare_symbol_lists(const char* sym1, const char* sym2); -int mpl_assign_symbol_list_from_matrix(const char *symbs, MPLsymbols* symlist); -char* mpl_query_symbols_from_matrix(Morphyp m); -int mpl_get_states_from_rawdata(Morphyp handl); -int mpl_copy_raw_matrix(const char* rawmatrix, Morphyp handl); -int mpl_check_nexus_matrix_dimensions(char *input_matrix, int input_num_taxa, int input_num_chars); -char* mpl_get_preprocessed_matrix(Morphyp handl); -int mpl_write_input_rawchars_to_cells(Morphyp handl); -int mpl_create_state_dictionary(Morphyp handl); -int mpl_convert_cells(Morphyp handl); -int mpl_preproc_rawdata(Morphyp handl); -MPLmatrix* mpl_new_mpl_matrix(const int ntaxa, const int nchar, const int nstates); -int mpl_delete_mpl_matrix(MPLmatrix* m); -MPLmatrix* mpl_get_mpl_matrix(Morphyp m); -char* mpl_translate_state2char(MPLstate cstates, Morphyp handl); -int mpl_init_charac_info(Morphyp handl); -void mpl_delete_charac_info(Morphyp handl); - -#endif /* statedata_h */ diff --git a/src/wagner.c b/src/wagner.c deleted file mode 100644 index 415c672a6..000000000 --- a/src/wagner.c +++ /dev/null @@ -1,121 +0,0 @@ -/* -// wagner.c -// morphylib -// -// Created by mbrazeau on 21/05/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ -#include "mpl.h" -#include "morphydefs.h" -#include "morphy.h" -#include "wagner.h" - -static inline unsigned mpl_closed_interval(MPLstate* res, MPLstate a, MPLstate b) -{ - unsigned steps = 0; - MPLstate c = 0; - - if (b > a) { - c = b; - b = a; - a = c; - } - - *res = a & (-a); - - while(!(*res & b)) { - ++steps; - *res |= a >> steps; - } - - return steps; -} - -int mpl_wagner_downpass -(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int steps = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* n = nset->downpass1; - - unsigned long* weights = part->intwts; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if (left[j] & right[j]) { - n[j] = left[j] & right[j]; - } - else { - - n[j] = 0; - steps += weights[i] * mpl_closed_interval(&n[j], left[j], right[j]); - } - } - - return steps; -} - -int mpl_wagner_uppass -(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - MPLstate* left = lset->downpass1; - MPLstate* right = rset->downpass1; - MPLstate* npre = nset->downpass1; - MPLstate* nfin = nset->uppass1; - MPLstate* anc = ancset->uppass1; - - for (i = 0; i < nchars; ++i) { - - j = indices[i]; - - if ((anc[j] & npre[j]) == anc[j]) { - nfin[j] = anc[j] & npre[j]; - } - else { - MPLstate res = 0; - mpl_closed_interval(&res, left[j], right[j]); - nfin[j] = (res & anc[j]) | npre[j]; - } - - assert(nfin[j]); - } - - return 0; -} - -int mpl_wagner_tip_update -(MPLndsets* tset, MPLndsets* ancset, MPLpartition* part) -{ - int i = 0; - int j = 0; - int* indices = part->charindices; - int nchars = part->ncharsinpart; - - MPLstate* tprelim = tset->downpass1; - MPLstate* tfinal = tset->uppass1; - MPLstate* astates = ancset->uppass1; - - for (i = 0; i < nchars; ++i) { - j = indices[i]; - if (tprelim[j] & astates[j]) { - tfinal[j] = tprelim[j] & astates[j]; - } - else { - tfinal[j] = tprelim[j]; - } - assert(tfinal[j]); - } - return 0; -} diff --git a/src/wagner.h b/src/wagner.h deleted file mode 100644 index 9d6984096..000000000 --- a/src/wagner.h +++ /dev/null @@ -1,19 +0,0 @@ -/* -// wagner.h -// morphylib -// -// Created by mbrazeau on 21/05/2017. -// Copyright © 2017 brazeaulab. All rights reserved. -*/ - -#ifndef wagner_h -#define wagner_h - -int mpl_wagner_downpass -(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLpartition* part); -int mpl_wagner_uppass -(MPLndsets* lset, MPLndsets* rset, MPLndsets* nset, MPLndsets* ancset, - MPLpartition* part); -int mpl_wagner_tip_update -(MPLndsets* tset, MPLndsets* ancset, MPLpartition* part); -#endif /* wagner_h */ diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index b0e26ae79..f942206aa 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -1,3 +1,3 @@ test_that("SPR errors", { - asan_error(matrix(9, 1, 1)) + expect_error(asan_error(matrix(9, 1, 1))) }) \ No newline at end of file From 39da59bf5dd60721d49d5c30541aed59117848e9 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 09:48:12 +0100 Subject: [PATCH 23/28] as.phylo(1, 3)$edge --- tests/testthat/test-rearrange.cpp.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index f942206aa..e075ff551 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -1,3 +1,4 @@ test_that("SPR errors", { - expect_error(asan_error(matrix(9, 1, 1))) + library("TreeTools") + expect_error(asan_error(as.phylo(1, 3)$edge)) }) \ No newline at end of file From 6a4485e2956be1b0c68f4c56bc53559990d85fb1 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 09:48:58 +0100 Subject: [PATCH 24/28] const ints --- src/rearrange.cpp | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/rearrange.cpp b/src/rearrange.cpp index db7bc26f3..86d1b4ed9 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -5,6 +5,14 @@ using namespace Rcpp; // [[Rcpp::export]] List asan_error (const IntegerMatrix x) { + const int + n_edge = x.nrow(), + n_internal = n_edge / 2, + n_tip = n_internal + 1, + n_vert = n_internal + n_tip, + root_node = n_tip + 1 + ; + Rf_error("Oh dear."); return List::create(); } From 33ad0df671661d9f7a130494e95f2413b2e40cf1 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 09:49:15 +0100 Subject: [PATCH 25/28] Only ASan --- .github/workflows/R-CMD-check.yml | 104 ------------------------------ .github/workflows/memcheck.yml | 104 ------------------------------ .github/workflows/pkgdown.yml | 74 --------------------- .github/workflows/revdep.yml | 73 --------------------- 4 files changed, 355 deletions(-) delete mode 100644 .github/workflows/R-CMD-check.yml delete mode 100644 .github/workflows/memcheck.yml delete mode 100644 .github/workflows/pkgdown.yml delete mode 100644 .github/workflows/revdep.yml diff --git a/.github/workflows/R-CMD-check.yml b/.github/workflows/R-CMD-check.yml deleted file mode 100644 index 3b20edd50..000000000 --- a/.github/workflows/R-CMD-check.yml +++ /dev/null @@ -1,104 +0,0 @@ -# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. -# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions -on: - push: - branches: - - main - - master - pull_request: - branches: - - main - - master - -name: R-CMD-check - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: windows-latest, r: 'release'} - - {os: macOS-latest, r: 'release'} - - {os: ubuntu-20.04, r: '3.6.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - env: - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - _R_CHECK_FORCE_SUGGESTS_: false - R_COMPILE_AND_INSTALL_PACKAGES: 'never' - RSPM: ${{ matrix.config.rspm }} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v1 - with: - r-version: ${{ matrix.config.r }} - - - uses: r-lib/actions/setup-pandoc@v1 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(c( - remotes::dev_package_deps(dependencies = c("soft", "Config/Needs/github-actions")) - ), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Cache R packages - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install system dependencies (Linux) - if: runner.os == 'Linux' - run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - - - name: Install system dependencies (macOS) - if: runner.os == 'macOS' - run: | - brew install libgit2 xquartz ghostscript - - - name: Install dependencies - run: | - remotes::install_deps(dependencies = c("soft", "Config/Needs/github-actions")) - shell: Rscript {0} - - - name: Install coverage dependencies - if: runner.os == 'macOS' - run: | - remotes::install_deps(dependencies = 'Config/Needs/coverage') - shell: Rscript {0} - - - name: Check - env: - _R_CHECK_CRAN_INCOMING_REMOTE_: false - run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") - shell: Rscript {0} - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check - - - name: Test coverage - if: runner.os == 'macOS' - run: | - covr::codecov() - shell: Rscript {0} diff --git a/.github/workflows/memcheck.yml b/.github/workflows/memcheck.yml deleted file mode 100644 index d1e451958..000000000 --- a/.github/workflows/memcheck.yml +++ /dev/null @@ -1,104 +0,0 @@ -# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. -# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions -on: - push: - branches: - - main - - master - paths: - - '.github/workflows/memcheck.yml' - - 'src/**' - - 'inst/include/**' - - 'memcheck/**' - - 'tests/testthat/**.R' - - 'vignettes/**.Rmd' - pull_request: - branches: - - main - - master - paths: - - '.github/workflows/memcheck.yml' - - 'src/**' - - 'inst/include/**' - - 'memcheck/**' - - 'tests/testthat/**.R' - - 'vignettes/**.Rmd' - -name: mem-check - -jobs: - mem-check: - runs-on: ubuntu-20.04 - - name: valgrind ${{ matrix.config.test }} - - strategy: - fail-fast: false - matrix: - config: - - {test: 'tests'} - - {test: 'examples'} - - {test: 'vignettes'} - - env: - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - _R_CHECK_FORCE_SUGGESTS_: false - RSPM: https://packagemanager.rstudio.com/cran/__linux__/focal/latest - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v1 - with: - r-version: release # CRAN uses devel, but takes ages to load deps. - - - name: Setup pandoc - if: ${{ matrix.config.test }} == 'vignettes' - uses: r-lib/actions/setup-pandoc@master - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = c('soft', 'Config/Needs/memcheck')), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Cache R packages - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install system dependencies - run: | - sudo apt-get install valgrind texlive-latex-base - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - - - name: Install dependencies - run: | - remotes::install_github('emmanuelparadis/ape') - if ("${{ matrix.config.test }}" == 'tests') { - remotes::install_github('r-lib/brio#20') # brio mem leak - } - remotes::install_deps(dependencies = c('soft', 'Config/Needs/memcheck')) - shell: Rscript {0} - - - name: Install package - run: | - cd .. - R CMD build --no-manual --no-build-vignettes --no-resave-data TreeSearch - R CMD INSTALL TreeSearch*.tar.gz - cd TreeSearch - - - name: valgrind - memcheck ${{ matrix.config.test }} - run: | - R -d "valgrind --tool=memcheck \ - --leak-check=full \ - --errors-for-leak-kinds=definite \ - --error-exitcode=1" \ - --vanilla < memcheck/${{ matrix.config.test }}.R diff --git a/.github/workflows/pkgdown.yml b/.github/workflows/pkgdown.yml deleted file mode 100644 index 4ff1177f5..000000000 --- a/.github/workflows/pkgdown.yml +++ /dev/null @@ -1,74 +0,0 @@ -on: - push: - branches: - - main - - master - -name: pkgdown - -jobs: - pkgdown: - runs-on: ubuntu-20.04 - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_COMPILE_AND_INSTALL_PACKAGES: 'never' - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@master - - - uses: r-lib/actions/setup-pandoc@master - - # - name: Locate fortran v8 - # run: | - # brew remove gcc - # brew link gcc@8 - # - # - name: Install X11 dependencies on MacOS - # run: | - # brew install cairo - - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - sudo apt-get install libharfbuzz-dev libfribidi-dev libglpk-dev libcurl4-openssl-dev - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps( - dependencies = c("soft", "Config/Needs/website") - ), - ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Cache R packages - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install dependencies - run: | - remotes::install_github("r-lib/pkgdown") - remotes::install_github("ms609/TreeTools@rogue") - remotes::install_deps( - dependencies = c("soft", "Config/Needs/website") - ) - shell: Rscript {0} - - - name: Install package - run: R CMD INSTALL . - - - name: Build and deploy documentation - run: | - git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE); if (length(warnings()) > 0) stop("Fail on warning")' diff --git a/.github/workflows/revdep.yml b/.github/workflows/revdep.yml deleted file mode 100644 index 6d58e5a12..000000000 --- a/.github/workflows/revdep.yml +++ /dev/null @@ -1,73 +0,0 @@ -on: - push: - branches: - - main - - master - pull_request: - branches: - - main - - master - -name: revdep-check - -jobs: - mem-check: - runs-on: macOS-latest - - name: revdepcheck, macOS, R release - - env: - _R_CHECK_CRAN_INCOMING_: true # Seemingly not set by --as-cran - _R_CHECK_FORCE_SUGGESTS_: false # CRAN settings - R_COMPILE_AND_INSTALL_PACKAGES: 'never' - _R_CHECK_THINGS_IN_CHECK_DIR_: false - R_REMOTES_STANDALONE: true - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - _R_CHECK_CRAN_INCOMING_USE_ASPELL_: false # Set to true when can figure how to install aspell on Windows - RSPM: ${{ matrix.config.rspm }} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v1 - with: - r-version: release - - - uses: r-lib/actions/setup-pandoc@v1 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = c('soft', 'Config/Needs/revdeps')), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Cache R packages - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install dependencies - run: | - remotes::install_github("r-lib/revdepcheck") - remotes::install_deps(dependencies = c('soft', 'Config/Needs/revdeps')) - shell: Rscript {0} - - - name: Check reverse dependencies - env: - _R_CHECK_CRAN_INCOMING_REMOTE_: false - run: | - revdepcheck::revdep_check(timeout = as.difftime(60, units = 'mins'), num_workers = 4) - problems <- readLines('revdep/problems.md', warn = FALSE) - if (length(problems) > 1) stop(paste0(problems, collapse= "\n")) - shell: Rscript {0} - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main - with: - name: revdep-results - path: revdep/*.md From ea0ffaa0b68bd4185c9b779844943cdff5b62d65 Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 10:23:53 +0100 Subject: [PATCH 26/28] Restore rest of test --- R/RcppExports.R | 4 +- src/RcppExports.cpp | 8 +- src/rearrange.cpp | 171 +++++++++++++++++++++++++++- tests/testthat/test-rearrange.cpp.R | 4 +- 4 files changed, 175 insertions(+), 12 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index f35811d22..408533aa9 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,7 +1,7 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -asan_error <- function(x) { - .Call(`_TreeSearch_asan_error`, x) +asan_error <- function(edge) { + .Call(`_TreeSearch_asan_error`, edge) } diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 006fd5894..49911c9ed 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -11,13 +11,13 @@ Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // asan_error -List asan_error(const IntegerMatrix x); -RcppExport SEXP _TreeSearch_asan_error(SEXP xSEXP) { +List asan_error(const IntegerMatrix edge); +RcppExport SEXP _TreeSearch_asan_error(SEXP edgeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type x(xSEXP); - rcpp_result_gen = Rcpp::wrap(asan_error(x)); + Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); + rcpp_result_gen = Rcpp::wrap(asan_error(edge)); return rcpp_result_gen; END_RCPP } diff --git a/src/rearrange.cpp b/src/rearrange.cpp index 86d1b4ed9..38e150822 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -3,16 +3,177 @@ using namespace std; using namespace Rcpp; +inline void add_children(unique_ptr &n_children, + const int16 parent, const int16 child) { + n_children[parent - 1] += n_children[child - 1]; +} + + +inline void set_child(unique_ptr &side, const int16 parent, + const int16 value, const int16 n_tip) { + side[parent - 1 - n_tip] = value; +} + +inline int16 get_child(unique_ptr &side, const int16 parent, const int16 n_tip) { + return side[parent - 1 - n_tip]; +} + +inline int16 count_children(unique_ptr &n_children, const int16 vert) { + return n_children[vert - 1]; +} + +inline int16 edge_above(const int16 vert, unique_ptr &parent_edge) { + return parent_edge[vert - 1]; +} + +inline IntegerMatrix fuse(const IntegerMatrix& tree_bits, + const int16* graft_edge, const int16* break_edge, + const int16* spare_edge, const int16* spare_node) { + IntegerMatrix new_tree = clone(tree_bits); + new_tree(*spare_edge, 1) = tree_bits(*graft_edge, 1); + new_tree(*graft_edge, 1) = *spare_node; + new_tree(*break_edge, 0) = *spare_node; + return TreeTools::preorder_edges_and_nodes(new_tree(_, 0), new_tree(_, 1)); +} + // [[Rcpp::export]] -List asan_error (const IntegerMatrix x) { +List asan_error (const IntegerMatrix edge, const IntegerVector break_order) { const int - n_edge = x.nrow(), + n_edge = edge.nrow(), n_internal = n_edge / 2, n_tip = n_internal + 1, n_vert = n_internal + n_tip, root_node = n_tip + 1 ; - Rf_error("Oh dear."); - return List::create(); -} + if (n_edge < 5000) { + Rf_error("Oh dear."); + } + + IntegerVector break_seq; + if (break_order.length()) { + break_seq = clone(break_order); + } else { + IntegerVector tmp (n_edge - 1); + break_seq = tmp; + for (int16 i = n_edge - 1; i--; ) { + break_seq[i] = i + 2; + } + } + + unique_ptr n_children = make_unique(n_vert); + // if both internal, left_node < right_node + unique_ptr left_node = make_unique(n_internal); + unique_ptr right_node = make_unique(n_internal); + // left_edge is plotted on top with ape::plot.phylo + unique_ptr left_edge = make_unique(n_internal); + unique_ptr right_edge = make_unique(n_internal); + unique_ptr parent_edge = make_unique(n_vert); + for (int16 i = n_tip; i--; ) { + n_children[i] = 1; + } + + for (int16 i = n_edge; i--; ) { + const int parent = edge(i, 0); + const int child = edge(i, 1); + add_children(n_children, parent, child); + parent_edge[child - 1] = i; + if (get_child(left_node, parent, n_tip)) { + set_child(right_node, parent, child, n_tip); + set_child(right_edge, parent, i, n_tip); + } else { + set_child(left_node, parent, child, n_tip); + set_child(left_edge, parent, i, n_tip); + } + } + + + List ret = List::create(); + + // Let's go. + for (int16 i = break_seq.length(); i--; ) { + IntegerMatrix two_bits = clone(edge); + if (break_seq[i] > n_edge) { + Rf_warning("Ignoring SPR break locations that exceed number of edges in tree.\n"); + continue; + } + if (break_seq[i] < 2) { + Rf_warning("Ignoring break locations < 2"); + continue; + } + const int16 + break_edge = break_seq[i] - 1, + break_parent = edge(break_edge, 0), + break_child = edge(break_edge, 1), + spare_node = break_parent, + + fragment_root = break_child, + fragment_leaves = count_children(n_children, break_child), + fragment_edges = fragment_leaves + fragment_leaves - 1, + fragment_min_edge = break_edge, + fragment_max_edge = break_edge + fragment_edges - 1 + ; + const bool broken_on_left = get_child(left_edge, break_parent, n_tip) == break_edge; + const int16 + spare_edge = broken_on_left ? + get_child(right_edge, break_parent, n_tip) : + get_child(left_edge, break_parent, n_tip) + ; + + two_bits(edge_above(break_parent, parent_edge), 1) = broken_on_left ? + get_child(right_node, break_parent, n_tip) : + get_child(left_node, break_parent, n_tip); + if (break_edge == 1) { + const int16 + fragment_base_right = 2, + fragment_base_left = get_child(left_edge, fragment_root, n_tip); + ; + + for (int16 insertion_point = fragment_min_edge + 2; + insertion_point != fragment_max_edge + 1; insertion_point++) { + if (insertion_point == fragment_base_left) { + continue; + } + + int16 invert_next = insertion_point; + IntegerMatrix rerooted = clone(two_bits); + + rerooted(invert_next, 0) = break_child; // Borrow fragment-root node id + rerooted(invert_next, 1) = two_bits(invert_next, 0); + + do { + invert_next = edge_above(two_bits(invert_next, 0), parent_edge); + rerooted(invert_next, 0) = two_bits(invert_next, 1); + rerooted(invert_next, 1) = two_bits(invert_next, 0); + } while (two_bits(invert_next, 0) != fragment_root); + + const bool new_root_on_right = invert_next == fragment_base_right; + const int16 repurposed_edge = new_root_on_right ? + fragment_base_left : + fragment_base_right; + rerooted(invert_next, 1) = two_bits(repurposed_edge, 1); + rerooted(repurposed_edge, 1) = two_bits(insertion_point, 1); + rerooted = TreeTools::preorder_edges_and_nodes(rerooted(_, 0), rerooted(_, 1)); + ret.push_back(rerooted); + } + } else { + for (int16 graft_edge = n_edge - 1; graft_edge; graft_edge--) { + if (graft_edge == fragment_max_edge) { + graft_edge = fragment_min_edge; + continue; + } else if (broken_on_left && graft_edge == get_child(right_edge, break_parent, n_tip)) { + graft_edge = edge_above(break_parent, parent_edge); + continue; + } else if (graft_edge == spare_edge) { + continue; + } else if (graft_edge == edge_above(break_parent, parent_edge)) { + continue; + } + ret.push_back(fuse(two_bits, &graft_edge, &break_edge, &spare_edge, + &spare_node)); + if (graft_edge < 0) break; // TODO REMOVE + } + } + } + return ret; +} \ No newline at end of file diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index e075ff551..67582b599 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -1,4 +1,6 @@ test_that("SPR errors", { library("TreeTools") - expect_error(asan_error(as.phylo(1, 3)$edge)) + expect_error(asan_error(as.phylo(1, 3)$edge)), integer(0) + expect_error(asan_error(Postorder(as.phylo(1, 6))$edge, integer(0))) + expect_error(asan_error(SortTree(as.phylo(1, 6))$edge, integer(0))) }) \ No newline at end of file From 6442ced96489af52e96833438110167a05dac69c Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 11:23:24 +0100 Subject: [PATCH 27/28] importFrom TreeTools --- NAMESPACE | 1 + R/RcppExports.R | 4 ++-- R/zzz.R | 1 + src/RcppExports.cpp | 9 +++++---- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 17bed8b09..a89c815a7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,3 +1,4 @@ # Generated by roxygen2: do not edit by hand +importFrom(TreeTools,Preorder) useDynLib(TreeSearch, .registration = TRUE) diff --git a/R/RcppExports.R b/R/RcppExports.R index 408533aa9..b72560973 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,7 +1,7 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -asan_error <- function(edge) { - .Call(`_TreeSearch_asan_error`, edge) +asan_error <- function(edge, break_order) { + .Call(`_TreeSearch_asan_error`, edge, break_order) } diff --git a/R/zzz.R b/R/zzz.R index a42e8c9e8..9ddb93b1e 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,5 +1,6 @@ # Suppress "NOTE: Nothing imported from Rdpack": #' @useDynLib TreeSearch, .registration = TRUE +#' @importFrom TreeTools Preorder .onUnload <- function (libpath) { library.dynam.unload("TreeSearch", libpath) } diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 49911c9ed..67a04a89c 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -11,19 +11,20 @@ Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // asan_error -List asan_error(const IntegerMatrix edge); -RcppExport SEXP _TreeSearch_asan_error(SEXP edgeSEXP) { +List asan_error(const IntegerMatrix edge, const IntegerVector break_order); +RcppExport SEXP _TreeSearch_asan_error(SEXP edgeSEXP, SEXP break_orderSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const IntegerMatrix >::type edge(edgeSEXP); - rcpp_result_gen = Rcpp::wrap(asan_error(edge)); + Rcpp::traits::input_parameter< const IntegerVector >::type break_order(break_orderSEXP); + rcpp_result_gen = Rcpp::wrap(asan_error(edge, break_order)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { - {"_TreeSearch_asan_error", (DL_FUNC) &_TreeSearch_asan_error, 1}, + {"_TreeSearch_asan_error", (DL_FUNC) &_TreeSearch_asan_error, 2}, {NULL, NULL, 0} }; From 5864f23238611afb7a46dce2aef66e825e4eaeac Mon Sep 17 00:00:00 2001 From: Martin Smith <1695515+ms609@users.noreply.github.com> Date: Fri, 24 Sep 2021 13:16:34 +0100 Subject: [PATCH 28/28] balance )s --- tests/testthat/test-rearrange.cpp.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-rearrange.cpp.R b/tests/testthat/test-rearrange.cpp.R index 67582b599..8c97a8bf6 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -1,6 +1,6 @@ test_that("SPR errors", { library("TreeTools") - expect_error(asan_error(as.phylo(1, 3)$edge)), integer(0) + expect_error(asan_error(as.phylo(1, 3)$edge), integer(0)) expect_error(asan_error(Postorder(as.phylo(1, 6))$edge, integer(0))) expect_error(asan_error(SortTree(as.phylo(1, 6))$edge, integer(0))) }) \ No newline at end of file