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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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