Bio/Factory/FTLocationFactory.pm

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