[Bio] / FigKernelPackages / raedraw.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/raedraw.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (view) (download) (as text)

1 : redwards 1.1
2 :     #### END tool_hdr ####
3 :    
4 :     =pod
5 :    
6 :     =head1 raedraw.pm
7 :    
8 :     A bunch of modules written by Rob to draw different things. Most of these are going to draw images
9 :     using SVG that has many advantages over png/gif images.
10 :    
11 :     A lot of this is geared towards drawing the genome browser that I am working on. The idea is not only
12 :     to plot sims but other data in tag/value pairs
13 :    
14 :     =cut
15 :    
16 :    
17 :     package raedraw;
18 :     use strict;
19 :     use FIG;
20 :     use SVG;
21 :     use Data::Dumper;
22 :     my $fig=new FIG;
23 :    
24 :    
25 :     =head1 new
26 :    
27 :     Instantiate the script and figure out what we are looking for. These are the options.
28 :     Remeber, this was originally taken from a standalone script I wrote, and then cgi-iffied.
29 :    
30 :     Returns a pointer to itself
31 :    
32 :     Arguments that can be passed in
33 :     -genome <genome> Number to draw as baseline
34 :     -compare_to <genome1,genome2,genome3> A reference to a list of similar genomes to plot on image
35 :     Note that this will be expanded with stuff, and some good stuff too
36 :    
37 :    
38 :     Image size
39 :     -width <width> Width of the image (default 800)
40 :     -margin <pixels> Left/right margin and gap btwn contigs (default 100)
41 :     -top_marg <pixels> Top margin (default=20)
42 :     -bottom_marg <pixels> Bottom margin (default=20) (note: was -p)
43 :     -box_height <box height> Height of the box to color (default=10)
44 :    
45 :     Display options
46 :     -rows <number> Number of rows to split image into (default=1)
47 :     -box_no_score <boolean> Draw boxes around pegs with no score (was: l)
48 :     -box_score <boolean> Draw boxes around pegs with sims (default=1) (was k)
49 :     -show_function <peg number> Show function every <peg number> pegs in target genome
50 :     -tick_mark_height <pixels> Height of the tick marks to show (default=3)
51 :     -genome_lines <boolean> Draw lines where the genome should be
52 : redwards 1.3 -twostrands <boolean> Put the boxes on two different strands for fwd and reverse (complement)
53 :     -bluescale <boolean> The default is to have darkest be a red color. This will make it a blue color
54 :     -scalefactor ([tag, scale]) An array of tuples on which to scale the numbers in tag/value pairs. Should end up so max no. is 1.
55 : redwards 1.1
56 :     Other things
57 : redwards 1.6 -abbrev <boolean> Use abbreviated names (default=1)
58 : redwards 1.1 -stopshort <peg count> Stop after drawing <peg count> pegs (just for development)
59 :    
60 :    
61 :     At the moment, $self->{'genome'} contains the genome that is drawn along the top, and $self->{'compareto'}
62 :     contains the comparators. We need to extend comparators so we can include homology and whatnot.
63 :    
64 :     EOF
65 :    
66 :     =cut
67 :    
68 :     sub new {
69 :     my ($class,%args) = @_;
70 :     my $self = bless{},$class;
71 :    
72 :     # parse out the arguments that are handed in
73 : redwards 1.3 foreach my $arg (qw[genome width margin top_marg bottom_marg box_height rows show_function stopshort box_no_score tick_mark_height
74 : redwards 1.6 genome_lines maxn maxp bluescale user]) {
75 : redwards 1.1 $args{"-".$arg} && ($self->{$arg}=$args{"-".$arg})
76 :     }
77 : redwards 1.6 foreach my $arg (qw[box_score abbrev twostrands]) {
78 : redwards 1.1 if (defined $args{"-".$arg}) {$self->{$arg}=$args{"-".$arg}} else {$self->{$arg}=$args{"-".$arg}=1}
79 :     }
80 : redwards 1.3
81 :     foreach my $arr ($args{"-scalefactor"}) {
82 :     $self->{'scale'}->{$arr->[0]}=$arr->[1];
83 :     }
84 :    
85 :    
86 : redwards 1.1 $args{'-compare_to'} && $self->compareto($args{'-compare_to'});
87 :    
88 :     # predefined things
89 :     $self->{'width'} =800 unless (defined $self->{'width'});
90 :     $self->{'box_height'} =10 unless (defined $self->{'box_height'});
91 :     $self->{'margin'} =100 unless (defined $self->{'margin'});
92 :     $self->{'top_marg'} =20 unless (defined $self->{'top_marg'});
93 :     $self->{'bot_marg'} =20 unless (defined $self->{'bot_marg'});
94 :     $self->{'rows'} =1 unless (defined $self->{'rows'});
95 :     $self->{'tick_mark_height'} =3 unless (defined $self->{'tick_mark_height'});
96 : redwards 1.3 $self->{'maxn'} =50 unless (defined $self->{'maxn'});
97 :     $self->{'maxp'} =1e-5 unless (defined $self->{'maxp'});
98 : redwards 1.1
99 : redwards 1.5
100 : redwards 1.6 # predefine some color things
101 :     $self->{'brightness'}=100;
102 :     $self->{'saturation'}=100;
103 :     $self->{'maxhue'}=0;
104 :    
105 : redwards 1.1 # each genome gets 3 box heights, and we have 2 top/bottom margins
106 :     # we also need to add room for the target genome track.
107 :     $self->{'height'}=(3 * $self->{'box_height'}* (scalar @{$self->compareto()} +1)) + ($self->{'top_marg'} + $self->{'bot_marg'});
108 :    
109 :     # we have the width of the image, and the effective width from which we calculate scaling of the pegs.
110 :     # the effective width is the width * the number of rows we want
111 :     $self->{'effectivewidth'}=$self->{'width'} * $self->{'rows'};
112 :    
113 : overbeek 1.10 $self->{'svg'}=SVG->new();
114 : redwards 1.1
115 :     return $self;
116 :     }
117 :    
118 :    
119 :     =head2 compareto
120 :    
121 :     Get or set the list of genomes or other things that we will compare this to.
122 :     args: A reference to an array of things to add to the comparisons
123 :     returns: A reference to an array of things that we will compare to
124 :    
125 : redwards 1.3 Things we understand are:
126 :     genome number \d+\.\d+
127 :     tagvalue pairs: must be as a ref to an array, and the first element MUST be 'tagvalue'
128 :     the second element must be the tag, and the optional third and fourth elements
129 :     are cutoff values - anything below the third cutoff and above the fourth cutoff
130 :     will not be shown.
131 :    
132 : redwards 1.1 =cut
133 :    
134 :     sub compareto {
135 :     my ($self, $ct)=@_;
136 : redwards 1.3 push (@{$self->{'compareto'}}, @$ct) if ($ct);
137 : redwards 1.1 return $self->{'compareto'};
138 :     }
139 :    
140 :     =head2 show_function
141 :    
142 :     Set a boolean to show the function
143 :     args: boolean whether to set the function
144 :     returns: whether the function is shown or not
145 :    
146 :     =cut
147 :    
148 :     sub show_function {
149 :     my ($self, $sf)=@_;
150 :     if (defined $sf) {$self->{'show_function'}=$sf}
151 :     return $self->{'show_function'}
152 :     }
153 :    
154 :    
155 :     =head2 write_image
156 :    
157 :     Write out the image to a file
158 :     Args: A file name to write to
159 :     Returns: 1 on success
160 :    
161 :     =cut
162 :    
163 :     sub write_image {
164 :     my ($self, $file)=@_;
165 :    
166 :     #print STDERR &Dumper($self);
167 :    
168 :     # make sure that we have something to compare to
169 :     unless ($self->compareto()) {die "Couldn't find any genomes to compare to"}
170 :    
171 :     # at the moment this is essentially a sequential call, but i think we may mess with this soon....
172 :     $self->_define_tracks unless ($self->{'track'});
173 :     $self->_scale_image unless ($self->{'rowcount'});
174 :     $self->_draw_image unless ($self->{'drawn'});
175 :     $self->_hz_lines if ($self->{'genome_lines'});
176 :    
177 :     open (OUT, ">$file") || die "Can't open $file";
178 :     print OUT $self->{'svg'}->xmlify;
179 :     close OUT;
180 :    
181 : redwards 1.4 my $height=(1 + $self->{'rowcount'}) * (((scalar (keys %{$self->{'trackposn'}})) * $self->{'box_height'}* 3) + $self->{'top_marg'}+ $self->{'box_height'} + $self->{'bot_marg'}) + $self->{'top_marg'}+ $self->{'bot_marg'};
182 : redwards 1.2
183 :     print STDERR "The image should be width: ", $self->{'width'}, " height: $height\n";
184 :    
185 :     print STDERR "Image is in $file\n";
186 : redwards 1.1 print STDERR "Processing took ", time-$^T, " seconds\n";
187 : redwards 1.2 return ($self->{'width'}, $height);
188 : redwards 1.1 }
189 :    
190 :    
191 :     =head2 _define_tracks
192 :    
193 :     Each genome has a track that contains all the information about the genome, including the boxes, names, and drawings. This is an internal method to define those tracks
194 :    
195 :     Args: none
196 :     Returns: nothing
197 :    
198 :     =cut
199 :    
200 :     sub _define_tracks {
201 :     my ($self)=@_;
202 :     {
203 :     my $gp=$self->{'top_marg'}+$self->{'box_height'};
204 :     foreach my $simgen ($self->{'genome'}, @{$self->{'compareto'}}) {
205 : redwards 1.3 # we have to copy this so we don't alter the one in the array
206 :     my $test_gen=$simgen;
207 :     my $an;
208 :     if (ref($test_gen) eq "ARRAY") {
209 :     # it is a reference to an array (hence tag val pairs, so we want the 2nd item
210 :     $test_gen=$test_gen->[1];
211 : redwards 1.6 if ($test_gen eq "pirsf") {$an = "PIR Superfamilies"}
212 :     else {$an=uc($test_gen)}
213 :     }
214 :     elsif ($test_gen eq "subsystems") {
215 :     $an = "FIG Subsystems";
216 : redwards 1.3 }
217 :     $self->{'track'}->{$test_gen}=$self->{'svg'}->group(id=>"${test_gen}_group");
218 :     $self->{'trackposn'}->{$test_gen}=$gp;
219 :    
220 :     # if testgen is a genome (an is not defined) so we need to get the genome name
221 : redwards 1.1
222 : redwards 1.3 if (!$an && $self->{'abbrev'}) {$an=$fig->abbrev($fig->genus_species($test_gen))}
223 :     elsif (!$an) {$an=$fig->genus_species($test_gen)}
224 :     $self->{'label'}->{$test_gen}=$an;
225 : redwards 1.1 $gp+=3*$self->{'box_height'};
226 :     }
227 :     }
228 :     }
229 :    
230 :    
231 :    
232 :     =head1 _scale_image
233 :    
234 :     An internal method to figure out how long the whole genome is and use this as the baseline for the image
235 :    
236 : redwards 1.2 We have somethinglike this for 3 contigs ccc and margins mmm:
237 : redwards 1.1 Row1 mmm ccccccccccc mmm
238 :     Row2 mmm ccc mmm ccc mmm
239 :     Row3 mmm ccccccccccc mmm
240 :     Row4 mmm cc mmm cccc mmm
241 :     The total length is $effectivewidth, but we have to remove 2*rows*margins from this
242 :     then we have to remove # contigs-1 * gap between them
243 :    
244 :     args: none
245 :     returns: none
246 :    
247 :     =cut
248 :    
249 :     sub _scale_image {
250 :     my ($self)=@_;
251 :     my %len; my @xs; $self->{'rowcount'}=0;
252 :     my $absorow;
253 :     {
254 :     my $contigcount;
255 :     foreach my $contig ($fig->all_contigs($self->{'genome'})) {
256 :     $contigcount++;
257 :     $self->{'totallen'}+=$fig->contig_ln($self->{'genome'}, $contig);
258 :     $len{$contig}=$fig->contig_ln($self->{'genome'}, $contig);
259 :     }
260 :    
261 :    
262 :     $contigcount = (($contigcount - 1) * $self->{'margin'}) + (2 * $self->{'rows'}*$self->{'margin'});
263 :     $self->{'xmultiplier'}=$self->{'effectivewidth'}- $contigcount;
264 :     # now we have the total length, the length of each contig, and the amount of free space. For each contig, the scale is
265 :     # the percent of contg/totallen. The space that it takes up is that * free space
266 :     # We also need to know the starts and stops for each row in nt and contigs
267 :     my $offset=0;
268 :     foreach my $contig (sort {$fig->contig_ln($self->{'genome'}, $b) <=> $fig->contig_ln($self->{'genome'}, $a)} keys %len) {
269 :     $self->{'xoffset'}->{$contig}=$self->{'margin'}+$offset;
270 :    
271 : redwards 1.2 #print STDERR "For contig $contig, length is $len{$contig} and start is ", $self->{'xoffset'}->{$contig};
272 :     #print STDERR " and end will be ", $self->{'xoffset'}->{$contig} + $self->{'margin'} + (($len{$contig}/$self->{'totallen'}) * $self->{'xmultiplier'}), "\n";
273 : redwards 1.1
274 :     ### Added rowinfo, but not sure about this
275 :     push (@{$self->{'contigrows'}->{$contig}}, $self->{'rowcount'});
276 :     my $laststart = $self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'start'}=$self->{'xoffset'}->{$contig};
277 :     my $rowend=$self->{'xoffset'}->{$contig} + (($len{$contig}/$self->{'totallen'}) * $self->{'xmultiplier'});
278 :     while (($rowend-$laststart) > ($self->{'width'} - (2 * $self->{'margin'}))) {
279 :     $laststart=
280 :     $self->{'rowinfo'}->{$self->{'rowcount'}+1}->{$contig}->{'start'}=
281 :     $self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'end'}=
282 :     $self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'start'}+($self->{'width'} - (2 * $self->{'margin'}));
283 :     $self->{'rowcount'}++;
284 :     push (@{$self->{'contigrows'}->{$contig}}, $self->{'rowcount'});
285 :     }
286 :     $offset=$self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'end'}=$rowend;
287 :     #### End added rowinfo section
288 :     }
289 :     }
290 :    
291 :     ##NOTE : ROWINFO HAS MARGINS INCLUDED
292 :    
293 :     # we want to find the absolute starts and stops for each row
294 :     # print out the saved information
295 :     for (my $i=0; $i <= $self->{'rowcount'}; $i++) {
296 :     foreach my $c (keys %{$self->{'rowinfo'}->{$i}}) {
297 :     if (!defined $absorow->{$i}->{'start'} || $absorow->{$i}->{'start'} > $self->{'rowinfo'}->{$i}->{$c}->{'start'})
298 :     {$absorow->{$i}->{'start'} = $self->{'rowinfo'}->{$i}->{$c}->{'start'}}
299 :     if (!defined $absorow->{$i}->{'end'} || $absorow->{$i}->{'end'} < $self->{'rowinfo'}->{$i}->{$c}->{'end'})
300 :     {$absorow->{$i}->{'end'} = $self->{'rowinfo'}->{$i}->{$c}->{'end'}}
301 :     }
302 :     }
303 :    
304 :    
305 :     ### Define the rows
306 :     for (my $row=0; $row <=$self->{'rowcount'}; $row++) {
307 :     my $transform=$row * (((scalar keys %{$self->{'trackposn'}}) * $self->{'box_height'} * 3) + $self->{'top_marg'} + $self->{'bot_marg'});
308 :     my $xtrans=$absorow->{$row}->{'start'} - $self->{'margin'};
309 :     $self->{'rowgroup'}->{$row}=$self->{'svg'}->group(id=>"row_$row", transform=>"translate(-$xtrans, $transform)");
310 : redwards 1.2
311 : redwards 1.1 # add genome labels to the rows
312 :     foreach my $simgen (keys %{$self->{'trackposn'}}) {
313 :     $self->{'rowgroup'}->{$row}->text(id=>"${simgen}_${row}_label", x=>$xtrans, y=>$self->{'trackposn'}->{$simgen}, textLength=>100, lengthAdjust=>"spacingAndGlyphs",
314 :     style=>{'font-family'=>"Helvetica", 'font-size'=>"10", fill=>"black",})->cdata($self->{'label'}->{$simgen});
315 :     }
316 :     }
317 :     } # end _scale_image
318 :    
319 :     =head1 _draw_genome
320 :    
321 :     An internal method to draw the genome that we are comparing to, and to define the locations of the pegs (perhaps)
322 :    
323 :     args: none
324 :     returns: none
325 :    
326 :     =cut
327 :    
328 :     sub _draw_image {
329 :     my ($self)=@_;
330 :     $self->{'drawn'}=1;
331 :     my $defs=$self->{'track'}->{$self->{'genome'}}->defs;
332 :     my $time=time; my $pegcount;
333 :     foreach my $peg ($fig->pegs_of($self->{'genome'})) {
334 :     $pegcount++;
335 :     last if ($self->{'stopshort'} && $self->{'stopshort'} == $pegcount);
336 : redwards 1.6 if ($self->{'user'} eq "master:RobE") {unless ($pegcount % 100) {print STDERR "Pegs done: $pegcount\n"}}
337 : redwards 1.1 # Define the location of the box once per peg
338 :     # also use this to figure out which row to add it to
339 :     my @loc=$fig->feature_location($peg);
340 :     $loc[0] =~ m/^(.*)\_(\d+)\_(\d+)$/;
341 :     my ($contig, $start, $stop)=($1, $2, $3);
342 :     my $len=$stop-$start;
343 :    
344 :     # if the orf is in the same direction want the sim on top, if not want it below
345 :     my $x=$self->{'xoffset'}->{$contig} + (($start/$self->{'totallen'}) * $self->{'xmultiplier'});
346 :     my $boxwidth = (abs($stop-$start)/$self->{'totallen'})*$self->{'xmultiplier'};
347 :    
348 :     # figure out the correct row for the current location. The row is after we have split up the genome
349 :     my $row;
350 :     foreach my $addrow (@{$self->{'contigrows'}->{$contig}}) {
351 :     if ($x >= $self->{'rowinfo'}->{$addrow}->{$contig}->{'start'} && $x < $self->{'rowinfo'}->{$addrow}->{$contig}->{'end'}) {$row=$addrow; last}
352 :     }
353 :     unless (defined $row) {
354 :     print STDERR "Couldn't get a row for $contig looking for a start of $x (real start: $start). These are the starts:\n";
355 :     print STDERR "These are the contigrows: ", join " ", @{$self->{'contigrows'}->{$contig}}, "\n";
356 :     print STDERR map {"$_: " . $self->{'rowinfo'}->{$_}->{$contig}->{'start'} . "\n"} @{$self->{'contigrows'}->{$contig}};
357 :     print STDERR "These are the stops\n";
358 :     print STDERR map {"$_: " . $self->{'rowinfo'}->{$_}->{$contig}->{'end'} . "\n"} @{$self->{'contigrows'}->{$contig}};
359 :     print STDERR "\n";
360 :     exit -1;
361 :     }
362 :    
363 :     # show the function if we are supposed to
364 : redwards 1.4 if ($self->{'show_function'} && !($pegcount % $self->{'show_function'})) {$self->_add_functions($defs, $peg, $x, $boxwidth, $row)}
365 : redwards 1.1
366 :    
367 :     # add a tick mark for the peg
368 :     my $sl=$self->{'trackposn'}->{$self->{'genome'}}-$self->{'tick_mark_height'}; # start line
369 :     my $el=$self->{'trackposn'}->{$self->{'genome'}}+$self->{'tick_mark_height'}; # end line
370 :     $self->{'rowgroup'}->{$row}->line(x1=>$x, x2=>$x, y1=>$sl, y2=>$el);
371 :     $self->{'rowgroup'}->{$row}->line(x1=>$x+$boxwidth, x2=>$x+$boxwidth, y1=>$sl, y2=>$el);
372 :    
373 :    
374 :     #if we want the empty boxes draw them first and then the color thing will overwrite.
375 :     if ($self->{'box_no_score'}) {
376 :     foreach my $simgen (keys %{$self->{'trackposn'}}) {
377 :     my $y=$self->{'trackposn'}->{$simgen};
378 :     if ($start > $stop) {$y-=$self->{'box_height'}}
379 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
380 :     width=>$boxwidth, id=>"${peg}_$y", style => {stroke => "rgb(0,0,0)", fill => "none"});
381 :     }
382 :     }
383 :    
384 :     # now for each peg we need to figure out what we need to add
385 : redwards 1.3 # figure out the strand
386 :     my $comp=0;
387 :     if ($self->{'twostrands'} && $start > $stop) {$comp=1}
388 : redwards 1.1 foreach my $match (@{$self->compareto()}) {
389 : redwards 1.3 next unless ($match);
390 :     if (ref($match) eq "ARRAY" && $match->[0] eq "tagvalue") {
391 :     # deal with tag value pairs
392 : redwards 1.6 $self->_plot_tag_value($peg, $x, $boxwidth, $row, $match);
393 :     }
394 :     elsif ($match eq "subsystems") {
395 :     $self->_plot_subsystems($peg, $x, $boxwidth, $row, $match);
396 : redwards 1.3 }
397 :     elsif ($match =~ /^\d+\.\d+/) {
398 : redwards 1.1 # it is a genome
399 :     $self->_plot_sims($peg, $x, $boxwidth, $row, $match, $comp);
400 :     }
401 :     else {
402 :     print STDERR "No support for matches to $match yet\n";
403 :     }
404 :     }
405 :     }
406 :     }
407 :    
408 :    
409 :     =head2 _add_functions
410 :    
411 :     An internal method to add the functions to the image.
412 :     Args: definitions (defs), peg, position (x) where to add the text, box width, row (y group) to add the text
413 :     Returns: None
414 :    
415 :     I want to make the text at 45 degrees, so we are going to have to make a path and then put the text on the path.
416 :     This is tricky. What we do is define a horizontal path from the point where we want to start to the end of the image
417 :     and we rotate it by 45 degrees. Then we put the text onto that path we have just created. Neato, huh?
418 :    
419 :     =cut
420 :    
421 :     sub _add_functions {
422 :     my ($self, $defs, $peg, $position, $boxwidth, $row)=@_;
423 :     return unless ($self->{'show_function'});
424 :     my $funclocx=$position+($boxwidth/2); # this should be the middle of the box?
425 :     my $funclocy=$self->{'trackposn'}->{$self->{'genome'}}-2;
426 :     my $funcendx=$self->{'effectivewidth'}+$funclocx; # this doesn't matter it just needs to be off the image!
427 :     $defs->path(id=>"${peg}_line", d=>"M $funclocx $funclocy L $funcendx $funclocy", transform=>"rotate(-45, $funclocx $funclocy)");
428 :    
429 :    
430 :     # now just add the text as a textPath
431 :     $self->{'rowgroup'}->{$row}->text(style=>{'font-family'=>"Helvetica, sans-serif", 'font-size'=>"2", fill=>"black",})
432 :     ->textPath(id=>"${peg}_function", '-href'=>"#${peg}_line")
433 :     ->cdata(scalar $fig->function_of($peg));
434 :     }
435 :    
436 :    
437 : redwards 1.6 =head2 _plot_subsystems
438 :    
439 :     An internal method to plot a box if the peg is in a subsystem
440 :     Takes the following as arguments:
441 :     peg, position (x) where to draw the box, width of the box to draw, row (y group)
442 :    
443 :     I am going to try and color the box based on some factor of the subsystems. I will keep saturation and brightness at 50%
444 :     and then vary the hue from 0-360
445 :    
446 :     =cut
447 :    
448 :     sub _plot_subsystems {
449 :     my ($self, $peg, $x, $boxwidth, $row)=@_;
450 :     my $y=$self->{'trackposn'}->{'subsystems'} - (0.5 * $self->{'box_height'});
451 :    
452 :     unless (defined $self->{'maxhue'}) {$self->{'maxhue'}=-5}
453 :     if ($self->{'maxhue'} > 360) {
454 :     $self->{'maxhue'}=-5;
455 :     $self->{'brightness'}-=10;
456 :     if ($self->{'brightness'} < 0) {
457 :     $self->{'brightness'}=100;
458 :     $self->{'saturation'}-=10;
459 :     }
460 :     }
461 :    
462 :     foreach my $ss (sort $fig->subsystems_for_peg($peg))
463 :     {
464 :     next if ($ss->[0] =~ /essential/i);
465 :     next if ($self->{'subsystems'}->{$peg}->{$ss->[0]});
466 :     $self->{'subsystems'}->{$peg}->{$ss->[0]}=1;
467 :     unless ($self->{'hue'}->{$ss->[0]}) {$self->{'hue'}->{$ss->[0]}=$self->{'maxhue'}+5; $self->{'maxhue'}+=5}
468 :     my @color=($self->{'hue'}, $self->{'saturation'}, $self->{'brightness'});
469 :     if ($self->{'bluescale'}) {($color[0], $color[3])=($color[3], $color[0])}
470 :     if ($self->{'box_score'}) {
471 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
472 :     width=>$boxwidth, id=>$ss->[0].".".$peg, style => {stroke => "rgb(0,0,0)", fill => "rgb(@color)"});
473 :     } else {
474 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
475 :     width=>$boxwidth, id=>$ss->[0].$peg, style => {stroke => "none", fill => "rgb(@color)"});
476 :     }
477 :     }
478 :     }
479 :    
480 : redwards 1.3 =head2 _plot_tag_value
481 :    
482 :     An internal method to plot tag value pairs.
483 :     Takes the following as arguments:
484 : redwards 1.6 peg, position (x) where to draw the box, width of the box to draw, row (y group)
485 : redwards 1.3 and then a reference to the tagvalue pairs
486 :    
487 :     The last element must be a reference to an array with the following four items:
488 :     'tagvalue' (ignored - just a boolean for this)
489 :     'tag' -- tag that is used for the plot
490 :     'minimum' -- optional, if supplied minimum cutoff
491 :     'maximum' -- optional, if supplied maximum cutoff
492 :    
493 :     =cut
494 :    
495 :     sub _plot_tag_value {
496 : redwards 1.6 my ($self, $peg, $x, $boxwidth, $row, $tv)=@_;
497 :     my $y=$self->{'trackposn'}->{$tv->[1]} - (0.5 * $self->{'box_height'});
498 :    
499 : redwards 1.3 my $min=$tv->[2] if ($tv->[2]);
500 :     my $max=$tv->[3] if ($tv->[3]);
501 : redwards 1.4
502 : redwards 1.3 my @attr = $fig->feature_attributes($peg);
503 :     if (@attr > 0) {
504 : redwards 1.9 foreach (@attr) {
505 : redwards 1.7 next if ($self->{'addedtv'}->{$tv->[1].$peg}); # specifically avoid dups with tag/value pairs
506 :     $self->{'addedtv'}->{$tv->[1].$peg}=1;
507 : redwards 1.8 my($fid,$tag,$val,$url) = @$_;
508 : redwards 1.7 next unless (lc($tag) eq lc($tv->[1]));
509 :    
510 :     # we are going to test if it is a number. If it is not a number, we don't want to check min/max
511 :     my $number=1;
512 :     eval {
513 :     use warnings; # make sure we warn
514 :     local $SIG{__WARN__} = sub {die $_[0]}; # die if there is a warning
515 :     $val+=0; # generate the warning
516 :     };
517 :     undef $number if ($@);
518 :    
519 :     next if ($number && $min && $val < $min);
520 :     next if ($number && $max && $val > $max);
521 :     # now color the box. We can do this based on the number. We should probably have a scale factor here, but I don't know what it is
522 :     # so we'll let people supply it.
523 :     my @color=(0,1,1); # maybe 1,1,1?
524 :     if ($number) {
525 :     @color=map {int(255 * $_)} my_color($number * $self->{'scale'}->{$tv->[1]});
526 :     }
527 :     if ($self->{'bluescale'}) {($color[0], $color[3])=($color[3], $color[0])}
528 :     if ($self->{'box_score'}) {
529 : redwards 1.3 $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
530 : redwards 1.7 width=>$boxwidth, id=>$tv->[1].$peg, style => {stroke => "rgb(0,0,0)", fill => "rgb(@color)"});
531 :     } else {
532 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
533 :     width=>$boxwidth, id=>$tv->[1].$peg, style => {stroke => "none", fill => "rgb(@color)"});
534 :     }
535 : redwards 1.3 }
536 :     }
537 :     }
538 :    
539 :    
540 :    
541 : redwards 1.1 =head2 _plot_sims
542 :    
543 :     An internal method to add the similarities to the image
544 :     Args: peg, position (x) where to add the text, width of the box to draw, row (y group) to add the text,
545 :     genome to compare to, flag for whether to put below the line (complement essentially)
546 :     Returns: None
547 :    
548 :     =cut
549 :    
550 :    
551 :     sub _plot_sims {
552 :     ##### PLOT SIMS #####
553 :     # find the sims for the genomes that we need
554 :     my ($self, $peg, $x, $boxwidth, $row, $simgen, $comp)=@_;
555 :     my %seensims; # genomes we have seen sims from for this peg. So we only get the best hit
556 : redwards 1.3 foreach my $sim ($fig->sims($peg, $self->{'maxn'}, $self->{'maxp'}, 'fig')) {
557 : redwards 1.1 next unless ($fig->genome_of($$sim[1]) == $simgen && defined $self->{'trackposn'}->{$fig->genome_of($$sim[1])});
558 :     # figure out the y posn
559 :     my $y=$self->{'trackposn'}->{$simgen};
560 :     if ($comp) {$y-=$self->{'box_height'}}
561 :     # now we just need to color based on the sim
562 :     my @color=map {int(255 * $_)} my_color($$sim[2]); # this will adjust it for rgb 0-255
563 :     # color at the moment is on a red based scale, but I'd rather have it on a blue based scale as i am in a blue mood
564 :     # (though not down in the dumps, I just like the color blue)
565 :     # swap r and b, leave g the same
566 : redwards 1.3 if ($self->{'bluescale'}) {($color[0], $color[3])=($color[3], $color[0])}
567 : redwards 1.1
568 :     #now we need to make a box:
569 :     #x from $x length $boxwidth
570 :     #y from $y length $boxheight
571 :     #color is in @{$colorgenome->{$fig->genome_of($$sim[1])}}
572 :     if ($self->{'box_score'}) {
573 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
574 :     width=>$boxwidth, id=>$$sim[1].$peg, style => {stroke => "rgb(0,0,0)", fill => "rgb(@color)"});
575 :     } else {
576 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
577 :     width=>$boxwidth, id=>$$sim[1].$peg, style => {stroke => "none", fill => "rgb(@color)"});
578 :     }
579 :     }
580 :     # lastx is used as the translate function x factor. We need to set it to the end position less the margin so we still have some margin (for error)
581 :     }
582 :    
583 :    
584 :    
585 :     =head2 _hz_lines
586 :    
587 :     An internal method to add horizontal lines to an image where the genomes are
588 :     Args: None
589 :     Returns: None
590 :    
591 :     =cut
592 :    
593 :    
594 :     sub _hz_lines {
595 :     my ($self)=@_;
596 :     for (my $row=0; $row <= $self->{'rowcount'}; $row++) {
597 :     foreach my $contig (keys %{$self->{'rowinfo'}->{$row}}) {
598 :     my ($start, $end)=($self->{'rowinfo'}->{$row}->{$contig}->{'start'}, $self->{'rowinfo'}->{$row}->{$contig}->{'end'});
599 :     foreach my $simgen (keys %{$self->{'trackposn'}}) {
600 :     $self->{'rowgroup'}->{$row}->line(id=>"line_${simgen}_${contig}_$row",
601 :     x1=>$start, x2=>$end, y1=>$self->{'trackposn'}->{$simgen}, y2=>$self->{'trackposn'}->{$simgen});
602 :     }
603 :     }
604 :     }
605 :     }
606 :    
607 :    
608 :    
609 :     #### COLORS.
610 :     #
611 :     # This has been stolen from protein.cgi written by Gary because I don't
612 :     # understand enough about colors
613 :    
614 :     sub my_color {
615 :     my $percent=shift;
616 :     return (255,255,255) unless ($percent);
617 :     $percent=1-$percent/100; # we want the more similar ones to be darker
618 :     my $hue = 5/6 * $percent - 1/12;
619 :     my $sat = 1 - 10 * $percent / 9;
620 :     my $br = 1;
621 :     return hsb2rgb( $hue, $sat, $br );
622 :     }
623 :    
624 :     #
625 :     # Convert HSB to RGB. Hue is taken to be in range 0 - 1 (red to red);
626 :     #
627 :    
628 :     sub hsb2rgb {
629 :     my ( $h, $s, $br ) = @_;
630 :     $h = 6 * ($h - floor($h)); # Hue is made cyclic modulo 1
631 :     if ( $s > 1 ) { $s = 1 } elsif ( $s < 0 ) { $s = 0 }
632 :     if ( $br > 1 ) { $br = 1 } elsif ( $br < 0 ) { $br = 0 }
633 :     my ( $r, $g, $b ) = ( $h <= 3 ) ? ( ( $h <= 1 ) ? ( 1, $h, 0 )
634 :     : ( $h <= 2 ) ? ( 2 - $h, 1, 0 )
635 :     : ( 0, 1, $h - 2 )
636 :     )
637 :     : ( ( $h <= 4 ) ? ( 0, 4 - $h, 1 )
638 :     : ( $h <= 5 ) ? ( $h - 4, 0, 1 )
639 :     : ( 1, 0, 6 - $h )
640 :     );
641 :     ( ( $r * $s + 1 - $s ) * $br,
642 :     ( $g * $s + 1 - $s ) * $br,
643 :     ( $b * $s + 1 - $s ) * $br
644 :     )
645 :     }
646 :    
647 :     sub floor {
648 :     my $x = $_[0];
649 :     defined( $x ) || return undef;
650 :     ( $x >= 0 ) || ( int($x) == $x ) ? int( $x ) : -1 - int( - $x );
651 :     }
652 :    
653 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3