File Coverage

blib/lib/Tree/BK.pm
Criterion Covered Total %
statement 56 58 96.5
branch 16 18 88.8
condition 2 3 66.6
subroutine 10 10 100.0
pod 5 5 100.0
total 89 94 94.6


line stmt bran cond sub pod time code
1             #
2             # This file is part of Tree-BK
3             #
4             # This software is copyright (c) 2014 by Nathan Glenn.
5             #
6             # This is free software; you can redistribute it and/or modify it under
7             # the same terms as the Perl 5 programming language system itself.
8             #
9             package Tree::BK;
10             $Tree::BK::VERSION = '0.02';
11 1     1   18729 use strict;
  1         2  
  1         28  
12 1     1   4 use warnings;
  1         1  
  1         21  
13 1     1   412 use Text::Levenshtein::XS qw(distance);
  1         625  
  1         69  
14 1     1   4 use Carp;
  1         2  
  1         424  
15              
16             # ABSTRACT: Structure for efficient fuzzy matching
17              
18              
19             sub new {
20 4     4 1 2049 my ($class, $metric) = @_;
21 4 100       10 if(defined $metric){
22 2 100       6 if((ref $metric) ne 'CODE'){
23 1         25 croak 'argument to new() should be ' .
24             'a code reference implementing a metric';
25             }
26             }else{
27 2         5 $metric = \&Text::Levenshtein::XS::distance;
28             }
29 3         13 my $tree = bless {
30             metric => $metric,
31             root => undef,
32             size => 0,
33             }, $class;
34 3         5 return $tree;
35             }
36              
37              
38             sub insert {
39 18     18 1 766 my ($self, $object) = @_;
40 18 100       28 if(!defined $self->{root}){
41 3         6 $self->{root} = { object=>$object };
42 3         4 $self->{size}++;
43 3         8 return $object;
44             }
45              
46 15         14 my $current = $self->{root};
47 15         29 my $dist = $self->{metric}->($current->{object}, $object);
48 15         106 while(exists $current->{$dist}){
49             # object was already in the tree
50 2 50       5 if($dist == 0){
51 0         0 return;
52             }
53 2         3 $current = $current->{$dist};
54 2         6 $dist = $self->{metric}->($current->{object}, $object);
55             }
56             # prevent adding the root node multiple times
57 15 100       30 if($dist == 0){
58 2         8 return;
59             }
60 13         23 $current->{$dist} = {object => $object};
61 13         11 $self->{size}++;
62 13         22 return $object;
63             }
64              
65             sub insert_all {
66 3     3 1 16 my ($self, @objects) = @_;
67 3 50       7 if(@objects < 1){
68 0         0 croak 'Must pass at least one object to insert_all method';
69             }
70 3         6 my $size_before = $self->size;
71 3         8 $self->insert($_) for @objects;
72 3         5 return $self->size - $size_before;
73             }
74              
75             sub find {
76 2     2 1 8 my ($self, $target, $threshold) = @_;
77 2         3 my @return;
78 2         5 $self->_find($self->{root}, \@return, $target, $threshold);
79 2         12 return \@return;
80             }
81              
82             sub _find {
83 8     8   9 my ($self, $node, $current_list, $target, $threshold) = @_;
84 8         14 my $distance = $self->{metric}->($node->{object}, $target);
85 8         31 my $min_dist = $distance - $threshold;
86 8         23 my $max_dist = $distance + $threshold;
87 8 100       15 if($distance <= $threshold){
88 7         9 push @$current_list, $node->{object};
89             }
90             # recursively search the children where nodes with the threshold
91             # distance might reside
92 8         16 for(keys %$node){
93 18 100       32 next if $_ eq 'object';
94 10 100 66     33 next unless $_ >= $min_dist && $_ <= $max_dist;
95 6         13 $self->_find($node->{$_}, $current_list, $target, $threshold);
96             }
97             }
98              
99             sub size {
100 9     9 1 12 my ($self) = @_;
101 9         28 return $self->{size};
102             }
103              
104              
105             1;
106              
107             __END__