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

Annotation of /FigWebServices/find_ss_genes.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (view) (download)

1 : overbeek 1.1 # -*- perl -*-
2 :     #
3 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
4 :     # for Interpretations of Genomes. All Rights Reserved.
5 :     #
6 :     # This file is part of the SEED Toolkit.
7 :     #
8 :     # The SEED Toolkit is free software. You can redistribute
9 :     # it and/or modify it under the terms of the SEED Toolkit
10 :     # Public License.
11 :     #
12 :     # You should have received a copy of the SEED Toolkit Public License
13 :     # along with this program; if not write to the University of Chicago
14 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
15 :     # Genomes at veronika@thefig.info or download a copy from
16 :     # http://www.theseed.org/LICENSE.TXT.
17 :     #
18 :    
19 :    
20 :     use FIG;
21 :     my $fig = new FIG;
22 :    
23 :     use HTML;
24 :     use CGI;
25 :     my $cgi = new CGI;
26 :    
27 :     my $user = $cgi->param('user');
28 :     $fig->set_user($user);
29 :    
30 :     if (0)
31 :     {
32 :     my $VAR1;
33 :     eval(join("",`cat /tmp/find_ss_genes_parms`));
34 :     $cgi = $VAR1;
35 :     # print STDERR &Dumper($cgi);
36 :     }
37 :    
38 :     if (0)
39 :     {
40 :     print $cgi->header;
41 :     my @params = $cgi->param;
42 :     print "<pre>\n";
43 :     foreach $_ (@params)
44 :     {
45 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
46 :     }
47 :    
48 :     if (0)
49 :     {
50 :     if (open(TMP,">/tmp/find_ss_genes_parms"))
51 :     {
52 :     print TMP &Dumper($cgi);
53 :     close(TMP);
54 :     }
55 :     }
56 :     exit;
57 :     }
58 :    
59 :     my $html = [];
60 :     unshift @$html, "<TITLE>Find SS Genes</TITLE>\n";
61 :    
62 :     my $genome = $cgi->param('genome');
63 :     my $request = $cgi->param('request');
64 :     if (! $request)
65 :     {
66 :     &show_initial($fig,$cgi,$html);
67 :     }
68 :     elsif ($request eq "show_genes")
69 :     {
70 :     @genomes = map { ($_ =~ /(\d+\.\d+)\s*$/) ? $1 : () } $cgi->param('genome');
71 :     if (@genomes == 0)
72 :     {
73 :     push (@$html,$cgi->h1('You need to pick one or more genomes'));
74 :     }
75 :     else
76 :     {
77 :     &process_request($fig,$cgi,$html,\@genomes);
78 :     }
79 :     }
80 :    
81 :     &HTML::show_page($cgi,$html);
82 :    
83 :     sub process_request {
84 :     my($fig,$cgi,$html,$genomes) = @_;
85 :    
86 : overbeek 1.4 if ($cgi->param('Genes in cluster, but not a subsystem'))
87 : overbeek 1.1 {
88 : overbeek 1.4 my @poss = ();
89 :     foreach $genome (@$genomes)
90 :     {
91 :     push(@poss,&process_one_genome($fig,$cgi,$html,$genome));
92 :     }
93 :     my @tab = map { my($sc,$sc1,$peg) = @$_; [$sc,$sc1,&link($cgi,$peg),scalar $fig->function_of($peg)] } sort { ($b->[0] <=> $a->[0]) or ($b->[1] <=> $a->[1]) } @poss;
94 :     push(@$html,&HTML::make_table(['Coupling Score','Size of Cluster','PEG','Function'],\@tab,'Best Hits'));
95 : overbeek 1.1 }
96 : overbeek 1.4 elsif ($cgi->param('Potentially Related Subsystems [cluster]'))
97 :     {
98 :     @hits =&process_split_ss($fig,$genomes);
99 :     my @tab = map { my($peg1,$peg2,$sc,$key) = @$_; [$sc,&link($cgi,$peg1),$peg2,split(/\t/,$key)] } sort { ($b->[2] <=> $a->[2]) or ($b->[0] cmp $a->[0]) } @hits;
100 :     push(@$html,&HTML::make_table(['Coupling Score','PEG1','PEG2','Sub1','Sub2'],\@tab,'Best Hits'));
101 :     }
102 :     }
103 :    
104 :     sub process_split_ss {
105 :     my($fig,$genomes) = @_;
106 : overbeek 1.1
107 : overbeek 1.4 my @hits = ();
108 :     my %seen;
109 :     foreach my $genome (@$genomes)
110 :     {
111 :     foreach my $peg ($fig->all_features($genome,'peg'))
112 :     {
113 :     my @sub1 = grep { $fig->usable_subsystem($_) } $fig->peg_to_subsystems($peg);
114 :    
115 :     if (@sub1 > 0)
116 :     {
117 :     my %sub1 = map { $_ => 1 } @sub1;
118 :     my @coupled = sort { $b->[1] <=> $a->[1] } grep { $_->[1] >= 10 } $fig->coupled_to($peg);
119 :     if (@coupled > 0)
120 :     {
121 :     foreach my $tuple (@coupled)
122 :     {
123 :     my($peg1,$sc1) = @$tuple;
124 :     my @sub2 = grep { $fig->usable_subsystem($_) } $fig->peg_to_subsystems($peg1);
125 :     my @comm = grep { $sub1{$_} } @sub2;
126 : overbeek 1.1
127 : overbeek 1.4 if ((@sub2 > 0) && (@comm == 0))
128 :     {
129 :     foreach my $x1 (@sub1)
130 :     {
131 :     foreach my $x2 (@sub2)
132 :     {
133 :     my $key = join("\t",sort ($x1,$x2));
134 :     if ((! $seen{$key}) || ($seen{$key}->[2] < $sc1))
135 :     {
136 :     $seen{$key} = [$peg,@$tuple];
137 :     }
138 :     }
139 :     }
140 :     }
141 :     }
142 :     }
143 :     }
144 :     }
145 :     }
146 :     foreach my $key (sort { $seen{$b}->[2] <=> $seen{$a}->[2] } keys(%seen))
147 :     {
148 :     push(@hits,[@{$seen{$key}},$key]);
149 :     }
150 :     return @hits;
151 : overbeek 1.1 }
152 :    
153 :     sub process_one_genome {
154 :     my($fig,$cgi,$html,$genome) = @_;
155 :    
156 :     my @hits = ();
157 :     foreach $peg ($fig->all_features($genome,'peg'))
158 :     {
159 : overbeek 1.4 my @tmp = grep { $fig->usable_subsystem($_) } $fig->peg_to_subsystems($peg);
160 : overbeek 1.1 if (@tmp == 0)
161 :     {
162 :     # print STDERR "$peg is not in SS\n";
163 :     my @coupled = sort { $b->[1] <=> $a->[1] } grep { $_->[1] >= 5 } $fig->coupled_to($peg);
164 :    
165 :     if ((@coupled > 0) && ($coupled[0]->[1] > 5))
166 :     {
167 :     my %in = map { $_->[0] => 1 } @coupled;
168 :     for (my $i=0; ($i < @coupled); $i++)
169 :     {
170 :     my @tmp = grep { $_->[1] >= 5 } $fig->coupled_to($coupled[$i]->[0]);
171 :     foreach my $tuple (@tmp)
172 :     {
173 :     my($peg1,$sc) = @$tuple;
174 :     if (! $in{$peg1})
175 :     {
176 :     push(@coupled,$tuple);
177 :     $in{$peg1} = 1;
178 :     }
179 :     }
180 :     }
181 :    
182 :     push(@hits,[$coupled[0]->[1],scalar keys(%in),$peg]);
183 :     }
184 :     }
185 :     }
186 :     return @hits;
187 :     }
188 :    
189 :     sub link {
190 :     my($cgi,$peg) = @_;
191 :    
192 :     my $user = $cgi->param('user');
193 :     return "<a href=protein.cgi?user=$user&prot=$peg> $peg </a>";
194 :     }
195 :    
196 :     sub show_initial {
197 :     my($fig,$cgi,$html) = @_;
198 :    
199 :     @genomes = sort map { $org = $_; $fig->genus_species($org) . ": $org" } $fig->genomes('complete');
200 :     push(@$html, $cgi->start_form(-action => "find_ss_genes.cgi",
201 :     -method => 'post'),
202 :     $cgi->hidden(-name => 'request', -value => 'show_genes', -override => 1),
203 :     $cgi->hidden(-name => 'user', -value=>$user),
204 :     $cgi->scrolling_list( -name => 'genome',
205 :     -values => \@genomes,
206 :     -size => 10,
207 :     -multiple => 1
208 :     ),
209 :     $cgi->br,
210 : overbeek 1.4 $cgi->submit( 'Genes in cluster, but not a subsystem' ),
211 :     $cgi->submit( 'Potentially Related Subsystems [cluster]' ),
212 : overbeek 1.1 $cgi->end_form
213 :     );
214 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3