;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: pubmed.lisp
;;;; Purpose: Library to access PubMed web application
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Jun 2001
;;;;
;;;; $Id: pubmed.lisp,v 1.1 2002/10/26 17:06:07 kevin Exp $
;;;;
;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; cl-pubmed users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU Lesser General Public License
;;;; (http://www.gnu.org/licenses/lgpl.html)
;;;; *************************************************************************
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package #:cl-user)
(defpackage #:pubmed
(:use #:common-lisp #:kmrcl)
(:export #:pm-search
#:disp-article
#:disp-articleset
#:fetch-pmids
#:total-count
#:article-count
#:articles
))
(in-package :pubmed)
(defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov")
(defparameter +pubmed-query-url+ "/entrez/utils/pmqty.fcgi")
(defparameter +pubmed-fetch-url+ "/entrez/utils/pmfetch.fcgi")
;;; ArticleSet and Article Classes
(defclass pmsearch ()
((search-str :type string :accessor search-str)
(date :type string :accessor date)
(user-id :type fixnum :accessor user-id))
(:documentation "Pubmed Stored Search Class"))
(defclass pmarticleset ()
((search-str :type string :initarg :search-str :accessor search-str)
(total-count :type fixnum :initarg :total-count :accessor total-count)
(article-count :type fixnum :initarg :article-count :accessor article-count)
(article-start :type fixnum :initarg :article-start :accessor article-start)
(articles :type list :initarg :articles :accessor articles))
(:documentation "Pubmed Article Set Class")
(:default-initargs :total-count 0 :article-start 0 :article-count 0
:search-str nil :articles nil))
(defclass pmarticle ()
(
(pmid :type integer :accessor pmid)
(title :type string :accessor title)
(authors :type list :accessor authors)
(affiliation :type string :accessor affiliation)
(journal :type string :accessor journal)
(pub-date :type string :accessor pub-date)
(volume :type string :accessor volume)
(issue :type string :accessor issue)
(pages :type string :accessor pages)
(abstract :type string :accessor abstract)
(mesh-headings :type list :accessor mesh-headings))
(:documentation "Pubmed Article Class"))
(defmethod print-object ((obj pmarticleset) (s stream))
(print-unreadable-object (obj s :type t :identity t)
(format s "~d total articles, ~d articles starting at #~d"
(total-count obj)
(article-count obj)
(article-start obj)
)))
(defmethod print-object ((obj pmarticle) (s stream))
(print-unreadable-object (obj s :type t :identity t)
(format s "pmid:~d" (pmid obj))))
;; (disp-article obj :os s :format :text)
(defun pmarticle-pubdata (art)
"Return a string of publication data for an article"
(let ((pubdata ""))
(awhen (pub-date art)
(string-append pubdata (format nil "~a; " :it)))
(awhen (volume art)
(string-append pubdata :it))
(awhen (issue art)
(string-append pubdata (format nil "(~a)" :it)))
(awhen (pages art)
(string-append pubdata (format nil ":~a" :it)))
pubdata))
(defmethod disp-articleset ((artset pmarticleset) &key (os *standard-output*) (format :text)
(complete nil) (disp-link t))
"Display an article set to specified stream in specified format"
(dotimes (i (article-count artset))
(disp-article (nth i (articles artset)) :os os :format format
:complete complete :disp-link disp-link)))
(defmethod disp-article ((art pmarticle) &key (os *standard-output*) (format :text)
(complete nil) (disp-link t))
"Display an article"
(if (eql format :text)
(format os "~a~%~a~%~a~a ~a~%~a~%"
(title art)
(list-to-delimited-string (authors art) ", ")
(aif (affiliation art)
(format nil "~a~%" :it) "")
(journal art) (pmarticle-pubdata art)
(if (abstract art)
(if complete
(abstract art)
"Abstract available")
"No abstract available")
(when complete
(format os "~a~%" (mesh-headings art))))
(let ((has-link (or (abstract art) (mesh-headings art))))
(when (and disp-link has-link)
(format os "" (make-url "disp-article") (pmid art)))
(format os "~a
~%" (title art))
(when (and disp-link has-link)
(format os ""))
(format os "
~a
~%"
(list-to-delimited-string (authors art) ", "))
(format os "~a ~a
~%"
(journal art) (pmarticle-pubdata art))
(when (and complete (abstract art))
(format os "~a
~%"
(abstract art)))
(when (and complete (mesh-headings art))
(format os "Mesh Headings:
")
(dolist (mh (mesh-headings art))
(format os "~a
~%" mh)))
(format os "~%"))))
;;; PubMed Search Functions
(defun pm-search (searchstr &key disp-max disp-start)
"Performs PubMed query and fetch and returns articleset structure"
(multiple-value-bind
(results status)
(pubmed-search-xml searchstr :disp-max disp-max :disp-start disp-start)
(if (xml-tag-contents "Count" status)
(let ((as (make-instance 'pmarticleset)))
(setf
(total-count as) (parse-integer (xml-tag-contents "Count" status))
(search-str as) searchstr
(article-start as) (parse-integer (xml-tag-contents "DispStart" status))
(article-count as) (parse-integer (xml-tag-contents "DispMax" status))
(articles as) (extract-articleset results))
as)
nil)))
(defun fetch-pmids (pmids)
"Fetchs list of Pubmed ID's and returns articleset class"
(setq pmids (mklist pmids))
(let ((results (pubmed-fetch-pmids-xml pmids)))
(if (xml-tag-contents "Error" results)
nil
(let ((as (make-instance 'pmarticleset)))
(setf
(total-count as) (length pmids)
(search-str as) (list-to-delimited-string pmids #\,)
(article-start as) 0
(article-count as) (length pmids)
(articles as) (extract-articleset results))
as))))
#+ignore
(defun pubmed-search-tree (searchstr &key disp-max disp-start)
"Performs a pubmed search and returns two values:
tree of PubMed search results and tree of PubMed search status"
(multiple-value-bind
(xml-search-results xml-search-status)
(pubmed-search-xml searchstr :disp-max disp-max :disp-start disp-start)
(if xml-search-results
(values (parse-xml-no-ws xml-search-results)
(parse-xml-no-ws xml-search-status))
(values nil (parse-xml-no-ws xml-search-status)))))
(defun pubmed-search-xml (searchstr &key disp-max disp-start)
"Performs a Pubmed search and returns two values:
XML string of PubMed search results and XML search status"
(multiple-value-bind
(pmids search-status)
(pubmed-query-xml searchstr :disp-max disp-max :disp-start disp-start)
(values (pubmed-fetch-pmids-xml pmids) search-status)))
(defun pubmed-query-xml (searchstr &key disp-max disp-start)
"Performs a Pubmed search and returns two values:
list of PubMed ID's that match search string and XML search status"
(let ((search-results (pubmed-query-status searchstr :disp-max disp-max :disp-start disp-start)))
(values (extract-pmid-list search-results) search-results)))
(defun pubmed-query-status (searchstr &key disp-max disp-start)
"Performs a Pubmed search and returns XML results of PubMed search
which contains PubMed ID's and status results"
(let ((query-alist `(("db" . "m") ("term" . ,searchstr) ("mode" . "xml"))))
(when disp-max (push (cons "dispmax" disp-max) query-alist))
(when disp-start (push (cons "dispstart" disp-start) query-alist))
(net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-query-url+)
:method :get
:query query-alist)))
(defun pubmed-fetch-pmids-xml (pmids)
"Fetch articles for a list of PubMed ID's and return XML string"
(setq pmids (mklist pmids)) ;; Ensure list
(if pmids
(net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
:method :get
:query
`(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
("id" . ,(list-to-delimited-string pmids #\,))))))
;;; XML Extraction Routines
(defun extract-articleset (results)
"Extract article set from PubMed XML string, return results in pmarticleset class"
(multiple-value-bind (as-start as-end as-next)
(positions-xml-tag-contents "PubmedArticleSet" results)
(declare (ignore as-end as-next))
(when as-start
(let ((done nil)
(articles '())
(pos as-start))
(until done
(multiple-value-bind
(a-start a-end a-next)
(positions-xml-tag-contents "PubmedArticle" results pos)
(if a-start
(progn
(push (extract-article results a-start a-end) articles)
(setq pos a-next)
)
(setq done t))))
(nreverse articles)))))
(defun extract-article (xmlstr a-start a-end)
"Extract article contents from PubMed XML string and return results in pmarticle class"
(let ((article (make-instance 'pmarticle)))
(setf
(pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start))
(title article) (xml-tag-contents "ArticleTitle" xmlstr a-start)
(journal article) (xml-tag-contents "MedlineTA" xmlstr a-start)
(pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start)
(affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start)
(abstract article) (xml-tag-contents "AbstractText" xmlstr a-start))
(multiple-value-bind (ji-start ji-end ji-next)
(positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
(declare (ignore ji-next))
(setf
(volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
(issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
(aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
(setf (pub-date article) :it)
(setf (pub-date article)
(concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end)
(aif (xml-tag-contents "Month" xmlstr ji-start ji-end)
(format nil " ~a" :it)
"")))))
(multiple-value-bind (al-start al-end al-next)
(positions-xml-tag-contents "AuthorList" xmlstr a-start a-end)
(declare (ignore al-next))
(setf (authors article)
(if al-start
(let ((done nil)
(authors '())
(pos al-start))
(until done
(multiple-value-bind
(au-start au-end au-next)
(positions-xml-tag-contents "Author" xmlstr pos al-end)
(if au-start
(progn
(push (extract-author xmlstr au-start au-end) authors)
(setq pos au-next))
(setq done t))))
(nreverse authors))
nil)))
(multiple-value-bind (mhl-start mhl-end mhl-next)
(positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
(declare (ignore mhl-next))
(setf (mesh-headings article)
(if mhl-start
(let ((done nil)
(mesh-headings '())
(pos mhl-start))
(until done
(multiple-value-bind
(mh-start mh-end mh-next)
(positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
(if mh-start
(progn
(push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
(setq pos mh-next)
)
(setq done t))))
(nreverse mesh-headings))
nil)))
article))
(defun extract-author (xmlstr start end)
"Extract author name from XML string"
(let ((last-name (xml-tag-contents "LastName" xmlstr start end))
(initials (xml-tag-contents "Initials" xmlstr start end)))
(concatenate 'string last-name " " initials)))
(defun extract-mesh-heading (xmlstr start end)
"Extract and format mesh headings from XML string"
(let ((desc (xml-tag-contents "Descriptor" xmlstr start end))
(sh (xml-tag-contents "SubHeading" xmlstr start end)))
(if sh
(format nil "~a(~a)" desc sh)
desc)))
(defun extract-pmid-list (results)
"Returns list of PubMed ID's from XML result string"
(if (search "" results)
nil
(awhen (xml-tag-contents "Id" results)
(delimited-string-to-list it #\space))))