view release on metacpan or  search on metacpan

lib/Algorithm/History/Levels.pm  view on Meta::CPAN

        },
        discard_young_histories => {
            schema => ['bool*'],
            default => 0,
        },
    },
    result_naked => 1,
};
sub group_histories_into_levels {
    require Array::Sample::Partition;

    my %args = @_;

    my $now = $args{now} // time();

    my $histories0 = $args{histories} or die "Please specify histories";
    my @histories;
    {
        my %seen;
        for my $h (@$histories0) {
            my ($name, $time);
            if (ref $h eq 'ARRAY') {
                ($name, $time) = @$h;
            } else {
                $name = $h;
                $time = $h;
        }
            $seen{$name}++ and die "Duplicate history name '$name'";
            push @histories, [$name, $time];
        }
    }

    my $levels = $args{levels} or die "Please specify levels";
    @$levels > 0 or die "Please specify at least one level";
    my $i = 0;
    my $min_period;
    for my $l (@$levels) {
        ref($l) eq 'ARRAY' or die "Level #$i: not an array";
        @$l == 2 or die "Level #$i: not a 2-element array";
        $l->[0] > 0  or die "Level #$i: period must be a positive number";
        $l->[1] >= 1 or die "Level #$i: number of items must be at least 1";
        if (defined $min_period) {
            $l->[0] > $min_period  or die "Level #$i: period must be larger than previous ($min_period)";
        }
        $min_period = $l->[0];
        $i++;
    }

    # first, we sort the histories by timestamp (newer first)
    @histories = sort { $b->[1] <=> $a->[1] } @histories;

    my $res = {
        levels => [ map {[]} @$levels],
        discard => [],
    };

  LEVEL:
    for my $l (0..$#{$levels}) {
        my ($period, $num_per_level) = @{ $levels->[$l] };

        # first, fill the level with histories that fit the time frame for each
        # level's slot
        for my $slot (0..$num_per_level-1) {
            my $min_time = $now-($slot+1)*$period;
            my $max_time = $now-($slot  )*$period;
            if ($l > 0) {
                my ($lower_period, $lower_num_per_level) = @{ $levels->[$l-1] };
                $min_time -= $lower_num_per_level*$lower_period;
                $max_time -= $lower_num_per_level*$lower_period;
            }
            my $h = _pick_history(\@histories, $min_time, $max_time);
            push @{ $res->{levels}[$l] }, $h if $h;
        }

        # if the level is not fully filled yet, fill it with young or old
        # histories
        my $num_filled = @{ $res->{levels}[$l] };
        #say "D:level=$l, num_filled=$num_filled";
        unless ($num_filled >= $num_per_level) {
            my @filler = @histories;
            if ($args{discard_young_histories} // 0) {
                my $time = $now-$num_per_level*$period;
                if ($l > 0) {
                    my ($lower_period, $lower_num_per_level) =
                        @{ $levels->[$l-1] };
                    $time -= $lower_num_per_level*$lower_period;
                }
                @filler = grep { $_->[1] <= $time }
                    @filler;
            }
            if ($args{discard_old_histories} // 0) {
                my $time = $now-$num_per_level*$period;
                if ($l > 0) {
                    my ($lower_period, $lower_num_per_level) =
                        @{ $levels->[$l-1] };
                    $time -= $lower_num_per_level*$lower_period;
                }
                @filler = grep { $_->[1] >= $time }
                    @filler;
            }
            my @sample = Array::Sample::Partition::sample_partition(
                \@filler, $num_per_level - $num_filled);
            $res->{levels}[$l] = [
                sort { $b->[1] <=> $a->[1] }
                    (@{ $res->{levels}[$l] }, @sample),
            ];
            for my $i (reverse 0..$#histories) {
                for my $j (0..$#sample) {
                    if ($histories[$i] eq $sample[$j]) {
                        splice @histories, $i, 1;
                        last;
                    }
                }
            }
        }

        # only return names
        $res->{levels}[$l] = [ map {$_->[0]} @{ $res->{levels}[$l] } ];
    }

    push @{ $res->{discard} }, $_->[0] for @histories;