;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: entrez.lisp ;;;; Purpose: Library to access NCBI Entrez web application ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: April 2013 ;;;; ;;;; This file, part of cl-entrez, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; ;;;; cl-entrez users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU Lesser General Public License ;;;; (http://www.gnu.org/licenses/lgpl.html) ;;;; ************************************************************************* (in-package #:entrez) (defparameter +entrez-host+ "eutils.ncbi.nlm.nih.gov") (defparameter +entrez-search-url+ "/entrez/eutils/esearch.fcgi") (defparameter +entrez-fetch-url+ "/entrez/eutils/efetch.fcgi") (defparameter +entrez-summary-url+ "/entrez/eutils/esummary.fcgi") (defparameter *proxy-host* nil) (define-condition entrez-condition () ()) (define-condition entrez-server-error (error entrez-condition) ((response :initarg :response :initform nil :reader entrez-condition-response)) (:report (lambda (c stream) (format stream "A Entrez server error occurred.") (awhen (entrez-condition-response c) (format stream " The server response was:~&~S" it))))) (define-condition entrez-query-error (error entrez-condition) ((response :initarg :response :initform nil :reader entrez-condition-response)) (:report (lambda (c stream) (format stream "A Entrez server error occurred.") (awhen (entrez-condition-response c) (format stream " The server response was:~&~S" it))))) ;;; Article-Set and Article Classes (defclass pm-article-set () ((query :type string :initarg :query :accessor articles-query) (webenv :type string :initarg :webenv :accessor articles-webenv) (qkey :type string :initarg :qkey :accessor articles-qkey) (articles :type list :initarg :articles :accessor articles) (total :type fixnum :initarg :total :accessor articles-total) (count :type fixnum :initarg :count :accessor articles-count) (start :type fixnum :initarg :start :accessor articles-start)) (:documentation "Entrez Article Set Class") (:default-initargs :total 0 :start 0 :count 0 :query nil :articles nil :qkey nil :webenv nil)) (defclass equery () ((query :type string :initarg :query :accessor query) (wenv :type string :initarg :webenv :accessor wenv) (qkey :type string :initarg :qkey :accessor qkey) (qcount :type fixnum :initarg :qcount :accessor qcount)) (:documentation "Entrez EQuery Results Class") (:default-initargs :qcount 0 :query nil :qkey nil :webenv nil)) (defclass pm-article () ( (pmid :type integer :accessor article-pmid) (title :type string :accessor article-title) (authors :type list :accessor article-authors) (affiliation :type string :accessor article-affiliation) (journal :type string :accessor article-journal) (date :type string :accessor article-date) (volume :type string :accessor article-volume) (issue :type string :accessor article-issue) (pages :type string :accessor article-pages) (abstract :type string :accessor article-abstract) (mesh-headings :type list :accessor article-mesh-headings)) (:documentation "Entrez Article Class")) (defmethod print-object ((obj pm-article-set) (s stream)) (print-unreadable-object (obj s :type t :identity t) (format s "~d total articles, ~d articles starting at #~d" (articles-total obj) (articles-count obj) (articles-start obj) ))) (defmethod print-object ((obj equery) (s stream)) (print-unreadable-object (obj s :type t :identity t) (format s "Found ~d with qkey ~a & wenv ~a" (qcount obj) (qkey obj) (wenv obj)))) (defmethod print-object ((obj pm-article) (s stream)) (print-unreadable-object (obj s :type t :identity t) (format s "pmid:~d, title:~S" (article-pmid obj) (article-title obj)))) (defun article-equal-p (a b) (check-type a pm-article) (check-type b pm-article) (eql (article-pmid a) (article-pmid b))) (defun article-ref (art) "Return a string of publication data for an article" (let ((ref "")) (awhen (article-date art) (string-append ref (format nil "~a; " it))) (awhen (article-volume art) (string-append ref it)) (awhen (article-issue art) (string-append ref (format nil "(~a)" it))) (awhen (article-pages art) (string-append ref (format nil ":~a" it))) ref)) (defmethod print-article-set ((artset pm-article-set) &key (os *standard-output*) (format :text) (complete nil) (print-link nil)) "Display an article set to specified stream in specified format" (dotimes (i (articles-count artset) artset) (if (nth i (articles artset)) (print-article (nth i (articles artset)) :os os :format format :complete complete :print-link print-link) (princ "NULL Article" os)))) (defmethod print-article ((art pm-article) &key (os *standard-output*) (format :text) (complete nil) (print-link nil)) "Display an article" (ecase format (:text (format os "~a~%~a~%~a~a ~a~%~a~%" (article-title art) (list-to-delimited-string (article-authors art) ", ") (aif (article-affiliation art) (format nil "~a~%" it) "") (article-journal art) (article-ref art) (aif (article-abstract art) (if complete it "Abstract available") "No abstract available") (when complete (format os "~a~%" (article-mesh-headings art))))) (:html (let ((has-link (or (article-abstract art) (article-mesh-headings art)))) (when (and print-link has-link) (format os "" (funcall print-link (article-pmid art)))) (format os "
~a
~%" (article-title art)) (when (and print-link has-link) (format os "
")) (format os "
~a
~%" (list-to-delimited-string (article-authors art) ", ")) (format os "
~a ~a
~%" (article-journal art) (article-ref art)) (when (and complete (article-abstract art)) (format os "
~a
~%" (article-abstract art))) (when (and complete (article-mesh-headings art)) (format os "
Mesh Headings:
") (dolist (mh (article-mesh-headings art)) (format os "
~a
~%" mh))) (format os "

~%")))) art) ;;; Entrez Query Functions (defun equery (searchstr &key (db "pubmed") (usehistory t) start max) "Performs Entrez query and returns article-set structure" (multiple-value-bind (xmlres ids) (do-equery searchstr :db db :usehistory usehistory :start start :max max) (when (xml-tag-contents "Count" xmlres) (let ((as (make-instance 'equery))) (setf (qcount as) (parse-integer (xml-tag-contents "Count" xmlres)) (query as) searchstr) (kmrcl:awhen (xml-tag-contents "WebEnv" xmlres) (setf (wenv as) kmrcl:it)) (kmrcl:awhen (xml-tag-contents "QueryKey" xmlres) (setf (qkey as) kmrcl:it)) as)))) (defun esummary (as &key maximum start) ;; (articles as) (extract-article-set results)) as) (defun pm-fetch-ids (pmids) "Fetchs list of Entrez ID's and returns pm-article-set class" (setq pmids (mklist pmids)) (let ((results (entrez-fetch-pmids-xml pmids))) (unless (xml-tag-contents "Error" results) (let ((as (make-instance 'pm-article-set))) (setf (articles-total as) (length pmids) (articles-query as) (list-to-delimited-string pmids #\,) (articles-start as) 0 (articles-count as) (length pmids) (articles as) (extract-article-set results)) as)))) #+ignore (defun entrez-search-tree (searchstr &key maximum start) "Performs a entrez search and returns two values: tree of Entrez search results and tree of Entrez search status" (multiple-value-bind (xml-search-results xml-search-status) (entrez-search-xml searchstr :maximum maximum :start start) (if xml-search-results (values (parse-xml-no-ws xml-search-results) (parse-xml-no-ws xml-search-status)) (values nil (parse-xml-no-ws xml-search-status))))) (defun do-equery (term &key (db "pubmed") start max (usehistory t)) "Performs a Entrez search and returns two values: XML string of Entrez search results and XML search status" (let ((res (http-equery term :start start :max max :usehistory usehistory :db db))) (values res (extract-pmid-list res)))) (defun http-equery (term &key start max (usehistory t) (db "pubmed")) "Performs a Entrez search and returns XML results of Entrez search which contains Entrez ID's and status results" (let* ((alist `(("db" . ,db) ("term" . ,term))) (geturl (format nil "http://~a~a" +entrez-host+ +entrez-search-url+))) (when usehistory (setq alist (acons "usehistory" "y" alist))) (when start (setq alist (acons "retstart" start alist))) (when max (setq alist (acons "retmax" max alist))) (multiple-value-bind (xmlres http-code http-server-alist) (net.aserve.client:do-http-request geturl :method :get :query alist :proxy *proxy-host*) (declare (ignore http-server-alist)) (when (not (equal http-code 200)) (error "HTTP code performing '~A' was ~D." geturl http-code)) xmlres))) (defun entrez-fetch-pmids-xml (pmids &key (db "pubmed")) "Fetch articles for a list of Entrez ID's and return XML string" (setq pmids (mklist pmids)) ;; Ensure list (when pmids (net.aserve.client:do-http-request (format nil "http://~a~a" +entrez-host+ +entrez-fetch-url+) :method :get :query `(("db" . ,db) ("report" . "xml") ("mode" . "text") ("id" . ,(list-to-delimited-string pmids #\,))) :proxy *proxy-host*))) ;;; XML Extraction Routines (defun extract-article-set (results) "Extract article set from Entrez XML string, return results in pm-article-set class" (multiple-value-bind (as-start as-end as-next) (positions-xml-tag-contents "PubmedArticleSet" results) (declare (ignore as-end as-next)) (when as-start (let ((done nil) (articles '()) (pos as-start)) (until done (multiple-value-bind (a-start a-end a-next) (positions-xml-tag-contents "PubmedArticle" results pos) (if a-start (progn (push (extract-article results a-start a-end) articles) (setq pos a-next) ) (setq done t)))) (nreverse articles))))) (defun extract-article (xmlstr a-start a-end) "Extract article contents from Entrez XML string and return results in pm-article class" (let ((article (make-instance 'pm-article))) (setf (article-pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start a-end)) (article-title article) (xml-tag-contents "ArticleTitle" xmlstr a-start a-end) (article-journal article) (xml-tag-contents "MedlineTA" xmlstr a-start a-end) (article-pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start a-end) (article-affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start a-end) (article-abstract article) (xml-tag-contents "AbstractText" xmlstr a-start a-end)) (multiple-value-bind (ji-start ji-end ji-next) (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end) (declare (ignore ji-next)) (setf (article-volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end) (article-issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end)) (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end) (setf (article-date article) it) (setf (article-date article) (concatenate 'string (xml-tag-contents "Year" xmlstr ji-start ji-end) (aif (xml-tag-contents "Month" xmlstr ji-start ji-end) (format nil " ~a" it) ""))))) (multiple-value-bind (al-start al-end al-next) (positions-xml-tag-contents "AuthorList" xmlstr a-start a-end) (declare (ignore al-next)) (setf (article-authors article) (when al-start (let ((done nil) (authors '()) (pos al-start)) (until done (multiple-value-bind (au-start au-end au-next) (positions-xml-tag-contents "Author" xmlstr pos al-end) (if au-start (progn (push (extract-author xmlstr au-start au-end) authors) (setq pos au-next)) (setq done t)))) (nreverse authors))))) (multiple-value-bind (mhl-start mhl-end mhl-next) (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end) (declare (ignore mhl-next)) (setf (article-mesh-headings article) (when mhl-start (let ((done nil) (mesh-headings '()) (pos mhl-start)) (until done (multiple-value-bind (mh-start mh-end mh-next) (positions-xml-tag-contents "MeshHeading" xmlstr pos mhl-end) (if mh-start (progn (push (extract-mesh-heading xmlstr mh-start mh-end) mesh-headings) (setq pos mh-next) ) (setq done t)))) (nreverse mesh-headings))))) article)) (defun extract-author (xmlstr start end) "Extract author name from XML string" (let ((last-name (xml-tag-contents "LastName" xmlstr start end)) (initials (xml-tag-contents "Initials" xmlstr start end))) (concatenate 'string last-name " " initials))) (defun extract-mesh-heading (xmlstr start end) "Extract and format mesh headings from XML string" (let ((desc (xml-tag-contents "DescriptorName" xmlstr start end)) (sh (xml-tag-contents "SubHeading" xmlstr start end))) (if sh (format nil "~a(~a)" desc sh) desc))) (defun extract-pmid-list (results) "Returns list of Entrez ID's from XML result string" (cond ((search "" results) (error 'entrez-query-error :response results)) ((search "

Server Error

" results) (error 'entrez-server-error :response results)) (t (awhen (xml-tag-contents "Id" results) (delimited-string-to-list it #\space)))))