# This module is part of Refence, and is released under the terms of # the GPL version 2, or any later version. See the file README and # COPYING for more information. # Copyright 2003 by Don Armstrong . # $Id: PubMed.pm 45 2013-09-10 18:05:31Z don $ package Reference::Retrieve::PubMed; =head1 NAME Reference::Retrieve::PubMed -- Reference Retrieval from PubMed =head1 SYNOPSIS my $reference = Reference::Retrieve::PubMed::get_reference(-pmid=>123456); my @references = Reference::Retrieve::PubMed::get_reference(-query=>'John Smith[AUTHOR] AND 230[Pages]',limit=>50); =head1 DESCRIPTION Uh. Retreives references from pubmed. Yeah. =head1 BUGS None known. =cut use strict; use vars qw($REVISION $DEBUG); use Carp; use LWP::UserAgent; use XML::Simple qw(:strict); use Reference; use HTML::Entities; use Params::Validate qw(:types validate_with); BEGIN{ ($REVISION) = q$LastChangedRevision: 45 $ =~ /\$LastChangedRevision:\s+([^\s+])/; $DEBUG = 0 unless defined $DEBUG; } =head2 get_reference =head3 Usage my $reference = Reference::Retrieve::PubMed::get_reference(-pmid=>123456); my @references = Reference::Retrieve::PubMed::get_reference(-query=>'John Smith[AUTHOR] AND 230[Pages]',-limit=>50); my @references = Reference::Retrieve::PubMed::get_reference(-query=>{author=>'John Smith', pages=>'230'},-limit=>50) =head3 Function Retrives a reference from pubmed =head3 Returns In scalar context, effectively assumes -limit=>1 and returns the highest listed reference according to the order, etc. [Probably only usefull with -pmid.] In list context, returns all results (or until it hits the -limit.) =head3 Args list of arguments to select a reference or collection of references from. =cut sub get_reference{ my %options = validate_with(params => @_, spec => {pubmed_site => {default => 'http://www.ncbi.nlm.nih.gov'}, pmid_query => {default => '/entrez/query.fcgi?cmd=Text&db=PubMed&dopt=XML&uid='}, search_query => {default => '/htbin-post/Entrez/query?db=m&form=4&dispmax=100&html=no&dopt=u&term='}, ua_agent => {default => "DA Reference::Retreive::PubMed/$REVISION"}, email => {default => "don+referenceretrieve$REVISION\@donarmstrong.com"}, }, allow_extra => 1, ); my $ua = new LWP::UserAgent(agent => $options{ua_agent}); } sub get_reference_by_pmid($;@){ my %options = validate_with(params => \@_, spec => {pmid => {type => SCALAR|ARRAYREF, #regex => qr/^\d+$/, }, pubmed_site => {default => 'http://www.ncbi.nlm.nih.gov'}, pmid_query => {default => '/entrez/eutils/efetch.fcgi?db=pubmed&retmode=xml&rettype=full&id='}, search_query => {default => '/htbin-post/Entrez/query?db=m&form=4&dispmax=100&html=no&dopt=u&term='}, ua_agent => {default => "DA Reference::Retreive::PubMed/$REVISION"}, email => {default => "don+referenceretrieve$REVISION\@donarmstrong.com"}, useragent => {optional => 1}, }, allow_extra => 1, ); my $pmid = $options{pmid}; my $ua; if ($options{useragent}) { $ua = $options{useragent}; } else { $ua = new LWP::UserAgent(agent=>$options{ua_agent}); } my $url = "$options{pubmed_site}$options{pmid_query}" . (ref($pmid) ? (join('&id=',@{$pmid})) : $pmid); print STDERR "url: $url" if $DEBUG; my $request = HTTP::Request->new('GET', $url); my $response = $ua->request($request); $response = $response->content; print STDERR "response: $response" if $DEBUG; # For some dumb reason, they send us xml with html # entities. Ditch them. #$response = decode_entities($response); # It's even more freaking broken; they don't double encode them. #$response =~ s/\>(\s|$)/>$1/gso; #$response =~ s/(?:(\s)\<|<(\/))/$1<$2/gso; $response =~ s/"/"/gso; # Ditch any doctype $response =~ s/^\s*<\?xml[^>]+>\s*//gso; $response =~ s/^\s*<\!DOCTYPE[^>]+>\s*//gso; # There is also a Pubmedarticleset $response =~ s/^\s*\s*//gso; $response =~ s#\s*$##gso; # Add the opt so we get an array of PubMedArticle $response = "$response"; print STDERR $response if $DEBUG; # Figure out if there was an error in the search. # Response should be in XML. Parse it. my $xa = new XML::Simple; my $ref_struct = $xa->XMLin($response, ForceArray => [ 'PubmedArticle' ],KeyAttr=>[]); use Data::Dumper; print STDERR Dumper($ref_struct) if $DEBUG; # Handle the XML structure my @references; foreach my $ref (@{$ref_struct->{PubmedArticle}}) { my $reference = _create_reference_from_xml($ref,$ua); if (not defined $reference) { warn "Unable to create reference for $ref->{MedlineCitation}->{PMID}\n"; } push @references, $reference; } if (wantarray) { return @references; } return $references[0]; } sub _create_reference_from_xml($$){ my ($ref,$ua) = @_; # Figure out what type of reference this is. We only support # Journal Articles right now. my $types = {'journal article'=>'article', 'letter' =>'article', 'editorial' => 'article', 'review' => 'article', }; my $ref_type = undef; my $reference = undef; foreach my $type (keys %{$types}) { if (ref($ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}) eq 'ARRAY'){ my $pubtypes; @{$pubtypes}{map {lc} @{$ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}}} = (1) x @{$ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}}; if ($pubtypes->{$type}) { $ref_type = $types->{$type}; last; } else { next; } } elsif (lc($ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}) eq lc($type)) { $ref_type = $types->{$type}; last; } } if (not defined $ref_type) { warn "Unsupported PublicationType: ".(ref($ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType})? join(',',@{$ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}}): $ref->{MedlineCitation}->{Article}->{PublicationTypeList}->{PublicationType}); print STDERR Dumper($ref) if $DEBUG; $ref_type = 'article'; } local $_ = $ref_type; if (/article/) { use Reference::Type::Article; $reference = new Reference::Type::Article; my $xml_mapping = {author => [ _fix_medline_authors($ref->{MedlineCitation}->{Article}->{AuthorList}) ], title => [_fix_medline_title($ref->{MedlineCitation}->{Article}->{ArticleTitle})], abstract => [_fix_medline_abstract($ref->{MedlineCitation}->{Article}->{Abstract}->{AbstractText})], journal => [_fix_medline_journal($ref->{MedlineCitation}->{Article}->{Journal}, $ref->{MedlineCitation}->{Article}->{MedlineJournalInfo}, $ua, #@_, # configuration )], _fix_ids($ref), # pmid => $ref->{MedlineCitation}->{PMID}, # medline_id => $ref->{MedlineCitation}->{MedlineID}, volume => [_fix_medline_ditch_empty($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{Volume})], date => [_fix_medline_pubdate($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{PubDate})], number => [_fix_medline_ditch_empty($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{Issue})], pages => [_fix_medline_pages($ref->{MedlineCitation}->{Article}->{Pagination}->{MedlinePgn})], # keywords => [_fix_medline_keywords($ref->{MedlineCitation}->{MeshHeadingList}, # $ref->{MedlineCitation}->{ChemicalList}, # )], # &_find_pubmed_links($ref->{MedlineCitation}->{PMID},$ua), }; # Deal with author foreach my $reference_key (keys %{$xml_mapping}) { my $method = $reference->can($reference_key); die "Reference::Type::Article was unable to handle $reference_key" if not $method; if (defined $xml_mapping->{$reference_key} and $method) { if (ref($xml_mapping->{$reference_key})) { &{$method}($reference,@{$xml_mapping->{$reference_key}}); } else { &{$method}($reference,$xml_mapping->{$reference_key}); } } else { warn "Reference_key $reference_key was not defined or unable to handle type of key." if not defined $xml_mapping->{$reference_key} and $DEBUG; } } return $reference; } } sub _fix_medline_title($){ my $title = shift; $title =~ s/\.$//; return $title; } sub _fix_medline_abstract{ my $abstract = shift; my $ret = ''; if (ref($abstract) and ref($abstract) eq 'ARRAY') { for my $element (@{$abstract}) { $ret .= "\n" if length $ret; $ret .= $element->{Label}.': '.$element->{content}; } return $ret; } else { return $abstract; } } sub _fix_medline_authors($){ my $author_list = shift; $author_list = $author_list->{Author}; my @authors; $author_list = [$author_list] if ref($author_list) ne 'ARRAY'; foreach my $author (@{$author_list}) { my %au; $au{first} = $author->{ForeName} if exists $author->{ForeName}; $au{last} = $author->{LastName} if exists $author->{LastName}; $au{initials} = $author->{Initials} if exists $author->{Initials}; $au{full}; push @authors,\%au; } return (author=>\@authors); } =head2 _fix_medline_journal =head3 Usage $reference->journal(_fix_medline_journal($ref->{MedlineCitation}->{Article}->{Journal}, $ref->{MedlineCitation}->{Article}->{MedlineJournalInfo}, $ua,)); =head3 Function From the medline citation informatino returns a properly formatted list of information for the journal reference listing. =head3 Args Journal information hashref medline journal information hashref user agent =cut sub _fix_medline_journal($$$;){ my ($journal,$medline_journal,$ua) = @_; # journal takes fullname, issn, medlineabbr, pmid, and nlmuid # Try to supply as much as possible. # Use esearch to get pmjournalid # http://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=journals&term=0021-9258 # use esummary to retreive the journalid # # # # 1 # 1 # 0 # # 4559 # # # # # # # 0021-9258[All Fields] # All Fields # 1 # # Y # # # my $ISSN = $journal->{ISSN}; if (ref $ISSN) { $ISSN = $ISSN->{content}; } my $url = qq(http://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=journals&term=$ISSN); print STDERR "url: $url" if $DEBUG; my $request = HTTP::Request->new('GET', $url); my $response = $ua->request($request); $response = $response->content; print STDERR "response: $response" if $DEBUG; my ($journal_id) = $response =~ m#\s*(\d+)\s*#i; # http://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?db=journals&id=4559 # # # # # 4559 # The Journal of biological chemistry. # J Biol Chem # J. Biol. Chem. # 2985121R # # 0021-9258 # 1083-351X # 1905 # # American Society for Biochemistry and Molecular Biology # eng # # United States # # # $url = qq(http://eutils.ncbi.nlm.nih.gov/entrez/eutils/esummary.fcgi?db=journals&id=$journal_id); print STDERR "url: $url" if $DEBUG; $request = HTTP::Request->new('GET', $url); $response = $ua->request($request); $response = $response->content; print STDERR "response: $response" if $DEBUG; my %journal; while ($response =~ m{^\s*(?:(?:\s*(\d+))| # Match ids (?:\s*([^<]+?)))\s* # Match item Name clauses $}ixmg) { if (not defined $2) { $journal{id} = $1; } else { $journal{lc($2)} = $3; } } my %journal_mapping = (title => q(title), medlineabbr => q(medabbr), isoabbr => q(isoabbr), nlmid => q(nlmid), issn => q(pissn), eissn => q(eissn), publisher => q(publisher), pmid => q(id) ); my @journal_entry; foreach my $key (keys %journal_mapping) { push @journal_entry,($key=>$journal{$journal_mapping{$key}}); } return @journal_entry; } =head2 =head3 Usage $reference->date(_fix_medline_pubdate($ref->{MedlineCitation}->{Article}->{Journal}->{JournalIssue}->{PubDate})); =head3 Function =head3 Returns =head3 Args =cut sub _fix_medline_pubdate($){ my ($date) = shift; return (year=>$date->{Year},month=>$date->{Month},day=>$date->{Day}) if exists $date->{Year}; # Ok... punt. if (exists $date->{MedlineDate}) { my ($year,$month,$day) = split /\s+/,$date->{MedlineDate}; return (year=>$year,month=>$month,day=>$day) } } =head2 _fix_medline_pages =head3 Usage pages => [_fix_medline_pages($ref->{MedlineCitation}->{Article}->{Pagination}->{MedlinePgn})], =head3 Function Returns output with a list of pages appropriate for an Article type of reference. =cut sub _fix_medline_pages($){ my ($pagination) = @_; my ($start,$stop) = $pagination =~ /(\d*)\s*\-\s*(\d*)/; if (not defined $start) { ($start) = $pagination =~ /(\d+)/ } if ($start > $stop and defined $stop) { # this must be a reduced page listing; fix it up $stop+=$start - $start % 10 ** (int(log($stop)/log(10))+1); } my @return; push @return, (start=>$start) if defined $start and $start ne ''; push @return, (stop=>$stop) if defined $stop and $stop ne ''; return @return; } sub _find_pubmed_links($$){ my ($pmid,$ua) = @_; return (); #http://eutils.ncbi.nlm.nih.gov/entrez/query/static/elink_help.html my $url = "http://eutils.ncbi.nlm.nih.gov/entrez/eutils/elink.fcgi?dbfrom=pubmed&cmd=llinks&id=" . (ref($pmid) ? (join('&id=',@{$pmid})) : $pmid); print STDERR "url: $url" if $DEBUG; my $request = HTTP::Request->new('GET', $url); my $response = $ua->request($request); $response = $response->content; print STDERR "response: $response" if $DEBUG; # Response should be in XML. Parse it. my $xa = new XML::Simple; my $ref_struct = $xa->XMLin($response, ForceArray => ['IdUrlSet'], KeyAttr=>[]); use Data::Dumper; print STDERR Dumper($ref_struct);# if $DEBUG; # Rearange data around Id. my $links = {}; map {$links->{$_->{Id}}=$_->{ObjUrl}} @{$ref_struct->{LinkSet}->{IdUrlList}->{IdUrlSet}}; foreach my $obj_url (@{$links->{$pmid}->{ObjUrl}}) { next unless $obj_url->{SubjectType} = 'publishers/providers'; #@links = _find_links_from_url($obj_url->{Url},$ua); } # Find publisher link # If no publisher link, use the first aggregator link. } =head2 _fix_ids _fix_ids =cut sub _fix_ids { my ($ref) = @_; my %ids_known = (medline => 'medline_id', pubmed => 'pmid', doi => 'doi', ); my %ids; if (exists $ref->{PubmedData}{ArticleIdList}{ArticleId}) { for my $art_id (ref($ref->{PubmedData}{ArticleIdList}{ArticleId}) eq 'ARRAY' ? @{$ref->{PubmedData}{ArticleIdList}{ArticleId}}: ($ref->{PubmedData}{ArticleIdList}{ArticleId})) { if (exists $ids_known{$art_id->{IdType}}) { $ids{$ids_known{$art_id->{IdType}}} = $art_id->{content}; } } } if (not exists $ids{pmid}) { $ids{pmid} = $ref->{MedlineCitation}->{PMID} if defined $ref->{MedlineCitation}->{PMID}; } if (not exists $ids{medline_id}) { $ids{medline_id} = $ref->{MedlineCitation}->{MedlineID} if defined $ref->{MedlineCitation}->{MedlineID}; } return %ids; } =head2 _find_links_from_url =head3 Usage =head3 Function =head3 Returns =head3 Args =cut sub _find_links_from_url($$){ my ($link,$ua) = @_; } sub _fix_medline_ditch_empty($){ my ($value) = @_; if (ref($value)) { if (ref($value) eq 'HASH') { if (scalar keys %{$value} > 0) { return $value; } else { return (); } } elsif (ref($value) eq 'ARRAY') { if (scalar @{$value} > 0) { return $value; } else { return (); } } else { return (); } } else { return $value if defined $value; return (); } } 1; __END__