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

Annotation of /FigKernelPackages/raedraw.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3