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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1
2 :     package Subsystem;
3 :    
4 :     use FIG;
5 :    
6 : olson 1.10 use FIGAttributes;
7 :     use base 'FIGAttributes';
8 :    
9 : olson 1.7 use DirHandle;
10 : olson 1.1 use Data::Dumper;
11 :     use File::Spec;
12 :    
13 :     use strict;
14 :    
15 : olson 1.2 =pod
16 :    
17 :     =head1 Subsystem manipulation.
18 :    
19 :     Any manipulation of subsystem data should happen through this interface.
20 :     This allows us to assure ourselves that the relational tables that
21 :     mirror and index the subsystem data are kept up to date with the
22 :     canonical version of the subsystem information in the flat-files
23 :     kept in $FIG_Config::data/Subsystems.
24 :    
25 :     =head2 Thoughts on locking
26 :    
27 :     It is currently dangerous for multiple users to modify spreadsheets at once.
28 :     It will likely remain dangerous while the subsystem backend is fairly
29 :     stateless, as it is with the CGI mechanism.
30 :    
31 :     We'd like to make this a little safer. One mechanism might be to allow
32 :     a user to open a subsystem for modification, and others for readonly access.
33 :     For this to work we have to be able to tell which users is allowed; current
34 :     implementation uses the curator of the subsystem for this purpose.
35 :    
36 :     NB: This module does not currently attempt to handle locking or exclusion.
37 :     It is up to the caller (user application, CGI script, etc) to do so.
38 :     It does attempt to use locking internally where appropriate.
39 :    
40 :     =head2 Data structures
41 :    
42 :     We maintain the following data structures (all members of %$self).
43 :    
44 :     =over 4
45 :    
46 :     =item dir
47 :    
48 :     Directory in which the subsystem is stored.
49 :    
50 :     =item notes
51 :    
52 :     The current notes contents for the subsystem
53 :    
54 :     =item version
55 :    
56 :     Current subsystem version.
57 :    
58 :     =item exchangable
59 :    
60 :     1 if subsystem is exchangable, 0 otherwise.
61 :    
62 :    
63 :     =item roles
64 :    
65 :     list of role names
66 :    
67 :     =item role_index
68 :    
69 :     hash that maps from role name to index
70 :    
71 :     =item role_abbrs
72 :    
73 :     list of role abbreviations
74 :    
75 :     =item abbr
76 :    
77 :     hash mapping from role abbreviation to role name
78 :    
79 :     =item col_subsets
80 :    
81 :     list of column subset names
82 :    
83 :     =item col_subset_members
84 :    
85 :     hash that maps from column subset name to subset members
86 :    
87 :     =item col_active_subset
88 :    
89 :     currently-active column subset
90 :    
91 :     =item row_active_subset
92 :    
93 :     currently-active row subset
94 :    
95 :     =item genome
96 :    
97 :     List (1-indexed, so element 0 is undef) of genome IDs.
98 :    
99 :     =item variant_code
100 :    
101 :     List (1-indexed, so element 0 is undef) of variant codes.
102 :    
103 :     =item genome_index
104 :    
105 :     Hash mapping from genome ID to genome index.
106 :    
107 :     =item variant_code
108 :    
109 :     List (1-indexed, so element 0 is undef) of variant codes.
110 :    
111 :     =item spreadsheet
112 :    
113 :     Spreadsheet data. Structured as a list of rows, each of which
114 :     is a list of entries. An entry is a list of PEG numbers.
115 :    
116 :     =item spreadsheet_inv
117 :    
118 :     Inverted structure of spreadsheet - list of columns, each of which is a list
119 :     of rows.
120 :    
121 :     =back
122 :    
123 :     =cut
124 : olson 1.1
125 :     use FIG;
126 :    
127 :     =pod
128 :    
129 :     =head1 Subsystem constructor
130 :    
131 :     usage: $sub = Subsystem->new("subsystem name", $fig, $createFlag)
132 :    
133 :     Load the subsystem. If it does not exist, and $createFlag is true, create
134 :     a new empty subsystem.
135 :    
136 :     =cut
137 :    
138 :     sub new
139 :     {
140 :     my($class, $name, $fig, $create) = @_;
141 :    
142 :     my $ssa_dir = get_dir_from_name($name);
143 :    
144 :     #
145 :     # For loading, the subsystem directory must already exist.
146 :     #
147 :    
148 :     if (! -d $ssa_dir)
149 :     {
150 :     if ($create)
151 :     {
152 :     return create_subsystem($class, $name, $fig);
153 :     }
154 :     else
155 :     {
156 : olson 1.11 # warn "Subsystem $name does not exist\n";
157 : olson 1.1 return undef;
158 :     }
159 :     }
160 :    
161 :     my $self = {
162 :     dir => $ssa_dir,
163 :     name => $name,
164 :     fig => $fig,
165 :     };
166 :    
167 :     bless($self, $class);
168 :    
169 :     $self->load();
170 :    
171 :     return $self;
172 :     }
173 :    
174 :     sub create_subsystem
175 :     {
176 :     my($class, $name, $fig) = @_;
177 :    
178 :     return undef;
179 :     }
180 :    
181 : olson 1.5 #
182 : olson 1.7 # Retrieve the diagrams associated with this subsystem.
183 :     #
184 :     # This is done via a lookup into FIG/Data/SubsystemDiagrams/<ssaname>/<diagram-name>.
185 :     #
186 :     # Returned is a list of names.
187 :     #
188 :    
189 :     sub get_diagrams
190 :     {
191 :     my($self) = @_;
192 :    
193 :     my $b = $self->{name};
194 :     $b =~ s/ /_/g;
195 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b);
196 :    
197 :     my $dh = new DirHandle($dir);
198 :    
199 :     my @names = grep(/^[^.]/, $dh->read());
200 :    
201 :     return @names;
202 :     }
203 :    
204 :     #
205 :     # Return a Subsystem::Diagram object for this diagram.
206 :     #
207 :     sub get_diagram
208 :     {
209 :     my($self, $name) = @_;
210 :    
211 :     my $b = $self->{name};
212 :     $b =~ s/ /_/g;
213 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b, $name);
214 :    
215 :     if (-d $dir)
216 :     {
217 :     return Subsystem::Diagram->new($self, $self->{fig}, $name, $dir);
218 :     }
219 :     else
220 :     {
221 :     return undef;
222 :     }
223 :     }
224 :    
225 :     #
226 : olson 1.5 # Synchronize the database index for this subsystem to the
227 :     # subsystem data.
228 :     #
229 :     # We assume the table already exists.
230 :     #
231 :    
232 :     sub db_sync
233 :     {
234 :     my($self, $skip_delete) = @_;
235 :    
236 :     my $rdbH = $self->{fig}->db_handle();
237 :    
238 :     if (!$skip_delete)
239 :     {
240 :     $rdbH->SQL("DELETE FROM subsystem_index where subsystem = '$self->{name}'")
241 :     }
242 :    
243 :     #
244 :     # We run thru all the cells, writing an entry in the database for the peg/subsystem/role.
245 :     #
246 :    
247 : olson 1.6 my $sth = $rdbH->{_dbh}->prepare("INSERT INTO subsystem_index values(?, ?, ?)");
248 :    
249 : olson 1.5 for my $role ($self->get_roles())
250 :     {
251 :     my $ridx = $self->get_role_index($role);
252 :     my $col = $self->get_col($ridx);
253 :     for my $cell (@$col)
254 :     {
255 :     if ($cell)
256 :     {
257 :     for my $peg (@$cell)
258 :     {
259 : olson 1.6 $sth->execute($peg, $self->{name}, $role);
260 : olson 1.5 }
261 :     }
262 :     }
263 :     }
264 :     }
265 :    
266 : olson 1.1 sub load
267 :     {
268 :     my($self) = @_;
269 :    
270 :     #
271 :     # Load the subsystem.
272 :     #
273 :    
274 :     my $ssa;
275 :     if (!open($ssa,"<$self->{dir}/spreadsheet"))
276 :     {
277 :     warn "Spreadsheet does not exist in subsystem\n";
278 :     return;
279 :     }
280 :    
281 :     local $/ = "//\n";
282 :    
283 :     my $roles = <$ssa>;
284 :     if ($roles)
285 :     {
286 :     $roles =~ s,$/$,,;
287 :     #
288 :     # Split on newline, filter for non-empty lines.
289 :     #
290 :     my @roles = split("\n", $roles);
291 :    
292 :     @roles = grep { $_ ne "" } @roles;
293 :    
294 :     $self->load_roles(@roles);
295 :     }
296 :    
297 :     my $subsets = <$ssa>;
298 :     if ($subsets)
299 :     {
300 :     $subsets =~ s,$/$,,;
301 :     $self->load_subsets($subsets);
302 :     }
303 :    
304 :     $/ = "\n";
305 :    
306 :     $self->load_genomes($ssa);
307 :    
308 :     #
309 :     # Now load the rest of the info.
310 :     #
311 :    
312 :     $self->load_notes();
313 :     $self->load_version();
314 :     $self->load_exchangable();
315 :     }
316 :    
317 :     sub load_notes
318 :     {
319 :     my($self) = @_;
320 :    
321 :     $self->{notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "notes"));
322 :     }
323 :    
324 :     sub load_version
325 :     {
326 :     my($self) = @_;
327 :    
328 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "VERSION"), 1);
329 :     my $l = $l[0];
330 :     chomp $l;
331 :     $self->{version} = $l;
332 :     }
333 :    
334 :     sub load_exchangable
335 :     {
336 :     my($self) = @_;
337 :    
338 :     my $file = File::Spec->catfile($self->{dir}, "EXCHANGABLE");
339 :    
340 :     if (-f $file)
341 :     {
342 :     my($l, @l);
343 :    
344 :     @l = &FIG::file_head($file, 1);
345 :     $l = $l[0];
346 :     chomp $l;
347 :     $self->{exchangable} = $l;
348 :     }
349 :     else
350 :     {
351 :     $self->{exchangable} = 0;
352 :     }
353 :     }
354 :    
355 :    
356 :     sub load_roles
357 :     {
358 :     my($self, @roles) = @_;
359 :    
360 : olson 1.5 $self->{abbr} = {};
361 :     $self->{role_index} = {};
362 :     $self->{roles} = [];
363 :     $self->{role_abbrs} = [];
364 :    
365 : olson 1.1 my $i = 1;
366 :     for my $role (@roles)
367 :     {
368 :     my($abbr, $name) = split(/\t/, $role);
369 : olson 1.2 # print "Role $i: abbr=$abbr name=$name\n";
370 : olson 1.1
371 :     $self->{abbr}->{$abbr} = $name;
372 :     $self->{role_index}->{$name} = $i;
373 :     $self->{roles}->[$i] = $name;
374 : olson 1.4 $self->{role_abbrs}->[$i] = $abbr;
375 : olson 1.1 $i++;
376 :     }
377 :     }
378 :    
379 :     sub load_subsets
380 :     {
381 :     my($self, $subsets) = @_;
382 :    
383 :     #
384 :     # Column and row subsets.
385 :     #
386 :     my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);
387 :    
388 :    
389 :     #
390 :     # Handle column subsets.
391 :     #
392 :    
393 :     my @subsetsC = split(/\n/, $subsetsC);
394 :    
395 :     #
396 :     # Determine active subset.
397 :     #
398 :    
399 :     my $active_subsetC;
400 :     if (@subsetsC > 0)
401 :     {
402 :     $active_subsetC = pop(@subsetsC);
403 :     }
404 :     else
405 :     {
406 :     $active_subsetC = 'All';
407 :     }
408 :    
409 :     $self->{col_active_subset} = $active_subsetC;
410 :    
411 :     $self->{col_subsets} = [];
412 : olson 1.5 $self->{col_subset_members} = {};
413 :    
414 : olson 1.1 for my $subset (@subsetsC)
415 :     {
416 :     my($name, @members) = split(/\s+/, $subset);
417 :    
418 :     push(@{$self->{col_subsets}}, $name);
419 :    
420 :     #
421 :     # Map role members from name to index if necessary.
422 :     #
423 :     # Is it really necessary? ssa2 code was looking up in %pos for this.
424 :     #
425 :     @members = map {
426 :     if (my $new = $self->{role_index}->{$_})
427 :     {
428 :     $new;
429 :     }
430 :     else
431 :     {
432 :     $_;
433 :     }
434 :     } @members;
435 :    
436 :     @{$self->{col_subset_members}->{$name}} = @members;
437 :     }
438 :    
439 :     #
440 :     # Now the row subsets.
441 :     #
442 :    
443 :     chomp($subsetsR);
444 :    
445 :     if ($subsetsR =~ /(\S+.*\S+)/)
446 :     {
447 :     $self->{row_subset_active} = $1;
448 :     }
449 :     else
450 :     {
451 :     $self->{row_subset_active} = 'All';
452 :     }
453 :     }
454 :    
455 :     sub load_genomes
456 :     {
457 :     my($self, $fh) = @_;
458 :     my(%seen);
459 :    
460 : olson 1.5 $self->{spreadsheet} = [];
461 :     $self->{spreadshhet_inv} = [];
462 :     $self->{genome} = [];
463 :     $self->{genome_index} = {};
464 :     $self->{variant_code} = [];
465 :    
466 : olson 1.1 my $i = 1;
467 :     while (<$fh>)
468 :     {
469 :     chomp;
470 :    
471 :     my($genome, $variant_code, @row) = split(/\t/);
472 :    
473 :     next if $seen{$genome};
474 :     $seen{$genome}++;
475 :    
476 :     my $j = 1;
477 :    
478 :     $self->{genome}->[$i] = $genome;
479 :     $self->{genome_index}->{$genome} = $i;
480 :     $self->{variant_code}->[$i] = $variant_code;
481 :    
482 :     for my $entry (@row)
483 :     {
484 :     my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
485 :     $self->{spreadsheet}->[$i]->[$j] = $e2;
486 :     $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
487 :     $j++;
488 :     }
489 :     $i++;
490 :    
491 :     }
492 :     }
493 :    
494 : olson 1.2 =pod
495 :    
496 :     =head1 get_genomes
497 :    
498 :     =cut
499 :    
500 :     sub get_genomes
501 :     {
502 :     my($self) = @_;
503 :    
504 :     my $glist = $self->{genome};
505 :    
506 :     return @$glist[1..$#$glist];
507 :     }
508 :    
509 :     =pod
510 :    
511 :     =head1 get_variant_codes
512 :    
513 :     =cut
514 :    
515 :     sub get_variant_codes
516 :     {
517 :     my($self) = @_;
518 :    
519 :     my $glist = $self->{variant_code};
520 :    
521 :     return @$glist[1..$#$glist];
522 :     }
523 :    
524 :     sub get_variant_code_for_genome
525 :     {
526 :     my($self, $genome) = @_;
527 :    
528 :     my $index = $self->{genome_index}->{$genome};
529 :     return $self->{variant_code}->[$index];
530 :     }
531 :    
532 :     sub get_roles
533 :     {
534 :     my($self) = @_;
535 :    
536 :     my $rlist = $self->{roles};
537 :    
538 :     return @$rlist[1..$#$rlist];
539 :     }
540 :    
541 : olson 1.10 sub get_row :scalar
542 : olson 1.1 {
543 :     my($self, $row) = @_;
544 :    
545 :     return $self->{spreadsheet}->[$row];
546 :     }
547 :    
548 :     sub get_col
549 :     {
550 :     my($self, $col) = @_;
551 :    
552 :     return $self->{spreadsheet_inv}->[$col];
553 :     }
554 :    
555 :     sub get_cell
556 :     {
557 :     my($self, $row, $col) = @_;
558 :    
559 : olson 1.5 my $cell = $self->{spreadsheet}->[$row]->[$col];
560 :     return $cell;
561 : olson 1.1 }
562 :    
563 : olson 1.3 sub get_genome_index
564 :     {
565 :     my($self, $genome) = @_;
566 :    
567 :     return $self->{genome_index}->{$genome};
568 :     }
569 :    
570 :     sub get_genome
571 :     {
572 :     my($self, $gidx) = @_;
573 :    
574 :     return $self->{genome}->[$gidx];
575 :     }
576 :    
577 : olson 1.5 sub get_role_index
578 :     {
579 :     my($self, $role) = @_;
580 :    
581 :     return $self->{role_index}->{$role};
582 :     }
583 :    
584 : olson 1.3 sub get_role
585 :     {
586 :     my($self, $ridx) = @_;
587 :    
588 :     return $self->{roles}->[$ridx];
589 :     }
590 :    
591 : olson 1.4 sub get_role_abbr
592 :     {
593 :     my($self, $ridx) = @_;
594 :    
595 :     return $self->{role_abbrs}->[$ridx];
596 :     }
597 :    
598 : olson 1.1 sub get_pegs_from_cell
599 :     {
600 :     my($self, $rowstr, $colstr) = @_;
601 :     my($row, $col);
602 :    
603 :     #
604 :     # If row isn't numeric, look it up in the genomes list.
605 :     #
606 :    
607 :     if ($rowstr !~ /^\d+$/)
608 :     {
609 :     $row = $self->{genome_index}->{$rowstr};
610 :     }
611 :     else
612 :     {
613 :     $row = $rowstr;
614 :     }
615 :    
616 :     if (!$row)
617 :     {
618 :     warn "Cannot find row for $rowstr\n";
619 :     return undef;
620 :     }
621 :    
622 :     #
623 :     # If col isn't numeric, look it up in the roles and role abbreviations.
624 :     #
625 :    
626 :     if ($colstr !~ /^\d+$/)
627 :     {
628 :     #
629 :     # See if it's an abbr
630 :     #
631 :    
632 :     my $a = $self->{abbr}->{$colstr};
633 :     $colstr = $a if $a;
634 :    
635 :     $col = $self->{role_index}->{$colstr};
636 :     }
637 :     else
638 :     {
639 :     $col = $colstr;
640 :     }
641 :    
642 :     if (!$col)
643 :     {
644 :     warn "Cannot find col for $colstr\n";
645 :     return undef;
646 :     }
647 :    
648 :     my $cell = $self->get_cell($row, $col);
649 :     if ($cell)
650 :     {
651 :     return @$cell;
652 :     }
653 :     else
654 :     {
655 :     return undef;
656 :     }
657 :     }
658 :    
659 :     sub dump
660 :     {
661 :     my($self) = @_;
662 :    
663 :     for my $k (keys(%$self))
664 :     {
665 :     next if $k eq "spreadsheet" or $k eq "spreadsheet_inv";
666 :     print "Key \"$k\": ", Dumper($self->{$k});
667 :     }
668 :     }
669 :    
670 :    
671 :     sub get_dir_from_name
672 :     {
673 :     my($name) = @_;
674 :    
675 :     my $b = $name;
676 :     $b =~ s/ /_/g;
677 :     my $dir = File::Spec->catfile($FIG_Config::data, 'Subsystems', $b);
678 :     return $dir;
679 :     }
680 :    
681 : olson 1.7 package Subsystem::Diagram;
682 :    
683 :     sub new
684 :     {
685 :     my($class, $sub, $fig, $name, $dir) = @_;
686 :    
687 :     if (!-d $dir)
688 :     {
689 :     return undef;
690 :     }
691 :    
692 :     my $self = {
693 :     fig => $fig,
694 :     subsystem => $sub,
695 :     name => $name,
696 :     dir =>$ dir,
697 :     };
698 :     bless $self, $class;
699 :    
700 :     $self->load();
701 :    
702 :     return $self;
703 :     }
704 :    
705 :     #
706 :     # Parse the diagram into internal data structure.
707 :     #
708 :    
709 :     sub load
710 :     {
711 :     my($self) = @_;
712 :    
713 :     $self->load_area();
714 :     }
715 :    
716 :     sub load_area
717 :     {
718 :     my($self) = @_;
719 :     my $fh;
720 :    
721 : olson 1.8 if (!open($fh, "<$self->{dir}/area_table"))
722 : olson 1.7 {
723 : olson 1.8 warn "Could not load $self->{dir}/area_table: $!\n";
724 : olson 1.7 return;
725 :     }
726 :    
727 :     $self->{areas} = [];
728 :    
729 :     my $area_list = $self->{areas};
730 :    
731 :     while (<$fh>)
732 :     {
733 :     chomp;
734 :     s/#.*$//;
735 :     s/^\s+//;
736 :     s/\s+$//;
737 :     next if $_ eq '';
738 :     my ($area, $tag, $value) = split(/\s+/, $_, 3);
739 :     # print "area=$area tag=$tag value=$value\n";
740 :    
741 :     push(@$area_list, [$area, $tag, $value]);
742 :    
743 :     #
744 :     # Do a little checking.
745 :     #
746 :    
747 :     if ($tag eq "role")
748 :     {
749 :     my $idx = $self->{subsystem}->get_role_index($value);
750 :     if (!defined($idx))
751 :     {
752 :     warn "Role not found for \"$value\" in subsystem $self->{subsystem}->{name}\n";
753 :     }
754 :     }
755 :     }
756 :     close($fh);
757 :     }
758 :    
759 :     sub get_areas
760 :     {
761 :     my($self) = @_;
762 :    
763 :     return @{$self->{areas}};
764 :     }
765 :    
766 : olson 1.1 1;
767 : olson 1.7
768 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3