File Coverage

Bio/Ontology/RelationshipType.pm
Criterion Covered Total %
statement 84 100 84.0
branch 27 56 48.2
condition 13 37 35.1
subroutine 20 22 90.9
pod 11 11 100.0
total 155 226 68.5


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::Ontology::RelationshipType
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Christian M. Zmasek or
7             #
8             # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002.
9             # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
10             #
11             # You may distribute this module under the same terms as perl itself.
12             # Refer to the Perl Artistic License (see the license accompanying this
13             # software package, or see http://www.perl.com/language/misc/Artistic.html)
14             # for the terms under which you may use, modify, and redistribute this module.
15             #
16             # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
17             # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
18             # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
19             #
20             # You may distribute this module under the same terms as perl itself
21              
22             # POD documentation - main docs before the code
23              
24             =head1 NAME
25              
26             Bio::Ontology::RelationshipType - a relationship type for an ontology
27              
28             =head1 SYNOPSIS
29              
30             #
31              
32             =head1 DESCRIPTION
33              
34             This class can be used to model various types of relationships
35             (such as "IS_A", "PART_OF", "CONTAINS", "FOUND_IN", "RELATED_TO").
36              
37             This class extends L, so it essentially is-a
38             L. In addition, all methods are overridden such
39             as to make the object immutable.
40              
41             =head1 FEEDBACK
42              
43             =head2 Mailing Lists
44              
45             User feedback is an integral part of the evolution of this and other
46             Bioperl modules. Send your comments and suggestions preferably to the
47             Bioperl mailing lists Your participation is much appreciated.
48              
49             bioperl-l@bioperl.org - General discussion
50             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
51              
52             =head2 Support
53              
54             Please direct usage questions or support issues to the mailing list:
55              
56             I
57              
58             rather than to the module maintainer directly. Many experienced and
59             reponsive experts will be able look at the problem and quickly
60             address it. Please include a thorough description of the problem
61             with code and data examples if at all possible.
62              
63             =head2 Reporting Bugs
64              
65             Report bugs to the Bioperl bug tracking system to help us keep track
66             the bugs and their resolution. Bug reports can be submitted via
67             the web:
68              
69             https://github.com/bioperl/bioperl-live/issues
70              
71             =head1 AUTHOR
72              
73             Christian M. Zmasek
74              
75             Email: czmasek-at-burnham.org or cmzmasek@yahoo.com
76              
77             WWW: http://monochrome-effect.net/
78              
79             Address:
80              
81             Genomics Institute of the Novartis Research Foundation
82             10675 John Jay Hopkins Drive
83             San Diego, CA 92121
84              
85             =head1 APPENDIX
86              
87             The rest of the documentation details each of the object
88             methods. Internal methods are usually preceded with a _
89              
90             =cut
91              
92              
93             # Let the code begin...
94              
95             package Bio::Ontology::RelationshipType;
96 6     6   3625 use strict;
  6         12  
  6         165  
97              
98              
99 6     6   27 use constant PART_OF => "PART_OF";
  6         9  
  6         336  
100 6     6   28 use constant RELATED_TO => "RELATED_TO";
  6         15  
  6         216  
101 6     6   25 use constant IS_A => "IS_A";
  6         10  
  6         223  
102 6     6   27 use constant CONTAINS => "CONTAINS";
  6         9  
  6         199  
103 6     6   29 use constant FOUND_IN => "FOUND_IN";
  6         11  
  6         210  
104 6     6   25 use constant REGULATES => "REGULATES";
  6         11  
  6         226  
105 6     6   27 use constant POSITIVELY_REGULATES => "POSITIVELY_REGULATES";
  6         11  
  6         227  
106 6     6   26 use constant NEGATIVELY_REGULATES => "NEGATIVELY_REGULATES";
  6         11  
  6         254  
107              
108              
109 6     6   29 use base qw(Bio::Ontology::Term);
  6         9  
  6         2831  
110              
111              
112             #
113             # cache for terms
114             #
115             my %term_name_map = ();
116              
117              
118             =head2 get_instance
119              
120             Title : get_instance
121             Usage : $IS_A = Bio::Ontology::RelationshipType->get_instance( "IS_A" );
122             $PART_OF = Bio::Ontology::RelationshipType->get_instance( "PART_OF" );
123             $RELATED_TO = Bio::Ontology::RelationshipType->get_instance( "RELATED_TO" );
124             $CONTAINS = Bio::Ontology::RelationshipType->get_instance( "CONTAINS" );
125             $FOUND_IN = Bio::Ontology::RelationshipType->get_instance( "FOUND_IN" );
126             Function: Factory method to create instances of RelationshipType
127             Returns : [Bio::Ontology::RelationshipType]
128             Args : "IS_A" or "PART_OF" or "CONTAINS" or "FOUND_IN" or
129             "RELATED_TO" [scalar]
130             the ontology [Bio::Ontology::OntologyI] (optional)
131              
132             =cut
133              
134             sub get_instance {
135 67     67 1 629 my ( $class, $name, $ont ) = @_;
136              
137 67 50       129 $class->throw("must provide predicate name") unless $name;
138              
139             # is one in the cache?
140 67         126 my $reltype = $term_name_map{$name};
141              
142 67 100 100     231 if($reltype &&
      100        
143             # check whether ontologies match
144             (($ont && $reltype->ontology() &&
145             ($ont->name() eq $reltype->ontology->name())) ||
146             (! ($reltype->ontology() || $ont)))) {
147             # we're done, return cached type
148 16         48 return $reltype;
149             }
150             # valid relationship type?
151              
152             #
153             #see the cell ontology. this code is too strict, even for dag-edit files. -allen
154             #
155             # if ( ! (($name eq IS_A) || ($name eq PART_OF) ||
156             # ($name eq CONTAINS) || ( $name eq FOUND_IN ))) {
157             # my $msg = "Found unknown type of relationship: [" . $name . "]\n";
158             # $msg .= "Known types are: [" . IS_A . "], [" . PART_OF . "], [" . CONTAINS . "], [" . FOUND_IN . "]";
159             # $class->throw( $msg );
160             # }
161             # if we get here we need to create the rel.type
162 51         178 $reltype = $class->new(-name => $name,
163             -ontology => $ont);
164             # cache it (FIXME possibly overrides one from another ontology)
165 51         97 $term_name_map{$name} = $reltype;
166 51         112 return $reltype;
167             } # get_instance
168              
169              
170             =head2 init
171              
172             Title : init()
173             Usage : $type->init();
174             Function: Initializes this to all undef and empty lists.
175             Returns :
176             Args :
177              
178             =cut
179              
180             sub init {
181 51     51 1 75 my $self = shift;
182              
183 51         111 $self->SUPER::init();
184              
185             # at this point we don't really need to do anything special for us
186             } # init
187              
188              
189             =head2 equals
190              
191             Title : equals
192             Usage : if ( $type->equals( $other_type ) ) { ...
193             Function: Compares this type to another one, based on string "eq" of
194             the "identifier" field, if at least one of the two types has
195             the identifier set, or string eq of the name otherwise.
196             Returns : true or false
197             Args : [Bio::Ontology::RelationshipType]
198              
199             =cut
200              
201             sub equals {
202 176     176 1 1037 my( $self, $type ) = @_;
203              
204 176         303 $self->_check_class( $type, "Bio::Ontology::RelationshipType" );
205              
206 176 50 25     243 if ( $self->identifier() xor $type->identifier() ) {
207 0         0 $self->warn("comparing relationship types when only ".
208             "one has an identifier will always return false" );
209             }
210              
211             return
212 176 50 33     244 ($self->identifier() || $type->identifier()) ?
213             $self->identifier() eq $type->identifier() :
214             $self->name() eq $type->name();
215            
216             } # equals
217              
218              
219             =head2 identifier
220              
221             Title : identifier
222             Usage : $term->identifier( "IS_A" );
223             or
224             print $term->identifier();
225             Function: Set/get for the immutable identifier of this Type.
226             Returns : The identifier [scalar].
227             Args : The identifier [scalar] (optional).
228              
229             =cut
230              
231             sub identifier {
232 796     796 1 899 my $self = shift;
233 796         1058 my $ret = $self->SUPER::identifier();
234 796 100       1122 if(@_) {
235 51 50 33     113 $self->throw($self->veto_change("identifier",$ret,$_[0]))
236             if $ret && ($ret ne $_[0]);
237 51         94 $ret = $self->SUPER::identifier(@_);
238             }
239 796         1581 return $ret;
240             } # identifier
241              
242              
243             =head2 name
244              
245             Title : name
246             Usage : $term->name( "is a type" );
247             or
248             print $term->name();
249             Function: Set/get for the immutable name of this Type.
250             Returns : The name [scalar].
251             Args : The name [scalar] (optional).
252              
253             =cut
254              
255             sub name {
256 595     595 1 1485 my $self = shift;
257 595         821 my $ret = $self->SUPER::name();
258 595 100       866 if(@_) {
259 102 50 33     168 $self->throw($self->veto_change("name",$ret,$_[0]))
260             if $ret && ($ret ne $_[0]);
261 102         159 $ret = $self->SUPER::name(@_);
262             }
263 595         1186 return $ret;
264             } # name
265              
266              
267              
268              
269              
270             =head2 definition
271              
272             Title : definition
273             Usage : $term->definition( "" );
274             or
275             print $term->definition();
276             Function: Set/get for the immutable definition of this Type.
277             Returns : The definition [scalar].
278             Args : The definition [scalar] (optional).
279              
280             =cut
281              
282             sub definition {
283 55     55 1 73 my $self = shift;
284 55         110 my $ret = $self->SUPER::definition();
285 55 100       127 if(@_) {
286 51 50 33     103 $self->veto_change("definition",$ret,$_[0])
287             if $ret && ($ret ne $_[0]);
288 51         84 $ret = $self->SUPER::definition(@_);
289             }
290             # let's be nice and return something readable here
291 55 50       104 return $ret if $ret;
292 55 100       85 return $self->name()." relationship predicate (type)" if $self->name();
293             } # definition
294              
295              
296              
297             =head2 ontology
298              
299             Title : ontology
300             Usage : $term->ontology( $top );
301             or
302             $top = $term->ontology();
303             Function: Set/get for the ontology this relationship type lives in.
304             Returns : The ontology [Bio::Ontology::OntologyI].
305             Args : On set, the ontology [Bio::Ontology::OntologyI] (optional).
306              
307             =cut
308              
309             sub ontology {
310 190     190 1 225 my $self = shift;
311 190         304 my $ret = $self->SUPER::ontology();
312 190 100       279 if(@_) {
313 95         106 my $ont = shift;
314 95 50       146 if($ret) {
315 0 0 0     0 $self->throw($self->veto_change("ontology",$ret->name,
    0          
316             $ont ? $ont->name : $ont))
317             unless $ont && ($ont->name() eq $ret->name());
318             }
319 95         146 $ret = $self->SUPER::ontology($ont,@_);
320             }
321 190         384 return $ret;
322             } # category
323              
324              
325              
326             =head2 version
327              
328             Title : version
329             Usage : $term->version( "1.00" );
330             or
331             print $term->version();
332             Function: Set/get for immutable version information.
333             Returns : The version [scalar].
334             Args : The version [scalar] (optional).
335              
336             =cut
337              
338             sub version {
339 0     0 1 0 my $self = shift;
340 0         0 my $ret = $self->SUPER::version();
341 0 0       0 if(@_) {
342 0 0 0     0 $self->throw($self->veto_change("version",$ret,$_[0]))
343             if $ret && ($ret ne $_[0]);
344 0         0 $ret = $self->SUPER::version(@_);
345             }
346 0         0 return $ret;
347             } # version
348              
349              
350              
351             =head2 is_obsolete
352              
353             Title : is_obsolete
354             Usage : $term->is_obsolete( 1 );
355             or
356             if ( $term->is_obsolete() )
357             Function: Set/get for the immutable obsoleteness of this Type.
358             Returns : the obsoleteness [0 or 1].
359             Args : the obsoleteness [0 or 1] (optional).
360              
361             =cut
362              
363             sub is_obsolete {
364 51     51 1 65 my $self = shift;
365 51         103 my $ret = $self->SUPER::is_obsolete();
366 51 50       91 if(@_) {
367 51 50 33     100 $self->throw($self->veto_change("is_obsolete",$ret,$_[0]))
368             if $ret && ($ret != $_[0]);
369 51         88 $ret = $self->SUPER::is_obsolete(@_);
370             }
371 51         69 return $ret;
372             } # is_obsolete
373              
374              
375             =head2 comment
376              
377             Title : comment
378             Usage : $term->comment( "..." );
379             or
380             print $term->comment();
381             Function: Set/get for an arbitrary immutable comment about this Type.
382             Returns : A comment.
383             Args : A comment (optional).
384              
385             =cut
386              
387             sub comment {
388 51     51 1 80 my $self = shift;
389 51         103 my $ret = $self->SUPER::comment();
390 51 50       92 if(@_) {
391 51 50 33     97 $self->throw($self->veto_change("comment",$ret,$_[0]))
392             if $ret && ($ret ne $_[0]);
393 51         83 $ret = $self->SUPER::comment(@_);
394             }
395 51         67 return $ret;
396             } # comment
397              
398             =head1 Private methods
399              
400             May be overridden in a derived class, but should never be called from
401             outside.
402              
403             =cut
404              
405             sub _check_class {
406 176     176   235 my ( $self, $value, $expected_class ) = @_;
407              
408 176 50       567 if ( ! defined( $value ) ) {
    50          
    50          
409 0           $self->throw( "Found [undef] where [$expected_class] expected" );
410             }
411             elsif ( ! ref( $value ) ) {
412 0           $self->throw( "Found [scalar] where [$expected_class] expected" );
413             }
414             elsif ( ! $value->isa( $expected_class ) ) {
415 0           $self->throw( "Found [" . ref( $value ) . "] where [$expected_class] expected" );
416             }
417              
418             } # _check_type
419              
420             =head2 veto_change
421              
422             Title : veto_change
423             Usage :
424             Function: Called if an attribute is changed. Setting an attribute is
425             considered a change if it had a value before and the attempt
426             to set it would change the value.
427              
428             This method returns the message to be printed in the exception.
429              
430             Example :
431             Returns : A string
432             Args : The name of the attribute that was attempted to change.
433             Optionally, the old value and the new value for reporting
434             purposes only.
435              
436             =cut
437              
438             sub veto_change{
439 0     0 1   my ($self,$attr,$old,$new) = @_;
440              
441 0 0         my $changetype = $old ? ($new ? "change" : "unset") : "change";
    0          
442 0           my $msg = "attempt to $changetype attribute $attr in ".ref($self).
443             ", which is immutable";
444 0 0 0       $msg .= " (\"$old\" to \"$new\")" if $old && $new;
445 0           return $msg;
446             }
447              
448             1;