lib/Bio/Annotation/AnnotationFactory.pm

   1 #
   2 # BioPerl module for Bio::Annotation::AnnotationFactory
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Hilmar Lapp <hlapp at gmx.net>
   7 #
   8 # Copyright Hilmar Lapp
   9 #
  10 # You may distribute this module under the same terms as perl itself
  11
  12 #
  13 # (c) Hilmar Lapp, hlapp at gmx.net, 2002.
  14 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
  15 #
  16 # You may distribute this module under the same terms as perl itself.
  17 # Refer to the Perl Artistic License (see the license accompanying this
  18 # software package, or see http://www.perl.com/language/misc/Artistic.html)
  19 # for the terms under which you may use, modify, and redistribute this module.
  20 #
  21 # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
  22 # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
  23 # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  24 #
  25
  26 # POD documentation - main docs before the code
  27
  28 =head1 NAME
  29
  30 Bio::Annotation::AnnotationFactory - Instantiates a new
  31 Bio::AnnotationI (or derived class) through a factory
  32
  33 =head1 SYNOPSIS
  34
  35     use Bio::Annotation::AnnotationFactory;
  36     #
  37     my $factory = Bio::Annotation::AnnotationFactory->new(
  38                     -type => 'Bio::Annotation::SimpleValue');
  39     my $ann = $factory->create_object(-value => 'peroxisome',
  40                                       -tagname => 'cellular component');
  41
  42
  43 =head1 DESCRIPTION
  44
  45 This object will build L<Bio::AnnotationI> objects generically.
  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
  53 the Bioperl mailing list.  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 of the bugs and their resolution. Bug reports can be submitted via
  73 the web:
  74
  75   https://github.com/bioperl/bioperl-live/issues
  76
  77 =head1 AUTHOR - Hilmar Lapp
  78
  79 Email hlapp at gmx.net
  80
  81
  82 =head1 CONTRIBUTORS
  83
  84 This is mostly copy-and-paste with subsequent adaptation from
  85 Bio::Seq::SeqFactory by Jason Stajich. Most credits should in fact go
  86 to him.
  87
  88 =head1 APPENDIX
  89
  90 The rest of the documentation details each of the object methods.
  91 Internal methods are usually preceded with a _
  92
  93 =cut
  94
  95
  96 # Let the code begin...
  97
  98
  99 package Bio::Annotation::AnnotationFactory;
 100
 101 use strict;
 102
 103
 104 use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI);
 105
 106 =head2 new
 107
 108  Title   : new
 109  Usage   : my $obj = Bio::Annotation::AnnotationFactory->new();
 110  Function: Builds a new Bio::Annotation::AnnotationFactory object
 111  Returns : Bio::Annotation::AnnotationFactory
 112  Args    : -type => string, name of a L<Bio::AnnotationI> derived class.
 113
 114 If type is not set the module guesses it based on arguments passed to
 115 method L<create_object>.
 116
 117 =cut
 118
 119 sub new {
 120     my($class,@args) = @_;
 121
 122     my $self = $class->SUPER::new(@args);
 123
 124     my ($type) = $self->_rearrange([qw(TYPE)], @args);
 125
 126     $self->{'_loaded_types'} = {};
 127     $self->type($type) if $type;
 128
 129     return $self;
 130 }
 131
 132
 133 =head2 create_object
 134
 135  Title   : create_object
 136  Usage   : my $seq = $factory->create_object(<named parameters>);
 137  Function: Instantiates new Bio::AnnotationI (or one of its child classes)
 138
 139            This object allows us to genericize the instantiation of
 140            cluster objects.
 141
 142  Returns : L<Bio::AnnotationI> compliant object
 143            The return type is configurable using new(-type =>"...").
 144  Args    : initialization parameters specific to the type of annotation
 145            object we want.
 146
 147 =cut
 148
 149 sub create_object {
 150    my ($self,@args) = @_;
 151
 152    my $type = $self->type;
 153    if(! $type) {
 154        # we need to guess this
 155        $type = $self->_guess_type(@args);
 156        if(! $type) {
 157        $self->throw("No annotation type set and unable to guess.");
 158        }
 159        # load dynamically if it hasn't been loaded yet
 160        if(! $self->{'_loaded_types'}->{$type}) {
 161        eval {
 162            $self->_load_module($type);
 163            $self->{'_loaded_types'}->{$type} = 1;
 164        };
 165        if($@) {
 166            $self->throw("Bio::AnnotationI implementation $type ".
 167                 "failed to load: ".$@);
 168        }
 169        }
 170    }
 171    return $type->new(-verbose => $self->verbose, @args);
 172 }
 173
 174 =head2 type
 175
 176  Title   : type
 177  Usage   : $obj->type($newval)
 178  Function: Get/set the type of L<Bio::AnnotationI> object to be created.
 179
 180            This may be changed at any time during the lifetime of this
 181            factory.
 182
 183  Returns : value of type
 184  Args    : newvalue (optional)
 185
 186
 187 =cut
 188
 189 sub type{
 190     my $self = shift;
 191
 192     if(@_) {
 193     my $type = shift;
 194     if($type && (! $self->{'_loaded_types'}->{$type})) {
 195         eval {
 196         $self->_load_module($type);
 197         };
 198         if( $@ ) {
 199         $self->throw("Annotation class '$type' failed to load: ".
 200                  $@);
 201         }
 202         my $a = bless {},$type;
 203         if( ! $a->isa('Bio::AnnotationI') ) {
 204         $self->throw("'$type' does not implement Bio::AnnotationI. ".
 205                  "Too bad.");
 206         }
 207         $self->{'_loaded_types'}->{$type} = 1;
 208     }
 209     return $self->{'type'} = $type;
 210     }
 211     return $self->{'type'};
 212 }
 213
 214 =head2 _guess_type
 215
 216  Title   : _guess_type
 217  Usage   :
 218  Function: Guesses the right type of L<Bio::AnnotationI> implementation
 219            based on initialization parameters for the prospective
 220            object.
 221  Example :
 222  Returns : the type (a string, the module name)
 223  Args    : initialization parameters to be passed to the prospective
 224            cluster object
 225
 226
 227 =cut
 228
 229 sub _guess_type{
 230     my ($self,@args) = @_;
 231     my $type;
 232
 233     # we can only guess from a certain number of arguments
 234     my ($val, $db, $text, $name, $authors, $start, $tree, $node) =
 235     $self->_rearrange([qw(VALUE
 236                   DATABASE
 237                   TEXT
 238                   NAME
 239                   AUTHORS
 240                   START
 241                   TREE_OBJ
 242                   NODE
 243                   )], @args);
 244     SWITCH: {
 245         $val        && do { $type = ref($val) ? "TagTree" : "SimpleValue"; last SWITCH; };
 246         $authors    && do { $type = "Reference"; last SWITCH; };
 247         $db         && do { $type = "DBLink"; last SWITCH; };
 248         $text       && do { $type = "Comment"; last SWITCH; };
 249         $name       && do { $type = "OntologyTerm"; last SWITCH; };
 250         $start      && do { $type = "Target"; last SWITCH; };
 251         $tree       && do { $type = "Tree"; last SWITCH; };
 252         $node       && do { $type = "TagTree"; last SWITCH; };
 253         # what else could we look for?
 254     }
 255     $type = "Bio::Annotation::".$type;
 256
 257     return $type;
 258 }
 259
 260 #####################################################################
 261 # aliases for naming consistency or other reasons                   #
 262 #####################################################################
 263
 264 *create = \&create_object;
 265
 266 1;