1######################################################
2# SetsBlock.pm
3######################################################
4# Author: Thomas Hladish
5# $Id: SetsBlock.pm,v 1.32 2007/09/21 23:09:09 rvos Exp $
6#################### START POD DOCUMENTATION ##################
7
8=head1 NAME
9
10Bio::NEXUS::SetsBlock - Represents SETS block of a NEXUS file
11
12=head1 SYNOPSIS
13
14$block_object = new Bio::NEXUS::SetsBlock($block_type, $block, $verbose);
15
16=head1 DESCRIPTION
17
18Parses Sets block of NEXUS file and stores Sets data.
19
20=head1 FEEDBACK
21
22All feedback (bugs, feature enhancements, etc.) are greatly appreciated.
23
24=head1 AUTHORS
25
26 Thomas Hladish (tjhladish at yahoo)
27
28=head1 VERSION
29
30$Revision: 1.32 $
31
32=head1 METHODS
33
34=cut
35
36package Bio::NEXUS::SetsBlock;
37
38use strict;
39#use Carp; # XXX this is not used, might as well not import it!
40#use Data::Dumper; # XXX this is not used, might as well not import it!
41use Bio::NEXUS::Functions;
42use Bio::NEXUS::Block;
43use Bio::NEXUS::Util::Exceptions;
44use Bio::NEXUS::Util::Logger;
45use vars qw(@ISA $VERSION $AUTOLOAD);
46use Bio::NEXUS; $VERSION = $Bio::NEXUS::VERSION;
47
48@ISA = qw(Bio::NEXUS::Block);
49my $logger = Bio::NEXUS::Util::Logger->new();
50
51=head2 new
52
53 Title   : new
54 Usage   : $block_object = new Bio::NEXUS::SetsBlock($block_type, $commands, $verbose)
55 Function: Creates a new Bio::NEXUS::SetsBlock object
56 Returns : Bio::NEXUS::SetsBlock object
57 Args    : type (string), the commands/comments to parse (array ref), and a verbose flag (0 or 1)
58
59=cut
60
61sub new {
62    my ( $class, $type, $commands, $verbose, $taxlabels ) = @_;
63    unless ($type) { ( $type = lc $class ) =~ s/Bio::NEXUS::(.+)Block/$1/i; }
64    my $self = { type => $type };
65    bless $self, $class;
66    $self->_parse_block( $commands, $verbose, $taxlabels )
67        if ( ( defined $commands ) and @$commands );
68    return $self;
69}
70
71=begin comment
72
73 Title   : _parse_taxset
74 Usage   :
75
76=end comment
77
78=cut
79
80sub _parse_taxset {
81    my ( $self, $buffer ) = @_;
82    my ( $setname, $equals_symb, @taxa ) = @{ _parse_nexus_words($buffer) };
83
84    my $taxsets;
85    $taxsets->{$setname} = \@taxa;
86
87    #$self->set_taxsets($taxsets);
88    $self->add_taxsets( { $setname, \@taxa } );
89
90    return $taxsets;
91}
92
93=head2 set_taxsets
94
95 Title   : set_taxsets
96 Usage   : $block->set_taxsets($taxsets);
97 Function: Set the taxsets hash
98 Returns : none
99 Args    : hash of set name keys and element arrays
100
101=cut
102
103sub set_taxsets {
104    my ( $self, $taxsets ) = @_;
105    $self->{'taxsets'} = $taxsets;
106}
107
108=head2 add_taxsets
109
110 Title   : add_taxsets
111 Usage   : $block->add_taxsets($taxsets);
112 Function: add taxa sets
113 Returns : none
114 Args    : a reference to a hash of taxa sets
115
116=cut
117
118sub add_taxsets {
119    my ( $self, $taxsets ) = @_;
120    for my $setname ( keys %{$taxsets} ) {
121        ${ $self->{'taxsets'} }{$setname} = ( $$taxsets{$setname} );
122    }
123}
124
125=head2 get_taxsets
126
127 Title   : get_taxsets
128 Usage   : $block->get_taxsets();
129 Function: Returns a hash of taxa sets
130 Returns : taxa sets
131 Args    : none
132
133=cut
134
135sub get_taxsets {
136    my ($self) = @_;
137    return $self->{'taxsets'} || {};
138}
139
140=head2 get_taxset
141
142 Title   : get_taxset
143 Usage   : $block->get_taxset($setname);
144 Function: Returns a list of OTU's
145 Returns : OTU's
146 Args    : none
147
148=cut
149
150sub get_taxset {
151    my ( $self, $setname ) = @_;
152    return $self->{'taxsets'}->{$setname} || [];
153}
154
155=head2 get_taxset_names
156
157 Title     : get_taxset_names
158 Usage     : $block->get_taxset_names()
159 Function: gets the names of all sets
160 Returns : array of names
161 Args     : none
162
163=cut
164
165sub get_taxset_names {
166    my ($self) = @_;
167    return [ sort keys %{ $self->{'taxsets'} } ];
168}
169
170=head2 print_all_taxsets
171
172 Title     : print_all_taxsets
173 Usage     : $block->print_all_taxsets($outfile)
174 Function: prints set names and elements
175 Returns : none
176 Args     : filename or filehandle
177
178=cut
179
180sub print_all_taxsets {
181    my ( $self, $outfile ) = @_;
182    my $fh;
183    if ( $outfile eq "-" || $outfile eq \*STDOUT ) {
184        $fh = \*STDOUT;
185    }
186    else {
187        open( $fh, ">$outfile" )
188            || Bio::NEXUS::Util::Exceptions::FileError->throw(
189        	'error' => "Could not open $outfile for writing"
190        );
191    }
192
193    for my $setname ( sort keys %{ $self->{'taxsets'} } ) {
194        print $fh "$setname = [@{$self->{'taxsets'}->{$setname}}]\n\n";
195    }
196}
197
198=head2 delete_taxsets
199
200 Title     : delete_taxsets
201 Usage     : $block->delete_taxsets($set1 [$set2 $set3 ...])
202 Function: Removes the named sets from the Sets block
203 Returns : none
204 Args     : Names of sets to be deleted
205
206=cut
207
208sub delete_taxsets {
209    my ( $self, @setnames ) = @_;
210    for my $setname (@setnames) {
211        delete ${ $self->{'taxsets'} }{$setname};
212    }
213}
214
215=head2 exclude_otus
216
217 Title     : exclude_otus
218 Usage     : $block->exclude_otus($otu_array_ref)
219 Function: Finds and deletes each of the given otus from any sets they appear in
220 Returns : none
221 Args     : Names of otus to be removed
222
223=cut
224
225sub exclude_otus {
226    my ( $self, $otus_to_remove ) = @_;
227    for my $setname ( keys %{ $self->{'taxsets'} } ) {
228        for ( my $i = 0; $i < @{ $self->{'taxsets'}{$setname} }; $i++ ) {
229            for my $otu_to_remove (@$otus_to_remove) {
230                if ( $self->{'taxsets'}->{$setname}[$i] eq $otu_to_remove ) {
231                    splice( @{ $self->{'taxsets'}{$setname} }, $i, 1 );
232                }
233            }
234        }
235    }
236}
237
238=head2 select_otus
239
240 Title     : select_otus
241 Usage     : $block->select_otus($otu_array_ref)
242 Function: Finds the given otus and removes all others from any sets they appear in
243 Returns : none
244 Args     : Names of otus to be removed
245
246=cut
247
248sub select_otus {
249    my ( $self, $otus_to_keep ) = @_;
250    my $newsets;
251    for my $setname ( keys %{ $self->{'taxsets'} } ) {
252        $$newsets{$setname} = [];
253        for my $otu_element ( @{ $self->{'taxsets'}{$setname} } ) {
254            for my $otu_to_keep (@$otus_to_keep) {
255                if ( $otu_element eq $otu_to_keep ) {
256                    push( @{ $$newsets{$setname} }, $otu_to_keep );
257                }
258            }
259        }
260    }
261    $self->set_taxsets($newsets);
262}
263
264=head2 rename_otus
265
266 Title   : rename_otus
267 Usage   : $block->rename_otus($names);
268 Function: rename all OTUs
269 Returns : none
270 Args    : hash of OTU names
271
272=cut
273
274sub rename_otus {
275    my ( $self, $translation ) = @_;
276    for my $setname ( @{ $self->get_taxset_names() } ) {
277        my @otu_names = @{ $self->get_taxset($setname) };
278        my @new_otu_names;
279        for my $otu_name (@otu_names) {
280            if ( my $new_name = $$translation{$otu_name} ) {
281                push( @new_otu_names, $new_name );
282            }
283            else {
284                push( @new_otu_names, $otu_name );
285            }
286        }
287        $self->add_taxsets( { $setname, \@new_otu_names } );
288    }
289}
290
291=head2 add_otu_clone
292
293 Title   : add_otu_clone
294 Usage   : ...
295 Function: ...
296 Returns : ...
297 Args    : ...
298
299=cut
300
301sub add_otu_clone {
302	my ( $self, $original_otu_name, $copy_otu_name ) = @_;
303	# print "Warning: Bio::NEXUS::SetsBlock::add_otu_clone() method not fully implemented\n";
304
305	# add the cloned otu to those sets that contain the original otu
306	foreach my $set_id (keys %{ $self->get_taxsets() }) {
307		#print "> set ", $set_id, "\n";
308		my @set = @{ $self->get_taxsets()->{$set_id} };
309		foreach my $otu (@set) {
310			if ($otu eq $original_otu_name) {
311				#print "> found the original otu in ", $set_id, "\n";
312				push (@{$self->{'taxsets'}{$set_id}}, $copy_otu_name);
313			}
314		}
315	}
316}
317
318=head2 rename_taxsets
319
320 Title     : rename_taxsets
321 Usage     : $block->rename_taxsets($oldsetname1, $newsetname1, ...)
322 Function: Renames sets
323 Returns : none
324 Args     : Oldname, newname pairs
325
326=cut
327
328sub rename_taxsets {
329    my ( $self, @old_and_new ) = @_;
330    my ( @old, @new );
331    while (@old_and_new) {
332        push( @old, shift(@old_and_new) );
333        push( @new, shift(@old_and_new) );
334    }
335    for ( my $i = 0; $i < scalar(@old); $i++ ) {
336        if ( $self->{'taxsets'}{ $old[$i] } ) {
337            $self->{'taxsets'}{ $new[$i] } = $self->{'taxsets'}{ $old[$i] };
338            delete $self->{'taxsets'}{ $old[$i] };
339        }
340        else {
341            print "$old[$i] is not the name of a set in this NEXUS file.\n";
342        }
343    }
344}
345
346=head2 equals
347
348 Name    : equals
349 Usage   : $setsblock->equals($another);
350 Function: compare if two Bio::NEXUS::SetsBlock objects are equal
351 Returns : boolean
352 Args    : a Bio::NEXUS::SetsBlock object
353
354=cut
355
356sub equals {
357    my ( $block1, $block2 ) = @_;
358    if ( !Bio::NEXUS::Block::equals( $block1, $block2 ) ) { return 0; }
359    my $sets1 = $block1->get_taxsets();
360    my $sets2 = $block2->get_taxsets();
361    if ( keys %$sets1 != keys %$sets2 ) { return 0; }
362    for my $setname1 ( keys %$sets1 ) {
363        unless ( ( defined $$sets2{$setname1} )
364            && ( @{ $$sets1{$setname1} } == @{ $$sets2{$setname1} } ) )
365        {
366            return 0;
367        }
368    }
369    for my $setname1 ( keys %$sets1 ) {
370        @{ $$sets1{$setname1} } = sort @{ $$sets1{$setname1} };
371        @{ $$sets2{$setname1} } = sort @{ $$sets2{$setname1} };
372        for ( my $i = 0; $i < @{ $$sets1{$setname1} }; $i++ ) {
373            unless (
374                ${ $$sets1{$setname1} }[$i] eq ${ $$sets2{$setname1} }[$i] )
375            {
376                return 0;
377            }
378        }
379    }
380    return 1;
381}
382
383=begin comment
384
385 Name    : _write
386 Usage   : $sets -> _write($filehandle, $verbose);
387 Function: Writes NEXUS Sets block from stored data
388 Returns : none
389 Args    : none
390
391=end comment
392
393=cut
394
395sub _write {
396    my ( $self, $fh, $verbose ) = @_;
397    $fh ||= \*STDOUT;
398
399    Bio::NEXUS::Block::_write( $self, $fh );
400    for my $setname ( sort keys %{ $self->{'taxsets'} } ) {
401        my @set_elements = sort @{ ${ $self->{'taxsets'} }{$setname} };
402        my $i            = 0;
403        for ( my $j = 0; $j + 1 < @set_elements; $j++ ) {
404            if ( $set_elements[$i] eq $set_elements[ $i + 1 ] ) {
405                splice( @set_elements, $i, 1 );
406            }
407            else {
408                $i++;
409            }
410        }
411        $setname = _nexus_formatted($setname);
412        print $fh "\tTAXSET $setname =";
413        for my $element (@set_elements) {
414            $element = _nexus_formatted($element);
415            print $fh " $element";
416        }
417        print $fh ";\n";
418    }
419    print $fh "END;\n";
420}
421
422sub AUTOLOAD {
423    return if $AUTOLOAD =~ /DESTROY$/;
424    my $package_name = __PACKAGE__ . '::';
425
426    # The following methods are deprecated and are temporarily supported
427    # via a warning and a redirection
428    my %synonym_for = (
429
430#        "${package_name}parse"      => "${package_name}_parse_tree",  # example
431    );
432
433    if ( defined $synonym_for{$AUTOLOAD} ) {
434        $logger->warn("$AUTOLOAD() is deprecated; use $synonym_for{$AUTOLOAD}() instead");
435        goto &{ $synonym_for{$AUTOLOAD} };
436    }
437    else {
438        Bio::NEXUS::Util::Exceptions::UnknownMethod->throw(
439        	'error' => "ERROR: Unknown method $AUTOLOAD called"
440        );
441    }
442    return;
443}
444
4451;
446