├── .Rbuildignore ├── .gitignore ├── CONDUCT.md ├── CONTRIBUTORS.md ├── DESCRIPTION ├── Makefile ├── NAMESPACE ├── NEWS ├── NEWS.md ├── R ├── AllClasses.R ├── AllGenerics.R ├── ancestor.R ├── ape.R ├── as-tibble.R ├── converter.R ├── filter.R ├── full-join.R ├── get-data.R ├── get-fields.R ├── groupClade.R ├── groupOTU.R ├── inner-join.R ├── isTip.R ├── left-join.R ├── method-MRCA.R ├── method-accessor.R ├── method-as-ultrametric.R ├── method-drop-tip.R ├── method-get-treetext.R ├── method-groupClade.R ├── method-groupOTU.R ├── method-merge.R ├── method-reroot.R ├── methods-tidyr.R ├── mutate.R ├── nodeid.R ├── offspring.R ├── pull.R ├── reexports.R ├── rename.R ├── select.R ├── show.R ├── sibling.R ├── tidy-package.R ├── tidy_utilities.R ├── tree-subset.R └── zzz.R ├── README.Rmd ├── README.md ├── TODO.md ├── inst └── CITATION ├── man ├── MRCA.Rd ├── Nnode.treedata.Rd ├── ancestor.Rd ├── as.treedata.Rd ├── as.ultrametric.Rd ├── child.Rd ├── drop.tip-methods.Rd ├── get.data-methods.Rd ├── get.fields-methods.Rd ├── get.treetext-methods.Rd ├── getNodeNum.Rd ├── get_tree_data.Rd ├── groupClade.Rd ├── groupOTU.Rd ├── isTip.Rd ├── node.label.Rd ├── nodeid.Rd ├── nodelab.Rd ├── offspring.Rd ├── parent.Rd ├── reexports.Rd ├── root-method.Rd ├── rootnode.Rd ├── show-methods.Rd ├── sibling.Rd ├── td-label-assign.Rd ├── tidytree-package.Rd ├── tip.label.Rd ├── tree_subset.Rd ├── treedata-class.Rd └── treedata.Rd ├── tests ├── testthat.R └── testthat │ ├── test-access-related-nodes.R │ ├── test-assign.R │ ├── test-dplyr-methods.R │ ├── test-drop.tip.R │ ├── test-fulljoin.R │ ├── test-grouping.R │ └── test-innerjoin.R ├── tidytree.Rproj └── vignettes └── tidytree.Rmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | Makefile 4 | CONTRIBUTORS.md 5 | README.Rmd 6 | CONDUCT.md 7 | README.md 8 | TODO.md 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | *~ 5 | -------------------------------------------------------------------------------- /CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, we pledge to respect all people who 4 | contribute through reporting issues, posting feature requests, updating documentation, 5 | submitting pull requests or patches, and other activities. 6 | 7 | We are committed to making participation in this project a harassment-free experience for 8 | everyone, regardless of level of experience, gender, gender identity and expression, 9 | sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. 10 | 11 | Examples of unacceptable behavior by participants include the use of sexual language or 12 | imagery, derogatory comments or personal attacks, trolling, public or private harassment, 13 | insults, or other unprofessional conduct. 14 | 15 | Project maintainers have the right and responsibility to remove, edit, or reject comments, 16 | commits, code, wiki edits, issues, and other contributions that are not aligned to this 17 | Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed 18 | from the project team. 19 | 20 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by 21 | opening an issue or contacting one or more of the project maintainers. 22 | 23 | This Code of Conduct is adapted from the Contributor Covenant 24 | (http:contributor-covenant.org), version 1.0.0, available at 25 | http://contributor-covenant.org/version/1/0/0/ 26 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | Bradley Jones 2 | ------------- 3 | + as.phylo method for data.frame 4 | - 5 | 6 | Zebulun Arendsee 7 | ---------------- 8 | + add tests for accessing related nodes 9 | - 10 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: tidytree 2 | Title: A Tidy Tool for Phylogenetic Tree Data Manipulation 3 | Version: 0.4.6.002 4 | Authors@R: c( 5 | person("Guangchuang", "Yu", email = "guangchuangyu@gmail.com", role = c("aut", "cre", "cph"), comment = c(ORCID = "0000-0002-6485-8781")), 6 | person("Bradley", "Jones", email = "brj1@sfu.ca", role = "ctb"), 7 | person("Zebulun", "Arendsee", email = "zbwrnz@gmail.com", role = "ctb") 8 | ) 9 | Description: Phylogenetic tree generally contains multiple components including node, edge, branch and associated data. 'tidytree' provides an approach to convert tree object to tidy data frame as well as provides tidy interfaces to manipulate tree data. 10 | Depends: 11 | R (>= 3.4.0) 12 | Imports: 13 | ape, 14 | dplyr, 15 | lazyeval, 16 | magrittr, 17 | methods, 18 | rlang, 19 | tibble, 20 | tidyr, 21 | tidyselect, 22 | yulab.utils (>= 0.1.5), 23 | pillar, 24 | cli 25 | Suggests: 26 | knitr, 27 | rmarkdown, 28 | prettydoc, 29 | testthat, 30 | utils 31 | VignetteBuilder: knitr 32 | ByteCompile: true 33 | License: Artistic-2.0 34 | URL: https://www.amazon.com/Integration-Manipulation-Visualization-Phylogenetic-Computational-ebook/dp/B0B5NLZR1Z/ 35 | BugReports: https://github.com/YuLab-SMU/tidytree/issues 36 | Encoding: UTF-8 37 | RoxygenNote: 7.3.2 38 | Roxygen: list(markdown = TRUE) 39 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PKGNAME := $(shell sed -n "s/Package: *\([^ ]*\)/\1/p" DESCRIPTION) 2 | PKGVERS := $(shell sed -n "s/Version: *\([^ ]*\)/\1/p" DESCRIPTION) 3 | PKGSRC := $(shell basename `pwd`) 4 | 5 | all: rd check clean 6 | 7 | rd: 8 | Rscript -e 'library(methods); devtools::document()' 9 | 10 | readme: 11 | Rscript -e 'rmarkdown::render("README.Rmd", encoding="UTF-8")' 12 | 13 | 14 | build: 15 | Rscript -e 'devtools::build()' 16 | # cd ..;\ 17 | # R CMD build $(PKGSRC) 18 | 19 | build2: 20 | Rscript -e 'devtools::build(vignettes = FALSE)' 21 | # cd ..;\ 22 | # R CMD build --no-build-vignettes $(PKGSRC) 23 | 24 | install: 25 | cd ..;\ 26 | R CMD INSTALL $(PKGNAME)_$(PKGVERS).tar.gz 27 | 28 | check: 29 | Rscript -e 'devtools::check()' 30 | # cd ..;\ 31 | # Rscript -e 'rcmdcheck::rcmdcheck("$(PKGNAME)_$(PKGVERS).tar.gz", args="--as-cran")' 32 | 33 | check2: build 34 | cd ..;\ 35 | R CMD check $(PKGNAME)_$(PKGVERS).tar.gz 36 | 37 | bioccheck: 38 | cd ..;\ 39 | Rscript -e 'BiocCheck::BiocCheck("$(PKGNAME)_$(PKGVERS).tar.gz")' 40 | 41 | clean: 42 | cd ..;\ 43 | $(RM) -r $(PKGNAME).Rcheck/ 44 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("[",treedata) 4 | S3method("[[",treedata) 5 | S3method("node.label<-",phylo) 6 | S3method("node.label<-",tbl_tree) 7 | S3method("node.label<-",treedata) 8 | S3method("tip.label<-",phylo) 9 | S3method("tip.label<-",tbl_tree) 10 | S3method("tip.label<-",treedata) 11 | S3method(MRCA,phylo) 12 | S3method(MRCA,tbl_tree) 13 | S3method(MRCA,treedata) 14 | S3method(Nnode,tbl_tree) 15 | S3method(Nnode,treedata) 16 | S3method(Ntip,tbl_tree) 17 | S3method(Ntip,treedata) 18 | S3method(Ntip,treedataList) 19 | S3method(ancestor,phylo) 20 | S3method(ancestor,tbl_tree) 21 | S3method(ancestor,treedata) 22 | S3method(as.phylo,tbl_tree) 23 | S3method(as.phylo,treedata) 24 | S3method(as.treedata,tbl_tree) 25 | S3method(as.ultrametric,phylo) 26 | S3method(as.ultrametric,tbl_tree) 27 | S3method(as.ultrametric,treedata) 28 | S3method(as_tibble,phylo) 29 | S3method(as_tibble,treedata) 30 | S3method(child,phylo) 31 | S3method(child,tbl_tree) 32 | S3method(child,treedata) 33 | S3method(filter,ggtree) 34 | S3method(filter,tbl_tree) 35 | S3method(filter,treedata) 36 | S3method(full_join,phylo) 37 | S3method(full_join,treedata) 38 | S3method(groupClade,phylo) 39 | S3method(groupClade,tbl_tree) 40 | S3method(groupClade,treedata) 41 | S3method(groupOTU,phylo) 42 | S3method(groupOTU,tbl_tree) 43 | S3method(groupOTU,treedata) 44 | S3method(inner_join,phylo) 45 | S3method(inner_join,treedata) 46 | S3method(is.rooted,treedata) 47 | S3method(isTip,phylo) 48 | S3method(isTip,tbl_tree) 49 | S3method(isTip,treedata) 50 | S3method(left_join,phylo) 51 | S3method(left_join,tbl_tree) 52 | S3method(left_join,treedata) 53 | S3method(merge,tbl_tree) 54 | S3method(mutate,tbl_tree) 55 | S3method(mutate,treedata) 56 | S3method(node.label,phylo) 57 | S3method(node.label,tbl_tree) 58 | S3method(node.label,treedata) 59 | S3method(nodeid,phylo) 60 | S3method(nodeid,tbl_tree) 61 | S3method(nodeid,treedata) 62 | S3method(nodelab,phylo) 63 | S3method(nodelab,tbl_tree) 64 | S3method(nodelab,treedata) 65 | S3method(offspring,phylo) 66 | S3method(offspring,tbl_tree) 67 | S3method(offspring,treedata) 68 | S3method(parent,phylo) 69 | S3method(parent,tbl_tree) 70 | S3method(parent,treedata) 71 | S3method(print,tbl_tree) 72 | S3method(print,treedata) 73 | S3method(pull,phylo) 74 | S3method(pull,treedata) 75 | S3method(rename,tbl_tree) 76 | S3method(rename,treedata) 77 | S3method(root,treedata) 78 | S3method(rootnode,phylo) 79 | S3method(rootnode,tbl_tree) 80 | S3method(select,ggtree) 81 | S3method(select,tbl_tree) 82 | S3method(select,treedata) 83 | S3method(sibling,phylo) 84 | S3method(sibling,tbl_tree) 85 | S3method(tip.label,phylo) 86 | S3method(tip.label,tbl_tree) 87 | S3method(tip.label,treedata) 88 | S3method(tree_subset,phylo) 89 | S3method(tree_subset,treedata) 90 | S3method(unnest,treedata) 91 | export("%<>%") 92 | export("%>%") 93 | export("node.label<-") 94 | export("tip.label<-") 95 | export(.data) 96 | export(MRCA) 97 | export(Nnode) 98 | export(Ntip) 99 | export(ancestor) 100 | export(arrange) 101 | export(as.phylo) 102 | export(as.treedata) 103 | export(as.ultrametric) 104 | export(as_tibble) 105 | export(child) 106 | export(drop.tip) 107 | export(filter) 108 | export(full_join) 109 | export(get.data) 110 | export(get.fields) 111 | export(get.treetext) 112 | export(getNodeNum) 113 | export(get_tree_data) 114 | export(groupClade) 115 | export(groupOTU) 116 | export(is.rooted) 117 | export(isTip) 118 | export(keep.tip) 119 | export(left_join) 120 | export(mutate) 121 | export(node.label) 122 | export(nodeid) 123 | export(nodelab) 124 | export(offspring) 125 | export(parent) 126 | export(pull) 127 | export(read.tree) 128 | export(rename) 129 | export(root) 130 | export(rootnode) 131 | export(rtree) 132 | export(select) 133 | export(sibling) 134 | export(summarise) 135 | export(summarize) 136 | export(tibble) 137 | export(tip.label) 138 | export(transmute) 139 | export(tree_subset) 140 | export(treedata) 141 | export(unnest) 142 | exportClasses(treedata) 143 | exportMethods(drop.tip) 144 | exportMethods(get.data) 145 | exportMethods(get.fields) 146 | exportMethods(get.treetext) 147 | exportMethods(keep.tip) 148 | exportMethods(show) 149 | importFrom(ape,Nnode) 150 | importFrom(ape,Ntip) 151 | importFrom(ape,as.DNAbin) 152 | importFrom(ape,as.phylo) 153 | importFrom(ape,extract.clade) 154 | importFrom(ape,is.rooted) 155 | importFrom(ape,print.phylo) 156 | importFrom(ape,read.tree) 157 | importFrom(ape,root) 158 | importFrom(ape,rtree) 159 | importFrom(ape,which.edge) 160 | importFrom(cli,cli_warn) 161 | importFrom(dplyr,arrange) 162 | importFrom(dplyr,bind_rows) 163 | importFrom(dplyr,filter) 164 | importFrom(dplyr,full_join) 165 | importFrom(dplyr,group_by) 166 | importFrom(dplyr,inner_join) 167 | importFrom(dplyr,left_join) 168 | importFrom(dplyr,mutate) 169 | importFrom(dplyr,pull) 170 | importFrom(dplyr,rename) 171 | importFrom(dplyr,select) 172 | importFrom(dplyr,summarise) 173 | importFrom(dplyr,summarize) 174 | importFrom(dplyr,transmute) 175 | importFrom(lazyeval,interp) 176 | importFrom(magrittr,"%<>%") 177 | importFrom(magrittr,"%>%") 178 | importFrom(methods,is) 179 | importFrom(methods,isClass) 180 | importFrom(methods,new) 181 | importFrom(methods,representation) 182 | importFrom(methods,setClass) 183 | importFrom(methods,setClassUnion) 184 | importFrom(methods,setGeneric) 185 | importFrom(methods,setOldClass) 186 | importFrom(methods,show) 187 | importFrom(pillar,style_subtle) 188 | importFrom(rlang,.data) 189 | importFrom(rlang,quo) 190 | importFrom(tibble,as_tibble) 191 | importFrom(tibble,tibble) 192 | importFrom(tidyr,unnest) 193 | importFrom(tidyselect,eval_select) 194 | importFrom(utils,head) 195 | importFrom(utils,tail) 196 | importFrom(yulab.utils,str_wrap) 197 | importFrom(yulab.utils,yulab_msg) 198 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | CHANGES IN VERSION 0.1.6 2 | ------------------------ 3 | o treedata constructor <2017-12-20, Wed> 4 | o treedata show method now supports treedata@file contains several file names <2017-12-20, Wed> 5 | o optimize accessor of related nodes <2017-12-15, Fri> 6 | + https://github.com/GuangchuangYu/tidytree/issues/4 7 | o remove isTip column which can be computed easily and fixed typo in vignette <2017-12-15, Fri> 8 | 9 | CHANGES IN VERSION 0.1.5 10 | ------------------------ 11 | o show and get.fields methods for treedata <2017-12-14, Thu> 12 | 13 | CHANGES IN VERSION 0.99.4 14 | ------------------------ 15 | o for CRAN submission 16 | + Bioconductor team has complex of using S4 and force contributor to using it. 17 | + https://github.com/Bioconductor/Contributions/issues/578 18 | o move treedata class definition and some generic method from treeio to tidytree, 19 | since dependency of BioC devel pkg for a CRAN pkg seems not possible. 20 | Those code will remove from treeio and import from tidytree when it is accepted. 21 | 22 | CHANGES IN VERSION 0.99.3 23 | ------------------------ 24 | o valid.tbl_tree for checking tbl_tree object contains. <2017-12-13, Wed> 25 | 26 | CHANGES IN VERSION 0.99.1 27 | ------------------------ 28 | o add tests for groupOTU and groupClade <2017-12-12, Tue> 29 | 30 | CHANGES IN VERSION 0.99.0 31 | ------------------------ 32 | o fixed BiocCheck and ready to submit to Bioconductor <2017-12-12, Tue> 33 | 34 | CHANGES IN VERSION 0.0.3 35 | ------------------------ 36 | o update vignette with examples of groupOTU and groupClade <2017-12-12, Tue> 37 | o groupOTU & groupClade methods <2017-12-11, Mon> 38 | 39 | CHANGES IN VERSION 0.0.2 40 | ------------------------ 41 | o mrca method <2017-12-08, Fri> 42 | o access method for related nodes, including child, parent, offspring and ancestor <2017-12-07, Thu> 43 | + test added by @arendsee 44 | o remove fortify method, which should belong to ggtree <2017-12-07, Thu> 45 | o re-implement as.data.frame to as_data_frame <2017-12-07, Thu> 46 | 47 | CHANGES IN VERSION 0.0.1 48 | ------------------------ 49 | o as.data.frame & fortify method for treedata object <2016-12-06, Tue> -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # tidytree 0.4.6.002 2 | 3 | + deprecate `random_ref()` and use `yulab.utils::yulab_msg()` (2024-07-26, Fri) 4 | + `Ntip()` method for 'treedataList' object (2024-04-08, Mon) 5 | 6 | # tidytree 0.4.6 7 | 8 | + import `methods::setClassUnion()` to fix R check (2023-12-12, Tue) 9 | + check before `setOldClass()`, which suppose to fix the #47 issue (2023-11-29, Wed) 10 | 11 | # tidytree 0.4.5 12 | 13 | + mv tree operation functions (e.g., `parent()`, `child()`, `tree_subset()`, etc.) from the 'treeio' package (2023-08-03, Thu, #44) 14 | + update `valid.edge()` to avoid warning (2023-7-18, Tue) 15 | 16 | # tidytree 0.4.4 17 | 18 | + update old-style 'CITATION' from `citEntry()` to `bibentry()` (2023-07-14, Fri, #38) 19 | + update dplyr-verb for 'tbl_tree' object to print information to avoid confusion (2023-07-13, Thu, #37, #39) 20 | + add accessor function of node label for 'tbl_tree', 'phylo' and 'treedata' object (2023-07-13, Thu, #37) 21 | 22 | # tidytree 0.4.3 23 | 24 | + add `print()` method for 'tbl_tree' object to avoid confusion with `tbl_df` (2023-07-12, Wed) 25 | 26 | # tidytree 0.4.2 27 | 28 | + fixed the `dots` issue of `left_join` (2022-12-16, Fri, #30, #31) 29 | 30 | # tidytree 0.4.1 31 | 32 | + update citation with the ggtree imeta paper (2022-08-13, Sat) 33 | 34 | # tidytree 0.4.0 35 | 36 | + update citation with the tree data book (2022-08-13, Sat) 37 | 38 | # tidytree 0.3.9 39 | 40 | + update package startup message (2022-03-04, Fri) 41 | 42 | # tidytree 0.3.8 43 | 44 | + add the CRC book in startup message (2022-02-17, Thu) 45 | 46 | # tidytree 0.3.7 47 | 48 | + update startup message to randomly print two citation items of the ggtree package suite (2022-01-10, Mon) 49 | 50 | # tidytree 0.3.6 51 | 52 | + use `yulab.utils::str_wrap` to print tree (2021-10-09, Sat) 53 | 54 | # tidytree 0.3.5 55 | 56 | + add `select`, `filter`, `mutate`, `left_join`, `unnest`, `pull` and `rename` verbs for `treedata` object (2021-08-22, Sun; @xiangpin, #19) 57 | + update `print` and `show` methods for `treedata` 58 | - with `options(show_data_for_treedata=TRUE)` to control whether show associated data (2021-08-20, Fri; @xiangpin, #18) 59 | 60 | # tidytree 0.3.4 61 | 62 | + implement `merge` method for `tbl_tree` object (2020-07-03, Fri) 63 | - 64 | + remove mutate_, filter_ and group_by_ according to the change of dplyr (v=1.0.0) (2020-04-09, Thu) 65 | 66 | # tidytree 0.3.3 67 | 68 | + remove `data_frame` according to the change of tibble (v=3.0.0) 69 | 70 | # tidytree 0.3.2 71 | 72 | + use `tibble` instead of `data_frame` as it was deprecated in tibble (v=3.0.0) (2020-04-02, Thu) 73 | + compatible with dplyr v=1.0.0 (2020-03-12, Thu) 74 | - 75 | - 76 | 77 | # tidytree 0.3.1 78 | 79 | + `groupOTU`: set group from 0 to NA if only root node is in group of 0 (2019-11-25, Mon) 80 | 81 | # tidytree 0.3.0 82 | 83 | + `offspring` supports a vector of node ids (2019-11-21, Thu) 84 | + bug fixed of `nodelab` 85 | + `filter` and `select` methods for `ggtree` object (2019-10-31, Thu) 86 | 87 | # tidytree 0.2.9 88 | 89 | + `offsprint(tip, self_include=TRUE)` will return the input tip (2019-10-06, Sun) 90 | 91 | # tidytree 0.2.8 92 | 93 | + update `offspring` to compatible with missing nodes, e.g. for tree after `ggtree::collapse` (2019-09-16, Mon) 94 | 95 | # tidytree 0.2.7 96 | 97 | + allow calling `MRCA` with only one node and will return the node itself (2019-08-30, Fri) 98 | 99 | # tidytree 0.2.6 100 | 101 | + `nodeid` and `nodelab` methods for converting from label to node number and vice versa (2019-08-09, Fri) 102 | + allow determine MRCA of a vector of tips (2019-08-08, Thu) 103 | 104 | # tidytree 0.2.5 105 | 106 | + convert elements of roxygen documentation to markdown (2019-05-05, Thu) 107 | 108 | # tidytree 0.2.4 109 | 110 | + call `child.tbl_tree` instead of `child` in `offspring`, (2019-02-26, Tue) 111 | so that it works more robust for `data.frame`. 112 | 113 | # tidytree 0.2.3 114 | 115 | + more parameter for `offspring` (2019-01-28, Mon) 116 | 117 | # tidytree 0.2.2 118 | 119 | + mv vignette to [treedata-book](https://yulab-smu.top/treedata-book/) (2019-01-10, Thu) 120 | 121 | # tidytree 0.2.1 122 | 123 | + `mutate.tbl_tree` method (2018-12-19, Wed) 124 | - 125 | + bug fixed in `child` 126 | - 127 | 128 | # tidytree 0.2.0 129 | 130 | + compatible with `tibble` v = 2.0.0 (2018-11-29, Thu) 131 | - change `as_data_frame` method to `as_tibble` since `as_data_frame` was deprecated in `tibble` and not exported as generics 132 | 133 | # tidytree 0.1.9 134 | 135 | + `as_data_frame.phylo` works with `phylo$root.edge` (2018-06-13, Wed) 136 | 137 | # tidytree 0.1.8 138 | 139 | + force `get_tree_data(treedata)$node` to be integer (2018-04-19, Thu) 140 | 141 | # tidytree 0.1.7 142 | 143 | + `get.data`, `[` and `[[` methods (2018-02-26, Mon) 144 | -------------------------------------------------------------------------------- /R/AllClasses.R: -------------------------------------------------------------------------------- 1 | 2 | ##' @importFrom methods setOldClass 3 | ##' @importFrom methods isClass 4 | if (!isClass("phylo")) setOldClass("phylo") 5 | ## setOldClass("multiPhylo") 6 | if (!isClass("DNAbin")) setOldClass("DNAbin") 7 | if (!isClass("AAbin")) setOldClass("AAbin") 8 | 9 | #' @importFrom methods setClassUnion 10 | setClassUnion("DNAbin_Or_AAbin", c("DNAbin", "AAbin", "NULL")) 11 | 12 | ##' Class "treedata" 13 | ##' This class stores phylogenetic tree with associated data 14 | ##' 15 | ##' 16 | ##' @name treedata-class 17 | ##' @aliases treedata-class 18 | ##' show,treedata-method 19 | ##' @docType class 20 | ##' @slot file tree file 21 | ##' @slot treetext newick tree string 22 | ##' @slot phylo phylo object for tree structure 23 | ##' @slot data associated data 24 | ##' @slot extraInfo extra information, reserve for merge_tree 25 | ##' @slot tip_seq tip sequences 26 | ##' @slot anc_seq ancestral sequences 27 | ##' @slot seq_type sequence type, one of NT or AA 28 | ##' @slot tipseq_file tip sequence file 29 | ##' @slot ancseq_file ancestral sequence file 30 | ##' @slot info extra information, e.g. metadata, software version etc. 31 | ##' @importFrom methods setClass 32 | ##' @importFrom methods representation 33 | ##' @importFrom ape as.DNAbin 34 | ##' @exportClass treedata 35 | ##' @author Guangchuang Yu 36 | ##' @keywords classes 37 | setClass("treedata", 38 | representation = representation( 39 | file = "character", 40 | treetext = "character", 41 | phylo = "phylo", 42 | data = "tbl_df", 43 | extraInfo = "tbl_df", 44 | tip_seq = "DNAbin_Or_AAbin", 45 | anc_seq = "DNAbin_Or_AAbin", 46 | seq_type = "character", 47 | tipseq_file = "character", 48 | ancseq_file = "character", 49 | info = "list" 50 | ), 51 | prototype = prototype( 52 | data = tibble(), 53 | extraInfo = tibble(), 54 | anc_seq = NULL,#ape::as.DNAbin(character(0)), 55 | tip_seq = NULL#ape::as.DNAbin(character(0)) 56 | ) 57 | ) 58 | 59 | ##' treedata object contructor 60 | ##' 61 | ##' 62 | ##' @title treedata 63 | ##' @param ... parameters 64 | ##' @return treedata object 65 | ##' @importFrom methods new 66 | ##' @export 67 | ##' @author guangchuang yu 68 | treedata <- function(...) { 69 | new("treedata", ...) 70 | } 71 | -------------------------------------------------------------------------------- /R/AllGenerics.R: -------------------------------------------------------------------------------- 1 | ##' @importFrom ape as.phylo 2 | ##' @export 3 | ape::as.phylo 4 | 5 | 6 | ##' convert a tree object to treedata object 7 | ##' 8 | ##' 9 | ##' @title as.treedata 10 | ##' @param tree tree object 11 | ##' @param ... additional parameters 12 | ##' @return treedata object 13 | ##' @rdname as.treedata 14 | ##' @export 15 | as.treedata <- function(tree, ...) { 16 | UseMethod("as.treedata") 17 | } 18 | 19 | 20 | ##' @docType methods 21 | ##' @name get.fields 22 | ##' @rdname get.fields-methods 23 | ##' @title get.fields method 24 | ##' @param object `treedata` object 25 | ##' @param ... additional parameter 26 | ##' @return available annotation variables 27 | ##' @export 28 | setGeneric("get.fields", function(object, ...) standardGeneric("get.fields")) 29 | 30 | ##' @docType methods 31 | ##' @name get.data 32 | ##' @rdname get.data-methods 33 | ##' @title get.data method 34 | ##' @param object `treedata` object 35 | ##' @param ... additional parameter 36 | ##' @return associated data of phylogeny 37 | ##' @export 38 | setGeneric("get.data", function(object, ...) standardGeneric("get.data")) 39 | 40 | 41 | ##' grouping OTUs 42 | ##' 43 | ##' 44 | ##' @title groupOTU 45 | ##' @param .data tree object (phylo, treedata, tbl_tree, ggtree etc.) 46 | ##' @param .node selected nodes 47 | ##' @param group_name character the name of the group cluster, default is \code{group}. 48 | ##' @param ... additional parameter 49 | ##' @return updated tree with group information or group index 50 | ##' @author Guangchuang Yu 51 | ##' @export 52 | groupOTU <- function(.data, .node, group_name = 'group', ...) { 53 | UseMethod("groupOTU") 54 | } 55 | 56 | ##' grouping clades 57 | ##' 58 | ##' 59 | ##' @title groupClade 60 | ##' @inheritParams groupOTU 61 | ##' @param overlap character one of \code{overwrite},\code{origin} and \code{abandon}, 62 | ##' default is \code{overwrite}. 63 | ##' @return updated tree with group information or group index 64 | ##' @author Guangchuang Yu 65 | ##' @export 66 | groupClade <- function(.data, .node, group_name = 'group', overlap = 'overwrite', ...) { 67 | UseMethod("groupClade") 68 | } 69 | 70 | ##' access child data 71 | ##' 72 | ##' 73 | ##' @title child 74 | ##' @rdname child 75 | ##' @param .data phylo or tbl_tree object 76 | ##' @param .node node number 77 | ##' @param ... additional parameters 78 | ##' @return child data 79 | ##' @export 80 | ##' @author Guangchuang Yu 81 | child <- function(.data, .node, ...) { 82 | UseMethod("child") 83 | } 84 | 85 | ##' access offspring data 86 | ##' 87 | ##' 88 | ##' @title offspring 89 | ##' @rdname offspring 90 | ##' @inheritParams child 91 | ##' @param tiponly whether only return tip nodes 92 | ##' @param self_include whether include the input node, 93 | ##' only applicable for tiponly = FALSE 94 | ##' @return offspring data 95 | ##' @export 96 | ##' @author Guangchuang Yu 97 | offspring <- function(.data, .node, tiponly, self_include, ...) { 98 | UseMethod("offspring") 99 | } 100 | 101 | 102 | ##' access parent data 103 | ##' 104 | ##' 105 | ##' @title parent 106 | ##' @rdname parent 107 | ##' @inheritParams child 108 | ##' @return parent data 109 | ##' @export 110 | ##' @author Guangchuang Yu 111 | parent <- function(.data, .node, ...) { 112 | UseMethod("parent") 113 | } 114 | 115 | 116 | ##' access ancestor data 117 | ##' 118 | ##' 119 | ##' @title ancestor 120 | ##' @rdname ancestor 121 | ##' @inheritParams child 122 | ##' @return ancestor data 123 | ##' @export 124 | ##' @author Guangchuang Yu 125 | ancestor <- function(.data, .node, ...) { 126 | UseMethod("ancestor") 127 | } 128 | 129 | ##' access most recent common ancestor data 130 | ##' 131 | ##' 132 | ##' @title MRCA 133 | ##' @rdname MRCA 134 | ##' @param .data phylo or tbl_tree object 135 | ##' @param ... additional parameters 136 | ##' @return MRCA data 137 | ##' @export 138 | ##' @author Guangchuang Yu 139 | MRCA <- function(.data, ...) { 140 | UseMethod("MRCA") 141 | } 142 | 143 | 144 | ##' access root node data 145 | ##' 146 | ##' 147 | ##' @title rootnode 148 | ##' @rdname rootnode 149 | ##' @inheritParams child 150 | ##' @return root node data 151 | ##' @export 152 | ##' @author Guangchuang Yu 153 | rootnode <- function(.data, ...) { 154 | UseMethod("rootnode") 155 | } 156 | 157 | ##' access sibling data 158 | ##' 159 | ##' 160 | ##' @title sibling 161 | ##' @rdname sibling 162 | ##' @inheritParams child 163 | ##' @return sibling 164 | ##' @export 165 | ##' @author Guangchuang Yu 166 | sibling <- function(.data, ...) { 167 | UseMethod("sibling") 168 | } 169 | 170 | ##' convert tree label to internal node number 171 | ##' 172 | ##' 173 | ##' @title nodeid 174 | ##' @rdname nodeid 175 | ##' @param tree tree object 176 | ##' @param label tip/node label(s) 177 | ##' @return node number 178 | ##' @export 179 | ##' @author Guangchuang Yu 180 | nodeid <- function(tree, label) { 181 | UseMethod("nodeid") 182 | } 183 | 184 | ##' convert internal node number tip/node label 185 | ##' 186 | ##' 187 | ##' @title nodelab 188 | ##' @rdname nodelab 189 | ##' @param tree tree object 190 | ##' @param id node number 191 | ##' @return tip/node label(s) 192 | ##' @export 193 | ##' @author Guangchuang Yu 194 | nodelab <- function(tree, id) { 195 | UseMethod("nodelab") 196 | } 197 | 198 | ##' @docType methods 199 | ##' @name drop.tip 200 | ##' @rdname drop.tip-methods 201 | ##' @title drop.tip method 202 | ##' @param object A treedata or phylo object 203 | ##' @param tip a vector of mode numeric or character specifying the tips to delete 204 | ##' @param ... additional parameters 205 | ##' @return updated object 206 | ##' @export 207 | setGeneric ( 208 | name = "drop.tip", 209 | def = function( object, tip, ... ) 210 | standardGeneric("drop.tip") 211 | ) 212 | 213 | ##' @rdname drop.tip-methods 214 | ##' @export 215 | setGeneric( 216 | name = 'keep.tip', 217 | def = function(object, tip, ...) 218 | standardGeneric('keep.tip') 219 | ) 220 | 221 | ##' whether the node is a tip 222 | ##' 223 | ##' 224 | ##' @title isTip 225 | ##' @param .data phylo, treedata or tbl_tree object 226 | ##' @param .node node number 227 | ##' @param ... additional parameters 228 | ##' @return logical value 229 | ##' @export 230 | ##' @author Guangchuang Yu 231 | isTip <- function(.data, .node, ...) { 232 | UseMethod("isTip") 233 | } 234 | 235 | ##' access tree text (newick text) from tree object 236 | ##' 237 | ##' 238 | ##' @docType methods 239 | ##' @name get.treetext 240 | ##' @rdname get.treetext-methods 241 | ##' @title get.treetext method 242 | ##' @param object treedata object 243 | ##' @param ... additional parameter 244 | ##' @return phylo object 245 | ##' @importFrom methods setGeneric 246 | ##' @export 247 | setGeneric( 248 | name = "get.treetext", 249 | def = function(object, ...) 250 | standardGeneric("get.treetext") 251 | ) 252 | -------------------------------------------------------------------------------- /R/ancestor.R: -------------------------------------------------------------------------------- 1 | ##' @importFrom lazyeval interp 2 | ##' @method parent tbl_tree 3 | ##' @export 4 | ##' @rdname parent 5 | ##' @examples 6 | ##' library(ape) 7 | ##' tree <- rtree(4) 8 | ##' x <- as_tibble(tree) 9 | ##' parent(x, 2) 10 | parent.tbl_tree <- function(.data, .node, ...) { 11 | valid.tbl_tree(.data) 12 | ## x <- filter_(.data, ~ (node == .node | label == .node) & node != parent) 13 | ## if (nrow(x) == 0) ## root node 14 | ## return(x) 15 | ## ## https://stackoverflow.com/questions/34219912/how-to-use-a-variable-in-dplyrfilter 16 | ## filter_(.data, interp(~node == p, p = x$parent)) 17 | 18 | ndata <- itself(.data, .node) 19 | .node <- ndata$node 20 | pnode <- ndata$parent 21 | 22 | if (pnode == .node) 23 | return(.data[0,]) ## empty tibble 24 | .data[.data$node == pnode, ] 25 | } 26 | 27 | itself <- function(.data, .node) { 28 | if (is.numeric(.node)) { 29 | i <- which(.data$node == .node) 30 | } else { 31 | i <- which(.data$label == .node) 32 | } 33 | 34 | ## .data[which(.data$node == .node | .data$label == .node), ] 35 | return(.data[i, ]) 36 | } 37 | 38 | ##' @method parent phylo 39 | ##' @export 40 | parent.phylo <- function(.data, .node, ...) { 41 | vapply(.node, function(nn) { 42 | if ( nn == rootnode(.data) ) 43 | return(0) 44 | edge <- .data[["edge"]] 45 | parent <- edge[,1] 46 | child <- edge[,2] 47 | res <- parent[child == nn] 48 | if (length(res) == 0) { 49 | stop("cannot found parent node...") 50 | } 51 | if (length(res) > 1) { 52 | stop("multiple parent found...") 53 | } 54 | return(res) 55 | }, numeric(1)) 56 | } 57 | 58 | ##' @method parent treedata 59 | ##' @export 60 | parent.treedata <- function(.data, .node, ...) { 61 | parent.phylo(as.phylo(.data), .node, ...) 62 | } 63 | 64 | 65 | 66 | ##' @method ancestor tbl_tree 67 | ##' @export 68 | ##' @rdname ancestor 69 | ##' @examples 70 | ##' library(ape) 71 | ##' tree <- rtree(4) 72 | ##' x <- as_tibble(tree) 73 | ##' ancestor(x, 3) 74 | ancestor.tbl_tree <- function(.data, .node, ...) { 75 | ## prevent using filter 76 | ## see https://github.com/GuangchuangYu/tidytree/issues/4 77 | 78 | ndata <- itself(.data, .node) 79 | ## ndata <- filter_(.data, ~ (node == .node | label == .node)) 80 | .node <- ndata$node 81 | pnode <- ndata$parent 82 | 83 | if (.node == pnode) { 84 | ## root node 85 | return(parent(.data, .node)) ## empty tibble 86 | } 87 | 88 | parent <- .data$parent 89 | children <- .data$node 90 | n <- length(children) 91 | 92 | pp <- vector("integer", n) 93 | for (i in seq_along(children)) { 94 | pp[[children[i]]] <- parent[i] 95 | } 96 | 97 | id <- pnode 98 | i <- 1 99 | while( i <= length(id) ) { 100 | pnode <- pp[id[i]] 101 | if (pnode == id[i]) 102 | break 103 | id <- c(id, pnode) 104 | i <- i + 1 105 | } 106 | ## filter_(.data, ~ node %in% id) 107 | .data[children %in% id,] 108 | } 109 | 110 | ##' @method ancestor phylo 111 | ##' @export 112 | ancestor.phylo <- function(.data, .node, ...) { 113 | root <- rootnode(.data) 114 | if (.node == root) { 115 | return(NA) 116 | } 117 | p <- parent(.data, .node) 118 | res <- p 119 | while(p != root) { 120 | p <- parent(.data, p) 121 | res <- c(res, p) 122 | } 123 | return(res) 124 | } 125 | 126 | ##' @method ancestor treedata 127 | ##' @export 128 | ancestor.treedata <- function(.data, .node, ...) { 129 | ancestor.phylo(as.phylo(.data), .node, ...) 130 | } 131 | 132 | ## ancestor.tbl_tree <- function(.data, .node, ...) { 133 | ## p <- parent(.data, .node) 134 | ## if (nrow(p) == 0) 135 | ## return(p) 136 | ## id <- p$node 137 | ## i <- 1 138 | ## while(i <= length(id)) { 139 | ## p <- parent(.data, id[i]) 140 | ## if (nrow(p) == 0) 141 | ## break 142 | ## id <- c(id, p$node) 143 | ## i <- i + 1 144 | ## } 145 | ## filter_(.data, ~ node %in% id) 146 | ## } 147 | 148 | 149 | ##' @method MRCA tbl_tree 150 | ##' @export 151 | MRCA.tbl_tree <- function(.data, .node1, .node2 = NULL, ...) { 152 | if (length(.node1) == 1 && length(.node2) == 1) { 153 | return(.MRCA.tbl_tree_internal(.data, .node1, .node2, ...)) 154 | } else if (is.null(.node2) && length(.node1) >= 1) { 155 | if (length(.node1) == 1) return(itself(.data, .node1)) 156 | ## else length(.node1) > 1 157 | node <- .MRCA.tbl_tree_internal(.data, .node1[1], .node1[2]) 158 | if (length(.node1) > 2) { 159 | for (i in 3:length(.node1)) { 160 | node <- .MRCA.tbl_tree_internal(.data, .node1[i], node$node) 161 | } 162 | } 163 | return(node) 164 | } else { 165 | stop("invalid input of '.node1' and '.node2'...") 166 | } 167 | } 168 | 169 | #' @noRd 170 | #' @keywords internal 171 | .MRCA.tbl_tree_internal <- function(.data, .node1, .node2, ...) { 172 | anc1 <- ancestor(.data, .node1) 173 | if (nrow(anc1) == 0) { 174 | ## .node1 is root 175 | return(anc1) 176 | } 177 | if (.node2 %in% anc1$node) { 178 | ## .node2 is the ancestor of .node1 179 | return(filter(anc1, .data$node == .node2)) 180 | } 181 | p <- parent(.data, .node2) 182 | if (nrow(p) == 0) { 183 | ## .node2 is root 184 | return(p) 185 | } 186 | while(! p$node %in% anc1$node) { 187 | p <- parent(.data, p$node) 188 | } 189 | return(p) 190 | } 191 | 192 | ##' @method rootnode tbl_tree 193 | ##' @export 194 | rootnode.tbl_tree <- function(.data, ...) { 195 | valid.tbl_tree(.data) 196 | ## filter_(.data, ~ parent == node) 197 | .data[.data$parent == .data$node, ] 198 | } 199 | 200 | ##' @method rootnode phylo 201 | ##' @export 202 | rootnode.phylo <- function(.data, ...) { 203 | edge <- .data[["edge"]] 204 | ## 1st col is parent, 205 | ## 2nd col is child, 206 | if (!is.null(attr(.data, "order")) && attr(.data, "order") == "postorder") 207 | return(edge[nrow(edge), 1]) 208 | 209 | parent <- unique(edge[,1]) 210 | child <- unique(edge[,2]) 211 | ## the node that has no parent should be the root 212 | root <- parent[ ! parent %in% child ] 213 | if (length(root) > 1) { 214 | stop("multiple roots found...") 215 | } 216 | return(root) 217 | } 218 | -------------------------------------------------------------------------------- /R/ape.R: -------------------------------------------------------------------------------- 1 | 2 | ##' @importFrom ape Nnode 3 | ##' @export 4 | ape::Nnode 5 | 6 | ##' @importFrom ape rtree 7 | ##' @export 8 | ape::rtree 9 | 10 | ##' @importFrom ape read.tree 11 | ##' @export 12 | ape::read.tree 13 | 14 | ##' @importFrom ape Ntip 15 | ##' @export 16 | ape::Ntip 17 | 18 | ##' @importFrom ape as.phylo 19 | ##' @export 20 | ape::as.phylo 21 | 22 | ##' @importFrom ape is.rooted 23 | ##' @export 24 | ape::is.rooted 25 | 26 | ##' @importFrom ape root 27 | ##' @export 28 | ape::root 29 | 30 | ##' @method is.rooted treedata 31 | ##' @importFrom ape is.rooted 32 | ##' @export 33 | is.rooted.treedata <- function(phy) { 34 | is.rooted(as.phylo(phy)) 35 | } 36 | 37 | 38 | ##' @method Ntip treedata 39 | ##' @importFrom ape Ntip 40 | ##' @export 41 | Ntip.treedata <- function(phy) { 42 | Ntip(as.phylo(phy)) 43 | } 44 | 45 | ##' @method Ntip treedataList 46 | ##' @importFrom ape Ntip 47 | ##' @export 48 | Ntip.treedataList <- function(phy) { 49 | Ntip(phy[[1]]) 50 | } 51 | 52 | ##' number of nodes 53 | ##' 54 | ##' 55 | ##' @title Nnode 56 | ##' @param phy treedata object 57 | ##' @param internal.only whether only count internal nodes 58 | ##' @param ... additional parameters 59 | ##' @return number of nodes 60 | ##' @method Nnode treedata 61 | ##' @export 62 | ##' @examples 63 | ##' Nnode(rtree(30)) 64 | ##' @author Guangchuang Yu 65 | Nnode.treedata <- function(phy, internal.only=TRUE, ...) { 66 | Nnode(as.phylo(phy), internal.only = internal.only, ...) 67 | } 68 | -------------------------------------------------------------------------------- /R/as-tibble.R: -------------------------------------------------------------------------------- 1 | ##' @method as_tibble phylo 2 | ##' @export 3 | ##' @importFrom dplyr full_join 4 | ##' @importFrom ape Ntip 5 | ##' @importFrom ape Nnode 6 | as_tibble.phylo <- function(x, ...) { 7 | phylo <- x 8 | ntip <- Ntip(phylo) 9 | N <- Nnode(phylo, internal.only=FALSE) 10 | 11 | tip.label <- phylo[["tip.label"]] 12 | edge <- phylo[["edge"]] 13 | colnames(edge) <- c("parent", "node") 14 | res <- as_tibble(edge) 15 | if (!is.null(phylo$edge.length)) 16 | res$branch.length <- phylo$edge.length 17 | 18 | label <- rep(NA, N) 19 | label[1:ntip] <- tip.label 20 | if ( !is.null(phylo$node.label) ) { 21 | label[(ntip+1):N] <- phylo$node.label 22 | } 23 | ## isTip <- rep(FALSE, N) 24 | ## isTip[1:ntip] <- TRUE 25 | 26 | label.df <- tibble(node=1:N, label=label) #, isTip = isTip) 27 | res <- full_join(res, label.df, by='node') 28 | 29 | idx <- is.na(res$parent) 30 | res$parent[idx] <- res$node[idx] 31 | 32 | if (!is.null(phylo$edge.length) && !is.null(phylo$root.edge)) 33 | res$branch.length[res$parent == res$node] = phylo$root.edge 34 | 35 | res <- res[order(res$node),] 36 | aa <- names(attributes(phylo)) 37 | group <- aa[ ! aa %in% c("names", "class", "order", "reroot", "node_map")] 38 | if (length(group) > 0) { 39 | for (group_ in group) { 40 | ## groupOTU & groupClade 41 | group_info <- attr(phylo, group_) 42 | if (length(group_info) == nrow(res)) { 43 | res[[group_]] <- group_info 44 | } 45 | } 46 | } 47 | #class(res) <- c("tbl_tree", class(res)) 48 | res <- add_class(res, 'tbl_tree') 49 | return(res) 50 | } 51 | 52 | 53 | ##' @method as_tibble treedata 54 | ##' @importFrom tibble as_tibble 55 | ##' @export 56 | as_tibble.treedata <- function(x, ...) { 57 | res <- as_tibble(x@phylo) 58 | tree_anno <- as_tibble(get_tree_data(x)) 59 | if (nrow(tree_anno) > 0) { 60 | by <- "node" 61 | tree_anno$node <- as.integer(tree_anno$node) 62 | if ("parent" %in% colnames(tree_anno)) { 63 | by <- c(by, "parent") 64 | tree_anno$parent <- as.integer(tree_anno$parent) 65 | } 66 | res <- full_join(res, tree_anno, by=by) 67 | } 68 | return(res) 69 | } 70 | 71 | 72 | ##' get associated data stored in treedata object 73 | ##' 74 | ##' 75 | ##' @title get_tree_data 76 | ##' @param tree_object a `treedata` object 77 | ##' @return tbl_df 78 | ##' @export 79 | ##' @author guangchuang yu 80 | get_tree_data <- function(tree_object) { 81 | tree_anno <- tree_object@data 82 | extraInfo <- tree_object@extraInfo 83 | 84 | if (nrow(tree_anno)==0 && nrow(extraInfo)==0){ 85 | return(NULL) 86 | } 87 | 88 | if (nrow(tree_anno) == 0) { 89 | extraInfo$node <- as.integer(extraInfo$node) 90 | return(extraInfo) 91 | } 92 | if (nrow(extraInfo) == 0) { 93 | tree_anno$node <- as.integer(tree_anno$node) 94 | return(tree_anno) 95 | } 96 | 97 | tree_anno$node <- as.integer(tree_anno$node) 98 | extraInfo$node <- as.integer(extraInfo$node) 99 | 100 | full_join(tree_anno, extraInfo, by = "node") 101 | } 102 | 103 | 104 | valid.tbl_tree <- function(object, cols = c("parent", "node", "label")) { 105 | cc <- cols[!cols %in% colnames(object)] 106 | if (length(cc) > 0) { 107 | msg <- paste0("invalid tbl_tree object.\n missing column:\n ", paste(cc, collapse=","), ".") 108 | } 109 | } 110 | 111 | valid.tbl_tree2 <- function(object, cols = c("parent", "node", "label")) { 112 | cc <- cols[!cols %in% colnames(object)] 113 | if (length(cc) > 0) { 114 | msg <- paste0("invalid tbl_tree object. Missing column: ", paste(cc, collapse=","), ".") 115 | msg <- strwrap(style_subtle(msg)) 116 | flag <- getOption(x="check.tbl_tree.verbose", default=TRUE) 117 | if (flag){ 118 | cli::cli_alert_info(msg) 119 | } 120 | return(FALSE) 121 | } 122 | if (valid.edge(object)){ 123 | return(TRUE) 124 | }else{ 125 | return(FALSE) 126 | } 127 | } 128 | 129 | valid.edge <- function(x){ 130 | x <- as.matrix(x[,c(1, 2)]) 131 | tip.num <- sum(!(x[,2] %in% x[,1])) 132 | root.num <- sum(x[,1] == x[,2]) 133 | node.index <- nrow(x) >=2 && min(x[,2])==1 && all(diff(x[,2])==1) 134 | if (root.num==1 && tip.num > 1 && !any(duplicated(x[,2])) && node.index){ 135 | return(TRUE) 136 | }else{ 137 | flag <- getOption(x="check.tbl_tree.verbose", default=TRUE) 138 | if (flag){ 139 | cli::cli_alert_warning("# Invaild edge matrix for {.cls phylo}. A {.cls tbl_df} is returned.") 140 | } 141 | return(FALSE) 142 | } 143 | } 144 | -------------------------------------------------------------------------------- /R/converter.R: -------------------------------------------------------------------------------- 1 | 2 | ##' @method as.phylo treedata 3 | ##' @export 4 | as.phylo.treedata <- function(x, ...) { 5 | return(x@phylo) 6 | } 7 | 8 | 9 | ##' @importFrom dplyr mutate 10 | ##' @importFrom ape as.phylo 11 | ##' @method as.phylo tbl_tree 12 | ##' @export 13 | ## original contributed by Bradley Jones and modified by Guangchuang Yu 14 | as.phylo.tbl_tree <- function(x, ...) { 15 | valid.tbl_tree(x) 16 | 17 | edge <- x[, c("parent", "node")] 18 | i <- which(edge[,1] != 0 & edge[,1] != edge[,2]) 19 | edge <- edge[i, ] 20 | if (is.null(x[["branch.length"]])) { 21 | edge.length <- NULL 22 | } else { 23 | edge.length <- x$branch.length[i] 24 | } 25 | 26 | x %<>% mutate(isTip = ! .data$node %in% .data$parent) 27 | tip.label <- as.character(x$label[x$isTip]) 28 | 29 | phylo <- list(edge = as.matrix(edge), 30 | edge.length = edge.length, 31 | tip.label = tip.label) 32 | 33 | node.label <- as.character(x$label[!x$isTip]) 34 | if (!all(is.na(node.label))) { 35 | phylo$node.label <- node.label 36 | } 37 | phylo$Nnode <- sum(!x[, "isTip"]) 38 | class(phylo) <- "phylo" 39 | return(phylo) 40 | } 41 | 42 | 43 | ##' @importFrom methods new 44 | ##' @method as.treedata tbl_tree 45 | ##' @export 46 | ##' @rdname as.treedata 47 | ##' @examples 48 | ##' library(ape) 49 | ##' set.seed(2017) 50 | ##' tree <- rtree(4) 51 | ##' d <- tibble(label = paste0('t', 1:4), 52 | ##' trait = rnorm(4)) 53 | ##' x <- as_tibble(tree) 54 | ##' full_join(x, d, by = 'label') %>% as.treedata 55 | as.treedata.tbl_tree <- function(tree, ...) { 56 | data <- tree 57 | cn <- colnames(data) 58 | idx <- cn[!cn %in% c("parent", "branch.length", "label", "isTip", "x", "y", "branch", "angle")] 59 | res <- new("treedata", 60 | phylo = as.phylo.tbl_tree(data)) 61 | if (length(idx)) 62 | res@data <- as_tibble(data[, idx]) 63 | return(res) 64 | } 65 | -------------------------------------------------------------------------------- /R/filter.R: -------------------------------------------------------------------------------- 1 | 2 | ##' @importFrom dplyr filter 3 | ##' @method filter ggtree 4 | ##' @export 5 | filter.ggtree <- function(.data, ..., .preserve = FALSE) { 6 | dots <- rlang::quos(...) 7 | dplyr::filter(.data$data, !!!dots, .preserve = .preserve) 8 | } 9 | 10 | ##' @method filter treedata 11 | ##' @export 12 | filter.treedata <- function(.data, ..., .preserve=FALSE, keep.td=TRUE){ 13 | dots <- rlang::quos(...) 14 | dat <- .extract_annotda.treedata(.data) 15 | da <- dplyr::filter(dat, !!!dots, .preserve = .preserve) 16 | if (keep.td){ 17 | .data <- .update.treedata(td=.data, da=da, dat=dat, type="extra") 18 | return(.data) 19 | } 20 | return(da) 21 | } 22 | 23 | 24 | ##' @method filter tbl_tree 25 | ##' @export 26 | filter.tbl_tree <- function(.data, ..., .preserve = FALSE){ 27 | x <- NextMethod() 28 | if (!valid.tbl_tree2(x)){ 29 | x <- drop_class(x, name='tbl_tree') 30 | } 31 | return(x) 32 | } 33 | -------------------------------------------------------------------------------- /R/full-join.R: -------------------------------------------------------------------------------- 1 | ##' @importFrom dplyr full_join 2 | ##' @importFrom tibble tibble 3 | ##' @importFrom cli cli_warn 4 | ##' @method full_join treedata 5 | ##' @export 6 | full_join.treedata <- function(x, y, by = NULL, 7 | copy = FALSE, suffix = c("", ".y"), ...) { 8 | 9 | dat <- .extract_annotda.treedata(x) 10 | ornm <- colnames(dat) 11 | msg <- c("The {.arg suffix} requires a character vector containing 2 different elements,", 12 | "The first element must be \"\", and the second element must not be \"\",", 13 | "it was set {.code suffix=c(\"\", \".y\")} automatically.") 14 | if (all(nchar(suffix)!=0)){ 15 | cli::cli_warn(msg) 16 | suffix[1] = "" 17 | } 18 | if (all(nchar(suffix)==0)){ 19 | cli::cli_warn(msg) 20 | suffix[2] = ".y" 21 | } 22 | if (nchar(suffix[1])!=0 && nchar(suffix[2])==0){ 23 | cli::cli_warn(msg) 24 | suffix <- rev(suffix[seq_len(2)]) 25 | } 26 | 27 | da <- dplyr::full_join(dat, y, by = by, copy = copy, suffix = suffix, ...) 28 | 29 | da <- da[!is.na(da$node),] 30 | 31 | if (any(duplicated(da$node))){ 32 | da %<>% .internal_nest(keepnm=ornm) 33 | } 34 | 35 | tr <- .update.td.join(td=x, da=da) 36 | return(tr) 37 | } 38 | 39 | ##' @method full_join phylo 40 | ##' @export 41 | full_join.phylo <- function(x, y, by = NULL, 42 | copy = FALSE, suffix = c("", ".y"), ...) { 43 | full_join(treedata(phylo=x), y = y, by = by, 44 | copy = copy, suffix = suffix, ...) 45 | } 46 | -------------------------------------------------------------------------------- /R/get-data.R: -------------------------------------------------------------------------------- 1 | ##' get.data method 2 | ##' 3 | ##' 4 | ##' @rdname get.data-methods 5 | ##' @exportMethod get.data 6 | setMethod("get.data", signature(object = "treedata"), 7 | function(object) { 8 | get_tree_data(object) 9 | }) 10 | 11 | ##' @method [ treedata 12 | ##' @export 13 | `[.treedata` <- function(x, i, j) { 14 | get.data(x)[i, j] 15 | } 16 | 17 | 18 | ##' @method [[ treedata 19 | ##' @export 20 | `[[.treedata` <- function(x, i) { 21 | get.data(x)[[i]] 22 | } 23 | 24 | -------------------------------------------------------------------------------- /R/get-fields.R: -------------------------------------------------------------------------------- 1 | ##' @rdname get.fields-methods 2 | ##' @aliases get.fields,treedata 3 | ##' @exportMethod get.fields 4 | setMethod("get.fields", signature(object = "treedata"), 5 | function(object) { 6 | get.fields.treedata(object) 7 | }) 8 | 9 | 10 | get.fields.treedata <- function(object) { 11 | fields1 <- get.fields.data(object) 12 | fields2 <- get.fields.extraInfo(object) 13 | return(c(fields1, fields2)) 14 | } 15 | 16 | get.fields.data <- function(object){ 17 | if (nrow(object@data) > 0) { 18 | fields <- colnames(object@data) 19 | fields <- fields[fields != "node"] 20 | } else { 21 | fields <- "" 22 | } 23 | return(fields) 24 | } 25 | 26 | get.fields.extraInfo <- function(object){ 27 | extraInfo <- object@extraInfo 28 | if (nrow(extraInfo) > 0) { 29 | cn <- colnames(extraInfo) 30 | i <- match(c("x", "y", "isTip", "node", "parent", "label", "branch", "branch.length"), cn) 31 | i <- i[!is.na(i)] 32 | fields <- cn[-i] 33 | return(fields) 34 | }else{ 35 | return(character(0)) 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /R/groupClade.R: -------------------------------------------------------------------------------- 1 | ##' @method groupClade tbl_tree 2 | ##' @export 3 | groupClade.tbl_tree <- function(.data, .node, 4 | group_name = "group", 5 | overlap = "overwrite", ...) { 6 | 7 | overlap <- match.arg(overlap, c("origin", "overwrite", "abandon")) 8 | valid.tbl_tree(.data) 9 | 10 | n <- nrow(.data) 11 | foc <- rep(0, n) 12 | if (length(.node) == 1) { 13 | ids <- c(.node, offspring(.data, .node)$node) 14 | foc[ids] <- 1 15 | .data[[group_name]] <- factor(foc[match(1:n, .data$node)]) 16 | return(.data) 17 | } 18 | 19 | for (i in seq_along(.node)) { 20 | hit <- c(.node[i], offspring(.data, .node[i])$node) 21 | 22 | if (overlap == "origin") { 23 | sn <- hit[is.na(foc[hit]) | foc[hit] == 0] 24 | } else if (overlap == "abandon") { 25 | idx <- !is.na(foc[hit]) & foc[hit] != 0 26 | foc[hit[idx]] <- NA 27 | sn <- hit[!idx] 28 | } else { 29 | sn <- hit 30 | } 31 | 32 | if (length(sn) > 0) { 33 | if (is.null(names(.node)[i])) { 34 | foc[sn] <- max(suppressWarnings(as.numeric(foc)), na.rm=TRUE) + 1 35 | } else { 36 | foc[sn] <- names(.node)[i] 37 | } 38 | } 39 | } 40 | .data[[group_name]] <- factor(foc[match(1:n, .data$node)]) 41 | return(.data) 42 | } 43 | -------------------------------------------------------------------------------- /R/groupOTU.R: -------------------------------------------------------------------------------- 1 | ##' @method groupOTU tbl_tree 2 | ##' @export 3 | ##' @importFrom methods is 4 | groupOTU.tbl_tree <- function(.data, .node, 5 | group_name = "group", 6 | ...) { 7 | valid.tbl_tree(.data) 8 | .data[[group_name]] <- NULL 9 | if ( is(.node, "list") ) { 10 | for (i in seq_along(.node)) { 11 | .data <- .groupOTU.tbl_tree_item(.data, .node[[i]], 12 | names(.node)[i], 13 | group_name = group_name, 14 | ...) 15 | } 16 | } else { 17 | .data <- .groupOTU.tbl_tree_item(.data, .node, 18 | group_name = group_name, 19 | ...) 20 | } 21 | 22 | rn <- rootnode(.data)$node 23 | if (sum(.data[[group_name]] == .data[[group_name]][rn]) == 1) { 24 | ## only root node is not classify as a group 25 | .data[[group_name]][rn] <- NA 26 | } 27 | .data[[group_name]] <- factor(.data[[group_name]]) 28 | return(.data) 29 | } 30 | 31 | ##' @noRd 32 | ##' @importFrom dplyr group_by 33 | ##' @keywords internal 34 | .groupOTU.tbl_tree_item <- function(.data, .node, 35 | focus_label = NULL, 36 | group_name, 37 | overlap="overwrite", 38 | connect = FALSE) { 39 | 40 | ## see https://groups.google.com/d/msg/bioc-ggtree/Q4LnwoTf1DM/yEe95OFfCwAJ 41 | ## for connect parameter 42 | 43 | overlap <- match.arg(overlap, c("origin", "overwrite", "abandon")) 44 | 45 | focus <- .node 46 | if (is.character(focus)) { 47 | focus <- filter(.data, .data$label %in% .node)$node 48 | } 49 | 50 | n <- nrow(.data) 51 | 52 | if (is.null(.data[[group_name]])) { 53 | foc <- rep(0, n) 54 | } else { 55 | foc <- .data[[group_name]] 56 | } 57 | 58 | g <- max(suppressWarnings(as.numeric(foc)), na.rm=TRUE) + 1 59 | if (is.null(focus_label)) { 60 | focus_label <- g 61 | } 62 | 63 | anc <- lapply(focus, function(.node) sort(ancestor(.data, .node)$node)) 64 | ll <- min(sapply(anc, length)) 65 | i <- 2L 66 | repeat { 67 | if ( i > ll) { 68 | break 69 | } 70 | 71 | x <- unique(unlist(lapply(anc, "[", i))) 72 | if (length(x) != 1) 73 | break 74 | i <- i + 1L 75 | } 76 | d <- -(1:(i - 1L)) 77 | x <- unique(unlist(lapply(anc, function(x) x[d]))) 78 | hit <- unique(c(anc[[1]][i-1L], x, focus)) 79 | 80 | if (overlap == "origin") { 81 | sn <- hit[is.na(foc[hit]) | foc[hit] == 0] 82 | } else if (overlap == "abandon") { 83 | idx <- !is.na(foc[hit]) & foc[hit] != 0 84 | foc[hit[idx]] <- NA 85 | sn <- hit[!idx] 86 | } else { 87 | sn <- hit 88 | } 89 | 90 | if (length(sn) > 0 && connect) { 91 | y <- filter(.data, .data$node %in% sn) %>% group_by(.data$parent) %>% summarize(degree = n()) 92 | if ( sum(y$degree > 1) == 1 ) { 93 | sn <- focus 94 | } 95 | } 96 | 97 | if (length(sn)) { 98 | foc[sn] <- focus_label 99 | } 100 | 101 | .data[[group_name]] <- foc[match(1:n, .data$node)] 102 | return(.data) 103 | } 104 | 105 | 106 | -------------------------------------------------------------------------------- /R/inner-join.R: -------------------------------------------------------------------------------- 1 | 2 | #' @method inner_join treedata 3 | #' @importFrom dplyr inner_join 4 | #' @importFrom cli cli_warn 5 | #' @export 6 | inner_join.treedata <- function(x, y, by = NULL, copy = FALSE, suffix=c("", ".y"), ...){ 7 | x %<>% dplyr::mutate(.UNIQUE.ID=paste0('ID.', seq_len(Nnode(x, internal = FALSE)))) 8 | dat <- .extract_annotda.treedata(x) 9 | ornm <- colnames(dat) 10 | msg <- c("The {.arg suffix} requires a character vector containing 2 different elements,", 11 | "The first element must be \"\", and the second element must not be \"\",", 12 | "it was set {.code suffix=c(\"\", \".y\")} automatically.") 13 | if (all(nchar(suffix)!=0)){ 14 | cli::cli_warn(msg) 15 | suffix[1] = "" 16 | } 17 | if (all(nchar(suffix)==0)){ 18 | cli::cli_warn(msg) 19 | suffix[2] = ".y" 20 | } 21 | if (nchar(suffix[1])!=0 && nchar(suffix[2])==0){ 22 | cli::cli_warn(msg) 23 | suffix <- rev(suffix[seq_len(2)]) 24 | } 25 | da <- dplyr::inner_join(dat, y, by = by, copy = copy, suffix = suffix, ...) 26 | 27 | keep.nodes <- da %>% dplyr::filter(.data$isTip) %>% 28 | dplyr::pull(.data$node) %>% unique() 29 | 30 | x <- drop.tip(x, setdiff(dat$node[dat$isTip], keep.nodes)) 31 | 32 | new.dat <- .extract_annotda.treedata(x) 33 | da$node <- new.dat$node[match(da$.UNIQUE.ID, new.dat$.UNIQUE.ID)] 34 | da <- da[!is.na(da$node),] 35 | 36 | if (any(duplicated(da$node))){ 37 | da %<>% .internal_nest(keepnm=ornm) 38 | } 39 | 40 | tr <- .update.td.join(td=x, da=da) 41 | tr %<>% dplyr::select(-'.UNIQUE.ID', keep.td=TRUE) 42 | return(tr) 43 | } 44 | 45 | #' @importFrom dplyr inner_join 46 | #' @method inner_join phylo 47 | #' @export 48 | inner_join.phylo <- function(x, y, by=NULL, copy=FALSE, suffix=c('', '.y'), ...){ 49 | x <- treedata(phylo=x) 50 | tr <- x %>% inner_join(y, by = by, copy = copy, suffix=suffix, ...) 51 | return(tr) 52 | } 53 | 54 | -------------------------------------------------------------------------------- /R/isTip.R: -------------------------------------------------------------------------------- 1 | ##' @method isTip tbl_tree 2 | ##' @rdname isTip 3 | ##' @export 4 | isTip.tbl_tree <- function(.data, .node, ...) { 5 | tips <- .data$node[!.data$node %in% .data$parent] 6 | return(.node %in% tips) 7 | } 8 | 9 | ##' @method isTip phylo 10 | ##' @rdname isTip 11 | ##' @export 12 | isTip.phylo <- function(.data, .node, ...) { 13 | isTip.tbl_tree(as_tibble(.data), .node, ...) 14 | } 15 | 16 | ##' @method isTip treedata 17 | ##' @rdname isTip 18 | ##' @export 19 | isTip.treedata <- isTip.phylo 20 | -------------------------------------------------------------------------------- /R/left-join.R: -------------------------------------------------------------------------------- 1 | #' @method left_join treedata 2 | #' @importFrom cli cli_warn 3 | #' @export 4 | left_join.treedata <- function(x, y, by = NULL, copy = FALSE, suffix=c("", ".y"), ...){ 5 | dat <- .extract_annotda.treedata(x) 6 | ornm <- colnames(dat) 7 | msg <- c("The {.arg suffix} requires a character vector containing 2 different elements,", 8 | "The first element must be \"\", and the second element must not be \"\",", 9 | "it was set {.code suffix=c(\"\", \".y\")} automatically.") 10 | if (all(nchar(suffix)!=0)){ 11 | cli::cli_warn(msg) 12 | suffix[1] = "" 13 | } 14 | if (all(nchar(suffix)==0)){ 15 | cli::cli_warn(msg) 16 | suffix[2] = ".y" 17 | } 18 | if (nchar(suffix[1])!=0 && nchar(suffix[2])==0){ 19 | cli::cli_warn(msg) 20 | suffix <- rev(suffix[seq_len(2)]) 21 | } 22 | da <- dplyr::left_join(dat, y, by = by, copy = copy, suffix = suffix, ...) 23 | 24 | if (any(duplicated(da$node))){ 25 | da %<>% .internal_nest(keepnm=ornm) 26 | } 27 | 28 | tr <- .update.td.join(td=x, da=da) 29 | return(tr) 30 | } 31 | 32 | #' @method left_join phylo 33 | #' @export 34 | left_join.phylo <- function(x, y, by=NULL, copy=FALSE, ...){ 35 | x <- treedata(phylo=x) 36 | tr <- x %>% left_join(y, by = by, copy = copy, ...) 37 | return(tr) 38 | } 39 | 40 | #' @method left_join tbl_tree 41 | #' @export 42 | left_join.tbl_tree <- function(x, y, by = NULL, copy = FALSE, 43 | suffix = c(".x", ".y"), ..., keep = NULL){ 44 | x <- NextMethod() 45 | if (!valid.tbl_tree2(x)){ 46 | x <- drop_class(x, 'tbl_tree') 47 | } 48 | return(x) 49 | } 50 | 51 | 52 | #' @keywords internal 53 | #' @param td treedata object 54 | #' @param da tbl_df after left_join. 55 | #' @noRd 56 | .update.td.join <- function(td, da){ 57 | aa <- names(attributes(td@phylo)) 58 | aa <- aa[!aa %in% c("names", "class", "order", "reroot", "node_map")] 59 | data.nm <- get.fields.data(td) 60 | if (length(data.nm)==1 && data.nm==""){ 61 | td@data <- tibble() 62 | }else{ 63 | td@data <- da %>% select(c("node", data.nm)) 64 | } 65 | extra.nm <- colnames(da)[!colnames(da) %in% c("node", "label", "isTip", data.nm, aa)] 66 | if (length(extra.nm) > 0){ 67 | td@extraInfo <- da %>% select(c("node", extra.nm)) 68 | } 69 | return(td) 70 | } 71 | -------------------------------------------------------------------------------- /R/method-MRCA.R: -------------------------------------------------------------------------------- 1 | 2 | ##' @method MRCA phylo 3 | ##' @export 4 | MRCA.phylo <- function(.data, .node1, .node2 = NULL, ...) { 5 | MRCA(as_tibble(.data), .node1, .node2, ...)[["node"]] 6 | } 7 | 8 | ##' @method MRCA treedata 9 | ##' @export 10 | MRCA.treedata <- function(.data, .node1, .node2 = NULL, ...) { 11 | MRCA.phylo(as.phylo(.data), .node1, .node2, ...) 12 | } 13 | -------------------------------------------------------------------------------- /R/method-accessor.R: -------------------------------------------------------------------------------- 1 | #' @title extract the node label of phylo, treedata or tbl_tree 2 | #' @param x object, should be one of \code{treedata},\code{phylo} or \code{tbl_tree}. 3 | #' @param node character, to extract which type node label, 4 | #' default is \code{internal}, should be one of \code{internal}, 5 | #' \code{external}, \code{all}, \code{tip}. 6 | #' @param ... additional parameters. 7 | #' @return label character vector. 8 | #' @export 9 | node.label <- function(x, node='internal', ...){ 10 | UseMethod("node.label") 11 | } 12 | 13 | #' @method node.label tbl_tree 14 | #' @export 15 | node.label.tbl_tree <- function(x, node = 'internal', ...){ 16 | node <- match.arg(node, c("internal", "external", "all", "tip")) 17 | isTip <- .isTip.tbl_tree(x) 18 | if (node %in% c('external', 'tip')){ 19 | lab <- x[isTip, "label", drop=TRUE] 20 | }else if (node == 'internal'){ 21 | lab <- x[!isTip, 'label', drop=TRUE] 22 | if (all(is.na(lab))){ 23 | lab <- NULL 24 | } 25 | }else if (node == 'all'){ 26 | lab1 <- x[isTip, "label", drop=TRUE] 27 | lab2 <- x[!isTip, 'label', drop=TRUE] 28 | if (all(is.na(lab2))){ 29 | lab2 <- NULL 30 | } 31 | lab <- c(lab1, lab2) 32 | } 33 | return(lab) 34 | } 35 | 36 | #' @method node.label phylo 37 | #' @export 38 | node.label.phylo <- function(x, node='internal',...){ 39 | node <- match.arg(node, c("internal", "external", "all", "tip")) 40 | if (node %in% c("external", "tip")){ 41 | lab <- x$tip.label 42 | }else if (node == 'internal'){ 43 | lab <- x$node.label 44 | }else if (node == 'all'){ 45 | lab <- c(x$tip.label, x$node.label) 46 | } 47 | return(lab) 48 | } 49 | 50 | #' @method node.label treedata 51 | #' @export 52 | node.label.treedata <- function(x, node = 'internal', ...){ 53 | node.label(x@phylo, node = node, ...) 54 | } 55 | 56 | #' @title extract the tip label of phylo treedata or tbl_tree 57 | #' @param x object, should be one of \code{treedata},\code{phylo} or \code{tbl_tree}. 58 | #' @param ... additional parameters. 59 | #' @export 60 | tip.label <- function(x, ...){ 61 | UseMethod("tip.label") 62 | } 63 | 64 | #' @method tip.label tbl_tree 65 | #' @export 66 | tip.label.tbl_tree <- function(x, ...){ 67 | node.label(x, node = 'tip') 68 | } 69 | 70 | #' @method tip.label phylo 71 | #' @export 72 | tip.label.phylo <- function(x, ...){ 73 | node.label(x, node = 'tip') 74 | } 75 | 76 | #' @method tip.label treedata 77 | #' @export 78 | tip.label.treedata <- function(x, ...){ 79 | node.label(x, node = 'tip') 80 | } 81 | 82 | #' the tip or internal node label assign of tbl_tree phylo and treedata 83 | #' @param x object, should be one of \code{tbl_tree}, \code{phylo} or \code{treedata} 84 | #' @param value character, the character vector 85 | #' @name td-label-assign 86 | NULL 87 | 88 | #' @rdname td-label-assign 89 | #' @export 90 | `tip.label<-` <- function(x, value){ 91 | UseMethod('tip.label<-') 92 | } 93 | 94 | #' @rdname td-label-assign 95 | #' @export 96 | `node.label<-` <- function(x, value){ 97 | UseMethod('node.label<-') 98 | } 99 | 100 | #' @method node.label<- phylo 101 | #' @rdname td-label-assign 102 | #' @export 103 | `node.label<-.phylo` <- function(x, value){ 104 | if (check.lab(value, ape::Nnode(x))){ 105 | x$node.label <- as.character(value) 106 | }else{ 107 | .internal.assign.lab.abort(x = 'internal node') 108 | } 109 | return(x) 110 | } 111 | 112 | #' @method node.label<- treedata 113 | #' @rdname td-label-assign 114 | #' @export 115 | `node.label<-.treedata` <- function(x, value){ 116 | node.label(x@phylo) <- value 117 | return(x) 118 | } 119 | 120 | #' @method node.label<- tbl_tree 121 | #' @rdname td-label-assign 122 | #' @export 123 | `node.label<-.tbl_tree` <- function(x, value){ 124 | isTip <- .isTip.tbl_tree(x) 125 | if (check.lab(value, Nnode(x))){ 126 | x[!isTip, 'label',drop=TRUE] <- as.character(value) 127 | }else{ 128 | .internal.assign.lab.abort(x = 'internal node') 129 | } 130 | return(x) 131 | } 132 | 133 | #' @method tip.label<- phylo 134 | #' @rdname td-label-assign 135 | #' @export 136 | `tip.label<-.phylo` <- function(x, value){ 137 | if (check.lab(value, ape::Ntip(x))){ 138 | x$tip.label <- as.character(value) 139 | }else{ 140 | .internal.assign.lab.abort(x = 'tip node') 141 | } 142 | return(x) 143 | } 144 | 145 | #' @method tip.label<- treedata 146 | #' @rdname td-label-assign 147 | #' @export 148 | `tip.label<-.treedata` <- function(x, value){ 149 | tip.label(x@phylo) <- value 150 | return(x) 151 | } 152 | 153 | #' @method tip.label<- tbl_tree 154 | #' @rdname td-label-assign 155 | #' @export 156 | `tip.label<-.tbl_tree` <- function(x, value){ 157 | isTip <- .isTip.tbl_tree(x) 158 | if (check.lab(value, Ntip(x))){ 159 | x[isTip,'label',drop=TRUE] <- as.character(value) 160 | }else{ 161 | .internal.assign.lab.abort(x = 'tip node') 162 | } 163 | return(x) 164 | } 165 | 166 | #' @method Ntip tbl_tree 167 | #' @importFrom ape Ntip 168 | #' @export 169 | Ntip.tbl_tree <- function(phy){ 170 | sum(!phy[,2,drop=TRUE] %in% phy[,1,drop=TRUE]) 171 | } 172 | 173 | #' @method Nnode tbl_tree 174 | #' @importFrom ape Nnode 175 | #' @export 176 | Nnode.tbl_tree <- function(phy, internal.only = TRUE, ...){ 177 | if (!internal.only){ 178 | return(nrow(phy)) 179 | } 180 | nrow(phy) - Ntip(phy) 181 | } 182 | 183 | #' @noRd 184 | .isTip.tbl_tree <- function(x){ 185 | !x[,2,drop=TRUE] %in% x[,1,drop=TRUE] 186 | } 187 | 188 | check.lab <- function(x, y){ 189 | length(x) == length(unique(x)) && length(x) == y && !any(is.na(x)) 190 | } 191 | 192 | .internal.assign.lab.abort <- function(x = 'tip node'){ 193 | cli::cli_abort(c( 194 | "The {.var label} must be a {.cls character} vector, and the length, ", 195 | paste0("of it must be equal to the number of ", x, ", "), 196 | "and NA or duplicated character are not be allowed" 197 | ), call = NULL) 198 | } 199 | -------------------------------------------------------------------------------- /R/method-as-ultrametric.R: -------------------------------------------------------------------------------- 1 | #' @title as.ultrametric 2 | #' @param tree tree object 3 | #' @param ... additional parameters 4 | #' @return treedata or phylo object 5 | #' @export 6 | as.ultrametric <- function(tree, ...){ 7 | UseMethod("as.ultrametric") 8 | } 9 | 10 | #' @method as.ultrametric phylo 11 | #' @export 12 | ## reference 13 | ## https://github.com/PuttickMacroevolution/MCMCtreeR/blob/master/R/readMCMCTree.R 14 | as.ultrametric.phylo <- function(tree, ...){ 15 | outer <- tree$edge[, 2] 16 | inner <- tree$edge[, 1] 17 | ntip <- Ntip(tree) 18 | totalPath <- c() 19 | tipindx <- which(outer <= ntip) 20 | for (i in tipindx) { 21 | start <- i 22 | end <- inner[start] 23 | edgeTimes <- tree$edge.length[start] 24 | while (end != inner[1]) { 25 | start <- which(outer == end) 26 | end <- inner[start] 27 | edgeTimes <- c(edgeTimes, tree$edge.length[start]) 28 | } 29 | totalPath <- c(totalPath, sum(edgeTimes)) 30 | } 31 | addLength <- max(totalPath) - totalPath 32 | tree$edge.length[tipindx] <- tree$edge.length[tipindx] + addLength 33 | return (tree) 34 | } 35 | 36 | #' @method as.ultrametric treedata 37 | #' @export 38 | as.ultrametric.treedata <- function(tree, ...){ 39 | tree@phylo <- as.ultrametric(tree=tree@phylo,...) 40 | return (tree) 41 | } 42 | 43 | #' @method as.ultrametric tbl_tree 44 | #' @export 45 | as.ultrametric.tbl_tree <- function(tree, ...){ 46 | tree <- as.treedata(tree) 47 | tree <- as.ultrametric(tree, ...) 48 | return(tree) 49 | } 50 | -------------------------------------------------------------------------------- /R/method-drop-tip.R: -------------------------------------------------------------------------------- 1 | ##' @rdname drop.tip-methods 2 | ##' @aliases drop.tip,treedata 3 | ##' @exportMethod drop.tip 4 | ##' @author Casey Dunn \url{http://dunnlab.org} and Guangchuang Yu \url{https://guangchuangyu.github.io} 5 | ##' @examples 6 | ##' library(tidytree) 7 | ##' set.seed(123) 8 | ##' tr <- ape::rtree(6) 9 | ##' da <- data.frame(id=tip.label(tr), value = letters[seq_len(6)]) 10 | ##' trda <- tr %>% dplyr::left_join(da, by = c('label'='id')) 11 | ##' tr1 <- drop.tip(tr, c("t2", "t1")) 12 | ##' tr2 <- keep.tip(tr, c("t2", "t1")) 13 | setMethod("drop.tip", signature(object="treedata"), 14 | function(object, tip, ...) { 15 | drop.tip.treedata(object, tip, ...) 16 | }) 17 | 18 | drop.tip.treedata <- function(object, tip, ...){ 19 | params <- list(...) 20 | if ("interactive" %in% names(params) && params$interactive){ 21 | message("The interactive mode is not implemented for treedata object!") 22 | params$interactive <- FALSE 23 | } 24 | res <- build_new_labels(tree=object) 25 | tree <- res$tree 26 | old_and_new <- res$node2old_new_lab 27 | if(is.character(tip)){ 28 | tip <- old_and_new[old_and_new$old %in% tip, "new"] %>% unlist(use.names=FALSE) 29 | } 30 | params$phy <- tree 31 | params$tip <- tip 32 | new_tree <- do.call(ape::drop.tip, params) 33 | 34 | if (is.null(new_tree)){ 35 | return(new_tree) 36 | } 37 | 38 | trans_node_data <- old_new_node_mapping(tree, new_tree) 39 | object@phylo <- build_new_tree(tree=new_tree, node2old_new_lab=old_and_new) 40 | 41 | update_data <- function(data, trans_node_data) { 42 | data <- data[match(trans_node_data$old, data$node),] 43 | data$node <- trans_node_data$new 44 | return(data) 45 | } 46 | 47 | if (nrow(object@data) > 0) { 48 | object@data <- update_data(object@data, trans_node_data) 49 | } 50 | 51 | if (nrow(object@extraInfo) > 0) { 52 | object@extraInfo <- update_data(object@extraInfo, trans_node_data) 53 | } 54 | return (object) 55 | } 56 | 57 | ##' @rdname drop.tip-methods 58 | ##' @exportMethod drop.tip 59 | ##' @aliases drop.tip,phylo 60 | ##' @source 61 | ##' drop.tip for phylo object is a wrapper method of ape::drop.tip 62 | ##' from the ape package. The documentation you should 63 | ##' read for the drop.tip function can be found here: \link[ape]{drop.tip} 64 | ##' @seealso 65 | ##' \link[ape]{drop.tip} 66 | setMethod("drop.tip", signature(object="phylo"), 67 | function(object, tip, ...){ 68 | ape::drop.tip(object, tip, ...) 69 | }) 70 | 71 | ##' @rdname drop.tip-methods 72 | ##' @export 73 | setMethod("keep.tip", signature(object = 'treedata'), 74 | function(object, tip, ...){ 75 | .internal.keep.tip(object, tip, ...) 76 | } 77 | ) 78 | 79 | ##' @rdname drop.tip-methods 80 | ##' @export 81 | setMethod('keep.tip', signature(object = 'phylo'), 82 | function(object, tip, ...){ 83 | .internal.keep.tip(object, tip, ...) 84 | }) 85 | 86 | .internal.keep.tip <- function(object, tip, ...){ 87 | if (inherits(object, 'treedata')){ 88 | tip.label <- object@phylo$tip.label 89 | } 90 | if (inherits(object, 'phylo')){ 91 | tip.label <- object$tip.label 92 | } 93 | Ntip <- length(tip.label) 94 | if (is.character(tip)) { 95 | idx <- match(tip, tip.label) 96 | if (anyNA(idx)) { 97 | cli::cli_abort( 98 | "unmatched {.var tip} label/labels was/were found in the {.class object} object.", 99 | "Considering remove the it/them: ", 100 | paste(tip[is.na(idx)], collapse = " ") 101 | ) 102 | } 103 | tip <- idx 104 | }else{ 105 | out.of.range <- tip > Ntip 106 | if (any(out.of.range)) { 107 | cli::cli_warn("some tip numbers were larger than the number of tips: they were ignored") 108 | tip <- tip[!out.of.range] 109 | } 110 | } 111 | toDrop <- setdiff(1:Ntip, tip) 112 | drop.tip(object, toDrop, ...) 113 | } 114 | -------------------------------------------------------------------------------- /R/method-get-treetext.R: -------------------------------------------------------------------------------- 1 | ##' get.treetext method 2 | ##' 3 | ##' 4 | ##' @rdname get.treetext-methods 5 | ##' @exportMethod get.treetext 6 | setMethod("get.treetext", signature(object = "treedata"), 7 | function(object) { 8 | object@treetext 9 | }) 10 | -------------------------------------------------------------------------------- /R/method-groupClade.R: -------------------------------------------------------------------------------- 1 | ##' @importFrom ape extract.clade 2 | ##' @method groupClade phylo 3 | ##' @export 4 | groupClade.phylo <- function(.data, .node, group_name = "group", ...) { 5 | if (length(.node) == 1) { 6 | clade <- extract.clade(.data, .node) 7 | tips <- clade$tip.label 8 | } else { 9 | tips <- lapply(.node, function(x) { 10 | clade <- extract.clade(.data, x) 11 | clade$tip.label 12 | }) 13 | } 14 | 15 | groupOTU(.data, tips, group_name) 16 | } 17 | 18 | ##' @method groupClade treedata 19 | ##' @export 20 | groupClade.treedata <- function(.data, .node, group_name = "group", ...) { 21 | .data@phylo <- groupClade(as.phylo(.data), .node, group_name, ...) 22 | .data 23 | } 24 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /R/method-groupOTU.R: -------------------------------------------------------------------------------- 1 | 2 | ##' @importFrom ape which.edge 3 | gfocus <- function(phy, focus, group_name, focus_label=NULL, 4 | overlap="overwrite", connect = FALSE) { 5 | 6 | ## see https://goo.gl/VMMVhi for connect parameter 7 | 8 | overlap <- match.arg(overlap, c("origin", "overwrite", "abandon")) 9 | 10 | if (is.factor(focus)) { 11 | focus <- as.character(focus) 12 | } 13 | 14 | if (is.character(focus)) { 15 | focus <- which(phy$tip.label %in% focus) 16 | } 17 | 18 | n <- getNodeNum(phy) 19 | if (is.null(attr(phy, group_name))) { 20 | foc <- rep(0, n) 21 | } else { 22 | foc <- attr(phy, group_name) 23 | } 24 | i <- max(suppressWarnings(as.numeric(foc)), na.rm=TRUE) + 1 25 | if (is.null(focus_label)) { 26 | focus_label <- i 27 | } 28 | 29 | induced_edge <- phy$edge[which.edge(phy, focus),] 30 | 31 | hit <- unique(as.vector(induced_edge)) 32 | if (overlap == "origin") { 33 | sn <- hit[is.na(foc[hit]) | foc[hit] == 0] 34 | } else if (overlap == "abandon") { 35 | idx <- !is.na(foc[hit]) & foc[hit] != 0 36 | foc[hit[idx]] <- NA 37 | sn <- hit[!idx] 38 | } else { 39 | sn <- hit 40 | } 41 | 42 | if (length(sn) > 0 && connect) { 43 | if (sum(table(induced_edge[,1]) > 1) == 1) { 44 | sn <- focus 45 | } 46 | } 47 | 48 | if (length(sn) > 0) { 49 | foc[sn] <- focus_label 50 | } 51 | 52 | attr(phy, group_name) <- foc 53 | phy 54 | } 55 | 56 | ##' @method groupOTU phylo 57 | ##' @export 58 | groupOTU.phylo <- function(.data, .node, group_name="group", ...) { 59 | phy <- .data 60 | focus <- .node 61 | attr(phy, group_name) <- NULL 62 | if ( is(focus, "list") ) { 63 | for (i in seq_along(focus)) { 64 | phy <- gfocus(phy, focus[[i]], group_name, names(focus)[i], ...) 65 | } 66 | } else { 67 | phy <- gfocus(phy, focus, group_name, ...) 68 | } 69 | res <- attr(phy, group_name) 70 | res[is.na(res)] <- 0 71 | attr(phy, group_name) <- factor(res) 72 | return(phy) 73 | } 74 | 75 | ##' @method groupOTU treedata 76 | ##' @export 77 | groupOTU.treedata <- function(.data, .node, group_name = "group", ...) { 78 | .data@phylo <- groupOTU(as.phylo(.data), .node, group_name, ...) 79 | return(.data) 80 | } 81 | 82 | 83 | ##' calculate total number of nodes 84 | ##' 85 | ##' 86 | ##' @title getNodeNum 87 | ##' @param tree tree object 88 | ##' @return number 89 | ##' @export 90 | ##' @examples 91 | ##' getNodeNum(rtree(30)) 92 | ##' @author Guangchuang Yu 93 | getNodeNum <- function(tree) { 94 | Nnode(tree, internal.only=FALSE) 95 | } 96 | -------------------------------------------------------------------------------- /R/method-merge.R: -------------------------------------------------------------------------------- 1 | ##' @method merge tbl_tree 2 | ##' @export 3 | merge.tbl_tree <- function(x, y, ...) { 4 | res <- NextMethod() 5 | if (valid.tbl_tree2(res)){ 6 | res <- add_class(res, 'tbl_tree') 7 | } 8 | return(res) 9 | } 10 | 11 | -------------------------------------------------------------------------------- /R/method-reroot.R: -------------------------------------------------------------------------------- 1 | old_new_node_mapping <- function(oldtree, newtree){ 2 | treelab1 <- oldtree %>% 3 | as_tibble() %>% 4 | dplyr::select(c("node", "label")) 5 | treelab2 <- newtree %>% 6 | as_tibble() %>% 7 | dplyr::select(c("node", "label")) 8 | node_map <- dplyr::inner_join(treelab1, treelab2, by="label") %>% 9 | dplyr::select(c("node.x", "node.y")) %>% 10 | dplyr::rename(c(old="node.x", new="node.y")) 11 | return(node_map) 12 | } 13 | 14 | # ##' re-root a tree 15 | # ##' 16 | # ##' 17 | # ##' @title root 18 | # ##' @rdname root-method 19 | # ##' @param phy tree object 20 | # ##' @param outgroup a vector of mode numeric or character specifying the new outgroup 21 | # ##' @param node node to reroot 22 | # ##' @param edgelabel a logical value specifying whether to treat node labels as 23 | # ##' edge labels and thus eventually switching them so that they are associated 24 | # ##' with the correct edges. 25 | # ##' @param ... additional parameters passed to ape::root.phylo 26 | # ##' @return rerooted tree 27 | # ##' @importFrom ape root 28 | # ##' @method root phylo 29 | # ##' @export 30 | # ##' @author Guangchuang Yu 31 | # 32 | # root.phylo <- function(phy, outgroup, node = NULL, edgelabel = TRUE, ...){ 33 | # tree <- ape::root.phylo(phy, outgroup = outgroup, node = node, 34 | # edgelabel = edgelabel, ...) 35 | # 36 | # attr(tree, "reroot") <- TRUE 37 | # node_map <- reroot_node_mapping(phy, tree) 38 | # attr(tree, "node_map") <- node_map 39 | # return(tree) 40 | # } 41 | 42 | 43 | ##' re-root a tree 44 | ##' 45 | ##' @title root 46 | ##' @rdname root-method 47 | ##' @param phy tree object 48 | ##' @param outgroup a vector of mode numeric or character specifying the new outgroup 49 | ##' @param node node to reroot 50 | ##' @param edgelabel a logical value specifying whether to treat node labels as 51 | ##' edge labels and thus eventually switching them so that they are associated 52 | ##' with the correct edges. 53 | ##' @param ... additional parameters passed to ape::root.phylo 54 | ##' @return rerooted treedata 55 | ##' @method root treedata 56 | ##' @export 57 | 58 | root.treedata <- function(phy, outgroup, node = NULL, edgelabel = TRUE, ...){ 59 | if (!missing(outgroup) && is.character(outgroup)){ 60 | outgroup <- match(outgroup, phy@phylo$tip.label) 61 | } 62 | if (!edgelabel){ 63 | ## warning message 64 | message("The use of this method may cause some node data to become incorrect (e.g. bootstrap values) if 'edgelabel' is FALSE.") 65 | } 66 | #object <- phy 67 | # generate node old label and new label map table. 68 | res <- build_new_labels(tree=phy) 69 | tree <- res$tree 70 | node2oldnewlab <- res$node2old_new_lab 71 | # reroot tree 72 | re_tree <- root(tree, outgroup = outgroup, node = node, 73 | edgelabel = edgelabel, ...) 74 | 75 | node_map <- old_new_node_mapping(tree, re_tree) 76 | n.tips <- Ntip(re_tree) 77 | 78 | # replace new label with old label 79 | phy@phylo <- build_new_tree(tree=re_tree, node2old_new_lab=node2oldnewlab) 80 | 81 | # update data or extraInfo function 82 | update_data <- function(data, node_map) { 83 | cn <- colnames(data) 84 | cn <- cn[cn != "node"] 85 | data <- dplyr::inner_join(data, node_map, by=c("node"="old")) %>% 86 | dplyr::select(c("new", cn)) %>% 87 | dplyr::rename(node=.data$new) 88 | 89 | # clear root data 90 | root <- data$node == (n.tips + 1) 91 | data[root,] <- NA 92 | data[root,'node'] <- n.tips + 1 93 | return(data) 94 | } 95 | if (nrow(phy@data) > 0) { 96 | phy@data <- update_data(phy@data, node_map) 97 | } 98 | if (nrow(phy@extraInfo) > 0){ 99 | phy@extraInfo <- update_data(phy@extraInfo, node_map) 100 | } 101 | 102 | return(phy) 103 | } 104 | 105 | 106 | ## reroot_node_mapping <- function(tree, tree2) { 107 | ## root <- rootnode(tree) 108 | ## 109 | ## 110 | ## node_map <- data.frame(from=1:getNodeNum(tree), to=NA, visited=FALSE) 111 | ## node_map[1:Ntip(tree), 2] <- match(tree$tip.label, tree2$tip.label) 112 | ## node_map[1:Ntip(tree), 3] <- TRUE 113 | ## 114 | ## node_map[root, 2] <- root 115 | ## node_map[root, 3] <- TRUE 116 | ## 117 | ## node <- rev(tree$edge[,2]) 118 | ## for (k in node) { 119 | ## ##ip <- getParent(tree, k) 120 | ## ip <- parent(tree, k) 121 | ## if (node_map[ip, "visited"]) 122 | ## next 123 | ## 124 | ## ## cc <- getChild(tree, ip) 125 | ## cc <- child(tree, ip) 126 | ## node2 <- node_map[cc,2] 127 | ## if (anyNA(node2)) { 128 | ## node <- c(node, k) 129 | ## next 130 | ## } 131 | ## 132 | ## ## to <- unique(sapply(node2, getParent, tr=tree2)) 133 | ## to <- unique(sapply(node2, parent, .data=tree2)) 134 | ## to <- to[! to %in% node_map[,2]] 135 | ## node_map[ip, 2] <- to 136 | ## node_map[ip, 3] <- TRUE 137 | ## } 138 | ## node_map <- node_map[, -3] 139 | ## return(node_map) 140 | ## } 141 | ## 142 | ## 143 | ## ##' re-root a tree 144 | ## ##' 145 | ## ##' 146 | ## ##' @title root 147 | ## ##' @rdname root-method 148 | ## ##' @param phy tree object 149 | ## ##' @param outgroup a vector of mode numeric or character specifying the new outgroup 150 | ## ##' @param node node to reroot 151 | ## ##' @param resolve.root a logical specifying whether to resolve the new root as a bifurcating node 152 | ## ##' @param ... additional parameters passed to ape::root.phylo 153 | ## ##' @return rerooted tree 154 | ## ##' @importFrom ape root 155 | ## ##' @method root phylo 156 | ## ##' @export 157 | ## ##' @author Guangchuang Yu 158 | ## root.phylo <- function(phy, outgroup, node = NULL, resolve.root = TRUE, ...) { 159 | ## ## pos <- 0.5* object$edge.length[which(object$edge[,2] == node)] 160 | ## 161 | ## ## @importFrom phytools reroot 162 | ## ## phytools <- "phytools" 163 | ## ## require(phytools, character.only = TRUE, quietly = TRUE) 164 | ## 165 | ## ## phytools_reroot <- eval(parse(text="phytools::reroot")) 166 | ## 167 | ## ## tree <- phytools_reroot(object, node, pos) 168 | ## 169 | ## tree <- ape::root.phylo(phy, outgroup = outgroup, 170 | ## node = node, resolve.root = resolve.root, ...) 171 | ## 172 | ## #if (Nnode(tree) != Nnode(phy)) { 173 | ## # return(tree) 174 | ## #} 175 | ## 176 | ## attr(tree, "reroot") <- TRUE 177 | ## node_map <- reroot_node_mapping(phy, tree) 178 | ## attr(tree, "node_map") <- node_map 179 | ## return(tree) 180 | ## } 181 | ## 182 | ## 183 | ## ##' @rdname root-method 184 | ## ##' @method root treedata 185 | ## ##' @export 186 | ## root.treedata <- function(phy, outgroup, node = NULL, resolve.root = TRUE, ...) { 187 | ## ## warning message 188 | ## message("The use of this method may cause some node data to become incorrect (e.g. bootstrap values).") 189 | ## 190 | ## object <- phy 191 | ## newobject <- object 192 | ## 193 | ## ## ensure nodes/tips have a label to properly map @anc_seq/@tip_seq 194 | ## tree <- object@phylo 195 | ## if (is.null(tree$tip.label)) { 196 | ## tree$tip.label <- as.character(1:Ntip(tree)) 197 | ## } 198 | ## if (is.null(tree$node.label)) { 199 | ## #tree$node.label <- as.character((1:tree$Nnode) + Ntip(tree)) 200 | ## tree$node.label <- paste0("node",1:Nnode(tree)) 201 | ## } 202 | ## 203 | ## ## reroot tree 204 | ## tree <- root(tree, outgroup = outgroup, node = node, 205 | ## resolve.root = resolve.root, ...) 206 | ## newobject@phylo <- tree 207 | ## 208 | ## ## update node numbers in data 209 | ## n.tips <- Ntip(tree) 210 | ## node_map<- attr(tree, "node_map") 211 | ## if (is.null(node_map)) { 212 | ## message("fail to assign associated data to rooted tree, only return tree structure (a phylo object)") 213 | ## if (!resolve.root) { 214 | ## message("maybe you can try again with `resolve.root = TRUE`") 215 | ## } 216 | ## return(tree) 217 | ## } 218 | ## 219 | ## update_data <- function(data, node_map) { 220 | ## newdata <- data 221 | ## 222 | ## indx <- match(node_map$from, data$node) 223 | ## indx <- indx[!is.na(indx)] 224 | ## 225 | ## indy <- match(data$node, node_map$from) 226 | ## indy <- indy[!is.na(indy)] 227 | ## 228 | ## newdata[indx, "node"] <- node_map[indy, "to"] 229 | ## 230 | ## # newdata[match(node_map$from, data$node), 'node'] <- node_map$to 231 | ## 232 | ## # clear root data 233 | ## root <- newdata$node == (n.tips + 1) 234 | ## newdata[root,] <- NA 235 | ## newdata[root,'node'] <- n.tips + 1 236 | ## 237 | ## return(newdata) 238 | ## } 239 | ## 240 | ## if (nrow(newobject@data) > 0) { 241 | ## newobject@data <- update_data(object@data, node_map) 242 | ## } 243 | ## 244 | ## if (nrow(object@extraInfo) > 0) { 245 | ## newobject@extraInfo <- update_data(object@extraInfo, node_map) 246 | ## } 247 | ## 248 | ## return(newobject) 249 | ## } 250 | 251 | build_new_labels <- function(tree){ 252 | node2label_old <- tree %>% as_tibble() %>% dplyr::select(c("node", "label")) 253 | if (inherits(tree, "treedata")){ 254 | tree <- tree@phylo 255 | } 256 | tree$tip.label <- paste0("t", seq_len(Ntip(tree))) 257 | tree$node.label <- paste0("n", seq_len(Nnode(tree))) 258 | node2label_new <- tree %>% as_tibble() %>% dplyr::select(c("node", "label")) 259 | old_and_new <- node2label_old %>% 260 | dplyr::inner_join(node2label_new, by="node") %>% 261 | dplyr::rename(old="label.x", new="label.y") 262 | return (list(tree=tree, node2old_new_lab=old_and_new)) 263 | } 264 | 265 | build_new_tree <- function(tree, node2old_new_lab){ 266 | # replace new label with old label 267 | treeda <- tree %>% as_tibble() 268 | treeda1 <- treeda %>% 269 | dplyr::filter(.data$label %in% node2old_new_lab$new) 270 | treeda2 <- treeda %>% 271 | dplyr::filter(!(.data$label %in% node2old_new_lab$new)) 272 | # original label 273 | treeda1$label <- node2old_new_lab[match(treeda1$label, node2old_new_lab$new), "old"] %>% 274 | unlist(use.names=FALSE) 275 | treeda <- rbind(treeda1, treeda2) 276 | tree <- treeda[order(treeda$node),] %>% as.phylo() 277 | return (tree) 278 | } 279 | -------------------------------------------------------------------------------- /R/methods-tidyr.R: -------------------------------------------------------------------------------- 1 | #' @method unnest treedata 2 | #' @export 3 | unnest.treedata <- function(data, 4 | cols, ..., 5 | keep_empty = FALSE, 6 | ptype = NULL, 7 | names_sep = NULL, 8 | names_repair = "check_unique"){ 9 | tbl_df_returned_message %>% 10 | pillar::style_subtle() %>% 11 | writeLines() 12 | cols <- rlang::enquo(cols) 13 | data <- .extract_annotda.treedata(data) 14 | data <- unnest(data, !!cols, ..., keep_empty=keep_empty, 15 | ptype=ptype, names_sep=names_sep, names_repair=names_repair) 16 | return(data) 17 | } 18 | -------------------------------------------------------------------------------- /R/mutate.R: -------------------------------------------------------------------------------- 1 | ##' @method mutate tbl_tree 2 | ##' @importFrom dplyr mutate 3 | ##' @export 4 | mutate.tbl_tree <- function(.data, ...) { 5 | res <- NextMethod() 6 | if (!valid.tbl_tree2(res)){ 7 | res <- drop_class(res, 'tbl_tree') 8 | } 9 | res 10 | } 11 | 12 | ##' @method mutate treedata 13 | ##' @export 14 | mutate.treedata <- function(.data, ..., keep.td=TRUE){ 15 | dots <- rlang::quos(...) 16 | dat <- .extract_annotda.treedata(.data) 17 | da <- dplyr::mutate(dat, !!!dots) 18 | if (keep.td){ 19 | if ('label' %in% names(dots)){ 20 | .data@phylo$tip.label <- as.vector(da[da$isTip, 'label', drop = TRUE]) 21 | if (!is.null(.data@phylo$node.label)){ 22 | .data@phylo$node.label <- as.vector(da[!da$isTip, 'label', drop = TRUE]) 23 | } 24 | } 25 | .data <- .update.treedata(td = .data, 26 | da = da, 27 | dat = dat, 28 | type = "extra") 29 | return(.data) 30 | } 31 | return(da) 32 | } 33 | -------------------------------------------------------------------------------- /R/nodeid.R: -------------------------------------------------------------------------------- 1 | ##' @method nodeid tbl_tree 2 | ##' @export 3 | nodeid.tbl_tree <- function(tree, label) { 4 | tree$node[match(label, tree$label)] 5 | } 6 | 7 | ##' @method nodelab tbl_tree 8 | ##' @export 9 | nodelab.tbl_tree <- function(tree, id) { 10 | tree$label[match(id, tree$node)] 11 | } 12 | 13 | ##' @method nodeid phylo 14 | ##' @export 15 | nodeid.phylo <- function(tree, label) { 16 | ## nodeid(as_tibble(tree), label) 17 | lab <- c(tree$tip.label, tree$node.label) 18 | match(label, lab) 19 | } 20 | 21 | ##' @method nodeid treedata 22 | ##' @export 23 | nodeid.treedata <- function(tree, label) { 24 | nodeid(as.phylo(tree), label) 25 | } 26 | 27 | ##' @method nodelab phylo 28 | ##' @export 29 | nodelab.phylo <- function(tree, id) { 30 | nodelab(as_tibble(tree), id) 31 | } 32 | 33 | ##' @method nodelab treedata 34 | ##' @export 35 | nodelab.treedata <- function(tree, id) { 36 | nodelab(as.phylo(tree), id) 37 | } 38 | -------------------------------------------------------------------------------- /R/offspring.R: -------------------------------------------------------------------------------- 1 | ##' @method child tbl_tree 2 | ##' @export 3 | ##' @rdname child 4 | ##' @examples 5 | ##' library(ape) 6 | ##' tree <- rtree(4) 7 | ##' x <- as_tibble(tree) 8 | ##' child(x, 4) 9 | child.tbl_tree <- function(.data, .node, ...) { 10 | valid.tbl_tree(.data) 11 | 12 | if (is.character(.node)) { 13 | .node <- .data$node[.data$label == .node] 14 | } 15 | 16 | .data[.data$parent == .node & .data$parent != .data$node,] 17 | } 18 | 19 | ##' @method offspring tbl_tree 20 | ##' @export 21 | ##' @rdname offspring 22 | ##' @examples 23 | ##' library(ape) 24 | ##' tree <- rtree(4) 25 | ##' x <- as_tibble(tree) 26 | ##' offspring(x, 4) 27 | offspring.tbl_tree <- function(.data, .node, tiponly = FALSE, self_include = FALSE, ...) { 28 | if (missing(.node) || is.null(.node)) { 29 | stop(".node is required") 30 | } 31 | if (length(.node) == 1) { 32 | res <- .offspring.tbl_tree_item(.data = .data, .node = .node, 33 | tiponly = tiponly, self_include = self_include, ...) 34 | } else { 35 | res <- lapply(.node, function(node) { 36 | .offspring.tbl_tree_item(.data = .data, .node = node, 37 | tiponly = tiponly, self_include = self_include, ...) 38 | }) 39 | names(res) <- .node 40 | } 41 | return(res) 42 | } 43 | 44 | #' @noRd 45 | #' @keywords internal 46 | .offspring.tbl_tree_item <- function(.data, .node, tiponly = FALSE, self_include = FALSE, ...) { 47 | x <- child.tbl_tree(.data, .node) 48 | 49 | ## https://github.com/GuangchuangYu/ggtree/issues/239 50 | rn <- rootnode.tbl_tree(.data)$node 51 | x <- x[x$node != rn, ] 52 | 53 | if (nrow(x) == 0) { 54 | if (self_include) { 55 | x <- .data[.data$node == .node, ] 56 | } 57 | 58 | return(x) 59 | } 60 | 61 | ## id <- x$node 62 | ## i <- 1 63 | ## while(i <= length(id)) { 64 | ## id <- c(id, child(.data, id[i])$node) 65 | ## i <- i + 1 66 | ## } 67 | ## filter_(.data, ~ node %in% id) 68 | 69 | parent <- .data$parent 70 | children <- .data$node 71 | ## n <- length(parent) 72 | n <- max(parent) 73 | 74 | kids <- vector("list", n) 75 | for (i in seq_along(parent)) { 76 | kids[[parent[i]]] <-c(kids[[parent[i]]], children[i]) 77 | } 78 | 79 | id <- x$node 80 | i <- 1 81 | while(i <= length(id)) { 82 | id <- c(id, kids[[id[i]]]) 83 | i <- i + 1 84 | } 85 | 86 | if (self_include) { 87 | id <- c(.node, id) 88 | } 89 | 90 | sp <- .data[children %in% id,] 91 | if (tiponly) { 92 | return(sp[sp$node < rn,]) 93 | } 94 | return(sp) 95 | } 96 | 97 | ##' @method child phylo 98 | ##' @export 99 | child.phylo <- function(.data, .node, type = 'children', ...) { 100 | res <- offspring(.data=.data, .node = .node, type = type) 101 | return(res) 102 | } 103 | 104 | ##' @method child treedata 105 | ##' @export 106 | child.treedata <- function(.data, .node, type = 'children', ...) { 107 | child.phylo(as.phylo(.data), .node, type = type, ...) 108 | } 109 | 110 | .internal.child <- function(data, node, type = 'children'){ 111 | if (!is_numeric(node)){ 112 | all.labs <- c(data$tip.label, data$node.label) 113 | names(all.labs) <- seq_len(length(all.labs)) 114 | node <- names(all.labs[all.labs %in% node]) 115 | } 116 | edge <- data$edge 117 | res <- edge[edge[,1] == node, 2] 118 | if (type != 'children'){ 119 | alltips <- edge[,2][! edge[,2] %in% edge[,1]] 120 | w <- which(res >= length(alltips)) 121 | if(length(w)>0){ 122 | for(i in 1:length(w)){ 123 | res <- c(res, 124 | .internal.child( 125 | data = data, 126 | node = res[w[i]], 127 | type = type 128 | ) 129 | ) 130 | } 131 | } 132 | if (type %in% c('tips', 'external')){ 133 | res <- res[res %in% alltips] 134 | }else if (type == "internal") { 135 | res <- res[!res %in% alltips] 136 | } 137 | } 138 | return(unname(res)) 139 | } 140 | 141 | ##' @method offspring phylo 142 | ##' @export 143 | offspring.phylo <- function(.data, .node, tiponly = FALSE, self_include = FALSE, type = 'all', ...){ 144 | type <- match.arg(type, c("children", 'tips', 'internal', 'external', 'all')) 145 | 146 | if (tiponly){ 147 | message('The "tiponly = TRUE" can be replaced by type="tips".') 148 | type = 'tips' 149 | } 150 | 151 | res <- lapply(.node, .internal.child, data = .data, type = type) 152 | if (length(res) <= 1){ 153 | res <- unlist(res) 154 | if (self_include){ 155 | res <- c(.node, res) 156 | } 157 | }else{ 158 | if (self_include){ 159 | res <- mapply(append, .node, res, SIMPLIFY=FALSE) 160 | } 161 | names(res) <- .node 162 | } 163 | return (res) 164 | #if (self_include) { 165 | # sp <- .node 166 | #} else { 167 | # sp <- child(.data, .node) 168 | #} 169 | 170 | #sp <- sp[sp != 0] 171 | #if (length(sp) == 0) { 172 | # return(sp) 173 | # ## stop("input node is a tip...") 174 | #} 175 | #i <- 1 176 | #while (i <= length(sp)) { 177 | # sp <- c(sp, child(.data, sp[i])) 178 | # sp <- sp[sp != 0] 179 | # i <- i + 1 180 | #} 181 | #if (tiponly) { 182 | # return(sp[sp <= Ntip(.data)]) 183 | #} 184 | #return(sp) 185 | } 186 | 187 | 188 | ##' @method offspring treedata 189 | ##' @export 190 | offspring.treedata <- function(.data, .node, tiponly = FALSE, self_include = FALSE, type = 'all', ...) { 191 | offspring.phylo(as.phylo(.data), .node, 192 | tiponly = tiponly, self_include = self_include, 193 | type = type, 194 | ...) 195 | } 196 | -------------------------------------------------------------------------------- /R/pull.R: -------------------------------------------------------------------------------- 1 | ##' @method pull treedata 2 | ##' @export 3 | pull.treedata <- function(.data, var = -1, name = NULL, ...){ 4 | var <- rlang::enquo(var) 5 | name <- rlang::enquo(name) 6 | dat <- .extract_annotda.treedata(.data) 7 | dplyr::pull(dat, var = !!var, name = !!name, ...) 8 | } 9 | 10 | ##' @method pull phylo 11 | ##' @export 12 | pull.phylo <- pull.treedata 13 | -------------------------------------------------------------------------------- /R/reexports.R: -------------------------------------------------------------------------------- 1 | ##' @importFrom magrittr %>% 2 | ##' @export 3 | magrittr::`%>%` 4 | 5 | ##' @importFrom magrittr %<>% 6 | ##' @export 7 | magrittr::`%<>%` 8 | 9 | ##' @importFrom tibble as_tibble 10 | ##' @export 11 | tibble::as_tibble 12 | 13 | ##' @importFrom tibble tibble 14 | ##' @export 15 | tibble::tibble 16 | 17 | 18 | ##' @importFrom dplyr filter 19 | ##' @export 20 | dplyr::filter 21 | 22 | ##' @importFrom dplyr arrange 23 | ##' @export 24 | dplyr::arrange 25 | 26 | ##' @importFrom dplyr select 27 | ##' @export 28 | dplyr::select 29 | 30 | ##' @importFrom dplyr rename 31 | ##' @export 32 | dplyr::rename 33 | 34 | ##' @importFrom dplyr mutate 35 | ##' @export 36 | dplyr::mutate 37 | 38 | ##' @importFrom dplyr transmute 39 | ##' @export 40 | dplyr::transmute 41 | 42 | ##' @importFrom dplyr summarise 43 | ##' @export 44 | dplyr::summarise 45 | 46 | ##' @importFrom dplyr summarize 47 | ##' @export 48 | dplyr::summarize 49 | 50 | ##' @importFrom dplyr full_join 51 | ##' @export 52 | dplyr::full_join 53 | 54 | ##' @importFrom rlang .data 55 | ##' @export 56 | rlang::.data 57 | 58 | ##' @importFrom dplyr left_join 59 | ##' @export 60 | dplyr::left_join 61 | 62 | ##' @importFrom dplyr pull 63 | ##' @export 64 | dplyr::pull 65 | 66 | ##' @importFrom dplyr rename 67 | ##' @export 68 | dplyr::rename 69 | 70 | ##' @importFrom tidyr unnest 71 | ##' @export 72 | tidyr::unnest 73 | -------------------------------------------------------------------------------- /R/rename.R: -------------------------------------------------------------------------------- 1 | ##' @method rename treedata 2 | ##' @importFrom tidyselect eval_select 3 | ##' @export 4 | rename.treedata <- function(.data, ...){ 5 | dat <- .data %>% .extract_annotda.treedata() 6 | 7 | cols <- eval_select(rlang::expr(c(...)), dat) 8 | 9 | loc <- check_names_from_phylo(x=dat, recol=cols) 10 | 11 | clnames <- colnames(dat) 12 | 13 | .data@data <- .update.td.rename(x=.data@data, loc=loc, clnames=clnames) 14 | 15 | .data@extraInfo <- .update.td.rename(x=.data@extraInfo, loc=loc, clnames=clnames) 16 | 17 | .data@phylo <- .update.phylo.rename(x=.data@phylo, loc = loc, clnames = clnames) 18 | 19 | return(.data) 20 | } 21 | 22 | ##' @method rename tbl_tree 23 | ##' @export 24 | rename.tbl_tree <- function(.data, ...){ 25 | x <- NextMethod() 26 | if (!valid.tbl_tree2(x)){ 27 | x <- drop_class(x, 'tbl_tree') 28 | } 29 | return(x) 30 | } 31 | 32 | 33 | #' @param x the data before rename 34 | #' @param recol the column will be renamed 35 | #' @noRd 36 | check_names_from_phylo <- function(x, recol){ 37 | clnm <- colnames(x) 38 | renm <- clnm[recol] 39 | if (any(renm %in% c("node", "label", "isTip"))){ 40 | warning("The 'node', 'label' and 'isTip' do not be renamed !") 41 | ind <- seq_len(length(recol)) 42 | names(ind) <- renm 43 | ind <- ind[!names(ind) %in% c("node", "label", "isTip")] 44 | recol <- recol[unname(ind)] 45 | } 46 | return(recol) 47 | } 48 | 49 | #' @noRd 50 | .update.td.rename <- function(x, loc, clnames){ 51 | clnmda <- colnames(x) 52 | loc <- sort(loc) 53 | ind.da1 <- which(clnames[loc] %in% clnmda) 54 | ind.da2 <- which(clnmda %in% clnames[loc]) 55 | clnmda[ind.da2] <- names(loc)[ind.da1] 56 | 57 | colnames(x) <- clnmda 58 | return(x) 59 | } 60 | 61 | .update.phylo.rename <- function(x, loc, clnames){ 62 | aa <- names(attributes(x)) 63 | group <- aa[!aa %in% c("names", "class", "order", "reroot", "node_map")] 64 | if (length(group) == 0) return(x) 65 | 66 | loc <- sort(loc) 67 | ind.da1 <- which(clnames[loc] %in% aa) 68 | ind.da2 <- which(aa %in% clnames[loc]) 69 | aa[ind.da2] <- names(loc)[ind.da1] 70 | names(attributes(x)) <- aa 71 | return(x) 72 | } 73 | -------------------------------------------------------------------------------- /R/select.R: -------------------------------------------------------------------------------- 1 | ##' @importFrom dplyr select 2 | ##' @method select ggtree 3 | ##' @export 4 | select.ggtree <- function(.data, ...) { 5 | dots <- rlang::quos(...) 6 | dplyr::select(.data$data, !!!dots) 7 | } 8 | 9 | ##' @method select treedata 10 | ##' @export 11 | select.treedata <- function(.data, ..., keep.td=FALSE){ 12 | dots <- rlang::quos(...) 13 | dat <- .extract_annotda.treedata(.data) 14 | da <- dplyr::select(dat, !!!dots) 15 | if (keep.td){ 16 | .data <- .update.treedata(td=.data, da=da, dat=dat) 17 | return(.data) 18 | } 19 | return(da) 20 | } 21 | 22 | ##' @method select tbl_tree 23 | ##' @export 24 | select.tbl_tree <- function(.data, ...){ 25 | x <- NextMethod() 26 | if (!valid.tbl_tree2(x)){ 27 | x <- drop_class(x, name = 'tbl_tree') 28 | } 29 | return(x) 30 | } 31 | -------------------------------------------------------------------------------- /R/show.R: -------------------------------------------------------------------------------- 1 | ##' show method for `treedata` instance 2 | ##' 3 | ##' 4 | ##' @name show 5 | ##' @docType methods 6 | ##' @rdname show-methods 7 | ##' 8 | ##' @title show method 9 | ##' @param object `treedata` object 10 | ##' @return print info 11 | ##' @importFrom methods show 12 | ##' @exportMethod show 13 | ##' @usage show(object) 14 | ##' @author Guangchuang Yu 15 | setMethod("show", signature(object = "treedata"), 16 | function(object) { 17 | print(object) 18 | }) 19 | 20 | print_fields <- function(object) { 21 | if (!has_fields(object)) return() 22 | 23 | fields <- get.fields(object) 24 | 25 | cat("\nwith the following features available:\n") 26 | ff <- paste0(" '",paste(fields, collapse="', '"), "'.\n") 27 | writeLines(yulab.utils::str_wrap(ff)) 28 | } 29 | 30 | has_fields <- function(object) { 31 | fields <- get.fields(object) 32 | if (length(fields) == 1 && fields == "") { 33 | return(FALSE) 34 | } 35 | return(TRUE) 36 | } 37 | 38 | fields_wrap <- function(ff) { 39 | w <- getOption('width') 40 | n <- nchar(ff) 41 | if (w < n) { 42 | s <- gregexpr("\t", substring(ff, 1, w))[[1]] 43 | i <- s[length(s)] 44 | ff2 <- substring(ff, 1:n, 1:n) 45 | ff2[i] <- '\n\t' 46 | n <- n+1 47 | i <- i+1 48 | ff <- paste0(ff2, collapse='') 49 | if (w < (n-i)) { 50 | ff1 <- substring(ff, 1, i) 51 | ff2 <- substring(ff, i+1, n) 52 | return(paste0(ff1, fields_wrap(ff2))) 53 | } 54 | } 55 | return(ff) 56 | } 57 | 58 | ##' @method print treedata 59 | ##' @export 60 | print.treedata <- function(x, ..., n = 10, width = NULL, max_extra_cols = NULL, max_footer_lines = NULL){ 61 | show.data = getOption('show_data_for_treedata', default=TRUE) 62 | if (show.data){ 63 | print1.treedata(x, n = n, width = width, max_extra_cols = max_extra_cols, max_footer_lines = max_footer_lines, ...) 64 | }else{ 65 | print2.treedata(x, ...) 66 | } 67 | } 68 | 69 | print1.treedata <- function(x, ..., n = 10, width = NULL, max_extra_cols = NULL, max_footer_lines = NULL){ 70 | 71 | annotda <- .extract_annotda.treedata(x) 72 | 73 | formatstr <- annotda %>% format(..., n = n, width = width, max_extra_cols = max_extra_cols, max_footer_lines = max_footer_lines) 74 | 75 | ## fields <- get.fields(x) 76 | 77 | ## if(length(fields)==1 && fields==""){ 78 | ## fields <- '' 79 | ## newheader <- c("\n None available features.") 80 | ## }else{ 81 | ## ff <- paste0("\t'",paste(fields, collapse="',\t'"), "'.\n") 82 | ## fields <- yulab.utils::str_wrap(ff) ## fields_wrap(ff) 83 | ## newheader <- c("\nwith the following features available:", fields) 84 | ## } 85 | 86 | ## msg <- .internal_print.treedata_msg(x) %>% 87 | ## yulab.utils::str_wrap() %>% 88 | ## writeLines() 89 | 90 | ## phyloinfo <- utils::capture.output(print.phylo(as.phylo(x))) 91 | ## writeLines(yulab.utils::str_wrap(phyloinfo)) 92 | 93 | print2.treedata(x, ...) 94 | 95 | if (has_fields(x)) { 96 | formatstr[1] <- gsub("(A tibble:)", "The associated data tibble abstraction:", formatstr[1]) 97 | formatstr %<>% append(pillar::style_subtle("# The 'node', 'label' and 'isTip' are from the phylo tree."), 98 | after=1) 99 | ## newheader %>% 100 | ## append(formatstr) %>% 101 | ## # yulab.utils::str_wrap() %>% 102 | ## writeLines() 103 | writeLines(formatstr) 104 | } 105 | 106 | invisible(x) 107 | } 108 | 109 | #' @importFrom ape print.phylo 110 | #' @importFrom yulab.utils str_wrap 111 | print2.treedata <- function(x, ...) { 112 | msg <- .internal_print.treedata_msg(x) 113 | writeLines(yulab.utils::str_wrap(msg)) 114 | phyloinfo <- utils::capture.output(print.phylo(as.phylo(x))) 115 | writeLines(yulab.utils::str_wrap(phyloinfo)) 116 | print_fields(x) 117 | } 118 | 119 | ##' @method print tbl_tree 120 | ##' @export 121 | print.tbl_tree <- function(x, width = NULL, ..., n = NULL, 122 | max_extra_cols = NULL, max_footer_lines = NULL){ 123 | formatted_tb <- x %>% format(..., n = n, width = width, 124 | max_extra_cols = max_extra_cols, 125 | max_footer_lines = max_footer_lines) 126 | if (valid.tbl_tree2(x)){ 127 | new_head = "A tbl_tree abstraction:" 128 | formatted_tb_tree <- formatted_tb %>% 129 | { 130 | x = (.); 131 | x[1] = gsub("(A tibble:)", new_head, x[1]); 132 | x 133 | } 134 | formatted_tb_tree <- append(formatted_tb_tree, 135 | pillar::style_subtle("# which can be converted to treedata or phylo \n# via as.treedata or as.phylo"), 136 | after = 1 137 | ) 138 | writeLines(formatted_tb_tree) 139 | }else{ 140 | writeLines(formatted_tb) 141 | } 142 | invisible(x) 143 | } 144 | 145 | 146 | .internal_print.treedata_msg <- function(x){ 147 | msg <- "'treedata' S4 object" 148 | files <- x@file 149 | files <- files[files != ""] 150 | if (length(files)) { 151 | ff <- paste(files, collapse="',\n\t'") 152 | msg <- paste0(msg, 153 | " that stored information of\n\t", 154 | "'", ff) 155 | } 156 | 157 | msg <- paste0(msg, "'.\n") 158 | msg <- c(msg, "...@ phylo:") 159 | 160 | return(msg) 161 | } 162 | 163 | .internal_add_isTip <- function(x){ 164 | x %<>% mutate(isTip=ifelse(!.data$node %in% .data$parent, TRUE, FALSE)) 165 | return(x) 166 | } 167 | -------------------------------------------------------------------------------- /R/sibling.R: -------------------------------------------------------------------------------- 1 | ##' @method sibling tbl_tree 2 | ##' @export 3 | sibling.tbl_tree <- function(.data, .node, ...) { 4 | valid.tbl_tree(.data) 5 | 6 | p <- parent(.data, .node) 7 | if (nrow(p) == 0) # if root node, return empty tibble 8 | return(p) 9 | child(.data, p$node) %>% filter(.data$node != .node) 10 | } 11 | 12 | ##' @method sibling phylo 13 | ##' @export 14 | sibling.phylo <- function(.data, .node, ...) { 15 | root <- rootnode(.data) 16 | if (.node == root) { 17 | return(NA) 18 | } 19 | 20 | pp <- parent(.data, .node) 21 | cc <- child(.data, pp) 22 | sib <- cc[cc != .node] 23 | return(sib) 24 | } 25 | -------------------------------------------------------------------------------- /R/tidy-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | "_PACKAGE" 3 | 4 | -------------------------------------------------------------------------------- /R/tidy_utilities.R: -------------------------------------------------------------------------------- 1 | .internal_add_isTip <- function(x){ 2 | x %<>% mutate(isTip=ifelse(!.data$node %in% .data$parent, TRUE, FALSE)) 3 | return(x) 4 | } 5 | 6 | .extract_annotda.treedata <- function(x){ 7 | if (inherits(x, "treedata")){ 8 | annotda <- get_tree_data(x) 9 | x <- x@phylo 10 | }else{ 11 | annotda <- NULL 12 | } 13 | trdf <- x %>% 14 | as_tibble() %>% 15 | .internal_add_isTip() %>% 16 | drop_class(name="tbl_tree") 17 | 18 | if (!any(is.null(annotda) || nrow(annotda)==0)){ 19 | annotda <- trdf %>% 20 | dplyr::left_join(annotda, by="node") 21 | }else{ 22 | annotda <- trdf 23 | } 24 | annotda <- annotda[, !colnames(annotda) %in% c("parent", "branch.length")] 25 | return(annotda) 26 | } 27 | 28 | .update.treedata <- function(td, da, dat, type=NULL){ 29 | if (inherits(td, "phylo")){ 30 | td <- treedata(phylo=td) 31 | } 32 | data.nm <- get.fields.data(td) 33 | extra.nm <- get.fields.extraInfo(td) 34 | data.nm <- intersect(data.nm, colnames(da)) 35 | if (!is.null(type) && type == "extra"){ 36 | clnm <- colnames(da)[!colnames(da) %in% c("label", "isTip", data.nm)] 37 | extra.nm <- union(extra.nm, clnm) 38 | dat <- da 39 | }else{ 40 | extra.nm <- intersect(extra.nm, colnames(da)) 41 | } 42 | if (length(data.nm)>0){ 43 | td@data <- dat %>% select(c("node", data.nm)) 44 | }else{ 45 | td@data <- tibble() 46 | } 47 | if (length(extra.nm)>0){ 48 | td@extraInfo <- dat %>% select(c("node", extra.nm)) 49 | }else{ 50 | td@extraInfo <- tibble() 51 | } 52 | return(td) 53 | } 54 | 55 | #' remove the some class names from x object 56 | #' @noRd 57 | drop_class <- function(x, name) { 58 | class(x) <- class(x)[!class(x) %in% name] 59 | x 60 | } 61 | 62 | add_class <- function(x, name){ 63 | xx <- setdiff(name, class(x)) 64 | if (length(xx)>0){ 65 | class(x) <- base::union(xx, class(x)) 66 | } 67 | return (x) 68 | } 69 | 70 | nodeIds <- function(tree, internal.only=TRUE) { 71 | if (internal.only) { 72 | return(Ntip(tree) + 1:Nnode(tree, internal.only)) 73 | } 74 | 1:Nnode(tree, internal.only) 75 | } 76 | 77 | .internal_nest <- function(x, keepnm, ..., .names_sep = NULL){ 78 | nest <- utils::getFromNamespace("nest", "tidyr") 79 | if (missing(...)){ 80 | idx <- x %>% vapply(is.list, logical(1)) 81 | clnm <- colnames(x) 82 | clnm <- clnm[!idx] 83 | clnm <- clnm[!clnm %in% keepnm] 84 | params <- c(list(x), lapply(clnm, function(x)x)) 85 | names(params) <- c(".data", clnm) 86 | }else{ 87 | res <- nest(.data=x, ..., .names_sep=.names_sep) 88 | return(res) 89 | } 90 | if (!is.null(.names_sep)){ 91 | params <- c(params, .names_sep=.names_sep) 92 | } 93 | res <- do.call(nest, params) 94 | return(res) 95 | } 96 | 97 | tbl_df_returned_message <- "# A tbl_df is returned for independent data analysis." 98 | 99 | if(getRversion() >= "2.15.1") utils::globalVariables(c(".")) 100 | 101 | is_numeric <- function(x) !anyNA(suppressWarnings(as.numeric(as.character(x)))) 102 | 103 | filename <- function(file) { 104 | ## textConnection(text_string) will work just like a file 105 | ## in this case, just set the filename as "" 106 | file_name <- "" 107 | if (is.character(file)) { 108 | file_name <- file 109 | } 110 | return(file_name) 111 | } 112 | -------------------------------------------------------------------------------- /R/tree-subset.R: -------------------------------------------------------------------------------- 1 | #' Subset tree objects by related nodes 2 | #' 3 | #' This function allows for a tree object to be subset by specifying a 4 | #' node and returns all related nodes within a selected number of 5 | #' levels 6 | #' 7 | #' @param tree a tree object of class phylo 8 | #' @param node either a tip label or a node number for the given 9 | #' tree that will be the focus of the subsetted tree 10 | #' @param levels_back a number specifying how many nodes back from 11 | #' the selected node the subsetted tree should include 12 | #' @param group_node whether add grouping information of selected node 13 | #' @param group_name group name (default 'group') for storing grouping information if group_node = TRUE 14 | #' @param root_edge If TRUE (by default), set root.edge to path length of orginal root to the root of subset tree 15 | #' 16 | #' @details This function will take a tree and a specified node from 17 | #' that tree and subset the tree showing all relatives back to a specified 18 | #' number of nodes. This function allows for a combination of 19 | #' \code{ancestor} and \code{offspring} to return a subsetted 20 | #' tree that is of class phylo. This allows for easy graphing of the tree 21 | #' with \code{ggtree} 22 | #' 23 | #' @examples 24 | #' set.seed(123) 25 | #' tree <- ape::rtree(6) 26 | #' sub_tree <- tree_subset(tree, node = "t1", levels_back = 2) 27 | #' @rdname tree_subset 28 | #' @export 29 | tree_subset <- function(tree, node, levels_back = 5, group_node = TRUE, 30 | group_name = "group", root_edge = TRUE){ 31 | UseMethod("tree_subset") 32 | } 33 | 34 | 35 | #' @method tree_subset phylo 36 | #' @rdname tree_subset 37 | #' @importFrom magrittr %>% 38 | #' @importFrom utils tail 39 | #' @importFrom utils head 40 | #' @importFrom rlang quo .data 41 | #' @export 42 | tree_subset.phylo <- function(tree, node, levels_back = 5, group_node = TRUE, 43 | group_name = "group", root_edge = TRUE){ 44 | 45 | x <- tree_subset_internal(tree = tree, node = node, levels_back = levels_back, root_edge = root_edge) 46 | 47 | 48 | ## This drops all of the tips that are not included in group_nodes 49 | subtree <- drop.tip(tree, tree$tip.label[-x$subset_nodes], rooted = TRUE) 50 | 51 | if (group_node) subtree <- groupOTU.phylo(subtree, .node = x$group_labels, group_name = group_name) 52 | 53 | subtree$root.edge <- x$root.edge 54 | 55 | return(subtree) 56 | } 57 | 58 | ##' @importFrom dplyr filter 59 | ##' @importFrom dplyr pull 60 | ##' @importFrom dplyr bind_rows 61 | tree_subset_internal <- function(tree, node, levels_back = 5, root_edge = TRUE) { 62 | 63 | ## error catching to ensure the tree input is of class phylo 64 | ## if (class(tree) %in% c("phylo", "treedata")) { 65 | ## tree_df <- tidytree::as_tibble(tree) 66 | ## } else { 67 | ## stop("tree must be of class 'phylo'") 68 | ## } 69 | 70 | ## error catching to ensure the levels_back input is numeric 71 | ## or can be converted to numeric 72 | if (!is.numeric(levels_back)) { 73 | levels_back <- as.numeric(levels_back) 74 | if (is.na(levels_back)) stop("'levels_back' must be of class numeric") 75 | } 76 | 77 | tree_df <- tidytree::as_tibble(tree) 78 | 79 | selected_node <- node 80 | 81 | is_tip <- tree_df %>% 82 | dplyr::mutate(isTip = !.data$node %in% .data$parent) %>% 83 | dplyr::filter(.data$node == selected_node | .data$label == selected_node) %>% 84 | dplyr::pull(.data$isTip) 85 | 86 | if (is_tip & levels_back == 0){ 87 | stop("The selected node (", selected_node, ") is a tip. 'levels_back' must be > 0", 88 | call. = FALSE) 89 | } 90 | 91 | if (is_tip) { 92 | group_labels <- tree_df %>% 93 | dplyr::filter(.data$node == selected_node | .data$label == selected_node) %>% 94 | dplyr::pull(.data$label) 95 | } else { 96 | group_labels <- tree_df %>% 97 | tidytree::offspring(selected_node) %>% 98 | dplyr::filter(!.data$node %in% .data$parent) %>% 99 | dplyr::pull(.data$label) 100 | } 101 | 102 | ## This pipeline returns the tip labels of all nodes related to 103 | ## the specified node 104 | ## 105 | ## The tail/head combo isolates the base node of the subsetted tree 106 | ## as the output from ancestor lists the closest parent nodes of a 107 | ## given node from the bototm up. 108 | ## 109 | ## It then finds all of the offspring of that parent node. From there 110 | ## it filters to include only tip and then pulls the labels. 111 | 112 | if (levels_back == 0) { 113 | new_root_node <- selected_node 114 | } else { 115 | new_root_node <- tidytree::ancestor(tree_df, selected_node) %>% 116 | tail(levels_back) %>% 117 | head(1) %>% 118 | dplyr::pull(.data$node) 119 | } 120 | 121 | subset_labels <- tidytree::offspring(tree_df, new_root_node) %>% 122 | dplyr::filter(!.data$node %in% .data$parent) %>% 123 | dplyr::pull(.data$label) 124 | 125 | ## This finds the nodes associated with the labels pulled 126 | subset_nodes <- which(tree$tip.label %in% subset_labels) 127 | 128 | root.edge <- NULL 129 | if (is.null(tree$edge.length)) { 130 | root_edge <- FALSE 131 | ## if not branch length info, no need to determine root.edge 132 | } 133 | 134 | if (root_edge) { 135 | root.edge <- ancestor(tree_df, new_root_node) %>% 136 | bind_rows(dplyr::filter(tree_df, node == new_root_node)) %>% 137 | pull(.data$branch.length) %>% 138 | sum(na.rm = TRUE) 139 | if (root.edge == 0) 140 | root.edge <- NULL 141 | } 142 | 143 | return(list( 144 | subset_nodes = subset_nodes, 145 | new_root_node = new_root_node, 146 | group_labels = group_labels, 147 | root.edge = root.edge 148 | )) 149 | } 150 | 151 | #' @method tree_subset treedata 152 | #' @rdname tree_subset 153 | #' @importFrom magrittr %>% 154 | #' 155 | #' @export 156 | tree_subset.treedata <- function(tree, node, levels_back = 5, group_node = TRUE, 157 | group_name = "group", root_edge = TRUE){ 158 | 159 | x <- tree_subset_internal(tree = tree@phylo, node = node, levels_back = levels_back) 160 | 161 | subtree <- drop.tip(tree, tree@phylo$tip.label[-x$subset_nodes], rooted = TRUE) 162 | 163 | if (group_node) subtree <- groupOTU(subtree, .node = x$group_labels, group_name = group_name) 164 | 165 | subtree@phylo$root.edge <- x$root.edge 166 | 167 | return(subtree) 168 | } 169 | 170 | 171 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | ##' @importFrom yulab.utils yulab_msg 2 | .onAttach <- function(libname, pkgname) { 3 | packageStartupMessage(yulab_msg(pkgname)) 4 | } 5 | 6 | 7 | # deprecated, for backward compatibility, 2024-07-26 8 | #' @importFrom pillar style_subtle 9 | random_ref <- function(pkgname = NULL, pkgVersion = NULL, random_n = 2){ 10 | if (!is.null(pkgname) && !is.null(pkgVersion)){ 11 | headermsg <- paste0(pkgname, " v", pkgVersion, " ", 12 | "For help: https://yulab-smu.top/treedata-book/", "\n\n") 13 | }else{ 14 | headermsg <- NULL 15 | } 16 | msg <- "If you use the ggtree package suite in published research, please cite the appropriate paper(s):\n\n" 17 | refs <- c( 18 | ggtreeBook = paste("Guangchuang Yu. ", 19 | "Data Integration, Manipulation and Visualization of Phylogenetic Trees (1st edition).", 20 | "Chapman and Hall/CRC. 2022, doi:10.1201/9781003279242\n"), 21 | ggtreeCPB = paste0( 22 | "Guangchuang Yu. ", 23 | "Using ggtree to visualize data on tree-like structures. ", 24 | "Current Protocols in Bioinformatics. 2020, 69:e96. doi:10.1002/cpbi.96\n" 25 | ), 26 | ggtree_imeta = paste0("Shuangbin Xu, Lin Li, Xiao Luo, Meijun Chen, Wenli Tang, Li Zhan, Zehan Dai, Tommy T. Lam, Yi Guan, Guangchuang Yu. ", 27 | "Ggtree: A serialized data object for visualization of a phylogenetic tree and annotation data. ", 28 | "iMeta 2022, 1(4):e56. doi:10.1002/imt2.56\n"), 29 | ggtreeMBE = paste0( 30 | "Guangchuang Yu, Tommy Tsan-Yuk Lam, Huachen Zhu, Yi Guan. ", 31 | "Two methods for mapping and visualizing associated data on phylogeny using ggtree. ", 32 | "Molecular Biology and Evolution. 2018, 35(12):3041-3043. doi:10.1093/molbev/msy194\n" 33 | ), 34 | ggtree = paste0( 35 | "Guangchuang Yu, David Smith, Huachen Zhu, Yi Guan, Tommy Tsan-Yuk Lam. ", 36 | "ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data. ", 37 | "Methods in Ecology and Evolution. 2017, 8(1):28-36. doi:10.1111/2041-210X.12628\n" 38 | ), 39 | treeio = paste0( 40 | "LG Wang, TTY Lam, S Xu, Z Dai, L Zhou, T Feng, P Guo, CW Dunn, BR Jones, T Bradley, H Zhu, Y Guan, Y Jiang, G Yu. ", 41 | "treeio: an R package for phylogenetic tree input and output with richly annotated and associated data. ", 42 | "Molecular Biology and Evolution. 2020, 37(2):599-603. doi: 10.1093/molbev/msz240\n" 43 | ), 44 | ggtreeExtra = paste0( 45 | "S Xu, Z Dai, P Guo, X Fu, S Liu, L Zhou, W Tang, T Feng, M Chen, L Zhan, T Wu, E Hu, Y Jiang, X Bo, G Yu. ", 46 | "ggtreeExtra: Compact visualization of richly annotated phylogenetic data. ", 47 | "Molecular Biology and Evolution. 2021, 38(9):4039-4042. doi: 10.1093/molbev/msab166\n" 48 | ), 49 | ggtreeCRC = paste0( 50 | "G Yu. ", 51 | "Data Integration, Manipulation and Visualization of Phylogenetic Trees (1st ed.). ", 52 | "Chapman and Hall/CRC. 2022. ISBN: 9781032233574\n" 53 | ) 54 | ) 55 | if (is.null(pkgname)){ 56 | refs <- paste0(sample(refs, random_n), collapse="\n") 57 | }else{ 58 | indx <- match(pkgname, names(refs)) 59 | refs <- paste0(c(refs[indx], sample(refs[-indx], random_n)), collapse="\n") 60 | } 61 | if (all(nchar(refs) > 0)){ 62 | return(paste(strwrap(style_subtle(paste0(headermsg, msg, refs))), collapse = "\n")) 63 | }else{ 64 | return(NULL) 65 | } 66 | } 67 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: 3 | md_document: 4 | variant: gfm 5 | html_preview: false 6 | --- 7 | 8 | 9 | 10 | 11 | # tidytree: A Tidy Tool for Phylogenetic Tree Data Manipulation 12 | 13 | ```{r echo=FALSE, results="hide", message=FALSE} 14 | library("badger") 15 | ``` 16 | 17 | [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/tidytree?color=green)](https://cran.r-project.org/package=tidytree) 18 | `r badge_devel("guangchuangyu/tidytree", "green")` 19 | [![](https://cranlogs.r-pkg.org/badges/grand-total/tidytree?color=green)](https://cran.r-project.org/package=tidytree) 20 | [![](https://cranlogs.r-pkg.org/badges/tidytree?color=green)](https://cranlogs.r-pkg.org/downloads/total/last-month/tidytree) 21 | [![](https://cranlogs.r-pkg.org/badges/last-week/tidytree?color=green)](https://cranlogs.r-pkg.org/downloads/total/last-week/tidytree) 22 | 23 | 24 | ```{r comment="", echo=FALSE, results='asis'} 25 | cat(packageDescription('tidytree')$Description) 26 | ``` 27 | 28 | Visit for details. 29 | 30 | 31 | ## :writing_hand: Author 32 | 33 | Guangchuang YU 34 | 35 | School of Basic Medical Sciences, Southern Medical University 36 | 37 | 38 | 39 | [![saythanks](https://img.shields.io/badge/say-thanks-ff69b4.svg)](https://saythanks.io/to/GuangchuangYu) 40 | `r badger::badge_custom("follow me on", "WeChat", "green", "https://guangchuangyu.github.io/blog_images/biobabble.jpg")` 41 | 42 | 43 | 44 | ## :arrow_double_down: Installation 45 | 46 | Get the released version from CRAN: 47 | 48 | ```r 49 | install.packages("tidytree") 50 | ``` 51 | 52 | Or the development version from github: 53 | 54 | ```r 55 | remotes::install_github("GuangchuangYu/tidytree") 56 | ``` 57 | 58 | ## :sparkling_heart: Contributing 59 | 60 | We welcome any contributions! By participating in this project you agree to 61 | abide by the terms outlined in the [Contributor Code of Conduct](CONDUCT.md). 62 | 63 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # tidytree: A Tidy Tool for Phylogenetic Tree Data Manipulation 4 | 5 | [![CRAN\_Status\_Badge](https://www.r-pkg.org/badges/version/tidytree?color=green)](https://cran.r-project.org/package=tidytree) 6 | [![](https://img.shields.io/badge/devel%20version-0.3.4-green.svg)](https://github.com/guangchuangyu/tidytree) 7 | [![](https://cranlogs.r-pkg.org/badges/grand-total/tidytree?color=green)](https://cran.r-project.org/package=tidytree) 8 | [![](https://cranlogs.r-pkg.org/badges/tidytree?color=green)](https://cranlogs.r-pkg.org/downloads/total/last-month/tidytree) 9 | [![](https://cranlogs.r-pkg.org/badges/last-week/tidytree?color=green)](https://cranlogs.r-pkg.org/downloads/total/last-week/tidytree) 10 | 11 | Phylogenetic tree generally contains multiple components including node, 12 | edge, branch and associated data. ‘tidytree’ provides an approach to 13 | convert tree object to tidy data frame as well as provides tidy 14 | interfaces to manipulate tree data. 15 | 16 | Visit for details. 17 | 18 | ## :writing\_hand: Author 19 | 20 | Guangchuang YU 21 | 22 | School of Basic Medical Sciences, Southern Medical University 23 | 24 | 25 | 26 | [![saythanks](https://img.shields.io/badge/say-thanks-ff69b4.svg)](https://saythanks.io/to/GuangchuangYu) 27 | [![](https://img.shields.io/badge/follow%20me%20on-WeChat-green.svg)](https://guangchuangyu.github.io/blog_images/biobabble.jpg) 28 | 29 | ## :arrow\_double\_down: Installation 30 | 31 | Get the released version from CRAN: 32 | 33 | ``` r 34 | install.packages("tidytree") 35 | ``` 36 | 37 | Or the development version from github: 38 | 39 | ``` r 40 | remotes::install_github("GuangchuangYu/tidytree") 41 | ``` 42 | 43 | ## :sparkling\_heart: Contributing 44 | 45 | We welcome any contributions\! By participating in this project you 46 | agree to abide by the terms outlined in the [Contributor Code of 47 | Conduct](CONDUCT.md). 48 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # TODO LIST 2 | 3 | + [ ] a `unnest` method for `tbl_tree` object. 4 | - 5 | 6 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citHeader("To cite tidytree in publications use:") 2 | 3 | yulab.utils:::bib_ggtree("book") 4 | 5 | -------------------------------------------------------------------------------- /man/MRCA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R 3 | \name{MRCA} 4 | \alias{MRCA} 5 | \title{MRCA} 6 | \usage{ 7 | MRCA(.data, ...) 8 | } 9 | \arguments{ 10 | \item{.data}{phylo or tbl_tree object} 11 | 12 | \item{...}{additional parameters} 13 | } 14 | \value{ 15 | MRCA data 16 | } 17 | \description{ 18 | access most recent common ancestor data 19 | } 20 | \author{ 21 | Guangchuang Yu 22 | } 23 | -------------------------------------------------------------------------------- /man/Nnode.treedata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ape.R 3 | \name{Nnode.treedata} 4 | \alias{Nnode.treedata} 5 | \title{Nnode} 6 | \usage{ 7 | \method{Nnode}{treedata}(phy, internal.only = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{phy}{treedata object} 11 | 12 | \item{internal.only}{whether only count internal nodes} 13 | 14 | \item{...}{additional parameters} 15 | } 16 | \value{ 17 | number of nodes 18 | } 19 | \description{ 20 | number of nodes 21 | } 22 | \examples{ 23 | Nnode(rtree(30)) 24 | } 25 | \author{ 26 | Guangchuang Yu 27 | } 28 | -------------------------------------------------------------------------------- /man/ancestor.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/ancestor.R 3 | \name{ancestor} 4 | \alias{ancestor} 5 | \alias{ancestor.tbl_tree} 6 | \title{ancestor} 7 | \usage{ 8 | ancestor(.data, .node, ...) 9 | 10 | \method{ancestor}{tbl_tree}(.data, .node, ...) 11 | } 12 | \arguments{ 13 | \item{.data}{phylo or tbl_tree object} 14 | 15 | \item{.node}{node number} 16 | 17 | \item{...}{additional parameters} 18 | } 19 | \value{ 20 | ancestor data 21 | } 22 | \description{ 23 | access ancestor data 24 | } 25 | \examples{ 26 | library(ape) 27 | tree <- rtree(4) 28 | x <- as_tibble(tree) 29 | ancestor(x, 3) 30 | } 31 | \author{ 32 | Guangchuang Yu 33 | } 34 | -------------------------------------------------------------------------------- /man/as.treedata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/converter.R 3 | \name{as.treedata} 4 | \alias{as.treedata} 5 | \alias{as.treedata.tbl_tree} 6 | \title{as.treedata} 7 | \usage{ 8 | as.treedata(tree, ...) 9 | 10 | \method{as.treedata}{tbl_tree}(tree, ...) 11 | } 12 | \arguments{ 13 | \item{tree}{tree object} 14 | 15 | \item{...}{additional parameters} 16 | } 17 | \value{ 18 | treedata object 19 | } 20 | \description{ 21 | convert a tree object to treedata object 22 | } 23 | \examples{ 24 | library(ape) 25 | set.seed(2017) 26 | tree <- rtree(4) 27 | d <- tibble(label = paste0('t', 1:4), 28 | trait = rnorm(4)) 29 | x <- as_tibble(tree) 30 | full_join(x, d, by = 'label') \%>\% as.treedata 31 | } 32 | -------------------------------------------------------------------------------- /man/as.ultrametric.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/method-as-ultrametric.R 3 | \name{as.ultrametric} 4 | \alias{as.ultrametric} 5 | \title{as.ultrametric} 6 | \usage{ 7 | as.ultrametric(tree, ...) 8 | } 9 | \arguments{ 10 | \item{tree}{tree object} 11 | 12 | \item{...}{additional parameters} 13 | } 14 | \value{ 15 | treedata or phylo object 16 | } 17 | \description{ 18 | as.ultrametric 19 | } 20 | -------------------------------------------------------------------------------- /man/child.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/offspring.R 3 | \name{child} 4 | \alias{child} 5 | \alias{child.tbl_tree} 6 | \title{child} 7 | \usage{ 8 | child(.data, .node, ...) 9 | 10 | \method{child}{tbl_tree}(.data, .node, ...) 11 | } 12 | \arguments{ 13 | \item{.data}{phylo or tbl_tree object} 14 | 15 | \item{.node}{node number} 16 | 17 | \item{...}{additional parameters} 18 | } 19 | \value{ 20 | child data 21 | } 22 | \description{ 23 | access child data 24 | } 25 | \examples{ 26 | library(ape) 27 | tree <- rtree(4) 28 | x <- as_tibble(tree) 29 | child(x, 4) 30 | } 31 | \author{ 32 | Guangchuang Yu 33 | } 34 | -------------------------------------------------------------------------------- /man/drop.tip-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/method-drop-tip.R 3 | \docType{methods} 4 | \name{drop.tip} 5 | \alias{drop.tip} 6 | \alias{keep.tip} 7 | \alias{drop.tip,treedata-method} 8 | \alias{drop.tip,treedata} 9 | \alias{drop.tip,phylo-method} 10 | \alias{drop.tip,phylo} 11 | \alias{keep.tip,treedata-method} 12 | \alias{keep.tip,phylo-method} 13 | \title{drop.tip method} 14 | \source{ 15 | drop.tip for phylo object is a wrapper method of ape::drop.tip 16 | from the ape package. The documentation you should 17 | read for the drop.tip function can be found here: \link[ape]{drop.tip} 18 | } 19 | \usage{ 20 | drop.tip(object, tip, ...) 21 | 22 | keep.tip(object, tip, ...) 23 | 24 | \S4method{drop.tip}{treedata}(object, tip, ...) 25 | 26 | \S4method{drop.tip}{phylo}(object, tip, ...) 27 | 28 | \S4method{keep.tip}{treedata}(object, tip, ...) 29 | 30 | \S4method{keep.tip}{phylo}(object, tip, ...) 31 | } 32 | \arguments{ 33 | \item{object}{A treedata or phylo object} 34 | 35 | \item{tip}{a vector of mode numeric or character specifying the tips to delete} 36 | 37 | \item{...}{additional parameters} 38 | } 39 | \value{ 40 | updated object 41 | } 42 | \description{ 43 | drop.tip method 44 | } 45 | \examples{ 46 | library(tidytree) 47 | set.seed(123) 48 | tr <- ape::rtree(6) 49 | da <- data.frame(id=tip.label(tr), value = letters[seq_len(6)]) 50 | trda <- tr \%>\% dplyr::left_join(da, by = c('label'='id')) 51 | tr1 <- drop.tip(tr, c("t2", "t1")) 52 | tr2 <- keep.tip(tr, c("t2", "t1")) 53 | } 54 | \seealso{ 55 | \link[ape]{drop.tip} 56 | } 57 | \author{ 58 | Casey Dunn \url{http://dunnlab.org} and Guangchuang Yu \url{https://guangchuangyu.github.io} 59 | } 60 | -------------------------------------------------------------------------------- /man/get.data-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/get-data.R 3 | \docType{methods} 4 | \name{get.data} 5 | \alias{get.data} 6 | \alias{get.data,treedata-method} 7 | \title{get.data method} 8 | \usage{ 9 | get.data(object, ...) 10 | 11 | \S4method{get.data}{treedata}(object) 12 | } 13 | \arguments{ 14 | \item{object}{\code{treedata} object} 15 | 16 | \item{...}{additional parameter} 17 | } 18 | \value{ 19 | associated data of phylogeny 20 | } 21 | \description{ 22 | get.data method 23 | 24 | get.data method 25 | } 26 | -------------------------------------------------------------------------------- /man/get.fields-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/get-fields.R 3 | \docType{methods} 4 | \name{get.fields} 5 | \alias{get.fields} 6 | \alias{get.fields,treedata-method} 7 | \alias{get.fields,treedata} 8 | \title{get.fields method} 9 | \usage{ 10 | get.fields(object, ...) 11 | 12 | \S4method{get.fields}{treedata}(object) 13 | } 14 | \arguments{ 15 | \item{object}{\code{treedata} object} 16 | 17 | \item{...}{additional parameter} 18 | } 19 | \value{ 20 | available annotation variables 21 | } 22 | \description{ 23 | get.fields method 24 | } 25 | -------------------------------------------------------------------------------- /man/get.treetext-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/method-get-treetext.R 3 | \docType{methods} 4 | \name{get.treetext} 5 | \alias{get.treetext} 6 | \alias{get.treetext,treedata-method} 7 | \title{get.treetext method} 8 | \usage{ 9 | get.treetext(object, ...) 10 | 11 | \S4method{get.treetext}{treedata}(object) 12 | } 13 | \arguments{ 14 | \item{object}{treedata object} 15 | 16 | \item{...}{additional parameter} 17 | } 18 | \value{ 19 | phylo object 20 | } 21 | \description{ 22 | access tree text (newick text) from tree object 23 | } 24 | -------------------------------------------------------------------------------- /man/getNodeNum.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/method-groupOTU.R 3 | \name{getNodeNum} 4 | \alias{getNodeNum} 5 | \title{getNodeNum} 6 | \usage{ 7 | getNodeNum(tree) 8 | } 9 | \arguments{ 10 | \item{tree}{tree object} 11 | } 12 | \value{ 13 | number 14 | } 15 | \description{ 16 | calculate total number of nodes 17 | } 18 | \examples{ 19 | getNodeNum(rtree(30)) 20 | } 21 | \author{ 22 | Guangchuang Yu 23 | } 24 | -------------------------------------------------------------------------------- /man/get_tree_data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/as-tibble.R 3 | \name{get_tree_data} 4 | \alias{get_tree_data} 5 | \title{get_tree_data} 6 | \usage{ 7 | get_tree_data(tree_object) 8 | } 9 | \arguments{ 10 | \item{tree_object}{a \code{treedata} object} 11 | } 12 | \value{ 13 | tbl_df 14 | } 15 | \description{ 16 | get associated data stored in treedata object 17 | } 18 | \author{ 19 | guangchuang yu 20 | } 21 | -------------------------------------------------------------------------------- /man/groupClade.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R 3 | \name{groupClade} 4 | \alias{groupClade} 5 | \title{groupClade} 6 | \usage{ 7 | groupClade(.data, .node, group_name = "group", overlap = "overwrite", ...) 8 | } 9 | \arguments{ 10 | \item{.data}{tree object (phylo, treedata, tbl_tree, ggtree etc.)} 11 | 12 | \item{.node}{selected nodes} 13 | 14 | \item{group_name}{character the name of the group cluster, default is \code{group}.} 15 | 16 | \item{overlap}{character one of \code{overwrite},\code{origin} and \code{abandon}, 17 | default is \code{overwrite}.} 18 | 19 | \item{...}{additional parameter} 20 | } 21 | \value{ 22 | updated tree with group information or group index 23 | } 24 | \description{ 25 | grouping clades 26 | } 27 | \author{ 28 | Guangchuang Yu 29 | } 30 | -------------------------------------------------------------------------------- /man/groupOTU.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R 3 | \name{groupOTU} 4 | \alias{groupOTU} 5 | \title{groupOTU} 6 | \usage{ 7 | groupOTU(.data, .node, group_name = "group", ...) 8 | } 9 | \arguments{ 10 | \item{.data}{tree object (phylo, treedata, tbl_tree, ggtree etc.)} 11 | 12 | \item{.node}{selected nodes} 13 | 14 | \item{group_name}{character the name of the group cluster, default is \code{group}.} 15 | 16 | \item{...}{additional parameter} 17 | } 18 | \value{ 19 | updated tree with group information or group index 20 | } 21 | \description{ 22 | grouping OTUs 23 | } 24 | \author{ 25 | Guangchuang Yu 26 | } 27 | -------------------------------------------------------------------------------- /man/isTip.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/isTip.R 3 | \name{isTip} 4 | \alias{isTip} 5 | \alias{isTip.tbl_tree} 6 | \alias{isTip.phylo} 7 | \alias{isTip.treedata} 8 | \title{isTip} 9 | \usage{ 10 | isTip(.data, .node, ...) 11 | 12 | \method{isTip}{tbl_tree}(.data, .node, ...) 13 | 14 | \method{isTip}{phylo}(.data, .node, ...) 15 | 16 | \method{isTip}{treedata}(.data, .node, ...) 17 | } 18 | \arguments{ 19 | \item{.data}{phylo, treedata or tbl_tree object} 20 | 21 | \item{.node}{node number} 22 | 23 | \item{...}{additional parameters} 24 | } 25 | \value{ 26 | logical value 27 | } 28 | \description{ 29 | whether the node is a tip 30 | } 31 | \author{ 32 | Guangchuang Yu 33 | } 34 | -------------------------------------------------------------------------------- /man/node.label.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/method-accessor.R 3 | \name{node.label} 4 | \alias{node.label} 5 | \title{extract the node label of phylo, treedata or tbl_tree} 6 | \usage{ 7 | node.label(x, node = "internal", ...) 8 | } 9 | \arguments{ 10 | \item{x}{object, should be one of \code{treedata},\code{phylo} or \code{tbl_tree}.} 11 | 12 | \item{node}{character, to extract which type node label, 13 | default is \code{internal}, should be one of \code{internal}, 14 | \code{external}, \code{all}, \code{tip}.} 15 | 16 | \item{...}{additional parameters.} 17 | } 18 | \value{ 19 | label character vector. 20 | } 21 | \description{ 22 | extract the node label of phylo, treedata or tbl_tree 23 | } 24 | -------------------------------------------------------------------------------- /man/nodeid.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R 3 | \name{nodeid} 4 | \alias{nodeid} 5 | \title{nodeid} 6 | \usage{ 7 | nodeid(tree, label) 8 | } 9 | \arguments{ 10 | \item{tree}{tree object} 11 | 12 | \item{label}{tip/node label(s)} 13 | } 14 | \value{ 15 | node number 16 | } 17 | \description{ 18 | convert tree label to internal node number 19 | } 20 | \author{ 21 | Guangchuang Yu 22 | } 23 | -------------------------------------------------------------------------------- /man/nodelab.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R 3 | \name{nodelab} 4 | \alias{nodelab} 5 | \title{nodelab} 6 | \usage{ 7 | nodelab(tree, id) 8 | } 9 | \arguments{ 10 | \item{tree}{tree object} 11 | 12 | \item{id}{node number} 13 | } 14 | \value{ 15 | tip/node label(s) 16 | } 17 | \description{ 18 | convert internal node number tip/node label 19 | } 20 | \author{ 21 | Guangchuang Yu 22 | } 23 | -------------------------------------------------------------------------------- /man/offspring.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/offspring.R 3 | \name{offspring} 4 | \alias{offspring} 5 | \alias{offspring.tbl_tree} 6 | \title{offspring} 7 | \usage{ 8 | offspring(.data, .node, tiponly, self_include, ...) 9 | 10 | \method{offspring}{tbl_tree}(.data, .node, tiponly = FALSE, self_include = FALSE, ...) 11 | } 12 | \arguments{ 13 | \item{.data}{phylo or tbl_tree object} 14 | 15 | \item{.node}{node number} 16 | 17 | \item{tiponly}{whether only return tip nodes} 18 | 19 | \item{self_include}{whether include the input node, 20 | only applicable for tiponly = FALSE} 21 | 22 | \item{...}{additional parameters} 23 | } 24 | \value{ 25 | offspring data 26 | } 27 | \description{ 28 | access offspring data 29 | } 30 | \examples{ 31 | library(ape) 32 | tree <- rtree(4) 33 | x <- as_tibble(tree) 34 | offspring(x, 4) 35 | } 36 | \author{ 37 | Guangchuang Yu 38 | } 39 | -------------------------------------------------------------------------------- /man/parent.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/ancestor.R 3 | \name{parent} 4 | \alias{parent} 5 | \alias{parent.tbl_tree} 6 | \title{parent} 7 | \usage{ 8 | parent(.data, .node, ...) 9 | 10 | \method{parent}{tbl_tree}(.data, .node, ...) 11 | } 12 | \arguments{ 13 | \item{.data}{phylo or tbl_tree object} 14 | 15 | \item{.node}{node number} 16 | 17 | \item{...}{additional parameters} 18 | } 19 | \value{ 20 | parent data 21 | } 22 | \description{ 23 | access parent data 24 | } 25 | \examples{ 26 | library(ape) 27 | tree <- rtree(4) 28 | x <- as_tibble(tree) 29 | parent(x, 2) 30 | } 31 | \author{ 32 | Guangchuang Yu 33 | } 34 | -------------------------------------------------------------------------------- /man/reexports.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R, R/ape.R, R/reexports.R 3 | \docType{import} 4 | \name{reexports} 5 | \alias{reexports} 6 | \alias{as.phylo} 7 | \alias{Nnode} 8 | \alias{rtree} 9 | \alias{read.tree} 10 | \alias{Ntip} 11 | \alias{is.rooted} 12 | \alias{root} 13 | \alias{\%>\%} 14 | \alias{\%<>\%} 15 | \alias{as_tibble} 16 | \alias{tibble} 17 | \alias{filter} 18 | \alias{arrange} 19 | \alias{select} 20 | \alias{rename} 21 | \alias{mutate} 22 | \alias{transmute} 23 | \alias{summarise} 24 | \alias{summarize} 25 | \alias{full_join} 26 | \alias{.data} 27 | \alias{left_join} 28 | \alias{pull} 29 | \alias{unnest} 30 | \title{Objects exported from other packages} 31 | \keyword{internal} 32 | \description{ 33 | These objects are imported from other packages. Follow the links 34 | below to see their documentation. 35 | 36 | \describe{ 37 | \item{ape}{\code{\link[ape]{as.phylo}}, \code{\link[ape]{as.phylo}}, \code{\link[ape:root]{is.rooted}}, \code{\link[ape:summary.phylo]{Nnode}}, \code{\link[ape:summary.phylo]{Ntip}}, \code{\link[ape]{read.tree}}, \code{\link[ape]{root}}, \code{\link[ape]{rtree}}} 38 | 39 | \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr:mutate-joins]{full_join}}, \code{\link[dplyr:mutate-joins]{left_join}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{pull}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{select}}, \code{\link[dplyr]{summarise}}, \code{\link[dplyr:summarise]{summarize}}, \code{\link[dplyr]{transmute}}} 40 | 41 | \item{magrittr}{\code{\link[magrittr:compound]{\%<>\%}}, \code{\link[magrittr:pipe]{\%>\%}}} 42 | 43 | \item{rlang}{\code{\link[rlang:dot-data]{.data}}} 44 | 45 | \item{tibble}{\code{\link[tibble]{as_tibble}}, \code{\link[tibble]{tibble}}} 46 | 47 | \item{tidyr}{\code{\link[tidyr]{unnest}}} 48 | }} 49 | 50 | -------------------------------------------------------------------------------- /man/root-method.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/method-reroot.R 3 | \name{root.treedata} 4 | \alias{root.treedata} 5 | \title{root} 6 | \usage{ 7 | \method{root}{treedata}(phy, outgroup, node = NULL, edgelabel = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{phy}{tree object} 11 | 12 | \item{outgroup}{a vector of mode numeric or character specifying the new outgroup} 13 | 14 | \item{node}{node to reroot} 15 | 16 | \item{edgelabel}{a logical value specifying whether to treat node labels as 17 | edge labels and thus eventually switching them so that they are associated 18 | with the correct edges.} 19 | 20 | \item{...}{additional parameters passed to ape::root.phylo} 21 | } 22 | \value{ 23 | rerooted treedata 24 | } 25 | \description{ 26 | re-root a tree 27 | } 28 | -------------------------------------------------------------------------------- /man/rootnode.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R 3 | \name{rootnode} 4 | \alias{rootnode} 5 | \title{rootnode} 6 | \usage{ 7 | rootnode(.data, ...) 8 | } 9 | \arguments{ 10 | \item{.data}{phylo or tbl_tree object} 11 | 12 | \item{...}{additional parameters} 13 | } 14 | \value{ 15 | root node data 16 | } 17 | \description{ 18 | access root node data 19 | } 20 | \author{ 21 | Guangchuang Yu 22 | } 23 | -------------------------------------------------------------------------------- /man/show-methods.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/show.R 3 | \docType{methods} 4 | \name{show} 5 | \alias{show} 6 | \title{show method} 7 | \usage{ 8 | show(object) 9 | } 10 | \arguments{ 11 | \item{object}{\code{treedata} object} 12 | } 13 | \value{ 14 | print info 15 | } 16 | \description{ 17 | show method for \code{treedata} instance 18 | } 19 | \author{ 20 | Guangchuang Yu \url{https://guangchuangyu.github.io} 21 | } 22 | -------------------------------------------------------------------------------- /man/sibling.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllGenerics.R 3 | \name{sibling} 4 | \alias{sibling} 5 | \title{sibling} 6 | \usage{ 7 | sibling(.data, ...) 8 | } 9 | \arguments{ 10 | \item{.data}{phylo or tbl_tree object} 11 | 12 | \item{...}{additional parameters} 13 | } 14 | \value{ 15 | sibling 16 | } 17 | \description{ 18 | access sibling data 19 | } 20 | \author{ 21 | Guangchuang Yu 22 | } 23 | -------------------------------------------------------------------------------- /man/td-label-assign.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/method-accessor.R 3 | \name{td-label-assign} 4 | \alias{td-label-assign} 5 | \alias{tip.label<-} 6 | \alias{node.label<-} 7 | \alias{node.label<-.phylo} 8 | \alias{node.label<-.treedata} 9 | \alias{node.label<-.tbl_tree} 10 | \alias{tip.label<-.phylo} 11 | \alias{tip.label<-.treedata} 12 | \alias{tip.label<-.tbl_tree} 13 | \title{the tip or internal node label assign of tbl_tree phylo and treedata} 14 | \usage{ 15 | tip.label(x) <- value 16 | 17 | node.label(x) <- value 18 | 19 | \method{node.label}{phylo}(x) <- value 20 | 21 | \method{node.label}{treedata}(x) <- value 22 | 23 | \method{node.label}{tbl_tree}(x) <- value 24 | 25 | \method{tip.label}{phylo}(x) <- value 26 | 27 | \method{tip.label}{treedata}(x) <- value 28 | 29 | \method{tip.label}{tbl_tree}(x) <- value 30 | } 31 | \arguments{ 32 | \item{x}{object, should be one of \code{tbl_tree}, \code{phylo} or \code{treedata}} 33 | 34 | \item{value}{character, the character vector} 35 | } 36 | \description{ 37 | the tip or internal node label assign of tbl_tree phylo and treedata 38 | } 39 | -------------------------------------------------------------------------------- /man/tidytree-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tidy-package.R 3 | \docType{package} 4 | \name{tidytree-package} 5 | \alias{tidytree} 6 | \alias{tidytree-package} 7 | \title{tidytree: A Tidy Tool for Phylogenetic Tree Data Manipulation} 8 | \description{ 9 | Phylogenetic tree generally contains multiple components including node, edge, branch and associated data. 'tidytree' provides an approach to convert tree object to tidy data frame as well as provides tidy interfaces to manipulate tree data. 10 | } 11 | \seealso{ 12 | Useful links: 13 | \itemize{ 14 | \item \url{https://www.amazon.com/Integration-Manipulation-Visualization-Phylogenetic-Computational-ebook/dp/B0B5NLZR1Z/} 15 | \item Report bugs at \url{https://github.com/YuLab-SMU/tidytree/issues} 16 | } 17 | 18 | } 19 | \author{ 20 | \strong{Maintainer}: Guangchuang Yu \email{guangchuangyu@gmail.com} (\href{https://orcid.org/0000-0002-6485-8781}{ORCID}) [copyright holder] 21 | 22 | Other contributors: 23 | \itemize{ 24 | \item Bradley Jones \email{brj1@sfu.ca} [contributor] 25 | \item Zebulun Arendsee \email{zbwrnz@gmail.com} [contributor] 26 | } 27 | 28 | } 29 | \keyword{internal} 30 | -------------------------------------------------------------------------------- /man/tip.label.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/method-accessor.R 3 | \name{tip.label} 4 | \alias{tip.label} 5 | \title{extract the tip label of phylo treedata or tbl_tree} 6 | \usage{ 7 | tip.label(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object, should be one of \code{treedata},\code{phylo} or \code{tbl_tree}.} 11 | 12 | \item{...}{additional parameters.} 13 | } 14 | \description{ 15 | extract the tip label of phylo treedata or tbl_tree 16 | } 17 | -------------------------------------------------------------------------------- /man/tree_subset.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tree-subset.R 3 | \name{tree_subset} 4 | \alias{tree_subset} 5 | \alias{tree_subset.phylo} 6 | \alias{tree_subset.treedata} 7 | \title{Subset tree objects by related nodes} 8 | \usage{ 9 | tree_subset( 10 | tree, 11 | node, 12 | levels_back = 5, 13 | group_node = TRUE, 14 | group_name = "group", 15 | root_edge = TRUE 16 | ) 17 | 18 | \method{tree_subset}{phylo}( 19 | tree, 20 | node, 21 | levels_back = 5, 22 | group_node = TRUE, 23 | group_name = "group", 24 | root_edge = TRUE 25 | ) 26 | 27 | \method{tree_subset}{treedata}( 28 | tree, 29 | node, 30 | levels_back = 5, 31 | group_node = TRUE, 32 | group_name = "group", 33 | root_edge = TRUE 34 | ) 35 | } 36 | \arguments{ 37 | \item{tree}{a tree object of class phylo} 38 | 39 | \item{node}{either a tip label or a node number for the given 40 | tree that will be the focus of the subsetted tree} 41 | 42 | \item{levels_back}{a number specifying how many nodes back from 43 | the selected node the subsetted tree should include} 44 | 45 | \item{group_node}{whether add grouping information of selected node} 46 | 47 | \item{group_name}{group name (default 'group') for storing grouping information if group_node = TRUE} 48 | 49 | \item{root_edge}{If TRUE (by default), set root.edge to path length of orginal root to the root of subset tree} 50 | } 51 | \description{ 52 | This function allows for a tree object to be subset by specifying a 53 | node and returns all related nodes within a selected number of 54 | levels 55 | } 56 | \details{ 57 | This function will take a tree and a specified node from 58 | that tree and subset the tree showing all relatives back to a specified 59 | number of nodes. This function allows for a combination of 60 | \code{ancestor} and \code{offspring} to return a subsetted 61 | tree that is of class phylo. This allows for easy graphing of the tree 62 | with \code{ggtree} 63 | } 64 | \examples{ 65 | set.seed(123) 66 | tree <- ape::rtree(6) 67 | sub_tree <- tree_subset(tree, node = "t1", levels_back = 2) 68 | } 69 | -------------------------------------------------------------------------------- /man/treedata-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllClasses.R 3 | \docType{class} 4 | \name{treedata-class} 5 | \alias{treedata-class} 6 | \alias{show,treedata-method} 7 | \title{Class "treedata" 8 | This class stores phylogenetic tree with associated data} 9 | \description{ 10 | Class "treedata" 11 | This class stores phylogenetic tree with associated data 12 | } 13 | \section{Slots}{ 14 | 15 | \describe{ 16 | \item{\code{file}}{tree file} 17 | 18 | \item{\code{treetext}}{newick tree string} 19 | 20 | \item{\code{phylo}}{phylo object for tree structure} 21 | 22 | \item{\code{data}}{associated data} 23 | 24 | \item{\code{extraInfo}}{extra information, reserve for merge_tree} 25 | 26 | \item{\code{tip_seq}}{tip sequences} 27 | 28 | \item{\code{anc_seq}}{ancestral sequences} 29 | 30 | \item{\code{seq_type}}{sequence type, one of NT or AA} 31 | 32 | \item{\code{tipseq_file}}{tip sequence file} 33 | 34 | \item{\code{ancseq_file}}{ancestral sequence file} 35 | 36 | \item{\code{info}}{extra information, e.g. metadata, software version etc.} 37 | }} 38 | 39 | \author{ 40 | Guangchuang Yu \url{https://guangchuangyu.github.io} 41 | } 42 | \keyword{classes} 43 | -------------------------------------------------------------------------------- /man/treedata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/AllClasses.R 3 | \name{treedata} 4 | \alias{treedata} 5 | \title{treedata} 6 | \usage{ 7 | treedata(...) 8 | } 9 | \arguments{ 10 | \item{...}{parameters} 11 | } 12 | \value{ 13 | treedata object 14 | } 15 | \description{ 16 | treedata object contructor 17 | } 18 | \author{ 19 | guangchuang yu 20 | } 21 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(tidytree) 3 | 4 | test_check("tidytree") 5 | -------------------------------------------------------------------------------- /tests/testthat/test-access-related-nodes.R: -------------------------------------------------------------------------------- 1 | context("related_nodes") 2 | 3 | library(ape) 4 | library(tidytree) 5 | 6 | ## R-devel has recently changed the default RNG kind: 7 | 8 | ## \item The default method for generating from a discrete uniform 9 | ## distribution (used in \code{sample()}, for instance) has been 10 | ## changed. This addresses the fact, pointed out by Ottoboni and 11 | ## Stark, that the previous method made \code{sample()} noticeably 12 | ## non-uniform on large populations. See \PR{17494} for a 13 | ## discussion. The previous method can be requested using 14 | ## \code{RNGkind()} if necessary for reproduction of old results. 15 | ## Thanks to Duncan Murdoch for contributing the patch and Gabe 16 | ## Becker for further assistance. 17 | 18 | ## and one should be able to reproduce the Debian error using a current 19 | ## version of R-devel (assuming that it builds). 20 | 21 | ## My suggestion is to disable tests affected by this for the time being. 22 | 23 | ## ----------------------------------------------------------------------- 24 | ## 25 | ## set.seed(42) 26 | ## # sample bifurcating tree 27 | ## bi_tree <- ape::rtree(10) 28 | ## bi_tree$tip.label <- paste0("t", 1:10) 29 | 30 | ## nwk is generated by the above source code in R-3.5.2 with ape v5.2 31 | nwk <- paste0("(((((t1:0.9040313873,t2:0.1387101677):0.5603327462,", 32 | "t3:0.9888917289):0.4749970816,(((t4:0.3902034671,t5:0.9057381309):", 33 | "0.5142117843,t6:0.4469696281):0.0824375581,(t7:0.7375956178,", 34 | "t8:0.8110551413):0.83600426):0.9466682326):0.1174873617,", 35 | "t9:0.3881082828):0.9782264284,t10:0.6851697294);") 36 | 37 | bi_tree <- read.tree(text = nwk) 38 | 39 | # sample non-bifurcating tree 40 | multi_tree <- ape::di2multi(bi_tree, tol=0.5) 41 | # bifurcating tree with node names 42 | named_bi_tree <- bi_tree 43 | named_bi_tree$node.label <- paste0("n", 11:19) 44 | # non-bifurcating tree with node names 45 | named_multi_tree <- multi_tree 46 | named_multi_tree$node.label <- paste0("n", 11:16) 47 | 48 | empty_tbl <- tibble::tibble( 49 | parent=integer(0), 50 | node=integer(0), 51 | branch.length=numeric(0), 52 | label=character(0) 53 | ) 54 | 55 | test_that("conversion to table is reversible", { 56 | expect_equal(as.phylo(as_tibble(bi_tree)), bi_tree) 57 | expect_equal(as.phylo(as_tibble(multi_tree)), multi_tree) 58 | expect_equal(as.phylo(as_tibble(named_bi_tree)), named_bi_tree) 59 | expect_equal(as.phylo(as_tibble(named_multi_tree)), named_multi_tree) 60 | }) 61 | 62 | test_that("child works for bifurcating trees", { 63 | # a leaf has no children 64 | ## expect_equal(child(as_tibble(bi_tree), 1), empty_tbl) 65 | expect_equal(nrow(child(as_tibble(bi_tree), 1)), 0) 66 | # can find node children 67 | expect_equal(child(as_tibble(bi_tree), 19)$node, 7:8) 68 | # can find root children 69 | expect_equal(child(as_tibble(bi_tree), 11)$node, c(10,12)) 70 | }) 71 | 72 | test_that("child works for non-bifurcating trees", { 73 | # a leaf has no children 74 | ## expect_equal(child(as_tibble(multi_tree), 1), empty_tbl) 75 | expect_equal(nrow(child(as_tibble(multi_tree), 1)), 0) 76 | # can find node children 77 | expect_equal(child(as_tibble(multi_tree), 12)$node, c(3,9,13,14)) 78 | # can find root children 79 | expect_equal(child(as_tibble(multi_tree), 11)$node, c(10,12)) 80 | }) 81 | 82 | test_that("offspring works on bifurcating trees", { 83 | ## expect_equal(offspring(as_tibble(bi_tree), 1), empty_tbl) 84 | expect_equal(nrow(offspring(as_tibble(bi_tree), 1)), 0) 85 | expect_equal(offspring(as_tibble(bi_tree), 11)$node, (1:19)[-11]) 86 | expect_equal(offspring(as_tibble(bi_tree), 17)$node, c(4:6, 18)) 87 | }) 88 | 89 | test_that("offspring works on non-bifurcating trees", { 90 | ## expect_equal(offspring(as_tibble(multi_tree), 1), empty_tbl) 91 | expect_equal(nrow(offspring(as_tibble(multi_tree), 1)), 0) 92 | expect_equal(offspring(as_tibble(multi_tree), 11)$node, (1:16)[-11]) 93 | expect_equal(offspring(as_tibble(multi_tree), 14)$node, c(4:8, 15:16)) 94 | }) 95 | 96 | test_that("parent works for bifurcating trees", { 97 | ## expect_equal(parent(as_tibble(bi_tree), 11), empty_tbl) 98 | expect_equal(nrow(parent(as_tibble(bi_tree), 11)), 0) 99 | expect_equal(parent(as_tibble(bi_tree), 1)$node, 15) 100 | expect_equal(parent(as_tibble(bi_tree), 17)$node, 16) 101 | }) 102 | 103 | test_that("parent works for non-bifurcating trees", { 104 | ## expect_equal(parent(as_tibble(multi_tree), 11), empty_tbl) 105 | expect_equal(nrow(parent(as_tibble(multi_tree), 11)), 0) 106 | expect_equal(parent(as_tibble(multi_tree), 8)$node, 16) 107 | expect_equal(parent(as_tibble(multi_tree), 14)$node, 12) 108 | }) 109 | 110 | test_that("ancestor works for bifurcating trees", { 111 | ## expect_equal(ancestor(as_tibble(bi_tree), 11), empty_tbl) 112 | expect_equal(nrow(ancestor(as_tibble(bi_tree), 11)), 0) 113 | expect_equal(ancestor(as_tibble(bi_tree), 1)$node, 11:15) 114 | expect_equal(ancestor(as_tibble(bi_tree), 17)$node, c(11:13, 16)) 115 | }) 116 | 117 | test_that("ancestor works for non-bifurcating trees", { 118 | ## expect_equal(ancestor(as_tibble(multi_tree), 11), empty_tbl) 119 | expect_equal(nrow(ancestor(as_tibble(multi_tree), 11)), 0) 120 | expect_equal(ancestor(as_tibble(multi_tree), 8)$node, c(11,12,14,16)) 121 | expect_equal(ancestor(as_tibble(multi_tree), 14)$node, 11:12) 122 | }) 123 | 124 | 125 | test_that("MRCA works for bifurcating trees", { 126 | ## 11 is the root node 127 | ## expect_equal(MRCA(as_tibble(multi_tree), 11, 5), empty_tbl) 128 | expect_equal(nrow(MRCA(as_tibble(multi_tree), 11, 5)), 0) 129 | expect_equal(MRCA(as_tibble(bi_tree), 5, 7)$node, 16) 130 | ## 16 is ancestor of 5 131 | expect_equal(MRCA(as_tibble(bi_tree), 5, 16)$node, 16) 132 | }) 133 | 134 | test_that("MRCA works for non-bifurcating trees", { 135 | ## expect_equal(MRCA(as_tibble(multi_tree), 11, 5), empty_tbl) 136 | expect_equal(nrow(MRCA(as_tibble(multi_tree), 11, 5)), 0) 137 | expect_equal(MRCA(as_tibble(multi_tree), 5, 7)$node, 14) 138 | expect_equal(MRCA(as_tibble(multi_tree), 5, 14)$node, 14) 139 | }) 140 | 141 | 142 | test_that("sibling works for bifurcating trees", { 143 | ## expect_equal(sibling(as_tibble(bi_tree), 11), empty_tbl) 144 | expect_equal(nrow(sibling(as_tibble(bi_tree), 11)), 0) 145 | expect_equal(sibling(as_tibble(bi_tree), 1)$node, 2) 146 | expect_equal(sibling(as_tibble(bi_tree), 17)$node, 19) 147 | }) 148 | 149 | test_that("sibling works for non-bifurcating trees", { 150 | ## expect_equal(sibling(as_tibble(multi_tree), 11), empty_tbl) 151 | expect_equal(nrow(sibling(as_tibble(multi_tree), 11)), 0) 152 | expect_equal(sibling(as_tibble(multi_tree), 12)$node, 10) 153 | expect_equal(sibling(as_tibble(multi_tree), 3)$node, c(9,13,14)) 154 | expect_equal(sibling(as_tibble(multi_tree), 4)$node, 5) 155 | }) 156 | 157 | # sample non-bifurcating tree 158 | multi_tree <- ape::di2multi(bi_tree, tol=0.5) 159 | # bifurcating tree with node names 160 | named_bi_tree <- bi_tree 161 | named_bi_tree$node.label <- paste0("n", 11:19) 162 | # non-bifurcating tree with node names 163 | named_multi_tree <- multi_tree 164 | named_multi_tree$node.label <- paste0("n", 11:16) 165 | 166 | 167 | test_that("child works for bifurcating trees", { 168 | # a leaf has no children 169 | expect_equal(child(bi_tree, 1), integer(0)) 170 | # can find node children 171 | expect_equal(sort(child(bi_tree, 19)), 7:8) 172 | # can find root children 173 | expect_equal(sort(child(bi_tree, 11)), c(10,12)) 174 | }) 175 | 176 | test_that("child works for non-bifurcating trees", { 177 | # a leaf has no children 178 | expect_equal(child(multi_tree, 1), integer(0)) 179 | # can find node children 180 | expect_equal(sort(child(multi_tree, 12)), c(3,9,13,14)) 181 | # can find root children 182 | expect_equal(sort(child(multi_tree, 11)), c(10,12)) 183 | }) 184 | 185 | test_that("offspring works on bifurcating trees", { 186 | expect_equal(sort(offspring(bi_tree, 11)), (1:19)[-11]) 187 | expect_equal(sort(offspring(bi_tree, 17)), c(4:6, 18)) 188 | expect_equal(offspring(bi_tree, 1), integer(0)) 189 | }) 190 | 191 | test_that("offspring works on non-bifurcating trees", { 192 | expect_equal(sort(offspring(multi_tree, 11)), (1:16)[-11]) 193 | expect_equal(sort(offspring(multi_tree, 14)), c(4:8, 15:16)) 194 | expect_equal(offspring(multi_tree, 1), integer(0)) 195 | }) 196 | 197 | test_that("parent works for bifurcating trees", { 198 | expect_equal(tidytree:::parent.phylo(bi_tree, 11), 0) 199 | expect_equal(parent(bi_tree, 1), 15) 200 | expect_equal(parent(bi_tree, 17), 16) 201 | expect_error(parent(bi_tree, 20)) 202 | }) 203 | 204 | test_that("parent works for non-bifurcating trees", { 205 | expect_equal(parent(multi_tree, 11), 0) 206 | expect_equal(parent(multi_tree, 8), 16) 207 | expect_equal(parent(multi_tree, 14), 12) 208 | expect_error(parent(multi_tree, 20)) 209 | }) 210 | 211 | 212 | test_that("ancestor works for bifurcating trees", { 213 | expect_equal(tidytree:::ancestor.phylo(bi_tree, 11), NA) 214 | expect_equal(sort(ancestor(bi_tree, 1)), 11:15) 215 | expect_equal(sort(ancestor(bi_tree, 17)), c(11:13, 16)) 216 | expect_error(ancestor(multi_tree, 20)) 217 | }) 218 | 219 | test_that("ancestor works for non-bifurcating trees", { 220 | expect_equal(ancestor(multi_tree, 11), NA) 221 | expect_equal(sort(ancestor(multi_tree, 8)), c(11,12,14,16)) 222 | expect_equal(sort(ancestor(multi_tree, 14)), 11:12) 223 | expect_error(ancestor(multi_tree, 20)) 224 | }) 225 | 226 | test_that("rootnode", { 227 | expect_equal(tidytree:::rootnode.phylo(bi_tree), 11) 228 | expect_equal(rootnode(multi_tree), 11) 229 | }) 230 | 231 | 232 | new_edge <- c(11, 15) 233 | bi_tree$edge <- rbind(bi_tree$edge, new_edge) 234 | multi_tree$edge <- rbind(multi_tree$edge, new_edge) 235 | test_that("throw error if multiple parent exists", { 236 | expect_error(tidytree:::parent.phylo(bi_tree, 15), "multiple parent found...") 237 | expect_error(parent(multi_tree, 15), "multiple parent found...") 238 | }) 239 | 240 | 241 | new_edge <- c(20, 15) 242 | bi_tree$edge <- rbind(bi_tree$edge, new_edge) 243 | multi_tree$edge <- rbind(multi_tree$edge, new_edge) 244 | test_that("throw error if multiple roots found", { 245 | expect_error(rootnode(bi_tree), "multiple roots found...") 246 | expect_error(rootnode(multi_tree), "multiple roots found...") 247 | }) 248 | -------------------------------------------------------------------------------- /tests/testthat/test-assign.R: -------------------------------------------------------------------------------- 1 | context("assign and access label methods") 2 | 3 | test_that("accessor and assignment label method for phylo, tbl_tree and treedata",{ 4 | tr <- ape::rtree(4) 5 | tr.da <- treedata(phylo=tr) 6 | tr.df <- as_tibble(tr) 7 | 8 | new.lab <- c('a', 'b', 'c', 'd') 9 | 10 | tip.label(tr) <- new.lab 11 | tip.label(tr.da) <- new.lab 12 | tip.label(tr.df) <- new.lab 13 | 14 | expect_equal(tip.label(tr), new.lab) 15 | expect_equal(tip.label(tr.da), new.lab) 16 | expect_equal(tip.label(tr.df), new.lab) 17 | 18 | node.lab <- c('node1', 'node2', 'node3') 19 | node.label(tr) <- node.lab 20 | node.label(tr.da) <- node.lab 21 | node.label(tr.df) <- node.lab 22 | 23 | expect_equal(node.label(tr), node.lab) 24 | expect_equal(node.label(tr.da), node.lab) 25 | expect_equal(node.label(tr.df), node.lab) 26 | } 27 | ) 28 | -------------------------------------------------------------------------------- /tests/testthat/test-dplyr-methods.R: -------------------------------------------------------------------------------- 1 | context("dplyr-methods") 2 | 3 | nwk <- '(((((((A:4,B:4):6,C:5):8,D:6):3,E:21):10,((F:4,G:12):14,H:8):13):13,((I:5,J:2):30,(K:11,L:11):2):17):4,M:56);' 4 | dat <- tibble(node=c(1, 2, 3, 4, 5), group=c("A", "A", "A", "B", "B"), test=c(10, 20, 30, 40, 50)) 5 | 6 | tree <- treedata(phylo=read.tree(text=nwk), data = dat) 7 | 8 | test_that("select fields from treedata and return tbl_df directly ",{ 9 | expect_equal(tree %>% select(group) %>% nrow(), tree %>% as_tibble() %>% nrow()) 10 | expect_equal(tree %>% select(node, group) %>% filter(!is.na(group)) %>% nrow(), dat %>% nrow()) 11 | }) 12 | 13 | test_that("select fields from treedata and return treedata",{ 14 | expect_true(inherits(tree %>% select(-group, keep.td=TRUE), "treedata")) 15 | expect_true(inherits(tree %>% select(-c(group, test), keep.td=TRUE), "treedata")) 16 | expect_equal(tree %>% select(-test, keep.td=TRUE) %>% get.fields, "group") 17 | }) 18 | 19 | test_that("filter fields for treedata and return tbl_df directly",{ 20 | expect_equal(tree %>% 21 | filter(group=="A", keep.td=FALSE) %>% 22 | nrow(), 23 | dat %>% 24 | filter(group=="A") %>% 25 | nrow() 26 | ) 27 | expect_equal(tree %>% 28 | filter(group=="A" & test>=20, keep.td=FALSE) %>% 29 | nrow(), 30 | dat %>% 31 | filter(group=="A" & test>=20) %>% 32 | nrow() 33 | ) 34 | }) 35 | 36 | test_that("filter fields for treedata and return treedata", { 37 | expect_true(inherits(tree %>% filter(group=="A", keep.td=TRUE), "treedata")) 38 | tree2 <- tree %>% filter(group=="A" & test>=20, keep.td=TRUE) 39 | expect_equal(tree2@data %>% 40 | filter(!is.na(group)) %>% 41 | nrow(), 42 | dat %>% 43 | filter(group=="A" & test>=20) %>% 44 | nrow() 45 | ) 46 | }) 47 | 48 | test_that("mutate fields for treedata and return tbl_df", { 49 | expect_equal(tree %>% 50 | mutate(type="A", keep.td=FALSE) %>% 51 | nrow(), 52 | tree %>% 53 | as_tibble() %>% 54 | nrow() 55 | ) 56 | 57 | expect_equal(tree %>% 58 | mutate(test="A", keep.td=FALSE) %>% 59 | colnames(), 60 | c("node", "label", "isTip", colnames(dat)[-1]) 61 | ) 62 | 63 | }) 64 | 65 | test_that("mutate fields for treedata and return treedata", { 66 | expect_true(inherits(tree %>% 67 | mutate(type="A", keep.td=TRUE), 68 | "treedata") 69 | ) 70 | tree2 <- tree %>% mutate(type="A", keep.td=TRUE) 71 | expect_equal(tree2@extraInfo %>% nrow(), 72 | ape::Nnode(tree@phylo, internal.only=FALSE) 73 | ) 74 | }) 75 | 76 | test_that("left_join for treedata",{ 77 | set.seed(123) 78 | df <- data.frame(label=tree@phylo$tip.label, value=abs(rnorm(length(tree@phylo$tip.label)))) 79 | N <- ape::Nnode(tree@phylo, internal.only=FALSE) 80 | dt <- data.frame(ind=rep(seq_len(N), 2), group=rep(c("A","B"), each=N)) 81 | 82 | tr2 <- tree %>% left_join(df, by="label") 83 | 84 | tr3 <- tree %>% left_join(dt, by=c("node"="ind")) 85 | 86 | expect_true(inherits(tr2, "treedata")) 87 | 88 | expect_true(inherits(tr3, "treedata")) 89 | 90 | expect_equal(tree %>% 91 | as_tibble() %>% 92 | nrow(), 93 | tr3 %>% 94 | as_tibble() %>% 95 | nrow()) 96 | 97 | expect_equal(tr3 %>% 98 | select("node", "group.y") %>% 99 | tidyr::unnest("group.y") %>% 100 | dplyr::rename(ind="node", group="group.y"), 101 | dt %>% 102 | tibble::as_tibble() %>% 103 | dplyr::arrange(ind) 104 | ) 105 | }) 106 | 107 | test_that("pull for treedata",{ 108 | expect_equal(tree %>% 109 | pull(label, name=node), 110 | tree %>% 111 | as_tibble() %>% 112 | pull(label, name=node) 113 | ) 114 | }) 115 | 116 | test_that("rename for treedata", { 117 | expect_equal(tree %>% 118 | rename(type=test) %>% 119 | select(node, group, type) %>% 120 | dplyr::slice(seq_len(5)), 121 | tree@data %>% 122 | rename(type=test) 123 | ) 124 | dat <- data.frame(node=c(1, 2, 3, 4, 5), GT="b", BMW="a") 125 | tree %<>% left_join(dat, by="node") 126 | 127 | expect_equal(tree %>% 128 | rename(Group=GT, BW=BMW) %>% 129 | select(node, Group, BW), 130 | tree@extraInfo %>% 131 | rename(Group=GT, BW=BMW) 132 | ) 133 | }) 134 | -------------------------------------------------------------------------------- /tests/testthat/test-drop.tip.R: -------------------------------------------------------------------------------- 1 | context("drop.tip and keep.tip") 2 | 3 | test_that("drop.tip and keep.tip for treedata",{ 4 | set.seed(123) 5 | tr <- ape::rtree(6) 6 | da <- data.frame(id=tip.label(tr), value = letters[seq_len(6)]) 7 | trda <- tr %>% dplyr::left_join(da, by = c('label'='id')) 8 | toDrop <- c("t2", "t1") 9 | toKeep <- setdiff(tip.label(trda), toDrop) 10 | tr1 <- drop.tip(trda, toDrop) 11 | tr2 <- keep.tip(trda, toKeep) 12 | expect_equal(tr1, tr2) 13 | }) 14 | 15 | -------------------------------------------------------------------------------- /tests/testthat/test-fulljoin.R: -------------------------------------------------------------------------------- 1 | context("fulljoin") 2 | 3 | 4 | set.seed(123) 5 | tr <- ape::rtree(6) 6 | da <- data.frame(label=tip.label(tr), value = letters[seq_len(6)]) 7 | y <- full_join(tr, da, by = 'label') 8 | 9 | test_that("linking external data to treedata", { 10 | expect_true(is(y, "treedata")) 11 | expect_true("value" %in% get.fields(y)) 12 | }) 13 | -------------------------------------------------------------------------------- /tests/testthat/test-grouping.R: -------------------------------------------------------------------------------- 1 | context("grouping") 2 | 3 | 4 | nwk <- '(((((((A:4,B:4):6,C:5):8,D:6):3,E:21):10,((F:4,G:12):14,H:8):13):13,((I:5,J:2):30,(K:11,L:11):2):17):4,M:56);' 5 | 6 | tree <- read.tree(text=nwk) 7 | 8 | d <- as_tibble(tree) 9 | x <- groupClade(d, c(17, 21)) 10 | 11 | test_that("group by clade", { 12 | expect_equal(filter(x, group == 1 & node != 17)$node, offspring(d, 17)$node) 13 | expect_equal(filter(x, group == 2 & node != 21)$node, offspring(d, 21)$node) 14 | }) 15 | 16 | cls <- list(c1=c("A", "B", "C", "D", "E"), 17 | c2=c("F", "G", "H"), 18 | c3=c("L", "K", "I", "J"), 19 | c4="M") 20 | 21 | y <- groupOTU(d, cls) 22 | 23 | test_that("group by taxa", { 24 | expect_equal(filter(y, group == 'c1')$node, 25 | filter(d, node %in% c(filter(d, node %in% 1:5)$parent, 1:5))$node) 26 | expect_equal(filter(y, group == 'c2')$node, 27 | filter(d, node %in% c(filter(d, node %in% 6:8)$parent, 6:8))$node) 28 | expect_equal(filter(y, group == 'c3')$node, 29 | sort(filter(d, node %in% c(filter(d, node %in% 9:12)$parent, 9:12, MRCA(d, 9, 12)$node))$node)) 30 | expect_equal(filter(y, group == 'c4')$node, 13:14) 31 | }) 32 | -------------------------------------------------------------------------------- /tests/testthat/test-innerjoin.R: -------------------------------------------------------------------------------- 1 | context("inner_join") 2 | 3 | tr <- ape::rtree(8) 4 | x <- data.frame(id = sample(tr$tip.label, 4), trait = rnorm(4)) 5 | y <- inner_join(tr, x, by=c("label"="id")) 6 | 7 | test_that("linking external data to treedata", { 8 | expect_true(is(y, "treedata")) 9 | expect_equal(nrow(x), Ntip(y)) 10 | expect_true("trait" %in% get.fields(y)) 11 | }) 12 | -------------------------------------------------------------------------------- /tidytree.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | Encoding: UTF-8 9 | 10 | AutoAppendNewline: Yes 11 | StripTrailingWhitespace: Yes 12 | 13 | BuildType: Package 14 | PackageUseDevtools: Yes 15 | PackageInstallArgs: --no-multiarch --with-keep.source 16 | PackageRoxygenize: rd,collate,namespace 17 | -------------------------------------------------------------------------------- /vignettes/tidytree.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "tidytree: A Tidy Tool for Phylogenetic Tree Data Manipulation" 3 | author: "Guangchuang Yu\\ 4 | 5 | School of Basic Medical Sciences, Southern Medical University" 6 | date: "`r Sys.Date()`" 7 | output: 8 | prettydoc::html_pretty: 9 | toc: true 10 | theme: cayman 11 | highlight: github 12 | pdf_document: 13 | toc: true 14 | vignette: > 15 | %\VignetteIndexEntry{tidytree} 16 | %\VignetteEngine{knitr::rmarkdown} 17 | %\usepackage[utf8]{inputenc} 18 | --- 19 | 20 | ```{r style, echo=FALSE, results="asis", message=FALSE} 21 | knitr::opts_chunk$set(tidy = FALSE, 22 | message = FALSE) 23 | ``` 24 | 25 | Please go to for the full vignette. 26 | 27 | --------------------------------------------------------------------------------