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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3