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: ".(ref($ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType})?
 193                                                 join(',',@{$ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}}):
 194                                                 $ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType});
 195           print STDERR Dumper($ref) if $DEBUG;
 196           $ref_type = 'article';
 197      }
 198      local $_ = $ref_type;
 199      if (/article/) {
 200           use Reference::Type::Article;
 201           $reference = new Reference::Type::Article;
 202           my $xml_mapping = {author     => [ _fix_medline_authors($ref->{MedlineCitation}->{Article}->{AuthorList}) ],
 203                              title      => [_fix_medline_title($ref->{MedlineCitation}->{Article}->{ArticleTitle})],
 204                              abstract   => [_fix_medline_abstract($ref->{MedlineCitation}->{Article}->{Abstract}->{AbstractText})],
 205                              journal    => [_fix_medline_journal($ref->{MedlineCitation}->{Article}->{Journal},
 206                                                                  $ref->{MedlineCitation}->{Article}->{MedlineJournalInfo},
 207                                                                  $ua,
 208                                                                  #@_, # configuration
 209                                                                 )],
 210                              _fix_ids($ref),
 211                              # pmid       => $ref->{MedlineCitation}->{PMID},
 212                              # medline_id => $ref->{MedlineCitation}->{MedlineID},
 213                              volume     => [_fix_medline_ditch_empty($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{Volume})],
 214                              date       => [_fix_medline_pubdate($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{PubDate})],
 215                              number     => [_fix_medline_ditch_empty($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{Issue})],
 216                              pages      => [_fix_medline_pages($ref->{MedlineCitation}->{Article}->{Pagination}->{MedlinePgn})],
 217 #                            keywords   => [_fix_medline_keywords($ref->{MedlineCitation}->{MeshHeadingList},
 218 #                                                                 $ref->{MedlineCitation}->{ChemicalList},
 219 #                                                                )],
 220 #                            &_find_pubmed_links($ref->{MedlineCitation}->{PMID},$ua),
 221                             };
 222           # Deal with author
 223
 224           foreach my $reference_key (keys %{$xml_mapping}) {
 225                my $method = $reference->can($reference_key);
 226                die "Reference::Type::Article was unable to handle $reference_key" if not $method;
 227                if (defined $xml_mapping->{$reference_key} and $method) {
 228                     if (ref($xml_mapping->{$reference_key})) {
 229                 &{$method}($reference,@{$xml_mapping->{$reference_key}});
 230                     }
 231                     else {
 232                          &{$method}($reference,$xml_mapping->{$reference_key});
 233                     }
 234                }
 235                else {
 236                     warn "Reference_key $reference_key was not defined or unable to handle type of key."
 237                          if not defined $xml_mapping->{$reference_key} and $DEBUG;
 238                }
 239           }
 240           return $reference;
 241      }
 242 }
 243
 244 sub _fix_medline_title($){
 245      my $title = shift;
 246
 247      $title =~ s/\.$//;
 248      return $title;
 249 }
 250
 251 sub _fix_medline_abstract{
 252     my $abstract = shift;
 253     my $ret = '';
 254     if (ref($abstract) and ref($abstract) eq 'ARRAY') {
 255         for my $element (@{$abstract}) {
 256             $ret .= "\n" if length $ret;
 257             $ret .= $element->{Label}.': '.$element->{content};
 258         }
 259         return $ret;
 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://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=journals&term=$ISSN);
 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      print STDERR "response: $response" if $DEBUG;
 345
 346      my ($journal_id) = $response =~ m#<Id>\s*(\d+)\s*</Id>#i;
 347
 348      # http://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?db=journals&id=4559
 349      #      <?xml version="1.0"?>
 350      # <!DOCTYPE eSummaryResult PUBLIC "-//NLM//DTD eSummaryResult, 11 May 2002//EN" "http://www.ncbi.nlm.nih.gov/entrez/query/DTD/eSummary_020511.dtd">
 351      # <eSummaryResult>
 352      # <DocSum>
 353      #  <Id>4559</Id>
 354      #  <Item Name="Title" Type="String">The Journal of biological chemistry.</Item>
 355      #  <Item Name="MedAbbr" Type="String">J Biol Chem</Item>
 356      #  <Item Name="IsoAbbr" Type="String">J. Biol. Chem.</Item>
 357      #  <Item Name="NlmId" Type="String">2985121R</Item>
 358      #
 359      #  <Item Name="pISSN" Type="String">0021-9258</Item>
 360      #  <Item Name="eISSN" Type="String">1083-351X</Item>
 361      #  <Item Name="PublicationStartYear" Type="String">1905</Item>
 362      #  <Item Name="PublicationEndYear" Type="String"></Item>
 363      #  <Item Name="Publisher" Type="String">American Society for Biochemistry and Molecular Biology</Item>
 364      #  <Item Name="Language" Type="String">eng</Item>
 365      #
 366      #  <Item Name="Country" Type="String">United States</Item>
 367      # </DocSum>
 368      #
 369      # </eSummaryResult>
 370      $url = qq(http://eutils.ncbi.nlm.nih.gov/entrez/eutils/esummary.fcgi?db=journals&id=$journal_id);
 371      print STDERR "url: $url" if $DEBUG;
 372      $request = HTTP::Request->new('GET', $url);
 373      $response = $ua->request($request);
 374      $response = $response->content;
 375      print STDERR "response: $response" if $DEBUG;
 376
 377      my %journal;
 378      while ($response =~ m{^\s*(?:(?:<id>\s*(\d+)</id>)| # Match ids
 379                            (?:<item\s+name=\"([^\"]+)\"\s+Type=\"String\">\s*([^<]+?)</item>))\s* # Match item Name clauses
 380                            $}ixmg) {
 381           if (not defined $2) {
 382                $journal{id} = $1;
 383           }
 384           else {
 385                $journal{lc($2)} = $3;
 386           }
 387      }
 388      my %journal_mapping = (title       => q(title),
 389                             medlineabbr => q(medabbr),
 390                             isoabbr     => q(isoabbr),
 391                             nlmid       => q(nlmid),
 392                             issn        => q(pissn),
 393                             eissn       => q(eissn),
 394                             publisher   => q(publisher),
 395                             pmid    => q(id)
 396                            );
 397      my @journal_entry;
 398      foreach my $key (keys %journal_mapping) {
 399           push @journal_entry,($key=>$journal{$journal_mapping{$key}});
 400      }
 401      return @journal_entry;
 402 }
 403
 404 =head2
 405
 406 =head3 Usage
 407
 408      $reference->date(_fix_medline_pubdate($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{PubDate}));
 409
 410 =head3 Function
 411
 412 =head3 Returns
 413
 414 =head3 Args
 415
 416 =cut
 417
 418 sub _fix_medline_pubdate($){
 419      my ($date) = shift;
 420      return (year=>$date->{Year},month=>$date->{Month},day=>$date->{Day}) if exists $date->{Year};
 421      # Ok... punt.
 422      if (exists $date->{MedlineDate}) {
 423           my ($year,$month,$day) = split /\s+/,$date->{MedlineDate};
 424           return (year=>$year,month=>$month,day=>$day)
 425      }
 426 }
 427
 428 =head2 _fix_medline_pages
 429
 430 =head3 Usage
 431
 432      pages      => [_fix_medline_pages($ref->{MedlineCitation}->{Article}->{Pagination}->{MedlinePgn})],
 433
 434 =head3 Function
 435
 436 Returns output with a list of pages appropriate for an Article type of
 437 reference.
 438
 439 =cut
 440
 441 sub _fix_medline_pages($){
 442      my ($pagination) = @_;
 443      my ($start,$stop) = $pagination =~ /(\d*)\s*\-\s*(\d*)/;
 444      if (not defined $start) {
 445          ($start) = $pagination =~ /(\d+)/
 446      }
 447      if ($start > $stop and defined $stop) {
 448          # this must be a reduced page listing; fix it up
 449          $stop+=$start - $start % 10 ** (int(log($stop)/log(10))+1);
 450      }
 451      my @return;
 452      push @return, (start=>$start) if defined $start and $start ne '';
 453      push @return, (stop=>$stop) if defined $stop and $stop ne '';
 454      return @return;
 455 }
 456
 457 sub _find_pubmed_links($$){
 458      my ($pmid,$ua) = @_;
 459      return ();
 460      #http://eutils.ncbi.nlm.nih.gov/entrez/query/static/elink_help.html
 461      my $url = "http://eutils.ncbi.nlm.nih.gov/entrez/eutils/elink.fcgi?dbfrom=pubmed&cmd=llinks&id=" . (ref($pmid) ? (join('&id=',@{$pmid})) : $pmid);
 462      print STDERR "url: $url" if $DEBUG;
 463      my $request = HTTP::Request->new('GET', $url);
 464      my $response = $ua->request($request);
 465      $response = $response->content;
 466      print STDERR "response: $response" if $DEBUG;
 467
 468      # Response should be in XML. Parse it.
 469      my $xa = new XML::Simple;
 470
 471      my $ref_struct = $xa->XMLin($response, ForceArray => ['IdUrlSet'], KeyAttr=>[]);
 472
 473      use Data::Dumper;
 474      print STDERR Dumper($ref_struct);# if $DEBUG;
 475      # Rearange data around Id.
 476      my $links = {};
 477      map {$links->{$_->{Id}}=$_->{ObjUrl}} @{$ref_struct->{LinkSet}->{IdUrlList}->{IdUrlSet}};
 478      foreach my $obj_url (@{$links->{$pmid}->{ObjUrl}}) {
 479           next unless $obj_url->{SubjectType} = 'publishers/providers';
 480           #@links = _find_links_from_url($obj_url->{Url},$ua);
 481      }
 482      # Find publisher link
 483      # If no publisher link, use the first aggregator link.
 484 }
 485
 486 =head2 _fix_ids
 487
 488      _fix_ids
 489
 490
 491
 492 =cut
 493
 494 sub _fix_ids {
 495      my ($ref) = @_;
 496
 497      my %ids_known = (medline => 'medline_id',
 498                       pubmed  => 'pmid',
 499                       doi     => 'doi',
 500                      );
 501      my %ids;
 502      if (exists $ref->{PubmedData}{ArticleIdList}{ArticleId}) {
 503           for my $art_id (ref($ref->{PubmedData}{ArticleIdList}{ArticleId}) eq 'ARRAY' ?
 504                @{$ref->{PubmedData}{ArticleIdList}{ArticleId}}:
 505                     ($ref->{PubmedData}{ArticleIdList}{ArticleId})) {
 506                if (exists $ids_known{$art_id->{IdType}}) {
 507                     $ids{$ids_known{$art_id->{IdType}}} = $art_id->{content};
 508                }
 509           }
 510      }
 511      if (not exists $ids{pmid}) {
 512           $ids{pmid} = $ref->{MedlineCitation}->{PMID} if defined $ref->{MedlineCitation}->{PMID};
 513      }
 514      if (not exists $ids{medline_id}) {
 515           $ids{medline_id} = $ref->{MedlineCitation}->{MedlineID} if defined $ref->{MedlineCitation}->{MedlineID};
 516      }
 517      return %ids;
 518 }
 519
 520
 521 =head2 _find_links_from_url
 522
 523 =head3 Usage
 524
 525 =head3 Function
 526
 527 =head3 Returns
 528
 529 =head3 Args
 530
 531 =cut
 532
 533 sub _find_links_from_url($$){
 534      my ($link,$ua) = @_;
 535
 536
 537
 538 }
 539
 540 sub _fix_medline_ditch_empty($){
 541      my ($value) = @_;
 542
 543      if (ref($value)) {
 544           if (ref($value) eq 'HASH') {
 545                if (scalar keys %{$value} > 0) {
 546                     return $value;
 547                }
 548                else {
 549                     return ();
 550                }
 551           }
 552           elsif (ref($value) eq 'ARRAY') {
 553                if (scalar @{$value} > 0) {
 554                     return $value;
 555                }
 556                else {
 557                     return ();
 558                }
 559           }
 560           else {
 561                return ();
 562           }
 563      }
 564      else {
 565           return $value if defined $value;
 566           return ();
 567      }
 568 }
 569
 570
 571 1;
 572
 573
 574 __END__
 575
 576
 577
 578
 579
 580