[Bio] / FigWebServices / diagram.cgi Repository:
ViewVC logotype

Diff of /FigWebServices/diagram.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1, Fri Feb 16 16:50:00 2007 UTC revision 1.6, Fri Mar 9 20:11:48 2007 UTC
# Line 15  Line 15 
15  # http://www.theseed.org/LICENSE.TXT.  # http://www.theseed.org/LICENSE.TXT.
16  #  #
17    
18    # $Id$
19    
20  use strict;  use strict;
21  use warnings;  use warnings;
22    no warnings qw( numeric ); # variant code comparison with >
23    
24  use FIG_CGI;  use FIG_CGI;
25  use FIG_Config;  use FIG_Config;
# Line 49  Line 52 
52        font-weight: normal;        font-weight: normal;
53        color: #000;        color: #000;
54        background-color: #FFFFFF;        background-color: #FFFFFF;
55      }~;      }
56        th, td {
57          font-size: 12px;
58        }
59        ~;
60    
61      # print out the page      # print out the page
62      print $cgi->header();      print $cgi->header();
63      print $cgi->start_html(-title => 'The SEED - Subsystem Diagram',      print "<html>\n<head>\n";
64                             -style => { -code => $css }      print "<title>The SEED - Subsystem Diagram</title>\n";
65          );      print "<style type='text/css'> \n <!-- \n $css \n --> \n </style> \n";
66        print "</head> \n <body> \n";
67    
68      print &get_Diagram($fig, $cgi);      print &get_Diagram($fig, $cgi);
69    
70        print $cgi->end_html;
71    
72  }  }
73    
74    
# Line 66  Line 76 
76      # get parameters      # get parameters
77      my ($fig, $cgi) = @_;      my ($fig, $cgi) = @_;
78    
79      unless ($cgi->param('subsystem_name') and      # get the subsystem
80              $cgi->param('diagram')) {      unless ($cgi->param('subsystem_name')) {
81          return '<p>CGI Parameter missing.</p>';          return '<p>CGI Parameter missing.</p>';
82      }      }
83        my $subsystem_name = $cgi->param('subsystem_name') || '';
     my $subsystem_name = $cgi->param('subsystem_name');  
     my $diagram_id  = $cgi->param('diagram');  
   
84      my $subsystem_pretty = $subsystem_name;      my $subsystem_pretty = $subsystem_name;
85      $subsystem_pretty =~ s/_/ /g;      $subsystem_pretty =~ s/_/ /g;
   
86      my $subsystem = $fig->get_subsystem($subsystem_name);      my $subsystem = $fig->get_subsystem($subsystem_name);
     my @genomes = $subsystem->get_genomes();  
     my $genome = $cgi->param('genome_id');  
     my %genome_labels = map { $_ => $fig->genus_species($_)." ( $_ )" } @genomes;  
