TIGERweb.pm

   1 package Geo::USCensus::TIGERweb;
   2
   3 use strict;
   4 use warnings;
   5
   6 use LWP::UserAgent;
   7 use HTTP::Request::Common;
   8 use JSON::MaybeXS;
   9 use IO::Socket::SSL;
  10 use List::Util qw(first);
  11
  12 use Geo::USCensus::TIGERweb::Service;
  13
  14 =head1 NAME
  15
  16 Geo::USCensus::TIGERweb - The U.S. Census Bureau TIGER data services
  17
  18 =cut
  19
  20 our $VERSION = '0.01';
  21 our $DEBUG = 0;
  22
  23 =head1 SYNOPSIS
  24
  25     use Geo::USCensus::TIGERweb;
  26
  27     print Dumper(Geo::USCensus::TIGERweb->info); # enumerates services
  28     my $service = Geo::USCensus::TIGERweb->service('Tracts_Blocks');
  29     print Dumper($service->info);
  30     my $layer = $service->layer('Census Blocks'); # id or name
  31     print Dumper($layer->info);
  32     my $result = $layer->query(
  33       # required fields
  34       geometry    => { x => -121.48778, y => 38.578793 }, # see below
  35       fields      => [ 'OID', 'GEOID', 'STATE', 'COUNTY' ],
  36       # optional
  37       # spatialRel  => 'esriSpatialRelIntersects', # see below
  38       # inSR      => 4326, # the default, GPS coords
  39       # outSR     => 4326,
  40     );
  41
  42     # convenience method: given a longitude and latitude, return
  43     # the census block containing that point, or dies on error
  44     my $blocknum = Geo::USCensus::TIGERweb->census_block_at_point(
  45       lat => 38.578793,
  46       lon => -121.48778
  47     );
  48
  49 =head1 CLASS METHODS
  50
  51 =over 4
  52
  53 =item info
  54
  55 Returns a description of the available services.
  56
  57 =item service NAME
  58
  59 Constructor; returns a L<Geo::USCensus::TIGERweb::Service> handle to the
  60 named service.
  61
  62 =cut
  63
  64 my $ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 0, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE });
  65 my $url = 'https://tigerweb.geo.census.gov/arcgis/rest/services';
  66
  67 our $GLOBAL = bless { debug => 0, info => undef, path => 'TIGERweb' };
  68
  69 # in principle this could be turned into a general ArcGIS client
  70
  71 sub request {
  72   my ($self, $path, $params) = @_;
  73   $self = $GLOBAL if !ref($self);
  74   my $full_path = join('/', $url, $self->{path});
  75   $full_path .= "/$path" if $path;
  76   $params = [ %$params ] if ref($params) eq 'HASH';
  77   push @$params, ( f => 'pjson' ); # always use this
  78   warn "POST $full_path\n" if $self->{debug};
  79   warn encode_json($params)."\n" if $self->{debug} > 1;
  80   my $response = $ua->request(
  81     POST $full_path, Content => $params
  82   );
  83   if ( !$response->is_success ) {
  84     $self->{error} = $response->status_line;
  85     return;
  86   }
  87   my $data = decode_json($response->decoded_content);
  88   if ( $data->{error} ) {
  89     $self->{error} = $data->{error}{message};
  90     return;
  91   }
  92   return $data;
  93 }
  94
  95 sub info {
  96   my $self = shift;
  97   $self = $GLOBAL if !ref($self);
  98   return $self->{info} ||= $self->request('');
  99 }
 100
 101 sub create {
 102   # internal constructor
 103   my $self = shift;
 104   my $subclass = shift;
 105   my $subpath = shift;
 106   $self = $GLOBAL if !ref($self);
 107   my $class = "Geo::USCensus::TIGERweb::$subclass";
 108   my $new = { debug => $self->{debug},
 109               info  => undef,
 110               path  => $self->{path} . '/' . $subpath,
 111             };
 112   bless $new, $class;
 113   return $new;
 114 }
 115
 116 sub service {
 117   my $class = shift;
 118   my $service_name = shift;
 119   my $def = first { $_->{name} eq "TIGERweb/$service_name" }
 120             @{ $GLOBAL->info->{services} };
 121   die "TIGERweb service name '$service_name' not found" if !$def;
 122   my $type = $def->{type};
 123   return $GLOBAL->create('Service', "$service_name/$type");
 124 }
 125
 126 =item census_block_at_point PARAMS
 127
 128 Takes numeric values for "lat" and "lon" and returns the census block number
 129 at that location. This is actually the reason for this entire library.
 130
 131 =cut
 132
 133 sub census_block_at_point {
 134   my ($class, %opt) = @_;
 135   die "latitude and longitude required\n"
 136     unless defined($opt{lat}) and defined($opt{lon});
 137   $GLOBAL->{debug} = $opt{debug} if $opt{debug};
 138   my $layer = $class->service('Tracts_Blocks')->layer('Census Blocks');
 139   my $result = $layer->query(
 140     geometry => { x => $opt{lon}, y => $opt{lat} },
 141     fields   => [ 'GEOID' ],
 142   );
 143   if ($layer->{error}) {
 144     warn $layer->{error}."\n";
 145   }
 146   if (my $f = $result->{features}) {
 147     if (scalar(@$f) == 0) {
 148       warn "no census block found\n";
 149       return;
 150     } else {
 151       return $f->[0]->{attributes}{GEOID};
 152     }
 153   } else {
 154     warn "no features in query result\n";
 155     return;
 156   }
 157 }
 158
 159 =back
 160
 161 =head1 LICENSE AND COPYRIGHT
 162
 163 Copyright (C) 2016 Mark Wells.
 164 Copyright (C) 2016 Freeside Internet Services, Inc.
 165
 166 This program is free software; you can redistribute it and/or modify it
 167 under the terms of either: the GNU General Public License as published
 168 by the Free Software Foundation; or the Artistic License.
 169
 170 See http://dev.perl.org/licenses/ for more information.
 171
 172 =cut
 173
 174 1;