[Bio] / FigKernelPackages / UnvSubsys.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/UnvSubsys.pm

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

revision 1.1, Sun Sep 11 23:44:46 2005 UTC revision 1.5, Thu Sep 15 14:33:49 2005 UTC
# Line 1  Line 1 
1  package UnvSubsys;  package UnvSubsys;
2    
3    use Subsystem;
4  use Carp;  use Carp;
5  use FIG;  use FIG;
6    
# Line 8  Line 9 
9    
10  sub new  sub new
11  {  {
12      my($class, $ssa, $fig, $colors, $aliases) = @_;      my($class, $ssa, $fig, $show_clusters, $aliases) = @_;
13    
14      $ssa =~ s/ /_/g;      $ssa =~ s/ /_/g;
15    
16    
17          ### format for one_sub = [Roles,ToRoleIndexHash,ColSubsets,Genomes,ToGenomeIndexHash,PegHash,ColorHash,AliasHash]          ### { Roles =>Roles,
18            ###   RoleIndex => ToRoleIndexHash,
19            ###   RoleSubsets => ColSubsets,
20            ###   Genomes => Genomes,
21            ###   GenomeIndex => ToGenomeIndexHash,
22            ###   PegHash => PegHash,
23            ###   Colors  => ColorHash,
24            ###   Aliases => AliasHash,
25            ###   Curator => Curator,
26            ###   Notes => Notes,
27            ###   Reactions => ReactionHash
28            ### }
29          ###          ###
30          ### Roles = pointer to a list of [Role,Abbrev,[ReactionURLs]]          ### Roles = pointer to a list of [Role,Abbrev,[ReactionURLs]]
31          ###          ###
# Line 32  Line 44 
44          ###          ###
45          ### AliasHash is a hash: key=PEG value=aliases          ### AliasHash is a hash: key=PEG value=aliases
46          ###          ###
47            ### ReactionHash is a hash: key=Role value=[reaction-ids]
48    
49      if (ref($fig) eq "FIG")      if (ref($fig) eq "FIG")
50      {      {
         my $subsystem = new Subsystem($ssa,$fig,0);  
51    
52    
53            my $subsystem = new Subsystem($ssa,$fig,0);
54            my $curator = $subsystem->get_curator;
55            my $notes = $subsystem->get_notes;
56            $notes =~ s/ /\n/g;
57          my @roles = $subsystem->get_roles;          my @roles = $subsystem->get_roles;
58          my $reactions = $subsystem->get_reactions;          my $reactions = $subsystem->get_reactions;
59          my @genomes = $subsystem->get_genomes;          my @genomes = $subsystem->get_genomes;
# Line 60  Line 77 
77          {          {
78              if ($subset ne 'All')              if ($subset ne 'All')
79              {              {
80                  push(@$subset_info,[$subset,[$subsystem->get_subsetC_roles($subset)]]);                  push(@$subset_info,[$subset,[map { $roleH->{$_} } $subsystem->get_subsetC_roles($subset)]]);
81              }              }
82          }          }
83    
# Line 85  Line 102 
102                  $pegH->{$i}->{$j} = [@pegs];                  $pegH->{$i}->{$j} = [@pegs];
103              }              }
104          }          }
105            my $colorsH  = $show_clusters  ? &set_colors($fig,$pegH)  : {};
         my $colorsH  = $colors  ? &set_colors($fig,$pegH)  : {};  
