[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.5, Tue Mar 6 16:39:39 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 59  Line 62 
62    
63      print &get_Diagram($fig, $cgi);      print &get_Diagram($fig, $cgi);
64    
65        print $cgi->end_html;
66    
67  }  }
68    
69    
# Line 66  Line 71 
71      # get parameters      # get parameters
72      my ($fig, $cgi) = @_;      my ($fig, $cgi) = @_;
73    
74      unless ($cgi->param('subsystem_name') and      # get the subsystem
75              $cgi->param('diagram')) {      unless ($cgi->param('subsystem_name')) {
76          return '<p>CGI Parameter missing.</p>';          return '<p>CGI Parameter missing.</p>';
77      }      }
78        my $subsystem_name = $cgi->param('subsystem_name') || '';
     my $subsystem_name = $cgi->param('subsystem_name');  
     my $diagram_id  = $cgi->param('diagram');  
   
79      my $subsystem_pretty = $subsystem_name;      my $subsystem_pretty = $subsystem_name;
80      $subsystem_pretty =~ s/_/ /g;      $subsystem_pretty =~ s/_/ /g;
   
81      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;  
82    
83      # generate the content      # check subsystem
84      my $content = '<p>No subsystem name given.</p>';      unless ($subsystem) {
85      if ($subsystem) {          return "<p>Unable to find a subsystem called '$subsystem_name'.</p>";
86        }
87    
         $content = "<h1>Subsystem: $subsystem_pretty</h1>";  
         $content .= '<hr/>';  
88    
89        # if diagram.cgi is called without the CGI param diagram (the diagram id)
90        # it will try to load the first 'new' diagram from the subsystem and
91        # print out an error message if there is no 'new' diagram
92        my $diagram_id  = $cgi->param('diagram') || '';
93        unless ($diagram_id) {
94            foreach my $d ($subsystem->get_diagrams) {
95                my ($id) = @$d;
96                if ($subsystem->is_new_diagram($id)) {
97                    $diagram_id = $id;
98                    last;
99                }
100            }
101        }
102    
103        # check diagram id
104        unless ($diagram_id) {
105            return "<h1>Subsystem: $subsystem_pretty</h1>".
106                "<p><em>Unable to find a diagram for this subsystem.</em><p>";
107        }
108          unless ($subsystem->is_new_diagram($diagram_id)) {          unless ($subsystem->is_new_diagram($diagram_id)) {
109              $content .= "<p><em>Diagram '$diagram_id' is not a new diagram.</em><p>";          return "<h1>Subsystem: $subsystem_pretty</h1>".
110              return $content;              "<p><em>Diagram '$diagram_id' is not a new diagram.</em><p>";
111        }
112    
113    
114        # get the genomes from the subsystem with positive variant codes
115        my @genomes;
116        my $genome = $cgi->param('genome_id');
117        foreach (sort { $fig->genus_species($a) cmp $fig->genus_species($b) } $subsystem->get_genomes()) {
118            my $vcode = $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) );
119            push @genomes, $_ if ($vcode > 0);
120          }          }
121    
122        my %genome_labels = map { $_ => $fig->genus_species($_)." ( $_ ) [".
123                                      $subsystem->get_variant_code( $subsystem->get_genome_index( $_ ) )."]"
124                                } @genomes;
125    
126    
127        # generate the content
128        my $content = "<h1>Subsystem: $subsystem_pretty</h1>";
129        $content .= '<hr/>';
130    
131          $content .= $cgi->start_form();          $content .= $cgi->start_form();
132          $content .= $cgi->hidden( -name  => 'subsystem_name',          $content .= $cgi->hidden( -name  => 'subsystem_name',
133                                    -value => $subsystem_name );                                    -value => $subsystem_name );
134          $content .= $cgi->hidden( -name  => 'diagram',          $content .= $cgi->hidden( -name  => 'diagram',
135                                    -value => $diagram_id );                                    -value => $diagram_id );
136        $content .= $cgi->hidden( -name  => 'dont_scale', -value => 1 )
137            if ($cgi->param('dont_scale'));
138        $content .= $cgi->hidden( -name  => 'debug', -value => 1 )
139            if ($cgi->param('debug'));
140          $content .= $cgi->popup_menu( -name    => 'genome_id',          $content .= $cgi->popup_menu( -name    => 'genome_id',
141                                        -values  => \@genomes,                                        -values  => \@genomes,
142                                        -default => $genome,                                        -default => $genome,
# Line 114  Line 152 
152          my $diagram_dir = $subsystem->{dir}."/diagrams/$diagram_id/";          my $diagram_dir = $subsystem->{dir}."/diagrams/$diagram_id/";
153          my $d = Diagram->new($subsystem_name, $diagram_dir);          my $d = Diagram->new($subsystem_name, $diagram_dir);
154    
155        # turn off scaling?
156        $d->min_scale(1) if ($cgi->param('dont_scale'));
157    
158    
159          # DEBUG: test all items of the diagram against the subsystem          # DEBUG: test all items of the diagram against the subsystem
160          # (for debug purposes during introduction of new diagrams)          # (for debug purposes during introduction of new diagrams)
161          # (remove when no longer needed)          # (remove when no longer needed)
162        # (1) roles
163          my $types = [ 'role', 'role_and', 'role_or' ];          my $types = [ 'role', 'role_and', 'role_or' ];
164          foreach my $t (@$types) {          foreach my $t (@$types) {
165              foreach my $id (@{$d->item_ids_of_type($t)}) {              foreach my $id (@{$d->item_ids_of_type($t)}) {
# Line 127  Line 169 
169                  }                  }
170              }              }
171          }          }
172        # (2) subsystem
173        foreach my $s (@{$d->item_ids_of_type('subsystem')}) {
174            unless ($fig->subsystem_version($s)) {
175                $status .= "Diagram item 'subsystem' = '$s' is not a subsystem.\n";
176            }
177        }
178          # END          # END
179    
   
         if ($genome) {  
   
             my @roles = $subsystem->get_roles_for_genome($genome);  
   
180              # 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
181              # 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
182              # to set a value there use $lookup->{role_abbr}->{role_abbr} = 1;              # to set a value there use $lookup->{role_abbr}->{role_abbr} = 1;
183        # declared outside if to be available for debug output
184              my $lookup = {};              my $lookup = {};
185    
186        if ($genome) {
187    
188            my @roles = $subsystem->get_roles_for_genome($genome);
189    
190              # find out about role_and              # find out about role_and
191              my $role_and = {};              my $role_and = {};
192              if (scalar(@{$d->item_ids_of_type('role_and')})) {              if (scalar(@{$d->item_ids_of_type('role_and')})) {
# Line 167  Line 215 
215    
216                      foreach my $r ($subsystem->get_subsetC_roles($subset)) {                      foreach my $r ($subsystem->get_subsetC_roles($subset)) {
217                          my $r_abbr = $subsystem->get_abbr_for_role($r);                          my $r_abbr = $subsystem->get_abbr_for_role($r);
218    
219                          unless ($r_abbr) {                          unless ($r_abbr) {
220                              die "Unable to get the abbreviation for role '$r'.";                              die "Unable to get the abbreviation for role '$r'.";
221                          }                          }
222    
223                          $lookup->{$r_abbr} = $role_and->{$subset};                      $lookup->{$r_abbr} = $role_or->{$subset};
224                          $role_or->{$subset}->{$r_abbr} = 0;                          $role_or->{$subset}->{$r_abbr} = 0;
225                      }                      }
226                  }                  }
# Line 186  Line 235 
235                  shift(@roles);                  shift(@roles);
236              }              }
237              else {              else {
238                  $content .= "<p><em>Showing colours for genome: $genome.</em><p>";              $content .= "<p><em>Showing colors for genome: ".
239                    $fig->genus_species($genome)." ( $genome ), variant code ".
240                    $subsystem->get_variant_code($subsystem->get_genome_index($genome)) ."</em><p>";
241              }              }
242    
243    
# Line 211  Line 262 
262                  $status .= "Role '$_' not found in the diagram.\n";                  $status .= "Role '$_' not found in the diagram.\n";
263              }              }
264    
             # use Data::Dumper;  
             # $content .= "<pre>".Data::Dumper->Dump([ $lookup ])."</pre>";  
   
