Archive Ensembl HomeArchive Ensembl Home
Taggable.pm
Go to the documentation of this file.
00001 =head1 LICENSE
00002 
00003   Copyright (c) 1999-2012 The European Bioinformatics Institute and
00004   Genome Research Limited.  All rights reserved.
00005 
00006   This software is distributed under a modified Apache license.
00007   For license details, please see
00008 
00009    http://www.ensembl.org/info/about/code_licence.html
00010 
00011 =head1 CONTACT
00012 
00013   Please email comments or questions to the public Ensembl
00014   developers list at <dev@ensembl.org>.
00015 
00016   Questions may also be sent to the Ensembl help desk at
00017   <helpdesk@ensembl.org>.
00018 
00019 =head1 NAME
00020 
00021 Bio::EnsEMBL::Compara::Taggable
00022 
00023 =head1 DESCRIPTION
00024 
00025 Base class for objects supporting tags / attributes
00026 
00027 =head1 MAINTAINER
00028 
00029 $Author: kb3 $
00030 
00031 =head VERSION
00032 
00033 $Revision: 1.8 $
00034 
00035 =head1 APPENDIX
00036 
00037 The rest of the documentation details each of the object methods.
00038 Internal methods are usually preceded with a _
00039 
00040 =cut
00041 
00042 package Bio::EnsEMBL::Compara::Taggable;
00043 
00044 use strict;
00045 
00046 
00047 =head2 add_tag
00048 
00049   Description: adds metadata tags to a node.  Both tag and value are added
00050                as metdata with the added ability to retreive the value given
00051                the tag (like a perl hash). In case of one to many relation i.e.
00052                one tag and different values associated with it, the values are
00053                returned in a array reference.
00054   Arg [1]    : <string> tag
00055   Arg [2]    : <string> value
00056   Arg [3]    : (optional) <int> allows overloading the tag with different values
00057                default is 0 (no overloading allowed, one tag points to one value)
00058   Example    : $ns_node->add_tag('scientific name', 'Mammalia');
00059                $ns_node->add_tag('lost_taxon_id', 9593, 1);
00060   Returntype : Boolean indicating if the tag could be added
00061   Exceptions : none
00062   Caller     : general
00063 
00064 =cut
00065 
00066 sub add_tag {
00067     my $self = shift;
00068     my $tag = shift;
00069     my $value = shift;
00070     my $allow_overloading = shift;
00071     #print STDERR "CALL add_tag $self/$tag/$value/$allow_overloading\n";
00072 
00073     # Argument check
00074     unless (defined $tag)   {warn "add_tag called on $self with an undef \$tag\n"; return 0};
00075     unless (defined $value) {warn "add_tag called on $self with an undef value for tag '$tag'\n"; return 0};
00076     $allow_overloading = 0 unless (defined $allow_overloading);
00077     
00078     $self->_load_tags;
00079     $tag = lc($tag);
00080 
00081     # Stores the value in the PERL object
00082     if ( ! exists($self->{'_tags'}->{$tag}) || ! $allow_overloading ) {
00083         # No overloading or new tag: store the value
00084         $self->{'_tags'}->{$tag} = $value;
00085 
00086     } elsif ( ref($self->{'_tags'}->{$tag}) eq 'ARRAY' ) {
00087         # Several values were there: we add a new one
00088         push @{$self->{'_tags'}->{$tag}}, $value;
00089 
00090     } else {
00091         # One value was there, we make an array
00092         $self->{'_tags'}->{$tag} = [ $self->{'_tags'}->{$tag}, $value ];
00093     }
00094     return 1;
00095 }
00096 
00097 
00098 =head2 store_tag
00099 
00100   Description: calls add_tag and then stores the tag in the database. Has the
00101                exact same arguments as add_tag
00102   Arg [1]    : <string> tag
00103   Arg [2]    : <string> value
00104   Arg [3]    : (optional) <int> allows overloading the tag with different values
00105                default is 0 (no overloading allowed, one tag points to one value)
00106   Example    : $ns_node->store_tag('scientific name', 'Mammalia');
00107                $ns_node->store_tag('lost_taxon_id', 9593, 1);
00108   Returntype : 0 if the tag couldn't be stored,
00109                1 if it is only in the PERL object,
00110                2 if it is also stored in the database
00111   Exceptions : none
00112   Caller     : general
00113 
00114 =cut
00115 
00116 sub store_tag {
00117     my $self = shift;
00118     my $tag = shift;
00119     my $value = shift;
00120     my $allow_overloading = shift;
00121     #print STDERR "CALL store_tag $self/$tag/$value/$allow_overloading\n";
00122 
00123     if ($self->add_tag($tag, $value, $allow_overloading)) {
00124         if($self->adaptor and $self->adaptor->isa("Bio::EnsEMBL::Compara::DBSQL::TagAdaptor")) {
00125             $self->adaptor->_store_tagvalue($self, lc($tag), $value, $allow_overloading);
00126             return 2;
00127         } else {
00128             warn "Calling store_tag on $self but the adaptor ", $self->adaptor, " doesn't have such capabilities\n";
00129             return 1;
00130         }
00131     } else {
00132         warn "add_tag has failed, store_tag is now skipped\n";
00133         return 0;
00134     }
00135 }
00136 
00137 
00138 =head2 delete_tag
00139 
00140   Description: removes a tag from the metadata. If the value is provided, it tries
00141                to delete only it (if present). Otherwise, it just clears the tag,
00142                whatever value it was containing
00143   Arg [1]    : <string> tag
00144   Arg [2]    : (optional) <string> value
00145   Example    : $ns_node->remove_tag('scientific name', 'Mammalia');
00146                $ns_node->remove_tag('lost_taxon_id', 9593);
00147   Returntype : 0 if the tag couldn't be removed,
00148                1 if it is only in the PERL object,
00149                2 if it is also stored in the database
00150   Exceptions : none
00151   Caller     : general
00152 
00153 =cut
00154 
00155 sub delete_tag {
00156     my $self = shift;
00157     my $tag = shift;
00158     my $value = shift;
00159 
00160     # Arguments check
00161     unless (defined $tag)   {warn "delete_tag called on $self with an undef \$tag\n"; return 0};
00162     $tag = lc($tag);
00163 
00164     $self->_load_tags;
00165     return 1 unless exists($self->{'_tags'}->{$tag});
00166 
00167     # Updates the PERL object
00168     my $found = 0;
00169     if (defined $value) {
00170         if ( ref($self->{'_tags'}->{$tag}) eq 'ARRAY' ) {
00171             my $arr = $self->{'_tags'}->{$tag};
00172             my $index = scalar(@$arr)-1;
00173             until ($index < 0) {
00174                 $index-- until ($index < 0) or ($arr->[$index] eq $value);
00175                 if ($index >= 0) {
00176                     splice(@$arr, $index, 1);
00177                     $found = 1;
00178                 }
00179             }
00180             if (scalar(@$arr) == 0) {
00181                 delete $self->{'_tags'}->{$tag};
00182             } elsif (scalar(@$arr) == 1) {
00183                 $self->{'_tags'}->{$tag} = $arr->[0];
00184             }
00185         } else {
00186             if ($self->{'_tags'}->{$tag} eq $value) {
00187                 delete $self->{'_tags'}->{$tag};
00188                 $found = 1;
00189             }
00190         }
00191     } else {
00192         delete $self->{'_tags'}->{$tag};
00193         $found = 1;
00194     }
00195 
00196     # Update the database
00197     if ($found) {
00198         if($self->adaptor and $self->adaptor->isa("Bio::EnsEMBL::Compara::DBSQL::TagAdaptor")) {
00199             $self->adaptor->_delete_tagvalue($self, $tag, $value);
00200             return 2;
00201         } else {
00202             return 1;
00203         }
00204     } else {
00205         return 1;
00206     }
00207 }
00208 
00209 
00210 =head2 has_tag
00211 
00212   Description: indicates whether the tag exists in the metadata
00213   Arg [1]    : <string> tag
00214   Example    : $ns_node->has_tag('scientific name');
00215   Returntype : Boolean
00216   Exceptions : none
00217   Caller     : general
00218 
00219 =cut
00220 
00221 sub has_tag {
00222     my $self = shift;
00223     my $tag = shift;
00224 
00225     return 0 unless defined $tag;
00226 
00227     $self->_load_tags;
00228     return exists($self->{'_tags'}->{lc($tag)});
00229 }
00230 
00231 
00232 =head2 get_tagvalue
00233 
00234   Description: returns the value(s) of the tag, or $default (undef
00235                if not provided) if the tag doesn't exist.
00236   Arg [1]    : <string> tag
00237   Arg [2]    : (optional) <scalar> default
00238   Example    : $ns_node->get_tagvalue('scientific name');
00239   Returntype : Scalar or ArrayRef
00240   Exceptions : none
00241   Caller     : general
00242 
00243 =cut
00244 
00245 sub get_tagvalue {
00246     my $self = shift;
00247     my $tag = shift;
00248     my $default = shift;
00249 
00250     return $default unless defined $tag;
00251 
00252     $tag = lc($tag);
00253     $self->_load_tags;
00254     return $default unless exists($self->{'_tags'}->{$tag});
00255     return $self->{'_tags'}->{$tag};
00256 }
00257 
00258 
00259 =head2 get_value_for_tag
00260 
00261   Description: returns the value of the tag, or $default (undef
00262                if not provided) if the tag doesn't exist. In case
00263                of multiple values, the first one is returned.
00264   Arg [1]    : <string> tag
00265   Arg [2]    : (optional) <scalar> default
00266   Example    : $ns_node->get_tagvalue('scientific name');
00267   Returntype : Scalar
00268   Exceptions : none
00269   Caller     : general
00270 
00271 =cut
00272 
00273 sub get_value_for_tag {
00274     my $self = shift;
00275     my $tag = shift;
00276     my $default = shift;
00277 
00278     my $ret = $self->get_tagvalue($tag, $default);
00279     if ((defined $ret) and (ref($ret) eq 'ARRAY')) {
00280         return $ret->[0];
00281     } else {
00282         return $ret;
00283     }
00284 }
00285 
00286 
00287 =head2 get_all_values_for_tag
00288 
00289   Description: returns all the values of the tag, or $default (undef
00290                if not provided) if the tag doesn't exist. In case of
00291                a single value, it is wrapped with an array
00292   Arg [1]    : <string> tag
00293   Arg [2]    : (optional) <scalar> default
00294   Example    : $ns_node->get_tagvalue('scientific name');
00295   Returntype : ArrayRef
00296   Exceptions : none
00297   Caller     : general
00298 
00299 =cut
00300 
00301 sub get_all_values_for_tag {
00302     my $self = shift;
00303     my $tag = shift;
00304     my $default = shift || [];
00305 
00306     my $ret = $self->get_tagvalue($tag);
00307     return $default if not defined $ret;
00308     if (ref($ret) eq 'ARRAY') {
00309         return $ret;
00310     } else {
00311         return [$ret];
00312     }
00313 }
00314 
00315 =head2 get_all_tags
00316 
00317   Description: returns an array of all the available tags
00318   Example    : $ns_node->get_all_tags();
00319   Returntype : Array
00320   Exceptions : none
00321   Caller     : general
00322 
00323 =cut
00324 
00325 sub get_all_tags {
00326     my $self = shift;
00327 
00328     $self->_load_tags;
00329     return keys(%{$self->{'_tags'}});
00330 }
00331 
00332 
00333 =head2 get_tagvalue_hash
00334 
00335   Description: returns the underlying hash that contains all
00336                the tags
00337   Example    : $ns_node->get_tagvalue_hash();
00338   Returntype : Hashref
00339   Exceptions : none
00340   Caller     : general
00341 
00342 =cut
00343 
00344 sub get_tagvalue_hash {
00345     my $self = shift;
00346 
00347     $self->_load_tags;
00348     return $self->{'_tags'};
00349 }
00350 
00351 =head2 _load_tags
00352 
00353   Description: loads all the tags (from the database) if possible.
00354                Otherwise, an empty hash is created
00355   Example    : $ns_node->_load_tags();
00356   Returntype : none
00357   Exceptions : none
00358   Caller     : internal
00359 
00360 =cut
00361 
00362 sub _load_tags {
00363     my $self = shift;
00364     #print STDERR "CALL _load_tags $self\n";
00365 
00366     return if(defined($self->{'_tags'}));
00367     $self->{'_tags'} = {};
00368     if($self->adaptor and $self->adaptor->isa("Bio::EnsEMBL::Compara::DBSQL::TagAdaptor")) {
00369         $self->adaptor->_load_tagvalues($self);
00370     }
00371 }
00372 
00373 
00374 =head2 AUTOLOAD
00375 
00376   Description: matches the get_value_for_XXX calls to get_value_for_tag('XXX') and other calls
00377   Returntype : none
00378   Exceptions : none
00379   Caller     : system
00380 
00381 =cut
00382 
00383 our $AUTOLOAD;
00384 
00385 sub AUTOLOAD {
00386     my $self = shift;
00387     #print "AUTOLOAD $AUTOLOAD\n";
00388     if ( $AUTOLOAD =~ m/::get_value_for_(\w+)$/ ) {
00389         #print "MATCHED $1\n";
00390         return $self->get_value_for_tag($1);
00391     } elsif ( $AUTOLOAD =~ m/::get_all_values_for_(\w+)$/ ) {
00392         return $self->get_all_values_for_tag($1);
00393     } elsif ( $AUTOLOAD =~ m/::get_(\w+)_value$/ ) {
00394         return $self->get_tagvalue($1);
00395     } elsif( $AUTOLOAD !~ /::DESTROY$/) {
00396         use Carp;
00397         croak "$self does not understand method $AUTOLOAD\n";
00398     }
00399 }
00400 
00401 
00402 1;
00403