1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: pubmed-src.lisp
6 ;;;; Purpose: Library to access PubMed web application
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Jun 2001
10 ;;;; $Id: pubmed-src.lisp,v 1.2 2003/06/12 11:10:38 kevin Exp $
12 ;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; cl-pubmed users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the GNU Lesser General Public License
16 ;;;; (http://www.gnu.org/licenses/lgpl.html)
17 ;;;; *************************************************************************
22 (defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov")
23 (defparameter +pubmed-query-url+ "/entrez/utils/pmqty.fcgi")
24 (defparameter +pubmed-fetch-url+ "/entrez/utils/pmfetch.fcgi")
27 (define-condition pubmed-condition ()
31 (define-condition pubmed-server-error (error pubmed-condition)
32 ((response :initarg :response
34 :reader pubmed-condition-response))
35 (:report (lambda (c stream)
36 (format stream "A PubMed server error occurred.")
37 (awhen (pubmed-condition-response c)
38 (format stream " The server response was:~&~S" it)))))
40 (define-condition pubmed-query-error (error pubmed-condition)
41 ((response :initarg :response
43 :reader pubmed-condition-response))
44 (:report (lambda (c stream)
45 (format stream "A PubMed server error occurred.")
46 (awhen (pubmed-condition-response c)
47 (format stream " The server response was:~&~S" it)))))
49 ;;; Article-Set and Article Classes
51 (defclass pm-article-set ()
52 ((query :type string :initarg :query :accessor articles-query)
53 (articles :type list :initarg :articles :accessor articles)
54 (total :type fixnum :initarg :total :accessor articles-total)
55 (count :type fixnum :initarg :count :accessor articles-count)
56 (start :type fixnum :initarg :start :accessor articles-start))
57 (:documentation "Pubmed Article Set Class")
58 (:default-initargs :total 0 :start 0 :count 0
59 :query nil :articles nil))
61 (defclass pm-article ()
63 (pmid :type integer :accessor article-pmid)
64 (title :type string :accessor article-title)
65 (authors :type list :accessor article-authors)
66 (affiliation :type string :accessor article-affiliation)
67 (journal :type string :accessor article-journal)
68 (date :type string :accessor article-date)
69 (volume :type string :accessor article-volume)
70 (issue :type string :accessor article-issue)
71 (pages :type string :accessor article-pages)
72 (abstract :type string :accessor article-abstract)
73 (mesh-headings :type list :accessor article-mesh-headings))
74 (:documentation "Pubmed Article Class"))
76 (defmethod print-object ((obj pm-article-set) (s stream))
77 (print-unreadable-object (obj s :type t :identity t)
78 (format s "~d total articles, ~d articles starting at #~d"
84 (defmethod print-object ((obj pm-article) (s stream))
85 (print-unreadable-object (obj s :type t :identity t)
86 (format s "pmid:~d, title:~S" (article-pmid obj)
87 (article-title obj))))
89 (defun article-equal-p (a b)
90 (check-type a pm-article)
91 (check-type b pm-article)
92 (eql (article-pmid a) (article-pmid b)))
94 (defun article-ref (art)
95 "Return a string of publication data for an article"
97 (awhen (article-date art)
98 (string-append ref (format nil "~a; " it)))
99 (awhen (article-volume art)
100 (string-append ref it))
101 (awhen (article-issue art)
102 (string-append ref (format nil "(~a)" it)))
103 (awhen (article-pages art)
104 (string-append ref (format nil ":~a" it)))
107 (defmethod print-article-set ((artset pm-article-set)
108 &key (os *standard-output*) (format :text)
109 (complete nil) (print-link nil))
110 "Display an article set to specified stream in specified format"
111 (dotimes (i (articles-count artset))
112 (print-article (nth i (articles artset)) :os os :format format
113 :complete complete :print-link print-link))
116 (defmethod print-article ((art pm-article) &key (os *standard-output*)
117 (format :text) (complete nil) (print-link nil))
121 (format os "~a~%~a~%~a~a ~a~%~a~%"
123 (list-to-delimited-string (article-authors art) ", ")
124 (aif (article-affiliation art)
125 (format nil "~a~%" it) "")
126 (article-journal art) (article-ref art)
127 (aif (article-abstract art)
130 "Abstract available")
131 "No abstract available")
133 (format os "~a~%" (article-mesh-headings art)))))
135 (let ((has-link (or (article-abstract art) (article-mesh-headings art))))
136 (when (and print-link has-link)
137 (format os "<a href=\"~A\">" (funcall print-link
138 (article-pmid art))))
139 (format os "<div class=\"article-title\">~a</div>~%"
141 (when (and print-link has-link)
143 (format os "<div class=\"article-authors\">~a</div>~%"
144 (list-to-delimited-string (article-authors art) ", "))
145 (format os "<div class=\"article-reference\">~a ~a</div>~%"
146 (article-journal art) (article-ref art))
147 (when (and complete (article-abstract art))
148 (format os "<div class=\"article-abstract\">~a</div>~%"
149 (article-abstract art)))
150 (when (and complete (article-mesh-headings art))
151 (format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
152 (dolist (mh (article-mesh-headings art))
153 (format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
154 (format os "<p/>~%"))))
158 ;;; PubMed Query Functions
160 (defun pm-query (searchstr &key maximum start)
161 "Performs PubMed query and fetch and returns article-set structure"
164 (pubmed-search-xml searchstr :maximum maximum :start start)
165 (when (xml-tag-contents "Count" status)
166 (let ((as (make-instance 'pm-article-set)))
168 (articles-total as) (parse-integer (xml-tag-contents "Count" status))
169 (articles-query as) searchstr
170 (articles-start as) (parse-integer (xml-tag-contents "DispStart" status))
171 (articles-count as) (parse-integer (xml-tag-contents "DispMax" status))
172 (articles as) (extract-article-set results))
175 (defun pm-fetch-ids (pmids)
176 "Fetchs list of Pubmed ID's and returns pm-article-set class"
177 (setq pmids (mklist pmids))
178 (let ((results (pubmed-fetch-pmids-xml pmids)))
179 (unless (xml-tag-contents "Error" results)
180 (let ((as (make-instance 'pm-article-set)))
182 (articles-total as) (length pmids)
183 (articles-query as) (list-to-delimited-string pmids #\,)
184 (articles-start as) 0
185 (articles-count as) (length pmids)
186 (articles as) (extract-article-set results))
190 (defun pubmed-search-tree (searchstr &key maximum start)
191 "Performs a pubmed search and returns two values:
192 tree of PubMed search results and tree of PubMed search status"
194 (xml-search-results xml-search-status)
195 (pubmed-search-xml searchstr :maximum maximum :start start)
196 (if xml-search-results
197 (values (parse-xml-no-ws xml-search-results)
198 (parse-xml-no-ws xml-search-status))
199 (values nil (parse-xml-no-ws xml-search-status)))))
201 (defun pubmed-search-xml (searchstr &key maximum start)
202 "Performs a Pubmed search and returns two values:
203 XML string of PubMed search results and XML search status"
205 (pmids search-status)
206 (pubmed-query-xml searchstr :maximum maximum :start start)
207 (values (pubmed-fetch-pmids-xml pmids) search-status)))
209 (defun pubmed-query-xml (searchstr &key maximum start)
210 "Performs a Pubmed search and returns two values:
211 list of PubMed ID's that match search string and XML search status"
212 (let ((search-results (pubmed-query-status searchstr :maximum maximum :start start)))
213 (values (extract-pmid-list search-results) search-results)))
215 (defun pubmed-query-status (searchstr &key start maximum)
216 "Performs a Pubmed search and returns XML results of PubMed search
217 which contains PubMed ID's and status results"
218 (let ((query-alist `(("db" . "m") ("term" . ,searchstr) ("mode" . "xml"))))
219 (when maximum (push (cons "dispmax" maximum) query-alist))
220 (when start (push (cons "dispstart" start) query-alist))
221 (net.aserve.client:do-http-request
222 (format nil "http://~a~a" +pubmed-host+ +pubmed-query-url+)
224 :query query-alist)))
226 (defun pubmed-fetch-pmids-xml (pmids)
227 "Fetch articles for a list of PubMed ID's and return XML string"
228 (setq pmids (mklist pmids)) ;; Ensure list
230 (net.aserve.client:do-http-request
231 (format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
234 `(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
235 ("id" . ,(list-to-delimited-string pmids #\,))))))
237 ;;; XML Extraction Routines
239 (defun extract-article-set (results)
240 "Extract article set from PubMed XML string, return results in pm-article-set class"
241 (multiple-value-bind (as-start as-end as-next)
242 (positions-xml-tag-contents "PubmedArticleSet" results)
243 (declare (ignore as-end as-next))
250 (a-start a-end a-next)
251 (positions-xml-tag-contents "PubmedArticle" results pos)
254 (push (extract-article results a-start a-end) articles)
258 (nreverse articles)))))
260 (defun extract-article (xmlstr a-start a-end)
261 "Extract article contents from PubMed XML string and return results in pm-article class"
262 (let ((article (make-instance 'pm-article)))
264 (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start a-end))
265 (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start a-end)
266 (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start a-end)
267 (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start a-end)
268 (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start a-end)
269 (article-abstract article) (xml-tag-contents "AbstractText" xmlstr a-start a-end))
270 (multiple-value-bind (ji-start ji-end ji-next)
271 (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
272 (declare (ignore ji-next))
274 (article-volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
275 (article-issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
276 (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
277 (setf (article-date article) it)
278 (setf (article-date article)
279 (concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end)
280 (aif (xml-tag-contents "Month" xmlstr ji-start ji-end)
281 (format nil " ~a" it)
284 (multiple-value-bind (al-start al-end al-next)
285 (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end)
286 (declare (ignore al-next))
287 (setf (article-authors article)
294 (au-start au-end au-next)
295 (positions-xml-tag-contents "Author" xmlstr pos al-end)
298 (push (extract-author xmlstr au-start au-end) authors)
301 (nreverse authors)))))
303 (multiple-value-bind (mhl-start mhl-end mhl-next)
304 (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
305 (declare (ignore mhl-next))
306 (setf (article-mesh-headings article)
313 (mh-start mh-end mh-next)
314 (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
317 (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
321 (nreverse mesh-headings)))))
325 (defun extract-author (xmlstr start end)
326 "Extract author name from XML string"
327 (let ((last-name (xml-tag-contents "LastName" xmlstr start end))
328 (initials (xml-tag-contents "Initials" xmlstr start end)))
329 (concatenate 'string last-name " " initials)))
331 (defun extract-mesh-heading (xmlstr start end)
332 "Extract and format mesh headings from XML string"
333 (let ((desc (xml-tag-contents "DescriptorName" xmlstr start end))
334 (sh (xml-tag-contents "SubHeading" xmlstr start end)))
336 (format nil "~a(~a)" desc sh)
339 (defun extract-pmid-list (results)
340 "Returns list of PubMed ID's from XML result string"
342 ((search "<ERROR>" results)
343 (error 'pubmed-query-error :response results))
344 ((search "<H1>Server Error</H1>" results)
345 (error 'pubmed-server-error :response results))
347 (awhen (xml-tag-contents "Id" results)
348 (delimited-string-to-list it #\space)))))