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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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