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

Annotation of /FigKernelPackages/raedraw.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (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 :     -abrrev <boolean> Use abbreviated names (default=1)
58 :     -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 :     genome_lines maxn maxp bluescale]) {
75 : redwards 1.1 $args{"-".$arg} && ($self->{$arg}=$args{"-".$arg})
76 :     }
77 : redwards 1.3 foreach my $arg (qw[box_score abrrev 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.1 # each genome gets 3 box heights, and we have 2 top/bottom margins
101 :     # we also need to add room for the target genome track.
102 :     $self->{'height'}=(3 * $self->{'box_height'}* (scalar @{$self->compareto()} +1)) + ($self->{'top_marg'} + $self->{'bot_marg'});
103 :    
104 :     # we have the width of the image, and the effective width from which we calculate scaling of the pegs.
105 :     # the effective width is the width * the number of rows we want
106 :     $self->{'effectivewidth'}=$self->{'width'} * $self->{'rows'};
107 :    
108 :     $self->{'svg'}=SVG->new(); # use 100% as default
109 :    
110 :     return $self;
111 :     }
112 :    
113 :    
114 :     =head2 compareto
115 :    
116 :     Get or set the list of genomes or other things that we will compare this to.
117 :     args: A reference to an array of things to add to the comparisons
118 :     returns: A reference to an array of things that we will compare to
119 :    
120 : redwards 1.3 Things we understand are:
121 :     genome number \d+\.\d+
122 :     tagvalue pairs: must be as a ref to an array, and the first element MUST be 'tagvalue'
123 :     the second element must be the tag, and the optional third and fourth elements
124 :     are cutoff values - anything below the third cutoff and above the fourth cutoff
125 :     will not be shown.
126 :    
127 : redwards 1.1 =cut
128 :    
129 :     sub compareto {
130 :     my ($self, $ct)=@_;
131 : redwards 1.3 push (@{$self->{'compareto'}}, @$ct) if ($ct);
132 : redwards 1.1 return $self->{'compareto'};
133 :     }
134 :    
135 :     =head2 show_function
136 :    
137 :     Set a boolean to show the function
138 :     args: boolean whether to set the function
139 :     returns: whether the function is shown or not
140 :    
141 :     =cut
142 :    
143 :     sub show_function {
144 :     my ($self, $sf)=@_;
145 :     if (defined $sf) {$self->{'show_function'}=$sf}
146 :     return $self->{'show_function'}
147 :     }
148 :    
149 :    
150 :     =head2 write_image
151 :    
152 :     Write out the image to a file
153 :     Args: A file name to write to
154 :     Returns: 1 on success
155 :    
156 :     =cut
157 :    
158 :     sub write_image {
159 :     my ($self, $file)=@_;
160 :    
161 :     #print STDERR &Dumper($self);
162 :    
163 :     # make sure that we have something to compare to
164 :     unless ($self->compareto()) {die "Couldn't find any genomes to compare to"}
165 :    
166 :     # at the moment this is essentially a sequential call, but i think we may mess with this soon....
167 :     $self->_define_tracks unless ($self->{'track'});
168 :     $self->_scale_image unless ($self->{'rowcount'});
169 :     $self->_draw_image unless ($self->{'drawn'});
170 :     $self->_hz_lines if ($self->{'genome_lines'});
171 :    
172 :     open (OUT, ">$file") || die "Can't open $file";
173 :     print OUT $self->{'svg'}->xmlify;
174 :     close OUT;
175 :    
176 : 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'};
177 : redwards 1.2
178 :     print STDERR "The image should be width: ", $self->{'width'}, " height: $height\n";
179 :    
180 :     print STDERR "Image is in $file\n";
181 : redwards 1.1 print STDERR "Processing took ", time-$^T, " seconds\n";
182 : redwards 1.2 return ($self->{'width'}, $height);
183 : redwards 1.1 }
184 :    
185 :    
186 :     =head2 _define_tracks
187 :    
188 :     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
189 :    
190 :     Args: none
191 :     Returns: nothing
192 :    
193 :     =cut
194 :    
195 :     sub _define_tracks {
196 :     my ($self)=@_;
197 :     {
198 :     my $gp=$self->{'top_marg'}+$self->{'box_height'};
199 :     foreach my $simgen ($self->{'genome'}, @{$self->{'compareto'}}) {
200 : redwards 1.3 # we have to copy this so we don't alter the one in the array
201 :     my $test_gen=$simgen;
202 :     my $an;
203 :     if (ref($test_gen) eq "ARRAY") {
204 :     # it is a reference to an array (hence tag val pairs, so we want the 2nd item
205 :     $test_gen=$test_gen->[1];
206 :     $an=$test_gen;
207 :     }
208 :     $self->{'track'}->{$test_gen}=$self->{'svg'}->group(id=>"${test_gen}_group");
209 :     $self->{'trackposn'}->{$test_gen}=$gp;
210 :    
211 :     # if testgen is a genome (an is not defined) so we need to get the genome name
212 : redwards 1.1
213 : redwards 1.3 if (!$an && $self->{'abbrev'}) {$an=$fig->abbrev($fig->genus_species($test_gen))}
214 :     elsif (!$an) {$an=$fig->genus_species($test_gen)}
215 :     $self->{'label'}->{$test_gen}=$an;
216 : redwards 1.1 $gp+=3*$self->{'box_height'};
217 :     }
218 :     }
219 :     }
220 :    
221 :    
222 :    
223 :     =head1 _scale_image
224 :    
225 :     An internal method to figure out how long the whole genome is and use this as the baseline for the image
226 :    
227 : redwards 1.2 We have somethinglike this for 3 contigs ccc and margins mmm:
228 : redwards 1.1 Row1 mmm ccccccccccc mmm
229 :     Row2 mmm ccc mmm ccc mmm
230 :     Row3 mmm ccccccccccc mmm
231 :     Row4 mmm cc mmm cccc mmm
232 :     The total length is $effectivewidth, but we have to remove 2*rows*margins from this
233 :     then we have to remove # contigs-1 * gap between them
234 :    
235 :     args: none
236 :     returns: none
237 :    
238 :     =cut
239 :    
240 :     sub _scale_image {
241 :     my ($self)=@_;
242 :     my %len; my @xs; $self->{'rowcount'}=0;
243 :     my $absorow;
244 :     {
245 :     my $contigcount;
246 :     foreach my $contig ($fig->all_contigs($self->{'genome'})) {
247 :     $contigcount++;
248 :     $self->{'totallen'}+=$fig->contig_ln($self->{'genome'}, $contig);
249 :     $len{$contig}=$fig->contig_ln($self->{'genome'}, $contig);
250 :     }
251 :    
252 :    
253 :     $contigcount = (($contigcount - 1) * $self->{'margin'}) + (2 * $self->{'rows'}*$self->{'margin'});
254 :     $self->{'xmultiplier'}=$self->{'effectivewidth'}- $contigcount;
255 :     # now we have the total length, the length of each contig, and the amount of free space. For each contig, the scale is
256 :     # the percent of contg/totallen. The space that it takes up is that * free space
257 :     # We also need to know the starts and stops for each row in nt and contigs
258 :     my $offset=0;
259 :     foreach my $contig (sort {$fig->contig_ln($self->{'genome'}, $b) <=> $fig->contig_ln($self->{'genome'}, $a)} keys %len) {
260 :     $self->{'xoffset'}->{$contig}=$self->{'margin'}+$offset;
261 :    
262 : redwards 1.2 #print STDERR "For contig $contig, length is $len{$contig} and start is ", $self->{'xoffset'}->{$contig};
263 :     #print STDERR " and end will be ", $self->{'xoffset'}->{$contig} + $self->{'margin'} + (($len{$contig}/$self->{'totallen'}) * $self->{'xmultiplier'}), "\n";
264 : redwards 1.1
265 :     ### Added rowinfo, but not sure about this
266 :     push (@{$self->{'contigrows'}->{$contig}}, $self->{'rowcount'});
267 :     my $laststart = $self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'start'}=$self->{'xoffset'}->{$contig};
268 :     my $rowend=$self->{'xoffset'}->{$contig} + (($len{$contig}/$self->{'totallen'}) * $self->{'xmultiplier'});
269 :     while (($rowend-$laststart) > ($self->{'width'} - (2 * $self->{'margin'}))) {
270 :     $laststart=
271 :     $self->{'rowinfo'}->{$self->{'rowcount'}+1}->{$contig}->{'start'}=
272 :     $self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'end'}=
273 :     $self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'start'}+($self->{'width'} - (2 * $self->{'margin'}));
274 :     $self->{'rowcount'}++;
275 :     push (@{$self->{'contigrows'}->{$contig}}, $self->{'rowcount'});
276 :     }
277 :     $offset=$self->{'rowinfo'}->{$self->{'rowcount'}}->{$contig}->{'end'}=$rowend;
278 :     #### End added rowinfo section
279 :     }
280 :     }
281 :    
282 :     ##NOTE : ROWINFO HAS MARGINS INCLUDED
283 :    
284 :     # we want to find the absolute starts and stops for each row
285 :     # print out the saved information
286 :     for (my $i=0; $i <= $self->{'rowcount'}; $i++) {
287 :     foreach my $c (keys %{$self->{'rowinfo'}->{$i}}) {
288 :     if (!defined $absorow->{$i}->{'start'} || $absorow->{$i}->{'start'} > $self->{'rowinfo'}->{$i}->{$c}->{'start'})
289 :     {$absorow->{$i}->{'start'} = $self->{'rowinfo'}->{$i}->{$c}->{'start'}}
290 :     if (!defined $absorow->{$i}->{'end'} || $absorow->{$i}->{'end'} < $self->{'rowinfo'}->{$i}->{$c}->{'end'})
291 :     {$absorow->{$i}->{'end'} = $self->{'rowinfo'}->{$i}->{$c}->{'end'}}
292 :     }
293 :     }
294 :    
295 :    
296 :     ### Define the rows
297 :     for (my $row=0; $row <=$self->{'rowcount'}; $row++) {
298 :     my $transform=$row * (((scalar keys %{$self->{'trackposn'}}) * $self->{'box_height'} * 3) + $self->{'top_marg'} + $self->{'bot_marg'});
299 :     my $xtrans=$absorow->{$row}->{'start'} - $self->{'margin'};
300 :     $self->{'rowgroup'}->{$row}=$self->{'svg'}->group(id=>"row_$row", transform=>"translate(-$xtrans, $transform)");
301 : redwards 1.2
302 : redwards 1.1 # add genome labels to the rows
303 :     foreach my $simgen (keys %{$self->{'trackposn'}}) {
304 :     $self->{'rowgroup'}->{$row}->text(id=>"${simgen}_${row}_label", x=>$xtrans, y=>$self->{'trackposn'}->{$simgen}, textLength=>100, lengthAdjust=>"spacingAndGlyphs",
305 :     style=>{'font-family'=>"Helvetica", 'font-size'=>"10", fill=>"black",})->cdata($self->{'label'}->{$simgen});
306 :     }
307 :     }
308 :     } # end _scale_image
309 :    
310 :     =head1 _draw_genome
311 :    
312 :     An internal method to draw the genome that we are comparing to, and to define the locations of the pegs (perhaps)
313 :    
314 :     args: none
315 :     returns: none
316 :    
317 :     =cut
318 :    
319 :     sub _draw_image {
320 :     my ($self)=@_;
321 :     $self->{'drawn'}=1;
322 :     my $defs=$self->{'track'}->{$self->{'genome'}}->defs;
323 :     my $time=time; my $pegcount;
324 :     foreach my $peg ($fig->pegs_of($self->{'genome'})) {
325 :     $pegcount++;
326 :     last if ($self->{'stopshort'} && $self->{'stopshort'} == $pegcount);
327 :     # Define the location of the box once per peg
328 :     # also use this to figure out which row to add it to
329 :     my @loc=$fig->feature_location($peg);
330 :     $loc[0] =~ m/^(.*)\_(\d+)\_(\d+)$/;
331 :     my ($contig, $start, $stop)=($1, $2, $3);
332 :     my $len=$stop-$start;
333 :    
334 :     # if the orf is in the same direction want the sim on top, if not want it below
335 :     my $x=$self->{'xoffset'}->{$contig} + (($start/$self->{'totallen'}) * $self->{'xmultiplier'});
336 :     my $boxwidth = (abs($stop-$start)/$self->{'totallen'})*$self->{'xmultiplier'};
337 :    
338 :     # figure out the correct row for the current location. The row is after we have split up the genome
339 :     my $row;
340 :     foreach my $addrow (@{$self->{'contigrows'}->{$contig}}) {
341 :     if ($x >= $self->{'rowinfo'}->{$addrow}->{$contig}->{'start'} && $x < $self->{'rowinfo'}->{$addrow}->{$contig}->{'end'}) {$row=$addrow; last}
342 :     }
343 :     unless (defined $row) {
344 :     print STDERR "Couldn't get a row for $contig looking for a start of $x (real start: $start). These are the starts:\n";
345 :     print STDERR "These are the contigrows: ", join " ", @{$self->{'contigrows'}->{$contig}}, "\n";
346 :     print STDERR map {"$_: " . $self->{'rowinfo'}->{$_}->{$contig}->{'start'} . "\n"} @{$self->{'contigrows'}->{$contig}};
347 :     print STDERR "These are the stops\n";
348 :     print STDERR map {"$_: " . $self->{'rowinfo'}->{$_}->{$contig}->{'end'} . "\n"} @{$self->{'contigrows'}->{$contig}};
349 :     print STDERR "\n";
350 :     exit -1;
351 :     }
352 :    
353 :     # show the function if we are supposed to
354 : redwards 1.4 if ($self->{'show_function'} && !($pegcount % $self->{'show_function'})) {$self->_add_functions($defs, $peg, $x, $boxwidth, $row)}
355 : redwards 1.1
356 :    
357 :     # add a tick mark for the peg
358 :     my $sl=$self->{'trackposn'}->{$self->{'genome'}}-$self->{'tick_mark_height'}; # start line
359 :     my $el=$self->{'trackposn'}->{$self->{'genome'}}+$self->{'tick_mark_height'}; # end line
360 :     $self->{'rowgroup'}->{$row}->line(x1=>$x, x2=>$x, y1=>$sl, y2=>$el);
361 :     $self->{'rowgroup'}->{$row}->line(x1=>$x+$boxwidth, x2=>$x+$boxwidth, y1=>$sl, y2=>$el);
362 :    
363 :    
364 :     #if we want the empty boxes draw them first and then the color thing will overwrite.
365 :     if ($self->{'box_no_score'}) {
366 :     foreach my $simgen (keys %{$self->{'trackposn'}}) {
367 :     my $y=$self->{'trackposn'}->{$simgen};
368 :     if ($start > $stop) {$y-=$self->{'box_height'}}
369 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
370 :     width=>$boxwidth, id=>"${peg}_$y", style => {stroke => "rgb(0,0,0)", fill => "none"});
371 :     }
372 :     }
373 :    
374 :     # now for each peg we need to figure out what we need to add
375 : redwards 1.3 # figure out the strand
376 :     my $comp=0;
377 :     if ($self->{'twostrands'} && $start > $stop) {$comp=1}
378 : redwards 1.1 foreach my $match (@{$self->compareto()}) {
379 : redwards 1.3 next unless ($match);
380 :     if (ref($match) eq "ARRAY" && $match->[0] eq "tagvalue") {
381 :     # deal with tag value pairs
382 :     $self->_plot_tag_value($peg, $x, $boxwidth, $row, $comp, $match);
383 :     }
384 :     elsif ($match =~ /^\d+\.\d+/) {
385 : redwards 1.1 # it is a genome
386 :     $self->_plot_sims($peg, $x, $boxwidth, $row, $match, $comp);
387 :     }
388 :     else {
389 :     print STDERR "No support for matches to $match yet\n";
390 :     }
391 :     }
392 :     }
393 :     }
394 :    
395 :    
396 :     =head2 _add_functions
397 :    
398 :     An internal method to add the functions to the image.
399 :     Args: definitions (defs), peg, position (x) where to add the text, box width, row (y group) to add the text
400 :     Returns: None
401 :    
402 :     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.
403 :     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
404 :     and we rotate it by 45 degrees. Then we put the text onto that path we have just created. Neato, huh?
405 :    
406 :     =cut
407 :    
408 :     sub _add_functions {
409 :     my ($self, $defs, $peg, $position, $boxwidth, $row)=@_;
410 :     return unless ($self->{'show_function'});
411 :     my $funclocx=$position+($boxwidth/2); # this should be the middle of the box?
412 :     my $funclocy=$self->{'trackposn'}->{$self->{'genome'}}-2;
413 :     my $funcendx=$self->{'effectivewidth'}+$funclocx; # this doesn't matter it just needs to be off the image!
414 :     $defs->path(id=>"${peg}_line", d=>"M $funclocx $funclocy L $funcendx $funclocy", transform=>"rotate(-45, $funclocx $funclocy)");
415 :    
416 :    
417 :     # now just add the text as a textPath
418 :     $self->{'rowgroup'}->{$row}->text(style=>{'font-family'=>"Helvetica, sans-serif", 'font-size'=>"2", fill=>"black",})
419 :     ->textPath(id=>"${peg}_function", '-href'=>"#${peg}_line")
420 :     ->cdata(scalar $fig->function_of($peg));
421 :     }
422 :    
423 :    
424 : redwards 1.3 =head2 _plot_tag_value
425 :    
426 :     An internal method to plot tag value pairs.
427 :     Takes the following as arguments:
428 :     peg, position (x) where to draw the box, width of the box to draw, row (y group) , flag for whether to put below the line (complement essentially),
429 :     and then a reference to the tagvalue pairs
430 :    
431 :     The last element must be a reference to an array with the following four items:
432 :     'tagvalue' (ignored - just a boolean for this)
433 :     'tag' -- tag that is used for the plot
434 :     'minimum' -- optional, if supplied minimum cutoff
435 :     'maximum' -- optional, if supplied maximum cutoff
436 :    
437 :     =cut
438 :    
439 :     sub _plot_tag_value {
440 :     my ($self, $peg, $x, $boxwidth, $row, $comp, $tv)=@_;
441 :     my $y=$self->{'trackposn'}->{$tv->[1]};
442 :     if ($comp) {$y-=$self->{'box_height'}}
443 :     my $min=$tv->[2] if ($tv->[2]);
444 :     my $max=$tv->[3] if ($tv->[3]);
445 : redwards 1.4
446 : redwards 1.3 my @attr = $fig->feature_attributes($peg);
447 :     if (@attr > 0) {
448 :     foreach $_ (@attr) {
449 : redwards 1.5 next if ($self->{'addedtv'}->{$tv->[1].$peg}); # specifically avoid dups with tag/value pairs
450 :     $self->{'addedtv'}->{$tv->[1].$peg}=1;
451 : redwards 1.3 my($tag,$val,$url) = @$_;
452 : redwards 1.5 next unless (lc($tag) eq lc($tv->[1]));
453 : redwards 1.4
454 : redwards 1.3 # we are going to test if it is a number. If it is not a number, we don't want to check min/max
455 :     my $number=1;
456 :     eval {
457 :     use warnings; # make sure we warn
458 :     local $SIG{__WARN__} = sub {die $_[0]}; # die if there is a warning
459 :     $val+=0; # generate the warning
460 :     };
461 :     undef $number if ($@);
462 :    
463 :     next if ($number && $min && $val < $min);
464 :     next if ($number && $max && $val > $max);
465 :     # 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
466 :     # so we'll let people supply it.
467 :     my @color=(0,1,1); # maybe 1,1,1?
468 :     if ($number) {
469 :     @color=map {int(255 * $_)} my_color($number * $self->{'scale'}->{$tv->[1]});
470 :     }
471 :     if ($self->{'bluescale'}) {($color[0], $color[3])=($color[3], $color[0])}
472 :     if ($self->{'box_score'}) {
473 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
474 :     width=>$boxwidth, id=>$tv->[1].$peg, style => {stroke => "rgb(0,0,0)", fill => "rgb(@color)"});
475 :     } else {
476 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
477 :     width=>$boxwidth, id=>$tv->[1].$peg, style => {stroke => "none", fill => "rgb(@color)"});
478 :     }
479 :     }
480 :     }
481 :     }
482 :    
483 :    
484 :    
485 : redwards 1.1 =head2 _plot_sims
486 :    
487 :     An internal method to add the similarities to the image
488 :     Args: peg, position (x) where to add the text, width of the box to draw, row (y group) to add the text,
489 :     genome to compare to, flag for whether to put below the line (complement essentially)
490 :     Returns: None
491 :    
492 :     =cut
493 :    
494 :    
495 :     sub _plot_sims {
496 :     ##### PLOT SIMS #####
497 :     # find the sims for the genomes that we need
498 :     my ($self, $peg, $x, $boxwidth, $row, $simgen, $comp)=@_;
499 :     my %seensims; # genomes we have seen sims from for this peg. So we only get the best hit
500 : redwards 1.3 foreach my $sim ($fig->sims($peg, $self->{'maxn'}, $self->{'maxp'}, 'fig')) {
501 : redwards 1.1 next unless ($fig->genome_of($$sim[1]) == $simgen && defined $self->{'trackposn'}->{$fig->genome_of($$sim[1])});
502 :     # figure out the y posn
503 :     my $y=$self->{'trackposn'}->{$simgen};
504 :     if ($comp) {$y-=$self->{'box_height'}}
505 :     # now we just need to color based on the sim
506 :     my @color=map {int(255 * $_)} my_color($$sim[2]); # this will adjust it for rgb 0-255
507 :     # 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
508 :     # (though not down in the dumps, I just like the color blue)
509 :     # swap r and b, leave g the same
510 : redwards 1.3 if ($self->{'bluescale'}) {($color[0], $color[3])=($color[3], $color[0])}
511 : redwards 1.1
512 :     #now we need to make a box:
513 :     #x from $x length $boxwidth
514 :     #y from $y length $boxheight
515 :     #color is in @{$colorgenome->{$fig->genome_of($$sim[1])}}
516 :     if ($self->{'box_score'}) {
517 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
518 :     width=>$boxwidth, id=>$$sim[1].$peg, style => {stroke => "rgb(0,0,0)", fill => "rgb(@color)"});
519 :     } else {
520 :     $self->{'rowgroup'}->{$row}->rect(x=>$x, y=>$y, height=>$self->{'box_height'},
521 :     width=>$boxwidth, id=>$$sim[1].$peg, style => {stroke => "none", fill => "rgb(@color)"});
522 :     }
523 :     }
524 :     # 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)
525 :     }
526 :    
527 :    
528 :    
529 :     =head2 _hz_lines
530 :    
531 :     An internal method to add horizontal lines to an image where the genomes are
532 :     Args: None
533 :     Returns: None
534 :    
535 :     =cut
536 :    
537 :    
538 :     sub _hz_lines {
539 :     my ($self)=@_;
540 :     for (my $row=0; $row <= $self->{'rowcount'}; $row++) {
541 :     foreach my $contig (keys %{$self->{'rowinfo'}->{$row}}) {
542 :     my ($start, $end)=($self->{'rowinfo'}->{$row}->{$contig}->{'start'}, $self->{'rowinfo'}->{$row}->{$contig}->{'end'});
543 :     foreach my $simgen (keys %{$self->{'trackposn'}}) {
544 :     $self->{'rowgroup'}->{$row}->line(id=>"line_${simgen}_${contig}_$row",
545 :     x1=>$start, x2=>$end, y1=>$self->{'trackposn'}->{$simgen}, y2=>$self->{'trackposn'}->{$simgen});
546 :     }
547 :     }
548 :     }
549 :     }
550 :    
551 :    
552 :    
553 :     #### COLORS.
554 :     #
555 :     # This has been stolen from protein.cgi written by Gary because I don't
556 :     # understand enough about colors
557 :    
558 :     sub my_color {
559 :     my $percent=shift;
560 :     return (255,255,255) unless ($percent);
561 :     $percent=1-$percent/100; # we want the more similar ones to be darker
562 :     my $hue = 5/6 * $percent - 1/12;
563 :     my $sat = 1 - 10 * $percent / 9;
564 :     my $br = 1;
565 :     return hsb2rgb( $hue, $sat, $br );
566 :     }
567 :    
568 :     #
569 :     # Convert HSB to RGB. Hue is taken to be in range 0 - 1 (red to red);
570 :     #
571 :    
572 :     sub hsb2rgb {
573 :     my ( $h, $s, $br ) = @_;
574 :     $h = 6 * ($h - floor($h)); # Hue is made cyclic modulo 1
575 :     if ( $s > 1 ) { $s = 1 } elsif ( $s < 0 ) { $s = 0 }
576 :     if ( $br > 1 ) { $br = 1 } elsif ( $br < 0 ) { $br = 0 }
577 :     my ( $r, $g, $b ) = ( $h <= 3 ) ? ( ( $h <= 1 ) ? ( 1, $h, 0 )
578 :     : ( $h <= 2 ) ? ( 2 - $h, 1, 0 )
579 :     : ( 0, 1, $h - 2 )
580 :     )
581 :     : ( ( $h <= 4 ) ? ( 0, 4 - $h, 1 )
582 :     : ( $h <= 5 ) ? ( $h - 4, 0, 1 )
583 :     : ( 1, 0, 6 - $h )
584 :     );
585 :     ( ( $r * $s + 1 - $s ) * $br,
586 :     ( $g * $s + 1 - $s ) * $br,
587 :     ( $b * $s + 1 - $s ) * $br
588 :     )
589 :     }
590 :    
591 :     sub floor {
592 :     my $x = $_[0];
593 :     defined( $x ) || return undef;
594 :     ( $x >= 0 ) || ( int($x) == $x ) ? int( $x ) : -1 - int( - $x );
595 :     }
596 :    
597 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3