File Coverage

blib/lib/Bio/NEXUS/SetsBlock.pm

Criterion	Covered	Total	%
statement	57	168	33.9
branch	6	32	18.7
condition	3	15	20.0
subroutine	14	24	58.3
pod	14	14	100.0
total	94	253	37.1

######################################################
# SetsBlock.pm
######################################################
# Author: Thomas Hladish
# $Id: SetsBlock.pm,v 1.32 2007/09/21 23:09:09 rvos Exp $
#################### START POD DOCUMENTATION ##################

=head1 NAME

Bio::NEXUS::SetsBlock - Represents SETS block of a NEXUS file

=head1 SYNOPSIS

$block_object = new Bio::NEXUS::SetsBlock($block_type, $block, $verbose);

=head1 DESCRIPTION

Parses Sets block of NEXUS file and stores Sets data.

=head1 FEEDBACK

All feedback (bugs, feature enhancements, etc.) are greatly appreciated.

=head1 AUTHORS

 Thomas Hladish (tjhladish at yahoo)

=head1 VERSION

$Revision: 1.32 $

=head1 METHODS

=cut

package Bio::NEXUS::SetsBlock;

use strict;
#use Carp; # XXX this is not used, might as well not import it!
#use Data::Dumper; # XXX this is not used, might as well not import it!
use Bio::NEXUS::Functions;
use Bio::NEXUS::Block;
use Bio::NEXUS::Util::Exceptions;
use Bio::NEXUS::Util::Logger;
use vars qw(@ISA $VERSION $AUTOLOAD);
use Bio::NEXUS; $VERSION = $Bio::NEXUS::VERSION;

@ISA = qw(Bio::NEXUS::Block);
my $logger = Bio::NEXUS::Util::Logger->new();

=head2 new

 Title   : new
 Usage   : $block_object = new Bio::NEXUS::SetsBlock($block_type, $commands, $verbose)
 Function: Creates a new Bio::NEXUS::SetsBlock object
 Returns : Bio::NEXUS::SetsBlock object
 Args    : type (string), the commands/comments to parse (array ref), and a verbose flag (0 or 1)

=cut

sub new {
    my ( $class, $type, $commands, $verbose, $taxlabels ) = @_;
    unless ($type) { ( $type = lc $class ) =~ s/Bio::NEXUS::(.+)Block/$1/i; }
    my $self = { type => $type };
    bless $self, $class;
    $self->_parse_block( $commands, $verbose, $taxlabels )
        if ( ( defined $commands ) and @$commands );
    return $self;
}

=begin comment

 Title   : _parse_taxset
 Usage   :

=end comment

=cut

sub _parse_taxset {
    my ( $self, $buffer ) = @_;
    my ( $setname, $equals_symb, @taxa ) = @{ _parse_nexus_words($buffer) };

    my $taxsets;
    $taxsets->{$setname} = \@taxa;

    #$self->set_taxsets($taxsets);
    $self->add_taxsets( { $setname, \@taxa } );

    return $taxsets;
}

=head2 set_taxsets

 Title   : set_taxsets
 Usage   : $block->set_taxsets($taxsets);
 Function: Set the taxsets hash
 Returns : none
 Args    : hash of set name keys and element arrays

=cut

sub set_taxsets {
    my ( $self, $taxsets ) = @_;
    $self->{'taxsets'} = $taxsets;
}

=head2 add_taxsets

 Title   : add_taxsets
 Usage   : $block->add_taxsets($taxsets);
 Function: add taxa sets
 Returns : none
 Args    : a reference to a hash of taxa sets

=cut

sub add_taxsets {
    my ( $self, $taxsets ) = @_;
    for my $setname ( keys %{$taxsets} ) {
        ${ $self->{'taxsets'} }{$setname} = ( $$taxsets{$setname} );
    }
}

=head2 get_taxsets

 Title   : get_taxsets
 Usage   : $block->get_taxsets();
 Function: Returns a hash of taxa sets
 Returns : taxa sets
 Args    : none

=cut

sub get_taxsets {
    my ($self) = @_;
    return $self->{'taxsets'} || {};
}

=head2 get_taxset

 Title   : get_taxset
 Usage   : $block->get_taxset($setname);
 Function: Returns a list of OTU's
 Returns : OTU's
 Args    : none

=cut

sub get_taxset {
    my ( $self, $setname ) = @_;
    return $self->{'taxsets'}->{$setname} || [];
}