106          my $aliasesH = $aliases ? &set_aliases($fig,$pegH) : {};          my $aliasesH = $aliases ? &set_aliases($fig,$pegH) : {};
107            my $reactions = $subsystem->get_reactions;
108          my $self = [$role_info,$roleH,$subset_info,$genomes_info,$genomeH,$pegH,$colorsH,$aliasesH];          my $self = { Roles => $role_info,
109                         RoleIndex => $roleH,
110                         RoleSubsets => $subset_info,
111                         Genomes => $genomes_info,
112                         GenomeIndex => $genomeH,
113                         PegHash => $pegH,
114                         Colors => $colorsH,
115                         Aliases => $aliasesH,
116                         Curator => $curator,
117                         Notes => $notes,
118                         Reactions => $reactions
119                       };
120          bless($self, $class);          bless($self, $class);
121          return $self;          return $self;
122      }      }
# Line 99  Line 126 
126      }      }
127  }  }
128    
129    sub set_aliases {
130        my($fig,$pegH) = @_;
131        my($genomeI,$roleI,$pegs,$peg,$roleH);
132    
133        my $aliasesH = {};
134    
135        foreach $genomeI (keys(%$pegH))
136        {
137            $roleH = $pegH->{$genomeI};
138            foreach $roleI (keys(%$roleH))
139            {
140                $pegs = $roleH->{$roleI};
141                foreach $peg (@$pegs)
142                {
143                    if (! $aliasesH->{$peg})
144                    {
145                        $aliasesH->{$peg} = scalar &ext_id($fig,$peg);
146                    }
147                }
148            }
149        }
150        return $aliasesH;
151    }
152    
153    sub set_colors {
154        my($fig,$pegH) = @_;
155        my($genomeI,$roleI,$pegs,$peg,$roleH,$peg,%pegs_in_genome);
156    
157        my $colorsH = {};
158    
159        foreach $genomeI (keys(%$pegH))
160        {
161            undef %pegs_in_genome;
162            $roleH = $pegH->{$genomeI};
163            foreach $roleI (keys(%$roleH))
164            {
165                $pegs = $roleH->{$roleI};
166                foreach $peg (@$pegs)
167                {
168                    $pegs_in_genome{$peg} = 1;
169                }
170            }
171    
172            my @pegs = keys(%pegs_in_genome);
173            my($tuple,$peg,$color);
174            my $colors_for_one_genome = &set_colors_for_genome($fig,\@pegs);
175    
176            while (($peg,$color) = each %$colors_for_one_genome)
177            {
178                $colorsH->{$peg} = $colors_for_one_genome->{$peg};
179            }
180        }
181        return $colorsH;
182    }
183    
184    sub set_colors_for_genome {
185        my($fig,$pegs) = @_;
186        my($peg,@clusters,$cluster,@colors,$color,%seen,%conn,$x,$peg1,@pegs,$i);
187    
188        my $color_of = {};
189        foreach $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' }
190    
191        @pegs = keys(%$color_of);  #  Use of keys makes @pegs entries unique
192    
193        foreach $peg (@pegs)
194        {
195            $conn{$peg} = [grep { $color_of->{$_} && ($_ ne $peg) } $fig->close_genes($peg,5000)];
196        }
197    
198        @clusters = ();
199        while ($peg = shift @pegs)
200        {
201            if (! $seen{$peg})
202            {
203                $cluster = [$peg];
204                $seen{$peg} = 1;
205                for ($i=0; ($i < @$cluster); $i++)
206                {
207                    my @tmp = grep { ! $seen{$_} } @{$conn{$cluster->[$i]}};
208                    if (@tmp > 0)
209                    {
210                        foreach my $peg1 (@tmp) { $seen{$peg1} = 1 }
211                        push(@$cluster,@tmp);
212                    }
213                }
214                push(@clusters,$cluster);
215            }
216        }
217    
218        @colors =  &cool_colors();
219    
220        @clusters = grep { @$_ > 1 } sort { @$a <=> @$b } @clusters;
221    
222        if (@clusters > @colors) { splice(@clusters,0,(@clusters - @colors)) }  # make sure we have enough colors
223    
224        my($cluster);
225        foreach $cluster (@clusters)
226        {
227            $color = shift @colors;
228            foreach $peg (@$cluster)
229            {
230                $color_of->{$peg} = $color;
231            }
232        }
233        return $color_of;
234    }
235    
236    sub cool_colors {
237     # just an array of "websafe" colors or whatever colors we want to use. Feel free to remove bad colors (hence the lines not being equal length!)
238     return (
239     '#C0C0C0', '#FF40C0', '#FF8040', '#FF0080', '#FFC040', '#40C0FF', '#40FFC0', '#C08080', '#C0FF00', '#00FF80', '#00C040',
240     "#6B8E23", "#483D8B", "#2E8B57", "#008000", "#006400", "#800000", "#00FF00", "#7FFFD4",
241     "#87CEEB", "#A9A9A9", "#90EE90", "#D2B48C", "#8DBC8F", "#D2691E", "#87CEFA", "#E9967A", "#FFE4C4", "#FFB6C1",
242     "#E0FFFF", "#FFA07A", "#DB7093", "#9370DB", "#008B8B", "#FFDEAD", "#DA70D6", "#DCDCDC", "#FF00FF", "#6A5ACD",
243     "#00FA9A", "#228B22", "#1E90FF", "#FA8072", "#CD853F", "#DC143C", "#FF6347", "#98FB98", "#4682B4",
244     "#D3D3D3", "#7B68EE", "#2F4F4F", "#FF7F50", "#FF69B4", "#BC8F8F", "#A0522D", "#DEB887", "#00DED1",
245     "#6495ED", "#800080", "#FFD700", "#F5DEB3", "#66CDAA", "#FF4500", "#4B0082", "#CD5C5C",
246     "#EE82EE", "#7CFC00", "#FFFF00", "#191970", "#FFFFE0", "#DDA0DD", "#00BFFF", "#DAA520", "#008080",
247     "#00FF7F", "#9400D3", "#BA55D3", "#D8BFD8", "#8B4513", "#3CB371", "#00008B", "#5F9EA0",
248     "#4169E1", "#20B2AA", "#8A2BE2", "#ADFF2F", "#556B2F",
249     "#F0FFFF", "#B0E0E6", "#FF1493", "#B8860B", "#FF0000", "#F08080", "#7FFF00", "#8B0000",
250     "#40E0D0", "#0000CD", "#48D1CC", "#8B008B", "#696969", "#AFEEEE", "#FF8C00", "#EEE8AA", "#A52A2A",
251     "#FFE4B5", "#B0C4DE", "#FAF0E6", "#9ACD32", "#B22222", "#FAFAD2", "#808080", "#0000FF",
252     "#000080", "#32CD32", "#FFFACD", "#9932CC", "#FFA500", "#F0E68C", "#E6E6FA", "#F4A460", "#C71585",
253     "#BDB76B", "#00FFFF", "#FFDAB9", "#ADD8E6", "#778899",
254     );
255    }
256    
257    sub ext_id {
258        my($fig,$peg) = @_;
259    
260        my @tmp;
261        my @aliases = $fig->feature_aliases($peg);
262        if      ((@tmp = grep { $_ =~ /^uni\|/ } @aliases) > 0)
263        {
264            @aliases =  @tmp;
265        }
266        elsif   ((@tmp = grep { $_ =~ /^sp\|/ } @aliases) > 0)
267        {
268            @aliases = @tmp;
269        }
270        elsif   ((@tmp = grep { $_ =~ /^gi\|/ } @aliases) > 0)
271        {
272            @aliases = @tmp;
273        }
274        elsif   ((@tmp = grep { $_ =~ /^kegg\|/ } @aliases) > 0)
275        {
276            @aliases = @tmp;
277        }
278        else
279        {
280            @aliases = ();
281        }
282    
283        if (wantarray())
284        {
285            return @aliases;
286        }
287        else
288        {
289            return $aliases[0];
290        }
291    }
292    
293    
294    sub subsystem_curator {
295        my($self) = @_;
296    
297        my $curator = $self->{Curator};
298        $curator =~ s/master://;
299        return $curator;
300    }
301    
302    sub get_roles {
303        my($self) = @_;
304    
305        return map { $_->[0] } @{$self->{Roles}};
306    }
307    
308    sub get_genome_index {
309        my($self,$genome) = @_;
310    
311        return $self->{GenomeIndex}->{$genome};
312    }
313    
314    sub get_genomes {
315        my($self) = @_;
316    
317        return map { $_->[0] } @{$self->{Genomes}};
318    }
319    
320    sub get_variant_code {
321        my($self,$genome) = @_;
322    
323        if ($genome =~ /^\d+$/)
324        {
325            return $self->{Genomes}->[$genome]->[1];
326        }
327        else
328        {
329            my $genomeI = $self->{GenomeIndex}->{$genome};
330            return $self->{Genomes}->[$genomeI]->[1];
331        }
332    }
333    
334    sub get_pegs_from_cell {
335        my($self,$genome,$role) = @_;
336    
337        my $genomeI = $self->{GenomeIndex}->{$genome};
338        my $roleI   = $self->{RoleIndex}->{$role};
339    
340        my $pegs    = $self->{PegHash}->{$genomeI}->{$roleI};
341        return $pegs ? @$pegs : ();
342    }
343    
344    sub get_notes {
345        my($self) = @_;
346    
347        return $self->{Notes};
348    }
349    
350    sub get_role_index {
351        my($self,$role) = @_;
352    
353        return $self->{RoleIndex}->{$role};
354    }
355    
356    sub get_role_abbr {
357        my($self,$roleI) = @_;
358    
359        if ($roleI !~ /^\d+$/)
360        {
361            $roleI = $self->{RoleIndex}->{$roleI};
362        }
363        my $roles = $self->{Roles};
364        return $roles->[$roleI]->[1];
365    }
366    
367    sub get_reactions {
368        my($self) = @_;
369    
370        return $self->{Reactions};
371    }
372    
373    sub get_subset_namesC {
374        my($self) = @_;
375    
376        return map { $_->[0] } @{$self->{RoleSubsets}};
377    }
378    
379    sub get_subsetC_roles {
380        my($self,$subset) = @_;
381        my($i,$j);
382    
383        my $subset_info = $self->{RoleSubsets};
384        for ($i=0; ($i < @$subset_info) && ($subset_info->[$i]->[0] ne $subset); $i++) {}
385        if ($i < @$subset_info)
386        {
387            my @roles = ();
388            foreach $j (@{$subset_info->[$i]->[1]})
389            {
390                push(@roles,$self->{Roles}->[$j]->[0]);
391            }
392            return @roles;
393        }
394        return undef;
395    }
396    
397    sub get_color_of {
398        my($self,$peg)  = @_;
399    
400        return $self->{Colors}->{$peg};
401    }
402    
403  1;  1;
404    
405    

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3