Как автоматическое создание шаблона на основе реальных данных?

Question

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

Пример:

A: XZ-4, XZ-23, XZ-217 
B: 1276, 1899, 22711 
C: 12-4, 12-75, 12 

Цель: если пользователь вводит строку «XZ-217» для поставщика B, алгоритм должен сравнить предыдущие данные и сказать: эта строка не похожа на продавец В предыдущих данных.

Есть ли хороший способ/инструменты для достижения такого сравнения? Ответ может быть некоторым общим алгоритмом или модулем Perl.

Редактировать: «Сходство» трудно определить, я согласен. Но я бы хотел поймать алгоритм, который мог бы проанализировать предыдущие около 100 выборок, а затем сравнить результаты анализа с новыми данными. Сходство может быть основано на длине, на использовании символов/чисел, шаблонов создания строк, схожих начала/конца/середины, с некоторыми разделителями.

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

Answer 1

Если бы был модуль Tie::StringApproxHash, он соответствовал бы счету.

Я думаю, что вы ищете что-то, что сочетает функции нечеткой логики String::Approx и хэш-интерфейс Tie::RegexpHash.

Первый является более важным; последний будет делать легкую работу по кодированию.

Answer 2

Вы можете пролистать: http://en.wikipedia.org/wiki/String_metric и http://search.cpan.org/dist/Text-Levenshtein/Levenshtein.pm (например)

Answer 3

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

выход:

A: (?^:\w{2,2}(?:\-){1}\d{1,3}) 
B: (?^:\d{4,5}) 
C: (?^:\d{2,2}(?:\-)?\d{0,2}) 

код:

#!/usr/bin/env perl 

use strict; 
use warnings; 

use List::MoreUtils qw'uniq each_arrayref'; 

my %examples = (
    A => [qw/ XZ-4 XZ-23 XZ-217 /], 
    B => [qw/ 1276 1899 22711 /], 
    C => [qw/ 12-4 12-75 12 /], 
); 

foreach my $example (sort keys %examples) { 
    print "$example: ", gen_regex(@{ $examples{$example} }) || "Generate failed!", "\n"; 
} 

sub gen_regex { 
    my @cases = @_; 

    my %exploded; 

    # ex. $case may be XZ-217 
    foreach my $case (@cases) { 
    my @parts = 
     grep { defined and length } 
     split(/(\d+|\w+)/, $case); 

    # @parts are (XZ, -, 217) 

    foreach (@parts) { 
     if (/\d/) { 
     # 217 becomes ['\d' => 3] 
     push @{ $exploded{$case} }, ['\d' => length]; 

     } elsif (/\w/) { 
     #XZ becomes ['\w' => 2] 
     push @{ $exploded{$case} }, ['\w' => length]; 

     } else { 
     # - becomes ['lit' => '-'] 
     push @{ $exploded{$case} }, ['lit' => $_ ]; 

     } 
    } 
    } 

    my $pattern = ''; 

    # iterate over nth element (part) of each case 
    my $ea = each_arrayref(values %exploded); 
    while (my @parts = $ea->()) { 

    # remove undefined (i.e. optional) parts 
    my @def_parts = grep { defined } @parts; 

    # check that all (defined) parts are the same type 
    my @part_types = uniq map {$_->[0]} @def_parts; 
    if (@part_types > 1) { 
     warn "Parts not aligned\n"; 
     return; 
    } 
    my $type = $part_types[0]; #same so make scalar 

    # were there optional parts? 
    my $required = (@parts == @def_parts); 

    # keep the values of each part 
    # these are either a repitition or lit strings 
    my @values = sort uniq map { $_->[1] } @def_parts; 

    # these are for non-literal quantifiers 
    my $min = $required ? $values[0] : 0; 
    my $max = $values[-1]; 

    # write the specific pattern for each type 
    if ($type eq '\d') { 
     $pattern .= '\d' . "{$min,$max}"; 

    } elsif ($type eq '\w') { 
     $pattern .= '\w' . "{$min,$max}"; 

    } elsif ($type eq 'lit') { 
     # quote special characters, - becomes \- 
     my @uniq = map { quotemeta } uniq @values; 
     # join with alternations, surround by non-capture grouup, add quantifier 
     $pattern .= '(?:' . join('|', @uniq) . ')' . ($required ? '{1}' : '?'); 
    } 
    } 


    # build the qr regex from pattern 
    my $regex = qr/$pattern/; 
    # test that all original patterns match (@fail should be empty) 
    my @fail = grep { $_ !~ $regex } @cases; 

    if (@fail) { 
    warn "Some cases fail for generated pattern $regex: (@fail)\n"; 
    return ''; 
    } else { 
    return $regex; 
    } 
} 

Чтобы упростить работу по поиску модели, дополнительные детали могут прийти в конце концов, но не необходимые детали не могут прийти после того, как факультативные. Вероятно, это можно преодолеть, но это может быть сложно.

Answer 4

Джоэл и я придумали похожие идеи. В приведенном ниже коде различаются 3 типа зон.

1. один или несколько символов, не слово
2. буквенно-цифровые кассетные
3. кластер цифр

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

use strict; 
use warnings; 
use List::Util qw<max min>; 

sub compile_search_expr { 
    shift; 
    @_ = @{ shift() } if @_ == 1; 
    my $str 
     = join('|' 
       , map { join('' 
          , grep { defined; } 
          map { 
           $_ eq 'P' ? quotemeta; 
           : $_ eq 'W' ? "\\w{$_->[1],$_->[2]}" 
           : $_ eq 'D' ? "\\d{$_->[1],$_->[2]}" 
           :    undef 
           ; 
          } @$_ 
         ) 
       } @_ == 1 ? @{ shift } : @_ 
     ); 
    return qr/^(?:$str)$/; 
} 

sub merge_profiles { 
    shift; 
    my ($profile_list, $new_profile) = @_; 
    my $found = 0; 
    PROFILE: 
    for my $profile (@$profile_list) { 
     my $profile_length = @$profile; 

     # it's not the same profile. 
     next PROFILE unless $profile_length == @$new_profile; 
     my @merged; 
     for (my $i = 0; $i < $profile_length; $i++) { 
      my $old = $profile->[$i]; 
      my $new = $new_profile->[$i]; 
      next PROFILE unless $old->[0] eq $new->[0]; 
      push(@merged 
       , [ $old->[0] 
        , min($old->[1], $new->[1]) 
        , max($old->[2], $new->[2]) 
        ]); 
     } 
     @$profile = @merged; 
     $found = 1; 
     last PROFILE; 
    } 
    push @$profile_list, $new_profile unless $found; 
    return; 
} 

sub compute_info_profile { 
    shift; 
    my @profile_chunks 
     = map { 
       /\W/ ? [ P => $_ ] 
      : /\D/ ? [ W => length, length ] 
      :  [ D => length, length ] 
     } 
     grep { length; } split /(\W+)/, shift 
     ; 
} 

# Psuedo-Perl 
sub process_input_task { 
    my ($application, $input) = @_; 

    my $patterns = $application->get_patterns_for_current_customer; 
    my $regex = $application->compile_search_expr($patterns); 

    if ($input =~ /$regex/) {} 
    elsif ($application->approve_divergeance($input)) { 
     $application->merge_profiles($patterns, compute_info_profile($input)); 
    } 
    else { 
     $application->escalate( 
      Incident->new(issue => INVALID_FORMAT 
         , input => $input 
         , customer => $customer 
         )); 
    } 

    return $application->process_approved_input($input); 
}