Skip to content

Commit 030e794

Browse files
ngthomasngthomas
committed
pack hapture w/ more additional perl modules s.t. it reduce users burden to cpan perl mod. Add Perl version guard on runHaplot
1 parent 02c13aa commit 030e794

File tree

100 files changed

+38732
-2010
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

100 files changed

+38732
-2010
lines changed

‎.Rbuildignore‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,3 +5,5 @@
55
^\.Rproj\.user$
66
^cran-comments\.md$
77
^LICENSE\.md$
8+
^inst/perl/fatlib/*$
9+
^inst/perl/fatpacker\.trace$

‎DESCRIPTION‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,5 @@ BugReports: https://github.com/ngthomas/microhaplot/issues
2828
RoxygenNote: 6.1.1
2929
Suggests:
3030
knitr,
31-
rmarkdown,
32-
testthat
31+
rmarkdown
3332
VignetteBuilder: knitr

‎R/runHaplot.R‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -93,12 +93,15 @@ prepHaplotFiles <- function(run.label, sam.path, label.path, vcf.path,
9393
tryCatch({system("perl -v", intern=T); message("Perl is found in system")},
9494
error= function(d) {
9595
if(.Platform$OS.type == "windows") {
96-
message("Perl is not found in system. Recommend installation from strawberryperl. Be sure to install version >5.014")
96+
message("Perl is not found in system. Recommend installation from strawberryperl. Be sure to install version >=5.014")
9797
}else {
98-
message("Perl is not found in system. Recommend Installation from perl.org. Be sure to install version >5.014")
98+
message("Perl is not found in system. Recommend Installation from perl.org. Be sure to install version >=5.014")
9999
}
100100
})
101101

102+
# ensure that the perl's version is at least 5.014
103+
perl.version <- system("perl -e 'print $];'", intern=T) %>% as.numeric
104+
if(perl.version < 5.014) stop ("The version Perl found in your current system is old-dated/incompatible. Microhaplot requires Perl v. >=5.014.")
102105

103106
# the perl script hapture should display any warning if the label field contains any missing or invalid elements
104107

‎inst/perl/fatlib/Algorithm/C3.pm‎

Lines changed: 339 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,339 @@
1+
2+
package Algorithm::C3;
3+
4+
use strict;
5+
use warnings;
6+
7+
use Carp 'confess';
8+
9+
our $VERSION = '0.10';
10+
11+
sub merge {
12+
my ($root, $parent_fetcher, $cache) = @_;
13+
14+
$cache ||= {};
15+
16+
my @STACK; # stack for simulating recursion
17+
18+
my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
19+
20+
unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
21+
confess "Could not find method $parent_fetcher in $root";
22+
}
23+
24+
my $current_root = $root;
25+
my $current_parents = [ $root->$parent_fetcher ];
26+
my $recurse_mergeout = [];
27+
my $i = 0;
28+
my %seen = ( $root => 1 );
29+
30+
my ($new_root, $mergeout, %tails);
31+
while(1) {
32+
if($i < @$current_parents) {
33+
$new_root = $current_parents->[$i++];
34+
35+
if($seen{$new_root}) {
36+
my @isastack;
37+
my $reached;
38+
for(my $i = 0; $i < $#STACK; $i += 4) {
39+
if($reached || ($reached = ($STACK[$i] eq $new_root))) {
40+
push(@isastack, $STACK[$i]);
41+
}
42+
}
43+
my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
44+
die "Infinite loop detected in parents of '$root': $isastack";
45+
}
46+
$seen{$new_root} = 1;
47+
48+
unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
49+
confess "Could not find method $parent_fetcher in $new_root";
50+
}
51+
52+
push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
53+
54+
$current_root = $new_root;
55+
$current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
56+
$recurse_mergeout = [];
57+
$i = 0;
58+
next;
59+
}
60+
61+
$seen{$current_root} = 0;
62+
63+
$mergeout = $cache->{merge}->{$current_root} ||= do {
64+
65+
# This do-block is the code formerly known as the function
66+
# that was a perl-port of the python code at
67+
# http://www.python.org/2.3/mro.html :)
68+
69+
# Initial set (make sure everything is copied - it will be modded)
70+
my @seqs = map { [@$_] } @$recurse_mergeout;
71+
push(@seqs, [@$current_parents]) if @$current_parents;
72+
73+
# Construct the tail-checking hash (actually, it's cheaper and still
74+
# correct to re-use it throughout this function)
75+
foreach my $seq (@seqs) {
76+
$tails{$seq->[$_]}++ for (1..$#$seq);
77+
}
78+
79+
my @res = ( $current_root );
80+
while (1) {
81+
my $cand;
82+
my $winner;
83+
foreach (@seqs) {
84+
next if !@$_;
85+
if(!$winner) { # looking for a winner
86+
$cand = $_->[0]; # seq head is candidate
87+
next if $tails{$cand}; # he loses if in %tails
88+
89+
# Handy warn to give a output like the ones on
90+
# http://www.python.org/download/releases/2.3/mro/
91+
#warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
92+
push @res => $winner = $cand;
93+
shift @$_; # strip off our winner
94+
$tails{$_->[0]}-- if @$_; # keep %tails sane
95+
}
96+
elsif($_->[0] eq $winner) {
97+
shift @$_; # strip off our winner
98+
$tails{$_->[0]}-- if @$_; # keep %tails sane
99+
}
100+
}
101+
102+
# Handy warn to give a output like the ones on
103+
# http://www.python.org/download/releases/2.3/mro/
104+
#warn " = " . join(' + ', @res) . "\n" if !$cand;
105+
106+
last if !$cand;
107+
die q{Inconsistent hierarchy found while merging '}
108+
. $current_root . qq{':\n\t}
109+
. qq{current merge results [\n\t\t}
110+
. (join ",\n\t\t" => @res)
111+
. qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
112+
if !$winner;
113+
}
114+
\@res;
115+
};
116+
117+
return @$mergeout if !@STACK;
118+
119+
$i = pop(@STACK);
120+
$recurse_mergeout = pop(@STACK);
121+
$current_parents = pop(@STACK);
122+
$current_root = pop(@STACK);
123+
124+
push(@$recurse_mergeout, $mergeout);
125+
}
126+
}
127+
128+
1;
129+
130+
__END__
131+
132+
=pod
133+
134+
=head1 NAME
135+
136+
Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
137+
138+
=head1 SYNOPSIS
139+
140+
use Algorithm::C3;
141+
142+
# merging a classic diamond
143+
# inheritance graph like this:
144+
#
145+
# <A>
146+
# / \
147+
# <B> <C>
148+
# \ /
149+
# <D>
150+
151+
my @merged = Algorithm::C3::merge(
152+
'D',
153+
sub {
154+
# extract the ISA array
155+
# from the package
156+
no strict 'refs';
157+
@{$_[0] . '::ISA'};
158+
}
159+
);
160+
161+
print join ", " => @merged; # prints D, B, C, A
162+
163+
=head1 DESCRIPTION
164+
165+
This module implements the C3 algorithm. I have broken this out
166+
into it's own module because I found myself copying and pasting
167+
it way too often for various needs. Most of the uses I have for
168+
C3 revolve around class building and metamodels, but it could
169+
also be used for things like dependency resolution as well since
170+
it tends to do such a nice job of preserving local precedence
171+
orderings.
172+
173+
Below is a brief explanation of C3 taken from the L<Class::C3>
174+
module. For more detailed information, see the L<SEE ALSO> section
175+
and the links there.
176+
177+
=head2 What is C3?
178+
179+
C3 is the name of an algorithm which aims to provide a sane method
180+
resolution order under multiple inheritance. It was first introduced
181+
in the language Dylan (see links in the L<SEE ALSO> section), and
182+
then later adopted as the preferred MRO (Method Resolution Order)
183+
for the new-style classes in Python 2.3. Most recently it has been
184+
adopted as the 'canonical' MRO for Perl 6 classes, and the default
185+
MRO for Parrot objects as well.
186+
187+
=head2 How does C3 work.
188+
189+
C3 works by always preserving local precedence ordering. This
190+
essentially means that no class will appear before any of it's
191+
subclasses. Take the classic diamond inheritance pattern for
192+
instance:
193+
194+
<A>
195+
/ \
196+
<B> <C>
197+
\ /
198+
<D>
199+
200+
The standard Perl 5 MRO would be (D, B, A, C). The result being that
201+
B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
202+
The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
203+
which does not have this same issue.
204+
205+
This example is fairly trivial, for more complex examples and a deeper
206+
explanation, see the links in the L<SEE ALSO> section.
207+
208+
=head1 FUNCTION
209+
210+
=over 4
211+
212+
=item B<merge ($root, $func_to_fetch_parent, $cache)>
213+
214+
This takes a C<$root> node, which can be anything really it
215+
is up to you. Then it takes a C<$func_to_fetch_parent> which
216+
can be either a CODE reference (see L<SYNOPSIS> above for an
217+
example), or a string containing a method name to be called
218+
on all the items being linearized. An example of how this
219+
might look is below:
220+
221+
{
222+
package A;
223+
224+
sub supers {
225+
no strict 'refs';
226+
@{$_[0] . '::ISA'};
227+
}
228+
229+
package C;
230+
our @ISA = ('A');
231+
package B;
232+
our @ISA = ('A');
233+
package D;
234+
our @ISA = ('B', 'C');
235+
}
236+
237+
print join ", " => Algorithm::C3::merge('D', 'supers');
238+
239+
The purpose of C<$func_to_fetch_parent> is to provide a way
240+
for C<merge> to extract the parents of C<$root>. This is
241+
needed for C3 to be able to do it's work.
242+
243+
The C<$cache> parameter is an entirely optional performance
244+
measure, and should not change behavior.
245+
246+
If supplied, it should be a hashref that merge can use as a
247+
private cache between runs to speed things up. Generally
248+
speaking, if you will be calling merge many times on related
249+
things, and the parent fetching function will return constant
250+
results given the same arguments during all of these calls,
251+
you can and should reuse the same shared cache hash for all
252+
of the calls. Example:
253+
254+
sub do_some_merging {
255+
my %merge_cache;
256+
my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
257+
my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
258+
my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
259+
my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
260+
# ...
261+
}
262+
263+
=back
264+
265+
=head1 CODE COVERAGE
266+
267+
I use B<Devel::Cover> to test the code coverage of my tests, below
268+
is the B<Devel::Cover> report on this module's test suite.
269+
270+
------------------------ ------ ------ ------ ------ ------ ------ ------
271+
File stmt bran cond sub pod time total
272+
------------------------ ------ ------ ------ ------ ------ ------ ------
273+
Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
274+
------------------------ ------ ------ ------ ------ ------ ------ ------
275+
Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
276+
------------------------ ------ ------ ------ ------ ------ ------ ------
277+
278+
=head1 SEE ALSO
279+
280+
=head2 The original Dylan paper
281+
282+
=over 4
283+
284+
=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
285+
286+
=back
287+
288+
=head2 The prototype Perl 6 Object Model uses C3
289+
290+
=over 4
291+
292+
=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
293+
294+
=back
295+
296+
=head2 Parrot now uses C3
297+
298+
=over 4
299+
300+
=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
301+
302+
=item L<http://use.perl.org/~autrijus/journal/25768>
303+
304+
=back
305+
306+
=head2 Python 2.3 MRO related links
307+
308+
=over 4
309+
310+
=item L<http://www.python.org/2.3/mro.html>
311+
312+
=item L<http://www.python.org/2.2.2/descrintro.html#mro>
313+
314+
=back
315+
316+
=head2 C3 for TinyCLOS
317+
318+
=over 4
319+
320+
=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
321+
322+
=back
323+
324+
=head1 AUTHORS
325+
326+
Stevan Little, E<lt>stevan@iinteractive.comE<gt>
327+
328+
Brandon L. Black, E<lt>blblack@gmail.comE<gt>
329+
330+
=head1 COPYRIGHT AND LICENSE
331+
332+
Copyright 2006 by Infinity Interactive, Inc.
333+
334+
L<http://www.iinteractive.com>
335+
336+
This library is free software; you can redistribute it and/or modify
337+
it under the same terms as Perl itself.
338+
339+
=cut

0 commit comments

Comments
 (0)