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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3