[Bio] / FigKernelPackages / gjolists.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/gjolists.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : golsen 1.1 #
2 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
3 :     # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 :     #
7 :     # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 :     # Public License.
10 :     #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 :     package gjolists;
19 :    
20 :     # Invoke with:
21 :     #
22 :     # use gjolists;
23 :     #
24 :     # List comparisons:
25 :     #
26 :     # @common = common_prefix( \@list1, \@list2 )
27 :     # @common = common_prefix_n( \@list1, \@list2, ... )
28 :     # ( \@pref, \@suf1, \@suf2 ) = common_and_unique( \@list1, \@list2 )
29 :     # ( \@suf1, \@suf2 ) = unique_suffixes( \@list1, \@list2 )
30 :     #
31 :     # List properties:
32 :     #
33 :     # @unique = unique_set( @list ) # Reduce a list to a set
34 :     # @dups = duplicates( @list )
35 :     #
36 :     # @random = random_order( @list )
37 :     #
38 :     # Set algebra:
39 :     #
40 :     # @A_or_B = union( \@list1, \@list2, ... )
41 :     # @A_and_B = intersection( \@list1, \@list2, ... )
42 :     # @A_not_B = set_difference( \@list1, \@list2 )
43 :    
44 :     require Exporter;
45 :    
46 :     our @ISA = qw(Exporter);
47 :     our @EXPORT_OK = qw(
48 :     common_prefix
49 :     common_prefix_n
50 :     common_and_unique
51 :     unique_suffixes
52 :    
53 :     unique_set
54 :     duplicates
55 :     random_order
56 :    
57 :     union
58 :     intersection
59 :     set_difference
60 :     );
61 :    
62 :     use strict;
63 :    
64 :    
65 :     #-----------------------------------------------------------------------------
66 :     # Return the common prefix of two lists:
67 :     #
68 :     # @common = common_prefix( \@list1, \@list2 )
69 :     #-----------------------------------------------------------------------------
70 :     sub common_prefix {
71 :     my ($l1, $l2) = @_;
72 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
73 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
74 :     my $i = 0;
75 :     my $l1_i;
76 :     while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }
77 :    
78 :     return @$l1[ 0 .. ($i-1) ]; # perl handles negative range
79 :     }
80 :    
81 :    
82 :     #-----------------------------------------------------------------------------
83 :     # Return the common prefix of two or more lists:
84 :     #
85 :     # @common = common_prefix_n( \@list1, \@list2, ... )
86 :     #-----------------------------------------------------------------------------
87 :     sub common_prefix_n {
88 :     my $n = @_;
89 :     $n > 1 || die "common_prefix: requires 2 or more arguments\n";
90 :     for (my $j = 1; $j <= $n; $j++) {
91 :     ref($_[$j-1]) eq "ARRAY" || die "common_prefix_n: arg $j is not an array ref\n";
92 :     }
93 :    
94 :     my $l0 = $_[0];
95 :     my $l0_i;
96 :     my $i;
97 :     for ( $i = 0; defined( $l0_i = $l0->[$i] ); $i++ ) {
98 :     for ( my $j = 1; $j < $n; $j++ ) {
99 :     $l0_i eq $_[$j]->[$i] || ( return @$l0[0 .. ($i-1)] )
100 :     }
101 :     }
102 :    
103 :     return @$l0[ 0 .. ($i-1) ]; # perl handles negative range
104 :     }
105 :    
106 :    
107 :     #-----------------------------------------------------------------------------
108 :     # Return the common prefix and unique suffixes of each of two lists:
109 :     #
110 :     # ( \@prefix, \@suffix1, \@suffix2 ) = common_and_unique( \@list1, \@list2 )
111 :     #-----------------------------------------------------------------------------
112 :     sub common_and_unique {
113 :     my ($l1, $l2) = @_;
114 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
115 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
116 :     my $i = 0;
117 :     my $l1_i;
118 :     while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }
119 :    
120 :     my $len1 = @$l1;
121 :     my $len2 = @$l2;
122 :     return ( [ @$l1[ 0 .. $i-1 ] ] # perl handles negative range
123 :     , [ @$l1[ $i .. $len1-1 ] ]
124 :     , [ @$l2[ $i .. $len2-1 ] ]
125 :     );
126 :     }
127 :    
128 :    
129 :     #-----------------------------------------------------------------------------
130 :     # Return the unique suffixes of each of two lists:
131 :     #
132 :     # ( \@suffix1, \@suffix2 ) = unique_suffixes( \@list1, \@list2 )
133 :     #-----------------------------------------------------------------------------
134 :     sub unique_suffixes {
135 :     my ($l1, $l2) = @_;
136 :     ref($l1) eq "ARRAY" || die "common_prefix: arg 1 is not an array ref\n";
137 :     ref($l2) eq "ARRAY" || die "common_prefix: arg 2 is not an array ref\n";
138 :     my $i = 0;
139 :     my $l1_i;
140 :     while ( defined( $l1_i = $l1->[$i] ) && $l1_i eq $l2->[$i] ) { $i++ }
141 :    
142 :     my $len1 = @$l1;
143 :     my $len2 = @$l2;
144 :     return ( [ @$l1[ $i .. $len1-1 ] ] # perl handles negative range
145 :     , [ @$l2[ $i .. $len2-1 ] ]
146 :     );
147 :     }
148 :    
149 :    
150 :     #-----------------------------------------------------------------------------
151 :     # Reduce a list to its unique elements (stable in order):
152 :     #
153 :     # @unique = unique_set( @list )
154 :     #-----------------------------------------------------------------------------
155 :     sub unique_set {
156 :     my %cnt = ();
157 :     map { ( $cnt{$_} = $cnt{$_} ? $cnt{$_}+1 : 1 ) == 1 ? $_ : () } @_;
158 :     }
159 :    
160 :    
161 :     #-------------------------------------------------------------------------------
162 :     # List of values duplicated in a list (stable in order by second occurance):
163 :     #
164 :     # @dups = duplicates( @list )
165 :     #-------------------------------------------------------------------------------
166 :     sub duplicates {
167 :     my %cnt = ();
168 :     map { ( $cnt{$_} = $cnt{$_} ? $cnt{$_}+1 : 1 ) == 2 ? $_ : () } @_;
169 :     }
170 :    
171 :    
172 :     #-------------------------------------------------------------------------------
173 :     # Randomize the order of a list:
174 :     #
175 :     # @random = random_order( @list )
176 :     #-------------------------------------------------------------------------------
177 :     sub random_order {
178 :     my ( $i, $j );
179 :     for ( $i = @_ - 1; $i > 0; $i-- ) {
180 :     $j = int( ($i+1) * rand() );
181 :     ( $_[$i], $_[$j] ) = ( $_[$j], $_[$i] );
182 :     }
183 :    
184 :     @_
185 :     }
186 :    
187 :    
188 :     #-----------------------------------------------------------------------------
189 :     # Union of two or more sets (by reference):
190 :     #
191 :     # @union = union( \@set1, \@set2, ... )
192 :     #-----------------------------------------------------------------------------
193 :     sub union {
194 :     my %cnt = ();
195 :     foreach (map { @$_ } @_) { $cnt{$_} = 1 };
196 :     keys %cnt;
197 :     }
198 :    
199 :    
200 :     #-----------------------------------------------------------------------------
201 :     # Intersection of two or more sets:
202 :     #
203 :     # @intersection = intersection( \@set1, \@set2, ... )
204 :     #-----------------------------------------------------------------------------
205 :     sub intersection {
206 :     my %cnt = ();
207 :     my $set = shift;
208 :     foreach (@$set) { $cnt{$_} = 1 };
209 :    
210 :     my $n = 1;
211 :     while ($set = shift) {
212 :     $n++;
213 :     foreach (@$set) { if ( exists $cnt{$_} ) { $cnt{$_} = $n } } # mark
214 :     delete @cnt{ map { $cnt{$_} != $n ? $_ : () } keys %cnt } # not seen?
215 :     }
216 :     keys %cnt;
217 :     }
218 :    
219 :    
220 :     #-----------------------------------------------------------------------------
221 :     # Elements in set 1, but not set 2:
222 :     #
223 :     # @difference = set_difference( \@set1, \@set2 )
224 :     #-----------------------------------------------------------------------------
225 :     sub set_difference {
226 :     my ($set1, $set2) = @_;
227 :     my %cnt = ();
228 :     foreach (@$set2) { $cnt{$_} = 1 };
229 :     map { exists $cnt{$_} ? () : $_ } @$set1;
230 :     }
231 :    
232 :    
233 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3