[Bio] / SubsystemEditor / WebPage / ShowVariants.pm Repository:
ViewVC logotype

Annotation of /SubsystemEditor/WebPage/ShowVariants.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (view) (download) (as text)

1 : bartels 1.1 package SubsystemEditor::WebPage::ShowVariants;
2 :    
3 :     use strict;
4 :     use warnings;
5 :     use URI::Escape;
6 :     use HTML;
7 :     use Data::Dumper;
8 :    
9 :     use FIG;
10 :    
11 :     use base qw( WebPage );
12 :    
13 :     1;
14 :    
15 :     ##################################################
16 :     # Method for registering components etc. for the #
17 :     # application #
18 :     ##################################################
19 :     sub init {
20 :     my ( $self ) = @_;
21 :    
22 :     $self->application->register_component( 'Table', 'ShowVariantsTable' );
23 :     $self->application->register_component( 'Table', 'FRTable' );
24 : bartels 1.5 $self->application->register_component( 'Table', 'VarDescTable' );
25 : bartels 1.1 }
26 :    
27 :     sub require_javascript {
28 :    
29 :     return [ './Html/showfunctionalroles.js' ];
30 :    
31 :     }
32 :    
33 :     ##############################################
34 :     # Website content is returned by this method #
35 :     ##############################################
36 :     sub output {
37 :     my ( $self ) = @_;
38 :    
39 : bartels 1.5 my $can_alter = 0;
40 :     my $user = $self->application->session->user;
41 : bartels 1.1
42 :     my $fig = new FIG;
43 :     my $cgi = $self->application->cgi;
44 :    
45 :     my $name = $cgi->param( 'subsystem' );
46 :     my $ssname = $name;
47 :     $ssname =~ s/\_/ /g;
48 :    
49 : bartels 1.5 my $dbmaster = DBMaster->new( -database => 'WebAppBackend' );
50 :     my $ppoapplication = $dbmaster->Backend->init( { name => 'SubsystemEditor' } );
51 :    
52 :     # get a seeduser #
53 :     my $seeduser = '';
54 :     if ( defined( $user ) && ref( $user ) ) {
55 :     my $preferences = $dbmaster->Preferences->get_objects( { user => $user,
56 :     name => 'SeedUser',
57 :     application => $ppoapplication } );
58 :     if ( defined( $preferences->[0] ) ) {
59 :     $seeduser = $preferences->[0]->value();
60 :     }
61 :     }
62 :    
63 :     if ( $user && $user->has_right( $self->application, 'edit', 'subsystem', $name ) ) {
64 :     $can_alter = 1;
65 :     $fig->set_user( $seeduser );
66 :     }
67 :    
68 : bartels 1.1 ######################
69 :     # Construct the menu #
70 :     ######################
71 :    
72 :     my $menu = $self->application->menu();
73 :    
74 :     # Build nice tab menu here
75 :     $menu->add_category( 'Subsystem Info', "SubsysEditor.cgi?page=ShowSubsystem&subsystem=$name" );
76 :     $menu->add_category( 'Functional Roles', "SubsysEditor.cgi?page=ShowFunctionalRoles&subsystem=$name" );
77 : bartels 1.4 $menu->add_category( 'Diagram', "SubsysEditor.cgi?page=ShowDiagram&subsystem=$name" );
78 :     $menu->add_category( 'Illustrations', "SubsysEditor.cgi?page=ShowIllustrations&subsystem=$name" );
79 :     $menu->add_category( 'Spreadsheet', "SubsysEditor.cgi?page=ShowSpreadsheet&subsystem=$name" );
80 :     $menu->add_category( 'Show Check', "SubsysEditor.cgi?page=ShowCheck&subsystem=$name" );
81 :     $menu->add_category( 'Show Tree', "SubsysEditor.cgi?page=ShowTree&subsystem=$name" );
82 : bartels 1.1
83 :    
84 :     ##############################
85 :     # Construct the page content #
86 :     ##############################
87 :     my $comment;
88 :     my $error;
89 :    
90 :     my $content = "<H1>Variants for Subsystem: $ssname</H1>";
91 :    
92 :     if ( !defined( $name ) ) {
93 :     $content .= "<B>No subsystem given</B>";
94 :     return $content;
95 :     }
96 :    
97 : bartels 1.5 my $subsystem = $fig->get_subsystem( $name );
98 :     my ( $datahash ) = get_data( $fig, $subsystem );
99 : bartels 1.1
100 :     my $application = $self->application;
101 :    
102 :     if ( $cgi->param( 'set_variants' ) ) {
103 :     $comment .= '<BR>';
104 :     $comment .= set_variants( $cgi, $fig, $name, $subsystem, $application, $datahash );
105 :     ( $datahash, $subsystem ) = get_data( $fig, $name );
106 :     }
107 : bartels 1.5 elsif ( $cgi->param( 'addsave_variants' ) ) {
108 :     my @varcodes = $cgi->param( 'VARIANT' );
109 :     my @vardescs = $cgi->param( 'VARIANTDESC' );
110 :     my %varhash;
111 :    
112 :     for ( my $i = 0; $i < scalar( @varcodes ); $i++ ) {
113 :    
114 :     if ( $varcodes[$i] eq '' ) {
115 :     if ( $vardescs[$i] ne '' ) {
116 :     $comment .= "No Variant Code given for description ".$vardescs[$i].", so this variant could not be saved.<BR>\n";
117 :     }
118 :     next;
119 :     }
120 :     if ( defined( $varhash{ $varcodes[$i] } ) ) {
121 :     $comment .= "Variant ".$varcodes[$i]." already has the description ".$varhash{ $varcodes[$i] }.", so description ".$vardescs[$i]." was ignored.<BR>\n";
122 :     next;
123 :     }
124 : bartels 1.1
125 : bartels 1.5 $varhash{ $varcodes[$i] } = $vardescs[$i];
126 :     }
127 :     my $newvarcode = $cgi->param( 'NEWVARIANT' );
128 :     my $newvardesc = $cgi->param( 'NEWVARIANTDESC' );
129 :     if ( defined( $newvarcode ) && $newvarcode ne '' && defined( $newvardesc ) && $newvardesc ne '' ) {
130 :     if ( $newvarcode eq '' ) {
131 :     if ( $newvarcode ne '' ) {
132 :     $comment .= "No Variant Code given for description $newvardesc, so this variant could not be saved.<BR>\n";
133 :     }
134 :     }
135 :     elsif ( defined( $varhash{ $newvarcode } ) ) {
136 :     $comment .= "Variant $newvarcode already has the description $newvardesc, so description $newvardesc was ignored.<BR>\n";
137 :     }
138 :     else {
139 :     $varhash{ $newvarcode } = $newvardesc;
140 :     }
141 :     }
142 :    
143 :     $subsystem->set_variants( \%varhash );
144 :     $subsystem->incr_version();
145 :     $subsystem->db_sync();
146 :     $subsystem->write_subsystem();
147 :     }
148 :    
149 :     $content .= show_variants( $self, $cgi, $fig, $name, $subsystem, $can_alter, $datahash );
150 : bartels 1.1
151 :     ###############################
152 :     # Display errors and comments #
153 :     ###############################
154 :    
155 :     if ( defined( $error ) && $error ne '' ) {
156 :     $self->application->add_message( 'warning', $error );
157 :     }
158 :     if ( defined( $comment ) && $comment ne '' ) {
159 :     $self->application->add_message( 'info', $comment );
160 :     }
161 :     return $content;
162 :     }
163 :    
164 : bartels 1.2 ###############
165 :     # data method #
166 :     ###############
167 : bartels 1.1 sub get_data {
168 : bartels 1.5 my ( $fig, $subsystem ) = @_;
169 : bartels 1.1
170 :     my $datahash = {};
171 :    
172 :     my @genomes = $subsystem->get_genomes;
173 :     my %variant_codes = map { $_ => $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) ) } @genomes;
174 :     my @roles = $subsystem->get_roles;
175 :    
176 :     $datahash->{ 'genomes' } = \@genomes;
177 :     $datahash->{ 'varcodes' } = \%variant_codes;
178 :     $datahash->{ 'roles' } = \@roles;
179 :    
180 :     return ( $datahash, $subsystem );
181 :     }
182 :    
183 : bartels 1.2 #########################################################
184 :     # show table with variants and button for changing them #
185 :     #########################################################
186 : bartels 1.1 sub show_variants {
187 : bartels 1.5 my ( $self, $cgi, $fig, $name, $sub, $can_alter, $datahash ) = @_;
188 : bartels 1.1
189 :     my $application = $self->application();
190 :    
191 :     my $cont = '';
192 :    
193 :     # get some datapoints #
194 :     my @genomes = @{ $datahash->{ 'genomes' } };
195 :     my %variant_codes = %{ $datahash->{ 'varcodes' } };
196 :     my @roles = @{ $datahash->{ 'roles' } };
197 :    
198 :     my ( $abbrev, $frtable ) = format_roles( $application, $fig, $cgi, $sub );
199 :    
200 :     my( @has, $role, %has_filled );
201 :     foreach my $genome ( @genomes ) {
202 :     @has = ();
203 :     foreach $role (@roles)
204 :     {
205 :     push(@has,($sub->get_pegs_from_cell($genome,$role) > 0) ? $abbrev->{$role} : ());
206 :     }
207 :     $has_filled{join(",",@has)}->{$variant_codes{$genome}}++;
208 :     }
209 :    
210 :     my ( $col_hdrs, $tab, $pattern );
211 :     $col_hdrs = [ { name => "Pattern" }, { name => "# Genomes with Pattern" },
212 :     { name => "Existing Variant Code" }, { name => "Set To" } ];
213 :     $tab = [];
214 :     foreach $pattern ( sort keys( %has_filled ) ) {
215 :    
216 :     my @codes = keys( %{ $has_filled{ $pattern } } );
217 :     my $code;
218 :     my $nrow = @codes;
219 :     if ( @codes > 0 ) {
220 :     $code = shift @codes;
221 :     push( @$tab, [ $pattern,
222 : bartels 1.3 $has_filled{ $pattern }->{ $code },
223 : bartels 1.1 $code,
224 :     $cgi->textfield(-name => "p:$pattern:$code", -size => 5, -value => $code, -override => 1)
225 :     ]);
226 :     }
227 :    
228 :     foreach $code ( @codes ) {
229 :    
230 : bartels 1.3 push( @$tab, [ $pattern,
231 :     $has_filled{ $pattern }->{ $code },
232 :     $code,
233 :     $cgi->textfield(-name => "p:$pattern:$code", -size => 5, -value => $code, -override => 1)
234 : bartels 1.1 ]);
235 :     }
236 :     }
237 :    
238 :     $cont .= $frtable;
239 :     $cont .= $self->start_form();
240 :    
241 :     # create table from parsed data
242 :     my $table = $application->component( 'ShowVariantsTable' );
243 :     $table->columns( $col_hdrs );
244 :     $table->data( $tab );
245 : bartels 1.5
246 :     ############################################
247 :     # Variant Descriptions from the Notes file #
248 :     ############################################
249 :     $cont .= "<H2>Variant descriptions</H2>\n";
250 :     my $variants = $sub->get_variants();
251 :    
252 :     my $infotable = '';
253 :     if ( $can_alter ) {
254 :     $infotable .= "<TABLE><TR><TH>Variant</TH><TH>Description</TH></TR>";
255 :     foreach my $kv ( sort keys %$variants ) {
256 :     $infotable .= "<TR><TD><INPUT TYPE=TEXT NAME='VARIANT' ID='VARIANT".$kv."' VALUE='$kv'></TD><TD><INPUT TYPE=TEXT NAME='VARIANTDESC' ID='VARIANTDESC".$kv."' VALUE='".$variants->{ $kv }."' STYLE='width: 500px;'></TD></TR>";
257 :     }
258 :     $infotable .= "<TR><TD><INPUT TYPE=TEXT NAME='NEWVARIANT' ID='NEWVARIANT'></TD><TD><INPUT TYPE=TEXT NAME='NEWVARIANTDESC' ID='NEWVARIANTDESC' STYLE='width: 500px;'></TD></TR>";
259 :     $infotable .= "<TR><TD>";
260 :     $infotable .= $cgi->submit( -name => "addsave_variants", -value => "Add/Save Variants" );
261 :     $infotable .= "</TD></TR></TABLE>";
262 :    
263 :     $cont .= $infotable;
264 :     }
265 :     else {
266 :     my $infotable = $application->component( 'VarDescTable' );
267 :     $infotable->columns( [ { name => "Variant" }, { name => "Description" } ] );
268 :    
269 :     my $vardata;
270 :     foreach my $kv ( sort keys %$variants ) {
271 :     push @$vardata, [ $kv, $variants->{ $kv } ];
272 :     }
273 :     $infotable->data( $vardata );
274 :     $cont .= $infotable->output();
275 :     }
276 :    
277 :    
278 : bartels 1.1 $cont .= "<H2>Variant groups</H2>\n";
279 :     $cont .= $application->component( 'ShowVariantsTable' )->output();
280 :    
281 :     $cont .= $cgi->hidden(-name => 'request', -value => 'set_variants', -override => 1);
282 :     $cont .= $cgi->hidden(-name => 'subsystem', -value => $name, -override => 1);
283 :     $cont .= $cgi->br;
284 :     $cont .= $cgi->submit( -name => "set_variants", -value => "Set Variants" );
285 :     $cont .= $self->end_form();
286 :    
287 :     return $cont;
288 :     }
289 :    
290 :    
291 : bartels 1.2 ###############################
292 :     # get a functional role table #
293 :     ###############################
294 : bartels 1.1 sub format_roles {
295 :     my( $application, $fig, $cgi, $subsystem ) = @_;
296 :     my( $i );
297 :    
298 :     my $col_hdrs = [ "Column", "Abbrev", "Functional Role" ];
299 :    
300 :     my $n = 1;
301 :     my ( $tab, $abbrevP ) = format_existing_roles( $fig, $subsystem, \$n );
302 :    
303 :     # create table from parsed data
304 :     my $table = $application->component( 'FRTable' );
305 :     $table->columns( $col_hdrs );
306 :     $table->data( $tab );
307 :    
308 :     my $formatted = '<H2>Functional Roles</H2>';
309 :     $formatted .= $application->component( 'FRTable' )->output();
310 :    
311 :     $formatted .= "<BR><BR>";
312 :     return ( $abbrevP, $formatted );
313 :     }
314 :    
315 : bartels 1.2 #########################################
316 :     # get rows of the functional role table #
317 :     #########################################
318 : bartels 1.1 sub format_existing_roles {
319 :     my ( $fig, $subsystem, $nP ) = @_;
320 :     my $tab = [];
321 :     my $abbrevP = {};
322 :    
323 :     foreach my $role ( $subsystem->get_roles ) {
324 :     my $i = $subsystem->get_role_index( $role );
325 :     my $abbrev = $role ? $subsystem->get_role_abbr( $i ) : "";
326 :     $abbrevP->{ $role } = $abbrev;
327 :     push( @$tab, [ $$nP, $abbrev, $role ] );
328 :     }
329 :    
330 :     return ( $tab, $abbrevP );
331 :     }
332 :    
333 : bartels 1.2
334 :     ##############################################
335 :     # change the variants in the subsystems file #
336 :     ##############################################
337 : bartels 1.1 sub set_variants {
338 :     my ( $cgi, $fig, $subsys, $sub, $application, $datahash ) = @_;
339 :    
340 :     my @genomes = @{ $datahash->{ 'genomes' } };
341 :     my %variant_codes = %{ $datahash->{ 'varcodes' } };
342 :     my @roles = @{ $datahash->{ 'roles' } };
343 :    
344 :     my ( $abbrev, $frtable ) = format_roles( $application, $fig, $cgi, $sub );
345 :    
346 :     my ( %genomes_with );
347 :     foreach my $genome ( @genomes ) {
348 :     my $vc = $variant_codes{ $genome };
349 :    
350 :     my @has = ();
351 :     foreach my $role ( @roles ) {
352 :     push( @has, ( $sub->get_pegs_from_cell( $genome, $role ) > 0 ) ? $abbrev->{ $role } : () );
353 :     }
354 :     my $pattern = join( ",", @has );
355 :     push( @{ $genomes_with{ "$pattern, $vc" } }, $genome );
356 :     }
357 :    
358 :     my $comment = '';
359 :    
360 :     my @params = grep { $_ =~ /^p:/ } $cgi->param;
361 :     foreach my $param (@params) {
362 :     if ( $param =~ /^p:(.*):(.*)$/ ) {
363 :     my ( $pattern, $vc ) = ( $1, $2 );
364 :     $pattern =~ s/ //g;
365 :     $vc =~ s/ //g;
366 :     my $to = $cgi->param( $param );
367 :    
368 :     if ( my $x = $genomes_with{ "$pattern, $vc" } ) {
369 :    
370 :     foreach my $genome ( @$x ) {
371 :     if ( $to ne $variant_codes{ $genome } ) {
372 :     my $old = $variant_codes{$genome};
373 :     my $gs = $fig->genus_species($genome);
374 :     $comment .= "resetting $genome $gs from $old to $to<BR>\n";
375 :     $sub->set_variant_code( $sub->get_genome_index( $genome ), $to );
376 :     }
377 :     }
378 :    
379 :     }
380 :     }
381 :     }
382 : bartels 1.5
383 :     $sub->incr_version();
384 :     $sub->db_sync();
385 : bartels 1.1 $sub->write_subsystem();
386 :    
387 :     return $comment;
388 :     }
389 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3