make sure stop has length too
[reference.git] / lib / Reference / Retrieve / PubMed.pm
1 # This module is part of Refence, and is released under the terms of
2 # the GPL version 2, or any later version. See the file README and
3 # COPYING for more information.
4 # Copyright 2003 by Don Armstrong <don@donarmstrong.com>.
5 # $Id: PubMed.pm 45 2013-09-10 18:05:31Z don $
6
7 package Reference::Retrieve::PubMed;
8
9 =head1 NAME
10
11 Reference::Retrieve::PubMed -- Reference Retrieval from PubMed
12
13 =head1 SYNOPSIS
14
15      my $reference = Reference::Retrieve::PubMed::get_reference(-pmid=>123456);
16      my @references = Reference::Retrieve::PubMed::get_reference(-query=>'John Smith[AUTHOR] AND 230[Pages]',limit=>50);
17
18
19 =head1 DESCRIPTION
20
21 Uh. Retreives references from pubmed. Yeah.
22
23 =head1 BUGS
24
25 None known.
26
27 =cut
28
29
30 use strict;
31 use vars qw($REVISION $DEBUG);
32 use Carp;
33
34 use LWP::UserAgent;
35 use XML::Simple qw(:strict);
36 use Reference;
37
38 use HTML::Entities;
39
40 use Params::Validate qw(:types validate_with);
41
42 BEGIN{
43      ($REVISION) = q$LastChangedRevision: 45 $ =~ /\$LastChangedRevision:\s+([^\s+])/;
44      $DEBUG = 0 unless defined $DEBUG;
45 }
46
47
48 =head2 get_reference
49
50 =head3 Usage
51
52      my $reference = Reference::Retrieve::PubMed::get_reference(-pmid=>123456);
53      my @references = Reference::Retrieve::PubMed::get_reference(-query=>'John Smith[AUTHOR] AND 230[Pages]',-limit=>50);
54      my @references = Reference::Retrieve::PubMed::get_reference(-query=>{author=>'John Smith', pages=>'230'},-limit=>50)
55
56 =head3 Function
57
58 Retrives a reference from pubmed
59
60 =head3 Returns
61
62 In scalar context, effectively assumes -limit=>1 and returns the
63 highest listed reference according to the order, etc. [Probably only
64 usefull with -pmid.] In list context, returns all results (or until it
65 hits the -limit.)
66
67 =head3 Args
68
69 list of arguments to select a reference or collection of references from.
70
71
72 =cut
73
74 sub get_reference{
75      my %options = validate_with(params => @_,
76                                  spec   => {pubmed_site  => {default => 'http://www.ncbi.nlm.nih.gov'},
77                                             pmid_query   => {default => '/entrez/query.fcgi?cmd=Text&db=PubMed&dopt=XML&uid='},
78                                             search_query => {default => '/htbin-post/Entrez/query?db=m&form=4&dispmax=100&html=no&dopt=u&term='},
79                                             ua_agent     => {default => "DA Reference::Retreive::PubMed/$REVISION"},
80                                             email        => {default => "don+referenceretrieve$REVISION\@donarmstrong.com"},
81                                            },
82                                  allow_extra => 1,
83                                 );
84      my $ua = new LWP::UserAgent(agent => $options{ua_agent});
85 }
86
87 sub get_reference_by_pmid($;@){
88      my %options = validate_with(params => \@_,
89                                  spec   => {pmid => {type => SCALAR|ARRAYREF,
90                                                      #regex => qr/^\d+$/,
91                                                     },
92                                             pubmed_site  => {default => 'http://www.ncbi.nlm.nih.gov'},
93                                             pmid_query   => {default => '/entrez/eutils/efetch.fcgi?db=pubmed&retmode=xml&rettype=full&id='},
94                                             search_query => {default => '/htbin-post/Entrez/query?db=m&form=4&dispmax=100&html=no&dopt=u&term='},
95                                             ua_agent     => {default => "DA Reference::Retreive::PubMed/$REVISION"},
96                                             email        => {default => "don+referenceretrieve$REVISION\@donarmstrong.com"},
97                                             useragent    => {optional => 1},
98                                            },
99                                  allow_extra => 1,
100                                 );
101      my $pmid = $options{pmid};
102
103      my $ua;
104      if ($options{useragent}) {
105           $ua = $options{useragent};
106      }
107      else {
108           $ua = new LWP::UserAgent(agent=>$options{ua_agent});
109      }
110      my $url = "$options{pubmed_site}$options{pmid_query}" . (ref($pmid) ? (join('&id=',@{$pmid})) : $pmid);
111      print STDERR "url: $url" if $DEBUG;
112      my $request = HTTP::Request->new('GET', $url);
113      my $response = $ua->request($request);
114      $response = $response->content;
115      print STDERR "response: $response" if $DEBUG;
116
117      # For some dumb reason, they send us xml with html
118      # entities. Ditch them.
119      #$response = decode_entities($response);
120      # It's even more freaking broken; they don't double encode them.
121      #$response =~ s/\&gt;(\s|$)/>$1/gso;
122      #$response =~ s/(?:(\s)\&lt;|&lt;(\/))/$1<$2/gso;
123      $response =~ s/&quot;/"/gso;
124
125      # Ditch any doctype
126      $response =~ s/^\s*<\?xml[^>]+>\s*//gso;
127      $response =~ s/^\s*<\!DOCTYPE[^>]+>\s*//gso;
128      # There is also a Pubmedarticleset
129      $response =~ s/^\s*<PubmedArticleSet>\s*//gso;
130      $response =~ s#</PubmedArticleSet>\s*$##gso;
131
132      # Add the opt so we get an array of PubMedArticle
133      $response = "<opt>$response</opt>";
134
135      print STDERR $response if $DEBUG;
136
137      # Figure out if there was an error in the search.
138
139      # Response should be in XML. Parse it.
140      my $xa = new XML::Simple;
141
142      my $ref_struct = $xa->XMLin($response, ForceArray => [ 'PubmedArticle' ],KeyAttr=>[]);
143
144      use Data::Dumper;
145      print STDERR Dumper($ref_struct) if $DEBUG;
146      # Handle the XML structure
147      my @references;
148      foreach my $ref (@{$ref_struct->{PubmedArticle}}) {
149           my $reference =  _create_reference_from_xml($ref,$ua);
150           if (not defined $reference) {
151                warn "Unable to create reference for $ref->{MedlineCitation}->{PMID}\n";
152           }
153           push @references, $reference;
154      }
155      if (wantarray) {
156           return @references;
157      }
158      return $references[0];
159 }
160
161 sub _create_reference_from_xml($$){
162      my ($ref,$ua) = @_;
163
164      # Figure out what type of reference this is. We only support
165      # Journal Articles right now.
166      my $types = {'journal article'=>'article',
167                   'letter'         =>'article',
168                   'editorial' => 'article',
169                   'review' => 'article',
170                  };
171      my $ref_type = undef;
172      my $reference = undef;
173      foreach my $type (keys %{$types}) {
174           if (ref($ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}) eq 'ARRAY'){
175                my $pubtypes;
176                @{$pubtypes}{map {lc} @{$ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}}} =
177                     (1) x @{$ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}};
178                if ($pubtypes->{$type}) {
179                     $ref_type = $types->{$type};
180                     last;
181                }
182                else {
183                     next;
184                }
185           }
186           elsif (lc($ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}) eq lc($type)) {
187                $ref_type = $types->{$type};
188                last;
189           }
190      }
191      if (not defined $ref_type) {
192           warn "Unsupported PublicationType: ".Dumper($ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType});
193           print STDERR Dumper($ref) if $DEBUG;
194           $ref_type = 'article';
195      }
196      local $_ = $ref_type;
197      if (/article/) {
198           use Reference::Type::Article;
199           $reference = new Reference::Type::Article;
200           my $xml_mapping = {author     => [ _fix_medline_authors($ref->{MedlineCitation}->{Article}->{AuthorList}) ],
201                              title      => [_fix_medline_title($ref->{MedlineCitation}->{Article}->{ArticleTitle})],
202                              abstract   => [_fix_medline_abstract($ref->{MedlineCitation}->{Article}->{Abstract}->{AbstractText})],
203                              journal    => [_fix_medline_journal($ref->{MedlineCitation}->{Article}->{Journal},
204                                                                  $ref->{MedlineCitation}->{Article}->{MedlineJournalInfo},
205                                                                  $ua,
206                                                                  #@_, # configuration
207                                                                 )],
208                              _fix_ids($ref),
209                              # pmid       => $ref->{MedlineCitation}->{PMID},
210                              # medline_id => $ref->{MedlineCitation}->{MedlineID},
211                              volume     => [_fix_medline_ditch_empty($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{Volume})],
212                              date       => [_fix_medline_pubdate($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{PubDate})],
213                              number     => [_fix_medline_ditch_empty($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{Issue})],
214                              pages      => [_fix_medline_pages($ref->{MedlineCitation}->{Article}->{Pagination}->{MedlinePgn})],
215 #                            keywords   => [_fix_medline_keywords($ref->{MedlineCitation}->{MeshHeadingList},
216 #                                                                 $ref->{MedlineCitation}->{ChemicalList},
217 #                                                                )],
218 #                            &_find_pubmed_links($ref->{MedlineCitation}->{PMID},$ua),
219                             };
220           # Deal with author
221
222           foreach my $reference_key (keys %{$xml_mapping}) {
223                my $method = $reference->can($reference_key);
224                die "Reference::Type::Article was unable to handle $reference_key" if not $method;
225                if (defined $xml_mapping->{$reference_key} and $method) {
226                     if (ref($xml_mapping->{$reference_key})) {
227                 &{$method}($reference,@{$xml_mapping->{$reference_key}});
228                     }
229                     else {
230                          &{$method}($reference,$xml_mapping->{$reference_key});
231                     }
232                }
233                else {
234                     warn "Reference_key $reference_key was not defined or unable to handle type of key."
235                          if not defined $xml_mapping->{$reference_key} and $DEBUG;
236                }
237           }
238           return $reference;
239      }
240 }
241
242 sub _fix_medline_title($){
243      my $title = shift;
244
245      $title =~ s/\.$//;
246      return $title;
247 }
248
249 sub _fix_medline_abstract{
250     my $abstract = shift;
251     my $ret = '';
252     if (ref($abstract) and ref($abstract) eq 'ARRAY') {
253         for my $element (@{$abstract}) {
254             $ret .= "\n" if length $ret;
255             $ret .= $element->{Label}.': '.$element->{content};
256         }
257         return $ret;
258     } elsif (ref($abstract) and ref($abstract) eq 'HASH') {
259         return $abstract->{Label}.': '.$abstract->{content};
260     } else {
261         return $abstract;
262     }
263 }
264
265
266 sub _fix_medline_authors($){
267      my $author_list = shift;
268      $author_list = $author_list->{Author};
269      my @authors;
270      $author_list = [$author_list] if ref($author_list) ne 'ARRAY';
271      foreach my $author (@{$author_list}) {
272           my %au;
273           $au{first} = $author->{ForeName} if exists $author->{ForeName};
274           $au{last}  = $author->{LastName} if exists $author->{LastName};
275           $au{initials} = $author->{Initials} if exists $author->{Initials};
276           $au{full};
277           push @authors,\%au;
278      }
279      return (author=>\@authors);
280 }
281
282 =head2 _fix_medline_journal
283
284 =head3 Usage
285
286      $reference->journal(_fix_medline_journal($ref->{MedlineCitation}->{Article}->{Journal},
287                                               $ref->{MedlineCitation}->{Article}->{MedlineJournalInfo},
288                                               $ua,));
289
290 =head3 Function
291
292 From the medline citation informatino returns a properly formatted
293 list of information for the journal reference listing.
294
295 =head3 Args
296
297 Journal information hashref
298
299 medline journal information hashref
300
301 user agent
302
303 =cut
304
305 sub _fix_medline_journal($$$;){
306      my ($journal,$medline_journal,$ua) = @_;
307      # journal takes fullname, issn, medlineabbr, pmid, and nlmuid
308      # Try to supply as much as possible.
309      # Use esearch to get pmjournalid
310      # http://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=journals&term=0021-9258
311      # use esummary to retreive the journalid
312      # <?xml version="1.0"?>
313      # <!DOCTYPE eSearchResult PUBLIC "-//NLM//DTD eSearchResult, 11 May 2002//EN" "http://www.ncbi.nlm.nih.gov/entrez/query/DTD/eSearch_020511.dtd">
314      # <eSearchResult>
315      #  <Count>1</Count>
316      #  <RetMax>1</RetMax>
317      #  <RetStart>0</RetStart>
318      #  <IdList>
319      #          <Id>4559</Id>
320      #
321      #  </IdList>
322      #  <TranslationSet>
323      #  </TranslationSet>
324      #  <TranslationStack>
325      #          <TermSet>
326      #                  <Term>0021-9258[All Fields]</Term>
327      #                  <Field>All Fields</Field>
328      #                  <Count>1</Count>
329      #
330      #                  <Explode>Y</Explode>
331      #          </TermSet>
332      #  </TranslationStack>
333      # </eSearchResult>
334
335      my $ISSN = $journal->{ISSN};
336      if (ref $ISSN) {
337           $ISSN = $ISSN->{content};
338      }
339      my $url = qq(http://www.ncbi.nlm.nih.gov/nlmcatalog/?term=${ISSN}[ISSN]&format=text&report=xml);
340      print STDERR "url: $url" if $DEBUG;
341      my $request = HTTP::Request->new('GET', $url);
342      my $response = $ua->request($request);
343      $response = $response->content;
344      $response =~ s/\&gt;/>/gso;
345      $response =~ s/\&lt;/</gso;
346      $response =~ s/^<\/?pre>//;
347
348      print STDERR "response: $response" if $DEBUG;
349      my $xa = new XML::Simple;
350      my $ref_struct = $xa->XMLin($response,ForceArray=>['NCBICatalogRecord'],KeyAttr=>[]);
351      my $ref = $ref_struct->{NCBICatalogRecord}[0];
352      print STDERR Dumper($ref) if $DEBUG;
353
354      my %journal;
355      while ($response =~ m{^\s*(?:(?:<id>\s*(\d+)</id>)| # Match ids
356                            (?:<item\s+name=\"([^\"]+)\"\s+Type=\"String\">\s*([^<]+?)</item>))\s* # Match item Name clauses
357                            $}ixmg) {
358           if (not defined $2) {
359                $journal{id} = $1;
360           }
361           else {
362                $journal{lc($2)} = $3;
363           }
364   }
365      if (ref $ref->{JrXml}{Serial}{ISSN} ne 'ARRAY') {
366          $ref->{JrXml}{Serial}{ISSN} = [$ref->{JrXml}{Serial}{ISSN}];
367      }
368      my $print_issn = $ref->{JrXml}{Serial}{ISSN}[0]{IssnType} eq 'Print' ? 0 : 1;
369      my @journal_entry =
370          (title       => $ref->{JrXml}{Serial}{Title},
371           medlineabbr => $ref->{JrXml}{Serial}{MedlineTA},
372           isoabbr     => $ref->{JrXml}{Serial}{ISOAbbreviation},
373           nlmid       => $ref->{JrXml}{Serial}{NlmUniqueID},
374           issn        => $ref->{JrXml}{Serial}{ISSN}[$print_issn]{ISSN},
375           eissn       => $ref->{JrXml}{Serial}{ISSN}[1-$print_issn]{ISSN},
376           publisher   => $ref->{JrXml}{Serial}{publicationInfo}{Publisher},
377           pmid        => $ref->{JrXml}{id},
378          );
379      print STDERR Dumper(\@journal_entry) if $DEBUG;
380      return @journal_entry;
381 }
382
383 =head2 
384
385 =head3 Usage
386
387      $reference->date(_fix_medline_pubdate($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{PubDate}));
388
389 =head3 Function
390
391 =head3 Returns
392
393 =head3 Args
394
395 =cut
396
397 sub _fix_medline_pubdate($){
398      my ($date) = shift;
399      return (year=>$date->{Year},month=>$date->{Month},day=>$date->{Day}) if exists $date->{Year};
400      # Ok... punt.
401      if (exists $date->{MedlineDate}) {
402           my ($year,$month,$day) = split /\s+/,$date->{MedlineDate};
403           return (year=>$year,month=>$month,day=>$day)
404      }
405 }
406
407 =head2 _fix_medline_pages
408
409 =head3 Usage
410
411      pages      => [_fix_medline_pages($ref->{MedlineCitation}->{Article}->{Pagination}->{MedlinePgn})],
412
413 =head3 Function
414
415 Returns output with a list of pages appropriate for an Article type of
416 reference.
417
418 =cut
419
420 sub _fix_medline_pages($){
421      my ($pagination) = @_;
422      my ($start,$stop) = $pagination =~ /(\d*)\s*\-\s*(\d*)/;
423      if (not defined $start) {
424          ($start) = $pagination =~ /(\d+)/
425      }
426      if ($start > $stop and defined $stop and length($stop)) {
427          # this must be a reduced page listing; fix it up
428          $stop+=$start - $start % 10 ** (int(log($stop)/log(10))+1);
429      }
430      my @return;
431      push @return, (start=>$start) if defined $start and $start ne '';
432      push @return, (stop=>$stop) if defined $stop and $stop ne '';
433      return @return;
434 }
435
436 sub _find_pubmed_links($$){
437      my ($pmid,$ua) = @_;
438      return ();
439      #http://eutils.ncbi.nlm.nih.gov/entrez/query/static/elink_help.html
440      my $url = "http://eutils.ncbi.nlm.nih.gov/entrez/eutils/elink.fcgi?dbfrom=pubmed&cmd=llinks&id=" . (ref($pmid) ? (join('&id=',@{$pmid})) : $pmid);
441      print STDERR "url: $url" if $DEBUG;
442      my $request = HTTP::Request->new('GET', $url);
443      my $response = $ua->request($request);
444      $response = $response->content;
445      print STDERR "response: $response" if $DEBUG;
446
447      # Response should be in XML. Parse it.
448      my $xa = new XML::Simple;
449
450      my $ref_struct = $xa->XMLin($response, ForceArray => ['IdUrlSet'], KeyAttr=>[]);
451
452      use Data::Dumper;
453      print STDERR Dumper($ref_struct);# if $DEBUG;
454      # Rearange data around Id.
455      my $links = {};
456      map {$links->{$_->{Id}}=$_->{ObjUrl}} @{$ref_struct->{LinkSet}->{IdUrlList}->{IdUrlSet}};
457      foreach my $obj_url (@{$links->{$pmid}->{ObjUrl}}) {
458           next unless $obj_url->{SubjectType} = 'publishers/providers';
459           #@links = _find_links_from_url($obj_url->{Url},$ua);
460      }
461      # Find publisher link
462      # If no publisher link, use the first aggregator link.
463 }
464
465 =head2 _fix_ids
466
467      _fix_ids
468
469
470
471 =cut
472
473 sub _fix_ids {
474      my ($ref) = @_;
475
476      my %ids_known = (medline => 'medline_id',
477                       pubmed  => 'pmid',
478                       doi     => 'doi',
479                      );
480      my %ids;
481      if (exists $ref->{PubmedData}{ArticleIdList}{ArticleId}) {
482           for my $art_id (ref($ref->{PubmedData}{ArticleIdList}{ArticleId}) eq 'ARRAY' ?
483                @{$ref->{PubmedData}{ArticleIdList}{ArticleId}}:
484                     ($ref->{PubmedData}{ArticleIdList}{ArticleId})) {
485                if (exists $ids_known{$art_id->{IdType}}) {
486                     $ids{$ids_known{$art_id->{IdType}}} = $art_id->{content};
487                }
488           }
489      }
490      if (not exists $ids{pmid}) {
491           $ids{pmid} = $ref->{MedlineCitation}->{PMID} if defined $ref->{MedlineCitation}->{PMID};
492      }
493      if (not exists $ids{medline_id}) {
494           $ids{medline_id} = $ref->{MedlineCitation}->{MedlineID} if defined $ref->{MedlineCitation}->{MedlineID};
495      }
496      return %ids;
497 }
498
499
500 =head2 _find_links_from_url
501
502 =head3 Usage
503
504 =head3 Function
505
506 =head3 Returns
507
508 =head3 Args
509
510 =cut
511
512 sub _find_links_from_url($$){
513      my ($link,$ua) = @_;
514
515      
516      
517 }
518
519 sub _fix_medline_ditch_empty($){
520      my ($value) = @_;
521
522      if (ref($value)) {
523           if (ref($value) eq 'HASH') {
524                if (scalar keys %{$value} > 0) {
525                     return $value;
526                }
527                else {
528                     return ();
529                }
530           }
531           elsif (ref($value) eq 'ARRAY') {
532                if (scalar @{$value} > 0) {
533                     return $value;
534                }
535                else {
536                     return ();
537                }
538           }
539           else {
540                return ();
541           }
542      }
543      else {
544           return $value if defined $value;
545           return ();
546      }
547 }
548
549
550 1;
551
552
553 __END__
554
555
556
557
558
559