annotate TFBScluster_candidates.pl @ 3:856008c4a5f3 draft default tip

Version 1.0.2 (updates bioperl to 1.7.2)
author pjbriggs
date Fri, 05 Oct 2018 05:33:31 -0400
parents 2f48cf393d25
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
2
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
1 #!/usr/bin/perl
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
2
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
3 # TFBScluster version 2.0 - cluster together TFBSs from distinct
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
4 # TFBSsearch generated libraries.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
5 #
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
6 # (c) Ian Donaldson 2003 and Mike Chapman (TFBS overlap subs)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
7 #
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
8 # This program is free software; you can redistribute it and/or
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
9 # modify it under the terms of the GNU General Public License
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
10 # as published by the Free Software Foundation; either version 2
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
11 # of the License, or (at your option) any later version.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
12 #
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
13 # This program is distributed in the hope that it will be useful,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
16 # GNU General Public License for more details.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
17 #
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
18 # You should have received a copy of the GNU General Public License
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
19 # along with this program; if not, write to the Free Software
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
20 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
21
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
22 use strict;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
23 use FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
24 #use integer; # Force floating point into integers
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
25
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
26 $|=1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
27
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
28 ###########
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
29 # Program to determine whether a TF site is in close proximity to
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
30 # one or more other TF sites.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
31 # September 2003. Ian Donaldson.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
32 # Revised 8 Sept. 2003 to not include the query TF site in the threshold.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
33 # This is to allow one to determine whether a TF is near to another of the
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
34 # same type.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
35 # Revised 9 Sept to alter the threshold size to only include the core of a
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
36 # pattern i.e. gata of nngatann.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
37 # Revised 19 Sept to replace query and subject libraries with the statement
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
38 # of all interested libraries.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
39 # Revised 22 Sept to scan output for overlapping patterns.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
40 # NOTE: Any overlap in comparative record start with start pattern
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
41 # Revised 30 Sept to ignore duplication of TFBS in a group record caused by
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
42 # palindrome. By skipping if name and positions the same.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
43 # Revised 6 Oct code for tree searching method to deal with overlapping TFBSs
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
44 ###########
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
45
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
46 #### Command line usage
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
47 if(@ARGV != 7)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
48 {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
49 die ("USAGE:
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
50 $0
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
51 TF libraries \(comma delimited NO SPACES\)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
52 Number of flanking 'N's for subject files \(comma delimited NO SPACES\)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
53 Minimum number of occurences \(comma delimited NO SPACES\)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
54 TF IDs \(comma delimited NO SPACES\)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
55 Single range value in bp \(+/-\) query start and end values
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
56 Include overlapping TFBSs \(include/exclude\)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
57 Output file\n\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
58 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
59
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
60 #### File handles
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
61 my $subject = new FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
62 my $combined = new FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
63 my $sorted = new FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
64 my $groups = new FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
65 my $filtered_groups = new FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
66 my $output = new FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
67 my $output2 = new FileHandle;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
68
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
69 #### Variables
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
70 my @subject_files = (); # Array containing the names of selected subject files
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
71 my @flanking_n = (); # Array containing the number of flanking 'n' for each pattern
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
72 my @min_occur = (); # Array containing the minimum occurences for the TF library
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
73 my @ids = (); # Array containing user defined IDs for the TF libraries
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
74 my @file_sizes = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
75 my @sorted_file_sizes = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
76 my $range = $ARGV[4];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
77 my $allow = $ARGV[5];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
78 my @regex_ids = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
79
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
80 #####################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
81 #### Deal with user arguments processed into an array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
82 #####################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
83
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
84 #### Convert TF file names string to an array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
85 @subject_files = split(/,/, $ARGV[0]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
86
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
87 #### Convert flanking 'N' numbers string into an array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
88 @flanking_n = split(/,/, $ARGV[1]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
89
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
90 #### Convert minimum occurences string into an array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
91 @min_occur = split(/,/, $ARGV[2]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
92
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
93 #### Convert minimum occurences string into an array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
94 @ids = split(/,/, $ARGV[3]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
95
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
96 foreach my $id_string (@ids) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
97 if($id_string !~ /^[\w\d_,]+$/) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
98 die("A non-letter/number character was detected in your label string!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
99 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
100 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
101
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
102 #### Record how large they are
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
103 for(my $i=0; $i < $#subject_files + 1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
104 my $size = (-s $subject_files[$i]); # -s performed on an unopened file!
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
105
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
106 push(@file_sizes, ["$subject_files[$i]", "$size", "$flanking_n[$i]", "$min_occur[$i]", "$ids[$i]"]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
107 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
108
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
109 #### Sort file sizes array by file sizes
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
110 # ARRAY NOT SORTED BUT COPIED TO ALLOW SORTING AT A LATER DATE
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
111 # @sorted_file_sizes = sort{$a->[1] <=> $b->[1]} @file_sizes;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
112 push(@sorted_file_sizes, @file_sizes);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
113
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
114 #### Summary file information
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
115 print STDOUT "TFBScluster analysis:\n",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
116 "--------------------\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
117
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
118 print STDOUT "TFBS library information:\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
119
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
120 #### Show file summary
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
121 for(my $i=0; $i < $#sorted_file_sizes + 1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
122 print STDOUT "TFBS lib. ID = $sorted_file_sizes[$i][4].\n",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
123 "Extended conservation = $sorted_file_sizes[$i][2].\n",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
124 "Minimum occurrence = $sorted_file_sizes[$i][3].\n\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
125 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
126
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
127 #print STDOUT "\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
128
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
129
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
130 #####################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
131 #### Information required by tree searching algorithm
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
132 #####################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
133
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
134 #### Array containing the minimum number of each TF, also corresp names
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
135 my @tf_min = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
136 my @tf_names = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
137
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
138 for(my $i=0; $i < $#sorted_file_sizes + 1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
139 push(@tf_min, $sorted_file_sizes[$i][3]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
140 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
141
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
142 for(my $i=0; $i < $#sorted_file_sizes + 1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
143 push(@tf_names, $sorted_file_sizes[$i][4]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
144 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
145
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
146 #### TEST
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
147 #print "ARRAY1 = @tf_min\n\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
148
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
149 #####################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
150 #### Open a file to store all the TF data from each selected library.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
151 #####################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
152 $combined->open(">TFcombined\.$$") or die("Could not open TFcombined file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
153
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
154 #### Copy each TF file to another file and sort it.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
155 for(my $i=0; $i < $#sorted_file_sizes + 1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
156 #### Save necessary parts of the current subject file to chr. specific arrays
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
157 $subject->open("<$sorted_file_sizes[$i][0]") or die("Could not open subject file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
158
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
159 #### Message to user
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
160 #print "Adding data for TF file $i\.\t";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
161
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
162 SUBLINE: while(defined(my $sub_line = <$subject>)) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
163 my ($sub_seqname, $sub_source, $sub_feature, $sub_start, $sub_end, $sub_score,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
164 $sub_strand, $sub_frame, $sub_attribute) = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
165
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
166 #### Skip line if GFF comment or blank line
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
167 if($sub_line =~ /(^\s|^#)/)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
168 {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
169 next SUBLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
170 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
171
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
172 #### Split each line by TAB
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
173 ($sub_seqname, $sub_source, $sub_feature, $sub_start, $sub_end, $sub_score,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
174 $sub_strand, $sub_frame, $sub_attribute) = split(/\t/, $sub_line, 9);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
175
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
176 #### Clean up attribute
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
177 #($sub_attribute) = $sub_attribute =~ /[ACTG\-]+/g;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
178 chomp($sub_attribute);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
179
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
180 #### Adjust thresold of subject positions to reflect the core sequence
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
181 #### Possibly make an argument?!
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
182 $sub_start = $sub_start + $sorted_file_sizes[$i][2];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
183 $sub_end = $sub_end - $sorted_file_sizes[$i][2];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
184
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
185 #### Determine chromosome
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
186 (my $sub_chr) = $sub_seqname;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
187
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
188 #### Add modified line to analysis library file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
189 $combined->print("$sub_seqname\t$sub_source\t$sub_feature\t$sub_start\t$sub_end\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
190 "$sub_score\t$sub_strand\t$sub_frame\t$sorted_file_sizes[$i][4]\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
191 # "$sub_score\t$sub_strand\t$sub_frame\t$sub_attribute",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
192 # "\_\_$sorted_file_sizes[$i][4]\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
193 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
194
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
195 #### Message
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
196 #print STDOUT "\[DONE\]\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
197
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
198 $subject->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
199 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
200
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
201 #### Spacer on screen
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
202 #print STDOUT "\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
203
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
204 $combined->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
205
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
206
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
207 #############################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
208 #### Sort the TFcombined file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
209 #############################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
210 #print STDOUT "Sorting TFcombined file.\t";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
211
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
212 #system("sort +0.3 -0.5 +3n -4n TFcombined\.$$ > TFcombined_sorted_temp\.$$");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
213 system("sort +0 -1 +3n -4n TFcombined\.$$ > TFcombined_sorted\.$$");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
214
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
215 #print "HELLO\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
216
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
217 ###################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
218 #### Convert all chr01 back to chr1
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
219 ###################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
220 #system("/home/donaldson/bin/TFBScluster/nozero_before_1-9.pl TFcombined_sorted_temp\.$$ TFcombined_sorted\.$$");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
221
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
222 #print STDOUT "\[DONE\]\n\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
223
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
224
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
225 #####################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
226 #### Sort the sorted file into groups
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
227 #####################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
228 #### Work thru each line of the combined TF file. Store record of all TFs downstream
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
229 #### WITHIN the predefined distance
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
230 #print STDOUT "Organising the sorted file into groups.\t";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
231
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
232 my $last = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
233
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
234 $sorted->open("<TFcombined_sorted\.$$") or die("Could not open sorted TFcombined file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
235
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
236 #### Rewind combined TF file to start
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
237 seek($sorted, 0, 0);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
238
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
239 COMBLINE: while(defined(my $comb_line = <$sorted>)) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
240 #### Get info about the line
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
241 my @comb_line_array = split(/\t/, $comb_line);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
242 my $comb_seqname = $comb_line_array[0];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
243 (my $comb_chr) = $comb_seqname;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
244
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
245 my $comb_start = $comb_line_array[3];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
246
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
247 #### Store the start of the next line
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
248 my $next_line_pos = tell($sorted);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
249
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
250 #### Variable to hold lines
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
251 my $group_holder = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
252
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
253 $group_holder = $comb_line;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
254
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
255 #### Read thru the next lines until the end position is not within the specified
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
256 #### range of the start line start
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
257 my $count_hit = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
258
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
259 GROUPLINE: while(defined(my $group_line = <$sorted>)) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
260 my @group_line_array = split(/\t/, $group_line);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
261 my $group_seqname = $group_line_array[0];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
262 (my $group_chr) = $group_seqname;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
263
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
264 my $group_end = $group_line_array[4];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
265
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
266 #### CHR
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
267 #if( (($group_end - $comb_start + 1) < $range ) and ($comb_chr eq $group_chr) ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
268 if( (($group_end - $comb_start + 1) <= $range ) and ($comb_chr eq $group_chr) ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
269 $group_holder .= $group_line;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
270 $count_hit++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
271 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
272
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
273 else {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
274 last GROUPLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
275 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
276 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
277
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
278 if($count_hit > 0) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
279 #Make the record
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
280 $groups->open(">>TFgroups\.$$") or die("Could not open TF groups file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
281
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
282 $groups->print("$group_holder\/\/\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
283
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
284 $groups->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
285
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
286 #### Move to the end of the last line
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
287 seek($sorted, $next_line_pos , 0);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
288
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
289 next COMBLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
290 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
291
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
292 else {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
293 #### Move to the end of the last line
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
294 seek($sorted, $next_line_pos , 0);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
295
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
296 next COMBLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
297 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
298 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
299
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
300 $sorted->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
301
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
302 #print STDOUT "\[DONE\]\n\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
303
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
304
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
305 ###################################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
306 #### Look through the groups file to find records matching the user defined params
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
307 ###################################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
308 my $record = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
309 my $target = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
310 my $count_pass = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
311
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
312 #### Another user message
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
313 print STDOUT "You have chosen to search for groups containing at least:\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
314
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
315 for(my $i=0; $i < $#sorted_file_sizes + 1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
316 print STDOUT "$sorted_file_sizes[$i][3] $sorted_file_sizes[$i][4] site(s).\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
317
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
318 #### Increment the desired number of matches for a group to be selected
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
319 $target++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
320 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
321
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
322 #### Another user message
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
323 #print STDOUT "\nOutput will be written to \[$ARGV[6]\].\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
324 print STDOUT "\nCombining overlapping clusters:\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
325
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
326 #### Open an output file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
327 $output->open(">$ARGV[6]\_v1") or die("Could not open output file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
328
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
329 #### Open the TFgroups files
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
330 $groups->open("<TFgroups\.$$") or die("Could not open TFgroups file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
331
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
332 #### Open the filtered record test file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
333 $filtered_groups->open(">filtered_groups\.$$") or die("Could not open filtered groups file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
334
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
335 #### Take each record of the groups file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
336 RECORD: while($record = GetNewRecord($groups)) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
337 #### What about if the positions overlap?
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
338 my @record_array = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
339 my $last_record_start = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
340 my $last_record_end = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
341 my $last_record_attribute = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
342
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
343 my $save_filtered_group = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
344
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
345 #### Take each line of the record beginning with chr...
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
346 RECORDLINE: while($record =~ /(\w.+\n)/mg) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
347 my $record_line = $1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
348
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
349 my @record_line_array = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
350 @record_line_array = split(/\t/, $record_line);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
351
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
352 my $record_seqname = $record_line_array[0];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
353 my $record_start = $record_line_array[3];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
354 my $record_end = $record_line_array[4];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
355 my $record_strand = $record_line_array[6];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
356 my $record_attribute = $record_line_array[8];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
357 chomp($record_attribute);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
358
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
359 #print "$record_seqname\t$record_start\t$record_end\t$record_strand\t$record_attribute\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
360 #exit;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
361
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
362 #### If the last motif exactly overlaps and is same ID - skip adding to array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
363 if( ($record_start == $last_record_start) and
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
364 ($record_end == $last_record_end) and
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
365 ($record_attribute eq $last_record_attribute) ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
366
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
367 $last_record_start = $record_start;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
368 $last_record_end = $record_end;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
369 $last_record_attribute = $record_attribute;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
370
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
371 next RECORDLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
372 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
373
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
374 $last_record_start = $record_start;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
375 $last_record_end = $record_end;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
376 $last_record_attribute = $record_attribute;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
377
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
378 #### File 2D array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
379 push(@record_array, ["$record_seqname", "$record_start", "$record_end", "$record_strand", "$record_attribute"]);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
380
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
381 #### Test file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
382 $save_filtered_group .= "$record_seqname\t$record_start\t$record_end\t$record_strand\t$record_attribute\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
383 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
384
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
385 #### Test file record marker
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
386 $save_filtered_group .= "//\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
387
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
388 ######################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
389 #### Make sure the record contains the minimum number of specified TFs
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
390 ######################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
391
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
392 #### Counter to see whether all params matched
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
393 my $pass = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
394 @regex_ids = (); # Array to hold regexs as they are used
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
395 my @regex_totals = (); # Array to hold info on regex totals in the record
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
396
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
397 #### Work thru each of the input parameter lists
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
398 for(my $i=0; $i < $#sorted_file_sizes + 1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
399 #### Site name for regex
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
400 my $regex = $sorted_file_sizes[$i][4];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
401
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
402 push(@regex_ids, $regex);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
403
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
404 #### Min number of hits for regex
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
405 my $min_regex = $sorted_file_sizes[$i][3];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
406
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
407 #### Search for current regex and tally
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
408 my $regex_hits = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
409
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
410 #### Work thru each of the non-repeating record lines array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
411 for(my $k=0; $k < $#record_array + 1; $k++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
412 my $line_regex = $record_array[$k][4];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
413
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
414 if($regex eq $line_regex) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
415 $regex_hits++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
416 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
417 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
418
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
419 #### Were the min number of regex hits found?
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
420 if($regex_hits >= $min_regex) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
421 $pass++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
422 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
423 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
424
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
425 #####################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
426 #### If there are the minimum number of TFBS then check they are not
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
427 #### sufficiently overlapping to reduce the numbers below the minimum
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
428 #####################################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
429 my $good_cluster = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
430
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
431 if($pass == $target) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
432 #### Test file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
433 $filtered_groups->print("$save_filtered_group");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
434
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
435 # Declarations
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
436 my ($end);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
437 my (@starts, @ends, @choices);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
438
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
439 # Assign start and end positions
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
440
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
441 grep { $starts[$_] = $record_array[$_][1]; $ends[$_] = $record_array[$_][2] }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
442 (0 .. $#record_array);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
443
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
444 $end = -1; # First choice does not refer to a transcription factor
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
445
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
446 # Loop through all transcription factors
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
447
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
448 I_LOOP:
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
449 for my $i (0 .. @starts) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
450 my $next_factor = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
451
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
452 # Now loop through all possible following transcription factors
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
453 # Note that $starts[0] and @ends[0] refer to the first transcription factor
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
454 # whereas $choices[1] will refer to the first transcription factor.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
455
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
456 for my $j ( $i .. $#starts) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
457 if ($starts[$j] > $end) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
458 $next_factor = ($j + 1);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
459 last;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
460 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
461 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
462
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
463 push @{ $choices[$i] }, $next_factor;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
464
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
465 # If no factor follows, we have a terminating factor and progress to the next.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
466 # Must first modify $end to be the end of the next transcription factor.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
467
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
468 unless ($next_factor) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
469 $end = $ends[$i];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
470 next I_LOOP;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
471 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
472
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
473 # Now need to check the factors overlapping with $next_factor and add them
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
474 # as possibilities. Note that in some circumstances, this may result in a
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
475 # redundant path. This will not give spurious results, however.
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
476
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
477 for my $k ( $next_factor .. $#starts ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
478 if ($starts[$k] <= $ends[$next_factor - 1]) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
479 push @{ $choices[$i] }, ($k + 1);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
480 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
481 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
482
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
483 # Finally, modify $end to be the end of the next transcription factor
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
484
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
485 $end = $ends[$i];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
486
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
487 # And go to next loop
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
488 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
489
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
490
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
491 #### Print out @choices array to file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
492 foreach (@choices) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
493 $filtered_groups->print("@{ $_ } \n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
494 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
495
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
496 $filtered_groups->print("//\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
497
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
498
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
499 #####################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
500 #### Information required by tree searching algorithm
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
501 #### Only for records that contain min number of TFBS
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
502 #####################################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
503
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
504 #### Array relating each TF to their minimum values
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
505 my @tf_relate = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
506
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
507 #$tf_relate[0] = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
508
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
509 #### Get TF ID for current record
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
510 for(my $i=0; $i < $#record_array+1; $i++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
511 #my $next_i = $i + 1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
512
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
513 my $current_attrib = $record_array[$i][4];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
514
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
515 #### Scan @sorted_files_sizes array for matching TF ID and save
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
516 #### row number. This will relate directly to @tf_min
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
517 for(my $f=0; $f < $#sorted_file_sizes + 1; $f++) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
518
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
519 if($current_attrib =~ /$sorted_file_sizes[$f][4]/) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
520 #$tf_relate[$next_i] = "$f";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
521 $tf_relate[$i] = "$f";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
522 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
523 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
524 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
525
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
526 #### TEST
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
527 # print "ARRAY2 = @tf_relate\n\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
528 # for(0..$#tf_relate) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
529 # print "[$_] $tf_relate[$_]\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
530 # }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
531
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
532 #### DUMMY ARRAYS
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
533 #@choices = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
534 #@choices = (
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
535 # [ 1,2,3 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
536 # [ 4,5,6 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
537 # [ 4,5,6 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
538 # [ 4,5,6 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
539 # [ 7 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
540 # [ 7 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
541 # [ 7 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
542 # [ 8,9,10 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
543 # [ 0 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
544 # [ 0 ],
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
545 # [ 0 ]
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
546 # );
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
547
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
548 #@tf_min = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
549 #@tf_min = ( 3, 1, 1);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
550
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
551 #@tf_relate = ();
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
552 #@tf_relate = (0,0,0,1,1,1,2,2,2,2);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
553
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
554
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
555
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
556 #### References for test_cluster sub
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
557 my $choices_to_pass = \@choices; #### Tree decisions
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
558 my $required_to_pass = \@tf_min; #### Min TFBS numbers
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
559 my $order = \@tf_relate; #### Relate TFBSs to min numbers
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
560
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
561
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
562 ########################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
563 #### Run tree searching algorithm (Mike)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
564 ########################################
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
565 if($allow eq 'exclude') {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
566 #$good_cluster = tf_cluster_tree($choices_to_pass, $required_to_pass, $order);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
567 $good_cluster = tf_cluster_tree(\@choices, \@tf_min, \@tf_relate);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
568
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
569 #print "GOODCLUSTER = $good_cluster\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
570 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
571
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
572 else {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
573 $good_cluster = 1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
574 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
575 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
576
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
577
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
578 #### If all parameters are matched create a summary of the record
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
579 #### Work thru each line of the record string start end and TF ID to an array
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
580
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
581 #### Carry on if overlapping not a problem ####
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
582 if( ($pass == $target) and ($good_cluster == 1) ){
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
583 my $regex_chr = $record_array[0][0];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
584 my $regex_start = $record_array[0][1];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
585 my $regex_end = $record_array[$#record_array][2];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
586 my $joined_ids = join("-", @regex_ids);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
587
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
588 $output->print("$regex_chr\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
589 "TFBScluster\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
590 "CNS\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
591 "$regex_start\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
592 "$regex_end\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
593 ".\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
594 "+\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
595 ".\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
596 "$joined_ids\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
597 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
598 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
599
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
600 $groups->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
601 $filtered_groups->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
602 $output->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
603
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
604 #### Space on screen
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
605 #print STDOUT "\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
606
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
607 #### Read each line of output file and combine lines that overlap
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
608 my $version = 1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
609
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
610 #### Remain in loop until last command given
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
611 while(1) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
612 my $last_seqname = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
613 my $last_chr = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
614 my $last_start = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
615 my $last_end = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
616 my $changes = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
617 my $outline_count = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
618
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
619 my ($out_seqname, $out_source, $out_feature, $out_start, $out_end, $out_score,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
620 $out_strand, $out_frame, $out_attribute, $out_chr) = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
621
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
622 $output->open("<$ARGV[6]\_v$version") or die("Could not open output file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
623
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
624 #### If the output file is empty then exit loop and finish
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
625 if(-z $output) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
626 $output->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
627
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
628 system("rm $ARGV[6]\_v$version");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
629
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
630 exit;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
631 #die("\nNo clusters were found!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
632 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
633
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
634 $version++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
635
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
636 $output2->open(">$ARGV[6]\_v$version") or die("Could not open output2 file!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
637
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
638 OUTLINE: while(defined(my $out_line = <$output>)) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
639 #### Skip line if GFF comment or blank line
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
640 if($out_line =~ /^\s/)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
641 {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
642 next OUTLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
643 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
644
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
645 #### Tally lines read
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
646 $outline_count++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
647
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
648 ($out_seqname, $out_source, $out_feature, $out_start, $out_end, $out_score,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
649 $out_strand, $out_frame, $out_attribute) = split(/\t/, $out_line, 9);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
650
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
651 $out_chr = $out_seqname;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
652
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
653 #### Handle the first line
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
654 if($outline_count == 1) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
655 $last_seqname = $out_seqname;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
656 $last_chr = $out_chr;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
657 $last_start = $out_start;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
658 $last_end = $out_end;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
659
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
660 next OUTLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
661 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
662
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
663 #### Remaining lines
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
664
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
665 #### If the patterns are on different chromosomes
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
666 #### CHR
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
667 if($last_chr ne $out_chr) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
668 #### Print the last line to the file and save the current
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
669 $output2->print("$last_seqname\t$out_source\t$out_feature\t$last_start\t$last_end\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
670 "$out_score\t$out_strand\t$out_frame\t$out_attribute");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
671
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
672 $last_seqname = $out_seqname;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
673 $last_chr = $out_chr;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
674 $last_start = $out_start;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
675 $last_end = $out_end;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
676
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
677 next OUTLINE;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
678 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
679
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
680 #### If they overlap change current line start to the previous
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
681 if( ($last_end > $out_start) and ($last_end <= $out_end) ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
682 $last_end = $out_end;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
683
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
684 #### Record the number of changes
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
685 $changes++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
686 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
687
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
688 #### If not just print to output
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
689 else {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
690 $output2->print("$last_seqname\t$out_source\t$out_feature\t$last_start\t$last_end\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
691 "$out_score\t$out_strand\t$out_frame\t$out_attribute");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
692
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
693 $last_seqname = $out_seqname;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
694 $last_chr = $out_chr;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
695 $last_start = $out_start;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
696 $last_end = $out_end;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
697 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
698 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
699
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
700 #### Print last line to outfile
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
701 $output2->print("$last_seqname\t$out_source\t$out_feature\t$last_start\t$last_end\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
702 "$out_score\t$out_strand\t$out_frame\t$out_attribute");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
703
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
704 #### Message
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
705 my $previous = $version - 1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
706
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
707 print STDOUT "Records in output file version $previous \($outline_count patterns\).\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
708
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
709
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
710 $output->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
711 $output2->close;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
712
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
713 if($changes == 0) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
714 my $joined_ids = join("-", @regex_ids);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
715 #### Copy last version to file name without v number
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
716 #system("cp $ARGV[6]\_v$version $ARGV[6]");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
717
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
718 #### Open final output file and convert the attribute
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
719 open(FINAL_VER, "<$ARGV[6]\_v$version") or die("Could not open final ver GFF!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
720 open(FINAL, ">$ARGV[6]") or die("Could not open final GFF!\n");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
721
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
722 while(defined(my $final_line = <FINAL_VER>)) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
723
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
724 my ($final_seqname, $final_source, $final_feature, $final_start, $final_end,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
725 $final_score, $final_strand, $final_frame, $final_attribute) =
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
726 split(/\t/, $final_line, 9);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
727
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
728 my $pattern_length = ($final_end - $final_start) + 1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
729
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
730 print FINAL "$final_seqname\t$final_source\t$final_feature\t$final_start\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
731 "$final_end\t$final_score\t$final_strand\t$final_frame\t",
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
732 "$joined_ids\_len$pattern_length\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
733
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
734 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
735
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
736 close(FINAL_VER);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
737 close(FINAL);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
738
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
739 last;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
740 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
741 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
742
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
743 #### Spacer for summary file
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
744 print STDOUT "\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
745
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
746 #### Remove intermediate files
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
747 system("rm ./TFcombined\.$$ ./TFcombined_sorted\.$$ ./TFgroups\.$$ ./filtered_groups\.$$ $ARGV[6]\_v*");
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
748
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
749 exit;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
750
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
751
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
752 ############
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
753 #Subroutines
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
754 ############
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
755 sub GetNewRecord
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
756 # Load record from a library file, delimited by //
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
757 {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
758 my $fh = shift (@_);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
759 my $record = '';
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
760 my $saveinputsep = $/;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
761 $/ = "//\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
762
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
763 $record = <$fh>;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
764
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
765 $/ = $saveinputsep;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
766 return $record;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
767 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
768
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
769 sub tf_cluster_tree {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
770
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
771 my @path;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
772 my $node_count;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
773 my $node = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
774 my $success = 0;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
775 my $choice = -1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
776 my @node_contains;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
777 my @node_to_choice;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
778 my @count;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
779 my @branches;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
780 $branches[0] = -1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
781 my $path_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
782 my $branch_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
783 my $node_contains;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
784 my $node_to_choice;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
785 my ($choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
786 $required_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
787 $tf_ref) = @_;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
788 my @choices = @$choice_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
789 my @required = @$required_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
790 my @tfs = @$tf_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
791 ($node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
792 $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
793 $node_count,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
794 $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
795 $path_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
796 $branch_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
797 $node_to_choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
798 $node_contains) = next_node ($node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
799 $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
800 $node_count,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
801 $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
802 \@path,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
803 \@branches,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
804 $tf_ref);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
805 @choices = @$choice_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
806 @path = @$path_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
807 @branches = @$branch_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
808 $node_contains[$node] = $node_contains;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
809 $node_to_choice[$node] = $node_to_choice;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
810
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
811 BLOCK_A:
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
812
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
813 while (1) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
814 no strict "vars";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
815
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
816 if ( node_terminating($choice, $choice_ref) ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
817 push @path, $node;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
818 @count = undef;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
819 grep { $count[ $node_contains[$_] ]++ } @path;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
820 #print "Count is @count.\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
821 my $score = grep { $count[$_] >= $required[$_] }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
822 (0 .. $#count);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
823 #print "Path is @path\n";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
824 if ($score == scalar @required) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
825 $success = 1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
826 last BLOCK_A;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
827 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
828 pop @path;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
829 ($node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
830 $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
831 $path_ref)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
832 = last_unexplored_node(\@path, $choice, $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
833 \@node_to_choice, \@branches);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
834 last BLOCK_A if ($node == -1);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
835 @path = @$path_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
836 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
837 if ( node_fully_explored($choice, $node, $choice_ref, \@branches) ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
838 ($node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
839 $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
840 $path_ref)
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
841 = last_unexplored_node(\@path, $choice, $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
842 \@node_to_choice, \@branches);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
843 @path = @$path_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
844 last BLOCK_A if ($node == -1);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
845 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
846 ($node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
847 $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
848 $node_count,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
849 $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
850 $path_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
851 $branch_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
852 $node_to_choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
853 $node_contains,) = next_node ($node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
854 $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
855 $node_count,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
856 $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
857 \@path,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
858 \@branches,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
859 $tf_ref);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
860 @choices = @$choice_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
861 @path = @$path_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
862 @branches = @$branch_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
863 $node_contains[$node] = $node_contains;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
864 $node_to_choice[$node] = $node_to_choice;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
865 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
866 return $success;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
867 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
868
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
869
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
870 sub next_node {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
871
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
872 my ($node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
873 my $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
874 my $node_count,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
875 my $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
876 my $path_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
877 my $branch_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
878 my $tf_ref) = @_;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
879 my @choices = @$choice_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
880 my @path = @$path_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
881 my @branches = @$branch_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
882 my @tfs = @$tf_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
883 my $new_choice = $choices[$choice][0];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
884 push @{ $choices[$choice] }, shift @{ $choices[$choice] };
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
885 $choice = $new_choice;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
886 my $node_to_choice = $choice;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
887 push @path, $node if $node;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
888 $branches[$node]++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
889 $node = $node_count++;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
890 my $node_contains = $tfs[$choice - 1] if $choice;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
891 return (
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
892 $node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
893 $choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
894 $node_count,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
895 \@choices,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
896 \@path,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
897 \@branches,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
898 $node_to_choice,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
899 $node_contains);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
900 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
901
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
902 sub node_fully_explored {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
903 no strict "vars";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
904
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
905 my $choice = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
906 my $node = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
907 my $choices_ref = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
908 my $branch_ref = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
909 my @choices = @$choices_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
910 my @branches = @$branch_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
911 if ($branches[$node] == (scalar @{ $choices[$choice] })) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
912 return 1 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
913 else { return 0 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
914 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
915
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
916 sub last_unexplored_node {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
917 no strict "vars";
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
918
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
919 my $path_ref = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
920 my $choice = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
921 my $choice_ref = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
922 my $node_to_choice_ref = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
923 my $branch_ref = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
924 my @path = @$path_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
925 my @node_to_choice = @$node_to_choice_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
926 my @branches = @$branch_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
927 my $node;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
928
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
929 do {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
930 $node = pop @path;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
931 $choice = $node_to_choice[$node];
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
932 if ( $node == 0 and node_fully_explored($choice, $node,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
933 $choice_ref, \@branches) ) {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
934 $node = -1;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
935 last;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
936 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
937 } while ( node_fully_explored($choice, $node, $choice_ref,
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
938 \@branches) );
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
939 return ($node, $choice, \@path);
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
940 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
941
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
942 sub node_terminating {
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
943
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
944 my $choice = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
945 my $choices_ref = shift;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
946 my @choices = @$choices_ref;
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
947 if ($choices[$choice][0]) { return 0 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
948 else { return 1 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
949
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
950 }
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
951
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
952
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
953
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
954
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
955
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
956
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
957
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
958
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
959
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
960
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
961
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
962
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
963
2f48cf393d25 Add Perl scripts missing from previous upload.
pjbriggs
parents:
diff changeset
964