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

Annotation of /SubsystemEditor/WebPage/ShowVariants.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3