1#################################################################
2# Block.pm
3#################################################################
4# Author: Chengzhi Liang, Weigang Wiu, Eugene Melamud, Peter Yang, Thomas Hladish
5# $Id: Block.pm,v 1.49 2007/09/24 04:52:11 rvos Exp $
6
7#################### START POD DOCUMENTATION ##################
8
9=head1 NAME
10
11Bio::NEXUS::Block - Provides useful functions for blocks in NEXUS file (parent class).
12
13=head1 SYNOPSIS
14
15This module is the super class of all NEXUS block classes. It is not used specifically from a program; in other words, you don't create a new Bio::NEXUS::Block object. Other modules, like AssumptionsBlock, simply inherit subroutines from this module.
16
17=head1 DESCRIPTION
18
19Provides a few useful functions for general blocks (to be used by sub-classes).
20
21=head1 COMMENTS
22
23=head1 FEEDBACK
24
25All feedback (bugs, feature enhancements, etc.) are greatly appreciated.
26
27=head1 AUTHORS
28
29 Chengzhi Liang (liangc@umbi.umd.edu)
30 Weigang Qiu (weigang@genectr.hunter.cuny.edu)
31 Eugene Melamud (melamud@carb.nist.gov)
32 Peter Yang (pyang@rice.edu)
33 Thomas Hladish (tjhladish at yahoo)
34
35=head1 VERSION
36
37$Revision: 1.49 $
38
39=head1 METHODS
40
41=cut
42
43package Bio::NEXUS::Block;
44
45use strict;
46use Bio::NEXUS::Functions;
47use Bio::NEXUS::Util::Logger;
48use Bio::NEXUS::Util::Exceptions 'throw';
49#use Data::Dumper; # XXX this is not used, might as well not import it!
50#use Carp; # XXX this is not used, might as well not import it!
51use vars qw($VERSION $AUTOLOAD);
52
53use Bio::NEXUS; $VERSION = $Bio::NEXUS::VERSION;
54my $logger = Bio::NEXUS::Util::Logger->new();
55
56=head2 clone
57
58 Title   : clone
59 Usage   : my $newblock = $block->clone();
60 Function: clone a block object (shallow)
61 Returns : Block object
62 Args    : none
63
64=cut
65
66sub clone {
67    my ($self) = @_;
68    my $class = ref($self);
69    my $newblock = bless( { %{$self} }, $class );
70    return $newblock;
71}
72
73=head2 get_type
74
75 Title   : get_type
76 Usage   : print $block->get_type();
77 Function: Returns a string containing the block type
78 Returns : type (string)
79 Args    : none
80
81=cut
82
83sub get_type { shift->{'type'} }
84
85=head2 set_ntax
86
87 Title   : set_ntax
88 Usage   : print $block->set_ntax();
89 Function: Sets the value of Dimensions:ntax
90 Returns : none
91 Args    : number of taxa (scalar)
92
93=cut
94
95sub set_ntax {
96    my ( $self, $ntax ) = @_;
97    $self->{'dimensions'}{'ntax'} = $ntax;
98    return;
99}
100
101=begin comment
102
103 Title   : _parse_block
104 Usage   : $block->_parse_block(\@commands, $verbose_flag);
105 Function: Generic block parser that works for all block types, so long as appropriate command parsers have been written
106 Returns : none
107 Args    : array ref of commands, as parsed by Bio::NEXUS::read; and an optional verbose flag
108
109=end comment
110
111=cut
112
113sub _parse_block {
114    my ( $self, $commands, $verbose ) = @_;
115    my $type = $self->get_type();
116    $logger->info("Analyzing $type block now.");
117	CMD: for my $command (@$commands) {
118        # some of these "commands" are actually command-level comments
119        if ( $command =~ /^\[.*\]$/s ) {
120            $self->add_comment($command);
121            next CMD;
122        }
123
124        my ( $key, $val ) = $command =~ /^ \s*  (\S+)  (?:\s+ (.+) )?  /xis;
125        $key = lc $key;
126        next CMD if $key eq 'begin' || $key eq 'end';
127
128        my $parser_name = "_parse_$key";
129        $self->$parser_name($val);
130    }
131
132    $self->_post_processing();
133    $logger->info("Analysis of $type block complete.");
134    return;
135}
136
137=begin comment
138
139# This is a placeholding method only, for blocks that do not require
140# any post-parser processing (i.e., most of them)
141
142=end comment
143
144=cut
145
146sub _post_processing() {
147    my ($self) = @_;
148    return;
149}
150
151=begin comment
152
153 Title   : _parse_title
154 Usage   : $block->_parse_title($title);
155 Function: parse title, set title attribute
156 Returns : none
157 Args    : block title (string)
158
159=end comment
160
161=cut
162
163sub _parse_title {
164    my ( $self, $title ) = @_;
165    my $words = _parse_nexus_words($title);
166    $self->set_title( $words->[0] );
167    return;
168}
169
170=begin comment
171
172 Title   : _parse_link
173 Usage   : $block->_parse_link($link_command);
174 Function: parse a link command, add a link attribute
175 Returns : none
176 Args    : link command (string)
177
178=end comment
179
180=cut
181
182sub _parse_link {
183    my ( $self, $string ) = @_;
184    my ( $name, $title ) = split /\s*=\s*/, $string;
185    my ($link) = @{ _parse_nexus_words($title) };
186    $self->add_link( $name, $link );
187    return $name, $link;
188}
189
190=begin comment
191
192 Title   : _parse_dimensions
193 Usage   : $block->_parse_dimensions($dimension_command);
194 Function: parse a dimensions command, set dimensions attributes
195 Returns : none
196 Args    : dimensions command (string)
197
198=end comment
199
200=cut
201
202sub _parse_dimensions {
203    my ( $self, $string ) = @_;
204    my %dimensions = ();
205
206    # Set dimension X to Y, if of the form X = Y; otherwise,
207    # set X to 1 (i.e., TRUE)
208    while ( $string =~ s/\s* (\S+) (?: \s*=\s* (\S+) )//x ) {
209        $dimensions{ lc $1 } = defined $2 ? lc $2 : 1;
210    }
211    $self->set_dimensions( \%dimensions );
212    return;
213}
214
215=head2 set_dimensions
216
217 Title   : set_dimensions
218 Usage   : $block->set_dimensions($dimensions);
219 Function: set a dimensions command
220 Returns : none
221 Args    : hash content of dimensions command
222
223=cut
224
225sub set_dimensions {
226    my ( $self, $dimensions ) = @_;
227    $self->{'dimensions'} = $dimensions;
228    return;
229}
230
231=head2 get_dimensions
232
233 Title   : get_dimensions
234 Usage   : $block->get_dimensions($attribute);
235 Function: get a dimensions command
236 Returns : hash content of dimensions command, or the value for a particular attribute if specified
237 Args    : none, or a string
238
239=cut
240
241sub get_dimensions {
242    my ( $self, $attribute ) = @_;
243    $attribute
244        ? return $self->{'dimensions'}->{$attribute}
245        : return $self->{'dimensions'};
246}
247
248=head2 set_command
249
250 Title   : set_command
251 Usage   : $block->set_command($command, $content);
252 Function: Set a command
253 Returns : none
254 Args    : comand name, and content (string)
255
256=cut
257
258sub set_command {
259    my ( $self, $command, $content ) = @_;
260    $self->{$command} = $content;
261    return;
262}
263
264=head2 set_title
265
266 Title   : set_title
267 Usage   : $block->set_title($name);
268 Function: Set the block name
269 Returns : none
270 Args    : block name (string)
271
272=cut
273
274sub set_title {
275    my ( $self, $title ) = @_;
276    $self->{'title'} = $title;
277    return;
278}
279
280=head2 get_title
281
282 Title   : get_title
283 Usage   : $block->get_title();
284 Function: Returns a string containing the block title
285 Returns : name (string)
286 Args    : none
287
288=cut
289
290sub get_title { shift->{'title'} }
291
292=head2 set_link
293
294 Title   : set_link
295 Usage   : $block->set_link($link_hashref);
296 Function: Set the block link commands
297 Returns : none
298 Args    : block link (hash)
299
300=cut
301
302sub set_link {
303    my ( $self, $link_hashref ) = @_;
304    $self->{'link'} = $link_hashref;
305    return;
306}
307
308=head2 add_link
309
310 Title   : add_link
311 Usage   : $block->add_link($linkname, $title);
312 Function: add a link command
313 Returns : none
314 Args    : $link, $title (of another block)
315
316=cut
317
318sub add_link {
319    my ( $self, $link, $title ) = @_;
320    $self->{'link'}{$link} = $title;
321}
322
323=head2 get_link
324
325 Title   : get_link
326 Usage   : $block->get_link();
327 Function: Returns a hash containing the block links
328 Returns : link (hash)
329 Args    : none
330
331=cut
332
333sub get_link {
334    my ( $self, $link ) = @_;
335    if ( !$self->{'link'} ) { return {}; }
336    if ($link) { return $self->{'link'}{$link}; }
337    return $self->{'link'};
338}
339
340=begin comment
341
342 Title   : _parse_taxlabels
343 Usage   : $self->_parse_taxlabels($buffer); (private)
344 Function: Processes the buffer containing taxonomic labels
345 Returns : array ref to the taxlabels
346 Args    : the buffer to parse (string)
347 Method  : Gets rid of extra blanks and semicolon if any. Removes 'taxlabels',
348           then separates by whitespace. For each OTU, creates a Bio::NEXUS::Node
349           to store information. Method halts
350           program if number of taxa input does not equal the dimensions given
351           in the actual file.
352
353=end comment
354
355=cut
356
357# Used by TaxaBlock and all Matrix subclasses
358
359sub _parse_taxlabels {
360    my ( $self, $buffer, $ntax ) = @_;
361    my @taxlabels = @{ _parse_nexus_words($buffer) };
362
363    my $counter = scalar @taxlabels;
364    if ( $ntax && $counter != $ntax ) {
365    	throw 'BadArgs' => "Number of taxa specified does not equal number of taxa listed:\n"
366            . "\tdimensions = $ntax, whereas actual number = $counter.\n";
367    }
368    $self->set_taxlabels( \@taxlabels );
369    return \@taxlabels;
370}
371
372=head2 set_taxlabels
373
374 Title   : set_taxlabels
375 Usage   : $block->set_taxlabels($labels);
376 Function: Set the taxa names
377 Returns : none
378 Args    : array of taxa names
379
380=cut
381
382# Used by TaxaBlock and all Matrix subclasses
383
384sub set_taxlabels {
385    my ( $self, $taxlabels ) = @_;
386    $self->{'taxlabels'} = $taxlabels;
387    return;
388}
389
390=head2 add_taxlabel
391
392 Title   : add_taxlabel
393 Usage   : $block->add_taxlabel($label);
394 Function: add a taxon name
395 Returns : none
396 Args    : a taxon name
397
398=cut
399
400# Used by TaxaBlock and all Matrix subclasses
401
402sub add_taxlabel {
403    my ( $self, $label ) = @_;
404    push @{ $self->{'taxlabels'} }, $label;
405}
406
407=head2 get_taxlabels
408
409 Title   : get_taxlabels
410 Usage   : $block->get_taxlabels();
411 Function: Returns an array of taxa labels
412 Returns : taxa names
413 Args    : none
414
415=cut
416
417# Used by TaxaBlock and all Matrix subclasses
418
419sub get_taxlabels { shift->{'taxlabels'} || [] }
420
421=head2 set_otus
422
423 Title   : set_otus
424 Usage   : $block->set_otus($otus);
425 Function: sets the list of OTUs
426 Returns : none
427 Args    : array of OTUs
428
429=cut
430
431sub set_otus {
432    my ( $self, $otus ) = @_;
433    $self->{'otuset'}->set_otus($otus);
434    return;
435}
436
437=head2 get_otus
438
439 Title   : get_otus
440 Usage   : $block->get_otus();
441 Function: Returns array of otus
442 Returns : all otus
443 Args    : none
444
445=cut
446
447sub get_otus { shift->{'otuset'}->get_otus() }
448
449=head2 set_otuset
450
451 Title   : set_otuset
452 Usage   : $block->set_otuset($otuset);
453 Function: Set the otus
454 Returns : none
455 Args    : TaxUnitSet object
456
457=cut
458
459sub set_otuset {
460    my ( $self, $set ) = @_;
461    $self->{'otuset'} = $set;
462    return;
463}
464
465=head2 get_otuset
466
467 Title   : get_otuset
468 Usage   : $block->get_otuset();
469 Function: get the OTUs
470 Returns : TaxUnitSet object
471 Args    : none
472
473=cut
474
475sub get_otuset { shift->{'otuset'} }
476
477=head2 select_otus
478
479 Title   : select_otus
480 Usage   : $block->select_otus($names);
481 Function: select a subset of OTUs
482 Returns : array of OTUs
483 Args    : OTU names
484
485=cut
486
487sub select_otus {
488    my ( $self, $otunames ) = @_;
489    if ( $self->get_otuset() ) {
490        $self->set_otuset( $self->get_otuset()->subset($otunames) );
491    }
492    if ( $self->get_taxlabels() ) {
493        $self->set_taxlabels($otunames);
494    }
495    if ( $self->get_type() =~ m/sets/i ) {
496        $self->select_otus($otunames);
497    }
498}
499
500=head2 rename_otus
501
502 Title   : rename_otus
503 Usage   : $block->rename_otus($names);
504 Function: rename all OTUs
505 Returns : none
506 Args    : hash of OTU names
507
508=cut
509
510sub rename_otus {
511    my ( $self, $translate ) = @_;
512    if ( $self->get_otuset() ) {
513        $self->get_otuset()->rename_otus($translate);
514    }
515    if ( $self->get_taxlabels() ) {
516        $self->set_taxlabels( values %{$translate} );
517    }
518}
519
520=head2 add_otu_clone
521
522 Title   : add_otu_clone
523 Usage   : ...
524 Function: ...
525 Returns : ...
526 Args    : ...
527
528=cut
529
530sub add_otu_clone {
531	my ( $self, $original_otu_name, $copy_otu_name ) = @_;
532	$logger->warn("method not fully implemented");
533}
534
535=head2 set_comments
536
537 Title   : set_comments
538 Usage   : $block->set_comments($comments);
539 Function: Set the block comments
540 Returns : none
541 Args    : block comments (array of strings)
542
543=cut
544
545sub set_comments {
546    my ( $self, $comments ) = @_;
547    $self->{'comments'} = $comments;
548    return;
549}
550
551=head2 get_comments
552
553 Title   : get_comments
554 Usage   : $block->get_comments();
555 Function: Returns block comments
556 Returns : comments (array of strings)
557 Args    : none
558
559=cut
560
561sub get_comments { shift->{'comments'} || [] }
562
563=head2 add_comment
564
565 Title   : add_comment
566 Usage   : $block->add_comment($comment);
567 Function: add a comment
568 Returns : none
569 Args    : comment (string)
570
571=cut
572
573sub add_comment {
574    my ( $self, $comment ) = @_;
575    push @{ $self->{'comments'} }, $comment;
576}
577
578=head2 equals
579
580 Name    : equals
581 Usage   : $block->equals($another);
582 Function: compare if two Block objects are equal
583 Returns : boolean
584 Args    : a Block object'
585
586=cut
587
588sub equals {
589    my ( $self, $block ) = @_;
590    if ( $self->get_type ne $block->get_type ) { return 0; }
591    if ( ( $self->get_title || $block->get_title )
592        && !( $self->get_title && $block->get_title ) )
593    {
594        return 0;
595    }
596    if ( ( $self->get_title || '' ) ne ( $block->get_title || '' ) ) {
597        return 0;
598    }
599    my @keys1 = sort keys %{ $self->get_link() };
600    my @keys2 = sort keys %{ $block->get_link() };
601    if ( scalar @keys1 != scalar @keys2 ) { return 0; }
602    for ( my $i = 0; $i < @keys1; $i++ ) {
603        if (   $keys1[$i] ne $keys2[$i]
604            || $self->{'link'}{ $keys1[$i] } ne $block->{'link'}{ $keys2[$i] } )
605        {
606            return 0;
607        }
608    }
609    return 1;
610}
611
612=begin comment
613
614 Title   : _write_comments
615 Usage   : $block->_write_comments();
616 Function: Writes comments stored in the block
617 Returns : none
618 Args    : none
619
620=end comment
621
622=cut
623
624sub _write_comments {
625    my $self = shift;
626    my $fh = shift || \*STDOUT;
627    for my $comment ( @{ $self->get_comments() } ) {
628        print $fh "$comment\n";
629    }
630}
631
632=begin comment
633
634 Title   : _load_module
635 Usage   : $block->_load_module('Some::Class');
636 Function: tries to load a class
637 Returns : class on success, throws ExtensionError on failure
638 Args    : a class name
639
640=end comment
641
642=cut
643
644sub _load_module {
645	my ( $self, $class ) = @_;
646	my $path = $class;
647	$path =~ s|::|/|g;
648	$path .= '.pm';
649	eval { require $path };
650	if ( $@ ) {
651		throw 'ExtensionError' => "Can't load $class: $@";
652	}
653	return $class;
654}
655
656=begin comment
657
658 Name    : _write
659 Usage   : $block->_write($filehandle, $verbose);
660 Function: Writes NEXUS block commands from stored data
661 Returns : none
662 Args    : none
663
664=end comment
665
666=cut
667
668sub _write {
669    my ( $self, $fh ) = @_;
670    $fh ||= \*STDOUT;
671
672    my $type = uc $self->get_type();
673    print $fh "BEGIN $type;\n";
674    $self->_write_comments($fh);
675
676    if ( $self->get_title ) {
677    # added _nexus_formatted to protect name with embedded symbols
678        print $fh "\tTITLE ", _nexus_formatted($self->get_title), ";\n";
679    }
680    if ( $self->get_link ) {
681        for my $key ( keys %{ $self->get_link } ) {
682            print $fh "\tLINK ", "$key=", $self->get_link->{$key}, ";\n";
683        }
684    }
685}
686
687sub AUTOLOAD {
688    return if $AUTOLOAD =~ /DESTROY$/;
689    my $package_name = __PACKAGE__ . '::';
690
691    # The following methods are deprecated and are temporarily supported
692    # via a warning and a redirection
693    my %synonym_for = (
694        "${package_name}parse_stringtokens" =>
695            "${package_name}_parse_nexus_words",
696        "${package_name}_parse_stringtokens" =>
697            "${package_name}_parse_nexus_words",
698        "${package_name}write" => "${package_name}_write",
699    );
700
701    if ( defined $synonym_for{$AUTOLOAD} ) {
702        $logger->warn("$AUTOLOAD() is deprecated; use $synonym_for{$AUTOLOAD}() instead");
703        goto &{ $synonym_for{$AUTOLOAD} };
704    }
705    else {
706    	throw 'UnknownMethod' => "ERROR: Unknown method $AUTOLOAD called";
707    }
708}
709
7101;
711