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

Annotation of /SubsystemEditor/WebPage/MetaSpreadsheet.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3