--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: pubmed.lisp
+;;;; Purpose: Library to access PubMed web application
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Jun 2001
+;;;;
+;;;; $Id: pubmed.lisp,v 1.1 2002/10/26 17:06:07 kevin Exp $
+;;;;
+;;;; This file, part of cl-pubmed, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; cl-pubmed 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)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+(in-package #:cl-user)
+
+(defpackage #:pubmed
+ (:use #:common-lisp #:kmrcl)
+ (:export #:pm-search
+ #:disp-article
+ #:disp-articleset
+ #:fetch-pmids
+ #:total-count
+ #:article-count
+ #:articles
+ ))
+
+(in-package :pubmed)
+
+
+(defparameter +pubmed-host+ "www.ncbi.nlm.nih.gov")
+(defparameter +pubmed-query-url+ "/entrez/utils/pmqty.fcgi")
+(defparameter +pubmed-fetch-url+ "/entrez/utils/pmfetch.fcgi")
+
+
+;;; ArticleSet and Article Classes
+
+(defclass pmsearch ()
+ ((search-str :type string :accessor search-str)
+ (date :type string :accessor date)
+ (user-id :type fixnum :accessor user-id))
+ (:documentation "Pubmed Stored Search Class"))
+
+(defclass pmarticleset ()
+ ((search-str :type string :initarg :search-str :accessor search-str)
+ (total-count :type fixnum :initarg :total-count :accessor total-count)
+ (article-count :type fixnum :initarg :article-count :accessor article-count)
+ (article-start :type fixnum :initarg :article-start :accessor article-start)
+ (articles :type list :initarg :articles :accessor articles))
+ (:documentation "Pubmed Article Set Class")
+ (:default-initargs :total-count 0 :article-start 0 :article-count 0
+ :search-str nil :articles nil))
+
+(defclass pmarticle ()
+ (
+ (pmid :type integer :accessor pmid)
+ (title :type string :accessor title)
+ (authors :type list :accessor authors)
+ (affiliation :type string :accessor affiliation)
+ (journal :type string :accessor journal)
+ (pub-date :type string :accessor pub-date)
+ (volume :type string :accessor volume)
+ (issue :type string :accessor issue)
+ (pages :type string :accessor pages)
+ (abstract :type string :accessor abstract)
+ (mesh-headings :type list :accessor mesh-headings))
+ (:documentation "Pubmed Article Class"))
+
+(defmethod print-object ((obj pmarticleset) (s stream))
+ (print-unreadable-object (obj s :type t :identity t)
+ (format s "~d total articles, ~d articles starting at #~d"
+ (total-count obj)
+ (article-count obj)
+ (article-start obj)
+ )))
+
+(defmethod print-object ((obj pmarticle) (s stream))
+ (print-unreadable-object (obj s :type t :identity t)
+ (format s "pmid:~d" (pmid obj))))
+;; (disp-article obj :os s :format :text)
+
+(defun pmarticle-pubdata (art)
+ "Return a string of publication data for an article"
+ (let ((pubdata ""))
+ (awhen (pub-date art)
+ (string-append pubdata (format nil "~a; " :it)))
+ (awhen (volume art)
+ (string-append pubdata :it))
+ (awhen (issue art)
+ (string-append pubdata (format nil "(~a)" :it)))
+ (awhen (pages art)
+ (string-append pubdata (format nil ":~a" :it)))
+ pubdata))
+
+(defmethod disp-articleset ((artset pmarticleset) &key (os *standard-output*) (format :text)
+ (complete nil) (disp-link t))
+ "Display an article set to specified stream in specified format"
+ (dotimes (i (article-count artset))
+ (disp-article (nth i (articles artset)) :os os :format format
+ :complete complete :disp-link disp-link)))
+
+(defmethod disp-article ((art pmarticle) &key (os *standard-output*) (format :text)
+ (complete nil) (disp-link t))
+ "Display an article"
+ (if (eql format :text)
+ (format os "~a~%~a~%~a~a ~a~%~a~%"
+ (title art)
+ (list-to-delimited-string (authors art) ", ")
+ (aif (affiliation art)
+ (format nil "~a~%" :it) "")
+ (journal art) (pmarticle-pubdata art)
+ (if (abstract art)
+ (if complete
+ (abstract art)
+ "Abstract available")
+ "No abstract available")
+ (when complete
+ (format os "~a~%" (mesh-headings art))))
+
+ (let ((has-link (or (abstract art) (mesh-headings art))))
+ (when (and disp-link has-link)
+ (format os "<a href=\"~a?key=~a\">" (make-url "disp-article") (pmid art)))
+ (format os "<div class=\"article-title\">~a</div>~%" (title art))
+ (when (and disp-link has-link)
+ (format os "</a>"))
+ (format os "<div class=\"article-authors\">~a</div>~%"
+ (list-to-delimited-string (authors art) ", "))
+ (format os "<div class=\"article-reference\">~a ~a</div>~%"
+ (journal art) (pmarticle-pubdata art))
+ (when (and complete (abstract art))
+ (format os "<div class=\"article-abstract\">~a</div>~%"
+ (abstract art)))
+ (when (and complete (mesh-headings art))
+ (format os "<div class=\"mesh-heading-title\">Mesh Headings:</div>")
+ (dolist (mh (mesh-headings art))
+ (format os "<div class=\"mesh-heading\">~a</div>~%" mh)))
+ (format os "<p/>~%"))))
+
+
+;;; PubMed Search Functions
+
+(defun pm-search (searchstr &key disp-max disp-start)
+ "Performs PubMed query and fetch and returns articleset structure"
+ (multiple-value-bind
+ (results status)
+ (pubmed-search-xml searchstr :disp-max disp-max :disp-start disp-start)
+ (if (xml-tag-contents "Count" status)
+ (let ((as (make-instance 'pmarticleset)))
+ (setf
+ (total-count as) (parse-integer (xml-tag-contents "Count" status))
+ (search-str as) searchstr
+ (article-start as) (parse-integer (xml-tag-contents "DispStart" status))
+ (article-count as) (parse-integer (xml-tag-contents "DispMax" status))
+ (articles as) (extract-articleset results))
+ as)
+ nil)))
+
+(defun fetch-pmids (pmids)
+ "Fetchs list of Pubmed ID's and returns articleset class"
+ (setq pmids (mklist pmids))
+ (let ((results (pubmed-fetch-pmids-xml pmids)))
+ (if (xml-tag-contents "Error" results)
+ nil
+ (let ((as (make-instance 'pmarticleset)))
+ (setf
+ (total-count as) (length pmids)
+ (search-str as) (list-to-delimited-string pmids #\,)
+ (article-start as) 0
+ (article-count as) (length pmids)
+ (articles as) (extract-articleset results))
+ as))))
+
+#+ignore
+(defun pubmed-search-tree (searchstr &key disp-max disp-start)
+ "Performs a pubmed search and returns two values:
+tree of PubMed search results and tree of PubMed search status"
+ (multiple-value-bind
+ (xml-search-results xml-search-status)
+ (pubmed-search-xml searchstr :disp-max disp-max :disp-start disp-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 pubmed-search-xml (searchstr &key disp-max disp-start)
+ "Performs a Pubmed search and returns two values:
+XML string of PubMed search results and XML search status"
+ (multiple-value-bind
+ (pmids search-status)
+ (pubmed-query-xml searchstr :disp-max disp-max :disp-start disp-start)
+ (values (pubmed-fetch-pmids-xml pmids) search-status)))
+
+(defun pubmed-query-xml (searchstr &key disp-max disp-start)
+ "Performs a Pubmed search and returns two values:
+ list of PubMed ID's that match search string and XML search status"
+ (let ((search-results (pubmed-query-status searchstr :disp-max disp-max :disp-start disp-start)))
+ (values (extract-pmid-list search-results) search-results)))
+
+(defun pubmed-query-status (searchstr &key disp-max disp-start)
+ "Performs a Pubmed search and returns XML results of PubMed search
+ which contains PubMed ID's and status results"
+ (let ((query-alist `(("db" . "m") ("term" . ,searchstr) ("mode" . "xml"))))
+ (when disp-max (push (cons "dispmax" disp-max) query-alist))
+ (when disp-start (push (cons "dispstart" disp-start) query-alist))
+ (net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-query-url+)
+ :method :get
+ :query query-alist)))
+
+(defun pubmed-fetch-pmids-xml (pmids)
+ "Fetch articles for a list of PubMed ID's and return XML string"
+ (setq pmids (mklist pmids)) ;; Ensure list
+ (if pmids
+ (net.aserve.client:do-http-request (format nil "http://~a~a" +pubmed-host+ +pubmed-fetch-url+)
+ :method :get
+ :query
+ `(("db" . "PubMed") ("report" . "xml") ("mode" . "text")
+ ("id" . ,(list-to-delimited-string pmids #\,))))))
+
+;;; XML Extraction Routines
+
+(defun extract-articleset (results)
+ "Extract article set from PubMed XML string, return results in pmarticleset 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 PubMed XML string and return results in pmarticle class"
+ (let ((article (make-instance 'pmarticle)))
+ (setf
+ (pmid article) (parse-integer (xml-tag-contents "PMID" xmlstr a-start))
+ (title article) (xml-tag-contents "ArticleTitle" xmlstr a-start)
+ (journal article) (xml-tag-contents "MedlineTA" xmlstr a-start)
+ (pages article) (xml-tag-contents "MedlinePgn" xmlstr a-start)
+ (affiliation article) (xml-tag-contents "Affiliation" xmlstr a-start)
+ (abstract article) (xml-tag-contents "AbstractText" xmlstr a-start))
+ (multiple-value-bind (ji-start ji-end ji-next)
+ (positions-xml-tag-contents "JournalIssue" xmlstr a-start a-end)
+ (declare (ignore ji-next))
+ (setf
+ (volume article) (xml-tag-contents "Volume" xmlstr ji-start ji-end)
+ (issue article) (xml-tag-contents "Issue" xmlstr ji-start ji-end))
+ (aif (xml-tag-contents "MedlineDate" xmlstr ji-start ji-end)
+ (setf (pub-date article) :it)
+ (setf (pub-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 (authors article)
+ (if 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))
+ nil)))
+
+ (multiple-value-bind (mhl-start mhl-end mhl-next)
+ (positions-xml-tag-contents "MeshHeadingList" xmlstr a-start a-end)
+ (declare (ignore mhl-next))
+ (setf (mesh-headings article)
+ (if 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))
+ nil)))
+ 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 "Descriptor" 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 PubMed ID's from XML result string"
+ (if (search "<ERROR>" results)
+ nil
+ (awhen (xml-tag-contents "Id" results)
+ (delimited-string-to-list it #\space))))
+
+
+
projects / pubmed.git / commitdiff