[Bio] / SubsystemExtension / JoinedCluster.pm Repository:
ViewVC logotype

Annotation of /SubsystemExtension/JoinedCluster.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : heiko 1.1 package SubsystemExtension::JoinedCluster;
2 :    
3 :    
4 :     use strict;
5 :     use warnings;
6 :     use Carp;
7 :     use GD;
8 :     use CGI;
9 :     use base qw(SubsystemExtension::Cluster);
10 :     use Data::Dumper;
11 :    
12 :     sub new {
13 :    
14 :     my ($class, $id, $clusters) = @_;
15 :    
16 :     my $self;
17 :     $self->{id} = $id;
18 :     $self->{containedGenes} = {};
19 :     $self->{spanSeq} = {};
20 :     $self->{sortedLocations} = [];
21 :     $self->{png} = '';
22 :     $self->{map} = '';
23 :     $self->{subclusters} = $clusters;
24 :    
25 :     bless $self, $class;
26 :    
27 :     foreach my $cluster (@$clusters) {
28 :     foreach ($cluster->containedGenes()) {
29 :     $self->{containedGenes}->{$_} = 1;
30 :     }
31 :     foreach ($cluster->spannedSequences()) {
32 :     $self->{spanSeq}->{$_} = $cluster->{spanSeq}->{$_};
33 :     }
34 :     foreach ($cluster->sortedLocations()) {
35 :     $self->addLocation($_);
36 :     }
37 :     }
38 :    
39 :    
40 :     return $self;
41 :    
42 :     }
43 :    
44 :    
45 :    
46 :     sub containedByGenePercent {
47 :     my ($self, $percent, $larger) = @_;
48 :     my $match = 0;
49 :     foreach (keys %{$self->{containedGenes}}) {
50 :     $match++ if ($larger->{containedGenes}->{$_});
51 :     }
52 :    
53 :     if ($match / scalar keys %{$self->{containedGenes}} > $percent/100) {
54 :     return 1;
55 :     } elsif ($match / scalar keys %{$larger->{containedGenes}} > $percent/100) {
56 :     return 1;
57 :     } else {
58 :     return;
59 :     }
60 :    
61 :     }
62 :    
63 :     sub _cluster_color {
64 :     my ($self, $im, $family) = @_;
65 :    
66 :     unless (ref $self->{colors}) {
67 :     $self->_init_cluster_colors($im);
68 :     }
69 :    
70 :     return $self->{colors}->{$family};
71 :    
72 :     }
73 :    
74 :     sub to_table_row {
75 :     my ($self, $cgi) = @_;
76 :     my $html;
77 :     if (ref $cgi && $cgi->isa("CGI")) {
78 :     $html .= $cgi->Tr($cgi->td($cgi->checkbox({-name=>'cluster', -label=>'', -checked=>0, -value=>$self->{id}}).$cgi->a({-href=>$cgi->self_url()."#".$self->{id}},$self->{id})), $cgi->td(scalar keys %{$self->{containedGenes}}),$cgi->td(scalar keys %{$self->{spanSeq}}),$cgi->td(scalar @{$self->{subclusters}}),$cgi->td(join ', ', sort {$a <=> $b} keys %{$self->{containedGenes}}));
79 :    
80 :     } else {
81 :    
82 :     $html .= sprintf ("<tr><td>%s</td><td>%s</td><td>%s</td><td>%s</td><td>%s</td></tr>", $self->{id}, scalar keys %{$self->{containedGenes}}, scalar keys %{$self->{spanSeq}}, scalar @{$self->{subclusters}} , join ', ', sort {$a <=> $b} keys %{$self->{containedGenes}});
83 :     }
84 :    
85 :     return $html;
86 :    
87 :     }
88 :    
89 :     sub to_string {
90 :    
91 :     my ($self) = @_;
92 :    
93 :     my $erg = "";
94 :    
95 :     my $containedGenesCount = scalar keys %{$self->{containedGenes}};
96 :     my $spanSeqCount = scalar keys %{$self->{spanSeq}};
97 :     $erg .= $self->{id}.": ";
98 :     $erg .= "#".$self->geneCount()."# ";
99 :     $erg .= "*".$self->sequencesCount()."* ";
100 :     foreach (@{$self->{sortedLocations}}) {
101 :     if (ref $_ eq "HASH") {
102 :     $erg .= "S".$_->{sequence}." (".$_->{start}.", ".$_->{stop}.") ";
103 :     }
104 :     }
105 :     $erg .= " Genes: [";
106 :     $erg .= join ', ', $self->containedGenes();
107 :    
108 :     $erg .= "]";
109 :    
110 :     $erg .= " SubClusters: [";
111 :     $erg .= join ', ', map {$_->{id};} $self->subClusters();
112 :     $erg .= "]\n";
113 :    
114 :     return $erg;
115 :     }
116 :    
117 :    
118 :     sub subClusters {
119 :     my ($self) = @_;
120 :    
121 :     if (wantarray) {
122 :     return @{$self->{subclusters}};
123 :     } else {
124 :     return $self->{subclusters};
125 :     }
126 :    
127 :     }
128 :    
129 :    
130 :     =pod
131 :    
132 :     =head3 addLocation
133 :    
134 :     This function adds a location to those existing in the cluster.
135 :     Therefore it checks wheter the new location is already completely
136 :     covered by an old one. In this case it is not added to the
137 :     list of locations.
138 :     If the location covers existing locations these are removed and the
139 :     location is appended to the list.
140 :    
141 :     =cut
142 :    
143 :    
144 :     sub addLocation {
145 :     my ($self, $location) = @_;
146 :    
147 :     # easy case empty list
148 :    
149 :     if (scalar @{$self->{sortedLocations}} == 0) {
150 :    
151 :     push @{$self->{sortedLocations}}, $location;
152 :    
153 :     } else {
154 :    
155 :     my $index = 0;
156 :    
157 :     # iterate through all existing locations and remember the current
158 :     # position in the list.
159 :    
160 :     foreach my $existing_loc (@{$self->{sortedLocations}}) {
161 :    
162 :     $index++;
163 :    
164 :     # ignore those that originate from other sequences
165 :     next if ($existing_loc->{sequence} != $location->{sequence});
166 :    
167 :     # ex_loc: xxxx
168 :     # loc: xx
169 :    
170 :     if (($existing_loc->{start} <= $location->{start}) && ($existing_loc->{stop} >= $location->{stop})) {
171 :    
172 :     # we have to do nothing because this location is already present
173 :     return;
174 :    
175 :     } elsif (($existing_loc->{start} >= $location->{start}) && ($existing_loc->{stop} <= $location->{stop})) {
176 :    
177 :     # ex_loc: xx
178 :     # loc: xxxx
179 :    
180 :     # groessere location als alte
181 :     # also fliegt die alte raus
182 :    
183 :     my $drop = splice (@{$self->{sortedLocations}}, $index-1 , 1);
184 :     $index--;
185 :     } elsif (($location->{start} > $existing_loc->{start}) && ($location->{start} <= $existing_loc->{stop})) {
186 :    
187 :     # append the overlapping genes to the existing
188 :     #
189 :     # ex_loc: xxxx
190 :     # loc: xxxx
191 :    
192 :    
193 :    
194 :    
195 :     my $diff = $location->{stop} - $existing_loc->{stop};
196 :     my $genes = scalar @{$location->{genes}};
197 :     $existing_loc->{stop} = $location->{stop};
198 :    
199 :     push @{$existing_loc->{genes}}, @{$location->{genes}}[$genes - $diff .. $genes];
200 :    
201 :     return;
202 :    
203 :     } elsif (($existing_loc->{start} > $location->{start}) && ($existing_loc->{start} <= $location->{stop})) {
204 :     # prepend the overlapping genes to the existing
205 :     #
206 :     # ex_loc: xxxx
207 :     # loc: xxxx
208 :    
209 :     # the non overlapping genes at the beginning of the new lcation will
210 :     # be prepended to the existing location
211 :     # diff is the number of non-overlapping genes
212 :    
213 :     my $diff = $existing_loc->{start} - $location->{start};
214 :    
215 :     $existing_loc->{start} = $location->{start};
216 :    
217 :     unshift @{$existing_loc->{genes}}, @{$location->{genes}}[0..$diff-1];
218 :    
219 :    
220 :     return;
221 :    
222 :     }
223 :     # jetzt noch der overlap fall!!!!
224 :     # sollte eine zu mehr als ... in der anderen
225 :     # vorhanden sein, dann merge die beiden regionen zu einer!
226 :     # finde min start und max stop und hole jeweils die
227 :     # genes aus den beiden regionen
228 :     }
229 :    
230 :     push @{$self->{sortedLocations}}, $location;
231 :     }
232 :     }
233 :    
234 :    
235 :     =pod
236 :    
237 :     =head3 addCluster
238 :    
239 :     This function adds the locations of the cluster and thereby joins
240 :     it with this JoinedCluster object.
241 :     The spanned sequences and contained genes are updated/extended as well.
242 :    
243 :     =cut
244 :    
245 :    
246 :    
247 :     sub addCluster {
248 :    
249 :     my ($self, $cluster) = @_;
250 :    
251 :     push @{$self->{subclusters}}, $cluster;
252 :    
253 :    
254 :     foreach ($cluster->containedGenes()) {
255 :     $self->{containedGenes}->{$_} = 1;
256 :     }
257 :     foreach ($cluster->spannedSequences()) {
258 :     $self->{spanSeq}->{$_} = $cluster->{spanSeq}->{$_};
259 :     }
260 :     foreach ($cluster->sortedLocations()) {
261 :     $self->addLocation($_);
262 :     }
263 :    
264 :     $self->{geneCount} = scalar keys %{$self->{containedGenes}};
265 :    
266 :     $self->{sequencesCount} = scalar keys %{$self->{spanSeq}};
267 :    
268 :     }
269 :    
270 :    
271 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3