[Bio] / FigKernelScripts / CSA_layout.pl Repository:
ViewVC logotype

Annotation of /FigKernelScripts/CSA_layout.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : overbeek 1.1 use strict;
2 : overbeek 1.2 #
3 :     # This is a SAS Component
4 :     #
5 : overbeek 1.1 use Data::Dumper;
6 :     use Carp;
7 :     use SeedEnv;
8 :    
9 :     my $usage = "usage: CSA_layout WorkingDir PegTbl1 RnaTbl1 Functions1";
10 :    
11 :     my($dir,$peg_tbl1,$rna_tbl1,$functions1);
12 :     (
13 :     ($dir = shift @ARGV) && (-s "$dir/output.second.pass") &&
14 :     ($peg_tbl1 = shift @ARGV) && (-s $peg_tbl1) &&
15 :     ($rna_tbl1 = shift @ARGV) && (-s $rna_tbl1) &&
16 :     ($functions1 = shift @ARGV) && (-s $functions1)
17 :     )
18 :     || die $usage;
19 :    
20 :     my %func_of = map { ($_ =~ /^(fig\S+)\t(\S.*\S)/) ? ($1 => $2) : () } `cat $functions1`;
21 :     my %to_abbrev = map { $_ =~ /^(\S+)\t(\S+)/; ($2 => $1) } `cat $dir/index1`;
22 :     my $n = 0;
23 :     my @pins = map { chop; [split(/\t/,$_)] } `cat $dir/output.second.pass`;
24 :     my @repeats = map { chop; [split(/\t/,$_)] } `cat $dir/repeats2`;
25 :    
26 :     my @points;
27 :     @pins = sort { ($a->[0] cmp $b->[0]) || ($a->[1] <=> $b->[1]) } @pins;
28 :     my $n = 1;
29 :     foreach my $_ (@pins)
30 :     {
31 :     push(@points,[$_->[3],$_->[4],'start',$_->[6] . ":" . $n]);
32 :     push(@points,[$_->[3],$_->[5],'start',$_->[6] . ":" . $n++]);
33 :     }
34 :    
35 :     $n = 1;
36 :     foreach my $_ (@repeats)
37 :     {
38 :     push(@points,[$_->[0],$_->[1],'start','repeat' . ":" . $n]);
39 :     push(@points,[$_->[0],$_->[2],'end','repeat' . ":" . $n++]);
40 :     }
41 :    
42 :     my $mapped = 0;
43 :     my $not_mapped = 0;
44 :     foreach $_ (`cat $peg_tbl1`,`cat $rna_tbl1`)
45 :     {
46 :     if ($_ =~ /^(fig\|\S+)\t(\S+)/)
47 :     {
48 :     my $peg = $1;
49 :     my($contig,$left,$right,$strand) = &SeedUtils::boundaries_of($2);
50 :     my($beg,$end) = ($strand eq "+") ? ($left,$right) : ($right,$left);
51 :     my $f = $func_of{$peg} ? $func_of{$peg} : '';
52 :     my($ptB,$ptE);
53 :    
54 :     if ($ptB = &locate($to_abbrev{$contig},$beg,\@pins))
55 :     {
56 :     push(@points,[@$ptB,'start',$peg,$f]);
57 :     $mapped++;
58 :     }
59 :     else
60 :     {
61 :     $not_mapped++;
62 :     }
63 :    
64 :     if (my $ptE = &locate($to_abbrev{$contig},$end,\@pins))
65 :     {
66 :     push(@points,[@$ptE,'end',$peg,$f]);
67 :     $mapped++;
68 :     }
69 :     else
70 :     {
71 :     $not_mapped++;
72 :     }
73 :     }
74 :     }
75 :     @points = sort { ($a->[0] cmp $b->[0]) or ($a->[1] <=> $b->[1]) } @points;
76 :     print "mapped gene boundaries = $mapped\n";
77 :     print "unmapped gene boundaries = $not_mapped\n";
78 :     foreach my $pt (@points)
79 :     {
80 :     print join("\t",@$pt),"\n";
81 :     }
82 :    
83 :     sub locate {
84 :     my($contig,$x,$pins) = @_;
85 :    
86 :     foreach $_ (@$pins)
87 :     {
88 :     my($c1,$b1,$e1,$c2,$b2,$e2) = @$_;
89 :     if (($contig eq $c1) && ($x >= $b1) && ($x <= $e1))
90 :     {
91 :     my $incr = $x - $b1;
92 :     return [$c2,($b2 < $e2) ? ($b2 + $incr) : ($b2 - $incr)];
93 :     }
94 :     }
95 :     return undef;
96 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3