Bio/Ontology/RelationshipType.pm

   1 #
   2 # BioPerl module for Bio::Ontology::RelationshipType
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Christian M. Zmasek <czmasek-at-burnham.org> or <cmzmasek@yahoo.com>
   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<Bio::Ontology::Term>, so it essentially is-a
  38 L<Bio::Ontology::TermI>. 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<bioperl-l@bioperl.org>
  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 use strict;
  97
  98
  99 use constant PART_OF    => "PART_OF";
 100 use constant RELATED_TO => "RELATED_TO";
 101 use constant IS_A       => "IS_A";
 102 use constant CONTAINS   => "CONTAINS";
 103 use constant FOUND_IN   => "FOUND_IN";
 104 use constant REGULATES   => "REGULATES";
 105 use constant POSITIVELY_REGULATES   => "POSITIVELY_REGULATES";
 106 use constant NEGATIVELY_REGULATES   => "NEGATIVELY_REGULATES";
 107
 108
 109 use base qw(Bio::Ontology::Term);
 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     my ( $class, $name, $ont ) = @_;
 136
 137     $class->throw("must provide predicate name") unless $name;
 138
 139     # is one in the cache?
 140     my $reltype = $term_name_map{$name};
 141
 142     if($reltype &&
 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         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     $reltype = $class->new(-name     => $name,
 163                            -ontology => $ont);
 164     # cache it (FIXME possibly overrides one from another ontology)
 165     $term_name_map{$name} = $reltype;
 166     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     my $self = shift;
 182
 183     $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     my( $self, $type ) = @_;
 203
 204     $self->_check_class( $type, "Bio::Ontology::RelationshipType" );
 205
 206     if ( $self->identifier() xor $type->identifier() ) {
 207         $self->warn("comparing relationship types when only ".
 208                     "one has an identifier will always return false" );
 209     }
 210
 211     return
 212         ($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     my $self = shift;
 233     my $ret = $self->SUPER::identifier();
 234     if(@_) {
 235         $self->throw($self->veto_change("identifier",$ret,$_[0]))
 236             if $ret && ($ret ne $_[0]);
 237         $ret = $self->SUPER::identifier(@_);
 238     }
 239     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     my $self = shift;
 257     my $ret = $self->SUPER::name();
 258     if(@_) {
 259         $self->throw($self->veto_change("name",$ret,$_[0]))
 260             if $ret && ($ret ne $_[0]);
 261         $ret = $self->SUPER::name(@_);
 262     }
 263     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     my $self = shift;
 284     my $ret = $self->SUPER::definition();
 285     if(@_) {
 286         $self->veto_change("definition",$ret,$_[0])
 287             if $ret && ($ret ne $_[0]);
 288         $ret = $self->SUPER::definition(@_);
 289     }
 290     # let's be nice and return something readable here
 291     return $ret if $ret;
 292     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     my $self = shift;
 311     my $ret = $self->SUPER::ontology();
 312     if(@_) {
 313         my $ont = shift;
 314         if($ret) {
 315             $self->throw($self->veto_change("ontology",$ret->name,
 316                                             $ont ? $ont->name : $ont))
 317                 unless $ont && ($ont->name() eq $ret->name());
 318         }
 319         $ret = $self->SUPER::ontology($ont,@_);
 320     }
 321     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     my $self = shift;
 340     my $ret = $self->SUPER::version();
 341     if(@_) {
 342         $self->throw($self->veto_change("version",$ret,$_[0]))
 343             if $ret && ($ret ne $_[0]);
 344         $ret = $self->SUPER::version(@_);
 345     }
 346     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     my $self = shift;
 365     my $ret = $self->SUPER::is_obsolete();
 366     if(@_) {
 367         $self->throw($self->veto_change("is_obsolete",$ret,$_[0]))
 368             if $ret && ($ret != $_[0]);
 369         $ret = $self->SUPER::is_obsolete(@_);
 370     }
 371     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     my $self = shift;
 389     my $ret = $self->SUPER::comment();
 390     if(@_) {
 391         $self->throw($self->veto_change("comment",$ret,$_[0]))
 392             if $ret && ($ret ne $_[0]);
 393         $ret = $self->SUPER::comment(@_);
 394     }
 395     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     my ( $self, $value, $expected_class ) = @_;
 407
 408     if ( ! defined( $value ) ) {
 409         $self->throw( "Found [undef] where [$expected_class] expected" );
 410     }
 411     elsif ( ! ref( $value ) ) {
 412         $self->throw( "Found [scalar] where [$expected_class] expected" );
 413     }
 414     elsif ( ! $value->isa( $expected_class ) ) {
 415         $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     my ($self,$attr,$old,$new) = @_;
 440
 441     my $changetype = $old ? ($new ? "change" : "unset") : "change";
 442     my $msg = "attempt to $changetype attribute $attr in ".ref($self).
 443     ", which is immutable";
 444     $msg .= " (\"$old\" to \"$new\")" if $old && $new;
 445     return $msg;
 446 }
 447
 448 1;