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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1 package Subsystem;
2 :    
3 : olson 1.25 use Carp;
4 : olson 1.1 use FIG;
5 :    
6 : olson 1.10 use FIGAttributes;
7 :     use base 'FIGAttributes';
8 :    
9 : olson 1.12 use POSIX;
10 : olson 1.7 use DirHandle;
11 : olson 1.1 use Data::Dumper;
12 : olson 1.14 use File::Copy;
13 : olson 1.1 use File::Spec;
14 : olson 1.12 use IPC::Open2;
15 : olson 1.1
16 :     use strict;
17 :    
18 : olson 1.2 =pod
19 :    
20 :     =head1 Subsystem manipulation.
21 :    
22 :     Any manipulation of subsystem data should happen through this interface.
23 : parrello 1.60 This allows us to assure ourselves that the relational tables that
24 :     mirror and index the subsystem data are kept up to date with the
25 : olson 1.2 canonical version of the subsystem information in the flat-files
26 :     kept in $FIG_Config::data/Subsystems.
27 :    
28 : olson 1.25 =head2 Objects.
29 :    
30 :     We define the following perl objects:
31 :    
32 :     Subsystem: represents a subsystem. It can be read from disk and
33 :     written to disk, and manipulated via its methods when in memory.
34 :    
35 :     If we were completely on the OO side of the world, we would also
36 :     define the following set of objects. However, we are not, so they are
37 :     only objects in a conceptual sense. They are implemented using the
38 : parrello 1.60 basic perl datatypes.
39 : olson 1.25
40 :     Role: represents a single role. A role has a name and an abbreviation.
41 :    
42 :     RoleSubset: represents a subset of available roles. A subset has a
43 :     name and a list of role names that comprise the subset.
44 :    
45 : olson 1.2 =head2 Thoughts on locking
46 :    
47 :     It is currently dangerous for multiple users to modify spreadsheets at once.
48 :     It will likely remain dangerous while the subsystem backend is fairly
49 :     stateless, as it is with the CGI mechanism.
50 :    
51 :     We'd like to make this a little safer. One mechanism might be to allow
52 :     a user to open a subsystem for modification, and others for readonly access.
53 :     For this to work we have to be able to tell which users is allowed; current
54 :     implementation uses the curator of the subsystem for this purpose.
55 :    
56 :     NB: This module does not currently attempt to handle locking or exclusion.
57 :     It is up to the caller (user application, CGI script, etc) to do so.
58 :     It does attempt to use locking internally where appropriate.
59 :    
60 :     =head2 Data structures
61 :    
62 :     We maintain the following data structures (all members of %$self).
63 :    
64 :     =over 4
65 :    
66 :     =item dir
67 :    
68 :     Directory in which the subsystem is stored.
69 :    
70 :     =item notes
71 :    
72 :     The current notes contents for the subsystem
73 :    
74 :     =item version
75 :    
76 :     Current subsystem version.
77 :    
78 :     =item exchangable
79 :    
80 :     1 if subsystem is exchangable, 0 otherwise.
81 :    
82 :     =item roles
83 :    
84 : olson 1.25 List of role names.
85 : olson 1.2
86 :     =item role_index
87 :    
88 :     hash that maps from role name to index
89 :    
90 :     =item role_abbrs
91 :    
92 :     list of role abbreviations
93 :    
94 :     =item abbr
95 :    
96 :     hash mapping from role abbreviation to role name
97 :    
98 :     =item col_subsets
99 :    
100 :     list of column subset names
101 :    
102 :     =item col_subset_members
103 :    
104 :     hash that maps from column subset name to subset members
105 :    
106 :     =item col_active_subset
107 :    
108 :     currently-active column subset
109 :    
110 :     =item row_active_subset
111 :    
112 :     currently-active row subset
113 :    
114 :     =item genome
115 :    
116 : olson 1.25 List of genome IDs.
117 : olson 1.2
118 :     =item variant_code
119 :    
120 : olson 1.25 List of variant codes.
121 : olson 1.2
122 :     =item genome_index
123 :    
124 :     Hash mapping from genome ID to genome index.
125 :    
126 :     =item spreadsheet
127 :    
128 :     Spreadsheet data. Structured as a list of rows, each of which
129 :     is a list of entries. An entry is a list of PEG numbers.
130 :    
131 :     =item spreadsheet_inv
132 :    
133 :     Inverted structure of spreadsheet - list of columns, each of which is a list
134 :     of rows.
135 :    
136 :     =back
137 :    
138 : olson 1.25 =head2 Methods
139 :    
140 :     =over 4
141 :    
142 :     =item index_cell
143 :    
144 :     Create the subsystem_index entries for the given cell.
145 :     (NEW).
146 :    
147 :     =item delete_role(name)
148 :    
149 :     Delete the given role.
150 :    
151 :     =item add_role(name, abbr)
152 :    
153 :     Add a new role.
154 :    
155 :     =item get_subset(name)
156 :    
157 : overbeek 1.31 A deprecated form of get_subsetC
158 :    
159 :     =item get_subsetC(name)
160 :    
161 : olson 1.25 Returns a given subset. A subset is an object, implemented as a blessed array
162 :     of roles.
163 :    
164 :     =item add_genome(genome_id, variant_code)
165 :    
166 :     =item remove_genome(genome_id)
167 :    
168 :     =back
169 :    
170 : olson 1.2 =cut
171 : olson 1.1
172 :     =pod
173 :    
174 :     =head1 Subsystem constructor
175 :    
176 :     usage: $sub = Subsystem->new("subsystem name", $fig, $createFlag)
177 :    
178 :     Load the subsystem. If it does not exist, and $createFlag is true, create
179 :     a new empty subsystem.
180 :    
181 :     =cut
182 :    
183 :     sub new
184 :     {
185 :     my($class, $name, $fig, $create) = @_;
186 :    
187 :     my $ssa_dir = get_dir_from_name($name);
188 :     #
189 :     # For loading, the subsystem directory must already exist.
190 :     #
191 : parrello 1.60
192 : olson 1.25 if (! -d $ssa_dir and not $create)
193 : olson 1.1 {
194 : olson 1.25 # warn "Subsystem $name does not exist\n";
195 :     return undef;
196 : olson 1.1 }
197 : olson 1.56
198 :     $name =~ s/ /_/g;
199 :    
200 : olson 1.1 my $self = {
201 :     dir => $ssa_dir,
202 :     name => $name,
203 :     fig => $fig,
204 :     };
205 :    
206 :     bless($self, $class);
207 :    
208 : olson 1.25 if ($create)
209 :     {
210 :     $self->create_subsystem();
211 :     }
212 :     else
213 :     {
214 :     $self->load();
215 :     }
216 : olson 1.1
217 :     return $self;
218 :     }
219 :    
220 : olson 1.19 sub new_from_dir
221 :     {
222 :     my($class, $dir, $fig) = @_;
223 :    
224 :     my $ssa_dir = $dir;
225 : olson 1.29 my $name = $dir;
226 :     $name =~ s,.*/,,;
227 : olson 1.19
228 :     #
229 :     # For loading, the subsystem directory must already exist.
230 :     #
231 : parrello 1.60
232 : olson 1.19 my $self = {
233 :     dir => $ssa_dir,
234 :     name => $name,
235 :     fig => $fig,
236 :     };
237 :    
238 :     bless($self, $class);
239 :    
240 :     $self->load();
241 :    
242 :     return $self;
243 :     }
244 :    
245 : olson 1.25 =pod
246 :    
247 :     =head2 create_subsystem()
248 :    
249 :     Create a new subsystem. This creates the subsystem directory in the
250 :     correct place ($FIG_Config::data/Subsystems), and populates it with
251 :     the correct initial data.
252 :    
253 :     =cut
254 :    
255 : olson 1.1 sub create_subsystem
256 :     {
257 : olson 1.25 my($self) = @_;
258 :    
259 :     my $dir = $self->{dir};
260 :     my $fig = $self->{fig};
261 :    
262 :     if (-d $dir)
263 :     {
264 :     warn "Not creating: Subsystem directory $dir already exists";
265 :     return;
266 :     }
267 :    
268 :     $fig->verify_dir($dir);
269 :    
270 :     #
271 :     # Initialize empty data structures.
272 :     #
273 : parrello 1.60
274 : olson 1.25 $self->{genome} = [];
275 :     $self->{genome_index} = {};
276 :     $self->{variant_code} = [];
277 :    
278 :     $self->{abbr} = {};
279 :     $self->{role_index} = {};
280 :     $self->{roles} = [];
281 :     $self->{role_abbrs} = [];
282 : olson 1.1
283 : olson 1.25 $self->{spreadsheet} = [];
284 :     $self->{spreadsheet_inv} = [];
285 :    
286 :     $self->{col_subsets} = [];
287 :     $self->{col_subset_members} = {};
288 :    
289 : overbeek 1.31 $self->{row_subsets} = [];
290 :     $self->{row_subset_members} = {};
291 : overbeek 1.35 $self->load_row_subsets();
292 : overbeek 1.31
293 : olson 1.25 $self->{row_active_subset} = "All";
294 :     $self->{col_active_subset} = "All";
295 :    
296 :     $self->{version} = 0;
297 :     $self->{exchangable} = 0;
298 : overbeek 1.45 $self->{classification} = [];
299 : olson 1.25
300 :     $self->write_subsystem();
301 : olson 1.1 }
302 :    
303 : olson 1.5 #
304 : olson 1.7 # Retrieve the diagrams associated with this subsystem.
305 :     #
306 : olson 1.61 # This is done via a lookup into the diagrams directory in the subsystem.
307 : olson 1.7 #
308 : olson 1.61 # Returned is a list of tuples (diagram_id, diagram_name, page_link, img_link).
309 : olson 1.7 #
310 :    
311 :     sub get_diagrams
312 :     {
313 :     my($self) = @_;
314 :    
315 : olson 1.61 opendir(D, "$self->{dir}/diagrams");
316 :     my @ids = grep { not /^\./ and -d "$self->{dir}/diagrams/$_" } readdir(D);
317 :     closedir(D);
318 :    
319 :     my @ret;
320 :    
321 :     for my $id (@ids)
322 :     {
323 :     my(@diag) = $self->get_diagram($id);
324 :    
325 :     if (@diag)
326 :     {
327 :     push(@ret, [$id, @diag]);
328 :     }
329 :     }
330 :    
331 :     return @ret;
332 :     }
333 :    
334 :     sub get_diagram
335 :     {
336 :     my($self, $id) = @_;
337 :    
338 :     my $ddir = "$self->{dir}/diagrams/$id";
339 :    
340 :     return unless -d $ddir;
341 :     my $name = &FIG::file_head("$ddir/NAME", 1);
342 :     $name = $id if $name eq '';
343 : olson 1.66 chomp($name);
344 : olson 1.61
345 :     my $link = $FIG_Config::cgi_base . "subsys_diagram.cgi?ssa=$self->{name}&diagram=$id";
346 :     my $img_link = $FIG_Config::cgi_base . "subsys_diagram.cgi?ssa=$self->{name}&diagram=$id&image=1";
347 :    
348 :     return($name, $link, $img_link);
349 :     }
350 :    
351 : olson 1.66 sub get_diagram_html_file
352 :     {
353 :     my($self, $id) = @_;
354 :    
355 :     my $ddir = "$self->{dir}/diagrams/$id";
356 :    
357 :     return unless -d $ddir;
358 :    
359 :     my $html = "$ddir/diagram.html";
360 :    
361 :     if (-f $html)
362 :     {
363 :     return $html;
364 :     }
365 :     else
366 :     {
367 :     return undef;
368 :     }
369 :     }
370 :    
371 : olson 1.61 sub open_diagram_image
372 :     {
373 :     my($self, $id) = @_;
374 :    
375 :     my $img_base = "$self->{dir}/diagrams/$id/diagram";
376 :    
377 :     my @types = ([".png", "image/png"],
378 : olson 1.62 [".gif", "image/gif"],
379 : olson 1.61 [".jpg", "image/jpeg"]);
380 :    
381 :     for my $tent (@types)
382 :     {
383 :     my($ext, $type) = @$tent;
384 :    
385 :     my $file = "$img_base$ext";
386 :    
387 :     if (open(my $fh, "<$file"))
388 :     {
389 :     return($type, $fh);
390 :     }
391 :     }
392 :    
393 :     return undef;
394 :     }
395 : olson 1.7
396 : olson 1.61 sub delete_diagram
397 :     {
398 :     my($self, $id) = @_;
399 : parrello 1.60
400 : olson 1.61 my $dir = "$self->{dir}/diagrams/$id";
401 : olson 1.7
402 : olson 1.61 if (-d $dir)
403 :     {
404 : olson 1.66 system("rm", "-r", $dir);
405 : olson 1.61 }
406 : olson 1.7 }
407 :    
408 : olson 1.61 sub rename_diagram
409 : olson 1.7 {
410 : olson 1.61 my($self, $id, $new_name) = @_;
411 : olson 1.7
412 : olson 1.61 my $dir = "$self->{dir}/diagrams/$id";
413 : olson 1.7
414 :     if (-d $dir)
415 :     {
416 : olson 1.61 open(F, ">$dir/NAME");
417 :     $new_name =~ s/\n.*$//s;
418 :     print F "$new_name\n";
419 :     close(F);
420 :     }
421 :     }
422 :    
423 :     sub create_new_diagram
424 :     {
425 : olson 1.65 my($self, $fh, $html_fh, $name, $id) = @_;
426 : olson 1.61
427 :     #
428 :     # Get a new id.
429 :     #
430 :    
431 :     my $dir = "$self->{dir}/diagrams";
432 :    
433 :     &FIG::verify_dir($dir);
434 :    
435 :     my $path;
436 :    
437 :     if (defined($id))
438 :     {
439 :     #
440 :     # Ensure this id doesn't already exist.
441 :     #
442 :    
443 :     $path = "$dir/$id";
444 :    
445 :     if (-d $path)
446 :     {
447 :     confess "Diagram id $id already exists in subsystem $self->{name}";
448 :     }
449 :    
450 : olson 1.7 }
451 :     else
452 :     {
453 : olson 1.61 $id = "d01";
454 :    
455 :     while (1)
456 :     {
457 :     $path = "$dir/$id";
458 :     last unless -e $path;
459 :     $id++;
460 :     }
461 :     }
462 :    
463 :     &FIG::verify_dir($path);
464 :    
465 :     if ($name)
466 :     {
467 :     open(F, ">$path/NAME");
468 :     $name =~ s/\n.*$//s;
469 :     print F "$name\n";
470 :     close(F);
471 :     }
472 :    
473 :     #
474 :     # Write the file if we have one.
475 :     #
476 :    
477 :     if ($fh)
478 :     {
479 : olson 1.62 my($ext, $buf);
480 :    
481 :     if (read($fh, $buf, 4096))
482 : olson 1.61 {
483 : olson 1.65 my($ext) = $self->classify_image_type($buf);
484 : olson 1.62 open(D, ">$path/diagram$ext");
485 : olson 1.61 print D $buf;
486 : olson 1.62
487 :     while (read($fh, $buf, 4096))
488 :     {
489 :     print D $buf;
490 :     }
491 :     close(D);
492 : olson 1.61 }
493 :     close($fh);
494 : olson 1.7 }
495 : olson 1.65
496 :     #
497 :     # And write the HTML file if we have one.
498 :     #
499 :     if ($html_fh)
500 :     {
501 :     my $buf;
502 :     open(D, ">$path/diagram.html");
503 :    
504 :     while (read($html_fh, $buf, 4096))
505 :     {
506 :     print D $buf;
507 :     }
508 :     close(D);
509 :     close($html_fh);
510 :     }
511 : olson 1.7 }
512 : parrello 1.60
513 : olson 1.65 sub upload_new_image
514 :     {
515 :     my($self, $id, $fh) = @_;
516 :    
517 : olson 1.67 if (!$fh)
518 :     {
519 :     warn "Subsystem::upload_new_image aborting: fh is undef\n";
520 :     return;
521 :     }
522 :    
523 : olson 1.65
524 :     my $dir = "$self->{dir}/diagrams/$id";
525 :    
526 : olson 1.67 if (not -d $dir)
527 :     {
528 :     warn "Subsystem::upload_new_image aborting: $dir does not exist\n";
529 :     return;
530 :     }
531 : olson 1.65
532 :     #
533 :     # remove any old diagram images.
534 :     #
535 :    
536 :     for my $path (<$dir/diagram.{png,gif,jpg}>)
537 :     {
538 :     unlink($path);
539 :     }
540 :    
541 :     my($ext, $buf);
542 :    
543 :     if (read($fh, $buf, 4096))
544 :     {
545 :     my($ext) = $self->classify_image_type($buf);
546 : olson 1.67
547 :     if (!open(D, ">$dir/diagram$ext"))
548 :     {
549 :     warn "Subsystem::upload_new_image open failed for $dir/diagram$ext: $!\n";
550 :     close($fh);
551 :     return;
552 :     }
553 :    
554 :     warn "Subsystem::upload_new_image classified new image as $ext\n";
555 : olson 1.65 print D $buf;
556 :    
557 :     while (read($fh, $buf, 4096))
558 :     {
559 :     print D $buf;
560 :     }
561 :     close(D);
562 :     }
563 : olson 1.67 else
564 :     {
565 :     warn "Subsystem::upload_new_image read failed for $fh: $!\n";
566 :     }
567 :    
568 :     warn "Subsystem::upload_new_image complete: " . `/bin/ls -l '$dir'`;
569 :    
570 : olson 1.65 close($fh);
571 :     }
572 :    
573 :     sub upload_new_html
574 :     {
575 :     my($self, $id, $fh) = @_;
576 :    
577 : olson 1.67 if (!$fh)
578 :     {
579 :     warn "Subsystem::upload_new_html aborting: fh is undef\n";
580 :     return;
581 :     }
582 : olson 1.65
583 :     my $dir = "$self->{dir}/diagrams/$id";
584 :    
585 : olson 1.67 if (not -d $dir)
586 :     {
587 :     warn "Subsystem::upload_new_html aborting: $dir does not exist\n";
588 :     return;
589 :     }
590 : olson 1.65
591 :     my($buf);
592 :    
593 : olson 1.67 if (!open(D, ">$dir/diagram.html"))
594 :     {
595 :     warn "Subsystem::upload_new_html open failed for $dir/diagram.html: $!\n";
596 :     return;
597 :     }
598 : olson 1.65
599 : olson 1.67 my $rc;
600 :     while ($rc = read($fh, $buf, 4096))
601 : olson 1.65 {
602 :     print D $buf;
603 :     }
604 : olson 1.67 if (!defined($rc))
605 :     {
606 :     warn "Subsystem::upload_new_html read failed for $fh: $!\n";
607 :     }
608 :    
609 :     warn "Subsystem::upload_new_html complete: " . `/bin/ls -l '$dir'`;
610 :    
611 : olson 1.65 close(D);
612 :     close($fh);
613 :     }
614 :    
615 :     sub classify_image_type
616 :     {
617 :     my($self, $buf) = @_;
618 :    
619 :     my $ext;
620 :    
621 :     #
622 :     # Determine file type, for PNG / JPG / GIF. If we could be assured
623 :     # the ImageMagick identify app worked properly, we'd use that instead.
624 :     #
625 :     # Maybe later.
626 :     #
627 :    
628 :     if (substr($buf, 0, 8) eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a")
629 :     {
630 :     $ext = ".png";
631 :     }
632 :     elsif (substr($buf, 0, 3) eq "GIF")
633 :     {
634 :     $ext = ".gif";
635 :     }
636 :     elsif (substr($buf, 0, 2) eq "\xff\xd8" and substr($buf, 6, 4) eq "JFIF")
637 :     {
638 :     $ext = ".jpg";
639 :     }
640 :     else
641 :     {
642 :     warn "Unknown file type in new diagram\n";
643 :     $ext = ".png";
644 :     }
645 :    
646 :     return $ext;
647 :     }
648 :    
649 :    
650 : olson 1.7 #
651 : olson 1.5 # Synchronize the database index for this subsystem to the
652 :     # subsystem data.
653 :     #
654 :     # We assume the table already exists.
655 : parrello 1.60 #
656 : olson 1.5
657 :     sub db_sync
658 :     {
659 :     my($self, $skip_delete) = @_;
660 :    
661 :     my $rdbH = $self->{fig}->db_handle();
662 :    
663 :     if (!$skip_delete)
664 :     {
665 : olson 1.25 $self->delete_indices();
666 : olson 1.5 }
667 :    
668 : olson 1.57 my $tmp = "$FIG_Config::temp/ixsub.$$";
669 :     open(TMP, ">$tmp") or die "Cannot open tmpfile $tmp: $!\n";
670 :    
671 : olson 1.5 #
672 :     # We run thru all the cells, writing an entry in the database for the peg/subsystem/role.
673 :     #
674 :    
675 : olson 1.57 # my $sth = $rdbH->{_dbh}->prepare("INSERT INTO subsystem_index values(?, ?, ?)");
676 : olson 1.6
677 : olson 1.5 for my $role ($self->get_roles())
678 :     {
679 :     my $ridx = $self->get_role_index($role);
680 :     my $col = $self->get_col($ridx);
681 :     for my $cell (@$col)
682 :     {
683 :     if ($cell)
684 :     {
685 :     for my $peg (@$cell)
686 :     {
687 : olson 1.57 # $sth->execute($peg, $self->{name}, $role);
688 : overbeek 1.63 print TMP "$peg\t$self->{name}\t$role\n";
689 : olson 1.5 }
690 :     }
691 :     }
692 :     }
693 : olson 1.57 close(TMP);
694 :     $rdbH->load_table(file => $tmp,
695 :     tbl => 'subsystem_index');
696 : olson 1.5 }
697 :    
698 : olson 1.22 #
699 :     # Delete this subsystem's entries from the database index.
700 :     #
701 :     sub delete_indices
702 :     {
703 :     my($self) = @_;
704 :    
705 :     my $rdbH = $self->{fig}->db_handle();
706 :    
707 :     $rdbH->SQL("DELETE FROM subsystem_index where subsystem = '$self->{name}'")
708 :     }
709 :    
710 : olson 1.1 sub load
711 :     {
712 :     my($self) = @_;
713 :    
714 :     #
715 :     # Load the subsystem.
716 :     #
717 :    
718 :     my $ssa;
719 :     if (!open($ssa,"<$self->{dir}/spreadsheet"))
720 :     {
721 :     warn "Spreadsheet does not exist in subsystem\n";
722 :     return;
723 :     }
724 :    
725 :     local $/ = "//\n";
726 :    
727 :     my $roles = <$ssa>;
728 :     if ($roles)
729 :     {
730 :     $roles =~ s,$/$,,;
731 :     #
732 :     # Split on newline, filter for non-empty lines.
733 :     #
734 :     my @roles = split("\n", $roles);
735 : parrello 1.60
736 : olson 1.1 @roles = grep { $_ ne "" } @roles;
737 : parrello 1.60
738 : olson 1.1 $self->load_roles(@roles);
739 :     }
740 :    
741 :     my $subsets = <$ssa>;
742 :     if ($subsets)
743 :     {
744 :     $subsets =~ s,$/$,,;
745 :     $self->load_subsets($subsets);
746 :     }
747 :    
748 :     $/ = "\n";
749 :    
750 : overbeek 1.35 $self->load_row_subsets();
751 : olson 1.1 $self->load_genomes($ssa);
752 :    
753 :     #
754 :     # Now load the rest of the info.
755 :     #
756 :    
757 : overbeek 1.58 $self->load_reactions();
758 : olson 1.1 $self->load_notes();
759 : redwards 1.44 $self->load_classification();
760 : olson 1.1 $self->load_version();
761 :     $self->load_exchangable();
762 : olson 1.17 $self->load_curation();
763 : olson 1.1 }
764 :    
765 :     sub load_notes
766 :     {
767 :     my($self) = @_;
768 :    
769 :     $self->{notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "notes"));
770 :     }
771 :    
772 : overbeek 1.58 sub load_reactions
773 :     {
774 :     my($self) = @_;
775 :    
776 :     my $reactions = undef;
777 :     if (open(REACT,"<$self->{dir}/reactions"))
778 :     {
779 :     while (defined($_ = <REACT>))
780 :     {
781 :     if ($_ =~ /^(\S.*\S)\t(\S+)/)
782 :     {
783 : overbeek 1.59 push(@{$reactions->{$1}},split(/,\s*/,$2));
784 : overbeek 1.58 }
785 :     }
786 :     close(REACT);
787 :     }
788 :    
789 :     $self->{reactions} = $reactions;
790 :     }
791 :    
792 :    
793 :    
794 :    
795 : redwards 1.44 sub load_classification
796 :     {
797 :     my($self) = @_;
798 :    
799 :     my $class = &FIG::file_read(File::Spec->catfile($self->{dir}, "CLASSIFICATION"));
800 :     if ($class) {$self->{classification} = [split /\t/, $class]} else {$self->{classification} = ['', '', '']}
801 :     }
802 :    
803 : olson 1.17 sub load_curation
804 :     {
805 :     my($self) = @_;
806 :    
807 : overbeek 1.47 # my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "curation.log"), 1);
808 :     #
809 :     # $_ = $l[0];
810 :     # chomp;
811 : olson 1.17
812 : overbeek 1.47 if (open(LOG,"<$self->{dir}/curation.log"))
813 : olson 1.17 {
814 : overbeek 1.47 while (defined($_ = <LOG>))
815 :     {
816 :     if (/^\d+\t(\S+)\s+started/)
817 :     {
818 :     $self->{curator} = $1;
819 :     }
820 :     }
821 :     close(LOG);
822 : olson 1.17 }
823 :     }
824 :    
825 : olson 1.1 sub load_version
826 :     {
827 :     my($self) = @_;
828 :    
829 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "VERSION"), 1);
830 :     my $l = $l[0];
831 :     chomp $l;
832 :     $self->{version} = $l;
833 :     }
834 :    
835 :     sub load_exchangable
836 :     {
837 :     my($self) = @_;
838 :    
839 :     my $file = File::Spec->catfile($self->{dir}, "EXCHANGABLE");
840 :    
841 :     if (-f $file)
842 :     {
843 :     my($l, @l);
844 :    
845 :     @l = &FIG::file_head($file, 1);
846 :     $l = $l[0];
847 :     chomp $l;
848 :     $self->{exchangable} = $l;
849 :     }
850 :     else
851 :     {
852 :     $self->{exchangable} = 0;
853 :     }
854 :     }
855 :    
856 :    
857 :     sub load_roles
858 :     {
859 :     my($self, @roles) = @_;
860 :    
861 : olson 1.5 $self->{abbr} = {};
862 :     $self->{role_index} = {};
863 :     $self->{roles} = [];
864 :     $self->{role_abbrs} = [];
865 :    
866 : olson 1.25 my $i = 0;
867 : olson 1.1 for my $role (@roles)
868 :     {
869 :     my($abbr, $name) = split(/\t/, $role);
870 : overbeek 1.49 $abbr =~ s/^\s+//;
871 :     $abbr =~ s/\s+$//;
872 :     $name =~ s/^\s+//;
873 :     $name =~ s/\s+$//;
874 : olson 1.2 # print "Role $i: abbr=$abbr name=$name\n";
875 : olson 1.1
876 :     $self->{abbr}->{$abbr} = $name;
877 :     $self->{role_index}->{$name} = $i;
878 :     $self->{roles}->[$i] = $name;
879 : olson 1.4 $self->{role_abbrs}->[$i] = $abbr;
880 : olson 1.1 $i++;
881 :     }
882 :     }
883 : parrello 1.60
884 : olson 1.1 sub load_subsets
885 :     {
886 :     my($self, $subsets) = @_;
887 :    
888 :     #
889 :     # Column and row subsets.
890 :     #
891 :     my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);
892 :    
893 :     #
894 :     # Handle column subsets.
895 :     #
896 :    
897 :     my @subsetsC = split(/\n/, $subsetsC);
898 :    
899 :     #
900 :     # Determine active subset.
901 :     #
902 :    
903 :     my $active_subsetC;
904 :     if (@subsetsC > 0)
905 :     {
906 :     $active_subsetC = pop(@subsetsC);
907 :     }
908 :     else
909 :     {
910 :     $active_subsetC = 'All';
911 :     }
912 :    
913 :     $self->{col_active_subset} = $active_subsetC;
914 :    
915 :     $self->{col_subsets} = [];
916 : olson 1.5 $self->{col_subset_members} = {};
917 : parrello 1.60
918 : olson 1.1 for my $subset (@subsetsC)
919 :     {
920 :     my($name, @members) = split(/\s+/, $subset);
921 :    
922 : olson 1.25 #
923 :     # File format has members 1-based.
924 :     #
925 :    
926 :     @members = map { $_ - 1 } @members;
927 :    
928 : olson 1.1 push(@{$self->{col_subsets}}, $name);
929 :    
930 :     #
931 :     # Map role members from name to index if necessary.
932 :     #
933 :     # Is it really necessary? ssa2 code was looking up in %pos for this.
934 :     #
935 :     @members = map {
936 :     if (my $new = $self->{role_index}->{$_})
937 :     {
938 :     $new;
939 :     }
940 :     else
941 :     {
942 :     $_;
943 :     }
944 :     } @members;
945 :    
946 :     @{$self->{col_subset_members}->{$name}} = @members;
947 :     }
948 :    
949 :     #
950 :     # Now the row subsets.
951 :     #
952 :    
953 :     chomp($subsetsR);
954 :    
955 :     if ($subsetsR =~ /(\S+.*\S+)/)
956 :     {
957 : olson 1.25 $self->{row_active_subset} = $1;
958 : olson 1.1 }
959 :     else
960 :     {
961 : olson 1.25 $self->{row_active_subset} = 'All';
962 : olson 1.1 }
963 : overbeek 1.35 $self->{row_subsets} = [];
964 : olson 1.1 }
965 :    
966 :     sub load_genomes
967 :     {
968 :     my($self, $fh) = @_;
969 :     my(%seen);
970 :    
971 : olson 1.5 $self->{spreadsheet} = [];
972 : olson 1.29 $self->{spreadsheet_inv} = [];
973 : olson 1.5 $self->{genome} = [];
974 :     $self->{genome_index} = {};
975 :     $self->{variant_code} = [];
976 :    
977 : olson 1.25 my $nr = @{$self->{roles}};
978 :    
979 :     my $i = 0;
980 : olson 1.1 while (<$fh>)
981 :     {
982 : overbeek 1.54 next if ($_ =~ /^\/\//);
983 : olson 1.1 chomp;
984 :    
985 : olson 1.25 my($genome, $variant_code, @row) = split(/\t/, $_, $nr + 2);
986 : overbeek 1.46 $variant_code =~ s/ //g;
987 : olson 1.1 next if $seen{$genome};
988 :     $seen{$genome}++;
989 : parrello 1.60
990 : olson 1.25 my $j = 0;
991 : olson 1.1
992 :     $self->{genome}->[$i] = $genome;
993 :     $self->{genome_index}->{$genome} = $i;
994 :     $self->{variant_code}->[$i] = $variant_code;
995 :    
996 : olson 1.25 my $thislen = @row;
997 :    
998 :     # if ($thislen != $nr)
999 :     # {
1000 :     # warn "Genome $genome has wrong column count ($thislen != $nr)\n";
1001 :     # warn "<$_> $genome $variant_code '", join(":", @row), "'\n";
1002 :     # }
1003 :    
1004 :     for my $j (0..$nr - 1)
1005 : olson 1.1 {
1006 : olson 1.25 my $entry = $row[$j];
1007 : olson 1.1 my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
1008 :     $self->{spreadsheet}->[$i]->[$j] = $e2;
1009 :     $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
1010 :     $j++;
1011 :     }
1012 :     $i++;
1013 : parrello 1.60
1014 : olson 1.1 }
1015 :     }
1016 :    
1017 : olson 1.2 =pod
1018 :    
1019 : olson 1.25 =head2 write_subsystem()
1020 :    
1021 :     Write the subsystem to the disk. Updates on-disk data with notes,
1022 :     etc. Perform backups when necessary.
1023 :    
1024 :     =cut
1025 :    
1026 :     sub write_subsystem
1027 :     {
1028 : olson 1.68 my($self, $force_backup) = @_;
1029 : olson 1.25
1030 :     my $dir = $self->{dir};
1031 :     my $fig = $self->{fig};
1032 :    
1033 :     #
1034 :     # We first move the existing spreadsheet and notes files (if present)
1035 :     # to spreadsheet~ and notes~, and current state.
1036 :     #
1037 :    
1038 :     my $ss_file = "$dir/spreadsheet";
1039 :     my $ss_bak = "$dir/spreadsheet~";
1040 :     my $notes_file = "$dir/notes";
1041 :     my $notes_bak = "$dir/notes~";
1042 : overbeek 1.58 my $reactions_file = "$dir/reactions";
1043 :     my $reactions_bak = "$dir/reactions~";
1044 : redwards 1.44 my $classification_file = "$dir/CLASSIFICATION";
1045 : olson 1.25
1046 :     if (-f $ss_file)
1047 :     {
1048 :     rename($ss_file, $ss_bak);
1049 :     }
1050 :    
1051 :     if (-f $notes_file)
1052 :     {
1053 :     rename($notes_file, $notes_bak);
1054 :     }
1055 :    
1056 : overbeek 1.58 if (-f $reactions_file)
1057 :     {
1058 :     rename($reactions_file, $reactions_bak) or warn "rename $reactions_file $reactions_bak failed $!";
1059 : overbeek 1.59 # print STDERR "wrote $reactions_bak\n";
1060 : overbeek 1.58 }
1061 :    
1062 : olson 1.25 #
1063 :     # Eval this whole chunk, so that if we get any fatal errors, we can
1064 :     # roll back to the old saved data.
1065 :     #
1066 : parrello 1.60
1067 : olson 1.25 eval {
1068 :     my $fh;
1069 :     open($fh, ">$ss_file") or die "Cannot open $ss_file for writing: $!\n";
1070 :     $self->write_spreadsheet($fh);
1071 :     close($fh);
1072 : overbeek 1.31 chmod(0777,$ss_file);
1073 : olson 1.25
1074 :     open($fh, ">$notes_file") or die "Cannot open $notes_file for writing: $!\n";
1075 :     print $fh "$self->{notes}\n";
1076 :     close($fh);
1077 : overbeek 1.31 chmod(0777,$notes_file);
1078 : olson 1.25
1079 : overbeek 1.58 open($fh, ">$reactions_file") or die "Cannot open $reactions_file for writing: $!\n";
1080 :     my $reactions = $self->{reactions};
1081 :     foreach $_ (sort keys(%$reactions))
1082 :     {
1083 :     print $fh "$_\t" . join(",", @{$reactions->{$_}}), "\n";
1084 :     }
1085 :     close($fh);
1086 :     chmod(0777,$reactions_file);
1087 :    
1088 : redwards 1.44 open($fh, ">$classification_file") or die "Can not open $classification_file for writing: $!\n";
1089 :     print $fh join "\t", (@{$self->{classification}}), "\n";
1090 :     close($fh);
1091 :     chmod(0777,$classification_file);
1092 :    
1093 : olson 1.25 $self->update_curation_log();
1094 :    
1095 :     #
1096 :     # Write out the piddly stuff.
1097 :     #
1098 :    
1099 :     open($fh, ">$dir/EXCHANGABLE") or die "Cannot write $dir/EXCHANGABLE: $!\n";
1100 :     print $fh "$self->{exchangable}\n";
1101 :     close($fh);
1102 : overbeek 1.31 chmod(0777,"EXCHANGABLE");
1103 : olson 1.25
1104 :     #
1105 :     # Process backup files. This is the smae process that determines when the
1106 :     # version number should be bumped, so write the version file afterward.
1107 :     #
1108 :    
1109 : olson 1.68 $self->update_backups($force_backup);
1110 : olson 1.25
1111 : overbeek 1.37 if ($self->{version} < 100) { $self->{version} += 100 }
1112 :     open($fh, ">$dir/VERSION") or die "Cannot write $dir/VERSION: $!\n";
1113 :     print $fh "$self->{version}\n";
1114 : olson 1.25 close($fh);
1115 : overbeek 1.31 chmod(0777,"VERSION");
1116 : olson 1.25 };
1117 :    
1118 :     if ($@ ne "")
1119 :     {
1120 :     warn "Spreadsheet write failed, reverting to backup. Error was\n$@\n";
1121 :     }
1122 : parrello 1.60
1123 : olson 1.25 }
1124 :    
1125 :     sub update_curation_log
1126 :     {
1127 :     my($self) = @_;
1128 :    
1129 :     my $fh;
1130 :     my $file = "$self->{dir}/curation.log";
1131 :    
1132 :     my $now = time;
1133 :     my $user = $self->{fig}->get_user();
1134 :    
1135 :     if (-f $file)
1136 :     {
1137 :     open($fh, ">>$file") or die "Cannot open $file for writing: $!\n";
1138 :     }
1139 :     else
1140 :     {
1141 :     open($fh, ">$file") or die "Cannot open $file for writing: $!\n";
1142 :     print $fh "$now\t$user\tstarted\n";
1143 :     }
1144 :     print $fh "$now\t$user\tupdated\n";
1145 :     close($fh);
1146 :     }
1147 :    
1148 :     sub update_backups
1149 :     {
1150 : olson 1.68 my($self, $force_backup) = @_;
1151 : olson 1.25
1152 :     my $dir = $self->{dir};
1153 :     my $fig = $self->{fig};
1154 :    
1155 :     my $ss_file = "$dir/spreadsheet";
1156 :     my $ss_bak = "$dir/spreadsheet~";
1157 :     my $notes_file = "$dir/notes";
1158 :     my $notes_bak = "$dir/notes~";
1159 : overbeek 1.58 my $reactions_file = "$dir/reactions";
1160 :     my $reactions_bak = "$dir/reactions~";
1161 : olson 1.25
1162 :     my $ss_diff = abs((-s $ss_file) - (-s $ss_bak));
1163 :     my $notes_diff = abs((-s $notes_file) - (-s $notes_bak));
1164 : olson 1.68 my $reactions_diff = (system("cmp", "-s", $reactions_file, $reactions_bak) != 0);
1165 : overbeek 1.59 # print STDERR "reactions_file=$reactions_file reactions_bak=$reactions_bak dif=$reactions_diff\n";
1166 : olson 1.25
1167 : olson 1.68 if ($force_backup or ($ss_diff > 10) or ($notes_diff > 10) or $reactions_diff)
1168 : olson 1.25 {
1169 :     $self->make_backup();
1170 :     }
1171 :     }
1172 :    
1173 :     sub make_backup
1174 :     {
1175 :     my($self) = @_;
1176 :    
1177 :     my $dir = $self->{dir};
1178 :     my $bak = "$dir/Backup";
1179 :    
1180 :     $self->{fig}->verify_dir($bak);
1181 :    
1182 :     my $ts = time;
1183 :    
1184 :     rename("$dir/spreadsheet~", "$bak/spreadsheet.$ts");
1185 :     rename("$dir/notes~", "$bak/notes.$ts");
1186 : overbeek 1.58 rename("$dir/reactions~", "$bak/reactions.$ts");
1187 : olson 1.25 $self->{version}++;
1188 :     }
1189 :    
1190 :    
1191 :    
1192 :     =pod
1193 :    
1194 :     =head1 write_spreadsheet($fh)
1195 :    
1196 :     Write the spreadsheet for this subsystem to filehandle $fh.
1197 :    
1198 :     =cut
1199 :    
1200 :     sub write_spreadsheet
1201 :     {
1202 :     my($self, $fh) = @_;
1203 :    
1204 :     $self->_write_roles($fh);
1205 :     print $fh "//\n";
1206 :    
1207 :     $self->_write_subsets($fh);
1208 :     print $fh "//\n";
1209 :    
1210 :     $self->_write_spreadsheet($fh);
1211 :     }
1212 :    
1213 :     sub _write_roles
1214 :     {
1215 :     my($self, $fh) = @_;
1216 :    
1217 :     my(@roles, @abbrs);
1218 :    
1219 :     @roles = $self->get_roles();
1220 :     @abbrs = $self->get_abbrs();
1221 :    
1222 :     while (@roles)
1223 :     {
1224 :     my $role = shift(@roles);
1225 :     my $abbr = shift(@abbrs);
1226 :    
1227 :     print $fh "$abbr\t$role\n";
1228 :     }
1229 :     }
1230 :    
1231 :     sub _write_subsets
1232 :     {
1233 :     my($self, $fh) = @_;
1234 :    
1235 : overbeek 1.31 for my $sub ($self->get_subset_namesC())
1236 : olson 1.25 {
1237 : overbeek 1.35 next if ($sub eq "All");
1238 : overbeek 1.31 my @members= $self->get_subsetC($sub);
1239 : olson 1.25
1240 :     #
1241 :     # member list on disk is 1-based
1242 :     #
1243 :    
1244 :     @members = map { $_ + 1 } @members;
1245 :     print $fh join("\t", $sub, @members), "\n";
1246 :     }
1247 : overbeek 1.39 my $active_row_subset = $self->{row_active_subset};
1248 :     my $active_col_subset = $self->{col_active_subset};
1249 :    
1250 :     print $fh "$active_col_subset\n";
1251 : olson 1.25
1252 :     #
1253 :     # separator
1254 :     #
1255 :    
1256 :     print $fh "\n";
1257 : parrello 1.60
1258 : olson 1.25 #
1259 :     # genome subsets.
1260 :     #
1261 :    
1262 : overbeek 1.39 print $fh "$active_row_subset\n";
1263 : olson 1.25 }
1264 :    
1265 :     sub _write_spreadsheet
1266 :     {
1267 :     my($self, $fh) = @_;
1268 :    
1269 :     my(@genomes);
1270 :    
1271 :     @genomes= $self->get_genomes();
1272 :    
1273 :     for (my $i = 0; $i < @genomes; $i++)
1274 :     {
1275 :     my $genome = $genomes[$i];
1276 :     my $vc = $self->get_variant_code($i);
1277 :    
1278 :     my $row = $self->get_row($i);
1279 :    
1280 :     if ($vc eq "")
1281 :     {
1282 :     $vc = "0";
1283 :     }
1284 :     print $fh "$genome\t$vc";
1285 :    
1286 :     for my $entry (@$row)
1287 :     {
1288 :     my(@p);
1289 : parrello 1.60
1290 : olson 1.25 for my $peg (@$entry)
1291 :     {
1292 :     if ($peg =~ /fig\|$genome\.peg\.(\d+)$/)
1293 :     {
1294 :     push(@p, $1);
1295 :     }
1296 :     else
1297 :     {
1298 :     warn "Bad peg $peg in cell for $genome";
1299 :     }
1300 :     }
1301 :     print $fh "\t", join(",", @p);
1302 :     }
1303 :     print $fh "\n";
1304 :     }
1305 :     }
1306 :    
1307 :    
1308 :     =pod
1309 :    
1310 : olson 1.2 =head1 get_genomes
1311 :    
1312 :     =cut
1313 : olson 1.25
1314 : olson 1.2 sub get_genomes
1315 :     {
1316 :     my($self) = @_;
1317 :    
1318 :     my $glist = $self->{genome};
1319 :    
1320 : olson 1.25 return @$glist;
1321 : olson 1.2 }
1322 :    
1323 :     =pod
1324 :    
1325 :     =head1 get_variant_codes
1326 :    
1327 :     =cut
1328 : olson 1.25
1329 : olson 1.2 sub get_variant_codes
1330 :     {
1331 :     my($self) = @_;
1332 :    
1333 :     my $glist = $self->{variant_code};
1334 :    
1335 : olson 1.25 return @$glist;
1336 :     }
1337 :    
1338 :     sub get_variant_code
1339 :     {
1340 :     my($self, $gidx) = @_;
1341 : overbeek 1.46 my $c = $self->{variant_code}->[$gidx];
1342 :     $c =~ s/ //g;
1343 :     return $c;
1344 : olson 1.2 }
1345 :    
1346 : overbeek 1.34 sub set_variant_code
1347 :     {
1348 :     my($self, $gidx, $val) = @_;
1349 :     $self->{variant_code}->[$gidx] = $val;
1350 :     return;
1351 :     }
1352 :    
1353 : olson 1.25
1354 : olson 1.2 sub get_variant_code_for_genome
1355 :     {
1356 :     my($self, $genome) = @_;
1357 :     my $index = $self->{genome_index}->{$genome};
1358 : redwards 1.55 if (defined $index) {
1359 :     return $self->{variant_code}->[$index];
1360 :     }
1361 :     else {
1362 :     return undef;
1363 :     }
1364 : olson 1.2 }
1365 :    
1366 :     sub get_roles
1367 :     {
1368 :     my($self) = @_;
1369 :    
1370 :     my $rlist = $self->{roles};
1371 :    
1372 : olson 1.25 return @$rlist;
1373 :     }
1374 :    
1375 :     sub get_abbrs
1376 :     {
1377 :     my($self) = @_;
1378 :    
1379 :     my $rlist = $self->{role_abbrs};
1380 :    
1381 :     return @$rlist;
1382 : olson 1.2 }
1383 :    
1384 : olson 1.29 sub roles_with_abbreviations
1385 :     {
1386 :     my($self) = @_;
1387 :    
1388 :     my @ret;
1389 :    
1390 :     for my $i (0..@{$self->{roles}} - 1)
1391 :     {
1392 :     push(@ret, [$self->{role_abbrs}->[$i], $self->{roles}->[$i]]);
1393 :     }
1394 :     return @ret;
1395 :     }
1396 :    
1397 :    
1398 : olson 1.52 sub get_sorted_rows
1399 :     {
1400 :     my($self, $sort_order) = @_;
1401 :    
1402 :     my $fig = $self->{fig};
1403 :    
1404 :     my @rows;
1405 :     for (my $i = 0; $i < @{$self->{genome}}; $i++)
1406 :     {
1407 :     my $gid = $self->{genome}->[$i];
1408 :     my $gs = $fig->genus_species($gid);
1409 :    
1410 :     my $q = quotemeta($gid);
1411 :     my $cells = [];
1412 :     for my $c (@{$self->{spreadsheet}->[$i]})
1413 :     {
1414 :     push(@$cells, [map { s/^fig\|$q\.peg\.//; $_ } @$c]);
1415 :     }
1416 :    
1417 :     push(@rows, [$self->{genome}->[$i], $gs, $self->{variant_code}->[$i], $cells]);
1418 :     }
1419 :    
1420 :     if ($sort_order eq "by_phylo")
1421 :     {
1422 :     return(map { $_->[0] }
1423 :     sort { ($a->[1] cmp $b->[1]) or ($a->[0]->[1] cmp $b->[0]->[1]) }
1424 :     map { [$_, $fig->taxonomy_of($_->[0]) ] } @rows);
1425 :     }
1426 :     elsif ($sort_order eq "alphabetic")
1427 :     {
1428 :     return sort { ($a->[1] cmp $b->[1]) or ($a->[0] <=> $b->[0]) } @rows;
1429 :     }
1430 :     elsif ($sort_order eq "by_tax_id")
1431 :     {
1432 :     return sort { $a->[0] <=> $b->[0] } @rows;
1433 :     }
1434 :     else
1435 :     {
1436 :     return @rows;
1437 :     }
1438 :     }
1439 :    
1440 :    
1441 : parrello 1.60 sub get_row :Scalar
1442 : olson 1.1 {
1443 :     my($self, $row) = @_;
1444 :    
1445 :     return $self->{spreadsheet}->[$row];
1446 :     }
1447 :    
1448 : parrello 1.60 sub get_col :Scalar
1449 : olson 1.1 {
1450 :     my($self, $col) = @_;
1451 :    
1452 :     return $self->{spreadsheet_inv}->[$col];
1453 :     }
1454 :    
1455 : parrello 1.60 sub get_cell :Scalar
1456 : olson 1.1 {
1457 :     my($self, $row, $col) = @_;
1458 :    
1459 : olson 1.5 my $cell = $self->{spreadsheet}->[$row]->[$col];
1460 : overbeek 1.37 if (! defined($cell))
1461 :     {
1462 :     $cell = $self->{spreadsheet}->[$row]->[$col] = [];
1463 :     }
1464 : olson 1.5 return $cell;
1465 : olson 1.1 }
1466 :    
1467 : parrello 1.60 sub get_genome_index :Scalar
1468 : olson 1.3 {
1469 :     my($self, $genome) = @_;
1470 :    
1471 :     return $self->{genome_index}->{$genome};
1472 :     }
1473 :    
1474 : parrello 1.60 sub get_genome :Scalar
1475 : olson 1.3 {
1476 :     my($self, $gidx) = @_;
1477 :    
1478 :     return $self->{genome}->[$gidx];
1479 :     }
1480 :    
1481 : parrello 1.60 sub get_role_index :Scalar
1482 : olson 1.5 {
1483 :     my($self, $role) = @_;
1484 :    
1485 :     return $self->{role_index}->{$role};
1486 :     }
1487 :    
1488 : parrello 1.60 sub get_role :Scalar
1489 : olson 1.3 {
1490 :     my($self, $ridx) = @_;
1491 :    
1492 :     return $self->{roles}->[$ridx];
1493 :     }
1494 :    
1495 : parrello 1.60 sub get_role_abbr :Scalar
1496 : olson 1.4 {
1497 :     my($self, $ridx) = @_;
1498 :    
1499 :     return $self->{role_abbrs}->[$ridx];
1500 :     }
1501 :    
1502 : parrello 1.60 sub get_role_from_abbr :Scalar
1503 : olson 1.20 {
1504 :     my($self, $abbr) = @_;
1505 :    
1506 :     return $self->{abbr}->{$abbr};
1507 :     }
1508 :    
1509 : olson 1.26 =pod
1510 :    
1511 :     =head1 set_pegs_in_cell($genome, $role, $peg_list)
1512 :    
1513 :     Set the cell for the given genome and role to $peg_list.
1514 :    
1515 :     =cut
1516 :    
1517 :     sub set_pegs_in_cell
1518 :     {
1519 :     my($self, $genome, $role, $peg_list) = @_;
1520 :     my($row, $col);
1521 :    
1522 :     #
1523 :     # If row isn't numeric, look it up in the genomes list.
1524 :     #
1525 : parrello 1.60
1526 : olson 1.26 if ($genome !~ /^\d+$/)
1527 :     {
1528 :     $row = $self->{genome_index}->{$genome};
1529 :     }
1530 :     else
1531 :     {
1532 :     $row = $genome
1533 :     }
1534 : parrello 1.60
1535 : overbeek 1.37 if (! defined($row))
1536 : olson 1.26 {
1537 : overbeek 1.37 print &Dumper($self->{genome_index});
1538 :     confess "Cannot find row for $genome\n";
1539 : olson 1.26 return undef;
1540 :     }
1541 :    
1542 :     #
1543 :     # If col isn't numeric, look it up in the roles and role abbreviations.
1544 :     #
1545 : parrello 1.60
1546 : olson 1.26 if ($role !~ /^\d+$/)
1547 :     {
1548 :     #
1549 :     # See if it's an abbr
1550 :     #
1551 :    
1552 :     my $a = $self->{abbr}->{$role};
1553 : olson 1.27 $role = $a if $a;
1554 : olson 1.26
1555 :     $col = $self->{role_index}->{$role};
1556 :     }
1557 :     else
1558 :     {
1559 :     $col = $role;
1560 :     }
1561 : parrello 1.60
1562 : overbeek 1.37 if (! defined($col))
1563 : olson 1.26 {
1564 : overbeek 1.38 print &Dumper($self->{role_index});
1565 :     confess "Cannot find col for $role\n";
1566 : olson 1.26 return undef;
1567 :     }
1568 :     my $cell = $self->get_cell($row, $col);
1569 :    
1570 : overbeek 1.37 if (defined($cell))
1571 : olson 1.26 {
1572 : overbeek 1.37 my $peg;
1573 :     my $rdbH = $self->{fig}->db_handle();
1574 : overbeek 1.40 my $roleQ = quotemeta $role;
1575 :    
1576 : overbeek 1.37 if (@$cell > 0)
1577 :     {
1578 :     foreach $peg (@$cell)
1579 :     {
1580 :     $rdbH->SQL("DELETE FROM subsystem_index where ( subsystem = '$self->{name}' ) AND
1581 : overbeek 1.40 ( role = '$roleQ' ) AND
1582 : overbeek 1.37 ( protein = '$peg' )" );
1583 :     }
1584 :     }
1585 : olson 1.26 @$cell = @$peg_list;
1586 : overbeek 1.37 foreach $peg (@$cell)
1587 :     {
1588 : overbeek 1.40 $rdbH->SQL("INSERT INTO subsystem_index (protein,subsystem,role) VALUES ('$peg','$self->{name}','$roleQ' )");
1589 : overbeek 1.37 }
1590 : olson 1.26 }
1591 :     else
1592 :     {
1593 :     warn "set_pegs_in_cell: Could not find cell!";
1594 :     }
1595 :     }
1596 :    
1597 : olson 1.1 sub get_pegs_from_cell
1598 :     {
1599 :     my($self, $rowstr, $colstr) = @_;
1600 :     my($row, $col);
1601 :    
1602 :     #
1603 :     # If row isn't numeric, look it up in the genomes list.
1604 :     #
1605 : parrello 1.60
1606 : olson 1.1 if ($rowstr !~ /^\d+$/)
1607 :     {
1608 :     $row = $self->{genome_index}->{$rowstr};
1609 :     }
1610 :     else
1611 :     {
1612 :     $row = $rowstr;
1613 :     }
1614 : parrello 1.60
1615 : overbeek 1.31 if (! defined($row))
1616 : olson 1.1 {
1617 : overbeek 1.38 print &Dumper($self->{genome_index});
1618 :     confess "Cannot find row for $rowstr\n";
1619 : olson 1.1 return undef;
1620 :     }
1621 :    
1622 :     #
1623 :     # If col isn't numeric, look it up in the roles and role abbreviations.
1624 :     #
1625 : parrello 1.60
1626 : olson 1.1 if ($colstr !~ /^\d+$/)
1627 :     {
1628 :     #
1629 :     # See if it's an abbr
1630 :     #
1631 :    
1632 :     my $a = $self->{abbr}->{$colstr};
1633 :     $colstr = $a if $a;
1634 :    
1635 :     $col = $self->{role_index}->{$colstr};
1636 :     }
1637 :     else
1638 :     {
1639 :     $col = $colstr;
1640 :     }
1641 : overbeek 1.32
1642 : overbeek 1.31 if (! defined($col))
1643 : olson 1.1 {
1644 :     warn "Cannot find col for $colstr\n";
1645 :     return undef;
1646 :     }
1647 : olson 1.12 my $cell = $self->get_cell($row, $col);
1648 : olson 1.1
1649 :     if ($cell)
1650 :     {
1651 :     return @$cell;
1652 :     }
1653 :     else
1654 :     {
1655 :     return undef;
1656 :     }
1657 :     }
1658 :    
1659 : olson 1.25 #
1660 :     # Subset support
1661 :     #
1662 :    
1663 : olson 1.30 sub get_active_subsetC
1664 :     {
1665 :     my($self) = @_;
1666 :    
1667 :     return $self->{col_active_subset};
1668 :     }
1669 :    
1670 :     sub get_active_subsetR
1671 :     {
1672 :     my($self) = @_;
1673 :    
1674 :     return $self->{row_active_subset};
1675 :     }
1676 :    
1677 :     sub set_active_subsetC
1678 :     {
1679 :     my($self, $subset) = @_;
1680 :    
1681 :     $self->{col_active_subset} = $subset;
1682 :     }
1683 :    
1684 :    
1685 :     sub set_active_subsetR
1686 :     {
1687 :     my($self, $subset) = @_;
1688 :    
1689 :     $self->{row_active_subset} = $subset;
1690 :     }
1691 :    
1692 :    
1693 : olson 1.25 sub get_subset_names
1694 : olson 1.17 {
1695 :     my($self) = @_;
1696 : olson 1.25
1697 : overbeek 1.31 return $self->get_subset_namesC;
1698 :     }
1699 :    
1700 :     sub get_subset_namesC
1701 :     {
1702 :     my($self) = @_;
1703 :    
1704 : overbeek 1.35 return ("All",@{$self->{col_subsets}});
1705 : overbeek 1.31 }
1706 :    
1707 :     sub get_subset_namesR
1708 :     {
1709 :     my($self) = @_;
1710 :    
1711 : overbeek 1.35 return ("All",@{$self->{row_subsets}});
1712 : olson 1.17 }
1713 :    
1714 : overbeek 1.33 sub get_subsetC_roles
1715 :     {
1716 :     my($self, $subname) = @_;
1717 :     return map { $self->get_role($_) } $self->get_subsetC($subname);
1718 :     }
1719 :    
1720 : overbeek 1.31 sub get_subsetC
1721 :     {
1722 :     my($self, $subname) = @_;
1723 : overbeek 1.33 if ($subname eq "All") { return map { $self->get_role_index($_) } $self->get_roles }
1724 : overbeek 1.31
1725 : olson 1.52 if (!defined($self->{col_subset_members}->{$subname}))
1726 :     {
1727 :     $self->{col_subset_members}->{$subname} = [];
1728 :     }
1729 : parrello 1.60
1730 : overbeek 1.31 return @{$self->{col_subset_members}->{$subname}};
1731 :     }
1732 :    
1733 : olson 1.25 sub get_subset
1734 : olson 1.17 {
1735 : olson 1.25 my($self, $subname) = @_;
1736 : overbeek 1.33 return $self->get_subsetC($subname);
1737 : overbeek 1.31 }
1738 :    
1739 :     sub get_subsetR
1740 :     {
1741 :     my($self, $subname) = @_;
1742 :     my($pair,$id,$members,$genome);
1743 :    
1744 :     if ($subname eq "All") { return $self->get_genomes }
1745 : overbeek 1.38 my %genomes = map { $_ => 1 } $self->get_genomes;
1746 :    
1747 :     return grep { $genomes{$_} } @{$self->{row_subset_members}->{$subname}};
1748 : overbeek 1.35 }
1749 :    
1750 :     sub load_row_subsets {
1751 :     my($self) = @_;
1752 :     my($id,$members,$pair);
1753 : overbeek 1.31
1754 : overbeek 1.35 my $taxonomic_groups = $self->{fig}->taxonomic_groups_of_complete(10);
1755 :     foreach $pair (@$taxonomic_groups)
1756 : overbeek 1.31 {
1757 : overbeek 1.35 ($id,$members) = @$pair;
1758 :     if ($id ne "All")
1759 : overbeek 1.31 {
1760 :     push(@{$self->{row_subsets}},$id);
1761 :     }
1762 : overbeek 1.35 $self->{row_subset_members}->{$id} = $members;
1763 : overbeek 1.31 }
1764 : olson 1.25 }
1765 :    
1766 : redwards 1.48 =pod
1767 :    
1768 :     =head2 load_row_subsets_by_kv
1769 :    
1770 :     Load a row subset based on a key/value pair. This will take a single key/value pair and only show that subset
1771 :    
1772 :     It is just a modification of load_row_subsets to deal with kv pairs
1773 :    
1774 :     This takes a required argument: the key that the genome must have, and a second optional argument, the value that key must hold.
1775 :    
1776 :     =cut
1777 :    
1778 :     sub load_row_subsets_by_kv {
1779 :     my ($self, $key, $want) = @_;
1780 :     my($id,$members,$pair);
1781 :     my $keep;
1782 :     foreach my $genome (@{$self->{genome}}) {
1783 : redwards 1.50 my @results=$self->{fig}->get_attributes($genome, $key);
1784 :     foreach my $res (@results) {
1785 : redwards 1.51 my ($gotid, $gottag, $value, $url)=@$res;
1786 : redwards 1.50 next if (!$value);
1787 :     next if ($want && $value ne $want);
1788 :     push @$keep, $genome;
1789 :     last;
1790 :     }
1791 : redwards 1.48 }
1792 :     $self->{row_subset_members}->{$key}=$keep;
1793 :     }
1794 : overbeek 1.35
1795 : olson 1.25 =pod
1796 :    
1797 : overbeek 1.31 =head2 set_subsetC($name, $members)
1798 : olson 1.25
1799 :     Create a subset with the given name and members.
1800 :    
1801 :     $members is a list of role names.
1802 :    
1803 :     =cut
1804 :    
1805 : overbeek 1.31 sub set_subsetC
1806 : olson 1.25 {
1807 :     my($self, $subname, $list) = @_;
1808 :    
1809 :     my $nl = [map { $self->get_role_index($_) } @$list];
1810 : parrello 1.60
1811 : olson 1.25 $self->_set_subset($subname, $nl);
1812 :     }
1813 :    
1814 : overbeek 1.31 sub set_subset
1815 :     {
1816 :     my($self, $subname, $list) = @_;
1817 :    
1818 :     $self->set_subsetsC($subname,$list);
1819 :     }
1820 :    
1821 : olson 1.25 =pod
1822 :    
1823 :     =head2 _set_subset($name, $members)
1824 :    
1825 :     Create a subset with the given name and members.
1826 :    
1827 :     Internal version - here, members is a list of role indices.
1828 :    
1829 :     =cut
1830 :    
1831 :     sub _set_subset
1832 :     {
1833 :     my($self, $subname, $list) = @_;
1834 :     $self->{col_subset_members}->{$subname} = $list;
1835 : overbeek 1.37 my($i,$x);
1836 :     $x = $self->{col_subsets};
1837 :     for ($i=0; ($i < @$x) && ($x->[$i] ne $subname); $i++) {}
1838 :     if ($i == @$x)
1839 :     {
1840 :     push(@$x,$subname);
1841 :     }
1842 :     }
1843 : parrello 1.60
1844 : overbeek 1.37 sub delete_subsetC
1845 :     {
1846 :     my($self, $subname) = @_;
1847 :     my($i,$x);
1848 :    
1849 :     $x = $self->{col_subsets};
1850 :     for ($i=0; ($i < @$x) && ($x->[$i] ne $subname); $i++) {}
1851 :     if ($i < @$x)
1852 :     {
1853 :     splice(@$x,$i,1);
1854 :     }
1855 :     delete $self->{col_subset_members}->{$subname};
1856 : olson 1.25 }
1857 : parrello 1.60
1858 : olson 1.25 #
1859 :     # Role manipulation.
1860 :     #
1861 :    
1862 :    
1863 :     =pod
1864 :    
1865 :     =head1 set_roles($role_list)
1866 :    
1867 :     Set the list of roles. C<$role_list> is a list of tuples C<[$role_name, $abbreviation]>.
1868 :    
1869 :     If a role already exists, it is used. If it does not exist, it is created empty.
1870 :    
1871 :     =cut
1872 :    
1873 :     sub set_roles
1874 :     {
1875 :     my($self, $roles) = @_;
1876 :    
1877 :     #
1878 :     # We do this by first creating a new spreadsheet.
1879 :     #
1880 :     # It is easiest to do this by manipulating the inverted spreadsheet
1881 :     # (role-major), and then creating the non-inverted spreadsheet from it.
1882 :     #
1883 :    
1884 :     my $oldss = $self->{spreadsheet};
1885 :     my $oldssinv = $self->{spreadsheet_inv};
1886 :    
1887 :     my $ss = [];
1888 :     my $ssinv = [];
1889 :    
1890 :     my $g = $self->{genome};
1891 :     my $ng = @$g;
1892 :    
1893 :     my $old_roles = $self->{role_index};
1894 :    
1895 :     my @role_index_conversion;
1896 :    
1897 :    
1898 :     $self->{abbr} = {};
1899 :     $self->{role_index} = {};
1900 :     $self->{roles} = [];
1901 :     $self->{role_abbrs} = [];
1902 :    
1903 :    
1904 :     for (my $idx = 0; $idx < @$roles; $idx++)
1905 :     {
1906 :     my $role = $roles->[$idx]->[0];
1907 :     my $abbr = $roles->[$idx]->[1];
1908 :    
1909 :     my $old_idx = $old_roles->{$role};
1910 :    
1911 :     if (defined($old_idx))
1912 :     {
1913 : overbeek 1.31 # print "Found old idx $old_idx for $role $idx\n";
1914 :     # print $oldssinv->[$old_idx];
1915 : olson 1.25 $ssinv->[$idx] = $oldssinv->[$old_idx];
1916 :    
1917 :     $role_index_conversion[$old_idx] = $idx;
1918 :     }
1919 :     else
1920 :     {
1921 : overbeek 1.37 # print "Did not find old role for $role $idx\n";
1922 :     # print Dumper($old_roles);
1923 : olson 1.25 my $l = [];
1924 :     for (my $j = 0; $j < $ng; $j++)
1925 :     {
1926 :     $l->[$j] = [];
1927 :     }
1928 : parrello 1.60
1929 : olson 1.25 $ssinv->[$idx] = $l;
1930 :     }
1931 :    
1932 :     #
1933 :     # While we're here, update the new role and abbrev indexes
1934 :     #
1935 :     $self->{role_index}->{$role} = $idx;
1936 :     $self->{abbr}->{$abbr} = $role;
1937 :     $self->{roles}->[$idx] = $role;
1938 :     $self->{role_abbrs}->[$idx] = $abbr;
1939 :     }
1940 :    
1941 :     #
1942 :     # Now create the uninverted spreadsheet.
1943 :     #
1944 :    
1945 :     for (my $gidx = 0; $gidx < $ng; $gidx++)
1946 :     {
1947 :     my $row = [];
1948 :     $ss->[$gidx] = $row;
1949 :     for (my $ridx = 0; $ridx < @$roles; $ridx++)
1950 :     {
1951 :     $row->[$ridx] = $ssinv->[$ridx]->[$gidx];
1952 :     }
1953 :     }
1954 :    
1955 :     $self->{spreadsheet} = $ss;
1956 :     $self->{spreadsheet_inv} = $ssinv;
1957 :    
1958 :     #
1959 :     # Fix up the subsets.
1960 :     #
1961 :    
1962 :    
1963 : overbeek 1.37 for my $subset (grep { $_ ne "All" } $self->get_subset_names())
1964 : olson 1.25 {
1965 :     my $n = [];
1966 :     for my $idx ($self->get_subset($subset))
1967 :     {
1968 :     my $new = $role_index_conversion[$idx];
1969 :     if (defined($new))
1970 :     {
1971 :     push(@$n, $new);
1972 :     }
1973 :     }
1974 :     $self->_set_subset($subset, $n);
1975 :     }
1976 :    
1977 :     }
1978 :    
1979 :     =pod
1980 :    
1981 :     =head1 C<add_role($role, $abbr)>
1982 :    
1983 :     Add the given role to the spreadsheet.
1984 :    
1985 :     This causes a new column to be added, with empty values in each cell.
1986 :    
1987 :     We do nothing if the role is already present.
1988 :    
1989 :     Return the index of the new role.
1990 :    
1991 :     =cut
1992 :    
1993 :     sub add_role
1994 :     {
1995 :     my($self, $role, $abbr) = @_;
1996 :    
1997 :     if (defined($self->get_role_index($role)))
1998 :     {
1999 :     warn "Role $role already present\n";
2000 :     return undef;
2001 :     }
2002 :    
2003 :     #
2004 :     # Add to the roles list. It goes at the end.
2005 :     #
2006 :    
2007 :     my $idx = @{$self->{roles}};
2008 :     $self->{roles}->[$idx] = $role;
2009 :     $self->{role_abbrs}->[$idx] = $abbr;
2010 :     $self->{role_index}->{$role} = $idx;
2011 :     $self->{abbr}->{$abbr} = $role;
2012 :    
2013 :     #
2014 :     # Update the spreadsheet.
2015 :     # On the standard one, we have to go through all the rows adding
2016 :     # a columnt to each.
2017 :     #
2018 :     # On the inverted one, we add a column with [] in each entry.
2019 :     #
2020 :    
2021 :     my $ng = @{$self->{genome}};
2022 :     my $newcol = [];
2023 :    
2024 :     for (my $i = 0; $i < $ng; $i++)
2025 :     {
2026 :     my $cell = [];
2027 :     # print "nr: Adding cell $cell for gidx=$i ridx=$idx\n";
2028 :     $self->{spreadsheet}->[$i]->[$idx] = $cell;
2029 :     $newcol->[$i] = $cell;
2030 :     }
2031 :    
2032 :     $self->{spreadsheet_inv}->[$idx] = $newcol;
2033 :    
2034 :     return $idx;
2035 :     }
2036 :    
2037 :     =pod
2038 :    
2039 :     =head1 remove_role($role)
2040 :    
2041 :     Remove the role from the spreadsheet.
2042 :    
2043 :     We do nothing if the role is not present.
2044 :    
2045 :     =cut
2046 :    
2047 :     sub remove_role
2048 :     {
2049 :     my($self, $role) = @_;
2050 :    
2051 :     my $idx = $self->get_role_index($role);
2052 :     if (!defined($idx))
2053 :     {
2054 :     warn "Role $role not present\n";
2055 :     return undef;
2056 :     }
2057 :    
2058 :     #
2059 : parrello 1.60 # Remove from the roles list.
2060 : olson 1.25 #
2061 :    
2062 :     my $abbr = $self->{role_abbrs}->[$idx];
2063 : parrello 1.60
2064 : olson 1.25 splice(@{$self->{roles}}, $idx, 1);
2065 :     splice(@{$self->{role_abbrs}}, $idx, 1);
2066 :     delete $self->{role_index}->{$role};
2067 :     delete $self->{abbr}->{$abbr};
2068 :    
2069 :     #
2070 :     # Update the spreadsheet.
2071 :     # On the standard one, we have to go through all the rows removing
2072 :     # the column from each.
2073 :     #
2074 :     # On the inverted one, we just remove the column.
2075 :     #
2076 :    
2077 :     my $ng = @{$self->{genome}};
2078 :     my $newcol = [];
2079 :    
2080 :     for (my $i = 0; $i < $ng; $i++)
2081 :     {
2082 :     splice(@{$self->{spreadsheet}->[$i]}, $idx, 1);
2083 :     }
2084 :    
2085 :     splice(@{$self->{spreadsheet_inv}}, $idx, 1);
2086 :    
2087 :     #
2088 :     # We need to rewrite the subsets. if $idx was present in one, it is
2089 :     # removed. Any index >$idx is decremented.
2090 :     #
2091 :    
2092 :     for my $subset ($self->get_subset_names())
2093 :     {
2094 :     my @n;
2095 :    
2096 :     for my $sidx ($self->get_subset($subset))
2097 :     {
2098 :     if ($sidx < $idx)
2099 :     {
2100 :     push(@n, $sidx);
2101 :     }
2102 :     elsif ($sidx > $idx)
2103 :     {
2104 :     push(@n, $sidx - 1);
2105 :     }
2106 :     }
2107 :    
2108 :     $self->_set_subset($subset, [@n]);
2109 :     }
2110 :     }
2111 :    
2112 :     =pod
2113 :    
2114 :     =head1 C<add_genome($genome, $abbr)>
2115 :    
2116 :     Add the given genome to the spreadsheet.
2117 :    
2118 :     This causes a new row to be added, with empty values in each cell.
2119 :    
2120 :     We do nothing if the genome is already present.
2121 :    
2122 :     Return the index of the new genome.
2123 :    
2124 :     =cut
2125 :    
2126 :     sub add_genome
2127 :     {
2128 :     my($self, $genome) = @_;
2129 :    
2130 :     my $idx = $self->get_genome_index($genome);
2131 :     if (defined($idx))
2132 :     {
2133 : parrello 1.64 warn "Genome $genome already present\n";
2134 :     return $idx;
2135 : olson 1.25 }
2136 :    
2137 :     #
2138 :     # Add to the genomes list. It goes at the end.
2139 :     #
2140 :    
2141 : parrello 1.64 $idx = @{$self->{genome}};
2142 : olson 1.26 $self->{variant_code}->[$idx] = 0;
2143 : olson 1.25 $self->{genome}->[$idx] = $genome;
2144 :     $self->{genome_index}->{$genome} = $idx;
2145 :    
2146 :     #
2147 :     # Update the spreadsheet.
2148 :     # On the inverted one, we have to go through all the columns adding
2149 :     # a row to each.
2150 :     #
2151 :     # On the regular one, we add a row with [] in each entry.
2152 :     #
2153 :    
2154 :     my $nr = @{$self->{roles}};
2155 :     my $newrow = [];
2156 :    
2157 :     for my $i (0.. $nr - 1)
2158 :     {
2159 :     my $cell = [];
2160 :     # print "ng: Adding cell $cell for gidx=$idx ridx=$i\n";
2161 :     $self->{spreadsheet_inv}->[$i]->[$idx] = $cell;
2162 :     $newrow->[$i] = $cell;
2163 :     }
2164 :    
2165 :     $self->{spreadsheet}->[$idx] = $newrow;
2166 :    
2167 :     return $idx;
2168 :     }
2169 :    
2170 :     =pod
2171 :    
2172 :     =head1 remove_genome($genome)
2173 :    
2174 :     Remove the genome from the spreadsheet.
2175 :    
2176 :     We do nothing if the genome is not present.
2177 :    
2178 :     =cut
2179 :    
2180 :     sub remove_genome
2181 :     {
2182 :     my($self, $genome) = @_;
2183 :    
2184 :     my $idx = $self->get_genome_index($genome);
2185 :     if (!defined($idx))
2186 :     {
2187 :     warn "Genome $genome not present\n";
2188 :     return undef;
2189 :     }
2190 :    
2191 :     #
2192 : parrello 1.60 # Remove from the genomes list.
2193 : olson 1.25 #
2194 :    
2195 :     splice(@{$self->{genome}}, $idx, 1);
2196 : overbeek 1.43
2197 :     my $genome1;
2198 :     foreach $genome1 (@{$self->{genome}})
2199 :     {
2200 :     if ($self->{genome_index}->{$genome1} > $idx)
2201 :     {
2202 :     $self->{genome_index}->{$genome1}--;
2203 :     }
2204 :     }
2205 : olson 1.25 splice(@{$self->{variant_code}}, $idx, 1);
2206 :    
2207 :     delete $self->{genome_index}->{$genome};
2208 :    
2209 :     #
2210 :     # Update the spreadsheet.
2211 :     # On the inverted one, we have to go through all the columns removing
2212 :     # the row from each.
2213 :     #
2214 :     # On the standard one, we just remove the row.
2215 :     #
2216 :    
2217 :     my $nr = @{$self->{roles}};
2218 :    
2219 :     for my $i (0 .. $nr - 1)
2220 :     {
2221 :     splice(@{$self->{spreadsheet_inv}->[$i]}, $idx, 1);
2222 :     }
2223 :    
2224 :     splice(@{$self->{spreadsheet}}, $idx, 1);
2225 :    
2226 :     }
2227 :    
2228 : parrello 1.60 sub get_name :Scalar
2229 : olson 1.25 {
2230 :     my($self) = @_;
2231 : overbeek 1.53 my $name = $self->{name};
2232 :     $name =~ s/ /_/g;
2233 :     return $name;
2234 : olson 1.25 }
2235 : parrello 1.60
2236 :     sub get_dir :Scalar
2237 : overbeek 1.41 {
2238 :     my($self) = @_;
2239 :     return $self->{dir};
2240 :     }
2241 : olson 1.25
2242 : parrello 1.60
2243 :     sub get_version :Scalar
2244 : olson 1.25 {
2245 :     my($self) = @_;
2246 :     return $self->{version};
2247 : olson 1.17 }
2248 :    
2249 : parrello 1.60 sub get_notes :Scalar
2250 : olson 1.26 {
2251 :     my($self) = @_;
2252 :    
2253 :     return $self->{notes};
2254 :     }
2255 :    
2256 : overbeek 1.58 sub get_reactions
2257 :     {
2258 :     my($self) = @_;
2259 :    
2260 :     return $self->{reactions};
2261 :     }
2262 :    
2263 : overbeek 1.59 sub set_reaction {
2264 :     my($self,$role,$rstring) = @_;
2265 :    
2266 :     $self->{reactions}->{$role} = [split(/,\s*/,$rstring)];
2267 :     }
2268 :    
2269 :    
2270 : olson 1.26 sub set_notes
2271 :     {
2272 :     my($self, $notes) = @_;
2273 :    
2274 : olson 1.28 $self->{notes} = $notes;
2275 : olson 1.26 }
2276 :    
2277 : redwards 1.44 sub get_classification
2278 :     {
2279 :     my($self) = @_;
2280 :    
2281 :     return $self->{classification};
2282 :     }
2283 :    
2284 :     sub set_classification
2285 :     {
2286 :     my($self, $classification) = @_;
2287 :    
2288 :     $self->{classification}=$classification;
2289 :     }
2290 :    
2291 :    
2292 : parrello 1.60
2293 :     sub get_curator :Scalar
2294 : olson 1.17 {
2295 :     my($self) = @_;
2296 :     return $self->{curator};
2297 :     }
2298 : overbeek 1.47
2299 : olson 1.25 #
2300 :     # Subsystem copying logic
2301 :     #
2302 :    
2303 :     =pod
2304 :    
2305 :     =head2 add_to_subsystem($subsystem_name, $columns, $notes_flag)
2306 :    
2307 :     Merge the given columns from $subsystem_name into this subsystem. Append the
2308 :     notes from the subsystem if $notes_flag is true.
2309 :    
2310 :     =cut
2311 :    
2312 :     sub add_to_subsystem
2313 :     {
2314 :     my($self, $subsystem_name, $cols, $add_notes) = @_;
2315 :    
2316 :     my $ss = $self->{fig}->get_subsystem($subsystem_name);
2317 :    
2318 :     if (!$ss)
2319 :     {
2320 :     warn "Cannot open subsystem '$subsystem_name' to copy from";
2321 :     return;
2322 :     }
2323 :    
2324 :     #
2325 :     # Merge the data from the other subsystem.
2326 :     #
2327 :     # First we assure ourselves that we have the appropriate roles. While
2328 :     # we do this, build the list of row indices (in this subsystem) that
2329 :     # map to the roles we are adding.
2330 :     #
2331 :    
2332 :     #
2333 :     # local_roles[$his_role] = $my_role (map from other role idx to local role idx)
2334 :     #
2335 : parrello 1.60
2336 : olson 1.25 my @local_roles;
2337 :    
2338 :     #
2339 :     # his_roles = list of role indices corresponding to the remote roles.
2340 :     #
2341 : overbeek 1.36 if ($cols->[0] eq "all")
2342 :     {
2343 :     $cols = [$ss->get_roles];
2344 :     }
2345 :    
2346 : olson 1.25 my @his_roles;
2347 : parrello 1.60
2348 : olson 1.25 for my $his_role (@$cols)
2349 :     {
2350 :     my $idx = $self->get_role_index($his_role);
2351 :     my $his_idx = $ss->get_role_index($his_role);
2352 :    
2353 :     if (!defined($his_idx))
2354 :     {
2355 :     confess "Cannot map his role $his_role\n";
2356 :     }
2357 :     push(@his_roles, $his_idx);
2358 :    
2359 :     if (!defined($idx))
2360 :     {
2361 :     my $his_abbr = $ss->get_role_abbr($his_idx);
2362 :    
2363 :     $idx = $self->add_role($his_role, $his_abbr);
2364 : overbeek 1.37 # print "Adding missing role $his_role idx=$idx\n";
2365 : olson 1.25 }
2366 :     else
2367 :     {
2368 : overbeek 1.37 # print "Found existing role $his_role idx=$idx\n";
2369 : olson 1.25 }
2370 : parrello 1.60
2371 : olson 1.25
2372 :     $local_roles[$his_idx] = $idx;
2373 :     }
2374 :    
2375 :     #
2376 :     # Similar scan to ensure that we have rows for the genomes
2377 :     # that are in the other subsystem.
2378 :     #
2379 :    
2380 :     my @local_genomes;
2381 :    
2382 :     my @his_genomes = $ss->get_genomes();
2383 :    
2384 :     for my $his_idx (0..@his_genomes - 1)
2385 :     {
2386 :     my $genome = $his_genomes[$his_idx];
2387 : overbeek 1.37
2388 : parrello 1.60
2389 : olson 1.25 my $my_idx = $self->get_genome_index($genome);
2390 :    
2391 :     if (!defined($my_idx))
2392 :     {
2393 :     #
2394 :     # Not there, need to add.
2395 :     #
2396 :    
2397 :     $my_idx = $self->add_genome($genome);
2398 : overbeek 1.37 # print "Adding missing genome $genome idx=$my_idx\n";
2399 : olson 1.25 }
2400 :     else
2401 :     {
2402 : overbeek 1.37 # print "Found existing genome $genome idx=$my_idx\n";
2403 : olson 1.25 }
2404 : parrello 1.60
2405 : olson 1.25 $local_genomes[$his_idx] = $my_idx;
2406 :     }
2407 :    
2408 : parrello 1.60
2409 : olson 1.25 #
2410 :     # Now that we have our local roles set up to receive the data,
2411 :     # process the incoming roles one at a time.
2412 :     #
2413 :    
2414 :    
2415 :     for my $his_role (@his_roles)
2416 :     {
2417 :     my $my_col = $self->get_col($local_roles[$his_role]);
2418 :     my $his_col = $ss->get_col($his_role);
2419 :    
2420 :     #
2421 :     # $his_col is the information for $his_role, indexed by
2422 :     # genome in @his_genomes.
2423 :     #
2424 :     # $my_col is hte information for my copy of $his_role,
2425 :     # indexed by genome in MY genome list.
2426 :     #
2427 :    
2428 :     my $my_role = $local_roles[$his_role];
2429 :    
2430 : overbeek 1.37 # print "merging: $self->{roles}->[$my_role] $ss->{roles}->[$his_role] his_role=$his_role my_role=$my_role\n";
2431 : olson 1.25
2432 :     for my $his_gidx (0 .. @his_genomes - 1)
2433 :     {
2434 :     my $hisent = $his_col->[$his_gidx];
2435 :    
2436 :     my $my_gidx = $local_genomes[$his_gidx];
2437 : parrello 1.60
2438 : overbeek 1.37
2439 : olson 1.25 my $myent = $my_col->[$my_gidx];
2440 :    
2441 : overbeek 1.37 # print " his_gidx=$his_gidx my_gidx=$my_gidx hisent=@$hisent myent=@$myent\n";
2442 : olson 1.25
2443 :     my %new;
2444 :     map { $new{$_}++ } @$hisent;
2445 :     map { $new{$_}++ } @$myent;
2446 :    
2447 :     @$myent = keys(%new);
2448 :    
2449 : overbeek 1.37 # print " new entry: @$myent\n";
2450 : olson 1.25 }
2451 :     }
2452 : olson 1.26
2453 :     #
2454 :     # Fix up the variant codes.
2455 :     #
2456 :    
2457 :     for my $his_gidx (0 .. @his_genomes - 1)
2458 :     {
2459 :     my $his_code = $ss->get_variant_code($his_gidx);
2460 :     my $my_gidx = $local_genomes[$his_gidx];
2461 :    
2462 :     if (!$self->get_variant_code($my_gidx))
2463 :     {
2464 :     $self->{variant_code}->[$my_gidx] = $his_code;
2465 :     }
2466 :     }
2467 :    
2468 :     #
2469 :     # If we are to add notes, append the other subsystem's notes text.
2470 :     #
2471 :    
2472 :     if ($add_notes)
2473 :     {
2474 :     my $his_notes = $ss->get_notes();
2475 :    
2476 :     $self->{notes} .= "\nNotes copied from $ss->{name}:\n$his_notes\n";
2477 :     }
2478 : olson 1.25 }
2479 : olson 1.17
2480 : olson 1.1 sub dump
2481 :     {
2482 :     my($self) = @_;
2483 :    
2484 :     for my $k (keys(%$self))
2485 :     {
2486 :     next if $k eq "spreadsheet" or $k eq "spreadsheet_inv";
2487 :     print "Key \"$k\": ", Dumper($self->{$k});
2488 :     }
2489 :     }
2490 : parrello 1.60
2491 : olson 1.14 #
2492 :     # Increment the subsystem's version number.
2493 :     #
2494 :     sub incr_version {
2495 :     my($self) = @_;
2496 :    
2497 :     my $dir = $self->{dir};
2498 :     my $vfile = "$dir/VERSION";
2499 :     my($ver);
2500 :    
2501 :     if (open(my $fh,"<$vfile"))
2502 :     {
2503 :     if (defined($ver = <$fh>) && ($ver =~ /^(\S+)/))
2504 :     {
2505 :     $ver = $1;
2506 :     }
2507 :     else
2508 :     {
2509 :     $ver = 0;
2510 :     }
2511 :     close($fh);
2512 :     }
2513 :     else
2514 :     {
2515 :     $ver = 0;
2516 :     }
2517 :    
2518 :     $ver++;
2519 :    
2520 :     open(my $fh, ">$vfile") || die "could not open $vfile";
2521 :     print $fh "$ver\n";
2522 :     close($fh);
2523 :    
2524 :     chmod(0777, $vfile);
2525 :    
2526 :     $self->load_version();
2527 :     }
2528 : olson 1.1
2529 :     sub get_dir_from_name
2530 :     {
2531 :     my($name) = @_;
2532 :    
2533 :     my $b = $name;
2534 :     $b =~ s/ /_/g;
2535 :     my $dir = File::Spec->catfile($FIG_Config::data, 'Subsystems', $b);
2536 :     return $dir;
2537 :     }
2538 :    
2539 : olson 1.12 #
2540 :     # Code for dealing with Bill McCune's prolog code for extending subsystems.
2541 :     #
2542 :     # The code here is a reconstruction of Bill's "go" script in perl with
2543 :     # data pulled from the local SEED configuration.
2544 :     #
2545 :    
2546 :     sub extend_with_billogix
2547 :     {
2548 : olson 1.42 my($self, $muser, $genomes) = @_;
2549 : olson 1.12 my($isMaster, $user);
2550 : parrello 1.60
2551 : olson 1.12 my $now = time();
2552 :    
2553 :     if ($muser =~ /master:(.*)/)
2554 :     {
2555 :     $isMaster = 1;
2556 :     $user = $1;
2557 :     }
2558 :     else
2559 :     {
2560 :     $isMaster = 0;
2561 :     $user = $muser;
2562 :     }
2563 :    
2564 :     #
2565 : olson 1.42 # initialize the genome list to all complete genomes, if none was passed in.
2566 :     #
2567 :    
2568 :     if (!$genomes)
2569 :     {
2570 :     $genomes = [$self->{fig}->genomes("complete")];
2571 :     warn "getting genome list from fig $self->{fig}";
2572 :     }
2573 :    
2574 :     #
2575 :     # Ensure genome list is of the right form.
2576 :     #
2577 :    
2578 :     if (ref($genomes) ne "ARRAY")
2579 :     {
2580 :     warn "billogix: genome list is not a list reference";
2581 :     return;
2582 :     }
2583 :    
2584 :     for my $g (@$genomes)
2585 :     {
2586 :     if ($g !~ /^\d+\.\d+/)
2587 :     {
2588 :     warn "billogix: genome '$g' is not of the proper form, aborting billogix run.";
2589 :     return;
2590 :     }
2591 :     }
2592 : parrello 1.60
2593 : olson 1.42 my $genome_list = "[" . join(", ", map { "'$_'" } @$genomes) . "]";
2594 :    
2595 :     warn "Genomes: $genome_list\n";
2596 :     warn Dumper($genomes);
2597 : parrello 1.60
2598 : olson 1.42 #
2599 : olson 1.12 # Find the executable.
2600 :     #
2601 :    
2602 :     my $exe = "$FIG_Config::bin/billogix";
2603 :    
2604 :     if (! -x $exe)
2605 :     {
2606 :     warn "Cannot find billogix exe at $exe\n";
2607 :     return;
2608 :     }
2609 : parrello 1.60
2610 : olson 1.12 my $ss_name = $self->{name};
2611 : olson 1.18
2612 :     $ss_name =~ s/\s+/_/g;
2613 : parrello 1.60
2614 : olson 1.14 my $ss_dir = "$self->{dir}/";
2615 : olson 1.15 my $assign_dir = "$FIG_Config::data/Assignments/$user/";
2616 : olson 1.12 &FIG::verify_dir($assign_dir);
2617 :    
2618 : olson 1.16 my $when= strftime("%m-%d-%y:%H:%M:%S", localtime($now));
2619 :     my $job_id = "${when}:sss:$ss_name";
2620 :    
2621 : olson 1.12 my $seed = &FIG::cgi_url() . "/";
2622 : olson 1.13 my $export_part = "ssa.cgi?user=$muser&request=delete_or_export_ssa&export=";
2623 : olson 1.12
2624 :     #
2625 :     # Have the prereq stuff, now start up the app.
2626 :     #
2627 :    
2628 :     $ENV{LOCALSZ} = "80000";
2629 :     $ENV{GLOBALSZ} = "80000";
2630 :     $ENV{TRAILSZ} = "30000";
2631 : olson 1.13
2632 :     my $arch = &FIG::get_current_arch();
2633 :    
2634 :     $ENV{BILLOGIX} = "$FIG_Config::fig_disk/dist/releases/current/$arch/lib/Billogix";
2635 :    
2636 :     #
2637 :     # Need to ensure pl2wam is in our path
2638 :     #
2639 :    
2640 :     $ENV{PATH} = "${FIG_Config::ext_bin}:$ENV{PATH}";
2641 : olson 1.12
2642 : olson 1.23 #
2643 :     # We're going to divide the run into $n_chunks chunks.
2644 :     #
2645 :    
2646 :     my $n_chunks = 10;
2647 :    
2648 :     my($log);
2649 :     open($log, ">$ss_dir/$job_id.log");
2650 :    
2651 :     for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2652 :     {
2653 :     my $app_input = <<EOINP;
2654 : olson 1.12 ['\$BILLOGIX/top'].
2655 :     loadup.
2656 : olson 1.42 asserta(job_genome_list($genome_list)).
2657 : olson 1.23 asserta(part($this_chunk, $n_chunks)).
2658 : olson 1.12 asserta(url_default_seed('$seed')).
2659 : olson 1.13 asserta(url_export_part('$export_part')).
2660 : olson 1.12 asserta(ss_directory('$ss_dir')).
2661 :     asserta(assign_directory('$assign_dir')).
2662 :     asserta(job_id('$job_id')).
2663 :     extend_test3('$ss_name').
2664 :     EOINP
2665 :    
2666 : olson 1.23 print STDERR <<EOF;
2667 : olson 1.12 Starting app
2668 :    
2669 : olson 1.23 chunk $this_chunk of $n_chunks
2670 : olson 1.12 ss_name = $ss_name
2671 :     ss_dir = $ss_dir
2672 :     user = $user
2673 :     assign_dir = $assign_dir
2674 :     exe = $exe
2675 : olson 1.13 libdir = $ENV{BILLOGIX}
2676 :     path = $ENV{PATH}
2677 : olson 1.12
2678 :     App input
2679 :     $app_input
2680 :     EOF
2681 :     # feh, put in a block to reset perlmode indentation.
2682 : olson 1.23 {
2683 :     my($app_read, $app_write);
2684 : parrello 1.60
2685 : olson 1.23 #
2686 :     # Start the actual application with stdin and stdout redirected
2687 :     # to pipes.
2688 :     #
2689 :     # We write $app_input to the stdin pipe, and close it.
2690 :     # Then loop reading stdout, logging that output.
2691 :     #
2692 :     my $pid = open2($app_read, $app_write, $exe);
2693 : parrello 1.60
2694 : olson 1.23 if (!$pid)
2695 :     {
2696 :     warn "open2 $exe failed: $!\n";
2697 :     print $log "open2 $exe failed: $!\n";
2698 :     return;
2699 :     }
2700 : parrello 1.60
2701 : olson 1.23 print $app_write $app_input;
2702 :     close($app_write);
2703 : parrello 1.60
2704 : olson 1.23 #
2705 :     # Set autoflush on the logfile.
2706 :     #
2707 : parrello 1.60
2708 : olson 1.23 my $old = select($log);
2709 :     $| = 1;
2710 :     select(STDERR);
2711 :     $| = 1;
2712 :     select($old);
2713 : parrello 1.60
2714 : olson 1.23 warn "Starting $exe with pid $pid\n";
2715 :     print $log "Starting $exe with pid $pid\n";
2716 : parrello 1.60
2717 : olson 1.23 while (<$app_read>)
2718 :     {
2719 :     print STDERR $_;
2720 :     print $log $_;
2721 :     }
2722 : parrello 1.60
2723 : olson 1.23 print STDERR "App done\n";
2724 :     print $log "App done\n";
2725 : parrello 1.60
2726 : olson 1.23 close($app_read);
2727 : parrello 1.60
2728 : olson 1.23 my $ret = waitpid($pid, 0);
2729 :     my $stat = $?;
2730 :     print STDERR "Return status is $?\n";
2731 :     print $log "Return status is $?\n";
2732 :    
2733 :     #
2734 :     # This chunk has finished. We should see a file
2735 :     # rows.$this_chunk.$n_chunks.
2736 :     #
2737 :     }
2738 :     }
2739 :     #
2740 :     # At this point, the extension is finished (we've run the
2741 :     # $n_chunks parts of the extension job).
2742 :     #
2743 : olson 1.12
2744 : olson 1.14 #
2745 : olson 1.23 # We read in all the individual rows files, writing the single
2746 :     # concatenation of rows.
2747 : olson 1.14 #
2748 : olson 1.12
2749 : olson 1.23 my $ssaD = $self->{dir};
2750 : parrello 1.60
2751 : olson 1.23 my $rows_file = "$ssaD/rows";
2752 :    
2753 :     my $rowFH;
2754 :     if (!open($rowFH, ">$rows_file"))
2755 : olson 1.12 {
2756 : olson 1.23 my $err = "Cannot open rows file $ssaD/rows for writing: $!\n";
2757 :     print STDERR $err;
2758 :     print $log $err;
2759 : olson 1.12 return;
2760 :     }
2761 :    
2762 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2763 :     {
2764 :     my $chunkFH;
2765 :     my $cfile = "$ssaD/rows.$this_chunk.$n_chunks";
2766 :     if (!open($chunkFH, "<$cfile"))
2767 :     {
2768 :     my $err = "Cannot open rows file $cfile for reading: $!\n";
2769 :     print STDERR $err;
2770 :     print $log $err;
2771 :     return;
2772 :     }
2773 :     while (<$chunkFH>)
2774 :     {
2775 :     print $rowFH $_;
2776 :     }
2777 :     close($chunkFH);
2778 :     }
2779 :     close($rowFH);
2780 : olson 1.12
2781 :     #
2782 : olson 1.23 # Concatenate the assignments into the assignment directory.
2783 : olson 1.12 #
2784 :    
2785 : olson 1.23 my $assignments_file = "$assign_dir$job_id";
2786 :     my $assignFH;
2787 : olson 1.12
2788 : olson 1.23 if (!open($assignFH, ">$assignments_file"))
2789 : olson 1.12 {
2790 : olson 1.23 my $err = "Cannot open assignments file $assignments_file for writing: $!\n";
2791 :     print STDERR $err;
2792 :     print $log $err;
2793 :     return;
2794 : olson 1.12 }
2795 :    
2796 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2797 : olson 1.19 {
2798 : olson 1.23 my $aFH;
2799 :     my $afile = "$ssaD/assignments.$this_chunk.$n_chunks";
2800 :     if (!open($aFH, "<$afile"))
2801 :     {
2802 :     my $err = "Cannot open assignments file $afile for reading: $!\n";
2803 :     print STDERR $err;
2804 :     print $log $err;
2805 :     return;
2806 :     }
2807 :     while (<$aFH>)
2808 :     {
2809 :     print $assignFH $_;
2810 :     }
2811 :     close($aFH);
2812 : olson 1.19 }
2813 : olson 1.23 close($assignFH);
2814 : olson 1.19
2815 : parrello 1.60
2816 :    
2817 : olson 1.19 #
2818 : olson 1.14 # Back up the spreadsheet, and append the rows file to it.
2819 :     #
2820 :    
2821 :     &FIG::verify_dir("$ssaD/Backup");
2822 :     my $ts = time;
2823 :     rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
2824 :     copy("$ssaD/spreadsheet","$ssaD/spreadsheet~");
2825 :     rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
2826 :    
2827 :     #
2828 :     # Append the new rows to the spreadsheet.
2829 :     #
2830 :    
2831 :     my($ssafh, $rowsfh);
2832 :     open($ssafh, ">>$ssaD/spreadsheet") or die "Cannot open $ssaD/spreadsheet for append: $!\n";
2833 :     open($rowsfh, "<$ssaD/rows") or die "Cannot open $ssaD/rows for reading: $!\n";
2834 : parrello 1.60
2835 : olson 1.14 while (<$rowsfh>)
2836 :     {
2837 :     print $ssafh $_;
2838 :     }
2839 :     close($ssafh);
2840 :     close($rowsfh);
2841 :    
2842 :     $self->incr_version();
2843 : olson 1.12 }
2844 : olson 1.13
2845 : olson 1.14
2846 : olson 1.13 sub set_current_extend_pid
2847 :     {
2848 :     my($self, $pid) = @_;
2849 :    
2850 :     if (open(my $fh, ">$self->{dir}/EXTEND_PID"))
2851 :     {
2852 :     print $fh "$pid\n";
2853 :     }
2854 :     else
2855 :     {
2856 :     warn "Cannot open $self->{dir}/EXTEND_PID: $!\n";
2857 :     }
2858 :     }
2859 :    
2860 :     sub get_current_extend_pid
2861 :     {
2862 :     my($self) = @_;
2863 :    
2864 :     if (open(my $fh, "<$self->{dir}/EXTEND_PID"))
2865 :     {
2866 :     my $pid = <$fh>;
2867 :     close($fh);
2868 :     if ($pid)
2869 :     {
2870 :     chomp $pid;
2871 : parrello 1.60
2872 : olson 1.13 return $pid;
2873 :     }
2874 :     }
2875 :     return undef;
2876 :     }
2877 : parrello 1.60
2878 : olson 1.7 package Subsystem::Diagram;
2879 :    
2880 :     sub new
2881 :     {
2882 :     my($class, $sub, $fig, $name, $dir) = @_;
2883 :    
2884 :     if (!-d $dir)
2885 :     {
2886 :     return undef;
2887 :     }
2888 :    
2889 :     my $self = {
2890 :     fig => $fig,
2891 :     subsystem => $sub,
2892 :     name => $name,
2893 :     dir =>$ dir,
2894 :     };
2895 :     bless $self, $class;
2896 :    
2897 :     $self->load();
2898 :    
2899 :     return $self;
2900 :     }
2901 :    
2902 :     #
2903 :     # Parse the diagram into internal data structure.
2904 :     #
2905 :    
2906 :     sub load
2907 :     {
2908 :     my($self) = @_;
2909 :    
2910 :     $self->load_area();
2911 :     }
2912 :    
2913 :     sub load_area
2914 :     {
2915 :     my($self) = @_;
2916 :     my $fh;
2917 :    
2918 : olson 1.8 if (!open($fh, "<$self->{dir}/area_table"))
2919 : olson 1.7 {
2920 : olson 1.8 warn "Could not load $self->{dir}/area_table: $!\n";
2921 : olson 1.7 return;
2922 :     }
2923 :    
2924 :     $self->{areas} = [];
2925 :    
2926 :     my $area_list = $self->{areas};
2927 : parrello 1.60
2928 : olson 1.7 while (<$fh>)
2929 :     {
2930 :     chomp;
2931 :     s/#.*$//;
2932 :     s/^\s+//;
2933 :     s/\s+$//;
2934 :     next if $_ eq '';
2935 :     my ($area, $tag, $value) = split(/\s+/, $_, 3);
2936 :     # print "area=$area tag=$tag value=$value\n";
2937 :    
2938 :     push(@$area_list, [$area, $tag, $value]);
2939 :    
2940 :     #
2941 :     # Do a little checking.
2942 :     #
2943 :    
2944 :     if ($tag eq "role")
2945 :     {
2946 :     my $idx = $self->{subsystem}->get_role_index($value);
2947 :     if (!defined($idx))
2948 :     {
2949 :     warn "Role not found for \"$value\" in subsystem $self->{subsystem}->{name}\n";
2950 :     }
2951 :     }
2952 :     }
2953 :     close($fh);
2954 :     }
2955 :    
2956 :     sub get_areas
2957 :     {
2958 :     my($self) = @_;
2959 :    
2960 :     return @{$self->{areas}};
2961 :     }
2962 :    
2963 : olson 1.1 1;
2964 : olson 1.7
2965 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3