Parent Directory
| 
Revision Log
Revision 1.7 - (view) (download)
| 1 : | redwards | 1.1 | |
| 2 : | =pod | ||
| 3 : | |||
| 4 : | =head1 | ||
| 5 : | |||
| 6 : | Create a summary of subsystems | ||
| 7 : | |||
| 8 : | =cut | ||
| 9 : | |||
| 10 : | use strict; | ||
| 11 : | use FIG; | ||
| 12 : | use HTML; | ||
| 13 : | use raelib; | ||
| 14 : | use CGI; | ||
| 15 : | my $cgi=new CGI; | ||
| 16 : | |||
| 17 : | |||
| 18 : | my $fig; | ||
| 19 : | eval { | ||
| 20 : | $fig = new FIG; | ||
| 21 : | }; | ||
| 22 : | |||
| 23 : | if ($@ ne "") | ||
| 24 : | { | ||
| 25 : | my $err = $@; | ||
| 26 : | |||
| 27 : | my(@html); | ||
| 28 : | |||
| 29 : | push(@html, $cgi->p("Error connecting to SEED database.")); | ||
| 30 : | if ($err =~ /Could not connect to DBI:.*could not connect to server/) | ||
| 31 : | { | ||
| 32 : | push(@html, $cgi->p("Could not connect to relational database of type $FIG_Config::dbms named $FIG_Config::db on port $FIG_Config::dbport.")); | ||
| 33 : | } | ||
| 34 : | else | ||
| 35 : | { | ||
| 36 : | push(@html, $cgi->pre($err)); | ||
| 37 : | } | ||
| 38 : | &HTML::show_page($cgi, \@html, 1); | ||
| 39 : | exit; | ||
| 40 : | } | ||
| 41 : | |||
| 42 : | |||
| 43 : | |||
| 44 : | $ENV{"PATH"} = "$FIG_Config::bin:$FIG_Config::ext_bin:" . $ENV{"PATH"}; | ||
| 45 : | |||
| 46 : | my $html = []; | ||
| 47 : | |||
| 48 : | |||
| 49 : | if ($cgi->param('submit') eq "Summarize Subsystems") | ||
| 50 : | { | ||
| 51 : | summarize_ss(); | ||
| 52 : | } | ||
| 53 : | else | ||
| 54 : | { | ||
| 55 : | show_initial(); | ||
| 56 : | } | ||
| 57 : | |||
| 58 : | unshift @$html, "<TITLE>The SEED - Subsystem summarizer </TITLE>\n"; | ||
| 59 : | &HTML::show_page($cgi, $html, 1); | ||
| 60 : | exit; | ||
| 61 : | |||
| 62 : | |||
| 63 : | |||
| 64 : | |||
| 65 : | |||
| 66 : | |||
| 67 : | |||
| 68 : | |||
| 69 : | |||
| 70 : | |||
| 71 : | sub summarize_ss { | ||
| 72 : | my @wants; | ||
| 73 : | foreach my $w ($cgi->param('korgs')) { | ||
| 74 : | $w =~ /\((\d+\.\d+)\)/; | ||
| 75 : | push @wants, $1; | ||
| 76 : | } | ||
| 77 : | |||
| 78 : | |||
| 79 : | redwards | 1.5 | my @wantheaders; |
| 80 : | foreach my $gen (@wants) {push @wantheaders, $fig->abbrev($fig->genus_species($gen))} | ||
| 81 : | |||
| 82 : | redwards | 1.1 | my @th; |
| 83 : | redwards | 1.2 | if ($cgi->param('levels')) {push @th, ('Level 1', 'Level 2')} |
| 84 : | push @th, 'Subsystem'; # we should have this, at least | ||
| 85 : | if ($cgi->param('genomes')) {push @th, ('Organisms')} | ||
| 86 : | redwards | 1.5 | if ($cgi->param('stats')) {push @th, ('Roles', 'Total Pegs', @wantheaders)} |
| 87 : | elsif ($cgi->param('korgs')) {push @th, ('Roles', @wantheaders)} | ||
| 88 : | redwards | 1.1 | |
| 89 : | my $tableheader="<tr><th>". (join "</th><th>", @th) . "</th></tr>\n\n"; | ||
| 90 : | |||
| 91 : | my $cols=scalar @th; | ||
| 92 : | my $table; | ||
| 93 : | foreach my $subsys ($fig->all_subsystems) { | ||
| 94 : | |||
| 95 : | # figure out how many roles we have, as this will determine the number of rows in the table | ||
| 96 : | my @roles=$fig->subsystem_to_roles($subsys); | ||
| 97 : | my $rows=1; | ||
| 98 : | redwards | 1.3 | if (!$cgi->param('stats') && $cgi->param('korgs')) {$rows=scalar @roles} |
| 99 : | redwards | 1.1 | |
| 100 : | # figure out which genomes are in this subsystem | ||
| 101 : | my %genomes; | ||
| 102 : | foreach my $gen (@{$fig->subsystem_genomes($subsys)}) {$genomes{$gen->[0]}=$gen->[1]} | ||
| 103 : | |||
| 104 : | redwards | 1.2 | # start a new row for this data |
| 105 : | redwards | 1.3 | # tablerows is a refence to an array. |
| 106 : | redwards | 1.4 | # each element is an array of tablecells with the following values value colspan rowspan width |
| 107 : | # if colspan or rowspan are undef they are believed to be 1 | ||
| 108 : | # if width is ommitted it is ignored | ||
| 109 : | |||
| 110 : | redwards | 1.3 | my $tablerows; |
| 111 : | redwards | 1.7 | my $mt; #DELETE THIS |
| 112 : | redwards | 1.1 | # get the classification if required |
| 113 : | if ($cgi->param('levels')) { | ||
| 114 : | redwards | 1.2 | # get the classification and make sure there are now 2 columns as andrei doesn't like #3. |
| 115 : | redwards | 1.1 | my $class=$fig->subsystem_classification($subsys); |
| 116 : | redwards | 1.2 | unless ($class) {@$class=(' ',' ')} |
| 117 : | unless ($$class[0]) {$$class[0] = " "} | ||
| 118 : | unless ($$class[1]) {$$class[1] = " "} | ||
| 119 : | # remove anything more than $$class[1]; | ||
| 120 : | @$class=($$class[0], $$class[1]); # could have done this with splice. Ech. | ||
| 121 : | |||
| 122 : | redwards | 1.3 | foreach my $c (@$class) { |
| 123 : | redwards | 1.5 | push @$tablerows, [$c, 1, $rows, 20]; |
| 124 : | redwards | 1.3 | } |
| 125 : | redwards | 1.1 | } |
| 126 : | |||
| 127 : | redwards | 1.2 | # add the subsystem to the table |
| 128 : | redwards | 1.4 | push @$tablerows, ["<strong>$subsys<strong>", '1', $rows]; |
| 129 : | redwards | 1.2 | |
| 130 : | redwards | 1.1 | # add the genomes in the subsystem |
| 131 : | redwards | 1.4 | if ($cgi->param('genomes') && $cgi->param('stats')) {push @$tablerows, [(scalar keys %genomes), '1', $rows]} |
| 132 : | redwards | 1.3 | elsif ($cgi->param('genomes')) { |
| 133 : | my $c=join "<br>\n", sort {$a cmp $b} values %genomes; | ||
| 134 : | redwards | 1.4 | push @$tablerows, [$c, 1, $rows]; |
| 135 : | redwards | 1.3 | } |
| 136 : | redwards | 1.2 | |
| 137 : | redwards | 1.3 | # |
| 138 : | # This is convolvuted because we may want to skip some empty cells, but we won't know whether | ||
| 139 : | # we want to skip them. Also, we are using rowspan/colspan to determine the size of the cells | ||
| 140 : | # so we need everything defined | ||
| 141 : | # | ||
| 142 : | # I store the table initially in @$tablerows, and then push it into @$table. Later on we | ||
| 143 : | # reconstruct @$table with <td> etc.... | ||
| 144 : | # | ||
| 145 : | # Now I am going to store the rows in @$toadd, and if we want them I will add them to @$table. | ||
| 146 : | # | ||
| 147 : | # For stats, there is only one row in @$toadd, but for other data there are several because | ||
| 148 : | # of the use of rowspan | ||
| 149 : | |||
| 150 : | my $pegcount; | ||
| 151 : | my $toadd; #this is what we will add if we need to | ||
| 152 : | redwards | 1.2 | if ($cgi->param('stats')) { |
| 153 : | redwards | 1.4 | push @$tablerows, [(scalar @roles), '1', $rows]; |
| 154 : | redwards | 1.3 | my $totalpegs; |
| 155 : | redwards | 1.2 | # there should be a quicker way of getting this ... ? |
| 156 : | foreach my $role (@roles) { | ||
| 157 : | foreach my $genome (keys %genomes) { | ||
| 158 : | my $count = scalar ($fig->pegs_in_subsystem_cell($subsys, $genome, $role)); | ||
| 159 : | $pegcount->{$genome} += $count; | ||
| 160 : | $totalpegs += $count; | ||
| 161 : | } | ||
| 162 : | } | ||
| 163 : | redwards | 1.3 | |
| 164 : | redwards | 1.4 | push @$tablerows, [$totalpegs, '1', $rows]; |
| 165 : | redwards | 1.2 | foreach my $w (@wants) { |
| 166 : | redwards | 1.4 | push @$tablerows, [$pegcount->{$w}, '1', $rows]; # pegs for each of the chosen genomes |
| 167 : | redwards | 1.2 | } |
| 168 : | redwards | 1.3 | push @$toadd, $tablerows; |
| 169 : | redwards | 1.2 | } |
| 170 : | redwards | 1.3 | elsif ($cgi->param('korgs')) { |
| 171 : | redwards | 1.1 | my $first=1; |
| 172 : | foreach my $role (@roles) { | ||
| 173 : | my $genomeroles; | ||
| 174 : | foreach my $gen (@wants) { | ||
| 175 : | redwards | 1.2 | my $cell = ' '; |
| 176 : | redwards | 1.1 | if ($genomes{$gen}) { |
| 177 : | foreach my $peg ($fig->pegs_in_subsystem_cell($subsys, $gen, $role)) { | ||
| 178 : | redwards | 1.6 | $cell .= &HTML::fid_link($cgi,$peg, 'local') . "; "; |
| 179 : | redwards | 1.1 | } |
| 180 : | } | ||
| 181 : | redwards | 1.4 | push @$genomeroles, [$cell, 1, 1]; |
| 182 : | redwards | 1.1 | } |
| 183 : | # because I am using rowspan to make long columns, we don't want the tr on the first of these. | ||
| 184 : | redwards | 1.3 | if ($first) { |
| 185 : | redwards | 1.7 | push @$tablerows, [$role, 1, 1], @$genomeroles; |
| 186 : | redwards | 1.4 | push @$toadd, @$tablerows; |
| 187 : | undef $first; | ||
| 188 : | redwards | 1.3 | } |
| 189 : | else { | ||
| 190 : | redwards | 1.4 | my @tr=([$role, 1, 1], @$genomeroles); |
| 191 : | redwards | 1.7 | push @$toadd, @tr; |
| 192 : | redwards | 1.3 | } |
| 193 : | redwards | 1.1 | } |
| 194 : | } | ||
| 195 : | redwards | 1.5 | |
| 196 : | unless ($toadd) { | ||
| 197 : | push @$toadd, @$tablerows; | ||
| 198 : | } # in case we didn't define it | ||
| 199 : | |||
| 200 : | |||
| 201 : | redwards | 1.3 | # now decide if we want the table |
| 202 : | if ($cgi->param('orgpegs')) { | ||
| 203 : | my $mustadd; | ||
| 204 : | foreach my $org (@wants) {if ($pegcount->{$org}) {$mustadd=1}} # we'll add it if one of the orgs has a role | ||
| 205 : | redwards | 1.7 | if ($mustadd) {push @$table, $toadd} |
| 206 : | redwards | 1.3 | } |
| 207 : | elsif ($cgi->param("haveroles")) { | ||
| 208 : | redwards | 1.7 | if (scalar(@roles)) {push @$table, $toadd} |
| 209 : | redwards | 1.3 | } |
| 210 : | else { | ||
| 211 : | redwards | 1.7 | push @$table, $toadd; |
| 212 : | redwards | 1.3 | } |
| 213 : | } | ||
| 214 : | |||
| 215 : | # now convert $table into a table | ||
| 216 : | redwards | 1.4 | |
| 217 : | # sort the table | ||
| 218 : | # if we have levels we want to sort on level 1 and then level 2 and then subsysname | ||
| 219 : | # if not, we just sort on subsys name | ||
| 220 : | if ($cgi->param("levels")) { | ||
| 221 : | @$table = sort { | ||
| 222 : | $a->[0]->[0] cmp $b->[0]->[0] | ||
| 223 : | || | ||
| 224 : | $a->[1]->[0] cmp $b->[1]->[0] | ||
| 225 : | || | ||
| 226 : | $a->[2]->[0] cmp $b->[2]->[0] | ||
| 227 : | } @$table; | ||
| 228 : | } | ||
| 229 : | else { | ||
| 230 : | @$table = sort { | ||
| 231 : | $a->[0]->[0] cmp $b->[0]->[0] | ||
| 232 : | } @$table; | ||
| 233 : | } | ||
| 234 : | |||
| 235 : | |||
| 236 : | redwards | 1.3 | my $tab; |
| 237 : | foreach my $row (@$table) { | ||
| 238 : | $tab .= "\n<tr>"; | ||
| 239 : | foreach my $cell (@$row) { | ||
| 240 : | redwards | 1.4 | unless (ref($cell) eq "ARRAY") { |
| 241 : | print STDERR "Didn't work. This is what we have for the row: ", join "\n", @$row, "\n"; | ||
| 242 : | exit(-1); | ||
| 243 : | } | ||
| 244 : | redwards | 1.5 | my $width=''; |
| 245 : | redwards | 1.6 | if ($cell->[3]) {$width="width=" . $cell->[3]} |
| 246 : | redwards | 1.5 | $tab .= "\n\t<td valign=top $width colspan=$cell->[1] rowspan=$cell->[2]>$cell->[0]</td>"; |
| 247 : | redwards | 1.3 | } |
| 248 : | $tab .= "\n</tr>\n"; | ||
| 249 : | redwards | 1.1 | } |
| 250 : | redwards | 1.3 | |
| 251 : | push @$html, ("\n<table border=1>" . $tableheader . $tab . "</table>\n"); | ||
| 252 : | redwards | 1.1 | } |
| 253 : | |||
| 254 : | |||
| 255 : | |||
| 256 : | |||
| 257 : | |||
| 258 : | |||
| 259 : | |||
| 260 : | |||
| 261 : | |||
| 262 : | |||
| 263 : | sub show_initial { | ||
| 264 : | ############# | ||
| 265 : | # | ||
| 266 : | # Stolen from index.cgi | ||
| 267 : | # | ||
| 268 : | # | ||
| 269 : | |||
| 270 : | my @display = ( 'All', 'Archaea', 'Bacteria', 'Eucarya', 'Viruses', 'Environmental samples' ); | ||
| 271 : | |||
| 272 : | # | ||
| 273 : | # Canonical names must match the keywords used in the DBMS. They are | ||
| 274 : | # defined in compute_genome_counts.pl | ||
| 275 : | # | ||
| 276 : | my %canonical = ( | ||
| 277 : | 'All' => undef, | ||
| 278 : | 'Archaea' => 'Archaea', | ||
| 279 : | 'Bacteria' => 'Bacteria', | ||
| 280 : | 'Eucarya' => 'Eukaryota', | ||
| 281 : | 'Viruses' => 'Virus', | ||
| 282 : | 'Environmental samples' => 'Environmental Sample' | ||
| 283 : | ); | ||
| 284 : | |||
| 285 : | my $req_dom = $cgi->param( 'domain' ) || 'All'; | ||
| 286 : | my @domains = $cgi->radio_group( -name => 'domain', | ||
| 287 : | -default => $req_dom, | ||
| 288 : | -override => 1, | ||
| 289 : | -values => [ @display ] | ||
| 290 : | ); | ||
| 291 : | |||
| 292 : | my $n_domain = 0; | ||
| 293 : | my %dom_num = map { ( $_, $n_domain++ ) } @display; | ||
| 294 : | my $req_dom_num = $dom_num{ $req_dom } || 0; | ||
| 295 : | |||
| 296 : | # | ||
| 297 : | # Viruses and Environmental samples must have completeness = All (that is | ||
| 298 : | # how they are in the database). Otherwise, default is Only "complete". | ||
| 299 : | # | ||
| 300 : | my $req_comp = ( $req_dom_num > $dom_num{ 'Eucarya' } ) ? 'All' | ||
| 301 : | : $cgi->param( 'complete' ) || 'Only "complete"'; | ||
| 302 : | my @complete = $cgi->radio_group( -name => 'complete', | ||
| 303 : | -default => $req_comp, | ||
| 304 : | -override => 1, | ||
| 305 : | -values => [ 'All', 'Only "complete"' ] | ||
| 306 : | ); | ||
| 307 : | # | ||
| 308 : | # Use $fig->genomes( complete, restricted, domain ) to get org list: | ||
| 309 : | # | ||
| 310 : | my $complete = ( $req_comp =~ /^all$/i ) ? undef : "complete"; | ||
| 311 : | |||
| 312 : | my @orgs = sort map { my $org = $_; my $gs = $fig->genus_species($org); my $gc=scalar $fig->all_contigs($org); "$gs ($org) [$gc contigs]" } | ||
| 313 : | $fig->genomes( $complete, undef, $canonical{ $req_dom } ); | ||
| 314 : | |||
| 315 : | my $n_genomes = @orgs; | ||
| 316 : | |||
| 317 : | push @$html, $cgi->start_form, | ||
| 318 : | $cgi->h2("Please choose one or more organisms from the list below to see in the subsystems table"), | ||
| 319 : | "<TABLE>\n", | ||
| 320 : | " <TR>\n", | ||
| 321 : | " <TD>", | ||
| 322 : | $cgi->scrolling_list( -name => 'korgs', | ||
| 323 : | -size => 10, | ||
| 324 : | -multiple => 1, | ||
| 325 : | -values => \@orgs, | ||
| 326 : | ), | ||
| 327 : | $cgi->br, | ||
| 328 : | "$n_genomes genomes shown ", | ||
| 329 : | $cgi->submit( 'Update List' ), $cgi->reset, $cgi->submit('submit', 'Summarize Subsystems'), | ||
| 330 : | "</TD>", | ||
| 331 : | " <TD>", | ||
| 332 : | join( "<br>", "<b>Domain(s) to show:</b>", @domains), "<br>\n", | ||
| 333 : | join( "<br>", "<b>Completeness?</b>", @complete), "\n", | ||
| 334 : | "</TD>", | ||
| 335 : | " </TR>\n", | ||
| 336 : | "</TABLE>\n", | ||
| 337 : | $cgi->p, | ||
| 338 : | redwards | 1.2 | $cgi->checkbox(-name=>"stats", -label=>"Only show statistics", -checked=>'on'), $cgi->p, |
| 339 : | redwards | 1.1 | $cgi->checkbox(-name=>"levels", -label=>"Show subsystem classification", -checked=>'on'), $cgi->p, |
| 340 : | $cgi->checkbox(-name=>"genomes", -label=>"Show genomes in subsystem", -checked=>'on'), $cgi->p, | ||
| 341 : | redwards | 1.4 | $cgi->checkbox(-name=>"haveroles", -label=>"Show only subsystems that have roles defined"), $cgi->p, |
| 342 : | $cgi->checkbox(-name=>"orgpegs", -label=>"Show only subsystems that have roles in the organism(s) you have chosen"), $cgi->p, | ||
| 343 : | redwards | 1.3 | |
| 344 : | redwards | 1.1 | $cgi->end_form, |
| 345 : | |||
| 346 : | } |
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |