;;;; -*- 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.2 2002/10/31 02:01: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 "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 PubMed ID's from XML result string"
  (if (search "<ERROR>" results)
      nil
    (awhen (xml-tag-contents "Id" results)
	   (delimited-string-to-list it #\space))))