Bio/Factory/FTLocationFactory.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::Factory::FTLocationFactory
   4 #
   5 # Cared for by Hilmar Lapp <hlapp at gmx.net>
   6 #
   7 # Copyright Hilmar Lapp
   8 #
   9 # You may distribute this module under the same terms as perl itself
  10 #
  11 # (c) Hilmar Lapp, hlapp at gnf.org, 2002.
  12 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
  13 #
  14 # You may distribute this module under the same terms as perl itself.
  15 # Refer to the Perl Artistic License (see the license accompanying this
  16 # software package, or see http://www.perl.com/language/misc/Artistic.html)
  17 # for the terms under which you may use, modify, and redistribute this module.
  18 #
  19 # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
  20 # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
  21 # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  22 #
  23
  24 # POD documentation - main docs before the code
  25
  26 =head1 NAME
  27
  28 Bio::Factory::FTLocationFactory - A FeatureTable Location Parser
  29
  30 =head1 SYNOPSIS
  31
  32     # parse a string into a location object
  33     $loc = Bio::Factory::FTLocationFactory->from_string("join(100..200,
  34                                                          400..500");
  35
  36 =head1 DESCRIPTION
  37
  38 Implementation of string-encoded location parsing for the Genbank feature
  39 table encoding of locations.
  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
  47 the Bioperl mailing list.  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 Reporting Bugs
  53
  54 Report bugs to the Bioperl bug tracking system to help us keep track
  55 of the bugs and their resolution. Bug reports can be submitted via the
  56 web:
  57
  58   http://bugzilla.open-bio.org/
  59
  60 =head1 AUTHOR - Hilmar Lapp
  61
  62 Email hlapp at gmx.net
  63
  64 =head1 CONTRIBUTORS
  65
  66 Jason Stajich, jason-at-bioperl-dot-org
  67 Chris Fields, cjfields-at-uiuc-dot-edu
  68
  69 =head1 APPENDIX
  70
  71 The rest of the documentation details each of the object methods.
  72 Internal methods are usually preceded with a _
  73
  74 =cut
  75
  76
  77 # Let the code begin...
  78
  79 package Bio::Factory::FTLocationFactory;
  80 use vars qw($LOCREG);
  81 use strict;
  82
  83 # Object preamble - inherits from Bio::Root::Root
  84
  85 use Bio::Location::Simple;
  86 use Bio::Location::Split;
  87 use Bio::Location::Fuzzy;
  88
  89
  90 use base qw(Bio::Root::Root Bio::Factory::LocationFactoryI);
  91
  92 BEGIN {
  93     # the below is an optimized regex obj. from J. Freidl's Mastering Reg Exp.
  94     $LOCREG = qr{
  95                 (?>
  96                 [^()]+
  97                 |
  98                 \(
  99                 (??{$LOCREG})
 100                 \)
 101                 )*
 102                 }x;
 103 }
 104
 105 =head2 new
 106
 107  Title   : new
 108  Usage   : my $obj = Bio::Factory::FTLocationFactory->new();
 109  Function: Builds a new Bio::Factory::FTLocationFactory object
 110  Returns : an instance of Bio::Factory::FTLocationFactory
 111  Args    :
 112
 113 =cut
 114
 115 =head2 from_string
 116
 117  Title   : from_string
 118  Usage   : $loc = $locfactory->from_string("100..200");
 119  Function: Parses the given string and returns a Bio::LocationI implementing
 120            object representing the location encoded by the string.
 121
 122            This implementation parses the Genbank feature table
 123            encoding of locations.
 124  Example :
 125  Returns : A Bio::LocationI implementing object.
 126  Args    : A string.
 127
 128 =cut
 129
 130 sub from_string {
 131     my ($self,$locstr,$op) = @_;
 132     my $loc;
 133
 134     #$self->debug("$locstr\n");
 135
 136     # $op for operator (error handling)
 137
 138     # run on first pass only
 139     # Note : These location types are now deprecated in GenBank (Oct. 2006)
 140     if (!defined($op)) {
 141         # convert all (X.Y) to [X.Y]
 142         $locstr =~ s{\((\d+\.\d+)\)}{\[$1\]}g;
 143         # convert ABC123:(X..Y) to ABC123:[X..Y]
 144         # we should never see the above
 145         $locstr =~ s{:\((\d+\.{2}\d+)\)}{:\[$1\]}g;
 146     }
 147
 148     if ($locstr =~ m{(.*?)\(($LOCREG)\)(.*)}o) { # any matching parentheses?
 149
 150         my ($beg, $mid, $end) = ($1, $2, $3);
 151         my (@sublocs) = (split(q(,),$beg), $mid, split(q(,),$end));
 152
 153         my @loc_objs;
 154         my $loc_obj;
 155
 156         SUBLOCS:
 157         while (@sublocs) {
 158             my $subloc = shift @sublocs;
 159             next if !$subloc;
 160             my $oparg = ($subloc eq 'join'   || $subloc eq 'bond' ||
 161                          $subloc eq 'order'  || $subloc eq 'complement') ? $subloc : undef;
 162
 163             # has operator, requires further work (recurse)
 164             if ($oparg) {
 165                 my $sub = shift @sublocs;
 166                 if (($oparg eq 'join' || $oparg eq 'order' || $oparg eq 'bond' )
 167                      && $sub !~ m{$oparg}) {
 168                     my @splitlocs = split(q(,), $sub);
 169                     $loc_obj = Bio::Location::Split->new();
 170                     while (my $splitloc = shift @splitlocs) {
 171                         next unless $splitloc;
 172                         #$loc_obj->add_sub_Location($self->from_string($splitloc, 1));
 173                         # this should work but doesn't
 174                         my $sobj;
 175                         if ($splitloc =~ m{\(($LOCREG)\)}) {
 176                             my $comploc = $1;
 177                             $sobj = $self->_parse_location($comploc);
 178                             $sobj->strand(-1);
 179                         } else {
 180                             $sobj = $self->_parse_location($splitloc);
 181                         }
 182                         $loc_obj->add_sub_Location($sobj);
 183                     }
 184                 } else {
 185                     $loc_obj = $self->from_string($sub, $oparg);
 186                 }
 187             }
 188             # no operator, simple or fuzzy
 189             else {
 190                 $loc_obj = $self->from_string($subloc,1);
 191             }
 192             $loc_obj->strand(-1) if ($op && $op eq 'complement');
 193             push @loc_objs, $loc_obj;
 194         }
 195         my $ct = @loc_objs;
 196         if ($op && !($op eq 'join' || $op eq 'order' || $op eq 'bond')
 197                 && $ct > 1 ) {
 198             $self->throw("Bad operator $op: had multiple locations ".
 199                          scalar(@loc_objs).", should be SplitLocationI");
 200         }
 201         if ($ct > 1) {
 202             $loc = Bio::Location::Split->new();
 203             $loc->add_sub_Location(shift @loc_objs) while (@loc_objs);
 204             return $loc;
 205         } else {
 206             $loc = shift @loc_objs;
 207             return $loc;
 208         }
 209     } else { # simple location(s)
 210         $loc = $self->_parse_location($locstr);
 211         $loc->strand(-1) if ($op && $op eq 'complement');
 212     }
 213     return $loc;
 214 }
 215
 216 =head2 _parse_location
 217
 218  Title   : _parse_location
 219  Usage   : $loc = $locfactory->_parse_location( $loc_string)
 220
 221  Function: Parses the given location string and returns a location object
 222            with start() and end() and strand() set appropriately.
 223            Note that this method is private.
 224  Returns : A Bio::LocationI implementing object or undef on failure
 225  Args    : location string
 226
 227 =cut
 228
 229 sub _parse_location {
 230     my ($self, $locstr) = @_;
 231     my ($loc, $seqid);
 232     #$self->debug( "Location parse, processing $locstr\n");
 233     # 'remote' location?
 234     if($locstr =~ m{^(\S+):(.*)$}o) {
 235         # yes; memorize remote ID and strip from location string
 236         $seqid = $1;
 237         $locstr = $2;
 238     }
 239
 240     # split into start and end
 241     my ($start, $end) = split(/\.\./, $locstr);
 242     # remove enclosing parentheses if any; note that because of parentheses
 243     # possibly surrounding the entire location the parentheses around start
 244     # and/or may be asymmetrical
 245     # Note: these are from X.Y fuzzy locations, which are deprecated!
 246     $start =~ s/(?:^\[+|\]+$)//g if $start;
 247     $end   =~ s/(?:^\[+|\]+$)//g if $end;
 248
 249     # Is this a simple (exact) or a fuzzy location? Simples have exact start
 250     # and end, or is between two adjacent bases. Everything else is fuzzy.
 251     my $loctype = ".."; # exact with start and end as default
 252
 253     $loctype = '?' if ( ($locstr =~ /\?/) && ($locstr !~ /\?\d+/) );
 254
 255     my $locclass = "Bio::Location::Simple";
 256     if(! defined($end)) {
 257         if($locstr =~ /(\d+)([\.\^])(\d+)/) {
 258             $start = $1;
 259             $end = $3;
 260             $loctype = $2;
 261             $locclass = "Bio::Location::Fuzzy"
 262               unless (abs($end-$start) <= 1) && ($loctype eq "^");
 263         } else {
 264             $end = $start;
 265         }
 266     }
 267     # start_num and end_num are for the numeric only versions of
 268     # start and end so they can be compared
 269     # in a few lines
 270     my ($start_num, $end_num) = ($start,$end);
 271     if ( ($start =~ /[\>\<\?\.\^]/) || ($end   =~ /[\>\<\?\.\^]/) ) {
 272         $locclass = 'Bio::Location::Fuzzy';
 273         if($start =~ /(\d+)/) {
 274             ($start_num) = $1;
 275         } else {
 276             $start_num = 0
 277         }
 278         if ($end =~ /(\d+)/) {
 279             ($end_num)   = $1;
 280         } else { $end_num = 0 }
 281     }
 282     my $strand = 1;
 283
 284     if( $start_num > $end_num && $loctype ne '?') {
 285         ($start,$end,$strand) = ($end,$start,-1);
 286     }
 287     # instantiate location and initialize
 288     $loc = $locclass->new(-verbose => $self->verbose,
 289                                  -start   => $start,
 290                                  -end     => $end,
 291                                  -strand  => $strand,
 292                                  -location_type => $loctype);
 293     # set remote ID if remote location
 294     if($seqid) {
 295         $loc->is_remote(1);
 296         $loc->seq_id($seqid);
 297     }
 298
 299     # done (hopefully)
 300     return $loc;
 301 }
 302
 303 1;