Bio/Matrix/PhylipDist.pm

   1 # BioPerl module for Bio::Matrix::PhylipDist
   2 #
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Shawn Hoon <shawnh@fugu-sg.org>
   7 #
   8 # Copyright Shawn Hoon
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 # POD documentation - main docs before the code
  13
  14 =head1 NAME
  15
  16 Bio::Matrix::PhylipDist - A Phylip Distance Matrix object
  17
  18 =head1 SYNOPSIS
  19
  20   use Bio::Tools::Phylo::Phylip::ProtDist;
  21   my $dist = Bio::Tools::Phylo::Phylip::ProtDist->new(
  22     -file=>"protdist.out",
  23     -program=>"ProtDist");
  24   #or
  25    my $dist = Bio::Tools::Phylo::Phylip::ProtDist->new(
  26     -fh=>"protdist.out",
  27     -program=>"ProtDist");
  28
  29
  30   #get specific entries
  31   my $distance_value = $dist->get_entry('ALPHA','BETA');
  32   my @columns        = $dist->get_column('ALPHA');
  33   my @rows           = $dist->get_row('BETA');
  34   my @diagonal       = $dist->get_diagonal();
  35
  36   #print the matrix in phylip numerical format
  37   print $dist->print_matrix;
  38
  39 =head1 DESCRIPTION
  40
  41 Simple object for holding Distance Matrices generated by the following Phylip programs:
  42
  43 1) dnadist
  44 2) protdist
  45 3) restdist
  46
  47 It currently handles parsing of the matrix without the data output option.
  48
  49     5
  50 Alpha          0.00000  4.23419  3.63330  6.20865  3.45431
  51 Beta           4.23419  0.00000  3.49289  3.36540  4.29179
  52 Gamma          3.63330  3.49289  0.00000  3.68733  5.84929
  53 Delta          6.20865  3.36540  3.68733  0.00000  4.43345
  54 Epsilon        3.45431  4.29179  5.84929  4.43345  0.00000
  55
  56 =head1 FEEDBACK
  57
  58
  59 =head2 Mailing Lists
  60
  61 User feedback is an integral part of the evolution of this and other
  62 Bioperl modules. Send your comments and suggestions preferably to one
  63 of the Bioperl mailing lists. Your participation is much appreciated.
  64
  65   bioperl-l@bioperl.org                  - General discussion
  66   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  67
  68 =head2 Support
  69
  70 Please direct usage questions or support issues to the mailing list:
  71
  72 I<bioperl-l@bioperl.org>
  73
  74 rather than to the module maintainer directly. Many experienced and
  75 reponsive experts will be able look at the problem and quickly
  76 address it. Please include a thorough description of the problem
  77 with code and data examples if at all possible.
  78
  79 =head2 Reporting Bugs
  80
  81 Report bugs to the Bioperl bug tracking system to help us keep track
  82 the bugs and their resolution.  Bug reports can be submitted via the
  83 web:
  84
  85   https://github.com/bioperl/bioperl-live/issues
  86
  87 =head1 AUTHOR - Shawn Hoon
  88
  89 Email shawnh@fugu-sg.org
  90
  91 =head1 CONTRIBUTORS
  92
  93 Jason Stajich, jason-at-bioperl-dot-org
  94
  95 =head1 APPENDIX
  96
  97
  98 The rest of the documentation details each of the object
  99 methods. Internal methods are usually preceded with a "_".
 100
 101 =cut
 102
 103 # Let the code begin...
 104
 105 package Bio::Matrix::PhylipDist;
 106 use strict;
 107
 108
 109 use base qw(Bio::Root::Root Bio::Matrix::MatrixI);
 110
 111 =head2 new
 112
 113  Title   : new
 114  Usage   : my $family = Bio::Matrix::PhylipDist->new(-file=>"protdist.out",
 115                                                      -program=>"protdist");
 116  Function: Constructor for PhylipDist Object
 117  Returns : L<Bio::Matrix::PhylipDist>
 118
 119 =cut
 120
 121 sub new {
 122     my ($class,@args) = @_;
 123     my $self = $class->SUPER::new(@args);
 124     my ($matrix,$values, $names,
 125         $program,$matname,
 126         $matid) = $self->_rearrange([qw(MATRIX
 127                                         VALUES
 128                                         NAMES
 129                                         PROGRAM
 130                                         MATRIX_NAME
 131                                         MATRIX_ID
 132                                         )],@args);
 133
 134     ($matrix && $values && $names) ||
 135         $self->throw("Need matrix, values, and names fields all provided!");
 136
 137     $program && $self->matrix_name($program) if defined $program;
 138
 139     $self->_matrix($matrix) if ref($matrix) =~ /HASH/i;
 140     $self->_values($values) if ref($values) =~ /ARRAY/i;
 141     $self->names($names) if ref($names) =~ /ARRAY/i;
 142
 143     $self->matrix_name($matname) if defined $matname;
 144     $self->matrix_id  ($matid)   if defined $matid;
 145
 146     return $self;
 147 }
 148
 149 =head2 get_entry
 150
 151  Title   : get_entry
 152  Usage   : $matrix->get_entry();
 153  Function: returns a particular entry
 154  Returns : a float
 155  Arguments:  string id1, string id2
 156
 157 =cut
 158
 159 sub get_entry {
 160   my ($self,$row,$column) = @_;
 161   $row && $column || $self->throw("Need at least 2 ids");
 162   my %matrix = %{$self->_matrix};
 163   my @values = @{$self->_values};
 164   if(ref $matrix{$row}{$column}){
 165       my ($i,$j) = @{$matrix{$row}{$column}};
 166       return $values[$i][$j];
 167   }
 168   return;
 169
 170 }
 171
 172 =head2 get_row
 173
 174  Title   : get_row
 175  Usage   : $matrix->get_row('ALPHA');
 176  Function: returns a particular row
 177  Returns : an array of float
 178  Arguments:  string id1
 179
 180 =cut
 181
 182 sub get_row {
 183     my ($self,$row) = @_;
 184     $row || $self->throw("Need at least a row id");
 185
 186     my %matrix = %{$self->_matrix};
 187     my @values = @{$self->_values};
 188     my @names = @{$self->names};
 189     $matrix{$row} || return;
 190     my ($val) = values %{$matrix{$row}};
 191     my $row_pointer = $val->[0];
 192     my $index = scalar(@names)-1;
 193     return @{$values[$row_pointer]}[0..$index];
 194 }
 195
 196 =head2 get_column
 197
 198  Title   : get_column
 199  Usage   : $matrix->get_column('ALPHA');
 200  Function: returns a particular column
 201  Returns : an array of floats
 202  Arguments:  string id1
 203
 204 =cut
 205
 206 sub get_column {
 207     my ($self,$column) = @_;
 208     $column || $self->throw("Need at least a column id");
 209
 210     my %matrix = %{$self->_matrix};
 211     my @values = @{$self->_values};
 212     my @names = @{$self->names};
 213     $matrix{$column} || return ();
 214     my ($val) = values %{$matrix{$column}};
 215     my $row_pointer = $val->[0];
 216     my @ret;
 217     for(my $i=0; $i < scalar(@names); $i++) {
 218         push @ret, $values[$i][$row_pointer];
 219     }
 220     return @ret;
 221 }
 222
 223 =head2 get_diagonal
 224
 225  Title   : get_diagonal
 226  Usage   : $matrix->get_diagonal();
 227  Function: returns the diagonal of the matrix
 228  Returns : an array of float
 229  Arguments:  string id1
 230
 231 =cut
 232
 233 sub get_diagonal {
 234   my ($self) = @_;
 235   my %matrix = %{$self->_matrix};
 236   my @values = @{$self->_values};
 237   my @return;
 238   foreach my $name (@{$self->names}){
 239     my ($i,$j) = @{$matrix{$name}{$name}};
 240     push @return,$values[$i][$j];
 241   }
 242   return @return;
 243 }
 244
 245 =head2 print_matrix
 246
 247  Title   : print_matrix
 248  Usage   : $matrix->print_matrix();
 249  Function: returns a string of the matrix in phylip format
 250  Returns : a string
 251  Arguments:
 252
 253 =cut
 254
 255 sub print_matrix {
 256   my ($self) = @_;
 257   my @names = @{$self->names};
 258   my @values = @{$self->_values};
 259   my %matrix = %{$self->_matrix};
 260   my $str;
 261   $str.= (" "x 4). scalar(@names)."\n";
 262   foreach my $name (@names){
 263     my $newname = $name. (" " x (15-length($name)));
 264     if( length($name) >= 15 ) { $newname .= " " }
 265     $str.=$newname;
 266     my $count = 0;
 267     foreach my $n (@names) {
 268       my ($i,$j) = @{$matrix{$name}{$n}};
 269       if($count < $#names){
 270         $str .= $values[$i][$j]. "  ";
 271       }
 272       else {
 273           if( ! defined $values[$i][$j] ) {
 274               $self->debug("no value for $i,$j cell\n");
 275           } else {
 276               $str .= $values[$i][$j];
 277           }
 278       }
 279       $count++;
 280     }
 281     $str.="\n";
 282   }
 283   return $str;
 284 }
 285
 286 =head2 _matrix
 287
 288  Title   : _matrix
 289  Usage   : $matrix->_matrix();
 290  Function: get/set for hash reference of the pointers
 291            to the value matrix
 292  Returns : hash reference
 293  Arguments: hash reference
 294
 295 =cut
 296
 297 sub _matrix {
 298   my ($self,$val) = @_;
 299   if($val){
 300     $self->{'_matrix'} = $val;
 301   }
 302   return $self->{'_matrix'};
 303 }
 304
 305
 306 =head2 names
 307
 308  Title   : names
 309  Usage   : $matrix->names();
 310  Function: get/set for array ref of names of sequences
 311  Returns : an array reference
 312  Arguments: an array reference
 313
 314 =cut
 315
 316 sub names {
 317   my ($self,$val) = @_;
 318   if($val){
 319     $self->{'_names'} = $val;
 320   }
 321   return $self->{'_names'};
 322 }
 323
 324 =head2 program
 325
 326  Title   : program
 327  Usage   : $matrix->program();
 328  Function: get/set for the program name generating this
 329            matrix
 330  Returns : string
 331  Arguments: string
 332
 333 =cut
 334
 335 sub program {
 336   my ($self) = shift;
 337   return $self->matrix_name(@_);
 338 }
 339
 340 =head2 _values
 341
 342  Title   : _values
 343  Usage   : $matrix->_values();
 344  Function: get/set for array ref of the matrix containing
 345            distance values
 346  Returns : an array reference
 347  Arguments: an array reference
 348
 349 =cut
 350
 351 sub _values {
 352   my ($self,$val) = @_;
 353   if($val){
 354     $self->{'_values'} = $val;
 355   }
 356   return $self->{'_values'};
 357 }
 358
 359
 360 =head1 L<Bio::Matrix::MatrixI> implementation
 361
 362
 363 =head2 matrix_id
 364
 365  Title   : matrix_id
 366  Usage   : my $id = $matrix->matrix_id
 367  Function: Get/Set the matrix ID
 368  Returns : scalar value
 369  Args    : [optional] new id value to store
 370
 371
 372 =cut
 373
 374 sub matrix_id{
 375    my $self = shift;
 376    return $self->{'_matid'} = shift if @_;
 377    return $self->{'_matid'};
 378
 379
 380 }
 381
 382 =head2 matrix_name
 383
 384  Title   : matrix_name
 385  Usage   : my $name = $matrix->matrix_name();
 386  Function: Get/Set the matrix name
 387  Returns : scalar value
 388  Args    : [optional] new matrix name value
 389
 390
 391 =cut
 392
 393 sub matrix_name{
 394    my $self = shift;
 395    return $self->{'_matname'} = shift if @_;
 396    return $self->{'_matname'};
 397 }
 398
 399 =head2 column_header
 400
 401  Title   : column_header
 402  Usage   : my $name = $matrix->column_header(0)
 403  Function: Gets the column header for a particular column number
 404  Returns : string
 405  Args    : integer
 406
 407
 408 =cut
 409
 410 sub column_header{
 411     my ($self,$num) = @_;
 412     my @coln = $self->column_names;
 413     return $coln[$num];
 414 }
 415
 416
 417 =head2 row_header
 418
 419  Title   : row_header
 420  Usage   : my $name = $matrix->row_header(0)
 421  Function: Gets the row header for a particular row number
 422  Returns : string
 423  Args    : integer
 424
 425
 426 =cut
 427
 428 sub row_header{
 429     my ($self,$num) = @_;
 430     my @rown = $self->row_names;
 431    return $rown[$num];
 432 }
 433 =head2 column_num_for_name
 434
 435  Title   : column_num_for_name
 436  Usage   : my $num = $matrix->column_num_for_name($name)
 437  Function: Gets the column number for a particular column name
 438  Returns : integer
 439  Args    : string
 440
 441
 442 =cut
 443
 444 sub column_num_for_name{
 445    my ($self,$name) = @_;
 446    my $ct = 0;
 447    foreach my $n ( $self->column_names ) {
 448        return $ct if $n eq $name;
 449        $ct++;
 450    }
 451    return;
 452 }
 453
 454 =head2 row_num_for_name
 455
 456  Title   : row_num_for_name
 457  Usage   : my $num = $matrix->row_num_for_name($name)
 458  Function: Gets the row number for a particular row name
 459  Returns : integer
 460  Args    : string
 461
 462
 463 =cut
 464
 465 sub row_num_for_name{
 466    my ($self,$name) = @_;
 467    my $ct = 0;
 468    foreach my $n ( $self->row_names ) {
 469        return $ct if $n eq $name;
 470        $ct++;
 471    }
 472 }
 473
 474 =head2 num_rows
 475
 476  Title   : num_rows
 477  Usage   : my $rowcount = $matrix->num_rows;
 478  Function: Get the number of rows
 479  Returns : integer
 480  Args    : none
 481
 482
 483 =cut
 484
 485 sub num_rows{ return scalar @{shift->names} }
 486
 487 =head2 num_columns
 488
 489  Title   : num_columns
 490  Usage   : my $colcount = $matrix->num_columns
 491  Function: Get the number of columns
 492  Returns : integer
 493  Args    : none
 494
 495
 496 =cut
 497
 498 sub num_columns{
 499    return scalar @{shift->names};
 500 }
 501
 502 =head2 row_names
 503
 504  Title   : row_names
 505  Usage   : my @rows = $matrix->row_names
 506  Function: The names of all the rows
 507  Returns : array in array context, arrayref in scalar context
 508  Args    : none
 509
 510
 511 =cut
 512
 513 sub row_names{ return @{shift->names} }
 514
 515 =head2 column_names
 516
 517  Title   : column_names
 518  Usage   : my @columns = $matrix->column_names
 519  Function: The names of all the columns
 520  Returns : array in array context, arrayref in scalar context
 521  Args    : none
 522
 523
 524 =cut
 525
 526 sub column_names{ return @{shift->names} }
 527 1;