Skip to content

Commit

Permalink
start splitting out multiple location behavior; there needs to be a s…
Browse files Browse the repository at this point in the history 
…imple container class that has all the necessary logic divorced from the simpler segmental coordinate stuff
  • Loading branch information
Chris Fields committed Feb 15, 2012
1 parent 1f56ffd commit dc78731
Show file tree
Hide file tree
Showing 5 changed files with 68 additions and 229 deletions.
5 changes: 3 additions & 2 deletions lib/Biome/Factory/FTLocationFactory.pm
View file
Expand Up @@ -53,6 +53,8 @@ sub from_string {
SUBLOCS:
while (@sublocs) {
my $subloc = shift @sublocs;

# TODO: make hash lookup
my $oparg = ($subloc eq 'join' || $subloc eq 'bond' ||
$subloc eq 'order' || $subloc eq 'complement') ? $subloc : undef;
# has operator, requires further work (recurse)
Expand All @@ -63,7 +65,7 @@ sub from_string {
my @splitlocs = split(q(,), $sub);
if (@splitlocs == 1) {
# this should be a complement only
$self->throw("getting nested l") unless $oparg eq 'complement';
#$self->throw("Getting nested joins is not supported") unless $oparg eq 'complement';
$loc_obj = $SIMPLE_CLASS->new(location_string => "complement($splitlocs[0])");
} else {
$loc_obj = $SIMPLE_CLASS->new(-verbose => 1,
Expand All @@ -74,7 +76,6 @@ sub from_string {
if ($splitloc =~ m{\(($LOCREG)\)}) {
my $comploc = $1;
$sobj = $SIMPLE_CLASS->new(location_string => $comploc);
$sobj->strand(-1);
} else {
$sobj = $SIMPLE_CLASS->new(location_string => $splitloc);
}
Expand Down
43 changes: 28 additions & 15 deletions lib/Biome/Role/Location/Simple.pm
View file
Expand Up @@ -10,11 +10,12 @@ use Biome::Type::Location qw(Location_Type
Location_Pos_Type
Location_Pos_Symbol);

with 'Biome::Role::Location::Stranded';
use Biome::Type::Sequence qw(Sequence_Strand);

has 'start' => (
isa => 'Num',
is => 'rw',
# TODO: should a default for a 1-based coord system be 0? Seems a cludge...
default => 0,

# TODO: may remove these and move to a validate() root method (see below)
Expand All @@ -33,6 +34,7 @@ has 'start' => (
has 'end' => (
isa => 'Num',
is => 'rw',
# TODO: should a default for a 1-based coord system be 0? Seems a cludge...
default => 0,

# TODO: may remove these and add a validate() root method (see below)
Expand All @@ -48,17 +50,13 @@ has 'end' => (
}
});

sub length {
my ($self) = @_;
given ($self->location_type) {
when ([qw(EXACT WITHIN)]) {
return $self->end - $self->start + 1;
}
default {
return 0
}
}
}
has strand => (
isa => Sequence_Strand,
is => 'rw',
default => 0,
coerce => 1
);


has 'start_pos_type' => (
isa => Location_Pos_Type,
Expand Down Expand Up @@ -122,6 +120,18 @@ has 'is_remote' => (
default => 0
);

sub length {
my ($self) = @_;
given ($self->location_type) {
when ([qw(EXACT WITHIN)]) {
return $self->end - $self->start + 1;
}
default {
return 0
}
}
}

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

# these just delegate to start, end, using the indicated offsets
Expand Down Expand Up @@ -173,14 +183,17 @@ sub to_string {

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) {
my $str;
if ($self->strand >= 0) {
$str = lc($type).'('.join(',', map {$_->to_string} @segs).')'
} else {
$str = lc($type).'('.join(',', map {$_->to_string} @segs).')';
$str = "complement($str)";
}
return $str;
}

# # JOIN assumes specific order, ORDER does not, BOND ?
# JOIN assumes specific order, ORDER does not, BOND ?
# my $type = $self->location_type;
# if ($self->resolve_Locations) {
# my $substrand = $self->sub_Location_strand;
Expand Down
192 changes: 11 additions & 181 deletions lib/Biome/Role/Location/Split.pm
View file
Expand Up @@ -3,7 +3,7 @@ package Biome::Role::Location::Split;
use 5.010;
use Biome::Role;
use Biome::Type::Location qw(Split_Location_Type ArrayRef_of_Locatable);
use Biome::Type::Sequence qw(Maybe_Sequence_Strand);
use Biome::Type::Sequence qw(Sequence_Strand);
use List::Util qw(reduce);
use namespace::clean -except => 'meta';

Expand Down Expand Up @@ -34,200 +34,30 @@ has 'auto_expand' => (
default => 1
);

has 'guide_strand' => (
isa => Sequence_Strand,
is => 'rw',
default => 1
);

sub add_sub_Location {
my ($self, $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 && !$loc->is_remote) {
my $union_loc = @$locs ? $self->union($loc) : $loc;
# carry over data
for my $att (qw(start end start_pos_type end_pos_type)) {
$self->$att($union_loc->$att);
}
$self->strand($union_loc->strand);
$self->start($union_loc->start);
$self->end($union_loc->end);
$self->start_pos_type($union_loc->start_pos_type);
$self->end_pos_type($union_loc->end_pos_type);
$self->seq_id($loc->seq_id) if $loc->seq_id && @$locs;
}
push @$locs, $loc;
1;
}

#has 'location_type' => (
# isa => Split_Location_Type,
# is => 'rw',
# lazy => 1,
# default => 'JOIN'
#);

#has 'resolve_Locations' => (
# isa => 'Bool',
# is => 'rw',
# lazy => 1,
# default => 1,
#);
#
#sub length {
# my ($self) = @_;
# return $self->end - $self->start + 1;
#}
#
#sub sub_Location_strand {
# my ($self) = @_;
# my ($strand, $lstrand);
#
# # this could use reduce()
# foreach my $loc ($self->sub_Locations()) {
# $lstrand = $loc->strand();
# if((! $lstrand) ||
# ($strand && ($strand != $lstrand)) ||
# $loc->is_remote()) {
# $strand = undef;
# last;
# } elsif(! $strand) {
# $strand = $lstrand;
# }
# }
# return $strand;
#}
#
## overrides
#
#has 'strand' => (
# isa => Maybe_Sequence_Strand,
# is => 'rw',
# lazy => 1,
# predicate => 'has_strand',
# default => sub {
# my $self = shift;
# return $self->sub_Location_strand;
# },
#);
#
#sub start {
# my ($self, $start) = @_;
# $self->get_sub_Location(0)->start($start) if defined($start);
# return $self->get_sub_Location(0)->start if $self->is_remote;
# return $self->_reduce('start');
#}
#
#sub end {
# my ($self, $end) = @_;
# $self->get_sub_Location(0)->end($end) if defined($end);
# return $self->get_sub_Location(0)->end if $self->is_remote;
# return $self->_reduce('end');
#}
#
#sub is_remote {
# my $self = shift;
# for my $seg ($self->sub_Locations) {
# return 1 if $seg->is_remote;
# }
# 0;
#}
#
#sub min_start {
# my $self = shift;
# return $self->get_sub_Location(0)->min_start if $self->is_remote;
# return $self->_reduce('min_start');
#}
#
#sub max_start {
# my $self = shift;
# return $self->get_sub_Location(0)->max_start if $self->is_remote;
# return $self->_reduce('max_start');
#}
#
#sub min_end {
# my $self = shift;
# return $self->get_sub_Location(0)->min_end if $self->is_remote;
# return $self->_reduce('min_end');
#}
#
#sub max_end {
# my $self = shift;
# return $self->get_sub_Location(0)->max_end if $self->is_remote;
# return $self->_reduce('max_end');
#}
#
#sub start_pos_type {
# my $self = shift;
# my $type = reduce {$a eq $b ? $a : undef}
# map {$_->start_pos_type} $self->sub_Locations;
# return $type;
#}
#
#sub end_pos_type {
# my $self = shift;
# my $type = reduce {$a eq $b ? $a : undef}
# map {$_->end_pos_type} $self->sub_Locations;
# return $type;
#}
#
#sub valid_Location {
# # TODO: add tests
# my $self = shift;
# my $type = reduce {$a eq $b ? 1 : 0}
# map {$_->valid_Location} $self->sub_Locations;
#}
#
#sub is_fuzzy {
# # TODO: add tests
# my $self = shift;
# my $type = reduce {$a eq $b ? 1 : 0}
# map {$_->is_fuzzy} $self->sub_Locations;
#}
#
## no offsets for splits? Or maybe for only the first/last one?
#sub start_offset { 0 }
#
#sub end_offset { 0 }
#
#sub flip_strand {
# my $self = shift;
# my @segs = @{$self->locations()};
# @segs = map {$_->flip_strand(); $_} reverse @segs;
# $self->_set_locations(\@segs);
#}
#
#sub to_string {
# my $self = shift;
# # 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;
#}
#
## could do all string parsing here instead of FTLocationFactory...
#sub from_string {
# shift->throw_not_implemented;
#}
#
## helper, just grabs the indicated value for the contained locations
#sub _reduce {
# my ($self, $caller) = @_;
# my @segs = sort {
# $a->$caller <=> $b->$caller
# }
# grep {$_->$caller} $self->sub_Locations;
# return unless @segs == $self->num_sub_Locations;
# $caller =~ /start/ ? return $segs[0]->$caller : return $segs[-1]->$caller;
#}

1;

__END__
Expand Down
15 changes: 5 additions & 10 deletions lib/Biome/Type/Sequence.pm
View file
Expand Up @@ -11,15 +11,15 @@ package Biome::Type::Sequence;
use MooseX::Types -declare => [qw(
Sequence_Strand
Maybe_Sequence_Strand
Sequence_Strand_Int
Sequence_Strand_Symbol
Sequence_Alphabet
Maybe_Sequence_Alphabet
Sequence_Phase
Output_ID_Type
)];

Expand All @@ -30,9 +30,6 @@ subtype Sequence_Strand,
where {$_ >= -1 && $_ <= 1},
message { "Strand can be -1, 0, or 1, not $_"};

subtype Maybe_Sequence_Strand,
as Maybe[Sequence_Strand];

subtype Sequence_Phase,
as Maybe[Int],
where { $_ >= 0 && $_ <= 2},
Expand All @@ -42,8 +39,7 @@ subtype Sequence_Strand_Symbol,
as Str,
where { /^(?:[\+\-\.])$/},
message { "Strand symbol can be one of [-.+], not $_"};



my %STRAND_SYMBOL = (
'+' => 1,
'.' => 0,
Expand All @@ -70,4 +66,3 @@ no MooseX::Types::Moose;
1;

__END__

0 comments on commit dc78731

Please sign in to comment.