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

Annotation of /SubsystemEditor/WebPage/MetaSpreadsheet.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : bartels 1.1 package SubsystemEditor::WebPage::MetaSpreadsheet;
2 :    
3 :     use strict;
4 :     use warnings;
5 :     use URI::Escape;
6 :     use HTML;
7 :     use Data::Dumper;
8 :     use DBMaster;
9 :    
10 :     use FIG;
11 :    
12 :     use MIME::Base64;
13 :     use Data::Dumper;
14 :     use File::Spec;
15 :     use GenomeLists;
16 :     use MetaSubsystem;
17 :     use base qw( WebPage );
18 :    
19 :     1;
20 :    
21 :    
22 :     ##############################################################
23 :     # Method for registering components etc. for the application #
24 :     ##############################################################
25 :     sub init {
26 :     my ( $self ) = @_;
27 :    
28 :     $self->application->register_component( 'Table', 'SubsystemSpreadsheet' );
29 :     $self->application->register_component( 'TabView', 'functionTabView' );
30 :     $self->application->register_component( 'Table', 'LD_SUBSETS' );
31 :     $self->application->register_component( 'Table', 'LD_ROLES' );
32 :     $self->application->register_component( 'Table', 'FunctionalRolesTable' );
33 :    
34 :     return 1;
35 :     }
36 :    
37 :     sub require_javascript {
38 :    
39 :     return [ './Html/showfunctionalroles.js' ];
40 :    
41 :     }
42 :    
43 :     ##############################################
44 :     # Website content is returned by this method #
45 :     ##############################################
46 :     sub output {
47 :     my ( $self ) = @_;
48 :    
49 :     # needed objects #
50 :     my $application = $self->application();
51 :     $self->{ 'fig' } = $application->data_handle( 'FIG' );
52 :     $self->{ 'cgi' } = $self->application->cgi;
53 :    
54 :     # subsystem name and 'nice name' #
55 :     my $name = $self->{ 'cgi' }->param( 'metasubsystem' );
56 :     my $ssname = $name;
57 :    
58 :     my $esc_name = uri_escape( $name );
59 :    
60 :     $ssname =~ s/\_/ /g;
61 :    
62 :     # look if someone is logged in and can write the subsystem #
63 :     $self->{ 'can_alter' } = 0;
64 :     my $user = $self->application->session->user;
65 :    
66 :     my $dbmaster = DBMaster->new( -database => 'WebAppBackend' );
67 :     my $ppoapplication = $dbmaster->Backend->init( { name => 'SubsystemEditor' } );
68 :    
69 :     ############################################
70 :     ### GET PREFERENCES FOR AN EXISTING USER ###
71 :     my $preferences = {};
72 :    
73 :     if ( defined( $user ) && ref( $user ) ) {
74 :     my $pre = $self->application->dbmaster->Preferences->get_objects( { user => $user,
75 :     application => $ppoapplication } );
76 :     %{ $preferences } = map { $_->name => $_ } @$pre;
77 :     }
78 :     ############################################
79 :    
80 :     # get a seeduser #
81 :     my $seeduser = '';
82 :    
83 :     if ( defined( $preferences->{ 'SeedUser' } ) ) {
84 :     $seeduser = $preferences->{ 'SeedUser' }->value;
85 :     }
86 :     if ( $user && $user->has_right( $self->application, 'edit', 'subsystem', $esc_name ) ) {
87 :     $self->{ 'can_alter' } = 1;
88 :     $self->{ 'fig' }->set_user( $seeduser );
89 :     $self->{ 'seeduser' } = $seeduser;
90 :     }
91 :    
92 :     $self->{ 'metasubsystem' } = new MetaSubsystem( $name, $self->{ 'fig' }, 0 );
93 :    
94 : bartels 1.2 my ( $phylo, $row_ss_members ) = $self->get_phylo_groups();
95 :     $self->{ 'row_subset_members' } = $row_ss_members;
96 : bartels 1.1
97 :     #########
98 :     # TASKS #
99 :     #########
100 :    
101 :     if ( defined( $self->{ 'cgi' }->param( 'buttonpressed' ) ) && $self->{ 'cgi' }->param( 'buttonpressed' ) eq 'LimitSubsets' ) {
102 :    
103 :     my @showsets = $self->{ 'cgi' }->param( 'show_set' );
104 :     my @collapsesets = $self->{ 'cgi' }->param( 'collapse_set' );
105 :     my @showrole = $self->{ 'cgi' }->param( 'show_role' );
106 :    
107 :     my $view;
108 :    
109 :     foreach my $set ( @showsets ) {
110 :     $set =~ /show_set_(.*)/;
111 :     $view->{ 'Subsets' }->{ $1 }->{ 'visible' } = 1;
112 :     }
113 :     foreach my $set ( @collapsesets ) {
114 :     $set =~ /collapse_set_(.*)/;
115 :     $view->{ 'Subsets' }->{ $1 }->{ 'collapsed' } = 1;
116 :     }
117 :     foreach my $role ( @showrole ) {
118 :     $role =~ /show_role_(.*)\##-##(.*)/;
119 :     my $tmprole = $1.'##-##'.$2;
120 :     $view->{ 'Roles' }->{ $tmprole }->{ 'visible' } = 1;
121 :     $view->{ 'Roles' }->{ $tmprole }->{ 'subsystem' } = $2;
122 :     }
123 :     $self->{ 'metasubsystem' }->{ 'view' } = $view;
124 :     $self->{ 'metasubsystem' }->write_metasubsystem();
125 :     }
126 : bartels 1.2 if ( !defined( $self->{ 'activeSubsetHash' } ) ) {
127 :     $self->{ 'activeSubsetHash' } = $self->getActiveSubsetHash();
128 :     }
129 : bartels 1.1
130 :     $self->get_metass_data();
131 :    
132 :     ########
133 :     # Data #
134 :     ########
135 :    
136 : bartels 1.2 my ( $hiddenvalues ) = $self->load_subsystem_spreadsheet( $application, $preferences );
137 : bartels 1.1
138 :     my $table = $self->application->component( 'SubsystemSpreadsheet' );
139 :     my $frtable = $self->application->component( 'FunctionalRolesTable' );
140 :    
141 :     ######################
142 :     # Construct the menu #
143 :     ######################
144 :    
145 :     my $menu = $self->application->menu();
146 :    
147 :     # Build nice tab menu here
148 :     $menu->add_category( 'Meta Overview', "SubsysEditor.cgi?page=MetaOverview" );
149 : bartels 1.2 $menu->add_category( 'Edit Subsets', "SubsysEditor.cgi?page=MetaSubsets&metasubsystem=$esc_name" );
150 :     $menu->add_category( 'Spreadsheet', "SubsysEditor.cgi?page=MetaSpreadsheet&metasubsystem=$esc_name" );
151 : bartels 1.1
152 :     ##############################
153 :     # Construct the page content #
154 :     ##############################
155 :    
156 :     # colorpanel #
157 :     my $colorpanel = $self->color_spreadsheet_panel( $preferences, $name );
158 :     # limitdisplaypanel #
159 :     my $limitdisplaypanel = $self->limit_display_panel();
160 :     my $limitsubsetspanel = $self->limit_subsets_panel();
161 :    
162 :     my $tab_view_component = $self->application->component( 'functionTabView' );
163 :     $tab_view_component->width( 900 );
164 :     # if ( $can_alter ) {
165 :     # $tab_view_component->add_tab( '<H2>&nbsp; Add Genomes to Spreadsheet &nbsp;</H2>', "$addgenomepanel" );
166 :     # }
167 :     $tab_view_component->add_tab( '<H2>&nbsp; Color Spreadsheet &nbsp;</H2>', "$colorpanel" );
168 :     $tab_view_component->add_tab( '<H2>&nbsp; Limit Genomes &nbsp;</H2>', "$limitdisplaypanel" );
169 :     $tab_view_component->add_tab( '<H2>&nbsp; Limit Subsets &nbsp;</H2>', "$limitsubsetspanel" );
170 :     $tab_view_component->add_tab( '<H2>&nbsp; Functional Roles &nbsp;</H2>', $frtable->output() );
171 :     # $tab_view_component->add_tab( '<H2>&nbsp; Show Variants &nbsp;</H2>', "$variantpanel" );
172 :    
173 :     if ( defined( $self->{ 'cgi' }->param( 'defaulttabhidden' ) ) ) {
174 :     $tab_view_component->default( $self->{ 'cgi' }->param( 'defaulttabhidden' ) );
175 :     }
176 :     else {
177 :     $tab_view_component->default( 0 );
178 :     }
179 :    
180 :     # add hidden parameter for the tab that is actually open #
181 :     my $dth = 0;
182 :     if ( defined( $self->{ 'cgi' }->param( 'defaulttabhidden' ) ) ) {
183 :     $dth = $self->{ 'cgi' }->param( 'defaulttabhidden' );
184 :     }
185 :    
186 :     $hiddenvalues->{ 'metasubsystem' } = $name;
187 :     $hiddenvalues->{ 'buttonpressed' } = 'none';
188 :     $hiddenvalues->{ 'defaulttabhidden' } = $dth;
189 :    
190 :     ###########
191 :     # Content #
192 :     ###########
193 :    
194 :     my $content = "<H1>Subsystem Metaview for $ssname</H1>";
195 :    
196 :     # start form #
197 :     $content .= $self->start_form( 'subsys_spreadsheet', $hiddenvalues );
198 :     $content .= "<TABLE><TR><TD>";
199 :    
200 :     $content .= $tab_view_component->output();
201 :     $content .= "</TD></TR><TR><TD>";
202 :     # put in color legends #
203 :     if ( defined( $self->{ 'legend' } ) ) {
204 :     $content .= $self->{ 'legend' };
205 :     $content .= "</TD></TR><TR><TD>";
206 :     }
207 :     if ( defined( $self->{ 'legendg' } ) ) {
208 :     $content .= $self->{ 'legendg' };
209 :     $content .= "</TD></TR><TR><TD>";
210 :     }
211 :    
212 :     $content .= $table->output();
213 :    
214 :     $content .= "</TD></TR>";
215 :     $content .= "</TABLE>";
216 :    
217 :     # end form
218 :     $content .= $self->end_form();
219 :    
220 :     return $content;
221 :     }
222 :    
223 :     ##############################
224 :     # draw subsystem spreadsheet #
225 :     ##############################
226 :     sub load_subsystem_spreadsheet {
227 :     my ( $self, $application, $preferences ) = @_;
228 :    
229 :     # initialize roles, subsets and spreadsheet
230 :     my $roles = $self->{ 'data_roles' };
231 :     my $subsets = $self->{ 'data_subsets' };
232 :     my $spreadsheet_hash = $self->{ 'data_spreadsheethash' };
233 :     my $pegsarr = $self->{ 'data_allpegs' };
234 :    
235 :     my $user = $application->session->user();
236 :     my $seeduser = $self->{ 'seeduser' };
237 :     my $metass = $self->{ 'metasubsystem' };
238 :    
239 :    
240 :     # get a list of sane colors
241 :     my $colors = $self->get_colors();
242 :    
243 :     #####################################
244 :     # Displaying and Collapsing Subsets #
245 :     #####################################
246 :    
247 :     # Now - what roles or what subsets do I take?
248 :     my $role_to_group;
249 :     my $columns;
250 : bartels 1.2 my $visible;
251 : bartels 1.1 my $role_to_function;
252 :     my $function_to_role;
253 :     my $subsetssupercolumns = 0;
254 : bartels 1.2 my $roletosubsethidden;
255 :    
256 :     my $th = $metass->{ 'view' }->{ 'Roles' };
257 : bartels 1.1
258 :     foreach my $subset ( keys %$subsets ) {
259 : bartels 1.2 foreach my $abb ( keys %{ $subsets->{ $subset } } ) {
260 :     push @{ $role_to_group->{ $abb } }, $subset;
261 :     $roletosubsethidden .= "$abb\t$subset\n";
262 :     }
263 :     $subsetssupercolumns++;
264 :     $columns->{ $subset } = scalar( keys %$columns );
265 : bartels 1.1 if ( $metass->{ 'view' }->{ 'Subsets' }->{ $subset }->{ 'visible' } ) {
266 :     if ( $metass->{ 'view' }->{ 'Subsets' }->{ $subset }->{ 'collapsed' } ) {
267 : bartels 1.2 $visible->{ $subset } = 1;
268 : bartels 1.1 }
269 :     else {
270 : bartels 1.2 my $ssvals = $subsets->{ $subset };
271 : bartels 1.1 }
272 :     }
273 :     }
274 :    
275 :     foreach my $role ( @$roles ) {
276 : bartels 1.2 my $rolesubsystem = $role->[0].'##-##'.$role->[3];
277 :     if ( defined( $th->{ $rolesubsystem } && $th->{ $rolesubsystem }->{ 'visible' } ) ) {
278 :     $visible->{ $rolesubsystem } = 1;
279 :     }
280 :     if ( defined( $role_to_group->{ $rolesubsystem } ) ) {
281 :     $visible->{ $rolesubsystem } = 1;
282 : bartels 1.1
283 : bartels 1.2 my @sss = @{ $role_to_group->{ $rolesubsystem } };
284 :     foreach my $ss ( @sss ) {
285 :     if ( $metass->{ 'view' }->{ 'Subsets' }->{ $ss }->{ 'visible' } ) {
286 :     if ( $metass->{ 'view' }->{ 'Subsets' }->{ $ss }->{ 'collapsed' } ) {
287 :     $visible->{ $rolesubsystem } = 0;
288 :     }
289 :     }
290 :     }
291 :     }
292 : bartels 1.1
293 :     $role_to_function->{ $rolesubsystem } = $role->[1];
294 :     $function_to_role->{ $role->[1] } = $role->[2];
295 :    
296 : bartels 1.2 $columns->{ $rolesubsystem } = scalar( keys %$columns );
297 : bartels 1.1 }
298 :    
299 :     ##########################################
300 :     # COLORING SETTINGS OF GENES AND GENOMES #
301 :     ##########################################
302 :     my $peg_to_color_alround;
303 :     my $cluster_colors_alround = {};
304 :     my $genome_colors;
305 :     my $genomes_to_color = {};
306 :     my $columnNameHash;
307 :     my $ind_to_subset;
308 :     my $name = $self->{ 'cgi' }->param( 'metasubsystem' );
309 :    
310 :     ### COLOR GENES ###
311 :     my $color_by = 'do not color'; #default
312 :     if ( $preferences->{ $name."_color_stuff" } ) {
313 :     $color_by = $preferences->{ $name."_color_stuff" }->value;
314 :     }
315 :     if ( defined( $self->{ 'cgi' }->param( 'color_stuff' ) ) ) {
316 :     $color_by = $self->{ 'cgi' }->param( 'color_stuff' );
317 :     unless ( $preferences->{ $name."_color_stuff" } ) {
318 :     if ( defined( $user ) && ref( $user ) ) {
319 :     $preferences->{ $name."_color_stuff" } = $self->application->dbmaster->Preferences->create( { user => $user,
320 :     application => $self->application->backend,
321 :     name => $name."_color_stuff",
322 :     value => $color_by } );
323 :     }
324 :     }
325 :     else {
326 :     $preferences->{ $name."_color_stuff" }->value( $color_by );
327 :     }
328 :     }
329 :     elsif ( $preferences->{ $name."_color_stuff" } ) {
330 :     $self->{ 'cgi' }->param( 'color_stuff', $preferences->{ $name."_color_stuff" }->value );
331 :     }
332 :    
333 :     if ( $color_by eq 'by attribute: ' ) {
334 :     my $attr = 'Essential_Gene_Sets_Bacterial';
335 :    
336 :     if ( $preferences->{ $name."_color_by_peg_tag" } ) {
337 :     $attr = $preferences->{ $name."_color_by_peg_tag" }->value;
338 :     }
339 :     if ( defined( $self->{ 'cgi' }->param( 'color_by_peg_tag' ) ) ) {
340 :     $attr = $self->{ 'cgi' }->param( 'color_by_peg_tag' );
341 :     unless ( $preferences->{ $name."_color_by_peg_tag" } ) {
342 :     if ( $user ) {
343 :     $preferences->{ $name."_color_by_peg_tag" } = $self->application->dbmaster->Preferences->create( { user => $user,
344 :     application => $self->application->backend,
345 :     name => $name."_color_by_peg_tag",
346 :     value => $attr } );
347 :     }
348 :     }
349 :     else {
350 :     $preferences->{ $name."_color_by_peg_tag" }->value( $attr );
351 :     }
352 :     }
353 :    
354 :     ( $peg_to_color_alround, $cluster_colors_alround ) = $self->get_color_by_attribute_infos( $attr, $pegsarr, $colors );
355 :     }
356 :    
357 :     ### COLOR GENOMES ###
358 :     my $colorg_by = 'do not color';
359 :     if ( $preferences->{ $name."_colorg_stuff" } ) {
360 :     $colorg_by = $preferences->{ $name."_colorg_stuff" }->value;
361 :     }
362 :     if ( defined( $self->{ 'cgi' }->param( 'colorg_stuff' ) ) ) {
363 :     $colorg_by = $self->{ 'cgi' }->param( 'colorg_stuff' );
364 :     unless ( $preferences->{ $name."_colorg_stuff" } ) {
365 :     if ( $user ) {
366 :     $preferences->{ $name."_colorg_stuff" } = $self->application->dbmaster->Preferences->create( { user => $user,
367 :     application => $self->application->backend,
368 :     name => $name."_colorg_stuff",
369 :     value => $color_by } );
370 :     }
371 :     }
372 :     else {
373 :     $preferences->{ $name."_colorg_stuff" }->value( $colorg_by );
374 :     }
375 :     }
376 :     elsif ( $preferences->{ $name."_colorg_stuff" } ) {
377 :     $self->{ 'cgi' }->param( 'colorg_stuff', $preferences->{ $name."_colorg_stuff" }->value );
378 :     }
379 :    
380 :     if ( $colorg_by eq 'by attribute: ' ) {
381 :    
382 :     my $attr;
383 :     if ( $preferences->{ $name."_color_by_ga" } ) {
384 :     $attr = $preferences->{ $name."_color_by_ga" }->value;
385 :     }
386 :    
387 :     if ( defined( $self->{ 'cgi' }->param( 'color_by_ga' ) ) && $self->{ 'cgi' }->param( 'color_by_ga' ) ne '' ) {
388 :     $attr = $self->{ 'cgi' }->param( 'color_by_ga' );
389 :    
390 :     unless ( $preferences->{ $name."_color_by_ga" } ) {
391 :     if ( $user ) {
392 :     $preferences->{ $name."_color_by_ga" } = $self->application->dbmaster->Preferences->create( { user => $user,
393 :     application => $self->application->backend,
394 :     name => $name."_color_by_ga",
395 :     value => $attr } );
396 :     }
397 :     }
398 :     elsif ( defined( $attr ) ) {
399 :     $preferences->{ $name."_color_by_ga" }->value( $attr );
400 :     $self->{ 'cgi' }->param( 'color_by_ga', $attr );
401 :     }
402 :     ( $genomes_to_color, $genome_colors ) = $self->get_color_by_attribute_infos_for_genomes( $spreadsheet_hash, $colors );
403 :     }
404 :     }
405 :    
406 :     ## END OF COLORING SETTINGS ##
407 :    
408 :     ################################
409 :     # Creating the table from here #
410 :     ################################
411 :    
412 : bartels 1.2 my $javascriptstring = '';
413 :    
414 : bartels 1.1 # create table headers
415 :     my $table_columns = [ '',
416 :     { name => 'Organism', filter => 1, sortable => 1, width => '150', operand => $self->{ 'cgi' }->param( 'filterOrganism' ) || '' },
417 :     { name => 'Domain', filter => 1, operator => 'combobox', operand => $self->{ 'cgi' }->param( 'filterDomain' ) || '' },
418 :     { name => 'Taxonomy', sortable => 1, visible => 0, show_control => 1 },
419 :     { name => 'Variant', sortable => 1 }
420 :     ];
421 :    
422 : bartels 1.2 my $supercolumns = [ [ '', 1 ], [ '', 1 ], [ '', 1 ], [ '', 1 ], [ '', 1 ], [ '', 1 ] ];
423 : bartels 1.1
424 :     if ( $subsetssupercolumns > 0 ) {
425 :     push @$supercolumns, [ 'Subsets', $subsetssupercolumns ];
426 :     }
427 :     my $supercolstobe;
428 :    
429 :     my $ii = 4; # this is for keeping in mind in what column we start the Functional Roles
430 :    
431 :     # if user can write he gets a writable variant column that if first invisible
432 :     if ( $self->{ 'can_alter' } ) {
433 :     push @$table_columns, { name => 'Variant', visible => 0 };
434 :     $ii++;
435 :     }
436 :    
437 :     my $i = $ii;
438 :    
439 :     ### Now add the column headers for all functional roles or subsets of the table ###
440 :     foreach my $column ( sort { $columns->{ $a } <=> $columns->{ $b } } keys( %$columns) ) {
441 :     $i++;
442 :    
443 :     if ( exists( $role_to_function->{ $column } ) ) {
444 :     $column =~ /(.*)\#\#\-\#\#(.*)/;
445 :     my $colrole = $1;
446 :     my $ss_of_role = $2;
447 :     my $tooltip = "<TABLE><TR><TH>Role</TH><TH>Subsystem</TH></TR>\n";
448 :     $tooltip .= "<TR><TD>".$role_to_function->{ $column }."</TD><TD>$ss_of_role</TD></TR</TABLE>";
449 : bartels 1.2 # if ( $visible->{ $column } ) {
450 :     push @$supercolstobe, [ $ss_of_role, 1 ];
451 :     # }
452 :     push( @$table_columns, { name => $colrole, tooltip => $tooltip, visible => $visible->{ $column } });
453 : bartels 1.1 $columnNameHash->{ $i } = $colrole.'<BR>'.$tooltip;
454 : bartels 1.2 $javascriptstring .= "\n$column\t$i";
455 : bartels 1.1 $ind_to_subset->{ $i } = 1;
456 :     }
457 :     else {
458 :     my $tooltip = "<table>";
459 : bartels 1.2 $tooltip .= "<tr><th colspan=2>Subset $column</th></tr>";
460 : bartels 1.1 foreach my $role ( keys %{ $subsets->{ $column } } ) {
461 : bartels 1.2 $role =~ /(.*)##-##(.*)/;
462 :     $tooltip .= "<tr><td>$1</td><td><b>$2</b></td></tr>";
463 : bartels 1.1 }
464 :     $tooltip .= "</table>";
465 : bartels 1.2 push( @$table_columns, { name => $column, tooltip => $tooltip, visible => $visible->{ $column } } );
466 : bartels 1.1 $columnNameHash->{ $i } = $column.'<BR>'.$tooltip;
467 : bartels 1.2 $javascriptstring .= "\n$column\t$i";
468 : bartels 1.1 }
469 :     }
470 :     push( @$table_columns, { name => 'Pattern', sortable => 1, visible => 0, show_control => 1 });
471 :    
472 :    
473 :     # Variants - default is not to show the -1 variants, so we have to ask if that is still true.
474 :     my $show_mo_variants = 0;
475 :     if ( defined( $self->{ 'cgi' }->param( 'buttonpressed' ) ) && $self->{ 'cgi' }->param( 'buttonpressed' ) eq 'MoVariants' || $self->{ 'cgi' }->param( 'showMoVariants' ) ) {
476 :     $show_mo_variants = 1;
477 :     }
478 :     if ( defined( $self->{ 'cgi' }->param( 'buttonpressed' ) ) && $self->{ 'cgi' }->param( 'buttonpressed' ) eq 'HideMoVariants' ) {
479 :     $show_mo_variants = 0;
480 :     }
481 :    
482 :     # For the lines of the table, walk through spreadsheet hash #
483 :     my $pretty_spreadsheet;
484 :    
485 :     my @sortedrows;
486 :    
487 :     if ( $preferences->{ 'sort_spreadsheet_by' } && $preferences->{ 'sort_spreadsheet_by' }->value() eq 'alphabetically' ) {
488 :     @sortedrows = sort { $spreadsheet_hash->{ $a }->{ 'name' } cmp $spreadsheet_hash->{ $b }->{ 'name' } } keys %$spreadsheet_hash;
489 :     }
490 :     else {
491 :     @sortedrows = sort { $spreadsheet_hash->{ $a }->{ 'taxonomy' } cmp $spreadsheet_hash->{ $b }->{ 'taxonomy' } } keys %$spreadsheet_hash;
492 :     }
493 :    
494 :     foreach my $g ( @sortedrows ) {
495 :    
496 : bartels 1.2 if ( defined( $self->{ 'activeSubsetHash' } ) ) {
497 :     next unless ( $self->{ 'activeSubsetHash' }->{ $g } );
498 :     }
499 :    
500 : bartels 1.1 my $new_row;
501 :    
502 :     # organism name, domain, taxonomy, variantcode #
503 :     my $gname = $spreadsheet_hash->{ $g }->{ 'name' };
504 :     my $domain = $spreadsheet_hash->{ $g }->{ 'domain' };
505 :     my $tax = $spreadsheet_hash->{ $g }->{ 'taxonomy' };
506 :     my $variant = $spreadsheet_hash->{ $g }->{ 'variant' };
507 :    
508 :     unless ( $show_mo_variants ) {
509 :     next if ( $variant eq '-1' );
510 :     }
511 :    
512 :     # add link to Organism page here #
513 :     $gname = "<A HREF='seedviewer.cgi?page=Organism&organism=" . $g."' target=_blank>$gname</A>";
514 :    
515 :     my $gentry = $gname;
516 :     if ( defined( $genomes_to_color->{ $g } ) ) {
517 :     $gentry = "<span style='background-color: " . $genome_colors->{ $genomes_to_color->{ $g } } . ";'>$gname</span>";
518 :     }
519 :    
520 :     my $genome_checkbox = $self->{ 'cgi' }->checkbox( -name => 'genome_checkbox',
521 :     -id => "genome_checkbox_$g",
522 :     -value => "genome_checkbox_$g",
523 :     -label => '',
524 :     -checked => 0,
525 :     -override => 1,
526 :     );
527 :    
528 :     push( @$new_row, $genome_checkbox );
529 :     push( @$new_row, $gentry );
530 :     push( @$new_row, $domain );
531 :     push( @$new_row, $tax );
532 :     push( @$new_row, $variant );
533 :     if ( $self->{ 'can_alter' } ) {
534 :     push( @$new_row, "<INPUT TYPE=TEXT NAME=\"variant$g\" SIZE=5 VALUE=\"$variant\">" );
535 :     }
536 :    
537 :     # now the genes #
538 :     my $thisrow = $spreadsheet_hash->{ $g }->{ 'row' };
539 :     my @row = @$thisrow;
540 :    
541 :     # memorize all pegs of this row
542 :     my $pegs;
543 :     my $rawpegs;
544 :    
545 :     # go through data cells and do grouping
546 :     my $data_cells;
547 :    
548 :     for ( my $i=0; $i<scalar( @row ); $i++ ) {
549 :     push( @$pegs, split( /, /, $row[$i] ) );
550 :    
551 :     my $roleident = $roles->[$i]->[0].'##-##'.$roles->[$i]->[3];
552 :    
553 :     if ( exists( $role_to_group->{ $roleident } ) ) {
554 :     my $subsetsofthisrole = $role_to_group->{ $roleident };
555 :    
556 :     my $thiscell = '';
557 :     foreach my $ss ( @$subsetsofthisrole ) {
558 :     my $index = $columns->{ $ss };
559 :     unless ( $row[$i] =~ /INPUT/ ) {
560 :     push( @{ $data_cells->[ $index ] }, split( /, /, $row[$i] ) );
561 :     }
562 :     }
563 :     }
564 : bartels 1.2 # else {
565 : bartels 1.1 my $index = $columns->{ $roleident };
566 :     push( @{ $data_cells->[ $index ] }, split( /, /, $row[$i] ) );
567 :     }
568 : bartels 1.2 # }
569 : bartels 1.1
570 :     foreach my $p ( @$pegs ) {
571 :     if ( $p =~ /(fig\|\d+\.\d+\.peg\.\d+)/ ) {
572 :     push @$rawpegs, $p;
573 :     }
574 :     }
575 :    
576 :     my $peg_to_color;
577 :     my $cluster_colors;
578 :    
579 :     # if we wanna color by cluster put it in here
580 :     if ( $color_by eq 'by cluster' ) {
581 :    
582 :     # compute clusters
583 :     my @clusters = $self->{ 'fig' }->compute_clusters( $rawpegs, undef, 5000 );
584 :    
585 :     for ( my $i = 0; $i < scalar( @clusters ); $i++ ) {
586 :    
587 :     my %countfunctions = map{ (scalar $self->{ 'fig' }->function_of( $_ ) => 1 ) } @{ $clusters[ $i ] };
588 :     next unless ( scalar( keys %countfunctions ) > 1);
589 :    
590 :     foreach my $peg ( @{ $clusters[ $i ] } ) {
591 :     $peg_to_color->{ $peg } = $i;
592 :     }
593 :     }
594 :     }
595 :     elsif ( $color_by eq 'by attribute: ' ) {
596 :     $peg_to_color = $peg_to_color_alround;
597 :     $cluster_colors = $cluster_colors_alround;
598 :     }
599 :    
600 :     # print actual cells
601 :     my $pattern = "a";
602 :     my $ind = $ii;
603 :     foreach my $data_cell ( @$data_cells ) {
604 :     $ind++;
605 :     my $num_clustered = 0;
606 :     my $num_unclustered = 0;
607 :     my $cluster_num = 0;
608 :     if ( defined( $data_cell ) ) {
609 :     $data_cell = [ sort( @$data_cell ) ];
610 : bartels 1.2 my $cell = {};
611 : bartels 1.1
612 :     foreach my $peg ( @$data_cell ) {
613 :    
614 :     if ( $peg =~ /(fig\|\d+\.\d+\.peg\.\d+)/ ) {
615 :     my $thispeg = $1;
616 :     my $pegf = $self->{ 'fig' }->function_of( $thispeg );
617 :     my $pegfnum = '';
618 :    
619 :     if ( !defined( $thispeg ) ) {
620 :     next;
621 :     }
622 :    
623 :     $thispeg =~ /fig\|\d+\.\d+\.peg\.(\d+)/;
624 :     my $n = $1;
625 :    
626 :     my $peg_link = $self->fid_link( $thispeg );
627 :     $peg_link = "<A HREF='$peg_link' target=_blank>$n</A>";
628 :     unless ( $ind_to_subset->{ $ind } ) {
629 :     my $add_to_peg = $self->get_peg_addition( $pegf );
630 :     $peg_link .= $add_to_peg;
631 :     }
632 :    
633 :     if ( exists( $peg_to_color->{ $peg } ) ) {
634 :     unless ( defined( $cluster_colors->{ $peg_to_color->{ $peg } } ) ) {
635 :     $cluster_colors->{ $peg_to_color->{ $peg } } = $colors->[ scalar( keys( %$cluster_colors ) ) ];
636 :     }
637 :     $cluster_num = scalar( keys( %$cluster_colors ) );
638 :     $num_clustered++;
639 : bartels 1.2 $cell->{ "<span style='background-color: " . $cluster_colors->{ $peg_to_color->{ $peg } } . ";'>$peg_link</span>" } = 1;
640 : bartels 1.1 }
641 :     else {
642 :     $num_unclustered++;
643 : bartels 1.2 $cell->{ "<span>$peg_link</span>" } = 1;
644 : bartels 1.1 }
645 :     }
646 :     else {
647 : bartels 1.2 $cell->{ $peg } = 1;
648 : bartels 1.1 }
649 :     }
650 :     my $tt = $columnNameHash->{ $ind };
651 : bartels 1.2 push( @$new_row, { data => join( '<br>', keys %$cell ), tooltip => $tt } );
652 : bartels 1.1 }
653 :     else {
654 :     my $tt = $columnNameHash->{ $ind };
655 :     push( @$new_row, { data => '', tooltip => $tt } );
656 :     }
657 :     $pattern .= $num_clustered.$num_unclustered.$cluster_num;
658 :     }
659 :    
660 :     # pattern
661 :     push(@$new_row, $pattern);
662 :    
663 :     # push row to table
664 :     push(@$pretty_spreadsheet, $new_row);
665 :     }
666 :    
667 :     ### create table from parsed data ###
668 :    
669 :     my $table = $application->component( 'SubsystemSpreadsheet' );
670 :     $table->columns( $table_columns );
671 :     $table->data( $pretty_spreadsheet );
672 :     $table->show_top_browse( 1 );
673 :     $table->show_export_button( { strip_html => 1,
674 :     hide_invisible_columns => 1,
675 :     title => 'Export plain data to Excel' } );
676 :    
677 :     my $ss;
678 :     my $ssval = 0;
679 :     foreach my $thisarr ( @$supercolstobe ) {
680 :     if ( !defined( $ss ) ) {
681 :     $ss = $thisarr->[0];
682 :     $ssval++;
683 :     }
684 :     elsif ( $ss eq $thisarr->[0] ) {
685 :     $ssval++;
686 :     }
687 :     else {
688 :     my $nicess = $ss;
689 :     $nicess =~ s/\_/ /g;
690 :     push @$supercolumns, [ $nicess, $ssval ];
691 :     $ss = $thisarr->[0];
692 :     $ssval = 1;
693 :     }
694 :     }
695 :     if ( defined( $ss ) ) {
696 :     my $nicess = $ss;
697 :     $nicess =~ s/\_/ /g;
698 :     push @$supercolumns, [ $nicess, $ssval ];
699 :     }
700 :    
701 :     $table->supercolumns( $supercolumns );
702 :    
703 :     $table->show_select_items_per_page( 1 );
704 :    
705 :     ### remember some hidden values ###
706 :    
707 :     my $hiddenvalues = { 'filterOrganism' => '',
708 :     'sortOrganism' => '',
709 :     'filterDomain' => '',
710 :     'tableid' => $table->id,
711 : bartels 1.2 'showMoVariants' => $show_mo_variants,
712 :     'javascripthidden' => $javascriptstring,
713 :     'roletosubsethidden' => $roletosubsethidden };
714 : bartels 1.1
715 :     # finished
716 : bartels 1.2 return ( $hiddenvalues );
717 : bartels 1.1 }
718 :    
719 :    
720 :     ######################################
721 :     # Panel for coloring the spreadsheet #
722 :     ######################################
723 :     sub color_spreadsheet_panel {
724 :    
725 :     my ( $self, $preferences, $name ) = @_;
726 :    
727 :     my $content = "<H2>Color genes in spreadsheet</H2>";
728 :    
729 :     my $default_coloring = $self->{ 'cgi' }->param( 'color_stuff' ) || 'do not color';
730 :    
731 :     if ( !defined( $self->{ 'cgi' }->param( 'color_by_peg_tag' ) ) && defined( $preferences->{ $name."_color_by_peg_tag" } ) ) {
732 :     $self->{ 'cgi' }->param( 'color_by_peg_tag', $preferences->{ $name."_color_by_peg_tag" }->value );
733 :     }
734 :    
735 :     my $defaultg_coloring = 'do not color';
736 :     if ( defined( $self->{ 'cgi' }->param( 'colorg_stuff' ) ) ) {
737 :     $defaultg_coloring = $self->{ 'cgi' }->param( 'colorg_stuff' );
738 :     }
739 :    
740 :     my @color_opt = $self->{ 'cgi' }->radio_group( -name => 'color_stuff',
741 :     -values => [ 'do not color', 'by cluster', 'by attribute: ' ],
742 :     -default => $default_coloring,
743 :     -override => 1
744 :     );
745 :    
746 :     my @pegkeys = $self->{ 'fig' }->get_peg_keys();
747 :     push @pegkeys, 'Expert_Annotations';
748 :    
749 :     # Compile and order the attribute keys found on pegs:
750 :     my $high_priority = qr/(essential|fitness)/i;
751 :     my @options = sort { $b =~ /$high_priority/o <=> $a =~ /$high_priority/o
752 :     || uc( $a ) cmp uc( $b )
753 :     }
754 :     @pegkeys;
755 :     my $blacklist = attribute_blacklist();
756 :    
757 :     @options = grep { !$blacklist->{ $_ } } @options;
758 :     unshift @options, undef; # Start list with empty
759 :    
760 :     my $att_popup = $self->{ 'cgi' }->popup_menu(-name => 'color_by_peg_tag', -values => \@options);
761 :    
762 :     $content .= join( "<BR>\n", @color_opt );
763 :     $content .= $att_popup;
764 :    
765 :     $content .= "<H2>Color genomes in spreadsheet</H2>";
766 :    
767 :     my @goptions = sort { uc( $a ) cmp uc( $b ) } $self->{ 'fig' }->get_genome_keys(); # get all the genome keys
768 :     unshift @goptions, undef; # a blank field at the start
769 :    
770 :     my @colorg_opt = $self->{ 'cgi' }->radio_group( -name => 'colorg_stuff',
771 :     -values => [ 'do not color', 'by attribute: ' ],
772 :     -default => $defaultg_coloring,
773 :     -override => 1
774 :     );
775 :    
776 :     my $genome_popup = $self->{ 'cgi' }->popup_menu( -name => 'color_by_ga', -values => \@goptions );
777 :     $content .= join( "<BR>\n", @colorg_opt );
778 :     $content .= $genome_popup;
779 :     if ( $self->{ 'can_alter' } ) {
780 :     $content .= "<BR><BR><INPUT TYPE=BUTTON VALUE='Color Spreadsheet' ONCLICK='SubmitSpreadsheet( \"Color Spreadsheet\", 1 );'>";
781 :     }
782 :     else {
783 :     $content .= "<BR><BR><INPUT TYPE=BUTTON VALUE='Color Spreadsheet' ONCLICK='SubmitSpreadsheet( \"Color Spreadsheet\", 0 );'>";
784 :     }
785 :    
786 :     return $content;
787 :     }
788 :    
789 :     ###############
790 :     # data method #
791 :     ###############
792 :     sub get_metass_data {
793 :    
794 :     my ( $self ) = @_;
795 :    
796 :     my $meta = $self->{ 'metasubsystem' };
797 :    
798 :     my $subsystems = $meta->{ 'subsystems' };
799 :    
800 :     my ( $subsets, $spreadsheet, $allpegs );
801 :     my $counter = 0;
802 :     my @roles;
803 :     my %spreadsheethash;
804 :     my @supercolumns;
805 :    
806 :     my $frtable = $self->application->component( 'FunctionalRolesTable' );
807 :     $frtable->columns( [ '#', 'Subsystem', 'Abbr.', 'Role Name' ] );
808 :     my $frtablerows;
809 :    
810 :     my @genomes = keys %{ $meta->{ 'genomes' } };
811 :     my $role_counter = 0;
812 :    
813 :     foreach my $ssname ( keys %$subsystems ) {
814 :     my $subsystem = $subsystems->{ $ssname };
815 :    
816 :     $counter ++;
817 :    
818 :     ## get da roles ##
819 :     my @rs = $subsystem->get_roles();
820 :     foreach my $r ( @rs ) {
821 :     $role_counter++;
822 :     my $abb = $subsystem->get_abbr_for_role( $r );
823 :     my $in = $subsystem->get_role_index( $r );
824 :     push @{ $self->{ 'roles_to_num' }->{ $r } }, [ $role_counter, $abb.'##-##'.$ssname ];
825 :     # $self->{ 'abb_ss_to_num' }->{ $abb.'##-##'.$ssname } = $role_counter;
826 :    
827 :    
828 :     push @roles, [ $abb, $r, $in, $ssname ];
829 :     push @$frtablerows, [ $role_counter, $ssname, $abb, $r ];
830 :     }
831 :    
832 :     foreach my $genome ( @genomes ) {
833 :     my $gidx = $subsystem->get_genome_index( $genome );
834 :    
835 :     $spreadsheethash{ $genome }->{ 'name' } = $self->{ 'fig' }->genus_species( $genome );
836 :     $spreadsheethash{ $genome }->{ 'domain' } = $self->{ 'fig' }->genome_domain( $genome );
837 :     $spreadsheethash{ $genome }->{ 'taxonomy' } = $self->{ 'fig' }->taxonomy_of( $genome );
838 :    
839 :     my $var = $subsystem->get_variant_code( $gidx );
840 :     if ( !defined( $gidx ) ) {
841 :     $var = '-';
842 :     }
843 :     if ( defined( $spreadsheethash{ $genome }->{ 'variant' } ) ) {
844 :     $spreadsheethash{ $genome }->{ 'variant' } .= "_$var";
845 :     }
846 :     else {
847 :     $spreadsheethash{ $genome }->{ 'variant' } = $var;
848 :     }
849 :    
850 :     my $rowss = $subsystem->get_row( $gidx );
851 :     my @row;
852 :    
853 :     foreach my $tr ( @$rowss ) {
854 :     if ( !defined( $gidx ) ) {
855 :     push @row, '';
856 :     }
857 :     else {
858 :     if ( defined( $tr->[0] ) ) {
859 :     push @$allpegs, @$tr;
860 :     push @row, join( ', ', @$tr );
861 :     }
862 :     else {
863 :     push @row, '';
864 :     }
865 :     }
866 :     }
867 :    
868 :     push @{ $spreadsheethash{ $genome }->{ 'row' } }, @row;
869 :     }
870 :    
871 :     $frtable->data( $frtablerows );
872 :    
873 :     }
874 :    
875 :     ## now get da subsets ##
876 :     my @subsetArr = keys %{ $meta->{ 'subsets' } };
877 :    
878 :     foreach my $subsetname ( @subsetArr ) {
879 :     next if ( $subsetname eq 'All' );
880 :     my @abb_subsets = keys %{ $meta->{ 'subsets' } };
881 :    
882 :     $subsets->{ $subsetname } = $meta->{ 'subsets' }->{ $subsetname };
883 :     }
884 :    
885 :     $self->{ 'data_roles' } = \@roles;
886 :     $self->{ 'data_subsets' } = $subsets;
887 :     $self->{ 'data_spreadsheethash' } = \%spreadsheethash;
888 :     $self->{ 'data_allpegs' } = $allpegs;
889 :    
890 :     }
891 :    
892 :     ######################################
893 :     # Panel for coloring the spreadsheet #
894 :     ######################################
895 :     sub limit_display_panel {
896 :    
897 :     my ( $self ) = @_;
898 :    
899 :     # create a new subsystem object #
900 :     my $subsets = $self->{ 'metasubsystem' }->{ 'subsets' };
901 :    
902 :     # my @tmp = grep { $_ ne "All" } sort $subsystem->get_subset_namesR;
903 :     my $genomes = $self->{ 'metasubsystem' }->{ 'genomes' };
904 :    
905 :     my %options = ( "higher_plants" => "Higher Plants",
906 :     "eukaryotic_ps" => "Photosynthetic Eukaryotes",
907 :     "nonoxygenic_ps" => "Anoxygenic Phototrophs",
908 :     "hundred_hundred" => "Hundred by a hundred",
909 :     "functional_coupling_paper" => "Functional Coupling Paper",
910 :     "cyano_or_plant" => "Cyanos OR Plants",
911 :     "ecoli_essentiality_paper" => "E. coli Essentiality Paper",
912 :     "has_essentiality_data" => "Genomes with essentiality data",
913 :     "" => "All"
914 :     );
915 :    
916 :     my @options = ( 'All',
917 :     'NMPDR',
918 :     'BRC',
919 :     'Hundred by a hundred' );
920 :    
921 :     my @genomeListsUser = GenomeLists::getListsForUser();
922 :     unshift @genomeListsUser, 'All';
923 :    
924 :     my @allsets = keys %$subsets;
925 :     my @starsets = @allsets;
926 :    
927 :     my $content .= "<P>Limit display of the the genomes in the table based on phylogeny or one of the preselected groups in the left box. Limit display of roles via their subsets and decide which subsets you want to uncollapse in the right box:<P>\n";
928 :    
929 :     # put in table #
930 :     $content .= "<TABLE><TR><TD>";
931 :    
932 :     # build a little table for the genomes limiting
933 :     $content .= "<H2>&nbsp; Limit displayed Genomes</H2><TABLE><TR><TD>";
934 :    
935 :     $content .= "<B>Phylogeny</B></TD><TD><B>Specific Sets</B></TD><TD><B>User Sets</B></TD></TR><TR><TD>";
936 :    
937 :     # phylogeny here #
938 : bartels 1.2 my ( $phylo, $row_ss_members ) = $self->get_phylo_groups();
939 :     # $self->{ 'row_subset_members' } = $row_ss_members;
940 : bartels 1.1 $content .= $self->{ 'cgi' }->scrolling_list( -id => 'phylogeny_set',
941 :     -name => 'phylogeny_set',
942 : bartels 1.2 -values => [ "All", sort @$phylo ],
943 : bartels 1.1 -default => 'All',
944 :     -size => 5
945 :     );
946 :     $content .= "</TD><TD>\n";
947 :    
948 :     # now special sets #
949 :     $content .= $self->{ 'cgi' }->scrolling_list( -id => 'special_set',
950 :     -name => 'special_set',
951 :     -values => \@options,
952 :     -default => 'All',
953 :     -size => 5
954 :     );
955 :     $content .= "</TD><TD>\n";
956 :    
957 :     # now special sets #
958 :     $content .= $self->{ 'cgi' }->scrolling_list( -id => 'user_set',
959 :     -name => 'user_set',
960 :     -values => \@genomeListsUser,
961 :     -default => 'All',
962 :     -size => 5
963 :     );
964 :     $content .= "</TD></TR></TABLE>\n";
965 :     $content .= "</TD></TR>\n</TABLE>";
966 :    
967 :     if ( $self->{ 'can_alter' } ) {
968 : bartels 1.2 $content .= "<BR><BR><INPUT TYPE=BUTTON VALUE='Limit Display' ONCLICK='SubmitSpreadsheet( \"LimitDisplay\", 1 );'>";
969 : bartels 1.1 }
970 :     else {
971 : bartels 1.2 $content .= "<BR><BR><INPUT TYPE=BUTTON VALUE='Limit Display' ONCLICK='SubmitSpreadsheet( \"LimitDisplay\", 1 );'>";
972 : bartels 1.1 }
973 :    
974 :     return $content;
975 :     }
976 :    
977 :    
978 :     ######################################
979 :     # Panel for coloring the spreadsheet #
980 :     ######################################
981 :     sub limit_subsets_panel {
982 :    
983 :     my ( $self ) = @_;
984 :    
985 :     # create a new subsystem object #
986 :     my $subsets = $self->{ 'metasubsystem' }->{ 'subsets' };
987 :    
988 :     my @allsets = keys %$subsets;
989 :     my @starsets = @allsets;
990 :    
991 :     my @roles = @{ $self->{ 'data_roles' } };
992 :     my %roles;
993 : bartels 1.2 my %abbtofr;
994 : bartels 1.1 foreach my $r ( @roles ) {
995 :     $roles{ $r->[0].'##-##'.$r->[3] } = $r;
996 :     }
997 :    
998 :     my $subsets_table = $self->application->component( 'LD_SUBSETS' );
999 :     my $roles_table = $self->application->component( 'LD_ROLES' );
1000 :    
1001 :     my $sstdata = [];
1002 :     foreach my $set ( @allsets ) {
1003 :     my $show_checked = $self->{ 'metasubsystem' }->{ 'view' }->{ 'Subsets' }->{ $set }->{ 'visible' } || 0;
1004 :     my $collapse_checked = $self->{ 'metasubsystem' }->{ 'view' }->{ 'Subsets' }->{ $set }->{ 'collapsed' } || 0;
1005 :    
1006 :     my $show_set = $self->{ 'cgi' }->checkbox( -name => 'show_set',
1007 :     -id => "show_set_$set",
1008 :     -value => "show_set_$set",
1009 :     -label => '',
1010 :     -checked => $show_checked,
1011 :     );
1012 :     my $collapse_set = $self->{ 'cgi' }->checkbox( -name => 'collapse_set',
1013 :     -id => "collapse_set_$set",
1014 :     -value => "collapse_set_$set",
1015 :     -label => '',
1016 :     -checked => $collapse_checked,
1017 :     );
1018 :    
1019 :     my @mems = keys %{ $subsets->{ $set } };
1020 : bartels 1.2 my @nicemems;
1021 :     my @nicesubsystems;
1022 : bartels 1.1 foreach ( @mems ) {
1023 : bartels 1.2 $self->{ 'in_subset_role' }->{ $_ } = 1;
1024 :     if ( $_ =~ /([^#^-]+)##-##(.*)/ ) {
1025 :     push @nicemems, $1;
1026 :     push @nicesubsystems, $2;
1027 :     }
1028 : bartels 1.1 }
1029 :    
1030 : bartels 1.2 my $row = [ $set, { data => join( ', ', @nicemems ), tooltip => join( ', ', @nicesubsystems ) },
1031 : bartels 1.1 $show_set, $collapse_set ];
1032 :    
1033 :     push @$sstdata, $row;
1034 :     }
1035 :    
1036 :     my $rowdata = [];
1037 :     my %rowdatahash;
1038 :     foreach my $r ( sort keys %roles ) {
1039 : bartels 1.2 next if ( defined( $self->{ 'in_subset_role' }->{ $r } ) );
1040 : bartels 1.1 my $checkid = "show_role_$r";
1041 :    
1042 :     my $show_checked = 0;
1043 :     if ( $self->{ 'metasubsystem' }->{ 'view' }->{ 'Roles' }->{ $r }->{ 'visible' } ) {
1044 :     $show_checked = 1;
1045 :     }
1046 :    
1047 :     my $show_set = $self->{ 'cgi' }->checkbox( -name => 'show_role',
1048 :     -id => "$checkid",
1049 :     -value => "$checkid",
1050 :     -label => '',
1051 :     -checked => $show_checked,
1052 :     );
1053 :     $r =~ /(.*)##-##.*/;
1054 :    
1055 :     $rowdatahash{ $roles{ $r }->[3] }->{ $1 }->{ 'funcrole' } = $roles{ $r }->[1];
1056 :     $rowdatahash{ $roles{ $r }->[3] }->{ $1 }->{ 'checkbox' } = $show_set;
1057 :     }
1058 :    
1059 :     my $isrow = 0;
1060 :     foreach my $subsys ( keys %rowdatahash ) {
1061 :     my $count = 0;
1062 :     my @row = ( $subsys );
1063 :     foreach my $abb ( keys %{ $rowdatahash{ $subsys } } ) {
1064 :     $count++;
1065 :     $isrow = 1;
1066 : bartels 1.2 push @row, { data => $abb."<BR>".$rowdatahash{ $subsys }->{ $abb }->{ 'checkbox' }, tooltip => $rowdatahash{ $subsys }->{ $abb }->{ 'funcrole' } };
1067 : bartels 1.1 if ( $count > 8 ) {
1068 :     $count = 0;
1069 :     push @$rowdata, [ @row ];
1070 :     @row = ( $subsys );
1071 :     }
1072 :     }
1073 :     if ( $count > 0 ) {
1074 :     for( my $i = $count; $i <= 8; $i++ ) {
1075 :     push @row, '';
1076 :     }
1077 :     push @$rowdata, [ @row ];
1078 :     }
1079 :     }
1080 :    
1081 : bartels 1.2 if ( scalar( @$sstdata ) > 0 ) {
1082 :     $subsets_table->columns( [ 'Name', 'Members', 'Show', 'Collapse' ] );
1083 :     $subsets_table->data( $sstdata );
1084 :     }
1085 :     if ( scalar( @$rowdata ) > 0 ) {
1086 :     $roles_table->columns( [ 'Subsystem', '', '', '', '', '', '', '', '', '' ] );
1087 :     $roles_table->data( $rowdata );
1088 :     }
1089 : bartels 1.1
1090 :     my $content = '<TABLE><TR>';
1091 :     $content .= "<TD><B>Subsets</B></TD></TR><TR>";
1092 :     $content .= "<TD>Choose which subsets should be visible, and for these if they should be displayed collapsed or show each role in a separate column.";
1093 :     $content .= "</TD></TR><TR><TD>";
1094 :     $content .= $subsets_table->output();
1095 :     if ( $isrow ) {
1096 :     $content .= '</TD></TR><TR>';
1097 :     $content .= "<TD><B>Functional Roles</B></TD></TR><TR>";
1098 :     $content .= "<TD>The following roles are not part of any defined subsystem. Check the roles you want to see in your display.</TD>";
1099 :     $content .= '</TR><TR><TD>';
1100 :     $content .= $roles_table->output();
1101 :     }
1102 :     $content .= '</TD></TR></TABLE>';
1103 :    
1104 : bartels 1.2 my $spreadsheettable = $self->application->component( 'SubsystemSpreadsheet' );
1105 :     my $spreadsheettableid = $spreadsheettable->id();
1106 :    
1107 :     $content .= "<BR><BR><INPUT TYPE=BUTTON VALUE='Limit Subsets and Functional Roles' ONCLICK='ChangeVisibility( \"$spreadsheettableid\" );'><INPUT TYPE=BUTTON VALUE='Make current setting Default' ONCLICK='SubmitSpreadsheet( \"LimitSubsets\", 2 );'>";
1108 :     # }
1109 : bartels 1.1
1110 :     return $content;
1111 :     }
1112 :    
1113 :    
1114 :     sub fid_link {
1115 :     my ( $self, $fid ) = @_;
1116 :     my $n;
1117 :     my $seeduser = $self->{ 'seeduser' };
1118 :     $seeduser = '' if ( !defined( $seeduser ) );
1119 :    
1120 :     if ($fid =~ /^fig\|\d+\.\d+\.([a-zA-Z]+)\.(\d+)/) {
1121 :     if ( $1 eq "peg" ) {
1122 :     $n = $2;
1123 :     }
1124 :     else {
1125 :     $n = "$1.$2";
1126 :     }
1127 :     }
1128 :    
1129 :     return "./protein.cgi?prot=$fid&user=$seeduser\&new_framework=0";
1130 :     }
1131 :    
1132 :    
1133 :    
1134 :     sub get_color_by_attribute_infos {
1135 :    
1136 : bartels 1.2 my ( $self, $attr, $pegsarr, $colors ) = @_;
1137 : bartels 1.1
1138 :     my $scalacolor = is_scala_attribute( $attr );
1139 :     my $peg_to_color_alround;
1140 :     my $cluster_colors_alround;
1141 :    
1142 :     if ( defined( $attr ) ) {
1143 : bartels 1.2 my $groups_for_pegs = get_groups_for_pegs( $self->{ 'fig' }, $attr, $pegsarr );
1144 : bartels 1.1 my $i = 0;
1145 :     my $biggestitem = 0;
1146 :     my $smallestitem = 100000000000;
1147 :    
1148 :     if ( $scalacolor ) {
1149 :     foreach my $item ( keys %$groups_for_pegs ) {
1150 :    
1151 :     if ( $biggestitem < $item ) {
1152 :     $biggestitem = $item;
1153 :     }
1154 :     if ( $smallestitem > $item ) {
1155 :     $smallestitem = $item;
1156 :     }
1157 :     }
1158 :     $self->{ 'legend' } = get_scala_legend( $biggestitem, $smallestitem, 'Color legend for CDSs' );
1159 :     }
1160 :    
1161 :     my $leghash;
1162 :     foreach my $item ( keys %$groups_for_pegs ) {
1163 :     foreach my $peg ( @{ $groups_for_pegs->{ $item } } ) {
1164 :     $peg_to_color_alround->{ $peg } = $i;
1165 :     }
1166 :    
1167 :     if ( $scalacolor ) {
1168 :     my $col = get_scalar_color( $item, $biggestitem, $smallestitem );
1169 :     $cluster_colors_alround->{ $i } = $col;
1170 :     }
1171 :     else {
1172 :     $cluster_colors_alround->{ $i } = $colors->[ scalar( keys( %$cluster_colors_alround ) ) ];
1173 :     $leghash->{ $item } = $cluster_colors_alround->{ $i };
1174 :     }
1175 :     $i++;
1176 :     }
1177 :     if ( !$scalacolor ) {
1178 :     $self->{ 'legend' } = get_value_legend( $leghash, 'Color Legend for CDSs' );
1179 :     }
1180 :     }
1181 :     return ( $peg_to_color_alround, $cluster_colors_alround );
1182 :     }
1183 :    
1184 :     sub get_peg_addition {
1185 :    
1186 :     my ( $self, $pegf ) = @_;
1187 :    
1188 :     my @frs = split( ' / ', $pegf );
1189 :     my $pegfnum = '';
1190 :    
1191 :     foreach ( @frs ) {
1192 :     my $m = $self->{ 'roles_to_num' }->{ $_ };
1193 :     next if ( !defined( $m ) );
1194 :    
1195 :     foreach my $pm ( @$m ) {
1196 :     my $pegfnumtmp = $pm->[0];
1197 :     $pegfnum .= '_'.$pegfnumtmp;
1198 :     }
1199 :     }
1200 :     return $pegfnum;
1201 :     }
1202 :    
1203 :     sub get_color_by_attribute_infos_for_genomes {
1204 :    
1205 : bartels 1.2 my ( $self, $spreadsheethash, $colors ) = @_;
1206 : bartels 1.1
1207 :     my $genomes_to_color;
1208 :     my $genome_colors;
1209 :     my $leghash;
1210 :     my $i = 0;
1211 :     my $biggestitem = 0;
1212 :     my $smallestitem = 100000000000;
1213 :    
1214 : bartels 1.2 my $attr = $self->{ 'cgi' }->param( 'color_by_ga' );
1215 : bartels 1.1 my $scalacolor = is_scala_attribute( $attr );
1216 :    
1217 :     my @genomes = keys %$spreadsheethash;
1218 : bartels 1.2 my $groups_for_genomes = get_groups_for_pegs( $self->{ 'fig' }, $attr, \@genomes );
1219 : bartels 1.1
1220 :     if ( $scalacolor ) {
1221 :    
1222 :     foreach my $item ( keys %$groups_for_genomes ) {
1223 :    
1224 :     if ( $biggestitem < $item ) {
1225 :     $biggestitem = $item;
1226 :     }
1227 :     if ( $smallestitem > $item ) {
1228 :     $smallestitem = $item;
1229 :     }
1230 :     }
1231 :     $self->{ 'legendg' } = get_scala_legend( $biggestitem, $smallestitem, 'Color Legend for Genomes' );
1232 :     }
1233 :    
1234 :     foreach my $item ( keys %$groups_for_genomes ) {
1235 :     foreach my $g ( @{ $groups_for_genomes->{ $item } } ) {
1236 :     $genomes_to_color->{ $g } = $i;
1237 :     }
1238 :    
1239 :     if ( $scalacolor ) {
1240 :     my $col = get_scalar_color( $item, $biggestitem, $smallestitem );
1241 :     $genome_colors->{ $i } = $col;
1242 :     }
1243 :     else {
1244 :     $genome_colors->{ $i } = $colors->[ scalar( keys( %$genome_colors ) ) ];
1245 :     $leghash->{ $item } = $genome_colors->{ $i };
1246 :     }
1247 :     $i++;
1248 :     }
1249 :     if ( !$scalacolor ) {
1250 :     $self->{ 'legendg' } = get_value_legend( $leghash, 'Color Legend for Genomes' );
1251 :     }
1252 :    
1253 :     return ( $genomes_to_color, $genome_colors );
1254 :     }
1255 :    
1256 :    
1257 :     sub get_colors {
1258 :     my ( $self ) = @_;
1259 :    
1260 :     return [ '#d94242', '#eaec19', '#715ae5', '#25d729', '#f9ae1d', '#19b5b3', '#b519b3', '#ffa6ef',
1261 :     '#744747', '#701414', '#70a444', '#C0C0C0', '#FF40C0', '#FF8040', '#FF0080', '#FFC040',
1262 :     '#40C0FF', '#40FFC0', '#C08080', '#C0FF00', '#00FF80', '#00C040',
1263 :     "#6B8E23", "#483D8B", "#2E8B57", "#008000", "#006400", "#800000", "#00FF00", "#7FFFD4",
1264 :     "#87CEEB", "#A9A9A9", "#90EE90", "#D2B48C", "#8DBC8F", "#D2691E", "#87CEFA", "#E9967A",
1265 :     "#FFE4C4", "#FFB6C1", "#E0FFFF", "#FFA07A", "#DB7093", "#9370DB", "#008B8B", "#FFDEAD",
1266 :     "#DA70D6", "#DCDCDC", "#FF00FF", "#6A5ACD", "#00FA9A", "#228B22", "#1E90FF", "#FA8072",
1267 :     "#CD853F", "#DC143C", "#FF6347", "#98FB98", "#4682B4", "#D3D3D3", "#7B68EE", "#2F4F4F",
1268 :     "#FF7F50", "#FF69B4", "#BC8F8F", "#A0522D", "#DEB887", "#00DED1", "#6495ED", "#800080",
1269 :     "#FFD700", "#F5DEB3", "#66CDAA", "#FF4500", "#4B0082", "#CD5C5C", "#EE82EE", "#7CFC00",
1270 :     "#FFFF00", "#191970", "#FFFFE0", "#DDA0DD", "#00BFFF", "#DAA520", "#008080", "#00FF7F",
1271 :     "#9400D3", "#BA55D3", "#D8BFD8", "#8B4513", "#3CB371", "#00008B", "#5F9EA0", "#4169E1",
1272 :     "#20B2AA", "#8A2BE2", "#ADFF2F", "#556B2F", "#F0FFFF", "#B0E0E6", "#FF1493", "#B8860B",
1273 :     "#FF0000", "#F08080", "#7FFF00", "#8B0000", "#40E0D0", "#0000CD", "#48D1CC", "#8B008B",
1274 :     "#696969", "#AFEEEE", "#FF8C00", "#EEE8AA", "#A52A2A", "#FFE4B5", "#B0C4DE", "#FAF0E6",
1275 :     "#9ACD32", "#B22222", "#FAFAD2", "#808080", "#0000FF", "#000080", "#32CD32", "#FFFACD",
1276 :     "#9932CC", "#FFA500", "#F0E68C", "#E6E6FA", "#F4A460", "#C71585", "#BDB76B", "#00FFFF",
1277 :     "#FFDAB9", "#ADD8E6", "#778899" ];
1278 :     }
1279 :    
1280 :    
1281 :     #####################################################
1282 :     # List of attributes that are not used for coloring #
1283 :     #####################################################
1284 :     sub attribute_blacklist {
1285 :    
1286 :     my $list = { 'pfam-domain' => 1,
1287 :     'PFAM' => 1,
1288 :     'CDD' => 1 };
1289 :     return $list;
1290 :    
1291 :     }
1292 : bartels 1.2
1293 :     sub get_phylo_groups {
1294 :     my ( $self ) = @_;
1295 :    
1296 :     my @row_subsets;
1297 :     my $row_subset_members;
1298 :    
1299 :     my $taxonomic_groups = $self->{ 'fig' }->taxonomic_groups_of_complete(10);
1300 :     foreach my $pair ( @$taxonomic_groups ) {
1301 :     my ( $id, $members ) = @$pair;
1302 :     if ( $id ne "All" ) {
1303 :     push( @row_subsets, $id );
1304 :     }
1305 :     $row_subset_members->{ $id } = $members;
1306 :     }
1307 :     return ( \@row_subsets, $row_subset_members );
1308 :     }
1309 :    
1310 :    
1311 :     sub getActiveSubsetHash {
1312 :    
1313 :     my ( $self ) = @_;
1314 :    
1315 :     my $activeR;
1316 :     my $evaluate = 0;
1317 :     my $andor;
1318 :    
1319 :     my $phylo = $self->{ 'cgi' }->param( 'phylogeny_set' );
1320 :     my $special = $self->{ 'cgi' }->param( 'special_set' );
1321 :     my $userset = $self->{ 'cgi' }->param( 'user_set' );
1322 :    
1323 :     if ( defined( $special ) && $special ne '' && $special ne 'All' ) {
1324 :     my @subsetspecial = moregenomes( $self, $special );
1325 :     my %activeRH = map { $_ => 1 } @subsetspecial;
1326 :     $activeR = \%activeRH;
1327 :     $evaluate = 1;
1328 :     }
1329 :     if ( defined( $phylo ) && $phylo ne '' && $phylo ne 'All' ) {
1330 :     my %genomes = %{ $self->{ 'metasubsystem' }->{ 'genomes' } };
1331 :     my @subsetR = grep { $genomes{ $_ } } @{ $self->{ 'row_subset_members' }->{ $phylo } };
1332 :    
1333 :     my %activeRH = map { $_ => 1 } @subsetR;
1334 :     if ( $evaluate ) {
1335 :     $activeR = andor( $activeR, \%activeRH, $andor );
1336 :     }
1337 :     else {
1338 :     $activeR = \%activeRH;
1339 :     }
1340 :     $evaluate = 1;
1341 :     }
1342 :     if ( defined( $userset ) && $userset ne '' && $userset ne 'All' ) {
1343 :     my %activeRH;
1344 :     my $gl = GenomeLists::load( $userset );
1345 :     my $gs = $gl->{ 'genomes' };
1346 :     foreach my $ssu ( @$gs ) {
1347 :     $activeRH{ $ssu } = 1;
1348 :     }
1349 :     if ( $evaluate ) {
1350 :     $activeR = andor( $activeR, \%activeRH, $andor );
1351 :     }
1352 :     else {
1353 :     $activeR = \%activeRH;
1354 :     }
1355 :     }
1356 :    
1357 :     return $activeR;
1358 :     }
1359 :    
1360 :    
1361 :     sub moregenomes {
1362 :     my ( $self, $more ) = @_;
1363 :    
1364 :     if ($more eq "Cyanobacteria") { return &selectgenomeattr( $self->{ 'fig' }, "phylogeny", "Cyanobacteria")}
1365 :     if ($more eq "NMPDR") { return &selectgenomeattr( $self->{ 'fig' }, "filepresent", "NMPDR")}
1366 :     if ($more eq "BRC") { return &selectgenomeattr( $self->{ 'fig' }, "filepresent", "BRC")}
1367 :     if ($more eq "higher_plants") { return &selectgenomeattr( $self->{ 'fig' }, "higher_plants")}
1368 :     if ($more eq "eukaryotic_ps") { return &selectgenomeattr( $self->{ 'fig' }, "eukaryotic_ps")}
1369 :     if ($more eq "nonoxygenic_ps") { return &selectgenomeattr( $self->{ 'fig' }, "nonoxygenic_ps")}
1370 :     if ($more eq "Hundred by a hundred") { return &selectgenomeattr( $self->{ 'fig' }, "hundred_hundred")}
1371 :     if ($more eq "functional_coupling_paper") { return &selectgenomeattr( $self->{ 'fig' }, "functional_coupling_paper")}
1372 :     }
1373 :    
1374 :     sub selectgenomeattr {
1375 :     my ( $fig, $tag, $value )=@_;
1376 :     my @orgs;
1377 :    
1378 :     if ( $tag eq "phylogeny" ) {
1379 :     my $taxonomic_groups = $fig->taxonomic_groups_of_complete(10);
1380 :     foreach my $pair (@$taxonomic_groups)
1381 :     {
1382 :     push @orgs, @{$pair->[1]} if ($pair->[0] eq "$value");
1383 :     }
1384 :     }
1385 :     elsif ( $tag eq "filepresent" ) {
1386 :     foreach my $genome ( $fig->genomes ) {
1387 :     push(@orgs, $genome) if (-e $FIG_Config::organisms."/$genome/$value");
1388 :     }
1389 :     }
1390 :     else {
1391 :     if ( $value ) {
1392 :     @orgs = map { $_->[0]} grep {$_->[0] =~ /^\d+\.\d+$/ } $fig->get_attributes( undef, $tag, $value );
1393 :     }
1394 :     else {
1395 :     @orgs = map { $_->[0]} grep {$_->[0] =~ /^\d+\.\d+$/ } $fig->get_attributes( undef, 'collection', $tag );
1396 :     }
1397 :     }
1398 :     return @orgs;
1399 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3