File Coverage

lib/Geo/Coder/Many/Util.pm
Criterion Covered Total %
statement 61 69 88.4
branch 13 30 43.3
condition 5 9 55.5
subroutine 18 18 100.0
pod 5 5 100.0
total 102 131 77.8


line stmt bran cond sub pod time code
1             package Geo::Coder::Many::Util;
2              
3 3     3   544 use strict;
  3         5  
  3         75  
4 3     3   12 use warnings;
  3         2  
  3         69  
5 3     3   1193 use Geo::Distance::XS; # for calculating precision
  3         37855  
  3         16  
6 3     3   100 use List::Util qw( reduce );
  3         3  
  3         229  
7 3     3   476 use List::MoreUtils qw( any );
  3         7560  
  3         25  
8              
9             our @EXPORT_OK = qw(
10             min_precision_filter
11             max_precision_picker
12             consensus_picker
13             country_filter
14             );
15 3     3   1101 use Exporter;
  3         3  
  3         93  
16 3     3   11 use base qw(Exporter);
  3         3  
  3         1447  
17              
18             our $VERSION = '0.01';
19              
20             my $GDXS = Geo::Distance->new;
21              
22             =head1 NAME
23              
24             Geo::Coder::Many::Util
25              
26             =head1 DESCRIPTION
27              
28             Miscellaneous routines that are convenient for, for example, generating
29             commonly used callback methods to be used with Geo::Coder::Many.
30              
31             =head1 SUBROUTINES
32              
33             =head2 min_precision_filter
34              
35             Constructs a result filter callback which only passes results which exceed the
36             specified precision.
37              
38             =cut
39              
40             sub min_precision_filter {
41 1     1 1 5 my $precision_cutoff = shift;
42             return sub {
43 150     150   135 my $result = shift;
44 150 50       192 if ( !defined $result->{precision} ) {
45 0         0 return 0;
46             }
47 150         457 return $result->{precision} >= $precision_cutoff;
48             }
49 1         4 }
50              
51             =head2 country_filter
52              
53             Constructs a result filter callback which only passes results with the
54             specified 'country' value.
55              
56             =cut
57              
58             sub country_filter {
59 1     1 1 29 my $country_name = shift;
60             return sub {
61 149     149   104 my $result = shift;
62 149 50       211 if ( !exists $result->{country} ) {
63 0         0 return 0;
64             }
65 149         443 return $result->{country} eq $country_name;
66             }
67 1         4 }
68              
69             =head2 max_precision_picker
70              
71             A picker callback that requests all available results, and then picks the one
72             with the highest precision. Note that querying all available geocoders may take
73             a comparatively long time.
74              
75             Example:
76              
77             $GCMU->set_picker_callback( \&max_precision_picker );
78              
79             =cut
80              
81             sub max_precision_picker {
82 553     553 1 434 my ($ra_results, $more_available) = @_;
83              
84             # If more results are available, request them
85 553 100       791 return if $more_available;
86              
87             # If we have all of the results, find the best
88 420         506 return &_find_max_precision($ra_results);
89             }
90              
91             =head2 consensus_picker
92              
93             Returns a picker callback that requires at least 'required_consensus' separate
94             geocoder results to be within a bounding square of side-length 'nearness'. If
95             this can be satisfied, the result from that square which has the highest
96             precision will be returned. Otherwise, asks for more/returns undef.
97              
98             WARNING: quadratic time in length of @$ra_results - could be improved if
99             necessary.
100              
101             Example:
102              
103             $GCMU->set_picker_callback(
104             consensus_picker({nearness => 0.1, required_consensus => 2})
105             );
106              
107             =cut
108              
109             sub consensus_picker {
110 1     1 1 15 my $rh_args = shift;
111 1         3 my $nearness = $rh_args->{nearness};
112 1         1 my $required_consensus = $rh_args->{required_consensus};
113             return sub {
114 570     570   458 my $ra_results = shift;
115              
116 570         334 for my $result_a (@{$ra_results}) {
  570         641  
117              
118 300         231 my $lat_a = $result_a->{latitude};
119 300         243 my $lon_a = $result_a->{longitude};
120              
121             # Find all of the other results that are close to this one
122             my @consensus = grep {
123 300         241 _in_box(
124             $lat_a,
125             $lon_a,
126             $nearness,
127             $_->{latitude},
128             $_->{longitude}
129             )
130 353         472 } @$ra_results;
131              
132 300 100       531 if ($required_consensus <= @consensus) {
133             # If the consensus is sufficiently large, return the result
134             # with the highest precision
135 53         85 return _find_max_precision(\@consensus);
136             }
137              
138             }
139              
140             # No consensus reached
141 517         693 return;
142 1         6 };
143             }
144              
145             =head2 determine_precision_from_bbox
146              
147             my $precision = Geo::Coder::Many::Util->determine_precision_from_bbox({
148             'lon1' => $sw_lon,
149             'lat1' => $sw_lat,
150             'lon2' => $ne_lon,
151             'lat2' => $ne_lat,
152             });
153              
154             returns a precison between 0 (unknown) and 1 (highly precise) based on
155             the size of the box supplied
156              
157             =cut
158              
159             sub determine_precision_from_bbox {
160 3   100 3 1 958 my $rh_args = shift || return 0;
161              
162             my $distance = $GDXS->distance('kilometer',
163             $rh_args->{lon1}, $rh_args->{lat1} =>
164 2         19 $rh_args->{lon2}, $rh_args->{lat2});
165              
166 2 50       5 return 0 if (!defined($distance));
167 2 100       7 return 1.0 if ($distance < 0.25);
168 1 50       3 return 0.9 if ($distance < 0.5);
169 1 50       2 return 0.8 if ($distance < 1);
170 1 50       4 return 0.7 if ($distance < 5);
171 0 0       0 return 0.6 if ($distance < 7.5);
172 0 0       0 return 0.5 if ($distance < 10);
173 0 0       0 return 0.4 if ($distance < 15);
174 0 0       0 return 0.3 if ($distance < 20);
175 0 0       0 return 0.2 if ($distance < 25);
176 0         0 return 0.1;
177             }
178              
179             =head1 INTERNAL ROUTINES
180              
181             =head2 _in_box
182              
183             Used by consensus_picker - returns true if ($lat, $lon) is inside the square
184             with centre ($centre_lat, $centre_lon) and side length 2*$half_width.
185              
186             =cut
187              
188             sub _in_box {
189 353     353   270 my ($centre_lat, $centre_lon, $half_width, $lat, $lon) = @_;
190              
191 353   33     2512 return $centre_lat - $half_width < $lat
192             && $centre_lat + $half_width > $lat
193             && $centre_lon - $half_width < $lon
194             && $centre_lon + $half_width > $lon;
195             }
196              
197             =head2 _find_max_precision
198              
199             Given a reference to an array of result hashes, returns the one with the
200             highest precision value
201              
202             =cut
203              
204             sub _find_max_precision {
205 473     473   330 my $ra_results = shift;
206             return reduce {
207 102 50 50 102   493 ($a->{precision} || 0.0) > ($b->{precision} || 0.0) ? $a : $b
      50        
208 473         901 } @{$ra_results};
  473         1361  
209             }
210              
211             1;