1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Library to access NCBI Entrez web application
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: April 2013
10 ;;;; This file, part of cl-entrez, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; cl-entrez users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the GNU Lesser General Public License
14 ;;;; (http://www.gnu.org/licenses/lgpl.html)
15 ;;;; *************************************************************************
20 (defparameter +entrez-host+ "eutils.ncbi.nlm.nih.gov")
21 (defparameter +entrez-search-url+ "/entrez/eutils/esearch.fcgi")
22 (defparameter +entrez-fetch-url+ "/entrez/eutils/efetch.fcgi")
23 (defparameter +entrez-summary-url+ "/entrez/eutils/esummary.fcgi")
24 (defparameter *proxy-host* nil)
27 (define-condition entrez-condition ()
31 (define-condition entrez-server-error (error entrez-condition)
32 ((response :initarg :response
34 :reader entrez-condition-response))
35 (:report (lambda (c stream)
36 (format stream "A Entrez server error occurred.")
37 (awhen (entrez-condition-response c)
38 (format stream " The server response was:~&~S" it)))))
40 (define-condition entrez-query-error (error entrez-condition)
41 ((response :initarg :response
43 :reader entrez-condition-response))
44 (:report (lambda (c stream)
45 (format stream "A Entrez server error occurred.")
46 (awhen (entrez-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 (webenv :type string :initarg :webenv :accessor articles-webenv)
54 (qkey :type string :initarg :qkey :accessor articles-qkey)
55 (articles :type list :initarg :articles :accessor articles)
56 (total :type fixnum :initarg :total :accessor articles-total)
57 (count :type fixnum :initarg :count :accessor articles-count)
58 (start :type fixnum :initarg :start :accessor articles-start))
59 (:documentation "Entrez Article Set Class")
60 (:default-initargs :total 0 :start 0 :count 0 :query nil
61 :articles nil :qkey nil :webenv nil))
64 ((query :type string :initarg :query :accessor query)
65 (wenv :type string :initarg :webenv :accessor wenv)
66 (qkey :type string :initarg :qkey :accessor qkey)
67 (qcount :type fixnum :initarg :qcount :accessor qcount))
68 (:documentation "Entrez EQuery Results Class")
69 (:default-initargs :qcount 0 :query nil :qkey nil :webenv nil))
71 (defclass pm-article ()
73 (pmid :type integer :accessor article-pmid)
74 (title :type string :accessor article-title)
75 (authors :type list :accessor article-authors)
76 (affiliation :type string :accessor article-affiliation)
77 (journal :type string :accessor article-journal)
78 (date :type string :accessor article-date)
79 (volume :type string :accessor article-volume)
80 (issue :type string :accessor article-issue)
81 (pages :type string :accessor article-pages)
82 (abstract :type string :accessor article-abstract)
83 (mesh-headings :type list :accessor article-mesh-headings))
84 (:documentation "Entrez Article Class"))
86 (defmethod print-object ((obj pm-article-set) (s stream))
87 (print-unreadable-object (obj s :type t :identity t)
88 (format s "~d total articles, ~d articles starting at #~d"
94 (defmethod print-object ((obj equery) (s stream))
95 (print-unreadable-object (obj s :type t :identity t)
96 (format s "Found ~d with qkey ~a & wenv ~a"
101 (defmethod print-object ((obj pm-article) (s stream))
102 (print-unreadable-object (obj s :type t :identity t)
103 (format s "pmid:~d, title:~S" (article-pmid obj)
104 (article-title obj))))
106 (defun article-equal-p (a b)
107 (check-type a pm-article)
108 (check-type b pm-article)
109 (eql (article-pmid a) (article-pmid b)))
111 (defun article-ref (art)
112 "Return a string of publication data for an article"
114 (awhen (article-date art)
115 (string-append ref (format nil "~a; " it)))
116 (awhen (article-volume art)
117 (string-append ref it))
118 (awhen (article-issue art)
119 (string-append ref (format nil "(~a)" it)))
120 (awhen (article-pages art)
121 (string-append ref (format nil ":~a" it)))
124 (defmethod print-article-set ((artset pm-article-set)
125 &key (os *standard-output*) (format :text)
126 (complete nil) (print-link nil))
127 "Display an article set to specified stream in specified format"
128 (dotimes (i (articles-count artset) artset)
129 (if (nth i (articles artset))
130 (print-article (nth i (articles artset)) :os os :format format
131 :complete complete :print-link print-link)
132 (princ "NULL Article" os))))
134 (defmethod print-article ((art pm-article) &key (os *standard-output*)
135 (format :text) (complete nil) (print-link nil))
139 (format os "~a~%~a~%~a~a ~a~%~a~%"
141 (list-to-delimited-string (article-authors art) ", ")
142 (aif (article-affiliation art)
143 (format nil "~a~%" it) "")
144 (article-journal art) (article-ref art)
145 (aif (article-abstract art)
148 "Abstract available")
149 "No abstract available")
151 (format os "~a~%" (article-mesh-headings art)))))
153 (let ((has-link (or (article-abstract art) (article-mesh-headings art))))
154 (when (and print-link has-link)
155 (format os "<a href=\"~A\">" (funcall print-link
156 (article-pmid art))))
157 (format os "<div class=\"article-title\">~a</div>~%"
159 (when (and print-link has-link)
161 (format os "<div class=\"article-authors\">~a</div>~%"
162 (list-to-delimited-string (article-authors art) ", "))
163 (format os "<div class=\"article-reference\">~a ~a</div>~%"
164 (article-journal art) (article-ref art))
165 (when (and complete (article-abstract art))
166 (format os "<div class=\"article-abstract\">~a</div>~%"
167 (article-abstract art)))
168 (when (and complete (article-mesh-headings art))
169 (format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
170 (dolist (mh (article-mesh-headings art))
171 (format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
172 (format os "<p/>~%"))))
176 ;;; Entrez Query Functions
178 (defun equery (searchstr &key (db "pubmed") (usehistory t) start max)
179 "Performs Entrez query and returns article-set structure"
181 (xmlres ids) (do-equery searchstr :db db :usehistory usehistory :start start :max max)
182 (when (xml-tag-contents "Count" xmlres)
183 (let ((as (make-instance 'equery)))
185 (qcount as) (parse-integer (xml-tag-contents "Count" xmlres))
186 (query as) searchstr)
187 (kmrcl:awhen (xml-tag-contents "WebEnv" xmlres)
188 (setf (wenv as) kmrcl:it))
189 (kmrcl:awhen (xml-tag-contents "QueryKey" xmlres)
190 (setf (qkey as) kmrcl:it))
193 (defun esummary (as &key maximum start)
194 ;; (articles as) (extract-article-set results))
197 (defun pm-fetch-ids (pmids)
198 "Fetchs list of Entrez ID's and returns pm-article-set class"
199 (setq pmids (mklist pmids))
200 (let ((results (entrez-fetch-pmids-xml pmids)))
201 (unless (xml-tag-contents "Error" results)
202 (let ((as (make-instance 'pm-article-set)))
204 (articles-total as) (length pmids)
205 (articles-query as) (list-to-delimited-string pmids #\,)
206 (articles-start as) 0
207 (articles-count as) (length pmids)
208 (articles as) (extract-article-set results))
212 (defun entrez-search-tree (searchstr &key maximum start)
213 "Performs a entrez search and returns two values:
214 tree of Entrez search results and tree of Entrez search status"
216 (xml-search-results xml-search-status)
217 (entrez-search-xml searchstr :maximum maximum :start start)
218 (if xml-search-results
219 (values (parse-xml-no-ws xml-search-results)
220 (parse-xml-no-ws xml-search-status))
221 (values nil (parse-xml-no-ws xml-search-status)))))
223 (defun do-equery (term &key (db "pubmed") start max (usehistory t))
224 "Performs a Entrez search and returns two values:
225 XML string of Entrez search results and XML search status"
226 (let ((res (http-equery term :start start :max max
227 :usehistory usehistory :db db)))
228 (values res (extract-pmid-list res))))
230 (defun http-equery (term &key start max (usehistory t)
232 "Performs a Entrez search and returns XML results of Entrez search
233 which contains Entrez ID's and status results"
234 (let* ((alist `(("db" . ,db) ("term" . ,term)))
235 (geturl (format nil "http://~a~a" +entrez-host+ +entrez-search-url+)))
237 (setq alist (acons "usehistory" "y" alist)))
239 (setq alist (acons "retstart" start alist)))
241 (setq alist (acons "retmax" max alist)))
242 (multiple-value-bind (xmlres http-code http-server-alist)
243 (net.aserve.client:do-http-request
248 (declare (ignore http-server-alist))
249 (when (not (equal http-code 200))
250 (error "HTTP code performing '~A' was ~D." geturl http-code))
253 (defun entrez-fetch-pmids-xml (pmids &key (db "pubmed"))
254 "Fetch articles for a list of Entrez ID's and return XML string"
255 (setq pmids (mklist pmids)) ;; Ensure list
257 (net.aserve.client:do-http-request
258 (format nil "http://~a~a" +entrez-host+ +entrez-fetch-url+)
261 `(("db" . ,db) ("report" . "xml") ("mode" . "text")
262 ("id" . ,(list-to-delimited-string pmids #\,)))
263 :proxy *proxy-host*)))
265 ;;; XML Extraction Routines
267 (defun extract-article-set (results)
268 "Extract article set from Entrez XML string, return results in pm-article-set class"
269 (multiple-value-bind (as-start as-end as-next)
270 (positions-xml-tag-contents "PubmedArticleSet" results)
271 (declare (ignore as-end as-next))
278 (a-start a-end a-next)
279 (positions-xml-tag-contents "PubmedArticle" results pos)
282 (push (extract-article results a-start a-end) articles)
286 (nreverse articles)))))
288 (defun extract-article (xmlstr a-start a-end)
289 "Extract article contents from Entrez XML string and return results in pm-article class"
290 (let ((article (make-instance 'pm-article)))
292 (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start a-end))
293 (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start a-end)
294 (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start a-end)
295 (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start a-end)
296 (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start a-end)
297 (article-abstract article) (xml-tag-contents "AbstractText" xmlstr a-start a-end))
298 (multiple-value-bind (ji-start ji-end ji-next)
299 (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
300 (declare (ignore ji-next))
302 (article-volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
303 (article-issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
304 (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
305 (setf (article-date article) it)
306 (setf (article-date article)
307 (concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end)
308 (aif (xml-tag-contents "Month" xmlstr ji-start ji-end)
309 (format nil " ~a" it)
312 (multiple-value-bind (al-start al-end al-next)
313 (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end)
314 (declare (ignore al-next))
315 (setf (article-authors article)
322 (au-start au-end au-next)
323 (positions-xml-tag-contents "Author" xmlstr pos al-end)
326 (push (extract-author xmlstr au-start au-end) authors)
329 (nreverse authors)))))
331 (multiple-value-bind (mhl-start mhl-end mhl-next)
332 (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
333 (declare (ignore mhl-next))
334 (setf (article-mesh-headings article)
341 (mh-start mh-end mh-next)
342 (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
345 (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
349 (nreverse mesh-headings)))))
353 (defun extract-author (xmlstr start end)
354 "Extract author name from XML string"
355 (let ((last-name (xml-tag-contents "LastName" xmlstr start end))
356 (initials (xml-tag-contents "Initials" xmlstr start end)))
357 (concatenate 'string last-name " " initials)))
359 (defun extract-mesh-heading (xmlstr start end)
360 "Extract and format mesh headings from XML string"
361 (let ((desc (xml-tag-contents "DescriptorName" xmlstr start end))
362 (sh (xml-tag-contents "SubHeading" xmlstr start end)))
364 (format nil "~a(~a)" desc sh)
367 (defun extract-pmid-list (results)
368 "Returns list of Entrez ID's from XML result string"
370 ((search "<ERROR>" results)
371 (error 'entrez-query-error :response results))
372 ((search "<H1>Server Error</H1>" results)
373 (error 'entrez-server-error :response results))
375 (awhen (xml-tag-contents "Id" results)
376 (delimited-string-to-list it #\space)))))