Skip to content

Commit

Permalink
combine split-ness with Location role
Browse files Browse the repository at this point in the history
  • Loading branch information
Chris Fields committed Nov 22, 2011
1 parent b3ac00c commit a384c7c
Show file tree
Hide file tree
Showing 8 changed files with 208 additions and 145 deletions.
6 changes: 4 additions & 2 deletions lib/Biome/Factory/FTLocationFactory.pm
View file
Expand Up @@ -18,8 +18,8 @@ $LOCREG = qr{
# make global for now, allow for abstraction later
our $SIMPLE_CLASS = 'Biome::Location::Simple';

#our $SPLIT_CLASS = 'Biome::Location::Split';

# TODO: refactor to a default attribute that lazily loads the class (I have code
# for that somewhere, let's see, where did I put that......)
sub BUILD {
my ($self) = @_;
$self->load_modules($SIMPLE_CLASS);
Expand All @@ -31,6 +31,8 @@ sub from_string {

# run on first pass only
# Note : These location types are now deprecated in GenBank (Oct. 2006)

# TODO: deprecate support for these?
if (!defined($op)) {
# convert all (X.Y) to [X.Y]
$locstr =~ s{\((\d+\.\d+)\)}{\[$1\]}g;
Expand Down
15 changes: 6 additions & 9 deletions lib/Biome/Role/Location/Locatable.pm
View file
Expand Up @@ -2,6 +2,7 @@ package Biome::Role::Location::Locatable;

use Biome::Role;
use namespace::clean -except => 'meta';
use List::Util qw(max min);

requires qw(start end strand from_string to_string);

Expand All @@ -10,7 +11,8 @@ requires qw(start end strand from_string to_string);

has 'seq_id' => (
is => 'rw',
isa => 'Str'
isa => 'Str',
predicate => 'has_seq_id',
);

# returns true if strands are equal and non-zero
Expand Down Expand Up @@ -132,15 +134,10 @@ sub union {

$self->_eval_ranges(@$given);

my @start = sort {$a <=> $b} map { $_->start() } ($self, @$given);
my @end = sort {$a <=> $b} map { $_->end() } ($self, @$given);
my $id = $self->seq_id;

my $start = shift @start;
while( !$start ) {
$start = shift @start;
}

my $end = pop @end;
my $start = min map { $_->start() } ($self, @$given);
my $end = max map { $_->end() } ($self, @$given);

my $union_strand = $self->strand; # Strand for the union range object.

Expand Down
30 changes: 15 additions & 15 deletions lib/Biome/Role/Location/LocationContainer.pm
View file
Expand Up @@ -33,17 +33,17 @@ role {
my $p = shift;

my ($class, $singular, $plural) = ($p->class, $p->short_name, $p->plural);

$class ||= 'Biome::Role::Location::Simple'; # any location consumer

if ($p->layered) {
$singular = "sub$singular";
$plural = "sub$plural";
}

has $singular => (
is => 'ro',
isa => 'ArrayRef[Biome::Role::Location::Simple]', # needs a subtype or role type
isa => "ArrayRef[$class]", # needs a subtype or role type
traits => ['Array'],
default => sub {[]},
handles => {
Expand All @@ -53,7 +53,7 @@ role {
"remove_$plural" => 'clear'
}
);

# implementing class must provide this, is implementation-specific
requires "add_$singular";
};
Expand All @@ -72,15 +72,15 @@ container.
=head1 SYNOPSIS
package Foo;
use Biome;
with 'Biome::Role::Location::LocationContainer' =>
{ class => 'Biome::SeqFeature::Generic',
abbrev => 'Feature'};
# Foo now can contain an array of Biome::SeqFeature::Generic. Adding
# a new
# a new
=head1 DESCRIPTION
Simple parameterizable role for anything that has one or more Locations
Expand All @@ -99,7 +99,7 @@ A method to add new Locations; as this is implementation-specific,
this is required for anything consuming this class. For instance, a consumer
=back
=back
=head1 SUBROUTINES/METHODS
Expand Down Expand Up @@ -158,12 +158,12 @@ BioPerl mailing lists. Your participation is much appreciated.
Patches are always welcome.
=head2 Support
=head2 Support
Please direct usage questions or support issues to the mailing list:
L<bioperl-l@bioperl.org>
rather than to the module maintainer directly. Many experienced and reponsive
experts will be able look at the problem and quickly address it. Please include
a thorough description of the problem with code and data examples if at all
Expand Down Expand Up @@ -258,4 +258,4 @@ followed by whatever licence you wish to release it under.
For Perl code that is often just:
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
modify it under the same terms as Perl itself. See L<perlartistic>.
36 changes: 33 additions & 3 deletions lib/Biome/Role/Location/Simple.pm
View file
Expand Up @@ -2,10 +2,13 @@ package Biome::Role::Location::Simple;

use 5.010;
use Biome::Role;
use namespace::clean -except => 'meta';
use namespace::autoclean -except => 'meta';

use Biome::Type::Location qw(Location_Type Location_Symbol
Location_Pos_Type Location_Pos_Symbol);
use Biome::Type::Location qw(Location_Type
Split_Location_Type
Location_Symbol
Location_Pos_Type
Location_Pos_Symbol);

with 'Biome::Role::Location::Stranded';

Expand Down Expand Up @@ -166,6 +169,33 @@ sub valid_Location {
sub to_string {
my ($self) = @_;

my $type = $self->location_type;

if (is_Split_Location_Type($type)) {
my @segs = $self->sub_Locations;
my $str = lc($type).'('.join(',', map {$_->to_string} @segs).')';
if ($self->strand && $self->strand < 0) {
$str = "complement($str)";
}
return $str;
}

# # JOIN assumes specific order, ORDER does not, BOND ?
# my $type = $self->location_type;
# if ($self->resolve_Locations) {
# my $substrand = $self->sub_Location_strand;
# if ($substrand && $substrand < 0) {
# $self->flip_strand();
# $self->strand(-1);
# }
# }
# my @segs = $self->sub_Locations;
# my $str = lc($type).'('.join(',', map {$_->to_string} @segs).')';
# if ($self->strand && $self->strand < 0) {
# $str = "complement($str)";
# }
# $str;

my %data;
for (qw(
start end
Expand Down
44 changes: 31 additions & 13 deletions lib/Biome/Role/Location/Split.pm
View file
Expand Up @@ -2,7 +2,7 @@ package Biome::Role::Location::Split;

use 5.010;
use Biome::Role;
use Biome::Type::Location qw(ArrayRef_of_Locatable);
use Biome::Type::Location qw(Split_Location_Type ArrayRef_of_Locatable);
use Biome::Type::Sequence qw(Maybe_Sequence_Strand);
use List::Util qw(reduce);
use namespace::clean -except => 'meta';
Expand All @@ -28,22 +28,40 @@ has 'locations' => (
default => sub { [] }
);


has 'auto_expand' => (
isa => 'Bool',
is => 'ro',
default => 1
);

sub add_sub_Location {
my ($self, $loc) = @_;

# TODO : deal with remote locations, offsets
# TODO : make expansion optional

#if ($self->auto_expand) {
my ($start,$end,$strand) = $self->union($loc);
$self->debug("$start-$end:$strand\n");
$self->start($start);
$self->end($end);
$self->strand($strand);
#}
$self->push_sub_Location($loc);
if (!is_Split_Location_Type($self->location_type)) {
$self->throw("Type ".$self->location_type." does not allow sub locations, change location_type");
}

my $locs = $self->locations;

if ($self->auto_expand) {
if (@$locs) {
if (!$loc->is_remote) {
my ($start,$end,$strand) = $self->union($loc);
$self->strand($strand);
$self->start($start);
$self->end($end);
}
} else {
$self->start($loc->start);
$self->end($loc->end);
$self->strand($loc->strand);
$self->seq_id($loc->seq_id) if $loc->seq_id;
}
}

push @$locs, $loc;

1;
}

#has 'location_type' => (
Expand Down
30 changes: 20 additions & 10 deletions lib/Biome/Type/Location.pm
View file
Expand Up @@ -13,6 +13,8 @@ use MooseX::Types -declare => [qw(
Location_Pos_Type
Location_Symbol
Location_Type
Simple_Location_Type
Split_Location_Type
Locatable
ArrayRef_of_Locatable
Expand Down Expand Up @@ -45,16 +47,22 @@ my %SYMBOL_TYPE = (

my %TYPE_SYMBOL = map {$SYMBOL_TYPE{$_} => $_} keys %SYMBOL_TYPE;

# TODO: convert these to enums
my %VALID_SPLIT_TYPE = map {$_ => 1}
qw(JOIN ORDER BOND);

my %VALID_SIMPLE_TYPE = map {$_ => 1}
qw(EXACT IN-BETWEEN WITHIN);

# WITHIN here is very rare but does occur, ex (122.144)
my %VALID_LOCATION_TYPE = map {$_ => 1}
qw(EXACT IN-BETWEEN WITHIN JOIN ORDER BOND);
(keys(%VALID_SIMPLE_TYPE), keys(%VALID_SPLIT_TYPE));

my %VALID_LOCATION_POS_TYPE = map {$_ => 1}
qw(EXACT BEFORE AFTER WITHIN UNCERTAIN);

# TODO: some of these could probably be redef. as enums, but it makes coercion
# easier, needs checking

subtype Location_Symbol,
as Str,
where {exists $VALID_LOCATION_SYMBOL{$_}},
Expand All @@ -65,6 +73,16 @@ subtype Location_Type,
where {exists $VALID_LOCATION_TYPE{$_}},
message {"Unknown Location type $_"};

subtype Split_Location_Type,
as Str,
where {exists $VALID_SPLIT_TYPE{uc $_}},
message {"Unknown Split Location type $_"};

subtype Simple_Location_Type,
as Str,
where {exists $VALID_SIMPLE_TYPE{uc $_}},
message {"Unknown Split Location type $_"};

subtype Location_Pos_Symbol,
as Str,
where {exists $VALID_LOCATION_POS_SYMBOL{$_}},
Expand All @@ -91,14 +109,6 @@ coerce Location_Type,
from Location_Symbol,
via {$TYPE_SYMBOL{$_}};

#my %VALID_SPLIT_TYPE = map {$_ => 1}
# qw(JOIN ORDER BOND);

#subtype Split_Location_Type,
# as Str,
# where {exists $VALID_SPLIT_TYPE{uc $_}},
# message {"Unknown Split Location type $_"};

role_type Locatable, { role => 'Biome::Role::Location::Locatable' };

subtype ArrayRef_of_Locatable,
Expand Down

0 comments on commit a384c7c

Please sign in to comment.