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

Annotation of /FigKernelPackages/SS.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :     use strict;
3 :    
4 :     #
5 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
6 :     # for Interpretations of Genomes. All Rights Reserved.
7 :     #
8 :     # This file is part of the SEED Toolkit.
9 :     #
10 :     # The SEED Toolkit is free software. You can redistribute
11 :     # it and/or modify it under the terms of the SEED Toolkit
12 :     # Public License.
13 :     #
14 :     # You should have received a copy of the SEED Toolkit Public License
15 :     # along with this program; if not write to the University of Chicago
16 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
17 :     # Genomes at veronika@thefig.info or download a copy from
18 :     # http://www.theseed.org/LICENSE.TXT.
19 :     #
20 :     package SS;
21 :    
22 :     use strict;
23 :     use ERDB;
24 :     use Tracer;
25 :     use SeedUtils;
26 :     use ServerThing;
27 :    
28 :     =head1 Subsystem Server Function Object
29 :    
30 :     This file contains the functions and utilities used by the Subsystem Server
31 :     (B<subsystem_server_sapling.cgi>). The L</Primary Methods> represent function
32 :     calls direct to the server. These all have a signature similar to the following.
33 :    
34 :     my $document = $ssObject->function_name($args);
35 :    
36 :     where C<$ssObject> is an object created by this module,
37 :     C<$args> is a parameter structure, and C<function_name> is the Subsystem
38 :     Server function name. The output is a structure, generally a hash reference, but
39 :     sometimes a string or a list reference.
40 :    
41 : parrello 1.8 All methods will take a hash reference as the parameter structure. In the
42 :     documentation, this will be depicted somewhat like this
43 :    
44 :     my $document = $ssObject->pegs_in_subsystems({
45 :     -subsystems => [$subsystemID,...],
46 :     -genomes => [$genomeID,...]
47 :     });
48 :    
49 :     This indicates that there are two hash keys permitted, the first mapped to a list of
50 :     subsystem IDs, and the second to a list of genome IDs.
51 :    
52 : parrello 1.1 =head2 Special Methods
53 :    
54 :     =head3 new
55 :    
56 : disz 1.10 my $ssObject = SSserver->new();
57 : parrello 1.1
58 :     Create a new Subsystem Server function object. The server function object
59 : parrello 1.8 contains a pointer to a L<Sapling> object, and is used to invoke the
60 : parrello 1.1 server functions.
61 :    
62 :     =cut
63 :    
64 : disz 1.10 #
65 :     # Actually, if you are using SS.pm, you should do SS->new(), not SSserver->new()
66 :     # That comment above is for the benefit of the pod doc stuff on how to use SSserver
67 :     # that is generated from this file.
68 :     #
69 :    
70 : parrello 1.1 sub new {
71 :     my ($class) = @_;
72 :     # Create the sapling object.
73 :     my $sap = ERDB::GetDatabase('Sapling');
74 :     # Create the server object.
75 :     my $retVal = { db => $sap };
76 :     # Bless and return it.
77 :     bless $retVal, $class;
78 :     return $retVal;
79 :     }
80 :    
81 :    
82 :     =head2 Primary Methods
83 :    
84 : parrello 1.5 =head3 methods
85 :    
86 : disz 1.7 my $document = $ssObject->methods();
87 : parrello 1.5
88 :     Return a list of the methods allowed on this object.
89 :    
90 :     =cut
91 :    
92 : parrello 1.11 use constant METHODS => [qw(all_subsystems
93 :     classification_of
94 :     is_in_subsystem
95 : parrello 1.5 is_in_subsystem_with
96 : parrello 1.11 metabolic_reconstruction
97 :     pegs_implementing_roles
98 :     pegs_in_subsystems
99 : parrello 1.5 subsystem_spreadsheet
100 :     )];
101 :    
102 :     sub methods {
103 :     # Get the parameters.
104 :     my ($self) = @_;
105 :     # Return the result.
106 :     return METHODS;
107 :     }
108 :    
109 : parrello 1.1 =head3 is_in_subsystem
110 :    
111 : parrello 1.8 my $document = $ssObject->is_in_subsystem({
112 :     -ids => [$fid1, $fid2, ...],
113 :     -unusable => 1
114 :     });
115 : parrello 1.1
116 :     Return the subsystem and role for each specified feature.
117 :    
118 :     =over 4
119 :    
120 : parrello 1.8 =item parameter
121 :    
122 :     The parameter should be a reference to a hash with the following keys.
123 :    
124 :     =over 8
125 :    
126 :     =item -ids
127 :    
128 :     Reference to a list of the FIG feature IDs for the features of interest.
129 :    
130 :     =item -unusable
131 :    
132 :     If TRUE, then results from unusable subsystems will be included. The default
133 :     is FALSE, which means only usable subsystems will show up in the results.
134 :    
135 :     =back
136 : parrello 1.1
137 : parrello 1.8 For backward compatibility, the parameter may also be a reference to a list
138 :     of FIG feature IDs.
139 : parrello 1.1
140 :     =item RETURN
141 :    
142 : parrello 1.8 In normal mode, returns a reference to a hash that maps each incoming feature ID
143 :     to a list of 2-tuples, each 2-tuple consisting of (0) the ID of a subsystem containing
144 :     the feature and (1) the feature's role in that subsystem.
145 :    
146 :     In backward-compatible mode, returns a reference to a list of 3-tuples, each
147 :     3-tuple consisting of (0) a subsystem ID, (1) a role ID, and (2) the ID of a
148 :     feature from the input list.
149 : parrello 1.1
150 :     =back
151 :    
152 :     =cut
153 :    
154 :     sub is_in_subsystem {
155 :     # Get the parameters.
156 :     my ($self, $args) = @_;
157 :     # Get the sapling database.
158 :     my $sapling = $self->{db};
159 : parrello 1.8 # This will be set to TRUE if we are in backward-compatible mode.
160 :     my $backwardMode = 0;
161 : parrello 1.1 # Convert a list to a hash.
162 :     if (ref $args ne 'HASH') {
163 :     $args = { -ids => $args };
164 : parrello 1.8 $backwardMode = 1;
165 :     }
166 :     # Create the filter clause. It contains at least a feature filter.
167 :     my $filter = 'Feature(id) = ?';
168 :     # Unless unusable subsystems are allowed, we restrict to usable ones.
169 :     if (! $args->{-unusable}) {
170 :     $filter .= ' AND Subsystem(usable) = 1';
171 : parrello 1.1 }
172 : parrello 1.8 # Declare the return variable.
173 :     my $retVal = {};
174 : parrello 1.1 # Get the fig IDs from the parameters.
175 :     my $ids = ServerThing::GetIdList(-ids => $args);
176 :     foreach my $fid (@$ids) {
177 : parrello 1.8 my @resultRows = $sapling->GetAll("Feature IsContainedIn MachineRole HasRole Role AND " .
178 :     "MachineRole IsRoleFor MolecularMachine Implements Variant IsDescribedBy Subsystem",
179 :     $filter, [$fid], [qw(Subsystem(id) Role(id))]);
180 :     $retVal->{$fid} = \@resultRows;
181 :     }
182 :     # If we're in backward-compatible mode, convert the return value to a list.
183 :     if ($backwardMode) {
184 :     my @list;
185 :     for my $fid (@$ids) {
186 :     push @list, map { [@$_, $fid] } @{$retVal->{$fid}};
187 :     }
188 :     $retVal = \@list;
189 : parrello 1.1 }
190 :     # Return the result.
191 :     return $retVal;
192 :     }
193 :    
194 :     =head3 is_in_subsystem_with
195 :    
196 : parrello 1.9 my $document = $ssObject->is_in_subsystem_with({
197 :     -ids => [$fid1, $fid2, ...],
198 :     -unusable => 1
199 :     });
200 :    
201 :     For each incoming feature, returns a list of the features in the same genome that
202 :     are part of the same subsystem. For each other feature returned, its role,
203 :     functional assignment, subsystem variant, and subsystem ID will be returned as
204 :     well.
205 : parrello 1.1
206 : parrello 1.9 =over 4
207 :    
208 :     =item parameter
209 :    
210 :     The parameter should be a reference to a hash with the following keys.
211 :    
212 :     =over 8
213 : parrello 1.1
214 : parrello 1.9 =item -ids
215 :    
216 :     Reference to a list of the FIG feature IDs for the features of interest.
217 :    
218 :     =item -unusable
219 :    
220 :     If TRUE, then results from unusable subsystems will be included. The default
221 :     is FALSE, which means only usable subsystems will show up in the results.
222 : parrello 1.1
223 : parrello 1.9 =back
224 : parrello 1.1
225 : parrello 1.9 For backward compatibility, the parameter may also be a reference to a list
226 :     of FIG feature IDs.
227 : parrello 1.1
228 :     =item RETURN
229 :    
230 : parrello 1.9 Returns a reference to a hash that maps each incoming feature ID to a list
231 :     of 5-tuples relating to features in the same subsystem. Each 5-tuple contains
232 :     (0) a subsystem ID, (1) a variant ID, (2) the related feature ID, (3) the
233 :     related feature's functional assignment, and (4) the related feature's role
234 :     in the subsystem.
235 :    
236 :     In backward-compatibility mode, returns a reference to a list of lists. Each
237 :     sub-list contains 6-tuples relating to a single incoming feature ID. Each
238 :     6-tuple consists of a subsystem ID, a variant ID, the incoming feature ID, the
239 :     other feature ID, the other feature's functional assignment, and the other
240 :     feature's role in the subsystem.
241 : parrello 1.1
242 :     =back
243 :    
244 :     =cut
245 :    
246 :     sub is_in_subsystem_with {
247 :     # Get the parameters.
248 :     my ($self, $args) = @_;
249 :     # Get the sapling database.
250 :     my $sapling = $self->{db};
251 :     # Declare the return variable.
252 :     my $retVal;
253 : parrello 1.9 # This will be set to TRUE if we are in backward-compatible mode.
254 :     my $backwardMode = 0;
255 : parrello 1.1 # Convert a list to a hash.
256 :     if (ref $args ne 'HASH') {
257 :     $args = { -ids => $args };
258 : parrello 1.9 $backwardMode = 1;
259 :     }
260 :     # Create the filter clause. It contains at least a feature filter.
261 :     my $filter = 'Feature(id) = ?';
262 :     # Unless unusable subsystems are allowed, we restrict to usable ones.
263 :     if (! $args->{-unusable}) {
264 :     $filter .= ' AND Subsystem(usable) = 1';
265 : parrello 1.1 }
266 :     # Get the fig IDs from the parameters.
267 :     my $ids = ServerThing::GetIdList(-ids => $args);
268 :     foreach my $fid (@$ids) {
269 :     my @resultRows = $sapling->GetAll("Feature IsContainedIn MachineRole IsRoleFor MolecularMachine Implements Variant IsDescribedBy Subsystem AND MolecularMachine IsMachineOf MachineRole2 Contains Feature2 AND MachineRole2 HasRole Role",
270 : parrello 1.9 $filter, [$fid],
271 :     [qw(Subsystem(id) Variant(code)
272 :     Feature2(id) Feature2(function)
273 :     Role(id))]);
274 :     $retVal->{$fid} = \@resultRows;
275 :     }
276 :     # If this is backward-compatability mode, convert the result to a list.
277 :     if ($backwardMode) {
278 :     my @outList;
279 :     for my $fid (@$ids) {
280 :     my $fidList = $retVal->{$fid};
281 :     if (! defined $fidList) {
282 :     push @outList, [];
283 :     } else {
284 :     # Because the incoming feature ID is no longer available as the
285 :     # hash key, we need to put it back into the output tuples. It goes
286 :     # in the third position (offset 2).
287 :     for my $fidTuple (@$fidList) {
288 :     splice @$fidTuple, 2, 0, $fid;
289 :     }
290 :     push @outList, $fidList;
291 :     }
292 :     }
293 :     $retVal = \@outList;
294 : parrello 1.1 }
295 :     # Return the result.
296 :     return $retVal;
297 :     }
298 :    
299 :     =head3 all_subsystems
300 :    
301 : parrello 1.11 my $document = $ssObject->all_subsystems({
302 :     -unusable => 1,
303 :     -exclude => [$type1, $type2, ...],
304 :     });
305 : parrello 1.1
306 :     Return a list of all subsystems in the system. For each subsystem, this
307 : parrello 1.11 method will return the ID, curator, the classifications, and roles.
308 : parrello 1.1
309 :     =over 4
310 :    
311 : parrello 1.11 =item parameter
312 :    
313 :     The parameter should be a reference to a hash with the following possible
314 :     keys, all of which are optional. Because all of the keys are optional,
315 :     it is permissible to pass an empty hash or no parameters at all.
316 :    
317 :     =over 8
318 :    
319 :     =item -unusable (optional)
320 :    
321 :     TRUE if unusable subsystems should be included, else FALSE. The default is
322 :     FALSE.
323 :    
324 :     =item -exclude (optional)
325 :    
326 :     Reference to a list of special subsystem types that should be excluded from the
327 :     result list. The permissible types are C<cluster-based>, C<experimental>, and
328 :     C<private>. Normally cluster-based subsystems are included, but experimental and
329 :     private subsystems are only included if the C<-unusable> option is turned on.
330 : parrello 1.1
331 : parrello 1.11 =back
332 : parrello 1.1
333 :     =item RETURN
334 :    
335 : parrello 1.11 Returns a hash mapping each subsystem ID to a 3-tuple consisting of (0) the name of the
336 :     curator, (1) a reference to a list of the subsystem classifications, and (2) a reference
337 :     to a list of the subsystem's roles.
338 : parrello 1.1
339 :     =back
340 :    
341 :     =cut
342 :    
343 :     sub all_subsystems {
344 :     # Get the parameters.
345 :     my ($self, $args) = @_;
346 :     # Get the spaling database.
347 :     my $sapling = $self->{db};
348 : parrello 1.11 # Declare the return variable.
349 :     my $retVal = {};
350 :     # Compute the filter based on the parameters.
351 :     my $filter = "";
352 :     ServerThing::AddSubsystemFilter(\$filter, $args);
353 :     # Create a hash for walking up the subsystem class hierarchy.
354 :     my %classMap = map { $_->[0] => $_->[1] } $sapling->GetAll("IsSubclassOf",
355 :     "", [],
356 :     [qw(from-link to-link)]);
357 :     # Read the subsystem role data from the database.
358 :     my @roleData = $sapling->GetAll("Subsystem Includes Role AND Subsystem IsInClass SubsystemClass",
359 :     $filter, [],
360 :     [qw(Subsystem(id) Subsystem(curator)
361 :     SubsystemClass(id) Role(id))]);
362 :     # Loop through the subsystems, building the result hash.
363 :     for my $roleDatum (@roleData) {
364 :     my ($subsystem, $curator, $class, $role) = @$roleDatum;
365 :     # Is this subsystem new?
366 :     if (! exists $retVal->{$subsystem}) {
367 :     # Yes. Get its classification data. We trace the classifications from
368 :     # the bottom up, so new ones are shifted onto the front.
369 :     my @classes;
370 :     while ($class) {
371 :     unshift @classes, $class;
372 :     $class = $classMap{$class};
373 :     }
374 :     # Create its hash entry.
375 :     $retVal->{$subsystem} = [$curator, \@classes, []];
376 :     }
377 :     # Now we know an entry exists for this subsystem. Push this role onto it.
378 :     push @{$retVal->{$subsystem}[2]}, $role;
379 :     }
380 : parrello 1.1 # Return the result.
381 : parrello 1.11 return $retVal;
382 :     }
383 :    
384 :     =head3 classification_of
385 :    
386 :     my $document = $ssObject->classification_of({
387 :     -ids => [$sub1, $sub2, ...]
388 :     });
389 :    
390 :     Return the classification for each specified subsystem.
391 :    
392 :     =over 4
393 :    
394 :     =item parameter
395 :    
396 :     Reference to a hash of parameters with the following possible keys.
397 :    
398 :     =over 8
399 :    
400 :     =item -ids
401 :    
402 :     Reference to a list of subsystem IDs.
403 :    
404 :     =back
405 :    
406 :     =item RETURN
407 :    
408 :     Returns a hash mapping each incoming subsystem ID to a list reference. Each
409 :     list contains the classification names in order from the largest classification to
410 :     the most detailed.
411 :    
412 :     =cut
413 :    
414 :     sub classification_of {
415 :     # Get the parameters.
416 :     my ($self, $args) = @_;
417 :     # Get the sapling database.
418 :     my $sap = $self->{db};
419 :     # Declare the return variable.
420 :     my $retVal = {};
421 :     # Get the list of subsystem IDs.
422 :     my $ids = ServerThing::GetIdList(-ids => $args);
423 :     # Loop through the subsystem IDs, getting the classification data.
424 :     for my $id (@$ids) {
425 :     # We'll build the classification list in here.
426 :     my @classes;
427 :     # Get the low-level class.
428 :     my ($class) = $sap->GetFlat("Subsystem IsInClass SubsystemClass",
429 :     "Subsystem(id) = ?", [$id], 'SubsystemClass(id)');
430 :     # Loop through the remaining classes. Note that since we're moving up
431 :     # the hierarchy, new classes are added at the beginning.
432 :     while (defined $class) {
433 :     unshift @classes, $class;
434 :     ($class) = $sap->GetFlat("SubsystemClass IsSubclassOf SubsystemClass2",
435 :     "SubsystemClass(id) = ?", [$class],
436 :     'SubsystemClass2(id)');
437 :     }
438 :     # Store this classification.
439 :     $retVal->{$id} = \@classes;
440 :     }
441 :     # Return the result.
442 :     return $retVal;
443 : parrello 1.1 }
444 :    
445 :     =head3 subsystem_spreadsheet
446 :    
447 : parrello 1.12 my $document = $ssObject->subsystem_spreadsheet({
448 :     -ids => [$sub1, $sub2, ...]
449 :     });
450 : parrello 1.1
451 :     This method takes a list of subsystem IDs, and for each one returns a
452 :     list of the features in the subsystem. For each feature, it will include
453 :     the feature's functional assignment, the subsystem name and variant
454 :     (spreadsheet row), and its role (spreadsheet column).
455 :    
456 :     =over 4
457 :    
458 : parrello 1.12 =item parameter
459 :    
460 :     Reference to a hash of parameters with the following possible keys.
461 :    
462 :     =over 8
463 :    
464 :     =item -ids
465 :    
466 :     Reference to a list of subsystem IDs.
467 :    
468 :     =back
469 : parrello 1.1
470 : parrello 1.12 For backward compatibility, this method can also accept a reference to a list of
471 :     subsystem IDs.
472 : parrello 1.1
473 :     =item RETURN
474 :    
475 : parrello 1.12 Returns a hash mapping each incoming subsystem ID to a list of 4-tuples. Each
476 :     tuple contains (0) a variant ID, (1) a feature ID, (2) the feature's functional
477 :     assignment, and (3) the feature's role in the subsystem.
478 :    
479 :     In backward-compatability mode, returns a list of 5-tuples. Each tuple contains
480 :     (0) a subsystem ID, (1) a variant ID, (2) a feature ID, (3) the feature's
481 :     functional assignment, and (4) the feature's role in the subsystem.
482 : parrello 1.1
483 :     =back
484 :    
485 :     =cut
486 :    
487 :     sub subsystem_spreadsheet {
488 :     # Get the parameters.
489 :     my ($self, $args) = @_;
490 :     # Get the sapling database.
491 :     my $sapling = $self->{db};
492 :     # Declare the return variable.
493 :     my $retVal;
494 : parrello 1.12 # Check for the backward-compatible mode.
495 :     my $backwardMode = 0;
496 : parrello 1.1 if (ref $args ne 'HASH') {
497 :     $args = { -ids => $args };
498 : parrello 1.12 $backwardMode = 1;
499 : parrello 1.1 }
500 :     # Get the list of subsystem IDs.
501 :     my $ids = ServerThing::GetIdList(-ids => $args);
502 :     # Loop through the subsystem IDs.
503 :     foreach my $subsysName (@$ids) {
504 :     # Normalize the subsystem ID.
505 :     my $subsysID = $sapling->SubsystemID($subsysName);
506 :     # Get the subsystem's spreadsheet data.
507 : parrello 1.12 my @resultRows = $sapling->GetAll("Subsystem Describes Variant IsImplementedBy MolecularMachine IsMachineOf MachineRole Contains Feature AND MachineRole HasRole Role Includes Subsystem",
508 :     'Subsystem(id) = ? ORDER BY Variant(id), Includes(sequence)',
509 :     [$subsysID], [qw(Variant(id)
510 : parrello 1.1 Feature(id)
511 :     Feature(function)
512 :     Role(id))]);
513 : parrello 1.12 $retVal->{$subsysName} = \@resultRows;
514 :     }
515 :     # In backward-compatible mode, convert the hash to a list.
516 :     if ($backwardMode) {
517 :     # We'll build the list in here.
518 :     my @listForm;
519 :     for my $subsysName (@$ids) {
520 :     # Get this subsystem's spreadsheet and paste in the subsystem ID.
521 :     my $spreadsheet = $retVal->{$subsysName};
522 :     for my $row (@$spreadsheet) {
523 :     unshift @$row, $subsysName;
524 :     }
525 :     # Put it into the output.
526 :     push @listForm, @$spreadsheet;
527 :     }
528 :     # Return the list.
529 :     $retVal = \@listForm;
530 : parrello 1.1 }
531 :     # Return the result.
532 :     return $retVal;
533 :     }
534 :    
535 : parrello 1.4 =head3 pegs_in_subsystems
536 : parrello 1.1
537 : parrello 1.12 my $document = $ssObject->pegs_in_subsystems({
538 :     -genomes => [$genome1, $genome2, ...],
539 :     -subsystems => [$sub1, $sub2, ...]
540 :     });
541 : parrello 1.1
542 :     This method takes a list of genomes and a list of subsystems and returns
543 :     a list of the roles represented in each genome/subsystem pair.
544 :    
545 :     =over 4
546 :    
547 : parrello 1.12 =item parameter
548 :    
549 :     Reference to a hash of parameter values with the following possible keys.
550 :    
551 :     =over 8
552 :    
553 :     =item -genomes
554 :    
555 :     Reference to a list of genome IDs.
556 :    
557 :     =item -subsystems
558 :    
559 :     Reference to a list of subsystem IDs.
560 :    
561 :     =back
562 : parrello 1.1
563 : parrello 1.12 For backward compatibility, the parameter may also be a reference to a 2-tuple,
564 :     the first element of which is a list of genome IDs and the second of which is a
565 :     list of subsystem IDs.
566 : parrello 1.1
567 :     =item RETURN
568 :    
569 : parrello 1.12 Returns a reference to a hash of hashes. The main hash is keyed by subsystem ID.
570 :     Each subsystem's hash is keyed by role ID and maps the role to a list of
571 :     the feature IDs for that role in the subsystem that belong to the specified
572 :     genomes.
573 :    
574 :     In backward-compatibility mode, returns a list of 2-tuples. Each tuple consists
575 :     of a subsystem ID and a second 2-tuple that contains a role ID and a reference
576 :     to a list of the feature IDs for that role that belong to the specified genomes.
577 : parrello 1.1
578 :     =back
579 :    
580 :     =cut
581 :    
582 : parrello 1.4 sub pegs_in_subsystems {
583 : parrello 1.1 # Get the parameters.
584 :     my ($self, $args) = @_;
585 :     # Get the sapling database.
586 :     my $sapling = $self->{db};
587 : parrello 1.12 # Get access to the sapling subsystem object.
588 : parrello 1.1 require SaplingSubsys;
589 :     # Declare the return variable.
590 : parrello 1.12 my $retVal = {};
591 :     # Check for backward-compatibility mode.
592 :     my $backwardMode = 0;
593 : parrello 1.1 if (ref $args ne 'HASH') {
594 :     $args = { -genomes => $args->[0], -subsystems => $args->[1] };
595 : parrello 1.12 $backwardMode = 1;
596 : parrello 1.1 }
597 :     # Get the list of genome IDs.
598 :     my $genomes = ServerThing::GetIdList(-genomes => $args);
599 :     # Get the list of subsystem IDs.
600 :     my $subs = ServerThing::GetIdList(-subsystems => $args);
601 :     # Loop through the subsystems.
602 : parrello 1.12 for my $sub (@{$subs}) {
603 : parrello 1.1 # Normalize the subsystem ID.
604 :     my $subID = $sapling->SubsystemID($sub);
605 :     # Get the subsystem spreadsheet in memory.
606 :     my $ss = SaplingSubsys->new($subID, $sapling);
607 : parrello 1.6 # Only proceed if we found it.
608 :     if (defined $ss) {
609 : parrello 1.12 # We'll build the subsystem's hash in here.
610 :     my $subHash = {};
611 :     # Loop through the genomes, assigning features to the roles.
612 : parrello 1.6 foreach my $g (@{$genomes}) {
613 : parrello 1.12 # Get role/featureList pairs for this genome.
614 :     my @roleTuples = $ss->get_roles_for_genome($g, 1);
615 :     # Loop through the pairs.
616 :     foreach my $roleTuple (@roleTuples) {
617 :     # Extract the role ID and the feature list.
618 :     my ($role, $features) = @$roleTuple;
619 :     # Attach the features to the role.
620 :     push @{$subHash->{$role}}, @$features;
621 :     }
622 :     }
623 :     # Attach this hash to this subsystem.
624 :     $retVal->{$sub} = $subHash;
625 :     }
626 :     }
627 :     # In backward-compatible mode, we have to conver the hashes to lists.
628 :     if ($backwardMode) {
629 :     # We'll build the output list in here.
630 :     my @outList;
631 :     # Loop through the subsystems in input order.
632 :     for my $ss (@$subs) {
633 :     my $subHash = $retVal->{$ss};
634 :     if (defined $subHash) {
635 :     # Now we convert the role -> feature map to a list of
636 :     # [sub, [role, feature]] nested pairs.
637 :     for my $role (keys %$subHash) {
638 :     push @outList, [$ss, [$role, $subHash->{$role}]];
639 : parrello 1.6 }
640 : parrello 1.1 }
641 :     }
642 : parrello 1.12 # Store the output list as the result.
643 :     $retVal = \@outList;
644 : parrello 1.1 }
645 :     # Return the result.
646 :     return $retVal;
647 :     }
648 :    
649 : parrello 1.12 # Synonym for "pegs_in_subsystems" provided for backward compatibility.
650 : parrello 1.4 sub pegs_in_subsystem {
651 :     return pegs_in_subsystems(@_);
652 :     }
653 :    
654 : parrello 1.1 =head3 pegs_implementing_roles
655 :    
656 :     my $document = $ssObject->pegs_implementing_roles($args);
657 :    
658 :     Given a subsystem and a list of roles, return a list of the subsystem's
659 :     features for each role.
660 :    
661 :     =over 4
662 :    
663 :     =item args
664 :    
665 :     Reference to either (1) a hash that maps C<-subsystem> to a subsystem ID and
666 :     C<-roles> to a list of roles or (2) a 2-tuple containing a subsystem ID followed
667 :     by a reference to a list of roles in that subsystem.
668 :    
669 :     =item RETURN
670 :    
671 :     Returns a list of 2-tuples. Each tuple consists of a role and a reference to a
672 :     list of the features in that role.
673 :    
674 :     =back
675 :    
676 :     =cut
677 :    
678 :     sub pegs_implementing_roles {
679 :     # Get the parameters.
680 :     my ($self, $args) = @_;
681 :     # Get the sapling database.
682 :     my $sapling = $self->{db};
683 :     # Get the sapling subsystem object.
684 :     require SaplingSubsys;
685 :     # Declare the return variable.
686 :     my $retVal;
687 :     # Convert a list to a hash.
688 :     if (ref $args ne 'HASH') {
689 :     $args = { -subsystem => $args->[0], -roles => $args->[1] };
690 :     }
691 :     # Get the subsystem ID.
692 :     my $subsystem = $args->{-subsystem};
693 :     # If there is no subsystem ID, it's an error.
694 :     if (! defined $subsystem) {
695 :     Confess("Subsystem ID not specified.");
696 :     } else {
697 :     # Normalize the subsystem ID.
698 :     my $subsystemID = $sapling->SubsystemID($subsystem);
699 :     # Get the list of roles.
700 :     my $roles = ServerThing::GetIdList(-roles => $args);
701 :     my $ss = SaplingSubsys->new($subsystemID, $sapling);
702 :     foreach my $role (@$roles) {
703 :     my @pegs = $ss->pegs_for_role($role);
704 :     push (@$retVal, [$role, \@pegs]);
705 :     }
706 :     }
707 :     # Return the result.
708 :     return $retVal;
709 :     }
710 :    
711 :    
712 :     =head3 metabolic_reconstruction
713 :    
714 :     my $document = $ssObject->metabolic_reconstruction($args);
715 :    
716 : parrello 1.2 This method will find for each subsystem, the subsystem variant that contains a
717 :     maximal subset of the roles in an incoming list, and output the ID of the
718 :     variant and a list of the roles in it.
719 : parrello 1.1
720 :     =over 4
721 :    
722 :     =item args
723 :    
724 :     Reference to (1) a list of role descriptors or (2) a hash mapping the key C<-roles>
725 :     to a list of role descriptors. A role descriptor is a 2-tuple consisting of the
726 :     role ID followed by an arbitrary ID of the caller's choosing.
727 :    
728 :     =item RETURN
729 :    
730 :     Returns a list of tuples, each containing a variant ID, a role ID, and optionally a
731 :     caller-provided ID for the role.
732 :    
733 :     =back
734 :    
735 :     =cut
736 :    
737 :     sub metabolic_reconstruction {
738 :     # Get the parameters.
739 :     my ($self, $args) = @_;
740 :     # Get the sapling database.
741 :     my $sapling = $self->{db};
742 :     # Declare the return variable.
743 :     my $retVal = [];
744 :     # Convert a list to a hash.
745 :     if (ref $args ne 'HASH') {
746 :     $args = { -roles => $args };
747 :     }
748 : parrello 1.2 # This counter will be used to generate user IDs for roles without them.
749 :     my $next = 1000;
750 : parrello 1.1 # Get the list of roles.
751 :     my $id_roles = ServerThing::GetIdList(-roles => $args);
752 : overbeek 1.3 my @id_roles1 = map { (ref $_ ? $_ : [$_, "FR" . ++$next]) } @$id_roles;
753 :    
754 :     my @id_roles = ();
755 :     foreach my $tuple (@id_roles1)
756 :     {
757 :     my($function,$id) = @$tuple;
758 :     foreach my $role (split(/(; )|( [\]\@] )/,$function))
759 :     {
760 :     push(@id_roles,[$role,$id]);
761 :     }
762 :     }
763 :    
764 : parrello 1.1 my %big;
765 :     my $id_display = 1;
766 :     map {push(@{$big{$_->[0]}}, $_->[1])} @id_roles;
767 :     my @resultRows = $sapling->GetAll("Subsystem Includes Role",
768 :     'ORDER BY Subsystem(id), Includes(sequence)', [],
769 :     [qw(Subsystem(id) Role(id) Includes(abbreviation))]);
770 :     my %ss_roles;
771 :     foreach my $row (@resultRows) {
772 :     my ($sub, $role, $abbr) = @$row;
773 :     $ss_roles{$sub}->{$role} = $abbr;
774 :     }
775 :     foreach my $sub (keys %ss_roles) {
776 :     my $roles = $ss_roles{$sub};
777 :    
778 :     my @abbr = map{$roles->{$_}} grep { $big{$_}} keys %$roles;
779 :     my $set = join(" ", @abbr);
780 :     if (@abbr > 0) {
781 :     my ($variant, $size) = $self->get_max_subset($sub, $set);
782 :     if ($variant) {
783 :     foreach my $role (keys %$roles) {
784 :     if ($id_display) {
785 :     foreach my $id (@{$big{$role}}) {
786 :     push (@$retVal, [$variant, $role, $id]);
787 :     }
788 :     } else {
789 :     push (@$retVal, [$variant, $role]);
790 :     }
791 :     }
792 :     }
793 :     }
794 :     }
795 :     # Return the result.
796 :     return $retVal;
797 :     }
798 :    
799 :     =head2 Internal Utility Methods
800 :    
801 :     =head3 get_max_subset
802 :    
803 :     my ($max_variant, $max_size) = $ssObject->get_max_subset($sub, $setA);
804 :    
805 :     Given a subsystem ID and a role rule, return the ID of the variant for
806 :     the subsystem that matches the most roles in the rule and the number of
807 :     roles matched.
808 :    
809 :     =over 4
810 :    
811 :     =item sub
812 :    
813 :     Name (ID) of the subsystem whose variants are to be examined.
814 :    
815 :     =item setA
816 :    
817 :     A space-delimited list of role abbreviations, lexically ordered. This provides
818 :     a unique specification of the roles in the set.
819 :    
820 :     =item RETURN
821 :    
822 :     Returns a 2-element list consisting of the ID of the variant found and the number
823 :     of roles matched.
824 :    
825 :     =back
826 :    
827 :     =cut
828 :    
829 :     sub get_max_subset {
830 :     my ($self, $sub, $setA) = @_;
831 :     my $sapling = $self->{db};
832 :     my $max_size = 0;
833 :     my $max_set;
834 :     my $max_variant;
835 :     my %set_hash;
836 :     my $qh = $sapling->Get("Subsystem Describes Variant", 'Subsystem(id) = ? AND Variant(type) = ?', [$sub, 'normal']);
837 :     while (my $resultRow = $qh->Fetch()) {
838 :     my @variantRoleRule = $resultRow->Value('Variant(role-rule)');
839 :     my ($variantCode) = $resultRow->Value('Variant(code)');
840 :     my $variantId = $sub.":".$variantCode;
841 :     foreach my $setB (@variantRoleRule) {
842 :     my $size = is_A_a_superset_of_B($setA, $setB);
843 :     if ($size && $size > $max_size) {
844 :     $max_size = $size;
845 :     $max_set = $setB;
846 :     $max_variant = $variantId;
847 :     }
848 :     }
849 :     }
850 :     #if ($max_size) {
851 :     #print STDERR "Success $max_variant, $max_set\n";
852 :     #}
853 :     return($max_variant, $max_size);
854 :     }
855 :    
856 :    
857 :     =head3 is_A_a_superset_of_B
858 :    
859 :     my $size = SS::is_A_a_superset_of_B($a, $b);
860 :    
861 :     This method takes as input two role rules, and returns 0 if the first
862 :     role rule is NOT a superset of the second; otherwise, it returns the size
863 :     of the second rule. A role rule is a space-delimited list of role
864 :     abbreviations in lexical order. This provides a unique identifier for a
865 :     set of roles in a subsystem.
866 :    
867 :     =over 4
868 :    
869 :     =item a
870 :    
871 :     First role rule.
872 :    
873 :     =item b
874 :    
875 :     Second role rule.
876 :    
877 :     =item RETURN
878 :    
879 :     Returns 0 if the first rule is NOT a superset of the second and the size of the
880 :     second rule if it is. As a result, if the first rule IS a superset, this method
881 :     will evaluate to TRUE, and to FALSE otherwise.
882 :    
883 :     =back
884 :    
885 :     =cut
886 :    
887 :     sub is_A_a_superset_of_B {
888 :     my ($a, $b) = @_;
889 :     my @a = split(" ", $a);
890 :     my @b = split(" ", $b);
891 :     if (@b > @a) {
892 :     return(0);
893 :     }
894 :     my %given;
895 :     map { $given{$_} = 1} @a;
896 :     map { if (! $given{$_}) {return 0}} split(" ", $b);
897 :     my $l = scalar(@b);
898 :     return scalar(@b);
899 :     }
900 :    
901 :    
902 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3