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

Annotation of /FigKernelScripts/diff_tbls.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : overbeek 1.1 # -*- perl -*-
2 :    
3 :     use FIG;
4 :     $fig = new FIG;
5 :     $code = &FIG::standard_genetic_code();
6 :    
7 :     (($old_tbl_file = shift) && (-f $old_tbl_file)) || die "Could not find old tbl $old_tbl_file";
8 :     (($new_tbl_file = shift) && (-f $new_tbl_file)) || die "Could not find new tbl $new_tbl_file";
9 :    
10 :     $old_tbl = &load_tbl($old_tbl_file);
11 :     $new_tbl = &load_tbl($new_tbl_file);
12 :    
13 :     use constant FID => 0;
14 :     use constant LOCUS => 1;
15 :     use constant CONTIG => 2;
16 :     use constant START => 3;
17 :     use constant STOP => 4;
18 :     use constant LEN => 5;
19 :     use constant STRAND => 6;
20 :     use constant CLASS => 7;
21 :     use constant TYPE => 8;
22 :     use constant TAXID => 9;
23 :    
24 :     $peg_offset = 0;
25 :     $rna_offset = 0;
26 :     foreach $key (sort by_locus keys %$new_tbl)
27 :     {
28 :     $trans = "";
29 :     $type = $new_tbl->{$key}->[TYPE];
30 :     $class = $new_tbl->{$key}->[CLASS];
31 :     $locus = $new_tbl->{$key}->[LOCUS];
32 :    
33 :     $action = "";
34 :     if ($old_tbl->{$key})
35 :     {
36 :     die "!!! Tax_ID mismatch" if ($old_tbl->{$key}->[TAXID] ne $old_tbl->{$key}->[TAXID]);
37 :    
38 :     if ($class eq 'changed')
39 :     {
40 :     $old_fid = $new_tbl->{$key}->[FID];
41 :     $old_fid =~ s/changed/fig/;
42 :     $changed{$old_fid} = 1;
43 :    
44 :     $action = 'change';
45 :     }
46 :     elsif ($class eq 'new')
47 :     {
48 :     die "Something is wrong:\n", Dumper($new_tbl->{$key});
49 :     }
50 :     else
51 :     {
52 :     #...Do nothing --- the entry has not changed...
53 :     $action = 'nothing';
54 :     }
55 :     }
56 :     else
57 :     {
58 :     if (($class eq 'new') || ($class eq 'fig'))
59 :     {
60 :     $action = 'add';
61 :     }
62 :     elsif ($class eq 'changed')
63 :     {
64 :     $old_fid = $new_tbl->{$key}->[FID];
65 :     $old_fid =~ s/changed/fig/;
66 :     $changed{$old_fid} = 1;
67 :    
68 :     $action = 'change';
69 :     }
70 :     }
71 :    
72 :     if ($action eq 'nothing')
73 :     {
74 :     next;
75 :     }
76 :     elsif (($action eq 'add') || ($action eq 'change'))
77 :     {
78 :     if ($type eq 'peg')
79 :     {
80 :     $dna = $fig->dna_seq($new_tbl->{$key}->[TAXID], $locus);
81 :     $trans = $fig->translate( $dna, $code, 'start' );
82 :     $trans =~ s/\*$//; #...chop off trailing STOP, if it exists...
83 :     unless (($trans =~ m/^M/) || $fig->possibly_truncated($new_tbl->{$key}->[TAXID], $locus))
84 :     {
85 :     warn "Possible problem with $new_tbl->{$key}->[FID]: codon=", substr($dna, 0, 3), ", AA=", substr($trans, 0, 1), "\n";
86 :     }
87 :    
88 :     if ($trans =~ m/\*/)
89 :     {
90 :     die "Locus $locus contains STOP codons (frameshift?)\n$trans\n";
91 :     }
92 :    
93 :     $token = "$type." . $peg_offset++;
94 :     }
95 :     elsif ($type eq 'rna')
96 :     {
97 :     $token = "$type." . $rna_offset++;
98 :     }
99 :     else
100 :     {
101 :     die "Unknown type:\n", Dumper($new_tbl->{$key});
102 :     }
103 :     }
104 :    
105 :     if ($action eq 'add')
106 :     {
107 :     print "ADD\t$token\t$new_tbl->{$key}->[LOCUS]\t$trans\n";
108 :     }
109 :     elsif ($action eq 'change')
110 :     {
111 :     print "CHANGE\t$old_fid\t$token\t$new_tbl->{$key}->[LOCUS]\t$trans\n";
112 :     }
113 :     else
114 :     {
115 :     die "Unknown action $action";
116 :     }
117 :     }
118 :    
119 :     foreach $key (sort by_locus keys %$old_tbl)
120 :     {
121 :     if (not $new_tbl->{$key})
122 :     {
123 :     if (not $changed{$old_tbl->{$key}->[FID]})
124 :     {
125 :     print "DELETE\t$old_tbl->{$key}->[FID]\n";
126 :     }
127 :     else
128 :     {
129 :     # warn "...Skipping changed $old_tbl->{$key}->[FID]\n";
130 :     }
131 :     }
132 :     }
133 :    
134 :    
135 :    
136 :     sub load_tbl
137 :     {
138 :     my ($file) = @_;
139 :     my ($entry, $id, $locus, $contig, $beg, $end, $len, $strand, $class, $taxid, $type);
140 :    
141 :     open(TBL, "<$file") || die "Could not open $file";
142 :    
143 :     my $tbl = {};
144 :     while (defined($entry = <TBL>))
145 :     {
146 :     chomp $entry;
147 :    
148 :     ($id, $locus) = split /\t/, $entry;
149 :     $id =~ m/^([^\|]+)\|(\d+\.\d+)\.([^\.]+)/;
150 :     ($class, $taxid, $type) = ($1, $2, $3);
151 :    
152 :     if ((($contig, $beg, $end, $len, $strand) = &from_locus($locus))
153 :     && defined($contig) && $contig
154 :     && defined($beg) && $beg
155 :     && defined($end) && $end
156 :     && defined($len) && $len
157 :     && defined($strand) && $strand
158 :     )
159 :     {
160 :     $tbl->{"$contig\t$strand$end"} = [ $id, $locus, $contig, $beg, $end, $len, $strand, $class, $type, $taxid ];
161 :     }
162 :     else
163 :     {
164 :     warn "INVALID ENTRY:\t$entry\n";
165 :     }
166 :     }
167 :    
168 :     return $tbl;
169 :     }
170 :    
171 :     sub from_locus
172 :     {
173 :     my ($locus) = @_;
174 :     my ($contig, $beg, $end);
175 :    
176 :     if ( ($locus =~ m/^([^,]+)_(\d+)_\d+/) && ($contig = $1) && ($beg = $2)
177 :     && ($locus =~ m/[^,]+_\d+_(\d+)$/) && ($end = $1)
178 :     )
179 :     {
180 :     return ($contig, $beg, $end, (1+abs($end-$beg)), (($beg < $end) ? '+' : '-'));
181 :     }
182 :     else
183 :     {
184 :     die "Invalid locus $locus";
185 :     }
186 :    
187 :     return ();
188 :     }
189 :    
190 :     sub by_locus
191 :     {
192 :     my ($x, $a, $b) = @_;
193 :    
194 :     my (undef, undef, $A_contig, $A_beg, $A_end, $A_len, $A_strand) = $x->[$a];
195 :     my (undef, undef, $B_contig, $B_beg, $B_end, $B_len, $B_strand) = $x->[$b];
196 :    
197 :     return ( ($A_contig cmp $B_contig)
198 :     || (&FIG::min($A_beg, $A_end) <=> &FIG::min($B_beg, $B_end))
199 :     || ($B_len <=> $A_len)
200 :     || ($A_strand cmp $B_strand)
201 :     );
202 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3