File Coverage

blib/lib/Lingua/Orthon.pm

Criterion	Covered	Total	%
statement	114	118	96.6
branch	25	34	73.5
condition	2	6	33.3
subroutine	24	25	96.0
pod	10	10	100.0
total	175	193	90.6

package Lingua::Orthon;
use 5.006;
use strict;
use warnings FATAL => 'all';
use Carp qw(croak);
use List::AllUtils qw(any);
use Number::Misc qw(is_numeric);
use Statistics::Lite qw(mean);
use String::Util qw(hascontent nocontent);
use Unicode::Collate;

$Lingua::Orthon::VERSION = '0.03';

=pod

=encoding CP-1252

=head1 NAME

Lingua-Orthon - Orthographic similarity of string to one or more others by Coltheart's N and related measures

=head1 VERSION

This is documentation for B of Lingua::Orthon.

=head1 SYNOPSIS

 use Lingua::Orthon 0.03;
 my $orthon = Lingua::Orthon->new();
 my $bool = $orthon->are_orthons('BANG', 'BARN'); # 0
 $bool = $orthon->are_orthons('BANG', 'BONG'); # 1
 my $idx = $orthon->index_diff('BANK', 'BARK'); # 2
 my $count = $orthon->index_identical('BANG', 'BARN'); # 2
 my (@diff) = $orthon->char_diff('BANG', 'BONG'); # (qw/A O/)
 $count = $orthon->onc(
    test => 'BANG',
    sample => [qw/BAND COCO BING RANG BONG SONG/]); # 4
 my $aref = $orthon->list_orthons(
    test => 'BANG',
    sample => [qw/BAND COCO BING RANG BONG SONG/]); # BAND, BING, RANG, BONG
 $count = $orthon->levenshtein('BANG', 'BARN'); # 2
 my $float = $orthon->old(
    test => 'BANG',
    sample => [qw/BAND COCO BING RANG BONG SONG/]); # ~= 1.67

=head1 DESCRIPTION

Lingua-Orthon provides measures of similarity of character strings based on their orthographic identity, as relevant to psycholinguistic research. Case- and mark-sensitivity for determining character equality can be controlled. Wraps to Levenshtein Distance methods, extended to the OLD-20 metric, are provided for convenience of comparison. No methods are explicitly exported; all methods are called in the object-oriented way.

=head1 SUBROUTINES/METHODS

=head2 new

 my $ortho = Lingua::Orthon->new();

Constructs/returns class object for accessing other methods.

Optionally, set the argument B to an integer value ranging from 0 to 3 to control case- and mark-sensitivity. See L.

=cut

sub new {
    my ( $class, %args ) = @_;
    my $self = {};
    bless $self, $class;
    $self->set_eq( match_level => $args{'match_level'} );
    return $self;
}

=head2 are_orthons

 $bool = $orthon->are_orthons('String1', 'String2');

