Parent Directory
| 
Revision Log
Revision 1.15 - (view) (download) (as text)
| 1 : | mkubal | 1.1 | package Observation; |
| 2 : | |||
| 3 : | require Exporter; | ||
| 4 : | @EXPORT_OK = qw(get_objects); | ||
| 5 : | |||
| 6 : | use strict; | ||
| 7 : | use warnings; | ||
| 8 : | arodri7 | 1.9 | use HTML; |
| 9 : | mkubal | 1.1 | |
| 10 : | 1; | ||
| 11 : | |||
| 12 : | arodri7 | 1.15 | # $Id: Observation.pm,v 1.14 2007/06/25 16:34:30 mkubal Exp $ |
| 13 : | mkubal | 1.1 | |
| 14 : | =head1 NAME | ||
| 15 : | |||
| 16 : | Observation -- A presentation layer for observations in SEED. | ||
| 17 : | |||
| 18 : | =head1 DESCRIPTION | ||
| 19 : | |||
| 20 : | The SEED environment contains various sources of information for sequence features. The purpose of this library is to provide a | ||
| 21 : | single interface to this data. | ||
| 22 : | |||
| 23 : | The data can be used to display information for a given sequence feature (protein or other, but primarily information is computed for proteins). | ||
| 24 : | |||
| 25 : | Example: | ||
| 26 : | |||
| 27 : | arodri7 | 1.9 | |
| 28 : | mkubal | 1.1 | use FIG; |
| 29 : | use Observation; | ||
| 30 : | |||
| 31 : | paczian | 1.2 | my $fig = new FIG; |
| 32 : | my $fid = "fig|83333.1.peg.3"; | ||
| 33 : | |||
| 34 : | my $observations = Observation::get_objects($fid); | ||
| 35 : | foreach my $observation (@$observations) { | ||
| 36 : | print "ID: " . $fid . "\n"; | ||
| 37 : | print "Start: " . $observation->start() . "\n"; | ||
| 38 : | ... | ||
| 39 : | } | ||
| 40 : | mkubal | 1.1 | |
| 41 : | B<return an array of objects> | ||
| 42 : | |||
| 43 : | |||
| 44 : | print "$Observation->acc\n" prints the Accession number if present for the Observation | ||
| 45 : | |||
| 46 : | =cut | ||
| 47 : | |||
| 48 : | =head1 BACKGROUND | ||
| 49 : | |||
| 50 : | =head2 Data incorporated in the Observations | ||
| 51 : | |||
| 52 : | As the goal of this library is to provide an integrated view, we combine diverse sources of evidence. | ||
| 53 : | |||
| 54 : | =head3 SEED core evidence | ||
| 55 : | |||
| 56 : | The core SEED data structures provided by FIG.pm. These are Similarities, BBHs and PCHs. | ||
| 57 : | |||
| 58 : | =head3 Attribute based Evidence | ||
| 59 : | |||
| 60 : | We use the SEED attribute infrastructure to store information computed by a variety of computational procedures. | ||
| 61 : | |||
| 62 : | These are e.g. InterPro hits via InterProScan (ipr), NCBI Conserved Domain Database Hits via PSSM(cdd), | ||
| 63 : | PFAM hits via HMM(pfam), SignalP results(signalp), and various others. | ||
| 64 : | |||
| 65 : | =head1 METHODS | ||
| 66 : | |||
| 67 : | The public methods this package provides are listed below: | ||
| 68 : | |||
| 69 : | =head3 acc() | ||
| 70 : | |||
| 71 : | A valid accession or remote ID (in the style of a db_xref) or a valid local ID (FID) in case this is supported. | ||
| 72 : | |||
| 73 : | =cut | ||
| 74 : | |||
| 75 : | sub acc { | ||
| 76 : | my ($self) = @_; | ||
| 77 : | |||
| 78 : | return $self->{acc}; | ||
| 79 : | } | ||
| 80 : | |||
| 81 : | =head3 description() | ||
| 82 : | |||
| 83 : | The description of the hit. Taken from the data or from the our Ontology database for some cases e.g. IPR or PFAM. | ||
| 84 : | |||
| 85 : | B<Please note:> | ||
| 86 : | Either remoteid or description is required. | ||
| 87 : | |||
| 88 : | =cut | ||
| 89 : | |||
| 90 : | sub description { | ||
| 91 : | my ($self) = @_; | ||
| 92 : | |||
| 93 : | arodri7 | 1.5 | return $self->{description}; |
| 94 : | mkubal | 1.1 | } |
| 95 : | |||
| 96 : | =head3 class() | ||
| 97 : | |||
| 98 : | The class of evidence (required). This is usually simply the name of the tool or the name of the SEED data structure. | ||
| 99 : | B<Please note> the connection of class and display_method and URL. | ||
| 100 : | mkubal | 1.7 | |
| 101 : | mkubal | 1.1 | Current valid classes are: |
| 102 : | |||
| 103 : | =over 9 | ||
| 104 : | |||
| 105 : | arodri7 | 1.9 | =item IDENTICAL (seq) |
| 106 : | |||
| 107 : | mkubal | 1.3 | =item SIM (seq) |
| 108 : | mkubal | 1.1 | |
| 109 : | mkubal | 1.3 | =item BBH (seq) |
| 110 : | mkubal | 1.1 | |
| 111 : | mkubal | 1.3 | =item PCH (fc) |
| 112 : | mkubal | 1.1 | |
| 113 : | mkubal | 1.3 | =item FIGFAM (seq) |
| 114 : | mkubal | 1.1 | |
| 115 : | mkubal | 1.3 | =item IPR (dom) |
| 116 : | mkubal | 1.1 | |
| 117 : | mkubal | 1.3 | =item CDD (dom) |
| 118 : | mkubal | 1.1 | |
| 119 : | mkubal | 1.3 | =item PFAM (dom) |
| 120 : | mkubal | 1.1 | |
| 121 : | mkubal | 1.12 | =item SIGNALP_CELLO_TMPRED (loc) |
| 122 : | mkubal | 1.1 | |
| 123 : | mkubal | 1.3 | =item TMHMM (loc) |
| 124 : | mkubal | 1.1 | |
| 125 : | mkubal | 1.3 | =item HMMTOP (loc) |
| 126 : | mkubal | 1.1 | |
| 127 : | =back | ||
| 128 : | |||
| 129 : | =cut | ||
| 130 : | |||
| 131 : | sub class { | ||
| 132 : | my ($self) = @_; | ||
| 133 : | |||
| 134 : | return $self->{class}; | ||
| 135 : | } | ||
| 136 : | |||
| 137 : | =head3 type() | ||
| 138 : | |||
| 139 : | The type of evidence (required). | ||
| 140 : | |||
| 141 : | Where type is one of the following: | ||
| 142 : | |||
| 143 : | =over 8 | ||
| 144 : | |||
| 145 : | =item seq=Sequence similarity | ||
| 146 : | |||
| 147 : | =item dom=domain based match | ||
| 148 : | |||
| 149 : | =item loc=Localization of the feature | ||
| 150 : | |||
| 151 : | =item fc=Functional coupling. | ||
| 152 : | |||
| 153 : | =back | ||
| 154 : | |||
| 155 : | =cut | ||
| 156 : | |||
| 157 : | sub type { | ||
| 158 : | my ($self) = @_; | ||
| 159 : | |||
| 160 : | return $self->{acc}; | ||
| 161 : | } | ||
| 162 : | |||
| 163 : | =head3 start() | ||
| 164 : | |||
| 165 : | Start of hit in query sequence. | ||
| 166 : | |||
| 167 : | =cut | ||
| 168 : | |||
| 169 : | sub start { | ||
| 170 : | my ($self) = @_; | ||
| 171 : | |||
| 172 : | return $self->{start}; | ||
| 173 : | } | ||
| 174 : | |||
| 175 : | =head3 end() | ||
| 176 : | |||
| 177 : | End of the hit in query sequence. | ||
| 178 : | |||
| 179 : | =cut | ||
| 180 : | |||
| 181 : | sub stop { | ||
| 182 : | my ($self) = @_; | ||
| 183 : | |||
| 184 : | return $self->{stop}; | ||
| 185 : | } | ||
| 186 : | |||
| 187 : | arodri7 | 1.11 | =head3 start() |
| 188 : | |||
| 189 : | Start of hit in query sequence. | ||
| 190 : | |||
| 191 : | =cut | ||
| 192 : | |||
| 193 : | sub qstart { | ||
| 194 : | my ($self) = @_; | ||
| 195 : | |||
| 196 : | return $self->{qstart}; | ||
| 197 : | } | ||
| 198 : | |||
| 199 : | =head3 qstop() | ||
| 200 : | |||
| 201 : | End of the hit in query sequence. | ||
| 202 : | |||
| 203 : | =cut | ||
| 204 : | |||
| 205 : | sub qstop { | ||
| 206 : | my ($self) = @_; | ||
| 207 : | |||
| 208 : | return $self->{qstop}; | ||
| 209 : | } | ||
| 210 : | |||
| 211 : | =head3 hstart() | ||
| 212 : | |||
| 213 : | Start of hit in hit sequence. | ||
| 214 : | |||
| 215 : | =cut | ||
| 216 : | |||
| 217 : | sub hstart { | ||
| 218 : | my ($self) = @_; | ||
| 219 : | |||
| 220 : | return $self->{hstart}; | ||
| 221 : | } | ||
| 222 : | |||
| 223 : | =head3 end() | ||
| 224 : | |||
| 225 : | End of the hit in hit sequence. | ||
| 226 : | |||
| 227 : | =cut | ||
| 228 : | |||
| 229 : | sub hstop { | ||
| 230 : | my ($self) = @_; | ||
| 231 : | |||
| 232 : | return $self->{hstop}; | ||
| 233 : | } | ||
| 234 : | |||
| 235 : | =head3 qlength() | ||
| 236 : | |||
| 237 : | length of the query sequence in similarities | ||
| 238 : | |||
| 239 : | =cut | ||
| 240 : | |||
| 241 : | sub qlength { | ||
| 242 : | my ($self) = @_; | ||
| 243 : | |||
| 244 : | return $self->{qlength}; | ||
| 245 : | } | ||
| 246 : | |||
| 247 : | =head3 hlength() | ||
| 248 : | |||
| 249 : | length of the hit sequence in similarities | ||
| 250 : | |||
| 251 : | =cut | ||
| 252 : | |||
| 253 : | sub hlength { | ||
| 254 : | my ($self) = @_; | ||
| 255 : | |||
| 256 : | return $self->{hlength}; | ||
| 257 : | } | ||
| 258 : | |||
| 259 : | |||
| 260 : | |||
| 261 : | mkubal | 1.1 | =head3 evalue() |
| 262 : | |||
| 263 : | E-value or P-Value if present. | ||
| 264 : | |||
| 265 : | =cut | ||
| 266 : | |||
| 267 : | sub evalue { | ||
| 268 : | my ($self) = @_; | ||
| 269 : | |||
| 270 : | return $self->{evalue}; | ||
| 271 : | } | ||
| 272 : | |||
| 273 : | =head3 score() | ||
| 274 : | |||
| 275 : | Score if present. | ||
| 276 : | |||
| 277 : | B<Please note: > | ||
| 278 : | Either score or eval are required. | ||
| 279 : | |||
| 280 : | =cut | ||
| 281 : | |||
| 282 : | sub score { | ||
| 283 : | my ($self) = @_; | ||
| 284 : | return $self->{score}; | ||
| 285 : | } | ||
| 286 : | |||
| 287 : | |||
| 288 : | mkubal | 1.12 | =head3 display() |
| 289 : | mkubal | 1.1 | |
| 290 : | mkubal | 1.12 | will be different for each type |
| 291 : | mkubal | 1.1 | |
| 292 : | =cut | ||
| 293 : | |||
| 294 : | mkubal | 1.7 | sub display { |
| 295 : | mkubal | 1.1 | |
| 296 : | mkubal | 1.7 | die "Abstract Method Called\n"; |
| 297 : | mkubal | 1.1 | |
| 298 : | } | ||
| 299 : | |||
| 300 : | mkubal | 1.7 | |
| 301 : | mkubal | 1.1 | =head3 rank() |
| 302 : | |||
| 303 : | Returns an integer from 1 - 10 indicating the importance of this observations. | ||
| 304 : | |||
| 305 : | Currently always returns 1. | ||
| 306 : | |||
| 307 : | =cut | ||
| 308 : | |||
| 309 : | sub rank { | ||
| 310 : | my ($self) = @_; | ||
| 311 : | |||
| 312 : | # return $self->{rank}; | ||
| 313 : | |||
| 314 : | return 1; | ||
| 315 : | } | ||
| 316 : | |||
| 317 : | =head3 supports_annotation() | ||
| 318 : | |||
| 319 : | Does a this observation support the annotation of its feature? | ||
| 320 : | |||
| 321 : | Returns | ||
| 322 : | |||
| 323 : | =over 3 | ||
| 324 : | |||
| 325 : | =item 10, if feature annotation is identical to $self->description | ||
| 326 : | |||
| 327 : | =item 1, Feature annotation is similar to $self->annotation; this is computed using FIG::SameFunc() | ||
| 328 : | |||
| 329 : | =item undef | ||
| 330 : | |||
| 331 : | =back | ||
| 332 : | |||
| 333 : | =cut | ||
| 334 : | |||
| 335 : | sub supports_annotation { | ||
| 336 : | my ($self) = @_; | ||
| 337 : | |||
| 338 : | # no code here so far | ||
| 339 : | |||
| 340 : | return $self->{supports_annotation}; | ||
| 341 : | } | ||
| 342 : | |||
| 343 : | =head3 url() | ||
| 344 : | |||
| 345 : | URL describing the subject. In case of a BLAST hit against a sequence, this URL will lead to a page displaying the sequence record for the sequence. In case of an HMM hit, the URL will be to the URL description. | ||
| 346 : | |||
| 347 : | =cut | ||
| 348 : | |||
| 349 : | sub url { | ||
| 350 : | my ($self) = @_; | ||
| 351 : | |||
| 352 : | my $url = get_url($self->type, $self->acc); | ||
| 353 : | |||
| 354 : | return $url; | ||
| 355 : | } | ||
| 356 : | |||
| 357 : | =head3 get_objects() | ||
| 358 : | |||
| 359 : | This is the B<REAL WORKHORSE> method of this Package. | ||
| 360 : | |||
| 361 : | It will probably have to: | ||
| 362 : | |||
| 363 : | - get all sims for the feature | ||
| 364 : | - get all bbhs for the feature | ||
| 365 : | - copy information from sim to bbh (bbh have no match location etc) | ||
| 366 : | - get pchs (difficult) | ||
| 367 : | - get attributes (there is code for this that in get_attribute_based_observations | ||
| 368 : | - get_attributes_based_observations returns an array of arrays of hashes like this" | ||
| 369 : | |||
| 370 : | mkubal | 1.7 | my $dataset |
| 371 : | mkubal | 1.1 | [ |
| 372 : | [ { name => 'acc', value => '1234' }, | ||
| 373 : | { name => 'from', value => '4' }, | ||
| 374 : | { name => 'to', value => '400' }, | ||
| 375 : | .... | ||
| 376 : | ], | ||
| 377 : | [ { name => 'acc', value => '456' }, | ||
| 378 : | { name => 'from', value => '1' }, | ||
| 379 : | { name => 'to', value => '100' }, | ||
| 380 : | .... | ||
| 381 : | ], | ||
| 382 : | ... | ||
| 383 : | ]; | ||
| 384 : | return $datasets; | ||
| 385 : | } | ||
| 386 : | |||
| 387 : | It will invoke the required calls to the SEED API to retrieve the information required. | ||
| 388 : | |||
| 389 : | =cut | ||
| 390 : | |||
| 391 : | sub get_objects { | ||
| 392 : | mkubal | 1.7 | my ($self,$fid,$classes) = @_; |
| 393 : | |||
| 394 : | |||
| 395 : | my $objects = []; | ||
| 396 : | my @matched_datasets=(); | ||
| 397 : | mkubal | 1.1 | |
| 398 : | mkubal | 1.7 | # call function that fetches attribute based observations |
| 399 : | # returns an array of arrays of hashes | ||
| 400 : | |||
| 401 : | if(scalar(@$classes) < 1){ | ||
| 402 : | get_attribute_based_observations($fid,\@matched_datasets); | ||
| 403 : | get_sims_observations($fid,\@matched_datasets); | ||
| 404 : | get_identical_proteins($fid,\@matched_datasets); | ||
| 405 : | get_functional_coupling($fid,\@matched_datasets); | ||
| 406 : | } | ||
| 407 : | else{ | ||
| 408 : | my %domain_classes; | ||
| 409 : | arodri7 | 1.9 | my $identical_flag=0; |
| 410 : | my $pch_flag=0; | ||
| 411 : | mkubal | 1.12 | my $location_flag = 0; |
| 412 : | arodri7 | 1.10 | my $sims_flag=0; |
| 413 : | arodri7 | 1.15 | my $cluster_flag = 0; |
| 414 : | mkubal | 1.7 | foreach my $class (@$classes){ |
| 415 : | arodri7 | 1.9 | if($class =~ /(IPR|CDD|PFAM)/){ |
| 416 : | mkubal | 1.7 | $domain_classes{$class} = 1; |
| 417 : | arodri7 | 1.9 | } |
| 418 : | elsif ($class eq "IDENTICAL") | ||
| 419 : | { | ||
| 420 : | $identical_flag = 1; | ||
| 421 : | } | ||
| 422 : | elsif ($class eq "PCH") | ||
| 423 : | { | ||
| 424 : | $pch_flag = 1; | ||
| 425 : | mkubal | 1.7 | } |
| 426 : | mkubal | 1.12 | elsif ($class =~/(SIGNALP_CELLO_TMPRED)/) |
| 427 : | { | ||
| 428 : | $location_flag = 1; | ||
| 429 : | } | ||
| 430 : | arodri7 | 1.10 | elsif ($class eq "SIM") |
| 431 : | { | ||
| 432 : | $sims_flag = 1; | ||
| 433 : | } | ||
| 434 : | arodri7 | 1.15 | elsif ($class eq "CLUSTER") |
| 435 : | { | ||
| 436 : | $cluster_flag = 1; | ||
| 437 : | } | ||
| 438 : | mkubal | 1.7 | } |
| 439 : | arodri7 | 1.9 | |
| 440 : | if ($identical_flag ==1) | ||
| 441 : | { | ||
| 442 : | get_identical_proteins($fid,\@matched_datasets); | ||
| 443 : | } | ||
| 444 : | if ( (defined($domain_classes{IPR})) || (defined($domain_classes{CDD})) || (defined($domain_classes{PFAM})) ) { | ||
| 445 : | get_attribute_based_domain_observations($fid,\%domain_classes,\@matched_datasets); | ||
| 446 : | } | ||
| 447 : | if ($pch_flag == 1) | ||
| 448 : | { | ||
| 449 : | get_functional_coupling($fid,\@matched_datasets); | ||
| 450 : | } | ||
| 451 : | arodri7 | 1.10 | if ($sims_flag == 1) |
| 452 : | { | ||
| 453 : | get_sims_observations($fid,\@matched_datasets); | ||
| 454 : | } | ||
| 455 : | arodri7 | 1.5 | |
| 456 : | mkubal | 1.12 | if ($location_flag == 1) |
| 457 : | { | ||
| 458 : | get_attribute_based_location_observations($fid,\@matched_datasets); | ||
| 459 : | } | ||
| 460 : | arodri7 | 1.15 | if ($cluster_flag == 1) |
| 461 : | { | ||
| 462 : | get_cluster_observations($fid,\@matched_datasets); | ||
| 463 : | } | ||
| 464 : | mkubal | 1.12 | |
| 465 : | mkubal | 1.1 | } |
| 466 : | mkubal | 1.7 | |
| 467 : | foreach my $dataset (@matched_datasets) { | ||
| 468 : | my $object; | ||
| 469 : | if($dataset->{'type'} eq "dom"){ | ||
| 470 : | $object = Observation::Domain->new($dataset); | ||
| 471 : | } | ||
| 472 : | arodri7 | 1.9 | if($dataset->{'class'} eq "PCH"){ |
| 473 : | $object = Observation::FC->new($dataset); | ||
| 474 : | } | ||
| 475 : | if ($dataset->{'class'} eq "IDENTICAL"){ | ||
| 476 : | $object = Observation::Identical->new($dataset); | ||
| 477 : | } | ||
| 478 : | mkubal | 1.12 | if ($dataset->{'class'} eq "SIGNALP_CELLO_TMPRED"){ |
| 479 : | $object = Observation::Location->new($dataset); | ||
| 480 : | } | ||
| 481 : | arodri7 | 1.10 | if ($dataset->{'class'} eq "SIM"){ |
| 482 : | $object = Observation::Sims->new($dataset); | ||
| 483 : | } | ||
| 484 : | arodri7 | 1.15 | if ($dataset->{'class'} eq "CLUSTER"){ |
| 485 : | $object = Observation::Cluster->new($dataset); | ||
| 486 : | } | ||
| 487 : | mkubal | 1.7 | push (@$objects, $object); |
| 488 : | mkubal | 1.1 | } |
| 489 : | mkubal | 1.7 | |
| 490 : | return $objects; | ||
| 491 : | mkubal | 1.1 | |
| 492 : | } | ||
| 493 : | |||
| 494 : | =head1 Internal Methods | ||
| 495 : | |||
| 496 : | These methods are not meant to be used outside of this package. | ||
| 497 : | |||
| 498 : | B<Please do not use them outside of this package!> | ||
| 499 : | |||
| 500 : | =cut | ||
| 501 : | |||
| 502 : | |||
| 503 : | =head3 get_url (internal) | ||
| 504 : | |||
| 505 : | get_url() return a valid URL or undef for any observation. | ||
| 506 : | |||
| 507 : | URLs are constructed by looking at the Accession acc() and name() | ||
| 508 : | |||
| 509 : | Info from both attributes is combined with a table of base URLs stored in this function. | ||
| 510 : | |||
| 511 : | =cut | ||
| 512 : | |||
| 513 : | sub get_url { | ||
| 514 : | |||
| 515 : | my ($self) = @_; | ||
| 516 : | my $url=''; | ||
| 517 : | |||
| 518 : | # a hash with a URL for each observation; identified by name() | ||
| 519 : | #my $URL => { 'PFAM' => "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?" ,\ | ||
| 520 : | # 'IPR' => "http://www.ebi.ac.uk/interpro/DisplayIproEntry?ac=" ,\ | ||
| 521 : | # 'CDD' => "http://www.ncbi.nlm.nih.gov/Structure/cdd/cddsrv.cgi?uid=",\ | ||
| 522 : | # 'PIR' => "http://www.ncbi.nlm.nih.gov/Structure/cdd/cddsrv.cgi?uid=",\ | ||
| 523 : | # 'FIGFAM' => '',\ | ||
| 524 : | # 'sim'=> "http://www.theseed.org/linkin.cgi?id=",\ | ||
| 525 : | # 'bbh'=> "http://www.theseed.org/linkin.cgi?id=" | ||
| 526 : | #}; | ||
| 527 : | |||
| 528 : | # if (defined $URL{$self->name}) { | ||
| 529 : | # $url = $URL{$self->name}.$self->acc; | ||
| 530 : | # return $url; | ||
| 531 : | # } | ||
| 532 : | # else | ||
| 533 : | return undef; | ||
| 534 : | } | ||
| 535 : | |||
| 536 : | =head3 get_display_method (internal) | ||
| 537 : | |||
| 538 : | get_display_method() return a valid URL or undef for any observation. | ||
| 539 : | |||
| 540 : | URLs are constructed by looking at the Accession acc() and name() | ||
| 541 : | and Info from both attributes is combined with a table of base URLs stored in this function. | ||
| 542 : | |||
| 543 : | =cut | ||
| 544 : | |||
| 545 : | sub get_display_method { | ||
| 546 : | |||
| 547 : | my ($self) = @_; | ||
| 548 : | |||
| 549 : | # a hash with a URL for each observation; identified by name() | ||
| 550 : | #my $URL => { 'sim'=> "http://www.theseed.org/featalign.cgi?id1=",\ | ||
| 551 : | # 'bbh'=> "http://www.theseed.org/featalign.cgi?id1=" | ||
| 552 : | # }; | ||
| 553 : | |||
| 554 : | #if (defined $URL{$self->name}) { | ||
| 555 : | # $url = $URL{$self->name}.$self->feature_id."&id2=".$self->acc; | ||
| 556 : | # return $url; | ||
| 557 : | # } | ||
| 558 : | # else | ||
| 559 : | return undef; | ||
| 560 : | } | ||
| 561 : | |||
| 562 : | mkubal | 1.7 | |
| 563 : | sub get_attribute_based_domain_observations{ | ||
| 564 : | |||
| 565 : | # we read a FIG ID and a reference to an array (of arrays of hashes, see above) | ||
| 566 : | my ($fid,$domain_classes,$datasets_ref) = (@_); | ||
| 567 : | |||
| 568 : | my $fig = new FIG; | ||
| 569 : | |||
| 570 : | foreach my $attr_ref ($fig->get_attributes($fid)) { | ||
| 571 : | my $key = @$attr_ref[1]; | ||
| 572 : | my @parts = split("::",$key); | ||
| 573 : | my $class = $parts[0]; | ||
| 574 : | |||
| 575 : | if($domain_classes->{$parts[0]}){ | ||
| 576 : | my $val = @$attr_ref[2]; | ||
| 577 : | mkubal | 1.8 | if($val =~/^(\d+\.\d+|0\.0);(\d+)-(\d+)/){ |
| 578 : | mkubal | 1.7 | my $raw_evalue = $1; |
| 579 : | mkubal | 1.8 | my $from = $2; |
| 580 : | my $to = $3; | ||
| 581 : | mkubal | 1.7 | my $evalue; |
| 582 : | if($raw_evalue =~/(\d+)\.(\d+)/){ | ||
| 583 : | my $part2 = 1000 - $1; | ||
| 584 : | my $part1 = $2/100; | ||
| 585 : | $evalue = $part1."e-".$part2; | ||
| 586 : | } | ||
| 587 : | else{ | ||
| 588 : | mkubal | 1.8 | $evalue = "0.0"; |
| 589 : | mkubal | 1.7 | } |
| 590 : | |||
| 591 : | my $dataset = {'class' => $class, | ||
| 592 : | 'acc' => $key, | ||
| 593 : | 'type' => "dom" , | ||
| 594 : | 'evalue' => $evalue, | ||
| 595 : | 'start' => $from, | ||
| 596 : | 'stop' => $to | ||
| 597 : | }; | ||
| 598 : | |||
| 599 : | push (@{$datasets_ref} ,$dataset); | ||
| 600 : | } | ||
| 601 : | } | ||
| 602 : | } | ||
| 603 : | } | ||
| 604 : | mkubal | 1.12 | |
| 605 : | sub get_attribute_based_location_observations{ | ||
| 606 : | |||
| 607 : | my ($fid,$datasets_ref) = (@_); | ||
| 608 : | my $fig = new FIG; | ||
| 609 : | |||
| 610 : | my $location_attributes = ['SignalP','CELLO','TMPRED']; | ||
| 611 : | |||
| 612 : | my $dataset = {'type' => "loc", 'class' => 'SIGNALP_CELLO_TMPRED'}; | ||
| 613 : | foreach my $attr_ref ($fig->get_attributes($fid,$location_attributes)) { | ||
| 614 : | my $key = @$attr_ref[1]; | ||
| 615 : | my @parts = split("::",$key); | ||
| 616 : | my $sub_class = $parts[0]; | ||
| 617 : | my $sub_key = $parts[1]; | ||
| 618 : | my $value = @$attr_ref[2]; | ||
| 619 : | if($sub_class eq "SignalP"){ | ||
| 620 : | if($sub_key eq "cleavage_site"){ | ||
| 621 : | my @value_parts = split(";",$value); | ||
| 622 : | $dataset->{'cleavage_prob'} = $value_parts[0]; | ||
| 623 : | $dataset->{'cleavage_loc'} = $value_parts[1]; | ||
| 624 : | } | ||
| 625 : | elsif($sub_key eq "signal_peptide"){ | ||
| 626 : | $dataset->{'signal_peptide_score'} = $value; | ||
| 627 : | } | ||
| 628 : | } | ||
| 629 : | elsif($sub_class eq "CELLO"){ | ||
| 630 : | $dataset->{'cello_location'} = $sub_key; | ||
| 631 : | $dataset->{'cello_score'} = $value; | ||
| 632 : | } | ||
| 633 : | elsif($sub_class eq "TMPRED"){ | ||
| 634 : | my @value_parts = split(";",$value); | ||
| 635 : | $dataset->{'tmpred_score'} = $value_parts[0]; | ||
| 636 : | $dataset->{'tmpred_locations'} = $value_parts[1]; | ||
| 637 : | } | ||
| 638 : | } | ||
| 639 : | |||
| 640 : | push (@{$datasets_ref} ,$dataset); | ||
| 641 : | |||
| 642 : | } | ||
| 643 : | |||
| 644 : | mkubal | 1.7 | |
| 645 : | mkubal | 1.1 | =head3 get_attribute_based_evidence (internal) |
| 646 : | |||
| 647 : | This method retrieves evidence from the attribute server | ||
| 648 : | |||
| 649 : | =cut | ||
| 650 : | |||
| 651 : | sub get_attribute_based_observations{ | ||
| 652 : | |||
| 653 : | # we read a FIG ID and a reference to an array (of arrays of hashes, see above) | ||
| 654 : | my ($fid,$datasets_ref) = (@_); | ||
| 655 : | |||
| 656 : | my $_myfig = new FIG; | ||
| 657 : | |||
| 658 : | foreach my $attr_ref ($_myfig->get_attributes($fid)) { | ||
| 659 : | |||
| 660 : | # convert the ref into a string for easier handling | ||
| 661 : | my ($string) = "@$attr_ref"; | ||
| 662 : | |||
| 663 : | # print "S:$string\n"; | ||
| 664 : | my ($key,$val) = ( $string =~ /\S+\s(\S+)\s(\S+)/); | ||
| 665 : | |||
| 666 : | # THIS SHOULD BE DONE ANOTHER WAY FM->TD | ||
| 667 : | # we need to do the right thing for each type, ie no evalue for CELLO and no coordinates, but a score, etc | ||
| 668 : | # as fas as possible this should be configured so that the type of observation and the regexp are | ||
| 669 : | # stored somewhere for easy expansion | ||
| 670 : | # | ||
| 671 : | |||
| 672 : | if (($key =~ /PFAM::/) || ( $key =~ /IPR::/) || ( $key =~ /CDD::/) ) { | ||
| 673 : | |||
| 674 : | # some keys are composite CDD::1233244 or PFAM:PF1233 | ||
| 675 : | |||
| 676 : | if ( $key =~ /::/ ) { | ||
| 677 : | my ($firstkey,$restkey) = ( $key =~ /([a-zA-Z0-9]+)::(.*)/); | ||
| 678 : | $val=$restkey.";".$val; | ||
| 679 : | $key=$firstkey; | ||
| 680 : | } | ||
| 681 : | |||
| 682 : | my ($acc,$raw_evalue, $from,$to) = ($val =~ /(\S+);(\S+);(\d+)-(\d+)/ ); | ||
| 683 : | |||
| 684 : | my $evalue= 255; | ||
| 685 : | if (defined $raw_evalue) { # some of the tool do not give us an evalue | ||
| 686 : | |||
| 687 : | my ($k,$expo) = ( $raw_evalue =~ /(\d+).(\d+)/); | ||
| 688 : | my ($new_k, $new_exp); | ||
| 689 : | |||
| 690 : | # | ||
| 691 : | # THIS DOES NOT WORK PROPERLY | ||
| 692 : | # | ||
| 693 : | if($raw_evalue =~/(\d+).(\d+)/){ | ||
| 694 : | |||
| 695 : | # $new_exp = (1000+$expo); | ||
| 696 : | # $new_k = $k / 100; | ||
| 697 : | |||
| 698 : | } | ||
| 699 : | $evalue = "0.01"#new_k."e-".$new_exp; | ||
| 700 : | } | ||
| 701 : | |||
| 702 : | # unroll it all into an array of hashes | ||
| 703 : | # this needs to be done differently for different types of observations | ||
| 704 : | my $dataset = [ { name => 'class', value => $key }, | ||
| 705 : | { name => 'acc' , value => $acc}, | ||
| 706 : | { name => 'type', value => "dom"} , # this clearly needs to be done properly FM->TD | ||
| 707 : | { name => 'evalue', value => $evalue }, | ||
| 708 : | { name => 'start', value => $from}, | ||
| 709 : | { name => 'stop' , value => $to} | ||
| 710 : | ]; | ||
| 711 : | |||
| 712 : | push (@{$datasets_ref} ,$dataset); | ||
| 713 : | } | ||
| 714 : | } | ||
| 715 : | } | ||
| 716 : | |||
| 717 : | arodri7 | 1.15 | =head3 get_cluster_observations() (internal) |
| 718 : | |||
| 719 : | This methods sets the type and class for cluster observations | ||
| 720 : | |||
| 721 : | =cut | ||
| 722 : | |||
| 723 : | sub get_cluster_observations{ | ||
| 724 : | my ($fid,$datasets_ref) = (@_); | ||
| 725 : | |||
| 726 : | $dataset = {'class' => 'CLUSTER', | ||
| 727 : | 'type' => 'fc' | ||
| 728 : | }; | ||
| 729 : | push (@{$datasets_ref} ,$dataset); | ||
| 730 : | } | ||
| 731 : | |||
| 732 : | |||
| 733 : | mkubal | 1.3 | =head3 get_sims_observations() (internal) |
| 734 : | |||
| 735 : | This methods retrieves sims fills the internal data structures. | ||
| 736 : | |||
| 737 : | =cut | ||
| 738 : | |||
| 739 : | sub get_sims_observations{ | ||
| 740 : | |||
| 741 : | my ($fid,$datasets_ref) = (@_); | ||
| 742 : | mkubal | 1.4 | my $fig = new FIG; |
| 743 : | arodri7 | 1.11 | # my @sims= $fig->nsims($fid,100,1e-20,"fig"); |
| 744 : | my @sims= $fig->nsims($fid,100,1e-20,"all"); | ||
| 745 : | mkubal | 1.4 | my ($dataset); |
| 746 : | mkubal | 1.3 | foreach my $sim (@sims){ |
| 747 : | mkubal | 1.4 | my $hit = $sim->[1]; |
| 748 : | arodri7 | 1.11 | my $percent = $sim->[2]; |
| 749 : | mkubal | 1.4 | my $evalue = $sim->[10]; |
| 750 : | arodri7 | 1.11 | my $qfrom = $sim->[6]; |
| 751 : | my $qto = $sim->[7]; | ||
| 752 : | my $hfrom = $sim->[8]; | ||
| 753 : | my $hto = $sim->[9]; | ||
| 754 : | my $qlength = $sim->[12]; | ||
| 755 : | my $hlength = $sim->[13]; | ||
| 756 : | my $db = get_database($hit); | ||
| 757 : | my $func = $fig->function_of($hit); | ||
| 758 : | my $organism = $fig->org_of($hit); | ||
| 759 : | |||
| 760 : | arodri7 | 1.10 | $dataset = {'class' => 'SIM', |
| 761 : | 'acc' => $hit, | ||
| 762 : | arodri7 | 1.11 | 'identity' => $percent, |
| 763 : | arodri7 | 1.10 | 'type' => 'seq', |
| 764 : | 'evalue' => $evalue, | ||
| 765 : | arodri7 | 1.11 | 'qstart' => $qfrom, |
| 766 : | 'qstop' => $qto, | ||
| 767 : | 'hstart' => $hfrom, | ||
| 768 : | 'hstop' => $hto, | ||
| 769 : | 'database' => $db, | ||
| 770 : | 'organism' => $organism, | ||
| 771 : | 'function' => $func, | ||
| 772 : | 'qlength' => $qlength, | ||
| 773 : | 'hlength' => $hlength | ||
| 774 : | arodri7 | 1.10 | }; |
| 775 : | |||
| 776 : | push (@{$datasets_ref} ,$dataset); | ||
| 777 : | mkubal | 1.3 | } |
| 778 : | } | ||
| 779 : | |||
| 780 : | arodri7 | 1.11 | =head3 get_database (internal) |
| 781 : | This method gets the database association from the sequence id | ||
| 782 : | |||
| 783 : | =cut | ||
| 784 : | |||
| 785 : | sub get_database{ | ||
| 786 : | my ($id) = (@_); | ||
| 787 : | |||
| 788 : | my ($db); | ||
| 789 : | if ($id =~ /^fig\|/) { $db = "FIG" } | ||
| 790 : | elsif ($id =~ /^gi\|/) { $db = "NCBI" } | ||
| 791 : | elsif ($id =~ /^^[NXYZA]P_/) { $db = "RefSeq" } | ||
| 792 : | elsif ($id =~ /^sp\|/) { $db = "SwissProt" } | ||
| 793 : | elsif ($id =~ /^uni\|/) { $db = "UniProt" } | ||
| 794 : | elsif ($id =~ /^tigr\|/) { $db = "TIGR" } | ||
| 795 : | elsif ($id =~ /^pir\|/) { $db = "PIR" } | ||
| 796 : | elsif ($id =~ /^kegg\|/) { $db = "KEGG" } | ||
| 797 : | elsif ($id =~ /^tr\|/) { $db = "TrEMBL" } | ||
| 798 : | elsif ($id =~ /^eric\|/) { $db = "ASAP" } | ||
| 799 : | elsif ($id =~ /^img\|/) { $db = "JGI" } | ||
| 800 : | |||
| 801 : | return ($db); | ||
| 802 : | |||
| 803 : | } | ||
| 804 : | |||
| 805 : | arodri7 | 1.5 | =head3 get_identical_proteins() (internal) |
| 806 : | |||
| 807 : | This methods retrieves sims fills the internal data structures. | ||
| 808 : | |||
| 809 : | =cut | ||
| 810 : | |||
| 811 : | sub get_identical_proteins{ | ||
| 812 : | |||
| 813 : | my ($fid,$datasets_ref) = (@_); | ||
| 814 : | my $fig = new FIG; | ||
| 815 : | my @funcs = (); | ||
| 816 : | |||
| 817 : | my @maps_to = grep { $_ ne $fid and $_ !~ /^xxx/ } map { $_->[0] } $fig->mapped_prot_ids($fid); | ||
| 818 : | |||
| 819 : | foreach my $id (@maps_to) { | ||
| 820 : | my ($tmp, $who); | ||
| 821 : | arodri7 | 1.6 | if (($id ne $fid) && ($tmp = $fig->function_of($id))) { |
| 822 : | arodri7 | 1.11 | $who = &get_database($id); |
| 823 : | arodri7 | 1.5 | push(@funcs, [$id,$who,$tmp]); |
| 824 : | } | ||
| 825 : | } | ||
| 826 : | |||
| 827 : | my ($dataset); | ||
| 828 : | foreach my $row (@funcs){ | ||
| 829 : | my $id = $row->[0]; | ||
| 830 : | my $organism = $fig->org_of($fid); | ||
| 831 : | my $who = $row->[1]; | ||
| 832 : | my $assignment = $row->[2]; | ||
| 833 : | arodri7 | 1.9 | |
| 834 : | my $dataset = {'class' => 'IDENTICAL', | ||
| 835 : | 'id' => $id, | ||
| 836 : | 'organism' => $organism, | ||
| 837 : | 'type' => 'seq', | ||
| 838 : | 'database' => $who, | ||
| 839 : | 'function' => $assignment | ||
| 840 : | }; | ||
| 841 : | |||
| 842 : | arodri7 | 1.5 | push (@{$datasets_ref} ,$dataset); |
| 843 : | } | ||
| 844 : | |||
| 845 : | } | ||
| 846 : | |||
| 847 : | arodri7 | 1.6 | =head3 get_functional_coupling() (internal) |
| 848 : | |||
| 849 : | This methods retrieves the functional coupling of a protein given a peg ID | ||
| 850 : | |||
| 851 : | =cut | ||
| 852 : | |||
| 853 : | sub get_functional_coupling{ | ||
| 854 : | |||
| 855 : | my ($fid,$datasets_ref) = (@_); | ||
| 856 : | my $fig = new FIG; | ||
| 857 : | my @funcs = (); | ||
| 858 : | |||
| 859 : | # initialize some variables | ||
| 860 : | my($sc,$neigh); | ||
| 861 : | |||
| 862 : | # set default parameters for coupling and evidence | ||
| 863 : | my ($bound,$sim_cutoff,$coupling_cutoff) = (5000, 1.0e-10, 4); | ||
| 864 : | |||
| 865 : | # get the fc data | ||
| 866 : | my @fc_data = $fig->coupling_and_evidence($fid,$bound,$sim_cutoff,$coupling_cutoff,1); | ||
| 867 : | |||
| 868 : | # retrieve data | ||
| 869 : | my @rows = map { ($sc,$neigh) = @$_; | ||
| 870 : | [$sc,$neigh,scalar $fig->function_of($neigh)] | ||
| 871 : | } @fc_data; | ||
| 872 : | |||
| 873 : | my ($dataset); | ||
| 874 : | foreach my $row (@rows){ | ||
| 875 : | my $id = $row->[1]; | ||
| 876 : | my $score = $row->[0]; | ||
| 877 : | my $description = $row->[2]; | ||
| 878 : | arodri7 | 1.9 | my $dataset = {'class' => 'PCH', |
| 879 : | 'score' => $score, | ||
| 880 : | 'id' => $id, | ||
| 881 : | 'type' => 'fc', | ||
| 882 : | 'function' => $description | ||
| 883 : | }; | ||
| 884 : | |||
| 885 : | arodri7 | 1.6 | push (@{$datasets_ref} ,$dataset); |
| 886 : | } | ||
| 887 : | } | ||
| 888 : | arodri7 | 1.5 | |
| 889 : | mkubal | 1.1 | =head3 get_sims_and_bbhs() (internal) |
| 890 : | |||
| 891 : | This methods retrieves sims and also BBHs and fills the internal data structures. | ||
| 892 : | |||
| 893 : | =cut | ||
| 894 : | |||
| 895 : | # sub get_sims_and_bbhs{ | ||
| 896 : | |||
| 897 : | # # blast m8 output format | ||
| 898 : | # # id1, id2, %ident, align len, mismatches, gaps, q.start, q.stop, s. start, s.stop, eval, bit | ||
| 899 : | |||
| 900 : | # my $Sims=(); | ||
| 901 : | # @sims_src = $fig->sims($fid,80,500,"fig",0); | ||
| 902 : | # print "found $#sims_src SIMs\n"; | ||
| 903 : | # foreach $sims (@sims_src) { | ||
| 904 : | # my ($sims_string) = "@$sims"; | ||
| 905 : | # # print "$sims_string\n"; | ||
| 906 : | # my ($rfid,$start,$stop,$eval) = ( $sims_string =~ /\S+\s+(\S+)\s+\S+\s\S+\s+(\S+)\s+(\S+)\s+ | ||
| 907 : | # \S+\s+\S+\s+\S+\s+\S+\s+(\S+)+.*/); | ||
| 908 : | # # print "ID: $rfid, E:$eval, Start:$start stop:$stop\n"; | ||
| 909 : | # $Sims{$rfid}{'eval'}=$eval; | ||
| 910 : | # $Sims{$rfid}{'start'}=$start; | ||
| 911 : | # $Sims{$rfid}{'stop'}=$stop; | ||
| 912 : | # print "$rfid $Sims{$rfid}{'eval'}\n"; | ||
| 913 : | # } | ||
| 914 : | |||
| 915 : | # # BBHs | ||
| 916 : | # my $BBHs=(); | ||
| 917 : | |||
| 918 : | # @bbhs_src = $fig->bbhs($fid,1.0e-10); | ||
| 919 : | # print "found $#bbhs_src BBHs\n"; | ||
| 920 : | # foreach $bbh (@bbhs_src) { | ||
| 921 : | # #print "@$bbh\n"; | ||
| 922 : | # my ($bbh_string) = "@$bbh"; | ||
| 923 : | # my ($rfid,$eval,$score) = ( $bbh_string =~ /(\S+)\s(\S+)\s(\S+)/); | ||
| 924 : | # #print "ID: $rfid, E:$eval, S:$score\n"; | ||
| 925 : | # $BBHs{$rfid}{'eval'}=$eval; | ||
| 926 : | # $BBHs{$rfid}{'score'}=$score; | ||
| 927 : | # #print "$rfid $BBHs{$rfid}{'eval'}\n"; | ||
| 928 : | # } | ||
| 929 : | |||
| 930 : | # } | ||
| 931 : | |||
| 932 : | |||
| 933 : | |||
| 934 : | =head3 new (internal) | ||
| 935 : | |||
| 936 : | Instantiate a new object. | ||
| 937 : | |||
| 938 : | =cut | ||
| 939 : | |||
| 940 : | sub new { | ||
| 941 : | mkubal | 1.7 | my ($class,$dataset) = @_; |
| 942 : | |||
| 943 : | mkubal | 1.1 | |
| 944 : | mkubal | 1.7 | #$self = { acc => '', |
| 945 : | # description => '', | ||
| 946 : | # class => '', | ||
| 947 : | # type => '', | ||
| 948 : | # start => '', | ||
| 949 : | # stop => '', | ||
| 950 : | # evalue => '', | ||
| 951 : | # score => '', | ||
| 952 : | # display_method => '', | ||
| 953 : | # feature_id => '', | ||
| 954 : | # rank => '', | ||
| 955 : | # supports_annotation => '', | ||
| 956 : | # id => '', | ||
| 957 : | # organism => '', | ||
| 958 : | # who => '' | ||
| 959 : | # }; | ||
| 960 : | mkubal | 1.1 | |
| 961 : | mkubal | 1.7 | my $self = { class => $dataset->{'class'}, |
| 962 : | type => $dataset->{'type'} | ||
| 963 : | arodri7 | 1.10 | }; |
| 964 : | mkubal | 1.7 | |
| 965 : | bless($self,$class); | ||
| 966 : | mkubal | 1.1 | |
| 967 : | return $self; | ||
| 968 : | } | ||
| 969 : | |||
| 970 : | arodri7 | 1.11 | =head3 identity (internal) |
| 971 : | |||
| 972 : | Returns the % identity of the similar sequence | ||
| 973 : | |||
| 974 : | =cut | ||
| 975 : | |||
| 976 : | sub identity { | ||
| 977 : | my ($self) = @_; | ||
| 978 : | |||
| 979 : | return $self->{identity}; | ||
| 980 : | } | ||
| 981 : | |||
| 982 : | mkubal | 1.1 | =head3 feature_id (internal) |
| 983 : | |||
| 984 : | |||
| 985 : | =cut | ||
| 986 : | |||
| 987 : | sub feature_id { | ||
| 988 : | my ($self) = @_; | ||
| 989 : | |||
| 990 : | return $self->{feature_id}; | ||
| 991 : | } | ||
| 992 : | arodri7 | 1.5 | |
| 993 : | =head3 id (internal) | ||
| 994 : | |||
| 995 : | Returns the ID of the identical sequence | ||
| 996 : | |||
| 997 : | =cut | ||
| 998 : | |||
| 999 : | sub id { | ||
| 1000 : | my ($self) = @_; | ||
| 1001 : | |||
| 1002 : | return $self->{id}; | ||
| 1003 : | } | ||
| 1004 : | |||
| 1005 : | =head3 organism (internal) | ||
| 1006 : | |||
| 1007 : | Returns the organism of the identical sequence | ||
| 1008 : | |||
| 1009 : | =cut | ||
| 1010 : | |||
| 1011 : | sub organism { | ||
| 1012 : | my ($self) = @_; | ||
| 1013 : | |||
| 1014 : | return $self->{organism}; | ||
| 1015 : | } | ||
| 1016 : | |||
| 1017 : | arodri7 | 1.9 | =head3 function (internal) |
| 1018 : | |||
| 1019 : | Returns the function of the identical sequence | ||
| 1020 : | |||
| 1021 : | =cut | ||
| 1022 : | |||
| 1023 : | sub function { | ||
| 1024 : | my ($self) = @_; | ||
| 1025 : | |||
| 1026 : | return $self->{function}; | ||
| 1027 : | } | ||
| 1028 : | |||
| 1029 : | arodri7 | 1.5 | =head3 database (internal) |
| 1030 : | |||
| 1031 : | Returns the database of the identical sequence | ||
| 1032 : | |||
| 1033 : | =cut | ||
| 1034 : | |||
| 1035 : | sub database { | ||
| 1036 : | my ($self) = @_; | ||
| 1037 : | |||
| 1038 : | return $self->{database}; | ||
| 1039 : | } | ||
| 1040 : | |||
| 1041 : | arodri7 | 1.6 | |
| 1042 : | arodri7 | 1.11 | |
| 1043 : | arodri7 | 1.9 | ############################################################ |
| 1044 : | ############################################################ | ||
| 1045 : | package Observation::Identical; | ||
| 1046 : | |||
| 1047 : | use base qw(Observation); | ||
| 1048 : | |||
| 1049 : | sub new { | ||
| 1050 : | |||
| 1051 : | my ($class,$dataset) = @_; | ||
| 1052 : | my $self = $class->SUPER::new($dataset); | ||
| 1053 : | $self->{id} = $dataset->{'id'}; | ||
| 1054 : | $self->{organism} = $dataset->{'organism'}; | ||
| 1055 : | $self->{function} = $dataset->{'function'}; | ||
| 1056 : | $self->{database} = $dataset->{'database'}; | ||
| 1057 : | |||
| 1058 : | bless($self,$class); | ||
| 1059 : | return $self; | ||
| 1060 : | } | ||
| 1061 : | |||
| 1062 : | =head3 display() | ||
| 1063 : | arodri7 | 1.6 | |
| 1064 : | If available use the function specified here to display the "raw" observation. | ||
| 1065 : | This code will display a table for the identical protein | ||
| 1066 : | |||
| 1067 : | |||
| 1068 : | arodri7 | 1.9 | B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evi |
| 1069 : | dence. | ||
| 1070 : | arodri7 | 1.6 | |
| 1071 : | =cut | ||
| 1072 : | |||
| 1073 : | arodri7 | 1.9 | sub display{ |
| 1074 : | my ($self, $cgi, $dataset) = @_; | ||
| 1075 : | arodri7 | 1.6 | |
| 1076 : | my $all_domains = []; | ||
| 1077 : | my $count_identical = 0; | ||
| 1078 : | arodri7 | 1.9 | my $content; |
| 1079 : | foreach my $thing (@$dataset) { | ||
| 1080 : | arodri7 | 1.6 | next if ($thing->class ne "IDENTICAL"); |
| 1081 : | arodri7 | 1.9 | my $single_domain = []; |
| 1082 : | push(@$single_domain,$thing->database); | ||
| 1083 : | my $id = $thing->id; | ||
| 1084 : | $count_identical++; | ||
| 1085 : | push(@$single_domain,&HTML::set_prot_links($cgi,$id)); | ||
| 1086 : | push(@$single_domain,$thing->organism); | ||
| 1087 : | #push(@$single_domain,$thing->type); | ||
| 1088 : | push(@$single_domain,$thing->function); | ||
| 1089 : | push(@$all_domains,$single_domain); | ||
| 1090 : | arodri7 | 1.6 | } |
| 1091 : | |||
| 1092 : | if ($count_identical >0){ | ||
| 1093 : | arodri7 | 1.9 | $content = $all_domains; |
| 1094 : | arodri7 | 1.6 | } |
| 1095 : | else{ | ||
| 1096 : | arodri7 | 1.9 | $content = "<p>This PEG does not have any essentially identical proteins</p>"; |
| 1097 : | arodri7 | 1.6 | } |
| 1098 : | return ($content); | ||
| 1099 : | } | ||
| 1100 : | mkubal | 1.7 | |
| 1101 : | arodri7 | 1.9 | 1; |
| 1102 : | |||
| 1103 : | |||
| 1104 : | ######################################### | ||
| 1105 : | ######################################### | ||
| 1106 : | package Observation::FC; | ||
| 1107 : | 1; | ||
| 1108 : | |||
| 1109 : | use base qw(Observation); | ||
| 1110 : | |||
| 1111 : | sub new { | ||
| 1112 : | |||
| 1113 : | my ($class,$dataset) = @_; | ||
| 1114 : | my $self = $class->SUPER::new($dataset); | ||
| 1115 : | $self->{score} = $dataset->{'score'}; | ||
| 1116 : | $self->{id} = $dataset->{'id'}; | ||
| 1117 : | $self->{function} = $dataset->{'function'}; | ||
| 1118 : | |||
| 1119 : | bless($self,$class); | ||
| 1120 : | return $self; | ||
| 1121 : | } | ||
| 1122 : | |||
| 1123 : | =head3 display() | ||
| 1124 : | |||
| 1125 : | If available use the function specified here to display the "raw" observation. | ||
| 1126 : | This code will display a table for the identical protein | ||
| 1127 : | |||
| 1128 : | |||
| 1129 : | B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evi | ||
| 1130 : | dence. | ||
| 1131 : | |||
| 1132 : | =cut | ||
| 1133 : | |||
| 1134 : | sub display { | ||
| 1135 : | my ($self,$cgi,$dataset, $fid) = @_; | ||
| 1136 : | |||
| 1137 : | my $functional_data = []; | ||
| 1138 : | my $count = 0; | ||
| 1139 : | my $content; | ||
| 1140 : | |||
| 1141 : | foreach my $thing (@$dataset) { | ||
| 1142 : | my $single_domain = []; | ||
| 1143 : | next if ($thing->class ne "PCH"); | ||
| 1144 : | $count++; | ||
| 1145 : | |||
| 1146 : | # construct the score link | ||
| 1147 : | my $score = $thing->score; | ||
| 1148 : | my $toid = $thing->id; | ||
| 1149 : | my $link = $cgi->url(-relative => 1) . "?user=master&request=show_coupling_evidence&prot=$fid&to=$toid&SPROUT="; | ||
| 1150 : | my $sc_link = "<a href=$link>$score</a>"; | ||
| 1151 : | |||
| 1152 : | push(@$single_domain,$sc_link); | ||
| 1153 : | push(@$single_domain,$thing->id); | ||
| 1154 : | push(@$single_domain,$thing->function); | ||
| 1155 : | push(@$functional_data,$single_domain); | ||
| 1156 : | } | ||
| 1157 : | |||
| 1158 : | if ($count >0){ | ||
| 1159 : | $content = $functional_data; | ||
| 1160 : | } | ||
| 1161 : | else | ||
| 1162 : | { | ||
| 1163 : | $content = "<p>This PEG does not have any functional coupling</p>"; | ||
| 1164 : | } | ||
| 1165 : | return ($content); | ||
| 1166 : | } | ||
| 1167 : | |||
| 1168 : | |||
| 1169 : | ######################################### | ||
| 1170 : | ######################################### | ||
| 1171 : | mkubal | 1.7 | package Observation::Domain; |
| 1172 : | |||
| 1173 : | use base qw(Observation); | ||
| 1174 : | |||
| 1175 : | sub new { | ||
| 1176 : | |||
| 1177 : | my ($class,$dataset) = @_; | ||
| 1178 : | my $self = $class->SUPER::new($dataset); | ||
| 1179 : | $self->{evalue} = $dataset->{'evalue'}; | ||
| 1180 : | $self->{acc} = $dataset->{'acc'}; | ||
| 1181 : | $self->{start} = $dataset->{'start'}; | ||
| 1182 : | $self->{stop} = $dataset->{'stop'}; | ||
| 1183 : | |||
| 1184 : | bless($self,$class); | ||
| 1185 : | return $self; | ||
| 1186 : | } | ||
| 1187 : | |||
| 1188 : | sub display { | ||
| 1189 : | my ($thing,$gd) = @_; | ||
| 1190 : | my $lines = []; | ||
| 1191 : | my $line_config = { 'title' => $thing->acc, | ||
| 1192 : | 'short_title' => $thing->type, | ||
| 1193 : | 'basepair_offset' => '1' }; | ||
| 1194 : | my $color = "4"; | ||
| 1195 : | |||
| 1196 : | my $line_data = []; | ||
| 1197 : | my $links_list = []; | ||
| 1198 : | my $descriptions = []; | ||
| 1199 : | |||
| 1200 : | my $description_function; | ||
| 1201 : | $description_function = {"title" => $thing->class, | ||
| 1202 : | "value" => $thing->acc}; | ||
| 1203 : | |||
| 1204 : | push(@$descriptions,$description_function); | ||
| 1205 : | |||
| 1206 : | my $score; | ||
| 1207 : | $score = {"title" => "score", | ||
| 1208 : | "value" => $thing->evalue}; | ||
| 1209 : | push(@$descriptions,$score); | ||
| 1210 : | |||
| 1211 : | my $link_id; | ||
| 1212 : | mkubal | 1.12 | if ($thing->acc =~/\w+::(\d+)/){ |
| 1213 : | mkubal | 1.7 | $link_id = $1; |
| 1214 : | } | ||
| 1215 : | |||
| 1216 : | my $link; | ||
| 1217 : | mkubal | 1.12 | my $link_url; |
| 1218 : | if ($thing->class eq "CDD"){$link_url = "http://0-www.ncbi.nlm.nih.gov.library.vu.edu.au:80/Structure/cdd/cddsrv.cgi?uid=$link_id"} | ||
| 1219 : | elsif($thing->class eq "PFAM"){$link_url = "http://www.sanger.ac.uk/cgi-bin/Pfam/getacc?$link_id"} | ||
| 1220 : | else{$link_url = "NO_URL"} | ||
| 1221 : | |||
| 1222 : | mkubal | 1.7 | $link = {"link_title" => $thing->acc, |
| 1223 : | mkubal | 1.12 | "link" => $link_url}; |
| 1224 : | mkubal | 1.7 | push(@$links_list,$link); |
| 1225 : | |||
| 1226 : | my $element_hash = { | ||
| 1227 : | "title" => $thing->type, | ||
| 1228 : | "start" => $thing->start, | ||
| 1229 : | "end" => $thing->stop, | ||
| 1230 : | "color"=> $color, | ||
| 1231 : | "zlayer" => '2', | ||
| 1232 : | "links_list" => $links_list, | ||
| 1233 : | "description" => $descriptions}; | ||
| 1234 : | |||
| 1235 : | push(@$line_data,$element_hash); | ||
| 1236 : | $gd->add_line($line_data, $line_config); | ||
| 1237 : | |||
| 1238 : | return $gd; | ||
| 1239 : | |||
| 1240 : | } | ||
| 1241 : | |||
| 1242 : | arodri7 | 1.10 | ######################################### |
| 1243 : | ######################################### | ||
| 1244 : | mkubal | 1.12 | package Observation::Location; |
| 1245 : | |||
| 1246 : | use base qw(Observation); | ||
| 1247 : | |||
| 1248 : | sub new { | ||
| 1249 : | |||
| 1250 : | my ($class,$dataset) = @_; | ||
| 1251 : | my $self = $class->SUPER::new($dataset); | ||
| 1252 : | $self->{cleavage_prob} = $dataset->{'cleavage_prob'}; | ||
| 1253 : | $self->{cleavage_loc} = $dataset->{'cleavage_loc'}; | ||
| 1254 : | $self->{signal_peptide_score} = $dataset->{'signal_peptide_score'}; | ||
| 1255 : | $self->{cello_location} = $dataset->{'cello_location'}; | ||
| 1256 : | $self->{cello_score} = $dataset->{'cello_score'}; | ||
| 1257 : | $self->{tmpred_score} = $dataset->{'tmpred_score'}; | ||
| 1258 : | $self->{tmpred_locations} = $dataset->{'tmpred_locations'}; | ||
| 1259 : | |||
| 1260 : | bless($self,$class); | ||
| 1261 : | return $self; | ||
| 1262 : | } | ||
| 1263 : | |||
| 1264 : | sub display { | ||
| 1265 : | my ($thing,$gd,$fid) = @_; | ||
| 1266 : | |||
| 1267 : | my $fig= new FIG; | ||
| 1268 : | my $length = length($fig->get_translation($fid)); | ||
| 1269 : | |||
| 1270 : | my $cleavage_prob; | ||
| 1271 : | if($thing->cleavage_prob){$cleavage_prob = $thing->cleavage_prob;} | ||
| 1272 : | my ($cleavage_loc_begin,$cleavage_loc_end) = split("-",$thing->cleavage_loc); | ||
| 1273 : | my $signal_peptide_score = $thing->signal_peptide_score; | ||
| 1274 : | my $cello_location = $thing->cello_location; | ||
| 1275 : | my $cello_score = $thing->cello_score; | ||
| 1276 : | my $tmpred_score = $thing->tmpred_score; | ||
| 1277 : | my @tmpred_locations = split(",",$thing->tmpred_locations); | ||
| 1278 : | |||
| 1279 : | my $lines = []; | ||
| 1280 : | my $line_config = { 'title' => 'Localization Evidence', | ||
| 1281 : | 'short_title' => 'Local', | ||
| 1282 : | 'basepair_offset' => '1' }; | ||
| 1283 : | |||
| 1284 : | #color is | ||
| 1285 : | my $color = "5"; | ||
| 1286 : | |||
| 1287 : | my $line_data = []; | ||
| 1288 : | |||
| 1289 : | if($cello_location){ | ||
| 1290 : | my $cello_descriptions = []; | ||
| 1291 : | my $description_cello_location = {"title" => 'Best Cello Location', | ||
| 1292 : | "value" => $cello_location}; | ||
| 1293 : | |||
| 1294 : | push(@$cello_descriptions,$description_cello_location); | ||
| 1295 : | |||
| 1296 : | my $description_cello_score = {"title" => 'Cello Score', | ||
| 1297 : | "value" => $cello_score}; | ||
| 1298 : | |||
| 1299 : | push(@$cello_descriptions,$description_cello_score); | ||
| 1300 : | |||
| 1301 : | my $element_hash = { | ||
| 1302 : | "title" => "CELLO", | ||
| 1303 : | "start" => "1", | ||
| 1304 : | "end" => $length + 1, | ||
| 1305 : | "color"=> $color, | ||
| 1306 : | "type" => 'box', | ||
| 1307 : | "zlayer" => '2', | ||
| 1308 : | "description" => $cello_descriptions}; | ||
| 1309 : | |||
| 1310 : | push(@$line_data,$element_hash); | ||
| 1311 : | } | ||
| 1312 : | |||
| 1313 : | my $color = "6"; | ||
| 1314 : | #if(0){ | ||
| 1315 : | if($tmpred_score){ | ||
| 1316 : | foreach my $tmpred (@tmpred_locations){ | ||
| 1317 : | my $descriptions = []; | ||
| 1318 : | my ($begin,$end) =split("-",$tmpred); | ||
| 1319 : | my $description_tmpred_score = {"title" => 'TMPRED score', | ||
| 1320 : | "value" => $tmpred_score}; | ||
| 1321 : | |||
| 1322 : | push(@$descriptions,$description_tmpred_score); | ||
| 1323 : | |||
| 1324 : | my $element_hash = { | ||
| 1325 : | "title" => "transmembrane location", | ||
| 1326 : | "start" => $begin + 1, | ||
| 1327 : | "end" => $end + 1, | ||
| 1328 : | "color"=> $color, | ||
| 1329 : | "zlayer" => '5', | ||
| 1330 : | "type" => 'smallbox', | ||
| 1331 : | "description" => $descriptions}; | ||
| 1332 : | |||
| 1333 : | push(@$line_data,$element_hash); | ||
| 1334 : | } | ||
| 1335 : | } | ||
| 1336 : | |||
| 1337 : | my $color = "1"; | ||
| 1338 : | if($signal_peptide_score){ | ||
| 1339 : | my $descriptions = []; | ||
| 1340 : | my $description_signal_peptide_score = {"title" => 'signal peptide score', | ||
| 1341 : | "value" => $signal_peptide_score}; | ||
| 1342 : | |||
| 1343 : | push(@$descriptions,$description_signal_peptide_score); | ||
| 1344 : | |||
| 1345 : | my $description_cleavage_prob = {"title" => 'cleavage site probability', | ||
| 1346 : | "value" => $cleavage_prob}; | ||
| 1347 : | |||
| 1348 : | push(@$descriptions,$description_cleavage_prob); | ||
| 1349 : | |||
| 1350 : | my $element_hash = { | ||
| 1351 : | "title" => "SignalP", | ||
| 1352 : | "start" => $cleavage_loc_begin - 2, | ||
| 1353 : | "end" => $cleavage_loc_end + 3, | ||
| 1354 : | "type" => 'bigbox', | ||
| 1355 : | "color"=> $color, | ||
| 1356 : | "zlayer" => '10', | ||
| 1357 : | "description" => $descriptions}; | ||
| 1358 : | |||
| 1359 : | push(@$line_data,$element_hash); | ||
| 1360 : | } | ||
| 1361 : | |||
| 1362 : | $gd->add_line($line_data, $line_config); | ||
| 1363 : | |||
| 1364 : | return ($gd); | ||
| 1365 : | |||
| 1366 : | } | ||
| 1367 : | |||
| 1368 : | sub cleavage_loc { | ||
| 1369 : | my ($self) = @_; | ||
| 1370 : | |||
| 1371 : | return $self->{cleavage_loc}; | ||
| 1372 : | } | ||
| 1373 : | |||
| 1374 : | sub cleavage_prob { | ||
| 1375 : | my ($self) = @_; | ||
| 1376 : | |||
| 1377 : | return $self->{cleavage_prob}; | ||
| 1378 : | } | ||
| 1379 : | |||
| 1380 : | sub signal_peptide_score { | ||
| 1381 : | my ($self) = @_; | ||
| 1382 : | |||
| 1383 : | return $self->{signal_peptide_score}; | ||
| 1384 : | } | ||
| 1385 : | |||
| 1386 : | sub tmpred_score { | ||
| 1387 : | my ($self) = @_; | ||
| 1388 : | |||
| 1389 : | return $self->{tmpred_score}; | ||
| 1390 : | } | ||
| 1391 : | |||
| 1392 : | sub tmpred_locations { | ||
| 1393 : | my ($self) = @_; | ||
| 1394 : | |||
| 1395 : | return $self->{tmpred_locations}; | ||
| 1396 : | } | ||
| 1397 : | |||
| 1398 : | sub cello_location { | ||
| 1399 : | my ($self) = @_; | ||
| 1400 : | |||
| 1401 : | return $self->{cello_location}; | ||
| 1402 : | } | ||
| 1403 : | |||
| 1404 : | sub cello_score { | ||
| 1405 : | my ($self) = @_; | ||
| 1406 : | |||
| 1407 : | return $self->{cello_score}; | ||
| 1408 : | } | ||
| 1409 : | |||
| 1410 : | |||
| 1411 : | ######################################### | ||
| 1412 : | ######################################### | ||
| 1413 : | arodri7 | 1.10 | package Observation::Sims; |
| 1414 : | |||
| 1415 : | use base qw(Observation); | ||
| 1416 : | |||
| 1417 : | sub new { | ||
| 1418 : | |||
| 1419 : | my ($class,$dataset) = @_; | ||
| 1420 : | my $self = $class->SUPER::new($dataset); | ||
| 1421 : | arodri7 | 1.11 | $self->{identity} = $dataset->{'identity'}; |
| 1422 : | arodri7 | 1.10 | $self->{acc} = $dataset->{'acc'}; |
| 1423 : | $self->{evalue} = $dataset->{'evalue'}; | ||
| 1424 : | arodri7 | 1.11 | $self->{qstart} = $dataset->{'qstart'}; |
| 1425 : | $self->{qstop} = $dataset->{'qstop'}; | ||
| 1426 : | $self->{hstart} = $dataset->{'hstart'}; | ||
| 1427 : | $self->{hstop} = $dataset->{'hstop'}; | ||
| 1428 : | $self->{database} = $dataset->{'database'}; | ||
| 1429 : | $self->{organism} = $dataset->{'organism'}; | ||
| 1430 : | $self->{function} = $dataset->{'function'}; | ||
| 1431 : | $self->{qlength} = $dataset->{'qlength'}; | ||
| 1432 : | $self->{hlength} = $dataset->{'hlength'}; | ||
| 1433 : | arodri7 | 1.10 | |
| 1434 : | bless($self,$class); | ||
| 1435 : | return $self; | ||
| 1436 : | } | ||
| 1437 : | |||
| 1438 : | =head3 display() | ||
| 1439 : | |||
| 1440 : | If available use the function specified here to display the "raw" observation. | ||
| 1441 : | This code will display a table for the similarities protein | ||
| 1442 : | |||
| 1443 : | B<Please note> that URL linked to in display_method() is an external component and needs to added to the code for every class of evidence. | ||
| 1444 : | |||
| 1445 : | =cut | ||
| 1446 : | |||
| 1447 : | sub display { | ||
| 1448 : | my ($self,$cgi,$dataset) = @_; | ||
| 1449 : | |||
| 1450 : | my $data = []; | ||
| 1451 : | my $count = 0; | ||
| 1452 : | my $content; | ||
| 1453 : | arodri7 | 1.11 | my $fig = new FIG; |
| 1454 : | arodri7 | 1.10 | |
| 1455 : | foreach my $thing (@$dataset) { | ||
| 1456 : | my $single_domain = []; | ||
| 1457 : | next if ($thing->class ne "SIM"); | ||
| 1458 : | $count++; | ||
| 1459 : | |||
| 1460 : | arodri7 | 1.11 | my $id = $thing->acc; |
| 1461 : | |||
| 1462 : | # add the subsystem information | ||
| 1463 : | my @in_sub = $fig->peg_to_subsystems($id); | ||
| 1464 : | my $in_sub; | ||
| 1465 : | |||
| 1466 : | if (@in_sub > 0) { | ||
| 1467 : | $in_sub = @in_sub; | ||
| 1468 : | |||
| 1469 : | # RAE: add a javascript popup with all the subsystems | ||
| 1470 : | my $ss_list=join "<br>", map { my $g = $_; $g =~ s/\_/ /g; $_ = $g } sort {$a cmp $b} @in_sub; | ||
| 1471 : | $in_sub = $cgi->a( {id=>"subsystems", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Subsystems', '$ss_list', ''); this.tooltip.addHandler(); return false;"}, $in_sub); | ||
| 1472 : | } else { | ||
| 1473 : | $in_sub = " "; | ||
| 1474 : | } | ||
| 1475 : | |||
| 1476 : | # add evidence code with tool tip | ||
| 1477 : | my $ev_codes=" "; | ||
| 1478 : | my @ev_codes = ""; | ||
| 1479 : | if ($id =~ /^fig\|\d+\.\d+\.peg\.\d+$/) { | ||
| 1480 : | my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig->get_attributes($id); | ||
| 1481 : | @ev_codes = (); | ||
| 1482 : | foreach my $code (@codes) { | ||
| 1483 : | my $pretty_code = $code->[2]; | ||
| 1484 : | if ($pretty_code =~ /;/) { | ||
| 1485 : | my ($cd, $ss) = split(";", $code->[2]); | ||
| 1486 : | $ss =~ s/_/ /g; | ||
| 1487 : | $pretty_code = $cd;# . " in " . $ss; | ||
| 1488 : | } | ||
| 1489 : | push(@ev_codes, $pretty_code); | ||
| 1490 : | } | ||
| 1491 : | } | ||
| 1492 : | |||
| 1493 : | if (scalar(@ev_codes) && $ev_codes[0]) { | ||
| 1494 : | my $ev_code_help=join("<br />", map {&HTML::evidence_codes_explain($_)} @ev_codes); | ||
| 1495 : | $ev_codes = $cgi->a( | ||
| 1496 : | { | ||
| 1497 : | id=>"evidence_codes", onMouseover=>"javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Evidence Codes', '$ev_code_help', ''); this.tooltip.addHandler(); return false;"}, join("<br />", @ev_codes)); | ||
| 1498 : | } | ||
| 1499 : | |||
| 1500 : | # add the aliases | ||
| 1501 : | my $aliases = undef; | ||
| 1502 : | $aliases = &html_enc( join( ", ", $fig->feature_aliases($id) ) ); | ||
| 1503 : | $aliases = &HTML::set_prot_links( $cgi, $aliases ); | ||
| 1504 : | $aliases ||= " "; | ||
| 1505 : | |||
| 1506 : | my $iden = $thing->identity; | ||
| 1507 : | my $ln1 = $thing->qlength; | ||
| 1508 : | my $ln2 = $thing->hlength; | ||
| 1509 : | my $b1 = $thing->qstart; | ||
| 1510 : | my $e1 = $thing->qstop; | ||
| 1511 : | my $b2 = $thing->hstart; | ||
| 1512 : | my $e2 = $thing->hstop; | ||
| 1513 : | my $d1 = abs($e1 - $b1) + 1; | ||
| 1514 : | my $d2 = abs($e2 - $b2) + 1; | ||
| 1515 : | my $reg1 = "$b1-$e1 (<b>$d1/$ln1</b>)"; | ||
| 1516 : | my $reg2 = "$b2-$e2 (<b>$d2/$ln2</b>)"; | ||
| 1517 : | |||
| 1518 : | |||
| 1519 : | push(@$single_domain,$thing->database); | ||
| 1520 : | arodri7 | 1.10 | push(@$single_domain,&HTML::set_prot_links($cgi,$thing->acc)); |
| 1521 : | push(@$single_domain,$thing->evalue); | ||
| 1522 : | arodri7 | 1.11 | push(@$single_domain,"$iden\%"); |
| 1523 : | push(@$single_domain,$reg1); | ||
| 1524 : | push(@$single_domain,$reg2); | ||
| 1525 : | push(@$single_domain,$in_sub); | ||
| 1526 : | push(@$single_domain,$ev_codes); | ||
| 1527 : | push(@$single_domain,$thing->organism); | ||
| 1528 : | push(@$single_domain,$thing->function); | ||
| 1529 : | push(@$single_domain,$aliases); | ||
| 1530 : | arodri7 | 1.10 | push(@$data,$single_domain); |
| 1531 : | } | ||
| 1532 : | |||
| 1533 : | if ($count >0){ | ||
| 1534 : | $content = $data; | ||
| 1535 : | } | ||
| 1536 : | else | ||
| 1537 : | { | ||
| 1538 : | $content = "<p>This PEG does not have any similarities</p>"; | ||
| 1539 : | } | ||
| 1540 : | return ($content); | ||
| 1541 : | } | ||
| 1542 : | arodri7 | 1.11 | |
| 1543 : | sub html_enc { $_ = $_[0]; s/\&/&/g; s/\>/>/g; s/\</</g; $_ } | ||
| 1544 : | mkubal | 1.12 | |
| 1545 : | arodri7 | 1.13 | |
| 1546 : | |||
| 1547 : | ############################ | ||
| 1548 : | package Observation::Cluster; | ||
| 1549 : | |||
| 1550 : | use base qw(Observation); | ||
| 1551 : | |||
| 1552 : | sub new { | ||
| 1553 : | |||
| 1554 : | my ($class,$dataset) = @_; | ||
| 1555 : | my $self = $class->SUPER::new($dataset); | ||
| 1556 : | |||
| 1557 : | bless($self,$class); | ||
| 1558 : | return $self; | ||
| 1559 : | } | ||
| 1560 : | |||
| 1561 : | sub display { | ||
| 1562 : | my ($self,$gd, $fid) = @_; | ||
| 1563 : | |||
| 1564 : | my $fig = new FIG; | ||
| 1565 : | mkubal | 1.14 | my $all_regions = []; |
| 1566 : | arodri7 | 1.13 | |
| 1567 : | #get the organism genome | ||
| 1568 : | mkubal | 1.14 | my $target_genome = $fig->genome_of($fid); |
| 1569 : | arodri7 | 1.13 | |
| 1570 : | # get location of the gene | ||
| 1571 : | my $data = $fig->feature_location($fid); | ||
| 1572 : | my ($contig, $beg, $end); | ||
| 1573 : | |||
| 1574 : | if ($data =~ /(.*)_(\d+)_(\d+)$/){ | ||
| 1575 : | $contig = $1; | ||
| 1576 : | $beg = $2; | ||
| 1577 : | $end = $3; | ||
| 1578 : | } | ||
| 1579 : | |||
| 1580 : | my ($region_start, $region_end); | ||
| 1581 : | if ($beg < $end) | ||
| 1582 : | { | ||
| 1583 : | $region_start = $beg - 4000; | ||
| 1584 : | $region_end = $end+4000; | ||
| 1585 : | } | ||
| 1586 : | else | ||
| 1587 : | { | ||
| 1588 : | $region_end = $end+4000; | ||
| 1589 : | $region_start = $beg-4000; | ||
| 1590 : | } | ||
| 1591 : | |||
| 1592 : | # call genes in region | ||
| 1593 : | mkubal | 1.14 | my ($target_gene_features, $reg_beg, $reg_end) = $fig->genes_in_region($target_genome, $contig, $region_start, $region_stop); |
| 1594 : | push(@$all_regions,$target_gene_features); | ||
| 1595 : | |||
| 1596 : | my %all_genes; | ||
| 1597 : | my %all_genomes; | ||
| 1598 : | foreach my $feature (@$target_gene_features){ $all_genes{$feature} = 1} | ||
| 1599 : | |||
| 1600 : | my @coup = $fig->coupling_and_evidence($fid,5000,1e-10,4,1); | ||
| 1601 : | |||
| 1602 : | foreach my $pair (@$coup[0]->[2]){ | ||
| 1603 : | my ($peg1,$peg2) = @$pair; | ||
| 1604 : | my $location = $fig->feature_location($peg1); | ||
| 1605 : | my ($pair_contig,$pair_beg,$pair_end,$pair_region_start,$pair_region_stop,$pair_genome); | ||
| 1606 : | if($location =~/(.*)_(\d+)_(\d+)$/){ | ||
| 1607 : | $pair_contig = $1; | ||
| 1608 : | $pair_beg = $2; | ||
| 1609 : | $pair_end = $3; | ||
| 1610 : | if ($pair_beg < $pair_end) | ||
| 1611 : | { | ||
| 1612 : | $pair_region_start = $pair_beg - 4000; | ||
| 1613 : | $pair_region_end = $pair_end+4000; | ||
| 1614 : | } | ||
| 1615 : | else | ||
| 1616 : | { | ||
| 1617 : | $pair_region_end = $pair_end+4000; | ||
| 1618 : | $pair_region_start = $pair_beg-4000; | ||
| 1619 : | } | ||
| 1620 : | |||
| 1621 : | $pair_genome = $fig->genome_of($peg1); | ||
| 1622 : | $all_genomes{$pair_genome} = 1; | ||
| 1623 : | my ($pair_features) = $fig->genes_in_region($pair_genome, $pair_contig, $pair_region_start, $pair_region_stop); | ||
| 1624 : | push(@$all_regions,$pair_features); | ||
| 1625 : | foreach my $pair_feature (@$pair_features){ $all_genes{$feature} = 1} | ||
| 1626 : | |||
| 1627 : | } | ||
| 1628 : | } | ||
| 1629 : | |||
| 1630 : | my $bbh_sets = []; | ||
| 1631 : | my %already; | ||
| 1632 : | foreach my $gene_key (keys(%all_genes)){ | ||
| 1633 : | if($already{$gene_key}){next;} | ||
| 1634 : | my $gene_set = [$gene_key]; | ||
| 1635 : | foreach my $genome_key (keys(%all_genomes)){ | ||
| 1636 : | my $return = $fig->bbh_list($genome_key,[$gene_key]); | ||
| 1637 : | my @$feature_list = $return->{$gene_key}; | ||
| 1638 : | foreach my $fl (@$feature_list){ | ||
| 1639 : | push(@$gene_set,$fl); | ||
| 1640 : | $already{$fl} = 1; | ||
| 1641 : | } | ||
| 1642 : | } | ||
| 1643 : | $already{$gene_key} = 1; | ||
| 1644 : | push(@$bbh_sets,$gene_set); | ||
| 1645 : | } | ||
| 1646 : | |||
| 1647 : | %bbh_set_rank; | ||
| 1648 : | my $order = 0; | ||
| 1649 : | foreach my $set (@$bbh_sets){ | ||
| 1650 : | my $count = scalar(@$set); | ||
| 1651 : | $bbh_rank{$order} = $count; | ||
| 1652 : | $order++; | ||
| 1653 : | } | ||
| 1654 : | |||
| 1655 : | my %peg_rank; | ||
| 1656 : | my $counter = 1; | ||
| 1657 : | foreach my $bbh_order (sort {$bbh_set_rank{$b} <=> $bbh_set_rank{$a}} keys %bbh_set_rank){ | ||
| 1658 : | my $good_set = @$bbh_sets[$bbh_order]; | ||
| 1659 : | foreach my $peg (@$good_set){ | ||
| 1660 : | $peg_rank{$peg} = $counter; | ||
| 1661 : | } | ||
| 1662 : | $counter++; | ||
| 1663 : | } | ||
| 1664 : | |||
| 1665 : | foreach my $region (@$all_regions){ | ||
| 1666 : | my $sample_peg = @$region[0]; | ||
| 1667 : | my $region_genome = $fig->genome_of($sample_peg); | ||
| 1668 : | my $region_gs = $fig->genus_species($region_genome); | ||
| 1669 : | my $line_config = { 'title' => $region_gs, | ||
| 1670 : | 'short_title' => $region_gs, | ||
| 1671 : | 'height' => 30, | ||
| 1672 : | 'basepair_offset' => '0'; | ||
| 1673 : | }; | ||
| 1674 : | my $line_data = []; | ||
| 1675 : | foreach my $fid (@$region){ | ||
| 1676 : | my $element_hash; | ||
| 1677 : | my $links_list = []; | ||
| 1678 : | my $descriptions = []; | ||
| 1679 : | |||
| 1680 : | my $color = $peg_rank{$fid}; | ||
| 1681 : | my $fid_location = $fig->feature_location($fid); | ||
| 1682 : | if($fid_location =~/(.*)_(\d+)_(\d+)$/){ | ||
| 1683 : | my($start,$stop); | ||
| 1684 : | if ($2 < $3){$start = $2; $stop = $3;} | ||
| 1685 : | else{$stop = $2; $start = $3;} | ||
| 1686 : | $element_hash = { | ||
| 1687 : | "title" => $fid, | ||
| 1688 : | "start" => $start, | ||
| 1689 : | "end" => $stop, | ||
| 1690 : | "type"=> 'arrow', | ||
| 1691 : | "color"=> $color, | ||
| 1692 : | "zlayer" => "2", | ||
| 1693 : | }; | ||
| 1694 : | push(@$line_data,$element_hash); | ||
| 1695 : | } | ||
| 1696 : | } | ||
| 1697 : | $gd->add_line($line_data, $line_config); | ||
| 1698 : | } | ||
| 1699 : | return $gd; | ||
| 1700 : | } | ||
| 1701 : | |||
| 1702 : |
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |