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

Annotation of /FigWebServices/protein_sets.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (view) (download)

1 : mkubal 1.1 # -*- perl -*-
2 : olson 1.4 #
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 : mkubal 1.1
20 :     =pod
21 :    
22 : mkubal 1.2 =head1 protein_sets.cgi
23 : mkubal 1.1
24 :     Get some information about a bunch of proteins.
25 :    
26 :     =cut
27 :    
28 :     #use strict;
29 :     use FIG;
30 :     use HTML;
31 :     use raelib;
32 :     my $raelib=new raelib;
33 :     use CGI;
34 :     my $cgi=new CGI;
35 :     use LWP::Simple qw(!head); # see the caveat in perldoc LWP about importing two head methods.
36 :    
37 :     my $fig;
38 :     eval {
39 :     $fig = new FIG;
40 :     };
41 :    
42 :    
43 :     my $html = [];
44 :     my $user = $cgi->param('user');
45 :    
46 :     unshift(@$html, "<TITLE>The SEED - Protein Information</TITLE>\n");
47 :    
48 :     my $tag_to_id;
49 :     my $inputs;
50 :     if ($cgi->param('request'))
51 :     {
52 :     my $input =$cgi->param('proteins');
53 :     my @inputs = split("\n",$input);
54 :     if ($cgi->upload('fileupload'))
55 :     {
56 :     my $fh=$cgi->upload('fileupload');
57 :     @inputs = <$fh> ;
58 :     }
59 :    
60 :     $tag_to_id = &parse_inputs(@inputs);
61 :    
62 :     }
63 :    
64 :     if ($tag_to_id && $cgi->param('request') eq "Subsystem Information")
65 :     {
66 :     &subsystem_info($fig,$cgi,$html,$tag_to_id);
67 :     }
68 :     else
69 :     {
70 :    
71 :     &show_initial($fig,$cgi,$html);
72 :     &HTML::show_page($cgi,$html,1);
73 :     exit;
74 :    
75 :     }
76 :    
77 :     sub show_initial {
78 :     my ($fig,$cgi,$html)=@_;
79 :     # generate a blank page
80 :     push @$html,
81 :     $cgi->start_multipart_form(),
82 :     "<p>Enter list of tag and id pairs where the tag represents an expression level in a microarray experiment or an isolate from a complete genome hybridization experiment and the id is a peg id</p>\n",
83 :     "<p>",
84 :     "<b>Paste tag ID pairs here:</b><br>\n",
85 :     $cgi->textarea(-name=>"proteins", -rows=>10, -columns=>40), "<br>\n",
86 :     "<br><b>Or choose a file here:</b><br>\n",
87 :     $cgi->filefield(-name=>"fileupload", -size=>50), "<br>\n",
88 :     $cgi->submit(-name=>'request', -value=>'Subsystem Information'),
89 :     $cgi->submit(-name=>'request', -value=>'Paint Subsystem Network Diagram'),
90 :     $cgi->reset, $cgi->end_form;
91 :     return $html;
92 :     }
93 :    
94 :     sub subsystem_info
95 :     {
96 :     my ($fig,$cgi,$html,$tag_to_id)=@_;
97 :    
98 :     my $html = [];
99 :     my $table = [];
100 :     my @headers = keys(%{$tag_to_id});
101 :     my $ss_counter;
102 :     my @all_subsystems;
103 :     my @pegs_with_no_ss;
104 :    
105 :     push (@$html,"<br><br>");
106 : mkubal 1.2 my $first_header = 1;
107 :     my $pegs_to_color_suffix;
108 : mkubal 1.1 foreach my $h (@headers)
109 :     {
110 :     my $p = $tag_to_id->{$h};
111 :     my @pegs = @$p;
112 :     foreach my $peg (@pegs)
113 :     {
114 : mkubal 1.2 if($first_header){$pegs_to_color_suffix = $pegs_to_color_suffix."&color=$peg"}
115 : mkubal 1.1 if ($peg =~/(fig\|\d+.\d+.peg.\d+)/){ $peg = $1};
116 :     my @subsystems = $fig->subsystems_for_peg($peg);
117 : mkubal 1.2
118 : mkubal 1.1 if(!$subsystems[0]){push(@pegs_with_no_ss,$peg)};
119 :     foreach my $ssr (@subsystems)
120 :     {
121 :     $ss = $ssr->[0];
122 :     my $key = $ss."_".$h;
123 :     if($ss_counter{$key}){$ss_counter{$key} = $ss_counter{$key} + 1}
124 :     else{$ss_counter{$key} = 1}
125 :     my $add = 1;
126 :     foreach my $s (@all_subsystems){if($s eq $ss){$add= 0}}
127 : mkubal 1.2 if($add){push(@all_subsystems,$ss)}
128 : mkubal 1.1 }
129 :     }
130 : mkubal 1.2 $first_header = 0;
131 :     }
132 : mkubal 1.1
133 : overbeek 1.3 my $prefix = "display_subsys.cgi?user=&ssa_name=";
134 : mkubal 1.2 my $suffix = "&request=show_ssa".$pegs_to_color_suffix;
135 : mkubal 1.1 push(@$table,"<TABLE><TR><TH>Subsystems</TH>");
136 :     foreach my $h (@headers)
137 :     {
138 :     push(@$table,"<TH>\t$h\t</TH>");
139 :     }
140 :     push(@$table,"</TR>");
141 :    
142 :     foreach my $ss (@all_subsystems)
143 :     {
144 :     print STDERR "each ss: $ss\n";
145 :     my $url = "<a href="."$prefix"."$ss"."$suffix>$ss</a>";
146 :     push(@$table,"<TR><TD>$url</TD>");
147 :     foreach my $h (@headers)
148 :     {
149 :     $key = $ss."_".$h;
150 :     if(!$ss_counter{$key}){$cell = "0"}else{$cell=$ss_counter{$key}}
151 :     push(@$table,"<TD>$cell</TD>");
152 :     }
153 :     push(@$table,"</TR>");
154 :    
155 :     }
156 :    
157 :     push(@$table,"</TABLE>");
158 :     push @$html, &HTML::make_table($table), "\n";
159 :    
160 :     push(@$html,$cgi->h3("Pegs Not in Subsystem"));
161 :     push(@$html,"<TABLE>");
162 :    
163 :     foreach my $p (@pegs_with_no_ss)
164 :     {
165 :     my $cgi = &FIG::cgi_url();
166 :     my $url =qq(<a href="$cgi/protein.cgi?prot=$p&user=">$p</a>);
167 :     push(@$html,"<TR><TD>$url</TD></TR>");
168 :     }
169 :    
170 :     push(@$html,"</TABLE>");
171 :    
172 :     &HTML::show_page($cgi,$html);
173 :    
174 :     }
175 :    
176 :     =head2 parse_inputs
177 :    
178 :     Given a list of of tab-separated tags and protein ids
179 :     return a hash with the tag as key and the value is a list of values
180 :     =cut
181 :    
182 :     sub parse_inputs
183 :     {
184 :    
185 :     my @given=@_;
186 :     my $hash;
187 :    
188 :     foreach my $g (@given)
189 :     {
190 :     if ($g =~/(\w+)\s+(.*)/)
191 :     {
192 :     if($hash{$1})
193 :     {
194 :     $list = $hash{$1};
195 :     @temp_list = @$list;
196 :     push(@temp_list,$2);
197 :     $hash{$1} = [@temp_list];
198 :     }
199 :     else
200 :     {
201 :     @temp_list = ();
202 :     push(@temp_list,$2);
203 :     $hash{$1} = [@temp_list];
204 :     }
205 :     }
206 :     }
207 :    
208 :     return \%hash;
209 :     }
210 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3