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.2 2002/10/31 02:01:07 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 #:pm-search
  26            #:disp-article
  27            #:disp-articleset
  28            #:fetch-pmids
  29            #:total-count
  30            #:article-count
  31            #:articles
  32            ))
  33
  34 (in-package :pubmed)
  35
  36
  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")
  40
  41
  42 ;;; ArticleSet and Article Classes
  43
  44 (defclass pmsearch ()
  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"))
  49
  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))
  59
  60 (defclass pmarticle ()
  61   (
  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"))
  74
  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"
  78             (total-count obj)
  79             (article-count obj)
  80             (article-start obj)
  81             )))
  82
  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)
  87
  88 (defun pmarticle-pubdata (art)
  89   "Return a string of publication data for an article"
  90   (let ((pubdata ""))
  91     (awhen (pub-date art)
  92            (string-append pubdata (format nil "~a; " it)))
  93     (awhen (volume art)
  94            (string-append pubdata it))
  95     (awhen (issue art)
  96            (string-append pubdata (format nil "(~a)" it)))
  97     (awhen (pages art)
  98            (string-append pubdata (format nil ":~a" it)))
  99     pubdata))
 100
 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)))
 107
 108 (defmethod disp-article ((art pmarticle) &key (os *standard-output*) (format :text)
 109                                               (complete nil) (disp-link t))
 110   "Display an article"
 111   (if (eql format :text)
 112       (format os "~a~%~a~%~a~a ~a~%~a~%"
 113               (title art)
 114               (list-to-delimited-string (authors art) ", ")
 115               (aif (affiliation art)
 116                    (format nil "~a~%" it) "")
 117               (journal art) (pmarticle-pubdata art)
 118               (if (abstract art)
 119                   (if complete
 120                       (abstract art)
 121                     "Abstract available")
 122                 "No abstract available")
 123               (when complete
 124                   (format os "~a~%" (mesh-headings art))))
 125
 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)
 131         (format os "</a>"))
 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>~%"
 138                 (abstract art)))
 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/>~%"))))
 144
 145
 146 ;;; PubMed Search Functions
 147
 148 (defun pm-search (searchstr &key disp-max disp-start)
 149   "Performs PubMed query and fetch and returns articleset structure"
 150     (multiple-value-bind
 151         (results status)
 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)))
 155              (setf
 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))
 161              as)
 162            nil)))
 163
 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)
 169         nil
 170       (let ((as (make-instance 'pmarticleset)))
 171         (setf
 172             (total-count as) (length pmids)
 173             (search-str as) (list-to-delimited-string pmids #\,)
 174             (article-start as) 0
 175             (article-count as) (length pmids)
 176             (articles as) (extract-articleset results))
 177         as))))
 178
 179 #+ignore
 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"
 183   (multiple-value-bind
 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)))))
 190
 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"
 194   (multiple-value-bind
 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)))
 198
 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)))
 204
 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+)
 212       :method :get
 213       :query query-alist)))
 214
 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
 218   (if pmids
 219       (net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
 220         :method :get
 221         :query
 222         `(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
 223                             ("id" . ,(list-to-delimited-string pmids #\,))))))
 224
 225 ;;; XML Extraction Routines
 226
 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))
 232     (when as-start
 233       (let ((done nil)
 234             (articles '())
 235             (pos as-start))
 236         (until done
 237                (multiple-value-bind
 238                    (a-start a-end a-next)
 239                    (positions-xml-tag-contents "PubmedArticle" results pos)
 240                  (if a-start
 241                      (progn
 242                        (push (extract-article results a-start a-end) articles)
 243                        (setq pos a-next)
 244                        )
 245                    (setq done t))))
 246         (nreverse articles)))))
 247
 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)))
 251     (setf
 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))
 261       (setf
 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)
 270                                "")))))
 271
 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)
 276         (if al-start
 277             (let ((done nil)
 278                   (authors '())
 279                   (pos al-start))
 280               (until done
 281                      (multiple-value-bind
 282                          (au-start au-end au-next)
 283                          (positions-xml-tag-contents "Author" xmlstr pos al-end)
 284                        (if au-start
 285                            (progn
 286                              (push (extract-author xmlstr au-start au-end) authors)
 287                              (setq pos au-next))
 288                          (setq done t))))
 289               (nreverse authors))
 290           nil)))
 291
 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)
 296         (if mhl-start
 297             (let ((done nil)
 298                   (mesh-headings '())
 299                   (pos mhl-start))
 300               (until done
 301                      (multiple-value-bind
 302                          (mh-start mh-end mh-next)
 303                          (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
 304                        (if mh-start
 305                            (progn
 306                              (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
 307                              (setq pos mh-next)
 308                              )
 309                          (setq done t))))
 310               (nreverse mesh-headings))
 311           nil)))
 312     article))
 313
 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)))
 319
 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)))
 324     (if sh
 325         (format nil "~a(~a)" desc sh)
 326       desc)))
 327
 328 (defun extract-pmid-list (results)
 329   "Returns list of PubMed ID's from XML result string"
 330   (if (search "<ERROR>" results)
 331       nil
 332     (awhen (xml-tag-contents "Id" results)
 333            (delimited-string-to-list it #\space))))
 334
 335
 336