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/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 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 diff --git a/NAMESPACE b/NAMESPACE index f067b902e..a89c815a7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,196 +1,4 @@ # 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/NEWS.md b/NEWS.md index e6604a9a7..1e3f460f7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,6 @@ # TreeSearch 1.0.1 -- Memory management with invalid input +- Memory management in RANDOMTREESCORE - Corrections to metadata # TreeSearch 1.0.0 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 33cb4a90f..b72560973 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,43 +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) -} - -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) +asan_error <- function(edge, break_order) { + .Call(`_TreeSearch_asan_error`, 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..9ddb93b1e 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,31 +1,6 @@ # Suppress "NOTE: Nothing imported from Rdpack": -#' @importFrom Rdpack reprompt +#' @useDynLib TreeSearch, .registration = TRUE +#' @importFrom TreeTools Preorder .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/codemeta.json b/codemeta.json index 496a407e3..8cc7843c6 100644 --- a/codemeta.json +++ b/codemeta.json @@ -319,7 +319,7 @@ }, "SystemRequirements": "C++14" }, - "fileSize": "2056.242KB", + "fileSize": "2143.071KB", "citation": [ { "@type": "SoftwareSourceCode", 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 bbb5c9868..67a04a89c 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -10,132 +10,25 @@ 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 -} -// all_spr -List all_spr(const IntegerMatrix edge, const IntegerVector break_order); -RcppExport SEXP _TreeSearch_all_spr(SEXP edgeSEXP, SEXP break_orderSEXP) { +// asan_error +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::traits::input_parameter< const IntegerVector >::type break_order(break_orderSEXP); - rcpp_result_gen = Rcpp::wrap(all_spr(edge, break_order)); + rcpp_result_gen = Rcpp::wrap(asan_error(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, 2}, + {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 110cbf2ce..38e150822 100644 --- a/src/rearrange.cpp +++ b/src/rearrange.cpp @@ -1,294 +1,16 @@ #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: -// * 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, - 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); +inline void add_children(unique_ptr &n_children, + const int16 parent, const int16 child) { + n_children[parent - 1] += n_children[child - 1]; } -// [[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) { + const int16 value, const int16 n_tip) { side[parent - 1 - n_tip] = value; } @@ -300,11 +22,6 @@ 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]; } @@ -319,32 +36,19 @@ inline IntegerMatrix fuse(const IntegerMatrix& tree_bits, return TreeTools::preorder_edges_and_nodes(new_tree(_, 0), new_tree(_, 1)); } - -// 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) { - const int16 +List asan_error (const IntegerMatrix edge, const IntegerVector break_order) { + const int 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 ; - // ASAN reports stack-use-after-scope (false positive?) if we fail here. - // So we test for these exceptions in R. - // # nocov begin - 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))."); + + if (n_edge < 5000) { + Rf_error("Oh dear."); } - // # nocov end IntegerVector break_seq; if (break_order.length()) { @@ -399,29 +103,29 @@ List all_spr (const IntegerMatrix edge, } const int16 break_edge = break_seq[i] - 1, - break_parent = edge(break_edge, 0), - break_child = edge(break_edge, 1), - spare_node = break_parent, + 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 + 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) + 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(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_right = 2, fragment_base_left = get_child(left_edge, fragment_root, n_tip); ; @@ -445,7 +149,7 @@ List all_spr (const IntegerMatrix edge, const bool new_root_on_right = invert_next == fragment_base_right; const int16 repurposed_edge = new_root_on_right ? - fragment_base_left : + fragment_base_left : fragment_base_right; rerooted(invert_next, 1) = two_bits(repurposed_edge, 1); rerooted(repurposed_edge, 1) = two_bits(insertion_point, 1); @@ -472,163 +176,4 @@ List all_spr (const IntegerMatrix edge, } } 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; -} +} \ No newline at end of file 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/_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 96498300b..000000000 --- a/tests/testthat/test-RandomTreeScore.R +++ /dev/null @@ -1,43 +0,0 @@ -test_that("RandomMorphyTree() errors are handled", { - expect_error(RandomMorphyTree(-1)) - expect_error(RandomMorphyTree(0)) - expect_error(RandomMorphyTree(1)) -}) - -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(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 1b0061d07..8c97a8bf6 100644 --- a/tests/testthat/test-rearrange.cpp.R +++ b/tests/testthat/test-rearrange.cpp.R @@ -1,161 +1,6 @@ -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)))) -}) - -test_that("TBR working", { - 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", { - expect_error(.all_spr(as.phylo(1, 3)$edge, integer(0))) - expect_error(.all_spr(Postorder(as.phylo(1, 6))$edge, integer(0))) - expect_error(.all_spr(SortTree(as.phylo(1, 6))$edge, integer(0))) -}) - -test_that("SPR works", { - 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)) - - # 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))) - - # 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)))) - - # Move more - expect_equal(0, length(unique(all_spr(tr$edge, 4)))) - expect_equal(4, length(unique(all_spr(tr$edge, 8)))) - - # 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))) - - 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]]) -}) - -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) - - + library("TreeTools") + 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 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)) -})