=head2 get_taxset_names

 Title     : get_taxset_names
 Usage     : $block->get_taxset_names()
 Function: gets the names of all sets
 Returns : array of names
 Args     : none

=cut

sub get_taxset_names {
    my ($self) = @_;
    return [ sort keys %{ $self->{'taxsets'} } ];
}

=head2 print_all_taxsets

 Title     : print_all_taxsets
 Usage     : $block->print_all_taxsets($outfile)
 Function: prints set names and elements
 Returns : none
 Args     : filename or filehandle

=cut

sub print_all_taxsets {
    my ( $self, $outfile ) = @_;
    my $fh;
    if ( $outfile eq "-" || $outfile eq \*STDOUT ) {
        $fh = \*STDOUT;
    }
    else {
        open( $fh, ">$outfile" )
            || Bio::NEXUS::Util::Exceptions::FileError->throw(
        	'error' => "Could not open $outfile for writing"
        );
    }

    for my $setname ( sort keys %{ $self->{'taxsets'} } ) {
        print $fh "$setname = [@{$self->{'taxsets'}->{$setname}}]\n\n";
    }
}

=head2 delete_taxsets

 Title     : delete_taxsets
 Usage     : $block->delete_taxsets($set1 [$set2 $set3 ...])
 Function: Removes the named sets from the Sets block
 Returns : none
 Args     : Names of sets to be deleted

=cut

sub delete_taxsets {
    my ( $self, @setnames ) = @_;
    for my $setname (@setnames) {
        delete ${ $self->{'taxsets'} }{$setname};
    }
}

=head2 exclude_otus

 Title     : exclude_otus
 Usage     : $block->exclude_otus($otu_array_ref)
 Function: Finds and deletes each of the given otus from any sets they appear in
 Returns : none
 Args     : Names of otus to be removed

=cut

sub exclude_otus {
    my ( $self, $otus_to_remove ) = @_;
    for my $setname ( keys %{ $self->{'taxsets'} } ) {
        for ( my $i = 0; $i < @{ $self->{'taxsets'}{$setname} }; $i++ ) {
            for my $otu_to_remove (@$otus_to_remove) {
                if ( $self->{'taxsets'}->{$setname}[$i] eq $otu_to_remove ) {
                    splice( @{ $self->{'taxsets'}{$setname} }, $i, 1 );
                }
            }
        }
    }
}

=head2 select_otus

 Title     : select_otus
 Usage     : $block->select_otus($otu_array_ref)
 Function: Finds the given otus and removes all others from any sets they appear in
 Returns : none
 Args     : Names of otus to be removed

=cut

sub select_otus {
    my ( $self, $otus_to_keep ) = @_;
    my $newsets;
    for my $setname ( keys %{ $self->{'taxsets'} } ) {
        $$newsets{$setname} = [];
        for my $otu_element ( @{ $self->{'taxsets'}{$setname} } ) {
            for my $otu_to_keep (@$otus_to_keep) {
                if ( $otu_element eq $otu_to_keep ) {
                    push( @{ $$newsets{$setname} }, $otu_to_keep );
                }
            }
        }
    }
    $self->set_taxsets($newsets);
}

=head2 rename_otus

 Title   : rename_otus
 Usage   : $block->rename_otus($names);
 Function: rename all OTUs
 Returns : none
 Args    : hash of OTU names

=cut

sub rename_otus {
    my ( $self, $translation ) = @_;
    for my $setname ( @{ $self->get_taxset_names() } ) {
        my @otu_names = @{ $self->get_taxset($setname) };
        my @new_otu_names;
        for my $otu_name (@otu_names) {
            if ( my $new_name = $$translation{$otu_name} ) {
                push( @new_otu_names, $new_name );
            }
            else {
                push( @new_otu_names, $otu_name );
            }
        }
        $self->add_taxsets( { $setname, \@new_otu_names } );
    }
}

=head2 add_otu_clone

 Title   : add_otu_clone
 Usage   : ...
 Function: ...
 Returns : ...
 Args    : ...

=cut

sub add_otu_clone {
	my ( $self, $original_otu_name, $copy_otu_name ) = @_;
	# print "Warning: Bio::NEXUS::SetsBlock::add_otu_clone() method not fully implemented\n";

	# add the cloned otu to those sets that contain the original otu
	foreach my $set_id (keys %{ $self->get_taxsets() }) {
		#print "> set ", $set_id, "\n";
		my @set = @{ $self->get_taxsets()->{$set_id} };
		foreach my $otu (@set) {
			if ($otu eq $original_otu_name) {
				#print "> found the original otu in ", $set_id, "\n";
				push (@{$self->{'taxsets'}{$set_id}}, $copy_otu_name);
			}
		}
	}
}

