lib/Bio/SeqFeature/Computation.pm

   1 #
   2 # BioPerl module for Bio::SeqFeature::Generic
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by mark Fiers <m.w.e.j.fiers@plant.wag-ur.nl>
   7 #
   8 # Copyright Ewan Birney, Mark Fiers
   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::SeqFeature::Computation - Computation SeqFeature
  17
  18 =head1 SYNOPSIS
  19
  20    $feat = Bio::SeqFeature::Computation->new(
  21        -start => 10,
  22        -end => 100,
  23        -strand => -1,
  24        -primary => 'repeat',
  25        -program_name => 'GeneMark',
  26        -program_date => '12-5-2000',
  27        -program_version => 'x.y',
  28        -database_name => 'Arabidopsis',
  29        -database_date => '12-dec-2000',
  30        -computation_id => 2231,
  31        -score => { no_score => 334 }
  32    );
  33
  34 =head1 DESCRIPTION
  35
  36 Bio::SeqFeature::Computation extends the Generic seqfeature object with
  37 a set of computation related fields and a more flexible set of storing
  38 more types of score and subseqfeatures. It is compatible with the Generic
  39 SeqFeature object.
  40
  41 The new way of storing score values is similar to the tag structure in the
  42 Generic object. For storing sets of subseqfeatures the array containing the
  43 subseqfeatures is now a hash which contains arrays of seqfeatures
  44 Both the score and subSeqfeature methods can be called in exactly the same
  45 way, the value's will be stored as a 'default' score or subseqfeature.
  46
  47 =head1 FEEDBACK
  48
  49 =head2 Mailing Lists
  50
  51 User feedback is an integral part of the evolution of this and other
  52 Bioperl modules. Send your comments and suggestions preferably to one
  53 of the Bioperl mailing lists.  Your participation is much appreciated.
  54
  55   bioperl-l@bioperl.org                  - General discussion
  56   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  57
  58 =head2 Support
  59
  60 Please direct usage questions or support issues to the mailing list:
  61
  62 I<bioperl-l@bioperl.org>
  63
  64 rather than to the module maintainer directly. Many experienced and
  65 reponsive experts will be able look at the problem and quickly
  66 address it. Please include a thorough description of the problem
  67 with code and data examples if at all possible.
  68
  69 =head2 Reporting Bugs
  70
  71 Report bugs to the Bioperl bug tracking system to help us keep track
  72 the bugs and their resolution.  Bug reports can be submitted via the
  73 web:
  74
  75   https://github.com/bioperl/bioperl-live/issues
  76
  77 =head1 AUTHOR - Ewan Birney, Mark Fiers
  78
  79 Ewan Birney E<lt>birney@sanger.ac.ukE<gt>
  80
  81 Mark Fiers E<lt>m.w.e.j.fiers@plant.wag-ur.nlE<gt>
  82
  83 =head1 DEVELOPERS
  84
  85 This class has been written with an eye out of inheritance. The fields
  86 the actual object hash are:
  87
  88    _gsf_sub_hash  = reference to a hash containing sets of sub arrays
  89    _gsf_score_hash= reference to a hash for the score values
  90
  91 =head1 APPENDIX
  92
  93 The rest of the documentation details each of the object
  94 methods. Internal methods are usually preceded with a _
  95
  96 =cut
  97
  98 # Let the code begin...
  99
 100 package Bio::SeqFeature::Computation;
 101
 102 use strict;
 103
 104 use base qw(Bio::SeqFeature::Generic);
 105
 106 sub new {
 107     my ( $class, @args) = @_;
 108
 109     my $self = $class->SUPER::new(@args);
 110
 111
 112     my ( $computation_id, $program_name, $program_date, $program_version,
 113          $database_name, $database_date, $database_version) =
 114          $self->_rearrange([qw( COMPUTATION_ID
 115                                  PROGRAM_NAME
 116                                  PROGRAM_DATE
 117                                  PROGRAM_VERSION
 118                                  DATABASE_NAME
 119                                  DATABASE_DATE
 120                                  DATABASE_VERSION )],@args);
 121
 122     $program_name     && $self->program_name($program_name);
 123     $program_date     && $self->program_date($program_date);
 124     $program_version  && $self->program_version($program_version);
 125     $database_name    && $self->database_name($database_name);
 126     $database_date    && $self->database_date($database_date);
 127     $database_version && $self->database_version($database_version);
 128     $computation_id   && $self->computation_id($computation_id);
 129
 130     return $self;
 131 }
 132
 133 =head2 has_score
 134
 135  Title   : has_score
 136  Usage   : $value = $self->has_score('some_score')
 137  Function: Tests whether a feature contains a score
 138  Returns : TRUE if the SeqFeature has the score,
 139            and FALSE otherwise.
 140  Args    : The name of a score
 141
 142 =cut
 143
 144 sub has_score {
 145     my ($self, $score) = @_;
 146     return unless defined $score;
 147     return exists $self->{'_gsf_score_hash'}->{$score};
 148 }
 149
 150 =head2 add_score_value
 151
 152  Title   : add_score_value
 153  Usage   : $self->add_score_value('P_value',224);
 154  Returns : TRUE on success
 155  Args    : score (string) and value (any scalar)
 156
 157 =cut
 158
 159 sub add_score_value {
 160    my ($self, $score, $value) = @_;
 161    if( ! defined $score || ! defined $value ) {
 162        $self->warn("must specify a valid $score and $value to add_score_value");
 163        return 0;
 164    }
 165
 166    if ( !defined $self->{'_gsf_score_hash'}->{$score} ) {
 167        $self->{'_gsf_score_hash'}->{$score} = [];
 168    }
 169
 170    push(@{$self->{'_gsf_score_hash'}->{$score}},$value);
 171 }
 172
 173 =head2 score
 174
 175  Title   : score
 176  Usage   : $value = $comp_obj->score()
 177            $comp_obj->score($value)
 178  Function: Returns the 'default' score or sets the 'default' score
 179            This method exist for compatibility options
 180            It would equal ($comp_obj->each_score_value('default'))[0];
 181  Returns : A value
 182  Args    : (optional) a new value for the 'default' score
 183
 184 =cut
 185
 186 sub score {
 187     my ($self, $value) = @_;
 188     my @v;
 189     if (defined $value) {
 190
 191         if( ref($value) =~ /HASH/i ) {
 192             while( my ($t,$val) = each %{ $value } ) {
 193                 $self->add_score_value($t,$val);
 194             }
 195         } else {
 196             @v = $value;
 197             $self->add_score_value('default', $value);
 198         }
 199
 200     } else {
 201         @v = $self->each_score_value('default');
 202     }
 203     return $v[0];
 204 }
 205
 206 =head2 each_score_value
 207
 208  Title   : each_score_value
 209  Usage   : @values = $gsf->each_score_value('note');
 210  Function: Returns a list of all the values stored
 211            under a particular score.
 212  Returns : A list of scalars
 213  Args    : The name of the score
 214
 215 =cut
 216
 217 sub each_score_value {
 218    my ($self, $score) = @_;
 219    if ( ! exists $self->{'_gsf_score_hash'}->{$score} ) {
 220        $self->warn("asking for score value that does not exist $score");
 221        return;
 222    }
 223    return @{$self->{'_gsf_score_hash'}->{$score}};
 224 }
 225
 226
 227 =head2 all_scores
 228
 229  Title   : all_scores
 230  Usage   : @scores = $feat->all_scores()
 231  Function: Get a list of all the scores in a feature
 232  Returns : An array of score names
 233  Args    : none
 234
 235
 236 =cut
 237
 238 sub all_scores {
 239    my ($self, @args) = @_;
 240
 241    return keys %{$self->{'_gsf_score_hash'}};
 242 }
 243
 244
 245 =head2 remove_score
 246
 247  Title   : remove_score
 248  Usage   : $feat->remove_score('some_score')
 249  Function: removes a score from this feature
 250  Returns : nothing
 251  Args    : score (string)
 252
 253
 254 =cut
 255
 256 sub remove_score {
 257    my ($self, $score) = @_;
 258
 259    if ( ! exists $self->{'_gsf_score_hash'}->{$score} ) {
 260        $self->warn("trying to remove a score that does not exist: $score");
 261    }
 262
 263    delete $self->{'_gsf_score_hash'}->{$score};
 264 }
 265
 266 =head2 computation_id
 267
 268  Title   : computation_id
 269  Usage   : $computation_id = $feat->computation_id()
 270            $feat->computation_id($computation_id)
 271  Function: get/set on program name information
 272  Returns : string
 273  Args    : none if get, the new value if set
 274
 275
 276 =cut
 277
 278 sub computation_id {
 279   my ($self,$value) = @_;
 280
 281   if (defined($value)) {
 282       $self->{'_gsf_computation_id'} = $value;
 283   }
 284
 285   return $self->{'_gsf_computation_id'};
 286 }
 287
 288
 289
 290
 291 =head2 program_name
 292
 293  Title   : program_name
 294  Usage   : $program_name = $feat->program_name()
 295            $feat->program_name($program_name)
 296  Function: get/set on program name information
 297  Returns : string
 298  Args    : none if get, the new value if set
 299
 300
 301 =cut
 302
 303 sub program_name {
 304   my ($self,$value) = @_;
 305
 306   if (defined($value)) {
 307       $self->{'_gsf_program_name'} = $value;
 308   }
 309
 310   return $self->{'_gsf_program_name'};
 311 }
 312
 313 =head2 program_date
 314
 315  Title   : program_date
 316  Usage   : $program_date = $feat->program_date()
 317            $feat->program_date($program_date)
 318  Function: get/set on program date information
 319  Returns : date (string)
 320  Args    : none if get, the new value if set
 321
 322
 323 =cut
 324
 325 sub program_date {
 326   my ($self,$value) = @_;
 327
 328   if (defined($value)) {
 329       $self->{'_gsf_program_date'} = $value;
 330   }
 331
 332   return $self->{'_gsf_program_date'};
 333 }
 334
 335
 336 =head2 program_version
 337
 338  Title   : program_version
 339  Usage   : $program_version = $feat->program_version()
 340            $feat->program_version($program_version)
 341  Function: get/set on program version information
 342  Returns : date (string)
 343  Args    : none if get, the new value if set
 344
 345
 346 =cut
 347
 348 sub program_version {
 349   my ($self,$value) = @_;
 350
 351   if (defined($value)) {
 352       $self->{'_gsf_program_version'} = $value;
 353   }
 354
 355   return $self->{'_gsf_program_version'};
 356 }
 357
 358 =head2 database_name
 359
 360  Title   : database_name
 361  Usage   : $database_name = $feat->database_name()
 362            $feat->database_name($database_name)
 363  Function: get/set on program name information
 364  Returns : string
 365  Args    : none if get, the new value if set
 366
 367 =cut
 368
 369 sub database_name {
 370   my ($self,$value) = @_;
 371
 372   if (defined($value)) {
 373       $self->{'_gsf_database_name'} = $value;
 374   }
 375
 376   return $self->{'_gsf_database_name'};
 377 }
 378
 379 =head2 database_date
 380
 381  Title   : database_date
 382  Usage   : $database_date = $feat->database_date()
 383            $feat->database_date($database_date)
 384  Function: get/set on program date information
 385  Returns : date (string)
 386  Args    : none if get, the new value if set
 387
 388
 389 =cut
 390
 391 sub database_date {
 392   my ($self,$value) = @_;
 393
 394   if (defined($value)) {
 395       $self->{'_gsf_database_date'} = $value;
 396   }
 397
 398   return $self->{'_gsf_database_date'};
 399 }
 400
 401
 402 =head2 database_version
 403
 404  Title   : database_version
 405  Usage   : $database_version = $feat->database_version()
 406            $feat->database_version($database_version)
 407  Function: get/set on program version information
 408  Returns : date (string)
 409  Args    : none if get, the new value if set
 410
 411
 412 =cut
 413
 414 sub database_version {
 415   my ($self,$value) = @_;
 416
 417   if (defined($value)) {
 418       $self->{'_gsf_database_version'} = $value;
 419   }
 420
 421   return $self->{'_gsf_database_version'};
 422
 423 }
 424
 425 =head2 get_SeqFeature_type
 426
 427  Title   : get_SeqFeature_type
 428  Usage   : $SeqFeature_type = $feat->get_SeqFeature_type()
 429            $feat->get_SeqFeature_type($SeqFeature_type)
 430  Function: Get SeqFeature type which is automatically set when adding
 431            a computation (SeqFeature) to a computation object
 432  Returns : SeqFeature_type (string)
 433  Args    : none if get, the new value if set
 434
 435 =cut
 436
 437 sub get_SeqFeature_type {
 438   my ($self, $value) = @_;
 439
 440   if (defined($value)) {
 441       $self->{'_gsf_sub_SeqFeature_type'} = $value;
 442   }
 443   return $self->{'_gsf_sub_SeqFeature_type'};
 444 }
 445
 446 =head2 get_all_SeqFeature_types
 447
 448  Title   : get_all_SeqFeature_types
 449  Usage   : @all_SeqFeature_types = $comp->get_all_SeqFeature_types();
 450  Function: Returns an array with all subseqfeature types
 451  Returns : An array
 452  Args    : none
 453
 454 =cut
 455
 456 sub get_all_SeqFeature_types {
 457    my ($self) = @_;
 458    return keys ( %{$self->{'gsf_sub_hash'}} );
 459 }
 460
 461 =head2 get_SeqFeatures
 462
 463  Title   : get_SeqFeatures('feature_type')
 464  Usage   : @feats = $feat->get_SeqFeatures();
 465            @feats = $feat->get_SeqFeatures('feature_type');
 466  Function: Returns an array of sub Sequence Features of a specific
 467            type or, if the type is omitted, all sub Sequence Features
 468  Returns : An array
 469  Args    : (optional) a SeqFeature type (ie exon, pattern)
 470
 471 =cut
 472
 473 sub get_SeqFeatures {
 474    my ($self, $ssf_type) = @_;
 475    my (@return_array) = ();
 476    if ($ssf_type eq '') {
 477        #return all SeqFeatures
 478        foreach (keys ( %{$self->{'gsf_sub_hash'}} )){
 479            push @return_array, @{$self->{'gsf_sub_hash'}->{$_}};
 480        }
 481        return @return_array;
 482    } else {
 483        if (defined ($self->{'gsf_sub_hash'}->{$ssf_type})) {
 484            return @{$self->{'gsf_sub_hash'}->{$ssf_type}};
 485        } else {
 486            $self->warn("$ssf_type is not a valid sub SeqFeature type");
 487        }
 488    }
 489 }
 490
 491 =head2 add_SeqFeature
 492
 493  Title   : add_SeqFeature
 494  Usage   : $feat->add_SeqFeature($subfeat);
 495            $feat->add_SeqFeature($subfeat,'seqfeature_type')
 496            $feat->add_SeqFeature($subfeat,'EXPAND')
 497            $feat->add_SeqFeature($subfeat,'EXPAND','seqfeature_type')
 498  Function: adds a SeqFeature into a specific subSeqFeature array.
 499            with no 'EXPAND' qualifer, subfeat will be tested
 500            as to whether it lies inside the parent, and throw
 501            an exception if not.
 502            If EXPAND is used, the parents start/end/strand will
 503            be adjusted so that it grows to accommodate the new
 504            subFeature,
 505            optionally a seqfeature type can be defined.
 506  Returns : nothing
 507  Args    : An object which has the SeqFeatureI interface
 508            (optional) 'EXPAND'
 509            (optional) 'SeqFeature_type'
 510
 511 =cut
 512
 513 sub add_SeqFeature{
 514    my ($self,$feat,$var1, $var2) = @_;
 515    $var1 = '' unless( defined $var1);
 516    $var2 = '' unless( defined $var2);
 517    my ($expand, $ssf_type) = ('', $var1 . $var2);
 518    $expand = 'EXPAND' if ($ssf_type =~ s/EXPAND//);
 519
 520    if ( !$feat->isa('Bio::SeqFeatureI') ) {
 521        $self->warn("$feat does not implement Bio::SeqFeatureI. Will add it anyway, but beware...");
 522    }
 523
 524    if($expand eq 'EXPAND') {
 525        $self->_expand_region($feat);
 526    } else {
 527        if ( !$self->contains($feat) ) {
 528            $self->throw("$feat is not contained within parent feature, and expansion is not valid");
 529        }
 530    }
 531
 532    $ssf_type = 'default' if ($ssf_type eq '');
 533
 534    if (!(defined ($self->{'gsf_sub_hash'}->{$ssf_type}))) {
 535       @{$self->{'gsf_sub_hash'}->{$ssf_type}} = ();
 536    }
 537    $feat->get_SeqFeature_type($ssf_type);
 538    push @{$self->{'gsf_sub_hash'}->{$ssf_type}}, $feat;
 539 }
 540
 541 =head2 remove_SeqFeatures
 542
 543  Title   : remove_SeqFeatures
 544  Usage   : $sf->remove_SeqFeatures
 545            $sf->remove_SeqFeatures('SeqFeature_type');
 546  Function: Removes all sub SeqFeature or all sub SeqFeatures of a specified type
 547            (if you want to remove a more specific subset, take an array of them
 548            all, flush them, and add back only the guys you want)
 549  Example :
 550  Returns : none
 551  Args    : none
 552
 553
 554 =cut
 555
 556 sub remove_SeqFeatures {
 557    my ($self, $ssf_type) = @_;
 558    if ($ssf_type) {
 559       if ((defined ($self->{'gsf_sub_hash'}->{$ssf_type}))) {
 560              delete $self->{'gsf_sub_hash'}->{$ssf_type};
 561        } else {
 562            $self->warn("$ssf_type is not a valid sub SeqFeature type");
 563        }
 564    } else {
 565       $self->{'_gsf_sub_hash'} = {}; # zap the complete hash implicitly.
 566    }
 567 }
 568
 569
 570 # Aliases to better match Bio::SeqFeature function names
 571 *sub_SeqFeature_type = \&get_SeqFeature_type;
 572 *all_sub_SeqFeature_types = \&get_all_SeqFeature_types;
 573 *sub_SeqFeature = \&get_SeqFeatures;
 574 *add_sub_SeqFeature = \&add_SeqFeature;
 575 *flush_sub_SeqFeatures = \&remove_SeqFeatures;
 576 *flush_sub_SeqFeature = \&remove_SeqFeatures;
 577
 578 1;