FTLocationFactory.pm: Fixed a long-standing issue at "from_string()"
[bioperl-live.git] / Bio / Factory / FTLocationFactory.pm
blobc909bf8e2c234c7e87f1eb48def39e098b731077
2 # BioPerl module for Bio::Factory::FTLocationFactory
4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
6 # Cared for by Hilmar Lapp <hlapp at gmx.net>
8 # Copyright Hilmar Lapp
10 # You may distribute this module under the same terms as perl itself
12 # (c) Hilmar Lapp, hlapp at gnf.org, 2002.
13 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
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.
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.
25 # POD documentation - main docs before the code
27 =head1 NAME
29 Bio::Factory::FTLocationFactory - A FeatureTable Location Parser
31 =head1 SYNOPSIS
33 # parse a string into a location object
34 $loc = Bio::Factory::FTLocationFactory->from_string("join(100..200,
35 400..500");
37 =head1 DESCRIPTION
39 Implementation of string-encoded location parsing for the Genbank feature
40 table encoding of locations.
42 =head1 FEEDBACK
44 =head2 Mailing Lists
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.
50 bioperl-l@bioperl.org - General discussion
51 http://bioperl.org/wiki/Mailing_lists - About the mailing lists
53 =head2 Support
55 Please direct usage questions or support issues to the mailing list:
57 I<bioperl-l@bioperl.org>
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.
64 =head2 Reporting Bugs
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:
70 https://github.com/bioperl/bioperl-live/issues
72 =head1 AUTHOR - Hilmar Lapp
74 Email hlapp at gmx.net
76 =head1 CONTRIBUTORS
78 Jason Stajich, jason-at-bioperl-dot-org
79 Chris Fields, cjfields-at-uiuc-dot-edu
81 =head1 APPENDIX
83 The rest of the documentation details each of the object methods.
84 Internal methods are usually preceded with a _
86 =cut
89 # Let the code begin...
91 package Bio::Factory::FTLocationFactory;
92 use vars qw($LOCREG);
93 use strict;
95 # Object preamble - inherits from Bio::Root::Root
97 use Bio::Location::Simple;
98 use Bio::Location::Split;
99 use Bio::Location::Fuzzy;
102 use base qw(Bio::Root::Root Bio::Factory::LocationFactoryI);
104 BEGIN {
105 # the below is an optimized regex obj. from J. Freidl's Mastering Reg Exp.
106 $LOCREG = qr{
108 [^()]+
111 (??{$LOCREG})
114 }x;
117 =head2 new
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 :
125 =cut
127 =head2 from_string
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.
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.
140 =cut
142 sub from_string {
143 my ($self,$locstr,$op) = @_;
144 my $loc;
146 #$self->debug("$locstr\n");
148 # $op for operator (error handling)
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;
160 if ($locstr =~ m{(.*?)\(($LOCREG)\)(.*)}o) { # any matching parentheses?
161 my ($beg, $mid, $end) = ($1, $2, $3);
162 my (@sublocs) = (split(q(,),$beg), $mid, split(q(,),$end));
164 my @loc_objs;
165 my $loc_obj;
167 SUBLOCS:
168 while (@sublocs) {
169 my $subloc = shift @sublocs;
170 next if !$subloc;
171 my $oparg = ($subloc eq 'join' || $subloc eq 'bond' ||
172 $subloc eq 'order' || $subloc eq 'complement') ? $subloc : undef;
173 # has operator, requires further work (recurse)
174 if ($oparg) {
175 my $sub = shift @sublocs;
176 # simple split operators (no recursive calls needed)
177 if (($oparg eq 'join' || $oparg eq 'order' || $oparg eq 'bond' )
178 && $sub !~ m{(?:join|order|bond)}) {
179 my @splitlocs = split(q(,), $sub);
180 $loc_obj = Bio::Location::Split->new(-verbose => 1,
181 -splittype => $oparg);
182 # Store strand values for later consistency check
183 my @subloc_strands;
184 my @s_objs;
185 foreach my $splitloc (@splitlocs) {
186 next unless $splitloc;
187 my $sobj;
188 if ($splitloc =~ m{\(($LOCREG)\)}) {
189 my $comploc = $1;
190 $sobj = $self->_parse_location($comploc);
191 $sobj->strand(-1);
192 push @subloc_strands, -1;
193 } else {
194 $sobj = $self->_parse_location($splitloc);
195 push @subloc_strands, 1;
197 push @s_objs, $sobj;
200 # Sublocations strand values consistency check to set
201 # Guide Strand and sublocations adding order
202 if (scalar @s_objs > 0) {
203 my $identical = 0;
205 my $first_value = $subloc_strands[0];
206 foreach my $strand (@subloc_strands) {
207 $identical++ if ($strand == $first_value);
210 if ($identical == scalar @subloc_strands) {
211 # Set guide_strand if all sublocations have the same strand
212 $loc_obj->guide_strand($first_value);
214 # Reverse sublocation order for negative strand locations, e.g.:
215 # Common (CAA24672.1):
216 # join(complement(4918..5163),complement(2691..4571))
217 # Trans-splicing (NP_958375.1):
218 # join(32737..32825,complement(174205..174384),complement(69520..71506))
219 if ($first_value == -1) {
220 @s_objs = reverse @s_objs;
223 else {
224 # Mixed strand values
225 $loc_obj->guide_strand(undef);
228 # Add sublocations
229 foreach my $s_obj (@s_objs) {
230 $loc_obj->add_sub_Location($s_obj);
233 } else {
234 $loc_obj = $self->from_string($sub, $oparg);
235 # reinsure the operator is set correctly for this level
236 # unless it is complement
237 $loc_obj->splittype($oparg) unless $oparg eq 'complement';
240 # no operator, simple or fuzzy
241 else {
242 $loc_obj = $self->from_string($subloc,1);
244 if ($op && $op eq 'complement') {
245 $loc_obj->strand(-1);
248 # For Split-type $loc_obj, if guide strand is set (meaning consistent strand for
249 # all sublocs) and guide strand is the same than the last location from @loc_objs,
250 # then recover the sublocations and add them to @loc_objs. This way,
251 # "join(10..20,join(30..40,50..60))" becomes "join(10..20,30..40,50..60)"
252 my $guide_strand = ($loc_obj->isa('Bio::Location::SplitLocationI')) ? ($loc_obj->guide_strand || 0) : 0;
253 my $last_strand = (scalar @loc_objs > 0) ? $loc_objs[-1]->strand : 0;
254 if ( $guide_strand != 0
255 and $guide_strand == $last_strand
256 and $oparg eq $op # join(,join()) OK, order(join()) NOT OK
258 my @subloc_objs = $loc_obj->sub_Location(0);
259 foreach my $subloc_obj (@subloc_objs) {
260 push @loc_objs, $subloc_obj;
263 else {
264 push @loc_objs, $loc_obj;
267 my $ct = @loc_objs;
268 if ($op && !($op eq 'join' || $op eq 'order' || $op eq 'bond')
269 && $ct > 1 ) {
270 $self->throw("Bad operator $op: had multiple locations ".
271 scalar(@loc_objs).", should be SplitLocationI");
273 if ($ct > 1) {
274 $loc = Bio::Location::Split->new();
275 $loc->add_sub_Location(shift @loc_objs) while (@loc_objs);
276 return $loc;
277 } else {
278 $loc = shift @loc_objs;
279 return $loc;
281 } else { # simple location(s)
282 $loc = $self->_parse_location($locstr);
283 $loc->strand(-1) if ($op && $op eq 'complement');
285 return $loc;
288 =head2 _parse_location
290 Title : _parse_location
291 Usage : $loc = $locfactory->_parse_location( $loc_string)
293 Function: Parses the given location string and returns a location object
294 with start() and end() and strand() set appropriately.
295 Note that this method is private.
296 Returns : A Bio::LocationI implementing object or undef on failure
297 Args : location string
299 =cut
301 sub _parse_location {
302 my ($self, $locstr) = @_;
303 my ($loc, $seqid);
304 #$self->debug( "Location parse, processing $locstr\n");
305 # 'remote' location?
306 if($locstr =~ m{^(\S+):(.*)$}o) {
307 # yes; memorize remote ID and strip from location string
308 $seqid = $1;
309 $locstr = $2;
312 # split into start and end
313 my ($start, $end) = split(/\.\./, $locstr);
314 # remove enclosing parentheses if any; note that because of parentheses
315 # possibly surrounding the entire location the parentheses around start
316 # and/or may be asymmetrical
317 # Note: these are from X.Y fuzzy locations, which are deprecated!
318 $start =~ s/(?:^\[+|\]+$)//g if $start;
319 $end =~ s/(?:^\[+|\]+$)//g if $end;
321 # Is this a simple (exact) or a fuzzy location? Simples have exact start
322 # and end, or is between two adjacent bases. Everything else is fuzzy.
323 my $loctype = ".."; # exact with start and end as default
325 $loctype = '?' if ( ($locstr =~ /\?/) && ($locstr !~ /\?\d+/) );
327 my $locclass = "Bio::Location::Simple";
328 if(! defined($end)) {
329 if($locstr =~ /(\d+)([\.\^])(\d+)/) {
330 $start = $1;
331 $end = $3;
332 $loctype = $2;
333 $locclass = "Bio::Location::Fuzzy"
334 unless (abs($end-$start) <= 1) && ($loctype eq "^");
335 } else {
336 $end = $start;
339 # start_num and end_num are for the numeric only versions of
340 # start and end so they can be compared
341 # in a few lines
342 my ($start_num, $end_num) = ($start,$end);
343 if ( ($start =~ /[\>\<\?\.\^]/) || ($end =~ /[\>\<\?\.\^]/) ) {
344 $locclass = 'Bio::Location::Fuzzy';
345 if($start =~ /(\d+)/) {
346 ($start_num) = $1;
347 } else {
348 $start_num = 0
350 if ($end =~ /(\d+)/) {
351 ($end_num) = $1;
352 } else { $end_num = 0 }
354 my $strand = 1;
356 if( $start_num > $end_num && $loctype ne '?') {
357 ($start,$end,$strand) = ($end,$start,-1);
359 # instantiate location and initialize
360 $loc = $locclass->new(-verbose => $self->verbose,
361 -start => $start,
362 -end => $end,
363 -strand => $strand,
364 -location_type => $loctype);
365 # set remote ID if remote location
366 if($seqid) {
367 $loc->is_remote(1);
368 $loc->seq_id($seqid);
371 # done (hopefully)
372 return $loc;