Bio/Cluster/SequenceFamily.pm

   1 #
   2 # BioPerl module for Bio::Cluster::SequenceFamily
   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::Cluster::SequenceFamily - Sequence Family object
  17
  18 =head1 SYNOPSIS
  19
  20   use Bio::SeqIO;
  21   use Bio::Cluster::SequenceFamily;
  22   use File::Spec;
  23
  24   my $file =  File::Spec->catfile('t','data','swiss.dat');
  25   my $seqio= Bio::SeqIO->new(-format => 'swiss',
  26                             -file => $file);
  27   my @mem;
  28   while(my $seq = $seqio->next_seq){
  29     push @mem, $seq;
  30   }
  31
  32   #create the family
  33   my $family = Bio::Cluster::SequenceFamily->new(
  34           -family_id=>"Family_1",
  35           -description=>"Family Description Here",
  36           -annotation_score=>"100",
  37           -members=>\@mem);
  38
  39   #access the family
  40
  41   foreach my $mem ($family->get_members){
  42     print $mem->display_id."\t".$mem->desc."\n";
  43   }
  44
  45   #select members if members have a Bio::Species Object
  46
  47   my @mem = $family->get_members(-binomial=>"Homo sapiens");
  48   @mem = $family->get_members(-ncbi_taxid => 9606);
  49   @mem = $family->get_members(-common_name=>"Human");
  50   @mem = $family->get_members(-species=>"sapiens");
  51   @mem = $family->get_members(-genus=>"Homo");
  52
  53 =head1 DESCRIPTION
  54
  55 This is a simple Family object that may hold any group of object. For more
  56 specific families, one should derive from FamilyI.
  57
  58 =head1 FEEDBACK
  59
  60 Email bioperl-l@bioperl.org for support and feedback.
  61
  62 =head2 Mailing Lists
  63
  64 User feedback is an integral part of the evolution of this and other
  65 Bioperl modules. Send your comments and suggestions preferably to one
  66 of the Bioperl mailing lists. Your participation is much appreciated.
  67
  68   bioperl-l@bioperl.org                  - General discussion
  69   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  70
  71 =head2 Support
  72
  73 Please direct usage questions or support issues to the mailing list:
  74
  75 I<bioperl-l@bioperl.org>
  76
  77 rather than to the module maintainer directly. Many experienced and
  78 reponsive experts will be able look at the problem and quickly
  79 address it. Please include a thorough description of the problem
  80 with code and data examples if at all possible.
  81
  82 =head2 Reporting Bugs
  83
  84 Report bugs to the Bioperl bug tracking system to help us keep track
  85 the bugs and their resolution.  Bug reports can be submitted via the
  86 web:
  87
  88   https://github.com/bioperl/bioperl-live/issues
  89
  90 =head1 AUTHOR - Shawn Hoon
  91
  92 Email shawnh@fugu-sg.org
  93
  94 =head1 APPENDIX
  95
  96 The rest of the documentation details each of the object
  97 methods. Internal methods are usually preceded with a "_".
  98
  99 =cut
 100
 101 # Let the code begin...
 102
 103
 104 package Bio::Cluster::SequenceFamily;
 105
 106 use strict;
 107 use warnings;
 108 use base qw(Bio::Root::Root Bio::Cluster::FamilyI);
 109
 110 =head2 new
 111
 112  Title   : new
 113  Usage   : my $family = Bio::Cluster::SequenceFamily->new(
 114                              -family_id=>"Family_1",
 115                              -description=>"Family Description Here",
 116                              -annotation_score=>"100",
 117                              -members=>\@mem);
 118  Function: Constructor for SequenceFamily object
 119  Returns : Bio::Cluster::SequenceFamily object
 120
 121 See L<Bio::Cluster::SequenceFamily>.
 122
 123 =cut
 124
 125 sub new {
 126     my ($class,@args) = @_;
 127     my $self = $class->SUPER::new(@args);
 128     my ($id,$description,$version,$annot_score,
 129     $family_score,$members) = $self->_rearrange([qw(FAMILY_ID DESCRIPTION VERSION
 130                                                     ANNOTATION_SCORE
 131                                                     FAMILY_SCORE MEMBERS)],@args);
 132     $self->{'_members'} = [];
 133     $id             && $self->family_id($id);
 134     $description    && $self->description($description);
 135     $version        && $self->version($version);
 136     $annot_score    && $self->annotation_score($annot_score);
 137     $family_score   && $self->family_score($family_score);
 138     $members        && $self->add_members($members);
 139
 140     return $self;
 141 }
 142
 143 =head2 version
 144
 145  Title   : version
 146  Usage   : $family->version("1.0");
 147  Function: get/set for version
 148  Returns : a string version of the family generated.
 149
 150 =cut
 151
 152 sub version{
 153     my ($self,$value) = @_;
 154     if($value){
 155         $self->{'_version'} =$value;
 156     }
 157     return $self->{'_version'};
 158 }
 159
 160 =head2 annotation_score
 161
 162  Title   : annotation_score
 163  Usage   : $family->annotation_score(100);
 164  Function: get/set for annotation_score which
 165            represent the confidence in which the
 166            consensus description has been assigned
 167            to the family.
 168  Returns : Bio::SimpleAlign
 169
 170 See L<Bio::SimpleAlign>
 171
 172 =cut
 173
 174 sub annotation_score{
 175     my ($self,$score) = @_;
 176     if($score){
 177         $self->{'_annotation_score'} = $score;
 178     }
 179     return $self->{'_annotation_score'};
 180 }
 181
 182 =head2 alignment
 183
 184  Title   : alignment
 185  Usage   : $family->alignment($align);
 186  Function: get/set for an alignment object representing
 187            the multiple alignment of the members of the family.
 188  Returns : Bio::SimpleAlign
 189
 190 See L<Bio::SimpleAlign>
 191
 192 =cut
 193
 194 sub alignment {
 195     my ($self,$align) = @_;
 196     if($align){
 197         $self->{'_alignment'} = $align;
 198     }
 199     return $self->{'_alignment'};
 200 }
 201
 202 =head2 tree
 203
 204  Title   : tree
 205  Usage   : $family->tree($tree);
 206  Function: get/set for an tree object representing
 207            the phylogenetic tree of the family.
 208  Returns : Bio::Tree
 209
 210 See L<Bio::Tree>
 211
 212 =cut
 213
 214 sub tree {
 215     my ($self,$tree) = @_;
 216     if($tree) {
 217         $self->{'_tree'} = $tree;
 218     }
 219     return $self->{'_tree'};
 220 }
 221
 222 =head1 L<Bio::Cluster::FamilyI> methods
 223
 224 =cut
 225
 226 =head2 family_score
 227
 228  Title   : family_score
 229  Usage   : Bio::Cluster::FamilyI->family_score(95);
 230  Function: get/set for the score of algorithm used to generate
 231            the family if present
 232
 233            This is aliased to cluster_score().
 234
 235  Returns : the score
 236  Args    : the score
 237
 238 =cut
 239
 240 sub family_score {
 241     return shift->cluster_score(@_);
 242 }
 243
 244
 245 =head2 family_id
 246
 247  Title   : family_id
 248  Usage   : $family->family_id("Family_1");
 249  Function: get/set for family id
 250
 251            This is aliased to display_id().
 252
 253  Returns : a string specifying identifier of the family
 254
 255 =cut
 256
 257 sub family_id{
 258     return shift->display_id(@_);
 259 }
 260
 261 =head1 L<Bio::ClusterI> methods
 262
 263 =cut
 264
 265 =head2 display_id
 266
 267  Title   : display_id
 268  Usage   :
 269  Function: Get/set the display name or identifier for the cluster
 270  Returns : a string
 271  Args    : optional, on set the display ID ( a string)
 272
 273 =cut
 274
 275 sub display_id{
 276     my ($self,$id) = @_;
 277     if($id){
 278         $self->{'_cluster_id'} = $id;
 279     }
 280     return $self->{'_cluster_id'};
 281 }
 282
 283 =head2 description
 284
 285  Title   : description
 286  Usage   : $fam->description("POLYUBIQUITIN")
 287  Function: get/set for the consensus description of the cluster
 288  Returns : the description string
 289  Args    : Optional the description string
 290
 291 =cut
 292
 293 sub description{
 294     my ($self,$desc) = @_;
 295     if($desc){
 296         $self->{'_description'} = $desc;
 297     }
 298     return $self->{'_description'};
 299 }
 300
 301 =head2 get_members
 302
 303  Title   : get_members
 304  Usage   : Valid criteria:
 305            -common_name
 306            -binomial
 307            -ncbi_taxid
 308            -organelle
 309            -genus
 310            $family->get_members(-common_name =>"human");
 311            $family->get_members(-species     =>"homo sapiens");
 312            $family->get_members(-ncbi_taxid  => 9606);
 313            For now, multiple critieria are ORed.
 314
 315            Will return all members if no criteria are provided.
 316
 317  Function: get members using methods from L<Bio::Species>
 318            the phylogenetic tree of the family.
 319  Returns : an array of objects that are member of this family.
 320
 321 =cut
 322
 323 sub get_members {
 324     my $self = shift;
 325     return @{$self->{'_members'}} unless @_;
 326
 327     ## since the logic behind the checks is OR, we keep the ids in an hash for
 328     ## performance (skip the test if it's already there) and to avoid repats
 329     my %match;
 330     my %filter = @_;
 331     foreach my $key (keys %filter) {
 332         (my $method = $key) =~ s/^-//;
 333         %match = (%match, map { $_ => $_ } grep {
 334             ! $match{$_} && $_->species &&
 335             ($_->species->can($method) ||
 336                 $self->throw("$method is an invalid criteria")) &&
 337             $_->species->$method() eq $filter{$key}
 338         } @{$self->{'_members'}});
 339     }
 340     return map {$match{$_}} keys (%match);
 341 }
 342
 343 =head2 size
 344
 345  Title   : size
 346  Usage   : $fam->size();
 347  Function: get/set for the size of the family,
 348            calculated from the number of members
 349  Returns : the size of the family
 350  Args    :
 351
 352 =cut
 353
 354 sub size {
 355     my ($self) = @_;
 356     return scalar(@{$self->{'_members'}});
 357 }
 358
 359 =head2 cluster_score
 360
 361  Title   : cluster_score
 362  Usage   : $fam->cluster_score(100);
 363  Function: get/set for cluster_score which
 364            represent the score in which the clustering
 365            algorithm assigns to this cluster.
 366  Returns : a number
 367
 368 =cut
 369
 370 sub cluster_score{
 371     my ($self,$score) = @_;
 372     if($score){
 373         $self->{'_cluster_score'} = $score;
 374     }
 375     return $self->{'_cluster_score'};
 376 }
 377
 378
 379 =head1 Implementation specific methods
 380
 381   These are mostly for adding/removing/changing.
 382
 383 =cut
 384
 385 =head2 add_members
 386
 387  Title   : add_members
 388  Usage   : $fam->add_member([$seq1,$seq1]);
 389  Function: add members to a family
 390  Returns :
 391  Args    : the member(s) to add, as an array or arrayref
 392
 393 =cut
 394
 395 sub add_members{
 396     my ($self,@mems) = @_;
 397
 398     if (@mems) {
 399         my $mem = shift(@mems);
 400         if(ref($mem) eq "ARRAY"){
 401             push @{$self->{'_members'}},@{$mem};
 402         } else {
 403             push @{$self->{'_members'}},$mem;
 404         }
 405         push @{$self->{'_members'}}, @mems;
 406     }
 407     return 1;
 408 }
 409
 410 =head2 remove_members
 411
 412  Title   : remove_members
 413  Usage   : $fam->remove_members();
 414  Function: remove all members from a family
 415  Returns : the previous array of members
 416  Args    : none
 417
 418 =cut
 419
 420 sub remove_members{
 421     my ($self) =  @_;
 422     my $mems = $self->{'_members'};
 423     $self->{'_members'} = [];
 424     return @$mems;
 425 }
 426
 427 #####################################################################
 428 # aliases for naming consistency or other reasons                   #
 429 #####################################################################
 430
 431 *flush_members = \&remove_members;
 432 *add_member = \&add_members;
 433
 434 =head2 members
 435
 436  Title   : members
 437  Usage   : $members = $fam->members([$seq1,$seq1]);
 438  Function: Deprecated. Use add_members() or get_members() instead
 439
 440 =cut
 441
 442 sub members{
 443     my $self = shift;
 444     if(@_) {
 445         # this is in set mode
 446         $self->warn("setting members() in ".ref($self)." is deprecated.\n".
 447                     "Use add_members() instead.");
 448         return $self->add_members(@_);
 449     } else {
 450         # get mode
 451         $self->warn("members() in ".ref($self)." is deprecated.\n".
 452                     "Use get_members() instead.");
 453         return $self->get_members();
 454     }
 455 }
 456
 457 1;