pubmed.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          pubmed.lisp
   6 ;;;; Purpose:       Library to access PubMed web application
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Jun 2001
   9 ;;;;
  10 ;;;; $Id: pubmed.lisp,v 1.7 2002/11/06 19:36:53 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  20
  21 (in-package #:cl-user)
  22
  23 (defpackage #:pubmed
  24   (:use #:common-lisp #:kmrcl)
  25   (:export
  26
  27    ;; Conditions
  28    #:pubmed-condition
  29    #:pubmed-query-error
  30    #:pubmed-server-error
  31
  32    ;; Query functions
  33    #:pm-query
  34    #:pm-fetch-ids
  35
  36    ;; Print functions
  37    #:print-article
  38    #:print-article-set
  39
  40    ; Classes
  41    #:pm-article
  42    #:pm-article-set
  43
  44    ;; pm-article-set accessors
  45    #:articles
  46    #:articles-query
  47    #:articles-total
  48    #:articles-count
  49    #:articles-start
  50
  51    ;; article accessors
  52    #:article-pmid
  53    #:article-title
  54    #:article-authors
  55    #:article-affiliation
  56    #:article-journal
  57    #:article-date
  58    #:article-volume
  59    #:article-issue
  60    #:article-pages
  61    #:article-abstract
  62    #:article-mesh-headings
  63    ))
  64
  65 (in-package #:pubmed)
  66
  67
  68 (defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov")
  69 (defparameter +pubmed-query-url+ "/entrez/utils/pmqty.fcgi")
  70 (defparameter +pubmed-fetch-url+ "/entrez/utils/pmfetch.fcgi")
  71
  72
  73 (define-condition pubmed-condition ()
  74   ())
  75
  76
  77 (define-condition pubmed-server-error (error pubmed-condition)
  78   ((response :initarg :response
  79              :initform nil
  80              :reader pubmed-server-error-response))
  81   (:report (lambda (c stream)
  82              (format stream "A PubMed server error occurred.")
  83              (awhen (pubmed-server-error-response c)
  84                     (format stream " The server response was:~&~S" it)))))
  85
  86 (define-condition pubmed-query-error (error pubmed-condition)
  87   ((response :initarg :response
  88              :initform nil
  89              :reader pubmed-query-error-response))
  90   (:report (lambda (c stream)
  91              (format stream "A PubMed server error occurred.")
  92              (awhen (pubmed-query-error-response c)
  93                     (format stream " The server response was:~&~S" it)))))
  94
  95 ;;; Article-Set and Article Classes
  96
  97 (defclass pm-article-set ()
  98   ((query :type string :initarg :query :accessor articles-query)
  99    (articles :type list :initarg :articles :accessor articles)
 100    (total :type fixnum :initarg :total :accessor articles-total)
 101    (count :type fixnum :initarg :count :accessor articles-count)
 102    (start :type fixnum :initarg :start :accessor articles-start))
 103   (:documentation "Pubmed Article Set Class")
 104   (:default-initargs :total 0 :start 0 :count 0
 105                      :query nil :articles nil))
 106
 107 (defclass pm-article ()
 108   (
 109    (pmid :type integer :accessor article-pmid)
 110    (title :type string :accessor article-title)
 111    (authors :type list :accessor article-authors)
 112    (affiliation :type string :accessor article-affiliation)
 113    (journal :type string :accessor article-journal)
 114    (date :type string :accessor article-date)
 115    (volume :type string :accessor article-volume)
 116    (issue :type string :accessor article-issue)
 117    (pages :type string :accessor article-pages)
 118    (abstract :type string :accessor article-abstract)
 119    (mesh-headings :type list :accessor article-mesh-headings))
 120   (:documentation "Pubmed Article Class"))
 121
 122 (defmethod print-object ((obj pm-article-set) (s stream))
 123   (print-unreadable-object (obj s :type t :identity t)
 124     (format s "~d total articles, ~d articles starting at #~d"
 125             (articles-total obj)
 126             (articles-count obj)
 127             (articles-start obj)
 128             )))
 129
 130 (defmethod print-object ((obj pm-article) (s stream))
 131   (print-unreadable-object (obj s :type t :identity t)
 132     (format s "pmid:~d, title:~S" (article-pmid obj)
 133             (article-title obj))))
 134
 135 (defun article-equal-p (a b)
 136   (check-type a pm-article)
 137   (check-type b pm-article)
 138   (eql (article-pmid a) (article-pmid b)))
 139
 140 (defun article-ref (art)
 141   "Return a string of publication data for an article"
 142   (let ((ref ""))
 143     (awhen (article-date art)
 144            (string-append ref (format nil "~a; " it)))
 145     (awhen (article-volume art)
 146            (string-append ref it))
 147     (awhen (article-issue art)
 148            (string-append ref (format nil "(~a)" it)))
 149     (awhen (article-pages art)
 150            (string-append ref (format nil ":~a" it)))
 151     ref))
 152
 153 (defmethod print-article-set ((artset pm-article-set) &key (os *standard-output*) (format :text)
 154                                                        (complete nil) (print-link t))
 155   "Display an article set to specified stream in specified format"
 156   (dotimes (i (articles-count artset))
 157     (print-article (nth i (articles artset)) :os os :format format
 158                    :complete complete :print-link print-link))
 159   artset)
 160
 161 (defmethod print-article ((art pm-article) &key (os *standard-output*) (format :text)
 162                                               (complete nil) (print-link t))
 163   "Display an article"
 164   (ecase format
 165     (:text
 166      (format os "~a~%~a~%~a~a ~a~%~a~%"
 167              (article-title art)
 168              (list-to-delimited-string (article-authors art) ", ")
 169              (aif (article-affiliation art)
 170                   (format nil "~a~%" it) "")
 171              (article-journal art) (article-ref art)
 172              (aif (article-abstract art)
 173                   (if complete
 174                       it
 175                     "Abstract available")
 176                   "No abstract available")
 177              (when complete
 178                (format os "~a~%" (article-mesh-headings art)))))
 179      (:html
 180       (let ((has-link (or (article-abstract art) (article-mesh-headings art))))
 181         (when (and print-link has-link)
 182           (format os "<a href=\"~a?key=~a\">" (make-url "print-article") (article-pmid art)))
 183         (format os "<div class=\"article-title\">~a</div>~%" (article-title art))
 184         (when (and print-link has-link)
 185           (format os "</a>"))
 186         (format os "<div class=\"article-authors\">~a</div>~%"
 187                 (list-to-delimited-string (article-authors art) ", "))
 188         (format os "<div class=\"article-reference\">~a ~a</div>~%"
 189                 (article-journal art) (article-ref art))
 190         (when (and complete (article-abstract art))
 191           (format os "<div class=\"article-abstract\">~a</div>~%"
 192                   (article-abstract art)))
 193         (when (and complete (article-mesh-headings art))
 194           (format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
 195           (dolist (mh (article-mesh-headings art))
 196             (format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
 197         (format os "<p/>~%"))))
 198   art)
 199
 200
 201 ;;; PubMed Query Functions
 202
 203 (defun pm-query (searchstr &key maximum start)
 204   "Performs PubMed query and fetch and returns article-set structure"
 205     (multiple-value-bind
 206         (results status)
 207         (pubmed-search-xml searchstr :maximum maximum :start start)
 208       (when (xml-tag-contents "Count" status)
 209            (let ((as (make-instance 'pm-article-set)))
 210              (setf
 211                  (articles-total as) (parse-integer (xml-tag-contents "Count" status))
 212                  (articles-query as) searchstr
 213                  (articles-start as) (parse-integer (xml-tag-contents "DispStart" status))
 214                  (articles-count as) (parse-integer (xml-tag-contents "DispMax" status))
 215                  (articles as) (extract-article-set results))
 216              as))))
 217
 218 (defun pm-fetch-ids (pmids)
 219   "Fetchs list of Pubmed ID's and returns pm-article-set class"
 220   (setq pmids (mklist pmids))
 221   (let ((results (pubmed-fetch-pmids-xml pmids)))
 222     (unless (xml-tag-contents "Error" results)
 223       (let ((as (make-instance 'pm-article-set)))
 224         (setf
 225             (articles-total as) (length pmids)
 226             (articles-query as) (list-to-delimited-string pmids #\,)
 227             (articles-start as) 0
 228             (articles-count as) (length pmids)
 229             (articles as) (extract-article-set results))
 230         as))))
 231
 232 #+ignore
 233 (defun pubmed-search-tree (searchstr &key maximum start)
 234   "Performs a pubmed search and returns two values:
 235 tree of PubMed search results and tree of PubMed search status"
 236   (multiple-value-bind
 237       (xml-search-results xml-search-status)
 238       (pubmed-search-xml searchstr :maximum maximum :start start)
 239     (if xml-search-results
 240         (values (parse-xml-no-ws xml-search-results)
 241                 (parse-xml-no-ws xml-search-status))
 242       (values nil (parse-xml-no-ws xml-search-status)))))
 243
 244 (defun pubmed-search-xml (searchstr &key maximum start)
 245   "Performs a Pubmed search and returns two values:
 246 XML string of PubMed search results and XML search status"
 247   (multiple-value-bind
 248       (pmids search-status)
 249       (pubmed-query-xml searchstr :maximum maximum :start start)
 250     (values (pubmed-fetch-pmids-xml pmids) search-status)))
 251
 252 (defun pubmed-query-xml (searchstr &key maximum start)
 253   "Performs a Pubmed search and returns two values:
 254  list of PubMed ID's that match search string and XML search status"
 255   (let ((search-results (pubmed-query-status searchstr :maximum maximum :start start)))
 256     (values (extract-pmid-list search-results) search-results)))
 257
 258 (defun pubmed-query-status (searchstr &key start maximum)
 259   "Performs a Pubmed search and returns XML results of PubMed search
 260  which contains PubMed ID's and status results"
 261   (let ((query-alist `(("db" . "m") ("term" . ,searchstr) ("mode" . "xml"))))
 262     (when maximum (push (cons "dispmax" maximum) query-alist))
 263     (when start (push (cons "dispstart" start) query-alist))
 264     (net.aserve.client:do-http-request
 265      (format nil "http://~a~a" +pubmed-host+ +pubmed-query-url+)
 266      :method :get
 267      :query query-alist)))
 268
 269 (defun pubmed-fetch-pmids-xml (pmids)
 270   "Fetch articles for a list of PubMed ID's and return XML string"
 271   (setq pmids (mklist pmids)) ;; Ensure list
 272   (when pmids
 273       (net.aserve.client:do-http-request
 274        (format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
 275        :method :get
 276        :query
 277        `(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
 278          ("id" . ,(list-to-delimited-string pmids #\,))))))
 279
 280 ;;; XML Extraction Routines
 281
 282 (defun extract-article-set (results)
 283   "Extract article set from PubMed XML string, return results in pm-article-set class"
 284   (multiple-value-bind (as-start as-end as-next)
 285       (positions-xml-tag-contents "PubmedArticleSet" results)
 286     (declare (ignore as-end as-next))
 287     (when as-start
 288       (let ((done nil)
 289             (articles '())
 290             (pos as-start))
 291         (until done
 292                (multiple-value-bind
 293                    (a-start a-end a-next)
 294                    (positions-xml-tag-contents "PubmedArticle" results pos)
 295                  (if a-start
 296                      (progn
 297                        (push (extract-article results a-start a-end) articles)
 298                        (setq pos a-next)
 299                        )
 300                    (setq done t))))
 301         (nreverse articles)))))
 302
 303 (defun extract-article (xmlstr a-start a-end)
 304   "Extract article contents from PubMed XML string and return results in pm-article class"
 305   (let ((article (make-instance 'pm-article)))
 306     (setf
 307         (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start a-end))
 308         (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start a-end)
 309         (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start a-end)
 310         (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start a-end)
 311         (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start a-end)
 312         (article-abstract article) (xml-tag-contents "AbstractText" xmlstr a-start a-end))
 313     (multiple-value-bind (ji-start ji-end ji-next)
 314         (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
 315       (declare (ignore ji-next))
 316       (setf
 317           (article-volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
 318           (article-issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
 319       (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
 320            (setf (article-date article) it)
 321            (setf (article-date article)
 322              (concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end)
 323                           (aif (xml-tag-contents "Month" xmlstr ji-start ji-end)
 324                                (format nil " ~a" it)
 325                                "")))))
 326
 327     (multiple-value-bind (al-start al-end al-next)
 328         (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end)
 329       (declare (ignore al-next))
 330       (setf (article-authors article)
 331         (when al-start
 332             (let ((done nil)
 333                   (authors '())
 334                   (pos al-start))
 335               (until done
 336                      (multiple-value-bind
 337                          (au-start au-end au-next)
 338                          (positions-xml-tag-contents "Author" xmlstr pos al-end)
 339                        (if au-start
 340                            (progn
 341                              (push (extract-author xmlstr au-start au-end) authors)
 342                              (setq pos au-next))
 343                          (setq done t))))
 344               (nreverse authors)))))
 345
 346     (multiple-value-bind (mhl-start mhl-end mhl-next)
 347         (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
 348       (declare (ignore mhl-next))
 349       (setf (article-mesh-headings article)
 350         (when mhl-start
 351             (let ((done nil)
 352                   (mesh-headings '())
 353                   (pos mhl-start))
 354               (until done
 355                      (multiple-value-bind
 356                          (mh-start mh-end mh-next)
 357                          (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
 358                        (if mh-start
 359                            (progn
 360                              (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
 361                              (setq pos mh-next)
 362                              )
 363                          (setq done t))))
 364               (nreverse mesh-headings)))))
 365
 366     article))
 367
 368 (defun extract-author (xmlstr start end)
 369   "Extract author name from XML string"
 370   (let ((last-name (xml-tag-contents "LastName" xmlstr start end))
 371         (initials  (xml-tag-contents "Initials" xmlstr start end)))
 372     (concatenate 'string last-name " " initials)))
 373
 374 (defun extract-mesh-heading (xmlstr start end)
 375   "Extract and format mesh headings from XML string"
 376   (let ((desc (xml-tag-contents "DescriptorName" xmlstr start end))
 377         (sh  (xml-tag-contents "SubHeading" xmlstr start end)))
 378     (if sh
 379         (format nil "~a(~a)" desc sh)
 380       desc)))
 381
 382 (defun extract-pmid-list (results)
 383   "Returns list of PubMed ID's from XML result string"
 384   (cond
 385    ((search "<ERROR>" results)
 386     (error 'pubmed-query-error :response results))
 387    ((search "<H1>Server Error</H1>" results)
 388     (error 'pubmed-server-error :response results))
 389    (t
 390     (awhen (xml-tag-contents "Id" results)
 391            (delimited-string-to-list it #\space)))))
 392
 393
 394