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

Annotation of /FigWebServices/chromosomal_clusters_old.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (view) (download)

1 : overbeek 1.1 #
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 : parrello 1.2 #
7 : overbeek 1.1 # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 : parrello 1.2 # Public License.
10 : overbeek 1.1 #
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 :     ####################
19 :    
20 :     use InterfaceRoutines;
21 :    
22 :     use CGI ':standard';
23 :     my $cgi = new CGI;
24 :    
25 :     use FIG;
26 :    
27 :     my $html = [];
28 :    
29 :     my $sproutAvail = eval {
30 :     require SproutFIG;
31 :     require PageBuilder;
32 :     };
33 :    
34 :     my($fig_or_sprout);
35 :     my $is_sprout;
36 :     if ($cgi->param('SPROUT')) {
37 :     $is_sprout = 1;
38 :     $fig_or_sprout = new SproutFIG($FIG_Config::sproutDB, $FIG_Config::sproutData);
39 :     unshift @$html, "<TITLE>The NMPDR Chromosomal Clusters Page</TITLE>\n";
40 :     } else {
41 :     $is_sprout = 0;
42 :     $fig_or_sprout = new FIG;
43 :     unshift @$html, "<TITLE>The SEED Chromosomal Clusters Page</TITLE>\n";
44 :     }
45 :    
46 :     use HTML;
47 :     use strict;
48 :     use GenoGraphics;
49 :     use FIGGenDB;
50 :     use LWP::UserAgent;
51 :     use URI::Escape;
52 :    
53 :     if (0)
54 :     {
55 :     my $VAR1;
56 :     eval(join("",`cat /tmp/chr_clust_parms`));
57 :     $cgi = $VAR1;
58 :     # print STDERR &Dumper($cgi);
59 :     }
60 :    
61 :     if (0)
62 :     {
63 :     print $cgi->header;
64 :     my @params = $cgi->param;
65 :     print "<pre>\n";
66 :     foreach $_ (@params)
67 :     {
68 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
69 :     }
70 :     if (0)
71 :     {
72 :     if (open(TMP,">/tmp/chr_clust_parms"))
73 :     {
74 :     print TMP &Dumper($cgi);
75 :     close(TMP);
76 :     }
77 :     }
78 :     exit;
79 :     }
80 :    
81 :     if (&handled_by_cache($fig_or_sprout,$cgi)) { exit }
82 :    
83 :     my $sim_cutoff = $cgi->param('sim_cutoff');
84 :     if (! $sim_cutoff) { $sim_cutoff = 1.0e-20 }
85 :    
86 :     my $request = $cgi->param('request');
87 :     my $user = $cgi->param('user');
88 :     $user = $user ? $user : "";
89 :     push @$html, &FIGjs::toolTipScript();
90 :     if ($request eq "show_commentary")
91 :     {
92 :     &show_commentary($fig_or_sprout,$cgi,$html);
93 :     my_show_page($cgi,$html);
94 :     exit;
95 :     }
96 :    
97 :     my( $prot, $pinned_to, $in_pin, $uniL, $uniM ) = get_prot_and_pins( $fig_or_sprout, $cgi, $html );
98 :    
99 :     my( $gg, $all_pegs, $pegI ) = get_initial_gg_and_all_pegs( $fig_or_sprout, $cgi, $prot, $pinned_to, $uniL, $uniM );
100 :    
101 :     add_change_sim_threshhold_form( $cgi, $html );
102 :    
103 :     my( $color, $text ) = form_sets_and_set_color_and_text( $fig_or_sprout, $cgi, $gg, $pegI, $all_pegs, $sim_cutoff );
104 :    
105 :     my $vals = update_gg_with_color_and_text( $cgi, $gg, $color, $text, $prot );
106 :    
107 :     if ( @$gg == 0 )
108 :     {
109 :     push( @$html,$cgi->h1("Sorry, no pins worked out") );
110 :     }
111 :     else
112 :     {
113 :     &add_commentary_form( $prot, $user, $html, $vals );
114 :     &thin_out_over_max( $cgi, $prot, $gg, $in_pin );
115 :    
116 :     # As of May 8, 2005, we are going to start caching results, so all GenoGraphics images
117 :     # are saved. Hence, I am disposing of the "save" option. RAO
118 :     push( @$html, @{ &GenoGraphics::render( $gg, 1000, 4, 1 ) } );
119 :     push( @$html, &FIGGenDB::linkClusterGenDB($prot) );
120 :     }
121 :    
122 :     &cache_html($fig_or_sprout,$cgi,$html);
123 :     my_show_page($cgi,$html);
124 :    
125 :     exit;
126 :    
127 :    
128 :     # Everything below here is subroutines. =======================================
129 :    
130 :     sub pick_color {
131 :     my( $cgi, $all_pegs, $color_set, $i, $colors ) = @_;
132 :    
133 :     if ( @$colors > 0 )
134 :     {
135 :     my( $j, $peg, $color );
136 :     my %colors_imported = map { ( $peg, $color ) = $_ =~ /^(.*):([^:]*)$/ } @$colors;
137 :     for ($j=0; ($j < @$color_set) && (! $colors_imported{$all_pegs->[$color_set->[$j]]}); $j++) {}
138 :     if ($j < @$color_set)
139 :     {
140 :     return $colors_imported{$all_pegs->[$color_set->[$j]]};
141 :     }
142 :     }
143 :     return ( $i == 0 ) ? "red" : "color$i";
144 :     }
145 :    
146 :     sub pick_text {
147 :     my($cgi,$all_pegs,$color_set,$i,$texts) = @_;
148 :     my($peg,$text,$j);
149 :    
150 :     if (@$texts > 0)
151 :     {
152 :     my %texts_imported = map { ($peg,$text) = split(/:/,$_); $peg => $text } @$texts;
153 :     for ($j=0; ($j < @$color_set) && (! $texts_imported{$all_pegs->[$color_set->[$j]]}); $j++) {}
154 :     if ($j < @$color_set)
155 :     {
156 :     return $texts_imported{$all_pegs->[$color_set->[$j]]};
157 :     }
158 :     }
159 :     return $i+1;
160 :     }
161 :    
162 :     sub in {
163 :     my( $x, $xL ) = @_;
164 :    
165 :     foreach ( @$xL ) { if ( $x == $_ ) { return 1 } }
166 :     return 0;
167 :     }
168 :    
169 :     sub in_bounds {
170 :     my($min,$max,$x) = @_;
171 :    
172 :     if ($x < $min) { return $min }
173 :     elsif ($x > $max) { return $max }
174 :     else { return $x }
175 :     }
176 :    
177 :     sub decr_coords {
178 :     my($genes,$min) = @_;
179 :     my($gene);
180 :    
181 :     foreach $gene (@$genes)
182 :     {
183 :     $gene->[0] -= $min;
184 :     $gene->[1] -= $min;
185 :     }
186 :     return $genes;
187 :     }
188 :    
189 :     sub flip_map {
190 :     my($genes,$min,$max) = @_;
191 :     my($gene);
192 : parrello 1.2
193 : overbeek 1.1 foreach $gene (@$genes)
194 :     {
195 :     ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
196 :     $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
197 :     }
198 :     return $genes;
199 :     }
200 :    
201 :     sub gs_of {
202 :     my($peg) = @_;
203 : parrello 1.2
204 : overbeek 1.1 $peg =~ /fig\|(\d+)/;
205 :     return $1;
206 :     }
207 :    
208 :    
209 :     # How about some color commentary?
210 :    
211 :     sub show_commentary {
212 :     my($fig_or_sprout,$cgi,$html) = @_;
213 :    
214 :     my(@vals,$val,%by_set,$col_hdrs,$tab,$n,$occ,$org,$fid,$set,$x,$i,%by_line,%fid_to_line);
215 :     $cgi->delete('request');
216 :    
217 :     @vals = $cgi->param('show');
218 :     foreach $val (@vals)
219 :     {
220 :     ( $n, $i, $fid, $org, $occ ) = split( /\@/, $val );
221 :     push( @{ $by_set{$n} }, [ $i, $org, $occ, $fid ] );
222 :     push( @{ $by_line{$i} }, $n );
223 :     if ($n == 1) { $fid_to_line{$fid} = $i }
224 :     }
225 :    
226 :     my($func,$user_entry,$func_entry,$target);
227 :    
228 :     my $user = $cgi->param('user');
229 :     if ($user)
230 :     {
231 :     $target = "window$$";
232 :     }
233 :    
234 :     foreach $set (sort { $a <=> $b } keys(%by_set))
235 :     {
236 :     if ($cgi->param('uni'))
237 :     {
238 :     $col_hdrs = ["Set","Organism","Occ","UniProt","UniProt Function","PEG","SS",
239 :     &evidence_codes_link($cgi),"Ln","Function"];
240 :     }
241 :     else
242 :     {
243 :     $col_hdrs = ["Set","Organism","Occ","PEG","SS",&evidence_codes_link($cgi),"Ln","Function"];
244 :     }
245 :     $tab = [];
246 :    
247 :     if ($user)
248 :     {
249 : parrello 1.2 push(@$html,$cgi->start_form(-method => 'post',
250 : overbeek 1.1 -target => $target,
251 :     -action => &FIG::cgi_url . "/fid_checked.cgi"),
252 :     $cgi->hidden(-name => 'user', -value => $user)
253 :     );
254 :     }
255 :    
256 :     # For colorized functions we need to get the functions, then set the
257 :     # colors. Given the structure of the current code, it seems easiest
258 :     # to accumulate the information on a first pass, exactly as done now,
259 :     # but then go back and stuff the colors in (possibly even by keeping
260 :     # a stack of references to the ultimate locations).
261 :    
262 :     my( @uni, $uni_link );
263 :     my @func_summary = ();
264 :     my %func_count = ();
265 :     my %order = ();
266 :     my $cnt = 0;
267 :    
268 :     foreach $x ( sort { ($a->[0] <=> $b->[0]) or ($a->[2] <=> $b->[2]) } @{ $by_set{$set} } )
269 :     {
270 :     ( undef, $org, $occ, $fid ) = @$x;
271 :     my $tran_len = &translation_length($fig_or_sprout,$fid);
272 :     my @subs = &peg_to_subsystems($fig_or_sprout,$fid);
273 :     my $in_sub = @subs;
274 :    
275 :     @uni = $cgi->param('uni') ? &to_alias($fig_or_sprout,$fid,"uni") : "";
276 :     $uni_link = join( ", ", map { &HTML::uni_link( $cgi, $_ ) } @uni );
277 :    
278 :     $user_entry = &HTML::fid_link( $cgi, $fid );
279 :    
280 :     if ($user)
281 :     {
282 :     $user_entry = $cgi->checkbox(-name => 'checked', -label => '', -value => $fid) . "&nbsp; $user_entry";
283 :     }
284 :    
285 :     $func = &function_ofS($fig_or_sprout,$fid,$cgi->param('user'));
286 :     if ($user && $func)
287 :     {
288 :     $func_entry = $cgi->checkbox(-name => 'from', -label => '', -value => $fid) . "&nbsp; $func";
289 :     }
290 :     else
291 :     {
292 :     $func_entry = $func;
293 :     }
294 :    
295 :     # Record the count of each function, and the order of first occurance:
296 :    
297 :     if ( $func ) { ( $func_count{ $func }++ ) or ( $order{ $func } = ++$cnt ) }
298 :    
299 :     # We need to build a table entry that HTML::make_table will color
300 :     # the cell. It would certainly be possible to use the old colon
301 :     # delimited prefix. Rob Edwards added the really nice feature that
302 :     # if the cell contents are a reference to an array, then the first
303 :     # element in the content, and the second element is the tag. We
304 :     # Will till it in so that if nothing else happens it is fine.
305 :    
306 :     my $func_ref = [ $func_entry, "td" ];
307 :     my $uni_ref = undef;
308 :     my $uni_func = undef;
309 :     my $ev = join("<br>",&evidence_codes($fig_or_sprout,$fid));
310 :    
311 :     if ($cgi->param('uni'))
312 :     {
313 :     my $uni_entry;
314 :     $uni_func = (@uni > 0) ? &function_ofS($fig_or_sprout,$uni[0]) : "";
315 :     if ( $uni_func && $user )
316 :     {
317 :     $uni_entry = $cgi->checkbox(-name => 'from', -label => '', -value => $uni[0]) . "&nbsp; $uni_func";
318 :     }
319 :     else
320 :     {
321 :     $uni_entry = $uni_func;
322 :     }
323 :     $uni_ref = [ $uni_entry, "td" ];
324 :     push( @$tab,[ $set, $org, $occ, $uni_link, $uni_ref, $user_entry, $in_sub, $ev,$tran_len, $func_ref ] );
325 :     }
326 :     else
327 :     {
328 :     push( @$tab, [ $set, $org, $occ, $user_entry, $in_sub, $ev, $tran_len, $func_ref ] );
329 :     }
330 :    
331 :     # Remember the information we need to do the coloring:
332 :    
333 :     push @func_summary, [ $func, $func_ref, $uni_func, $uni_ref ];
334 :     }
335 :    
336 :     # Okay, let's propose some colors:
337 :    
338 :     my @colors = qw( #EECCAA #FFAAAA #FFCC66 #FFFF00 #AAFFAA #BBBBFF #FFAAFF ); # #FFFFFF
339 :     my %func_color = map { $_ => ( shift @colors || "#DDDDDD" ) }
340 :     sort { $func_count{ $b } <=> $func_count{ $a }
341 :     or $order{ $a } <=> $order{ $b }
342 :     }
343 :     keys %func_count;
344 :    
345 :     my ( $row );
346 :     foreach $row ( @func_summary )
347 :     {
348 :     my ( $func, $func_ref, $uni_func, $uni_ref ) = @$row;
349 :     $func_ref->[1] = "td bgcolor=" . ( $func_color{ $func } || "#DDDDDD" );
350 :     if ( $uni_ref )
351 :     {
352 :     $uni_ref->[1] = "td bgcolor=" . ( $func_color{ $uni_func } || "#DDDDDD" )
353 :     }
354 :     }
355 :    
356 :     push( @$html, &HTML::make_table( $col_hdrs, $tab, "Description By Set" ) );
357 :    
358 :     if ($user)
359 :     {
360 :     push(@$html,$cgi->submit('assign/annotate'), "&nbsp;","&nbsp;","&nbsp;","&nbsp;",
361 : parrello 1.2 $cgi->submit('Align DNA'),
362 : overbeek 1.1 "&nbsp;","&nbsp;","Size upstream: ",
363 :     $cgi->textfield(-name => 'upstream', -size => 4, -value => 0),
364 : parrello 1.2 "&nbsp;","&nbsp;",
365 : overbeek 1.1 "&nbsp;","&nbsp;", "Restrict coding area to (optional): ",
366 :     $cgi->textfield(-name => 'gene', -size => 4, -value => "")
367 :     );
368 :    
369 :     push(@$html,$cgi->end_form);
370 :     }
371 :     }
372 :    
373 :    
374 :     # Build a form for extracting subsets of genomes:
375 :    
376 :     my $target = "window$$";
377 : parrello 1.2 push(@$html,$cgi->start_form(-method => 'post',
378 : overbeek 1.1 -action => &FIG::cgi_url . "/chromosomal_clusters.cgi",
379 :     -name => "fid_checked",
380 :     -target => $target),
381 :     $cgi->hidden(-name => 'sim_cutoff', -value => $sim_cutoff));
382 :    
383 :     foreach $set (keys(%by_set))
384 :     {
385 :     my($x,$set0,$peg);
386 :     $set0 = $set - 1;
387 :     foreach $x (@{$by_set{$set}})
388 :     {
389 :     $peg = $x->[3];
390 :     push(@$html,$cgi->hidden(-name => "color", -value => "$peg:color$set0"),
391 :     $cgi->hidden(-name => "text", -value => "$peg:$set"));
392 :     }
393 :     }
394 :    
395 :     my $prot = $cgi->param('prot');
396 :    
397 :     $col_hdrs = ["show","map","genome","description","PEG","colors"];
398 :     $tab = [];
399 :     $set = $by_set{1};
400 :    
401 :     my %seen_peg;
402 :     foreach $x (sort { $a->[1] cmp $b->[1] } @$set)
403 :     {
404 :     (undef,$org,undef,$fid) = @$x;
405 :     next if ($seen_peg{$fid});
406 :     $seen_peg{$fid} = 1;
407 :    
408 : parrello 1.2 push(@$tab,[$cgi->checkbox(-name => 'pinned_to',
409 : overbeek 1.1 -checked => 1,
410 :     -label => '',
411 :     -value => $fid),
412 :     $org,&FIG::genome_of($fid),&org_of($fig_or_sprout,$fid),&HTML::fid_link($cgi,$fid),
413 :     join(",",sort { $a <=> $b } @{$by_line{$fid_to_line{$fid}}})
414 :     ]);
415 :     }
416 :     push(@$html,$cgi->hr);
417 :     push (@$html, $cgi->br, &HTML::java_buttons("fid_checked", "pinned_to"), $cgi->br); # RAE: Add check all/none buttons
418 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Keep Just Checked"),
419 :     $cgi->hidden(-name => 'user', -value => $user),
420 :     # $cgi->hidden(-name => 'prot', -value => $prot),
421 :     # $cgi->hidden(-name => 'pinned_to', -value => $prot),
422 :     $cgi->br,
423 :     $cgi->submit('Picked Maps Only'),
424 :     $cgi->end_form);
425 :     }
426 :    
427 :    
428 :     sub get_prot_and_pins {
429 :     my($fig_or_sprout,$cgi,$html) = @_;
430 :    
431 :     my $prot = $cgi->param('prot');
432 :     # RAE: added this so that you can paste spaces and get a resonable answer!
433 :     $prot =~ s/^\s+//; $prot =~ s/\s+$//;
434 : parrello 1.2
435 : overbeek 1.1 my @pegs = map { split(/,/,$_) } $cgi->param('pinned_to');
436 :     # RAE: remove leading and trailing spaces from IDs
437 :     map {s/^\s+//; s/\s+$//} @pegs;
438 :     my @nonfig = grep { $_ !~ /^fig\|/ } @pegs;
439 :     my @pinned_to = ();
440 :    
441 :     my $uniL = {};
442 :     my $uniM = {};
443 :    
444 :     if (@nonfig > 0)
445 :     {
446 :     my $col_hdrs = ["UniProt ID","UniProt Org","UniProt Function","FIG IDs","FIG orgs","FIG Functions"];
447 :     my $tab = [];
448 :     my $x;
449 :     foreach $x (@nonfig)
450 :     {
451 :     if ($x =~ /^[A-Z0-9]{6}$/)
452 :     {
453 :     $x = "uni|$x";
454 :     }
455 :     my @to_fig = &resolve_id($fig_or_sprout,$x);
456 :     my($fig_id,$fig_func,$fig_org);
457 :     if (@to_fig == 0)
458 :     {
459 :     $fig_id = "No Matched FIG IDs";
460 :     $fig_func = "";
461 :     $fig_org = "";
462 :     $x =~ /uni\|(\S+)/;
463 :     $uniM->{$1} = 1;
464 :     }
465 :     else
466 :     {
467 :     $fig_id = join("<br>",map { &HTML::fid_link($cgi,$_) } @to_fig);
468 :     $fig_func = join("<br>",map { &function_ofS($fig_or_sprout,$_) } @to_fig);
469 :     $fig_org = join("<br>",map { &org_of($fig_or_sprout,$_) } @to_fig);
470 :     push(@pinned_to,@to_fig);
471 :     }
472 :     my $uni_org = &org_of($fig_or_sprout,$x);
473 :     push(@$tab,[&HTML::uni_link($cgi,$x),&org_of($fig_or_sprout,$x),scalar &function_ofS($fig_or_sprout,$x),$fig_id,$fig_org,$fig_func]);
474 :     }
475 :     push(@$html,$cgi->hr);
476 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Correspondence Between UniProt and FIG IDs"));
477 :     push(@$html,$cgi->hr);
478 :     }
479 :     else
480 :     {
481 :     @pinned_to = @pegs;
482 :     }
483 :    
484 :     # Make @pinned_to non-redundant by building a hash and extracting the keys
485 :    
486 :     my %pinned_to = map { $_ => 1 } @pinned_to;
487 :     @pinned_to = sort { &FIG::by_fig_id($a,$b) } keys(%pinned_to);
488 :     # print STDERR &Dumper(\@pinned_to);
489 :    
490 :     # Do we have an explicit or implicit protein?
491 :    
492 :     if ((! $prot) && (@pinned_to < 2))
493 :     {
494 :     #push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");
495 :     # RAE: A nicer rejection if no protein is specified. This will allow them to choose one or more pinned regions
496 : parrello 1.2 push(@$html,
497 : overbeek 1.1 $cgi->start_form, $cgi->p("Please enter an id of the protein to look at:", $cgi->textfield(-name=>"prot", -size=>40)),
498 : parrello 1.2 $cgi->p("You can also choose some other proteins to pin this to. Paste a comma separated list here: ",
499 : overbeek 1.1 $cgi->textfield(-name=>"pinned_to", -size=>80)),
500 :     $cgi->submit, $cgi->reset, $cgi->end_form);
501 :     my_show_page($cgi,$html);
502 :     exit;
503 :     }
504 :    
505 :     # No explicit protein, take one from the list:
506 :    
507 :     if (! $prot)
508 :     {
509 :     $prot = shift @pinned_to;
510 :     }
511 :    
512 :     my $in_pin = @pinned_to;
513 :    
514 :     # Make sure that there are pins
515 :    
516 :     if (@pinned_to < 1)
517 :     {
518 :     @pinned_to = &get_pin($fig_or_sprout,$prot);
519 :     $in_pin = @pinned_to;
520 :     my $max = $cgi->param('maxpin');
521 :     $max = $max ? $max : 300;
522 :     if (@pinned_to > (2 * $max))
523 :     {
524 :     @pinned_to = &limit_pinned($prot,\@pinned_to,2 * $max);
525 :     }
526 :     }
527 :    
528 : parrello 1.2 # print STDERR &Dumper(\@pinned_to);
529 : overbeek 1.1 if (@pinned_to == 0)
530 :     {
531 :     push(@$html,"<h1>Sorry, protein is not pinned</h1>\nTry to establish coupling before displaying pinned region");
532 :     my_show_page($cgi,$html);
533 :     exit;
534 :     }
535 :    
536 :     # Ensure that there is exactly one copy of $prot, then sort by taxonomy:
537 :    
538 :     @pinned_to = ( $prot, grep { $_ ne $prot } @pinned_to );
539 :     @pinned_to = &sort_fids_by_taxonomy($fig_or_sprout,@pinned_to);
540 :     # print &Dumper([$prot,\@pinned_to,$in_pin]);
541 :    
542 :     # $uniL is always {}. What was it for? -- GJO
543 :    
544 :     return ( $prot, \@pinned_to, $in_pin, $uniL, $uniM );
545 :     }
546 :    
547 :    
548 :    
549 :     sub get_initial_gg_and_all_pegs {
550 :     my( $fig_or_sprout, $cgi, $prot, $pinned_to, $uniL, $uniM ) = @_;
551 :    
552 :     # $prot is the protein the reference protein
553 :     # @$pinned_to is the complete list of proteins to be aligned across genomes
554 :     # $uniL is {} and is never used!
555 :     # %$uniM is a hash of uniprot ids from $cgi->param('pinned_to'),
556 :     # with no other information. They create empty lines.
557 :    
558 :     my $gg = [];
559 :     my($peg,$loc,$org,$contig,$beg,$end,$min,$max,$genes,$feat,$fid);
560 :     my($contig1,$beg1,$end1,@all_pegs,$map,$mid,$pegI);
561 :    
562 :     foreach $peg ( @$pinned_to )
563 :     {
564 :     $org = &org_of($fig_or_sprout,$peg);
565 :     # print STDERR "processing $peg\n";
566 :     $loc = &feature_locationS($fig_or_sprout,$peg);
567 :     if ( $loc)
568 :     {
569 :     ($contig,$beg,$end) = &FIG::boundaries_of($loc);
570 :     if ($contig && $beg && $end)
571 :     {
572 :     $mid = int(($beg + $end) / 2);
573 :     $min = $mid - 8000;
574 :     $max = $mid + 8000;
575 :     $genes = [];
576 :     ($feat,undef,undef) = &genes_in_region($fig_or_sprout,$cgi,&FIG::genome_of($peg),$contig,$min,$max);
577 :     # print STDERR &Dumper($feat);
578 :     foreach $fid (@$feat)
579 :     {
580 :     ($contig1,$beg1,$end1) = &FIG::boundaries_of(&feature_locationS($fig_or_sprout,$fid));
581 :     # print STDERR "contig1=$contig1 beg1=$beg1 end1=$end1\n";
582 :     # print STDERR &Dumper([$fid,&feature_locationS($fig_or_sprout,$fid),&boundaries_of($fig_or_sprout,&feature_locationS($fig_or_sprout,$fid))]);
583 :     $beg1 = &in_bounds($min,$max,$beg1);
584 :     $end1 = &in_bounds($min,$max,$end1);
585 :    
586 :     # Build the pop-up information for the gene:
587 :    
588 :     my $function = &function_ofS($fig_or_sprout,$fid);
589 :     my $aliases1 = &feature_aliasesS($fig_or_sprout,$fid);
590 :     my ( $uniprot ) = $aliases1 =~ /(uni\|[^,]+)/;
591 :    
592 :    
593 :     my $info = join( '<br/>', "<b>Org:</b> $org",
594 :     "<b>PEG:</b> $fid",
595 :     "<b>Contig:</b> $contig1",
596 :     "<b>Begin:</b> $beg1",
597 :     "<b>End:</b> $end1",
598 :     ( $function ? "<b>Function:</b> $function" : () ),
599 :     ( $uniprot ? "<b>Uniprot ID:</b> $uniprot" : () )
600 :     );
601 :    
602 :     #my @allattributes=$fig_or_sprout->get_attributes($fid);
603 :     #foreach my $eachattr (@allattributes) {
604 :     # my ($gotpeg,$gottag,$val, $url)=@$eachattr;
605 :     # $info .= "<br/><b>Attribute:</b> $gottag $val $url";
606 :     # }
607 :    
608 :     push( @$genes, [ &FIG::min($beg1,$end1),
609 :     &FIG::max($beg1,$end1),
610 :     ($beg1 < $end1) ? "rightArrow" : "leftArrow",
611 :     "",
612 :     "",
613 :     $fid,
614 :     $info
615 :     ] );
616 :    
617 :     if ( $fid =~ /peg/ ) { push @all_pegs, $fid }
618 :     }
619 :    
620 :     # Everything is done for the one "genome", push it onto GenoGraphics input:
621 :     # Sequence title can be replaced by [ title, url, popup_text, menu, popup_title ]
622 :    
623 :     my $org = $fig_or_sprout->org_of( $peg );
624 :     my $desc = "Genome: $org<br />Contig: $contig";
625 :     $map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ],
626 :     0,
627 :     $max+1-$min,
628 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)
629 :     ];
630 :    
631 :     push( @$gg, $map );
632 :     }
633 :     }
634 :     }
635 :    
636 :     &GenoGraphics::disambiguate_maps($gg);
637 :    
638 :     # %$uniM is a hash of uniprot IDs. This just draws blank genome lines for each.
639 :    
640 :     foreach $_ (sort keys %$uniM )
641 :     {
642 :     push( @$gg, [ $_, 0, 8000, [] ] );
643 :     }
644 :     # print STDERR &Dumper($gg); die "abort";
645 :    
646 :     # move all pegs from the $prot genome to the front of all_pegs.
647 :    
648 :     my $genome_of_prot = $prot ? FIG::genome_of( $prot ) : "";
649 :    
650 :     if ( $genome_of_prot ) {
651 :     my @tmp = ();
652 :     foreach $peg ( @all_pegs )
653 :     {
654 :     if ( $genome_of_prot eq FIG::genome_of( $peg ) ) { unshift @tmp, $peg }
655 :     else { push @tmp, $peg }
656 :     }
657 :     @all_pegs = @tmp;
658 :     }
659 :    
660 :     # Find the index of $prot in @all_pegs
661 :    
662 :    
663 :     for ($pegI = 0; ($pegI < @all_pegs) && ($prot ne $all_pegs[$pegI]); $pegI++) {}
664 :     if ($pegI == @all_pegs)
665 :     {
666 :     $pegI = 0;
667 :     }
668 :    
669 :     # print STDERR "pegi=$pegI prot=$prot $all_pegs[$pegI]\n";
670 :    
671 :     return ( $gg, \@all_pegs, $pegI );
672 :     }
673 :    
674 :    
675 :     sub add_change_sim_threshhold_form {
676 :     my($cgi,$html) = @_;
677 :    
678 :     my $user = $cgi->param('user');
679 :    
680 :     my @change_sim_threshhold_form = ();
681 :     push(@change_sim_threshhold_form,start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"));
682 :     if ($user)
683 :     {
684 :     push(@change_sim_threshhold_form,hidden(-name => "user", -value => $user));
685 : parrello 1.2 }
686 : overbeek 1.1
687 :     my $max = $cgi->param('maxpin');
688 :     $max = $max ? $max : 300;
689 :    
690 :     push(@change_sim_threshhold_form,hidden(-name => "maxpin", -value => $max));
691 :     push(@change_sim_threshhold_form,hidden(-name => "prot", -value => $prot));
692 :     push(@change_sim_threshhold_form,hidden(-name => "pinned_to", -value => [@$pinned_to]));
693 :     push(@change_sim_threshhold_form,"Similarity Threshold: ", $cgi->textfield(-name => 'sim_cutoff', -size => 10, -value => 1.0e-20),
694 :     $cgi->submit('compute at given similarity threshhold'),
695 :     $cgi->end_form);
696 :     push(@$html,@change_sim_threshhold_form);
697 :     return;
698 :     }
699 :    
700 :    
701 :     # I now attempt to document, clean code, and make orphan genes gray. Wish us all luck. -- GJO
702 :    
703 :     sub form_sets_and_set_color_and_text {
704 :     my( $fig_or_sprout, $cgi, $gg, $pegI, $all_pegs, $sim_cutoff ) = @_;
705 :    
706 :     # @$gg is GenoGraphics objects (maps exist, but they will be modified)
707 :     # $pegI is index of the reference protein in @$all_pegs
708 :     # @$all_pegs is a list of all proteins on the diagram
709 :    
710 :     # all of the PEGs are now stashed in $all_pegs. We are going to now look up similarities
711 :     # between them and form connections. The tricky part is that we are going to use "raw" sims,
712 :     # which means that we need to translate IDs; a single ID in a raw similarity may refer to multiple
713 :     # entries in $all_pegs. $pos_of{$peg} is set to a list of positions (of essentially identical PEGs).
714 :    
715 :     my %peg2i; # map from id (in @$all_pegs) to index in @$all_pegs
716 :     my %pos_of; # maps representative id to indexes in @$all_pegs, and original id to its index
717 :     my @rep_ids; # list of representative ids (product of all maps_to_id)
718 :    
719 :     my ( $i, $id_i, %counts );
720 :     for ($i=0; ($i < @$all_pegs); $i++)
721 :     {
722 :     $id_i = $all_pegs->[$i];
723 :     $peg2i{ $id_i } = $i;
724 :    
725 :     my $rep = &maps_to_id($fig_or_sprout, $id_i );
726 :     defined( $pos_of{ $rep } ) or push @rep_ids, $rep;
727 :     $counts{$rep}++;
728 :     push @{ $pos_of{ $rep } }, $i;
729 :     if ( $rep ne $id_i )
730 :     {
731 :     push @{ $pos_of{ $id_i } }, $i;
732 :     }
733 :     }
734 :    
735 :     # print STDERR Dumper(\%pos_of, \%peg2i, \@rep_ids);
736 :    
737 :     # @{$conn{ $rep }} will list all connections of a representative id
738 :     # (this used to be for every protein, not the representatives).
739 :    
740 :     my %conn;
741 :    
742 :     my @texts = $cgi->param('text'); # map of id to text
743 :     my @colors = $cgi->param('color'); # peg:color pairs
744 :     my @color_sets = ();
745 :    
746 :     # Case 1, find sets of related sequences using sims:
747 :    
748 :     if ( @colors == 0 )
749 :     {
750 :     # Get sequence similarities among representatives
751 :    
752 :     my ( $rep, $id2 );
753 :     foreach $rep ( @rep_ids )
754 :     {
755 :     # We get $sim_cutoff as a global var (ouch)
756 :    
757 :     $conn{ $rep } = [ map { defined( $pos_of{ $id2 = $_->id2 } ) ? $id2 : () }
758 :     $fig_or_sprout->sims($rep, 500, $sim_cutoff, "raw" )
759 :     ];
760 :     }
761 :     # print STDERR &Dumper(\%conn);
762 :    
763 :     # Build similarity clusters
764 :    
765 :     my %seen = ();
766 :     foreach $rep ( @rep_ids )
767 :     {
768 :     next if $seen{ $rep };
769 :    
770 :     my @cluster = ( $rep );
771 :     my @pending = ( $rep );
772 :     $seen{ $rep } = 1;
773 :    
774 :     while ( $id2 = shift @pending )
775 :     {
776 :     my $k;
777 :     foreach $k ( @{ $conn{ $id2 } } )
778 :     {
779 :     next if $seen{ $k };
780 :    
781 :     push @cluster, $k;
782 :     push @pending, $k;
783 :     $seen{ $k } = 1;
784 :     }
785 :    
786 :     }
787 :     if ((@cluster > 1) || ($counts{$cluster[0]} > 1))
788 :     {
789 :     push @color_sets, \@cluster;
790 :     }
791 :     }
792 :    
793 :     # Clusters were built by representatives.
794 :     # Map (and expand) back to lists of indices into @all_pegs.
795 :    
796 :     @color_sets = map { [ map { @{ $pos_of{ $_ } } } @$_ ] }
797 :     @color_sets;
798 :     }
799 :     else # Case 2, supplied colors are group labels that should be same color
800 :     {
801 :     my( %sets, $peg, $x, $color );
802 :     foreach $x ( @colors )
803 :     {
804 :     ( $peg, $color ) = $x =~ /^(.*):([^:]*)$/;
805 :     if ( $peg2i{ $peg } )
806 :     {
807 :     push @{ $sets{ $color } }, $peg2i{ $peg };
808 :     }
809 :     }
810 :    
811 :     @color_sets = map { $sets{ $_ } } keys %sets;
812 :     }
813 :    
814 :     # Order the clusters from largest to smallest
815 :    
816 :     @color_sets = sort { @$b <=> @$a } @color_sets;
817 :     # foreach ( @color_sets ) { print STDERR "[ ", join( ", ", @$_ ), " ]\n" }
818 :    
819 :     # Move cluster with reference prot to the beginning:
820 :    
821 :     my $set1;
822 :     @color_sets = map { ( &in( $pegI, $_ ) && ( $set1 = $_ ) ) ? () : $_ } @color_sets;
823 :     if ( $set1 )
824 :     {
825 :     unshift @color_sets, $set1;
826 :     # print STDERR &Dumper(["color_sets",[map { [ map { $all_pegs->[$_] } @$_ ] } @color_sets]]); die "aborted";
827 :     }
828 :     # else
829 :     # {
830 :     # print STDERR &Dumper(\@color_sets);
831 :     # print STDERR "could not find initial PEG in color sets\n";
832 :     # }
833 :    
834 :     my( %color, %text, $i, $j );
835 :     for ( $i=0; ($i < @color_sets); $i++)
836 :     {
837 :     my $color_set_i = $color_sets[ $i ];
838 :     my $picked_color = &pick_color( $cgi, $all_pegs, $color_set_i, $i, \@colors );
839 :     my $picked_text = &pick_text( $cgi, $all_pegs, $color_set_i, $i, \@texts );
840 :    
841 :     foreach $j ( @$color_set_i )
842 :     {
843 :     $color{$all_pegs->[$j]} = $picked_color;
844 :     $text{$all_pegs->[$j]} = $picked_text;
845 :     }
846 :     }
847 :    
848 :     # print STDERR &Dumper($all_pegs,\@color_sets);
849 :     return (\%color,\%text);
850 :     }
851 :    
852 :     sub add_commentary_form {
853 :     my($prot,$user,$html,$vals) = @_;
854 :    
855 :    
856 :     my @commentary_form = ();
857 :     my $ctarget = "window$$";
858 :    
859 :     my $uni = $cgi->param('uni');
860 :     if (! defined($uni)) { $uni = "" }
861 :    
862 :     push(@commentary_form,start_form(-target => $ctarget,
863 :     -action => &FIG::cgi_url . "/chromosomal_clusters.cgi"
864 :     ));
865 :     push(@commentary_form,hidden(-name => "request", -value => "show_commentary"));
866 :     push(@commentary_form,hidden(-name => "prot", -value => $prot));
867 :     push(@commentary_form,hidden(-name => "user", -value => $user));
868 :     push(@commentary_form,hidden(-name => "uni", -value => $uni));
869 :    
870 :     push(@commentary_form,hidden(-name => "show", -value => [@$vals]));
871 :     push(@commentary_form,submit('commentary'));
872 :     push(@commentary_form,end_form());
873 :     push(@$html,@commentary_form);
874 : parrello 1.2
875 : overbeek 1.1 return;
876 :     }
877 :    
878 :     sub update_gg_with_color_and_text {
879 :     my( $cgi, $gg, $color, $text, $prot ) = @_;
880 :    
881 :     my( $gene, $n, %how_many, $x, $map, $i, %got_color );
882 :    
883 :     my %must_have_color;
884 :    
885 :     my @must_have = $cgi->param('must_have');
886 :     push @must_have, $prot;
887 :    
888 :     my @vals = ();
889 :     for ( $i = (@$gg - 1); ($i >= 0); $i--)
890 :     {
891 :     my @vals1 = ();
892 :     $map = $gg->[$i]; # @$map = ( abbrev, min_coord, max_coord, \@genes )
893 : parrello 1.2
894 : overbeek 1.1 undef %got_color;
895 :     my $got_red = 0;
896 :     my $found = 0;
897 :     undef %how_many;
898 :    
899 :     foreach $gene ( @{$map->[3]} )
900 :     {
901 :     # @$gene = ( min_coord, max_coord, symbol, color, text, id_link, pop_up_info )
902 :    
903 :     my $id = $gene->[5];
904 :     if ( $x = $color->{ $id } )
905 :     {
906 :     $gene->[3] = $x;
907 :     $gene->[4] = $n = $text->{ $id };
908 :     $got_color{ $x } = 1;
909 :     if ( ( $x =~ /^(red|color0)$/ )
910 :     && &FIG::between( $gene->[0], ($map->[1]+$map->[2])/2, $gene->[1] )
911 :     ) { $got_red = 1 }
912 :     $how_many{ $n }++;
913 :     push @vals1, join( "@", $n, $i, $id, $map->[0]->[0], $how_many{$n} );
914 :     $found++;
915 :     }
916 :     else
917 :     {
918 :     $gene->[3] = "ltgray"; # Light gray
919 :     }
920 :     $gene->[5] = &HTML::fid_link( $cgi, $id, 0, 1 );
921 :     }
922 :    
923 :     for ( $x = 0; ( $x < @must_have ) && $got_color{ $color->{ $must_have[ $x ] } }; $x++ ) {}
924 :     if ( ( $x < @must_have ) || ( ! $got_red ) )
925 :     {
926 :     # print STDERR &Dumper($map);
927 :     if ( @{ $map->[3] } > 0 ) { splice( @$gg, $i, 1 ) }
928 :     }
929 :     else
930 :     {
931 :     push @vals, @vals1;
932 :     }
933 :     }
934 :     # print STDERR &Dumper($gg);
935 :    
936 :     return \@vals;
937 :     }
938 :    
939 :     sub thin_out_over_max {
940 :     my($cgi,$prot,$gg,$in_pin) = @_;
941 :    
942 :     my $user = $cgi->param('user');
943 :     $user = $user ? $user : "";
944 :    
945 :     my $max = $cgi->param('maxpin');
946 :     $max = $max ? $max : 300;
947 :    
948 :     if ($in_pin > $max)
949 :     {
950 :     my $sim_cutoff = $cgi->param('sim_cutoff');
951 :     if (! $sim_cutoff) { $sim_cutoff = 1.0e-20 }
952 :    
953 :     my $to = &FIG::min(scalar @$gg,$max);
954 :     push(@$html,$cgi->h1("Truncating from $in_pin pins to $to pins"),
955 :     $cgi->start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"),,
956 :     "Max Pins: ", $cgi->textfield(-name => 'maxpin',
957 :     -value => $_,
958 :     -override => 1),
959 :     $cgi->hidden(-name => 'user', -value => $user),
960 :     $cgi->hidden(-name => 'prot', -value => $prot),
961 :     $cgi->hidden(-name => 'sim_cutoff', -value => $sim_cutoff),
962 :     $cgi->submit("Recompute after adjusting Max Pins"),
963 :     $cgi->end_form,
964 :     $cgi->hr);
965 :    
966 :     if (@$gg > $max)
967 :     {
968 :     my($i,$to_cut);
969 :     for ($i=0; ($i < @$gg) && (! &in_map($prot,$gg->[$i])); $i++) {}
970 :    
971 :     if ($i < @$gg)
972 :     {
973 :     my $beg = $i - int($max/2);
974 :     my $end = $i + int($max/2);
975 :     if (($beg < 0) && ($end < @$gg))
976 :     {
977 :     $beg = 0;
978 :     $end = $beg + ($max - 1);
979 :     }
980 :     elsif (($end >= @$gg) && ($beg > 0))
981 :     {
982 :     $end = @$gg - 1;
983 :     $beg = $end - ($max - 1);
984 :     }
985 : parrello 1.2
986 : overbeek 1.1 if ($end < (@$gg - 1))
987 :     {
988 :     splice(@$gg,$end+1);
989 :     }
990 : parrello 1.2
991 : overbeek 1.1 if ($beg > 0)
992 :     {
993 :     splice(@$gg,0,$beg);
994 :     }
995 :     }
996 :     }
997 :     }
998 :     }
999 :    
1000 :     sub in_map {
1001 :     my($peg,$map) = @_;
1002 :     my $i;
1003 :    
1004 :     my $genes = $map->[3];
1005 :     for ($i=0; ($i < @$genes) && (index($genes->[$i]->[5],"$peg\&") < 0); $i++) {}
1006 :     return ($i < @$genes);
1007 :     }
1008 : parrello 1.2
1009 : overbeek 1.1 sub limit_pinned {
1010 :     my($prot,$pinned_to,$max) = @_;
1011 :    
1012 :     my($i,$to_cut);
1013 :     for ($i=0; ($i < @$pinned_to) && ($pinned_to->[$i] ne $prot); $i++) {}
1014 :    
1015 :     if ($i < @$pinned_to)
1016 :     {
1017 :     my $beg = $i - int($max/2);
1018 :     my $end = $i + int($max/2);
1019 :     if (($beg < 0) && ($end < @$pinned_to))
1020 :     {
1021 :     $beg = 0;
1022 :     $end = $beg + ($max - 1);
1023 :     }
1024 :     elsif (($end >= @$pinned_to) && ($beg > 0))
1025 :     {
1026 :     $end = @$pinned_to - 1;
1027 :     $beg = $end - ($max - 1);
1028 :     }
1029 : parrello 1.2
1030 : overbeek 1.1 if ($end < (@$pinned_to - 1))
1031 :     {
1032 :     splice(@$pinned_to,$end+1);
1033 :     }
1034 : parrello 1.2
1035 : overbeek 1.1 if ($beg > 0)
1036 :     {
1037 :     splice(@$pinned_to,0,$beg);
1038 :     }
1039 :     }
1040 :     return @$pinned_to;
1041 :     }
1042 :    
1043 :     sub resolve_id {
1044 :     my($fig_or_sprout,$id) = @_;
1045 :     my(@pegs);
1046 :    
1047 :     if ($id =~ /^fig/) { return $id }
1048 :    
1049 :     if (@pegs = &by_alias($fig_or_sprout,$id)) { return @pegs }
1050 :    
1051 :     if (($id =~ /^[A-Z0-9]{6}$/) && (@pegs = &by_alias($fig_or_sprout,"uni|$id"))) { return @pegs }
1052 :    
1053 :     if (($id =~ /^\d+$/) && (@pegs = &by_alias($fig_or_sprout,"gi|$id"))) { return @pegs }
1054 :    
1055 :     if (($id =~ /^\d+$/) && (@pegs = &by_alias($fig_or_sprout,"gi|$id"))) { return @pegs }
1056 :    
1057 :     return ();
1058 :     }
1059 :    
1060 :     sub cache_html {
1061 :     my($fig_or_sprout,$cgi,$html) = @_;
1062 :    
1063 :     my @params = sort $cgi->param;
1064 :     # print STDERR &Dumper(\@params);
1065 :     if ((@params == 3) &&
1066 :     ($params[0] eq 'prot') &&
1067 :     ($params[1] eq 'uni') &&
1068 :     ($params[2] eq 'user'))
1069 :     {
1070 :     my $prot = $cgi->param('prot');
1071 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
1072 :     {
1073 :     my $user = $cgi->param('user');
1074 :     my $uni = $cgi->param('uni');
1075 :     my $file = &cache_file($prot,$uni);
1076 :     if (open(CACHE,">$file"))
1077 :     {
1078 :     foreach $_ (@$html)
1079 :     {
1080 :     # $_ =~ s/user=$user/USER=@@@/g;
1081 :     print CACHE $_;
1082 :     }
1083 :     close(CACHE);
1084 :     }
1085 :     }
1086 :     }
1087 :     }
1088 :    
1089 :     sub cache_file {
1090 :     my($prot,$uni) = @_;
1091 :    
1092 :     &FIG::verify_dir("$FIG_Config::temp/Cache");
1093 :     return "$FIG_Config::temp/Cache/$prot:$uni";
1094 :     }
1095 :    
1096 :     sub handled_by_cache {
1097 :     my($fig_or_sprout,$cgi) = @_;
1098 :    
1099 :     my @params = sort $cgi->param;
1100 :    
1101 :     my $is_sprout = $cgi->param('SPROUT');
1102 :    
1103 :     my $i;
1104 :     for ($i=0; ($params[$i] =~ /prot|uni|user|SPROUT/); $i++) {}
1105 :    
1106 :     # warn "handled_by_cache: i=$i params=@params\n";
1107 :     if ($i == @params)
1108 :     {
1109 :     my $prot = $cgi->param('prot');
1110 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
1111 :     {
1112 : parrello 1.2 my $sprout = $is_sprout ? "&SPROUT=1" : "";
1113 : overbeek 1.1 my $user = $cgi->param('user');
1114 :     my $uni = $cgi->param('uni');
1115 :     my $file = &cache_file($prot,$uni);
1116 :    
1117 :     if (open(CACHE,"<$file"))
1118 :     {
1119 :     warn "Using local cache $file\n";
1120 :     my $html = [];
1121 :     my $fig_loc;
1122 :     my $to_loc = &FIG::cgi_url;
1123 :     $to_loc =~ /http:\/\/(.*?)\/FIG/;
1124 :     $to_loc = $1;
1125 :     while (defined($_ = <CACHE>))
1126 :     {
1127 :     if ((! $fig_loc) && ($_ =~ /http:\/\/(.*?)\/FIG\/chromosomal_clusters.cgi/))
1128 :     {
1129 :     $fig_loc = quotemeta $1;
1130 :     }
1131 :    
1132 :     $_ =~ s/http:\/\/$fig_loc\//http:\/\/$to_loc\//g;
1133 :     $_ =~ s/USER=\@\@\@/user=$user$sprout/g;
1134 :     $_ =~ s/\buser=[^&;\"]*/user=$user$sprout/g;
1135 :    
1136 :     push(@$html,$_);
1137 :     }
1138 :     close(CACHE);
1139 : parrello 1.2
1140 : overbeek 1.1 my_show_page($cgi,$html);
1141 :     return 1;
1142 :     }
1143 :     else
1144 :     {
1145 :     my $to_loc = &FIG::cgi_url;
1146 :     my $h;
1147 :     if ($h = get_pins_html($fig_or_sprout, $prot))
1148 :     {
1149 :     #
1150 :     # If we're in sprout, strip the form at the end.
1151 :     # We need to also tack on a hidden variable that sets SPROUT=1.
1152 :     #
1153 :    
1154 :     my $html = [];
1155 :    
1156 :     for (split(/\n/, $h))
1157 :     {
1158 :     if ($is_sprout)
1159 :     {
1160 :     if(/form.*GENDB/)
1161 :     {
1162 :     last;
1163 :     }
1164 :     elsif (/type="submit" name=\"(commentary|compute)/)
1165 :     {
1166 :     push(@$html, qq(<input type="hidden" name="SPROUT" value="1">\n));
1167 :     }
1168 :    
1169 :     #
1170 :     # Don't offer the recompute option.#
1171 :     #
1172 :    
1173 :     s,Similarity Threshold:.*value="compute at given similarity threshhold" />,,;
1174 : parrello 1.2
1175 : overbeek 1.1 }
1176 :     s/user=master:cached/user=$user$sprout/g;
1177 :     s/name="user" value="master:cached"/name="user" value="$user"/;
1178 :     push(@$html, "$_\n");
1179 :     }
1180 : parrello 1.2
1181 : overbeek 1.1 my_show_page($cgi, $html);
1182 :     return 1;
1183 :     }
1184 :     }
1185 :     }
1186 :     }
1187 :     return 0;
1188 :     }
1189 :    
1190 :     sub get_pin {
1191 :     my($fig_or_sprout,$peg) = @_;
1192 :    
1193 :     my($peg2,%pinned_to,$tuple);
1194 :    
1195 : parrello 1.2 if (&table_exists($fig_or_sprout,'pchs') &&
1196 : overbeek 1.1 &is_complete($fig_or_sprout,&genome_of($fig_or_sprout,$peg)))
1197 :     {
1198 :     foreach $peg2 (map { $_->[0] } &coupled_to($fig_or_sprout,$peg))
1199 :     {
1200 :     foreach $tuple (&coupling_evidence($fig_or_sprout,$peg,$peg2))
1201 :     {
1202 :     $pinned_to{$tuple->[0]} = 1;
1203 :     }
1204 :     }
1205 :     my @tmp = &sort_fids_by_taxonomy($fig_or_sprout,keys(%pinned_to));
1206 :     if (@tmp > 0)
1207 :     {
1208 :     return @tmp;
1209 :     }
1210 :     }
1211 :     return &sort_fids_by_taxonomy($fig_or_sprout,&in_pch_pin_with($fig_or_sprout,$peg));
1212 :     }
1213 :    
1214 :     sub get_pins_html
1215 :     {
1216 :     my($fig_or_sprout, $peg) = @_;
1217 :    
1218 :     my $ua = new LWP::UserAgent;
1219 :    
1220 :     my $peg_enc = uri_escape($peg);
1221 :     my $my_url_enc = uri_escape(&cgi_url($fig_or_sprout));
1222 :     my $pins_url = "http://clearinghouse.theseed.org/Clearinghouse/pins_for_peg.cgi";
1223 :    
1224 :     my $url = "$pins_url?peg=$peg_enc&fig_base=$my_url_enc";
1225 :     my $resp = $ua->get($url);
1226 :    
1227 :     if ($resp->is_success)
1228 :     {
1229 :     return $resp->content;
1230 :     }
1231 :     else
1232 :     {
1233 :     return undef;
1234 :     }
1235 :     }
1236 :    
1237 :     sub my_show_page
1238 :     {
1239 :     my($cgi, $html) = @_;
1240 : parrello 1.2
1241 : overbeek 1.1 if ($cgi->param('SPROUT'))
1242 :     {
1243 :     my $loc_url = $cgi->url(-absolute => 1, -full => 1, -query => 1, -path_info => 1);
1244 :    
1245 :     #
1246 :     # Truncate it in case the url is humongous (like it will be for the pins commentary page).
1247 :     #
1248 : parrello 1.2
1249 : overbeek 1.1 $loc_url = substr($loc_url, 0, 100);
1250 : parrello 1.2
1251 :     my $h = {
1252 : overbeek 1.1 location_tag => [uri_escape($loc_url)],
1253 :     pins => $html
1254 :     };
1255 :     print "Content-Type: text/html\n";
1256 :     print "\n";
1257 :     my $templ = "$FIG_Config::fig/CGI/Html/CCluster_tmpl.html";
1258 : parrello 1.2 print PageBuilder::Build("<<$templ", $h,"Html");
1259 : overbeek 1.1 }
1260 :     else
1261 :     {
1262 :     &HTML::show_page($cgi, $html);
1263 :     }
1264 :     }
1265 :    
1266 :     sub evidence_codes_link {
1267 :     my($cgi) = $_;
1268 :    
1269 :     return "<A href=\"Html/evidence_codes.html\" target=\"SEED_or_SPROUT_help\">Ev</A>";
1270 :     }
1271 :    
1272 :     sub evidence_codes {
1273 :     my($fig_or_sprout,$peg) = @_;
1274 :    
1275 :     if ($peg !~ /^fig\|\d+\.\d+\.peg\.\d+$/) { return "" }
1276 :    
1277 :     my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig_or_sprout->get_attributes($peg);
1278 :     return (@codes > 0) ? map { $_->[2] } @codes : ();
1279 :     }
1280 :    
1281 :    
1282 :     #####################################################################

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3