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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.107 - (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 : paarmann 1.97 sub is_new_diagram {
444 :     my ($self, $id) = @_;
445 :    
446 :     my $image_map = $self->get_diagram_html_file($id);
447 :     if ($image_map) {
448 :    
449 :     open(IN, "$image_map") or die "Unable to open file $image_map.";
450 :     my $header = <IN>;
451 :     close(IN);
452 :    
453 :     if ($header =~ /\<map name=\"GraffleExport\"\>/) {
454 :     return 1;
455 :     }
456 :     }
457 :    
458 :     return undef;
459 :     }
460 :    
461 :     sub get_link_for_new_diagram {
462 :     my ($self, $id) = @_;
463 :    
464 :     my $ss_name = $self->{name};
465 :     return "./diagram.cgi?subsystem_name=$ss_name&diagram=$id";
466 :     }
467 :    
468 : parrello 1.90
469 : olson 1.61 sub open_diagram_image
470 :     {
471 :     my($self, $id) = @_;
472 :    
473 :     my $img_base = "$self->{dir}/diagrams/$id/diagram";
474 :    
475 :     my @types = ([".png", "image/png"],
476 : parrello 1.69 [".gif", "image/gif"],
477 :     [".jpg", "image/jpeg"]);
478 : olson 1.61
479 :     for my $tent (@types)
480 :     {
481 : parrello 1.69 my($ext, $type) = @$tent;
482 : olson 1.61
483 : parrello 1.69 my $file = "$img_base$ext";
484 : olson 1.61
485 : parrello 1.69 if (open(my $fh, "<$file"))
486 :     {
487 :     return($type, $fh);
488 :     }
489 : olson 1.61 }
490 :    
491 :     return undef;
492 :     }
493 : olson 1.7
494 : olson 1.61 sub delete_diagram
495 :     {
496 :     my($self, $id) = @_;
497 : parrello 1.60
498 : olson 1.61 my $dir = "$self->{dir}/diagrams/$id";
499 : olson 1.7
500 : olson 1.61 if (-d $dir)
501 :     {
502 : parrello 1.69 system("rm", "-r", $dir);
503 : olson 1.61 }
504 : olson 1.7 }
505 :    
506 : olson 1.61 sub rename_diagram
507 : olson 1.7 {
508 : olson 1.61 my($self, $id, $new_name) = @_;
509 : olson 1.7
510 : olson 1.61 my $dir = "$self->{dir}/diagrams/$id";
511 : olson 1.7
512 :     if (-d $dir)
513 :     {
514 : parrello 1.69 open(F, ">$dir/NAME");
515 :     $new_name =~ s/\n.*$//s;
516 :     print F "$new_name\n";
517 :     close(F);
518 : olson 1.61 }
519 :     }
520 :    
521 :     sub create_new_diagram
522 :     {
523 : olson 1.65 my($self, $fh, $html_fh, $name, $id) = @_;
524 : olson 1.61
525 :     #
526 :     # Get a new id.
527 :     #
528 :    
529 :     my $dir = "$self->{dir}/diagrams";
530 :    
531 :     &FIG::verify_dir($dir);
532 :    
533 :     my $path;
534 :    
535 :     if (defined($id))
536 :     {
537 : parrello 1.69 #
538 :     # Ensure this id doesn't already exist.
539 :     #
540 :    
541 :     $path = "$dir/$id";
542 :    
543 :     if (-d $path)
544 :     {
545 :     confess "Diagram id $id already exists in subsystem $self->{name}";
546 :     }
547 : olson 1.61
548 : olson 1.7 }
549 :     else
550 :     {
551 : parrello 1.69 $id = "d01";
552 : olson 1.61
553 : parrello 1.69 while (1)
554 :     {
555 :     $path = "$dir/$id";
556 :     last unless -e $path;
557 :     $id++;
558 :     }
559 : olson 1.61 }
560 :    
561 :     &FIG::verify_dir($path);
562 :    
563 :     if ($name)
564 :     {
565 : parrello 1.69 open(F, ">$path/NAME");
566 :     $name =~ s/\n.*$//s;
567 :     print F "$name\n";
568 :     close(F);
569 : olson 1.61 }
570 :    
571 :     #
572 :     # Write the file if we have one.
573 :     #
574 :    
575 :     if ($fh)
576 :     {
577 : parrello 1.69 my($ext, $buf);
578 : parrello 1.73
579 : parrello 1.69 if (read($fh, $buf, 4096))
580 :     {
581 :     my($ext) = $self->classify_image_type($buf);
582 :     open(D, ">$path/diagram$ext");
583 :     print D $buf;
584 : parrello 1.73
585 : parrello 1.69 while (read($fh, $buf, 4096))
586 :     {
587 :     print D $buf;
588 :     }
589 :     close(D);
590 :     }
591 :     close($fh);
592 : olson 1.7 }
593 : olson 1.65
594 :     #
595 :     # And write the HTML file if we have one.
596 :     #
597 :     if ($html_fh)
598 :     {
599 : parrello 1.69 my $buf;
600 :     open(D, ">$path/diagram.html");
601 : parrello 1.73
602 : parrello 1.69 while (read($html_fh, $buf, 4096))
603 :     {
604 :     print D $buf;
605 :     }
606 :     close(D);
607 :     close($html_fh);
608 : olson 1.65 }
609 : paarmann 1.98
610 :     return $id;
611 : olson 1.7 }
612 : parrello 1.60
613 : olson 1.65 sub upload_new_image
614 :     {
615 :     my($self, $id, $fh) = @_;
616 :    
617 : olson 1.67 if (!$fh)
618 :     {
619 : parrello 1.69 warn "Subsystem::upload_new_image aborting: fh is undef\n";
620 :     return;
621 : olson 1.67 }
622 :    
623 : olson 1.65
624 :     my $dir = "$self->{dir}/diagrams/$id";
625 :    
626 : olson 1.67 if (not -d $dir)
627 :     {
628 : parrello 1.69 warn "Subsystem::upload_new_image aborting: $dir does not exist\n";
629 :     return;
630 : olson 1.67 }
631 : olson 1.65
632 :     #
633 :     # remove any old diagram images.
634 :     #
635 :    
636 :     for my $path (<$dir/diagram.{png,gif,jpg}>)
637 :     {
638 : parrello 1.69 unlink($path);
639 : olson 1.65 }
640 :    
641 :     my($ext, $buf);
642 : parrello 1.73
643 : olson 1.65 if (read($fh, $buf, 4096))
644 :     {
645 : parrello 1.69 my($ext) = $self->classify_image_type($buf);
646 : olson 1.67
647 : parrello 1.69 if (!open(D, ">$dir/diagram$ext"))
648 :     {
649 :     warn "Subsystem::upload_new_image open failed for $dir/diagram$ext: $!\n";
650 :     close($fh);
651 :     return;
652 :     }
653 :    
654 :     warn "Subsystem::upload_new_image classified new image as $ext\n";
655 :     print D $buf;
656 : parrello 1.73
657 : parrello 1.69 while (read($fh, $buf, 4096))
658 :     {
659 :     print D $buf;
660 :     }
661 :     close(D);
662 : olson 1.65 }
663 : olson 1.67 else
664 :     {
665 : parrello 1.69 warn "Subsystem::upload_new_image read failed for $fh: $!\n";
666 : olson 1.67 }
667 :    
668 :     warn "Subsystem::upload_new_image complete: " . `/bin/ls -l '$dir'`;
669 :    
670 : olson 1.65 close($fh);
671 :     }
672 :    
673 :     sub upload_new_html
674 :     {
675 :     my($self, $id, $fh) = @_;
676 :    
677 : olson 1.67 if (!$fh)
678 :     {
679 : parrello 1.69 warn "Subsystem::upload_new_html aborting: fh is undef\n";
680 :     return;
681 : olson 1.67 }
682 : olson 1.65
683 :     my $dir = "$self->{dir}/diagrams/$id";
684 :    
685 : olson 1.67 if (not -d $dir)
686 :     {
687 : parrello 1.69 warn "Subsystem::upload_new_html aborting: $dir does not exist\n";
688 :     return;
689 : olson 1.67 }
690 : olson 1.65
691 :     my($buf);
692 :    
693 : olson 1.67 if (!open(D, ">$dir/diagram.html"))
694 :     {
695 : parrello 1.69 warn "Subsystem::upload_new_html open failed for $dir/diagram.html: $!\n";
696 :     return;
697 : olson 1.67 }
698 : olson 1.65
699 : olson 1.67 my $rc;
700 :     while ($rc = read($fh, $buf, 4096))
701 : olson 1.65 {
702 : parrello 1.69 print D $buf;
703 : olson 1.65 }
704 : olson 1.67 if (!defined($rc))
705 :     {
706 : parrello 1.69 warn "Subsystem::upload_new_html read failed for $fh: $!\n";
707 : olson 1.67 }
708 :    
709 :     warn "Subsystem::upload_new_html complete: " . `/bin/ls -l '$dir'`;
710 :    
711 : olson 1.65 close(D);
712 :     close($fh);
713 :     }
714 :    
715 :     sub classify_image_type
716 :     {
717 :     my($self, $buf) = @_;
718 :    
719 :     my $ext;
720 : parrello 1.73
721 : olson 1.65 #
722 :     # Determine file type, for PNG / JPG / GIF. If we could be assured
723 :     # the ImageMagick identify app worked properly, we'd use that instead.
724 :     #
725 :     # Maybe later.
726 :     #
727 : parrello 1.73
728 : olson 1.65 if (substr($buf, 0, 8) eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a")
729 :     {
730 : parrello 1.69 $ext = ".png";
731 : olson 1.65 }
732 :     elsif (substr($buf, 0, 3) eq "GIF")
733 :     {
734 : parrello 1.69 $ext = ".gif";
735 : olson 1.65 }
736 :     elsif (substr($buf, 0, 2) eq "\xff\xd8" and substr($buf, 6, 4) eq "JFIF")
737 :     {
738 : parrello 1.69 $ext = ".jpg";
739 : olson 1.65 }
740 :     else
741 :     {
742 : parrello 1.69 warn "Unknown file type in new diagram\n";
743 :     $ext = ".png";
744 : olson 1.65 }
745 :    
746 :     return $ext;
747 :     }
748 :    
749 :    
750 : olson 1.7 #
751 : olson 1.5 # Synchronize the database index for this subsystem to the
752 :     # subsystem data.
753 :     #
754 :     # We assume the table already exists.
755 : parrello 1.60 #
756 : olson 1.5
757 :     sub db_sync
758 :     {
759 :     my($self, $skip_delete) = @_;
760 :    
761 : olson 1.84 if ($self->{empty_ss})
762 :     {
763 :     warn "Not synching empty subsystem $self->{name}\n";
764 :     return;
765 :     }
766 :    
767 : olson 1.5 my $rdbH = $self->{fig}->db_handle();
768 :    
769 :     if (!$skip_delete)
770 :     {
771 : parrello 1.69 $self->delete_indices();
772 : overbeek 1.94 $self->delete_aux();
773 :     }
774 :    
775 :     my @aux_roles = map { $self->get_subsetC_roles($_) }
776 :     grep { $_ =~ /^(AUX|auxiliary)/ }
777 :     $self->get_subset_namesC;
778 :    
779 :     my $nameQ = quotemeta $self->{name};
780 :     foreach my $role (@aux_roles)
781 :     {
782 :     my $roleQ = quotemeta $role;
783 :     $rdbH->SQL("INSERT INTO aux_roles ( subsystem, role) VALUES ('$nameQ','$roleQ')");
784 : olson 1.5 }
785 :    
786 : olson 1.57 my $tmp = "$FIG_Config::temp/ixsub.$$";
787 :     open(TMP, ">$tmp") or die "Cannot open tmpfile $tmp: $!\n";
788 :    
789 : olson 1.5 #
790 :     # We run thru all the cells, writing an entry in the database for the peg/subsystem/role.
791 :     #
792 :    
793 : olson 1.70 # my $sth = $rdbH->{_dbh}->prepare("INSERT INTO subsystem_index values(?, ?, ?, ?)");
794 : olson 1.6
795 : olson 1.70 my @roles = $self->get_roles();
796 :     for my $genome ($self->get_genomes())
797 : olson 1.5 {
798 : olson 1.70 my $gidx = $self->get_genome_index($genome);
799 :     my $variant = $self->get_variant_code($gidx);
800 : olson 1.71 # print "Index $genome variant=$variant\n";
801 : olson 1.70 my $row = $self->get_row($gidx);
802 :    
803 :     for my $i (0..$#$row)
804 :     {
805 :     my $cell = $row->[$i];
806 :     my $role = $roles[$i];
807 :     if ($cell)
808 :     {
809 :     for my $peg (@$cell)
810 :     {
811 :     # $sth->execute($peg, $self->{name}, $role);
812 :     if ($self->{old_database})
813 :     {
814 :     print TMP "$peg\t$self->{name}\t$role\n";
815 :     }
816 :     else
817 :     {
818 :     print TMP "$peg\t$self->{name}\t$role\t$variant\n";
819 :     }
820 :     }
821 :     }
822 :     }
823 : olson 1.5 }
824 : olson 1.57 close(TMP);
825 :     $rdbH->load_table(file => $tmp,
826 : parrello 1.69 tbl => 'subsystem_index');
827 : olson 1.5 }
828 :    
829 : olson 1.22 #
830 :     # Delete this subsystem's entries from the database index.
831 :     #
832 :     sub delete_indices
833 :     {
834 :     my($self) = @_;
835 :    
836 :     my $rdbH = $self->{fig}->db_handle();
837 :    
838 : olson 1.70 $rdbH->SQL("DELETE FROM subsystem_index where subsystem = ?", undef, $self->{name});
839 : olson 1.22 }
840 :    
841 : overbeek 1.94 sub delete_aux
842 :     {
843 :     my($self) = @_;
844 :    
845 :     my $rdbH = $self->{fig}->db_handle();
846 :    
847 :     $rdbH->SQL("DELETE FROM aux_roles where subsystem = ?", undef, $self->{name});
848 :     }
849 :    
850 :     sub is_aux_role {
851 :     my($self,$role) = @_;
852 :    
853 :     my $rdbH = $self->{fig}->db_handle();
854 : overbeek 1.95 if (! $rdbH->table_exists('aux_roles')) { return 0 }
855 : overbeek 1.94 my $nameQ = quotemeta $self->{name};
856 :     my $roleQ = quotemeta $role;
857 :     my $q = "SELECT subsystem FROM aux_roles WHERE subsystem = '$nameQ' AND role = '$roleQ'";
858 :    
859 :     my $relational_db_response;
860 :     return (($relational_db_response = $rdbH->SQL($q)) && (@$relational_db_response > 0));
861 :     }
862 :    
863 :    
864 : olson 1.1 sub load
865 :     {
866 :     my($self) = @_;
867 :    
868 :     #
869 :     # Load the subsystem.
870 :     #
871 :    
872 :     my $ssa;
873 :     if (!open($ssa,"<$self->{dir}/spreadsheet"))
874 :     {
875 : heiko 1.87 Trace("Spreadsheet does not exist in subsystem $self->{name}") if T(1);
876 : olson 1.84 $self->{empty_ss}++;
877 : parrello 1.69 return;
878 : olson 1.1 }
879 :    
880 :     local $/ = "//\n";
881 :    
882 :     my $roles = <$ssa>;
883 :     if ($roles)
884 :     {
885 : parrello 1.69 $roles =~ s,$/$,,;
886 :     #
887 :     # Split on newline, filter for non-empty lines.
888 :     #
889 :     my @roles = split("\n", $roles);
890 : parrello 1.60
891 : parrello 1.69 @roles = grep { $_ ne "" } @roles;
892 : parrello 1.60
893 : parrello 1.69 $self->load_roles(@roles);
894 : olson 1.1 }
895 :    
896 :     my $subsets = <$ssa>;
897 :     if ($subsets)
898 :     {
899 : parrello 1.69 $subsets =~ s,$/$,,;
900 :     $self->load_subsets($subsets);
901 : olson 1.1 }
902 :    
903 :     $/ = "\n";
904 :    
905 : overbeek 1.35 $self->load_row_subsets();
906 : olson 1.1 $self->load_genomes($ssa);
907 :    
908 :     #
909 :     # Now load the rest of the info.
910 :     #
911 :    
912 : overbeek 1.58 $self->load_reactions();
913 : olson 1.105 $self->load_hope_kegg_info();
914 :     $self->load_hope_reactions();
915 :     $self->load_hope_reaction_notes();
916 :     $self->load_hope_reaction_links();
917 :     $self->load_hope_curation_notes();
918 : olson 1.1 $self->load_notes();
919 : redwards 1.44 $self->load_classification();
920 : olson 1.1 $self->load_version();
921 :     $self->load_exchangable();
922 : olson 1.17 $self->load_curation();
923 : olson 1.84
924 :     return 1;
925 : olson 1.1 }
926 :    
927 :     sub load_notes
928 :     {
929 :     my($self) = @_;
930 :    
931 :     $self->{notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "notes"));
932 :     }
933 :    
934 : olson 1.105 sub load_hope_kegg_info
935 :     {
936 :     my($self) =@_;
937 :    
938 :     if (open(HOPE_KEGG,"<$self->{dir}/hope_kegg_info"))
939 :     {
940 :     my @lines = <HOPE_KEGG>;
941 :    
942 :     for (my $i = 0; $i < scalar @lines; $i += 6)
943 :     {
944 :     if (defined $lines[$i])
945 :     {
946 :     chomp $lines[$i];
947 :     $self->add_hope_scenario($lines[$i]);
948 :     }
949 :     if (defined $lines[$i+1])
950 :     {
951 :     chomp $lines[$i+1];
952 :     $self->set_hope_input_compounds($lines[$i], $lines[$i+1]);
953 :     }
954 :     if (defined $lines[$i+2])
955 :     {
956 :     chomp $lines[$i+2];
957 :     $self->set_hope_output_compounds($lines[$i], $lines[$i+2]);
958 :     }
959 :     if (defined $lines[$i+3])
960 :     {
961 :     chomp $lines[$i+3];
962 :     $self->set_hope_map_ids($lines[$i], $lines[$i+3]);
963 :     }
964 :     if (defined $lines[$i+4])
965 :     {
966 :     chomp $lines[$i+4];
967 :     $self->set_hope_additional_reactions($lines[$i], $lines[$i+4]);
968 :     }
969 :     if (defined $lines[$i+5])
970 :     {
971 :     chomp $lines[$i+5];
972 :     $self->set_hope_ignore_reactions($lines[$i], $lines[$i+5]);
973 :     }
974 :     }
975 :    
976 :     close(HOPE_KEGG);
977 :     }
978 :     }
979 :    
980 :     sub load_hope_curation_notes
981 :     {
982 :     my($self) = @_;
983 :    
984 :     $self->{hope_curation_notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "hope_curation_notes"));
985 :     }
986 :    
987 : overbeek 1.58 sub load_reactions
988 :     {
989 :     my($self) = @_;
990 :    
991 :     my $reactions = undef;
992 :     if (open(REACT,"<$self->{dir}/reactions"))
993 :     {
994 : parrello 1.69 while (defined($_ = <REACT>))
995 :     {
996 :     if ($_ =~ /^(\S.*\S)\t(\S+)/)
997 :     {
998 :     push(@{$reactions->{$1}},split(/,\s*/,$2));
999 :     }
1000 :     }
1001 :     close(REACT);
1002 : overbeek 1.58 }
1003 :    
1004 :     $self->{reactions} = $reactions;
1005 :     }
1006 : olson 1.105 sub load_hope_reactions
1007 :     {
1008 :     my($self) = @_;
1009 :    
1010 :     my $hope_reactions = {};
1011 :     if (open(HOPE_REACT,"<$self->{dir}/hope_reactions"))
1012 :     {
1013 :     while (defined($_ = <HOPE_REACT>))
1014 :     {
1015 :     if ($_ =~ /^(\S.*\S)\t(\S+)/)
1016 :     {
1017 :     my ($role, $reactions) = ($1, $2);
1018 :    
1019 :     if ($self->get_role_index($role) >= 0)
1020 :     {
1021 :     push(@{$hope_reactions->{$role}},split(/,\s*/,$reactions));
1022 :     }
1023 :     else
1024 :     {
1025 :     print STDERR "\nIgnoring obsolete role '$role' for ", $self->get_name,
1026 :     ", role index is ", $self->get_role_index($role), "\n";
1027 :     }
1028 :     }
1029 :     }
1030 :     close(HOPE_REACT);
1031 :     }
1032 :    
1033 :     $self->{hope_reactions} = $hope_reactions;
1034 :     }
1035 :    
1036 :     sub load_hope_reaction_notes
1037 :     {
1038 :     my($self) = @_;
1039 :    
1040 :     my $hope_reaction_notes = {};
1041 :     if (open(HOPE_REACTION_NOTES,"<$self->{dir}/hope_reaction_notes"))
1042 :     {
1043 :     while (defined($_ = <HOPE_REACTION_NOTES>))
1044 :     {
1045 :     if ($_ =~ /^(\S.*\S)\t(.+)$/)
1046 :     {
1047 :     $hope_reaction_notes->{$1} = $2;
1048 :     }
1049 :     }
1050 :     close(HOPE_REACTION_NOTES);
1051 :     }
1052 :    
1053 :     $self->{hope_reaction_notes} = $hope_reaction_notes;
1054 :     }
1055 :    
1056 :     sub load_hope_reaction_links
1057 :     {
1058 :     my($self) = @_;
1059 :    
1060 :     my $hope_reaction_links = undef;
1061 :     if (open(HOPE_REACTION_LINKS,"<$self->{dir}/hope_reaction_links"))
1062 :     {
1063 :     while (defined($_ = <HOPE_REACTION_LINKS>))
1064 :     {
1065 :     if ($_ =~ /^(\S.*\S)\t(.+)$/)
1066 :     {
1067 :     $hope_reaction_links->{$1} = $2;
1068 :     }
1069 :     }
1070 :     close(HOPE_REACTION_LINKS);
1071 :     }
1072 :    
1073 :     $self->{hope_reaction_links} = $hope_reaction_links;
1074 :     }
1075 : overbeek 1.58
1076 : redwards 1.44 sub load_classification
1077 :     {
1078 :     my($self) = @_;
1079 :    
1080 :     my $class = &FIG::file_read(File::Spec->catfile($self->{dir}, "CLASSIFICATION"));
1081 :     if ($class) {$self->{classification} = [split /\t/, $class]} else {$self->{classification} = ['', '', '']}
1082 :     }
1083 :    
1084 : olson 1.17 sub load_curation
1085 :     {
1086 :     my($self) = @_;
1087 :    
1088 : overbeek 1.47 # my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "curation.log"), 1);
1089 :     #
1090 :     # $_ = $l[0];
1091 :     # chomp;
1092 : olson 1.17
1093 : overbeek 1.47 if (open(LOG,"<$self->{dir}/curation.log"))
1094 : olson 1.17 {
1095 : parrello 1.69 while (defined($_ = <LOG>))
1096 :     {
1097 :     if (/^\d+\t(\S+)\s+started/)
1098 :     {
1099 :     $self->{curator} = $1;
1100 :     }
1101 :     }
1102 :     close(LOG);
1103 : olson 1.17 }
1104 :     }
1105 :    
1106 : olson 1.1 sub load_version
1107 :     {
1108 :     my($self) = @_;
1109 :    
1110 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "VERSION"), 1);
1111 :     my $l = $l[0];
1112 :     chomp $l;
1113 :     $self->{version} = $l;
1114 :     }
1115 :    
1116 :     sub load_exchangable
1117 :     {
1118 :     my($self) = @_;
1119 :    
1120 :     my $file = File::Spec->catfile($self->{dir}, "EXCHANGABLE");
1121 :    
1122 :     if (-f $file)
1123 :     {
1124 : parrello 1.69 my($l, @l);
1125 : olson 1.1
1126 : parrello 1.69 @l = &FIG::file_head($file, 1);
1127 :     $l = $l[0];
1128 :     chomp $l;
1129 :     $self->{exchangable} = $l;
1130 : olson 1.1 }
1131 :     else
1132 :     {
1133 : parrello 1.69 $self->{exchangable} = 0;
1134 : olson 1.1 }
1135 :     }
1136 :    
1137 :    
1138 :     sub load_roles
1139 :     {
1140 :     my($self, @roles) = @_;
1141 :    
1142 : olson 1.5 $self->{abbr} = {};
1143 :     $self->{role_index} = {};
1144 :     $self->{roles} = [];
1145 :     $self->{role_abbrs} = [];
1146 :    
1147 : olson 1.25 my $i = 0;
1148 : olson 1.1 for my $role (@roles)
1149 :     {
1150 : parrello 1.69 my($abbr, $name) = split(/\t/, $role);
1151 :     $abbr =~ s/^\s+//;
1152 :     $abbr =~ s/\s+$//;
1153 :     $name =~ s/^\s+//;
1154 :     $name =~ s/\s+$//;
1155 :     # print "Role $i: abbr=$abbr name=$name\n";
1156 :    
1157 :     $self->{abbr}->{$abbr} = $name;
1158 :     $self->{role_index}->{$name} = $i;
1159 :     $self->{roles}->[$i] = $name;
1160 :     $self->{role_abbrs}->[$i] = $abbr;
1161 :     $i++;
1162 : olson 1.1 }
1163 :     }
1164 : parrello 1.60
1165 : olson 1.1 sub load_subsets
1166 :     {
1167 :     my($self, $subsets) = @_;
1168 :    
1169 :     #
1170 :     # Column and row subsets.
1171 :     #
1172 :     my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);
1173 :    
1174 :     #
1175 :     # Handle column subsets.
1176 :     #
1177 :    
1178 :     my @subsetsC = split(/\n/, $subsetsC);
1179 :    
1180 :     #
1181 :     # Determine active subset.
1182 :     #
1183 :    
1184 :     my $active_subsetC;
1185 :     if (@subsetsC > 0)
1186 :     {
1187 : parrello 1.69 $active_subsetC = pop(@subsetsC);
1188 : olson 1.1 }
1189 :     else
1190 :     {
1191 : parrello 1.69 $active_subsetC = 'All';
1192 : olson 1.1 }
1193 :    
1194 :     $self->{col_active_subset} = $active_subsetC;
1195 :    
1196 :     $self->{col_subsets} = [];
1197 : olson 1.5 $self->{col_subset_members} = {};
1198 : parrello 1.60
1199 : olson 1.1 for my $subset (@subsetsC)
1200 :     {
1201 : parrello 1.69 my($name, @members) = split(/\s+/, $subset);
1202 : olson 1.1
1203 : parrello 1.69 #
1204 :     # File format has members 1-based.
1205 :     #
1206 :    
1207 :     @members = map { $_ - 1 } @members;
1208 :    
1209 :     push(@{$self->{col_subsets}}, $name);
1210 :    
1211 :     #
1212 :     # Map role members from name to index if necessary.
1213 :     #
1214 :     # Is it really necessary? ssa2 code was looking up in %pos for this.
1215 :     #
1216 :     @members = map {
1217 :     if (my $new = $self->{role_index}->{$_})
1218 :     {
1219 :     $new;
1220 :     }
1221 :     else
1222 :     {
1223 :     $_;
1224 :     }
1225 :     } @members;
1226 : olson 1.1
1227 : parrello 1.69 @{$self->{col_subset_members}->{$name}} = @members;
1228 : olson 1.1 }
1229 :    
1230 :     #
1231 :     # Now the row subsets.
1232 :     #
1233 :    
1234 :     chomp($subsetsR);
1235 :    
1236 :     if ($subsetsR =~ /(\S+.*\S+)/)
1237 :     {
1238 : parrello 1.69 $self->{row_active_subset} = $1;
1239 : olson 1.1 }
1240 :     else
1241 :     {
1242 : parrello 1.69 $self->{row_active_subset} = 'All';
1243 : olson 1.1 }
1244 : overbeek 1.35 $self->{row_subsets} = [];
1245 : olson 1.1 }
1246 :    
1247 :     sub load_genomes
1248 :     {
1249 :     my($self, $fh) = @_;
1250 :     my(%seen);
1251 :    
1252 : olson 1.5 $self->{spreadsheet} = [];
1253 : olson 1.29 $self->{spreadsheet_inv} = [];
1254 : olson 1.5 $self->{genome} = [];
1255 :     $self->{genome_index} = {};
1256 :     $self->{variant_code} = [];
1257 : parrello 1.91 $self->{peg_roles} = {};
1258 : olson 1.5
1259 : olson 1.25 my $nr = @{$self->{roles}};
1260 :    
1261 :     my $i = 0;
1262 : olson 1.1 while (<$fh>)
1263 :     {
1264 : parrello 1.69 next if ($_ =~ /^\/\//);
1265 :     chomp;
1266 :    
1267 :     my($genome, $variant_code, @row) = split(/\t/, $_, $nr + 2);
1268 :     $variant_code =~ s/ //g;
1269 : overbeek 1.82 next if ($seen{$genome} || (! $self->{fig}->is_genome($genome)));
1270 : parrello 1.69 $seen{$genome}++;
1271 :    
1272 :     my $j = 0;
1273 :    
1274 :     $self->{genome}->[$i] = $genome;
1275 :     $self->{genome_index}->{$genome} = $i;
1276 :     $self->{variant_code}->[$i] = $variant_code;
1277 : olson 1.1
1278 : parrello 1.69 my $thislen = @row;
1279 :    
1280 :     # if ($thislen != $nr)
1281 :     # {
1282 :     # warn "Genome $genome has wrong column count ($thislen != $nr)\n";
1283 :     # warn "<$_> $genome $variant_code '", join(":", @row), "'\n";
1284 :     # }
1285 :    
1286 :     for my $j (0..$nr - 1)
1287 :     {
1288 :     my $entry = $row[$j];
1289 : overbeek 1.99 # OLD my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
1290 :     my $e2 = [map { ($_ =~ /^[a-zA-Z]+\.\d+$/) ? "fig|$genome.$_" : "fig|$genome.peg.$_" }
1291 :     split(/,/, $entry)
1292 :     ];
1293 : parrello 1.69 $self->{spreadsheet}->[$i]->[$j] = $e2;
1294 :     $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
1295 : parrello 1.91 for my $fidj (@{$e2}) {
1296 :     push @{$self->{peg_roles}->{$fidj}}, $j;
1297 :     }
1298 : parrello 1.69 $j++;
1299 :     }
1300 :     $i++;
1301 : parrello 1.60
1302 : olson 1.1 }
1303 :     }
1304 :    
1305 : olson 1.92 sub add_virtual_genome
1306 :     {
1307 :     my($self, $name, $genome, $variant, $bindings) = @_;
1308 :    
1309 :     my $gidx = @{$self->{genome}};
1310 :    
1311 :     $self->{genome}->[$gidx] = $genome;
1312 :     $self->{genome_index}->{$genome} = $gidx;
1313 :     $self->{variant_code}->[$gidx] = $variant;
1314 :    
1315 :     for my $role (keys %$bindings)
1316 :     {
1317 :     my $role_idx = $self->get_role_index($role);
1318 :    
1319 :     my $plist = $bindings->{$role};
1320 :    
1321 :     # warn "Role $role maps to $role_idx with pegs @$plist\n";
1322 :    
1323 :     $self->{spreadsheet}->[$gidx]->[$role_idx] = $plist;
1324 :     $self->{spreadsheet_inv}->[$role_idx]->[$gidx] = $plist;
1325 :     for my $peg (@$plist)
1326 :     {
1327 :     # warn "Peg $peg => $role_idx\n";
1328 :     push(@{$self->{peg_roles}->{$peg}}, $role_idx);
1329 :     }
1330 :     }
1331 :     # warn "After add virtual: \n", Dumper($self), "\n";
1332 :     }
1333 :    
1334 : parrello 1.91 =head3 get_peg_roles
1335 :    
1336 :     C<< my @cols = $sub->get_peg_roles($peg); >>
1337 :    
1338 :     Return the column numbers in which the specified PEG appears.
1339 :    
1340 :     =over 4
1341 :    
1342 :     =item peg
1343 :    
1344 :     ID of the feature whose roles are desired.
1345 :    
1346 :     =item RETURN
1347 :    
1348 :     Returns a list of the column numbers in which the peg appears, or an empty
1349 :     list if it is not found.
1350 :    
1351 :     =back
1352 :    
1353 :     =cut
1354 :    
1355 :     sub get_peg_roles {
1356 :     # Get the parameters.
1357 :     my ($self, $peg) = @_;
1358 :     # Declare the return variable.
1359 :     my @retVal;
1360 :     # Find this peg's roles.
1361 :     if (exists $self->{peg_roles}->{$peg}) {
1362 :     @retVal = @{$self->{peg_roles}->{$peg}};
1363 :     }
1364 :     # Return the result.
1365 :     return @retVal;
1366 :     }
1367 :    
1368 : parrello 1.73 =head3 write_subsystem
1369 : olson 1.25
1370 :     Write the subsystem to the disk. Updates on-disk data with notes,
1371 :     etc. Perform backups when necessary.
1372 :    
1373 :     =cut
1374 :    
1375 :     sub write_subsystem
1376 :     {
1377 : olson 1.68 my($self, $force_backup) = @_;
1378 : olson 1.25
1379 :     my $dir = $self->{dir};
1380 :     my $fig = $self->{fig};
1381 :    
1382 :     #
1383 :     # We first move the existing spreadsheet and notes files (if present)
1384 :     # to spreadsheet~ and notes~, and current state.
1385 :     #
1386 :    
1387 :     my $ss_file = "$dir/spreadsheet";
1388 :     my $ss_bak = "$dir/spreadsheet~";
1389 :     my $notes_file = "$dir/notes";
1390 :     my $notes_bak = "$dir/notes~";
1391 : overbeek 1.58 my $reactions_file = "$dir/reactions";
1392 :     my $reactions_bak = "$dir/reactions~";
1393 : olson 1.105 my $hope_kegg_info_file = "$dir/hope_kegg_info";
1394 :     my $hope_kegg_info_bak = "$dir/hope_kegg_info~";
1395 :     my $hope_reactions_file = "$dir/hope_reactions";
1396 :     my $hope_reactions_bak = "$dir/hope_reactions~";
1397 :     my $hope_reaction_notes_file = "$dir/hope_reaction_notes";
1398 :     my $hope_reaction_notes_bak = "$dir/hope_reaction_notes~";
1399 :     my $hope_reaction_links_file = "$dir/hope_reaction_links";
1400 :     my $hope_reaction_links_bak = "$dir/hope_reaction_links~";
1401 :     my $hope_curation_notes_file = "$dir/hope_curation_notes";
1402 :     my $hope_curation_notes_bak = "$dir/hope_curation_notes~";
1403 : redwards 1.44 my $classification_file = "$dir/CLASSIFICATION";
1404 : olson 1.25
1405 :     if (-f $ss_file)
1406 :     {
1407 : parrello 1.69 rename($ss_file, $ss_bak);
1408 : olson 1.25 }
1409 :    
1410 :     if (-f $notes_file)
1411 :     {
1412 : parrello 1.69 rename($notes_file, $notes_bak);
1413 : olson 1.25 }
1414 :    
1415 : overbeek 1.58 if (-f $reactions_file)
1416 :     {
1417 : parrello 1.69 rename($reactions_file, $reactions_bak) or warn "rename $reactions_file $reactions_bak failed $!";
1418 :     # print STDERR "wrote $reactions_bak\n";
1419 : overbeek 1.58 }
1420 :    
1421 : olson 1.105 if( -f $hope_kegg_info_file)
1422 :     {
1423 :     rename($hope_kegg_info_file, $hope_kegg_info_bak) or warn "rename $hope_kegg_info_file $hope_kegg_info_bak failed $!";
1424 :     }
1425 :    
1426 :     if (-f $hope_reactions_file)
1427 :     {
1428 :     rename($hope_reactions_file, $hope_reactions_bak) or warn "rename $hope_reactions_file $hope_reactions_bak failed $!";
1429 :     # print STDERR "wrote $hope_reactions_bak\n";
1430 :     }
1431 :    
1432 :     if (-f $hope_reaction_notes_file)
1433 :     {
1434 :     rename($hope_reaction_notes_file, $hope_reaction_notes_bak) or warn "rename $hope_reaction_notes_file $hope_reaction_notes_bak failed $!";
1435 :     # print STDERR "wrote $hope_reaction_notes_bak\n";
1436 :     }
1437 :    
1438 :     if (-f $hope_reaction_links_file)
1439 :     {
1440 :     rename($hope_reaction_links_file, $hope_reaction_links_bak) or warn "rename $hope_reaction_links_file $hope_reaction_links_bak failed $!";
1441 :     # print STDERR "wrote $hope_reaction_links_bak\n";
1442 :     }
1443 :    
1444 :     if (-f $hope_curation_notes_file)
1445 :     {
1446 :     rename($hope_curation_notes_file, $hope_curation_notes_bak) or warn "rename $hope_curation_notes_file $hope_curation_notes_bak failed $!";
1447 :     # print STDERR "wrote $hope_curation_notes_bak\n";
1448 :     }
1449 :    
1450 : olson 1.25 #
1451 :     # Eval this whole chunk, so that if we get any fatal errors, we can
1452 :     # roll back to the old saved data.
1453 :     #
1454 : parrello 1.60
1455 : olson 1.25 eval {
1456 : parrello 1.69 my $fh;
1457 :     open($fh, ">$ss_file") or die "Cannot open $ss_file for writing: $!\n";
1458 :     $self->write_spreadsheet($fh);
1459 :     close($fh);
1460 :     chmod(0777,$ss_file);
1461 :    
1462 :     open($fh, ">$notes_file") or die "Cannot open $notes_file for writing: $!\n";
1463 : overbeek 1.88 print $fh "$self->{notes}";
1464 : parrello 1.69 close($fh);
1465 :     chmod(0777,$notes_file);
1466 :    
1467 :     open($fh, ">$reactions_file") or die "Cannot open $reactions_file for writing: $!\n";
1468 :     my $reactions = $self->{reactions};
1469 :     foreach $_ (sort keys(%$reactions))
1470 :     {
1471 :     print $fh "$_\t" . join(",", @{$reactions->{$_}}), "\n";
1472 :     }
1473 :     close($fh);
1474 :     chmod(0777,$reactions_file);
1475 :    
1476 : olson 1.105 open($fh, ">$hope_kegg_info_file") or die "Cannot open $hope_kegg_info_file for writing: $!\n";
1477 :     foreach my $scenario_name (keys %{$self->{hope_scenarios}})
1478 :     {
1479 :     print $fh $scenario_name, "\n";
1480 :     my $scenario = $self->{hope_scenarios}->{$scenario_name};
1481 :     my $input_compounds = $scenario->{input_compounds};
1482 :     my $temp = join ",", @$input_compounds;
1483 :     print $fh $temp , "\n";
1484 :     my $output_compounds = $scenario->{output_compounds};
1485 :     my @output_compounds_lists;
1486 :     foreach my $cpd_list (@$output_compounds)
1487 :     {
1488 :     if (scalar @$cpd_list > 1)
1489 :     {
1490 :     push @output_compounds_lists, "(".join(",",@$cpd_list).")";
1491 :     }
1492 :     else
1493 :     {
1494 :     push @output_compounds_lists, @$cpd_list;
1495 :     }
1496 :     }
1497 :     $temp = join ",", @output_compounds_lists;
1498 :     print $fh $temp , "\n";
1499 :     my $map_ids = $scenario->{map_ids};
1500 :     $temp = join ",", @$map_ids;
1501 :     print $fh $temp , "\n";
1502 :     my $additional_reactions = $scenario->{additional_reactions};
1503 :     $temp = join ",", @$additional_reactions;
1504 :     print $fh $temp , "\n";
1505 :     my $ignore_reactions = $scenario->{ignore_reactions};
1506 :     $temp = join ",", @$ignore_reactions;
1507 :     print $fh $temp , "\n";
1508 :     }
1509 :    
1510 :     close($fh);
1511 :     chmod(0777,$hope_kegg_info_file);
1512 :    
1513 :     open($fh, ">$hope_reactions_file") or die "Cannot open $hope_reactions_file for writing: $!\n";
1514 :     my $hope_reactions = $self->{hope_reactions};
1515 :     foreach $_ (sort keys(%$hope_reactions))
1516 :     {
1517 :     print $fh "$_\t" . join(",", @{$hope_reactions->{$_}}), "\n";
1518 :     }
1519 :     close($fh);
1520 :     chmod(0777,$hope_reactions_file);
1521 :    
1522 :     open($fh, ">$hope_reaction_notes_file") or die "Cannot open $hope_reaction_notes_file for writing: $!\n";
1523 :     my $hope_reaction_notes = $self->{hope_reaction_notes};
1524 :     foreach $_ (sort keys(%$hope_reaction_notes))
1525 :     {
1526 :     print $fh "$_\t" . $hope_reaction_notes->{$_}, "\n";
1527 :     }
1528 :     close($fh);
1529 :     chmod(0777,$hope_reaction_notes_file);
1530 :    
1531 :     open($fh, ">$hope_reaction_links_file") or die "Cannot open $hope_reaction_links_file for writing: $!\n";
1532 :     my $hope_reaction_links = $self->{hope_reaction_links};
1533 :     foreach $_ (sort keys(%$hope_reaction_links))
1534 :     {
1535 :     print $fh "$_\t" . $hope_reaction_links->{$_}, "\n";
1536 :     }
1537 :     close($fh);
1538 :     chmod(0777,$hope_reaction_links_file);
1539 :    
1540 :     open($fh, ">$hope_curation_notes_file") or die "Cannot open $hope_curation_notes_file for writing: $!\n";
1541 :     print $fh "$self->{hope_curation_notes}";
1542 :     close($fh);
1543 :     chmod(0777,$hope_curation_notes_file);
1544 :    
1545 : parrello 1.69 open($fh, ">$classification_file") or die "Can not open $classification_file for writing: $!\n";
1546 :     print $fh join "\t", (@{$self->{classification}}), "\n";
1547 :     close($fh);
1548 :     chmod(0777,$classification_file);
1549 :    
1550 :     $self->update_curation_log();
1551 :    
1552 :     #
1553 :     # Write out the piddly stuff.
1554 :     #
1555 :    
1556 :     open($fh, ">$dir/EXCHANGABLE") or die "Cannot write $dir/EXCHANGABLE: $!\n";
1557 :     print $fh "$self->{exchangable}\n";
1558 :     close($fh);
1559 :     chmod(0777,"EXCHANGABLE");
1560 :    
1561 :     #
1562 :     # Process backup files. This is the smae process that determines when the
1563 :     # version number should be bumped, so write the version file afterward.
1564 :     #
1565 :    
1566 :     $self->update_backups($force_backup);
1567 :    
1568 :     if ($self->{version} < 100) { $self->{version} += 100 }
1569 :     open($fh, ">$dir/VERSION") or die "Cannot write $dir/VERSION: $!\n";
1570 :     print $fh "$self->{version}\n";
1571 :     close($fh);
1572 :     chmod(0777,"VERSION");
1573 : olson 1.25 };
1574 :    
1575 :     if ($@ ne "")
1576 :     {
1577 : parrello 1.69 warn "Spreadsheet write failed, reverting to backup. Error was\n$@\n";
1578 : olson 1.25 }
1579 : parrello 1.60
1580 : olson 1.25 }
1581 :    
1582 :     sub update_curation_log
1583 :     {
1584 :     my($self) = @_;
1585 :    
1586 :     my $fh;
1587 :     my $file = "$self->{dir}/curation.log";
1588 :    
1589 :     my $now = time;
1590 :     my $user = $self->{fig}->get_user();
1591 :    
1592 :     if (-f $file)
1593 :     {
1594 : parrello 1.69 open($fh, ">>$file") or die "Cannot open $file for writing: $!\n";
1595 : olson 1.25 }
1596 :     else
1597 :     {
1598 : parrello 1.69 open($fh, ">$file") or die "Cannot open $file for writing: $!\n";
1599 :     print $fh "$now\t$user\tstarted\n";
1600 : olson 1.25 }
1601 :     print $fh "$now\t$user\tupdated\n";
1602 :     close($fh);
1603 :     }
1604 :    
1605 :     sub update_backups
1606 :     {
1607 : olson 1.68 my($self, $force_backup) = @_;
1608 : olson 1.25
1609 :     my $dir = $self->{dir};
1610 :     my $fig = $self->{fig};
1611 :    
1612 :     my $ss_file = "$dir/spreadsheet";
1613 :     my $ss_bak = "$dir/spreadsheet~";
1614 :     my $notes_file = "$dir/notes";
1615 :     my $notes_bak = "$dir/notes~";
1616 : overbeek 1.58 my $reactions_file = "$dir/reactions";
1617 :     my $reactions_bak = "$dir/reactions~";
1618 : olson 1.105 my $hope_reactions_file = "$dir/hope_reactions";
1619 :     my $hope_reactions_bak = "$dir/hope_reactions~";
1620 :     my $hope_reaction_notes_file = "$dir/hope_reaction_notes";
1621 :     my $hope_reaction_notes_bak = "$dir/hope_reaction_notes~";
1622 :     my $hope_reaction_links_file = "$dir/hope_reaction_links";
1623 :     my $hope_reaction_links_bak = "$dir/hope_reaction_links~";
1624 :     my $hope_curation_notes_file = "$dir/hope_curation_notes";
1625 :     my $hope_curation_notes_bak = "$dir/hope_curation_notes~";
1626 :     my $hope_kegg_info_file = "$dir/hope_kegg_info";
1627 :     my $hope_kegg_info_bak = "$dir/hope_kegg_info~";
1628 : olson 1.25
1629 :     my $ss_diff = abs((-s $ss_file) - (-s $ss_bak));
1630 :     my $notes_diff = abs((-s $notes_file) - (-s $notes_bak));
1631 : olson 1.68 my $reactions_diff = (system("cmp", "-s", $reactions_file, $reactions_bak) != 0);
1632 : overbeek 1.59 # print STDERR "reactions_file=$reactions_file reactions_bak=$reactions_bak dif=$reactions_diff\n";
1633 : olson 1.105 my $hope_reactions_diff = (system("cmp", "-s", $hope_reactions_file, $hope_reactions_bak) != 0);
1634 :     my $hope_reaction_notes_diff = (system("cmp", "-s", $hope_reaction_notes_file, $hope_reaction_notes_bak) != 0);
1635 :     my $hope_reaction_links_diff = (system("cmp", "-s", $hope_reaction_links_file, $hope_reaction_links_bak) != 0);
1636 :     my $hope_curation_notes_diff = (system("cmp", "-s", $hope_curation_notes_file, $hope_curation_notes_bak) != 0);
1637 :     my $hope_kegg_info_diff = (system("cmp", "-s", $hope_kegg_info_file, $hope_kegg_info_bak) != 0);
1638 : olson 1.25
1639 : olson 1.105 if ($force_backup or ($ss_diff > 10) or ($notes_diff > 10) or $reactions_diff or $hope_reactions_diff or $hope_reaction_notes_diff or $hope_reaction_links_diff or $hope_curation_notes_diff or $hope_kegg_info_diff)
1640 : olson 1.25 {
1641 : parrello 1.69 $self->make_backup();
1642 : olson 1.25 }
1643 :     }
1644 :    
1645 :     sub make_backup
1646 :     {
1647 :     my($self) = @_;
1648 :    
1649 :     my $dir = $self->{dir};
1650 :     my $bak = "$dir/Backup";
1651 :    
1652 :     $self->{fig}->verify_dir($bak);
1653 :    
1654 :     my $ts = time;
1655 :    
1656 :     rename("$dir/spreadsheet~", "$bak/spreadsheet.$ts");
1657 :     rename("$dir/notes~", "$bak/notes.$ts");
1658 : overbeek 1.58 rename("$dir/reactions~", "$bak/reactions.$ts");
1659 : olson 1.105 rename("$dir/hope_reactions~", "$bak/hope_reactions.$ts");
1660 :     rename("$dir/hope_reaction_notes~", "$bak/hope_reaction_notes.$ts");
1661 :     rename("$dir/hope_reaction_links~", "$bak/hope_reaction_links.$ts");
1662 :     rename("$dir/hope_curation_notes~", "$bak/hope_curation_notes.$ts");
1663 :     rename("$dir/hope_kegg_info~", "$bak/hope_kegg_info.$ts");
1664 : olson 1.25 $self->{version}++;
1665 :     }
1666 :    
1667 :    
1668 :    
1669 : parrello 1.73 =head3 write_spreadsheet
1670 : olson 1.25
1671 : parrello 1.73 C<< $sub->write_spreadsheet($fh); >>
1672 : olson 1.25
1673 :     Write the spreadsheet for this subsystem to filehandle $fh.
1674 :    
1675 :     =cut
1676 :    
1677 :     sub write_spreadsheet
1678 :     {
1679 :     my($self, $fh) = @_;
1680 :    
1681 :     $self->_write_roles($fh);
1682 :     print $fh "//\n";
1683 :    
1684 :     $self->_write_subsets($fh);
1685 :     print $fh "//\n";
1686 :    
1687 :     $self->_write_spreadsheet($fh);
1688 :     }
1689 :    
1690 :     sub _write_roles
1691 :     {
1692 :     my($self, $fh) = @_;
1693 :    
1694 :     my(@roles, @abbrs);
1695 :    
1696 :     @roles = $self->get_roles();
1697 :     @abbrs = $self->get_abbrs();
1698 :    
1699 : olson 1.100 #
1700 : olson 1.101 # Check abbreviations for validity. We disallow spaces, commas, and colons,
1701 :     # and enforce uniqueness.
1702 : olson 1.100 #
1703 :    
1704 :     my %abbrs;
1705 : olson 1.101 map { s/[\s,:]*//g; } @abbrs;
1706 : olson 1.100 map { $abbrs{$_}++ } @abbrs;
1707 :    
1708 :     for (my $i = 0; $i < @abbrs; $i++)
1709 :     {
1710 :     my $a = $abbrs[$i];
1711 :     if ($abbrs{$a} > 1)
1712 :     {
1713 :     #
1714 :     # abbrev is not unique
1715 :     #
1716 :     $a = "${a}_" . ($i + 1);
1717 :     $abbrs[$i] = $a;
1718 :     }
1719 :     }
1720 :    
1721 : olson 1.25 while (@roles)
1722 :     {
1723 : parrello 1.69 my $role = shift(@roles);
1724 :     my $abbr = shift(@abbrs);
1725 : olson 1.25
1726 : parrello 1.69 print $fh "$abbr\t$role\n";
1727 : olson 1.25 }
1728 :     }
1729 :    
1730 :     sub _write_subsets
1731 :     {
1732 :     my($self, $fh) = @_;
1733 :    
1734 : overbeek 1.31 for my $sub ($self->get_subset_namesC())
1735 : olson 1.25 {
1736 : parrello 1.69 next if ($sub eq "All");
1737 :     my @members= $self->get_subsetC($sub);
1738 : olson 1.25
1739 : parrello 1.69 #
1740 :     # member list on disk is 1-based
1741 :     #
1742 : olson 1.25
1743 : parrello 1.69 @members = map { $_ + 1 } @members;
1744 :     print $fh join("\t", $sub, @members), "\n";
1745 : olson 1.25 }
1746 : overbeek 1.39 my $active_row_subset = $self->{row_active_subset};
1747 :     my $active_col_subset = $self->{col_active_subset};
1748 :    
1749 :     print $fh "$active_col_subset\n";
1750 : olson 1.25
1751 :     #
1752 :     # separator
1753 :     #
1754 :    
1755 :     print $fh "\n";
1756 : parrello 1.60
1757 : olson 1.25 #
1758 :     # genome subsets.
1759 :     #
1760 :    
1761 : overbeek 1.39 print $fh "$active_row_subset\n";
1762 : olson 1.25 }
1763 :    
1764 :     sub _write_spreadsheet
1765 :     {
1766 :     my($self, $fh) = @_;
1767 :    
1768 :     my(@genomes);
1769 :    
1770 :     @genomes= $self->get_genomes();
1771 :    
1772 :     for (my $i = 0; $i < @genomes; $i++)
1773 :     {
1774 : parrello 1.69 my $genome = $genomes[$i];
1775 :     my $vc = $self->get_variant_code($i);
1776 :    
1777 :     my $row = $self->get_row($i);
1778 :    
1779 :     if ($vc eq "")
1780 :     {
1781 :     $vc = "0";
1782 :     }
1783 :     print $fh "$genome\t$vc";
1784 : olson 1.25
1785 : parrello 1.69 for my $entry (@$row)
1786 :     {
1787 :     my(@p);
1788 : olson 1.25
1789 : parrello 1.69 for my $peg (@$entry)
1790 :     {
1791 : overbeek 1.99 if ($peg =~ /fig\|$genome\.(([a-zA-Z]+)\.(\d+))$/)
1792 : parrello 1.69 {
1793 : overbeek 1.99 push(@p, ($2 eq "peg") ? $3 : $1);
1794 : parrello 1.69 }
1795 :     else
1796 :     {
1797 :     warn "Bad peg $peg in cell for $genome";
1798 :     }
1799 :     }
1800 :     print $fh "\t", join(",", @p);
1801 :     }
1802 :     print $fh "\n";
1803 : olson 1.25 }
1804 :     }
1805 :    
1806 : parrello 1.73 =head3 get_genomes
1807 : olson 1.25
1808 : parrello 1.73 C<< my @genomeList = $sub->get_genomes(); >>
1809 : olson 1.25
1810 : parrello 1.73 Return a list of the genome IDs for this subsystem. Each genome corresponds to a row
1811 :     in the subsystem spreadsheet. Indexing into this list returns the ID of the genome
1812 :     in the specified row.
1813 : olson 1.2
1814 :     =cut
1815 : olson 1.25
1816 : olson 1.2 sub get_genomes
1817 :     {
1818 :     my($self) = @_;
1819 :    
1820 :     my $glist = $self->{genome};
1821 :    
1822 : olson 1.84 return ref($glist) ? @$glist : ();
1823 : olson 1.2 }
1824 :    
1825 : parrello 1.73 =head3 get_variant_codes
1826 :    
1827 :     C<< my @codes = $sub->get_variant_codes(); >>
1828 : olson 1.2
1829 : parrello 1.73 Return a list of the variant codes for each genome, in row index order. The variant
1830 :     code indicates which variation of the subsystem is used by the given genome.
1831 : olson 1.2
1832 :     =cut
1833 : olson 1.25
1834 : olson 1.2 sub get_variant_codes
1835 :     {
1836 :     my($self) = @_;
1837 :    
1838 :     my $glist = $self->{variant_code};
1839 :    
1840 : olson 1.25 return @$glist;
1841 :     }
1842 :    
1843 : parrello 1.73 =head3 get_variant_code
1844 :    
1845 :     C<< my $code = $sub->get_variant_code($gidx); >>
1846 :    
1847 :     Return the variant code for the specified genome. Each subsystem has multiple
1848 :     variants which involve slightly different chemical reactions, and each variant
1849 :     has an associated variant code. When a genome is connected to the spreadsheet,
1850 :     the subsystem variant used by the genome must be specified.
1851 :    
1852 :     =over 4
1853 :    
1854 :     =item gidx
1855 :    
1856 :     Row index for the genome whose variant code is desired.
1857 :    
1858 :     =item RETURN
1859 :    
1860 :     Returns the variant code for the specified genome.
1861 :    
1862 :     =back
1863 :    
1864 :     =cut
1865 :    
1866 : olson 1.25 sub get_variant_code
1867 :     {
1868 :     my($self, $gidx) = @_;
1869 : overbeek 1.46 my $c = $self->{variant_code}->[$gidx];
1870 :     $c =~ s/ //g;
1871 :     return $c;
1872 : olson 1.2 }
1873 :    
1874 : overbeek 1.34 sub set_variant_code
1875 :     {
1876 :     my($self, $gidx, $val) = @_;
1877 :     $self->{variant_code}->[$gidx] = $val;
1878 : olson 1.70
1879 :     #
1880 :     # Update the index for all the pegs in this row.
1881 :     # (only if we have a new database)
1882 :     #
1883 :    
1884 :     if ($self->{old_database})
1885 :     {
1886 :     return;
1887 :     }
1888 : parrello 1.73
1889 : olson 1.70 my $rdbH = $self->{fig}->db_handle();
1890 :     my $dbh = $rdbH->{_dbh};
1891 :     my $cells = $self->get_row($gidx);
1892 :     my $sub_name = $self->{name};
1893 :    
1894 :     my $sth = $dbh->prepare(qq(UPDATE subsystem_index
1895 :     SET variant = ?
1896 :     WHERE (subsystem = ? AND
1897 :     role = ? AND
1898 :     protein = ?)
1899 :     ));
1900 :     for my $i (0 .. $#$cells)
1901 :     {
1902 :     my $cell = $cells->[$i];
1903 :     my $role = $self->get_role($i);
1904 :    
1905 :     for my $peg (@$cell)
1906 :     {
1907 :     $sth->execute($val, $sub_name, $role, $peg);
1908 : olson 1.79 #warn "Update variant $sub_name $role $peg v='$val'\n";
1909 : olson 1.70 }
1910 :     }
1911 :    
1912 : overbeek 1.34 return;
1913 :     }
1914 :    
1915 : olson 1.2 sub get_variant_code_for_genome
1916 :     {
1917 :     my($self, $genome) = @_;
1918 :     my $index = $self->{genome_index}->{$genome};
1919 : redwards 1.55 if (defined $index) {
1920 :     return $self->{variant_code}->[$index];
1921 :     }
1922 :     else {
1923 :     return undef;
1924 :     }
1925 : olson 1.2 }
1926 :    
1927 : parrello 1.73 =head3 get_roles
1928 :    
1929 :     C<< my @roles = $sub->get_roles(); >>
1930 :    
1931 :     Return a list of the subsystem's roles. Each role corresponds to a column
1932 :     in the subsystem spreadsheet. The list entry at a specified position in
1933 :     the list will contain the ID of that column's role.
1934 :    
1935 :     =cut
1936 :    
1937 : olson 1.2 sub get_roles
1938 :     {
1939 :     my($self) = @_;
1940 :    
1941 :     my $rlist = $self->{roles};
1942 :    
1943 : olson 1.83 return ref($rlist) ? @$rlist : ();
1944 : olson 1.25 }
1945 :    
1946 :     sub get_abbrs
1947 :     {
1948 :     my($self) = @_;
1949 :    
1950 :     my $rlist = $self->{role_abbrs};
1951 :    
1952 : olson 1.83 return ref($rlist) ? @$rlist : ();
1953 : heiko 1.87 }
1954 :    
1955 : olson 1.96 =head3 get_abbr_for_role
1956 :    
1957 :     C<< my $abbr = $sub->get_abbr_for_role($name); >>
1958 :    
1959 :     Return the abbreviation for the given role name.
1960 :    
1961 :     =cut
1962 :    
1963 :     sub get_abbr_for_role
1964 :     {
1965 :     my($self, $name) = @_;
1966 :     my $idx = $self->{role_index}->{$name};
1967 :     if (defined($idx))
1968 :     {
1969 :     return $self->{role_abbrs}->[$idx];
1970 :     }
1971 :     else
1972 :     {
1973 :     return undef;
1974 :     }
1975 :     }
1976 :    
1977 :    
1978 :     =head3 get_roles_for_genome
1979 :    
1980 :     C<< my $abbr = $sub->get_roles_for_genome($genome_id); >>
1981 :    
1982 :     Return the list of roles for which the given genome has nonempty cells.
1983 :    
1984 :     =cut
1985 :    
1986 :     sub get_roles_for_genome
1987 :     {
1988 :     my($self, $genome) = @_;
1989 :    
1990 :     my $gidx = $self->{genome_index}->{$genome};
1991 :     return undef unless defined($gidx);
1992 :    
1993 :     my $row = $self->{spreadsheet}->[$gidx];
1994 :    
1995 :     my @out;
1996 :     for my $ridx (0 .. $#$row)
1997 :     {
1998 :     my $cell = $row->[$ridx];
1999 :     if (@$cell > 0)
2000 :     {
2001 :     push(@out, $self->{roles}->[$ridx]);
2002 :     }
2003 :     }
2004 :     return @out;
2005 :     }
2006 : olson 1.2
2007 : olson 1.29 sub roles_with_abbreviations
2008 :     {
2009 :     my($self) = @_;
2010 :    
2011 :     my @ret;
2012 :    
2013 :     for my $i (0..@{$self->{roles}} - 1)
2014 :     {
2015 : parrello 1.69 push(@ret, [$self->{role_abbrs}->[$i], $self->{roles}->[$i]]);
2016 : olson 1.29 }
2017 :     return @ret;
2018 :     }
2019 :    
2020 :    
2021 : olson 1.52 sub get_sorted_rows
2022 :     {
2023 :     my($self, $sort_order) = @_;
2024 :    
2025 :     my $fig = $self->{fig};
2026 :    
2027 :     my @rows;
2028 :     for (my $i = 0; $i < @{$self->{genome}}; $i++)
2029 :     {
2030 : parrello 1.69 my $gid = $self->{genome}->[$i];
2031 :     my $gs = $fig->genus_species($gid);
2032 : olson 1.52
2033 : parrello 1.69 my $q = quotemeta($gid);
2034 :     my $cells = [];
2035 :     for my $c (@{$self->{spreadsheet}->[$i]})
2036 :     {
2037 :     push(@$cells, [map { s/^fig\|$q\.peg\.//; $_ } @$c]);
2038 :     }
2039 : olson 1.52
2040 : parrello 1.69 push(@rows, [$self->{genome}->[$i], $gs, $self->{variant_code}->[$i], $cells]);
2041 : olson 1.52 }
2042 :    
2043 :     if ($sort_order eq "by_phylo")
2044 :     {
2045 : parrello 1.69 return(map { $_->[0] }
2046 :     sort { ($a->[1] cmp $b->[1]) or ($a->[0]->[1] cmp $b->[0]->[1]) }
2047 :     map { [$_, $fig->taxonomy_of($_->[0]) ] } @rows);
2048 : olson 1.52 }
2049 :     elsif ($sort_order eq "alphabetic")
2050 :     {
2051 : parrello 1.69 return sort { ($a->[1] cmp $b->[1]) or ($a->[0] <=> $b->[0]) } @rows;
2052 : olson 1.52 }
2053 :     elsif ($sort_order eq "by_tax_id")
2054 :     {
2055 : parrello 1.69 return sort { $a->[0] <=> $b->[0] } @rows;
2056 : olson 1.52 }
2057 :     else
2058 :     {
2059 : parrello 1.69 return @rows;
2060 : olson 1.52 }
2061 :     }
2062 :    
2063 :    
2064 : parrello 1.60 sub get_row :Scalar
2065 : olson 1.1 {
2066 :     my($self, $row) = @_;
2067 :    
2068 :     return $self->{spreadsheet}->[$row];
2069 :     }
2070 :    
2071 : parrello 1.60 sub get_col :Scalar
2072 : olson 1.1 {
2073 :     my($self, $col) = @_;
2074 :    
2075 :     return $self->{spreadsheet_inv}->[$col];
2076 :     }
2077 :    
2078 : parrello 1.60 sub get_cell :Scalar
2079 : olson 1.1 {
2080 :     my($self, $row, $col) = @_;
2081 :    
2082 : olson 1.5 my $cell = $self->{spreadsheet}->[$row]->[$col];
2083 : overbeek 1.37 if (! defined($cell))
2084 :     {
2085 : parrello 1.69 $cell = $self->{spreadsheet}->[$row]->[$col] = [];
2086 : overbeek 1.37 }
2087 : olson 1.5 return $cell;
2088 : olson 1.1 }
2089 :    
2090 : parrello 1.73 =head3 get_genome_index
2091 :    
2092 :     C<< my $idx = $sub->get_genome_index($genome); >>
2093 :    
2094 :     Return the row index for the genome with the specified ID.
2095 :    
2096 :     =over 4
2097 :    
2098 :     =item genome
2099 :    
2100 :     ID of the genome whose row index is desired.
2101 :    
2102 :     =item RETURN
2103 :    
2104 :     Returns the row index for the genome with the specified ID, or an undefined
2105 :     value if the genome does not participate in the subsystem.
2106 :    
2107 :     =back
2108 :    
2109 :     =cut
2110 :    
2111 : parrello 1.60 sub get_genome_index :Scalar
2112 : olson 1.3 {
2113 :     my($self, $genome) = @_;
2114 :    
2115 :     return $self->{genome_index}->{$genome};
2116 :     }
2117 :    
2118 : parrello 1.60 sub get_genome :Scalar
2119 : olson 1.3 {
2120 :     my($self, $gidx) = @_;
2121 :    
2122 :     return $self->{genome}->[$gidx];
2123 :     }
2124 :    
2125 : parrello 1.73 =head3 get_role_index
2126 :    
2127 :     C<< my $idx = $sub->get_role_index($role); >>
2128 :    
2129 :     Return the column index for the role with the specified ID.
2130 :    
2131 :     =over 4
2132 :    
2133 :     =item role
2134 :    
2135 :     ID (full name) of the role whose column index is desired.
2136 :    
2137 :     =item RETURN
2138 :    
2139 :     Returns the column index for the role with the specified name.
2140 :    
2141 :     =back
2142 :    
2143 :     =cut
2144 :    
2145 : parrello 1.60 sub get_role_index :Scalar
2146 : olson 1.5 {
2147 :     my($self, $role) = @_;
2148 :    
2149 :     return $self->{role_index}->{$role};
2150 :     }
2151 :    
2152 : parrello 1.60 sub get_role :Scalar
2153 : olson 1.3 {
2154 :     my($self, $ridx) = @_;
2155 :    
2156 :     return $self->{roles}->[$ridx];
2157 :     }
2158 :    
2159 : parrello 1.73 =head3 get_role_abbr
2160 :    
2161 :     C<< my $abbr = $sub->get_role_abbr($ridx); >>
2162 :    
2163 :     Return the abbreviation for the role in the specified column. The abbreviation
2164 :     is a shortened identifier that is not necessarily unique, but is more likely to
2165 :     fit in a column heading.
2166 :    
2167 :     =over 4
2168 :    
2169 :     =item ridx
2170 :    
2171 :     Column index for the role whose abbreviation is desired.
2172 :    
2173 :     =item RETURN
2174 :    
2175 :     Returns an abbreviated name for the role corresponding to the indexed column.
2176 :    
2177 :     =back
2178 :    
2179 :     =cut
2180 :    
2181 : parrello 1.60 sub get_role_abbr :Scalar
2182 : olson 1.4 {
2183 :     my($self, $ridx) = @_;
2184 :    
2185 :     return $self->{role_abbrs}->[$ridx];
2186 :     }
2187 :    
2188 : parrello 1.60 sub get_role_from_abbr :Scalar
2189 : olson 1.20 {
2190 :     my($self, $abbr) = @_;
2191 :    
2192 :     return $self->{abbr}->{$abbr};
2193 :     }
2194 :    
2195 : parrello 1.73 =head3 set_pegs_in_cell
2196 : olson 1.26
2197 : parrello 1.73 C<< $sub->set_pegs_in_cell($genome, $role, $peg_list); >>
2198 : olson 1.26
2199 :     Set the cell for the given genome and role to $peg_list.
2200 :    
2201 :     =cut
2202 :    
2203 :     sub set_pegs_in_cell
2204 :     {
2205 :     my($self, $genome, $role, $peg_list) = @_;
2206 :     my($row, $col);
2207 :    
2208 :     #
2209 :     # If row isn't numeric, look it up in the genomes list.
2210 :     #
2211 : parrello 1.60
2212 : olson 1.26 if ($genome !~ /^\d+$/)
2213 :     {
2214 : parrello 1.69 $row = $self->{genome_index}->{$genome};
2215 : olson 1.26 }
2216 :     else
2217 :     {
2218 : parrello 1.69 $row = $genome
2219 : olson 1.26 }
2220 : parrello 1.60
2221 : overbeek 1.37 if (! defined($row))
2222 : olson 1.26 {
2223 : parrello 1.69 print &Dumper($self->{genome_index});
2224 :     confess "Cannot find row for $genome\n";
2225 :     return undef;
2226 : olson 1.26 }
2227 :    
2228 :     #
2229 :     # If col isn't numeric, look it up in the roles and role abbreviations.
2230 :     #
2231 : parrello 1.60
2232 : olson 1.26 if ($role !~ /^\d+$/)
2233 :     {
2234 : parrello 1.69 #
2235 :     # See if it's an abbr
2236 :     #
2237 : olson 1.26
2238 : parrello 1.69 my $a = $self->{abbr}->{$role};
2239 :     $role = $a if $a;
2240 : olson 1.26
2241 : parrello 1.69 $col = $self->{role_index}->{$role};
2242 : olson 1.26 }
2243 :     else
2244 :     {
2245 : parrello 1.69 $col = $role;
2246 : olson 1.26 }
2247 : parrello 1.60
2248 : overbeek 1.37 if (! defined($col))
2249 : olson 1.26 {
2250 : parrello 1.69 print &Dumper($self->{role_index});
2251 :     confess "Cannot find col for $role\n";
2252 :     return undef;
2253 : olson 1.26 }
2254 :     my $cell = $self->get_cell($row, $col);
2255 :    
2256 : olson 1.70
2257 : overbeek 1.37 if (defined($cell))
2258 : olson 1.26 {
2259 : olson 1.70 my $sub_name = $self->{name};
2260 :     my $peg;
2261 :     my $rdbH = $self->{fig}->db_handle();
2262 :     my $dbh = $rdbH->{_dbh};
2263 :    
2264 :     my $variant = $self->get_variant_code($row);
2265 : parrello 1.73
2266 : olson 1.70 if (@$cell > 0)
2267 :     {
2268 :     my $sth = $dbh->prepare(qq(DELETE FROM subsystem_index
2269 :     WHERE (subsystem = ? AND
2270 :     role = ? AND
2271 :     protein = ?)
2272 :     ));
2273 :     foreach $peg (@$cell)
2274 :     {
2275 :     $sth->execute($sub_name, $role, $peg);
2276 : olson 1.93 # warn "Deleting $sub_name $role $peg\n";
2277 : olson 1.70 }
2278 :     }
2279 : parrello 1.73
2280 : olson 1.70 @$cell = @$peg_list;
2281 :    
2282 :     if ($self->{old_database})
2283 :     {
2284 :     my $sth = $rdbH->{_dbh}->prepare(qq(INSERT INTO subsystem_index (protein,subsystem,role)
2285 :     VALUES (?, ?, ?)));
2286 :     foreach $peg (@$cell)
2287 :     {
2288 :     $sth->execute($peg, $sub_name, $role);
2289 : olson 1.93 # warn "Add old $peg $sub_name $role\n";
2290 : olson 1.70 }
2291 :     }
2292 :     else
2293 :     {
2294 :     my $sth = $rdbH->{_dbh}->prepare(qq(INSERT INTO subsystem_index (protein,subsystem,role,variant)
2295 :     VALUES (?, ?, ?, ?)));
2296 :     foreach $peg (@$cell)
2297 :     {
2298 :     $sth->execute($peg, $sub_name, $role, $variant);
2299 : olson 1.79 #warn "Add new $peg $sub_name $role v='$variant'\n";
2300 : olson 1.70 }
2301 :     }
2302 : olson 1.26 }
2303 :     else
2304 :     {
2305 : parrello 1.69 warn "set_pegs_in_cell: Could not find cell!";
2306 : olson 1.26 }
2307 :     }
2308 :    
2309 : parrello 1.73 =head3 get_pegs_from_cell
2310 :    
2311 :     C<< my @pegs = $sub->get_pegs_from_cell($rowstr, $colstr); >>
2312 :    
2313 :     Return a list of the peg IDs for the features in the specified spreadsheet cell.
2314 :    
2315 :     =over 4
2316 :    
2317 :     =item rowstr
2318 :    
2319 :     Genome row, specified either as a row index or a genome ID.
2320 :    
2321 :     =item colstr
2322 :    
2323 :     Role column, specified either as a column index, a role name, or a role
2324 :     abbreviation.
2325 :    
2326 :     =item RETURN
2327 :    
2328 :     Returns a list of PEG IDs. The PEGs in the list belong to the genome in the
2329 :     specified row and perform the role in the specified column. If the indicated
2330 :     row and column does not exist, returns an empty list.
2331 :    
2332 :     =back
2333 :    
2334 :     =cut
2335 :    
2336 : olson 1.1 sub get_pegs_from_cell
2337 :     {
2338 :     my($self, $rowstr, $colstr) = @_;
2339 :     my($row, $col);
2340 :    
2341 :     #
2342 :     # If row isn't numeric, look it up in the genomes list.
2343 :     #
2344 : parrello 1.60
2345 : olson 1.1 if ($rowstr !~ /^\d+$/)
2346 :     {
2347 : parrello 1.69 $row = $self->{genome_index}->{$rowstr};
2348 : olson 1.1 }
2349 :     else
2350 :     {
2351 : parrello 1.69 $row = $rowstr;
2352 : olson 1.1 }
2353 : parrello 1.60
2354 : overbeek 1.31 if (! defined($row))
2355 : olson 1.1 {
2356 : parrello 1.69 print &Dumper($self->{genome_index});
2357 :     confess "Cannot find row for $rowstr\n";
2358 :     return undef;
2359 : olson 1.1 }
2360 :    
2361 :     #
2362 :     # If col isn't numeric, look it up in the roles and role abbreviations.
2363 :     #
2364 : parrello 1.60
2365 : olson 1.1 if ($colstr !~ /^\d+$/)
2366 :     {
2367 : parrello 1.69 #
2368 :     # See if it's an abbr
2369 :     #
2370 : olson 1.1
2371 : parrello 1.69 my $a = $self->{abbr}->{$colstr};
2372 :     $colstr = $a if $a;
2373 : olson 1.1
2374 : parrello 1.69 $col = $self->{role_index}->{$colstr};
2375 : olson 1.1 }
2376 :     else
2377 :     {
2378 : parrello 1.69 $col = $colstr;
2379 : olson 1.1 }
2380 : overbeek 1.32
2381 : overbeek 1.31 if (! defined($col))
2382 : olson 1.1 {
2383 : parrello 1.69 warn "Cannot find col for $colstr\n";
2384 :     return undef;
2385 : olson 1.1 }
2386 : olson 1.12 my $cell = $self->get_cell($row, $col);
2387 : olson 1.1
2388 :     if ($cell)
2389 :     {
2390 : parrello 1.69 return @$cell;
2391 : olson 1.1 }
2392 :     else
2393 :     {
2394 : parrello 1.69 return undef;
2395 : olson 1.1 }
2396 :     }
2397 :    
2398 : olson 1.25 #
2399 :     # Subset support
2400 :     #
2401 :    
2402 : olson 1.30 sub get_active_subsetC
2403 :     {
2404 :     my($self) = @_;
2405 :    
2406 :     return $self->{col_active_subset};
2407 :     }
2408 :    
2409 :     sub get_active_subsetR
2410 :     {
2411 :     my($self) = @_;
2412 :    
2413 :     return $self->{row_active_subset};
2414 :     }
2415 :    
2416 :     sub set_active_subsetC
2417 :     {
2418 :     my($self, $subset) = @_;
2419 :    
2420 :     $self->{col_active_subset} = $subset;
2421 :     }
2422 :    
2423 :    
2424 :     sub set_active_subsetR
2425 :     {
2426 :     my($self, $subset) = @_;
2427 :    
2428 :     $self->{row_active_subset} = $subset;
2429 :     }
2430 :    
2431 :    
2432 : olson 1.25 sub get_subset_names
2433 : olson 1.17 {
2434 :     my($self) = @_;
2435 : olson 1.25
2436 : overbeek 1.31 return $self->get_subset_namesC;
2437 :     }
2438 :    
2439 : parrello 1.73 =head3 get_subset_namesC
2440 :    
2441 :     C<< my @subsetNames = $sub->get_subset_namesC(); >>
2442 :    
2443 :     Return a list of the names for all the column (role) subsets. Given a subset
2444 :     name, you can use the L</get_subsetC_roles> method to get the roles in the
2445 :     subset.
2446 :    
2447 :     =cut
2448 :    
2449 : overbeek 1.31 sub get_subset_namesC
2450 :     {
2451 :     my($self) = @_;
2452 :    
2453 : overbeek 1.35 return ("All",@{$self->{col_subsets}});
2454 : overbeek 1.31 }
2455 :    
2456 :     sub get_subset_namesR
2457 :     {
2458 :     my($self) = @_;
2459 :    
2460 : overbeek 1.35 return ("All",@{$self->{row_subsets}});
2461 : olson 1.17 }
2462 :    
2463 : parrello 1.73 =head3 get_subsetC_roles
2464 :    
2465 :     C<< my @roles = $sub->get_subsetC_roles($subname); >>
2466 :    
2467 :     Return the names of the roles contained in the specified role (column) subset.
2468 :    
2469 :     =over 4
2470 :    
2471 :     =item subname
2472 :    
2473 :     Name of the role subset whose roles are desired.
2474 :    
2475 :     =item RETURN
2476 :    
2477 :     Returns a list of the role names for the columns in the named subset.
2478 :    
2479 :     =back
2480 :    
2481 :     =cut
2482 :    
2483 : overbeek 1.33 sub get_subsetC_roles
2484 :     {
2485 :     my($self, $subname) = @_;
2486 :     return map { $self->get_role($_) } $self->get_subsetC($subname);
2487 :     }
2488 :    
2489 : overbeek 1.31 sub get_subsetC
2490 :     {
2491 :     my($self, $subname) = @_;
2492 : overbeek 1.33 if ($subname eq "All") { return map { $self->get_role_index($_) } $self->get_roles }
2493 : overbeek 1.31
2494 : olson 1.52 if (!defined($self->{col_subset_members}->{$subname}))
2495 :     {
2496 : parrello 1.69 $self->{col_subset_members}->{$subname} = [];
2497 : olson 1.52 }
2498 : parrello 1.60
2499 : overbeek 1.31 return @{$self->{col_subset_members}->{$subname}};
2500 :     }
2501 :    
2502 : olson 1.25 sub get_subset
2503 : olson 1.17 {
2504 : olson 1.25 my($self, $subname) = @_;
2505 : overbeek 1.33 return $self->get_subsetC($subname);
2506 : overbeek 1.31 }
2507 :    
2508 : parrello 1.104 =head3 get_subsetR
2509 :    
2510 :     C<< my @genomes = $sub->get_subsetR($subName); >>
2511 :    
2512 :     Return the genomes in the row subset indicated by the specified subset name.
2513 :    
2514 :     =over 4
2515 :    
2516 :     =item subName
2517 :    
2518 :     Name of the desired row subset, or C<All> to get all of the rows.
2519 :    
2520 :     =item RETURN
2521 :    
2522 :     Returns a list of genome IDs corresponding to the named subset.
2523 :    
2524 :     =back
2525 :    
2526 :     =cut
2527 :    
2528 :     sub get_subsetR {
2529 : overbeek 1.31 my($self, $subname) = @_;
2530 :     my($pair,$id,$members,$genome);
2531 :    
2532 :     if ($subname eq "All") { return $self->get_genomes }
2533 : overbeek 1.38 my %genomes = map { $_ => 1 } $self->get_genomes;
2534 :    
2535 :     return grep { $genomes{$_} } @{$self->{row_subset_members}->{$subname}};
2536 : overbeek 1.35 }
2537 :    
2538 :     sub load_row_subsets {
2539 :     my($self) = @_;
2540 :     my($id,$members,$pair);
2541 : overbeek 1.31
2542 : overbeek 1.35 my $taxonomic_groups = $self->{fig}->taxonomic_groups_of_complete(10);
2543 :     foreach $pair (@$taxonomic_groups)
2544 : overbeek 1.31 {
2545 : parrello 1.69 ($id,$members) = @$pair;
2546 :     if ($id ne "All")
2547 :     {
2548 :     push(@{$self->{row_subsets}},$id);
2549 :     }
2550 :     $self->{row_subset_members}->{$id} = $members;
2551 : overbeek 1.31 }
2552 : olson 1.25 }
2553 :    
2554 : parrello 1.73 =head3 load_row_subsets_by_kv
2555 : redwards 1.48
2556 :     Load a row subset based on a key/value pair. This will take a single key/value pair and only show that subset
2557 :    
2558 :     It is just a modification of load_row_subsets to deal with kv pairs
2559 :    
2560 :     This takes a required argument: the key that the genome must have, and a second optional argument, the value that key must hold.
2561 :    
2562 :     =cut
2563 :    
2564 :     sub load_row_subsets_by_kv {
2565 :     my ($self, $key, $want) = @_;
2566 :     my($id,$members,$pair);
2567 :     my $keep;
2568 : olson 1.102 #
2569 :     # First do a single call to retrieve all the values for the subset key.
2570 :     #
2571 : olson 1.103 my @attr_values = $self->{fig}->get_attributes($self->{genome}, $key);
2572 : olson 1.102 my %amap;
2573 :     map { push(@{$amap{$_->[0]}}, [@$_]); } @attr_values;
2574 :    
2575 : redwards 1.48 foreach my $genome (@{$self->{genome}}) {
2576 : olson 1.102 #my @results=$self->{fig}->get_attributes($genome, $key);
2577 :     my $results = $amap{$genome};
2578 :     next unless $results;
2579 :     foreach my $res (@$results) {
2580 : redwards 1.51 my ($gotid, $gottag, $value, $url)=@$res;
2581 : overbeek 1.85 next if ($value && $want && $value ne $want);
2582 :     next if ($gotid ne $genome);
2583 : redwards 1.50 push @$keep, $genome;
2584 :     last;
2585 :     }
2586 : redwards 1.48 }
2587 :     $self->{row_subset_members}->{$key}=$keep;
2588 :     }
2589 : overbeek 1.35
2590 : parrello 1.73 =head3 set_subsetC
2591 : olson 1.25
2592 : parrello 1.73 C<< $sub->set_subsetC($name, $members); >>
2593 : olson 1.25
2594 :     Create a subset with the given name and members.
2595 :    
2596 :     $members is a list of role names.
2597 :    
2598 :     =cut
2599 :    
2600 : overbeek 1.31 sub set_subsetC
2601 : olson 1.25 {
2602 :     my($self, $subname, $list) = @_;
2603 :    
2604 :     my $nl = [map { $self->get_role_index($_) } @$list];
2605 : parrello 1.60
2606 : olson 1.25 $self->_set_subset($subname, $nl);
2607 :     }
2608 :    
2609 : overbeek 1.31 sub set_subset
2610 :     {
2611 :     my($self, $subname, $list) = @_;
2612 :    
2613 :     $self->set_subsetsC($subname,$list);
2614 :     }
2615 :    
2616 : parrello 1.73 =head3 _set_subset
2617 : olson 1.25
2618 :     Create a subset with the given name and members.
2619 :    
2620 :     Internal version - here, members is a list of role indices.
2621 :    
2622 :     =cut
2623 :    
2624 :     sub _set_subset
2625 :     {
2626 :     my($self, $subname, $list) = @_;
2627 :     $self->{col_subset_members}->{$subname} = $list;
2628 : overbeek 1.37 my($i,$x);
2629 :     $x = $self->{col_subsets};
2630 :     for ($i=0; ($i < @$x) && ($x->[$i] ne $subname); $i++) {}
2631 :     if ($i == @$x)
2632 :     {
2633 : parrello 1.69 push(@$x,$subname);
2634 : overbeek 1.37 }
2635 :     }
2636 : parrello 1.60
2637 : overbeek 1.37 sub delete_subsetC
2638 :     {
2639 :     my($self, $subname) = @_;
2640 :     my($i,$x);
2641 :    
2642 :     $x = $self->{col_subsets};
2643 :     for ($i=0; ($i < @$x) && ($x->[$i] ne $subname); $i++) {}
2644 :     if ($i < @$x)
2645 :     {
2646 : parrello 1.69 splice(@$x,$i,1);
2647 : overbeek 1.37 }
2648 :     delete $self->{col_subset_members}->{$subname};
2649 : olson 1.25 }
2650 : parrello 1.60
2651 : olson 1.25 #
2652 :     # Role manipulation.
2653 :     #
2654 :    
2655 :    
2656 : parrello 1.73 =head3 set_roles
2657 : olson 1.25
2658 : parrello 1.73 C<< $sub->set_roles($role_list); >>
2659 : olson 1.25
2660 :     Set the list of roles. C<$role_list> is a list of tuples C<[$role_name, $abbreviation]>.
2661 :    
2662 :     If a role already exists, it is used. If it does not exist, it is created empty.
2663 :    
2664 :     =cut
2665 :    
2666 :     sub set_roles
2667 :     {
2668 :     my($self, $roles) = @_;
2669 :    
2670 :     #
2671 :     # We do this by first creating a new spreadsheet.
2672 :     #
2673 :     # It is easiest to do this by manipulating the inverted spreadsheet
2674 :     # (role-major), and then creating the non-inverted spreadsheet from it.
2675 :     #
2676 :    
2677 :     my $oldss = $self->{spreadsheet};
2678 :     my $oldssinv = $self->{spreadsheet_inv};
2679 :    
2680 :     my $ss = [];
2681 :     my $ssinv = [];
2682 :    
2683 :     my $g = $self->{genome};
2684 :     my $ng = @$g;
2685 :    
2686 :     my $old_roles = $self->{role_index};
2687 :    
2688 :     my @role_index_conversion;
2689 : olson 1.70 my @old_role_list = @{$self->{roles}};
2690 : olson 1.25
2691 : olson 1.70 #
2692 :     # Since we're setting up completely new roles, wipe the
2693 :     # existing state.
2694 :     #
2695 : olson 1.25
2696 :     $self->{abbr} = {};
2697 :     $self->{role_index} = {};
2698 :     $self->{roles} = [];
2699 :     $self->{role_abbrs} = [];
2700 :    
2701 : olson 1.70 #
2702 :     # Initialize %defunct_roles with the list of all roles.
2703 :     # Remove entries as we walk the list of new roles below.
2704 :     # Any that are remaining need to be pulled from the index.
2705 :     #
2706 : olson 1.25
2707 : olson 1.70 my %defunct_roles = map { $_ => 1 } @old_role_list;
2708 : parrello 1.73
2709 : olson 1.70 # warn "Defunct at start: ", Dumper(\%defunct_roles);
2710 : olson 1.25 for (my $idx = 0; $idx < @$roles; $idx++)
2711 :     {
2712 : parrello 1.69 my $role = $roles->[$idx]->[0];
2713 :     my $abbr = $roles->[$idx]->[1];
2714 :    
2715 :     my $old_idx = $old_roles->{$role};
2716 : olson 1.25
2717 : olson 1.70 if (defined($old_idx))
2718 :     {
2719 :     # warn "Found old idx $old_idx for $role $idx\n";
2720 :     # warn $oldssinv->[$old_idx];
2721 :     $ssinv->[$idx] = $oldssinv->[$old_idx];
2722 :    
2723 :     $role_index_conversion[$old_idx] = $idx;
2724 :    
2725 :     #
2726 :     # We're keeping it, so it's not defunct anymore.
2727 :     #
2728 :     delete $defunct_roles{$role};
2729 :     }
2730 :     else
2731 :     {
2732 :     # warn "Did not find old role for $role $idx\n";
2733 :     # warn Dumper($old_roles);
2734 :     my $l = [];
2735 :     for (my $j = 0; $j < $ng; $j++)
2736 :     {
2737 :     $l->[$j] = [];
2738 :     }
2739 :    
2740 :     $ssinv->[$idx] = $l;
2741 :     }
2742 :    
2743 : parrello 1.73
2744 : olson 1.70 #
2745 :     # While we're here, update the new role and abbrev indexes
2746 :     #
2747 :     $self->{role_index}->{$role} = $idx;
2748 :     $self->{abbr}->{$abbr} = $role;
2749 :     $self->{roles}->[$idx] = $role;
2750 :     $self->{role_abbrs}->[$idx] = $abbr;
2751 :     }
2752 : olson 1.25
2753 : olson 1.70 #
2754 :     # Now we delete the pegs showing up for the list of defunct roles.
2755 :     #
2756 :     # warn "Defunct at finish: ", Dumper(\%defunct_roles);
2757 : parrello 1.73
2758 : olson 1.70 my $rdbH = $self->{fig}->db_handle();
2759 :     my $dbh = $rdbH->{_dbh};
2760 :     my $sub_name = $self->{name};
2761 : parrello 1.73
2762 : olson 1.70 my $sth = $dbh->prepare(qq(DELETE FROM subsystem_index
2763 :     WHERE (subsystem = ? AND
2764 :     role = ? AND
2765 :     protein = ?)
2766 :     ));
2767 : parrello 1.73
2768 :    
2769 : olson 1.70 for my $defunct_role (keys(%defunct_roles))
2770 :     {
2771 :     my $defunct_role_idx = $old_roles->{$defunct_role};
2772 :     my $col = $oldssinv->[$defunct_role_idx];
2773 :     # warn "Handle defunct role $defunct_role idx=$defunct_role_idx\n", Dumper($col);
2774 : parrello 1.73
2775 : olson 1.70 for my $cell (@$col)
2776 :     {
2777 :     for my $peg (@$cell)
2778 :     {
2779 :     $sth->execute($sub_name, $defunct_role, $peg);
2780 :     warn "Deleting $sub_name $defunct_role $peg\n";
2781 :     }
2782 :     }
2783 : olson 1.25 }
2784 : parrello 1.73
2785 : olson 1.25
2786 :     #
2787 :     # Now create the uninverted spreadsheet.
2788 :     #
2789 :    
2790 :     for (my $gidx = 0; $gidx < $ng; $gidx++)
2791 :     {
2792 : parrello 1.69 my $row = [];
2793 :     $ss->[$gidx] = $row;
2794 :     for (my $ridx = 0; $ridx < @$roles; $ridx++)
2795 :     {
2796 :     $row->[$ridx] = $ssinv->[$ridx]->[$gidx];
2797 :     }
2798 : olson 1.25 }
2799 :    
2800 :     $self->{spreadsheet} = $ss;
2801 :     $self->{spreadsheet_inv} = $ssinv;
2802 :    
2803 :     #
2804 :     # Fix up the subsets.
2805 :     #
2806 :    
2807 :    
2808 : overbeek 1.37 for my $subset (grep { $_ ne "All" } $self->get_subset_names())
2809 : olson 1.25 {
2810 : parrello 1.69 my $n = [];
2811 :     for my $idx ($self->get_subset($subset))
2812 :     {
2813 :     my $new = $role_index_conversion[$idx];
2814 :     if (defined($new))
2815 :     {
2816 :     push(@$n, $new);
2817 :     }
2818 :     }
2819 :     $self->_set_subset($subset, $n);
2820 : olson 1.25 }
2821 :    
2822 :     }
2823 :    
2824 : parrello 1.73 =head3 add_role($role, $abbr)
2825 : olson 1.25
2826 :     Add the given role to the spreadsheet.
2827 :    
2828 :     This causes a new column to be added, with empty values in each cell.
2829 :    
2830 :     We do nothing if the role is already present.
2831 :    
2832 :     Return the index of the new role.
2833 :    
2834 :     =cut
2835 :    
2836 :     sub add_role
2837 :     {
2838 :     my($self, $role, $abbr) = @_;
2839 :    
2840 :     if (defined($self->get_role_index($role)))
2841 :     {
2842 : parrello 1.69 warn "Role $role already present\n";
2843 :     return undef;
2844 : olson 1.25 }
2845 :    
2846 :     #
2847 :     # Add to the roles list. It goes at the end.
2848 :     #
2849 :    
2850 :     my $idx = @{$self->{roles}};
2851 :     $self->{roles}->[$idx] = $role;
2852 :     $self->{role_abbrs}->[$idx] = $abbr;
2853 :     $self->{role_index}->{$role} = $idx;
2854 :     $self->{abbr}->{$abbr} = $role;
2855 :    
2856 :     #
2857 :     # Update the spreadsheet.
2858 :     # On the standard one, we have to go through all the rows adding
2859 :     # a columnt to each.
2860 :     #
2861 :     # On the inverted one, we add a column with [] in each entry.
2862 :     #
2863 :    
2864 :     my $ng = @{$self->{genome}};
2865 :     my $newcol = [];
2866 :    
2867 :     for (my $i = 0; $i < $ng; $i++)
2868 :     {
2869 : parrello 1.69 my $cell = [];
2870 :     # print "nr: Adding cell $cell for gidx=$i ridx=$idx\n";
2871 :     $self->{spreadsheet}->[$i]->[$idx] = $cell;
2872 :     $newcol->[$i] = $cell;
2873 : olson 1.25 }
2874 :    
2875 :     $self->{spreadsheet_inv}->[$idx] = $newcol;
2876 :    
2877 :     return $idx;
2878 :     }
2879 :    
2880 : parrello 1.73 =head3 remove_role
2881 : olson 1.25
2882 :     Remove the role from the spreadsheet.
2883 :    
2884 :     We do nothing if the role is not present.
2885 :    
2886 :     =cut
2887 :    
2888 :     sub remove_role
2889 :     {
2890 :     my($self, $role) = @_;
2891 :    
2892 :     my $idx = $self->get_role_index($role);
2893 :     if (!defined($idx))
2894 :     {
2895 : parrello 1.69 warn "Role $role not present\n";
2896 :     return undef;
2897 : olson 1.25 }
2898 :    
2899 :     #
2900 : olson 1.70 # Update the index. Again, do this before removing roles
2901 :     # so we have full data to work with.
2902 :     # We walk the role's column of the spreadsheet removing pegs from the index.
2903 :     #
2904 :    
2905 :     my $rdbH = $self->{fig}->db_handle();
2906 :     my $dbh = $rdbH->{_dbh};
2907 :     my $sub_name = $self->{name};
2908 :    
2909 :     my $sth = $dbh->prepare(qq(DELETE FROM subsystem_index
2910 :     WHERE (subsystem = ? AND
2911 :     role = ? AND
2912 :     protein = ?)
2913 :     ));
2914 :     my $col = $self->get_col($idx);
2915 :     for my $cell (@$col)
2916 :     {
2917 :     for my $peg (@$cell)
2918 :     {
2919 :     $sth->execute($sub_name, $role, $peg);
2920 :     warn "Deleting $sub_name $role $peg\n";
2921 :     }
2922 :     }
2923 :    
2924 :     #
2925 : parrello 1.60 # Remove from the roles list.
2926 : olson 1.25 #
2927 :    
2928 :     my $abbr = $self->{role_abbrs}->[$idx];
2929 : parrello 1.60
2930 : olson 1.25 splice(@{$self->{roles}}, $idx, 1);
2931 :     splice(@{$self->{role_abbrs}}, $idx, 1);
2932 :     delete $self->{role_index}->{$role};
2933 :     delete $self->{abbr}->{$abbr};
2934 :    
2935 : olson 1.70
2936 : olson 1.25 #
2937 :     # Update the spreadsheet.
2938 :     # On the standard one, we have to go through all the rows removing
2939 :     # the column from each.
2940 :     #
2941 :     # On the inverted one, we just remove the column.
2942 :     #
2943 :    
2944 :     my $ng = @{$self->{genome}};
2945 :     my $newcol = [];
2946 :    
2947 :     for (my $i = 0; $i < $ng; $i++)
2948 :     {
2949 : parrello 1.69 splice(@{$self->{spreadsheet}->[$i]}, $idx, 1);
2950 : olson 1.25 }
2951 :    
2952 :     splice(@{$self->{spreadsheet_inv}}, $idx, 1);
2953 :    
2954 :     #
2955 :     # We need to rewrite the subsets. if $idx was present in one, it is
2956 :     # removed. Any index >$idx is decremented.
2957 :     #
2958 :    
2959 :     for my $subset ($self->get_subset_names())
2960 :     {
2961 : parrello 1.69 my @n;
2962 : olson 1.25
2963 : parrello 1.69 for my $sidx ($self->get_subset($subset))
2964 :     {
2965 :     if ($sidx < $idx)
2966 :     {
2967 :     push(@n, $sidx);
2968 :     }
2969 :     elsif ($sidx > $idx)
2970 :     {
2971 :     push(@n, $sidx - 1);
2972 :     }
2973 :     }
2974 : olson 1.25
2975 : parrello 1.69 $self->_set_subset($subset, [@n]);
2976 : olson 1.25 }
2977 :     }
2978 :    
2979 : parrello 1.73 =head3 add_genome($genome, $abbr)
2980 : olson 1.25
2981 :     Add the given genome to the spreadsheet.
2982 :    
2983 :     This causes a new row to be added, with empty values in each cell.
2984 :    
2985 :     We do nothing if the genome is already present.
2986 :    
2987 :     Return the index of the new genome.
2988 :    
2989 :     =cut
2990 :    
2991 :     sub add_genome
2992 :     {
2993 :     my($self, $genome) = @_;
2994 :    
2995 :     my $idx = $self->get_genome_index($genome);
2996 :     if (defined($idx))
2997 :     {
2998 : parrello 1.64 warn "Genome $genome already present\n";
2999 :     return $idx;
3000 : olson 1.25 }
3001 :    
3002 :     #
3003 :     # Add to the genomes list. It goes at the end.
3004 :     #
3005 :    
3006 : parrello 1.64 $idx = @{$self->{genome}};
3007 : olson 1.26 $self->{variant_code}->[$idx] = 0;
3008 : olson 1.25 $self->{genome}->[$idx] = $genome;
3009 :     $self->{genome_index}->{$genome} = $idx;
3010 :    
3011 :     #
3012 :     # Update the spreadsheet.
3013 :     # On the inverted one, we have to go through all the columns adding
3014 :     # a row to each.
3015 :     #
3016 :     # On the regular one, we add a row with [] in each entry.
3017 :     #
3018 :    
3019 :     my $nr = @{$self->{roles}};
3020 :     my $newrow = [];
3021 :    
3022 :     for my $i (0.. $nr - 1)
3023 :     {
3024 : parrello 1.69 my $cell = [];
3025 :     # print "ng: Adding cell $cell for gidx=$idx ridx=$i\n";
3026 :     $self->{spreadsheet_inv}->[$i]->[$idx] = $cell;
3027 :     $newrow->[$i] = $cell;
3028 : olson 1.25 }
3029 :    
3030 :     $self->{spreadsheet}->[$idx] = $newrow;
3031 :    
3032 :     return $idx;
3033 :     }
3034 :    
3035 : parrello 1.73 =head3 remove_genome
3036 : olson 1.25
3037 :     Remove the genome from the spreadsheet.
3038 :    
3039 :     We do nothing if the genome is not present.
3040 :    
3041 :     =cut
3042 :    
3043 :     sub remove_genome
3044 :     {
3045 :     my($self, $genome) = @_;
3046 :    
3047 :     my $idx = $self->get_genome_index($genome);
3048 :     if (!defined($idx))
3049 :     {
3050 : parrello 1.69 warn "Genome $genome not present\n";
3051 :     return undef;
3052 : olson 1.25 }
3053 :    
3054 :     #
3055 : olson 1.70 # Remove from database index (before we delete stuff from here,
3056 :     # so we have access to th e data structures).
3057 :     #
3058 :    
3059 :     my $rdbH = $self->{fig}->db_handle();
3060 :     my $dbh = $rdbH->{_dbh};
3061 :     my $cells = $self->get_row($idx);
3062 :     my $sub_name = $self->{name};
3063 :    
3064 :     my $sth = $dbh->prepare(qq(DELETE FROM subsystem_index
3065 :     WHERE (subsystem = ? AND
3066 :     role = ? AND
3067 :     protein = ?)
3068 :     ));
3069 :     for my $i (0 .. $#$cells)
3070 :     {
3071 :     my $cell = $cells->[$i];
3072 :     my $role = $self->get_role($i);
3073 :    
3074 :     for my $peg (@$cell)
3075 :     {
3076 :     $sth->execute($sub_name, $role, $peg);
3077 :     warn "Deleting $sub_name $role $peg\n";
3078 :     }
3079 :     }
3080 :    
3081 :     #
3082 : parrello 1.60 # Remove from the genomes list.
3083 : olson 1.25 #
3084 :    
3085 :     splice(@{$self->{genome}}, $idx, 1);
3086 : overbeek 1.43
3087 :     my $genome1;
3088 :     foreach $genome1 (@{$self->{genome}})
3089 :     {
3090 : parrello 1.69 if ($self->{genome_index}->{$genome1} > $idx)
3091 :     {
3092 :     $self->{genome_index}->{$genome1}--;
3093 :     }
3094 : overbeek 1.43 }
3095 : olson 1.25 splice(@{$self->{variant_code}}, $idx, 1);
3096 :    
3097 :     delete $self->{genome_index}->{$genome};
3098 :    
3099 :     #
3100 :     # Update the spreadsheet.
3101 :     # On the inverted one, we have to go through all the columns removing
3102 :     # the row from each.
3103 :     #
3104 :     # On the standard one, we just remove the row.
3105 :     #
3106 :    
3107 :     my $nr = @{$self->{roles}};
3108 :    
3109 :     for my $i (0 .. $nr - 1)
3110 :     {
3111 : parrello 1.69 splice(@{$self->{spreadsheet_inv}->[$i]}, $idx, 1);
3112 : olson 1.25 }
3113 :    
3114 :     splice(@{$self->{spreadsheet}}, $idx, 1);
3115 :    
3116 :     }
3117 :    
3118 : parrello 1.60 sub get_name :Scalar
3119 : olson 1.25 {
3120 :     my($self) = @_;
3121 : overbeek 1.53 my $name = $self->{name};
3122 :     $name =~ s/ /_/g;
3123 :     return $name;
3124 : olson 1.25 }
3125 : parrello 1.60
3126 :     sub get_dir :Scalar
3127 : overbeek 1.41 {
3128 :     my($self) = @_;
3129 :     return $self->{dir};
3130 :     }
3131 : olson 1.25
3132 : parrello 1.60
3133 :     sub get_version :Scalar
3134 : olson 1.25 {
3135 :     my($self) = @_;
3136 :     return $self->{version};
3137 : olson 1.17 }
3138 :    
3139 : parrello 1.73 =head3 get_notes
3140 :    
3141 :     C<< my $text = $sub->get_notes(); >>
3142 :    
3143 :     Return the descriptive notes for this subsystem.
3144 :    
3145 :     =cut
3146 :    
3147 : parrello 1.60 sub get_notes :Scalar
3148 : olson 1.26 {
3149 :     my($self) = @_;
3150 :    
3151 :     return $self->{notes};
3152 :     }
3153 :    
3154 : parrello 1.73 =head3 get_reactions
3155 :    
3156 :     C<< my $reactHash = $sub->get_reactions(); >>
3157 :    
3158 :     Return a reference to a hash that maps each role ID to a list of the reactions
3159 :     catalyzed by the role.
3160 :    
3161 :     =cut
3162 :    
3163 : overbeek 1.58 sub get_reactions
3164 :     {
3165 :     my($self) = @_;
3166 :    
3167 :     return $self->{reactions};
3168 :     }
3169 :    
3170 : overbeek 1.59 sub set_reaction {
3171 :     my($self,$role,$rstring) = @_;
3172 :    
3173 :     $self->{reactions}->{$role} = [split(/,\s*/,$rstring)];
3174 :     }
3175 :    
3176 : olson 1.105 sub get_hope_scenario_names
3177 :     {
3178 :     my($self) = @_;
3179 :    
3180 :     return sort keys %{$self->{hope_scenarios}};
3181 :     }
3182 :    
3183 :     sub change_hope_scenario_name
3184 :     {
3185 :     my($self, $old_name, $new_name) = @_;
3186 :     my $hope_scenarios = $self->{hope_scenarios};
3187 :     my $scenario = $hope_scenarios->{$old_name};
3188 :     delete $hope_scenarios->{$old_name};
3189 :     $hope_scenarios->{$new_name} = $scenario;
3190 :     }
3191 :    
3192 :     sub add_hope_scenario
3193 :     {
3194 :     my($self, $new_name) = @_;
3195 :     $new_name =~ s/\// /g;
3196 :     $self->{hope_scenarios}->{$new_name} = { input_compounds => [], output_compounds => [], map_ids => [], additional_reactions => [], ignore_reactions => [] };
3197 :     }
3198 :    
3199 :     sub delete_hope_scenario
3200 :     {
3201 :     my($self, $scenario_name) = @_;
3202 :    
3203 :     delete $self->{hope_scenarios}->{$scenario_name};
3204 :     }
3205 :    
3206 :     sub get_hope_input_compounds
3207 :     {
3208 :     my($self, $scenario_name) = @_;
3209 :    
3210 :     return $self->{hope_scenarios}->{$scenario_name}->{input_compounds};
3211 :     }
3212 :    
3213 :     sub set_hope_input_compounds
3214 :     {
3215 :     my($self,$scenario_name,$compounds) = @_;
3216 :     $compounds =~ s/^\s+//g;
3217 :     $compounds =~ s/\s+$//g;
3218 :     $compounds =~ s/,\s+/,/g;
3219 :     $compounds =~ s/\s+,/,/g;
3220 :     $compounds =~ s/\s+/,/g;
3221 :     $self->{hope_scenarios}->{$scenario_name}->{input_compounds} = [split(/,/,$compounds)];
3222 :     }
3223 :    
3224 :     sub get_hope_output_compounds
3225 :     {
3226 :     my($self,$scenario_name) = @_;
3227 :    
3228 :     return $self->{hope_scenarios}->{$scenario_name}->{output_compounds};
3229 :     }
3230 :    
3231 :     sub set_hope_output_compounds
3232 :     {
3233 :     my($self,$scenario_name,$compounds) = @_;
3234 :     $compounds =~ s/^\s+//g;
3235 :     $compounds =~ s/\s+$//g;
3236 :     $compounds =~ s/,\s+/,/g;
3237 :     $compounds =~ s/\s+,/,/g;
3238 :     $compounds =~ s/\s+/,/g;
3239 :    
3240 :     # allow one level of nesting with parentheses
3241 :     my @output_compounds_lists;
3242 :     my @inner_list;
3243 :    
3244 :     foreach my $cpd (split(/,/,$compounds))
3245 :     {
3246 :     if ($cpd =~ /\(/)
3247 :     {
3248 :     $cpd =~ s/\(//g;
3249 :     push @inner_list, $cpd;
3250 :     }
3251 :     elsif (scalar @inner_list > 0 && $cpd =~ /\)/)
3252 :     {
3253 :     $cpd =~ s/\)//g;
3254 :     push @inner_list, $cpd;
3255 :     my @new_inner_list = @inner_list;
3256 :     push @output_compounds_lists, \@new_inner_list;
3257 :     @inner_list = ();
3258 :     }
3259 :     elsif (scalar @inner_list > 0)
3260 :     {
3261 :     push @inner_list, $cpd;
3262 :     }
3263 :     else
3264 :     {
3265 :     push @output_compounds_lists, [$cpd];
3266 :     }
3267 :     }
3268 :    
3269 :     $self->{hope_scenarios}->{$scenario_name}->{output_compounds} = \@output_compounds_lists;
3270 :     }
3271 :    
3272 :     sub get_hope_map_ids
3273 :     {
3274 :     my($self,$scenario_name) = @_;
3275 :    
3276 :     return $self->{hope_scenarios}->{$scenario_name}->{map_ids};
3277 :     }
3278 :    
3279 :     sub set_hope_map_ids
3280 :     {
3281 :     my($self,$scenario_name,$ids) = @_;
3282 :     $ids =~ s/^\s+//g;
3283 :     $ids =~ s/\s+$//g;
3284 :     $ids =~ s/,\s+/,/g;
3285 :     $ids =~ s/\s+,/,/g;
3286 :     $ids =~ s/\s+/,/g;
3287 :     $self->{hope_scenarios}->{$scenario_name}->{map_ids} = [split(/,/,$ids)];
3288 :     }
3289 :    
3290 :     sub get_hope_additional_reactions
3291 :     {
3292 :     my($self,$scenario_name) = @_;
3293 :    
3294 :     return $self->{hope_scenarios}->{$scenario_name}->{additional_reactions};
3295 :     }
3296 :    
3297 :     sub set_hope_additional_reactions
3298 :     {
3299 :     my($self,$scenario_name,$rids) = @_;
3300 :     $rids =~ s/^\s+//g;
3301 :     $rids =~ s/\s+$//g;
3302 :     $rids =~ s/,\s+/,/g;
3303 :     $rids =~ s/\s+,/,/g;
3304 :     $rids =~ s/\s+/,/g;
3305 :     $self->{hope_scenarios}->{$scenario_name}->{additional_reactions} = [split(/,/,$rids)];
3306 :     }
3307 :    
3308 :     sub get_hope_ignore_reactions
3309 :     {
3310 :     my($self,$scenario_name) = @_;
3311 :    
3312 :     return $self->{hope_scenarios}->{$scenario_name}->{ignore_reactions};
3313 :     }
3314 :    
3315 :     sub set_hope_ignore_reactions
3316 :     {
3317 :     my($self,$scenario_name,$rids) = @_;
3318 :     $rids =~ s/^\s+//g;
3319 :     $rids =~ s/\s+$//g;
3320 :     $rids =~ s/,\s+/,/g;
3321 :     $rids =~ s/\s+,/,/g;
3322 :     $rids =~ s/\s+/,/g;
3323 :     $self->{hope_scenarios}->{$scenario_name}->{ignore_reactions} = [split(/,/,$rids)];
3324 :     }
3325 :    
3326 : dejongh 1.106 sub get_hope_reactions_for_genome
3327 :     {
3328 :     my($self, $genome) = @_;
3329 :     my $index = $self->{genome_index}->{$genome};
3330 :     if (defined $index) {
3331 :     my @roles = $self->get_roles;
3332 :     my %hope_reactions = %{$self->get_hope_reactions};
3333 :    
3334 : dejongh 1.107 my %ss_reactions;
3335 : dejongh 1.106
3336 :     foreach my $role (@roles)
3337 :     {
3338 : dejongh 1.107 my @peg_list = $self->get_pegs_from_cell($genome,$role);
3339 :    
3340 :     if (defined $hope_reactions{$role} && scalar @peg_list > 0)
3341 :    
3342 : dejongh 1.106 {
3343 : dejongh 1.107 foreach my $reaction (@{$hope_reactions{$role}})
3344 :     {
3345 :     push @{$ss_reactions{$reaction}}, @peg_list;
3346 :     }
3347 : dejongh 1.106 }
3348 :     }
3349 :    
3350 : dejongh 1.107 return \%ss_reactions;
3351 : dejongh 1.106 }
3352 :     else {
3353 :     return undef;
3354 :     }
3355 :     }
3356 :    
3357 : olson 1.105 sub get_hope_reactions
3358 :     {
3359 :     my($self) = @_;
3360 :    
3361 :     return $self->{hope_reactions};
3362 :     }
3363 :    
3364 :     sub set_hope_reaction {
3365 :     my($self,$role,$rids) = @_;
3366 :     $rids =~ s/,\s+/,/g;
3367 :     $rids =~ s/\s+/,/g;
3368 :     $self->{hope_reactions}->{$role} = [split(/,/,$rids)];
3369 :     }
3370 :    
3371 :     sub get_hope_reaction_notes
3372 :     {
3373 :     my($self) = @_;
3374 :    
3375 :     return $self->{hope_reaction_notes};
3376 :     }
3377 :    
3378 :     sub set_hope_reaction_note {
3379 :     my($self,$role,$rstring) = @_;
3380 :    
3381 :     $self->{hope_reaction_notes}->{$role} = $rstring;
3382 :     }
3383 :    
3384 :     sub get_hope_reaction_links
3385 :     {
3386 :     my($self) = @_;
3387 :    
3388 :     return $self->{hope_reaction_links};
3389 :     }
3390 :    
3391 :     sub set_hope_reaction_link {
3392 :     my($self,$role,$rstring) = @_;
3393 :    
3394 :     $self->{hope_reaction_links}->{$role} = $rstring;
3395 :     }
3396 :    
3397 :     sub get_hope_curation_notes :Scalar
3398 :     {
3399 :     my($self) = @_;
3400 :    
3401 :     return $self->{hope_curation_notes};
3402 :     }
3403 :    
3404 :     sub set_hope_curation_notes
3405 :     {
3406 :     my($self, $hope_curation_notes) = @_;
3407 :    
3408 :     $self->{hope_curation_notes} = $hope_curation_notes;
3409 :     }
3410 : overbeek 1.59
3411 : olson 1.26 sub set_notes
3412 :     {
3413 :     my($self, $notes) = @_;
3414 :    
3415 : olson 1.28 $self->{notes} = $notes;
3416 : olson 1.26 }
3417 :    
3418 : redwards 1.44 sub get_classification
3419 :     {
3420 :     my($self) = @_;
3421 :    
3422 :     return $self->{classification};
3423 :     }
3424 :    
3425 :     sub set_classification
3426 :     {
3427 :     my($self, $classification) = @_;
3428 :    
3429 :     $self->{classification}=$classification;
3430 :     }
3431 :    
3432 :    
3433 : parrello 1.73 =head3 get_curator
3434 :    
3435 :     C<< my $userName = $sub->get_curator(); >>
3436 :    
3437 :     Return the name of this subsystem's official curator.
3438 :    
3439 :     =cut
3440 : parrello 1.60
3441 :     sub get_curator :Scalar
3442 : olson 1.17 {
3443 :     my($self) = @_;
3444 :     return $self->{curator};
3445 :     }
3446 : overbeek 1.47
3447 : olson 1.25 #
3448 :     # Subsystem copying logic
3449 :     #
3450 :    
3451 : parrello 1.73 =head3 add_to_subsystem($subsystem_name, $columns, $notes_flag)
3452 : olson 1.25
3453 :     Merge the given columns from $subsystem_name into this subsystem. Append the
3454 :     notes from the subsystem if $notes_flag is true.
3455 :    
3456 :     =cut
3457 :    
3458 :     sub add_to_subsystem
3459 :     {
3460 :     my($self, $subsystem_name, $cols, $add_notes) = @_;
3461 :    
3462 :     my $ss = $self->{fig}->get_subsystem($subsystem_name);
3463 :    
3464 :     if (!$ss)
3465 :     {
3466 : parrello 1.69 warn "Cannot open subsystem '$subsystem_name' to copy from";
3467 :     return;
3468 : olson 1.25 }
3469 :    
3470 :     #
3471 :     # Merge the data from the other subsystem.
3472 :     #
3473 :     # First we assure ourselves that we have the appropriate roles. While
3474 :     # we do this, build the list of row indices (in this subsystem) that
3475 :     # map to the roles we are adding.
3476 :     #
3477 :    
3478 :     #
3479 :     # local_roles[$his_role] = $my_role (map from other role idx to local role idx)
3480 :     #
3481 : parrello 1.60
3482 : olson 1.25 my @local_roles;
3483 :    
3484 :     #
3485 :     # his_roles = list of role indices corresponding to the remote roles.
3486 :     #
3487 : overbeek 1.36 if ($cols->[0] eq "all")
3488 :     {
3489 : parrello 1.69 $cols = [$ss->get_roles];
3490 : overbeek 1.36 }
3491 :    
3492 : olson 1.25 my @his_roles;
3493 : parrello 1.60
3494 : olson 1.25 for my $his_role (@$cols)
3495 :     {
3496 : parrello 1.69 my $idx = $self->get_role_index($his_role);
3497 :     my $his_idx = $ss->get_role_index($his_role);
3498 :    
3499 :     if (!defined($his_idx))
3500 :     {
3501 :     confess "Cannot map his role $his_role\n";
3502 :     }
3503 :     push(@his_roles, $his_idx);
3504 : olson 1.25
3505 : parrello 1.69 if (!defined($idx))
3506 :     {
3507 :     my $his_abbr = $ss->get_role_abbr($his_idx);
3508 : parrello 1.60
3509 : parrello 1.69 $idx = $self->add_role($his_role, $his_abbr);
3510 :     # print "Adding missing role $his_role idx=$idx\n";
3511 :     }
3512 :     else
3513 :     {
3514 :     # print "Found existing role $his_role idx=$idx\n";
3515 :     }
3516 : olson 1.25
3517 : parrello 1.69
3518 :     $local_roles[$his_idx] = $idx;
3519 : olson 1.25 }
3520 :    
3521 :     #
3522 :     # Similar scan to ensure that we have rows for the genomes
3523 :     # that are in the other subsystem.
3524 :     #
3525 :    
3526 :     my @local_genomes;
3527 :    
3528 :     my @his_genomes = $ss->get_genomes();
3529 :    
3530 :     for my $his_idx (0..@his_genomes - 1)
3531 :     {
3532 : parrello 1.69 my $genome = $his_genomes[$his_idx];
3533 :    
3534 : overbeek 1.37
3535 : parrello 1.69 my $my_idx = $self->get_genome_index($genome);
3536 : parrello 1.60
3537 : parrello 1.69 if (!defined($my_idx))
3538 :     {
3539 :     #
3540 :     # Not there, need to add.
3541 :     #
3542 : olson 1.25
3543 : parrello 1.69 $my_idx = $self->add_genome($genome);
3544 :     # print "Adding missing genome $genome idx=$my_idx\n";
3545 :     }
3546 :     else
3547 :     {
3548 :     # print "Found existing genome $genome idx=$my_idx\n";
3549 :     }
3550 : parrello 1.60
3551 : parrello 1.69 $local_genomes[$his_idx] = $my_idx;
3552 : olson 1.25 }
3553 :    
3554 : parrello 1.60
3555 : olson 1.25 #
3556 :     # Now that we have our local roles set up to receive the data,
3557 :     # process the incoming roles one at a time.
3558 :     #
3559 :    
3560 :    
3561 :     for my $his_role (@his_roles)
3562 :     {
3563 : parrello 1.69 my $my_col = $self->get_col($local_roles[$his_role]);
3564 :     my $his_col = $ss->get_col($his_role);
3565 : olson 1.25
3566 : parrello 1.69 #
3567 :     # $his_col is the information for $his_role, indexed by
3568 :     # genome in @his_genomes.
3569 :     #
3570 :     # $my_col is hte information for my copy of $his_role,
3571 :     # indexed by genome in MY genome list.
3572 :     #
3573 : olson 1.25
3574 : parrello 1.69 my $my_role = $local_roles[$his_role];
3575 : olson 1.25
3576 : parrello 1.69 # print "merging: $self->{roles}->[$my_role] $ss->{roles}->[$his_role] his_role=$his_role my_role=$my_role\n";
3577 : olson 1.25
3578 : parrello 1.69 for my $his_gidx (0 .. @his_genomes - 1)
3579 :     {
3580 :     my $hisent = $his_col->[$his_gidx];
3581 : olson 1.25
3582 : parrello 1.69 my $my_gidx = $local_genomes[$his_gidx];
3583 : parrello 1.60
3584 : overbeek 1.37
3585 : parrello 1.69 my $myent = $my_col->[$my_gidx];
3586 : olson 1.25
3587 : parrello 1.69 # print " his_gidx=$his_gidx my_gidx=$my_gidx hisent=@$hisent myent=@$myent\n";
3588 : olson 1.25
3589 : parrello 1.69 my %new;
3590 :     map { $new{$_}++ } @$hisent;
3591 :     map { $new{$_}++ } @$myent;
3592 : olson 1.25
3593 : parrello 1.69 @$myent = keys(%new);
3594 : olson 1.25
3595 : parrello 1.69 # print " new entry: @$myent\n";
3596 :     }
3597 : olson 1.25 }
3598 : olson 1.26
3599 :     #
3600 :     # Fix up the variant codes.
3601 :     #
3602 :    
3603 :     for my $his_gidx (0 .. @his_genomes - 1)
3604 :     {
3605 : parrello 1.69 my $his_code = $ss->get_variant_code($his_gidx);
3606 :     my $my_gidx = $local_genomes[$his_gidx];
3607 : olson 1.26
3608 : parrello 1.69 if (!$self->get_variant_code($my_gidx))
3609 :     {
3610 :     $self->{variant_code}->[$my_gidx] = $his_code;
3611 :     }
3612 : olson 1.26 }
3613 :    
3614 :     #
3615 :     # If we are to add notes, append the other subsystem's notes text.
3616 :     #
3617 :    
3618 :     if ($add_notes)
3619 :     {
3620 : parrello 1.69 my $his_notes = $ss->get_notes();
3621 : olson 1.26
3622 : parrello 1.69 $self->{notes} .= "\nNotes copied from $ss->{name}:\n$his_notes\n";
3623 : olson 1.26 }
3624 : olson 1.25 }
3625 : olson 1.17
3626 : olson 1.1 sub dump
3627 :     {
3628 :     my($self) = @_;
3629 :    
3630 :     for my $k (keys(%$self))
3631 :     {
3632 : parrello 1.69 next if $k eq "spreadsheet" or $k eq "spreadsheet_inv";
3633 :     print "Key \"$k\": ", Dumper($self->{$k});
3634 : olson 1.1 }
3635 :     }
3636 : parrello 1.60
3637 : olson 1.14 #
3638 :     # Increment the subsystem's version number.
3639 :     #
3640 :     sub incr_version {
3641 :     my($self) = @_;
3642 :    
3643 :     my $dir = $self->{dir};
3644 :     my $vfile = "$dir/VERSION";
3645 :     my($ver);
3646 :    
3647 :     if (open(my $fh,"<$vfile"))
3648 :     {
3649 :     if (defined($ver = <$fh>) && ($ver =~ /^(\S+)/))
3650 :     {
3651 :     $ver = $1;
3652 :     }
3653 :     else
3654 :     {
3655 :     $ver = 0;
3656 :     }
3657 :     close($fh);
3658 :     }
3659 :     else
3660 :     {
3661 :     $ver = 0;
3662 :     }
3663 :    
3664 :     $ver++;
3665 :    
3666 :     open(my $fh, ">$vfile") || die "could not open $vfile";
3667 :     print $fh "$ver\n";
3668 :     close($fh);
3669 :    
3670 :     chmod(0777, $vfile);
3671 :    
3672 :     $self->load_version();
3673 :     }
3674 : olson 1.1
3675 : heiko 1.78
3676 :     =head3 functional_role_instances
3677 :    
3678 :     C<< my @role_instances = $sub->functional_role_instances($role); >>
3679 :    
3680 :     Returns the set of genes for a functional role that belong to
3681 :     genomes with functional variants (> 0).
3682 :    
3683 : heiko 1.87 If the flag $strict is set to true,
3684 :     an additional check for the correct function assignment is performed.
3685 :     If the name of the functional role does not occur exaclty in the
3686 :     latest function assignment of the PEG, it is not included in the
3687 :     returned array. A simple index check is done.
3688 :    
3689 : heiko 1.78 =cut
3690 :    
3691 :     sub functional_role_instances {
3692 :    
3693 : heiko 1.87 my ($self, $role, $strict) = @_;
3694 : heiko 1.78 my $i =0;
3695 :    
3696 :     my @instances;
3697 :    
3698 :     foreach my $cell (@{$self->get_col($self->get_role_index($role))}) {
3699 :    
3700 :     if ((scalar @$cell > 0) && ($self->get_variant_code($i) > 0)) {
3701 :     foreach (@$cell) {
3702 : heiko 1.87
3703 :    
3704 :     unless ($strict) {
3705 :     push @instances, $_;
3706 :     } else {
3707 :     # check if the peg is still in sync with the role assignment
3708 :     # will tolerate multiple role assignments but no mismatches
3709 :     my $current_function = $self->{fig}->function_of($_);
3710 :     if (index($current_function, $role) != -1) {
3711 :     push @instances, $_;
3712 :     } else {
3713 :     print STDERR "[Warning] Function of $_ out of sync for role $role in subsystem ".$self->get_name()."\n";
3714 :     }
3715 :     }
3716 : heiko 1.78 }
3717 :     }
3718 :     $i++;
3719 :     }
3720 :    
3721 :    
3722 :     return @instances if wantarray;
3723 :     return \@instances;
3724 :    
3725 :     }
3726 :    
3727 :    
3728 :    
3729 :    
3730 : parrello 1.75 =head3 get_dir_from_name
3731 :    
3732 :     C<< my $dirName = Subsystem::get_dir_from_name($name); >>
3733 :    
3734 :     Return the name of the directory containing the SEED data for the specified
3735 :     subsystem.
3736 :    
3737 :     =over 4
3738 :    
3739 :     =item name
3740 :    
3741 :     Name of the subsystem whose directory is desired.
3742 :    
3743 :     =item RETURN
3744 :    
3745 :     Returns the fully-qualified directory name for the subsystem.
3746 :    
3747 :     =back
3748 :    
3749 :     =cut
3750 :    
3751 : olson 1.1 sub get_dir_from_name
3752 :     {
3753 :     my($name) = @_;
3754 :    
3755 :     my $b = $name;
3756 :     $b =~ s/ /_/g;
3757 :     my $dir = File::Spec->catfile($FIG_Config::data, 'Subsystems', $b);
3758 :     return $dir;
3759 :     }
3760 :    
3761 : olson 1.12 #
3762 :     # Code for dealing with Bill McCune's prolog code for extending subsystems.
3763 :     #
3764 :     # The code here is a reconstruction of Bill's "go" script in perl with
3765 :     # data pulled from the local SEED configuration.
3766 :     #
3767 :    
3768 :     sub extend_with_billogix
3769 :     {
3770 : olson 1.42 my($self, $muser, $genomes) = @_;
3771 : olson 1.12 my($isMaster, $user);
3772 : parrello 1.60
3773 : olson 1.12 my $now = time();
3774 :    
3775 :     if ($muser =~ /master:(.*)/)
3776 :     {
3777 : parrello 1.69 $isMaster = 1;
3778 :     $user = $1;
3779 : olson 1.12 }
3780 :     else
3781 :     {
3782 : parrello 1.69 $isMaster = 0;
3783 :     $user = $muser;
3784 : olson 1.12 }
3785 :    
3786 :     #
3787 : olson 1.42 # initialize the genome list to all complete genomes, if none was passed in.
3788 :     #
3789 :    
3790 :     if (!$genomes)
3791 :     {
3792 : parrello 1.69 $genomes = [$self->{fig}->genomes("complete")];
3793 :     warn "getting genome list from fig $self->{fig}";
3794 : olson 1.42 }
3795 :    
3796 :     #
3797 :     # Ensure genome list is of the right form.
3798 :     #
3799 :    
3800 :     if (ref($genomes) ne "ARRAY")
3801 :     {
3802 : parrello 1.69 warn "billogix: genome list is not a list reference";
3803 :     return;
3804 : olson 1.42 }
3805 :    
3806 :     for my $g (@$genomes)
3807 :     {
3808 : parrello 1.69 if ($g !~ /^\d+\.\d+/)
3809 :     {
3810 :     warn "billogix: genome '$g' is not of the proper form, aborting billogix run.";
3811 :     return;
3812 :     }
3813 : olson 1.42 }
3814 : parrello 1.60
3815 : olson 1.42 my $genome_list = "[" . join(", ", map { "'$_'" } @$genomes) . "]";
3816 :    
3817 :     warn "Genomes: $genome_list\n";
3818 :     warn Dumper($genomes);
3819 : parrello 1.60
3820 : olson 1.42 #
3821 : olson 1.12 # Find the executable.
3822 :     #
3823 :    
3824 :     my $exe = "$FIG_Config::bin/billogix";
3825 :    
3826 :     if (! -x $exe)
3827 :     {
3828 : parrello 1.69 warn "Cannot find billogix exe at $exe\n";
3829 :     return;
3830 : olson 1.12 }
3831 : parrello 1.60
3832 : olson 1.12 my $ss_name = $self->{name};
3833 : olson 1.18
3834 :     $ss_name =~ s/\s+/_/g;
3835 : parrello 1.60
3836 : olson 1.14 my $ss_dir = "$self->{dir}/";
3837 : olson 1.15 my $assign_dir = "$FIG_Config::data/Assignments/$user/";
3838 : olson 1.12 &FIG::verify_dir($assign_dir);
3839 :    
3840 : olson 1.16 my $when= strftime("%m-%d-%y:%H:%M:%S", localtime($now));
3841 :     my $job_id = "${when}:sss:$ss_name";
3842 :    
3843 : olson 1.12 my $seed = &FIG::cgi_url() . "/";
3844 : olson 1.13 my $export_part = "ssa.cgi?user=$muser&request=delete_or_export_ssa&export=";
3845 : olson 1.12
3846 :     #
3847 :     # Have the prereq stuff, now start up the app.
3848 :     #
3849 :    
3850 :     $ENV{LOCALSZ} = "80000";
3851 :     $ENV{GLOBALSZ} = "80000";
3852 :     $ENV{TRAILSZ} = "30000";
3853 : olson 1.13
3854 :     my $arch = &FIG::get_current_arch();
3855 :    
3856 :     $ENV{BILLOGIX} = "$FIG_Config::fig_disk/dist/releases/current/$arch/lib/Billogix";
3857 :    
3858 :     #
3859 :     # Need to ensure pl2wam is in our path
3860 :     #
3861 :    
3862 :     $ENV{PATH} = "${FIG_Config::ext_bin}:$ENV{PATH}";
3863 : olson 1.12
3864 : olson 1.23 #
3865 :     # We're going to divide the run into $n_chunks chunks.
3866 :     #
3867 :    
3868 :     my $n_chunks = 10;
3869 :    
3870 :     my($log);
3871 :     open($log, ">$ss_dir/$job_id.log");
3872 :    
3873 :     for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
3874 :     {
3875 : parrello 1.69 my $app_input = <<EOINP;
3876 : olson 1.12 ['\$BILLOGIX/top'].
3877 :     loadup.
3878 : olson 1.42 asserta(job_genome_list($genome_list)).
3879 : olson 1.23 asserta(part($this_chunk, $n_chunks)).
3880 : olson 1.12 asserta(url_default_seed('$seed')).
3881 : olson 1.13 asserta(url_export_part('$export_part')).
3882 : olson 1.12 asserta(ss_directory('$ss_dir')).
3883 :     asserta(assign_directory('$assign_dir')).
3884 :     asserta(job_id('$job_id')).
3885 :     extend_test3('$ss_name').
3886 :     EOINP
3887 :    
3888 : olson 1.23 print STDERR <<EOF;
3889 : olson 1.12 Starting app
3890 :    
3891 : olson 1.23 chunk $this_chunk of $n_chunks
3892 : olson 1.12 ss_name = $ss_name
3893 :     ss_dir = $ss_dir
3894 :     user = $user
3895 :     assign_dir = $assign_dir
3896 :     exe = $exe
3897 : olson 1.13 libdir = $ENV{BILLOGIX}
3898 :     path = $ENV{PATH}
3899 : olson 1.12
3900 :     App input
3901 :     $app_input
3902 :     EOF
3903 :     # feh, put in a block to reset perlmode indentation.
3904 : olson 1.23 {
3905 : parrello 1.69 my($app_read, $app_write);
3906 : parrello 1.60
3907 : parrello 1.69 #
3908 :     # Start the actual application with stdin and stdout redirected
3909 :     # to pipes.
3910 :     #
3911 :     # We write $app_input to the stdin pipe, and close it.
3912 :     # Then loop reading stdout, logging that output.
3913 :     #
3914 :     my $pid = open2($app_read, $app_write, $exe);
3915 :    
3916 :     if (!$pid)
3917 :     {
3918 :     warn "open2 $exe failed: $!\n";
3919 :     print $log "open2 $exe failed: $!\n";
3920 :     return;
3921 :     }
3922 :    
3923 :     print $app_write $app_input;
3924 :     close($app_write);
3925 :    
3926 :     #
3927 :     # Set autoflush on the logfile.
3928 :     #
3929 :    
3930 :     my $old = select($log);
3931 :     $| = 1;
3932 :     select(STDERR);
3933 :     $| = 1;
3934 :     select($old);
3935 :    
3936 :     warn "Starting $exe with pid $pid\n";
3937 :     print $log "Starting $exe with pid $pid\n";
3938 :    
3939 :     while (<$app_read>)
3940 :     {
3941 :     print STDERR $_;
3942 :     print $log $_;
3943 :     }
3944 :    
3945 :     print STDERR "App done\n";
3946 :     print $log "App done\n";
3947 :    
3948 :     close($app_read);
3949 :    
3950 :     my $ret = waitpid($pid, 0);
3951 :     my $stat = $?;
3952 :     print STDERR "Return status is $?\n";
3953 :     print $log "Return status is $?\n";
3954 :    
3955 :     #
3956 :     # This chunk has finished. We should see a file
3957 :     # rows.$this_chunk.$n_chunks.
3958 :     #
3959 :     }
3960 : olson 1.23 }
3961 :     #
3962 :     # At this point, the extension is finished (we've run the
3963 :     # $n_chunks parts of the extension job).
3964 :     #
3965 : olson 1.12
3966 : olson 1.14 #
3967 : olson 1.23 # We read in all the individual rows files, writing the single
3968 :     # concatenation of rows.
3969 : olson 1.14 #
3970 : olson 1.12
3971 : olson 1.23 my $ssaD = $self->{dir};
3972 : parrello 1.60
3973 : olson 1.23 my $rows_file = "$ssaD/rows";
3974 :    
3975 :     my $rowFH;
3976 :     if (!open($rowFH, ">$rows_file"))
3977 : olson 1.12 {
3978 : parrello 1.69 my $err = "Cannot open rows file $ssaD/rows for writing: $!\n";
3979 :     print STDERR $err;
3980 :     print $log $err;
3981 :     return;
3982 : olson 1.12 }
3983 :    
3984 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
3985 :     {
3986 : parrello 1.69 my $chunkFH;
3987 :     my $cfile = "$ssaD/rows.$this_chunk.$n_chunks";
3988 :     if (!open($chunkFH, "<$cfile"))
3989 :     {
3990 :     my $err = "Cannot open rows file $cfile for reading: $!\n";
3991 :     print STDERR $err;
3992 :     print $log $err;
3993 :     return;
3994 :     }
3995 :     while (<$chunkFH>)
3996 :     {
3997 :     print $rowFH $_;
3998 :     }
3999 :     close($chunkFH);
4000 : olson 1.23 }
4001 :     close($rowFH);
4002 : olson 1.12
4003 :     #
4004 : olson 1.23 # Concatenate the assignments into the assignment directory.
4005 : olson 1.12 #
4006 :    
4007 : olson 1.23 my $assignments_file = "$assign_dir$job_id";
4008 :     my $assignFH;
4009 : olson 1.12
4010 : olson 1.23 if (!open($assignFH, ">$assignments_file"))
4011 : olson 1.12 {
4012 : parrello 1.69 my $err = "Cannot open assignments file $assignments_file for writing: $!\n";
4013 :     print STDERR $err;
4014 :     print $log $err;
4015 :     return;
4016 : olson 1.12 }
4017 :    
4018 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
4019 : olson 1.19 {
4020 : parrello 1.69 my $aFH;
4021 :     my $afile = "$ssaD/assignments.$this_chunk.$n_chunks";
4022 :     if (!open($aFH, "<$afile"))
4023 :     {
4024 :     my $err = "Cannot open assignments file $afile for reading: $!\n";
4025 :     print STDERR $err;
4026 :     print $log $err;
4027 :     return;
4028 :     }
4029 :     while (<$aFH>)
4030 :     {
4031 :     print $assignFH $_;
4032 :     }
4033 :     close($aFH);
4034 : olson 1.19 }
4035 : olson 1.23 close($assignFH);
4036 : olson 1.19
4037 : parrello 1.60
4038 :    
4039 : olson 1.19 #
4040 : olson 1.14 # Back up the spreadsheet, and append the rows file to it.
4041 :     #
4042 :    
4043 :     &FIG::verify_dir("$ssaD/Backup");
4044 :     my $ts = time;
4045 :     rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
4046 :     copy("$ssaD/spreadsheet","$ssaD/spreadsheet~");
4047 :     rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
4048 :    
4049 :     #
4050 :     # Append the new rows to the spreadsheet.
4051 :     #
4052 :    
4053 :     my($ssafh, $rowsfh);
4054 :     open($ssafh, ">>$ssaD/spreadsheet") or die "Cannot open $ssaD/spreadsheet for append: $!\n";
4055 :     open($rowsfh, "<$ssaD/rows") or die "Cannot open $ssaD/rows for reading: $!\n";
4056 : parrello 1.60
4057 : olson 1.14 while (<$rowsfh>)
4058 :     {
4059 : parrello 1.69 print $ssafh $_;
4060 : olson 1.14 }
4061 :     close($ssafh);
4062 :     close($rowsfh);
4063 :    
4064 :     $self->incr_version();
4065 : olson 1.12 }
4066 : olson 1.13
4067 : olson 1.105 sub copy_hope_info
4068 :     {
4069 :     my ($self) = @_;
4070 :    
4071 :     my $dir = $self->{dir};
4072 :     my $b = $self->{name};
4073 :     $b =~ s/ /_/g;
4074 :     my $hope_dir = File::Spec->catfile($FIG_Config::data, 'Subsystems.hope', $b);
4075 :    
4076 :     copy("$hope_dir/hope_curation_notes", "$dir/hope_curation_notes");
4077 :     copy("$hope_dir/hope_kegg_info", "$dir/hope_kegg_info");
4078 :     copy("$hope_dir/hope_reaction_links", "$dir/hope_reaction_links");
4079 :     copy("$hope_dir/hope_reaction_notes", "$dir/hope_reaction_notes");
4080 :     copy("$hope_dir/hope_reactions", "$dir/hope_reactions");
4081 :    
4082 :     $self->incr_version();
4083 :     }
4084 : olson 1.14
4085 : olson 1.13 sub set_current_extend_pid
4086 :     {
4087 :     my($self, $pid) = @_;
4088 :    
4089 :     if (open(my $fh, ">$self->{dir}/EXTEND_PID"))
4090 :     {
4091 : parrello 1.69 print $fh "$pid\n";
4092 : olson 1.13 }
4093 :     else
4094 :     {
4095 : parrello 1.69 warn "Cannot open $self->{dir}/EXTEND_PID: $!\n";
4096 : olson 1.13 }
4097 :     }
4098 :    
4099 :     sub get_current_extend_pid
4100 :     {
4101 :     my($self) = @_;
4102 :    
4103 :     if (open(my $fh, "<$self->{dir}/EXTEND_PID"))
4104 :     {
4105 : parrello 1.69 my $pid = <$fh>;
4106 :     close($fh);
4107 :     if ($pid)
4108 :     {
4109 :     chomp $pid;
4110 : parrello 1.60
4111 : parrello 1.69 return $pid;
4112 :     }
4113 : olson 1.13 }
4114 :     return undef;
4115 :     }
4116 : parrello 1.60
4117 : parrello 1.75 =head2 Static Utilities
4118 :    
4119 :     These are internal static methods used by the Sprout Subsystem object
4120 :     (SproutSubsys.pm). They insure that common functions are implemented with
4121 :     common code.
4122 :    
4123 :     =head3 GetDiagramIDs
4124 :    
4125 :     C<< my @diagramIDs = Subsystem::GetDiagramIDs($subDir); >>
4126 :    
4127 :     Return a list of the subsystem diagram IDs. The parameters are
4128 :    
4129 :     =over 4
4130 :    
4131 :     =item subDir
4132 :    
4133 :     Fully-qualified directory name for the subsystem.
4134 :    
4135 :     =item RETURN
4136 :    
4137 :     Returns a list of the diagram IDs for this subsystem. Each diagram ID corresponds
4138 :     to a diagram subdirectory in the subsystem's directory.
4139 :    
4140 :     =back
4141 :    
4142 :     =cut
4143 :    
4144 :     sub GetDiagramIDs {
4145 :     # Get the parameters.
4146 :     my ($subDir) = @_;
4147 :     # Read the diagram subdirectories.
4148 :     opendir(D, "$subDir/diagrams");
4149 :     my @ids = grep { not /^\./ and -d "$subDir/diagrams/$_" } readdir(D);
4150 :     closedir(D);
4151 :     # Return the IDs.
4152 :     return @ids;
4153 :    
4154 :     }
4155 :    
4156 :     =head3 GetDiagramName
4157 :    
4158 :     C<< my $name = Subsystem::GetDiagramName($subDir, $diagramID); >>
4159 :    
4160 :     Return the name of the subsystem diagram with the specified ID.
4161 :    
4162 :     =over 4
4163 :    
4164 :     =item subDir
4165 :    
4166 :     Subsystem directory name.
4167 :    
4168 :     =item diagramID
4169 :    
4170 :     ID of the diagram whose name is desired.
4171 :    
4172 :     =item RETURN
4173 :    
4174 :     Returns the name of the specified diagram, or C<undef> if the diagram does
4175 :     not exist.
4176 :    
4177 :     =back
4178 :    
4179 :     =cut
4180 :    
4181 :     sub GetDiagramName {
4182 :     # Get the parameters.
4183 :     my ($subDir, $diagramID) = @_;
4184 : parrello 1.77 # Declare the return value.
4185 :     my $retVal;
4186 : parrello 1.75 # Get the diagram's directory.
4187 :     my $ddir = "$subDir/diagrams/$diagramID";
4188 : parrello 1.77 Trace("Looking for directory $ddir.") if T(3);
4189 : parrello 1.75 # Only proceed if the directory exists.
4190 : parrello 1.77 if (-d $ddir) {
4191 :     # Read the name.
4192 :     my $name = &FIG::file_head("$ddir/NAME", 1);
4193 :     # If there was no name, use the diagram ID.
4194 :     Trace("Diagram name is \"$name\".") if T(3);
4195 :     if (! $name) {
4196 :     Trace("Using default name $diagramID.") if T(3);
4197 :     $name = $diagramID;
4198 :     }
4199 :     # Lop off the line terminator.
4200 :     chomp ($name);
4201 :     # Return the result.
4202 :     $retVal = $name;
4203 :     }
4204 :     Trace("Returning diagram name \"$retVal\".") if T(3);
4205 :     return $retVal;
4206 : parrello 1.75 }
4207 :    
4208 :     =head3 ComputeDiagramURLs
4209 :    
4210 :     C<< my ($link, $imgLink) = Subsystem::ComputeDiagramURLs($ssName, $diagramID); >>
4211 :    
4212 :     This is an internal static method that computes the URLs for a subsystem diagram.
4213 :     It insures that both SEED and Sprout use the same rules for generating the
4214 :     diagram URLs. The parameters are as follows.
4215 :    
4216 :     =over 4
4217 :    
4218 :     =item ssName
4219 :    
4220 :     Name of the relevant subsystem.
4221 :    
4222 :     =item diagramID
4223 :    
4224 :     ID of the relevant diagram.
4225 :    
4226 : parrello 1.90 =item sprout (optional)
4227 :    
4228 :     If specified, indicates this should be a Sprout URL.
4229 :    
4230 : parrello 1.75 =item RETURN
4231 :    
4232 :     Returns a two-element list, the first element of which is a link to the diagram
4233 :     page, and the second of which is a link to the diagram image.
4234 :    
4235 :     =back
4236 :    
4237 :     =cut
4238 :    
4239 :     sub ComputeDiagramURLs {
4240 :     # Get the parameters.
4241 : parrello 1.90 my ($ssName, $diagramID, $sprout) = @_;
4242 : parrello 1.75 # Compute the CGI directory base. Originally this was a configuration
4243 :     # parameter. Now we use a dot to force a relative URL.
4244 :     # my $base = $FIG_Config::cgi_base;
4245 :     my $base = './';
4246 :     # Create the links.
4247 :     my $link = $base . "subsys_diagram.cgi?ssa=$ssName&diagram=$diagramID";
4248 : parrello 1.90 if ($sprout) {
4249 :     $link .= "&SPROUT=1";
4250 :     }
4251 : parrello 1.75 my $img_link = $link . "&image=1";
4252 :     # Return them.
4253 :     return ($link, $img_link);
4254 :     }
4255 :    
4256 : olson 1.7 package Subsystem::Diagram;
4257 :    
4258 :     sub new
4259 :     {
4260 :     my($class, $sub, $fig, $name, $dir) = @_;
4261 :    
4262 :     if (!-d $dir)
4263 :     {
4264 : parrello 1.69 return undef;
4265 : olson 1.7 }
4266 :    
4267 :     my $self = {
4268 : parrello 1.69 fig => $fig,
4269 :     subsystem => $sub,
4270 :     name => $name,
4271 :     dir =>$ dir,
4272 : olson 1.7 };
4273 :     bless $self, $class;
4274 :    
4275 :     $self->load();
4276 :    
4277 :     return $self;
4278 :     }
4279 :    
4280 :     #
4281 :     # Parse the diagram into internal data structure.
4282 :     #
4283 :    
4284 :     sub load
4285 :     {
4286 :     my($self) = @_;
4287 :    
4288 :     $self->load_area();
4289 :     }
4290 :    
4291 :     sub load_area
4292 :     {
4293 :     my($self) = @_;
4294 :     my $fh;
4295 :    
4296 : olson 1.8 if (!open($fh, "<$self->{dir}/area_table"))
4297 : olson 1.7 {
4298 : parrello 1.69 warn "Could not load $self->{dir}/area_table: $!\n";
4299 :     return;
4300 : olson 1.7 }
4301 :    
4302 :     $self->{areas} = [];
4303 :    
4304 :     my $area_list = $self->{areas};
4305 : parrello 1.60
4306 : olson 1.7 while (<$fh>)
4307 :     {
4308 : parrello 1.69 chomp;
4309 :     s/#.*$//;
4310 :     s/^\s+//;
4311 :     s/\s+$//;
4312 :     next if $_ eq '';
4313 :     my ($area, $tag, $value) = split(/\s+/, $_, 3);
4314 :     # print "area=$area tag=$tag value=$value\n";
4315 :    
4316 :     push(@$area_list, [$area, $tag, $value]);
4317 :    
4318 :     #
4319 :     # Do a little checking.
4320 :     #
4321 :    
4322 :     if ($tag eq "role")
4323 :     {
4324 :     my $idx = $self->{subsystem}->get_role_index($value);
4325 :     if (!defined($idx))
4326 :     {
4327 :     warn "Role not found for \"$value\" in subsystem $self->{subsystem}->{name}\n";
4328 :     }
4329 :     }
4330 : olson 1.7 }
4331 :     close($fh);
4332 :     }
4333 :    
4334 :     sub get_areas
4335 :     {
4336 :     my($self) = @_;
4337 :    
4338 :     return @{$self->{areas}};
4339 :     }
4340 :    
4341 : parrello 1.75
4342 : olson 1.1 1;
4343 : olson 1.7
4344 : parrello 1.73 =head2 Method Listing
4345 :    
4346 :     =over 4
4347 :    
4348 :     =item index_cell
4349 :    
4350 :     Create the subsystem_index entries for the given cell.
4351 :     (NEW).
4352 :    
4353 :     =item delete_role(name)
4354 :    
4355 :     Delete the given role.
4356 :    
4357 :     =item add_role(name, abbr)
4358 :    
4359 :     Add a new role.
4360 :    
4361 :     =item get_subset(name)
4362 :