Làm thế nào để tự động tạo mẫu dựa trên dữ liệu thực?

Question

Tôi có nhiều nhà cung cấp trong cơ sở dữ liệu, tất cả đều khác nhau ở một số khía cạnh của dữ liệu của họ. Tôi muốn thực hiện quy tắc xác thực dữ liệu dựa trên dữ liệu trước đó.

Ví dụ:

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

Mục tiêu: nếu người dùng đầu vào chuỗi 'XZ-217' cho nhà cung cấp B, thuật toán nên so sánh dữ liệu trước đó và nói: string này là không giống với nhà cung cấp dữ liệu trước đó B.

Có một số cách/công cụ tốt để đạt được so sánh như vậy không? Câu trả lời có thể là một số thuật toán chung hoặc mô-đun Perl.

Chỉnh sửa: Tính tương tự "" khó xác định, tôi đồng ý. Nhưng tôi muốn bắt được thuật toán, có thể phân tích 100 mẫu ca trước đó và sau đó so sánh kết quả phân tích với dữ liệu mới. Sự tương tự có thể dựa trên độ dài, về việc sử dụng các ký tự/số, mẫu tạo chuỗi, đầu/cuối/đầu tương tự, có một số dấu phân cách.

Tôi cảm thấy nó không phải là công việc dễ dàng, nhưng mặt khác, tôi nghĩ rằng nó có sử dụng rất rộng. Vì vậy, tôi hy vọng, đã có một số gợi ý.

Answer 1

Nếu có mô-đun Tie::StringApproxHash, nó sẽ phù hợp với hóa đơn tại đây.

Tôi nghĩ bạn đang tìm kiếm thứ gì đó kết hợp chức năng logic mờ của String::Approx và giao diện băm của Tie::RegexpHash.

Điều trước quan trọng hơn; sau này sẽ làm cho công việc nhẹ của mã hóa.

Answer 2

Bạn có thể muốn kiểm tra nội dung: http://en.wikipedia.org/wiki/String_metric và http://search.cpan.org/dist/Text-Levenshtein/Levenshtein.pm (ví dụ)

Answer 3

Đây là triển khai thực hiện của tôi và một vòng qua các trường hợp thử nghiệm của bạn. Về cơ bản bạn đưa ra một danh sách các giá trị tốt cho hàm và nó cố gắng xây dựng một regex cho nó.

đầu ra:

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

mã:

#!/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; 
    } 
} 

Để đơn giản hóa công việc của việc tìm kiếm các mô hình, các bộ phận không bắt buộc có thể đến lúc kết thúc, nhưng không có bộ phận cần thiết có thể đến sau những tùy chọn. Điều này có thể có thể được khắc phục nhưng nó có thể là khó khăn.

Answer 4

Joel và tôi nghĩ ra những ý tưởng tương tự. Mã dưới đây phân biệt 3 loại vùng.

1. một hoặc nhiều ký tự không phải chữ
2. chữ và số cụm
3. một cụm chữ số

Nó tạo ra một hồ sơ cá nhân của chuỗi và một regex để phù hợp với đầu vào. Ngoài ra, nó cũng chứa logic để mở rộng các cấu hình hiện có. Cuối cùng, trong nhiệm vụ phụ, nó chứa một số logic giả cho biết làm thế nào điều này có thể được tích hợp vào một ứng dụng lớn hơn.

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); 
}