87    
88      # generate the content      # check subsystem
89      my $content = '<p>No subsystem name given.</p>';      unless ($subsystem) {
90      if ($subsystem) {          return "<p>Unable to find a subsystem called '$subsystem_name'.</p>";
91        }
92    
         $content = "<h1>Subsystem: $subsystem_pretty</h1>";  
         $content .= '<hr/>';  
93    
94        # if diagram.cgi is called without the CGI param diagram (the diagram id)
95        # it will try to load the first 'new' diagram from the subsystem and
96        # print out an error message if there is no 'new' diagram
97        my $diagram_id  = $cgi->param('diagram') || '';
98        unless ($diagram_id) {
99            foreach my $d ($subsystem->get_diagrams) {
100                my ($id) = @$d;
101                if ($subsystem->is_new_diagram($id)) {
102                    $diagram_id = $id;
103                    last;
104                }
105            }
106        }
107    
108        # check diagram id
109        unless ($diagram_id) {
110            return "<h1>Subsystem: $subsystem_pretty</h1>".
111                "<p><em>Unable to find a diagram for this subsystem.</em><p>";
112        }
113          unless ($subsystem->is_new_diagram($diagram_id)) {          unless ($subsystem->is_new_diagram($diagram_id)) {
114              $content .= "<p><em>Diagram '$diagram_id' is not a new diagram.</em><p>";          return "<h1>Subsystem: $subsystem_pretty</h1>".
115              return $content;              "<p><em>Diagram '$diagram_id' is not a new diagram.</em><p>";
116        }
117    
118    
119        # find out about sort order
120        my $sort_by = $cgi->param('sort_by') || 'name';
121    
122        # get the genomes from the subsystem with zero or positive variant codes
123        my @genomes;
124        my $genome = $cgi->param('genome_id');
125        if ($sort_by eq 'variant_code') {
126            foreach (sort { ($subsystem->get_variant_code( $subsystem->get_genome_index($a) ) cmp
127                             $subsystem->get_variant_code( $subsystem->get_genome_index($b) )) or
128                             ( $fig->genus_species($a) cmp $fig->genus_species($b) )
129                     } $subsystem->get_genomes()) {
130                my $vcode = $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) );
131                push @genomes, $_ if ($vcode >= 0);
132          }          }
133        }
134        else {
135            foreach (sort { $fig->genus_species($a) cmp $fig->genus_species($b) } $subsystem->get_genomes()) {
136                my $vcode = $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) );
137                push @genomes, $_ if ($vcode >= 0);
138            }
139        }
140    
141        my %genome_labels = map { $_ => $fig->genus_species($_)." ( $_ ) [".
142                                      $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) )."]"
143                                } @genomes;
144    
145          $content .= $cgi->start_form();      @genomes = ('0', @genomes);
146        $genome_labels{'0'} = 'please select a genome to color the diagram with' ;
147    
148    
149        # generate the content
150        my $content = "<h1>Subsystem: $subsystem_pretty</h1>";
151        $content .= '<hr/>';
152    
153        $content .= $cgi->start_form( -id => 'diagram_select_genome' );
154          $content .= $cgi->hidden( -name  => 'subsystem_name',          $content .= $cgi->hidden( -name  => 'subsystem_name',
155                                    -value => $subsystem_name );                                    -value => $subsystem_name );
156          $content .= $cgi->hidden( -name  => 'diagram',          $content .= $cgi->hidden( -name  => 'diagram',
157                                    -value => $diagram_id );                                    -value => $diagram_id );
158        $content .= $cgi->hidden( -name  => 'dont_scale', -value => 1 )
159            if ($cgi->param('dont_scale'));
160        $content .= $cgi->hidden( -name  => 'debug', -value => 1 )
161            if ($cgi->param('debug'));
162        $content .= '<p>Sort by: '.
163            $cgi->radio_group( -name    => 'sort_by',
164                               -values  => ['name', 'variant_code'],
165                               -default => $sort_by,
166                               -labels  => { 'name' => 'Genome name',
167                                             'variant_code' => 'Variant code, then genome name' },
168                               -onChange => 'document.getElementById("diagram_select_genome").submit();',
169            ).'</p>';
170          $content .= $cgi->popup_menu( -name    => 'genome_id',          $content .= $cgi->popup_menu( -name    => 'genome_id',
171                                        -values  => \@genomes,                                        -values  => \@genomes,
172                                        -default => $genome,                                        -default => $genome,
# Line 114  Line 182 
182          my $diagram_dir = $subsystem->{dir}."/diagrams/$diagram_id/";          my $diagram_dir = $subsystem->{dir}."/diagrams/$diagram_id/";
183          my $d = Diagram->new($subsystem_name, $diagram_dir);          my $d = Diagram->new($subsystem_name, $diagram_dir);
184    
185        # turn off scaling?
186        $d->min_scale(1) if ($cgi->param('dont_scale'));
187    
188    
189          # DEBUG: test all items of the diagram against the subsystem          # DEBUG: test all items of the diagram against the subsystem
190          # (for debug purposes during introduction of new diagrams)          # (for debug purposes during introduction of new diagrams)
191          # (remove when no longer needed)          # (remove when no longer needed)
192        # (1) roles
193          my $types = [ 'role', 'role_and', 'role_or' ];          my $types = [ 'role', 'role_and', 'role_or' ];
194          foreach my $t (@$types) {          foreach my $t (@$types) {
195              foreach my $id (@{$d->item_ids_of_type($t)}) {              foreach my $id (@{$d->item_ids_of_type($t)}) {
# Line 127  Line 199 
199                  }                  }
200              }              }
201          }          }
202        # (2) subsystem
203        foreach my $s (@{$d->item_ids_of_type('subsystem')}) {
204            unless ($fig->subsystem_version($s)) {
205                $status .= "Diagram item 'subsystem' = '$s' is not a subsystem.\n";
206            }
207        }
208          # END          # END
209    
210    
211          if ($genome) {      # add notes to roles
212        # to reduce the total number of loos role_or, role_and get their notes
213        # attached in the loops further down
214        foreach my $id (@{$d->item_ids_of_type('role')}) {
215            my $role = $subsystem->get_role_from_abbr($id);
216            if ($role) {
217                $d->add_note('role', $id, $role);
218            }
219        }
220    
             my @roles = $subsystem->get_roles_for_genome($genome);  
221    
222              # build a lookup hash, make one entry for each role_and and role_or item              # build a lookup hash, make one entry for each role_and and role_or item
223              # the index references to the inner hash of the role_and/role_or hash              # the index references to the inner hash of the role_and/role_or hash
224              # to set a value there use $lookup->{role_abbr}->{role_abbr} = 1;              # to set a value there use $lookup->{role_abbr}->{role_abbr} = 1;
225        # declared outside if to be available for debug output
226              my $lookup = {};              my $lookup = {};
227    
228              # find out about role_and              # find out about role_and
# Line 146  Line 232 
232    
233                      $role_and->{$subset} = {};                      $role_and->{$subset} = {};
234    
235                my $note = '';
236                      foreach my $r ($subsystem->get_subsetC_roles($subset)) {                      foreach my $r ($subsystem->get_subsetC_roles($subset)) {
237                          my $r_abbr = $subsystem->get_abbr_for_role($r);                          my $r_abbr = $subsystem->get_abbr_for_role($r);
238                          unless ($r_abbr) {                          unless ($r_abbr) {
239                              die "Unable to get the abbreviation for role '$r'.";                              die "Unable to get the abbreviation for role '$r'.";
240                          }                          }
241    
242                    $note .= "<li>$r</li>";
243                          $lookup->{$r_abbr} = $role_and->{$subset};                          $lookup->{$r_abbr} = $role_and->{$subset};
244                          $role_and->{$subset}->{$r_abbr} = 0;                          $role_and->{$subset}->{$r_abbr} = 0;
245                      }                      }
246                $d->add_note('role_and', $subset, "<h4>Requires all of:</h4><ul>$note</ul>");
247                  }                  }
248              }              }
249    
# Line 165  Line 254 
254    
255                      $role_or->{$subset} = {};                      $role_or->{$subset} = {};
256    
257                my $note = '';
258                      foreach my $r ($subsystem->get_subsetC_roles($subset)) {                      foreach my $r ($subsystem->get_subsetC_roles($subset)) {
259                          my $r_abbr = $subsystem->get_abbr_for_role($r);                          my $r_abbr = $subsystem->get_abbr_for_role($r);
260    
261                          unless ($r_abbr) {                          unless ($r_abbr) {
262                              die "Unable to get the abbreviation for role '$r'.";                              die "Unable to get the abbreviation for role '$r'.";
263                          }                          }
264    
265                          $lookup->{$r_abbr} = $role_and->{$subset};                  $note .= "<li>$r</li>";
266                    $lookup->{$r_abbr} = $role_or->{$subset};
267                          $role_or->{$subset}->{$r_abbr} = 0;                          $role_or->{$subset}->{$r_abbr} = 0;
268                      }                      }
269                $d->add_note('role_or', $subset, "<h4>Requires any of:</h4><ul>$note</ul>");
270                  }                  }
271              }              }
272    
273    
274        if ($genome) {
275    
276            my @roles = $subsystem->get_roles_for_genome($genome);
277    
278              # check if genome is present in subsystem              # check if genome is present in subsystem
279              # genomes not present, unfortunately return @roles = ( undef )              # genomes not present, unfortunately return @roles = ( undef )
280              if (scalar(@roles) == 0 or              if (scalar(@roles) == 0 or
# Line 186  Line 283 
283                  shift(@roles);                  shift(@roles);
284              }              }
285              else {              else {
286                  $content .= "<p><em>Showing colours for genome: $genome.</em><p>";              $content .= "<p><em>Showing colors for genome: ".
287                    $fig->genus_species($genome)." ( $genome ), variant code ".
288                    $subsystem->get_variant_code($subsystem->get_genome_index($genome)) ."</em><p>";
289              }              }
290    
291    
# Line 211  Line 310 
310                  $status .= "Role '$_' not found in the diagram.\n";                  $status .= "Role '$_' not found in the diagram.\n";
311              }              }
312    
             # use Data::Dumper;  
             # $content .= "<pre>".Data::Dumper->Dump([ $lookup ])."</pre>";  
   
