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 use strict;
 101
 102
 103 use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI);
 104
 105 =head2 new
 106
 107  Title   : new
 108  Usage   : my $obj = Bio::Annotation::AnnotationFactory->new();
 109  Function: Builds a new Bio::Annotation::AnnotationFactory object
 110  Returns : Bio::Annotation::AnnotationFactory
 111  Args    : -type => string, name of a L<Bio::AnnotationI> derived class.
 112
 113 If type is not set the module guesses it based on arguments passed to
 114 method L<create_object>.
 115
 116 =cut
 117
 118 sub new {
 119     my($class,@args) = @_;
 120
 121     my $self = $class->SUPER::new(@args);
 122
 123     my ($type) = $self->_rearrange([qw(TYPE)], @args);
 124
 125     $self->{'_loaded_types'} = {};
 126     $self->type($type) if $type;
 127
 128     return $self;
 129 }
 130
 131
 132 =head2 create_object
 133
 134  Title   : create_object
 135  Usage   : my $seq = $factory->create_object(<named parameters>);
 136  Function: Instantiates new Bio::AnnotationI (or one of its child classes)
 137
 138            This object allows us to genericize the instantiation of
 139            cluster objects.
 140
 141  Returns : L<Bio::AnnotationI> compliant object
 142            The return type is configurable using new(-type =>"...").
 143  Args    : initialization parameters specific to the type of annotation
 144            object we want.
 145
 146 =cut
 147
 148 sub create_object {
 149    my ($self,@args) = @_;
 150
 151    my $type = $self->type;
 152    if(! $type) {
 153        # we need to guess this
 154        $type = $self->_guess_type(@args);
 155        if(! $type) {
 156        $self->throw("No annotation type set and unable to guess.");
 157        }
 158        # load dynamically if it hasn't been loaded yet
 159        if(! $self->{'_loaded_types'}->{$type}) {
 160        eval {
 161            $self->_load_module($type);
 162            $self->{'_loaded_types'}->{$type} = 1;
 163        };
 164        if($@) {
 165            $self->throw("Bio::AnnotationI implementation $type ".
 166                 "failed to load: ".$@);
 167        }
 168        }
 169    }
 170    return $type->new(-verbose => $self->verbose, @args);
 171 }
 172
 173 =head2 type
 174
 175  Title   : type
 176  Usage   : $obj->type($newval)
 177  Function: Get/set the type of L<Bio::AnnotationI> object to be created.
 178
 179            This may be changed at any time during the lifetime of this
 180            factory.
 181
 182  Returns : value of type
 183  Args    : newvalue (optional)
 184
 185
 186 =cut
 187
 188 sub type{
 189     my $self = shift;
 190
 191     if(@_) {
 192     my $type = shift;
 193     if($type && (! $self->{'_loaded_types'}->{$type})) {
 194         eval {
 195         $self->_load_module($type);
 196         };
 197         if( $@ ) {
 198         $self->throw("Annotation class '$type' failed to load: ".
 199                  $@);
 200         }
 201         my $a = bless {},$type;
 202         if( ! $a->isa('Bio::AnnotationI') ) {
 203         $self->throw("'$type' does not implement Bio::AnnotationI. ".
 204                  "Too bad.");
 205         }
 206         $self->{'_loaded_types'}->{$type} = 1;
 207     }
 208     return $self->{'type'} = $type;
 209     }
 210     return $self->{'type'};
 211 }
 212
 213 =head2 _guess_type
 214
 215  Title   : _guess_type
 216  Usage   :
 217  Function: Guesses the right type of L<Bio::AnnotationI> implementation
 218            based on initialization parameters for the prospective
 219            object.
 220  Example :
 221  Returns : the type (a string, the module name)
 222  Args    : initialization parameters to be passed to the prospective
 223            cluster object
 224
 225
 226 =cut
 227
 228 sub _guess_type{
 229     my ($self,@args) = @_;
 230     my $type;
 231
 232     # we can only guess from a certain number of arguments
 233     my ($val, $db, $text, $name, $authors, $start, $tree, $node) =
 234     $self->_rearrange([qw(VALUE
 235                   DATABASE
 236                   TEXT
 237                   NAME
 238                   AUTHORS
 239                   START
 240                   TREE_OBJ
 241                   NODE
 242                   )], @args);
 243     SWITCH: {
 244         $val        && do { $type = ref($val) ? "TagTree" : "SimpleValue"; last SWITCH; };
 245         $authors    && do { $type = "Reference"; last SWITCH; };
 246         $db         && do { $type = "DBLink"; last SWITCH; };
 247         $text       && do { $type = "Comment"; last SWITCH; };
 248         $name       && do { $type = "OntologyTerm"; last SWITCH; };
 249         $start      && do { $type = "Target"; last SWITCH; };
 250         $tree       && do { $type = "Tree"; last SWITCH; };
 251         $node       && do { $type = "TagTree"; last SWITCH; };
 252         # what else could we look for?
 253     }
 254     $type = "Bio::Annotation::".$type;
 255
 256     return $type;
 257 }
 258
 259 #####################################################################
 260 # aliases for naming consistency or other reasons                   #
 261 #####################################################################
 262
 263 *create = \&create_object;
 264
 265 1;