Mercurial > repos > cpt > cpt_psm_comparison_table

comparison lib/CPT/Plot/Base.pm @ 1:f093e08f21f3 draft default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload commit 94b0cd1fff0826c6db3e7dc0c91c0c5a8be8bb0c
author cpt
date Mon, 05 Jun 2023 02:47:24 +0000
parents
children
comparison
equal deleted inserted replaced
0:b8b8b52904a5 1:f093e08f21f3
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