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 use strict;
 102
 103 use base qw(Bio::SeqFeature::Generic);
 104
 105 sub new {
 106     my ( $class, @args) = @_;
 107
 108     my $self = $class->SUPER::new(@args);
 109
 110
 111     my ( $computation_id, $program_name, $program_date, $program_version,
 112          $database_name, $database_date, $database_version) =
 113          $self->_rearrange([qw( COMPUTATION_ID
 114                                  PROGRAM_NAME
 115                                  PROGRAM_DATE
 116                                  PROGRAM_VERSION
 117                                  DATABASE_NAME
 118                                  DATABASE_DATE
 119                                  DATABASE_VERSION )],@args);
 120
 121     $program_name     && $self->program_name($program_name);
 122     $program_date     && $self->program_date($program_date);
 123     $program_version  && $self->program_version($program_version);
 124     $database_name    && $self->database_name($database_name);
 125     $database_date    && $self->database_date($database_date);
 126     $database_version && $self->database_version($database_version);
 127     $computation_id   && $self->computation_id($computation_id);
 128
 129     return $self;
 130 }
 131
 132 =head2 has_score
 133
 134  Title   : has_score
 135  Usage   : $value = $self->has_score('some_score')
 136  Function: Tests whether a feature contains a score
 137  Returns : TRUE if the SeqFeature has the score,
 138            and FALSE otherwise.
 139  Args    : The name of a score
 140
 141 =cut
 142
 143 sub has_score {
 144     my ($self, $score) = @_;
 145     return unless defined $score;
 146     return exists $self->{'_gsf_score_hash'}->{$score};
 147 }
 148
 149 =head2 add_score_value
 150
 151  Title   : add_score_value
 152  Usage   : $self->add_score_value('P_value',224);
 153  Returns : TRUE on success
 154  Args    : score (string) and value (any scalar)
 155
 156 =cut
 157
 158 sub add_score_value {
 159    my ($self, $score, $value) = @_;
 160    if( ! defined $score || ! defined $value ) {
 161        $self->warn("must specify a valid $score and $value to add_score_value");
 162        return 0;
 163    }
 164
 165    if ( !defined $self->{'_gsf_score_hash'}->{$score} ) {
 166        $self->{'_gsf_score_hash'}->{$score} = [];
 167    }
 168
 169    push(@{$self->{'_gsf_score_hash'}->{$score}},$value);
 170 }
 171
 172 =head2 score
 173
 174  Title   : score
 175  Usage   : $value = $comp_obj->score()
 176            $comp_obj->score($value)
 177  Function: Returns the 'default' score or sets the 'default' score
 178            This method exist for compatibility options
 179            It would equal ($comp_obj->each_score_value('default'))[0];
 180  Returns : A value
 181  Args    : (optional) a new value for the 'default' score
 182
 183 =cut
 184
 185 sub score {
 186     my ($self, $value) = @_;
 187     my @v;
 188     if (defined $value) {
 189
 190         if( ref($value) =~ /HASH/i ) {
 191             while( my ($t,$val) = each %{ $value } ) {
 192                 $self->add_score_value($t,$val);
 193             }
 194         } else {
 195             @v = $value;
 196             $self->add_score_value('default', $value);
 197         }
 198
 199     } else {
 200         @v = $self->each_score_value('default');
 201     }
 202     return $v[0];
 203 }
 204
 205 =head2 each_score_value
 206
 207  Title   : each_score_value
 208  Usage   : @values = $gsf->each_score_value('note');
 209  Function: Returns a list of all the values stored
 210            under a particular score.
 211  Returns : A list of scalars
 212  Args    : The name of the score
 213
 214 =cut
 215
 216 sub each_score_value {
 217    my ($self, $score) = @_;
 218    if ( ! exists $self->{'_gsf_score_hash'}->{$score} ) {
 219        $self->warn("asking for score value that does not exist $score");
 220        return;
 221    }
 222    return @{$self->{'_gsf_score_hash'}->{$score}};
 223 }
 224
 225
 226 =head2 all_scores
 227
 228  Title   : all_scores
 229  Usage   : @scores = $feat->all_scores()
 230  Function: Get a list of all the scores in a feature
 231  Returns : An array of score names
 232  Args    : none
 233
 234
 235 =cut
 236
 237 sub all_scores {
 238    my ($self, @args) = @_;
 239
 240    return keys %{$self->{'_gsf_score_hash'}};
 241 }
 242
 243
 244 =head2 remove_score
 245
 246  Title   : remove_score
 247  Usage   : $feat->remove_score('some_score')
 248  Function: removes a score from this feature
 249  Returns : nothing
 250  Args    : score (string)
 251
 252
 253 =cut
 254
 255 sub remove_score {
 256    my ($self, $score) = @_;
 257
 258    if ( ! exists $self->{'_gsf_score_hash'}->{$score} ) {
 259        $self->warn("trying to remove a score that does not exist: $score");
 260    }
 261
 262    delete $self->{'_gsf_score_hash'}->{$score};
 263 }
 264
 265 =head2 computation_id
 266
 267  Title   : computation_id
 268  Usage   : $computation_id = $feat->computation_id()
 269            $feat->computation_id($computation_id)
 270  Function: get/set on program name information
 271  Returns : string
 272  Args    : none if get, the new value if set
 273
 274
 275 =cut
 276
 277 sub computation_id {
 278   my ($self,$value) = @_;
 279
 280   if (defined($value)) {
 281       $self->{'_gsf_computation_id'} = $value;
 282   }
 283
 284   return $self->{'_gsf_computation_id'};
 285 }
 286
 287
 288
 289
 290 =head2 program_name
 291
 292  Title   : program_name
 293  Usage   : $program_name = $feat->program_name()
 294            $feat->program_name($program_name)
 295  Function: get/set on program name information
 296  Returns : string
 297  Args    : none if get, the new value if set
 298
 299
 300 =cut
 301
 302 sub program_name {
 303   my ($self,$value) = @_;
 304
 305   if (defined($value)) {
 306       $self->{'_gsf_program_name'} = $value;
 307   }
 308
 309   return $self->{'_gsf_program_name'};
 310 }
 311
 312 =head2 program_date
 313
 314  Title   : program_date
 315  Usage   : $program_date = $feat->program_date()
 316            $feat->program_date($program_date)
 317  Function: get/set on program date information
 318  Returns : date (string)
 319  Args    : none if get, the new value if set
 320
 321
 322 =cut
 323
 324 sub program_date {
 325   my ($self,$value) = @_;
 326
 327   if (defined($value)) {
 328       $self->{'_gsf_program_date'} = $value;
 329   }
 330
 331   return $self->{'_gsf_program_date'};
 332 }
 333
 334
 335 =head2 program_version
 336
 337  Title   : program_version
 338  Usage   : $program_version = $feat->program_version()
 339            $feat->program_version($program_version)
 340  Function: get/set on program version information
 341  Returns : date (string)
 342  Args    : none if get, the new value if set
 343
 344
 345 =cut
 346
 347 sub program_version {
 348   my ($self,$value) = @_;
 349
 350   if (defined($value)) {
 351       $self->{'_gsf_program_version'} = $value;
 352   }
 353
 354   return $self->{'_gsf_program_version'};
 355 }
 356
 357 =head2 database_name
 358
 359  Title   : database_name
 360  Usage   : $database_name = $feat->database_name()
 361            $feat->database_name($database_name)
 362  Function: get/set on program name information
 363  Returns : string
 364  Args    : none if get, the new value if set
 365
 366 =cut
 367
 368 sub database_name {
 369   my ($self,$value) = @_;
 370
 371   if (defined($value)) {
 372       $self->{'_gsf_database_name'} = $value;
 373   }
 374
 375   return $self->{'_gsf_database_name'};
 376 }
 377
 378 =head2 database_date
 379
 380  Title   : database_date
 381  Usage   : $database_date = $feat->database_date()
 382            $feat->database_date($database_date)
 383  Function: get/set on program date information
 384  Returns : date (string)
 385  Args    : none if get, the new value if set
 386
 387
 388 =cut
 389
 390 sub database_date {
 391   my ($self,$value) = @_;
 392
 393   if (defined($value)) {
 394       $self->{'_gsf_database_date'} = $value;
 395   }
 396
 397   return $self->{'_gsf_database_date'};
 398 }
 399
 400
 401 =head2 database_version
 402
 403  Title   : database_version
 404  Usage   : $database_version = $feat->database_version()
 405            $feat->database_version($database_version)
 406  Function: get/set on program version information
 407  Returns : date (string)
 408  Args    : none if get, the new value if set
 409
 410
 411 =cut
 412
 413 sub database_version {
 414   my ($self,$value) = @_;
 415
 416   if (defined($value)) {
 417       $self->{'_gsf_database_version'} = $value;
 418   }
 419
 420   return $self->{'_gsf_database_version'};
 421
 422 }
 423
 424 =head2 get_SeqFeature_type
 425
 426  Title   : get_SeqFeature_type
 427  Usage   : $SeqFeature_type = $feat->get_SeqFeature_type()
 428            $feat->get_SeqFeature_type($SeqFeature_type)
 429  Function: Get SeqFeature type which is automatically set when adding
 430            a computation (SeqFeature) to a computation object
 431  Returns : SeqFeature_type (string)
 432  Args    : none if get, the new value if set
 433
 434 =cut
 435
 436 sub get_SeqFeature_type {
 437   my ($self, $value) = @_;
 438
 439   if (defined($value)) {
 440       $self->{'_gsf_sub_SeqFeature_type'} = $value;
 441   }
 442   return $self->{'_gsf_sub_SeqFeature_type'};
 443 }
 444
 445 =head2 get_all_SeqFeature_types
 446
 447  Title   : get_all_SeqFeature_types
 448  Usage   : @all_SeqFeature_types = $comp->get_all_SeqFeature_types();
 449  Function: Returns an array with all subseqfeature types
 450  Returns : An array
 451  Args    : none
 452
 453 =cut
 454
 455 sub get_all_SeqFeature_types {
 456    my ($self) = @_;
 457    return keys ( %{$self->{'gsf_sub_hash'}} );
 458 }
 459
 460 =head2 get_SeqFeatures
 461
 462  Title   : get_SeqFeatures('feature_type')
 463  Usage   : @feats = $feat->get_SeqFeatures();
 464            @feats = $feat->get_SeqFeatures('feature_type');
 465  Function: Returns an array of sub Sequence Features of a specific
 466            type or, if the type is omitted, all sub Sequence Features
 467  Returns : An array
 468  Args    : (optional) a SeqFeature type (ie exon, pattern)
 469
 470 =cut
 471
 472 sub get_SeqFeatures {
 473    my ($self, $ssf_type) = @_;
 474    my (@return_array) = ();
 475    if ($ssf_type eq '') {
 476        #return all SeqFeatures
 477        foreach (keys ( %{$self->{'gsf_sub_hash'}} )){
 478            push @return_array, @{$self->{'gsf_sub_hash'}->{$_}};
 479        }
 480        return @return_array;
 481    } else {
 482        if (defined ($self->{'gsf_sub_hash'}->{$ssf_type})) {
 483            return @{$self->{'gsf_sub_hash'}->{$ssf_type}};
 484        } else {
 485            $self->warn("$ssf_type is not a valid sub SeqFeature type");
 486        }
 487    }
 488 }
 489
 490 =head2 add_SeqFeature
 491
 492  Title   : add_SeqFeature
 493  Usage   : $feat->add_SeqFeature($subfeat);
 494            $feat->add_SeqFeature($subfeat,'seqfeature_type')
 495            $feat->add_SeqFeature($subfeat,'EXPAND')
 496            $feat->add_SeqFeature($subfeat,'EXPAND','seqfeature_type')
 497  Function: adds a SeqFeature into a specific subSeqFeature array.
 498            with no 'EXPAND' qualifer, subfeat will be tested
 499            as to whether it lies inside the parent, and throw
 500            an exception if not.
 501            If EXPAND is used, the parents start/end/strand will
 502            be adjusted so that it grows to accommodate the new
 503            subFeature,
 504            optionally a seqfeature type can be defined.
 505  Returns : nothing
 506  Args    : An object which has the SeqFeatureI interface
 507            (optional) 'EXPAND'
 508            (optional) 'SeqFeature_type'
 509
 510 =cut
 511
 512 sub add_SeqFeature{
 513    my ($self,$feat,$var1, $var2) = @_;
 514    $var1 = '' unless( defined $var1);
 515    $var2 = '' unless( defined $var2);
 516    my ($expand, $ssf_type) = ('', $var1 . $var2);
 517    $expand = 'EXPAND' if ($ssf_type =~ s/EXPAND//);
 518
 519    if ( !$feat->isa('Bio::SeqFeatureI') ) {
 520        $self->warn("$feat does not implement Bio::SeqFeatureI. Will add it anyway, but beware...");
 521    }
 522
 523    if($expand eq 'EXPAND') {
 524        $self->_expand_region($feat);
 525    } else {
 526        if ( !$self->contains($feat) ) {
 527            $self->throw("$feat is not contained within parent feature, and expansion is not valid");
 528        }
 529    }
 530
 531    $ssf_type = 'default' if ($ssf_type eq '');
 532
 533    if (!(defined ($self->{'gsf_sub_hash'}->{$ssf_type}))) {
 534       @{$self->{'gsf_sub_hash'}->{$ssf_type}} = ();
 535    }
 536    $feat->get_SeqFeature_type($ssf_type);
 537    push @{$self->{'gsf_sub_hash'}->{$ssf_type}}, $feat;
 538 }
 539
 540 =head2 remove_SeqFeatures
 541
 542  Title   : remove_SeqFeatures
 543  Usage   : $sf->remove_SeqFeatures
 544            $sf->remove_SeqFeatures('SeqFeature_type');
 545  Function: Removes all sub SeqFeature or all sub SeqFeatures of a specified type
 546            (if you want to remove a more specific subset, take an array of them
 547            all, flush them, and add back only the guys you want)
 548  Example :
 549  Returns : none
 550  Args    : none
 551
 552
 553 =cut
 554
 555 sub remove_SeqFeatures {
 556    my ($self, $ssf_type) = @_;
 557    if ($ssf_type) {
 558       if ((defined ($self->{'gsf_sub_hash'}->{$ssf_type}))) {
 559              delete $self->{'gsf_sub_hash'}->{$ssf_type};
 560        } else {
 561            $self->warn("$ssf_type is not a valid sub SeqFeature type");
 562        }
 563    } else {
 564       $self->{'_gsf_sub_hash'} = {}; # zap the complete hash implicitly.
 565    }
 566 }
 567
 568
 569 # Aliases to better match Bio::SeqFeature function names
 570 *sub_SeqFeature_type = \&get_SeqFeature_type;
 571 *all_sub_SeqFeature_types = \&get_all_SeqFeature_types;
 572 *sub_SeqFeature = \&get_SeqFeatures;
 573 *add_sub_SeqFeature = \&add_SeqFeature;
 574 *flush_sub_SeqFeatures = \&remove_SeqFeatures;
 575 *flush_sub_SeqFeature = \&remove_SeqFeatures;
 576
 577 1;