1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Library to access PubMed web application
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Jun 2001
10 ;;;; $Id: pubmed.lisp,v 1.2 2002/10/31 02:01:07 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 ;;;; *************************************************************************
19 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
21 (in-package #:cl-user)
24 (:use #:common-lisp #:kmrcl)
37 (defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov")
38 (defparameter +pubmed-query-url+ "/entrez/utils/pmqty.fcgi")
39 (defparameter +pubmed-fetch-url+ "/entrez/utils/pmfetch.fcgi")
42 ;;; ArticleSet and Article Classes
45 ((search-str :type string :accessor search-str)
46 (date :type string :accessor date)
47 (user-id :type fixnum :accessor user-id))
48 (:documentation "Pubmed Stored Search Class"))
50 (defclass pmarticleset ()
51 ((search-str :type string :initarg :search-str :accessor search-str)
52 (total-count :type fixnum :initarg :total-count :accessor total-count)
53 (article-count :type fixnum :initarg :article-count :accessor article-count)
54 (article-start :type fixnum :initarg :article-start :accessor article-start)
55 (articles :type list :initarg :articles :accessor articles))
56 (:documentation "Pubmed Article Set Class")
57 (:default-initargs :total-count 0 :article-start 0 :article-count 0
58 :search-str nil :articles nil))
60 (defclass pmarticle ()
62 (pmid :type integer :accessor pmid)
63 (title :type string :accessor title)
64 (authors :type list :accessor authors)
65 (affiliation :type string :accessor affiliation)
66 (journal :type string :accessor journal)
67 (pub-date :type string :accessor pub-date)
68 (volume :type string :accessor volume)
69 (issue :type string :accessor issue)
70 (pages :type string :accessor pages)
71 (abstract :type string :accessor abstract)
72 (mesh-headings :type list :accessor mesh-headings))
73 (:documentation "Pubmed Article Class"))
75 (defmethod print-object ((obj pmarticleset) (s stream))
76 (print-unreadable-object (obj s :type t :identity t)
77 (format s "~d total articles, ~d articles starting at #~d"
83 (defmethod print-object ((obj pmarticle) (s stream))
84 (print-unreadable-object (obj s :type t :identity t)
85 (format s "pmid:~d" (pmid obj))))
86 ;; (disp-article obj :os s :format :text)
88 (defun pmarticle-pubdata (art)
89 "Return a string of publication data for an article"
92 (string-append pubdata (format nil "~a; " it)))
94 (string-append pubdata it))
96 (string-append pubdata (format nil "(~a)" it)))
98 (string-append pubdata (format nil ":~a" it)))
101 (defmethod disp-articleset ((artset pmarticleset) &key (os *standard-output*) (format :text)
102 (complete nil) (disp-link t))
103 "Display an article set to specified stream in specified format"
104 (dotimes (i (article-count artset))
105 (disp-article (nth i (articles artset)) :os os :format format
106 :complete complete :disp-link disp-link)))
108 (defmethod disp-article ((art pmarticle) &key (os *standard-output*) (format :text)
109 (complete nil) (disp-link t))
111 (if (eql format :text)
112 (format os "~a~%~a~%~a~a ~a~%~a~%"
114 (list-to-delimited-string (authors art) ", ")
115 (aif (affiliation art)
116 (format nil "~a~%" it) "")
117 (journal art) (pmarticle-pubdata art)
121 "Abstract available")
122 "No abstract available")
124 (format os "~a~%" (mesh-headings art))))
126 (let ((has-link (or (abstract art) (mesh-headings art))))
127 (when (and disp-link has-link)
128 (format os "<a href=\"~a?key=~a\">" (make-url "disp-article") (pmid art)))
129 (format os "<div class=\"article-title\">~a</div>~%" (title art))
130 (when (and disp-link has-link)
132 (format os "<div class=\"article-authors\">~a</div>~%"
133 (list-to-delimited-string (authors art) ", "))
134 (format os "<div class=\"article-reference\">~a ~a</div>~%"
135 (journal art) (pmarticle-pubdata art))
136 (when (and complete (abstract art))
137 (format os "<div class=\"article-abstract\">~a</div>~%"
139 (when (and complete (mesh-headings art))
140 (format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
141 (dolist (mh (mesh-headings art))
142 (format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
143 (format os "<p/>~%"))))
146 ;;; PubMed Search Functions
148 (defun pm-search (searchstr &key disp-max disp-start)
149 "Performs PubMed query and fetch and returns articleset structure"
152 (pubmed-search-xml searchstr :disp-max disp-max :disp-start disp-start)
153 (if (xml-tag-contents "Count" status)
154 (let ((as (make-instance 'pmarticleset)))
156 (total-count as) (parse-integer (xml-tag-contents "Count" status))
157 (search-str as) searchstr
158 (article-start as) (parse-integer (xml-tag-contents "DispStart" status))
159 (article-count as) (parse-integer (xml-tag-contents "DispMax" status))
160 (articles as) (extract-articleset results))
164 (defun fetch-pmids (pmids)
165 "Fetchs list of Pubmed ID's and returns articleset class"
166 (setq pmids (mklist pmids))
167 (let ((results (pubmed-fetch-pmids-xml pmids)))
168 (if (xml-tag-contents "Error" results)
170 (let ((as (make-instance 'pmarticleset)))
172 (total-count as) (length pmids)
173 (search-str as) (list-to-delimited-string pmids #\,)
175 (article-count as) (length pmids)
176 (articles as) (extract-articleset results))
180 (defun pubmed-search-tree (searchstr &key disp-max disp-start)
181 "Performs a pubmed search and returns two values:
182 tree of PubMed search results and tree of PubMed search status"
184 (xml-search-results xml-search-status)
185 (pubmed-search-xml searchstr :disp-max disp-max :disp-start disp-start)
186 (if xml-search-results
187 (values (parse-xml-no-ws xml-search-results)
188 (parse-xml-no-ws xml-search-status))
189 (values nil (parse-xml-no-ws xml-search-status)))))
191 (defun pubmed-search-xml (searchstr &key disp-max disp-start)
192 "Performs a Pubmed search and returns two values:
193 XML string of PubMed search results and XML search status"
195 (pmids search-status)
196 (pubmed-query-xml searchstr :disp-max disp-max :disp-start disp-start)
197 (values (pubmed-fetch-pmids-xml pmids) search-status)))
199 (defun pubmed-query-xml (searchstr &key disp-max disp-start)
200 "Performs a Pubmed search and returns two values:
201 list of PubMed ID's that match search string and XML search status"
202 (let ((search-results (pubmed-query-status searchstr :disp-max disp-max :disp-start disp-start)))
203 (values (extract-pmid-list search-results) search-results)))
205 (defun pubmed-query-status (searchstr &key disp-max disp-start)
206 "Performs a Pubmed search and returns XML results of PubMed search
207 which contains PubMed ID's and status results"
208 (let ((query-alist `(("db" . "m") ("term" . ,searchstr) ("mode" . "xml"))))
209 (when disp-max (push (cons "dispmax" disp-max) query-alist))
210 (when disp-start (push (cons "dispstart" disp-start) query-alist))
211 (net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-query-url+)
213 :query query-alist)))
215 (defun pubmed-fetch-pmids-xml (pmids)
216 "Fetch articles for a list of PubMed ID's and return XML string"
217 (setq pmids (mklist pmids)) ;; Ensure list
219 (net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
222 `(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
223 ("id" . ,(list-to-delimited-string pmids #\,))))))
225 ;;; XML Extraction Routines
227 (defun extract-articleset (results)
228 "Extract article set from PubMed XML string, return results in pmarticleset class"
229 (multiple-value-bind (as-start as-end as-next)
230 (positions-xml-tag-contents "PubmedArticleSet" results)
231 (declare (ignore as-end as-next))
238 (a-start a-end a-next)
239 (positions-xml-tag-contents "PubmedArticle" results pos)
242 (push (extract-article results a-start a-end) articles)
246 (nreverse articles)))))
248 (defun extract-article (xmlstr a-start a-end)
249 "Extract article contents from PubMed XML string and return results in pmarticle class"
250 (let ((article (make-instance 'pmarticle)))
252 (pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start))
253 (title article) (xml-tag-contents "ArticleTitle" xmlstr a-start)
254 (journal article) (xml-tag-contents "MedlineTA" xmlstr a-start)
255 (pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start)
256 (affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start)
257 (abstract article) (xml-tag-contents "AbstractText" xmlstr a-start))
258 (multiple-value-bind (ji-start ji-end ji-next)
259 (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
260 (declare (ignore ji-next))
262 (volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
263 (issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
264 (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
265 (setf (pub-date article) it)
266 (setf (pub-date article)
267 (concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end)
268 (aif (xml-tag-contents "Month" xmlstr ji-start ji-end)
269 (format nil " ~a" it)
272 (multiple-value-bind (al-start al-end al-next)
273 (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end)
274 (declare (ignore al-next))
275 (setf (authors article)
282 (au-start au-end au-next)
283 (positions-xml-tag-contents "Author" xmlstr pos al-end)
286 (push (extract-author xmlstr au-start au-end) authors)
292 (multiple-value-bind (mhl-start mhl-end mhl-next)
293 (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
294 (declare (ignore mhl-next))
295 (setf (mesh-headings article)
302 (mh-start mh-end mh-next)
303 (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
306 (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
310 (nreverse mesh-headings))
314 (defun extract-author (xmlstr start end)
315 "Extract author name from XML string"
316 (let ((last-name (xml-tag-contents "LastName" xmlstr start end))
317 (initials (xml-tag-contents "Initials" xmlstr start end)))
318 (concatenate 'string last-name " " initials)))
320 (defun extract-mesh-heading (xmlstr start end)
321 "Extract and format mesh headings from XML string"
322 (let ((desc (xml-tag-contents "DescriptorName" xmlstr start end))
323 (sh (xml-tag-contents "SubHeading" xmlstr start end)))
325 (format nil "~a(~a)" desc sh)
328 (defun extract-pmid-list (results)
329 "Returns list of PubMed ID's from XML result string"
330 (if (search "<ERROR>" results)
332 (awhen (xml-tag-contents "Id" results)
333 (delimited-string-to-list it #\space))))