$Bio::MUST::Core::Tree::VERSION
=
'0.200510'
;
'Bio::MUST::Core::Roles::Listable'
;
has
'tree'
=> (
is
=>
'ro'
,
isa
=>
'Maybe[Bio::Phylo::Forest::Tree]'
,
default
=>
undef
,
writer
=>
'_set_tree'
,
);
sub
all_seq_ids {
my
$self
=
shift
;
my
@full_ids
;
$self
->tree->visit_depth_first(
-pre
=>
sub
{
my
$node
=
shift
;
if
(
$node
->is_terminal) {
push
@full_ids
, SeqId->new(
full_id
=>
$node
->get_name );
}
return
;
},
);
return
@full_ids
;
}
sub
shorten_ids {
return
shift
->_change_ids_(1,
@_
);
}
sub
restore_ids {
return
shift
->_change_ids_(0,
@_
);
}
sub
_change_ids_ {
my
$self
=
shift
;
my
$abbr
=
shift
;
my
$id_mapper
=
shift
;
for
my
$tip
( @{
$self
->tree->get_terminals } ) {
my
$seq_id
= SeqId->new(
full_id
=>
$tip
->get_name );
my
$new_id
=
$abbr
?
$id_mapper
->abbr_id_for(
$seq_id
->full_id )
:
$id_mapper
->long_id_for(
$seq_id
->full_id );
$tip
->set_name(
$new_id
)
if
$new_id
;
}
return
;
}
sub
switch_attributes_and_labels_for_terminals {
return
shift
->_switch_attributes_and_labels_(0,
@_
);
}
sub
switch_attributes_and_labels_for_internals {
return
shift
->_switch_attributes_and_labels_(1,
@_
);
}
sub
switch_attributes_and_labels_for_entities {
return
shift
->_switch_attributes_and_labels_(2,
@_
);
}
sub
_switch_attributes_and_labels_ {
my
$self
=
shift
;
my
$mode
=
shift
;
my
$key
=
shift
;
my
$tree
=
$self
->tree;
my
@nodes
= @{
$mode
== 2 ?
$tree
->get_entities :
$mode
== 1 ?
$tree
->get_internals :
$tree
->get_terminals
};
for
my
$node
(
@nodes
) {
my
$label
=
$node
->get_name;
my
$attribute
=
$node
->get_generic(
$key
);
$node
->set_generic(
$key
=>
$label
);
$node
->set_name(
$attribute
);
}
return
;
}
sub
switch_branch_lengths_and_labels_for_entities {
my
$self
=
shift
;
my
$length
=
shift
;
my
$tree
=
$self
->tree;
for
my
$node
( @{
$tree
->get_internals } ) {
$node
->set_name(
$node
->get_branch_length);
}
for
my
$node
( @{
$tree
->get_entities } ) {
$node
->set_branch_length(
$length
);
}
return
;
}
sub
collapse_subtrees {
my
$self
=
shift
;
my
$key
=
shift
//
'taxon_collapse'
;
my
$tree_max_path
=
$self
->tree->get_root->calc_max_path_to_tips;
my
$collapsed
;
$self
->tree->visit_depth_first(
-pre_daughter
=>
sub
{
my
$node
=
shift
;
return
if
$node
->is_terminal;
$node
->set_generic(
'!collapse'
=>
undef
);
return
if
$collapsed
;
my
@attrs
;
for
(
my
$i
= 0;
my
$child
=
$node
->get_child(
$i
);
$i
++) {
push
@attrs
,
$child
->get_generic(
$key
);
}
return
if
List::AllUtils::any { not
defined
$_
}
@attrs
;
return
if
uniq(
@attrs
) > 1;
my
$sub_max_path
=
$node
->calc_max_path_to_tips
+
$node
->calc_path_to_root;
my
$node_height
=
$tree_max_path
-
$sub_max_path
;
$node
->set_generic(
'!collapse'
=>
qq|{"collapsed",$node_height}|
);
$collapsed
=
$node
->get_id;
return
;
},
-post_daughter
=>
sub
{
my
$node
=
shift
;
return
if
$node
->is_terminal;
$collapsed
=
undef
if
defined
$collapsed
&&
$collapsed
eq
$node
->get_id;
return
;
},
);
return
;
}
sub
match_branch_lengths {
my
$self
=
shift
;
my
$other
=
shift
;
my
$tree1
=
$self
->tree;
my
$tree2
=
$other
->tree;
tie
my
%blens_for
,
'Tie::IxHash'
;
for
my
$tree
(
$tree1
,
$tree2
) {
for
my
$node
( @{
$tree
->get_entities } ) {
my
$clade_key
=
join
'::'
,
sort
{
$a
cmp
$b
}
map
{
$_
->get_internal_name } @{
$node
->get_terminals }
;
my
$branch_length
=
$node
->get_branch_length;
push
@{
$blens_for
{
$clade_key
} },
$branch_length
if
defined
$branch_length
;
}
}
carp
'[BMC] Warning: cannot match all bipartitions; returning useless hash!'
unless
List::AllUtils::all {
@{
$blens_for
{
$_
} } == 2
}
keys
%blens_for
;
return
\
%blens_for
;
}
sub
load {
my
$class
=
shift
;
my
$infile
=
shift
;
open
my
$in
,
'<'
,
$infile
;
my
$tree
=
$class
->new();
my
$newick_str
;
LINE:
while
(
my
$line
= <
$in
>) {
chomp
$line
;
next
LINE
if
$line
=~
$EMPTY_LINE
||
$tree
->is_comment(
$line
);
$newick_str
.=
$line
;
}
my
$forest
= parse(
-format
=>
'newick'
,
-string
=>
$newick_str
);
$tree
->_set_tree(
$forest
->first);
return
$tree
;
}
sub
store {
my
$self
=
shift
;
my
$outfile
=
shift
;
my
$args
=
shift
// {};
$args
->{-nodelabels} //= 1;
open
my
$out
,
'>'
,
$outfile
;
say
{
$out
} _clean_newick_str(
$self
->tree->to_newick(
%$args
) );
return
;
}
sub
store_figtree {
my
$self
=
shift
;
my
$outfile
=
shift
;
for
my
$node
( @{
$self
->tree->get_internals } ) {
my
$taxon
=
$node
->get_generic(
'taxon'
);
$node
->set_generic(
'!name'
=>
qq|"$taxon"|
)
if
$taxon
;
}
my
$newick_str
=
$self
->tree->to_newick(
-nodelabels
=> 1,
-nhxkeys
=> [
'!name'
,
'!color'
,
'!collapse'
],
-nhxstyle
=>
'mesquite'
,
);
$newick_str
=~ s{\[%}{[&}xmsg;
$newick_str
=~ s{\b Node\d+ \b}{0}xmsg;
open
my
$out
,
'>'
,
$outfile
;
print
{
$out
}
<<"EOF";
#NEXUS
begin trees;
tree tree_1 = [&R] $newick_str
end;
EOF
return
;
}
sub
store_arb {
my
$self
=
shift
;
my
$outfile
=
shift
;
my
$args
=
shift
// {};
my
$alifile
=
$args
->{alifile};
if
(
$alifile
) {
my
(
$basename
,
$dir
,
$ext
) = fileparse(
$alifile
,
qr{\.[^.]*}
xms);
$self
->insert_comment(
"$basename$ext"
);
}
my
$newick_str
= _clean_newick_str(
$self
->tree->to_newick(
-nodelabels
=> 0 )
);
open
my
$out
,
'>'
,
$outfile
;
print
{
$out
}
$self
->header;
say
{
$out
}
$newick_str
;
return
;
}
sub
store_grp {
my
$self
=
shift
;
my
$outfile
=
shift
;
my
@tip_ids
=
map
{
$_
->foreign_id }
$self
->all_seq_ids;
my
@nodes
=
grep
{ not
$_
->is_root } @{
$self
->tree->get_internals };
my
@bp_vals
=
map
{
$_
->get_name }
@nodes
;
my
$pp
= List::AllUtils::all {
$_
>= 0.0 &&
$_
<= 1.0 }
@bp_vals
;
open
my
$out
,
'>'
,
$outfile
;
for
my
$node
(
@nodes
) {
my
%in_bip
=
map
{
SeqId->new(
full_id
=>
$_
->get_name )->
foreign_id
=> 1
} @{
$node
->get_terminals };
my
$bip
=
join
q{}
,
map
{
$in_bip
{
$_
} ?
'*'
:
'.'
}
@tip_ids
;
my
$support
=
shift
@bp_vals
;
$support
=
int
(
$support
* 100.0 )
if
$pp
;
say
{
$out
}
"$bip $support"
;
}
return
;
}
sub
store_tpl {
my
$self
=
shift
;
my
$outfile
=
shift
;
my
@branch_lengths
;
for
my
$node
( @{
$self
->tree->get_entities } ) {
push
@branch_lengths
,
$node
->get_branch_length;
$node
->set_branch_length(
undef
);
}
open
my
$out
,
'>'
,
$outfile
;
say
{
$out
}
'1'
;
say
{
$out
} _clean_newick_str(
$self
->tree->to_newick(
-nodelabels
=> 0 )
);
for
my
$node
( @{
$self
->tree->get_entities } ) {
$node
->set_branch_length(
shift
@branch_lengths
);
}
return
;
}
sub
_clean_newick_str {
my
$newick_str
=
shift
;
$newick_str
=~
tr
{'"}{}d;
$newick_str
=~ s{:0\.0+;}{;}xmsg;
return
$newick_str
;
}
__PACKAGE__->meta->make_immutable;
1;