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

Annotation of /FigWebServices/index.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.92 - (view) (download)

1 : overbeek 1.49 ### start
2 :    
3 : efrank 1.1 use FIG;
4 : olson 1.89 use FIG_CGI;
5 : efrank 1.1
6 : golsen 1.65 use strict;
7 : parrello 1.78 use Tracer;
8 : golsen 1.65 use FIGjs qw( toolTipScript );
9 :     use GenoGraphics qw( render );
10 :     use IPC::Open2 qw( open2 );
11 :    
12 : efrank 1.92 use URI::Escape; # uri_escape
13 : olson 1.36 use POSIX;
14 : efrank 1.1 use HTML;
15 : golsen 1.65
16 : olson 1.89 my($fig, $cgi, $user);
17 : olson 1.90 my $this_script = "index.cgi";
18 : efrank 1.1
19 : olson 1.54 eval {
20 : olson 1.89 ($fig, $cgi, $user) = FIG_CGI::init(debug_save => 0,
21 :     debug_load => 0,
22 :     print_params => 0);
23 : olson 1.54 };
24 :    
25 :     if ($@ ne "")
26 :     {
27 :     my $err = $@;
28 :    
29 :     my(@html);
30 :    
31 :     push(@html, $cgi->p("Error connecting to SEED database."));
32 :     if ($err =~ /Could not connect to DBI:.*could not connect to server/)
33 :     {
34 : parrello 1.75 push(@html, $cgi->p("Could not connect to relational database of type $FIG_Config::dbms named $FIG_Config::db on port $FIG_Config::dbport."));
35 : olson 1.54 }
36 :     else
37 :     {
38 : parrello 1.75 push(@html, $cgi->pre($err));
39 : olson 1.54 }
40 :     &HTML::show_page($cgi, \@html, 1);
41 :     exit;
42 :     }
43 : olson 1.89
44 : parrello 1.78 Trace("Connected to FIG.") if T(2);
45 : overbeek 1.28 my($map,@orgs,$user,$map,$org,$made_by,$from_func,$to_func);
46 : efrank 1.1
47 : overbeek 1.85 #for my $k (sort keys %ENV)
48 :     #{
49 :     # warn "$k=$ENV{$k}\n";
50 :     #}
51 : overbeek 1.81
52 : efrank 1.1 $ENV{"PATH"} = "$FIG_Config::bin:$FIG_Config::ext_bin:" . $ENV{"PATH"};
53 :    
54 :     my $html = [];
55 : golsen 1.23
56 : overbeek 1.51 my($pattern,$seq_pat,$tool,$ids,$subsearch);
57 : redwards 1.80
58 : overbeek 1.87 my $user = $cgi->param('user');
59 :    
60 : overbeek 1.28 if ($cgi->param('Search for Genes Matching an Occurrence Profile or Common to a Set of Organisms'))
61 : efrank 1.1 {
62 : parrello 1.78 Trace("Gene search chosen.") if T(2);
63 : golsen 1.23 unshift @$html, "<TITLE>The SEED: Phylogenetic Signatures</TITLE>\n";
64 : efrank 1.1 $ENV{"REQUEST_METHOD"} = "GET";
65 :     $ENV{"QUERY_STRING"} = "user=$user";
66 :     my @out = `./sigs.cgi`;
67 : overbeek 1.49 print @out;
68 :     exit;
69 :     }
70 :     #-----------------------------------------------------------------------
71 :     # Statistics for a single organism
72 :     #-----------------------------------------------------------------------
73 :     elsif ($cgi->param('statistics'))
74 :     {
75 : parrello 1.78 Trace("Statistics chosen.") if T(2);
76 : overbeek 1.49 @orgs = $cgi->param('korgs');
77 :     @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;
78 :     if (@orgs != 1)
79 :     {
80 : golsen 1.72 unshift @$html, "<TITLE>The SEED Statistics Page</TITLE>\n";
81 : overbeek 1.49 push(@$html,$cgi->h1('Please select a single organism to get statistcs'));
82 :     }
83 :     else
84 :     {
85 : parrello 1.75 $ENV{"REQUEST_METHOD"} = "GET";
86 :     $ENV{"QUERY_STRING"} = "user=$user&genome=$orgs[0]";
87 :     my @out = `./genome_statistics.cgi`;
88 :     print @out;
89 :     exit;
90 : overbeek 1.49 }
91 : efrank 1.1 }
92 : overbeek 1.17 #-----------------------------------------------------------------------
93 : overbeek 1.51 # Locate PEGs in Subsystems
94 :     #-----------------------------------------------------------------------
95 :     elsif ($cgi->param('Find PEGs') && ($subsearch = $cgi->param('subsearch')))
96 :     {
97 : parrello 1.78 Trace("PEG find chosen.") if T(2);
98 : overbeek 1.51 my $genome = $cgi->param('genome');
99 :     my (@pegs,$peg);
100 : overbeek 1.52
101 :     my @poss = $fig->by_alias($subsearch);
102 :     if (@poss > 0) { $subsearch = $poss[0] }
103 :    
104 : overbeek 1.51 if ($subsearch =~ /(fig\|\d+\.\d+\.peg\.\d+)/)
105 :     {
106 : parrello 1.75 # handle searching for homologs that occur in subsystems
107 :     $peg = $1;
108 :     @pegs = ($peg);
109 :     push(@pegs,map { $_->id2 } $fig->sims( $peg, 500, 1.0e-10, "fig"));
110 :     if ($genome)
111 :     {
112 :     my $genomeQ = quotemeta $genome;
113 :     @pegs = grep { $_ =~ /^fig\|$genomeQ/ } @pegs;
114 :     }
115 : overbeek 1.51 }
116 :     else
117 :     {
118 : parrello 1.75 # handle searching for PEGs with functional role in subsystems
119 :     @pegs = $fig->seqs_with_role($subsearch,"master",$genome);
120 : overbeek 1.51 }
121 :    
122 :     print $cgi->header;
123 :     if (@pegs == 0)
124 :     {
125 : parrello 1.75 print $cgi->h1("Sorry, could not even find PEGs to check");
126 : overbeek 1.51 }
127 :     else
128 :     {
129 : parrello 1.75 my(@pairs,$pair,@sub);
130 :     @pairs = map { $peg = $_;
131 :     @sub = $fig->peg_to_subsystems($peg);
132 :     map { [$peg,$_] } @sub } @pegs;
133 :     if (@pairs == 0)
134 :     {
135 :     print $cgi->h1("Sorry, could not map any PEGs to subsystems");
136 :     }
137 :     else
138 :     {
139 :     my($uni,$uni_func);
140 :     my $col_hdrs = ["PEG","Genome","Function","UniProt","UniProt Function","Subsystem"];
141 :     my $tab = [ map { $pair = $_; $uni = $fig->to_alias($pair->[0],"uni");
142 :     ($uni,$uni_func) = $uni ? (&HTML::uni_link($cgi,$uni),scalar $fig->function_of($uni)) : ("","");
143 :     [&HTML::fid_link($cgi,$pair->[0]),
144 :     $fig->org_of($pair->[0]),
145 :     scalar $fig->function_of($pair->[0]),
146 :     $uni,$uni_func,
147 :     &HTML::sub_link($cgi,$pair->[1])] } @pairs];
148 :     print &HTML::make_table($col_hdrs,$tab,"PEGs that Occur in Subsystems");
149 :     }
150 : overbeek 1.51 }
151 :     exit;
152 :     }
153 :     #-----------------------------------------------------------------------
154 : overbeek 1.31 # Align Sequences
155 :     #-----------------------------------------------------------------------
156 :     elsif ($cgi->param('Align Sequences'))
157 :     {
158 : parrello 1.78 Trace("Sequence alignment chosen.");
159 : overbeek 1.31 my $seqs = $cgi->param('seqids');
160 :     $seqs =~ s/^\s+//;
161 :     $seqs =~ s/\s+$//;
162 :     my @seq_ids = split(/[ \t,;]+/,$seqs);
163 :     if (@seq_ids < 2)
164 :     {
165 : parrello 1.75 print $cgi->header;
166 :     print $cgi->h1("Sorry, you need to specify at least two sequence IDs");
167 : overbeek 1.31 }
168 :     else
169 :     {
170 : parrello 1.75 $ENV{"REQUEST_METHOD"} = "GET";
171 :     $_ = join('&checked=',@seq_ids);
172 :     $ENV{"QUERY_STRING"} = "user=$user&align=1&checked=" . $_;
173 :     my @out = `./fid_checked.cgi`;
174 :     print join("",@out);
175 : overbeek 1.31 }
176 :     exit;
177 :     }
178 :     #-----------------------------------------------------------------------
179 : overbeek 1.17 # Search (text) || Find Genes in Org that Might Play the Role
180 :     #-----------------------------------------------------------------------
181 : golsen 1.59 elsif ( ( $pattern = $cgi->param('pattern') )
182 :     && ( $cgi->param('Search')
183 :     || $cgi->param('Search genome selected below')
184 : redwards 1.63 || $cgi->param('Search Selected Organisms')
185 : golsen 1.59 || $cgi->param('Find Genes in Org that Might Play the Role')
186 :     )
187 :     )
188 : efrank 1.1 {
189 : parrello 1.78 Trace("Pattern search chosen.") if T(2);
190 : overbeek 1.17 # Remove leading and trailing spaces from pattern -- GJO:
191 :     $pattern =~ s/^\s+//;
192 :     $pattern =~ s/\s+$//;
193 : efrank 1.1 if ($cgi->param('Find Genes in Org that Might Play the Role') &&
194 : parrello 1.75 (@orgs = $cgi->param('korgs')) && (@orgs == 1))
195 : efrank 1.1 {
196 : parrello 1.75 unshift @$html, "<TITLE>The SEED: Genes in that Might Play Specific Role</TITLE>\n";
197 :     @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;
198 :     $ENV{"REQUEST_METHOD"} = "GET";
199 :     $ENV{"QUERY_STRING"} = "user=$user&request=find_in_org&role=$pattern&org=$orgs[0]";
200 :     my @out = `./pom.cgi`;
201 :     print join("",@out);
202 :     exit;
203 : efrank 1.1 }
204 :     else
205 :     {
206 : parrello 1.75 unshift @$html, "<TITLE>The SEED: Search Results</TITLE>\n";
207 :     &show_indexed_objects($fig, $cgi, $html, $pattern);
208 : efrank 1.1 }
209 :     }
210 : overbeek 1.17 #-----------------------------------------------------------------------
211 :     # Metabolic Overview
212 :     #-----------------------------------------------------------------------
213 : efrank 1.1 elsif (($map = $cgi->param('kmap')) && $cgi->param('Metabolic Overview'))
214 :     {
215 : parrello 1.78 Trace("Metabolic overview chosen.") if T(2);
216 : olson 1.38 if ($map =~ /\(([^)]*)\)$/)
217 :     {
218 : parrello 1.75 $map = $1;
219 : olson 1.38 }
220 :     else
221 :     {
222 : parrello 1.75 # ??? Gary ???
223 : olson 1.38 }
224 :    
225 :     #$map =~ s/^.*\((MAP\d+)\).*$/$1/;
226 : efrank 1.1 @orgs = $cgi->param('korgs');
227 :     @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;
228 :     $ENV{"REQUEST_METHOD"} = "GET";
229 :     if (@orgs > 0)
230 :     {
231 : parrello 1.75 $ENV{"QUERY_STRING"} = "user=$user&map=$map&org=$orgs[0]";
232 : efrank 1.1 }
233 :     else
234 :     {
235 : parrello 1.75 $ENV{"QUERY_STRING"} = "user=$user&map=$map";
236 : efrank 1.1 }
237 :    
238 : golsen 1.23 unshift @$html, "<TITLE>The SEED: Metabolic Overview</TITLE>\n";
239 : olson 1.38 my @out = `./show_map.cgi`;
240 : efrank 1.1 &HTML::trim_output(\@out);
241 : golsen 1.23 push( @$html, "<br>\n", @out );
242 : efrank 1.1 }
243 : overbeek 1.17
244 :     #-----------------------------------------------------------------------
245 :     # Search for Matches (sequence or pattern)
246 :     #-----------------------------------------------------------------------
247 : efrank 1.1 elsif (($seq_pat = $cgi->param('seq_pat')) &&
248 :     ($tool = $cgi->param('Tool')) &&
249 :     $cgi->param('Search for Matches'))
250 :     {
251 : parrello 1.78 Trace("Match search chosen.") if T(2);
252 : overbeek 1.30 @orgs = $cgi->param('korgs');
253 :     if (@orgs > 0)
254 :     {
255 : parrello 1.75 @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;
256 : overbeek 1.30 }
257 :     else
258 :     {
259 : parrello 1.75 @orgs = ("");
260 : overbeek 1.30 }
261 :    
262 : efrank 1.1 if ($tool =~ /blast/)
263 :     {
264 : parrello 1.75 unshift @$html, "<TITLE>The SEED: BLAST Search Results</TITLE>\n";
265 :     &run_blast($fig,$cgi,$html,$orgs[0],$tool,$seq_pat);
266 : efrank 1.1 }
267 :     elsif ($tool =~ /Protein scan_for_matches/)
268 :     {
269 : parrello 1.75 unshift @$html, "<TITLE>The SEED: Protein Pattern Match Results</TITLE>\n";
270 :     &run_prot_scan_for_matches($fig,$cgi,$html,$orgs[0],$seq_pat);
271 : efrank 1.1 }
272 :     elsif ($tool =~ /DNA scan_for_matches/)
273 :     {
274 : parrello 1.75 unshift @$html, "<TITLE>The SEED: Nucleotide Pattern Match Results</TITLE>\n";
275 :     &run_dna_scan_for_matches($fig,$cgi,$html,$orgs[0],$seq_pat);
276 : efrank 1.1 }
277 :     }
278 : overbeek 1.7 elsif (($made_by = $cgi->param('made_by')) && $cgi->param('Extract Assignments'))
279 :     {
280 : parrello 1.78 Trace("Assignment export chosen.") if T(2);
281 : overbeek 1.7 &export_assignments($fig,$cgi,$html,$made_by);
282 :     }
283 : overbeek 1.28 elsif ($cgi->param('Generate Assignments via Translation') &&
284 :     ($from_func = $cgi->param('from_func')) &&
285 :     ($to_func = $cgi->param('to_func')))
286 :     {
287 : parrello 1.78 Trace("Assignment translate chosen.") if T(2);
288 : overbeek 1.28 &translate_assignments($fig,$cgi,$html,$from_func,$to_func);
289 :     }
290 : overbeek 1.30 elsif ($cgi->param('Extract Matched Sequences') && ($ids = $cgi->param('ids')))
291 :     {
292 : parrello 1.78 Trace("Matched sequence extract chosen.") if T(2);
293 : overbeek 1.30 my @ids = split(/,/,$ids);
294 :     my($list_to,$i);
295 :     if ($list_to = $cgi->param('list_to'))
296 :     {
297 : parrello 1.75 for ($i=0; ($i < @ids) && ($ids[$i] ne $list_to); $i++) {}
298 :     if ($i < @ids)
299 :     {
300 :     $#ids = $i;
301 :     }
302 : overbeek 1.30 }
303 :    
304 :     my($id,$seq,$i,$func);
305 :     push(@$html,$cgi->pre);
306 :    
307 :     foreach $id (@ids)
308 :     {
309 : parrello 1.75 if ($seq = $fig->get_translation($id))
310 :     {
311 :     $func = $fig->function_of($id);
312 :     push(@$html,">$id $func\n");
313 :     for ($i=0; ($i < length($seq)); $i += 60)
314 :     {
315 :     if ($i > (length($seq) - 60))
316 :     {
317 :     push(@$html,substr($seq,$i) . "\n");
318 :     }
319 :     else
320 :     {
321 :     push(@$html,substr($seq,$i,60) . "\n");
322 :     }
323 :     }
324 :     }
325 : overbeek 1.30 }
326 :     push(@$html,$cgi->end_pre);
327 :     }
328 : overbeek 1.17
329 :     #-----------------------------------------------------------------------
330 :     # Initial search page
331 :     #-----------------------------------------------------------------------
332 : efrank 1.1 else
333 :     {
334 : parrello 1.78 Trace("SEED Entry page chosen.") if T(2);
335 : golsen 1.23 unshift @$html, "<TITLE>The SEED: Entry Page</TITLE>\n";
336 : efrank 1.1 &show_initial($fig,$cgi,$html);
337 :     }
338 :     &HTML::show_page($cgi,$html,1);
339 : overbeek 1.49 exit;
340 : efrank 1.1
341 : overbeek 1.17
342 :     #==============================================================================
343 :     # Initial page (alias search)
344 :     #==============================================================================
345 :    
346 : efrank 1.1 sub show_initial {
347 :     my($fig,$cgi,$html) = @_;
348 :     my($map,$name,$olrg,$gs);
349 :    
350 : overbeek 1.83
351 :     #
352 :     # Display the message of the day, if present.
353 :     #
354 :    
355 :     show_motd($fig, $cgi, $html);
356 :    
357 : golsen 1.47 my( $a, $b, $e, $v, $env ) = $fig->genome_counts;
358 :     push(@$html,$cgi->h2("Contains $a archaeal, $b bacterial, $e eukaryal, $v viral and $env environmental genomes"));
359 :     my( $a, $b, $e ) = $fig->genome_counts("complete");
360 :     push(@$html,$cgi->h2("Of these, $a archaeal, $b bacterial and $e eukaryal genomes are more-or-less complete"),$cgi->hr);
361 : efrank 1.1
362 :     push(@$html,
363 : parrello 1.75 $cgi->h2('Work on Subsystems'),
364 : overbeek 1.46
365 : parrello 1.75 # $cgi->start_form(-action => "ssa2.cgi"),
366 :     # "Enter user: ",
367 :     # $cgi->textfield(-name => "user", -size => 20),
368 :     # $cgi->submit('Work on Subsystems'),
369 :     # $cgi->end_form,
370 :    
371 :     # $cgi->h2('Work on Subsystems Using New, Experimental Code'),
372 :     "This is the <i>new</i> subsystems code, and is now officially released.",
373 :     $cgi->start_form(-action => "subsys.cgi"),
374 :     "Enter user: ",
375 :     $cgi->textfield(-name => "user", -size => 20),
376 :     $cgi->submit('Work on Subsystems'),
377 :     $cgi->end_form,
378 :     $cgi->hr,
379 :     );
380 : olson 1.42
381 :     push(@$html,
382 : olson 1.89 $cgi->start_form(-action => $this_script),
383 : parrello 1.75 $cgi->h2('Searching for Genes or Functional Roles Using Text'),
384 :     "<table><tr>",
385 : overbeek 1.17 "<td>Search Pattern: </td><td>",
386 : parrello 1.75 $cgi->textfield(-name => "pattern", -size => 65),
387 : efrank 1.92 "</td><td>",
388 :     "Search <select name=search_kind>
389 :     <option value=DIRECT >Directly</option>
390 :     <option value=GO >Via Gene Ontology</option>
391 :     <option value=HUGO >Via HUGO Gene Nomenclature Committee</option>
392 :     </select> &nbsp;&nbsp",
393 : parrello 1.75 "</td></tr><tr>",
394 :     "<td>User ID:</td><td>",
395 :     $cgi->textfield(-name => "user", -size => 20),
396 :     " [optional] ",
397 : overbeek 1.17 "&nbsp; &nbsp; Max Genes: ",
398 : parrello 1.75 $cgi->textfield(-name => "maxpeg", -size => 6, -value => 100),
399 : overbeek 1.17 "&nbsp; &nbsp; Max Roles: ",
400 : parrello 1.75 $cgi->textfield(-name => "maxrole", -size => 6, -value => 100),
401 :     $cgi->checkbox(-name => "substring_match", -label => 'Allow substring match'),
402 :     "</td></td></table>",
403 :     $cgi->submit('Search'),
404 :     $cgi->submit('Search genome selected below'),
405 :     $cgi->reset('Clear'),
406 :     $cgi->hr);
407 : olson 1.41
408 : golsen 1.47 my @display = ( 'All', 'Archaea', 'Bacteria', 'Eucarya', 'Viruses', 'Environmental samples' );
409 :    
410 :     #
411 :     # Canonical names must match the keywords used in the DBMS. They are
412 :     # defined in compute_genome_counts.pl
413 :     #
414 :     my %canonical = (
415 :     'All' => undef,
416 :     'Archaea' => 'Archaea',
417 :     'Bacteria' => 'Bacteria',
418 :     'Eucarya' => 'Eukaryota',
419 :     'Viruses' => 'Virus',
420 :     'Environmental samples' => 'Environmental Sample'
421 :     );
422 :    
423 :     my $req_dom = $cgi->param( 'domain' ) || 'All';
424 :     my @domains = $cgi->radio_group( -name => 'domain',
425 :     -default => $req_dom,
426 :     -override => 1,
427 :     -values => [ @display ]
428 :     );
429 :    
430 :     my $n_domain = 0;
431 :     my %dom_num = map { ( $_, $n_domain++ ) } @display;
432 :     my $req_dom_num = $dom_num{ $req_dom } || 0;
433 :    
434 :     #
435 :     # Viruses and Environmental samples must have completeness = All (that is
436 :     # how they are in the database). Otherwise, default is Only "complete".
437 :     #
438 :     my $req_comp = ( $req_dom_num > $dom_num{ 'Eucarya' } ) ? 'All'
439 :     : $cgi->param( 'complete' ) || 'Only "complete"';
440 :     my @complete = $cgi->radio_group( -name => 'complete',
441 :     -default => $req_comp,
442 :     -override => 1,
443 :     -values => [ 'All', 'Only "complete"' ]
444 :     );
445 :     #
446 :     # Use $fig->genomes( complete, restricted, domain ) to get org list:
447 :     #
448 :     my $complete = ( $req_comp =~ /^all$/i ) ? undef : "complete";
449 : redwards 1.48
450 :     my @orgs = sort map { $org = $_; my $gs = $fig->genus_species($org); my $gc=scalar $fig->all_contigs($org); "$gs ($org) [$gc contigs]" }
451 : golsen 1.47 $fig->genomes( $complete, undef, $canonical{ $req_dom } );
452 :    
453 :     my $n_genomes = @orgs;
454 :    
455 : golsen 1.59 push( @$html, $cgi->h2('If You Need to Pick a Genome for Options Below'),
456 : golsen 1.47 "<TABLE>\n",
457 :     " <TR>\n",
458 :     " <TD>",
459 : parrello 1.75 $cgi->scrolling_list( -name => 'korgs',
460 : golsen 1.47 -values => [ @orgs ],
461 : redwards 1.63 -size => 10,
462 : golsen 1.60 ), $cgi->br,
463 : golsen 1.47 "$n_genomes genomes shown ",
464 : golsen 1.60 $cgi->submit( 'Update List' ), $cgi->reset, $cgi->br,
465 : parrello 1.75 "Show some ", $cgi->submit('statistics')," of the selected genome",
466 : overbeek 1.77 " </TD>");
467 :    
468 :     push(@$html,
469 : golsen 1.47 " <TD>",
470 :     join( "<br>", "<b>Domain(s) to show:</b>", @domains), "<br>\n",
471 :     join( "<br>", "<b>Completeness?</b>", @complete), "\n",
472 :     "</TD>",
473 :     " </TR>\n",
474 :     "</TABLE>\n",
475 : golsen 1.60 $cgi->hr
476 :     );
477 : overbeek 1.49
478 : golsen 1.47 push( @$html, $cgi->h2('Finding Candidates for a Functional Role'),
479 : parrello 1.75 "Make sure that you type the functional role you want to search for in the Search Pattern above",
480 :     $cgi->br,
481 :     $cgi->submit('Find Genes in Org that Might Play the Role'),
482 :     $cgi->hr);
483 : overbeek 1.17
484 : golsen 1.60 my @maps = sort map { $map = $_; $name = $fig->map_name($map); "$name ($map)" } $fig->all_maps;
485 :    
486 : golsen 1.47 push( @$html, $cgi->h2('Metabolic Overviews and Subsystem Maps (via KEGG & SEED) - Choose Map'),
487 : parrello 1.75 $cgi->submit('Metabolic Overview'),
488 :     $cgi->br,
489 :     $cgi->br,
490 :     $cgi->scrolling_list(-name => 'kmap',
491 : efrank 1.1 -values => [@maps],
492 : parrello 1.75 -size => 10
493 : efrank 1.1 ),
494 : parrello 1.75 $cgi->hr);
495 : overbeek 1.17
496 : golsen 1.47 push( @$html, $cgi->h2('Searching DNA or Protein Sequences (in a selected organism)'),
497 : parrello 1.75 "<TABLE>\n",
498 :     " <TR>\n",
499 :     " <TD>Sequence/Pattern: </TD>",
500 :     " <TD Colspan=3>", $cgi->textarea(-name => 'seq_pat', -rows => 10, -cols => 70), "</TD>\n",
501 :     " </TR>\n",
502 :     " <TR>\n",
503 :     " <TD>Search Program: </TD>",
504 :     " <TD>", $cgi->popup_menu(-name => 'Tool', -values => ['blastp', 'blastx', 'blastn', 'tblastn', 'blastp against complete genomes', 'Protein scan_for_matches', 'DNA scan_for_matches'], -default => 'blastp'), " </TD>",
505 :     " <TD> Program Options:</TD>",
506 :     " <TD>", $cgi->textfield( -name => "blast_options", -size => 27 ), "</TD>",
507 :     " </TR>\n",
508 :     "</TABLE>\n",
509 :     $cgi->submit('Search for Matches'),
510 :     $cgi->hr);
511 : overbeek 1.17
512 : olson 1.41 #
513 :     # Make assignment export tbl.
514 :     #
515 :    
516 :     my @atbl;
517 : golsen 1.64 push(@atbl, [ "Extract assignments made by ",
518 : parrello 1.75 $cgi->textfield(-name => "made_by", -size => 25) . " (do not prefix with <b>master:</b>)" ]);
519 : golsen 1.64 push(@atbl, [ "Save as user: ",
520 : parrello 1.75 $cgi->textfield(-name => "save_user", -size => 25) . " (do not prefix with <b>master:</b>)" ] );
521 : golsen 1.64 push(@atbl, [ "After date (MM/DD/YYYY) ",
522 : parrello 1.75 $cgi->textfield(-name => "after_date", -size => 15)]);
523 : olson 1.41
524 :     push(@$html,
525 : overbeek 1.84 $cgi->h2($cgi->a({name => "exporting_assignments"}, 'Exporting Assignments')),
526 : parrello 1.75 &HTML::make_table(undef, \@atbl, '', border => 0),
527 :     $cgi->checkbox(-label => 'Tab-delimited Spreadsheet', -name => 'tabs', -value => 1),
528 :     $cgi->br,
529 :     $cgi->checkbox(-label => 'Save Assignments', -name => 'save_assignments', -value => 1),
530 :     $cgi->br,
531 :     $cgi->submit('Extract Assignments'),
532 :     $cgi->br, $cgi->br, $cgi->br,
533 :     "Alternatively, you can generate a set of assignments as translations of existing assignments. ",
534 :     "To do so, you need to make sure that you fill in the <b>Save as user</b> field just above. You ",
535 :     "should use something like <b>RossO</b> (leave out the <b>master:</b>). When you look at the assignments (and decide which ",
536 :     "to actually install), they will be made available under that name (but, when you access them, ",
537 :     "you will normally be using something like <b>master:RossO</b>)",
538 :     $cgi->br,$cgi->br,
539 :     "From: ",
540 :     $cgi->textarea(-name => 'from_func', -rows => 4, -cols => 100),
541 :     $cgi->br,$cgi->br,
542 :     "To:&nbsp;&nbsp;&nbsp;&nbsp; ",$cgi->textfield(-name => "to_func", -size => 100),
543 :     $cgi->br,
544 : overbeek 1.76 $cgi->a({class=>"help", target=>"help", href=>"Html/seedtips.html#replace_names"}, "Help with generate assignments via translation"),
545 : parrello 1.75 $cgi->submit('Generate Assignments via Translation'),
546 :     $cgi->hr,
547 :     $cgi->h2('Searching for Interesting Genes'),
548 :     $cgi->submit('Search for Genes Matching an Occurrence Profile or Common to a Set of Organisms'),
549 : overbeek 1.17 $cgi->end_form
550 : parrello 1.75 );
551 : overbeek 1.14
552 :     push(@$html,
553 : parrello 1.75 $cgi->hr,
554 :     $cgi->h2('Process Saved Assignments Sets'),
555 :     $cgi->start_form(-action => "assignments.cgi"),
556 :     "Here you should include the <b>master:</b>. Thus use something like <b>master:RossO</b>",$cgi->br,
557 :     $cgi->br,
558 :     "Enter user: ",
559 :     $cgi->textfield(-name => "user", -size => 20),
560 :     $cgi->submit('Process Assignment Sets'),
561 : overbeek 1.17 $cgi->end_form
562 : parrello 1.75 );
563 : efrank 1.1
564 : overbeek 1.19 push(@$html,
565 : parrello 1.75 $cgi->hr,
566 :     $cgi->h2('Align Sequences'),
567 : olson 1.89 $cgi->start_form(-action => $this_script),
568 : parrello 1.75 "Enter user: ",
569 :     $cgi->textfield(-name => "user", -size => 20), $cgi->br,
570 :     $cgi->submit('Align Sequences'),": ",
571 :     $cgi->textfield(-name => "seqids", -size => 100),
572 : overbeek 1.31 $cgi->end_form
573 : parrello 1.75 );
574 : overbeek 1.51
575 :     push(@$html,
576 : parrello 1.75 $cgi->hr,
577 :     $cgi->h2('Locate PEGs in Subsystems'),
578 :     "If you wish to locate PEGs in subsystems, you have two approaches supported. You can
579 : overbeek 1.56 give a FIG id, and you will get a list of all homologs in the designated genome that occur in subsystems.
580 :     Alternatively, you can specify a functional role, and all PEGs in the genome that match that role will be shown.",
581 : olson 1.89 $cgi->start_form(-action => $this_script),
582 : parrello 1.75 "Enter user: ",
583 :     $cgi->textfield(-name => "user", -size => 20), $cgi->br,
584 :     $cgi->br,"Genome: ",$cgi->textfield(-name => "genome", -size => 15),$cgi->br,
585 :     "Search: ",$cgi->textfield(-name => "subsearch", -size => 100),$cgi->br,
586 :     $cgi->submit('Find PEGs'),": ",
587 : overbeek 1.51 $cgi->end_form
588 : parrello 1.75 );
589 : efrank 1.1 }
590 :    
591 : overbeek 1.83 #
592 :     # Show a message of the day if it's present.
593 :     #
594 :     sub show_motd
595 :     {
596 :     my($fig, $cgi, $html) = @_;
597 :    
598 :     my $motd_file = "$FIG_Config::fig_disk/config/motd";
599 :    
600 :     if (open(F, "<$motd_file"))
601 :     {
602 :     push(@$html, "<p>\n");
603 :     while (<F>)
604 :     {
605 :     push(@$html, $_);
606 :     }
607 :     close(F);
608 :     push(@$html, "<hr>\n");
609 :     }
610 :     }
611 : overbeek 1.17
612 :     #==============================================================================
613 :     # Indexed objects (text search)
614 :     #==============================================================================
615 :    
616 : efrank 1.1 sub show_indexed_objects {
617 : golsen 1.22 my($fig, $cgi, $html, $pattern) = @_;
618 :     my($msg, $i);
619 : efrank 1.1
620 :     if ($pattern =~ /^\s*(fig\|\d+\.\d+\.peg\.\d+)\s*$/)
621 :     {
622 : parrello 1.75 my $peg = $1;
623 :     my $user = $cgi->param('user');
624 :     $user = $user ? $user : "";
625 :     $ENV{'REQUEST_METHOD'} = "GET";
626 :     $ENV{"QUERY_STRING"} = "prot=$peg\&user=$user";
627 : olson 1.89 $ENV{"REQUEST_URI"} =~ s/$this_script/protein.cgi/;
628 : parrello 1.78 # TICK is like the back-tick ` operator, but works in Windows.
629 :     my @prot_out = TICK("./protein.cgi");
630 : parrello 1.75 print @prot_out;
631 :     exit;
632 : efrank 1.1 }
633 : overbeek 1.71 $pattern =~ s/([a-zA-Z0-9])\|([a-zA-Z0-9])/$1\\\|$2/ig;
634 : efrank 1.92
635 :     my $search_kind = $cgi->param("search_kind");
636 :     if ( $search_kind && ! ($search_kind eq "DIRECT") ) {
637 :     #otherwise $search_kind is name of controlled vocab
638 :     find_pegs_by_cv($fig, $cgi, $html, $user, $pattern, $search_kind);
639 :     return;
640 :     }
641 :    
642 : overbeek 1.17 push( @$html, $cgi->br );
643 : olson 1.70 my( $peg_index_data, $role_index_data ) = $fig->search_index($pattern, $cgi->param("substring_match") eq "on");
644 : overbeek 1.17 my $maxpeg = defined( $cgi->param("maxpeg") ) ? $cgi->param("maxpeg") : 100;
645 :     my $maxrole = defined( $cgi->param("maxrole") ) ? $cgi->param("maxrole") : 100;
646 :    
647 : redwards 1.53 # RAE added lines to allow searching within a single organism
648 : golsen 1.59 # if ($cgi->param('korgs'))
649 :     # {
650 :     # $cgi->param('korgs') =~ /\((\d+\.*\d*)\)/;
651 :     # $org=$1; # this should be undef if korgs is not defined
652 :    
653 :     # push (@$html, $cgi->br, "Matches found in ",$cgi->param('korgs'), $cgi->p);
654 :     # my @clean_data; my @clean_index;
655 :     # while (@$peg_index_data)
656 :     # {
657 :     # my ($data, $index)=(shift @$peg_index_data, shift @$role_index_data);
658 :     # next unless (${$data}[0] =~ /^fig\|$org\.peg/);
659 :     # push @clean_data, $data;
660 :     # push @clean_index, $index;
661 :     # }
662 :    
663 :     # @$peg_index_data=@clean_data;
664 :     # @$role_index_data=@clean_index;
665 :     # }
666 :     ## End of added lines
667 : redwards 1.53
668 : redwards 1.63 # RAE version with separate submit buttons and more than one org in korg
669 :     # this is used by organisms.cgi for group specific searches
670 :     if ( $cgi->param('korgs') && $cgi->param('Search Selected Organisms')
671 :     )
672 :     {
673 :     my @temp;
674 :     foreach my $org ($cgi->param('korgs'))
675 :     {
676 :     push @temp, grep { $_->[0] =~ /^fig\|$org/ } @$peg_index_data;
677 :     }
678 :     @$peg_index_data = @temp;
679 :     }
680 :    
681 : golsen 1.59 # GJO version with separate submit buttons
682 : redwards 1.53
683 : golsen 1.59 if ( $cgi->param('korgs') && $cgi->param('korgs') =~ /\((\d+\.*\d*)\)/
684 :     && $cgi->param('Search genome selected below')
685 :     )
686 :     {
687 : parrello 1.75 my $org = $1;
688 :     push @$html, $cgi->br, "Matches found in ",$cgi->param('korgs'), $cgi->p;
689 : mkubal 1.79 @$peg_index_data = grep { $_->[0] =~ /^fig\|$org\.*/ } @$peg_index_data;
690 : redwards 1.53 }
691 :    
692 : golsen 1.59 if ( ( $maxpeg > 0 ) && @$peg_index_data )
693 : overbeek 1.17 {
694 : parrello 1.75 # RAE: Added javascript buttons see below. Only two things are needed.
695 :     # The form must have a name parameter, and the one line of code for the
696 :     # buttons. Everything else is automatic
697 :    
698 :     push( @$html, $cgi->start_form( -method => 'post',
699 :     -target => "window$$",
700 :     -action => 'fid_checked.cgi',
701 :     -name => 'found_pegs'
702 :     ),
703 :     $cgi->hidden(-name => 'user', -value => $user),
704 :     "For Selected (checked) sequences: ",
705 :     $cgi->submit('get sequences'),
706 :     $cgi->submit('view annotations'),
707 :     $cgi->submit('assign/annotate'),
708 :     $cgi->param('SPROUT') ? () : $cgi->submit('view similarities'),
709 :     $cgi->br, $cgi->br
710 :     );
711 : efrank 1.1
712 : redwards 1.63 # RAE Add the check all/uncheck all boxes.
713 :     push (@$html, $cgi->br, &HTML::java_buttons("found_pegs", "checked"), $cgi->br);
714 : parrello 1.75
715 :     my $n = @$peg_index_data;
716 :     if ($n > $maxpeg)
717 :     {
718 :     $msg = "Showing first $maxpeg out of $n protein genes";
719 :     $#{$peg_index_data} = $maxpeg-1;
720 :     }
721 :     else
722 :     {
723 : mkubal 1.79 $msg = "Showing $n FEATURES";
724 : parrello 1.75 }
725 :    
726 : mkubal 1.79 my $col_hdrs = ["Sel","FEATURE","Organism","Aliases","Function","Who"];
727 : parrello 1.75 my $tab = [ map { format_peg_entry( $fig, $cgi, $_ ) } @$peg_index_data ];
728 :     push( @$html, &HTML::make_table($col_hdrs,$tab,$msg),
729 :     $cgi->br,
730 :     "For SELECTed (checked) sequences: ",
731 :     $cgi->submit('get sequences'),
732 :     $cgi->submit('view annotations'),
733 :     $cgi->submit('assign/annotate'),
734 :     $cgi->param('SPROUT') ? () : $cgi->submit('view similarities'),
735 :     $cgi->br,
736 :     $cgi->end_form
737 :     );
738 : efrank 1.1 }
739 : golsen 1.59 elsif ( $maxpeg > 0 )
740 :     {
741 : parrello 1.75 push @$html, $cgi->h3('No matching protein genes');
742 : golsen 1.59 }
743 : overbeek 1.17
744 : golsen 1.59 if ( ( $maxrole > 0 ) && @$role_index_data )
745 : efrank 1.1 {
746 : parrello 1.75 my $n = @$role_index_data;
747 :     if ($n > $maxrole)
748 :     {
749 :     $msg = "Showing first $maxrole out of $n Roles";
750 :     $#{$role_index_data} = $maxrole - 1;
751 :     }
752 :     else
753 :     {
754 :     $msg = "Showing $n Roles";
755 :     }
756 :    
757 :     if ( $maxpeg > 0 ) { push( @$html, $cgi->hr ) }
758 :     my $col_hdrs = ["Role"];
759 :     my $tab = [ map { &format_role_entry($fig,$cgi,$_) } @$role_index_data ];
760 :     push( @$html, &HTML::make_table($col_hdrs,$tab,$msg) );
761 : efrank 1.1 }
762 : golsen 1.59 elsif ( $maxrole > 0 )
763 :     {
764 : parrello 1.75 push @$html, $cgi->h3('No matching roles');
765 : golsen 1.59 }
766 : efrank 1.1 }
767 :    
768 : golsen 1.59
769 : efrank 1.1 sub format_peg_entry {
770 : golsen 1.67 my( $fig, $cgi, $entry ) = @_;
771 : efrank 1.1 my($i,$function,$who);
772 :    
773 :     my($peg,$gs,$aliases,@funcs) = @$entry;
774 : overbeek 1.17
775 : golsen 1.21 $gs =~ s/\s+\d+$//; # Org name comes with taxon_id appended (why?) -- GJO
776 : efrank 1.1
777 :     @funcs = map { $_ =~ s/^function:\s*//; $_ } @funcs;
778 :    
779 :     if ($aliases)
780 :     {
781 : parrello 1.75 $aliases =~ s/^aliases://;
782 : efrank 1.1 }
783 :     else
784 :     {
785 : parrello 1.75 $aliases = "";
786 : efrank 1.1 }
787 :    
788 : golsen 1.21 my $user = $cgi->param('user');
789 :     $user = $user ? $user : "";
790 :    
791 : efrank 1.1 if ($user)
792 :     {
793 : parrello 1.75 for ($i=0; ($i < @funcs) && ($funcs[$i] !~ /\#$user/); $i++) {}
794 :     if ($i < @funcs)
795 :     {
796 :     ($function,$who) = split(/\#/,$funcs[$i]);
797 :     }
798 : efrank 1.1 }
799 : golsen 1.21
800 : efrank 1.1 if (! $function)
801 :     {
802 : parrello 1.75 for ($i=0; ($i < @funcs) && ($funcs[$i] !~ /\#master/); $i++) {}
803 :     if ($i < @funcs)
804 :     {
805 :     ($function,$who) = split(/\#/,$funcs[$i]);
806 :     }
807 : efrank 1.1 }
808 :    
809 :     if ((! $function) && (@funcs > 0))
810 :     {
811 : parrello 1.75 ($function,$who) = split(/\#/,$funcs[0]);
812 : efrank 1.1 }
813 : golsen 1.67 my $box = "<input type=checkbox name=checked value=\"$peg\">";
814 : overbeek 1.17 return [ $box, &HTML::fid_link($cgi,$peg), $gs, $aliases, $function, $who ];
815 : efrank 1.1 }
816 :    
817 :     sub format_role_entry {
818 :     my($fig,$cgi,$entry) = @_;
819 :    
820 :     return [&HTML::role_link($cgi,$entry)];
821 :     }
822 :    
823 :     sub run_prot_scan_for_matches {
824 :     my($fig,$cgi,$html,$org,$pat) = @_;
825 :     my($string,$peg,$beg,$end,$user,$col_hdrs,$tab,$i);
826 :    
827 :     my $tmp_pat = "$FIG_Config::temp/tmp$$.pat";
828 :     open(PAT,">$tmp_pat")
829 : parrello 1.75 || die "could not open $tmp_pat";
830 : efrank 1.1 $pat =~ s/[\s\012\015]+/ /g;
831 :     print PAT "$pat\n";
832 :     close(PAT);
833 :     my @out = `$FIG_Config::ext_bin/scan_for_matches -p $tmp_pat < $FIG_Config::organisms/$org/Features/peg/fasta`;
834 :     if (@out < 1)
835 :     {
836 : parrello 1.75 push(@$html,$cgi->h1("Sorry, no hits"));
837 : efrank 1.1 }
838 :     else
839 :     {
840 : parrello 1.75 if (@out > 2000)
841 :     {
842 :     push(@$html,$cgi->h1("truncating to the first 1000 hits"));
843 :     $#out = 1999;
844 :     }
845 :    
846 :     push(@$html,$cgi->pre);
847 :     $user = $cgi->param('user');
848 :     $col_hdrs = ["peg","begin","end","string","function of peg"];
849 :     for ($i=0; ($i < @out); $i += 2)
850 :     {
851 :     if ($out[$i] =~ /^>([^:]+):\[(\d+),(\d+)\]/)
852 :     {
853 :     $peg = $1;
854 :     $beg = $2;
855 :     $end = $3;
856 :     $string = $out[$i+1];
857 :     chomp $string;
858 :     push( @$tab, [ &HTML::fid_link($cgi,$peg,1),
859 :     $beg,
860 :     $end,
861 :     $string,
862 :     scalar $fig->function_of( $peg, $user )
863 :     ]
864 :     );
865 :     }
866 :     }
867 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Matches"));
868 :     push(@$html,$cgi->end_pre);
869 : efrank 1.1 }
870 :     unlink($tmp_pat);
871 :     }
872 :    
873 : overbeek 1.17 #==============================================================================
874 :     # Scan for matches
875 :     #==============================================================================
876 :    
877 : efrank 1.1 sub run_dna_scan_for_matches {
878 :     my($fig,$cgi,$html,$org,$pat) = @_;
879 :     my($string,$contig,$beg,$end,$col_hdrs,$tab,$i);
880 :    
881 :     my $tmp_pat = "$FIG_Config::temp/tmp$$.pat";
882 :     open(PAT,">$tmp_pat")
883 : parrello 1.75 || die "could not open $tmp_pat";
884 : efrank 1.1 $pat =~ s/[\s\012\015]+/ /g;
885 :     print PAT "$pat\n";
886 :     close(PAT);
887 :     my @out = `cat $FIG_Config::organisms/$org/contigs | $FIG_Config::ext_bin/scan_for_matches -c $tmp_pat`;
888 :     if (@out < 1)
889 :     {
890 : parrello 1.75 push(@$html,$cgi->h1("Sorry, no hits"));
891 : efrank 1.1 }
892 :     else
893 :     {
894 : parrello 1.75 if (@out > 2000)
895 :     {
896 :     push(@$html,$cgi->h1("truncating to the first 1000 hits"));
897 :     $#out = 1999;
898 :     }
899 :    
900 :     push(@$html,$cgi->pre);
901 :     $col_hdrs = ["contig","begin","end","string"];
902 :     for ($i=0; ($i < @out); $i += 2)
903 :     {
904 :     if ($out[$i] =~ /^>([^:]+):\[(\d+),(\d+)\]/)
905 :     {
906 :     $contig = $1;
907 :     $beg = $2;
908 :     $end = $3;
909 :     $string = $out[$i+1];
910 :     chomp $string;
911 :     push(@$tab,[$contig,$beg,$end,$string]);
912 :     }
913 :     }
914 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Matches"));
915 :     push(@$html,$cgi->end_pre);
916 : efrank 1.1 }
917 :     unlink($tmp_pat);
918 :     }
919 :    
920 : overbeek 1.17 #==============================================================================
921 :     # BLAST search
922 :     #==============================================================================
923 :    
924 : efrank 1.1 sub run_blast {
925 : golsen 1.45 my( $fig, $cgi, $html, $org, $tool, $seq ) = @_;
926 :     my( $query, @out );
927 : efrank 1.1
928 : golsen 1.45 my $tmp_seq = "$FIG_Config::temp/run_blast_tmp$$.seq";
929 : efrank 1.1
930 : overbeek 1.17 #--------------------------------------------------------------------------
931 :     # Is the request for an id? Get the sequence
932 :     #--------------------------------------------------------------------------
933 : golsen 1.91 if ( ( $query ) = $seq =~ /^\s*([a-zA-Z]{2,4}\|\S+)/ )
934 : efrank 1.1 {
935 : parrello 1.75 # Replaced $id with $query so that output inherits label -- GJO
936 : golsen 1.91 # Found ugly fairure to build correct query sequence for
937 :     # 'blastp against complete genomes'. Can't figure out
938 :     # why it ever worked with and id -- GJO
939 :    
940 : parrello 1.75 $seq = "";
941 : golsen 1.91 if ( ($tool eq "blastp") || ($tool eq "tblastn")
942 :     || ($tool eq 'blastp against complete genomes')
943 :     )
944 : parrello 1.75 {
945 :     $seq = $fig->get_translation($query);
946 :     }
947 :     elsif ($query =~ /^fig/)
948 :     {
949 :     my @locs;
950 :     if ((@locs = $fig->feature_location($query)) && (@locs > 0))
951 :     {
952 :     $seq = $fig->dna_seq($fig->genome_of($query),@locs);
953 :     }
954 :     }
955 :     if (! $seq)
956 :     {
957 :     push(@$html,$cgi->h1("Sorry, could not get sequence for $query"));
958 :     return;
959 :     }
960 : efrank 1.1 }
961 : golsen 1.45
962 : overbeek 1.17 #--------------------------------------------------------------------------
963 :     # Is it a fasta format? Get the query name
964 :     #--------------------------------------------------------------------------
965 : golsen 1.45
966 :     elsif ( $seq =~ s/^>\s*(\S+[^\n\012\015]*)// ) # more flexible match -- GJO
967 : efrank 1.1 {
968 : parrello 1.75 $query = $1;
969 : efrank 1.1 }
970 : golsen 1.45
971 : overbeek 1.17 #--------------------------------------------------------------------------
972 :     # Take it as plain text
973 :     #--------------------------------------------------------------------------
974 : golsen 1.45
975 : efrank 1.1 else
976 :     {
977 : parrello 1.75 $query = "query";
978 : efrank 1.1 }
979 : golsen 1.45
980 :     #
981 :     # The rest is taken as the sequence
982 :     #
983 :    
984 : golsen 1.23 $seq =~ s/\s+//g;
985 : golsen 1.45 open( SEQ, ">$tmp_seq" ) || die "run_blast could not open $tmp_seq";
986 : efrank 1.1 print SEQ ">$query\n$seq\n";
987 : golsen 1.45 close( SEQ );
988 : efrank 1.1
989 :     if (! $ENV{"BLASTMAT"}) { $ENV{"BLASTMAT"} = "$FIG_Config::blastmat" }
990 : golsen 1.88 my $blast_opt = $cgi->param( 'blast_options' ) || '';
991 : efrank 1.1
992 : golsen 1.45 if ( $tool eq "blastp" )
993 : efrank 1.1 {
994 : parrello 1.75 my $db = "$FIG_Config::organisms/$org/Features/peg/fasta";
995 :     &verify_db( $db, "p" );
996 : golsen 1.88 @out = map { &HTML::set_prot_links($cgi,$_) } execute_blastall( 'blastp', $tmp_seq, $db, $blast_opt );
997 : efrank 1.1 }
998 : golsen 1.45
999 :     elsif ( $tool eq "blastx" )
1000 : efrank 1.1 {
1001 : parrello 1.75 my $db = "$FIG_Config::organisms/$org/Features/peg/fasta";
1002 :     &verify_db( $db, "p" );
1003 : golsen 1.88 @out = map { &HTML::set_prot_links($cgi,$_) } execute_blastall( 'blastx', $tmp_seq, $db, $blast_opt );
1004 : efrank 1.1 }
1005 : golsen 1.45
1006 :     elsif ( $tool eq "blastn" )
1007 : efrank 1.1 {
1008 : parrello 1.75 my $db = "$FIG_Config::organisms/$org/contigs";
1009 :     &verify_db( $db, "n" ); ### fix to get all contigs
1010 : golsen 1.88 @out = execute_blastall( 'blastn', $tmp_seq, $db, "-r 1 -q -1 " . $blast_opt );
1011 : parrello 1.75 push @$html, blast_graphics( $fig, $cgi, $org, \@out, $tool );
1012 : efrank 1.1 }
1013 : golsen 1.45
1014 :     elsif ( $tool eq "tblastn" )
1015 : efrank 1.1 {
1016 : parrello 1.75 my $db = "$FIG_Config::organisms/$org/contigs";
1017 :     &verify_db( $db, "n" ); ### fix to get all contigs
1018 : golsen 1.88 @out = execute_blastall( 'tblastn', $tmp_seq, $db, $blast_opt );
1019 : parrello 1.75 push @$html, blast_graphics( $fig, $cgi, $org, \@out, $tool );
1020 : efrank 1.1 }
1021 : golsen 1.45
1022 :     elsif ( $tool eq 'blastp against complete genomes' ) ### this tool gets nonstandard treatment: RAO
1023 : overbeek 1.30 {
1024 : golsen 1.91 &blast_complete( $fig, $cgi, $html, $tmp_seq );
1025 :     unlink( $tmp_seq );
1026 :     return;
1027 : overbeek 1.30 }
1028 : golsen 1.45
1029 : overbeek 1.17 if (@out < 1) # This is really a bigger problem than no hits (GJO)
1030 : efrank 1.1 {
1031 : golsen 1.88 push @$html, $cgi->h1( "Sorry, no blast output" );
1032 : efrank 1.1 }
1033 :     else
1034 :     {
1035 : golsen 1.88 push @$html, $cgi->pre, @out, $cgi->end_pre;
1036 : efrank 1.1 }
1037 : golsen 1.45 unlink( $tmp_seq );
1038 : efrank 1.1 }
1039 :    
1040 : golsen 1.45
1041 : golsen 1.88 # `$blastall -p $prog -i $tmp_seq -d $db $blast_opt`
1042 :     # execute_blastall( $prog, $input_file, $db, $options )
1043 :    
1044 :     sub execute_blastall
1045 :     {
1046 :     my( $prog, $input, $db, $options ) = @_;
1047 :    
1048 :     my $blastall = "$FIG_Config::ext_bin/blastall";
1049 :     my @args = ( '-p', $prog, '-i', $input, '-d', $db, split(/\s+/, $options) );
1050 :    
1051 :     my $bfh;
1052 :     my $pid = open( $bfh, "-|" );
1053 :     if ( $pid == 0 )
1054 :     {
1055 :     exec( $blastall, @args );
1056 :     die join( " ", $blastall, @args, "failed: $!" );
1057 :     }
1058 :    
1059 : golsen 1.91 <$bfh>
1060 : golsen 1.88 }
1061 :    
1062 :    
1063 : golsen 1.91 # Changed to:
1064 :     # Include low complexity filter in blast search.
1065 :     # Remove all but first match to a given database sequence.
1066 :     # Sort by bit-score, not E-value (which becomes equal for all strong matches).
1067 :     # Limit to 1000 matches.
1068 :     # -- GJO
1069 :    
1070 :     sub blast_complete
1071 :     {
1072 :     my( $fig, $cgi, $html, $seqfile ) = @_;
1073 : golsen 1.88 my( $genome, @sims );
1074 :    
1075 : overbeek 1.30 @sims = ();
1076 : golsen 1.91 foreach $genome ( $fig->genomes("complete") )
1077 : overbeek 1.30 {
1078 : parrello 1.75 my $db = "$FIG_Config::organisms/$genome/Features/peg/fasta";
1079 :     next if (! -s $db);
1080 : overbeek 1.30
1081 : parrello 1.75 &verify_db($db,"p");
1082 :     my $sim;
1083 : golsen 1.91 my %seen = ();
1084 :     push @sims, map { chomp;
1085 :     $sim = [ split /\t/ ];
1086 :     $sim->[10] =~ s/^e-/1.0e-/;
1087 :     $seen{ $sim->[1] }++ ? () : $sim
1088 :     }
1089 :     execute_blastall( 'blastp', $seqfile, $db, '-m 8 -F T -e 1e-5' );
1090 : overbeek 1.30 }
1091 : golsen 1.91
1092 :     @sims = sort { $b->[11] <=> $a->[11] } @sims;
1093 :     if ( @sims > 1000 ) { @sims = @sims[0 .. 999] }
1094 : golsen 1.88 &format_sims( $fig, $cgi, $html, \@sims );
1095 : overbeek 1.30 }
1096 :    
1097 : golsen 1.65
1098 :     #------------------------------------------------------------------------------
1099 :     # Graphically display searches against contigs
1100 :     #
1101 :     # use FIGjs qw( toolTipScript );
1102 :     # use GenoGraphics qw( render );
1103 :     # use IPC::Open2 qw( open2 );
1104 :     #------------------------------------------------------------------------------
1105 :     # Fields produced by rationalize_blast:
1106 :     #
1107 :     # 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
1108 :     # HSP score exp p_n p_val n_match n_ident n_sim n_gap dir q1 q2 q_sq s1 s2 s_sq
1109 :     #------------------------------------------------------------------------------
1110 :    
1111 :     sub blast_graphics {
1112 :     my ( $fig_or_sprout, $cgi, $genome, $out, $tool ) = @_;
1113 :    
1114 :     my $e_min = 0.1;
1115 :     my $gg = [];
1116 :     my @html = ();;
1117 :    
1118 :     # Run rationalize_blast:
1119 :    
1120 :     my( $pid, $rd, $wr );
1121 :     if ( $pid = open2( $rd, $wr, "rationalize_blast" ) )
1122 :     {
1123 : parrello 1.75 my $outlen = 0;
1124 :     foreach ( @$out ) { $outlen += length( $_ ) }
1125 : golsen 1.65
1126 : parrello 1.75 $wr->write( join( "", @$out ), $outlen );
1127 :     close( $wr );
1128 : golsen 1.65
1129 :     my ( $qid, $qdef, $qlen, $contig, $sdef, $slen );
1130 :     my @rational = <$rd>;
1131 :     foreach ( map { chomp; $_ } @rational )
1132 :     {
1133 :     if ( /^Query=/ ) { ( undef, $qid, undef, $qlen ) = split /\t/ }
1134 :     elsif ( /^>/ ) { ( undef, $contig, undef, $slen ) = split /\t/ }
1135 :     elsif ( /^HSP/ && $qid && $qlen && $contig && $slen )
1136 :     {
1137 :     my @hsp = split /\t/;
1138 :     next if $hsp[2] > $e_min;
1139 :     my ( $e_val, $q1, $q2, $s1, $s2 ) = @hsp[ 2, 10, 11, 13, 14 ];
1140 :     my ( $genes, $min, $max ) = hsp_context( $fig_or_sprout, $cgi, $genome,
1141 :     $e_val, 100 * $hsp[6] / $hsp[5],
1142 :     $qid, $q1, $q2, $qlen,
1143 :     $contig, $s1, $s2, $slen
1144 :     );
1145 : overbeek 1.74 if ($min && $max)
1146 :     {
1147 :     push @$gg, [ substr( $contig, 0, 18 ), $min, $max, $genes ];
1148 :     }
1149 : golsen 1.65 }
1150 :     }
1151 :     close( $rd );
1152 :    
1153 :     # $gene = [ $beg, $end, $shape, $color, $text, $url, $pop-up, $alt_action, $pop-up_title ];
1154 :     # $genes = [ $gene, $gene, ... ];
1155 :     # $map = [ $label, $min_coord, $max_coord, $genes ];
1156 :     # $gg = [ $map, $map, ... ];
1157 :     # render( $gg, $width, $obj_half_heigth, $save, $img_index_number )
1158 :    
1159 : overbeek 1.86 if ( @$gg )
1160 :     {
1161 :     # print STDERR Dumper( $gg );
1162 :     my $gs = $fig_or_sprout->genus_species( $genome );
1163 :     my $space = "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;";
1164 :     my $legend = "<TABLE>\n"
1165 :     . " <TR>\n"
1166 :     . " <TD>Q = Query sequence$space</TD>\n"
1167 :     . " <TD Bgcolor='#FF0000'>$space</TD><TD>Frame 1 translation$space</TD>\n"
1168 :     . " <TD Bgcolor='#00FF00'>$space</TD><TD>Frame 2 translation$space</TD>\n"
1169 :     . " <TD Bgcolor='#0000FF'>$space</TD><TD>Frame 3 translation$space</TD>\n"
1170 :     . " <TD Bgcolor='#808080'>$space</TD><TD>Untranslated sequence</TD>\n"
1171 :     . " </TR>\n"
1172 :     . "</TABLE><P />";
1173 :    
1174 :     push @html, "\n", FIGjs::toolTipScript(), "\n",
1175 :     $cgi->h2( "Results of $tool search of contigs from $gs\n"),
1176 :     $legend,
1177 :     @{ GenoGraphics::render( $gg, 600, 4, 0, 1 ) },
1178 :     $cgi->hr, "\n";
1179 :     }
1180 :    
1181 : parrello 1.75 waitpid $pid, 0;
1182 : golsen 1.65 }
1183 :    
1184 :     return @html;
1185 :     }
1186 :    
1187 :    
1188 :     sub hsp_context {
1189 :     my( $fig_or_sprout, $cgi, $genome, $e_val, $pct_id,
1190 :     $qid, $q1, $q2, $qlen,
1191 : parrello 1.75 $contig, $s1, $s2, $slen ) = @_;
1192 : golsen 1.65 my $half_sz = 5000;
1193 :    
1194 :     my( $from, $to, $features, $fid, $beg, $end );
1195 :     my( $link, $lbl, $isprot, $function, $uniprot, $info, $prot_query );
1196 :    
1197 :     my $user = $cgi->param( 'user' ) || "";
1198 :     my $sprout = $cgi->param( 'SPROUT' ) ? '&SPROUT=1' : '';
1199 :    
1200 :     my @genes = ();
1201 :    
1202 :     # Based on the match position of the query, select the context region:
1203 :    
1204 :     ( $from, $to ) = ( $s1 <= $s2 ) ? ( $s1 - $half_sz, $s2 + $half_sz )
1205 :     : ( $s2 - $half_sz, $s1 + $half_sz );
1206 :     $from = 1 if ( $from < 1 );
1207 :     $to = $slen if ( $to > $slen );
1208 :    
1209 :     # Get the genes in the region, and adjust the ends to include whole genes:
1210 :    
1211 :     ( $features, $from, $to ) = genes_in_region( $fig_or_sprout, $cgi, $genome, $contig, $from, $to );
1212 :    
1213 :    
1214 :     # Add the other features:
1215 :    
1216 :     foreach $fid ( @$features )
1217 :     {
1218 : parrello 1.75 my $contig1;
1219 :     ( $contig1, $beg, $end ) = boundaries_of( $fig_or_sprout, feature_locationS( $fig_or_sprout, $fid ) );
1220 :     next if $contig1 ne $contig;
1221 :    
1222 :     $link = "";
1223 :     if ( ( $lbl ) = $fid =~ /peg\.(\d+)$/ ) {
1224 : overbeek 1.82 ( $link = $cgi->url(-relative => 1) ) =~ s/index\.cgi/protein.cgi/;
1225 : parrello 1.75 $link .= "?prot=$fid&user=$user$sprout";
1226 :     $isprot = 1;
1227 :     } elsif ( ( $lbl ) = $fid =~ /\.([a-z]+)\.\d+$/ ) {
1228 :     $lbl = uc $lbl;
1229 :     $isprot = 0;
1230 :     } else {
1231 :     $lbl = "";
1232 :     $isprot = 0;
1233 :     }
1234 :    
1235 :     $function = function_ofS( $fig_or_sprout, $fid );
1236 :    
1237 :     $uniprot = join ", ", grep { /^uni\|/ } feature_aliasesL( $fig_or_sprout, $fid);
1238 :    
1239 :     $info = join( '<br />', "<b>Feature:</b> $fid",
1240 :     "<b>Contig:</b> $contig",
1241 :     "<b>Begin:</b> $beg",
1242 :     "<b>End:</b> $end",
1243 :     $function ? "<b>Function:</b> $function" : '',
1244 :     $uniprot ? "<b>Uniprot ID:</b> $uniprot" : ''
1245 :     );
1246 :    
1247 :     push @genes, [ feature_graphic( $beg, $end, $isprot ),
1248 :     $lbl, $link, $info,
1249 :     $isprot ? () : ( undef, "Feature information" )
1250 :     ];
1251 : golsen 1.65 }
1252 :    
1253 :     # Draw the query. The subject coordinates are always DNA. If the query
1254 :     # is protein, it is about 3 times shorter than the matching contig DNA.
1255 :     # Splitting the difference, if 1.7 times the query length is still less
1256 :     # than the subject length, we will call it a protein query (and reading
1257 :     # frame in the contig coordinates has meaning). If it is nucleotides,
1258 :     # there is no defined frame.
1259 :    
1260 :     $info = join( '<br />', $qid ne 'query ' ? "<b>Query:</b> $qid" : (),
1261 :     "<b>Length:</b> $qlen",
1262 :     "<b>E-value:</b> $e_val",
1263 :     "<b>% identity:</b> " . sprintf( "%.1f", $pct_id ),
1264 :     "<b>Region of similarity:</b> $q1 &#150; $q2"
1265 :     );
1266 :     $prot_query = ( 1.7 * abs( $q2 - $q1 ) < abs( $s2 - $s1 ) ) ? 1 : 0;
1267 :    
1268 :     push @genes, [ feature_graphic( $s1, $s2, $prot_query ),
1269 :     'Q', undef, $info, undef, 'Query and match information'
1270 :     ];
1271 :    
1272 :     return \@genes, $from, $to;
1273 :     }
1274 :    
1275 :    
1276 :     sub feature_graphic {
1277 :     my ( $beg, $end, $isprot ) = @_;
1278 :     my ( $min, $max, $symb, $color );
1279 :    
1280 :     ( $min, $max, $symb ) = ( $beg <= $end ) ? ( $beg, $end, "rightArrow" )
1281 :     : ( $end, $beg, "leftArrow" );
1282 :    
1283 :     # Color proteins by translation frame
1284 :    
1285 :     $color = $isprot ? qw( blue red green )[ $beg % 3 ] : 'grey';
1286 :    
1287 :     ( $min, $max, $symb, $color );
1288 :     }
1289 :    
1290 :    
1291 :     sub genes_in_region {
1292 :     my( $fig_or_sprout, $cgi, $genome, $contig, $min, $max ) = @_;
1293 :    
1294 :     if ( $cgi->param( 'SPROUT' ) )
1295 :     {
1296 : parrello 1.75 my( $x, $feature_id );
1297 :     my( $feat, $min, $max ) = $fig_or_sprout->genes_in_region( $genome, $contig, $min, $max );
1298 :     my @tmp = sort { ($a->[1] cmp $b->[1]) or
1299 :     (($a->[2]+$a->[3]) <=> ($b->[2]+$b->[3]))
1300 :     }
1301 :     map { $feature_id = $_;
1302 :     $x = feature_locationS( $fig_or_sprout, $feature_id );
1303 :     $x ? [ $feature_id, boundaries_of( $fig_or_sprout, $x )] : ()
1304 :     }
1305 :     @$feat;
1306 :     return ( [map { $_->[0] } @tmp ], $min, $max );
1307 : golsen 1.65 }
1308 :     else
1309 :     {
1310 : parrello 1.75 return $fig_or_sprout->genes_in_region( $genome, $contig, $min, $max );
1311 : golsen 1.65 }
1312 :     }
1313 :    
1314 :    
1315 :     sub feature_locationS {
1316 :     my ( $fig_or_sprout, $peg ) = @_;
1317 :     scalar $fig_or_sprout->feature_location( $peg );
1318 :     }
1319 :    
1320 :    
1321 :     sub boundaries_of {
1322 :     my( $fig_or_sprout, $loc ) = @_;
1323 :     $fig_or_sprout->boundaries_of( $loc );
1324 :     }
1325 :    
1326 :    
1327 :     sub function_ofS {
1328 :     my( $fig_or_sprout, $peg, $user ) = @_;
1329 :     scalar $fig_or_sprout->function_of( $peg, $user );
1330 :     }
1331 :    
1332 :    
1333 :     sub feature_aliasesL {
1334 :     my( $fig_or_sprout, $fid ) = @_;
1335 :     my @tmp = $fig_or_sprout->feature_aliases( $fid );
1336 :     @tmp
1337 :     }
1338 :    
1339 :    
1340 : overbeek 1.30 sub format_sims {
1341 :     my($fig,$cgi,$html,$sims) = @_;
1342 :     my($col_hdrs,$table,@ids,$ids,$sim,%seen);
1343 :    
1344 :     $col_hdrs = [ "Select up to here",
1345 : parrello 1.75 "Similar sequence",
1346 :     "E-val",
1347 :     "Function",
1348 :     "Organism",
1349 :     "Aliases"
1350 :     ];
1351 : overbeek 1.30
1352 :     $table = [];
1353 :     @ids = ();
1354 :     if (@$sims > 1000) { $#{$sims} = 999 }
1355 :     foreach $sim (@$sims)
1356 :     {
1357 : parrello 1.75 if (! $seen{$sim->[1]})
1358 :     {
1359 : golsen 1.91 my $alii = scalar $fig->feature_aliases($sim->[1]);
1360 :     $alii =~ s/,/, /g;
1361 : parrello 1.75 push(@$table,[$cgi->checkbox(-name => 'list_to', -value => $sim->[1], -override => 1, -checked => 0, -label => ""),
1362 :     &HTML::fid_link($cgi,$sim->[1]),
1363 :     $sim->[10],
1364 :     scalar $fig->function_of($sim->[1]),
1365 : overbeek 1.30 $fig->genus_species(&FIG::genome_of($sim->[1])),
1366 : golsen 1.91 $alii
1367 : parrello 1.75 ]);
1368 :     push(@ids,$sim->[1]);
1369 :     }
1370 : overbeek 1.30 }
1371 :     $ids = join(",",@ids);
1372 :     my $target = "window$$";
1373 :     push(@$html, $cgi->start_form( -method => 'post',
1374 : parrello 1.75 -target => $target,
1375 : olson 1.89 -action => $this_script
1376 : parrello 1.75 ),
1377 :     $cgi->hidden(-name => 'ids', -value => $ids),
1378 :     &HTML::make_table($col_hdrs,$table,"Best Hits"),
1379 :     $cgi->submit('Extract Matched Sequences'),
1380 :     $cgi->end_form);
1381 : overbeek 1.30 }
1382 : overbeek 1.17
1383 : efrank 1.1 sub verify_db {
1384 :     my($db,$type) = @_;
1385 :    
1386 : overbeek 1.17 if ($type =~ /^p/i)
1387 : efrank 1.1 {
1388 : parrello 1.75 if ((! -s "$db.psq") || (-M "$db.psq" > -M $db))
1389 :     {
1390 :     system "$FIG_Config::ext_bin/formatdb -p T -i $db";
1391 :     }
1392 : efrank 1.1 }
1393 :     else
1394 :     {
1395 : parrello 1.75 if ((! -s "$db.nsq") || (-M "$db.nsq" > -M $db))
1396 :     {
1397 :     system "$FIG_Config::ext_bin/formatdb -p F -i $db";
1398 :     }
1399 : efrank 1.1 }
1400 : parrello 1.75 }
1401 : overbeek 1.7
1402 :     sub export_assignments {
1403 :     my($fig,$cgi,$html,$who) = @_;
1404 :     my($genome,$x);
1405 :    
1406 :     my @genomes = map { $_ =~ /\((\d+\.\d+)\)/; $1 } $cgi->param('korgs');
1407 :    
1408 :     if (@genomes == 0)
1409 :     {
1410 : parrello 1.75 @genomes = $fig->genomes;
1411 : overbeek 1.7 }
1412 :    
1413 : overbeek 1.10 my @assignments = $fig->assignments_made(\@genomes,$who,$cgi->param('after_date'));
1414 : overbeek 1.7 if (@assignments == 0)
1415 :     {
1416 : parrello 1.75 push(@$html,$cgi->h1("Sorry, no assignments where made by $who"));
1417 : overbeek 1.7 }
1418 :     else
1419 :     {
1420 : parrello 1.75 my $col_hdrs = ["FIG id", "External ID", "Genus/Species","Assignment"];
1421 :     my $tab = [];
1422 :     my($x,$peg,$func);
1423 :     foreach $x (@assignments)
1424 :     {
1425 :     ( $peg, $func ) = @$x;
1426 :     push( @$tab,[ HTML::set_prot_links( $cgi, $peg ),
1427 :     HTML::set_prot_links( $cgi, ext_id( $fig, $peg ) ),
1428 :     $fig->genus_species($fig->genome_of($peg)),
1429 :     $func
1430 :     ] );
1431 :     }
1432 :    
1433 :     if ($cgi->param('save_assignments'))
1434 :     {
1435 :     my $user = $cgi->param('save_user');
1436 :     if ($user)
1437 :     {
1438 :     &FIG::verify_dir("$FIG_Config::data/Assignments/$user");
1439 :     my $file = &FIG::epoch_to_readable(time) . ":$who:exported_from_local_SEED";
1440 :     if (open(TMP,">$FIG_Config::data/Assignments/$user/$file"))
1441 :     {
1442 :     print TMP join("",map { join("\t",@$_) . "\n" } map { [$_->[0],$_->[3]] } @$tab);
1443 :     close(TMP);
1444 :     }
1445 :     push(@$html,$cgi->h1("Saved Assignment Set $file"));
1446 :     }
1447 :     else
1448 :     {
1449 :     push(@$html,$cgi->h1("You need to specify a user to save an assignment set"));
1450 :     }
1451 :     }
1452 :    
1453 :     if ($cgi->param('tabs'))
1454 :     {
1455 :     print $cgi->header;
1456 :     print "<pre>\n";
1457 :     print join("",map { join("\t",@$_) . "\n" } @$tab);
1458 :     print "</pre>\n";
1459 :     exit;
1460 :     }
1461 :     else
1462 :     {
1463 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Assignments Made by $who"));
1464 :     }
1465 : overbeek 1.7 }
1466 :     }
1467 :    
1468 :     sub ext_id {
1469 :     my($fig,$peg) = @_;
1470 :    
1471 :     my @mapped = grep { $_ !~ /^fig/ } map { $_->[0] } $fig->mapped_prot_ids($peg);
1472 :     if (@mapped == 0)
1473 :     {
1474 : parrello 1.75 return $peg;
1475 : overbeek 1.7 }
1476 :    
1477 :     my @tmp = ();
1478 :     if ((@tmp = grep { $_ =~ /^sp/ } @mapped) && (@tmp > 0)) { return $tmp[0] }
1479 :     if ((@tmp = grep { $_ =~ /^pir/ } @mapped) && (@tmp > 0)) { return $tmp[0] }
1480 :     if ((@tmp = grep { $_ =~ /^gi/ } @mapped) && (@tmp > 0)) { return $tmp[0] }
1481 :     if ((@tmp = grep { $_ =~ /^tr/ } @mapped) && (@tmp > 0)) { return $tmp[0] }
1482 :     if ((@tmp = grep { $_ =~ /^tn/ } @mapped) && (@tmp > 0)) { return $tmp[0] }
1483 :     if ((@tmp = grep { $_ =~ /^kegg/ } @mapped) && (@tmp > 0)) { return $tmp[0] }
1484 :    
1485 :     return $peg;
1486 :     }
1487 :    
1488 : overbeek 1.28 sub translate_assignments {
1489 :     my($fig,$cgi,$html,$from_func,$to_func) = @_;
1490 :    
1491 : overbeek 1.56 my @funcs = grep { $_ =~ /^\S.*\S$/ } split(/[\012\015]+/,$from_func);
1492 :    
1493 : overbeek 1.28 my $user = $cgi->param('save_user');
1494 :     if ($user)
1495 :     {
1496 :     &FIG::verify_dir("$FIG_Config::data/Assignments/$user");
1497 :     my $file = &FIG::epoch_to_readable(time) . ":$user:translation";
1498 :     if (open(TMP,">$FIG_Config::data/Assignments/$user/$file"))
1499 :     {
1500 : overbeek 1.55 my($peg,$func);
1501 : overbeek 1.28
1502 : overbeek 1.56 foreach $from_func (@funcs)
1503 : overbeek 1.28 {
1504 : overbeek 1.57 my $from_funcQ = quotemeta $from_func;
1505 :    
1506 : overbeek 1.56 foreach $peg ($fig->seqs_with_role($from_func))
1507 : overbeek 1.28 {
1508 : overbeek 1.56 if ($peg =~ /^fig\|/)
1509 : overbeek 1.28 {
1510 : overbeek 1.56 $func = $fig->function_of($peg);
1511 :     if ($func eq $from_func)
1512 :     {
1513 :     print TMP "$peg\t$to_func\n";
1514 :     }
1515 : overbeek 1.73 else
1516 : overbeek 1.57 {
1517 : overbeek 1.73 my @pieces = grep { $_ } split(/(\s+[\/@]\s+)|(\s*;\s+)/,$func);
1518 :     if (@pieces > 1)
1519 :     {
1520 :     my $func1 = join("",map { $_ =~ s/^$from_funcQ$/$to_func/; $_ } @pieces);
1521 :     if ($func ne $func1)
1522 :     {
1523 :     print TMP "$peg\t$func1\n";
1524 :     }
1525 :     }
1526 : overbeek 1.57 }
1527 : overbeek 1.28 }
1528 :     }
1529 :     }
1530 :     close(TMP);
1531 :     }
1532 :     push(@$html,$cgi->h1("Saved Assignment Set $file"));
1533 :     }
1534 :     else
1535 :     {
1536 : parrello 1.75 push(@$html,$cgi->h1("You need to specify a user to save an assignment set"));
1537 : overbeek 1.28 }
1538 :     }
1539 : efrank 1.92
1540 :     sub find_pegs_by_cv1 {
1541 :     my ($fig, $cgi, $html, $user, $pattern, $cv) = @_;
1542 :    
1543 :     # Remember kind of search that got us hear so we can call back
1544 :     # with same kind
1545 :     my $search = "Search";
1546 :     if ($cgi->param('Search genome selected below')) {
1547 :     $search=uri_escape('Search genome selected below');
1548 :     } elsif ( $cgi->param('Search Selected Organisms') ) {
1549 :     $search = uri_escape('Search Selected Organisms');
1550 :     } elsif ( $cgi->param('Find Genes in Org that Might Play the Role') ) {
1551 :     $search = uri_escape('Find Genes in Org that Might Play the Role');
1552 :     }
1553 :    
1554 :     my $search_results = $fig->search_cv_file($cv, $pattern);
1555 :    
1556 :     my $find_col_hdrs = ["Find","Vocab. Name","ID; Term"];
1557 :     my $find_table_rows;
1558 :     my $counter = 0;
1559 :     for my $r (@$search_results)
1560 :     {
1561 :     my @temp = split("\t",$r);
1562 :     my $row = [];
1563 :     my $id= $temp[1];
1564 :     my $term = $temp[2];
1565 :     my $id_and_term = $id."; ".$term;
1566 :     my $pattern=uri_escape("$id; $term");
1567 :    
1568 :     my $link = "index.cgi?pattern=$pattern&Search=1&user=$user";
1569 :     my $cb = "<a href=$link>Find PEGs</a>";
1570 :    
1571 :     #feh my $cb = $cgi->submit(-name=>'$search', -value=>'Find PEGs');
1572 :     #my $cb_value = $cv."split_here".$id."; ".$term;
1573 :     #my $cb ="<input type=checkbox name=find_checked_$counter value='$cb_value'>" ;
1574 :     push(@$row,$cb);
1575 :     push(@$row,$cv);
1576 :     push(@$row,$id_and_term);
1577 :     push(@$find_table_rows,$row);
1578 :     $counter = $counter + 1;
1579 :     }
1580 :    
1581 :     my $find_terms_button="";
1582 :     if ($counter > 0) {
1583 :     $find_terms_button= $cgi->submit(-name=>'$search', -value=>'$search');
1584 :     }
1585 :    
1586 :     # build the page
1587 :     push @$html,
1588 :     $cgi->start_form(),
1589 :     $cgi->hidden(-name=>'user', -value=>'$user'),
1590 :     $cgi->br,
1591 :     "<h2>Search for PEGs annotated with Contrlled Vocabulary Terms</h2>",
1592 :     $cgi->hr,
1593 :     "<h4>Terms Matching Your Criteria </h4>\n",
1594 :     $cgi->br,
1595 :     &HTML::make_table($find_col_hdrs,$find_table_rows),
1596 :     $cgi->br,
1597 :     $find_terms_button,
1598 :     $cgi->end_form;
1599 :    
1600 :     return $html;
1601 :     }
1602 :    
1603 :     sub find_pegs_by_cv {
1604 :     my ($fig, $cgi, $html, $user, $pattern, $cv) = @_;
1605 :    
1606 :     # Remember kind of search that got us hear so we can call back
1607 :     # with same kind (not working so force to simple Search)
1608 :    
1609 :     my $search = "Search";
1610 :    
1611 :     #if ($cgi->param('Search genome selected below')) {
1612 :     # $search='Search genome selected below';
1613 :     #} elsif ( $cgi->param('Search Selected Organisms') ) {
1614 :     # $search = 'Search Selected Organisms';
1615 :     #} elsif ( $cgi->param('Find Genes in Org that Might Play the Role') ) {
1616 :     # $search = 'Find Genes in Org that Might Play the Role';
1617 :     #}
1618 :    
1619 :     my $search_results = $fig->search_cv_file($cv, $pattern);
1620 :    
1621 :     my $find_col_hdrs = ["Find","Vocab. Name","ID; Term"];
1622 :     my @patterns=();
1623 :     for my $r (@$search_results)
1624 :     {
1625 :     my @temp = split("\t",$r);
1626 :     my $id= $temp[1];
1627 :     my $term = $temp[2];
1628 :     my $pattern="$id; $term";
1629 :    
1630 :     push(@patterns,$pattern);
1631 :     }
1632 :    
1633 :     my @pattern_radio;
1634 :     if ($#patterns + 1) {
1635 :     @pattern_radio = $cgi->radio_group( -name => 'pattern',
1636 :     -values => [ @patterns ]
1637 :     );
1638 :     } else {
1639 :     @pattern_radio = ("Nothing found");
1640 :     }
1641 :    
1642 :     my $find_terms_button= $cgi->submit(-name=>"Search", -value=>"Search");
1643 :    
1644 :     # build the page
1645 :     push @$html,
1646 :     $cgi->start_form(),
1647 :     $cgi->hidden(-name=>'user', -value=>'$user'),
1648 :     $cgi->br,
1649 :     "<h2>Search for PEGs annotated with Contrlled Vocabulary Terms</h2>",
1650 :     $cgi->hr,
1651 :     "<h4>$cv Terms Matching Your Criteria </h4>\n",
1652 :     $cgi->br,
1653 :     $find_terms_button,
1654 :     $cgi->br,
1655 :     $cgi->br,
1656 :     join( "<br>", @pattern_radio),
1657 :     # &HTML::make_table($find_col_hdrs,$find_table_rows),
1658 :     $cgi->br,
1659 :     $find_terms_button,
1660 :     $cgi->end_form;
1661 :    
1662 :     return $html;
1663 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3