6cc771be078e9db14c95cfdf087d1b117626e771
[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\n" 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\n" if $DEBUG;
349      my $xa = new XML::Simple;
350      my $ref_struct = $xa->XMLin($response,ForceArray=>['NCBICatalogRecord'],KeyAttr=>[]);
351      my $ref;
352      for (0..@{$ref_struct->{NCBICatalogRecord}}) {
353          if (exists $ref_struct->{NCBICatalogRecord}[$_]{JrXml}) {
354              $ref = $ref_struct->{NCBICatalogRecord}[$_];
355              last;
356          }
357      }
358      $ref = $ref_struct->{NCBICatalogRecord}[0] if not defined $ref;
359      print STDERR Dumper($ref) if $DEBUG;
360
361      my %journal;
362      while ($response =~ m{^\s*(?:(?:<id>\s*(\d+)</id>)| # Match ids
363                            (?:<item\s+name=\"([^\"]+)\"\s+Type=\"String\">\s*([^<]+?)</item>))\s* # Match item Name clauses
364                            $}ixmg) {
365           if (not defined $2) {
366                $journal{id} = $1;
367           }
368           else {
369                $journal{lc($2)} = $3;
370           }
371   }
372      print STDERR Dumper($ref) if $DEBUG;
373      if (ref $ref->{JrXml}{Serial}{ISSN} ne 'ARRAY') {
374          $ref->{JrXml}{Serial}{ISSN} = [$ref->{JrXml}{Serial}{ISSN}];
375      }
376      print STDERR Dumper($ref->{JrXml}) if $DEBUG;
377      my $print_issn = $ref->{JrXml}{Serial}{ISSN}[0]{IssnType} eq 'Print' ? 0 : 1;
378      my @journal_entry =
379          (title       => $ref->{JrXml}{Serial}{Title},
380           medlineabbr => $ref->{JrXml}{Serial}{MedlineTA},
381           isoabbr     => $ref->{JrXml}{Serial}{ISOAbbreviation},
382           nlmid       => $ref->{JrXml}{Serial}{NlmUniqueID},
383           issn        => $ref->{JrXml}{Serial}{ISSN}[$print_issn]{ISSN},
384           eissn       => $ref->{JrXml}{Serial}{ISSN}[1-$print_issn]{ISSN},
385           publisher   => $ref->{JrXml}{Serial}{publicationInfo}{Publisher},
386           pmid        => $ref->{JrXml}{id},
387          );
388      print STDERR Dumper(\@journal_entry) if $DEBUG;
389      return @journal_entry;
390 }
391
392 =head2 
393
394 =head3 Usage
395
396      $reference->date(_fix_medline_pubdate($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{PubDate}));
397
398 =head3 Function
399
400 =head3 Returns
401
402 =head3 Args
403
404 =cut
405
406 sub _fix_medline_pubdate($){
407      my ($date) = shift;
408      return (year=>$date->{Year},month=>$date->{Month},day=>$date->{Day}) if exists $date->{Year};
409      # Ok... punt.
410      if (exists $date->{MedlineDate}) {
411           my ($year,$month,$day) = split /\s+/,$date->{MedlineDate};
412           return (year=>$year,month=>$month,day=>$day)
413      }
414 }
415
416 =head2 _fix_medline_pages
417
418 =head3 Usage
419
420      pages      => [_fix_medline_pages($ref->{MedlineCitation}->{Article}->{Pagination}->{MedlinePgn})],
421
422 =head3 Function
423
424 Returns output with a list of pages appropriate for an Article type of
425 reference.
426
427 =cut
428
429 sub _fix_medline_pages($){
430      my ($pagination) = @_;
431      my ($start,$stop) = $pagination =~ /(\d*)\s*\-\s*(\d*)/;
432      if (not defined $start) {
433          ($start) = $pagination =~ /(\d+)/
434      }
435      if ($start > $stop and defined $stop and length($stop)) {
436          # this must be a reduced page listing; fix it up
437          $stop+=$start - $start % 10 ** (int(log($stop)/log(10))+1);
438      }
439      my @return;
440      push @return, (start=>$start) if defined $start and $start ne '';
441      push @return, (stop=>$stop) if defined $stop and $stop ne '';
442      return @return;
443 }
444
445 sub _find_pubmed_links($$){
446      my ($pmid,$ua) = @_;
447      return ();
448      #http://eutils.ncbi.nlm.nih.gov/entrez/query/static/elink_help.html
449      my $url = "http://eutils.ncbi.nlm.nih.gov/entrez/eutils/elink.fcgi?dbfrom=pubmed&cmd=llinks&id=" . (ref($pmid) ? (join('&id=',@{$pmid})) : $pmid);
450      print STDERR "url: $url" if $DEBUG;
451      my $request = HTTP::Request->new('GET', $url);
452      my $response = $ua->request($request);
453      $response = $response->content;
454      print STDERR "response: $response" if $DEBUG;
455
456      # Response should be in XML. Parse it.
457      my $xa = new XML::Simple;
458
459      my $ref_struct = $xa->XMLin($response, ForceArray => ['IdUrlSet'], KeyAttr=>[]);
460
461      use Data::Dumper;
462      print STDERR Dumper($ref_struct);# if $DEBUG;
463      # Rearange data around Id.
464      my $links = {};
465      map {$links->{$_->{Id}}=$_->{ObjUrl}} @{$ref_struct->{LinkSet}->{IdUrlList}->{IdUrlSet}};
466      foreach my $obj_url (@{$links->{$pmid}->{ObjUrl}}) {
467           next unless $obj_url->{SubjectType} = 'publishers/providers';
468           #@links = _find_links_from_url($obj_url->{Url},$ua);
469      }
470      # Find publisher link
471      # If no publisher link, use the first aggregator link.
472 }
473
474 =head2 _fix_ids
475
476      _fix_ids
477
478
479
480 =cut
481
482 sub _fix_ids {
483      my ($ref) = @_;
484
485      my %ids_known = (medline => 'medline_id',
486                       pubmed  => 'pmid',
487                       doi     => 'doi',
488                      );
489      my %ids;
490      if (exists $ref->{PubmedData}{ArticleIdList}{ArticleId}) {
491           for my $art_id (ref($ref->{PubmedData}{ArticleIdList}{ArticleId}) eq 'ARRAY' ?
492                @{$ref->{PubmedData}{ArticleIdList}{ArticleId}}:
493                     ($ref->{PubmedData}{ArticleIdList}{ArticleId})) {
494                if (exists $ids_known{$art_id->{IdType}}) {
495                     $ids{$ids_known{$art_id->{IdType}}} = $art_id->{content};
496                }
497           }
498      }
499      if (not exists $ids{pmid}) {
500           $ids{pmid} = $ref->{MedlineCitation}->{PMID} if defined $ref->{MedlineCitation}->{PMID};
501      }
502      if (not exists $ids{medline_id}) {
503           $ids{medline_id} = $ref->{MedlineCitation}->{MedlineID} if defined $ref->{MedlineCitation}->{MedlineID};
504      }
505      return %ids;
506 }
507
508
509 =head2 _find_links_from_url
510
511 =head3 Usage
512
513 =head3 Function
514
515 =head3 Returns
516
517 =head3 Args
518
519 =cut
520
521 sub _find_links_from_url($$){
522      my ($link,$ua) = @_;
523
524      
525      
526 }
527
528 sub _fix_medline_ditch_empty($){
529      my ($value) = @_;
530
531      if (ref($value)) {
532           if (ref($value) eq 'HASH') {
533                if (scalar keys %{$value} > 0) {
534                     return $value;
535                }
536                else {
537                     return ();
538                }
539           }
540           elsif (ref($value) eq 'ARRAY') {
541                if (scalar @{$value} > 0) {
542                     return $value;
543                }
544                else {
545                     return ();
546                }
547           }
548           else {
549                return ();
550           }
551      }
552      else {
553           return $value if defined $value;
554           return ();
555      }
556 }
557
558
559 1;
560
561
562 __END__
563
564
565
566
567
568