File Coverage

blib/lib/Sort/Rank.pm

Criterion	Covered	Total	%
statement	40	43	93.0
branch	12	18	66.6
condition	6	8	75.0
subroutine	7	7	100.0
pod	2	2	100.0
total	67	78	85.9

package Sort::Rank;

use warnings;
use strict;
use Carp;

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(rank_sort rank_group);

use version; our $VERSION = qv( '0.0.2' );

sub rank_group {
    my $array   = shift;
    my $extract = shift;

    if ( ref( $array ) eq 'HASH' ) {

        # Turn a hash into an array
        my @a = map { [ $_, $array->{$_} ] } keys %$array;
        $array = \@a;
    }

    croak "rank_sort needs an array reference"
      unless ref $array eq 'ARRAY';

    # Default score extraction sub
    $extract ||= sub {
        my $item = shift;
        croak "Array item must be a hash with a key called 'score'."
          unless ref( $item ) eq 'HASH' && exists $item->{score};
        return $item->{score};
    };

    croak "Key extractor must be a code ref"
      unless ref( $extract ) eq 'CODE';

    my $pos = 1;
    my @ar  = sort {

        # Sort on score then original position
        $b->[0] <=> $a->[0]
          || $a->[1] <=> $b->[1]
      }
      map {

        # Build array of score, original position, value
        [ $extract->( $_ ), $pos++, $_ ]
      } @$array;

    my @out = ();
    for my $i ( 0 .. $#ar ) {

        # Need to start a new chunk?
        if ( $i == 0 || $ar[$i]->[0] != $ar[ $i - 1 ]->[0] ) {
            push @out, [ $i + 1 ];
        }

        # Add item to current chunk
        push @{ $out[-1] }, $ar[$i]->[2];
    }

    return wantarray ? @out : \@out;
}

sub rank_sort {
    my @grp = rank_group( @_ );
    my @out = ();

    # Unwrap groups
    for my $g ( @grp ) {
        my $rank = shift @$g;
        my $many = ( @$g > 1 ) ? '=' : '';
        for my $i ( @$g ) {
            push @out, [ $rank, $many, $i ];
        }
    }

    return wantarray ? @out : \@out;
}

1;
__END__