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