Regexes aren't always the best solution to fuzzy matching:

#! perl -slw
use strict;

my @queries = qw[ GCGAT CACGT ];

chomp( my @targets = <DATA> );

for my $q ( @queries ) {
    for my $t ( @targets ) {
        my $matched = ( $q ^ substr( $t, 0, length( $q ) ) ) =~ tr[\0]
+[\0];
        if(  $matched >= ( length( $q ) -1 ) ) {
            print "$q matched $t";
        }
    }
}

__DATA__
GNGATNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
+NNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
GCGANBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB
+BBBBBBBBBBBBBBBBBBBBBBBBBBBBBB
CNCGTNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
+NNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
[download]

Gives:

[ 2:16:30.49] c:\test>junk77
GCGAT matched GNGATNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
+NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
GCGAT matched GCGANBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB
+BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB
CACGT matched CNCGTNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
+NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
[download]

Hi BrowserUk, You code has worked perfectly for my problem!!! I agree that my problem was one that needed more than just regular expression. However I was struggling to get an elegant solution in perl. Could I please ask you to explain me these two lines:

my $matched = ( $q ^ substr( $t, 0, length( $q ) ) ) =~ tr[\0]
+[\0];
        if(  $matched >= ( length( $q ) -1 ) )
[download]

Sure.

During the first iteration, the first of those lines will come down to:

my $matched = ( 'GCGAT' ^ 'GNGAT' ) =~ tr[\0][\0];
[download]

In words, the first of the query strings is exclusive-Or'd (^) with the first 5 characters of the first target string.

Where the aligned characters in those two string are the same, the result of xoring them will be zero. Where the two characters differ, the result will be non-zero:

$xord = 'GCGAT' ^ 'GNGAT';;

print unpack 'C*', $xord;;
0 13 0 0 0
[download]

In order to know how many characters matched, all we need to do is count the zeros, which is efficiently done using the transliteration operator:

$matched = ( 'GCGAT' ^ 'GNGAT' ) =~ tr[\0][\0];;

print $matched;;
4
[download]

The result of the first line is that $matched is assigned the number of characters that matched between the two strings.

As you want all characters, except one in any position, to match, the second line tests the number that matched against the length of the query string minus 1:

