如何根據實際數據自動創建模式？

Question

我在數據庫中有很多廠商，他們在數據的某些方面都有所不同。我想製作基於以前數據的數據驗證規則。

實施例：

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

目標：如果用戶輸入字符串「XZ-217」的供應商B，算法應該比較先前的數據和說：此字符串不類似於供應商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); 
}