265              # check if to color any role_and              # check if to color any role_and
266              foreach my $id_role_and (keys(%$role_and)) {              foreach my $id_role_and (keys(%$role_and)) {
267                  my $result = 1;                  my $result = 1;
# Line 222  Line 270 
270                  }                  }
271                  $d->color_item('role_and', $id_role_and, 'green') if ($result);                  $d->color_item('role_and', $id_role_and, 'green') if ($result);
272              }              }
273    
274            # check if to color any role_or
275            foreach my $id_role_or (keys(%$role_or)) {
276                foreach (keys(%{$role_or->{$id_role_or}})) {
277                    if ($role_or->{$id_role_or}->{$_}) {
278                        $d->color_item('role_or', $id_role_or, 'green');
279                        last;
280                    }
281                }
282            }
283    
284          }          }
285          else {          else {
286              $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>';
287          }          }
288    
289        # add an info line about diagram scaling
290        my $scale = $d->calculate_scale * 100;
291        unless ($scale == 100) {
292            $content .= '<p><em>This diagram has been scaled to '.sprintf("%.2f", $scale).'%. ';
293            $content .= "(<a href='?subsystem_name=$subsystem_name&diagram_id=$diagram_id&dont_scale=1'>".
294                "view in original size</a>)";
295            $content .= '</em></p>';
296        }
297        if ($cgi->param('dont_scale')) {
298            $content .= '<p><em>You have switched off scaling this diagram down. ';
299            $content .= "(<a href='?subsystem_name=$subsystem_name&diagram_id=$diagram_id'>".
300                "Allow scaling</a>)";
301            $content .= '</em></p>';
302        }
303    
304        # print diagram
305          $content .= $d->html;          $content .= $d->html;
306    
307        # print status
308          $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>'.
309              "<pre>$status</pre>" if ($status);              "<pre>$status</pre>" if ($status);
310    
311        # print debug
312        if ($cgi->param('debug')) {
313            require Data::Dumper;
314            $content .= '<hr/>';
315            $content .= "<h2>Diagram dump:</h2><pre>".Data::Dumper->Dump([ $d ])."</pre>";
316            $content .= "<h2>Lookup dump:</h2><pre>".Data::Dumper->Dump([ $lookup ])."</pre>";
317      }      }
318    
319      return $content;      return $content;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3