comparison 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
comparison
equal deleted inserted replaced
0:54c7a3ea81e2 1:8691c1c61a8e
1 package CPT::Plot::Base;
2 use Data::Dumper;
3 use CPT::Plot::Label;
4 use CPT::Plot::Class;
5 use CPT::Plot::Gene;
6 use CPT::Plot::Colours;
7 use Bio::SeqIO;
8 use SVG;
9 use Moose;
10
11 # ABSTRACT: Main plotting class for genome mapper
12
13 has 'svg' => ( is => 'rw', isa => 'Any' );
14 has 'line_count' => ( is => 'rw', isa => 'Num', default => 1 );
15 has '_ft_count' => ( is => 'rw', isa => 'Num', default => 0 );
16 has 'classes' => ( is => 'rw', isa => 'HashRef' );
17
18 # Labels
19 has 'label' => ( is => 'rw', isa => 'Bool' );
20
21 has 'label_pos' => ( is => 'rw', isa => 'Any' );
22 has 'label_shrink_mode' => ( is => 'rw', isa => 'Any' );
23 has 'label_callouts' => ( is => 'rw', isa => 'Any' );
24 has 'label_from' => ( is => 'rw', isa => 'Any' );
25 has 'label_text_source' => ( is => 'rw', isa => 'Any' );
26 has 'label_numeric_features' => ( is => 'rw', isa => 'Any' );
27 has 'label_query' => ( is => 'rw', isa => 'Any' );
28 has 'label_numbering_count' => ( is => 'rw', isa => 'Any', default => 1 );
29
30 has 'justified' => ( is => 'rw', isa => 'Str' );
31
32 # CHanged to any b/c unpassed = undef
33 has 'separate_strands' => ( is => 'rw', isa => 'Any' );
34 has 'double_line_for_overlap' => ( is => 'rw', isa => 'Any' );
35 has 'opacity' => ( is => 'rw', isa => 'Str' );
36 has 'view' => ( is => 'rw', isa => 'Str' );
37
38 has 'color_scheme' => ( is => 'rw', isa => 'HashRef' );
39 has 'wanted_tags' => ( is => 'rw', isa => 'HashRef' );
40 has 'genome_length' => ( is => 'rw', isa => 'Int' );
41 has 'features' => ( is => 'rw', isa => 'ArrayRef' );
42 has 'start' => ( is => 'rw', isa => 'Int' );
43 has 'end' => ( is => 'rw', isa => 'Int' );
44
45 has 'avgRowLength' => ( is => 'rw', isa => 'Int' );
46 has 'calc_height' => ( is => 'rw', isa => 'Int' );
47 has 'calc_width' => ( is => 'rw', isa => 'Int' );
48 has 'x_offset' => ( is => 'rw', isa => 'Num' );
49 has 'y_offset' => ( is => 'rw', isa => 'Num' );
50 has 'ils' => ( is => 'rw', isa => 'Num' );
51 has 'width_mode' => ( is => 'rw', isa => 'Str' );
52 has 'width_value' => ( is => 'rw', isa => 'Num' );
53 has 'rows' => ( is => 'rw', isa => 'Num' );
54 has 'split_factor' => ( is => 'rw', isa => 'Num' );
55
56 has 'rowdata' => ( is => 'rw', isa => 'HashRef' );
57 has '_internal_maxrowlength' => ( is => 'rw', isa => 'Num' );
58
59 my $color_spec = CPT::Plot::Colours->new( 'default' => '#000000' );
60 our ( $parser, $tree, $cb );
61
62 sub init {
63 my ($self) = @_;
64 my %classes;
65 my %cs = %{ $self->color_scheme() };
66 foreach my $key ( keys %cs ) {
67 $classes{$key} = CPT::Plot::Class->new(
68 'key' => $key,
69 'color' => $cs{$key}{color},
70 'border' => $cs{$key}{border},
71 'plot' => $cs{$key}{plot},
72 'included' => 1,
73 );
74 }
75 $self->classes( \%classes );
76 $self->init_label_stuff();
77 $self->filterFeatues();
78 }
79
80 sub init_label_stuff {
81 my ($self) = @_;
82
83 if ( $self->{'label_from'} eq 'custom' ) {
84 use Parse::BooleanLogic;
85 $parser = new Parse::BooleanLogic( operators => [ '', 'OR' ] );
86 $tree = $parser->as_array( $self->label_query );
87 print $parser;
88
89 #foreach bio feature,
90 #if solve == 1, then add to our return,
91 #else doesn't match
92 #endforeach
93 #my $new_tree = $parser->solve($tree,$filter);
94 $cb = sub {
95 my $query = $_[0]->{'operand'};
96 my $feature = $_[1];
97
98 my $negate = 0;
99 if ( substr( $query, 0, 1 ) eq '!' ) { #negate
100 $negate = 1;
101 $query = substr( $query, 1 );
102 }
103 if ( $query =~ m/([^:]+):["']{0,1}([^'"]*)["']{0,1}/ ) {
104 my ( $k, $v ) = ( $1, $2 );
105 my $result;
106 if ( $k eq 'contains' ) {
107 my $values = join(
108 "\t",
109 map {
110 if ( $_ ne
111 "translation" )
112 {
113 join(
114 '',
115 $feature
116 ->get_tag_values
117 (
118 $_
119 )
120 );
121 }
122 } $feature->get_all_tags()
123 );
124 if ( $values =~ m/$v/i ) {
125 $result = 1;
126 }
127 else {
128 $result = 0;
129 }
130 }
131 elsif ( $k eq 'key' ) {
132 if ( $v =~ m/,/ ) {
133 $result = 0;
134 foreach ( split( /,/, $v ) ) {
135 if ( $feature
136 ->primary_tag
137 eq $_ )
138 {
139 $result = 1;
140 }
141 }
142 }
143 else {
144 $result =
145 $feature->primary_tag eq $v;
146 }
147 }
148 elsif ( $k eq 'tag' ) {
149 if ( $v =~ m/([^=]+)=(.*)/ ) {
150 my ( $tag_name, $tag_match ) =
151 ( $1, $2 );
152 if ( $feature->has_tag($1) ) {
153 if (
154 join(
155 '',
156 $feature
157 ->get_tag_values
158 (
159 $1
160 )
161 ) =~ /$2/i
162 )
163 {
164 $result = 1;
165 }
166 else {
167 $result = 0;
168 }
169 }
170 else {
171 $result = 0;
172 }
173 }
174 else {
175 $result = $feature->has_tag($v);
176 }
177 }
178 else {
179
180 #error
181 $result = 0;
182 }
183 return ( $negate xor $result );
184 }
185 else {
186
187 #error
188 return 0;
189 }
190
191 #error
192 return 0;
193 };
194 }
195 }
196
197 sub filterFeatues {
198 my ($self) = @_;
199
200 #$self->{'wanted_tags'} = map { $_ => 1 } split(/,/,$self->{'q'});
201 my %tags = map { $_ => 1 } split( /,/, "tRNA,CDS" );
202 $self->wanted_tags( \%tags );
203 my @feats = @{ $self->features() };
204 for my $feat_object (@feats) {
205 my $should_add = 1;
206 if ( $feat_object->primary_tag eq 'source' ) {
207 $should_add = 0;
208 }
209 if ( $feat_object->primary_tag eq 'gene' ) {
210 $should_add = 0;
211 }
212 if ( defined $self->start()
213 && $feat_object->start < $self->start() )
214 {
215 $should_add = 0;
216 }
217 if ( defined $self->end()
218 && $feat_object->end > $self->end() )
219 {
220 $should_add = 0;
221 }
222 if ($should_add) {
223 $self->addGene($feat_object);
224 }
225 }
226 }
227
228 sub addGene {
229 my ( $self, $feat_object ) = @_;
230 my $tag = $feat_object->primary_tag;
231 my $label = "";
232 if ( $self->label() ) {
233
234 #If it meets the criteria specified for labelling an object, set the label, else don't set a label
235 if ( $self->label_from() eq 'custom' ) {
236 if ( $parser->solve( $tree, $cb, $feat_object ) ) {
237 if (
238 $feat_object->has_tag(
239 $self->label_text_source()
240 )
241 )
242 {
243 $label = join(
244 ' ',
245 $feat_object->get_tag_values(
246 $self
247 ->label_text_source(
248 )
249 )
250 );
251 }
252 else {
253 $label = '[]';
254 }
255 }
256
257 #if($feat_object->has_tag($self->label_text_source())){
258 #$label = ' '.join(' ', $feat_object->get_tag_values($self->label_text_source()));
259 #}
260 }
261 elsif ( $self->label_from() eq 'numeric' ) {
262 if ( ${ $self->wanted_tags() }{$tag} ) {
263 $label = $self->label_numbering_count();
264 $self->label_numbering_count(
265 $self->label_numbering_count() + 1 );
266 }
267 }
268 else {
269 die $self->label_from();
270 }
271 }
272 my @color_arr;
273 my $color;
274 if ( $feat_object->has_tag('color') ) {
275 push( @color_arr, $feat_object->get_tag_values('color') );
276 }
277 if ( $feat_object->has_tag('color') ) {
278 push( @color_arr, $feat_object->get_tag_values('color') );
279 }
280 if ( scalar @color_arr ) {
281 $color = $color_arr[0];
282 }
283
284 my $gene = CPT::Plot::Gene->new(
285 'tag' => $tag,
286 'label' => $label,
287 'start' => $feat_object->start,
288 'end' => $feat_object->end,
289 'strand' => $feat_object->strand,
290 'color' => $color,
291 );
292
293 #This is a "failsafe" addition of classes, in case the user didn't specify a color
294 if ( !defined ${ $self->classes() }{$tag} ) {
295 ${ $self->classes() }{$tag} = CPT::Plot::Class->new(
296 'key' => $tag,
297 'color' => '#000000',
298 'border' => 1,
299 'plot' => 1,
300 'included' => 1,
301 );
302 }
303 else {
304 ${ $self->classes() }{$tag}->addObject($gene);
305 }
306 }
307
308 sub partitionLines {
309 my ($self) = @_;
310
311 # To use when I finally get partitioning.pm working
312 #sub partitionLines{
313 # my ($self) = @_;
314 #
315 # my $partioner = Partitioning->new(
316 # genome_length => $self->genome_length(),
317 # rows => $self->rows(),
318 # justified => $self->justified(),
319 # );
320 #
321 # # Add data to it
322 # foreach(keys %classes){
323 # if($classes{$_}->isIncludedInPartioning()){
324 # $partioner->add($classes{$_}->getItemList());
325 # }
326 # }
327 # # Run && get Results
328 # my %result = %{$partioner->run()};
329 # # . . .
330 # print Dupmer %results;
331 # # Profit
332 # exit 1;
333 # # This is supposed to merge two hashes. [http://perldoc.perl.org/perlfaq4.html#How-do-I-merge-two-hashes%3f]
334 # @self{keys %result} = values %result;
335
336 my @items;
337
338 $self->avgRowLength(
339 int(
340 $self->genome_length() /
341 $self->rows() *
342 $self->split_factor()
343 )
344 )
345 ; #TODO, allow adjusting or just re-calc? need to benchmark first I guess.
346 $self->calc_height( int( ( 1 + $self->rows() ) * $self->ils() ) );
347
348 if ( $self->width_mode() eq 'dynamic' ) {
349 $self->calc_width(
350 int( $self->avgRowLength() / $self->width_value() ) );
351 }
352 else {
353 $self->calc_width( $self->width_value() );
354 }
355
356 my $fake_count = 100;
357 if ($fake_count) {
358 for ( my $i = 0 ; $i <= $fake_count ; $i++ ) {
359 my $key =
360 int( $self->genome_length() * $i / $fake_count );
361 push( @items, [ $key, $key, 1 ] );
362 }
363 }
364
365 my %classes = %{ $self->classes() };
366 foreach ( keys %classes ) {
367 if ( $classes{$_}->included() ) {
368 push( @items, @{ $classes{$_}->getItemList() } );
369 }
370 }
371
372 #Sort based on where each item starts
373 @items = sort { ${$a}[0] <=> ${$b}[0] } @items;
374
375 #my $z = '(' . join('),(',map { "${$_}[0],${$_}[1]" } @items ) . ')';
376 #print join("\n",split(/(.{1,120})/msxog, $z)) . "\n";
377 my %rowdata;
378
379 my ( $longest_last_object, $thisRowEnd, $currentRow ) =
380 ( 1, 1 + $self->avgRowLength(), 1 );
381 $rowdata{1}{start} = 1;
382 foreach my $item_ref (@items) {
383 my ( $item_start, $item_end ) = @{$item_ref};
384
385 #print "\t$item_start\t$item_end\t$thisRowEnd\n";
386 if ( $item_start >= $thisRowEnd || $item_end > $thisRowEnd ) {
387
388 # This was just cleaned up from the following commented out piece of code
389 if ( $self->justified() eq 'justify'
390 || $item_start >= $rowdata{$currentRow}{end} )
391 {
392 $rowdata{$currentRow}{end} = $thisRowEnd;
393 }
394 else {
395 $rowdata{$currentRow}{end} =
396 max( $longest_last_object, $item_start );
397 }
398
399 # There was a corner case here:
400 # O represents the end of a gene,
401 # --- represents a gene
402 # | represents $thisRowEnd
403 #
404 #
405 # ------O | O---------
406 # In this case, the second end would be chosen as
407 # max($longest_last_object,$item_start), which is NOT what we
408 # want. You want | to be chosen, not O, so in the case that
409 # item_start is >= current row end (or should that be >?), we
410 # use this.
411 #
412 # ------O |
413 # O--+--------
414 # This case works fine
415 #
416 #
417 # ------O |
418 # O--------+--------
419 # This case also works fine
420 #
421 #
422 # if($self->justified()){
423 # $rowdata{$currentRow}end() = $thisRowEnd;
424 # }else{
425 # if($item_start <= $rowdata{$currentRow}end()){
426 # $rowdata{$currentRow}end() = max($longest_last_object,$item_start);
427 # }else{
428 # $rowdata{$currentRow}end() = $thisRowEnd;
429 # }
430 # }
431 $self->_internal_maxrowlength(
432 max(
433 $self->_internal_maxrowlength(),
434 $rowdata{$currentRow}{end} -
435 $rowdata{$currentRow}{start}
436 )
437 );
438 $currentRow++;
439
440 #print "$item_start $rowdata{$currentRow-1}{end}\n";
441 if ( $item_start <= $rowdata{ $currentRow - 1 }{end} ) {
442 $rowdata{$currentRow}{start} = $item_start;
443 }
444 else { #nonjustified never encounters the following line
445 $rowdata{$currentRow}{start} =
446 $rowdata{ $currentRow - 1 }{end} + 1;
447 }
448 $thisRowEnd =
449 $self->avgRowLength() + $rowdata{$currentRow}{start};
450 }
451 }
452
453 # if($self->justified()){
454 # foreach my $item_ref(@items){
455 # my ($item_start, $item_end) = @{$item_ref};
456 # # If the item starts OR ends after this row is supposed to end
457 # # print "\t$item_start\t$item_end\t$thisrowend\n";
458 # if($item_start >= $thisRowEnd || $item_end > $thisRowEnd){
459 # $rowdata{$currentRow}end() = $thisRowEnd;
460 # #Internal max row length is the length of the longest row
461 # $self->_internal_maxrowlength'} = max($self->{'_internal_maxrowlength'},$rowdata{$currentRow}{'end'}-$rowdata{$currentRow}{'start());
462 # #Update which row we're on (so we aren't using +1s everywhere)
463 # $currentRow++;
464 # if($item_start <= $rowdata{$currentRow-1}end()){
465 # $rowdata{$currentRow}start() = $item_start;
466 # }else{
467 # $rowdata{$currentRow}start'} = $rowdata{$currentRow-1}{'end() + 1;
468 # }
469 # #tracks where the current row ends
470 # #print Dumper $rowdata;
471 # #print ">>$thisRowEnd\t".$self->avgRowLength'}." + ".$rowdata{$currentRow}{'start()."\n";
472 # $thisRowEnd = $self->avgRowLength'} + $rowdata{$currentRow}{'start();
473 # #print ">>$thisRowEnd\t".$self->avgRowLength'}." + ".$rowdata{$currentRow}{'start()."\n";
474 # }
475 # }
476 # }else{#Non justified, raggedright
477 # foreach my $item_ref(@items){
478 # my ($item_start, $item_end) = @{$item_ref};
479 # #print "\t$item_start\t$item_end\t$thisrowend\n";
480 # if($item_start >= $thisRowEnd || $item_end > $thisRowEnd){
481 ## print "\t> $item_start\t$item_end\t$thisRowEnd\n";
482 ## print "Candidate for ending [" . ($item_start >= $thisRowEnd) ."]\t[" .($item_end >= $thisRowEnd) . "]\n";
483 ## # If we have ``justified'' rulers, they all need to the be the SAME length (until the last)
484 ## print " -- $rowdata{$currentRow}end()$thisRowEnd\n";
485 # $rowdata{$currentRow}end() = max($longest_last_object,$item_start);
486 # #Internal max row length is the length of the longest row
487 # $self->_internal_maxrowlength'} = max($self->{'_internal_maxrowlength'},$rowdata{$currentRow}{'end'}-$rowdata{$currentRow}{'start());
488 # #Update which row we're on (so we aren't using +1s everywhere)
489 # $currentRow++;
490 # #if($item_start <= $rowdata{$currentRow-1}end()){
491 # $rowdata{$currentRow}start() = $item_start;
492 # #}
493 # #tracks where the current row ends
494 # $thisRowEnd = $self->avgRowLength'} + $rowdata{$currentRow}{'start();
495 # }
496 # $longest_last_object = max($longest_last_object,$item_end);
497 # }
498 # }
499 #make sure the final row length is set, in addition to the _int_max_rowlength
500 $thisRowEnd = $rowdata{$currentRow}{end} =
501 $self->genome_length() + 1; #Putative
502 $self->_internal_maxrowlength(
503 max(
504 $self->_internal_maxrowlength(),
505 $rowdata{$currentRow}{end} -
506 $rowdata{$currentRow}{start}
507 )
508 );
509 $rowdata{max} = $currentRow;
510
511 if ( defined $self->{start} && defined $self->{end} ) {
512 %rowdata = (
513 '1' =>
514 { 'end' => $self->{end}, 'start' => $self->{start} },
515 'max' => 1,
516 );
517 }
518
519 $self->rowdata( \%rowdata );
520
521 }
522
523 sub getSVG {
524 my ($self) = @_;
525 return $self->svg();
526 }
527
528 # SVG
529 sub createSVG {
530 my ($self) = @_;
531 my %rowdata = %{ $self->rowdata() };
532 $self->calc_height( int( ( 1 + $rowdata{max} ) * $self->ils() ) );
533 if ( $self->width_mode() eq 'dynamic' ) {
534 $self->calc_width(
535 int( $self->avgRowLength() / $self->width_value() ) );
536 }
537 else {
538 $self->calc_width( $self->width_value() );
539 }
540
541 $self->svg(
542 SVG->new(
543 width => $self->calc_width() + 2 * $self->x_offset(),
544 height => $self->calc_height() + 2 * $self->y_offset(),
545 )
546 );
547
548 #$self->svg()->title( id => 'documenfeatures from t-title' )->cdata("Genome Map of [$file_name]");
549
550 my $ui_group = $self->svg()->tag(
551 'g',
552 id => 'group_ui',
553 style => {
554 stroke => '#000000',
555 fill => '#000000',
556 'fill-opacity' => 1,
557 }
558 );
559
560 foreach ( my $i = 1 ; $i <= $rowdata{max} ; $i++ ) {
561 $self->_addRuler( $i, $ui_group );
562 }
563
564 my %classes = %{ $self->classes() };
565 foreach my $class_key ( keys %classes ) {
566
567 #print "Adding features from $class_key\n";
568 my $class = $classes{$class_key};
569 if ( !$class->plot() ) {
570 next;
571 }
572 my $group = $self->svg()->tag(
573 'g',
574 id => 'group_' . $class->key(),
575 style => {
576 stroke => (
577 $class->plot()
578 ? (
579 $class->border()
580 ? "black"
581 : "none"
582 )
583 : 'none'
584 ),
585 fill => $class->color(),
586 'fill-opacity' => $self->opacity(),
587 }
588 );
589 my @data = @{ $class->getObjects() };
590 foreach my $gene (@data) {
591 my ( $start, $end ) =
592 ( $gene->start(), $gene->end() );
593 my $row = calculateRow( $self, $start, $end );
594 addFeature(
595 $self,
596 group => $group,
597 row => $row,
598 start => $start,
599 end => $end,
600 key => $gene->tag(),
601 strand => $gene->strand(),
602 label => $gene->label(),
603 ui_group => $ui_group,
604 color => $gene->color(),
605 );
606
607 }
608 }
609
610 }
611
612 sub calculateRow {
613 my ( $self, $start, $end ) = @_;
614 my %rowdata = %{ $self->rowdata() };
615 for ( my $i = 1 ; $i <= $rowdata{max} ; $i++ ) {
616 if (
617 $start > $rowdata{$i}{start} - 1
618 && $start < $rowdata{$i}{end} + 1
619 && $end > $rowdata{$i}{start} - 1
620 && $end < $rowdata{$i}{end} + 1
621
622 )
623 {
624 return $i;
625 }
626 }
627
628 #print "<b>$start,$end,".$self->rowdata'}{$i}{'start'}.",".$self->{'rowdata'}{$i}{'end()."<\/b>\n";
629 return 1.5;
630 }
631
632 sub _addRuler {
633 my ( $self, $row, $ui_group ) = @_;
634 my $y_fix = $self->ils() * ( $row - 1 );
635
636 # my @d = (
637 # $self->calc_width(),
638 # $self->rowdata'}{$row}{'end(),
639 # $self->rowdata'}{$row}{'start(),
640 # ($self->rowdata'}{$row}{'end'}-$self->{'rowdata'}{$row}{'start()),
641 # $self->_internal_maxrowlength(),
642 # );
643 # print join("\t",@d),"\n";
644 my %rowdata = %{ $self->rowdata() };
645 my $line_width =
646 $self->calc_width() *
647 ( $rowdata{$row}{end} - $rowdata{$row}{start} ) /
648 $self->_internal_maxrowlength();
649
650 #print "Adding ruler\t".$self->rowdata'}{$row}{'start'}."\t".$self->{'rowdata'}{$row}{'end'}."\t" . ($self->{'rowdata'}{$row}{'end'} - $self->{'rowdata'}{$row}{'start()) . "\n";
651
652 $ui_group->line(
653 id => 'ui_element_' . ( $self->line_count() + rand() ),
654 x1 => 0 + $self->x_offset(),
655 x2 => $line_width + $self->x_offset(),
656 y1 => $y_fix + $self->y_offset(),
657 y2 => $y_fix + $self->y_offset()
658 );
659
660 # print "Ruler is being plotted from $y_fix to $line_width\n";
661 if ( $self->separate_strands() ) {
662
663 #$ui_group->rectangle(
664 #id => 'ui_element_' . ( $self->line_count() + rand() ) . "_" . rand(1),
665 #x => 0 + $self->x_offset(),
666 #y => $y_fix - 2.5 + $self->y_offset(),
667 #width => $line_width,
668 #height => 5
669 #);
670
671 #$y_fix += 100;
672 }
673
674 if ( $self->double_line_for_overlap() && $row > 1 )
675 { #This shows any duplicated part of the scale
676 if ( $rowdata{ $row - 1 }{end} - $rowdata{$row}{start} >= 0 )
677 { #Equal to zero indicates ONE base of overlap
678 $ui_group->line(
679 id => 'ui_element_'
680 . ( $self->line_count() + rand() ),
681 y1 => $y_fix - 5 + $self->y_offset(),
682 y2 => $y_fix - 5 + $self->y_offset(),
683 x1 => 0 + $self->x_offset(),
684 x2 => $self->calc_width() * (
685 $rowdata{ $row - 1 }{end} -
686 $rowdata{$row}{start}
687 ) / $self->_internal_maxrowlength() +
688 $self->x_offset(),
689
690 #$calc_width*($rowdata{$row-1}end'}-$rowdata{$row}{'start'})/$self->{'_internal_maxrowlength'} + $self->{'x_offset(),
691 );
692 }
693 }
694 $ui_group->line(
695 id => 'ui_element_' . ( $self->line_count() + rand() ),
696 x1 => 0 + $self->x_offset(),
697 x2 => $line_width + $self->x_offset(),
698 y1 => $y_fix + $self->y_offset(),
699 y2 => $y_fix + $self->y_offset()
700 );
701 foreach ( $rowdata{$row}{start} - 1 .. $rowdata{$row}{end} ) {
702 if ( $_ % 1000 == 0 && $_ % 10000 != 0 ) {
703 my $current_location =
704 $self->calc_width() *
705 ( $_ - $rowdata{$row}{start} ) /
706 $self->_internal_maxrowlength();
707 $ui_group->line(
708 id => 'ui_element_'
709 . ( $self->line_count() + rand() ),
710 x1 => $current_location + $self->x_offset(),
711 x2 => $current_location + $self->x_offset(),
712 y1 => $y_fix + $self->y_offset(),
713 y2 => $y_fix + 5 + $self->y_offset(),
714 );
715 }
716 if ( $_ % 10000 == 0 ) {
717 my $current_location =
718 $self->calc_width() *
719 ( $_ - $rowdata{$row}{start} ) /
720 $self->_internal_maxrowlength();
721 $ui_group->line(
722 id => 'ui_element_'
723 . ( $self->line_count() + rand() ),
724 x1 => $current_location + $self->x_offset(),
725 x2 => $current_location + $self->x_offset(),
726 y1 => $y_fix + $self->y_offset(),
727 y2 => $y_fix + 10 + $self->y_offset(),
728 );
729 $ui_group->text(
730 id => 'ui_text'
731 . ( $self->line_count() + rand() ),
732 x => $current_location + 10 + $self->x_offset(),
733 y => $y_fix + 20 + $self->y_offset(),
734 -cdata => ( $_ / 1000 ) . " kb",
735 'fill' => '#000000',
736 'fill-opacity' => 1,
737 'font-family' => 'mono',
738 'stroke' => 'none'
739 );
740 }
741
742 if (
743 (
744 $_ == $rowdata{$row}{start} - 1
745 || $_ == $rowdata{$row}{end}
746 )
747 && ( $_ % 10000 != 0 )
748 )
749 {
750 my $current_location =
751 $self->calc_width() *
752 ( $_ - $rowdata{$row}{start} ) /
753 $self->_internal_maxrowlength();
754 $ui_group->line(
755 id => 'ui_element_'
756 . ( $self->line_count() + rand() ),
757 x1 => $current_location + $self->x_offset(),
758 x2 => $current_location + $self->x_offset(),
759 y1 => $y_fix + $self->y_offset(),
760 y2 => $y_fix + 10 + $self->y_offset(),
761 );
762 $ui_group->text(
763 id => 'ui_text'
764 . ( $self->line_count() + rand() ),
765 x => $current_location + $self->x_offset(),
766 y => $y_fix + 20 + $self->y_offset(),
767 -cdata => sprintf( '%d kb', ( $_ / 1000 ) ),
768 'fill' => '#000000',
769 'fill-opacity' => 1,
770 'font-family' => 'mono',
771 'stroke' => 'none'
772 );
773 }
774 }
775 }
776
777 sub addFeature {
778 my ( $self, %data ) = @_;
779 my %rowdata = %{ $self->rowdata() };
780 my $x =
781 $self->calc_width() *
782 ( $data{'start'} - $rowdata{ $data{'row'} }{'start'} ) /
783 $self->_internal_maxrowlength() + $self->x_offset();
784 my $w =
785 $self->calc_width() *
786 ( $data{'end'} - $data{'start'} ) /
787 $self->_internal_maxrowlength();
788 my $h = 15;
789 my $y =
790 ( $data{'row'} - 1 ) * $self->ils() + $self->y_offset() - $h / 2;
791
792 my $id = "$x$y$w$h" . rand();
793
794 #print "Item(".$data{'start'}.",".$data{'end'}.",".$data{'row'}.") =\t($x,$y,$w,$h)\n";
795
796 if ( $self->separate_strands() ) {
797 $y += -$data{'strand'} * 30;
798 }
799
800 if ( $self->view() eq 'alt_random' ) { # Max add = 20
801 $y += 4 * ( $x % 5 );
802 }
803 elsif ( $self->view() eq 'alt_every' ) { # Max add = 10
804 # We (Sort of like a convolution?) multiply by strand This has
805 # the following effect; when on the top strand, we will only
806 # ever add a positive to the height of the item (moving it
807 # downward and closer to the ruler). On the bottom strand
808 # however, we only ever add a negative to the height of the
809 # item (moving it upwards towards the ruler). This allows the
810 # items on the top and bottom to stay balanced.
811 $y +=
812 $data{'strand'} * 10 *
813 ( ( $self->_ft_count( $self->_ft_count() + 1 ) ) % 2 ) -
814 10 * $data{'strand'};
815
816 # However, This is imperfect, since we add items based on class,
817 # not from left to right
818 }
819 elsif ( $self->view() eq 'alt_artemis' ) { # Max add = 20?
820 # Muwahahahaha. Sorry. Determined coefficient and constant by
821 # trial and error, but this matches up with the artemis view
822 # without an if/else based on which strand. :D
823 $y +=
824 10 * ( ( $data{'start'} - 2 * $data{'strand'} + 1 ) % 3 ) -
825 10 * $data{'strand'};
826 }
827
828 my $item_color = $color_spec->getColour( $data{'color'} );
829 if ($item_color) {
830 $data{'group'}->rectangle(
831 x => ($x),
832 y => $y,
833 width => $w,
834 height => $h,
835 id => $id,
836 fill => $color_spec->getColour( $data{'color'} )
837 );
838 }
839 else {
840 $data{'group'}->rectangle(
841 x => ($x),
842 y => $y,
843 width => $w,
844 height => $h,
845 id => $id,
846 );
847 }
848 if ( $self->label() && $data{'label'} ) {
849
850 my ( $lx, $ly );
851 my @char_data = split( //, $data{label} );
852
853 #Exit early if we don't even want to plot.
854 my $is_too_small = ( scalar(@char_data) * 2 > $w );
855 if ( $self->label_shrink_mode() eq 'cutoff' && $is_too_small ) {
856 return;
857 }
858
859 #Font Scaling
860 my $font_scaling = 100;
861 if ( $self->label_shrink_mode() eq 'shrink' ) {
862 $font_scaling *= $w / ( 8 * scalar(@char_data) );
863 }
864
865 # Horizontal positioning
866 $lx =
867 $x +
868 $w / 2
869 ; #Horizontally center it, but this is by the leading edge of the text
870 if ( scalar(@char_data) * 8 > $w
871 && $self->label_shrink_mode() eq 'shrink' )
872 {
873 $lx -=
874 scalar(@char_data) * 4 *
875 $font_scaling / 100
876 ; #Adjustment for scaled text. Determined by experiment
877 }
878 else {
879 $lx -=
880 scalar(@char_data) * 4
881 ; #Move four pixels left for every character in the label
882 }
883
884 # Vertical positioning
885 if ( $self->label_pos() eq "above" ) { #Label is ABOVE
886 if ( $self->separate_strands()
887 && $data{'strand'} == -1 )
888 {
889 $ly =
890 $y +
891 $h / 2 + 10 + 30
892 ; #Need to consider below strand, only one strand.
893 }
894 else {
895 $ly =
896 $y +
897 $h / 2 - 30
898 ; #Need to consider below strand, only one strand.
899 }
900 }
901 else { #Label is ON
902 $ly = $y + $h / 2 + 5;
903 }
904
905 if ( $data{'label'} !~ /^gene_[0-9]+$/ ){
906 $self->plot_label( $lx, $ly, $font_scaling, $data{'label'},
907 $data{'ui_group'} );
908
909 if ( $self->label_callouts()
910 && $self->label_pos() eq "above" )
911 {
912 $data{'ui_group'}->line(
913 id => 'l' . "_" . rand(1),
914 x1 => $x + ( $w / 2 ),
915 x2 => $x + ( $w / 2 ),
916 y1 => (
917 $self->separate_strands()
918 && $data{'strand'} eq '-1' ? $y + $h
919 : $y
920 ),
921 y2 => (
922 $self->separate_strands()
923 && $data{'strand'} eq '-1' ? $ly - 12
924 : $ly
925 )
926 );
927 }
928 }
929
930 }
931 }
932
933 sub plot_label {
934 my ( $self, $x, $y, $font_size, $label, $ui_group ) = @_;
935 if ( $font_size < 80 ) {
936 $font_size = 80;
937 }
938 $ui_group->text(
939 id => 'text' . rand(1),
940 x => $x,
941 y => $y,
942 -cdata => $label,
943 'fill' => '#000000',
944 'fill-opacity' => 1,
945 'font-family' => 'mono',
946 'font-size' => $font_size . '%',
947 'stroke' => 'none'
948 );
949 }
950
951 sub max ($$) { $_[ $_[0] < $_[1] ] }
952 sub min ($$) { $_[ $_[0] > $_[1] ] }
953
954 no Moose;
955 1;
956
957 __END__
958
959 =pod
960
961 =encoding UTF-8
962
963 =head1 NAME
964
965 CPT::Plot::Base - Main plotting class for genome mapper
966
967 =head1 VERSION
968
969 version 1.96
970
971 =head1 AUTHOR
972
973 Eric Rasche <rasche.eric@yandex.ru>
974
975 =head1 COPYRIGHT AND LICENSE
976
977 This software is Copyright (c) 2014 by Eric Rasche.
978
979 This is free software, licensed under:
980
981 The GNU General Public License, Version 3, June 2007
982
983 =cut