diff options
| -rw-r--r-- | challenge-172/cheok-yin-fung/perl/ch-2.pl | 122 |
1 files changed, 122 insertions, 0 deletions
diff --git a/challenge-172/cheok-yin-fung/perl/ch-2.pl b/challenge-172/cheok-yin-fung/perl/ch-2.pl new file mode 100644 index 0000000000..eed5cb37dd --- /dev/null +++ b/challenge-172/cheok-yin-fung/perl/ch-2.pl @@ -0,0 +1,122 @@ +#!/usr/bin/perl +# "For discrete distributions, there is no universal +# agreement on selecting the quartile values." +# (https://en.wikipedia.org/wiki/Quartile) +# +# For method 3: +# test data of method 3 comes from https://www.wolframalpha.com +# the definition on en.wikipedia.org seems wrong +# Thursday, July 07, 2022 AM12:34:44 HKT +# +# The Weekly Challenge 172 +# Task 2 Five-number Summary +use v5.24.0; +use feature qw(signatures); +no warnings qw(experimental::signatures); +use POSIX qw/floor/; + +if (defined $ARGV[1]) { + for my $i (1..4) { + say " ", join ", ", map {sprintf "%.2f", $_ } fns([@ARGV], $i)->@*; + } +} + + + +sub _median { # expect @arr is sorted + my @arr = @_; + my $s = scalar @arr; + return $s % 2 == 0 + ? ($arr[$s/2-1] + $arr[$s/2])/2 + : $arr[($s-1)/2]; +} + + + +sub fns ($inp , $quartile_method = 1) { +# (definition of the methods follows en.wikipedia.org/wiki/Quartile) + my @arr = $inp->@*; + @arr = sort {$a<=>$b} @arr; + my $s = scalar @arr; + if ($quartile_method == 2 && $s % 2 == 1) { + return [$arr[0], + _median(@arr[0..($s-1)/2]), + $arr[($s-1)/2], + _median(@arr[($s-1)/2..$s-1]), + $arr[-1]]; + } + if ( ($quartile_method == 2 || $quartile_method == 1) && $s % 2 == 0) { + return [$arr[0], + _median(@arr[0..$s/2-1]), + _median(@arr), + _median(@arr[$s/2..$s-1]), + $arr[-1]]; + } + if ( $quartile_method == 1 && $s % 2 == 1) { + return [$arr[0], + _median(@arr[0..($s-3)/2]), + $arr[($s-1)/2], + _median(@arr[($s+1)/2..$s-1]), + $arr[-1]]; + } + if ( $quartile_method == 3 ) { + return fns([@arr], 1) if $s % 2 == 0; + my $m = _median(@arr); + my $f = scalar @arr / 4; + if (scalar @arr % 4 == 1) { + return [$arr[0], + $arr[$f-1]/4 + $arr[$f]*3/4, + $m, + $arr[3*$f]*3/4 + $arr[3*$f+1]/4, + $arr[-1]]; + } + else { # scalar @arr % 4 == 3 + return [$arr[0], + $arr[$f]*3/4 + $arr[$f+1]/4, + $m, + $arr[3*$f-1]/4 + $arr[3*$f]*3/4, + $arr[-1]]; + } + } + if ( $quartile_method == 4 ) { + my $k1 = floor(($s+1)/4); + my $k3 = floor(($s+1)*3/4); + my $a1 = ($s+1)/4 - $k1; + my $a3 = ($s+1)*3/4 - $k3; + return [$arr[0], + $arr[$k1-1]+$a1*($arr[$k1]-$arr[$k1-1]), + _median(@arr), + $arr[$k3-1]+$a3*($arr[$k3]-$arr[$k3-1]), + $arr[-1]]; + } + + # if the quartile method parameter is set incorrectly + return fns([@arr], 1); +} + + + +use Test::More tests => 13; +use Test::Deep; +cmp_deeply fns([1,3],1), [1, 1, 2, 3, 3]; +cmp_deeply fns([1,2,3],1), [1, 1, 2, 3, 3]; +cmp_deeply fns([6, 7, 15, 36, 39, 40, 41, 42, 43, 47, 49], 1), + [6, 15, 40, 43, 49]; +cmp_deeply fns([7, 15, 36, 39, 40, 41], 1), + [7, 15, 37.5, 40, 41]; +cmp_deeply fns([1,3],2), [1, 1, 2, 3, 3]; +cmp_deeply fns([1,2,3],2), [1, 1.5, 2, 2.5, 3]; +cmp_deeply fns([6, 7, 15, 36, 39, 40, 41, 42, 43, 47, 49], 2), + [6, 25.5, 40, 42.5, 49]; +cmp_deeply fns([7, 15, 36, 39, 40, 41], 2), + [7, 15, 37.5, 40, 41]; +cmp_deeply fns([7, 15, 36, 39, 40, 41], 3), + [7, 15, 37.5, 40, 41]; +cmp_deeply fns([7, 15, 36, 39, 40, 41, 42, 43, 47], 3), # $s == 9 + [7, 30.75, 40, 42.25, 47]; +cmp_deeply fns([6, 7, 15, 36, 39, 40, 41, 42, 43, 47, 49], 3), # $s == 11 + [6, 20.25, 40, 42.75, 49]; +cmp_deeply fns([6, 7, 15, 36, 39, 40, 41, 42, 43, 47, 49], 4), + [6, 15, 40, 43, 49]; +cmp_deeply fns([7, 15, 36, 39, 40, 41], 4), + [7, 13, 37.5, 40.25, 41]; |