pubmed-src.lisp

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