[Bio] / FigWebServices / sgv.cgi Repository:
ViewVC logotype

Annotation of /FigWebServices/sgv.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (view) (download)

1 : overbeek 1.1 # -*- perl -*-
2 :     #
3 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
4 :     # for Interpretations of Genomes. All Rights Reserved.
5 :     #
6 :     # This file is part of the SEED Toolkit.
7 :     #
8 :     # The SEED Toolkit is free software. You can redistribute
9 :     # it and/or modify it under the terms of the SEED Toolkit
10 :     # Public License.
11 :     #
12 :     # You should have received a copy of the SEED Toolkit Public License
13 :     # along with this program; if not write to the University of Chicago
14 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
15 :     # Genomes at veronika@thefig.info or download a copy from
16 :     # http://www.theseed.org/LICENSE.TXT.
17 :     #
18 :    
19 :     use SeedHTML;
20 :     use strict;
21 :     use SeedEnv;
22 :     use SeedV;
23 :     use ProtSims;
24 :     use GenoGraphics;
25 :    
26 :     use CGI;
27 :     my $cgi = new CGI;
28 :    
29 : olson 1.8 $GenoGraphics::image_type = "png";
30 :     $GenoGraphics::image_suffix = "png";
31 :     $GenoGraphics::temp_url = "/FIG-Tmp";
32 :     #print STDERR "$_ = $ENV{$_}\n" for sort keys %ENV;
33 :    
34 : overbeek 1.1 if (0)
35 :     {
36 :     my $VAR1;
37 :     eval(join("",`cat /tmp/sgv_parms`));
38 :     $cgi = $VAR1;
39 :     # print STDERR &Dumper($cgi);
40 :     }
41 :    
42 :     if (0)
43 :     {
44 :     print $cgi->header;
45 :     my @params = $cgi->param;
46 :     print "<pre>\n";
47 :     foreach $_ (@params)
48 :     {
49 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
50 :     }
51 :    
52 :     if (0)
53 :     {
54 :     if (open(TMP,">/tmp/sgv_parms"))
55 :     {
56 :     print TMP &Dumper($cgi);
57 :     close(TMP);
58 :     }
59 :     }
60 :     exit;
61 :     }
62 :    
63 : olson 1.8
64 : overbeek 1.1 my $html = [];
65 :     unshift @$html, "<TITLE>Simple Genome Viewer</TITLE>\n";
66 :    
67 :     my $dir = $cgi->param('dir');
68 :     if ((! $dir) || ($dir !~ /\d+\.\d+$/))
69 :     {
70 :     push(@$html,$cgi->h2('You must set dir= to a SEED-format genome directory with a path ending in the genome ID'));
71 :     &SeedHTML::show_page($cgi,$html);
72 :     exit;
73 :     }
74 :    
75 :     my $request = $cgi->param('request');
76 :     if (! $request)
77 :     {
78 :     &start_computing_reference_genome_set($cgi,$dir,$html);
79 :     &make_subsystem_index($cgi,$html,$dir);
80 :     &basic_query($cgi,$html);
81 :     }
82 :     elsif ($request eq 'basic')
83 :     {
84 :     &basic_query($cgi,$html);
85 :     }
86 :     elsif ($request eq 'id')
87 :     {
88 :     &process_id($cgi,$html);
89 :     }
90 :     elsif ($request eq 'features')
91 :     {
92 :     &process_feature_search($cgi,$html);
93 :     }
94 :     elsif ($request eq 'feature')
95 :     {
96 :     &process_feature_display($cgi,$html);
97 :     }
98 :     elsif ($request eq 'subsystems')
99 :     {
100 :     &process_subsystems_search($cgi,$html);
101 :     }
102 :     elsif ($request eq 'peg2subsystems')
103 :     {
104 :     &process_peg2subsystems_search($cgi,$html);
105 :     }
106 :     elsif ($request eq 'compare')
107 :     {
108 :     &comparison($cgi,$html);
109 :     }
110 :     elsif ($request eq 'corresponding')
111 :     {
112 :     &process_corr_search($cgi,$html);
113 :     }
114 :     elsif ($request =~ 'query_only')
115 :     {
116 :     &process_query_only_search($cgi,$html);
117 :     }
118 :     elsif ($request eq 'reference_only')
119 :     {
120 :     &process_ref_only_search($cgi,$html);
121 :     }
122 :    
123 :     &SeedHTML::show_page($cgi,$html);
124 :    
125 :    
126 :     sub make_subsystem_index {
127 :     my($cgi,$html,$dir) = @_;
128 :    
129 : overbeek 1.6 my %ss = map { chomp; my($subsys,$var) = split(/\t/,$_); (($var ne "-1") && ($var ne 0)) ? (&fix_ss($subsys) => $var) : () }
130 : overbeek 1.1 `cat $dir/Subsystems/subsystems`;
131 :    
132 :     my $sapObject = SAPserver->new;
133 :     my $ssH = $sapObject->classification_of( -ids => [keys(%ss)]);
134 :     open(INDEX,"| sort > $dir/Subsystems/subsystems.index") || die "could not open $dir/Subsystems/subsystems.index";
135 :     foreach $_ (`cat $dir/Subsystems/bindings`)
136 :     {
137 :     chomp;
138 :     my($subsys,$role,$peg) = split(/\t/,$_);
139 : overbeek 1.6 $subsys = &fix_ss($subsys);
140 : overbeek 1.3 if ($ss{$subsys})
141 :     {
142 :     my $class = ($_ = $ssH->{$subsys}) ? join("; ",@$_) : "";
143 :     print INDEX join("\t",($class,$subsys,$role,$ss{$subsys},$peg)),"\n";
144 :     }
145 : overbeek 1.1 }
146 :     close(INDEX);
147 :     }
148 :    
149 :     sub id_search_form {
150 :     my($cgi,$dir,$html) = @_;
151 :    
152 :     my $queryG = $cgi->param('genome');
153 : parrello 1.7 push(@$html,$cgi->start_form(), # -action => "sgv.cgi"),
154 : overbeek 1.1 '<br><b>Get Protein Page for FIG ID, or ACH Page for non-FIG IDs</b><br><br> ',
155 :     $cgi->textfield(-name => 'id', -size => 20),
156 :     $cgi->submit('go'),
157 :     $cgi->hidden(-name => 'request', -value => 'id', -override => 1),
158 :     $cgi->hidden(-name => 'dir', -value => $dir, -override => 1),
159 :     $cgi->end_form,
160 :     $cgi->hr,$cgi->hr);
161 :     }
162 :    
163 :     sub start_computing_reference_genome_set {
164 :     my($cgi,$dir,$html) = @_;
165 :    
166 :     if (! -d "$dir/CorrToReferenceGenomes")
167 :     {
168 : parrello 1.7 my $rc = system "$FIG_Config::bin/get_neighbors_and_corr_to_ref $dir &";
169 : overbeek 1.1 }
170 :     }
171 :    
172 :     sub basic_query {
173 :     my($cgi,$html) = @_;
174 :    
175 :     my $queryG = $cgi->param('genome');
176 :     my $dir = $cgi->param('dir');
177 :    
178 :     &id_search_form($cgi,$dir,$html);
179 :    
180 : parrello 1.7 push(@$html,$cgi->start_form(), # -action => "sgv.cgi"),
181 : overbeek 1.1 '<b>Query Features in Genome</b>: ',
182 :     $cgi->textfield(-name => 'pattern', -size => 30),
183 :     $cgi->submit('go'),
184 :     $cgi->hidden(-name => 'request', -value => 'features', -override => 1),
185 :     $cgi->hidden(-name => 'dir', -value => $dir, -override => 1),
186 :     $cgi->end_form,
187 :     $cgi->hr,
188 :    
189 : parrello 1.7 $cgi->start_form(), # -action => "sgv.cgi"),
190 : overbeek 1.1 '<b>Query Subsystems in Genome</b>: ',
191 :     $cgi->textfield(-name => 'pattern', -size => 30),
192 :     $cgi->submit('go'),
193 :     $cgi->hidden(-name => 'request', -value => 'subsystems', -override => 1),
194 :     $cgi->hidden(-name => 'dir', -value => $dir, -override => 1),
195 :     $cgi->end_form,
196 :     $cgi->hr
197 :     );
198 :    
199 :     my $cache = "$dir/CorrToReferenceGenomes";
200 : overbeek 1.6 my @refG;
201 :     if (opendir(CACHE,$cache))
202 :     {
203 :     @refG = map { ((-s "$cache/$_") && ($_ =~ /^(\d+\.\d+$)/)) ? $1 : () } readdir(CACHE);
204 :     closedir(CACHE);
205 :     }
206 :     else
207 :     {
208 :     @refG = ();
209 :     }
210 : overbeek 1.1
211 :     if (@refG > 0)
212 :     {
213 :     my $sapObject = SAPserver->new();
214 :     my($refG,$labels) = &build_labels(\@refG,$sapObject);
215 :    
216 : parrello 1.7 push(@$html,$cgi->start_form(), # -action => "sgv.cgi"),
217 : overbeek 1.1 '<b>Compare Genome Against Reference Genome</b>: ',
218 :     $cgi->scrolling_list( -name => 'reference',
219 :     -values => $refG,
220 :     -labels => $labels,
221 :     -size => 4),
222 :     $cgi->submit('go'),
223 :     $cgi->hidden(-name => 'request', -value => "compare", -override => 1),
224 :     $cgi->hidden(-name => 'dir', -value => $dir, -override => 1),
225 :     $cgi->end_form
226 :     );
227 :     }
228 :     }
229 :    
230 :     sub build_labels {
231 :     my($genomes,$sapObject) = @_;
232 :    
233 :     my $genomesH = $sapObject->all_genomes(-complete => 1);
234 :     my $metricsH = $sapObject->genome_metrics(-ids => $genomes);
235 :     my %labels = map { my($contigs,$sz) = @{$metricsH->{$_}};
236 :     my $lab = $genomesH->{$_} . " ($_): $sz bp, $contigs contigs";
237 :     $_ => $lab
238 :     }
239 :     @$genomes;
240 :    
241 :     my @genomes = sort { lc($labels{$a}) cmp lc($labels{$b}) } @$genomes;
242 :    
243 :     return (\@genomes,\%labels);
244 :     }
245 :    
246 :     sub process_feature_search {
247 :     my($cgi,$html) = @_;
248 :    
249 :     my $pattern = $cgi->param('pattern');
250 :     my $dir = $cgi->param('dir');
251 :     my $file = "$dir/assigned_functions";
252 :     my @hits = &process_index($file,$pattern);
253 :     &format_function_table($cgi,$html,\@hits);
254 :     }
255 :    
256 :     sub process_subsystems_search {
257 :     my($cgi,$html) = @_;
258 :    
259 :     my $pattern = $cgi->param('pattern');
260 :     my $dir = $cgi->param('dir');
261 :     my $file = "$dir/Subsystems/subsystems.index";
262 :     my @hits = &process_index($file,$pattern);
263 :     &format_subsystems_table($cgi,$html,\@hits);
264 :     }
265 :    
266 :     sub process_peg2subsystems_search {
267 :     my($cgi,$html) = @_;
268 :    
269 :     my $peg = $cgi->param('peg');
270 :     my $dir = $cgi->param('dir');
271 :     my $file = "$dir/Subsystems/subsystems.index";
272 :     my %subs = map { $_->[1] => 1 } &process_index($file,$peg);
273 :     my @hits = sort { ($a->[0] cmp $b->[0]) or ($a->[1] cmp $b->[1]) or ($a->[2] cmp $b->[2])
274 :     or &SeedUtils::by_fig_id($a->[4],$b->[4]) }
275 :     map { chop; [split(/\t/,$_)] }
276 :     grep { ($_ =~ /^[^\t]*\t([^\t]+)/) && $subs{$1} }
277 :     `cat $file`;
278 :     &format_subsystems_table($cgi,$html,\@hits);
279 :     }
280 :    
281 :     sub comparison {
282 :     my($cgi,$html) = @_;
283 :    
284 :     my $refG = $cgi->param('reference');
285 :     my $queryG = $cgi->param('genome');
286 :     my $dir = $cgi->param('dir');
287 : parrello 1.7 push(@$html,$cgi->start_form(), # -action => "sgv.cgi"),
288 : overbeek 1.1 '<b>Corresponding Features</b>: ',
289 :     $cgi->textfield(-name => 'pattern', -size => 30),
290 :     $cgi->submit('go'),
291 :     $cgi->hidden(-name => 'request', -value => 'corresponding', -override => 1),
292 :     $cgi->hidden(-name => 'dir', -value => $dir, -override => 1),
293 :     $cgi->hidden(-name => 'reference', -value => $refG, -override => 1),
294 :     $cgi->end_form,
295 :     $cgi->hr,
296 :    
297 : parrello 1.7 $cgi->start_form(), # -action => "sgv.cgi"),
298 : overbeek 1.1 '<b>Features in Query, but Not Reference</b>: ',
299 :     $cgi->textfield(-name => 'pattern', -size => 30),
300 :     $cgi->submit('go'),
301 :     $cgi->hidden(-name => 'request', -value => 'query_only', -override => 1),
302 :     $cgi->hidden(-name => 'dir', -value => $dir, -override => 1),
303 :     $cgi->hidden(-name => 'reference', -value => $refG, -override => 1),
304 :     $cgi->end_form,
305 :     $cgi->hr,
306 :    
307 : parrello 1.7 $cgi->start_form(), # -action => "sgv.cgi"),
308 : overbeek 1.1 '<b>Features in Reference, but Not Query</b>: ',
309 :     $cgi->textfield(-name => 'pattern', -size => 30),
310 :     $cgi->submit('go'),
311 :     $cgi->hidden(-name => 'request', -value => 'reference_only', -override => 1),
312 :     $cgi->hidden(-name => 'dir', -value => $dir, -override => 1),
313 :     $cgi->hidden(-name => 'reference', -value => $refG, -override => 1),
314 :     $cgi->end_form,
315 :     $cgi->hr
316 :     );
317 :     }
318 :    
319 :     sub process_corr_search {
320 :     my($cgi,$html) = @_;
321 :    
322 :     my $pattern = $cgi->param('pattern');
323 :     my $dir = $cgi->param('dir');
324 :     my $refG = $cgi->param('reference');
325 : overbeek 1.5 my $refGgs = &genus_species($refG);
326 : overbeek 1.1 my $genome = $cgi->param('genome');
327 :     my $file = "$dir/CorrToReferenceGenomes/$refG";
328 :     my @corr = sort { &SeedUtils::by_fig_id($a->[0],$b->[0]) }
329 :     map { chomp; [split(/\t/,$_)] } `cat $file`;
330 :    
331 :     my @genes = map { ($_->[0],$_->[1]) } @corr;
332 :     my $col_headings = ['PEG','Function','reference','Reference Function','P-sc',
333 :     'BBH','Context-Matches','AliasesR'];
334 :     my $tab = [];
335 :     foreach my $entry (@corr)
336 :     {
337 :     my($pegG,$pegR,$n_context,undef,$funcG,$funcR,$aliasesG,$aliasesR,$bbh,undef,$psc) = @$entry;
338 :    
339 :     push(@$tab,[&peg_link($cgi,$pegG),$funcG,&ref_peg_link($cgi,$pegR),$funcR,
340 :     $psc,$bbh,$n_context,$aliasesR]);
341 :     }
342 :     my $filtered = &filter_tab_entries($tab,$pattern);
343 : overbeek 1.5 push(@$html,&SeedHTML::make_table($col_headings,$filtered,"Correspondences with $refGgs"));
344 : overbeek 1.1 }
345 :    
346 :     sub process_query_only_search {
347 :     my($cgi,$html) = @_;
348 :    
349 :     my $pattern = $cgi->param('pattern');
350 :     my $dir = $cgi->param('dir');
351 :     my $refG = $cgi->param('reference');
352 : overbeek 1.5 my $refGgs = &genus_species($refG);
353 : overbeek 1.1 my $queryG = $cgi->param('genome');
354 :     my $file = "$dir/CorrToReferenceGenomes/$refG";
355 :     my %in_corr = map { $_ =~ /^(\S+)/; $1 => 1 } `cat $file`;
356 :    
357 :     my @to_show = grep { ! $in_corr{$_} }
358 :     map { $_ =~ /^(\S+)/; $1 }
359 :     `cut -f1 $dir/Features/peg/tbl`;
360 :     my %functionsH = map { $_ =~ /^(\S+)\t(\S.*\S)/; $1 => $2 } `cat $dir/assigned_functions`;
361 :     my $col_hdrs = ["PEG","Function"];
362 :     my @tab = map { [&peg_link($cgi,$_),$functionsH{$_} ? $functionsH{$_} : ""] }
363 :     sort { &SeedUtils::by_fig_id($a,$b) } @to_show;
364 :     my $filtered = &filter_tab_entries(\@tab,$pattern);
365 : overbeek 1.5 if (@$filtered > 0)
366 :     {
367 :     push(@$html,&SeedHTML::make_table($col_hdrs,$filtered,"Genes Missing in Reference Genome $refGgs"));
368 :     }
369 :     else
370 :     {
371 :     push(@$html,$cgi->h2('No Genes Found only in the Given Genome'));
372 :     }
373 : overbeek 1.1 }
374 :    
375 :     sub process_ref_only_search {
376 :     my($cgi,$html) = @_;
377 :    
378 :     my $pattern = $cgi->param('pattern');
379 :     my $dir = $cgi->param('dir');
380 :     my $refG = $cgi->param('reference');
381 : overbeek 1.5 my $refGgs = &genus_species($refG);
382 :    
383 : overbeek 1.1 my $queryG = $cgi->param('genome');
384 :     my $file = "$dir/CorrToReferenceGenomes/$refG";
385 :    
386 :     my %in_ref = map { $_ =~ /^\S+\t(\S+)/; $1 => 1 } `cat $file`;
387 :    
388 :     my $sapObject = SAPserver->new();
389 :     my $genomeH = $sapObject->all_features(-ids => [$refG], -type => 'peg');
390 :     my @to_show = grep { ! $in_ref{$_} } @{$genomeH->{$refG}};
391 :    
392 :     my $functionsH = $sapObject->ids_to_functions(-ids => \@to_show);
393 :     my $col_hdrs = ["PEG","Function"];
394 :     my @tab = map { [&ref_peg_link($cgi,$_),$functionsH->{$_} ? $functionsH->{$_} : ""] }
395 :     sort { &SeedUtils::by_fig_id($a,$b) } @to_show;
396 :     my $filtered = &filter_tab_entries(\@tab,$pattern);
397 : overbeek 1.5 if (@$filtered > 0)
398 :     {
399 :     push(@$html,&SeedHTML::make_table($col_hdrs,$filtered,"Genes Present Only in Reference Genome $refGgs"));
400 :     }
401 :     else
402 :     {
403 :     push(@$html,$cgi->h2('No Genes Found only in $refGgs'));
404 :     }
405 :     }
406 :    
407 :     sub genus_species {
408 :     my($g) = @_;
409 :    
410 :     my $sapO = SAPserver->new;
411 :     my $gH = $sapO->genome_names( -ids => $g);
412 :     return $gH->{$g};
413 : overbeek 1.1 }
414 :    
415 :     sub process_index {
416 :     my($file,$pattern) = @_;
417 :    
418 :     my @lines = `cat $file`;
419 :     if ( ! $pattern)
420 :     {
421 :     return map { chop; [split(/\t/,$_)] } @lines;
422 :     }
423 :     elsif ($pattern =~ /^\s*\/(.*)\/\s*$/)
424 :     {
425 :     return &perl_patmatch(\@lines,$1);
426 :     }
427 :     else
428 :     {
429 :     return &substr_match(\@lines,$pattern);
430 :     }
431 :     }
432 :    
433 :     sub perl_patmatch {
434 :     my($lines,$pat) = @_;
435 :    
436 :     my @lines = grep { $_ =~ /$pat/i } @$lines;
437 :     return map { chop; [split(/\t/,$_)] } @lines;
438 :     }
439 :    
440 :     sub substr_match {
441 :     my($lines,$pat) = @_;
442 :    
443 :     $pat =~ s/^\s+//;
444 :     $pat =~ s/\s+$//;
445 :     my @words = split(/\s+/,$pat);
446 :     my @lines = @$lines;
447 :     foreach my $word (@words)
448 :     {
449 :     @lines = grep { &matchword($word,$_) } @lines;
450 :     }
451 :     return map { chop; [split(/\t/,$_)] } @lines;
452 :     }
453 :    
454 :     sub matchword {
455 :     my($word,$str) = @_;
456 :    
457 :     my $wordL = lc $word;
458 :     my $strL = lc $str;
459 :     if (index($strL,$wordL) >= 0)
460 :     {
461 :     if ($wordL =~ /^fig\|\d+\.\d+\.peg\.\d+$/i)
462 :     {
463 :     my $wordQ = quotemeta $wordL;
464 :     return ($strL =~ /$wordQ\b/);
465 :     }
466 :     return 1;
467 :     }
468 :     return 0;
469 :     }
470 :    
471 :     sub format_function_table {
472 :     my($cgi,$html,$entries) = @_;
473 :    
474 :     my $col_hdrs = ['ID','Type','Function','Psi-blast','Subsystems'];
475 :     my $tab = [];
476 :    
477 :     foreach my $entry (@$entries)
478 :     {
479 :     my($fid,$function) = @$entry;
480 :     $fid =~ /fig\|\d+\.\d+\.([^\.]+)\.\d+$/;
481 :     my $type = $1;
482 :     if ($type eq "peg")
483 :     {
484 :     push(@$tab,[
485 :     &comp_reg_link($fid,$cgi),
486 :     'peg',
487 :     $function,
488 :     &psi_blast_link($fid),
489 :     &subsys_link($cgi,$fid)
490 :     ]);
491 :     }
492 :     else
493 :     {
494 :     push(@$tab,[$fid,$type,$function,"",""]);
495 :     }
496 :     }
497 :    
498 :     if (@$tab > 0)
499 :     {
500 :     push(@$html,&SeedHTML::make_table($col_hdrs,$tab,"Features"));
501 :     }
502 :     else
503 :     {
504 :     push(@$html,$cgi->h3('no matches'));
505 :     }
506 :     push(@$html,$cgi->hr,&query_link($cgi));
507 :     }
508 :    
509 :     sub format_subsystems_table {
510 :     my($cgi,$html,$entries) = @_;
511 :    
512 :     my $col_hdrs = ['Classification','Subsystem','Role','Variant','PEG'];
513 :     my $tab = [];
514 :    
515 :     foreach my $entry (@$entries)
516 :     {
517 :     my($class,$subsys,$role,$variant,$peg) = @$entry;
518 :     push(@$tab,[
519 :     $class,
520 : overbeek 1.6 &fix_ss($subsys),
521 : overbeek 1.1 $role,
522 :     $variant,
523 :     &peg_link($cgi,$peg)
524 :     ]);
525 :     }
526 :     if (@$tab > 0)
527 :     {
528 :     push(@$html,&SeedHTML::make_table($col_hdrs,$tab,"Subsystems"));
529 :     }
530 :     else
531 :     {
532 :     push(@$html,$cgi->h3('no matches'));
533 :     }
534 :     push(@$html,$cgi->hr,&query_link($cgi));
535 :     }
536 :    
537 : overbeek 1.4 sub url_to_new {
538 :     my($cgi,$fid) = @_;
539 :    
540 :     if ($fid !~ /\.peg\./) { return "" }
541 :     my $dir = $cgi->param('dir');
542 :     my $url = $cgi->url() . "?request=features&dir=$dir&pattern=$fid";
543 :     return $url;
544 :     }
545 :    
546 :     sub url_to_sv {
547 :     my($cgi,$fid) = @_;
548 :    
549 :     if ($fid !~ /\.peg\./) { return "" }
550 :     my $dir = $cgi->param('dir');
551 :     return $cgi->url() . "?request=feature&fid=$fid&dir=$dir";
552 :     }
553 : overbeek 1.1
554 :     sub comp_reg_link {
555 :     my($peg,$cgi) = @_;
556 :    
557 :     my $target = "target.$$";
558 :     my $dir = $cgi->param('dir');
559 :     my $url = $cgi->url() . "?request=feature&fid=$peg&dir=$dir";
560 :     return "<a target=$target href=$url>$peg</a>";
561 :     }
562 :    
563 :     sub psi_blast_link {
564 :     my($peg) = @_;
565 :    
566 :     my $url = "http://seed-viewer.theseed.org/protein.cgi?prot=$peg&request=use_protein_tool&tool=Psi-Blast";
567 :     my $target = "target.$$";
568 :     return "<a target=$target href=$url>Psi</a>";
569 :     }
570 :    
571 :     sub ach_link {
572 :     my($cgi,$peg) = @_;
573 :     my $url = "http://seed-viewer.theseed.org/seedviewer.cgi?page=ACHresults&query=$peg";
574 :     my $target = "target.$$";
575 :     return "<a target=$target href=$url>ACH</a>";
576 :     }
577 :    
578 :     sub subsys_link {
579 :     my($cgi,$peg) = @_;
580 :    
581 :     my $dir = $cgi->param('dir');
582 :     my $url = $cgi->url() . "?request=peg2subsystems&dir=$dir&peg=$peg";
583 :     my $target = "target.$$";
584 :     return "<a target=$target href=$url>sub</a>";
585 :     }
586 :    
587 :     sub peg_link {
588 :     my($cgi,$peg) = @_;
589 :    
590 :     my $dir = $cgi->param('dir');
591 :     my $url = $cgi->url() . "?request=features&dir=$dir&pattern=$peg";
592 :     my $target = "target.$$";
593 :     return "<a target=$target href=$url>$peg</a>";
594 :     }
595 :    
596 :     sub ref_peg_link {
597 :     my($cgi,$peg) = @_;
598 :    
599 :    
600 :     my $target = "target.$$";
601 :     my $url = "http://seed-viewer.theseed.org/seedviewer.cgi?page=Annotation&feature=$peg";
602 :     return "<a target=$target href=$url>$peg</a>";
603 :     }
604 :    
605 :     sub query_link {
606 :     my($cgi) = @_;
607 :    
608 :     my $dir = $cgi->param('dir');
609 :     my $url = $cgi->url() . "?request=basic&dir=$dir";
610 :     return "<a href=$url>Basic Query Form</a>";
611 :     }
612 :    
613 :     sub filter_tab_entries {
614 :     my($tab,$pattern) = @_;
615 :    
616 :     if (! $pattern) { return $tab }
617 :    
618 :     my $filtered = [];
619 :     foreach my $entry (@$tab)
620 :     {
621 :     my @tmp = &substr_match([join("\t",@$entry)],$pattern);
622 :     if (@tmp > 0)
623 :     {
624 :     push(@$filtered,$entry);
625 :     }
626 :     }
627 :     return $filtered;
628 :     }
629 :    
630 :     sub process_id {
631 :     my($cgi,$html) = @_;
632 :    
633 :     my $id = $cgi->param('id');
634 :     if ($id =~ /^\s*(fig\|\d+\.\d+\.peg\.\d+)\s*$/)
635 :     {
636 :     my $peg = $1;
637 :     print $cgi->redirect("http://seed-viewer.theseed.org/seedviewer.cgi?page=Annotation&feature=$peg");
638 :     exit;
639 :     }
640 :     elsif ($id =~ /^\s*(\S+)\s*$/)
641 :     {
642 :     print $cgi->redirect("http://seed-viewer.theseed.org/seedviewer.cgi?page=ACHresults&query=$1");
643 :     exit;
644 :     }
645 :     else
646 :     {
647 :     push(@$html,$cgi->h2('Invalid request'));
648 :     }
649 :     }
650 :    
651 :     sub process_feature_display {
652 :     my($cgi,$html) = @_;
653 :    
654 :     my $dir = $cgi->param('dir');
655 :     my $seedV = SeedV->new($dir);
656 :     my $sapObject = SAPserver->new();
657 :    
658 :     my $fid = $cgi->param('fid');
659 :     my $func = $seedV->function_of($fid);
660 :     my $loc = $seedV->feature_location($fid);
661 :     my $dna_seq = $seedV->dna_seq($loc);
662 :    
663 :     my ($contig,$beg,$end);
664 :     if ($loc =~ /^(\S+)_(\d+)_(\d+)$/)
665 :     {
666 :     ($contig,$beg,$end) = ($1,$2,$3);
667 :     $loc = "contig: $1, from $2 to $3"
668 :     }
669 :     push(@$html,$cgi->h1("Feature: $fid"),$cgi->h2("Function: $func"),$cgi->h3("Location: $loc"));
670 :     &push_seq($cgi,$html,$fid,$dna_seq);
671 :    
672 :     if (($fid =~ /\.peg\.\d+$/) && $contig)
673 :     {
674 :     my $pseq = $seedV->get_translation($fid);
675 :     &push_seq($cgi,$html,$fid,$pseq);
676 :     &push_compare_regions($cgi,$html,$fid,$sapObject,$seedV,$contig,$beg,$end);
677 :     }
678 :     }
679 :    
680 :     sub push_seq {
681 :     my($cgi,$html,$id,$pseq) = @_;
682 :    
683 :     push(@$html,"<pre>\n>$id\n");
684 :     my $i;
685 :     for ($i=0; ($i < length($pseq)); $i += 60)
686 :     {
687 :     my $piece = ($i < (length($pseq) - 60)) ? substr($pseq,$i,60) : substr($pseq,$i);
688 :     push(@$html,"$piece\n");
689 :     }
690 :     push(@$html,"</pre>\n");
691 :     }
692 :    
693 :     sub push_compare_regions {
694 :     my($cgi,$html,$fid,$sapObject,$seedV,$contig,$beg,$end) = @_;
695 :    
696 : overbeek 1.6 my $mid = int(($beg+$end)/2);
697 :     my $min = ($beg < $end) ? ($mid - 4000) : $mid - 4000;
698 :     my $max = ($beg < $end) ? ($mid + 4000) : $mid + 4000;
699 :    
700 : overbeek 1.1 my ($genes,$minV,$maxV) = $seedV->genes_in_region($contig,$min,$max);
701 :     my %genesG = map { ($_ => 1 ) } @$genes;
702 :     my %locsG = map { $_ => $seedV->feature_location($_) } @$genes;
703 :    
704 :     my $dir = $cgi->param('dir');
705 :     my $cache = "$dir/CorrToReferenceGenomes";
706 :     my %connected;
707 :     my %color; # note that for simplicity, I am using peg ids in the given genome as symbolic colors
708 :    
709 :     foreach $_ (`cat $cache/* | cut -f1,2`)
710 :     {
711 :     if (($_ =~ /^(\S+)\t(\S+)/) && $genesG{$1})
712 :     {
713 :     push(@{$connected{$1}},$2);
714 :     $color{$2} = $1;
715 :     }
716 :     }
717 :    
718 :     my $pinned = $connected{$fid};
719 :     my $locH = {};
720 :     if ($pinned)
721 :     {
722 :     my $pinLocH = $sapObject->fid_locations( -boundaries => 1, -ids => $pinned);
723 :     my @locations = map { &format_location($pinLocH->{$_}) } keys(%$pinLocH);
724 :     $locH = $sapObject->genes_in_region( -locations => \@locations, -includeLocation => 1);
725 :     }
726 :     # print &Dumper(\%genesG,\%locsG,$pinned,$locH,\%color);
727 : overbeek 1.4 my @x = @{&build_maps($seedV,$sapObject,$fid,\%genesG,\%locsG,$pinned,$locH,\%color,$cgi)};
728 :     # print STDERR &Dumper(\@x); die "aborted";
729 :     push(@$html,@{&build_maps($seedV,$sapObject,$fid,\%genesG,\%locsG,$pinned,$locH,\%color,$cgi)});
730 : overbeek 1.1 }
731 :    
732 :     sub format_location {
733 :     my($loc) = @_;
734 :    
735 :     if ($loc =~ /^(\d+\.\d+):(\S+)_(\d+)([+-])(\d+)$/)
736 :     {
737 :     my($genome,$contig,$beg,$strand,$ln) = ($1,$2,$3,$4,$5);
738 :    
739 :     my($min,$max);
740 :     if ($strand eq "+")
741 :     {
742 :     $min = &SeedUtils::max(1,$beg-4000);
743 :     $max = $beg+$ln+4000;
744 :     }
745 :     else
746 :     {
747 : overbeek 1.6 $min = &SeedUtils::max(1,$beg-($ln+4000));
748 : overbeek 1.1 $max = $beg + 4000;
749 :     }
750 :     return "$genome:$contig\_$min\_$max";
751 :     }
752 :     else
753 :     {
754 :     die "bad location: $loc";
755 :     }
756 :     }
757 :    
758 :     sub build_maps {
759 : overbeek 1.4 my($seedV,$sapObject,$pegG,$genesG,$locsG,$pinned,$locH,$color,$cgi) = @_;
760 : overbeek 1.1
761 :    
762 :     my @genome_ids = map { &SeedUtils::genome_of($_) } @$pinned;
763 :     my $genomeH = $sapObject->genome_names( -ids => \@genome_ids);
764 :     #
765 :     # first, compute a list of what we use to build each map. This will include
766 :     #
767 :     # [pinned_gene, Contig,Beg,End,GenusSpecies]]
768 :     # [[gene,Contig,Beg,End,color],...] sorted in order
769 :     #
770 :     my @map_data = ();
771 :     push(@map_data,&data_for_given_genome($pegG,$genesG,$locsG,$seedV));
772 :    
773 :     foreach my $pegR (@$pinned)
774 :     {
775 :     push(@map_data,&data_for_pinned($pegR,$locH,$color,$genomeH));
776 :     }
777 :     &set_colors($pegG,\@map_data);
778 : overbeek 1.4
779 : overbeek 1.1 my $functionH = &function_hash($sapObject,$seedV,\@map_data);
780 :    
781 :     my $gg = [];
782 : overbeek 1.6 my $sz_region = 8500;
783 : overbeek 1.1
784 :     foreach my $map_set (@map_data)
785 :     {
786 :     my($pin_data,$gene_data) = @$map_set;
787 :     my($peg,$contig,$beg,$end,$genus_species) = @$pin_data;
788 :    
789 :     if ($contig && $beg && $end) {
790 :     my $mid = int(($beg + $end) / 2);
791 :     my $min = int($mid - ($sz_region / 2));
792 :     my $max = int($mid + ($sz_region / 2));
793 :     my $genes = [];
794 :     foreach my $entry (@$gene_data)
795 :     {
796 :     my($fid1,$contig1,$beg1,$end1,$color) = @$entry;
797 : parrello 1.7 $beg1 = &in_bounds($min,$max,$beg1);
798 :     $end1 = &in_bounds($min,$max,$end1);
799 : overbeek 1.1 my $function = $functionH->{$fid1};
800 : overbeek 1.4 if (! $function) { $function = "hypothetical protein" }
801 : overbeek 1.1 my $info = join('<br/>', "<b>PEG:</b> $fid1",
802 :     "<b>Contig:</b> $contig1",
803 :     "<b>Begin:</b> $beg1",
804 :     "<b>End:</b> $end1",
805 :     $function ? "<b>Function:</b> $function" : ()
806 :     );
807 :    
808 :     my $shape = "Rectangle";
809 :     if (($fid1 !~ /\.bs\./) && ($beg1 < $end1)) { $shape = "rightArrow" }
810 :     elsif (($fid1 !~ /\.bs\./) && ($beg1 > $end1)) { $shape = "leftArrow" }
811 :    
812 : overbeek 1.4 my $gene_entry = [&min($beg1,$end1),
813 :     &max($beg1,$end1),
814 :     $shape,
815 :     ($fid1 !~ /\.bs\./) ? $color : 'black',
816 :     undef,,
817 :     (@$gg == 0) ? &url_to_new($cgi,$fid1) : &url_to_sv($cgi,$fid1),
818 :     $info
819 :     ];
820 :    
821 :     push(@$genes,$gene_entry);
822 : overbeek 1.1 }
823 :    
824 :     # Sequence title can be replaced by [ title, url, popup_text, menu, popup_title ]
825 :    
826 :     my $desc = "Genome: $genus_species<br />Contig: $contig";
827 :     my $map = [ [ SeedUtils::abbrev( $genus_species ), undef, $desc, undef, 'Contig' ],
828 :     0,
829 :     $max+1 - $min,
830 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)
831 :     ];
832 :    
833 :     push(@$gg,$map);
834 :     }
835 :     }
836 :    
837 :     &GenoGraphics::disambiguate_maps($gg);
838 :     return &GenoGraphics::render($gg,700,4,0,2);
839 :     }
840 :    
841 :     sub data_for_given_genome {
842 :     my($peg,$pegs,$locs,$seedV) = @_;
843 :    
844 :     my @gene_data = ();
845 :     foreach my $peg1 (keys(%$pegs))
846 :     {
847 :     push(@gene_data,[$peg1,&split_loc($locs->{$peg1}),$peg1]);
848 :     }
849 : parrello 1.7 @gene_data = sort { ($a->[2]+$a->[3]) <=> ($b->[2]+$b->[3]) } @gene_data;
850 : overbeek 1.1 return [[$peg,&split_loc($locs->{$peg}),$seedV->genus_species],[@gene_data]];
851 :     }
852 :    
853 :     sub data_for_pinned {
854 :     my($peg,$locH,$color,$genomeH) = @_;
855 :    
856 :     my $genome = &SeedUtils::genome_of($peg);
857 :     my @tmp = grep { $locH->{$_}->{$peg} } keys(%$locH);
858 :     my $locH1 = $locH->{$tmp[0]};
859 :     my $pinned_data = [$peg,&split_new_loc($locH1->{$peg}->[0]),$genomeH->{&SeedUtils::genome_of($peg)}];
860 :     my @gene_data = ();
861 :     foreach my $peg1 (keys(%$locH1))
862 :     {
863 :     # print STDERR &Dumper($peg1,$color->{$peg1}); die "aborted";
864 :     push(@gene_data,[$peg1,&split_new_loc($locH1->{$peg1}->[0]),$color->{$peg1}]);
865 :     }
866 : parrello 1.7 @gene_data = sort { ($a->[2]+$a->[3]) <=> ($b->[2]+$b->[3]) } @gene_data;
867 : overbeek 1.1 return [$pinned_data,[@gene_data]];
868 :     }
869 :    
870 :     sub split_loc {
871 :     my($loc) = @_;
872 :    
873 :     if ($loc && ($loc =~ /^(.*:)?(\S+)_(\d+)_(\d+)$/))
874 :     {
875 :     return ($2,$3,$4);
876 :     }
877 :     die "bad_loc: $loc";
878 :     }
879 :    
880 :     sub split_new_loc {
881 :     my($loc) = @_;
882 :    
883 :     if ($loc =~ /^(\d+\.\d+):(\S+)_(\d+)([+-])(\d+)$/)
884 :     {
885 :     my($genome,$contig,$beg,$strand,$ln) = ($1,$2,$3,$4,$5);
886 :     if ($strand eq "+")
887 :     {
888 :     return ($contig,$beg,$beg+$ln-1);
889 :     }
890 :     else
891 :     {
892 :     return ($contig,$beg,$beg-($ln-1));
893 :     }
894 :     }
895 :     die "bad_loc: $loc";
896 :     }
897 :    
898 :     sub in_bounds {
899 :     my($min,$max,$x) = @_;
900 :    
901 :     if ($x < $min) { return $min }
902 :     elsif ($x > $max) { return $max }
903 :     else { return $x }
904 :     }
905 :    
906 :     sub decr_coords {
907 :     my($genes,$min) = @_;
908 :     my($gene);
909 :    
910 :     foreach $gene (@$genes) {
911 :     $gene->[0] -= $min;
912 :     $gene->[1] -= $min;
913 :     }
914 :     return $genes;
915 :     }
916 :    
917 :     sub function_hash {
918 :     my($sapObject,$seedV,$map_data) = @_;
919 :    
920 :     my $functionH = {};
921 :     my $gene_data = $map_data->[0]->[1];
922 :     foreach my $tuple (@$gene_data)
923 :     {
924 :     my $fid = $tuple->[0];
925 :     my $func = $seedV->function_of($fid);
926 :     $functionH->{$fid} = $func;
927 :     }
928 :    
929 :     my $i;
930 :     my @ids = ();
931 :     for ($i=1; ($i < @$map_data); $i++)
932 :     {
933 :     $gene_data = $map_data->[$i]->[1];
934 :     push(@ids,map { $_->[0] } @$gene_data);
935 :     }
936 :    
937 :     my $fH = $sapObject->ids_to_functions( -ids => \@ids);
938 :     while (my($id,$func) = each(%$fH))
939 :     {
940 :     $functionH->{$id} = $func;
941 :     }
942 :     return $functionH;
943 :     }
944 :    
945 :     sub flip_map {
946 :     my($genes,$min,$max) = @_;
947 :     my($gene);
948 :    
949 :     foreach $gene (@$genes) {
950 :     ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
951 :     if ($gene->[2] eq "rightArrow") { $gene->[2] = "leftArrow" }
952 :     elsif ($gene->[2] eq "leftArrow") { $gene->[2] = "rightArrow" }
953 :     }
954 :     return $genes;
955 :     }
956 :    
957 : overbeek 1.4
958 : overbeek 1.1 sub set_colors {
959 :     my($red_peg,$map_data) = @_;
960 :    
961 :     my %colors;
962 :     foreach my $map (@$map_data)
963 :     {
964 :     my $genes = $map->[1];
965 :     foreach $_ (@$genes)
966 :     {
967 :     if ($_->[4])
968 :     {
969 :     $colors{$_->[4]}++;
970 :     }
971 :     }
972 :     }
973 :     my @by_occ = sort { $colors{$b} <=> $colors{$a} } keys(%colors);
974 :     my $i;
975 :     my %to_color;
976 :     for ($i=1; ($i <= @by_occ); $i++)
977 :     {
978 :     $to_color{$by_occ[$i-1]} = "color$i";
979 :     }
980 :     $to_color{$red_peg} = "red";
981 :     foreach my $map (@$map_data)
982 :     {
983 :     my $genes = $map->[1];
984 :     foreach $_ (@$genes)
985 :     {
986 :     if ($_->[4])
987 :     {
988 :     $_->[4] = $to_color{$_->[4]};
989 :     }
990 :     else
991 :     {
992 :     $_->[4] = 'grey';
993 :     }
994 :     }
995 :     }
996 :     }
997 :    
998 : overbeek 1.6 sub fix_ss {
999 :     my($ss) = @_;
1000 :    
1001 :     $ss =~ s/_/ /g;
1002 :     return $ss;
1003 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3