Как я могу сгенерировать набор диапазонов от первых букв списка слов в Perl?

Question

Я не уверен, как это объяснить, поэтому я просто начну с примера.

Учитывая следующие данные:

Apple 
Apricot 
Blackberry 
Blueberry 
Cherry 
Crabapple 
Cranberry 
Elderberry 
Grapefruit 
Grapes 
Kiwi 
Mulberry 
Nectarine 
Pawpaw 
Peach 
Pear 
Plum 
Raspberry 
Rhubarb 
Strawberry 

Я хочу, чтобы создать индекс, основанный на первой букве моих данных, но я хочу, буквы сгруппированы вместе.

Здесь частота первых букв в приведенном выше наборе:

2 A 
    2 B 
    3 C 
    1 E 
    2 G 
    1 K 
    1 M 
    1 N 
    4 P 
    2 R 
    1 S 

Поскольку мой набор примеров данных мало, давайте просто скажем, что максимальное количество, чтобы объединить буквы вместе 3. Используя данные выше, это то, что мой индекс выйдет быть:

A B C D-G H-O P Q-Z 

Щелчок "DG" ссылка будет показывать:

Elderberry 
Grapefruit 
Grapes 

В моем диапазоне листинг выше, я охватывающий весь алфавит - я думаю, что это не совсем необходимому - я бы хорошо с этим выходом, а также:

A B C E-G K-N P R-S 

Очевидно мой набор данные не плод, у меня будет больше данных (около 1000-2000 пунктов), а мой «максимум за диапазон» будет больше 3.

Я тоже не слишком беспокоюсь о однобоких данных - так что если 40% моих данных начинается с «S» », то у S будет просто своя связь - мне не нужно разбить ее на вторую букву в данных.

Поскольку мой набор данных не будет меняться слишком часто, мне будет хорошо со статическим «максимумом за диапазон», но было бы неплохо, чтобы это было рассчитано динамически. Кроме того, набор данных не будет начинаться с цифр - он гарантированно начнется с буквы A-Z.

Я начал строить алгоритм для этого, но он продолжает становиться настолько грязным, что я начинаю все заново. Я не знаю, как искать Google для этого - я не уверен, что этот метод вызывается.

Вот что я начал с:

#!/usr/bin/perl 

use strict; 
use warnings; 

my $index_frequency = { map { ($_, 0) } ('A' .. 'Z') }; 
my $ranges = {}; 

open($DATASET, '<', 'mydata') || die "Cannot open data file: $!\n"; 

while (my $item = <$DATASET>) { 
    chomp($item); 
    my $first_letter = uc(substr($item, 0, 1)); 
    $index_frequency->{$first_letter}++; 
} 

foreach my $letter (sort keys %{$index_frequency}) { 
    if ($index_frequency->{$letter}) { 

     # build $ranges here 
    } 
} 

Моя проблема заключается в том, что я продолжать использовать кучу глобальных переменных, чтобы следить за подсчетов и предыдущие письма изученных - мой код становится очень грязным очень быстро.

Может ли кто-нибудь дать мне шаг в правильном направлении? Я думаю, что это скорее вопрос алгоритма, поэтому, если у вас нет способа сделать это в Perl, псевдокод тоже будет работать, я думаю - я могу преобразовать его в Perl.

Заранее благодарен!

Answer 1

Базовый подход:

#!/usr/bin/perl -w 
use strict; 
use autodie; 

my $PAGE_SIZE = 3; 
my %frequencies; 

open my $fh, '<', 'data'; 
while (my $l = <$fh>) { 
    next unless $l =~ m{\A([a-z])}i; 
    $frequencies{ uc $1 }++; 
} 
close $fh; 

my $current_sum = 0; 
my @letters  =(); 
my @pages  =(); 

for my $letter ("A" .. "Z") { 
    my $letter_weigth = ($frequencies{ $letter } || 0); 

    if ($letter_weigth + $current_sum > $PAGE_SIZE) { 
     if ($current_sum) { 
      my $title = $letters[ 0 ]; 
      $title .= '-' . $letters[ -1 ] if 1 < scalar @letters; 
      push @pages, $title; 
     } 
     $current_sum = $letter_weigth; 
     @letters  = ($letter); 
     next; 
    } 
    push @letters, $letter; 
    $current_sum += $letter_weigth; 
} 
if ($current_sum) { 
    my $title = $letters[ 0 ]; 
    $title .= '-' . $letters[ -1 ] if 1 < scalar @letters; 
    push @pages, $title; 
} 

print "Pages : " . join(" , ", @pages) . "\n"; 

Проблема с ним в том, что он выводит (из данных):

Pages : A , B , C-D , E-J , K-O , P , Q-Z 

Но я бы сказал, что это на самом деле хороший подход :) А вам всегда может изменить цикл for на:

