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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1
2 :     package Subsystem;
3 :    
4 : olson 1.25 use Carp;
5 : olson 1.1 use FIG;
6 :    
7 : olson 1.10 use FIGAttributes;
8 :     use base 'FIGAttributes';
9 :    
10 : olson 1.12 use POSIX;
11 : olson 1.7 use DirHandle;
12 : olson 1.1 use Data::Dumper;
13 : olson 1.14 use File::Copy;
14 : olson 1.1 use File::Spec;
15 : olson 1.12 use IPC::Open2;
16 : olson 1.1
17 :     use strict;
18 :    
19 : olson 1.2 =pod
20 :    
21 :     =head1 Subsystem manipulation.
22 :    
23 :     Any manipulation of subsystem data should happen through this interface.
24 :     This allows us to assure ourselves that the relational tables that
25 :     mirror and index the subsystem data are kept up to date with the
26 :     canonical version of the subsystem information in the flat-files
27 :     kept in $FIG_Config::data/Subsystems.
28 :    
29 : olson 1.25 =head2 Objects.
30 :    
31 :     We define the following perl objects:
32 :    
33 :     Subsystem: represents a subsystem. It can be read from disk and
34 :     written to disk, and manipulated via its methods when in memory.
35 :    
36 :     If we were completely on the OO side of the world, we would also
37 :     define the following set of objects. However, we are not, so they are
38 :     only objects in a conceptual sense. They are implemented using the
39 :     basic perl datatypes.
40 :    
41 :     Role: represents a single role. A role has a name and an abbreviation.
42 :    
43 :     RoleSubset: represents a subset of available roles. A subset has a
44 :     name and a list of role names that comprise the subset.
45 :    
46 : olson 1.2 =head2 Thoughts on locking
47 :    
48 :     It is currently dangerous for multiple users to modify spreadsheets at once.
49 :     It will likely remain dangerous while the subsystem backend is fairly
50 :     stateless, as it is with the CGI mechanism.
51 :    
52 :     We'd like to make this a little safer. One mechanism might be to allow
53 :     a user to open a subsystem for modification, and others for readonly access.
54 :     For this to work we have to be able to tell which users is allowed; current
55 :     implementation uses the curator of the subsystem for this purpose.
56 :    
57 :     NB: This module does not currently attempt to handle locking or exclusion.
58 :     It is up to the caller (user application, CGI script, etc) to do so.
59 :     It does attempt to use locking internally where appropriate.
60 :    
61 :     =head2 Data structures
62 :    
63 :     We maintain the following data structures (all members of %$self).
64 :    
65 :     =over 4
66 :    
67 :     =item dir
68 :    
69 :     Directory in which the subsystem is stored.
70 :    
71 :     =item notes
72 :    
73 :     The current notes contents for the subsystem
74 :    
75 :     =item version
76 :    
77 :     Current subsystem version.
78 :    
79 :     =item exchangable
80 :    
81 :     1 if subsystem is exchangable, 0 otherwise.
82 :    
83 :     =item roles
84 :    
85 : olson 1.25 List of role names.
86 : olson 1.2
87 :     =item role_index
88 :    
89 :     hash that maps from role name to index
90 :    
91 :     =item role_abbrs
92 :    
93 :     list of role abbreviations
94 :    
95 :     =item abbr
96 :    
97 :     hash mapping from role abbreviation to role name
98 :    
99 :     =item col_subsets
100 :    
101 :     list of column subset names
102 :    
103 :     =item col_subset_members
104 :    
105 :     hash that maps from column subset name to subset members
106 :    
107 :     =item col_active_subset
108 :    
109 :     currently-active column subset
110 :    
111 :     =item row_active_subset
112 :    
113 :     currently-active row subset
114 :    
115 :     =item genome
116 :    
117 : olson 1.25 List of genome IDs.
118 : olson 1.2
119 :     =item variant_code
120 :    
121 : olson 1.25 List of variant codes.
122 : olson 1.2
123 :     =item genome_index
124 :    
125 :     Hash mapping from genome ID to genome index.
126 :    
127 :     =item spreadsheet
128 :    
129 :     Spreadsheet data. Structured as a list of rows, each of which
130 :     is a list of entries. An entry is a list of PEG numbers.
131 :    
132 :     =item spreadsheet_inv
133 :    
134 :     Inverted structure of spreadsheet - list of columns, each of which is a list
135 :     of rows.
136 :    
137 :     =back
138 :    
139 : olson 1.25 =head2 Methods
140 :    
141 :     =over 4
142 :    
143 :     =item index_cell
144 :    
145 :     Create the subsystem_index entries for the given cell.
146 :     (NEW).
147 :    
148 :     =item delete_role(name)
149 :    
150 :     Delete the given role.
151 :    
152 :     =item add_role(name, abbr)
153 :    
154 :     Add a new role.
155 :    
156 :     =item get_subset(name)
157 :    
158 :     Returns a given subset. A subset is an object, implemented as a blessed array
159 :     of roles.
160 :    
161 :     =item add_genome(genome_id, variant_code)
162 :    
163 :     =item remove_genome(genome_id)
164 :    
165 :     =back
166 :    
167 : olson 1.2 =cut
168 : olson 1.1
169 :     =pod
170 :    
171 :     =head1 Subsystem constructor
172 :    
173 :     usage: $sub = Subsystem->new("subsystem name", $fig, $createFlag)
174 :    
175 :     Load the subsystem. If it does not exist, and $createFlag is true, create
176 :     a new empty subsystem.
177 :    
178 :     =cut
179 :    
180 :     sub new
181 :     {
182 :     my($class, $name, $fig, $create) = @_;
183 :    
184 :     my $ssa_dir = get_dir_from_name($name);
185 :    
186 :     #
187 :     # For loading, the subsystem directory must already exist.
188 :     #
189 :    
190 : olson 1.25 if (! -d $ssa_dir and not $create)
191 : olson 1.1 {
192 : olson 1.25 # warn "Subsystem $name does not exist\n";
193 :     return undef;
194 : olson 1.1 }
195 :    
196 :     my $self = {
197 :     dir => $ssa_dir,
198 :     name => $name,
199 :     fig => $fig,
200 :     };
201 :    
202 :     bless($self, $class);
203 :    
204 : olson 1.25 if ($create)
205 :     {
206 :     $self->create_subsystem();
207 :     }
208 :     else
209 :     {
210 :     $self->load();
211 :     }
212 : olson 1.1
213 :     return $self;
214 :     }
215 :    
216 : olson 1.19 sub new_from_dir
217 :     {
218 :     my($class, $dir, $fig) = @_;
219 :    
220 :     my $ssa_dir = $dir;
221 : olson 1.29 my $name = $dir;
222 :     $name =~ s,.*/,,;
223 : olson 1.19
224 :     #
225 :     # For loading, the subsystem directory must already exist.
226 :     #
227 :    
228 :     my $self = {
229 :     dir => $ssa_dir,
230 :     name => $name,
231 :     fig => $fig,
232 :     };
233 :    
234 :     bless($self, $class);
235 :    
236 :     $self->load();
237 :    
238 :     return $self;
239 :     }
240 :    
241 : olson 1.25 =pod
242 :    
243 :     =head2 create_subsystem()
244 :    
245 :     Create a new subsystem. This creates the subsystem directory in the
246 :     correct place ($FIG_Config::data/Subsystems), and populates it with
247 :     the correct initial data.
248 :    
249 :     =cut
250 :    
251 : olson 1.1 sub create_subsystem
252 :     {
253 : olson 1.25 my($self) = @_;
254 :    
255 :     my $dir = $self->{dir};
256 :     my $fig = $self->{fig};
257 :    
258 :     if (-d $dir)
259 :     {
260 :     warn "Not creating: Subsystem directory $dir already exists";
261 :     return;
262 :     }
263 :    
264 :     $fig->verify_dir($dir);
265 :    
266 :     #
267 :     # Initialize empty data structures.
268 :     #
269 :    
270 :     $self->{genome} = [];
271 :     $self->{genome_index} = {};
272 :     $self->{variant_code} = [];
273 :    
274 :     $self->{abbr} = {};
275 :     $self->{role_index} = {};
276 :     $self->{roles} = [];
277 :     $self->{role_abbrs} = [];
278 : olson 1.1
279 : olson 1.25 $self->{spreadsheet} = [];
280 :     $self->{spreadsheet_inv} = [];
281 :    
282 :     $self->{col_subsets} = [];
283 :     $self->{col_subset_members} = {};
284 :    
285 :     $self->{row_active_subset} = "All";
286 :     $self->{col_active_subset} = "All";
287 :    
288 :     $self->{version} = 0;
289 :     $self->{exchangable} = 0;
290 :    
291 :     $self->write_subsystem();
292 : olson 1.1 }
293 :    
294 : olson 1.5 #
295 : olson 1.7 # Retrieve the diagrams associated with this subsystem.
296 :     #
297 :     # This is done via a lookup into FIG/Data/SubsystemDiagrams/<ssaname>/<diagram-name>.
298 :     #
299 :     # Returned is a list of names.
300 :     #
301 :    
302 :     sub get_diagrams
303 :     {
304 :     my($self) = @_;
305 :    
306 :     my $b = $self->{name};
307 :     $b =~ s/ /_/g;
308 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b);
309 :    
310 :     my $dh = new DirHandle($dir);
311 :    
312 :     my @names = grep(/^[^.]/, $dh->read());
313 :    
314 :     return @names;
315 :     }
316 :    
317 :     #
318 :     # Return a Subsystem::Diagram object for this diagram.
319 :     #
320 :     sub get_diagram
321 :     {
322 :     my($self, $name) = @_;
323 :    
324 :     my $b = $self->{name};
325 :     $b =~ s/ /_/g;
326 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b, $name);
327 :    
328 :     if (-d $dir)
329 :     {
330 :     return Subsystem::Diagram->new($self, $self->{fig}, $name, $dir);
331 :     }
332 :     else
333 :     {
334 :     return undef;
335 :     }
336 :     }
337 :    
338 :     #
339 : olson 1.5 # Synchronize the database index for this subsystem to the
340 :     # subsystem data.
341 :     #
342 :     # We assume the table already exists.
343 :     #
344 :    
345 :     sub db_sync
346 :     {
347 :     my($self, $skip_delete) = @_;
348 :    
349 :     my $rdbH = $self->{fig}->db_handle();
350 :    
351 :     if (!$skip_delete)
352 :     {
353 : olson 1.25 $self->delete_indices();
354 : olson 1.5 }
355 :    
356 :     #
357 :     # We run thru all the cells, writing an entry in the database for the peg/subsystem/role.
358 :     #
359 :    
360 : olson 1.6 my $sth = $rdbH->{_dbh}->prepare("INSERT INTO subsystem_index values(?, ?, ?)");
361 :    
362 : olson 1.5 for my $role ($self->get_roles())
363 :     {
364 :     my $ridx = $self->get_role_index($role);
365 :     my $col = $self->get_col($ridx);
366 :     for my $cell (@$col)
367 :     {
368 :     if ($cell)
369 :     {
370 :     for my $peg (@$cell)
371 :     {
372 : olson 1.6 $sth->execute($peg, $self->{name}, $role);
373 : olson 1.5 }
374 :     }
375 :     }
376 :     }
377 :     }
378 :    
379 : olson 1.22 #
380 :     # Delete this subsystem's entries from the database index.
381 :     #
382 :     sub delete_indices
383 :     {
384 :     my($self) = @_;
385 :    
386 :     my $rdbH = $self->{fig}->db_handle();
387 :    
388 :     $rdbH->SQL("DELETE FROM subsystem_index where subsystem = '$self->{name}'")
389 :     }
390 :    
391 : olson 1.1 sub load
392 :     {
393 :     my($self) = @_;
394 :    
395 :     #
396 :     # Load the subsystem.
397 :     #
398 :    
399 :     my $ssa;
400 :     if (!open($ssa,"<$self->{dir}/spreadsheet"))
401 :     {
402 :     warn "Spreadsheet does not exist in subsystem\n";
403 :     return;
404 :     }
405 :    
406 :     local $/ = "//\n";
407 :    
408 :     my $roles = <$ssa>;
409 :     if ($roles)
410 :     {
411 :     $roles =~ s,$/$,,;
412 :     #
413 :     # Split on newline, filter for non-empty lines.
414 :     #
415 :     my @roles = split("\n", $roles);
416 :    
417 :     @roles = grep { $_ ne "" } @roles;
418 :    
419 :     $self->load_roles(@roles);
420 :     }
421 :    
422 :     my $subsets = <$ssa>;
423 :     if ($subsets)
424 :     {
425 :     $subsets =~ s,$/$,,;
426 :     $self->load_subsets($subsets);
427 :     }
428 :    
429 :     $/ = "\n";
430 :    
431 :     $self->load_genomes($ssa);
432 :    
433 :     #
434 :     # Now load the rest of the info.
435 :     #
436 :    
437 :     $self->load_notes();
438 :     $self->load_version();
439 :     $self->load_exchangable();
440 : olson 1.17 $self->load_curation();
441 : olson 1.1 }
442 :    
443 :     sub load_notes
444 :     {
445 :     my($self) = @_;
446 :    
447 :     $self->{notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "notes"));
448 :     }
449 :    
450 : olson 1.17 sub load_curation
451 :     {
452 :     my($self) = @_;
453 :    
454 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "curation.log"), 1);
455 :    
456 :     $_ = $l[0];
457 :     chomp;
458 :     if (/^\d+\t(\S+)\s+started/)
459 :     {
460 :     $self->{curator} = $1;
461 :     }
462 :     }
463 :    
464 : olson 1.1 sub load_version
465 :     {
466 :     my($self) = @_;
467 :    
468 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "VERSION"), 1);
469 :     my $l = $l[0];
470 :     chomp $l;
471 :     $self->{version} = $l;
472 :     }
473 :    
474 :     sub load_exchangable
475 :     {
476 :     my($self) = @_;
477 :    
478 :     my $file = File::Spec->catfile($self->{dir}, "EXCHANGABLE");
479 :    
480 :     if (-f $file)
481 :     {
482 :     my($l, @l);
483 :    
484 :     @l = &FIG::file_head($file, 1);
485 :     $l = $l[0];
486 :     chomp $l;
487 :     $self->{exchangable} = $l;
488 :     }
489 :     else
490 :     {
491 :     $self->{exchangable} = 0;
492 :     }
493 :     }
494 :    
495 :    
496 :     sub load_roles
497 :     {
498 :     my($self, @roles) = @_;
499 :    
500 : olson 1.5 $self->{abbr} = {};
501 :     $self->{role_index} = {};
502 :     $self->{roles} = [];
503 :     $self->{role_abbrs} = [];
504 :    
505 : olson 1.25 my $i = 0;
506 : olson 1.1 for my $role (@roles)
507 :     {
508 :     my($abbr, $name) = split(/\t/, $role);
509 : olson 1.2 # print "Role $i: abbr=$abbr name=$name\n";
510 : olson 1.1
511 :     $self->{abbr}->{$abbr} = $name;
512 :     $self->{role_index}->{$name} = $i;
513 :     $self->{roles}->[$i] = $name;
514 : olson 1.4 $self->{role_abbrs}->[$i] = $abbr;
515 : olson 1.1 $i++;
516 :     }
517 :     }
518 :    
519 :     sub load_subsets
520 :     {
521 :     my($self, $subsets) = @_;
522 :    
523 :     #
524 :     # Column and row subsets.
525 :     #
526 :     my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);
527 :    
528 :     #
529 :     # Handle column subsets.
530 :     #
531 :    
532 :     my @subsetsC = split(/\n/, $subsetsC);
533 :    
534 :     #
535 :     # Determine active subset.
536 :     #
537 :    
538 :     my $active_subsetC;
539 :     if (@subsetsC > 0)
540 :     {
541 :     $active_subsetC = pop(@subsetsC);
542 :     }
543 :     else
544 :     {
545 :     $active_subsetC = 'All';
546 :     }
547 :    
548 :     $self->{col_active_subset} = $active_subsetC;
549 :    
550 :     $self->{col_subsets} = [];
551 : olson 1.5 $self->{col_subset_members} = {};
552 :    
553 : olson 1.1 for my $subset (@subsetsC)
554 :     {
555 :     my($name, @members) = split(/\s+/, $subset);
556 :    
557 : olson 1.25 #
558 :     # File format has members 1-based.
559 :     #
560 :    
561 :     @members = map { $_ - 1 } @members;
562 :    
563 : olson 1.1 push(@{$self->{col_subsets}}, $name);
564 :    
565 :     #
566 :     # Map role members from name to index if necessary.
567 :     #
568 :     # Is it really necessary? ssa2 code was looking up in %pos for this.
569 :     #
570 :     @members = map {
571 :     if (my $new = $self->{role_index}->{$_})
572 :     {
573 :     $new;
574 :     }
575 :     else
576 :     {
577 :     $_;
578 :     }
579 :     } @members;
580 :    
581 :     @{$self->{col_subset_members}->{$name}} = @members;
582 :     }
583 :    
584 :     #
585 :     # Now the row subsets.
586 :     #
587 :    
588 :     chomp($subsetsR);
589 :    
590 :     if ($subsetsR =~ /(\S+.*\S+)/)
591 :     {
592 : olson 1.25 $self->{row_active_subset} = $1;
593 : olson 1.1 }
594 :     else
595 :     {
596 : olson 1.25 $self->{row_active_subset} = 'All';
597 : olson 1.1 }
598 :     }
599 :    
600 :     sub load_genomes
601 :     {
602 :     my($self, $fh) = @_;
603 :     my(%seen);
604 :    
605 : olson 1.5 $self->{spreadsheet} = [];
606 : olson 1.29 $self->{spreadsheet_inv} = [];
607 : olson 1.5 $self->{genome} = [];
608 :     $self->{genome_index} = {};
609 :     $self->{variant_code} = [];
610 :    
611 : olson 1.25 my $nr = @{$self->{roles}};
612 :    
613 :     my $i = 0;
614 : olson 1.1 while (<$fh>)
615 :     {
616 :     chomp;
617 :    
618 : olson 1.25 my($genome, $variant_code, @row) = split(/\t/, $_, $nr + 2);
619 : olson 1.1
620 :     next if $seen{$genome};
621 :     $seen{$genome}++;
622 :    
623 : olson 1.25 my $j = 0;
624 : olson 1.1
625 :     $self->{genome}->[$i] = $genome;
626 :     $self->{genome_index}->{$genome} = $i;
627 :     $self->{variant_code}->[$i] = $variant_code;
628 :    
629 : olson 1.25 my $thislen = @row;
630 :    
631 :     # if ($thislen != $nr)
632 :     # {
633 :     # warn "Genome $genome has wrong column count ($thislen != $nr)\n";
634 :     # warn "<$_> $genome $variant_code '", join(":", @row), "'\n";
635 :     # }
636 :    
637 :     for my $j (0..$nr - 1)
638 : olson 1.1 {
639 : olson 1.25 my $entry = $row[$j];
640 : olson 1.1 my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
641 :     $self->{spreadsheet}->[$i]->[$j] = $e2;
642 :     $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
643 :     $j++;
644 :     }
645 :     $i++;
646 :    
647 :     }
648 :     }
649 :    
650 : olson 1.2 =pod
651 :    
652 : olson 1.25 =head2 write_subsystem()
653 :    
654 :     Write the subsystem to the disk. Updates on-disk data with notes,
655 :     etc. Perform backups when necessary.
656 :    
657 :     =cut
658 :    
659 :     sub write_subsystem
660 :     {
661 :     my($self) = @_;
662 :    
663 :     my $dir = $self->{dir};
664 :     my $fig = $self->{fig};
665 :    
666 :     #
667 :     # We first move the existing spreadsheet and notes files (if present)
668 :     # to spreadsheet~ and notes~, and current state.
669 :     #
670 :    
671 :     my $ss_file = "$dir/spreadsheet";
672 :     my $ss_bak = "$dir/spreadsheet~";
673 :     my $notes_file = "$dir/notes";
674 :     my $notes_bak = "$dir/notes~";
675 :    
676 :     if (-f $ss_file)
677 :     {
678 :     rename($ss_file, $ss_bak);
679 :     }
680 :    
681 :     if (-f $notes_file)
682 :     {
683 :     rename($notes_file, $notes_bak);
684 :     }
685 :    
686 :     #
687 :     # Eval this whole chunk, so that if we get any fatal errors, we can
688 :     # roll back to the old saved data.
689 :     #
690 :    
691 :     eval {
692 :     my $fh;
693 :     open($fh, ">$ss_file") or die "Cannot open $ss_file for writing: $!\n";
694 :     $self->write_spreadsheet($fh);
695 :     close($fh);
696 :    
697 :     open($fh, ">$notes_file") or die "Cannot open $notes_file for writing: $!\n";
698 :     print $fh "$self->{notes}\n";
699 :     close($fh);
700 :    
701 :     $self->update_curation_log();
702 :    
703 :     #
704 :     # Write out the piddly stuff.
705 :     #
706 :    
707 :     open($fh, ">$dir/EXCHANGABLE") or die "Cannot write $dir/EXCHANGABLE: $!\n";
708 :     print $fh "$self->{exchangable}\n";
709 :     close($fh);
710 :    
711 :     #
712 :     # Process backup files. This is the smae process that determines when the
713 :     # version number should be bumped, so write the version file afterward.
714 :     #
715 :    
716 :     $self->update_backups();
717 :    
718 :     open($fh, ">$dir/VERSION") or die "Cannot write $dir/EXCHANGABLE: $!\n";
719 :     print $fh "$self->{exchangable}\n";
720 :     close($fh);
721 :    
722 :     };
723 :    
724 :     if ($@ ne "")
725 :     {
726 :     warn "Spreadsheet write failed, reverting to backup. Error was\n$@\n";
727 :     }
728 :    
729 :     }
730 :    
731 :     sub update_curation_log
732 :     {
733 :     my($self) = @_;
734 :    
735 :     my $fh;
736 :     my $file = "$self->{dir}/curation.log";
737 :    
738 :     my $now = time;
739 :     my $user = $self->{fig}->get_user();
740 :    
741 :     if (-f $file)
742 :     {
743 :     open($fh, ">>$file") or die "Cannot open $file for writing: $!\n";
744 :     }
745 :     else
746 :     {
747 :     open($fh, ">$file") or die "Cannot open $file for writing: $!\n";
748 :     print $fh "$now\t$user\tstarted\n";
749 :     }
750 :     print $fh "$now\t$user\tupdated\n";
751 :     close($fh);
752 :     }
753 :    
754 :     sub update_backups
755 :     {
756 :     my($self) = @_;
757 :    
758 :     my $dir = $self->{dir};
759 :     my $fig = $self->{fig};
760 :    
761 :     my $ss_file = "$dir/spreadsheet";
762 :     my $ss_bak = "$dir/spreadsheet~";
763 :     my $notes_file = "$dir/notes";
764 :     my $notes_bak = "$dir/notes~";
765 :    
766 :     my $ss_diff = abs((-s $ss_file) - (-s $ss_bak));
767 :     my $notes_diff = abs((-s $notes_file) - (-s $notes_bak));
768 :    
769 :     if ($ss_diff > 10 or $notes_diff > 10)
770 :     {
771 :     $self->make_backup();
772 :     }
773 :     }
774 :    
775 :     sub make_backup
776 :     {
777 :     my($self) = @_;
778 :    
779 :     my $dir = $self->{dir};
780 :     my $bak = "$dir/Backup";
781 :    
782 :     $self->{fig}->verify_dir($bak);
783 :    
784 :     my $ts = time;
785 :    
786 :     rename("$dir/spreadsheet~", "$bak/spreadsheet.$ts");
787 :     rename("$dir/notes~", "$bak/notes.$ts");
788 :     $self->{version}++;
789 :     }
790 :    
791 :    
792 :    
793 :     =pod
794 :    
795 :     =head1 write_spreadsheet($fh)
796 :    
797 :     Write the spreadsheet for this subsystem to filehandle $fh.
798 :    
799 :     =cut
800 :    
801 :     sub write_spreadsheet
802 :     {
803 :     my($self, $fh) = @_;
804 :    
805 :     $self->_write_roles($fh);
806 :     print $fh "//\n";
807 :    
808 :     $self->_write_subsets($fh);
809 :     print $fh "//\n";
810 :    
811 :     $self->_write_spreadsheet($fh);
812 :     }
813 :    
814 :     sub _write_roles
815 :     {
816 :     my($self, $fh) = @_;
817 :    
818 :     my(@roles, @abbrs);
819 :    
820 :     @roles = $self->get_roles();
821 :     @abbrs = $self->get_abbrs();
822 :    
823 :     while (@roles)
824 :     {
825 :     my $role = shift(@roles);
826 :     my $abbr = shift(@abbrs);
827 :    
828 :     print $fh "$abbr\t$role\n";
829 :     }
830 :     }
831 :    
832 :     sub _write_subsets
833 :     {
834 :     my($self, $fh) = @_;
835 :    
836 :     for my $sub ($self->get_subset_names())
837 :     {
838 :     my @members= $self->get_subset($sub);
839 :    
840 :     #
841 :     # member list on disk is 1-based
842 :     #
843 :    
844 :     @members = map { $_ + 1 } @members;
845 :     print $fh join("\t", $sub, @members), "\n";
846 :     }
847 :     print $fh "All\n";
848 :    
849 :     #
850 :     # separator
851 :     #
852 :    
853 :     print $fh "\n";
854 :    
855 :     #
856 :     # genome subsets.
857 :     #
858 :    
859 :     print $fh "All\n";
860 :     }
861 :    
862 :     sub _write_spreadsheet
863 :     {
864 :     my($self, $fh) = @_;
865 :    
866 :     my(@genomes);
867 :    
868 :     @genomes= $self->get_genomes();
869 :    
870 :     for (my $i = 0; $i < @genomes; $i++)
871 :     {
872 :     my $genome = $genomes[$i];
873 :     my $vc = $self->get_variant_code($i);
874 :    
875 :     my $row = $self->get_row($i);
876 :    
877 :     if ($vc eq "")
878 :     {
879 :     $vc = "0";
880 :     }
881 :     print $fh "$genome\t$vc";
882 :    
883 :     for my $entry (@$row)
884 :     {
885 :     my(@p);
886 :    
887 :     for my $peg (@$entry)
888 :     {
889 :     if ($peg =~ /fig\|$genome\.peg\.(\d+)$/)
890 :     {
891 :     push(@p, $1);
892 :     }
893 :     else
894 :     {
895 :     warn "Bad peg $peg in cell for $genome";
896 :     }
897 :     }
898 :     print $fh "\t", join(",", @p);
899 :     }
900 :     print $fh "\n";
901 :     }
902 :     }
903 :    
904 :    
905 :     =pod
906 :    
907 : olson 1.2 =head1 get_genomes
908 :    
909 :     =cut
910 : olson 1.25
911 : olson 1.2 sub get_genomes
912 :     {
913 :     my($self) = @_;
914 :    
915 :     my $glist = $self->{genome};
916 :    
917 : olson 1.25 return @$glist;
918 : olson 1.2 }
919 :    
920 :     =pod
921 :    
922 :     =head1 get_variant_codes
923 :    
924 :     =cut
925 : olson 1.25
926 : olson 1.2 sub get_variant_codes
927 :     {
928 :     my($self) = @_;
929 :    
930 :     my $glist = $self->{variant_code};
931 :    
932 : olson 1.25 return @$glist;
933 :     }
934 :    
935 :     sub get_variant_code
936 :     {
937 :     my($self, $gidx) = @_;
938 :     return $self->{variant_code}->[$gidx];
939 : olson 1.2 }
940 :    
941 : olson 1.25
942 : olson 1.2 sub get_variant_code_for_genome
943 :     {
944 :     my($self, $genome) = @_;
945 :    
946 :     my $index = $self->{genome_index}->{$genome};
947 :     return $self->{variant_code}->[$index];
948 :     }
949 :    
950 :     sub get_roles
951 :     {
952 :     my($self) = @_;
953 :    
954 :     my $rlist = $self->{roles};
955 :    
956 : olson 1.25 return @$rlist;
957 :     }
958 :    
959 :     sub get_abbrs
960 :     {
961 :     my($self) = @_;
962 :    
963 :     my $rlist = $self->{role_abbrs};
964 :    
965 :     return @$rlist;
966 : olson 1.2 }
967 :    
968 : olson 1.29 sub roles_with_abbreviations
969 :     {
970 :     my($self) = @_;
971 :    
972 :     my @ret;
973 :    
974 :     for my $i (0..@{$self->{roles}} - 1)
975 :     {
976 :     push(@ret, [$self->{role_abbrs}->[$i], $self->{roles}->[$i]]);
977 :     }
978 :     return @ret;
979 :     }
980 :    
981 :    
982 : olson 1.10 sub get_row :scalar
983 : olson 1.1 {
984 :     my($self, $row) = @_;
985 :    
986 :     return $self->{spreadsheet}->[$row];
987 :     }
988 :    
989 : olson 1.21 sub get_col :scalar
990 : olson 1.1 {
991 :     my($self, $col) = @_;
992 :    
993 :     return $self->{spreadsheet_inv}->[$col];
994 :     }
995 :    
996 : olson 1.21 sub get_cell :scalar
997 : olson 1.1 {
998 :     my($self, $row, $col) = @_;
999 :    
1000 : olson 1.5 my $cell = $self->{spreadsheet}->[$row]->[$col];
1001 :     return $cell;
1002 : olson 1.1 }
1003 :    
1004 : olson 1.21 sub get_genome_index :scalar
1005 : olson 1.3 {
1006 :     my($self, $genome) = @_;
1007 :    
1008 :     return $self->{genome_index}->{$genome};
1009 :     }
1010 :    
1011 : olson 1.21 sub get_genome :scalar
1012 : olson 1.3 {
1013 :     my($self, $gidx) = @_;
1014 :    
1015 :     return $self->{genome}->[$gidx];
1016 :     }
1017 :    
1018 : olson 1.21 sub get_role_index :scalar
1019 : olson 1.5 {
1020 :     my($self, $role) = @_;
1021 :    
1022 :     return $self->{role_index}->{$role};
1023 :     }
1024 :    
1025 : olson 1.21 sub get_role :scalar
1026 : olson 1.3 {
1027 :     my($self, $ridx) = @_;
1028 :    
1029 :     return $self->{roles}->[$ridx];
1030 :     }
1031 :    
1032 : olson 1.21 sub get_role_abbr :scalar
1033 : olson 1.4 {
1034 :     my($self, $ridx) = @_;
1035 :    
1036 :     return $self->{role_abbrs}->[$ridx];
1037 :     }
1038 :    
1039 : olson 1.21 sub get_role_from_abbr :scalar
1040 : olson 1.20 {
1041 :     my($self, $abbr) = @_;
1042 :    
1043 :     return $self->{abbr}->{$abbr};
1044 :     }
1045 :    
1046 : olson 1.26 =pod
1047 :    
1048 :     =head1 set_pegs_in_cell($genome, $role, $peg_list)
1049 :    
1050 :     Set the cell for the given genome and role to $peg_list.
1051 :    
1052 :     =cut
1053 :    
1054 :     sub set_pegs_in_cell
1055 :     {
1056 :     my($self, $genome, $role, $peg_list) = @_;
1057 :     my($row, $col);
1058 :    
1059 :     #
1060 :     # If row isn't numeric, look it up in the genomes list.
1061 :     #
1062 :    
1063 :     if ($genome !~ /^\d+$/)
1064 :     {
1065 :     $row = $self->{genome_index}->{$genome};
1066 :     }
1067 :     else
1068 :     {
1069 :     $row = $genome
1070 :     }
1071 :    
1072 :     if (!$row)
1073 :     {
1074 :     warn "Cannot find row for $genome\n";
1075 :     return undef;
1076 :     }
1077 :    
1078 :     #
1079 :     # If col isn't numeric, look it up in the roles and role abbreviations.
1080 :     #
1081 :    
1082 :     if ($role !~ /^\d+$/)
1083 :     {
1084 :     #
1085 :     # See if it's an abbr
1086 :     #
1087 :    
1088 :     my $a = $self->{abbr}->{$role};
1089 : olson 1.27 $role = $a if $a;
1090 : olson 1.26
1091 :     $col = $self->{role_index}->{$role};
1092 :     }
1093 :     else
1094 :     {
1095 :     $col = $role;
1096 :     }
1097 :    
1098 :     if (!$col)
1099 :     {
1100 :     warn "Cannot find col for $role\n";
1101 :     return undef;
1102 :     }
1103 :     my $cell = $self->get_cell($row, $col);
1104 :    
1105 :     if ($cell)
1106 :     {
1107 :     @$cell = @$peg_list;
1108 :     }
1109 :     else
1110 :     {
1111 :     warn "set_pegs_in_cell: Could not find cell!";
1112 :     }
1113 :     }
1114 :    
1115 : olson 1.1 sub get_pegs_from_cell
1116 :     {
1117 :     my($self, $rowstr, $colstr) = @_;
1118 :     my($row, $col);
1119 :    
1120 :     #
1121 :     # If row isn't numeric, look it up in the genomes list.
1122 :     #
1123 :    
1124 :     if ($rowstr !~ /^\d+$/)
1125 :     {
1126 :     $row = $self->{genome_index}->{$rowstr};
1127 :     }
1128 :     else
1129 :     {
1130 :     $row = $rowstr;
1131 :     }
1132 :    
1133 :     if (!$row)
1134 :     {
1135 :     warn "Cannot find row for $rowstr\n";
1136 :     return undef;
1137 :     }
1138 :    
1139 :     #
1140 :     # If col isn't numeric, look it up in the roles and role abbreviations.
1141 :     #
1142 :    
1143 :     if ($colstr !~ /^\d+$/)
1144 :     {
1145 :     #
1146 :     # See if it's an abbr
1147 :     #
1148 :    
1149 :     my $a = $self->{abbr}->{$colstr};
1150 :     $colstr = $a if $a;
1151 :    
1152 :     $col = $self->{role_index}->{$colstr};
1153 :     }
1154 :     else
1155 :     {
1156 :     $col = $colstr;
1157 :     }
1158 :    
1159 :     if (!$col)
1160 :     {
1161 :     warn "Cannot find col for $colstr\n";
1162 :     return undef;
1163 :     }
1164 : olson 1.12 my $cell = $self->get_cell($row, $col);
1165 : olson 1.1
1166 :     if ($cell)
1167 :     {
1168 :     return @$cell;
1169 :     }
1170 :     else
1171 :     {
1172 :     return undef;
1173 :     }
1174 :     }
1175 :    
1176 : olson 1.25 #
1177 :     # Subset support
1178 :     #
1179 :    
1180 :     sub get_subset_names
1181 : olson 1.17 {
1182 :     my($self) = @_;
1183 : olson 1.25
1184 :     return @{$self->{col_subsets}};
1185 : olson 1.17 }
1186 :    
1187 : olson 1.25 sub get_subset
1188 : olson 1.17 {
1189 : olson 1.25 my($self, $subname) = @_;
1190 :     return @{$self->{col_subset_members}->{$subname}};
1191 :     }
1192 :    
1193 :     =pod
1194 :    
1195 :     =head2 set_subset($name, $members)
1196 :    
1197 :     Create a subset with the given name and members.
1198 :    
1199 :     $members is a list of role names.
1200 :    
1201 :     =cut
1202 :    
1203 :     sub set_subset
1204 :     {
1205 :     my($self, $subname, $list) = @_;
1206 :    
1207 :     my $nl = [map { $self->get_role_index($_) } @$list];
1208 :    
1209 :     $self->_set_subset($subname, $nl);
1210 :     }
1211 :    
1212 :     =pod
1213 :    
1214 :     =head2 _set_subset($name, $members)
1215 :    
1216 :     Create a subset with the given name and members.
1217 :    
1218 :     Internal version - here, members is a list of role indices.
1219 :    
1220 :     =cut
1221 :    
1222 :     sub _set_subset
1223 :     {
1224 :     my($self, $subname, $list) = @_;
1225 :     $self->{col_subset_members}->{$subname} = $list;
1226 :     }
1227 :    
1228 :     #
1229 :     # Role manipulation.
1230 :     #
1231 :    
1232 :    
1233 :     =pod
1234 :    
1235 :     =head1 set_roles($role_list)
1236 :    
1237 :     Set the list of roles. C<$role_list> is a list of tuples C<[$role_name, $abbreviation]>.
1238 :    
1239 :     If a role already exists, it is used. If it does not exist, it is created empty.
1240 :    
1241 :     =cut
1242 :    
1243 :     sub set_roles
1244 :     {
1245 :     my($self, $roles) = @_;
1246 :    
1247 :     #
1248 :     # We do this by first creating a new spreadsheet.
1249 :     #
1250 :     # It is easiest to do this by manipulating the inverted spreadsheet
1251 :     # (role-major), and then creating the non-inverted spreadsheet from it.
1252 :     #
1253 :    
1254 :     my $oldss = $self->{spreadsheet};
1255 :     my $oldssinv = $self->{spreadsheet_inv};
1256 :    
1257 :     my $ss = [];
1258 :     my $ssinv = [];
1259 :    
1260 :     my $g = $self->{genome};
1261 :     my $ng = @$g;
1262 :    
1263 :     my $old_roles = $self->{role_index};
1264 :    
1265 :     my @role_index_conversion;
1266 :    
1267 :    
1268 :     $self->{abbr} = {};
1269 :     $self->{role_index} = {};
1270 :     $self->{roles} = [];
1271 :     $self->{role_abbrs} = [];
1272 :    
1273 :    
1274 :     for (my $idx = 0; $idx < @$roles; $idx++)
1275 :     {
1276 :     my $role = $roles->[$idx]->[0];
1277 :     my $abbr = $roles->[$idx]->[1];
1278 :    
1279 :     my $old_idx = $old_roles->{$role};
1280 :    
1281 :     if (defined($old_idx))
1282 :     {
1283 :     print "Found old idx $old_idx for $role $idx\n";
1284 :     print $oldssinv->[$old_idx];
1285 :     $ssinv->[$idx] = $oldssinv->[$old_idx];
1286 :    
1287 :     $role_index_conversion[$old_idx] = $idx;
1288 :     }
1289 :     else
1290 :     {
1291 :     print "Did not find old role for $role $idx\n";
1292 :     print Dumper($old_roles);
1293 :     my $l = [];
1294 :     for (my $j = 0; $j < $ng; $j++)
1295 :     {
1296 :     $l->[$j] = [];
1297 :     }
1298 :    
1299 :     $ssinv->[$idx] = $l;
1300 :     }
1301 :    
1302 :     #
1303 :     # While we're here, update the new role and abbrev indexes
1304 :     #
1305 :     $self->{role_index}->{$role} = $idx;
1306 :     $self->{abbr}->{$abbr} = $role;
1307 :     $self->{roles}->[$idx] = $role;
1308 :     $self->{role_abbrs}->[$idx] = $abbr;
1309 :     }
1310 :    
1311 :     #
1312 :     # Now create the uninverted spreadsheet.
1313 :     #
1314 :    
1315 :     for (my $gidx = 0; $gidx < $ng; $gidx++)
1316 :     {
1317 :     my $row = [];
1318 :     $ss->[$gidx] = $row;
1319 :     for (my $ridx = 0; $ridx < @$roles; $ridx++)
1320 :     {
1321 :     $row->[$ridx] = $ssinv->[$ridx]->[$gidx];
1322 :     }
1323 :     }
1324 :    
1325 :     $self->{spreadsheet} = $ss;
1326 :     $self->{spreadsheet_inv} = $ssinv;
1327 :    
1328 :     #
1329 :     # Fix up the subsets.
1330 :     #
1331 :    
1332 :    
1333 :     for my $subset ($self->get_subset_names())
1334 :     {
1335 :     my $n = [];
1336 :     for my $idx ($self->get_subset($subset))
1337 :     {
1338 :     my $new = $role_index_conversion[$idx];
1339 :     if (defined($new))
1340 :     {
1341 :     push(@$n, $new);
1342 :     }
1343 :     }
1344 :     $self->_set_subset($subset, $n);
1345 :     }
1346 :    
1347 :     }
1348 :    
1349 :     =pod
1350 :    
1351 :     =head1 C<add_role($role, $abbr)>
1352 :    
1353 :     Add the given role to the spreadsheet.
1354 :    
1355 :     This causes a new column to be added, with empty values in each cell.
1356 :    
1357 :     We do nothing if the role is already present.
1358 :    
1359 :     Return the index of the new role.
1360 :    
1361 :     =cut
1362 :    
1363 :     sub add_role
1364 :     {
1365 :     my($self, $role, $abbr) = @_;
1366 :    
1367 :     if (defined($self->get_role_index($role)))
1368 :     {
1369 :     warn "Role $role already present\n";
1370 :     return undef;
1371 :     }
1372 :    
1373 :     #
1374 :     # Add to the roles list. It goes at the end.
1375 :     #
1376 :    
1377 :     my $idx = @{$self->{roles}};
1378 :     $self->{roles}->[$idx] = $role;
1379 :     $self->{role_abbrs}->[$idx] = $abbr;
1380 :     $self->{role_index}->{$role} = $idx;
1381 :     $self->{abbr}->{$abbr} = $role;
1382 :    
1383 :     #
1384 :     # Update the spreadsheet.
1385 :     # On the standard one, we have to go through all the rows adding
1386 :     # a columnt to each.
1387 :     #
1388 :     # On the inverted one, we add a column with [] in each entry.
1389 :     #
1390 :    
1391 :     my $ng = @{$self->{genome}};
1392 :     my $newcol = [];
1393 :    
1394 :     for (my $i = 0; $i < $ng; $i++)
1395 :     {
1396 :     my $cell = [];
1397 :     # print "nr: Adding cell $cell for gidx=$i ridx=$idx\n";
1398 :     $self->{spreadsheet}->[$i]->[$idx] = $cell;
1399 :     $newcol->[$i] = $cell;
1400 :     }
1401 :    
1402 :     $self->{spreadsheet_inv}->[$idx] = $newcol;
1403 :    
1404 :     return $idx;
1405 :     }
1406 :    
1407 :     =pod
1408 :    
1409 :     =head1 remove_role($role)
1410 :    
1411 :     Remove the role from the spreadsheet.
1412 :    
1413 :     We do nothing if the role is not present.
1414 :    
1415 :     =cut
1416 :    
1417 :     sub remove_role
1418 :     {
1419 :     my($self, $role) = @_;
1420 :    
1421 :     my $idx = $self->get_role_index($role);
1422 :     if (!defined($idx))
1423 :     {
1424 :     warn "Role $role not present\n";
1425 :     return undef;
1426 :     }
1427 :    
1428 :     #
1429 :     # Remove from the roles list.
1430 :     #
1431 :    
1432 :     my $abbr = $self->{role_abbrs}->[$idx];
1433 :    
1434 :     splice(@{$self->{roles}}, $idx, 1);
1435 :     splice(@{$self->{role_abbrs}}, $idx, 1);
1436 :     delete $self->{role_index}->{$role};
1437 :     delete $self->{abbr}->{$abbr};
1438 :    
1439 :     #
1440 :     # Update the spreadsheet.
1441 :     # On the standard one, we have to go through all the rows removing
1442 :     # the column from each.
1443 :     #
1444 :     # On the inverted one, we just remove the column.
1445 :     #
1446 :    
1447 :     my $ng = @{$self->{genome}};
1448 :     my $newcol = [];
1449 :    
1450 :     for (my $i = 0; $i < $ng; $i++)
1451 :     {
1452 :     splice(@{$self->{spreadsheet}->[$i]}, $idx, 1);
1453 :     }
1454 :    
1455 :     splice(@{$self->{spreadsheet_inv}}, $idx, 1);
1456 :    
1457 :     #
1458 :     # We need to rewrite the subsets. if $idx was present in one, it is
1459 :     # removed. Any index >$idx is decremented.
1460 :     #
1461 :    
1462 :     for my $subset ($self->get_subset_names())
1463 :     {
1464 :     my @n;
1465 :    
1466 :     for my $sidx ($self->get_subset($subset))
1467 :     {
1468 :     if ($sidx < $idx)
1469 :     {
1470 :     push(@n, $sidx);
1471 :     }
1472 :     elsif ($sidx > $idx)
1473 :     {
1474 :     push(@n, $sidx - 1);
1475 :     }
1476 :     }
1477 :    
1478 :     $self->_set_subset($subset, [@n]);
1479 :     }
1480 :     }
1481 :    
1482 :     =pod
1483 :    
1484 :     =head1 C<add_genome($genome, $abbr)>
1485 :    
1486 :     Add the given genome to the spreadsheet.
1487 :    
1488 :     This causes a new row to be added, with empty values in each cell.
1489 :    
1490 :     We do nothing if the genome is already present.
1491 :    
1492 :     Return the index of the new genome.
1493 :    
1494 :     =cut
1495 :    
1496 :     sub add_genome
1497 :     {
1498 :     my($self, $genome) = @_;
1499 :    
1500 :     my $idx = $self->get_genome_index($genome);
1501 :     if (defined($idx))
1502 :     {
1503 :     warn "Genome $genome already present\n";
1504 :     return $idx;
1505 :     }
1506 :    
1507 :     #
1508 :     # Add to the genomes list. It goes at the end.
1509 :     #
1510 :    
1511 :     my $idx = @{$self->{genome}};
1512 : olson 1.26 $self->{variant_code}->[$idx] = 0;
1513 : olson 1.25 $self->{genome}->[$idx] = $genome;
1514 :     $self->{genome_index}->{$genome} = $idx;
1515 :    
1516 :     #
1517 :     # Update the spreadsheet.
1518 :     # On the inverted one, we have to go through all the columns adding
1519 :     # a row to each.
1520 :     #
1521 :     # On the regular one, we add a row with [] in each entry.
1522 :     #
1523 :    
1524 :     my $nr = @{$self->{roles}};
1525 :     my $newrow = [];
1526 :    
1527 :     for my $i (0.. $nr - 1)
1528 :     {
1529 :     my $cell = [];
1530 :     # print "ng: Adding cell $cell for gidx=$idx ridx=$i\n";
1531 :     $self->{spreadsheet_inv}->[$i]->[$idx] = $cell;
1532 :     $newrow->[$i] = $cell;
1533 :     }
1534 :    
1535 :     $self->{spreadsheet}->[$idx] = $newrow;
1536 :    
1537 :     return $idx;
1538 :     }
1539 :    
1540 :     =pod
1541 :    
1542 :     =head1 remove_genome($genome)
1543 :    
1544 :     Remove the genome from the spreadsheet.
1545 :    
1546 :     We do nothing if the genome is not present.
1547 :    
1548 :     =cut
1549 :    
1550 :     sub remove_genome
1551 :     {
1552 :     my($self, $genome) = @_;
1553 :    
1554 :     my $idx = $self->get_genome_index($genome);
1555 :     if (!defined($idx))
1556 :     {
1557 :     warn "Genome $genome not present\n";
1558 :     return undef;
1559 :     }
1560 :    
1561 :     #
1562 :     # Remove from the genomes list.
1563 :     #
1564 :    
1565 :     splice(@{$self->{genome}}, $idx, 1);
1566 :     splice(@{$self->{variant_code}}, $idx, 1);
1567 :    
1568 :     delete $self->{genome_index}->{$genome};
1569 :    
1570 :     #
1571 :     # Update the spreadsheet.
1572 :     # On the inverted one, we have to go through all the columns removing
1573 :     # the row from each.
1574 :     #
1575 :     # On the standard one, we just remove the row.
1576 :     #
1577 :    
1578 :     my $nr = @{$self->{roles}};
1579 :    
1580 :     for my $i (0 .. $nr - 1)
1581 :     {
1582 :     splice(@{$self->{spreadsheet_inv}->[$i]}, $idx, 1);
1583 :     }
1584 :    
1585 :     splice(@{$self->{spreadsheet}}, $idx, 1);
1586 :    
1587 :     }
1588 :    
1589 :     sub get_name :scalar
1590 :     {
1591 :     my($self) = @_;
1592 :     return $self->{name};
1593 :     }
1594 :    
1595 :    
1596 :     sub get_version :scalar
1597 :     {
1598 :     my($self) = @_;
1599 :     return $self->{version};
1600 : olson 1.17 }
1601 :    
1602 : olson 1.26 sub get_notes :scalar
1603 :     {
1604 :     my($self) = @_;
1605 :    
1606 :     return $self->{notes};
1607 :     }
1608 :    
1609 :     sub set_notes
1610 :     {
1611 :     my($self, $notes) = @_;
1612 :    
1613 : olson 1.28 $self->{notes} = $notes;
1614 : olson 1.26 }
1615 :    
1616 : olson 1.17 sub get_curator :scalar
1617 :     {
1618 :     my($self) = @_;
1619 :     return $self->{curator};
1620 :     }
1621 :    
1622 : olson 1.25 #
1623 :     # Subsystem copying logic
1624 :     #
1625 :    
1626 :     =pod
1627 :    
1628 :     =head2 add_to_subsystem($subsystem_name, $columns, $notes_flag)
1629 :    
1630 :     Merge the given columns from $subsystem_name into this subsystem. Append the
1631 :     notes from the subsystem if $notes_flag is true.
1632 :    
1633 :     =cut
1634 :    
1635 :     sub add_to_subsystem
1636 :     {
1637 :     my($self, $subsystem_name, $cols, $add_notes) = @_;
1638 :    
1639 :     my $ss = $self->{fig}->get_subsystem($subsystem_name);
1640 :    
1641 :     if (!$ss)
1642 :     {
1643 :     warn "Cannot open subsystem '$subsystem_name' to copy from";
1644 :     return;
1645 :     }
1646 :    
1647 :     #
1648 :     # Merge the data from the other subsystem.
1649 :     #
1650 :     # First we assure ourselves that we have the appropriate roles. While
1651 :     # we do this, build the list of row indices (in this subsystem) that
1652 :     # map to the roles we are adding.
1653 :     #
1654 :    
1655 :     #
1656 :     # local_roles[$his_role] = $my_role (map from other role idx to local role idx)
1657 :     #
1658 :    
1659 :     my @local_roles;
1660 :    
1661 :     #
1662 :     # his_roles = list of role indices corresponding to the remote roles.
1663 :     #
1664 :     my @his_roles;
1665 :    
1666 :     for my $his_role (@$cols)
1667 :     {
1668 :     my $idx = $self->get_role_index($his_role);
1669 :     my $his_idx = $ss->get_role_index($his_role);
1670 :    
1671 :     if (!defined($his_idx))
1672 :     {
1673 :     confess "Cannot map his role $his_role\n";
1674 :     }
1675 :     push(@his_roles, $his_idx);
1676 :    
1677 :     if (!defined($idx))
1678 :     {
1679 :     my $his_abbr = $ss->get_role_abbr($his_idx);
1680 :    
1681 :     $idx = $self->add_role($his_role, $his_abbr);
1682 :     print "Adding missing role $his_role idx=$idx\n";
1683 :     }
1684 :     else
1685 :     {
1686 :     print "Found existing role $his_role idx=$idx\n";
1687 :     }
1688 :    
1689 :    
1690 :     $local_roles[$his_idx] = $idx;
1691 :     }
1692 :    
1693 :     #
1694 :     # Similar scan to ensure that we have rows for the genomes
1695 :     # that are in the other subsystem.
1696 :     #
1697 :    
1698 :     my @local_genomes;
1699 :    
1700 :     my @his_genomes = $ss->get_genomes();
1701 :    
1702 :     for my $his_idx (0..@his_genomes - 1)
1703 :     {
1704 :     my $genome = $his_genomes[$his_idx];
1705 :    
1706 :     my $my_idx = $self->get_genome_index($genome);
1707 :    
1708 :     if (!defined($my_idx))
1709 :     {
1710 :     #
1711 :     # Not there, need to add.
1712 :     #
1713 :    
1714 :     $my_idx = $self->add_genome($genome);
1715 :     print "Adding missing genome $genome idx=$my_idx\n";
1716 :     }
1717 :     else
1718 :     {
1719 :     print "Found existing genome $genome idx=$my_idx\n";
1720 :     }
1721 :    
1722 :     $local_genomes[$his_idx] = $my_idx;
1723 :     }
1724 :    
1725 :    
1726 :     #
1727 :     # Now that we have our local roles set up to receive the data,
1728 :     # process the incoming roles one at a time.
1729 :     #
1730 :    
1731 :    
1732 :     for my $his_role (@his_roles)
1733 :     {
1734 :     my $my_col = $self->get_col($local_roles[$his_role]);
1735 :     my $his_col = $ss->get_col($his_role);
1736 :    
1737 :     #
1738 :     # $his_col is the information for $his_role, indexed by
1739 :     # genome in @his_genomes.
1740 :     #
1741 :     # $my_col is hte information for my copy of $his_role,
1742 :     # indexed by genome in MY genome list.
1743 :     #
1744 :    
1745 :     my $my_role = $local_roles[$his_role];
1746 :    
1747 :     print "merging: $self->{roles}->[$my_role] $ss->{roles}->[$his_role] his_role=$his_role my_role=$my_role\n";
1748 :    
1749 :     for my $his_gidx (0 .. @his_genomes - 1)
1750 :     {
1751 :     my $hisent = $his_col->[$his_gidx];
1752 :    
1753 :     my $my_gidx = $local_genomes[$his_gidx];
1754 :    
1755 :     my $myent = $my_col->[$my_gidx];
1756 :    
1757 :     print " his_gidx=$his_gidx my_gidx=$my_gidx hisent=@$hisent myent=@$myent\n";
1758 :    
1759 :     my %new;
1760 :     map { $new{$_}++ } @$hisent;
1761 :     map { $new{$_}++ } @$myent;
1762 :    
1763 :     @$myent = keys(%new);
1764 :    
1765 :     print " new entry: @$myent\n";
1766 :     }
1767 :     }
1768 : olson 1.26
1769 :     #
1770 :     # Fix up the variant codes.
1771 :     #
1772 :    
1773 :     for my $his_gidx (0 .. @his_genomes - 1)
1774 :     {
1775 :     my $his_code = $ss->get_variant_code($his_gidx);
1776 :     my $my_gidx = $local_genomes[$his_gidx];
1777 :    
1778 :     if (!$self->get_variant_code($my_gidx))
1779 :     {
1780 :     $self->{variant_code}->[$my_gidx] = $his_code;
1781 :     }
1782 :     }
1783 :    
1784 :     #
1785 :     # If we are to add notes, append the other subsystem's notes text.
1786 :     #
1787 :    
1788 :     if ($add_notes)
1789 :     {
1790 :     my $his_notes = $ss->get_notes();
1791 :    
1792 :     $self->{notes} .= "\nNotes copied from $ss->{name}:\n$his_notes\n";
1793 :     }
1794 : olson 1.25 }
1795 : olson 1.17
1796 : olson 1.1 sub dump
1797 :     {
1798 :     my($self) = @_;
1799 :    
1800 :     for my $k (keys(%$self))
1801 :     {
1802 :     next if $k eq "spreadsheet" or $k eq "spreadsheet_inv";
1803 :     print "Key \"$k\": ", Dumper($self->{$k});
1804 :     }
1805 :     }
1806 :    
1807 : olson 1.14 #
1808 :     # Increment the subsystem's version number.
1809 :     #
1810 :     sub incr_version {
1811 :     my($self) = @_;
1812 :    
1813 :     my $dir = $self->{dir};
1814 :     my $vfile = "$dir/VERSION";
1815 :     my($ver);
1816 :    
1817 :     if (open(my $fh,"<$vfile"))
1818 :     {
1819 :     if (defined($ver = <$fh>) && ($ver =~ /^(\S+)/))
1820 :     {
1821 :     $ver = $1;
1822 :     }
1823 :     else
1824 :     {
1825 :     $ver = 0;
1826 :     }
1827 :     close($fh);
1828 :     }
1829 :     else
1830 :     {
1831 :     $ver = 0;
1832 :     }
1833 :    
1834 :     $ver++;
1835 :    
1836 :     open(my $fh, ">$vfile") || die "could not open $vfile";
1837 :     print $fh "$ver\n";
1838 :     close($fh);
1839 :    
1840 :     chmod(0777, $vfile);
1841 :    
1842 :     $self->load_version();
1843 :     }
1844 : olson 1.1
1845 :     sub get_dir_from_name
1846 :     {
1847 :     my($name) = @_;
1848 :    
1849 :     my $b = $name;
1850 :     $b =~ s/ /_/g;
1851 :     my $dir = File::Spec->catfile($FIG_Config::data, 'Subsystems', $b);
1852 :     return $dir;
1853 :     }
1854 :    
1855 : olson 1.12 #
1856 :     # Code for dealing with Bill McCune's prolog code for extending subsystems.
1857 :     #
1858 :     # The code here is a reconstruction of Bill's "go" script in perl with
1859 :     # data pulled from the local SEED configuration.
1860 :     #
1861 :    
1862 :     sub extend_with_billogix
1863 :     {
1864 :     my($self, $muser) = @_;
1865 :     my($isMaster, $user);
1866 :    
1867 :     my $now = time();
1868 :    
1869 :     if ($muser =~ /master:(.*)/)
1870 :     {
1871 :     $isMaster = 1;
1872 :     $user = $1;
1873 :     }
1874 :     else
1875 :     {
1876 :     $isMaster = 0;
1877 :     $user = $muser;
1878 :     }
1879 :    
1880 :     #
1881 :     # Find the executable.
1882 :     #
1883 :    
1884 :     my $exe = "$FIG_Config::bin/billogix";
1885 :    
1886 :     if (! -x $exe)
1887 :     {
1888 :     warn "Cannot find billogix exe at $exe\n";
1889 :     return;
1890 :     }
1891 :    
1892 :     my $ss_name = $self->{name};
1893 : olson 1.18
1894 :     $ss_name =~ s/\s+/_/g;
1895 :    
1896 : olson 1.14 my $ss_dir = "$self->{dir}/";
1897 : olson 1.15 my $assign_dir = "$FIG_Config::data/Assignments/$user/";
1898 : olson 1.12 &FIG::verify_dir($assign_dir);
1899 :    
1900 : olson 1.16 my $when= strftime("%m-%d-%y:%H:%M:%S", localtime($now));
1901 :     my $job_id = "${when}:sss:$ss_name";
1902 :    
1903 : olson 1.12 my $seed = &FIG::cgi_url() . "/";
1904 : olson 1.13 my $export_part = "ssa.cgi?user=$muser&request=delete_or_export_ssa&export=";
1905 : olson 1.12
1906 :     #
1907 :     # Have the prereq stuff, now start up the app.
1908 :     #
1909 :    
1910 :     $ENV{LOCALSZ} = "80000";
1911 :     $ENV{GLOBALSZ} = "80000";
1912 :     $ENV{TRAILSZ} = "30000";
1913 : olson 1.13
1914 :     my $arch = &FIG::get_current_arch();
1915 :    
1916 :     $ENV{BILLOGIX} = "$FIG_Config::fig_disk/dist/releases/current/$arch/lib/Billogix";
1917 :    
1918 :     #
1919 :     # Need to ensure pl2wam is in our path
1920 :     #
1921 :    
1922 :     $ENV{PATH} = "${FIG_Config::ext_bin}:$ENV{PATH}";
1923 : olson 1.12
1924 : olson 1.23 #
1925 :     # We're going to divide the run into $n_chunks chunks.
1926 :     #
1927 :    
1928 :     my $n_chunks = 10;
1929 :    
1930 :     my($log);
1931 :     open($log, ">$ss_dir/$job_id.log");
1932 :    
1933 :     for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
1934 :     {
1935 :     my $app_input = <<EOINP;
1936 : olson 1.12 ['\$BILLOGIX/top'].
1937 :     loadup.
1938 : olson 1.23 asserta(part($this_chunk, $n_chunks)).
1939 : olson 1.12 asserta(url_default_seed('$seed')).
1940 : olson 1.13 asserta(url_export_part('$export_part')).
1941 : olson 1.12 asserta(ss_directory('$ss_dir')).
1942 :     asserta(assign_directory('$assign_dir')).
1943 :     asserta(job_id('$job_id')).
1944 :     extend_test3('$ss_name').
1945 :     EOINP
1946 :    
1947 : olson 1.23 print STDERR <<EOF;
1948 : olson 1.12 Starting app
1949 :    
1950 : olson 1.23 chunk $this_chunk of $n_chunks
1951 : olson 1.12 ss_name = $ss_name
1952 :     ss_dir = $ss_dir
1953 :     user = $user
1954 :     assign_dir = $assign_dir
1955 :     exe = $exe
1956 : olson 1.13 libdir = $ENV{BILLOGIX}
1957 :     path = $ENV{PATH}
1958 : olson 1.12
1959 :     App input
1960 :     $app_input
1961 :     EOF
1962 :     # feh, put in a block to reset perlmode indentation.
1963 : olson 1.23 {
1964 :     my($app_read, $app_write);
1965 :    
1966 :     #
1967 :     # Start the actual application with stdin and stdout redirected
1968 :     # to pipes.
1969 :     #
1970 :     # We write $app_input to the stdin pipe, and close it.
1971 :     # Then loop reading stdout, logging that output.
1972 :     #
1973 :     my $pid = open2($app_read, $app_write, $exe);
1974 :    
1975 :     if (!$pid)
1976 :     {
1977 :     warn "open2 $exe failed: $!\n";
1978 :     print $log "open2 $exe failed: $!\n";
1979 :     return;
1980 :     }
1981 :    
1982 :     print $app_write $app_input;
1983 :     close($app_write);
1984 :    
1985 :     #
1986 :     # Set autoflush on the logfile.
1987 :     #
1988 :    
1989 :     my $old = select($log);
1990 :     $| = 1;
1991 :     select(STDERR);
1992 :     $| = 1;
1993 :     select($old);
1994 :    
1995 :     warn "Starting $exe with pid $pid\n";
1996 :     print $log "Starting $exe with pid $pid\n";
1997 :    
1998 :     while (<$app_read>)
1999 :     {
2000 :     print STDERR $_;
2001 :     print $log $_;
2002 :     }
2003 :    
2004 :     print STDERR "App done\n";
2005 :     print $log "App done\n";
2006 :    
2007 :     close($app_read);
2008 :    
2009 :     my $ret = waitpid($pid, 0);
2010 :     my $stat = $?;
2011 :     print STDERR "Return status is $?\n";
2012 :     print $log "Return status is $?\n";
2013 :    
2014 :     #
2015 :     # This chunk has finished. We should see a file
2016 :     # rows.$this_chunk.$n_chunks.
2017 :     #
2018 :     }
2019 :     }
2020 :     #
2021 :     # At this point, the extension is finished (we've run the
2022 :     # $n_chunks parts of the extension job).
2023 :     #
2024 : olson 1.12
2025 : olson 1.14 #
2026 : olson 1.23 # We read in all the individual rows files, writing the single
2027 :     # concatenation of rows.
2028 : olson 1.14 #
2029 : olson 1.12
2030 : olson 1.23 my $ssaD = $self->{dir};
2031 :    
2032 :     my $rows_file = "$ssaD/rows";
2033 :    
2034 :     my $rowFH;
2035 :     if (!open($rowFH, ">$rows_file"))
2036 : olson 1.12 {
2037 : olson 1.23 my $err = "Cannot open rows file $ssaD/rows for writing: $!\n";
2038 :     print STDERR $err;
2039 :     print $log $err;
2040 : olson 1.12 return;
2041 :     }
2042 :    
2043 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2044 :     {
2045 :     my $chunkFH;
2046 :     my $cfile = "$ssaD/rows.$this_chunk.$n_chunks";
2047 :     if (!open($chunkFH, "<$cfile"))
2048 :     {
2049 :     my $err = "Cannot open rows file $cfile for reading: $!\n";
2050 :     print STDERR $err;
2051 :     print $log $err;
2052 :     return;
2053 :     }
2054 :     while (<$chunkFH>)
2055 :     {
2056 :     print $rowFH $_;
2057 :     }
2058 :     close($chunkFH);
2059 :     }
2060 :     close($rowFH);
2061 : olson 1.12
2062 :     #
2063 : olson 1.23 # Concatenate the assignments into the assignment directory.
2064 : olson 1.12 #
2065 :    
2066 : olson 1.23 my $assignments_file = "$assign_dir$job_id";
2067 :     my $assignFH;
2068 : olson 1.12
2069 : olson 1.23 if (!open($assignFH, ">$assignments_file"))
2070 : olson 1.12 {
2071 : olson 1.23 my $err = "Cannot open assignments file $assignments_file for writing: $!\n";
2072 :     print STDERR $err;
2073 :     print $log $err;
2074 :     return;
2075 : olson 1.12 }
2076 :    
2077 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2078 : olson 1.19 {
2079 : olson 1.23 my $aFH;
2080 :     my $afile = "$ssaD/assignments.$this_chunk.$n_chunks";
2081 :     if (!open($aFH, "<$afile"))
2082 :     {
2083 :     my $err = "Cannot open assignments file $afile for reading: $!\n";
2084 :     print STDERR $err;
2085 :     print $log $err;
2086 :     return;
2087 :     }
2088 :     while (<$aFH>)
2089 :     {
2090 :     print $assignFH $_;
2091 :     }
2092 :     close($aFH);
2093 : olson 1.19 }
2094 : olson 1.23 close($assignFH);
2095 : olson 1.19
2096 : olson 1.23
2097 :    
2098 : olson 1.19 #
2099 : olson 1.14 # Back up the spreadsheet, and append the rows file to it.
2100 :     #
2101 :    
2102 :     &FIG::verify_dir("$ssaD/Backup");
2103 :     my $ts = time;
2104 :     rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
2105 :     copy("$ssaD/spreadsheet","$ssaD/spreadsheet~");
2106 :     rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
2107 :    
2108 :     #
2109 :     # Append the new rows to the spreadsheet.
2110 :     #
2111 :    
2112 :     my($ssafh, $rowsfh);
2113 :     open($ssafh, ">>$ssaD/spreadsheet") or die "Cannot open $ssaD/spreadsheet for append: $!\n";
2114 :     open($rowsfh, "<$ssaD/rows") or die "Cannot open $ssaD/rows for reading: $!\n";
2115 :    
2116 :     while (<$rowsfh>)
2117 :     {
2118 :     print $ssafh $_;
2119 :     }
2120 :     close($ssafh);
2121 :     close($rowsfh);
2122 :    
2123 :     $self->incr_version();
2124 : olson 1.12 }
2125 : olson 1.13
2126 : olson 1.14
2127 : olson 1.13 sub set_current_extend_pid
2128 :     {
2129 :     my($self, $pid) = @_;
2130 :    
2131 :     if (open(my $fh, ">$self->{dir}/EXTEND_PID"))
2132 :     {
2133 :     print $fh "$pid\n";
2134 :     }
2135 :     else
2136 :     {
2137 :     warn "Cannot open $self->{dir}/EXTEND_PID: $!\n";
2138 :     }
2139 :     }
2140 :    
2141 :     sub get_current_extend_pid
2142 :     {
2143 :     my($self) = @_;
2144 :    
2145 :     if (open(my $fh, "<$self->{dir}/EXTEND_PID"))
2146 :     {
2147 :     my $pid = <$fh>;
2148 :     close($fh);
2149 :     if ($pid)
2150 :     {
2151 :     chomp $pid;
2152 :    
2153 :     return $pid;
2154 :     }
2155 :     }
2156 :     return undef;
2157 :     }
2158 : olson 1.12
2159 : olson 1.7 package Subsystem::Diagram;
2160 :    
2161 :     sub new
2162 :     {
2163 :     my($class, $sub, $fig, $name, $dir) = @_;
2164 :    
2165 :     if (!-d $dir)
2166 :     {
2167 :     return undef;
2168 :     }
2169 :    
2170 :     my $self = {
2171 :     fig => $fig,
2172 :     subsystem => $sub,
2173 :     name => $name,
2174 :     dir =>$ dir,
2175 :     };
2176 :     bless $self, $class;
2177 :    
2178 :     $self->load();
2179 :    
2180 :     return $self;
2181 :     }
2182 :    
2183 :     #
2184 :     # Parse the diagram into internal data structure.
2185 :     #
2186 :    
2187 :     sub load
2188 :     {
2189 :     my($self) = @_;
2190 :    
2191 :     $self->load_area();
2192 :     }
2193 :    
2194 :     sub load_area
2195 :     {
2196 :     my($self) = @_;
2197 :     my $fh;
2198 :    
2199 : olson 1.8 if (!open($fh, "<$self->{dir}/area_table"))
2200 : olson 1.7 {
2201 : olson 1.8 warn "Could not load $self->{dir}/area_table: $!\n";
2202 : olson 1.7 return;
2203 :     }
2204 :    
2205 :     $self->{areas} = [];
2206 :    
2207 :     my $area_list = $self->{areas};
2208 :    
2209 :     while (<$fh>)
2210 :     {
2211 :     chomp;
2212 :     s/#.*$//;
2213 :     s/^\s+//;
2214 :     s/\s+$//;
2215 :     next if $_ eq '';
2216 :     my ($area, $tag, $value) = split(/\s+/, $_, 3);
2217 :     # print "area=$area tag=$tag value=$value\n";
2218 :    
2219 :     push(@$area_list, [$area, $tag, $value]);
2220 :    
2221 :     #
2222 :     # Do a little checking.
2223 :     #
2224 :    
2225 :     if ($tag eq "role")
2226 :     {
2227 :     my $idx = $self->{subsystem}->get_role_index($value);
2228 :     if (!defined($idx))
2229 :     {
2230 :     warn "Role not found for \"$value\" in subsystem $self->{subsystem}->{name}\n";
2231 :     }
2232 :     }
2233 :     }
2234 :     close($fh);
2235 :     }
2236 :    
2237 :     sub get_areas
2238 :     {
2239 :     my($self) = @_;
2240 :    
2241 :     return @{$self->{areas}};
2242 :     }
2243 :    
2244 : olson 1.1 1;
2245 : olson 1.7
2246 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3