;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Jun 2001
;;;;
-;;;; $Id: pubmed.lisp,v 1.2 2002/10/31 02:01:07 kevin Exp $
+;;;; $Id: pubmed.lisp,v 1.3 2002/10/31 19:42:26 kevin Exp $
;;;;
;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(defpackage #:pubmed
(:use #:common-lisp #:kmrcl)
- (:export #:pm-search
- #:disp-article
- #:disp-articleset
- #:fetch-pmids
- #:total-count
- #:article-count
- #:articles
- ))
-
-(in-package :pubmed)
+ (:export
+
+ ;; Conditions
+ #:pubmed-condition
+ #:pubmed-server-error
+
+ ;; Query functions
+ #:pm-query
+ #:pm-fetch-ids
+
+ ;; Print functions
+ #:print-article
+ #:print-article-set
+
+ ; Classes
+ #:pm-article
+ #:pm-article-set
+
+ ;; pm-article-set accessors
+ #:articles
+ #:articles-query
+ #:articles-total
+ #:articles-count
+ #:articles-start
+
+ ;; article accessors
+ #:article-pmid
+ #:article-title
+ #:article-authors
+ #:article-affiliation
+ #:article-journal
+ #:article-date
+ #:article-volume
+ #:article-issue
+ #:article-pages
+ #:article-abstract
+ #:article-mesh-headings
+ ))
+
+(in-package #:pubmed)
(defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov")
(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))
+(define-condition pubmed-condition ()
+ ())
+
+
+(define-condition pubmed-server-error (error pubmed-condition)
+ ((response :initarg :response
+ :initform nil
+ :reader pubmed-server-error-response))
+ (:report (lambda (c stream)
+ (format stream "A PubMed server error occurred.")
+ (awhen (pubmed-server-error-response c)
+ (format stream " The server response was:~&~S" it)))))
+
+;;; Article-Set and Article Classes
+
+(defclass pm-article-set ()
+ ((query :type string :initarg :query :accessor articles-query)
+ (articles :type list :initarg :articles :accessor articles)
+ (total :type fixnum :initarg :total :accessor articles-total)
+ (count :type fixnum :initarg :count :accessor articles-count)
+ (start :type fixnum :initarg :start :accessor articles-start))
(:documentation "Pubmed Article Set Class")
- (:default-initargs :total-count 0 :article-start 0 :article-count 0
- :search-str nil :articles nil))
+ (:default-initargs :total 0 :start 0 :count 0
+ :query nil :articles nil))
-(defclass pmarticle ()
+(defclass pm-article ()
(
- (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))
+ (pmid :type integer :accessor article-pmid)
+ (title :type string :accessor article-title)
+ (authors :type list :accessor article-authors)
+ (affiliation :type string :accessor article-affiliation)
+ (journal :type string :accessor article-journal)
+ (date :type string :accessor article-date)
+ (volume :type string :accessor article-volume)
+ (issue :type string :accessor article-issue)
+ (pages :type string :accessor article-pages)
+ (abstract :type string :accessor article-abstract)
+ (mesh-headings :type list :accessor article-mesh-headings))
(:documentation "Pubmed Article Class"))
-(defmethod print-object ((obj pmarticleset) (s stream))
+(defmethod print-object ((obj pm-article-set) (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)
+ (articles-total obj)
+ (articles-count obj)
+ (articles-start obj)
)))
-(defmethod print-object ((obj pmarticle) (s stream))
+(defmethod print-object ((obj pm-article) (s stream))
(print-unreadable-object (obj s :type t :identity t)
- (format s "pmid:~d" (pmid obj))))
-;; (disp-article obj :os s :format :text)
+ (format s "pmid: ~d" (article-pmid obj))))
-(defun pmarticle-pubdata (art)
+(defun article-equal-p (a b)
+ (check-type a pm-article)
+ (check-type b pm-article)
+ (eql (article-pmid a) (article-pmid b)))
+
+(defun article-ref (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))
+ (let ((ref ""))
+ (awhen (article-date art)
+ (string-append ref (format nil "~a; " it)))
+ (awhen (article-volume art)
+ (string-append ref it))
+ (awhen (article-issue art)
+ (string-append ref (format nil "(~a)" it)))
+ (awhen (article-pages art)
+ (string-append ref (format nil ":~a" it)))
+ ref))
+
+(defmethod print-article-set ((artset pm-article-set) &key (os *standard-output*) (format :text)
+ (complete nil) (print-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)))
+ (dotimes (i (articles-count artset))
+ (print-article (nth i (articles artset)) :os os :format format
+ :complete complete :print-link print-link)))
-(defmethod disp-article ((art pmarticle) &key (os *standard-output*) (format :text)
- (complete nil) (disp-link t))
+(defmethod print-article ((art pm-article) &key (os *standard-output*) (format :text)
+ (complete nil) (print-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)
+ (article-title art)
+ (list-to-delimited-string (article-authors art) ", ")
+ (aif (article-affiliation art)
(format nil "~a~%" it) "")
- (journal art) (pmarticle-pubdata art)
- (if (abstract art)
+ (article-journal art) (article-ref art)
+ (aif (article-abstract art)
(if complete
- (abstract art)
+ it
"Abstract available")
"No abstract available")
(when complete
- (format os "~a~%" (mesh-headings art))))
+ (format os "~a~%" (article-mesh-headings art))))
- (let ((has-link (or (abstract art) (mesh-headings art))))
- (when (and disp-link has-link)
- (format os "<a href=\"~a?key=~a\">" (make-url "disp-article") (pmid art)))
- (format os "<div class=\"article-title\">~a</div>~%" (title art))
- (when (and disp-link has-link)
+ (let ((has-link (or (article-abstract art) (article-mesh-headings art))))
+ (when (and print-link has-link)
+ (format os "<a href=\"~a?key=~a\">" (make-url "print-article") (article-pmid art)))
+ (format os "<div class=\"article-title\">~a</div>~%" (article-title art))
+ (when (and print-link has-link)
(format os "</a>"))
(format os "<div class=\"article-authors\">~a</div>~%"
- (list-to-delimited-string (authors art) ", "))
+ (list-to-delimited-string (article-authors art) ", "))
(format os "<div class=\"article-reference\">~a ~a</div>~%"
- (journal art) (pmarticle-pubdata art))
- (when (and complete (abstract art))
+ (article-journal art) (article-ref art))
+ (when (and complete (article-abstract art))
(format os "<div class=\"article-abstract\">~a</div>~%"
- (abstract art)))
- (when (and complete (mesh-headings art))
+ (article-abstract art)))
+ (when (and complete (article-mesh-headings art))
(format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
- (dolist (mh (mesh-headings art))
+ (dolist (mh (article-mesh-headings art))
(format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
(format os "<p/>~%"))))
-;;; PubMed Search Functions
+;;; PubMed Query Functions
-(defun pm-search (searchstr &key disp-max disp-start)
- "Performs PubMed query and fetch and returns articleset structure"
+(defun pm-query (searchstr &key maximum start)
+ "Performs PubMed query and fetch and returns article-set 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)))
+ (pubmed-search-xml searchstr :maximum maximum :start start)
+ (when (xml-tag-contents "Count" status)
+ (let ((as (make-instance 'pm-article-set)))
(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"
+ (articles-total as) (parse-integer (xml-tag-contents "Count" status))
+ (articles-query as) searchstr
+ (articles-start as) (parse-integer (xml-tag-contents "DispStart" status))
+ (articles-count as) (parse-integer (xml-tag-contents "DispMax" status))
+ (articles as) (extract-article-set results))
+ as))))
+
+(defun pm-fetch-ids (pmids)
+ "Fetchs list of Pubmed ID's and returns pm-article-set class"
(setq pmids (mklist pmids))
(let ((results (pubmed-fetch-pmids-xml pmids)))
- (if (xml-tag-contents "Error" results)
- nil
- (let ((as (make-instance 'pmarticleset)))
+ (unless (xml-tag-contents "Error" results)
+ (let ((as (make-instance 'pm-article-set)))
(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))
+ (articles-total as) (length pmids)
+ (articles-query as) (list-to-delimited-string pmids #\,)
+ (articles-start as) 0
+ (articles-count as) (length pmids)
+ (articles as) (extract-article-set results))
as))))
#+ignore
-(defun pubmed-search-tree (searchstr &key disp-max disp-start)
+(defun pubmed-search-tree (searchstr &key maximum 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)
+ (pubmed-search-xml searchstr :maximum maximum :start 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)
+(defun pubmed-search-xml (searchstr &key maximum 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)
+ (pubmed-query-xml searchstr :maximum maximum :start start)
(values (pubmed-fetch-pmids-xml pmids) search-status)))
-(defun pubmed-query-xml (searchstr &key disp-max disp-start)
+(defun pubmed-query-xml (searchstr &key maximum 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)))
+ (let ((search-results (pubmed-query-status searchstr :maximum maximum :start start)))
(values (extract-pmid-list search-results) search-results)))
-(defun pubmed-query-status (searchstr &key disp-max disp-start)
+(defun pubmed-query-status (searchstr &key start maximum)
"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)))
+ (when maximum (push (cons "dispmax" maximum) query-alist))
+ (when start (push (cons "dispstart" 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 #\,))))))
+ (when 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"
+(defun extract-article-set (results)
+ "Extract article set from PubMed XML string, return results in pm-article-set class"
(multiple-value-bind (as-start as-end as-next)
(positions-xml-tag-contents "PubmedArticleSet" results)
(declare (ignore as-end as-next))
(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)))
+ "Extract article contents from PubMed XML string and return results in pm-article class"
+ (let ((article (make-instance 'pm-article)))
(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))
+ (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start))
+ (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start)
+ (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start)
+ (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start)
+ (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start)
+ (article-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))
+ (article-volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
+ (article-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)
+ (setf (article-date article) it)
+ (setf (article-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
+ (setf (article-authors article)
+ (when al-start
(let ((done nil)
(authors '())
(pos al-start))
(push (extract-author xmlstr au-start au-end) authors)
(setq pos au-next))
(setq done t))))
- (nreverse authors))
- nil)))
+ (nreverse authors)))))
(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
+ (setf (article-mesh-headings article)
+ (when mhl-start
(let ((done nil)
(mesh-headings '())
(pos mhl-start))
(setq pos mh-next)
)
(setq done t))))
- (nreverse mesh-headings))
- nil)))
+ (nreverse mesh-headings)))))
+
article))
(defun extract-author (xmlstr start end)
(defun extract-pmid-list (results)
"Returns list of PubMed ID's from XML result string"
- (if (search "<ERROR>" results)
- nil
+ (if (or (search "<ERROR>" results)
+ (search "<H1>Server Error</H1>" results))
+ (error 'pubmed-server-error :response results)
(awhen (xml-tag-contents "Id" results)
(delimited-string-to-list it #\space))))
projects / pubmed.git / commitdiff