for my $letter (sort keys %frequencies) { 

, если вам нужно.

Answer 2

Попробуйте что-то в этом роде, где frequency - это частотный массив, вычисленный на предыдущем шаге, и threshold_low - минимальное количество записей в диапазоне, а threshold_high - макс. номер. Это должно дать гармоничные результаты.

count=0 
threshold_low=3 
threshold_high=6 
inrange=false 
frequency['Z'+1]=threshold_high+1 
for letter in range('A' to 'Z'): 
    count += frequency[letter]; 
    if (count>=threshold_low or count+frequency[letter+1]>threshold_high): 
    if (inrange): print rangeStart+'-' 
    print letter+' ' 
    inrange=false 
    count=0 
    else: 
    if (not inrange) rangeStart=letter 
    inrange=true 

Answer 3

Вот мое предложение:

# get the number of instances of each letter 
my %count =(); 
while (<FILE>) 
{ 
    $count{ uc(substr($_, 0, 1)) }++; 
} 

# transform the list of counts into a map of count => letters 
my %freq =(); 
while (my ($letter, $count) = each %count) 
{ 
    push @{ $freq{ $count } }, $letter; 
} 

# now print out the list of letters for each count (or do other appropriate 
# output) 
foreach (sort keys %freq) 
{ 
    my @sorted_letters = sort @{ $freq{$_} }; 
    print "$_: @sorted_letters\n"; 
} 

Update: Я думаю, что я неправильно понял ваши требования. Следующий блок кода делает что-то более похожее на то, что вы хотите.

my %count =(); 
while (<FILE>) 
{ 
    $count{ uc(substr($_, 0, 1)) }++; 
} 

# get the maximum frequency 
my $max_freq = (sort values %count)[-1]; 

my $curr_set_count = 0; 
my @curr_set =(); 
foreach ('A' .. 'Z') { 
    push @curr_set, $_; 
    $curr_set_count += $count{$_}; 

    if ($curr_set_count >= $max_freq) { 

     # print out the range of the current set, then clear the set 
     if (@curr_set > 1) 
      print "$curr_set[0] - $curr_set[-1]\n"; 
     else 
      print "$_\n"; 

     @curr_set =(); 
     $curr_set_count = 0; 
    } 
} 

# print any trailing letters from the end of the alphabet 
if (@curr_set > 1) 
    print "$curr_set[0] - $curr_set[-1]\n"; 
else 
    print "$_\n"; 

Answer 4

Это пример того, как я буду писать эту программу.

#! /opt/perl/bin/perl 
use strict; 
use warnings; 

my %frequency; 
{ 
    use autodie; 
    open my $data_file, '<', 'datafile'; 

    while(my $line = <$data_file>){ 
    my $first_letter = uc(substr($line, 0, 1)); 
    $frequency{$first_letter} ++ 
    } 
    # $data_file is automatically closed here 
} 
#use Util::Any qw'sum'; 
use List::Util qw'sum'; 

# This is just an example of how to calculate a threshold 
my $mean = sum(values %frequency)/scalar values %frequency; 
my $threshold = $mean * 2; 

my @index; 
my @group; 
for my $letter (sort keys %frequency){ 
    my $frequency = $frequency{$letter}; 

    if($frequency >= $threshold){ 
    if(@group){ 
     if(@group == 1){ 
     push @index, @group; 
     }else{ 
     # push @index, [@group]; # copy @group 
     push @index, "$group[0]-$group[-1]"; 
     } 
     @group =(); 
    } 
    push @index, $letter; 
    }elsif(sum(@frequency{@group,$letter}) >= $threshold){ 
    if(@group == 1){ 
     push @index, @group; 
    }else{ 
     #push @index, [@group]; 
     push @index, "$group[0]-$group[-1]" 
    } 
    @group = ($letter); 
    }else{ 
    push @group, $letter; 
    } 
} 
#push @index, [@group] if @group; 
push @index, "$group[0]-$group[-1]" if @group; 

print join(', ', @index), "\n"; 

Answer 5

use strict; 
use warnings; 
use List::Util qw(sum); 

my @letters = ('A' .. 'Z'); 
my @raw_data = qw(
    Apple Apricot Blackberry Blueberry Cherry Crabapple Cranberry 
    Elderberry Grapefruit Grapes Kiwi Mulberry Nectarine 
    Pawpaw Peach Pear Plum Raspberry Rhubarb Strawberry 
); 

# Store the data by starting letter. 
my %data; 
push @{$data{ substr $_, 0, 1 }}, $_ for @raw_data; 

# Set max page size dynamically, based on the average 
# letter-group size (in this case, a multiple of it). 
my $MAX_SIZE = sum(map { scalar @$_ } values %data)/keys %data; 
$MAX_SIZE = int(1.5 * $MAX_SIZE + .5); 

# Organize the data into pages. Each page is an array reference, 
# with the first element being the letter range. 
my @pages = (['']); 
for my $letter (@letters){ 
    my @d = exists $data{$letter} ? @{$data{$letter}} :(); 
    if (@{$pages[-1]} - 1 < $MAX_SIZE or @d == 0){ 
     push @{$pages[-1]}, @d; 
     $pages[-1][0] .= $letter; 
    } 
    else { 
     push @pages, [ $letter, @d ]; 
    } 
} 
$_->[0] =~ s/^(.).*(.)$/$1-$2/ for @pages; # Convert letters to range.