313              # check if to color any role_and              # check if to color any role_and
314              foreach my $id_role_and (keys(%$role_and)) {              foreach my $id_role_and (keys(%$role_and)) {
315                  my $result = 1;                  my $result = 1;
# Line 222  Line 318 
318                  }                  }
319                  $d->color_item('role_and', $id_role_and, 'green') if ($result);                  $d->color_item('role_and', $id_role_and, 'green') if ($result);
320              }              }
321    
322            # check if to color any role_or
323            foreach my $id_role_or (keys(%$role_or)) {
324                foreach (keys(%{$role_or->{$id_role_or}})) {
325                    if ($role_or->{$id_role_or}->{$_}) {
326                        $d->color_item('role_or', $id_role_or, 'green');
327                        last;
328                    }
329                }
330            }
331    
332          }          }
333          else {          else {
334              $content .= '<p><em>You have not provided a genome id to color the diagram with.</em><p>';              $content .= '<p><em>You have not provided a genome id to color the diagram with.</em><p>';
335          }          }
336    
337        # add an info line about diagram scaling
338        my $scale = $d->calculate_scale * 100;
339        unless ($scale == 100) {
340            $content .= '<p><em>This diagram has been scaled to '.sprintf("%.2f", $scale).'%. ';
341            $content .= "(<a href='?subsystem_name=$subsystem_name&diagram_id=$diagram_id&dont_scale=1'>".
342                "view in original size</a>)";
343            $content .= '</em></p>';
344        }
345        if ($cgi->param('dont_scale')) {
346            $content .= '<p><em>You have switched off scaling this diagram down. ';
347            $content .= "(<a href='?subsystem_name=$subsystem_name&diagram_id=$diagram_id'>".
348                "Allow scaling</a>)";
349            $content .= '</em></p>';
350        }
351    
352        # print diagram
353          $content .= $d->html;          $content .= $d->html;
354    
355        # print status
356          $content .= '<hr/><p><em>Below follows a status message to help test the new diagrams:</em><p>'.          $content .= '<hr/><p><em>Below follows a status message to help test the new diagrams:</em><p>'.
357              "<pre>$status</pre>" if ($status);              "<pre>$status</pre>" if ($status);
358    
359        # print debug
360        if ($cgi->param('debug')) {
361            require Data::Dumper;
362            $content .= '<hr/>';
363            $content .= "<h2>Diagram dump:</h2><pre>".Data::Dumper->Dump([ $d ])."</pre>";
364            $content .= "<h2>Lookup dump:</h2><pre>".Data::Dumper->Dump([ $lookup ])."</pre>";
365      }      }
366    
367      return $content;      return $content;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3