use strict;
use base qw(Test::GenOO);
#######################################################################
################ Startup (Runs once in the begining ################
#######################################################################
sub _check_loading : Test(startup => 1) {
my ($self) = @_;
use_ok $self->class;
};
#######################################################################
################# Setup (Runs before every method) #################
#######################################################################
sub create_new_test_objects : Test(setup) {
my ($self) = @_;
my $test_class = ref($self) || $self;
$self->{TEST_OBJECTS} = $test_class->test_objects();
};
#######################################################################
########################## Initial Tests ##########################
#######################################################################
sub _isa_test : Test(1) {
my ($self) = @_;
isa_ok $self->obj(0), $self->class, "... and the object";
}
sub _role_check : Test(1) {
my ($self) = @_;
does_ok($self->obj(0), 'GenOO::Region', '... does the GenOO::Region role');
}
#######################################################################
####################### Class Interface Tests #####################
#######################################################################
sub name : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'name', "... test object has the 'name' attribute");
is $self->obj(0)->name, 'test_object_0', "... and returns the correct value";
}
sub species : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'species', "... test object has the 'species' attribute");
is $self->obj(0)->species, 'human', "... and returns the correct value";
}
sub strand : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'strand', "... test object has the 'strand' attribute");
is $self->obj(0)->strand, 1, "... and returns the correct value";
}
sub chromosome : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'chromosome', "... test object has the 'chromosome' attribute");
is $self->obj(0)->chromosome, 'chr1', "... and returns the correct value";
}
sub start : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'start', "... test object has the 'start' attribute");
is $self->obj(0)->start, 3, "... and returns the correct value";
}
sub stop : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'stop', "... test object has the 'stop' attribute");
is $self->obj(0)->stop, 10, "... and returns the correct value";
}
sub copy_number : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'copy_number', "... test object has the 'copy_number' attribute");
is $self->obj(0)->copy_number, 7, "... and returns the correct value";
}
sub sequence : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'sequence', "... test object has the 'sequence' attribute");
is $self->obj(0)->sequence, 'AGCTAGCU', "... and returns the correct value";
}
sub rname : Test(2) {
my ($self) = @_;
can_ok $self->obj(0), 'rname';
is $self->obj(0)->rname, 'chr1', "... and returns the correct value";
}
sub id : Test(2) {
my ($self) = @_;
can_ok $self->obj(0), 'id';
is $self->obj(0)->id, 'chr1:3-10:1', "... and returns the correct value";
}
#######################################################################
####################### Role Interface Tests ######################
#######################################################################
sub length : Test(2) {
my ($self) = @_;
has_attribute_ok($self->obj(0), 'length', "... test object has the 'length' attribute");
is $self->obj(0)->length, 8, "... and returns the correct value";
}
sub location : Test(2) {
my ($self) = @_;
can_ok $self->obj(0), 'location';
is $self->obj(0)->location, 'chr1:3-10:1', "... and returns the correct value";
}
sub strand_symbol : Test(2) {
my ($self) = @_;
can_ok $self->obj(0), 'strand_symbol';
is $self->obj(0)->strand_symbol, '+', "... and returns the correct value";
}
sub head_position : Test(3) {
my ($self) = @_;
can_ok $self->obj(0), 'head_position';
is $self->obj(0)->head_position, 3, "... and returns the correct value";
is $self->obj(6)->head_position, 30, "... and returns the correct value";
}
sub tail_position : Test(3) {
my ($self) = @_;
can_ok $self->obj(0), 'tail_position';
is $self->obj(0)->tail_position, 10, "... and returns the correct value";
is $self->obj(6)->tail_position, 21, "... and returns the correct value";
}
sub mid_position : Test(5) {
my ($self) = @_;
can_ok $self->obj(0), 'mid_position';
is $self->obj(0)->mid_position, 6.5, "... and returns the correct value";
is $self->obj(1)->mid_position, 6, "... and returns the correct value";
is $self->obj(6)->mid_position, 25.5, "... and returns the correct value";
is $self->obj(7)->mid_position, 26, "... and returns the correct value";
}
sub mid_mid_distance_from : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'mid_mid_distance_from';
is $self->obj(1)->mid_mid_distance_from($self->obj(0)), -0.5, "... and returns the correct value";
is $self->obj(0)->mid_mid_distance_from($self->obj(1)), 0.5, "... and returns the correct value";
is $self->obj(9)->mid_mid_distance_from($self->obj(12)), 24.5, "... and returns the correct value";
is $self->obj(12)->mid_mid_distance_from($self->obj(9)), -24.5, "... and returns the correct value";
dies_ok {$self->obj(6)->mid_mid_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";
}
sub mid_head_distance_from : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'mid_head_distance_from';
is $self->obj(1)->mid_head_distance_from($self->obj(0)), 3, "... and returns the correct value";
is $self->obj(0)->mid_head_distance_from($self->obj(1)), 4.5, "... and returns the correct value";
is $self->obj(9)->mid_head_distance_from($self->obj(12)), 32, "... and returns the correct value";
is $self->obj(12)->mid_head_distance_from($self->obj(9)), -22.5, "... and returns the correct value";
dies_ok {$self->obj(6)->mid_head_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";
}
sub head_head_distance_from : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'head_head_distance_from';
is $self->obj(1)->head_head_distance_from($self->obj(0)), -1, "... and returns the correct value";
is $self->obj(0)->head_head_distance_from($self->obj(1)), 1, "... and returns the correct value";
is $self->obj(12)->head_head_distance_from($self->obj(9)), -30 , "... and returns the correct value";
is $self->obj(9)->head_head_distance_from($self->obj(12)), 30 , "... and returns the correct value";
dies_ok {$self->obj(6)->head_head_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";
}
sub head_tail_distance_from : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'head_tail_distance_from';
is $self->obj(1)->head_tail_distance_from($self->obj(0)), -8, "... and returns the correct value";
is $self->obj(0)->head_tail_distance_from($self->obj(1)), -7, "... and returns the correct value";
is $self->obj(6)->head_tail_distance_from($self->obj(7)), -8, "... and returns the correct value";
is $self->obj(12)->head_tail_distance_from($self->obj(9)), -34, "... and returns the correct value";
dies_ok {$self->obj(6)->head_tail_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";
}
sub tail_head_distance_from : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'tail_head_distance_from';
is $self->obj(0)->tail_head_distance_from($self->obj(2)), 9, "... and returns the correct value";
is $self->obj(2)->tail_head_distance_from($self->obj(0)), 7, "... and returns the correct value";
is $self->obj(6)->tail_head_distance_from($self->obj(7)), 9, "... and returns the correct value";
is $self->obj(7)->tail_head_distance_from($self->obj(6)), 8, "... and returns the correct value";
dies_ok {$self->obj(0)->tail_head_distance_from($self->obj(3))} "... and dies when comparing regions on different reference";
}
sub tail_tail_distance_from : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'tail_tail_distance_from';
is $self->obj(3)->tail_tail_distance_from($self->obj(4)), -1, "... and returns the correct value";
is $self->obj(4)->tail_tail_distance_from($self->obj(3)), 1, "... and returns the correct value";
is $self->obj(6)->tail_tail_distance_from($self->obj(7)), 1, "... and returns the correct value";
is $self->obj(7)->tail_tail_distance_from($self->obj(6)), -1, "... and returns the correct value";
dies_ok {$self->obj(0)->tail_tail_distance_from($self->obj(3))} "... and dies when comparing regions on different reference";
}
sub to_string : Test(2) {
my ($self) = @_;
can_ok $self->obj(0), 'to_string';
is $self->obj(0)->to_string, 'chr1:3-10:1', "... and returns the correct value";
}
sub overlaps : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'overlaps';
is $self->obj(0)->overlaps($self->obj(1)), 1, "... and returns the correct value";
is $self->obj(0)->overlaps($self->obj(6)), 0, "... and returns the correct value";
is $self->obj(6)->overlaps($self->obj(7)), 1, "... and returns the correct value";
is $self->obj(12)->overlaps($self->obj(13)), 0, "... and returns the correct value"; # strand sensitive
is $self->obj(12)->overlaps($self->obj(13), 0), 1, "... and returns the correct value"; # strand insensitive
}
sub overlaps_with_offset : Test(6) {
my ($self) = @_;
can_ok $self->obj(0), 'overlaps_with_offset';
is $self->obj(0)->overlaps_with_offset($self->obj(1)), 1, "... and returns the correct value";
is $self->obj(11)->overlaps_with_offset($self->obj(12)), 0, "... and returns the correct value"; # without span
is $self->obj(11)->overlaps_with_offset($self->obj(12), 1, 10), 1, "... and returns the correct value"; # with span
is $self->obj(12)->overlaps_with_offset($self->obj(13)), 0, "... and returns the correct value"; # strand sensitive
is $self->obj(12)->overlaps_with_offset($self->obj(13), 0), 1, "... and returns the correct value"; # strand insensitive
}
sub overlap_length : Test(5) {
my ($self) = @_;
can_ok $self->obj(0), 'overlap_length';
is $self->obj(0)->overlap_length($self->obj(1)), 8, "... and returns the correct value";
is $self->obj(0)->overlap_length($self->obj(6)), 0, "... and returns the correct value";
is $self->obj(6)->overlap_length($self->obj(7)), 9, "... and returns the correct value";
is $self->obj(12)->overlap_length($self->obj(13)), 0, "... and returns the correct value";
}
sub contains : Test(7) {
my ($self) = @_;
can_ok $self->obj(0), 'contains';
is $self->obj(0)->contains($self->obj(1)), 0, "... and returns the correct value";
is $self->obj(1)->contains($self->obj(0)), 1, "... and returns the correct value";
is $self->obj(0)->contains($self->obj(6)), 0, "... and returns the correct value";
is $self->obj(6)->contains($self->obj(7)), 1, "... and returns the correct value";
is $self->obj(7)->contains($self->obj(6)), 0, "... and returns the correct value";
is $self->obj(12)->contains($self->obj(13)), 0, "... and returns the correct value";
}
sub contains_position : Test(5) {
my ($self) = @_;
can_ok $self->obj(0), 'contains_position';
is $self->obj(0)->contains_position(5), 1, "... and returns the correct value";
is $self->obj(0)->contains_position(1), 0, "... and returns the correct value";
is $self->obj(6)->contains_position(22), 1, "... and returns the correct value";
is $self->obj(6)->contains_position(20), 0, "... and returns the correct value";
}
#######################################################################
########################## Helper Methods #########################
#######################################################################
sub obj {
my ($self, $index) = @_;
return $self->{TEST_OBJECTS}->[$index];
}
sub objs {
my ($self) = @_;
return @{$self->{TEST_OBJECTS}};
}
#######################################################################
############### Class method to create test objects ###############
#######################################################################
sub test_objects {
my ($test_class) = @_;
eval "require ".$test_class->class;
my @test_objects;
push @test_objects, $test_class->class->new(
name => 'test_object_0',
species => 'human',
strand => '+',
chromosome => 'chr1',
start => 3,
stop => 10,
copy_number => 7,
sequence => 'AGCTAGCU'
);
push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr1', start => 2, stop => 10);
push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr1', start => 1, stop => 10);
push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr2', start => 11, stop => 20);
push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr2', start => 12, stop => 21);
push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr2', start => 13, stop => 20);
push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr3', start => 21, stop => 30); # No 6
push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr3', start => 22, stop => 30);
push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr3', start => 23, stop => 30);
push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 31, stop => 35);
push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 33, stop => 40);
push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 32, stop => 40);
push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 50, stop => 65);
push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr4', start => 50, stop => 65); # No 13
return \@test_objects;
}
1;