if(  $matched >= ( length( $q ) -1 ) ) {
    ## we have a winner
[download]

If you know all your query strings are always five characters, then you could hard code the value 4 instead of ( length( $q ) -1 ). Ditto for the usage of length in the substr, but it never hurts to be flexible if there is little cost involved in doing so.

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

The OP seems to want to match at the start of the target string with either

• an exact match to the query string, or
• a match to a string formed by replacing a single character anywhere in the query string with a single 'N'.
The code of Re: string match using with an N in any position matches 'CACGT' against 'CBCGTNNN' ('B' vice 'N').

>perl -wMstrict -le
"my @queries = qw[ GCGAT CACGT ];
 ;;
 my @targets = qw(GNGATNNN GCGANBBB CNCGTNNN   CBCGTNNN  );
 ;;
 for my $q (@queries) {
   for my $t (@targets) {
     my $matched = ($q ^ substr($t, 0, length $q)) =~ tr[\0][\0];
     if($matched >= (length($q) - 1)) {
       print qq{'$q' matched '$t'};
       }
     }
   }
"
'GCGAT' matched 'GNGATNNN'
'GCGAT' matched 'GCGANBBB'
'CACGT' matched 'CNCGTNNN'
'CACGT' matched 'CBCGTNNN'
[download]

Here's a variation that avoids this (although the conditional logic is a bit obscure).

>perl -wMstrict -le
"use List::MoreUtils qw(uniq);
 ;;
 my @queries = qw(GCGAT CACGTT);
 ;;
 my $n_diff =
   join '',
   uniq
   map  { sprintf '\x%02x', ord($_ ^ 'N') }
   map  { split // }
   @queries
   ;
 $n_diff = eval qq{ sub { return \$_[0] =~ tr/$n_diff/$n_diff/; } };
 ;;
 my @targets = qw(
   GNGATNNNHIT GCGANBBBHIT CNCGTTNNNHIT CACGTTNNNHIT
   CBCGTTNNNMISS CNNGTTNNNMISS NCACGTTNNNMISS
   );
 ;;
 for my $q (@queries) {
   my $len_q = length $q;
   TARGET:
   for my $t (@targets) {
     my $mask  = $q ^ substr $t, 0, $len_q;
     my $nulls = $mask =~ tr{\0}{\0};
     next TARGET if $len_q > $nulls + 1
                 or $len_q > $nulls && $n_diff->($mask) != 1
                  ;
     print qq{'$q' matched '$t'};
     }
   }
"
'GCGAT' matched 'GNGATNNNHIT'
'GCGAT' matched 'GCGANBBBHIT'
'CACGTT' matched 'CNCGTTNNNHIT'
'CACGTT' matched 'CACGTTNNNHIT'
[download]

If the possibility your describe can happen, I think this is a computationally simpler solution:

#! perl -slw
use strict;

my @queries = qw[ GCGAT CACGT ];

chomp( my @targets = <DATA> );

for my $q ( @queries ) {
    for my $t ( @targets ) {
        my $matched = ( $q ^ substr( $t, 0, length( $q ) ) ) =~ tr[\0]
+[\0];
        if(
            $matched == length( $q )
        or  $matched == length( $q )-1 
        and substr( $t, 0, length( $q ) ) =~ tr[N][N] == 1
        ) {
            print "$q matched $t";
        }
    }
}

__DATA__
GNGATNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
+NNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
GCGANBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB
+BBBBBBBBBBBBBBBBBBBBBBBBBBBBBB
CNCGTNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
+NNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
GBGATNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
+NNNNNNNNNNNNNNNNNNNNNNNNNNNNNN
[download]

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

The code of Re: string match using with an N in any position matches 'CACGT' against 'CBCGTNNN' ('B' vice 'N').

Agreed. But in the genomic encoding scheme of things, the 'N' means 'aNy'. Whereas 'B' means 'any except A'.

With my very limited understanding, 'N' therefore encompasses 'B' in as much as there is no mention in his post of excluding strings that have an 'A' in the wild-card position. Nor is there any mention in the post of the possibility of "targets"(*) ever contains 'B's in the relevant positions.

In this case, the OP seems satisfied with the solution for his particular problem. I'll leave it up to him to know his data and problem domain.

(*An unusual term in this context -- the wild-cards are usually in the query -- but whatever :)

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

You could probably do something like this:

# reading in each query string (file1) into an array
my @barcode;
while ( my $line1 = <INP1> ) {
    chomp $line1;
    my @temp = ( $line1, ( $line1 ) x length $line1 );
    substr $temp[ $_ ], $_, 1, 'N' for 0 .. $#temp - 1;
    local $" = '|';
    push @barcode, [ $line1, qr/@temp/ ];
    }

for my $code ( @barcode ) {
    my $filename = $code->[ 0 ];
    open OUT, '>', $filename or die "Cannot open '$filename' because: 
+$!";
    # I have stored each of the query strings in a hash.
    # The value of the hash contains the target strings.
    # The keys are 1,2,3...
    for my $value ( values %idhash ) {
        if ( $value =~ /^$code->[1]/ ) {
            # where the query string matches the target
            # string print value of the hash
            print "$value\n";
            }
        }
    }
[download]

biobee07:

Update: My solution just wasn't as good as the others in this thread. It looks like BrowserUk has the best solution.

...roboticus

When your only tool is a hammer, all problems look like your thumb.

/^[NG][NC][NG][NA][NT]/ will also match the string 'NNNNN'

Thanks for replying to my thread -:)

You can use substr or whatever in the code that lists out the combinations. When the regex engine compiles this automagically built regex, it can deal with it very efficiently even if there are a lot of "OR" terms because there isn't any backtracking or forward looking or anything fancy.

So I am suggesting: think simple regex that is program generated. Oh, I don't see any reason for the search patterns to be in hash keyed by a sequential number, why not just have an array?

Update: I saw BrowserUk's solution and I like it. I wasn't aware that you could calculate the XOR byte by byte of 2 strings in a single Perl operation. Cool. There are some approximate pattern matching algorithms (eg agrep) where this is useful and the manner in which BrowserUk is using the XOR function is apropos.

Perl has made some very significant enhancements to the regex engine as of late. I am still on Perl 5.10. What I am wondering (I don't know the answer) is how sophisticated the regex compiler has become in 5.14 and what its optimization points are. For example if the data to matched against starts with 'C', then none of the optional patterns will ever match and all of the rest of the calculations become irrelevant - first character isn't a 'G' or 'N' so: stop! If it does that then the result is likely to be faster than the procedure of XOR'ing the strings together and going thru the resultant XOR produced string to count the 0's (fewer character by character operations get done on average vs a smarter "give up early" strategy..well maybe..).

What I am suggesting is that if performance matters, benchmarking is definitely in order!

I have used the above algorithm in other situations where for example certain character positions can be swapped and others not. The requirement described in the OP is at the lower limit of what this "write a program to write a program" approach can do (the regex is essentially a program that is compiled by the regex engine at run time). Next year I am going to attempt a performance increase on my regex writing code - I'll report back if I find something particularly stunning.

Here's a snippet of code that implements what you describe:

sub fuzzy {
    my $string = shift;
    my @alt;
    for(my $i = 0; $i < length($string); $i++) {
        my $alt = $string;
        substr($alt, $i, 1) = 'N';
        push @alt, $alt;
    }
    return join '|', $string, @alt;   # original too
}

print fuzzy('GCGAT');
[download]

You can just do

$re = fuzzy($string);
if($value =~ /^($re)/) { ... }
[download]

Note the parens for grouping.

If there's only one value for $re during the run of the file, you can use /o (as in /^($re)/o) but in a modern perl I don't think that makes much difference.

Yes, this is the idea!
I was out of town and using a friend's laptop without Perl installed and I was reluctant to post "untested code". This idea applies also in much more complex situations. I have one function that can generate regex'es with 4-12 terms from very similar length "search for" strings due to the "rules".

Anyway if the "rules" can be described as a regex generation algorithm, then I am suggesting in this thread an "additional tool to add to the Perl toolbox".

This had the added benefit of when the end user thinks that something should have either matched or not matched, the test output of the module can print regex'es for test cases (mine does). And the terms are simple enough that a user familiar with Windows '.', and '*' wildcards can tell me some new case to add or delete.

This "write the regex" code replaced what my working group came to call "the regex from hell" - so complicated that you might have to read Mastering Regular Expressions by Jeffrey-Friedl several times before you could understand it!

my %match = map { $_ => 1 } qw(GCGAT CACGT);

while (<>) {
    my $line = $_;
    s/N//; # remove the first N in the string
    print "match: $line" if $match{substr($_, 0, 5)}
}
[download]

my $pattern = join('|', qw(GCGAT CACGT));
$pattern = qr/^(?:$pattern)/;
while (<>) {
    my $line = $_;
    s/N//; # remove the first N in the string
    print "match: $line" if $_ =~ $pattern;
}
[download]

my $str = "GCGAT";
my @PATS = map {
    my $s = $str;
    substr $s, $_, 1, "N";
    $s;
} 0 .. length($str) - 1;
push @PATS, $str;
foreach my $str (@PATS) {
    if (index $value, $str) == 0) {
        print "Oh, joy, it's a match";
    }
}
[download]

Just one more, not necessarily better or quicker than the other solutions

1. Each of the query strings should be matched only in the beginning of the string 2. The query strings can have an N (and ONLY ONE?) at any position which means for each query string eg. GCGAT we can have NCGAT,GNGAT,GCNAT,GCGNT,GCGAN.

Why the ".*?$"?

Just a matter of personal preferences. It will helps me to remember what I was doing in future reviews, but you can avoid it if you want (and gain a little speed).