158 lines
3.6 KiB
Perl
158 lines
3.6 KiB
Perl
package Ascii_genome_illustrator;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Carp;
|
|
|
|
sub new {
|
|
my $packagename = shift;
|
|
|
|
my ($molecule_name, $illustration_length) = @_;
|
|
|
|
my $self = { name => $molecule_name,
|
|
illustration_length => $illustration_length,
|
|
features => [],
|
|
};
|
|
|
|
bless ($self, $packagename);
|
|
|
|
return ($self);
|
|
}
|
|
|
|
|
|
####
|
|
sub add_features { ## accepts list of features
|
|
my $self = shift;
|
|
my @features = @_;
|
|
|
|
foreach my $feature (@features) {
|
|
unless (ref $feature eq 'ARRAY') { confess "Error, improper params; should be a list of feature array refs"; }
|
|
$self->add_feature(@$feature);
|
|
}
|
|
|
|
|
|
return;
|
|
}
|
|
|
|
####
|
|
sub add_feature {
|
|
my $self = shift;
|
|
my ($feature_name, $feature_end5, $feature_end3, $glyph) = @_;
|
|
|
|
unless ($feature_name && $feature_end5 =~ /^\d+$/ && $feature_end3 =~ /^\d+$/ && defined($glyph) ) {
|
|
confess "Error, improper params";
|
|
}
|
|
|
|
unless (length($glyph) == 1 && $glyph !~ /\s/) { confess "Error, glyph must be a single non ws character.";}
|
|
|
|
my $orient = ($feature_end5 < $feature_end3) ? '+' : '-';
|
|
|
|
my ($lend, $rend) = sort {$a<=>$b} ($feature_end5, $feature_end3);
|
|
|
|
#print "Feature: $feature_name, $lend => $rend ($orient)\n";
|
|
|
|
my $feature_struct = { name => $feature_name,
|
|
lend => $lend,
|
|
rend => $rend,
|
|
orient => $orient,
|
|
glyph => $glyph,
|
|
};
|
|
|
|
push (@{$self->{features}}, $feature_struct);
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
####
|
|
sub get_features {
|
|
my $self = shift;
|
|
return (@{$self->{features}});
|
|
}
|
|
|
|
|
|
|
|
####
|
|
sub illustrate {
|
|
my $self = shift;
|
|
|
|
my ($mol_lend, $mol_rend) = @_;
|
|
|
|
|
|
unless ($mol_lend && $mol_rend) { confess "invalid params"; }
|
|
|
|
my $illustration_length = $self->{illustration_length};
|
|
|
|
my $text = sprintf("%+20s ", "$mol_lend-$mol_rend") . "[" . ("=" x ($illustration_length-2)) . "]\t" . $self->{name} . "\n";
|
|
|
|
foreach my $feature ($self->get_features()) {
|
|
|
|
my ($name, $lend, $rend, $orient, $glyph) = ($feature->{name}, $feature->{lend}, $feature->{rend}, $feature->{orient}, $feature->{glyph});
|
|
|
|
my @illustration_array;
|
|
## init to clean palette
|
|
for (my $i = 0; $i < $illustration_length; $i++) { $illustration_array[$i] = " "; }
|
|
|
|
my ($pos_lend, $pos_rend) = $self->_compute_palette_position([$lend, $rend], [$mol_lend, $mol_rend]);
|
|
|
|
# draw
|
|
for (my $i = $pos_lend; $i <= $pos_rend; $i++) { $illustration_array[$i] = $glyph; }
|
|
|
|
if ($orient eq '+') {
|
|
$illustration_array[$pos_rend] = '>';
|
|
}
|
|
elsif ($orient eq '-') {
|
|
$illustration_array[$pos_lend] = '<';
|
|
}
|
|
else {
|
|
confess "Don't recognize orient:$orient";
|
|
}
|
|
|
|
$text .= sprintf ("%+20s$orient ", "$lend-$rend") . join ("", @illustration_array) . "\t$name\n";
|
|
}
|
|
|
|
return ($text);
|
|
}
|
|
|
|
|
|
####
|
|
sub _compute_palette_position {
|
|
my $self = shift;
|
|
|
|
my ($feature_coords_aref, $mol_coords_aref) = @_;
|
|
|
|
my $illustration_length = $self->{illustration_length};
|
|
|
|
my ($feature_lend, $feature_rend) = @$feature_coords_aref;
|
|
my ($mol_lend, $mol_rend) = @$mol_coords_aref;
|
|
|
|
unless ($feature_lend <= $mol_rend && $feature_rend >= $mol_lend) {
|
|
## no overlap
|
|
return (-1, -1);
|
|
}
|
|
|
|
if ($feature_lend < $mol_lend) {
|
|
$feature_lend = $mol_lend;
|
|
}
|
|
|
|
if ($feature_rend > $mol_rend) {
|
|
$feature_rend = $mol_rend;
|
|
}
|
|
|
|
my $mol_region_length = $mol_rend - $mol_lend + 1;
|
|
|
|
my $delta_left = $feature_lend - $mol_lend + 1;
|
|
my $delta_right = $feature_rend - $mol_lend + 1;
|
|
|
|
my $pos_left = int($delta_left / $mol_region_length * $illustration_length + 0.5) - 1;
|
|
$pos_left = 0 if $pos_left < 0;
|
|
my $pos_right = int($delta_right / $mol_region_length * $illustration_length + 0.5) - 1;
|
|
$pos_right = 0 if $pos_right < 0;
|
|
|
|
return ($pos_left, $pos_right);
|
|
}
|
|
|
|
|
|
|
|
1; #EOM
|