Returns 0 or 1 (Coltheart's Boolean) if two given strings are orthographic neighbours by a 1-mismatch I: i.e., the strings are of the same size (are equal in character count) and there is only one discrepancy between them by a single substitution of a character in the same ordinal position (no additions, deletions or transpositions). So I and I are orthons by this measure (they differ only in the final letter), but I and I are not (the letter I is an I to I via I, or a I from I to I).

I: If two identical letter strings are given (I, I), they are defined as I being orthons: the number of index identical characters must be at least one less than the length of the string(s).

I: By default, identity is defined case-insensitively; e.g., I and I, and I and I are orthons. However, if B has been set (in L or L) to a higher level than 1 (or as undef or 0), then case is respected; e.g., I and I are orthons, but I and I are NOT orthons (they involve substituting both the Is and the second letters (I and I) ... but I and I, or I and I, are orthons. (This usefully applies to putting L|Lingua::Orthon/onc, coltheart_n> (the sum of single-substitution orthons a string has within a lexicon) to questions of the featural versus lexical basis of neighbourhood effects).

See Coltheart et al. (1977) (in L). The measure is computationally simple and economical, relative to other measures, such as based on a wider array of edit-types (e.g., Levenshtein Distance), that, while having greater explanatory power (Yarkoni et al., 2008), can tax resources on the order of days to effectively compute for a single string relative to a humanly memorable corpus.

=cut

sub are_orthons {
    my ( $self, $w1, $w2 ) = @_;
    return _are_orthons( $w1, $w2, $self->{'_EQ'} );
}

=head2 index_identical

 $count = $orthon->index_identical('String1', 'String2');

Returns a count: the number of letters that are identical and in the same serial position among two given letter-strings.

For example, given I and I, 2 is returned for the two index-identical letters, I and I; I is in both strings, but it is ignored as it is the third letter in I but the fourth letter in I, and so not in the same serial position across the two words.

=cut

sub index_identical {
    my ( $self, $w1, $w2 ) = @_;
    return _index_identical( $w1, $w2, $self->{'_EQ'} );
}

=head2 index_diff

 $posint = $orthon->index_diff('String1', 'String2');

Assuming the two strings are single-substitution orthons, returns the single index (anchored at zero) at which their letters differ.  So if the two strings are "bring" and "being", the returned value is 1.

=cut

sub index_diff {
    my ( $self, $w1, $w2 ) = @_;
    my $idx = 0;
    for my $i ( 0 .. _smallest_len( $w1, $w2 ) - 1 ) {
        if ( not $self->{'_EQ'}->( map { substr $_, $i, 1 } ( $w1, $w2 ) ) ) {
            $idx = $i;
            last;
        }
    }
    return $idx;
}

=head2 char_diff

 @ari = $orthon->char_diff('String1', 'String2');

Returns a list of the first two characters (letters) that, reading from left to right, differ between two given strings. If the strings are single-substitution orthons, these are the characters that make them so. So if the two strings are "bring" and "being", the returned list is ('r', 'e') - the order of these characters in the returned list respecting the order of the given strings. The search across the strings terminates as soon there is a mismatch; otherwise, it continues only for as long as the length of the shortest string.

The identity match (or mismatch) is sensitive to the setting of the equality function per case and marks; see L.

=cut

sub char_diff {
    my ( $self, $w1, $w2 ) = @_;
    my @ds = ();
    for my $i ( 0 .. _smallest_len( $w1, $w2 ) - 1 ) {
        my @tmp = map { substr $_, $i, 1 } ( $w1, $w2 );
        if ( not $self->{'_EQ'}->(@tmp) ) {
            @ds = @tmp;
            last;
        }
    }
    return @ds;
}

=head2 onc, coltheart_n

 $int = $orthon->onc(test => CHARSTR, sample => AREF);

Returns the I (ONC), a.k.a. Coltheart's I: the number of single-letter substitution orthons a particular string has with respect to a list of strings (or "lexicon") (Coltheart et al., 1977). So I has two orthons (I and I) in the list (I, I, I and I).

=cut

sub onc {
    my ( $self, %args ) = @_;
    my $test_str =
      hascontent( $args{'test'} )
      ? $args{'test'}
      : croak 'Need a single character string to test for orthons';
    my $sample_aref =
      ref $args{'sample'}
      ? $args{'sample'}
      : croak
      'Need a list (aref) of character-strings to sample for orthon listing';
    my $count = 0;
    for ( 0 .. ( scalar @{$sample_aref} - 1 ) ) {
        if ( _are_orthons( $test_str, $sample_aref->[$_], $self->{'_EQ'} ) ) {
            $count++;
        }
    }
    return $count;
}
*coltheart_n = \&index_indentical;

=head2 list_orthons

 $aref = $orthon->list_orthons(test => CHARSTR, sample => AREF);

Returns a reference to an array of single-substitution orthographic neighbours of a given B character-string that are among a given list of B character-strings. The referenced is to an empty array if no orthons are found. The order of items in the returned array follows that in which they appear in the B.

=cut

sub list_orthons {
    my ( $self, %args ) = @_;
    my $test_str =
      hascontent( $args{'test'} )
      ? $args{'test'}
      : croak 'Need a single character string to test for orthons';
    my $sample_aref =
      ref $args{'sample'}
      ? $args{'sample'}
      : croak
      'Need a list (aref) of character-strings to sample for orthon listing';
    my @orthon_list = ();
    for ( 0 .. ( scalar @{$sample_aref} - 1 ) ) {
        if ( _are_orthons( $test_str, $sample_aref->[$_], $self->{'_EQ'} ) ) {
            push @orthon_list, $sample_aref->[$_];
        }
    }
    return \@orthon_list;
}

=head2 ldist, levenshtein

 $count = $orthon->ldist('String1', 'String2'); # minimal, strings will be lower-cased

Returns the Levenshtein Distance between two given letter strings, wrapping to various Perl module's that more or less implement the Levenshtein algorithm for efficiency and case-sensitivity. Specifically, if the match level has been set at 1 (to ignore case and diacritics), the method uses L (which offers "ignoring diacritics"); otherwise, it uses L to ignore case but not marks (given present limitations of this module). The required case- and mark-sensitivity are set in the L or L methods. By default, the match is made case- and mark-Isensitively (by canned Perl L).

=cut

sub ldist {
    my ( $self, $w1, $w2 ) = @_;
    my $ldist;
    if ( $self->{'_MATCH_LEVEL'} == 1 ) {
        require Text::Levenshtein;
        $ldist =
          Text::Levenshtein::distance( $w1, $w2, { ignore_diacritics => 1 } )
          ;    # also ignores case
    }
    else {
        require Text::Levenshtein::XS;
        if ( $self->{'_MATCH_LEVEL'} == 2 ) {
            ( $w1, $w2 ) = map { lc } ( $w1, $w2 );  # ignore case but not marks
        }
        $ldist = Text::Levenshtein::XS::distance( $w1, $w2 )
          ;    # ignores nothing on its own
    }
    return $ldist;
}

=head2 old

 $mean = $orthon->old(test => CHARSTR, sample => AREF, lim => INT);

Returns the mean orthographic Levenshtein distance (OLD) of the smallest B such edit distances for a given B string to all the strings in a B list. Based on Yarkoni et al. (2008), where, with the value of B is set to 20, the measure substantially contributes to prediction of performance in word recognition tasks. Here, if B is not defined, not numeric, or greater than the size of the B, then it is set by default to the size of the sample.

Levenshtein distance is calculated per the method L, wrapping to external modules with respect to the conditions of string equality set in L or L. Different settings lead to different speed of calculation. The slowest calculation (by far) occurs if B => 1 so that case- and mark-insensitive matching occurs; this relies on the pure Perl implementation in Text::Levenshtein with its argument B => 1. The fastest calculation (the default) occurs by setting B => 3, when exact characters are matched, e.g., I in the test-string and I in a sample-string at the same index across them are taken as unequal and so will count as a substitution. This relies on the C-implementation in Text::Levenshtein::XS. Ignore case but not marks with B => 2.

=cut

sub old {
    my ( $self, %args ) = @_;
    my $test_str =
      hascontent( $args{'test'} )
      ? $args{'test'}
      : croak 'Need a single character string to calculate OLD';
    my $sample_aref =
      ref $args{'sample'}
      ? $args{'sample'}
      : croak 'Need a list (aref) of character-strings to calculate OLD';
    my @ldists = ();
    for ( 0 .. ( scalar @{$sample_aref} - 1 ) ) {
        push @ldists, $self->ldist( $test_str, $sample_aref->[$_] );
    }
    my $lim =
      ( is_numeric( $args{'lim'} ) and $args{'lim'} <= scalar @ldists )
      ? $args{'lim'}
      : scalar @ldists;
    return mean( ( sort { $a <=> $b } @ldists )[ 0 .. int $lim - 1 ] )
      ;    # mean of first/smallest $lim-th values
}

=head2 set_eq

 $orthon->set_eq(match_level => INT); # undef, 0, 1, 2 or 3

Sets the string-matching level used in the above methods. This is called implicitly in L when given a B, or with the default value of 0. This is adopted and slightly adapted from how L controls for case/diacritic-sensitive matching.

=over 4

=item match_level = undef, 0

Match with respect to case and diacritics: same as B<3> but simply by Perl's eq. So, e.g., I<éclair> and I would be taken as non-identical, just as would I and I.

This is the fastest option. The higher levels, as follow, use the C() function in L.

=item match_level = 1

Match ignoring case and diacritics: I to I involves 1 edit (from I to I only)

=item match_level = 2

Match ignoring case but respect diacritics: "ber" to "BéZ" involves 2 edits (the "er" to "éZ")

=item match_level = 3

Match with respect to case and diacritics: "ber" to "BéZ" involves 3 edits (of all its letters)

=back

So, for example, if the test string is "abbé", it could be picked up as having the single-substitution orthographic neighbour "able" if the match level is 1, but not if it is 0, 2 or 3.

=cut

sub set_eq {
    my ( $self, %args ) = @_;
    my $match_level_arg = $args{'match_level'};
    if ( nocontent($match_level_arg) or $match_level_arg == 0 ) {
        $self->{'_MATCH_LEVEL'} = 0;
        $self->{'_EQ'} = sub { return $_[0] eq $_[1] };
    }
    elsif ( any { $match_level_arg == $_ } ( 1 .. 3 ) ) {
        $self->{'_MATCH_LEVEL'} = $match_level_arg;
        my $collator = Unicode::Collate->new(
            normalization => undef,
            level         => $match_level_arg
        );
        $self->{'_EQ'} = sub {
            return $collator->eq(@_);
        };
    }
    else {
        croak "Invalid value '$match_level_arg' given as a match level";
    }
    return;
}

# private methods

sub _smallest_len {
    my @strs = @_;
    return ( sort { $a <=> $b } map { length } @strs )[0];
}

sub _are_orthons {
    my ( $w1, $w2, $eq_fn ) = @_;
    return 0 if length $w1 != length $w2;
    return _index_identical( $w1, $w2, $eq_fn ) == ( length $w1 ) - 1;
}

sub _index_identical {
    my ( $w1, $w2, $eq_fn ) = @_;
    my $count = 0;
    for my $i ( 0 .. _smallest_len( $w1, $w2 ) - 1 ) {
        if ( $eq_fn->( map { substr $_, $i, 1 } ( $w1, $w2 ) ) ) {
            $count++;
        }
    }
    return $count;
}

=head1 DIAGNOSTICS

=over 4

=item Invalid value '...' given as a match level

Argument B in new() or set_eq() needs to be an integer in range 0 .. 3, or undefined.

=item Need a single character string to test for orthons

Argument B for calculating ONC and OLD, and listing orthons, needs to be defined and not empty.

=item Need a single character string to test for orthons

Argument B should reference an array of character-strings when calculating ONC and OLD, and listing orthons.

=back

=head1 REFERENCES

Coltheart, M., Davelaar, E., Jonasson, J. T., & Besner, D. (1977). Access to the internal lexicon. In S. Dornic (Ed.), I (Vol. 6, pp. 535-555). London, UK: Academic.

Yarkoni, T., Balota, D. A., & Yap, M. (2008). Moving beyond Coltheart's I: A new measure of orthographic similarity. I, I<15>, 971-979. doi: L<10.3758/PBR.15.5.971|http://dx.doi.org/10.3758/PBR.15.5.971>.

=head1 DEPENDENCIES

L

L

L

L

L

L

L

=head1 AUTHOR

Roderick Garton, C<<  >>

=head1 SEE ALSO

L

L

L

=head1 BUGS AND LIMITATIONS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Lingua::Orthon

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2011-2018 Roderick Garton.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See L for more information.

=cut

1;    # End of Lingua::Orthon