Mercurial > repos > cpt > cpt_psm_plotter
diff lib/CPT/Plot/Base.pm @ 1:8691c1c61a8e draft default tip
planemo upload commit 94b0cd1fff0826c6db3e7dc0c91c0c5a8be8bb0c
author | cpt |
---|---|
date | Mon, 05 Jun 2023 02:48:47 +0000 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/CPT/Plot/Base.pm Mon Jun 05 02:48:47 2023 +0000 @@ -0,0 +1,983 @@ +package CPT::Plot::Base; +use Data::Dumper; +use CPT::Plot::Label; +use CPT::Plot::Class; +use CPT::Plot::Gene; +use CPT::Plot::Colours; +use Bio::SeqIO; +use SVG; +use Moose; + +# ABSTRACT: Main plotting class for genome mapper + +has 'svg' => ( is => 'rw', isa => 'Any' ); +has 'line_count' => ( is => 'rw', isa => 'Num', default => 1 ); +has '_ft_count' => ( is => 'rw', isa => 'Num', default => 0 ); +has 'classes' => ( is => 'rw', isa => 'HashRef' ); + +# Labels +has 'label' => ( is => 'rw', isa => 'Bool' ); + +has 'label_pos' => ( is => 'rw', isa => 'Any' ); +has 'label_shrink_mode' => ( is => 'rw', isa => 'Any' ); +has 'label_callouts' => ( is => 'rw', isa => 'Any' ); +has 'label_from' => ( is => 'rw', isa => 'Any' ); +has 'label_text_source' => ( is => 'rw', isa => 'Any' ); +has 'label_numeric_features' => ( is => 'rw', isa => 'Any' ); +has 'label_query' => ( is => 'rw', isa => 'Any' ); +has 'label_numbering_count' => ( is => 'rw', isa => 'Any', default => 1 ); + +has 'justified' => ( is => 'rw', isa => 'Str' ); + +# CHanged to any b/c unpassed = undef +has 'separate_strands' => ( is => 'rw', isa => 'Any' ); +has 'double_line_for_overlap' => ( is => 'rw', isa => 'Any' ); +has 'opacity' => ( is => 'rw', isa => 'Str' ); +has 'view' => ( is => 'rw', isa => 'Str' ); + +has 'color_scheme' => ( is => 'rw', isa => 'HashRef' ); +has 'wanted_tags' => ( is => 'rw', isa => 'HashRef' ); +has 'genome_length' => ( is => 'rw', isa => 'Int' ); +has 'features' => ( is => 'rw', isa => 'ArrayRef' ); +has 'start' => ( is => 'rw', isa => 'Int' ); +has 'end' => ( is => 'rw', isa => 'Int' ); + +has 'avgRowLength' => ( is => 'rw', isa => 'Int' ); +has 'calc_height' => ( is => 'rw', isa => 'Int' ); +has 'calc_width' => ( is => 'rw', isa => 'Int' ); +has 'x_offset' => ( is => 'rw', isa => 'Num' ); +has 'y_offset' => ( is => 'rw', isa => 'Num' ); +has 'ils' => ( is => 'rw', isa => 'Num' ); +has 'width_mode' => ( is => 'rw', isa => 'Str' ); +has 'width_value' => ( is => 'rw', isa => 'Num' ); +has 'rows' => ( is => 'rw', isa => 'Num' ); +has 'split_factor' => ( is => 'rw', isa => 'Num' ); + +has 'rowdata' => ( is => 'rw', isa => 'HashRef' ); +has '_internal_maxrowlength' => ( is => 'rw', isa => 'Num' ); + +my $color_spec = CPT::Plot::Colours->new( 'default' => '#000000' ); +our ( $parser, $tree, $cb ); + +sub init { + my ($self) = @_; + my %classes; + my %cs = %{ $self->color_scheme() }; + foreach my $key ( keys %cs ) { + $classes{$key} = CPT::Plot::Class->new( + 'key' => $key, + 'color' => $cs{$key}{color}, + 'border' => $cs{$key}{border}, + 'plot' => $cs{$key}{plot}, + 'included' => 1, + ); + } + $self->classes( \%classes ); + $self->init_label_stuff(); + $self->filterFeatues(); +} + +sub init_label_stuff { + my ($self) = @_; + + if ( $self->{'label_from'} eq 'custom' ) { + use Parse::BooleanLogic; + $parser = new Parse::BooleanLogic( operators => [ '', 'OR' ] ); + $tree = $parser->as_array( $self->label_query ); + print $parser; + + #foreach bio feature, + #if solve == 1, then add to our return, + #else doesn't match + #endforeach + #my $new_tree = $parser->solve($tree,$filter); + $cb = sub { + my $query = $_[0]->{'operand'}; + my $feature = $_[1]; + + my $negate = 0; + if ( substr( $query, 0, 1 ) eq '!' ) { #negate + $negate = 1; + $query = substr( $query, 1 ); + } + if ( $query =~ m/([^:]+):["']{0,1}([^'"]*)["']{0,1}/ ) { + my ( $k, $v ) = ( $1, $2 ); + my $result; + if ( $k eq 'contains' ) { + my $values = join( + "\t", + map { + if ( $_ ne + "translation" ) + { + join( + '', + $feature + ->get_tag_values + ( + $_ + ) + ); + } + } $feature->get_all_tags() + ); + if ( $values =~ m/$v/i ) { + $result = 1; + } + else { + $result = 0; + } + } + elsif ( $k eq 'key' ) { + if ( $v =~ m/,/ ) { + $result = 0; + foreach ( split( /,/, $v ) ) { + if ( $feature + ->primary_tag + eq $_ ) + { + $result = 1; + } + } + } + else { + $result = + $feature->primary_tag eq $v; + } + } + elsif ( $k eq 'tag' ) { + if ( $v =~ m/([^=]+)=(.*)/ ) { + my ( $tag_name, $tag_match ) = + ( $1, $2 ); + if ( $feature->has_tag($1) ) { + if ( + join( + '', + $feature + ->get_tag_values + ( + $1 + ) + ) =~ /$2/i + ) + { + $result = 1; + } + else { + $result = 0; + } + } + else { + $result = 0; + } + } + else { + $result = $feature->has_tag($v); + } + } + else { + + #error + $result = 0; + } + return ( $negate xor $result ); + } + else { + + #error + return 0; + } + + #error + return 0; + }; + } +} + +sub filterFeatues { + my ($self) = @_; + + #$self->{'wanted_tags'} = map { $_ => 1 } split(/,/,$self->{'q'}); + my %tags = map { $_ => 1 } split( /,/, "tRNA,CDS" ); + $self->wanted_tags( \%tags ); + my @feats = @{ $self->features() }; + for my $feat_object (@feats) { + my $should_add = 1; + if ( $feat_object->primary_tag eq 'source' ) { + $should_add = 0; + } + if ( $feat_object->primary_tag eq 'gene' ) { + $should_add = 0; + } + if ( defined $self->start() + && $feat_object->start < $self->start() ) + { + $should_add = 0; + } + if ( defined $self->end() + && $feat_object->end > $self->end() ) + { + $should_add = 0; + } + if ($should_add) { + $self->addGene($feat_object); + } + } +} + +sub addGene { + my ( $self, $feat_object ) = @_; + my $tag = $feat_object->primary_tag; + my $label = ""; + if ( $self->label() ) { + +#If it meets the criteria specified for labelling an object, set the label, else don't set a label + if ( $self->label_from() eq 'custom' ) { + if ( $parser->solve( $tree, $cb, $feat_object ) ) { + if ( + $feat_object->has_tag( + $self->label_text_source() + ) + ) + { + $label = join( + ' ', + $feat_object->get_tag_values( + $self + ->label_text_source( + ) + ) + ); + } + else { + $label = '[]'; + } + } + +#if($feat_object->has_tag($self->label_text_source())){ +#$label = ' '.join(' ', $feat_object->get_tag_values($self->label_text_source())); +#} + } + elsif ( $self->label_from() eq 'numeric' ) { + if ( ${ $self->wanted_tags() }{$tag} ) { + $label = $self->label_numbering_count(); + $self->label_numbering_count( + $self->label_numbering_count() + 1 ); + } + } + else { + die $self->label_from(); + } + } + my @color_arr; + my $color; + if ( $feat_object->has_tag('color') ) { + push( @color_arr, $feat_object->get_tag_values('color') ); + } + if ( $feat_object->has_tag('color') ) { + push( @color_arr, $feat_object->get_tag_values('color') ); + } + if ( scalar @color_arr ) { + $color = $color_arr[0]; + } + + my $gene = CPT::Plot::Gene->new( + 'tag' => $tag, + 'label' => $label, + 'start' => $feat_object->start, + 'end' => $feat_object->end, + 'strand' => $feat_object->strand, + 'color' => $color, + ); + +#This is a "failsafe" addition of classes, in case the user didn't specify a color + if ( !defined ${ $self->classes() }{$tag} ) { + ${ $self->classes() }{$tag} = CPT::Plot::Class->new( + 'key' => $tag, + 'color' => '#000000', + 'border' => 1, + 'plot' => 1, + 'included' => 1, + ); + } + else { + ${ $self->classes() }{$tag}->addObject($gene); + } +} + +sub partitionLines { + my ($self) = @_; + +# To use when I finally get partitioning.pm working +#sub partitionLines{ +# my ($self) = @_; +# +# my $partioner = Partitioning->new( +# genome_length => $self->genome_length(), +# rows => $self->rows(), +# justified => $self->justified(), +# ); +# +# # Add data to it +# foreach(keys %classes){ +# if($classes{$_}->isIncludedInPartioning()){ +# $partioner->add($classes{$_}->getItemList()); +# } +# } +# # Run && get Results +# my %result = %{$partioner->run()}; +# # . . . +# print Dupmer %results; +# # Profit +# exit 1; +# # This is supposed to merge two hashes. [http://perldoc.perl.org/perlfaq4.html#How-do-I-merge-two-hashes%3f] +# @self{keys %result} = values %result; + + my @items; + + $self->avgRowLength( + int( + $self->genome_length() / + $self->rows() * + $self->split_factor() + ) + ) + ; #TODO, allow adjusting or just re-calc? need to benchmark first I guess. + $self->calc_height( int( ( 1 + $self->rows() ) * $self->ils() ) ); + + if ( $self->width_mode() eq 'dynamic' ) { + $self->calc_width( + int( $self->avgRowLength() / $self->width_value() ) ); + } + else { + $self->calc_width( $self->width_value() ); + } + + my $fake_count = 100; + if ($fake_count) { + for ( my $i = 0 ; $i <= $fake_count ; $i++ ) { + my $key = + int( $self->genome_length() * $i / $fake_count ); + push( @items, [ $key, $key, 1 ] ); + } + } + + my %classes = %{ $self->classes() }; + foreach ( keys %classes ) { + if ( $classes{$_}->included() ) { + push( @items, @{ $classes{$_}->getItemList() } ); + } + } + + #Sort based on where each item starts + @items = sort { ${$a}[0] <=> ${$b}[0] } @items; + + #my $z = '(' . join('),(',map { "${$_}[0],${$_}[1]" } @items ) . ')'; + #print join("\n",split(/(.{1,120})/msxog, $z)) . "\n"; + my %rowdata; + + my ( $longest_last_object, $thisRowEnd, $currentRow ) = + ( 1, 1 + $self->avgRowLength(), 1 ); + $rowdata{1}{start} = 1; + foreach my $item_ref (@items) { + my ( $item_start, $item_end ) = @{$item_ref}; + + #print "\t$item_start\t$item_end\t$thisRowEnd\n"; + if ( $item_start >= $thisRowEnd || $item_end > $thisRowEnd ) { + + # This was just cleaned up from the following commented out piece of code + if ( $self->justified() eq 'justify' + || $item_start >= $rowdata{$currentRow}{end} ) + { + $rowdata{$currentRow}{end} = $thisRowEnd; + } + else { + $rowdata{$currentRow}{end} = + max( $longest_last_object, $item_start ); + } + + # There was a corner case here: + # O represents the end of a gene, + # --- represents a gene + # | represents $thisRowEnd + # + # + # ------O | O--------- + # In this case, the second end would be chosen as + # max($longest_last_object,$item_start), which is NOT what we + # want. You want | to be chosen, not O, so in the case that + # item_start is >= current row end (or should that be >?), we + # use this. + # + # ------O | + # O--+-------- + # This case works fine + # + # + # ------O | + # O--------+-------- + # This case also works fine + # + # + # if($self->justified()){ + # $rowdata{$currentRow}end() = $thisRowEnd; + # }else{ + # if($item_start <= $rowdata{$currentRow}end()){ + # $rowdata{$currentRow}end() = max($longest_last_object,$item_start); + # }else{ + # $rowdata{$currentRow}end() = $thisRowEnd; + # } + # } + $self->_internal_maxrowlength( + max( + $self->_internal_maxrowlength(), + $rowdata{$currentRow}{end} - + $rowdata{$currentRow}{start} + ) + ); + $currentRow++; + + #print "$item_start $rowdata{$currentRow-1}{end}\n"; + if ( $item_start <= $rowdata{ $currentRow - 1 }{end} ) { + $rowdata{$currentRow}{start} = $item_start; + } + else { #nonjustified never encounters the following line + $rowdata{$currentRow}{start} = + $rowdata{ $currentRow - 1 }{end} + 1; + } + $thisRowEnd = + $self->avgRowLength() + $rowdata{$currentRow}{start}; + } + } + +# if($self->justified()){ +# foreach my $item_ref(@items){ +# my ($item_start, $item_end) = @{$item_ref}; +# # If the item starts OR ends after this row is supposed to end +# # print "\t$item_start\t$item_end\t$thisrowend\n"; +# if($item_start >= $thisRowEnd || $item_end > $thisRowEnd){ +# $rowdata{$currentRow}end() = $thisRowEnd; +# #Internal max row length is the length of the longest row +# $self->_internal_maxrowlength'} = max($self->{'_internal_maxrowlength'},$rowdata{$currentRow}{'end'}-$rowdata{$currentRow}{'start()); +# #Update which row we're on (so we aren't using +1s everywhere) +# $currentRow++; +# if($item_start <= $rowdata{$currentRow-1}end()){ +# $rowdata{$currentRow}start() = $item_start; +# }else{ +# $rowdata{$currentRow}start'} = $rowdata{$currentRow-1}{'end() + 1; +# } +# #tracks where the current row ends +# #print Dumper $rowdata; +# #print ">>$thisRowEnd\t".$self->avgRowLength'}." + ".$rowdata{$currentRow}{'start()."\n"; +# $thisRowEnd = $self->avgRowLength'} + $rowdata{$currentRow}{'start(); +# #print ">>$thisRowEnd\t".$self->avgRowLength'}." + ".$rowdata{$currentRow}{'start()."\n"; +# } +# } +# }else{#Non justified, raggedright +# foreach my $item_ref(@items){ +# my ($item_start, $item_end) = @{$item_ref}; +# #print "\t$item_start\t$item_end\t$thisrowend\n"; +# if($item_start >= $thisRowEnd || $item_end > $thisRowEnd){ +## print "\t> $item_start\t$item_end\t$thisRowEnd\n"; +## print "Candidate for ending [" . ($item_start >= $thisRowEnd) ."]\t[" .($item_end >= $thisRowEnd) . "]\n"; +## # If we have ``justified'' rulers, they all need to the be the SAME length (until the last) +## print " -- $rowdata{$currentRow}end()$thisRowEnd\n"; +# $rowdata{$currentRow}end() = max($longest_last_object,$item_start); +# #Internal max row length is the length of the longest row +# $self->_internal_maxrowlength'} = max($self->{'_internal_maxrowlength'},$rowdata{$currentRow}{'end'}-$rowdata{$currentRow}{'start()); +# #Update which row we're on (so we aren't using +1s everywhere) +# $currentRow++; +# #if($item_start <= $rowdata{$currentRow-1}end()){ +# $rowdata{$currentRow}start() = $item_start; +# #} +# #tracks where the current row ends +# $thisRowEnd = $self->avgRowLength'} + $rowdata{$currentRow}{'start(); +# } +# $longest_last_object = max($longest_last_object,$item_end); +# } +# } +#make sure the final row length is set, in addition to the _int_max_rowlength + $thisRowEnd = $rowdata{$currentRow}{end} = + $self->genome_length() + 1; #Putative + $self->_internal_maxrowlength( + max( + $self->_internal_maxrowlength(), + $rowdata{$currentRow}{end} - + $rowdata{$currentRow}{start} + ) + ); + $rowdata{max} = $currentRow; + + if ( defined $self->{start} && defined $self->{end} ) { + %rowdata = ( + '1' => + { 'end' => $self->{end}, 'start' => $self->{start} }, + 'max' => 1, + ); + } + + $self->rowdata( \%rowdata ); + +} + +sub getSVG { + my ($self) = @_; + return $self->svg(); +} + +# SVG +sub createSVG { + my ($self) = @_; + my %rowdata = %{ $self->rowdata() }; + $self->calc_height( int( ( 1 + $rowdata{max} ) * $self->ils() ) ); + if ( $self->width_mode() eq 'dynamic' ) { + $self->calc_width( + int( $self->avgRowLength() / $self->width_value() ) ); + } + else { + $self->calc_width( $self->width_value() ); + } + + $self->svg( + SVG->new( + width => $self->calc_width() + 2 * $self->x_offset(), + height => $self->calc_height() + 2 * $self->y_offset(), + ) + ); + +#$self->svg()->title( id => 'documenfeatures from t-title' )->cdata("Genome Map of [$file_name]"); + + my $ui_group = $self->svg()->tag( + 'g', + id => 'group_ui', + style => { + stroke => '#000000', + fill => '#000000', + 'fill-opacity' => 1, + } + ); + + foreach ( my $i = 1 ; $i <= $rowdata{max} ; $i++ ) { + $self->_addRuler( $i, $ui_group ); + } + + my %classes = %{ $self->classes() }; + foreach my $class_key ( keys %classes ) { + + #print "Adding features from $class_key\n"; + my $class = $classes{$class_key}; + if ( !$class->plot() ) { + next; + } + my $group = $self->svg()->tag( + 'g', + id => 'group_' . $class->key(), + style => { + stroke => ( + $class->plot() + ? ( + $class->border() + ? "black" + : "none" + ) + : 'none' + ), + fill => $class->color(), + 'fill-opacity' => $self->opacity(), + } + ); + my @data = @{ $class->getObjects() }; + foreach my $gene (@data) { + my ( $start, $end ) = + ( $gene->start(), $gene->end() ); + my $row = calculateRow( $self, $start, $end ); + addFeature( + $self, + group => $group, + row => $row, + start => $start, + end => $end, + key => $gene->tag(), + strand => $gene->strand(), + label => $gene->label(), + ui_group => $ui_group, + color => $gene->color(), + ); + + } + } + +} + +sub calculateRow { + my ( $self, $start, $end ) = @_; + my %rowdata = %{ $self->rowdata() }; + for ( my $i = 1 ; $i <= $rowdata{max} ; $i++ ) { + if ( + $start > $rowdata{$i}{start} - 1 + && $start < $rowdata{$i}{end} + 1 + && $end > $rowdata{$i}{start} - 1 + && $end < $rowdata{$i}{end} + 1 + + ) + { + return $i; + } + } + +#print "<b>$start,$end,".$self->rowdata'}{$i}{'start'}.",".$self->{'rowdata'}{$i}{'end()."<\/b>\n"; + return 1.5; +} + +sub _addRuler { + my ( $self, $row, $ui_group ) = @_; + my $y_fix = $self->ils() * ( $row - 1 ); + + # my @d = ( + # $self->calc_width(), + # $self->rowdata'}{$row}{'end(), + # $self->rowdata'}{$row}{'start(), + # ($self->rowdata'}{$row}{'end'}-$self->{'rowdata'}{$row}{'start()), + # $self->_internal_maxrowlength(), + # ); + # print join("\t",@d),"\n"; + my %rowdata = %{ $self->rowdata() }; + my $line_width = + $self->calc_width() * + ( $rowdata{$row}{end} - $rowdata{$row}{start} ) / + $self->_internal_maxrowlength(); + +#print "Adding ruler\t".$self->rowdata'}{$row}{'start'}."\t".$self->{'rowdata'}{$row}{'end'}."\t" . ($self->{'rowdata'}{$row}{'end'} - $self->{'rowdata'}{$row}{'start()) . "\n"; + + $ui_group->line( + id => 'ui_element_' . ( $self->line_count() + rand() ), + x1 => 0 + $self->x_offset(), + x2 => $line_width + $self->x_offset(), + y1 => $y_fix + $self->y_offset(), + y2 => $y_fix + $self->y_offset() + ); + + # print "Ruler is being plotted from $y_fix to $line_width\n"; + if ( $self->separate_strands() ) { + + #$ui_group->rectangle( + #id => 'ui_element_' . ( $self->line_count() + rand() ) . "_" . rand(1), + #x => 0 + $self->x_offset(), + #y => $y_fix - 2.5 + $self->y_offset(), + #width => $line_width, + #height => 5 + #); + + #$y_fix += 100; + } + + if ( $self->double_line_for_overlap() && $row > 1 ) + { #This shows any duplicated part of the scale + if ( $rowdata{ $row - 1 }{end} - $rowdata{$row}{start} >= 0 ) + { #Equal to zero indicates ONE base of overlap + $ui_group->line( + id => 'ui_element_' + . ( $self->line_count() + rand() ), + y1 => $y_fix - 5 + $self->y_offset(), + y2 => $y_fix - 5 + $self->y_offset(), + x1 => 0 + $self->x_offset(), + x2 => $self->calc_width() * ( + $rowdata{ $row - 1 }{end} - + $rowdata{$row}{start} + ) / $self->_internal_maxrowlength() + + $self->x_offset(), + +#$calc_width*($rowdata{$row-1}end'}-$rowdata{$row}{'start'})/$self->{'_internal_maxrowlength'} + $self->{'x_offset(), + ); + } + } + $ui_group->line( + id => 'ui_element_' . ( $self->line_count() + rand() ), + x1 => 0 + $self->x_offset(), + x2 => $line_width + $self->x_offset(), + y1 => $y_fix + $self->y_offset(), + y2 => $y_fix + $self->y_offset() + ); + foreach ( $rowdata{$row}{start} - 1 .. $rowdata{$row}{end} ) { + if ( $_ % 1000 == 0 && $_ % 10000 != 0 ) { + my $current_location = + $self->calc_width() * + ( $_ - $rowdata{$row}{start} ) / + $self->_internal_maxrowlength(); + $ui_group->line( + id => 'ui_element_' + . ( $self->line_count() + rand() ), + x1 => $current_location + $self->x_offset(), + x2 => $current_location + $self->x_offset(), + y1 => $y_fix + $self->y_offset(), + y2 => $y_fix + 5 + $self->y_offset(), + ); + } + if ( $_ % 10000 == 0 ) { + my $current_location = + $self->calc_width() * + ( $_ - $rowdata{$row}{start} ) / + $self->_internal_maxrowlength(); + $ui_group->line( + id => 'ui_element_' + . ( $self->line_count() + rand() ), + x1 => $current_location + $self->x_offset(), + x2 => $current_location + $self->x_offset(), + y1 => $y_fix + $self->y_offset(), + y2 => $y_fix + 10 + $self->y_offset(), + ); + $ui_group->text( + id => 'ui_text' + . ( $self->line_count() + rand() ), + x => $current_location + 10 + $self->x_offset(), + y => $y_fix + 20 + $self->y_offset(), + -cdata => ( $_ / 1000 ) . " kb", + 'fill' => '#000000', + 'fill-opacity' => 1, + 'font-family' => 'mono', + 'stroke' => 'none' + ); + } + + if ( + ( + $_ == $rowdata{$row}{start} - 1 + || $_ == $rowdata{$row}{end} + ) + && ( $_ % 10000 != 0 ) + ) + { + my $current_location = + $self->calc_width() * + ( $_ - $rowdata{$row}{start} ) / + $self->_internal_maxrowlength(); + $ui_group->line( + id => 'ui_element_' + . ( $self->line_count() + rand() ), + x1 => $current_location + $self->x_offset(), + x2 => $current_location + $self->x_offset(), + y1 => $y_fix + $self->y_offset(), + y2 => $y_fix + 10 + $self->y_offset(), + ); + $ui_group->text( + id => 'ui_text' + . ( $self->line_count() + rand() ), + x => $current_location + $self->x_offset(), + y => $y_fix + 20 + $self->y_offset(), + -cdata => sprintf( '%d kb', ( $_ / 1000 ) ), + 'fill' => '#000000', + 'fill-opacity' => 1, + 'font-family' => 'mono', + 'stroke' => 'none' + ); + } + } +} + +sub addFeature { + my ( $self, %data ) = @_; + my %rowdata = %{ $self->rowdata() }; + my $x = + $self->calc_width() * + ( $data{'start'} - $rowdata{ $data{'row'} }{'start'} ) / + $self->_internal_maxrowlength() + $self->x_offset(); + my $w = + $self->calc_width() * + ( $data{'end'} - $data{'start'} ) / + $self->_internal_maxrowlength(); + my $h = 15; + my $y = + ( $data{'row'} - 1 ) * $self->ils() + $self->y_offset() - $h / 2; + + my $id = "$x$y$w$h" . rand(); + +#print "Item(".$data{'start'}.",".$data{'end'}.",".$data{'row'}.") =\t($x,$y,$w,$h)\n"; + + if ( $self->separate_strands() ) { + $y += -$data{'strand'} * 30; + } + + if ( $self->view() eq 'alt_random' ) { # Max add = 20 + $y += 4 * ( $x % 5 ); + } + elsif ( $self->view() eq 'alt_every' ) { # Max add = 10 + # We (Sort of like a convolution?) multiply by strand This has + # the following effect; when on the top strand, we will only + # ever add a positive to the height of the item (moving it + # downward and closer to the ruler). On the bottom strand + # however, we only ever add a negative to the height of the + # item (moving it upwards towards the ruler). This allows the + # items on the top and bottom to stay balanced. + $y += + $data{'strand'} * 10 * + ( ( $self->_ft_count( $self->_ft_count() + 1 ) ) % 2 ) - + 10 * $data{'strand'}; + + # However, This is imperfect, since we add items based on class, + # not from left to right + } + elsif ( $self->view() eq 'alt_artemis' ) { # Max add = 20? + # Muwahahahaha. Sorry. Determined coefficient and constant by + # trial and error, but this matches up with the artemis view + # without an if/else based on which strand. :D + $y += + 10 * ( ( $data{'start'} - 2 * $data{'strand'} + 1 ) % 3 ) - + 10 * $data{'strand'}; + } + + my $item_color = $color_spec->getColour( $data{'color'} ); + if ($item_color) { + $data{'group'}->rectangle( + x => ($x), + y => $y, + width => $w, + height => $h, + id => $id, + fill => $color_spec->getColour( $data{'color'} ) + ); + } + else { + $data{'group'}->rectangle( + x => ($x), + y => $y, + width => $w, + height => $h, + id => $id, + ); + } + if ( $self->label() && $data{'label'} ) { + + my ( $lx, $ly ); + my @char_data = split( //, $data{label} ); + + #Exit early if we don't even want to plot. + my $is_too_small = ( scalar(@char_data) * 2 > $w ); + if ( $self->label_shrink_mode() eq 'cutoff' && $is_too_small ) { + return; + } + + #Font Scaling + my $font_scaling = 100; + if ( $self->label_shrink_mode() eq 'shrink' ) { + $font_scaling *= $w / ( 8 * scalar(@char_data) ); + } + + # Horizontal positioning + $lx = + $x + + $w / 2 + ; #Horizontally center it, but this is by the leading edge of the text + if ( scalar(@char_data) * 8 > $w + && $self->label_shrink_mode() eq 'shrink' ) + { + $lx -= + scalar(@char_data) * 4 * + $font_scaling / 100 + ; #Adjustment for scaled text. Determined by experiment + } + else { + $lx -= + scalar(@char_data) * 4 + ; #Move four pixels left for every character in the label + } + + # Vertical positioning + if ( $self->label_pos() eq "above" ) { #Label is ABOVE + if ( $self->separate_strands() + && $data{'strand'} == -1 ) + { + $ly = + $y + + $h / 2 + 10 + 30 + ; #Need to consider below strand, only one strand. + } + else { + $ly = + $y + + $h / 2 - 30 + ; #Need to consider below strand, only one strand. + } + } + else { #Label is ON + $ly = $y + $h / 2 + 5; + } + + if ( $data{'label'} !~ /^gene_[0-9]+$/ ){ + $self->plot_label( $lx, $ly, $font_scaling, $data{'label'}, + $data{'ui_group'} ); + + if ( $self->label_callouts() + && $self->label_pos() eq "above" ) + { + $data{'ui_group'}->line( + id => 'l' . "_" . rand(1), + x1 => $x + ( $w / 2 ), + x2 => $x + ( $w / 2 ), + y1 => ( + $self->separate_strands() + && $data{'strand'} eq '-1' ? $y + $h + : $y + ), + y2 => ( + $self->separate_strands() + && $data{'strand'} eq '-1' ? $ly - 12 + : $ly + ) + ); + } + } + + } +} + +sub plot_label { + my ( $self, $x, $y, $font_size, $label, $ui_group ) = @_; + if ( $font_size < 80 ) { + $font_size = 80; + } + $ui_group->text( + id => 'text' . rand(1), + x => $x, + y => $y, + -cdata => $label, + 'fill' => '#000000', + 'fill-opacity' => 1, + 'font-family' => 'mono', + 'font-size' => $font_size . '%', + 'stroke' => 'none' + ); +} + +sub max ($$) { $_[ $_[0] < $_[1] ] } +sub min ($$) { $_[ $_[0] > $_[1] ] } + +no Moose; +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +CPT::Plot::Base - Main plotting class for genome mapper + +=head1 VERSION + +version 1.96 + +=head1 AUTHOR + +Eric Rasche <rasche.eric@yandex.ru> + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2014 by Eric Rasche. + +This is free software, licensed under: + + The GNU General Public License, Version 3, June 2007 + +=cut