[Bio] / Sprout / NewStuffCheck.pl Repository:
ViewVC logotype

Annotation of /Sprout/NewStuffCheck.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     =head1 New Stuff Checker
4 :    
5 :     This script compares the genomes, features, and annotations in
6 : parrello 1.16 the old and new sprouts and lists the differences and produces
7 :     a report in HTML. The output is an HTML fragment, not an entire
8 :     web page. This is because we expect it to be included in another
9 :     page.
10 : parrello 1.1
11 : parrello 1.11 The currently-supported command-line options for NewStuffCheck are as follows.
12 : parrello 1.1
13 :     =over 4
14 :    
15 : parrello 1.8 =item nofeats
16 :    
17 :     Do not process features.
18 :    
19 : parrello 1.1 =item user
20 :    
21 :     Name suffix to be used for log files. If omitted, the PID is used.
22 :    
23 :     =item trace
24 :    
25 :     Numeric trace level. A higher trace level causes more messages to appear. The
26 :     default trace level is 2. Tracing will be directly to the standard output
27 :     as well as to a C<trace>I<User>C<.log> file in the FIG temporary directory,
28 :     where I<User> is the value of the B<user> option above.
29 :    
30 :     =item sql
31 :    
32 :     If specified, turns on tracing of SQL activity.
33 :    
34 :     =item background
35 :    
36 :     Save the standard and error output to files. The files will be created
37 :     in the FIG temporary directory and will be named C<err>I<User>C<.log> and
38 :     C<out>I<User>C<.log>, respectively, where I<User> is the value of the
39 :     B<user> option above.
40 :    
41 :     =item h
42 :    
43 :     Display this command's parameters and options.
44 :    
45 :     =item phone
46 :    
47 :     Phone number to message when the script is complete.
48 :    
49 : parrello 1.11 =item groupFile
50 :    
51 :     Name of the group file (described below). The default is C<groups.tbl>
52 :     in the Sprout data directory.
53 :    
54 : parrello 1.16 =item outFile
55 :    
56 : parrello 1.19 Output file name. The default is C<html/includes/diff.inc> in the
57 : parrello 1.16 nmpdr C<next> directory.
58 :    
59 : parrello 1.11 =back
60 :    
61 :     =head2 The Group File
62 :    
63 :     A key data file for this process is C<groups.tbl>. This file is kept in the
64 :     Sprout Data directory, and contains the following columns:
65 :    
66 :     =over 4
67 :    
68 :     =item name
69 :    
70 :     Name of the group.
71 :    
72 :     =item page
73 :    
74 :     Name of the group's page on the web site (e.g. C<campy.php> for
75 :     Campylobacter)
76 :    
77 :     =item genus
78 :    
79 :     Genus of the group
80 :    
81 :     =item species
82 :    
83 :     Species of the group, or an empty string if the group is for an entire
84 : parrello 1.13 genus. If the group contains more than one species, the species names
85 :     should be separated by commas.
86 : parrello 1.11
87 : parrello 1.1 =back
88 :    
89 :     =cut
90 :    
91 :     use strict;
92 :     use Tracer;
93 :     use DocUtils;
94 :     use TestUtils;
95 :     use Cwd;
96 :     use File::Copy;
97 :     use File::Path;
98 :     use FIG;
99 :     use SFXlate;
100 :     use Sprout;
101 : parrello 1.16 use CGI;
102 : parrello 1.20 use FIGRules;
103 : parrello 1.1
104 :     # Get the command-line options and parameters.
105 :     my ($options, @parameters) = StandardSetup([qw(Sprout) ],
106 :     {
107 : parrello 1.11 groupFile => ["$FIG_Config::sproutData/groups.tbl", "location of the NMPDR group description file"],
108 : parrello 1.8 nofeats => ["", "if specified, only genome changes will be displayed; otherwise, genome features will be compared and differences shown"],
109 : parrello 1.16 trace => ["2", "tracing level; use a minus to prevent tracing to standard output"],
110 : parrello 1.1 phone => ["", "phone number (international format) to call when load finishes"],
111 : parrello 1.16 outFile => ["$FIG_Config::nmpdr_base/next/html/includes/diff.inc", "output file for the difference report"],
112 : parrello 1.1 },
113 :     "",
114 :     @ARGV);
115 :     # Set a variable to contain return type information.
116 :     my $rtype;
117 :     # Insure we catch errors.
118 :     eval {
119 : parrello 1.16 # Get a CGI object for building the output. We pass it the options hash so
120 :     # the formatting subroutines have access to it. Also, we want it to know
121 :     # we're not a real web script.
122 :     my $cgi = CGI->new($options);
123 :     # Start accumulating HTML data.
124 :     my @html = ();
125 :     # Open the output file. We do this early in case there's a problem.
126 :     my $outFileName = $options->{outFile};
127 :     Trace("Opening output file $outFileName.") if T(2);
128 :     Open(\*OUTPUT, ">$outFileName");
129 :     # Get a nice-looking version name and make it into a title.
130 :     my $version = uc $FIG_Config::nmpdr_version;
131 :     $version =~ tr/_/ /;
132 :     push @html, $cgi->h4({align => "center"}, "Difference Report for $version.");
133 :     # Start the table.
134 :     push @html, $cgi->start_table({align => "center", border => "2"});
135 : parrello 1.11 # Get the group file.
136 :     my $groupFileName = $options->{groupFile};
137 :     Trace("Reading group file $groupFileName.") if T(2);
138 : parrello 1.16 # We'll put each group's data into a hash, keyed by group
139 : parrello 1.11 # name, each entry being a 3-tuple of page name, genus,
140 :     # and species
141 : parrello 1.13 my %groups = Sprout::ReadGroupFile($groupFileName);
142 : parrello 1.2 Trace("Processing genomes.") if T(2);
143 : parrello 1.8 # Get the current SEED.
144 :     my $fig = FIG->new();
145 : parrello 1.1 # Get the old Sprout.
146 :     my $oldSprout = SFXlate->new_sprout_only($FIG_Config::oldSproutDB);
147 :     # Get its genomes in alphabetical order.
148 : parrello 1.8 my @oldGenomes = GetGenomes($oldSprout);
149 : parrello 1.1 # Get the new Sprout.
150 :     my $newSprout = SFXlate->new_sprout_only();
151 :     # Get its genomes in alphabetical order.
152 : parrello 1.8 my @newGenomes = GetGenomes($newSprout);
153 : parrello 1.7 # Compare the two genomes lists.
154 : parrello 1.1 my ($insertedGenomes, $deletedGenomes) = Tracer::CompareLists(\@newGenomes, \@oldGenomes);
155 : parrello 1.7 # Add feature counts to the new genomes.
156 :     for my $insertedGenome (@{$insertedGenomes}) {
157 :     my $genomeID = $insertedGenome->[0];
158 : parrello 1.20 # For a new genome, display the feature and BBH counts.
159 : parrello 1.7 my $count = $newSprout->GetCount(['HasFeature'], "HasFeature(from-link) = ?",
160 :     [$genomeID]);
161 :     my $suffix = ($count == 1 ? " one feature" : "$count features");
162 : parrello 1.20 my $bbhCount = FIGRules::BatchBBHs("fig|$genomeID.%", 1e-10);
163 :     $suffix .= "; " . ($bbhCount == 1 ? "one BBH" : "$bbhCount BBHs");
164 : parrello 1.7 $insertedGenome->[1] .= "($suffix)";
165 :     }
166 : parrello 1.8 # Add information about SEED status to the deleted genomes.
167 :     for my $deletedGenome (@{$deletedGenomes}) {
168 :     my $genomeID = $deletedGenome->[0];
169 :     if ($fig->is_genome($genomeID)) {
170 :     my $complete = ($fig->is_complete($genomeID) ? "complete" : "incomplete");
171 : parrello 1.9 $deletedGenome->[1] .= "(still in SEED, $complete)";
172 : parrello 1.8 }
173 :     }
174 : parrello 1.1 # Display the lists.
175 : parrello 1.16 push @html, ShowLists($cgi, 'New Genomes' => $insertedGenomes,
176 :     'Deleted Genomes' => $deletedGenomes);
177 : parrello 1.8 # Now the groups.
178 :     Trace("Comparing groups.") if T(2);
179 :     my %oldGroups = $oldSprout->GetGroups();
180 :     my %newGroups = $newSprout->GetGroups();
181 :     # Loop through the new groups.
182 :     for my $newGroup (sort keys %newGroups) {
183 :     Trace("Processing group $newGroup.") if T(3);
184 :     # Find out if this group is new to this version.
185 :     if (! exists $oldGroups{$newGroup}) {
186 :     # Construct a list of this group's genes.
187 :     my @groupGenomes = NameGenomes($newSprout, $newGroups{$newGroup});
188 : parrello 1.16 push @html, ShowLists($cgi, "Genomes in new group $newGroup" => \@groupGenomes);
189 : parrello 1.8 } else {
190 :     # Here the group is in both versions. Fix the lists and compare them.
191 :     my @newGroupList = NameGenomes($newSprout, $newGroups{$newGroup});
192 :     my @oldGroupList = NameGenomes($oldSprout, $oldGroups{$newGroup});
193 : parrello 1.10 Trace("Comparing lists for $newGroup.") if T(4);
194 : parrello 1.8 my ($insertedGroupGenomes, $deletedGroupGenomes) = Tracer::CompareLists(\@newGroupList, \@oldGroupList);
195 : parrello 1.10 Trace("Comparison complete.") if T(4);
196 : parrello 1.16 # Delete the old group data. When we're done, this means the hash
197 :     # will contain only the deleted groups.
198 : parrello 1.8 delete $oldGroups{$newGroup};
199 :     # Show the lists. Empty lists will not be shown.
200 : parrello 1.10 Trace("Displaying group lists.") if T(4);
201 : parrello 1.16 push @html, ShowLists($cgi, "Genomes new to $newGroup" => $insertedGroupGenomes,
202 :     "Genomes no longer in $newGroup" => $deletedGroupGenomes);
203 : parrello 1.8 }
204 :     }
205 : parrello 1.10 Trace("Processing deleted groups.") if T(4);
206 : parrello 1.8 # Now list the deleted groups.
207 :     for my $oldGroup (sort keys %oldGroups) {
208 :     Trace("Processing deleted group $oldGroup.") if T(3);
209 :     my @groupGenomes = NameGenomes($oldSprout, $oldGroups{$oldGroup});
210 : parrello 1.16 push @html, ShowLists($cgi, "Genomes in deleted group $oldGroup" => \@groupGenomes);
211 : parrello 1.8 }
212 : parrello 1.1 # Next, we get the subsystems.
213 : parrello 1.2 Trace("Processing subsystems.") if T(2);
214 : parrello 1.1 my @oldSubsystems = GetSubsystems($oldSprout);
215 :     my @newSubsystems = GetSubsystems($newSprout);
216 :     # Compare and display the subsystem lists.
217 :     my ($insertedSubs, $deletedSubs) = Tracer::CompareLists(\@newSubsystems, \@oldSubsystems);
218 : parrello 1.8 # Check the deleted subsystems to see if they're in SEED.
219 :     if (scalar @{$deletedSubs} > 0) {
220 :     my %subChecker = map { $_ => 1 } $fig->all_subsystems();
221 :     for my $deletedSub (@{$deletedSubs}) {
222 :     my $subID = $deletedSub->[0];
223 :     if ($subChecker{$subID}) {
224 :     my $trusted = ($fig->usable_subsystem($subID) ? "usable" : "not usable");
225 : parrello 1.9 $deletedSub->[1] .= " (still in SEED, $trusted)";
226 : parrello 1.8 }
227 :     }
228 :     }
229 : parrello 1.16 push @html, ShowLists($cgi, 'New Subsystems' => $insertedSubs,
230 :     'Deleted Subsystems' => $deletedSubs);
231 : parrello 1.11 # Next, we show some basic counts.
232 : parrello 1.16 push @html, ShowTitle($cgi, "Statistics for old Sprout");
233 :     push @html, ShowCounts($cgi, $oldSprout);
234 :     push @html, ShowTitle($cgi, "Statistics for new Sprout");
235 :     push @html, ShowCounts($cgi, $newSprout);
236 : parrello 1.11 # Now we show the genomes that are not in groups but could be. First, we convert
237 :     # our group hash from the new Sprout into the form used on the web site.
238 :     Trace("Examining possible missing genomes in groups.") if T(2);
239 :     my %fixedGroups = Sprout::Fix(%newGroups);
240 :     for my $group (sort keys %groups) {
241 :     Trace("Checking group $group.");
242 :     # Get this group's genus and species.
243 :     my $genus = $groups{$group}->[1];
244 :     my $species = $groups{$group}->[2];
245 :     # Get a hash of the genomes already in it.
246 :     my %inGroup = map { $_ => 1 } @{$fixedGroups{$group}};
247 :     # Get a list of its possible genomes.
248 :     my $filter = 'Genome(genus) = ?';
249 :     my @parms = ($genus);
250 : parrello 1.13 # The species list is tricky because a given group may involve more than
251 :     # one target species. The species names will be comma-separated, and
252 :     # we use some PERL trickiness to generate an OR filter for them.
253 : parrello 1.11 if ($species) {
254 : parrello 1.13 # Get the individual species.
255 :     my @speciesList = split /\s*,\s*/, $species;
256 :     # Create one species filter per species.
257 :     my @filterClauses = map { 'Genome(species) = ?' } @speciesList;
258 :     # OR the filter clauses together to get a real filter.
259 :     $filter .= " AND (" . (join " OR ", @filterClauses) . ")";
260 :     # Add the specieis names to the SQL parameter list.
261 :     push @parms, @speciesList;
262 : parrello 1.11 }
263 :     my @possibles = $newSprout->GetFlat(['Genome'], $filter, \@parms, 'Genome(id)');
264 :     # Get the possibles that aren't in the group and add identifying information.
265 : parrello 1.12 my @leftOut = NameGenomes($newSprout, [ grep { ! exists $inGroup{$_} } @possibles ]);
266 : parrello 1.11 # If anything survived, show the list.
267 :     if (@leftOut) {
268 : parrello 1.16 push @html, ShowLists($cgi, "Candidates for $group" => \@leftOut);
269 : parrello 1.11 }
270 :     }
271 :     # Compare the property tables.
272 :     Trace("Comparing properties.") if T(2);
273 :     # Set up lists of all the properties in each sprout.
274 :     my @oldProps = GetProperties($oldSprout);
275 :     my @newProps = GetProperties($newSprout);
276 :     # Compare the lists.
277 :     my ($insertedProps, $deletedProps) = Tracer::CompareLists(\@oldProps, \@newProps);
278 :     # Now get all the properties in the new Sprout without any features.
279 :     my @emptyProps = grep { $_->[1] == 0 } @newProps;
280 :     # Show what we've found.
281 : parrello 1.16 push @html, ShowLists($cgi, 'New Properties' => $insertedProps,
282 :     'Deleted Properties' => $deletedProps,
283 :     'Empty Properties' => \@emptyProps);
284 : parrello 1.8 # Now we process the features of the common genes.
285 :     if (! $options->{nofeats}) {
286 :     # First we need a hash of the inserted stuff so we know to skip it.
287 :     my %skipGenomes = map { $_->[0] => 1 } @{$insertedGenomes};
288 :     # Loop through the genomees.
289 :     for my $genome (@newGenomes) {
290 :     # Get the ID and name.
291 :     my ($genomeID, $genomeName) = @{$genome};
292 :     Trace("Processing $genomeID.") if T(3);
293 :     # Only process the common genes.
294 :     if (! $skipGenomes{$genomeID}) {
295 :     # Compare the genome group information.
296 :     # Get the new and old features. This will be very stressful to the machine,
297 :     # because there are lots of features.
298 :     my @oldFeatures = GetFeatures($oldSprout, $genomeID);
299 :     my @newFeatures = GetFeatures($newSprout, $genomeID);
300 :     Trace("Comparing features for $genomeID.") if T(3);
301 :     # Compare the lists.
302 :     my ($insertedFeatures, $deletedFeatures) = Tracer::CompareLists(\@newFeatures, \@oldFeatures);
303 :     # Display the lists. Only nonempty lists are displayed; however, we do a check
304 :     # first anyway so the trace tells us what's happening.
305 :     if (scalar @{$insertedFeatures} + scalar @{$deletedFeatures} > 0) {
306 :     Trace("Displaying feature differences.") if T(3);
307 : parrello 1.16 push @html, ShowLists($cgi, "New Features for $genomeID" => $insertedFeatures,
308 :     "Features Deleted from $genomeID" => $deletedFeatures);
309 : parrello 1.8 }
310 : parrello 1.1 }
311 :     }
312 :     }
313 : parrello 1.16 # Close the table.
314 :     push @html, $cgi->end_table();
315 :     # Assemble and write the HTML.
316 :     Trace("Writing to output.") if T(2);
317 :     print OUTPUT join("\n", @html, "");
318 :     # Close the output file.
319 :     close OUTPUT;
320 :     Trace("Analysis complete.") if T(2);
321 : parrello 1.1 };
322 :     if ($@) {
323 :     Trace("Script failed with error: $@") if T(0);
324 :     $rtype = "error";
325 :     } else {
326 :     Trace("Script complete.") if T(2);
327 :     $rtype = "no error";
328 :     }
329 :     if ($options->{phone}) {
330 : parrello 1.11 my $msgID = Tracer::SendSMS($options->{phone}, "New Stuff Checker terminated with $rtype.");
331 : parrello 1.1 if ($msgID) {
332 :     Trace("Phone message sent with ID $msgID.") if T(2);
333 :     } else {
334 :     Trace("Phone message not sent.") if T(2);
335 :     }
336 :     }
337 :    
338 : parrello 1.8 =head3 GetGenomes
339 : parrello 1.1
340 : parrello 1.8 C<< my @geneList = GetGenomes($sprout); >>
341 : parrello 1.1
342 :     Return a list of the genomes in the specified Sprout instance. The genomes
343 :     are returned in alphabetical order by genome ID.
344 :    
345 :     =over 4
346 :    
347 :     =item sprout
348 :    
349 :     Sprout instance whose gene list is desired.
350 :    
351 :     =item RETURN
352 :    
353 :     Returns a list of two-tuples. The first element in each tuple is the genome ID,
354 :     and the second is the genome name (genus, species, strain).
355 :    
356 :     =back
357 :    
358 :     =cut
359 :    
360 : parrello 1.8 sub GetGenomes {
361 : parrello 1.1 # Get the parameters.
362 :     my ($sprout) = @_;
363 :     # Get the desired data.
364 :     my @genomes = $sprout->GetAll(['Genome'], "ORDER BY Genome(id)", [], ['Genome(id)',
365 :     'Genome(genus)',
366 :     'Genome(species)',
367 :     'Genome(unique-characterization)']);
368 :     # Create the genome names from the three pieces of the name.
369 :     my @retVal = map { [$_->[0], join(" ", @{$_}[1..3])] } @genomes;
370 :     # Return the result.
371 :     return @retVal;
372 :     }
373 :    
374 : parrello 1.8 =head3 NameGenomes
375 :    
376 : parrello 1.11 C<< my @newList = NameGenomes($sprout, \@genomes); >>
377 : parrello 1.8
378 :     Convert a list of genome IDs to a list of genome IDs with names.
379 :    
380 :     =over 4
381 :    
382 :     =item sprout
383 :    
384 :     The relevant sprout instance.
385 :    
386 :     =item genomes
387 :    
388 :     Reference to a list of genome IDs
389 :    
390 :     =item RETURN
391 :    
392 :     Returns a list of 2-tuples, each tuple consisting of a genome ID followed by a
393 :     genome name.
394 :    
395 :     =back
396 :    
397 :     =cut
398 :    
399 :     sub NameGenomes {
400 :     # Get the parameters.
401 :     my ($sprout, $genomes) = @_;
402 :     # Attach the names.
403 : parrello 1.16 my @retVal = map { [$sprout->GenusSpecies($_), $_ ] } @{$genomes};
404 : parrello 1.8 # Return the result.
405 :     return @retVal;
406 :     }
407 :    
408 : parrello 1.1 =head3 GetSubsystems
409 :    
410 :     C<< my @subsystems = GetSubsystems($sprout); >>
411 :    
412 :     Get a list of the subsystems in the specified Sprout instance.
413 :    
414 :     =over 4
415 :    
416 :     =item sprout
417 :    
418 :     Sprout instance whose subsystems are desired.
419 :    
420 :     =item RETURN
421 :    
422 :     Returns a list of 2-tuples, each consisting of the subsystem name followed by
423 :     the name of the curator.
424 :    
425 :     =back
426 :    
427 :     =cut
428 :    
429 :     sub GetSubsystems {
430 :     # Get the parameters.
431 :     my ($sprout) = @_;
432 :     # Declare the return variable.
433 :     my @retVal = $sprout->GetAll(['Subsystem'], "ORDER BY Subsystem(id)",
434 :     [], ['Subsystem(id)', 'Subsystem(curator)']);
435 :     # Return the result.
436 :     return @retVal;
437 :     }
438 :    
439 : parrello 1.11 =head3 GetProperties
440 :    
441 :     C<< my @propertyList = GetProperties($sprout); >>
442 :    
443 :     Return a list of properties. Each element in the list will be a 2-tuple containing
444 :     the property name and value in the first column and its ID in the second column.
445 :    
446 :     =over 4
447 :    
448 :     =item sprout
449 :    
450 :     Sprout instance to be used to retrieve the properties.
451 :    
452 :     =item RETURN
453 :    
454 :     Returns a list of 2-tuples. The first element in each 2-tuple will be a string
455 :     in the form of an assignment of the property value to the property name. The second
456 :     element will be the number of features possessing the property. The list will be
457 :     sorted in ascending alphabetical order.
458 :    
459 :     =back
460 :    
461 :     =cut
462 :    
463 :     sub GetProperties {
464 :     # Get the parameters.
465 :     my ($sprout) = @_;
466 :     # Get the properties.
467 :     my @props = $sprout->GetAll(['Property'],
468 :     "ORDER BY Property(property-name), Property(property-value)", [],
469 :     ['Property(property-name)', 'Property(property-value)', 'Property(id)']);
470 :     # Combine the property names and values and replace each property ID by a feature count.
471 :     my @retVal;
472 :     for my $propItem (@props) {
473 : parrello 1.19 # Split up the value on punctuation boundaries for readability.
474 :     my $propValue = $propItem->[1];
475 :     $propValue =~ s/::/ :: /g;
476 :     $propValue =~ s/([,;])(\S)/$1 $2/g;
477 :     my $label = $propItem->[0] . " = " . $propValue;
478 : parrello 1.11 my $count = $sprout->GetCount(['Feature', 'HasProperty'], "HasProperty(to-link) = ?",
479 :     [$propItem->[2]]);
480 :     push @retVal, [$label, $count];
481 :     }
482 :     # Return the result.
483 :     return @retVal;
484 :     }
485 :    
486 : parrello 1.1 =head3 GetFeatures
487 :    
488 :     C<< my @features = GetFeatures($sprout, $genomeID); >>
489 :    
490 :     Return the features of the specified genome in the specified Sprout instance.
491 :    
492 :     =over 4
493 :    
494 :     =item sprout
495 :    
496 :     Sprout instance to use to get the features.
497 :    
498 :     =item genomeID
499 :    
500 :     ID of the genome in question.
501 :    
502 :     =item RETURN
503 :    
504 :     Returns a list of 2-tuples, the first element being the feature ID and the second its
505 :     functional assignment (if any).
506 :    
507 :     =back
508 :    
509 :     =cut
510 :    
511 :     sub GetFeatures {
512 :     # Get the parameters.
513 :     my ($sprout, $genomeID) = @_;
514 :     # Get a list of the feature IDs and map them to their functional assignments.
515 :     my @retVal = map { [$_, $sprout->FunctionOf($_)] } $sprout->GetFlat(['HasFeature'],
516 :     "HasFeature(from-link) = ? ORDER BY HasFeature(to-link)",
517 :     [$genomeID], 'HasFeature(to-link)');
518 :     # Return the result.
519 :     return @retVal;
520 :     }
521 :    
522 :     =head3 ShowLists
523 :    
524 : parrello 1.16 C<< my @htmlLines = ShowLists($cgi, %lists); >>
525 : parrello 1.1
526 : parrello 1.16 Display a set of lists. Each list should consist of 2-tuples, and the list
527 :     entries will be displayed as 2-element table rows with a header row.
528 : parrello 1.1
529 :     =over 4
530 :    
531 : parrello 1.16 =item cgi
532 : parrello 1.2
533 : parrello 1.16 A CGI query object containing the options for this program. It is also used to format
534 :     HTML.
535 : parrello 1.2
536 : parrello 1.1 =item lists
537 :    
538 :     A hash mapping list names to list references.
539 :    
540 : parrello 1.16 =item RETURN
541 :    
542 :     Returns a list of HTML lines displaying the list in tabular form.
543 :    
544 : parrello 1.15 =back
545 :    
546 : parrello 1.1 =cut
547 :    
548 :     sub ShowLists {
549 :     # Get the parameters.
550 : parrello 1.16 my $cgi = shift @_;
551 : parrello 1.1 my %lists = @_;
552 : parrello 1.16 # Declare the return variable. The HTML lines will be accumulated
553 :     # in here and then joined with new-lines.
554 :     my @retVal = ();
555 : parrello 1.1 # Loop through the lists in alphabetical order by list name.
556 : parrello 1.6 for my $listName (sort keys %lists) {
557 : parrello 1.1 # Get the list itself.
558 :     my $list = $lists{$listName};
559 :     # Get the number of list items.
560 :     my $listSize = scalar @{$list};
561 : parrello 1.6 # Only proceed if the list is nonempty.
562 :     if ($listSize > 0) {
563 : parrello 1.16 my $header = ComputeHeader($listName, $listSize);
564 : parrello 1.6 Trace($header) if T(3);
565 : parrello 1.16 # Display the header line as a header.
566 :     push @retVal, ShowTitle($cgi, $header);
567 : parrello 1.17 # Now display the list as table rows. Note we convert underbars to spaces
568 :     # in the name row to make the table easier to fit into narrow places.
569 : parrello 1.16 for my $entry (@{$list}) {
570 :     my ($name, $data) = @{$entry};
571 : parrello 1.18 $name =~ tr/_/ /;
572 : parrello 1.16 push @retVal, $cgi->Tr($cgi->td($name), $cgi->td({align => "right"}, $data));
573 : parrello 1.1 }
574 :     }
575 :     }
576 : parrello 1.16 # Return the list of HTML lines.
577 :     return @retVal;
578 : parrello 1.1 }
579 :    
580 : parrello 1.16 =head3 ComputeHeader
581 : parrello 1.7
582 : parrello 1.16 C<< my $header = ComputeHeader($name, $count); >>
583 : parrello 1.7
584 :     Return a list header for a list of the specified length.
585 :    
586 :     =over 4
587 :    
588 :     =item name
589 :    
590 :     Name of the list.
591 :    
592 :     =item count
593 :    
594 :     Number of entries in the list.
595 :    
596 :     =item RETURN
597 :    
598 :     Returns a list header that shows the name of the list and the number of entries.
599 :    
600 :     =back
601 :    
602 :     =cut
603 :    
604 : parrello 1.16 sub ComputeHeader {
605 : parrello 1.7 # Get the parameters.
606 :     my ($name, $count) = @_;
607 :     # Declare the return variable.
608 : parrello 1.15 my $retVal;
609 : parrello 1.7 if ($count == 0) {
610 : parrello 1.16 $retVal = "$name: none";
611 : parrello 1.7 } elsif ($count == 1) {
612 : parrello 1.16 $retVal = "$name: one";
613 : parrello 1.7 } else {
614 : parrello 1.16 $retVal = "$name: $count";
615 : parrello 1.7 }
616 :     # Return the result.
617 :     return $retVal;
618 :     }
619 :    
620 : parrello 1.11 =head3 ShowCounts
621 :    
622 :     C<< ShowCounts($sprout); >>
623 :    
624 :     Display general counts for the specified sprout instance. These counts are
625 :     used in progress reports.
626 :    
627 :     =over 4
628 :    
629 : parrello 1.16 =item cgi
630 :    
631 :     CGI query object used to format the output.
632 :    
633 : parrello 1.11 =item sprout
634 :    
635 :     Sprout instance for which counts are to be produced.
636 :    
637 : parrello 1.16 =item RETURN
638 :    
639 :     Returns a list of HTML lines with the counts arranged in table rows.
640 :    
641 : parrello 1.11 =back
642 :    
643 :     =cut
644 :    
645 :     sub ShowCounts {
646 :     # Get the parameters.
647 : parrello 1.16 my ($cgi, $sprout) = @_;
648 : parrello 1.11 # Count genomes and subsystems.
649 :     my $genomes = $sprout->GetCount(['Genome']);
650 :     my $subsystems = $sprout->GetCount(['Subsystem']);
651 :     # Count roles, external functional assignments, and functional couplings.
652 :     my $roles = $sprout->GetCount(['OccursInSubsystem']);
653 :     my $funcs = $sprout->GetCount(['ExternalAliasFunc']);
654 :     my $couples = $sprout->GetCount(['Coupling']);
655 : parrello 1.16 # Count features.
656 : parrello 1.11 my $features = $sprout->GetCount(['Feature']);
657 :     # Display the counts.
658 : parrello 1.16 my @retVal = ();
659 :     push @retVal, $cgi->Tr($cgi->td("Genomes"), $cgi->td({ align => "right" }, $genomes));
660 :     push @retVal, $cgi->Tr($cgi->td("Subsystems"), $cgi->td({ align => "right" }, $subsystems));
661 :     push @retVal, $cgi->Tr($cgi->td("Roles"), $cgi->td({ align => "right" }, $roles));
662 :     push @retVal, $cgi->Tr($cgi->td("External function assignments"), $cgi->td({ align => "right" }, $funcs));
663 :     push @retVal, $cgi->Tr($cgi->td("Features"), $cgi->td({ align => "right" }, $features));
664 :     push @retVal, $cgi->Tr($cgi->td("Functional Coupling"), $cgi->td({ align => "right" }, $couples));
665 :     # Return the html.
666 :     return @retVal;
667 :     }
668 :    
669 :     =head3 ShowTitle
670 :    
671 :     C<< my $html = ShowTitle($cgi, $title); >>
672 :    
673 :     Display a title line. This will be a merged table row with bolded text.
674 :    
675 :     =over 4
676 :    
677 :     =item cgi
678 :    
679 :     CGI query object used to generate HTML output.
680 :    
681 :     =item RETURN
682 :    
683 :     Returns the HTML text.
684 :    
685 :     =back
686 :    
687 :     =cut
688 :    
689 :     sub ShowTitle {
690 :     # Get the parameters.
691 :     my ($cgi, $title) = @_;
692 :     # Declare the return variable.
693 :     my $retVal = $cgi->Tr($cgi->th({colspan => 2, align => "center"}, $title));
694 :     # Return the result.
695 :     return $retVal;
696 : parrello 1.11 }
697 : parrello 1.16
698 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3