view release on metacpan or  search on metacpan

bin/format-tree.pl  view on Meta::CPAN

#!/usr/bin/env perl
# PODNAME: format-tree.pl
# ABSTRACT: Format (and annotate) trees for printing
# CONTRIBUTOR: Valerian LUPO <valerian.lupo@uliege.be>

use Modern::Perl '2011';
use autodie;

use Getopt::Euclid qw(:vars);
use List::AllUtils qw(pairfirst);
use Smart::Comments;
use Try::Tiny;

use Bio::MUST::Core;
use Bio::MUST::Core::Utils qw(:filenames secure_outfile);
use aliased 'Bio::MUST::Core::IdList';
use aliased 'Bio::MUST::Core::IdMapper';
use aliased 'Bio::MUST::Core::SeqId';
use aliased 'Bio::MUST::Core::Taxonomy';
use aliased 'Bio::MUST::Core::Tree';

# TODO: implement numbered taxonomic levels as in fetch-tax.pl
# check for conditionally required arguments
die <<'EOT' if !$ARGV_annotate && ($ARGV_collapse || $ARGV_colorize);
Missing required arguments:
    --annotate=<level>
EOT

die <<'EOT' if !$ARGV_taxdir && ($ARGV_root_on_taxon || $ARGV_annotate || $ARGV_auto_final_ids);
Missing required arguments:
    --taxdir=<dir>
EOT

# optionally read global org-mapper
my $org_mapper;
if ($ARGV_org_mapper) {
    ### Mapping organisms from: $ARGV_org_mapper
    $org_mapper = IdMapper->load($ARGV_org_mapper);
}

# optionally build taxonomy object
my $tax;
if ($ARGV_taxdir) {
    ### Annotating trees using: $ARGV_taxdir
    $tax = Taxonomy->new_from_cache( tax_dir => $ARGV_taxdir );
}

# setup potential rooting strategy
my $filter;
my ($component, $target) = pairfirst { $b }
    map { $_ => $ARGV{"--root-on-$_"} } qw(taxon genus species family tag);
if ($component) {
    ### Rooting strategy: "$component = $target"
    $filter = $component eq 'taxon' ? $tax->tax_filter(     ["+$target"] )
            :        SeqId->${\ ($component . '_filter') }( ["+$target"] )
    ;
}

# setup collapsing and group naming
my $annotate_key;
my $collapse_key;
if ($ARGV_collapse && ($ARGV_collapse =~ m/label|color/xms)) {
    $annotate_key  = 'taxon_label' if $ARGV_annotate eq 'missing';
    $collapse_key  = 'taxon_label' if $ARGV_collapse eq 'label';
    $collapse_key  = '!color'      if $ARGV_collapse eq 'color';
    $ARGV_collapse = 'no rank';
}
$ARGV_annotate = 'no rank' if $ARGV_annotate && $ARGV_annotate eq 'missing';
my %opts = (name  => $ARGV_annotate);
$opts{  collapse} =  $ARGV_collapse if $ARGV_collapse;

TREE: