#' @title Create a phylogenetic tree
#'
#' @description
#' This function creates a tree, more a less stepwise, depending on the data in the function.
#' The function can be run without arguments.
#' If the desired phylogeny is already known and prepared, it is advised to prepare and save the elements used in this function, in case of small errors (yet, the function doesn't allow one to recover inputted data if there is an error).
#'
#' @usage create.tree(nbtaxa,taxa,age_taxa=NULL,nbnodes,nodes,age_nodes=NULL,node.labels=NA,tax_selection,
#' ultra=FALSE,format,plot=FALSE)
#'
#' @param nbtaxa Desired number of taxa; optional, especially if either \code{taxa} or \code{age_taxa} parameters are present
#' @param taxa A vector specifying the name of \strong{all} desired taxa; if not all taxa names are known, rather do not specify the known names yet and specify them by running the function without this parameter
#' @param age_taxa A vector specifying the age of \strong{all} desired taxa; if not all taxa ages are known, rather do not specify the known ages yet and specify them by running the function without this parameter
#' @param nbnodes Desired number of nodes; optional, especially if \code{age_nodes} is present
#' @param nodes A list of vectors; each vector is a node and must contains the names of the "targets", either the taxa (full name) or other nodes (Ni, i being the i-th node). It is advised to name each vector of the list "Ni" (i being the i-th node); if not, nodes are assumed to be hierarchized from oldest to youngest (while by naming nodes, the order does not matter).
#' @param age_nodes A vector specifying the age of \strong{all} nodes; if not all node ages are known, rather do not specify the known ages yet and specify them by running the function without this parameter. If \code{nodes} are provided, should be in the same order
#' @param node.labels A vector specifying the labels of the tree nodes, if there are. Can be set to \code{NA}, \code{NULL}, or \code{FALSE} for no node labels (the default), to \code{TRUE} for node labels set while creating the tree (node names in the parameter \code{nodes} if present, else default node names with prefix Node), or to a vector of same length than the nodes for user-defined names.
#' @param tax_selection The method to choose taxa if \code{taxa} and/or \code{nodes} are not specified. Can be either \code{BYNAME} (choose taxa by their name) or \code{BYGRAPH} (choose taxa by clicking them)
#' @param ultra Logical; if the tree has to be ultrametric (i.e. without specific node ages)
#' @param format The format of the output; can be an object of class \code{phylo} by specifying \code{"phylo"} or \code{"phylo object"} or simply a newick/parenthetic text by specifying \code{"newick"}, \code{"NEWICK"} or \code{"parenthetic"}
#' @param plot Optional. Turned to \code{TRUE} by default, meaning that the final phylogeny is plotted at the end of the execution of the function. Turn to \code{FALSE} if not desired.
#'
#' @return Returns either an object of class \code{phylo} or a text in newick/parenthetic format. If the latter, the tree can also be saved during performing the function.
#'
#' @importFrom graphics points text axis locator strwidth
#' @importFrom gtools ask
#' @importFrom ape plot.phylo read.tree write.tree
#' @importFrom foreach foreach %do%
#' @importFrom DescTools RoundTo
#' @importFrom stats setNames
#' @importFrom grDevices pdf
#' @importFrom grDevices dev.off
#'
#' @export
<- (nbtaxa,taxa,age_taxa=,nbnodes,nodes,age_nodes=,node.labels=,tax_selection,ultra=,,=){
((age_taxa)&(age_nodes)&((ultra)|ultra==)){
temp_ultra<-ask("Do you want an ultrametric tree (i.e. without specifying ages of nodes) ? (Y/N)")
(temp_ultra=="Y"|temp_ultra=="y"|temp_ultra=="YES"|temp_ultra=="yes"|temp_ultra=="Yes"){
ultra<-
}
{
ultra<-
}
}
(ultra==&(age_taxa)==){
temp_ultra<-ask("You specified both an ultrametric tree and ages to the tips, which are incompatible. Do you still want an ultrametric tree (i.e. without specifying ages of nodes) ? (Y/N)")
(temp_ultra=="yes"|temp_ultra=="Y"|temp_ultra=="y"|temp_ultra=="Yes"|temp_ultra=="YES"){
ultra<-
age_taxa<-
}
{
ultra<-
}
}
(ultra==&(age_nodes)==){
temp_ultra<-ask("You specified both an ultrametric tree and ages to the nodes, which are incompatible. Do you still want an ultrametric tree (i.e. without specifying ages of nodes) ? (Y/N)")
(temp_ultra=="yes"|temp_ultra=="Y"|temp_ultra=="y"|temp_ultra=="Yes"|temp_ultra=="YES"){
ultra<-
age_nodes<-
}
{
ultra<-
}
}
if ((taxa)) {
taxa <- ()
if ((nbtaxa)) {
loop <- "go"
nbtaxa <- 0
while (loop != "end") {
nbtaxa <- nbtaxa + 1
temp_taxa <- ask(("Please give the name of the ",nbtaxa,
if (nbtaxa == 1) {"-st"}
{
if (nbtaxa == 2) {"-nd"}
{"-th"}},
" taxon; if you finished, please write 'end'"))
if (temp_taxa != "end") {
(ultra==){
temp_age_taxa <- ask(("Please give the numeric age of the ",nbtaxa,
if (nbtaxa == 1) {"-st"}
{
if (nbtaxa == 2) {"-nd"}
{"-th"}},
" taxon; if you finished, please write 'end'"))
if ((((temp_age_taxa))) == ) {
("You did not provide an age for this taxon, please provide it now or function will stop","\n")
temp_age_taxa <- ask(("Please give the numeric age of the ",nbtaxa,
if (nbtaxa == 1) {"-st"}
{
if (nbtaxa == 2) {"-nd"}
{"-th"}},
" taxon; if you finished, please write 'end'"))
}
age_taxa[nbtaxa] <- (temp_age_taxa)
}
taxa[nbtaxa] <- (temp_taxa)
}
{
loop <- "end"
nbtaxa <- nbtaxa - 1
}
}
}
{
for (i 1:nbtaxa) {
temp_taxa <- ask(("Please give the name of the ", i,
if (i == 1) {"-st"}
{
if (i == 2) {"-nd"}
{"-th"}},
" taxon"))
taxa[i] <- (temp_taxa)
(ultra==){
temp_age_taxa <- ask(("Please give the numeric age of the ",i,
if (i == 1) {"-st"}
{
if (i == 2) {"-nd"}
{"-th"}},
" taxon"))
if ((((temp_age_taxa))) == ) {
("You did not provide an age for this taxon, please provide it now or function will stop","\n")
temp_age_taxa <- ask(("Please give the numeric age of the ",i,
if (i == 1) {"-st"}
{
if (i == 2) {"-nd"}
{"-th"}},
" taxon"))
}
age_taxa[i] <- (temp_age_taxa)
}
}
}
}
{
taxa <- (taxa)
nbtaxa <- (taxa)
(ultra==){
if (((((age_taxa))))) {
for (i 1:(taxa)) {
temp_age_taxa <- ask(("Please give the numeric age of the taxon ", taxa[i]))
if (((((temp_age_taxa))) == )) {
("You did not provide an age for this taxon, please provide it now or function will stop","\n")
temp_age_taxa <- ask(("Please give the numeric age of the taxon ", taxa[i]))
}
age_taxa[i] <- (temp_age_taxa)
}
age_taxa <- (age_taxa)
}
{
age_taxa <- ((age_taxa),(age_taxa))
}
}
}
(ultra){
age_taxa<-(0,(taxa))
}
((nodes)==){
temp_phylo <- ()
plot_depth <- (age_taxa,((age_nodes)==){age_nodes})
for (i 1:nbtaxa) {
temp_phylo[i] <- (taxa[i], ":", plot_depth - age_taxa[i], ",", collapse = "")
}
temp_phylo <- ("(", ('.{1}$', '', (temp_phylo, collapse = "", sep = "")), ");")
temp <- read.tree( = temp_phylo)
taxa_short<-()
for (i 1:(taxa)){
((taxa[i])>4){
(((taxa[i],="[ ]")[1]])>1){
temp_tax_names<-(taxa[i],="[ ]")[1]]
taxa_short[i]<-((foreach(j=1:(temp_tax_names))%do%((temp_tax_names,="")[j]][1:2],collapse="")),collapse=" ")
}
{
taxa_short[i]<-((taxa[i],="")[1]][1:4],collapse="")
}
}
{
taxa_short[i]<-taxa[i]
}
}
temp$tip.label <- taxa_short
x_gap<-(plot_depth - (age_taxa))/10
(x_gap==0){x_gap<-1}
((x_gap)+1<=1){
x_gap_magnitude<-0
x_gap_temp<-0
(x_gap_temp<1){
x_gap_temp<-x_gap*10^x_gap_magnitude
(x_gap_temp<1){x_gap_magnitude<-x_gap_magnitude+1}
}
x_gap<-1/10^x_gap_magnitude
}
{
x_gap<-(x_gap)
}
plot.phylo(temp,edge.color = "white",x.lim = ((age_taxa), plot_depth),label.offset = -x_gap/10)
x_ticks <-((1, = ,tick = ,at = (((age_taxa)), plot_depth, x_gap)+(RoundTo(plot_depth,x_gap)-plot_depth)))
x_labels <- (x_ticks)-(RoundTo(plot_depth,x_gap)-plot_depth)
(1, at = x_ticks, = x_labels)
node_nb_ends <- ()
node_ends <- ()
node_coords_x <- ()
node_coords_y <- ()
loop <- "go"
node <- 0
nodemax<--1
((age_nodes)==|(nbnodes)==){
((nbnodes)){
nbnodes<-(age_nodes)
}
nodemax<-nbnodes
}
{
nbnodes<-()
}
while (loop != "end" & node != nodemax) {
node <- node + 1
((tax_selection)){
tax_selection<-ask(("Do you want to select the terminal taxa and the nodes by their name (type BYNAME) or do you want to select them graphically (type BYGRAPH)?"))
}
(tax_selection=="BYNAME"){
node_nb_ends[node]] <- ask((
(nodemax<0){"If their are no more nodes, type 'end', otherwise, i"}
{"I"},
"f the ",node,
if (node == 1) {"-st"}
{
if (node == 2) {"-nd"}
{"-th"}},
" node is dichotomic, type 2, or type the number of branches arising from it"))
if (node_nb_ends[node]] == "end") {
loop <- "end"
node_nb_ends <- node_nb_ends-node]
node <- node - 1
nbnodes<-node
}
if ((((node_nb_ends[node]]))) == ) {
("You did not provide a number of branches, please provide it now or function will stop","\n")
node_nb_ends[node]] <- ask((
(nodemax<0){"If their are no more nodes, type 'end', otherwise, i"}
{"I"},
"f the ",node,
if (node == 1) {"-st"}
{
if (node == 2) {"-nd"}
{"-th"}},
" node is dichotomic, type 2, or type the number of branches arising from it"))
}
node_ends[node]] <- (0)
for (i 1:(node_nb_ends[node]])) {
node_ends[node]][i] <- ask(("If the ",i,
if (i == 1) {"-st"}
{
if (i == 2) {"-nd"}
{"-th"}},
" end is a taxon, type its name; if it is a node, type 'N' and its displayed number"))
if ((((taxa == node_ends[node]][i])) | (((node_ends) == node_ends[node]][i]))) == ) {
("You did not provide the name of the written taxa or nodes, please provide it now or function will stop","\n")
node_ends[node]][i] <- ask(("If the ",i,
if (i == 1) {"-st"}
{
if (i == 2) {"-nd"}
{"-th"}},
" end is a taxon, type its name; if it is a node, type 'N' and its displayed number"))
}
if ((((((node_ends[node]][i], "")[1]]-1],collapse=""))))==) {
node_ends[node]][i] <- (taxa == node_ends[node]][i])
}
(node_ends)[node] <- ("N", node)
}
}
(tax_selection=="BYGRAPH"){
(("max_depth")==){
max_depth<-plot_depth
}
("Please click close to the taxa you want to pick; press Esc when you are done or if there are no more nodes\n")
selected_points<-()
((selected_points)){
loop<-"end"
}
selected_taxa<-( = (selected_points))
for (i 1:(selected_points$x)){
x_pos_taxa<-age_taxa
y_pos_taxa<-1:nbtaxa
list_taxa<-taxa
(("node_coords_x")){
x_pos_taxa<-(x_pos_taxa,age_nodes)
y_pos_taxa<-(y_pos_taxa,node_coords_y)
list_taxa<-(taxa,(node_ends))
}
selected_taxa[i]<-((((x_pos_taxa)-(plot_depth-selected_points$x[i]))^2+((y_pos_taxa)-selected_points$y[i])^2))
}
node_nb_ends[node]] <- (selected_taxa)
node_ends[node]]<-"NULL"
(node_ends)[node]<-("N",node)
for (i 1:node_nb_ends[node]]){
(selected_taxa[i]>nbtaxa){
node_ends[node]][i]<-(node_ends)[selected_taxa[i]-nbtaxa]
}
{
node_ends[node]][i]<-(taxa==taxa[selected_taxa[i]])
}
}
}
(nodemax>0){
age_nodes<-age_nodes
}
{
(ultra==){
age_nodes[node] <- ((((age_taxa[na.omit((node_ends[node]]))])), ((age_nodes[unlist(foreach(i=1:(node_nb_ends[node]]))%do%(((node_ends)==node_ends[node]][i])))])))) + 1
}
{
age_nodes[node] <- (ask(("Please give the age of the ",node,
if (node == 1) {"-st"}
{
if (node == 2) {"-nd"}
{"-th"}},
" node; if not known, type 0")))
}
if (age_nodes[node]!=0&age_nodes[node] < ((age_taxa[na.omit((node_ends[node]]))]))) {
age_nodes[node] <- (ask(("Error: node age is more recent than (at least) on of the terminal taxa; please give its age or, if not known, type 0")))
}
if (age_nodes[node] == 0) {
if ((age_nodes) == 1) {
age_nodes[node] <-((age_taxa[na.omit((node_ends[node]]))])) + 1
}
{
age_nodes[node] <- ((((age_taxa[na.omit((node_ends[node]]))])), ((age_nodes[unlist(foreach(i=1:(node_nb_ends[node]]))%do%(((node_ends)==node_ends[node]][i])))])))) + 1
}
}
}
max_depth <- (((age_taxa), (age_nodes)),na.rm=)
node_coords_x[node] <- plot_depth - age_nodes[node]
if (((((node_ends[node]]))) == )) {
node_coords_y[node] <- ((node_ends[node]]))
}
{
where <- (((node_ends[node]])))
if ((((where))) == 2) {
prev_node <- (((node_ends[node]][where == ], "")[1]]-1],collapse=""))
node_coords_y[node] <- (((node_ends[node]][where == ]), node_coords_y[prev_node]))
}
{
prev_node_1 <- (((node_ends[node]][where == ], "")[1]]-1],collapse=""))
prev_node_2 <- (((node_ends[node]][where == ], "")[2]]-1],collapse=""))
node_coords_y[node] <- ((node_coords_y[prev_node_1], node_coords_y[prev_node_2]))
}
}
if (max_depth > plot_depth) {
plot.phylo(temp,edge.color = "white",x.lim = (((age_taxa) - (max_depth - (age_taxa))), (age_taxa)),label.offset = 0)
x_ticks <- ((1, = ,tick = ,at = (((age_taxa) - (max_depth - (age_taxa))), ((age_taxa)), (1,(((age_taxa) - ((age_taxa) - (max_depth - (age_taxa)))))))))
if ((x_ticks) < 0) {
x_labels <- (x_ticks - ((x_ticks)))
}
{
x_labels <- (x_ticks)
}
(1, at = x_ticks, = x_labels)
for (i 1:((1, (node_ends) - 1))) {
(node_coords_x[i],node_coords_y[i], = (node_ends)[i], = 0)
x_offset <- ("i")
for (j 1:(node_nb_ends[i]])) {
start_x <- node_coords_x[i] + x_offset
end_x <- ()
if ((((node_ends[i]][j]))) == ) {
end_x <- node_coords_x[i] + age_nodes[i] - age_taxa[as.numeric(node_ends[i]][j])] - x_offset
}
{
end_x <- node_coords_x[i] + age_nodes[i] - age_nodes[as.numeric(((node_ends[i]][j], = "")[1]]-1],collapse=""))] - x_offset
}
start_y <- node_coords_y[i]
end_y <- ()
if ((((node_ends[i]][j]))) == ) {
end_y <- (node_ends[i]][j])
}
{
end_y <- node_coords_y[as.numeric(((node_ends[i]][j], = "")[1]]-1],collapse=""))]
}
((start_x, end_x), (start_y, end_y), = "l")
}
}
}
(node_coords_x[node],node_coords_y[node], = (node_ends)[node], = 0)
x_offset <- ("i")
for (i 1:(node_nb_ends[node]])) {
start_x <- node_coords_x[node] + x_offset
end_x <- ()
if ((((node_ends[node]][i]))) == ) {
end_x <- node_coords_x[node] + age_nodes[node] - age_taxa[as.numeric(node_ends[node]][i])] - x_offset
}
{
end_x <- node_coords_x[node] + age_nodes[node] - age_nodes[as.numeric(((node_ends[node]][i], = "")[1]]-1],collapse=""))] - x_offset
}
start_y <- node_coords_y[node]
end_y <- ()
if ((((node_ends[node]][i]))) == ) {
end_y <- (node_ends[node]][i])
}
{
end_y <- node_coords_y[as.numeric(((node_ends[node]][i], = "")[1]]-1],collapse=""))]
}
((start_x, end_x), (start_y, end_y), = "l")
}
}
}
{
nbnodes<-(nodes)
node_nb_ends<-foreach(i=1:(nodes))%do%(nodes[i]])
node_ends<-nodes
(((node_ends))){
(node_ends)<-("NA",(node_ends))
}
for (i 1:nbnodes){
for (j 1:node_nb_ends[i]]){
if (((node_ends[i]][j], "")[1]][1]=="N"&
!(((((node_ends[i]][j], "")[1]]-1],collapse="")))))==) {
node_ends[i]][j] <- (taxa == node_ends[i]][j])
}
}
(ultra){
age_nodes[i] <- ((((age_taxa[na.omit((node_ends[i]]))])), ((age_nodes[unlist(foreach(j=1:(node_nb_ends[i]]))%do%(((node_ends)==node_ends[i]][j])))])))) + 1
}
}
(((node_ends)!=(node_ends[paste("N",1:nbnodes,sep="")]))){
good_order<-("N",1:nbnodes,sep="")
(!ultra){
age_nodes<-(age_nodes,(node_ends))
age_nodes<-age_nodes[good_order]
age_nodes<-(age_nodes)
}
node_ends<-node_ends[good_order]
}
}
((nbnodes)){
nbnodes<-(node_ends)
}
numb_branches <- (node_ends)
branches_temp <- ( = 2 * (numb_branches), = (node_ends),)
for (i 1:nbnodes) {
term_unit <- (node_ends[i]])
temp <- ()
for (j 1:numb_branches[i]) {
if ((((term_unit[j]))) == ) {
temp[j] <- (((term_unit[j], "")[1]]-1],collapse="")) + (taxa)
}
{
temp[j] <- (term_unit[j])
}
}
term_unit <- temp
apic_unit <- ((((node_ends)[i], "")[1]]-1],collapse="")) + (taxa)
branches_temp[i, (1, 1 + 2 * (numb_branches[i] - 1), 2)] <- apic_unit
branches_temp[i, (2, 2 + 2 * (numb_branches[i] - 1), 2)] <- term_unit
}
branches <- (( = 2, = ((branches_temp)) / 2,(branches_temp),byrow = ))
for (i 1:2) {
branches, i] <- (branches, i])
}
(!((age_taxa))){
(((age_taxa)%in%taxa)){
age_taxa<-age_taxa[match(taxa,(age_taxa))]
}
}
(!((age_nodes))){
(((age_nodes)%in%(nodes))){
age_nodes<-age_nodes[match((nodes),(age_nodes))]
}
}
age_all <- (age_taxa, age_nodes)
(!ultra){
root.time<-(age_all)
}
age_branches <- ()
for (i 1:(branches, 1])) {
age_branches[i] <- age_all[branches[i, 1]] - age_all[branches[i, 2]]
}
branches<-(branches,(1,2),(x){(x>nbtaxa){nbtaxa+1+((nbtaxa+nbnodes)-x)}{x}})
(ultra==){
output <-(edge = branches,edge.length = age_branches,Nnode = (nbnodes),tip.label = taxa)
}
{
output <-(edge = branches,Nnode = (nbnodes),tip.label = taxa)
}
(output)$ <- "phylo"
(output)$ <- "cladewise"
output <- read.tree( = write.tree(output))
(!ultra){
output$root.time<-root.time
}
noplot.phylo<-(x){
(=)
plot.phylo(x)
()
}
(((noplot.phylo(output)))==){
if (()) {
<- "phylo object"
}
if ( == "parenthetic" | == "newick" | == "NEWICK") {
q_save <- ask("Do you want to save the tree ? (Y/N)")
if (q_save == "Y" | q_save == "yes" | q_save == "Yes" | q_save == "YES" | q_save == "y") {
loc <- (
ask("Please give the path where you want to save your tree"),
ask("Please give the name of your tree"),
".tre"
)
write.tree(output, = loc)
}
{
output <- write.tree(output)
}
}
if ( == "phylo object" | == "phylo"){
output <- output
}
(!(((node.labels))||((node.labels))||!node.labels)){
((node.labels)==1&&node.labels){
(!(nodes)){
output$node.label<-(nodes)
}
{
output<-makeNodeLabel(output)
}
}
((node.labels)==Nnode(output)){
output$node.label<-node.labels
}
}
(){
plot.phylo(output)
}
(output)
}
{
output_error<-(taxa=taxa,age_taxa=age_taxa,age_nodes=age_nodes,node_ends=node_ends,node_nb_ends=node_nb_ends,numb_branches=numb_branches,branches_temp=branches_temp,branches=branches,age_branches=age_branches)
(output_error)
}
}
