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

Annotation of /SubsystemEditor/WebPage/ShowVariants.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (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 : bartels 1.6
99 :     my $datahash = get_data( $fig, $subsystem );
100 : bartels 1.1
101 :     my $application = $self->application;
102 :    
103 :     if ( $cgi->param( 'set_variants' ) ) {
104 :     $comment .= '<BR>';
105 :     $comment .= set_variants( $cgi, $fig, $name, $subsystem, $application, $datahash );
106 : bartels 1.6 $datahash = get_data( $fig, $subsystem );
107 : bartels 1.1 }
108 : bartels 1.5 elsif ( $cgi->param( 'addsave_variants' ) ) {
109 :     my @varcodes = $cgi->param( 'VARIANT' );
110 :     my @vardescs = $cgi->param( 'VARIANTDESC' );
111 :     my %varhash;
112 :    
113 :     for ( my $i = 0; $i < scalar( @varcodes ); $i++ ) {
114 :    
115 :     if ( $varcodes[$i] eq '' ) {
116 :     if ( $vardescs[$i] ne '' ) {
117 :     $comment .= "No Variant Code given for description ".$vardescs[$i].", so this variant could not be saved.<BR>\n";
118 :     }
119 :     next;
120 :     }
121 :     if ( defined( $varhash{ $varcodes[$i] } ) ) {
122 :     $comment .= "Variant ".$varcodes[$i]." already has the description ".$varhash{ $varcodes[$i] }.", so description ".$vardescs[$i]." was ignored.<BR>\n";
123 :     next;
124 :     }
125 : bartels 1.1
126 : bartels 1.5 $varhash{ $varcodes[$i] } = $vardescs[$i];
127 :     }
128 :     my $newvarcode = $cgi->param( 'NEWVARIANT' );
129 :     my $newvardesc = $cgi->param( 'NEWVARIANTDESC' );
130 :     if ( defined( $newvarcode ) && $newvarcode ne '' && defined( $newvardesc ) && $newvardesc ne '' ) {
131 :     if ( $newvarcode eq '' ) {
132 :     if ( $newvarcode ne '' ) {
133 :     $comment .= "No Variant Code given for description $newvardesc, so this variant could not be saved.<BR>\n";
134 :     }
135 :     }
136 :     elsif ( defined( $varhash{ $newvarcode } ) ) {
137 :     $comment .= "Variant $newvarcode already has the description $newvardesc, so description $newvardesc was ignored.<BR>\n";
138 :     }
139 :     else {
140 :     $varhash{ $newvarcode } = $newvardesc;
141 :     }
142 :     }
143 :    
144 :     $subsystem->set_variants( \%varhash );
145 :     $subsystem->incr_version();
146 :     $subsystem->db_sync();
147 :     $subsystem->write_subsystem();
148 :     }
149 :    
150 :     $content .= show_variants( $self, $cgi, $fig, $name, $subsystem, $can_alter, $datahash );
151 : bartels 1.1
152 :     ###############################
153 :     # Display errors and comments #
154 :     ###############################
155 :    
156 :     if ( defined( $error ) && $error ne '' ) {
157 :     $self->application->add_message( 'warning', $error );
158 :     }
159 :     if ( defined( $comment ) && $comment ne '' ) {
160 :     $self->application->add_message( 'info', $comment );
161 :     }
162 :     return $content;
163 :     }
164 :    
165 : bartels 1.2 ###############
166 :     # data method #
167 :     ###############
168 : bartels 1.1 sub get_data {
169 : bartels 1.5 my ( $fig, $subsystem ) = @_;
170 : bartels 1.1
171 :     my $datahash = {};
172 :    
173 :     my @genomes = $subsystem->get_genomes;
174 :     my %variant_codes = map { $_ => $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) ) } @genomes;
175 :     my @roles = $subsystem->get_roles;
176 :    
177 :     $datahash->{ 'genomes' } = \@genomes;
178 :     $datahash->{ 'varcodes' } = \%variant_codes;
179 :     $datahash->{ 'roles' } = \@roles;
180 :    
181 : bartels 1.6 return $datahash;
182 : bartels 1.1 }
183 :    
184 : bartels 1.2 #########################################################
185 :     # show table with variants and button for changing them #
186 :     #########################################################
187 : bartels 1.1 sub show_variants {
188 : bartels 1.5 my ( $self, $cgi, $fig, $name, $sub, $can_alter, $datahash ) = @_;
189 : bartels 1.1
190 :     my $application = $self->application();
191 :    
192 :     my $cont = '';
193 :    
194 :     # get some datapoints #
195 :     my @genomes = @{ $datahash->{ 'genomes' } };
196 :     my %variant_codes = %{ $datahash->{ 'varcodes' } };
197 :     my @roles = @{ $datahash->{ 'roles' } };
198 :    
199 :     my ( $abbrev, $frtable ) = format_roles( $application, $fig, $cgi, $sub );
200 :    
201 :     my( @has, $role, %has_filled );
202 :     foreach my $genome ( @genomes ) {
203 :     @has = ();
204 :     foreach $role (@roles)
205 :     {
206 :     push(@has,($sub->get_pegs_from_cell($genome,$role) > 0) ? $abbrev->{$role} : ());
207 :     }
208 :     $has_filled{join(",",@has)}->{$variant_codes{$genome}}++;
209 :     }
210 :    
211 : bartels 1.6 my ( $col_hdrs, $pattern_uq );
212 :     if ( $can_alter ) {
213 :     $col_hdrs = [ { name => "Pattern" }, { name => "# Genomes with Pattern" },
214 :     { name => "Existing Variant Code" }, { name => "Set To" } ];
215 :     }
216 :     else {
217 :     $col_hdrs = [ { name => "Pattern" }, { name => "# Genomes with Pattern" },
218 :     { name => "Existing Variant Code" } ];
219 :     }
220 :    
221 :     my $tab = [];
222 :     foreach $pattern_uq ( sort keys( %has_filled ) ) {
223 :    
224 :     my $pattern = quotemeta( $pattern_uq );
225 : bartels 1.1
226 : bartels 1.6 my @codes = keys( %{ $has_filled{ $pattern_uq } } );
227 : bartels 1.1 my $code;
228 :     my $nrow = @codes;
229 :     if ( @codes > 0 ) {
230 :     $code = shift @codes;
231 : bartels 1.6 if ( $can_alter ) {
232 :     push( @$tab, [ $pattern_uq,
233 :     $has_filled{ $pattern_uq }->{ $code },
234 :     $code,
235 :     $cgi->textfield(-name => "p##:##$pattern##:##$code", -size => 5, -value => $code, -override => 1)
236 :     ]);
237 :     }
238 :     else {
239 :     push( @$tab, [ $pattern_uq,
240 :     $has_filled{ $pattern_uq }->{ $code },
241 :     $code
242 :     ]);
243 :     }
244 : bartels 1.1 }
245 :    
246 :     foreach $code ( @codes ) {
247 : bartels 1.6 if ( $can_alter ) {
248 :     push( @$tab, [ $pattern_uq,
249 :     $has_filled{ $pattern_uq }->{ $code },
250 :     $code,
251 :     $cgi->textfield(-name => "p##:##$pattern##:##$code", -size => 5, -value => $code, -override => 1)
252 :     ]);
253 :     }
254 :     else {
255 :     push( @$tab, [ $pattern_uq,
256 :     $has_filled{ $pattern_uq }->{ $code },
257 :     $code
258 :     ]);
259 :     }
260 : bartels 1.1 }
261 :     }
262 : bartels 1.6
263 : bartels 1.1 $cont .= $frtable;
264 :     $cont .= $self->start_form();
265 :    
266 :     # create table from parsed data
267 :     my $table = $application->component( 'ShowVariantsTable' );
268 :     $table->columns( $col_hdrs );
269 :     $table->data( $tab );
270 : bartels 1.5
271 :     ############################################
272 :     # Variant Descriptions from the Notes file #
273 :     ############################################
274 :     $cont .= "<H2>Variant descriptions</H2>\n";
275 :     my $variants = $sub->get_variants();
276 :    
277 :     my $infotable = '';
278 :     if ( $can_alter ) {
279 :     $infotable .= "<TABLE><TR><TH>Variant</TH><TH>Description</TH></TR>";
280 :     foreach my $kv ( sort keys %$variants ) {
281 :     $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>";
282 :     }
283 :     $infotable .= "<TR><TD><INPUT TYPE=TEXT NAME='NEWVARIANT' ID='NEWVARIANT'></TD><TD><INPUT TYPE=TEXT NAME='NEWVARIANTDESC' ID='NEWVARIANTDESC' STYLE='width: 500px;'></TD></TR>";
284 :     $infotable .= "<TR><TD>";
285 :     $infotable .= $cgi->submit( -name => "addsave_variants", -value => "Add/Save Variants" );
286 :     $infotable .= "</TD></TR></TABLE>";
287 :    
288 :     $cont .= $infotable;
289 :     }
290 :     else {
291 :     my $infotable = $application->component( 'VarDescTable' );
292 :     $infotable->columns( [ { name => "Variant" }, { name => "Description" } ] );
293 :    
294 :     my $vardata;
295 :     foreach my $kv ( sort keys %$variants ) {
296 :     push @$vardata, [ $kv, $variants->{ $kv } ];
297 :     }
298 :     $infotable->data( $vardata );
299 :     $cont .= $infotable->output();
300 :     }
301 :    
302 :    
303 : bartels 1.1 $cont .= "<H2>Variant groups</H2>\n";
304 :     $cont .= $application->component( 'ShowVariantsTable' )->output();
305 :    
306 :     $cont .= $cgi->hidden(-name => 'request', -value => 'set_variants', -override => 1);
307 :     $cont .= $cgi->hidden(-name => 'subsystem', -value => $name, -override => 1);
308 : bartels 1.6 if ( $can_alter ) {
309 :     $cont .= $cgi->br;
310 :     }
311 : bartels 1.1 $cont .= $cgi->submit( -name => "set_variants", -value => "Set Variants" );
312 :     $cont .= $self->end_form();
313 :    
314 :     return $cont;
315 :     }
316 :    
317 :    
318 : bartels 1.2 ###############################
319 :     # get a functional role table #
320 :     ###############################
321 : bartels 1.1 sub format_roles {
322 :     my( $application, $fig, $cgi, $subsystem ) = @_;
323 :     my( $i );
324 :    
325 :     my $col_hdrs = [ "Column", "Abbrev", "Functional Role" ];
326 :    
327 :     my $n = 1;
328 :     my ( $tab, $abbrevP ) = format_existing_roles( $fig, $subsystem, \$n );
329 :    
330 :     # create table from parsed data
331 :     my $table = $application->component( 'FRTable' );
332 :     $table->columns( $col_hdrs );
333 :     $table->data( $tab );
334 :    
335 :     my $formatted = '<H2>Functional Roles</H2>';
336 :     $formatted .= $application->component( 'FRTable' )->output();
337 :    
338 :     $formatted .= "<BR><BR>";
339 :     return ( $abbrevP, $formatted );
340 :     }
341 :    
342 : bartels 1.2 #########################################
343 :     # get rows of the functional role table #
344 :     #########################################
345 : bartels 1.1 sub format_existing_roles {
346 :     my ( $fig, $subsystem, $nP ) = @_;
347 :     my $tab = [];
348 :     my $abbrevP = {};
349 :    
350 :     foreach my $role ( $subsystem->get_roles ) {
351 :     my $i = $subsystem->get_role_index( $role );
352 :     my $abbrev = $role ? $subsystem->get_role_abbr( $i ) : "";
353 :     $abbrevP->{ $role } = $abbrev;
354 :     push( @$tab, [ $$nP, $abbrev, $role ] );
355 :     }
356 :    
357 :     return ( $tab, $abbrevP );
358 :     }
359 :    
360 : bartels 1.2
361 :     ##############################################
362 :     # change the variants in the subsystems file #
363 :     ##############################################
364 : bartels 1.1 sub set_variants {
365 :     my ( $cgi, $fig, $subsys, $sub, $application, $datahash ) = @_;
366 :    
367 :     my @genomes = @{ $datahash->{ 'genomes' } };
368 :     my %variant_codes = %{ $datahash->{ 'varcodes' } };
369 :     my @roles = @{ $datahash->{ 'roles' } };
370 :    
371 :     my ( $abbrev, $frtable ) = format_roles( $application, $fig, $cgi, $sub );
372 :    
373 :     my ( %genomes_with );
374 :     foreach my $genome ( @genomes ) {
375 :     my $vc = $variant_codes{ $genome };
376 :    
377 :     my @has = ();
378 :     foreach my $role ( @roles ) {
379 :     push( @has, ( $sub->get_pegs_from_cell( $genome, $role ) > 0 ) ? $abbrev->{ $role } : () );
380 :     }
381 : bartels 1.6 my $pattern = quotemeta( join( ",", @has ) );
382 : bartels 1.1 push( @{ $genomes_with{ "$pattern, $vc" } }, $genome );
383 :     }
384 :    
385 :     my $comment = '';
386 : bartels 1.6 my @params = grep { $_ =~ /^p##:##/ } $cgi->param;
387 :    
388 : bartels 1.1 foreach my $param (@params) {
389 : bartels 1.6
390 :     if ( $param =~ /^p##:##(.*)##:##(.*)$/ ) {
391 : bartels 1.1 my ( $pattern, $vc ) = ( $1, $2 );
392 : bartels 1.6
393 : bartels 1.1 $pattern =~ s/ //g;
394 :     $vc =~ s/ //g;
395 :     my $to = $cgi->param( $param );
396 :    
397 :     if ( my $x = $genomes_with{ "$pattern, $vc" } ) {
398 : bartels 1.6 foreach my $genome ( @$x ) {
399 : bartels 1.1
400 :     if ( $to ne $variant_codes{ $genome } ) {
401 : bartels 1.6
402 : bartels 1.1 my $old = $variant_codes{$genome};
403 :     my $gs = $fig->genus_species($genome);
404 :     $comment .= "resetting $genome $gs from $old to $to<BR>\n";
405 :     $sub->set_variant_code( $sub->get_genome_index( $genome ), $to );
406 :     }
407 :     }
408 :    
409 :     }
410 :     }
411 :     }
412 : bartels 1.5
413 :     $sub->incr_version();
414 :     $sub->db_sync();
415 : bartels 1.1 $sub->write_subsystem();
416 :    
417 :     return $comment;
418 :     }
419 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3