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

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

5 голосов
/ 13 января 2012

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

Пример: 

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

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

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

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

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

Ответы [ 4 ]

2 голосов
/ 13 января 2012
1 голос
/ 13 января 2012

Джоэл и я пришли с похожими идеями. Код ниже дифференцирует 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 );
}
1 голос
/ 13 января 2012

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

output: 

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

code: 

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

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

0 голосов
/ 13 января 2012

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

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

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

...