=head2 rename_taxsets

 Title     : rename_taxsets
 Usage     : $block->rename_taxsets($oldsetname1, $newsetname1, ...)
 Function: Renames sets
 Returns : none
 Args     : Oldname, newname pairs

=cut

sub rename_taxsets {
    my ( $self, @old_and_new ) = @_;
    my ( @old, @new );
    while (@old_and_new) {
        push( @old, shift(@old_and_new) );
        push( @new, shift(@old_and_new) );
    }
    for ( my $i = 0; $i < scalar(@old); $i++ ) {
        if ( $self->{'taxsets'}{ $old[$i] } ) {
            $self->{'taxsets'}{ $new[$i] } = $self->{'taxsets'}{ $old[$i] };
            delete $self->{'taxsets'}{ $old[$i] };
        }
        else {
            print "$old[$i] is not the name of a set in this NEXUS file.\n";
        }
    }
}

=head2 equals

 Name    : equals
 Usage   : $setsblock->equals($another);
 Function: compare if two Bio::NEXUS::SetsBlock objects are equal
 Returns : boolean
 Args    : a Bio::NEXUS::SetsBlock object

=cut

sub equals {
    my ( $block1, $block2 ) = @_;
    if ( !Bio::NEXUS::Block::equals( $block1, $block2 ) ) { return 0; }
    my $sets1 = $block1->get_taxsets();
    my $sets2 = $block2->get_taxsets();
    if ( keys %$sets1 != keys %$sets2 ) { return 0; }
    for my $setname1 ( keys %$sets1 ) {
        unless ( ( defined $$sets2{$setname1} )
            && ( @{ $$sets1{$setname1} } == @{ $$sets2{$setname1} } ) )
        {
            return 0;
        }
    }
    for my $setname1 ( keys %$sets1 ) {
        @{ $$sets1{$setname1} } = sort @{ $$sets1{$setname1} };
        @{ $$sets2{$setname1} } = sort @{ $$sets2{$setname1} };
        for ( my $i = 0; $i < @{ $$sets1{$setname1} }; $i++ ) {
            unless (
                ${ $$sets1{$setname1} }[$i] eq ${ $$sets2{$setname1} }[$i] )
            {
                return 0;
            }
        }
    }
    return 1;
}

=begin comment

 Name    : _write
 Usage   : $sets -> _write($filehandle, $verbose);
 Function: Writes NEXUS Sets block from stored data
 Returns : none
 Args    : none

=end comment

=cut

sub _write {
    my ( $self, $fh, $verbose ) = @_;
    $fh ||= \*STDOUT;

    Bio::NEXUS::Block::_write( $self, $fh );
    for my $setname ( sort keys %{ $self->{'taxsets'} } ) {
        my @set_elements = sort @{ ${ $self->{'taxsets'} }{$setname} };
        my $i            = 0;
        for ( my $j = 0; $j + 1 < @set_elements; $j++ ) {
            if ( $set_elements[$i] eq $set_elements[ $i + 1 ] ) {
                splice( @set_elements, $i, 1 );
            }
            else {
                $i++;
            }
        }
        $setname = _nexus_formatted($setname);
        print $fh "\tTAXSET $setname =";
        for my $element (@set_elements) {
            $element = _nexus_formatted($element);
            print $fh " $element";
        }
        print $fh ";\n";
    }
    print $fh "END;\n";
}

sub AUTOLOAD {
    return if $AUTOLOAD =~ /DESTROY$/;
    my $package_name = __PACKAGE__ . '::';

    # The following methods are deprecated and are temporarily supported
    # via a warning and a redirection
    my %synonym_for = (

#        "${package_name}parse"      => "${package_name}_parse_tree",  # example
    );

    if ( defined $synonym_for{$AUTOLOAD} ) {
        $logger->warn("$AUTOLOAD() is deprecated; use $synonym_for{$AUTOLOAD}() instead");
        goto &{ $synonym_for{$AUTOLOAD} };
    }
    else {
        Bio::NEXUS::Util::Exceptions::UnknownMethod->throw(
        	'error' => "ERROR: Unknown method $AUTOLOAD called"
        );
    }
    return;
}

1;