entrez.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          entrez.lisp
   6 ;;;; Purpose:       Library to access NCBI Entrez web application
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  April 2013
   9 ;;;;
  10 ;;;; This file, part of cl-entrez, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17 (in-package #:entrez)
  18
  19
  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)
  25
  26
  27 (define-condition entrez-condition ()
  28   ())
  29
  30
  31 (define-condition entrez-server-error (error entrez-condition)
  32   ((response :initarg :response
  33              :initform nil
  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)))))
  39
  40 (define-condition entrez-query-error (error entrez-condition)
  41   ((response :initarg :response
  42              :initform nil
  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)))))
  48
  49 ;;; Article-Set and Article Classes
  50
  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))
  62
  63 (defclass equery ()
  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))
  70
  71 (defclass pm-article ()
  72   (
  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"))
  85
  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"
  89             (articles-total obj)
  90             (articles-count obj)
  91             (articles-start obj)
  92             )))
  93
  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"
  97             (qcount obj)
  98             (qkey obj)
  99             (wenv obj))))
 100
 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))))
 105
 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)))
 110
 111 (defun article-ref (art)
 112   "Return a string of publication data for an article"
 113   (let ((ref ""))
 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)))
 122     ref))
 123
 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))))
 133
 134 (defmethod print-article ((art pm-article) &key (os *standard-output*)
 135                           (format :text) (complete nil) (print-link nil))
 136   "Display an article"
 137   (ecase format
 138     (:text
 139      (format os "~a~%~a~%~a~a ~a~%~a~%"
 140              (article-title art)
 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)
 146                   (if complete
 147                       it
 148                     "Abstract available")
 149                   "No abstract available")
 150              (when complete
 151                (format os "~a~%" (article-mesh-headings art)))))
 152      (:html
 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>~%"
 158                 (article-title art))
 159         (when (and print-link has-link)
 160           (format os "</a>"))
 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/>~%"))))
 173   art)
 174
 175
 176 ;;; Entrez Query Functions
 177
 178 (defun equery (searchstr &key (db "pubmed") (usehistory t) start max)
 179   "Performs Entrez query and returns article-set structure"
 180     (multiple-value-bind
 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)))
 184              (setf
 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))
 191              as))))
 192
 193 (defun esummary (as &key maximum start)
 194 ;;  (articles as) (extract-article-set results))
 195   as)
 196
 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)))
 203         (setf
 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))
 209         as))))
 210
 211 #+ignore
 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"
 215   (multiple-value-bind
 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)))))
 222
 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))))
 229
 230 (defun http-equery (term &key start max (usehistory t)
 231                            (db "pubmed"))
 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+)))
 236     (when usehistory
 237       (setq alist (acons "usehistory" "y" alist)))
 238     (when start
 239       (setq alist (acons "retstart" start alist)))
 240     (when max
 241       (setq alist (acons "retmax" max alist)))
 242     (multiple-value-bind (xmlres http-code http-server-alist)
 243         (net.aserve.client:do-http-request
 244           geturl
 245           :method :get
 246           :query alist
 247           :proxy *proxy-host*)
 248       (declare (ignore http-server-alist))
 249       (when (not (equal http-code 200))
 250         (error "HTTP code performing '~A' was ~D." geturl http-code))
 251       xmlres)))
 252
 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
 256   (when pmids
 257       (net.aserve.client:do-http-request
 258        (format nil "http://~a~a" +entrez-host+ +entrez-fetch-url+)
 259        :method :get
 260        :query
 261        `(("db" . ,db) ("report" . "xml") ("mode" . "text")
 262          ("id" . ,(list-to-delimited-string pmids #\,)))
 263        :proxy *proxy-host*)))
 264
 265 ;;; XML Extraction Routines
 266
 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))
 272     (when as-start
 273       (let ((done nil)
 274             (articles '())
 275             (pos as-start))
 276         (until done
 277                (multiple-value-bind
 278                    (a-start a-end a-next)
 279                    (positions-xml-tag-contents "PubmedArticle" results pos)
 280                  (if a-start
 281                      (progn
 282                        (push (extract-article results a-start a-end) articles)
 283                        (setq pos a-next)
 284                        )
 285                    (setq done t))))
 286         (nreverse articles)))))
 287
 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)))
 291     (setf
 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))
 301       (setf
 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)
 310                                "")))))
 311
 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)
 316         (when al-start
 317             (let ((done nil)
 318                   (authors '())
 319                   (pos al-start))
 320               (until done
 321                      (multiple-value-bind
 322                          (au-start au-end au-next)
 323                          (positions-xml-tag-contents "Author" xmlstr pos al-end)
 324                        (if au-start
 325                            (progn
 326                              (push (extract-author xmlstr au-start au-end) authors)
 327                              (setq pos au-next))
 328                          (setq done t))))
 329               (nreverse authors)))))
 330
 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)
 335         (when mhl-start
 336             (let ((done nil)
 337                   (mesh-headings '())
 338                   (pos mhl-start))
 339               (until done
 340                      (multiple-value-bind
 341                          (mh-start mh-end mh-next)
 342                          (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end)
 343                        (if mh-start
 344                            (progn
 345                              (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings)
 346                              (setq pos mh-next)
 347                              )
 348                          (setq done t))))
 349               (nreverse mesh-headings)))))
 350
 351     article))
 352
 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)))
 358
 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)))
 363     (if sh
 364         (format nil "~a(~a)" desc sh)
 365       desc)))
 366
 367 (defun extract-pmid-list (results)
 368   "Returns list of Entrez ID's from XML result string"
 369   (cond
 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))
 374    (t
 375     (awhen (xml-tag-contents "Id" results)
 376            (delimited-string-to-list it #\space)))))