¿Cómo crear automáticamente un patrón basado en datos reales?

Question

Tengo muchos proveedores en la base de datos, todos difieren en algún aspecto de sus datos. Me gustaría hacer una regla de validación de datos que se base en datos previos.

Ejemplo:

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

Objetivo: determinar si las entradas de usuario cadena 'XZ-217' para el proveedor B, el algoritmo debe comparar los datos anteriores y decir: esta cadena no es similar al proveedor de datos anteriores B.

¿Hay alguna buena forma/herramienta para lograr tal comparación? La respuesta podría ser algún algoritmo genérico o módulo de Perl.

Editar: La "similitud" es difícil de definir, estoy de acuerdo. Pero me gustaría encontrar un algoritmo que pueda analizar muestras de ca 100 anteriores y luego comparar el resultado del análisis con nuevos datos. La similitud puede basarse en la longitud, en el uso de caracteres/números, patrones de creación de cadenas, inicio/fin/medio similares, con algunos separadores.

Creo que no es tarea fácil, pero por otro lado, creo que tiene uso muy amplio. Así que esperaba, ya hay algunas pistas.

Answer 1

Si hubiera un módulo Tie::StringApproxHash, encajaría aquí.

Creo que está buscando algo que combine la funcionalidad de lógica difusa de String::Approx y la interfaz hash de Tie::RegexpHash.

Lo primero es más importante; este último haría un trabajo ligero de codificación.

Answer 2

Es posible que desee leer: http://en.wikipedia.org/wiki/String_metric y http://search.cpan.org/dist/Text-Levenshtein/Levenshtein.pm (por ejemplo)

Answer 3

Aquí es mi aplicación y un bucle sobre sus casos de prueba. Básicamente le das una lista de buenos valores a la función e intenta construir una expresión regular para ella.

de salida:

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

código:

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

para simplificar el trabajo de encontrar el patrón, piezas opcionales Puede llegar al final, pero no hay piezas necesarias puede venir después de los opcionales. Esto probablemente podría ser superado, pero podría ser difícil.

Answer 4

A Joel y a mí se nos ocurrieron ideas similares. El siguiente código diferencia 3 tipos de zonas.

1. uno o más caracteres que no son palabras
2. racimo alfanumérica
3. un grupo de dígitos

Se crea un perfil de la cadena y una expresión regular para que coincida con la entrada. Además, también contiene lógica para expandir los perfiles existentes. Al final, en la tarea secundaria, contiene cierta pseudo lógica que indica cómo podría integrarse en una aplicación más grande.

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