From 0ececd07987c48de78c14a60136014a2df7b280b Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 5 Oct 2002 20:17:14 +0000 Subject: [PATCH] r2947: *** empty log message *** --- .cvsignore | 1 + data-structures.lisp | 44 ++ debian/changelog | 6 + debian/control | 15 + debian/copyright | 14 + debian/postinst | 45 ++ debian/prerm | 41 ++ debian/rules | 83 +++ obj-composite.lisp | 177 ++++++ obj-sql.lisp | 1257 ++++++++++++++++++++++++++++++++++++++++++ obj.lisp | 624 +++++++++++++++++++++ package.lisp | 153 +++++ parse-2002.lisp | 433 +++++++++++++++ parse-common.lisp | 458 +++++++++++++++ parse-macros.lisp | 44 ++ sql.lisp | 96 ++++ umlisp.asd | 18 + utils.lisp | 83 +++ 18 files changed, 3592 insertions(+) create mode 100644 .cvsignore create mode 100644 data-structures.lisp create mode 100644 debian/changelog create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/postinst create mode 100644 debian/prerm create mode 100755 debian/rules create mode 100644 obj-composite.lisp create mode 100644 obj-sql.lisp create mode 100644 obj.lisp create mode 100644 package.lisp create mode 100644 parse-2002.lisp create mode 100644 parse-common.lisp create mode 100644 parse-macros.lisp create mode 100644 sql.lisp create mode 100644 umlisp.asd create mode 100644 utils.lisp diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..ca8d09f --- /dev/null +++ b/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/data-structures.lisp b/data-structures.lisp new file mode 100644 index 0000000..d13b709 --- /dev/null +++ b/data-structures.lisp @@ -0,0 +1,44 @@ +;;;; $Id: data-structures.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + + +;;; Paths for files + +(defvar *umls-path* + (kboot:find-directory + '((nil (:absolute "data" "umls" "2002AC")) + (nil (:absolute "data" "umls" "2002AB")) + (nil (:absolute "data" "umls" "UMLS2001")) + #+mswindows ("F" (:absolute "umls" "2002ac")) + #+mswindows ("C" (:absolute "umls")) + #+mswindows ("F" (:absolute "umls" "UMLS2001")) + )) + "Path for base of UMLS data files") + +(defvar *meta-path* + (merge-pathnames + (make-pathname :directory '(:relative "META")) + *umls-path*)) + +(defvar *lex-path* + (merge-pathnames + (make-pathname :directory '(:relative "LEX")) + *umls-path*)) + +(defvar *net-path* + (merge-pathnames + (make-pathname :directory '(:relative "NET")) + *umls-path*)) + +(defun umls-path! (p) + (setq *umls-path* p)) + + +;;; Structures for parsing UMLS text files + +(defparameter *umls-files* nil + "List of umls file structures. Used when parsing text files.") +(defparameter *umls-cols* nil + "List of meta column structures. Used when parsing text files.") + diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..9115e9e --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +cl-umlisp (1.0-1) unstable; urgency=low + + * Initial Release. + + -- Kevin M. Rosenberg Sat, 5 Oct 2002 12:52:28 -0600 + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..b41294c --- /dev/null +++ b/debian/control @@ -0,0 +1,15 @@ +Source: cl-umlisp +Section: contrib/devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>= 4.0.0) +Standards-Version: 3.5.7.0 + +Package: cl-umlisp +Architecture: all +Depends: ${shlibs:Depends} +Description: Common Lisp interface for the Unified Medical Language System + The Unified Medical Language System is a multi-gigabyte database of + medical terminology. This a interface for Common Lisp programs that utilizes + the a SQL database engine and Common Lisp classes for efficient access. + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..5f117b5 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,14 @@ +This package was debianized by Kevin M. Rosenberg on +Sat, 5 Oct 2002 12:52:28 -0600. + +It was downloaded from ftp://umlisp.b9.com + +Upstream Author: Kevin M. Rosenberg + +Copyright: + +UMLisp is Copyright (C) 2000-2002 by Kevin M. Rosenberg +It is open-source software govened by the GNU GPL License. + +The GNU GPL License is in your Debian file system as +/usr/share/common-licenses/GPL. diff --git a/debian/postinst b/debian/postinst new file mode 100644 index 0000000..f1c0a35 --- /dev/null +++ b/debian/postinst @@ -0,0 +1,45 @@ +#! /bin/sh +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=umlisp + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 diff --git a/debian/prerm b/debian/prerm new file mode 100644 index 0000000..5a64fa7 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,41 @@ +#! /bin/sh +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=umlisp + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..db8ed18 --- /dev/null +++ b/debian/rules @@ -0,0 +1,83 @@ +#!/usr/bin/make -f + +export DH_COMPAT=4 + +pkg := umlisp +debpkg := cl-umlisp + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-umlisp := $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-umlisp.postinst.* debian/cl-umlisp.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/umlisp. + dh_installdirs $(clc-systems) $(clc-umlisp) $(doc-dir) + dh_install umlisp.asd $(shell echo *.lisp) $(clc-umlisp) + #dh_install $(shell echo *.html) $(doc-dir) + dh_link $(clc-umlisp)/umlisp.asd $(clc-systems)/umlisp.asd + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/obj-composite.lisp b/obj-composite.lisp new file mode 100644 index 0000000..61f62d5 --- /dev/null +++ b/obj-composite.lisp @@ -0,0 +1,177 @@ +;;;; $Id: obj-composite.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + + +;;; Semantic type constants + +(defun find-tui-word (words) + (gu:aif (car (find-usty-word words)) + (tui gu::it) + nil)) +(gu:memoize 'find-tui-word) + +(defun tui-disease-or-syndrome () + (find-tui-word "disease or syndrome")) +(defun tui-sign-or-symptom () + (find-tui-word "sign or symptom")) +(defun tui-finding () + (find-tui-word "finding")) + + +;;;; Related concepts with specific tui lookup functions + +(defun ucon-is-tui? (ucon tui) + "Returns t if ucon has a semantic type of tui" + (find tui (s#sty ucon) :key #'tui)) + +(defun find-ucon2-tui (ucon tui cui2-func related-con-func) + "Returns a list of related ucons that have specific tui" + (remove-duplicates + (filter + #'(lambda (c) + (gu:aif (funcall cui2-func c) + (let ((ucon2 (find-ucon-cui gu::it))) + (when (ucon-is-tui? ucon2 tui) + ucon2)) + nil)) + (funcall related-con-func ucon)) + :key #'cui)) + +(defun find-ucon2-coc-tui (ucon tui) + "Return list of ucon's that have co-occuring concepts of semantic type tui" + (find-ucon2-tui ucon tui #'cui2 #'s#coc)) + +(defun find-ucon2-rel-tui (ucon tui) + "Return list of ucon's that have related concepts to ucon and semantic type tui" + (find-ucon2-tui ucon tui #'cui2 #'s#rel)) + +;;; Composite Objects + +(defclass ucon_freq (umlsclass) + ((ucon :type ucon :initarg :ucon :reader ucon) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :cui nil :pfstr nil :freq nil) + (:title "Concept and Count") + (:fields (cui :string fmt-cui) (freq :fixnum) (pfstr :cdata)) + (:ref-fields (cui find-ucon-cui)) + (:documentation "Composite object of ucon/freq")) + +(defun ucon_freq-cui (c) + (cui (ucon c))) + +(defun ucon_freq-pfstr (c) + (pfstr (ucon c))) + +(defclass ustr_freq (umlsclass) + ((ustr :type ustr :initarg :ustr :reader ustr) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :cui nil :pfstr nil :freq nil) + (:title "String and Count") + (:fields (sui :string fmt-sui) (freq :fixnum) (stt :string) (lrl :fixnum) (str :cdata)) + (:ref-fields (sui find-ustr-sui)) + (:documentation "Composite object of ustr/freq")) + +(defun ustr_freq-sui (s) + (sui (ustr s))) + +(defun ustr_freq-str (s) + (str (ustr s))) + +(defun ustr_freq-lrl (s) + (lrl (ustr s))) + +(defun ustr_freq-stt (s) + (stt (ustr s))) + +(defclass usty_freq (umlsclass) + ((usty :type usty :initarg :usty :reader usty) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :usty nil :freq nil) + (:title "Semantic Type and Count") + (:ref-fields (tui find-ucon-tui "subobjects=no")) + (:fields (tui :string fmt-tui) (freq :fixnum) (sty :string)) + (:documentation "Composite object of usty/freq")) + +(defun usty_freq-tui (s) + (tui (usty s))) + +(defun usty_freq-sty (s) + (sty (usty s))) + +(defclass usrl_freq (umlsclass) + ((usrl :type usrl :initarg :usrl :reader usrl) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :usrl nil :freq nil) + (:title "Source and Count") + (:ref-fields (sab find-ustr-sab)) + (:fields (sab :string) (freq :commainteger) (srl :fixnum)) + (:documentation "Composite object of usrl/freq")) + +(defun usrl_freq-sab (s) + (sab (usrl s))) + +(defun usrl_freq-srl (s) + (srl (usrl s))) + + +;; Frequency finding functions +(defun find-ucon2_freq-coc-tui (ucon tui) +"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui" + (let ((ucon_freqs '())) + (dolist (ucoc (s#coc ucon)) + (gu:aif (cui2 ucoc) + (let ((ucon2 (find-ucon-cui gu::it))) + (when (ucon-is-tui? ucon2 tui) + (push (make-instance 'ucon_freq :ucon ucon2 :freq (cof ucoc)) + ucon_freqs))))) + (setq ucon_freqs (delete-duplicates ucon_freqs :key #'cui)) + (sort ucon_freqs #'> :key #'freq))) + +(defun find-ucon2-str&sty (str sty lookup-func) + "Call lookup-func for ucon and usty for given str and sty" + (let ((ucon (car (find-ucon-str str))) + (usty (car (find-usty-word sty)))) + (if (and ucon usty) + (funcall lookup-func ucon (tui usty)) + nil))) + +(defun find-ucon2-coc-str&sty (str sty) + "Find all ucons that are a co-occuring concept for concept named str + and that have semantic type of sty" + (find-ucon2-str&sty str sty #'find-ucon2-coc-tui)) + +(defun find-ucon2-rel-str&sty (str sty) + "Find all ucons that are a relationship to concept named str + and that have semantic type of sty" + (find-ucon2-str&sty str sty #'find-ucon2-rel-tui)) + +;;; Most common relationships, co-occurances + +(defun find-ucon2_freq-tui-all (tui ucon2-tui-func) + "Return sorted list of all ucon2 that have a semantic type tui with ucon that is also has sty of tui" + (let ((ucon_freqs (make-array (1+ (find-cui-max)) :initial-element nil))) + (dolist (ucon (find-ucon-tui tui)) ;; for all disease-or-syn + (dolist (ucon2 (funcall ucon2-tui-func ucon tui)) ;; for each related disease + (gu:aif (aref ucon_freqs (cui ucon2)) + (setf (freq gu::it) (1+ (freq gu::it))) + (setf (aref ucon_freqs (cui ucon2)) + (make-instance 'ucon_freq :ucon ucon2 :freq 1))))) + (let ((ucon_freq-list '())) + (dotimes (i (find-cui-max)) + (declare (fixnum i)) + (gu:awhen (aref ucon_freqs i) + (push gu::it ucon_freq-list))) + (sort ucon_freq-list #'> :key #'freq)))) + +(defun find-ucon2_freq-rel-tui-all (tui) + "Sorted list of ucon_freq with semantic type tui that are rel's of ucons with semantic type tui" + (find-ucon2_freq-tui-all tui #'find-ucon2-rel-tui)) + +(defun find-ucon2_freq-coc-tui-all (tui) + (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui)) + diff --git a/obj-sql.lisp b/obj-sql.lisp new file mode 100644 index 0000000..e05e096 --- /dev/null +++ b/obj-sql.lisp @@ -0,0 +1,1257 @@ +;;; $Id: obj-sql.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + +(declaim (optimize (speed 3) (safety 1))) + +(defvar *current-srl* nil) +(defun current-srl () + *current-srl*) +(defun current-srl! (srl) + (setq *current-srl* srl)) + +;;; Initializers + +(defun post-import-sql () + (make-ustats) + (make-usrl) + (make-user-table) + #+pubmed (create-pmsearch-table)) + +;;; Accessors (read on demand) + +;; defines a slot-unbound method for class and slot-name, fills +;; the slot by calling reader function with the slot values of +;; the instance's reader-keys +(defmacro def-lazy-reader (class slot-name reader &rest reader-keys) + (let* ((the-slot-name (gensym)) + (the-class (gensym)) + (the-instance (gensym)) + (keys '())) + (dolist (key reader-keys) + (push (list 'slot-value the-instance (list 'quote key)) keys)) + (setq keys (nreverse keys)) + `(defmethod slot-unbound (,the-class (,the-instance ,class) + (,the-slot-name (eql ',slot-name))) + (declare (ignore ,the-class)) + (setf (slot-value ,the-instance ,the-slot-name) + (,reader ,@keys))))) + +(def-lazy-reader ucon s#term find-uterm-cui cui) +(def-lazy-reader ucon s#def find-udef-cui cui) +(def-lazy-reader ucon s#sty find-usty-cui cui) +(def-lazy-reader ucon s#rel find-urel-cui cui) +(def-lazy-reader ucon s#coc find-ucoc-cui cui) +(def-lazy-reader ucon s#lo find-ulo-cui cui) +(def-lazy-reader ucon s#atx find-uatx-cui cui) +(def-lazy-reader ucon s#sat find-usat-ui cui) + +;; For uterms +(def-lazy-reader uterm s#str find-ustr-cuilui cui lui) +(def-lazy-reader uterm s#sat find-usat-ui cui lui) + +;; For ustrs +(def-lazy-reader ustr s#sat find-usat-ui cui lui sui) +(def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui) +(def-lazy-reader ustr s#so find-uso-cuisui cui sui) + +;;; Object lookups + +;;; Lookup functions for uterms,ustr in ucons + +(defun find-uterm-in-ucon (ucon lui) + (find lui (s#term ucon) :key #'uterm-lui :test 'equal)) + +(defun find-ustr-in-uterm (uterm sui) + (find sui (s#str uterm) :key #'ustr-sui :test 'equal)) + +(defun find-ustr-in-ucon (ucon sui) + (let ((found-ustr nil)) + (dolist (uterm (s#term ucon)) + (unless found-ustr + (dolist (ustr (s#str uterm)) + (unless found-ustr + (when (string-equal sui (sui ustr)) + (setq found-ustr ustr)))))) + found-ustr)) + + +(defun find-ucon-cui (cui &key (srl *current-srl*)) + "Find ucon for a cui" + (if (stringp cui) + (setq cui (parse-cui cui))) + (if cui + (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" + cui))) + (if srl + (string-append ls (format nil " and KCUILRL <= ~d limit 1" srl)) + (string-append ls " limit 1")) + (gu:awhen (car (mutex-sql-query ls)) + (make-instance 'ucon :cui cui :pfstr (car gu::it) + :lrl (ensure-integer (cadr gu::it))))) + nil)) + +(defun find-ucon-lui (lui &key (srl *current-srl*)) + "Find list of ucon for lui" + (if (stringp lui) + (setq lui (parse-lui lui))) + (if lui + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui))) + (if srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) + :pfstr (nth 1 tuple) + :lrl (ensure-integer (nth 2 tuple))) + ucons)) + (nreverse ucons)) + nil)) + +(defun find-ucon-sui (sui &key (srl *current-srl*)) + "Find list of ucon for sui" + (if (stringp sui) + (setq sui (parse-sui sui))) + (if sui + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui))) + (when srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (let ((tuples (mutex-sql-query ls))) + (dolist (tuple tuples) + (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) + :pfstr (nth 1 tuple) + :lrl (ensure-integer (nth 2 tuple))) + ucons))) + (nreverse ucons)) + nil)) + +(defun find-ucon-cuisui (cui sui &key (srl *current-srl*)) + "Find ucon for cui/sui" + (if (stringp cui) + (setq cui (parse-cui cui))) + (if (stringp sui) + (setq sui (parse-sui sui))) + (if (and cui sui) + (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (gu:aif (car (mutex-sql-query ls)) + (make-instance 'ucon :cui (ensure-integer (nth 0 gu::it)) + :pfstr (nth 1 gu::it) + :lrl (ensure-integer (nth 2 gu::it))) + nil)) + nil)) + +(defun find-ucon-str (str &key (srl *current-srl*)) + "Find ucon that are exact match for str" + (if str + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str))) + (when srl + (string-append ls " and KCUILRL <= ~d" srl)) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) + :pfstr (nth 1 tuple) + :lrl (ensure-integer (nth 2 tuple))) ucons)) + (nreverse ucons)) + nil)) + +(defun find-ucon-all (&key (srl *current-srl*)) + "Return list of all ucon's" + (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON")) + (when srl + (string-append ls (format nil " where KCUILRL <= ~d" srl))) + (string-append ls " order by CUI asc") + (with-sql-connection (db) + (clsql:map-query + 'list + #'(lambda (cui pfstr cuilrl) + (make-instance 'ucon :cui (ensure-integer cui) + :pfstr pfstr + :lrl (ensure-integer cuilrl))) + ls + :database db)))) + + + +(defun find-udef-cui (cui &key (srl *current-srl*)) + "Return a list of udefs for cui" + (let ((udefs '()) + (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'udef :sab (car tuple) :def (cadr tuple)) udefs)) + (nreverse udefs))) + +(defun find-usty-cui (cui &key (srl *current-srl*)) + "Return a list of usty for cui" + (let ((ustys '()) + (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) + ustys)) + +(defun find-usty-word (word &key (srl *current-srl*)) + "Return a list of usty that match word" + (let ((ustys '()) + (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) + ustys)) + +(defun find-urel-cui (cui &key (srl *current-srl*)) + "Return a list of urel for cui" + (let ((urels '()) + (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'urel + :cui1 cui + :rel (nth 0 tuple) + :cui2 (ensure-integer (nth 1 tuple)) + :rela (nth 2 tuple) + :sab (nth 3 tuple) + :sl (nth 4 tuple) + :mg (nth 5 tuple) + :pfstr2 (nth 6 tuple)) + urels)) + (nreverse urels))) + +(defun find-urel-cui2 (cui2 &key (srl *current-srl*)) + "Return a list of urel for cui2" + (let ((urels '()) + (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2))) + (when srl + (string-append ls (format nil " and SRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'urel + :cui2 cui2 + :rel (nth 0 tuple) + :cui1 (ensure-integer (nth 1 tuple)) + :rela (nth 2 tuple) + :sab (nth 3 tuple) + :sl (nth 4 tuple) + :mg (nth 5 tuple) + :pfstr2 (nth 6 tuple)) + urels)) + (nreverse urels))) + +(defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*)) + (mapcar + #'(lambda (cui) (find-ucon-cui cui :key srl)) + (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl))))) + +(defun find-ucoc-cui (cui &key (srl *current-srl*)) + "Return a list of ucoc for cui" + (let ((ucocs '()) + (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by COF asc") + (dolist (tuple (mutex-sql-query ls)) + (let ((cui2 (ensure-integer (nth 0 tuple)))) + (when (zerop cui2) + (setq cui2 nil)) + (push (make-instance 'ucoc :cui1 cui + :cui2 cui2 + :soc (nth 1 tuple) + :cot (nth 2 tuple) + :cof (ensure-integer (nth 3 tuple)) + :coa (nth 4 tuple) + :pfstr2 (nth 5 tuple)) + ucocs))) + ucocs)) ;; akready ordered by SQL select + +(defun find-ucoc-cui2 (cui2 &key (srl *current-srl*)) + "Return a list of ucoc for cui2" + (let ((ucocs '()) + (ls (format nil "select CUI1,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI2=~d" cui2))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (string-append ls " order by COF asc") + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucoc :cui1 (ensure-integer (nth 0 tuple)) + :cui2 cui2 + :soc (nth 1 tuple) + :cot (nth 2 tuple) + :cof (ensure-integer (nth 3 tuple)) + :coa (nth 4 tuple) + :pfstr2 (nth 5 tuple)) + ucocs)) + ucocs)) ;; already ordered by SQL select + +(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*)) + "List of ucon with co-occurance cui2" + (mapcar + #'(lambda (cui) (find-ucon-cui cui :key srl)) + (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl))))) + +(defun find-ulo-cui (cui &key (srl *current-srl*)) + "Return a list of ulo for cui" + (let ((ulos '()) + (ls (format nil "select ISN,FR,UN,SUI,SNA,SOUI from MRLO where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ulo :isn (nth 0 tuple) + :fr (ensure-integer (nth 1 tuple)) + :un (nth 2 tuple) + :sui (ensure-integer (nth 3 tuple)) + :sna (nth 4 tuple) + :soui (nth 5 tuple)) + ulos)) + (nreverse ulos))) + +(defmethod suistr ((lo ulo)) + "Return the string for a ulo object" + (find-string-sui (sui lo))) + +(defun find-uatx-cui (cui &key (srl *current-srl*)) + "Return a list of uatx for cui" + (let ((uatxs '()) + (ls (format nil "select SAB,REL,ATX from MRATX where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uatx :sab (nth 0 tuple) + :rel (nth 1 tuple) + :atx (nth 2 tuple)) + uatxs)) + (nreverse uatxs))) + + +(defun find-uterm-cui (cui &key (srl *current-srl*)) + "Return a list of uterm for cui" + (let ((uterms '()) + (ls (format nil "select distinct LUI,LAT,TS,KLUILRL from MRCON where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KLUILRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uterm :lui (ensure-integer (nth 0 tuple)) + :cui cui + :lat (nth 1 tuple) + :ts (nth 2 tuple) + :lrl (ensure-integer (nth 3 tuple))) + uterms)) + (nreverse uterms))) + +(defun find-uterm-lui (lui &key (srl *current-srl*)) + "Return a list of uterm for lui" + (if (stringp lui) + (setq lui (parse-lui lui))) + (let ((uterms '()) + (ls (format nil "select distinct CUI,LAT,TS,KLUILRL from MRCON where LUI=~d" lui))) + (when srl + (string-append ls (format nil " and KLUILRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uterm :cui (ensure-integer (nth 0 tuple)) + :lui lui + :lat (nth 1 tuple) + :ts (nth 2 tuple) + :lrl (ensure-integer (nth 3 tuple))) + uterms)) + (nreverse uterms))) + +(defun find-uterm-cuilui (cui lui &key (srl *current-srl*)) + "Return single uterm for cui/lui" + (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui)))) + (when srl + (string-append ls (format nil " and KLUILRL <= ~d" srl))) + (gu:aif (car (mutex-sql-query ls)) + (make-instance 'uterm :cui cui + :lui lui + :lat (nth 0 gu::it) + :ts (nth 1 gu::it) + :lrl (ensure-integer (nth 2 gu::it))) + nil))) + +(defun find-ustr-cuilui (cui lui &key (srl *current-srl*)) + "Return a list of ustr for cui/lui" + (declare (fixnum cui lui)) + (let ((ustrs '()) + (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui)))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (let* ((sui (ensure-integer (car tuple))) + (ustr (make-instance 'ustr :sui sui + :cui cui + :cuisui (make-cuisui cui sui) + :lui lui + :stt (nth 1 tuple) + :str (nth 2 tuple) + :lrl (ensure-integer (nth 3 tuple))))) + (push ustr ustrs))) + (nreverse ustrs))) + +(defun find-ustr-cuisui (cui sui &key (srl *current-srl*)) + "Return the single ustr for cuisui" + (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (gu:aif (car (mutex-sql-query ls)) + (make-instance 'ustr :sui sui + :cui cui + :cuisui (make-cuisui cui sui) + :lui (ensure-integer (nth 0 gu::it)) + :stt (nth 1 gu::it) + :str (nth 2 gu::it) + :lrl (ensure-integer (nth 3 gu::it))) + nil))) + +(defun find-ustr-sui (sui &key (srl *current-srl*)) + "Return the list of ustr for sui" + (if (stringp sui) + (setq sui (parse-sui sui))) + (let ((ustrs '()) + (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (let ((cui (ensure-integer (car tuple)))) + (push (make-instance 'ustr :sui sui + :cui cui + :cuisui (make-cuisui cui sui) + :lui (ensure-integer (nth 1 tuple)) + :stt (nth 2 tuple) + :str (nth 3 tuple) + :lrl (ensure-integer (nth 4 tuple))) + ustrs))) + (nreverse ustrs))) + +(defun find-ustr-sab (sab &key (srl *current-srl*)) + "Return the list of ustr for sab" + (let ((ustrs '()) + (ls (format nil "select KCUISUI from MRSO where SAB='~a'" sab))) + (when srl + (string-append ls (format nil " and SRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (let ((cuisui (ensure-integer (car tuple)))) + (push (apply #'find-ustr-cuisui + (append + (multiple-value-list (decompose-cuisui cuisui)) + (list :srl srl))) + ustrs))) + (nreverse ustrs))) + +(defun find-ustr-all (&key (srl *current-srl*)) + "Return list of all ustr's" + (let ((ls "select distinct CUI,LUI,SUI,STT,LRL,KPFSTR from MRCON")) + (when srl + (string-append ls (format nil " where LRL <= ~d" srl))) + (string-append ls " order by SUI asc") + (with-sql-connection (db) + (clsql:map-query + 'list + #'(lambda (cui lui sui stt lrl pfstr) + (setq cui (ensure-integer cui)) + (setq lui (ensure-integer lui)) + (setq sui (ensure-integer sui)) + (setq lrl (ensure-integer lrl)) + (make-instance 'ustr :cui cui + :lui lui + :sui sui + :cuisui (make-cuisui cui sui) + :stt stt + :lrl lrl + :str pfstr)) + ls + :database db)))) + +(defun find-string-sui (sui &key (srl *current-srl*)) + "Return the string associated with sui" + (let ((ls (format nil "select STR from MRCON where SUI=~d" sui))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (string-append ls " limit 1") + (caar (mutex-sql-query ls)))) + +(defun find-uso-cuisui (cui sui &key (srl *current-srl*)) + (declare (fixnum cui sui)) + (let ((usos '()) + (ls (format nil "select SAB,CODE,SRL,TTY from MRSO where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and SRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uso :sab (nth 0 tuple) :code (nth 1 tuple) + :srl (nth 2 tuple) :tty (nth 3 tuple)) + usos)) + (nreverse usos))) + +(defun find-ucxt-cuisui (cui sui &key (srl *current-srl*)) + (declare (fixnum cui sui)) + (let ((ucxts '()) + (ls (format nil "select SAB,CODE,CXN,CXL,RNK,CXS,CUI2,HCD,RELA,XC from MRCXT where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucxt :sab (nth 0 tuple) + :code (nth 1 tuple) + :cxn (ensure-integer (nth 2 tuple)) + :cxl (nth 3 tuple) + :rnk (ensure-integer (nth 4 tuple)) + :cxs (nth 5 tuple) + :cui2 (ensure-integer (nth 6 tuple)) + :hcd (nth 7 tuple) + :rela (nth 8 tuple) + :xc (nth 9 tuple)) + ucxts)) + (nreverse ucxts))) + +(defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*)) + (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where "))) + (cond + (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui)))) + (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui)))) + (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui)))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (let ((usats '())) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'usat :code (nth 0 tuple) + :atn (nth 1 tuple) + :sab (nth 2 tuple) + :atv (nth 3 tuple)) + usats)) + (nreverse usats)))) + +(defun find-bsab-sab (sab) + (gu:aif (car (mutex-sql-query + (format nil "select NAME,COUNT from BONUS_SAB where SAB='~a'" sab))) + (make-instance 'bsab :sab sab :name (nth 0 gu::it) + :hits (ensure-integer (nth 1 gu::it))) + nil)) + +(defun find-bsab-all () + (let ((usabs '())) + (dolist (tuple (mutex-sql-query "select SAB,NAME,COUNT from BONUS_SAB")) + (push + (make-instance 'bsab :sab (nth 0 tuple) :name (nth 1 tuple) + :hits (ensure-integer (nth 2 tuple))) + usabs)) + (nreverse usabs))) + +(defun find-btty-tty (tty) + (gu:aif (car (mutex-sql-query + (format nil "select NAME from BONUS_TTY where TTY='~a'" tty))) + (make-instance 'btty :tty tty :name (nth 0 gu::it)) + nil)) + +(defun find-btty-all () + (let ((uttys '())) + (dolist (tuple (mutex-sql-query "select TTY,NAME from BONUS_TTY")) + (push + (make-instance 'btty :tty (nth 0 tuple) :name (nth 1 tuple)) + uttys)) + (nreverse uttys))) + +(defun find-brel-rel (rel) + (let ((brels '())) + (dolist (tuple (mutex-sql-query + (format nil "select SAB,SL,REL,RELA,COUNT from BONUS_REL where REL='~a'" rel))) + (push + (make-instance 'brel :sab (nth 0 tuple) :sl (nth 1 tuple) :rel (nth 2 tuple) + :rela (nth 3 tuple) :hits (ensure-integer (nth 4 tuple))) + brels)) + (nreverse brels))) + +(defun find-pfstr-cui (cui) + (caar (mutex-sql-query (format nil "select KPFSTR from MRCON where CUI=~d limit 1" cui)))) + +(defun find-usty-tui (tui) + "Find usty for tui" + (setq tui (parse-tui tui)) + (gu:aif (car (mutex-sql-query + (format nil "select STY from MRSTY where TUI=~d limit 1" tui))) + (make-instance 'usty :tui tui :sty (nth 0 gu::it)) + nil)) + +(defun find-usty-sty (sty) + "Find usty for a sty" + (gu:aif (car (mutex-sql-query + (format nil "select TUI from MRSTY where STY='~a' limit 1" sty))) + (make-instance 'usty :tui (ensure-integer (nth 0 gu::it)) :sty sty) + nil)) + +(defun find-usty-all () + "Return list of usty's for all semantic types" + (let ((ustys '())) + (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) + (push (find-usty-tui (nth 0 tuple)) ustys)) + (nreverse ustys))) + +(defun find-usty_freq-all () + (let ((usty_freqs '())) + (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) + (let* ((tui (car tuple)) + (freq (ensure-integer + (caar (mutex-sql-query + (format nil "select count(*) from MRSTY where TUI=~a" tui)))))) + (push (make-instance 'usty_freq :usty (find-usty-tui tui) :freq freq) usty_freqs))) + (sort usty_freqs #'> :key #'usty_freq-freq))) + + +(defun make-user-table () + (mutex-sql-execute "create table UMLISP_USERS (ID integer UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,FIRST_NAME varchar(20),LAST_NAME varchar(20),ORGANIZATION varchar(80),ADDRESS1 varchar(60),ADDRESS2 varchar(60),CITY varchar(30),STATE char(2),ZIP char(10),COUNTRY varchar(40),OCCUPATION varchar(120),EMAIL varchar(80),PASSWD varchar(20),MAILLIST char(1),LICENSED char(1),SRL integer,TIMEOUT integer,DATETIME_CREATED datetime,DATETIME_MODIFIED datetime)")) + +(defun find-umlisp-user-email (email) + (let ((tuple (car (mutex-sql-query + (format nil "select ID,FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED from UMLISP_USERS where EMAIL='~a'" email))))) + (when tuple + (make-instance 'umlisp-user :email email + :id (ensure-integer (nth 0 tuple)) + :first-name (nth 1 tuple) + :last-name (nth 2 tuple) + :organization (nth 3 tuple) + :address1 (nth 4 tuple) + :address2 (nth 5 tuple) + :city (nth 6 tuple) + :state (nth 7 tuple) + :zip (nth 8 tuple) + :country (nth 9 tuple) + :occupation (nth 10 tuple) + :licensed (if (string-equal "Y" (nth 11 tuple)) t nil) + :maillist (if (string-equal "Y" (nth 12 tuple)) t nil) + :passwd (nth 13 tuple) + :srl (ensure-integer (nth 14 tuple)) + :timeout (ensure-integer (nth 15 tuple)) + :datetime-created (nth 16 tuple) + :datetime-modified (nth 17 tuple))))) + +(defun find-umlisp-user-all () + (let ((users '())) + (dolist (email (find-umlisp-user-all-email)) + (push (find-umlisp-user-email email) users)) + (nreverse users))) + +(defun find-umlisp-user-all-email () + (let ((emails '())) + (dolist (tuple (mutex-sql-query "select EMAIL from UMLISP_USERS")) + (push (car tuple) emails)) + (nreverse emails))) + +(defun find-umlisp-user-announce-email () + (let ((emails '())) + (dolist (tuple (mutex-sql-query + "select EMAIL from UMLISP_USERS where MAILLIST='Y'")) + (push (car tuple) emails)) + (nreverse emails))) + +(defun add-umlisp-user (user) + (if (typep user 'umlisp-user) + (progn + (mutex-sql-execute + (format nil "insert into UMLISP_USERS (FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,EMAIL,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED) values ('~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a',~d,~d,NOW(),NOW())" + (first-name user) (last-name user) + (organization user) + (address1 user) (address2 user) + (city user) (state user) + (zip user) (country user) (occupation user) + (if (licensed user) #\Y #\N) + (if (maillist user) #\Y #\N) + (email user) + (passwd user) (srl user) + (timeout user))) + (let ((read-user (find-umlisp-user-email (email user)))) + (setf (slot-value user 'id) (id read-user) + (slot-value user 'datetime-created) (datetime-created read-user) + (slot-value user 'datetime-modified) (datetime-modified read-user))) + t) + nil)) + +(defun umlisp-user-verify-passwd (user passwd) + (when user + (string-equal passwd (passwd user)))) + +(defun umlisp-user-set-srl (email srl) + (when (and (integerp srl) (find-umlisp-user-email email)) + (mutex-sql-execute + (format nil "update UMLISP_USERS set SRL=~d,DATETIME_MODIFIED=NOW() where EMAIL='~a'" srl email)) + srl)) + +(defun make-ustats () + (with-sql-connection (conn) + (sql-execute "drop table if exists USTATS" conn) + (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn) + + (dotimes (srl 4) + (insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl) + (insert-ustats-count conn "Term Count" "MRCON" "distinct KCUILUI" "KCUILRL" srl) + (insert-ustats-count conn "Distinct Term Count" "MRCON" "distinct LUI" "KLUILRL" srl) + (insert-ustats-count conn "String Count" "MRCON" "*" "LRL" srl) + (insert-ustats-count conn "Distinct String Count" "MRCON" "distinct SUI" "LRL" srl) + (insert-ustats-count conn "Associated Expression Count" "MRATX" "*" "KSRL" srl) + (insert-ustats-count conn "Context Count" "MRCXT" "*" "KSRL" srl) + (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl) + (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl) + (insert-ustats-count conn "Locator Count" "MRLO" "*" "KLRL" srl) + (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl) + (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl) + (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl) + (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl) + (insert-ustats-count conn "Source Count" "MRSO" "*" "SRL" srl) + (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl) + (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl) + (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl) + (insert-ustats-count conn "Bonus Attribute Name Count" "BONUS_ATN" "*" nil srl) + (insert-ustats-count conn "Bonus Relationship Count" "BONUS_REL" "*" nil srl) + (insert-ustats-count conn "Bonus Source Abbreviation Count" "BONUS_SAB" "*" nil srl) + (insert-ustats-count conn "Bonus Term Type Count" "BONUS_TTY" "*" nil srl)) + (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn)) + (find-ustats-all)) + +(defun insert-ustats-count (conn name table count-variable srl-control srl) + (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl)) + +(defun find-count-table (conn table srl count-variable srl-control) + (cond + ((stringp srl-control) + (ensure-integer + (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d" + count-variable table srl-control srl) + conn)))) + ((null srl-control) + (ensure-integer + (caar (sql-query (format nil "select count(~a) from ~a" + count-variable table ) + conn)))) + (t + (error "Unknown srl-control") + 0))) + +(defun insert-ustats (conn name count srl) + (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)" + name count (if srl srl 3)) + conn)) + +(defun find-ustats-all (&key (srl *current-srl*)) + (let ((ustats '()) + (ls "select NAME,COUNT,SRL from USTATS")) + (when srl + (string-append ls (format nil " where SRL=~d" srl))) + (string-append ls " order by NAME asc") + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ustats :name (nth 0 tuple) + :hits (ensure-integer (nth 1 tuple)) + :srl (ensure-integer (nth 2 tuple))) + ustats)) + (nreverse ustats))) + +(defun find-ustats-srl (srl) + (let ((ustats '())) + (dolist (tuple (mutex-sql-query + (format nil "select NAME,COUNT from USTATS where SRL=~d order by NAME asc" srl))) + (push (make-instance 'ustats :name (nth 0 tuple) + :hits (ensure-integer (nth 1 tuple)) + :srl srl) + ustats)) + (nreverse ustats))) + +(defun make-usrl () + (with-sql-connection (conn) + (sql-execute "drop table if exists USRL" conn) + (sql-execute "create table USRL (sab varchar(80), srl integer)" conn) + (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc")) + (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)" + (car tuple) (ensure-integer (cadr tuple))) + conn))) + (find-usrl-all)) + +(defun find-usrl-all () + (let ((usrls '()) + (tuples (mutex-sql-query "select SAB,SRL from USRL order by SAB desc"))) + (dolist (tuple tuples) + (push (make-instance 'usrl :sab (nth 0 tuple) + :srl (ensure-integer (nth 1 tuple))) usrls)) + usrls)) ;; already reversed by sql + +(defun find-usrl_freq-all () + (let ((freqs '())) + (dolist (usrl (find-usrl-all)) + (let ((freq (ensure-integer + (caar (mutex-sql-query + (format nil "select count(*) from MRSO where SAB='~a'" + (sab usrl))))))) + (push (make-instance 'usrl_freq :usrl usrl :freq freq) freqs))) + (sort freqs #'> :key #'usrl_freq-freq))) + +(defun find-cui-max () + (let ((cui (caar (mutex-sql-query "select max(CUI) from MRCON")))) + (ensure-integer cui))) + +;;;; Cross table find functions + +(defun find-ucon-tui (tui &key (srl *current-srl*)) + "Find list of ucon for tui" + (when (stringp tui) + (setq tui (parse-tui tui))) + (let ((ucons '()) + (ls (format nil "select CUI from MRSTY where TUI=~d" tui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons)) + ucons)) + +(defun find-ucon-word (word &key (srl *current-srl*) (like nil)) + "Return list of ucons that match word. Optionally, use SQL's LIKE syntax" + (let ((ucons '()) + (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'" + (if like " LIKE " "=") + word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ucon-cui (car tuple) :srl srl) ucons)) + ucons)) + +(defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil)) + "Return list of ucons that match word, optionally use SQL's LIKE syntax" + (let ((ucons '()) + (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'" + (if like " LIKE " "=") + word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ucon-cui (car tuple) :srl srl) ucons)) + ucons)) + +(defun find-ustr-word (word &key (srl *current-srl*)) + "Return list of ustrs that match word" + (let ((ustrs '()) + (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc,sui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) + ustrs)) + ustrs)) + +(defun find-ustr-normalized-word (word &key (srl *current-srl*)) + "Return list of ustrs that match word" + (let ((ustrs '()) + (ls (format nil "select cui,sui from MRXNW_ENG where nwd='~a'" word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc,sui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) + ustrs)) + ustrs)) + + +;;; Multiword lookup and score functions + +(defun find-ucon-multiword (str &key (srl *current-srl*)) + "Return sorted list of ucon's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ucons '())) + (dolist (word words) + (setq ucons (append ucons (find-ucon-word word :srl srl)))) + (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui)))) + +(defun find-ucon-normalized-multiword (str &key (srl *current-srl*)) + "Return sorted list of ucon's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ucons '()) + (nwords '())) + (dolist (word words) + (let ((nws (lvg:process-terms word))) + (dolist (nword nws) + (push nword nwords)))) + (dolist (word nwords) + (setq ucons (append ucons (find-ucon-word word :srl srl)))) + (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui)))) + +(defun find-ustr-multiword (str &key (srl *current-srl*)) + "Return sorted list of ustr's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ustrs '())) + (dolist (word words) + (setq ustrs (append ustrs (find-ustr-word word :srl srl)))) + (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui)))) + +(defun find-ustr-normalized-multiword (str &key (srl *current-srl*)) + "Return sorted list of ustr's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ustrs '()) + (nwords '())) + (dolist (word words) + (let ((nws (lvg:process-terms word))) + (dolist (nword nws) + (push nword nwords)))) + (dolist (word nwords) + (setq ustrs (append ustrs (find-ustr-word word :srl srl)))) + (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'ustr-cui)))) + +(defun a (str) + (find-normalized-matches-for-str str #'find-ustr-normalized-word #'ustr-sui)) + +(defun find-normalized-matches-for-str (str lookup-func key-func) + "Return list of objects that normalize match for words in string, +eliminate duplicates." + (let ((objs '()) + (nwords '())) + (dolist (word (delimited-string-to-list str #\space)) + (dolist (nword (lvg:process-terms word)) + (unless (member nword nwords :test #'string-equal) + (push nword nwords)))) + (dolist (nw nwords) + (setq objs (append objs (funcall lookup-func nw)))) + (delete-duplicates objs :key key-func :test #'eql))) + +(defun sort-score-ucon-str (str ucons) + "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" + (sort-score-umlsclass-str ucons str #'pfstr)) + +(defun sort-score-ustr-str (str ustrs) + "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" + (sort-score-umlsclass-str ustrs str #'str)) + +(defun sort-score-umlsclass-str (objs str lookup-func) + "Sort a list of objects based on scoring to a string" + (let ((scored '())) + (dolist (obj objs) + (push + (list obj + (score-multiword-match str (funcall lookup-func obj))) + scored)) + (mapcar #'car (sort scored #'> :key #'cadr)))) + +(defun score-multiword-match (s1 s2) + "Score a match between two strings with s1 being reference string" + (let* ((word-list-1 (delimited-string-to-list s1 #\space)) + (word-list-2 (delimited-string-to-list s2 #\space)) + (n1 (length word-list-1)) + (n2 (length word-list-2)) + (unmatched n1) + (score 0) + (nlong 0) + (nshort 0) + short-list long-list) + (declare (fixnum n1 n2 nshort nlong score unmatched)) + (if (> n1 n2) + (progn + (setq nlong n1) + (setq nshort n2) + (setq long-list word-list-1) + (setq short-list word-list-2)) + (progn + (setq nlong n2) + (setq nshort n1) + (setq long-list word-list-2) + (setq short-list word-list-1))) + (decf score (- nlong nshort)) ;; reduce score for extra words + (dotimes (iword nshort) + (declare (fixnum iword)) + (gu:aif (position (nth iword short-list) long-list :test #'string-equal) + (progn + (incf score (- 10 (abs (- gu::it iword)))) + (decf unmatched)))) + (decf score (* 2 unmatched)) + score)) + + +;;; LEX SQL functions + +(defun find-lexterm-eui (eui) + (gu:awhen (car (mutex-sql-query + (format nil "select WRD from LRWD where EUI=~d" eui))) + (make-instance 'lexterm :eui eui :wrd (nth 0 gu:it)))) + +(defun find-lexterm-word (wrd) + (gu:awhen (mutex-sql-query + (format nil "select EUI from LRWD where WRD='~a'" wrd)) + (let ((terms '())) + (dolist (tuple gu:it) + (let ((eui (ensure-integer (nth 0 tuple)))) + (push + (make-instance 'lexterm :eui eui :wrd (copy-seq wrd)) + terms))) + (nreverse terms)))) + +;; LEXTERM accessors, read on demand + +(def-lazy-reader lexterm s#abr find-labr-eui eui) +(def-lazy-reader lexterm s#agr find-lagr-eui eui) +(def-lazy-reader lexterm s#cmp find-lcmp-eui eui) +(def-lazy-reader lexterm s#mod find-lmod-eui eui) +(def-lazy-reader lexterm s#nom find-lnom-eui eui) +(def-lazy-reader lexterm s#prn find-lprn-eui eui) +(def-lazy-reader lexterm s#prp find-lprp-eui eui) +(def-lazy-reader lexterm s#spl find-lspl-eui eui) +(def-lazy-reader lexterm s#trm find-ltrm-eui eui) +(def-lazy-reader lexterm s#typ find-ltyp-eui eui) + +;; LEX SQL Read functions + +(defun find-labr-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'labr :eui eui + :bas (nth 0 tuple) + :abr (nth 1 tuple) + :eui2 (ensure-integer (nth 2 tuple)) + :bas2 (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-labr-bas (bas) + (gu:awhen (mutex-sql-query + (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" bas)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'labr :eui (ensure-integer (nth 0 tuple)) + :bas (copy-seq bas) + :abr (nth 1 tuple) + :eui2 (ensure-integer (nth 2 tuple)) + :bas2 (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-lagr-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lagr + :eui eui + :str (nth 0 tuple) + :sca (nth 1 tuple) + :agr (nth 2 tuple) + :cit (nth 3 tuple) + :bas (nth 4 tuple)) + results)) + (nreverse results)))) + +(defun find-lcmp-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lcmp + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :com (nth 2 tuple)) + results)) + (nreverse results)))) + +(defun find-lmod-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lmod + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :psnmod (nth 2 tuple) + :fea (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-lnom-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lnom + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :eui2 (ensure-integer (nth 2 tuple)) + :bas2 (nth 3 tuple) + :sca2 (nth 4 tuple)) + results)) + (nreverse results)))) + +(defun find-lprn-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lprn + :eui eui + :bas (nth 0 tuple) + :num (nth 1 tuple) + :gnd (nth 2 tuple) + :cas (nth 3 tuple) + :pos (nth 4 tuple) + :qnt (nth 5 tuple) + :fea (nth 6 tuple)) + results)) + (nreverse results)))) + +(defun find-lprp-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lprp + :eui eui + :bas (nth 0 tuple) + :str (nth 1 tuple) + :sca (nth 2 tuple) + :fea (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-lspl-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select SPV,BAS from LRSPL where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lspl + :eui eui + :spv (nth 0 tuple) + :bas (nth 1 tuple)) + results)) + (nreverse results)))) + + +(defun find-ltrm-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,GEN from LRTRM where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'ltrm + :eui eui + :bas (nth 0 tuple) + :gen (nth 1 tuple)) + results)) + (nreverse results)))) + +(defun find-ltyp-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'ltyp + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :typ (nth 2 tuple)) + results)) + (nreverse results)))) + +(defun find-lwd-wrd (wrd) + (gu:awhen (mutex-sql-query + (format nil "select EUI from LRWD where WRD='~a'" wrd)) + (let ((results '())) + (dolist (tuple gu::it) + (push (ensure-integer (nth 0 tuple)) results)) + (make-instance 'lwd :wrd wrd + :euilist (nreverse results))))) + +;;; Semantic Network SQL access functions + +(defun find-sdef-ui (ui) + (gu:awhen (car (mutex-sql-query + (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui))) + (make-instance 'sdef :rt (nth 0 gu::it) + :ui ui + :styrl (nth 1 gu::it) + :stnrtn (nth 2 gu::it) + :def (nth 3 gu::it) + :ex (nth 4 gu::it) + :un (nth 5 gu::it) + :rh (nth 6 gu::it) + :abr (nth 7 gu::it) + :rin (nth 8 gu::it)))) + +(defun find-sstre1-ui (ui) + (gu:awhen (mutex-sql-query + (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstre1 :ui ui + :ui2 (ensure-integer (nth 0 tuple)) + :ui3 (ensure-integer (nth 1 tuple))) + results)) + (nreverse results)))) + +(defun find-sstre1-ui2 (ui2) + (gu:awhen (mutex-sql-query + (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstre1 :ui (ensure-integer (nth 0 tuple)) + :ui2 ui2 + :ui3 (ensure-integer (nth 1 tuple))) + results)) + (nreverse results)))) + +(defun find-sstr-rl (rl) + (gu:awhen (mutex-sql-query + (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstr + :rl rl + :styrl (nth 0 tuple) + :styrl2 (nth 1 tuple) + :ls (nth 2 tuple)) + results)) + (nreverse results)))) + + +(defun find-sstre2-sty (sty) + (gu:awhen (mutex-sql-query + (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstre2 + :sty (copy-seq sty) + :rl (nth 0 tuple) + :sty2 (nth 1 tuple)) + results)) + (nreverse results)))) + +(defun find-sstr-styrl (styrl) + (gu:awhen (mutex-sql-query + (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstr :styrl styrl + :rl (nth 0 tuple) + :styrl2 (nth 1 tuple) + :ls (nth 2 tuple)) + results)) + (nreverse results)))) + + diff --git a/obj.lisp b/obj.lisp new file mode 100644 index 0000000..f52a2b6 --- /dev/null +++ b/obj.lisp @@ -0,0 +1,624 @@ +;;; $Id: obj.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ +;;; +;;; UMLS object defintions and printing routines + +(in-package :umlisp) +(declaim (optimize (speed 3) (safety 1))) + +(defclass umlsclass () + () + (:metaclass ml-class) + (:documentation "Parent class of all UMLS objects")) + + +(defmethod print-object ((obj umlsclass) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (let ((fmt (make-instance 'gu.ml::textformat))) + (apply #'format + s (funcall (gu.ml::obj-data-fmtstr fmt) obj) + (multiple-value-list + (funcall (funcall (gu.ml::obj-data-value-func fmt) obj) obj)))))) + + +(defclass umlisp-user (umlsclass) + ((id :type fixnum :initarg :id :reader id) + (first-name :type string :initarg :first-name :reader first-name) + (last-name :type string :initarg :last-name :reader last-name) + (organization :type string :initarg :organization :reader organization) + (address1 :type string :initarg :address1 :reader address1) + (address2 :type string :initarg :address2 :reader address2) + (city :type string :initarg :city :reader city) + (state :type string :initarg :state :reader state) + (zip :type string :initarg :zip :reader zip) + (country :type string :initarg :country :reader country) + (licensed :type boolean :initarg :licensed :reader licensed) + (occupation :type string :initarg :occupation :reader occupation) + (email :type string :initarg :email :reader email) + (passwd :type string :initarg :passwd :reader passwd) + (srl :type fixnum :initarg :srl :reader srl) + (timeout :type fixnum :initarg :timeout :reader timeout) + (maillist :type boolean :initarg :maillist :reader maillist) + (datetime-created :type string :initarg :datetime-created + :reader datetime-created) + (datetime-modified :type string :initarg :datetime-modified + :reader datetime-modified)) + (:default-initargs + :id nil :first-name nil :last-name nil :email nil :passwd nil :srl nil + :organization nil :address1 nil :address2 nil :city nil :state nil + :zip nil :country nil :licensed nil :occupation nil :maillist nil + :timeout nil :datetime-created nil :datetime-modified nil) + (:metaclass ml-class) + (:title "UMLisp User") + (:fields + (id :fixnum) (first-name :string) (last-name :string) (email :string) + (occupation :string) (organization :string) (address1 :string) + (address2 :string) (city :string) (state :string) (zip :string) + (country :string) (licensed :boolean) (maillist :boolean) (srl :fixnum) + (timeout :fixnum) (datetime-created :string) (datetime-modified :string)) + (:documentation "Class for UMLisp user database")) + +(defclass ustats (umlsclass) + ((name :type string :initarg :name :reader name) + (hits :type integer :initarg :hits :reader hits) + (srl :type fixnum :initarg :srl :reader srl)) + (:metaclass ml-class) + (:default-initargs :name nil :hits nil :srl nil) + (:title "UMLS Statistic") + (:fields (name :string) (hits :commainteger) (srl :fixnum)) + (:documentation "Custom Table: UMLS Database statistics.")) + +(defclass usrl (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (srl :type integer :initarg :srl :reader srl)) + (:metaclass ml-class) + (:default-initargs :sab nil :srl nil) + (:title "Source Restriction Level") + (:fields (sab :string) (srl :fixnum)) + (:documentation "Custom Table: Source Restriction Level")) + +(defclass bsab (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (name :type string :initarg :name :reader name) + (hits :type fixnum :initarg :hits :reader hits)) + (:metaclass ml-class) + (:default-initargs :sab nil :name nil :hits nil) + (:title "Source of Abbreviation") + (:fields (sab :string) (name :string) (hits :commainteger)) + (:ref-fields (sab find-ustr-sab (("subobjects" "no")))) + (:documentation "Bonus SAB file")) + +(defclass btty (umlsclass) + ((tty :type string :initarg :tty :reader tty) + (name :type string :initarg :name :reader name)) + (:metaclass ml-class) + (:default-initargs :tty nil :name nil) + (:title "Bonus TTY") + (:fields (tty :string) (name :fixnum)) + (:documentation "Bonus TTY file")) + +(defclass brel (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (sl :type string :initarg :sl :reader sl) + (rel :type string :initarg :rel :reader rel) + (rela :type string :initarg :rela :reader rela) + (hits :type fixnum :initarg :hits :reader hits)) + (:metaclass ml-class) + (:default-initargs :sab nil :sl nil :rel nil :rela nil :hits nil) + (:title "Bonus REL") + (:fields + (sab :string) (sl :string) (rel :string) (rela :string) (hits :commainteger)) + (:documentation "Bonus REL file")) + +(defclass batn (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (atn :type string :initarg :atn :reader atn) + (hits :type fixnum :initarg :hits :reader hits)) + (:metaclass ml-class) + (:default-initargs :sab nil :atn nil) + (:title "Bonus ATN") + (:fields (sab :string) (atn :string) (hits :commaninteger)) + (:documentation "Bonus ATN file")) + +(defclass urank (umlsclass) + ((rank :type fixnum :initarg :rank :reader rank) + (sab :type string :initarg :sab :reader sab) + (tty :type string :initarg :tty :reader tty) + (supres :type string :initarg :supres :reader supres)) + (:metaclass ml-class) + (:default-initargs :rank nil :sab nil :tty nil :supres nil) + (:title "Rank") + (:fields (rank :fixnum) (sab :string) (tty :string) (supres :string))) + +(defclass udef (umlsclass) + ((def :type string :initarg :def :reader def) + (sab :type string :initarg :sab :reader sab)) + (:metaclass ml-class) + (:default-initargs :def nil :sab nil) + (:title "Definition") + (:ref-fields (sab find-bsab-sab)) + (:fields (sab :string) (def :cdata))) + +(defclass usat (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (code :type string :initarg :code :reader code) + (atn :type string :initarg :atn :reader atn) + (atv :type string :initarg :atv :reader atv)) + (:metaclass ml-class) + (:default-initargs :sab nil :code nil :atn nil :atv nil) + (:title "Simple Attribute") + (:ref-fields (sab find-bsab-sab)) + (:fields (sab :string) (code :string) (atn :string) (atv :cdata))) + +(defclass uso (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (code :type string :initarg :code :reader code) + (tty :type string :initarg :tty :reader tty) + (srl :type fixnum :initarg :srl :reader srl)) + (:metaclass ml-class) + (:default-initargs :sab nil :code nil :tty nil :srl nil) + (:title "Source") + (:ref-fields (sab find-bsab-sab) (tty find-btty-tty)) + (:fields (sab :string) (code :string) (tty :string) (srl :fixnum))) + +(defclass ucxt (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (code :type string :initarg :code :reader code) + (rnk :type fixnum :initarg :rnk :reader rnk) + (cxn :type fixnum :initarg :cxn :reader cxn) + (cxl :type string :initarg :cxl :reader cxl) + (cxs :type string :initarg :cxs :reader cxs) + (cui2 :type fixnum :initarg :cui2 :reader cui2) + (hcd :type string :initarg :hcd :reader hcd) + (rela :type string :initarg :rela :reader rela) + (xc :type string :initarg :xc :reader xc)) + (:metaclass ml-class) + (:default-initargs :sab nil :code nil :rnk nil :cxn nil :cxl nil :cxs nil + :cui2 nil :hcd nil :rela nil :xc nil) + (:title "Context") + (:ref-fields (sab find-bsab-sab) (cui2 find-ucon-cui)) + (:fields + (sab :string) (code :string) (rnk :fixnum) (cxn :fixnum) (cxl :string) + (hcd :string) (rela :string) (xc :string) (cui2 :string fmt-cui) + (cxs :cdata))) + +(defclass ustr (umlsclass) + ((sui :type fixnum :initarg :sui :reader sui) + (cui :type fixnum :initarg :cui :reader cui) + (lui :type fixnum :initarg :lui :reader lui) + (cuisui :type integer :initarg :cuisui :reader cuisui ) + (str :type string :initarg :str :reader str) + (lrl :type fixnum :initarg :lrl :reader lrl) + (stt :type string :initarg :stt :reader stt) + (s#sat :reader s#sat) + (s#so :reader s#so) + (s#cxt :reader s#cxt)) + (:metaclass ml-class) + (:default-initargs + :sui nil :cui nil :lui nil :cuisui nil :str nil :lrl nil :stt nil) + (:title "String") + (:subobjects-lists (s#sat usat) (s#so uso) (s#cxt ucxt)) + (:fields (sui :string fmt-sui) (stt :string) (lrl :fixnum) (str :cdata)) + (:ref-fields (sui find-ustr-sui))) + +(defclass ulo (umlsclass) + ((isn :type string :initarg :isn :reader isn) + (fr :type fixnum :initarg :fr :reader fr) + (un :type string :initarg :un :reader un) + (sui :type fixnum :initarg :sui :reader sui) + (sna :type string :initarg :sna :reader sna) + (soui :type string :initarg :soui :reader soui)) + (:metaclass ml-class) + (:default-initargs :isn nil :fr nil :un nil :sui nil :sna nil :soui nil) + (:title "Locator") + (:fields (isn :string) (fr :fixnum) (un :string) (sna :string) + (soui :string) (sui :string fmt-sui) (suistr :string))) + +(defclass uterm (umlsclass) + ((lui :type fixnum :initarg :lui :reader lui) + (cui :type fixnum :initarg :cui :reader cui) + (lat :type string :initarg :lat :reader lat) + (ts :type string :initarg :ts :reader ts) + (lrl :type fixnum :initarg :lrl :reader lrl) + (s#str :reader s#str) + (s#sat :reader s#sat)) + (:metaclass ml-class) + (:default-initargs :lui nil :cui nil :lat nil :ts nil :lrl nil) + (:title "Term") + (:subobjects-lists (s#sat usat) (s#str ustr)) + (:fields (lui :string fmt-lui) (lat :string) (ts :string) (lrl :fixnum)) + (:ref-fields (lui find-uterm-lui))) + +(defclass usty (umlsclass) + ((tui :type fixnum :initarg :tui :reader tui) + (sty :type string :initarg :sty :reader sty)) + (:metaclass ml-class) + (:default-initargs :tui nil :sty nil) + (:title "Semantic Type") + (:ref-fields (tui find-ucon-tui (("subobjects" "no")))) + (:fields (tui :string fmt-tui) (sty :string))) + +(defclass urel (umlsclass) + ((rel :type string :initarg :rel :reader rel) + (cui1 :type fixnum :initarg :cui1 :reader cui1) + (cui2 :type fixnum :initarg :cui2 :reader cui2) + (pfstr2 :type string :initarg :pfstr2 :reader pfstr2) + (rela :type string :initarg :rela :reader rela) + (sab :type string :initarg :sab :reader sab) + (sl :type string :initarg :sl :reader sl) + (mg :type string :initarg :mg :reader mg)) + (:metaclass ml-class) + (:default-initargs + :rel nil :cui1 nil :cui2 nil :pfstr2 nil :rela nil :sab nil :sl nil :mg nil) + (:title "Relationship") + (:ref-fields (rel find-brel-rel) (sab find-bsab-sab) (cui2 find-ucon-cui)) + (:fields (rel :string) (rela :string) (sab :string) (sl :string) + (mg :string) (cui2 :string fmt-cui) (pfstr2 :cdata))) + +(defclass ucoc (umlsclass) + ((cui1 :type fixnum :initarg :cui1 :reader cui1) + (cui2 :type fixnum :initarg :cui2 :reader cui2) + (pfstr2 :type string :initarg :pfstr2 :reader pfstr2) + (soc :type string :initarg :soc :reader soc) + (cot :type string :initarg :cot :reader cot) + (cof :type fixnum :initarg :cof :reader cof) + (coa :type string :initarg :coa :reader coa)) + (:metaclass ml-class) + (:default-initargs + :cui1 nil :cui2 nil :pfstr2 nil :soc nil :cot nil :cof nil :coa nil) + (:title "Co-occuring Concept") + (:ref-fields (cui2 find-ucon-cui)) + (:fields (soc :string) (cot :string) (cof :fixnum) (coa :cdata) + (cui2 :string fmt-cui) (pfstr2 :cdata))) + + +(defclass uatx (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (rel :type string :initarg :rel :reader rel) + (atx :type string :initarg :atx :reader atx)) + (:metaclass ml-class) + (:default-initargs :sab nil :rel nil :atx nil) + (:title "Associated Expression") + (:fields (sab :string) (rel :string) (atx :cdata))) + +(defclass ucon (umlsclass) + ((cui :type fixnum :initarg :cui :reader cui ) + (pfstr :initarg :pfstr :reader pfstr) + (lrl :initarg :lrl :reader lrl) + (s#term :reader s#term) + (s#def :reader s#def) + (s#lo :reader s#lo) + (s#rel :reader s#rel) + (s#coc :reader s#coc) + (s#sat :reader s#sat) + (s#atx :reader s#atx) + (s#sty :reader s#sty)) + (:metaclass ml-class) + (:default-initargs :cui nil :pfstr nil :lrl nil) + (:title "Concept") + (:subobjects-lists + (s#def udef) (s#sty usty) (s#lo ulo) (s#atx uatx) (s#sat usat) (s#rel urel) + (s#coc ucoc) (s#term uterm)) + (:fields (cui :string fmt-cui) (lrl :fixum) (pfstr :cdata)) + (:ref-fields (cui find-ucon-cui))) + +(defclass uxw (umlsclass) + ((wd :type string :initarg :wd :reader wd) + (cui :type fixnum :initform nil :initarg :cui :reader cui) + (lui :type fixnum :initform nil :initarg :lui :reader lui) + (sui :type fixnum :initform nil :initarg :sui :reader sui)) + (:metaclass ml-class) + (:default-initargs :wd nil :cui nil :lui nil :sui nil) + (:title "XW Index") + (:fields (wd :string) (cui :string fmt-cui) (lui :string fmt-lui) + (sui :string fmt-sui))) + +(defclass uxnw (umlsclass) + ((lat :type string :initarg :lat :reader lat) + (nwd :type string :initarg :nwd :reader nwd) + (cuilist :type list :initarg :cuilist :reader uxnw-cuilist)) + (:metaclass ml-class) + (:default-initargs :lat nil :nwd nil :cuilist nil) + (:title "XNW Index") + (:fields (lat :string) (nwd :string) (cuilist :string))) + +(defclass uxns (umlsclass) + ((lat :type string :initarg :lat :reader lat) + (nstr :type string :initarg :nstr :reader nstr) + (cuilist :type list :initarg :cuilist :reader cuilist)) + (:metaclass ml-class) + (:default-initargs :lat nil :nstr nil :cuilist nil) + (:title "XNS Index") + (:fields (lat :string) (nstr :string) (cuilist :string))) + + +;;; LEX objects + +(defclass lexterm (umlsclass) + ((eui :type fixnum :initarg :eui :reader eui) + (wrd :type string :initarg :wrd :reader wrd) + (s#abr :reader s#abr) + (s#agr :reader s#agr) + (s#cmp :reader s#cmp) + (s#mod :reader s#mod) + (s#nom :reader s#nom) + (s#prn :reader s#prn) + (s#prp :reader s#prp) + (s#spl :reader s#spl) + (s#trm :reader s#trm) + (s#typ :reader s#typ)) + (:metaclass ml-class) + (:default-initargs :eui nil :wrd nil) + (:title "Lexical Term") + (:subobjects-lists + (s#abr labr) (s#agr lagr) (s#cmp lcmp) (s#mod lmod) (s#nom unom) + (s#prn lprn) (s#prp lprp) (s#spl lspl) (s#trm ltrm) (s#typ ltyp)) + (:fields (eui :string fmt-eui) (wrd :string)) + (:ref-fields (eui find-lexterm-eui))) + + +(defclass labr (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (abr :type string :initarg :abr :reader abr) + (eui2 :type integer :initarg :eui2 :reader eui2) + (bas2 :type string :initarg :bas2 :reader bas2)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :abr nil :eui2 nil :bas2 nil) + (:title "Abbreviations and Acronyms") + (:fields (eui :string fmt-eui) (bas :string) (abr :string) + (eui2 :string fmt-eui) (bas2 :string ))) + +(defclass lagr (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (str :type string :initarg :str :reader str) + (sca :type string :initarg :sca :reader sca) + (agr :type string :initarg :agr :reader agr) + (cit :type string :initarg :cit :reader cit) + (bas :type string :initarg :bas :reader bas)) + (:metaclass ml-class) + (:default-initargs :eui nil :str nil :sca nil :agr nil :cit nil :bas nil) + (:title "Agreement and Inflection") + (:fields (eui :string fmt-eui) (str :string) (sca :string) (agr :string) + (cit :string) (bas :string))) + +(defclass lcmp (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (com :type string :initarg :com :reader com)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :com nil) + (:title "Complementation") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) (com :string))) + +(defclass lmod (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (psnmod :type string :initarg :psnmod :reader psnmod) + (fea :type string :initarg :fea :reader fea)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :psnmod nil :fea nil) + (:title "Modifiers") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) (psnmod :string) + (fea :string))) + +(defclass lnom (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (eui2 :type integer :initarg :eui2 :reader eui2) + (bas2 :type string :initarg :bas2 :reader bas2) + (sca2 :type string :initarg :sca2 :reader sca2)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :eui2 nil :bas2 nil :sca2 nil) + (:title "Nominalizations") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) + (eui2 :string fmt-eui) (bas2 :string) (sca2 :string))) + +(defclass lprn (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (num :type string :initarg :num :reader num) + (gnd :type string :initarg :gnd :reader gnd) + (cas :type string :initarg :cas :reader cas) + (pos :type string :initarg :pos :reader pos) + (qnt :type string :initarg :qnt :reader qnt) + (fea :type string :initarg :fea :reader fea)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :num nil :gnd nil :cas nil + :pos nil :qnt nil :fea nil) + (:title "Pronouns") + (:fields (eui :string fmt-eui) (bas :string) (num :string) (gnd :string) + (cas :string) (pos :string) (qnt :string) (fea :string))) + +(defclass lprp (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (str :type string :initarg :str :reader str) + (sca :type string :initarg :sca :reader sca) + (fea :type string :initarg :fea :reader fea)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :str nil :sca nil :fea nil) + (:title "Properties") + (:fields (eui :string fmt-eui) (bas :string) (str :string) (sca :string) + (fea :string))) + + +(defclass lspl (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (spv :type string :initarg :spv :reader spv) + (bas :type string :initarg :bas :reader bas)) + (:metaclass ml-class) + (:default-initargs :eui nil :spv nil :bas nil) + (:title "Spelling Variants") + (:fields (eui :string fmt-eui) (spv :string) (bas :string))) + + + +(defclass ltrm (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (gen :type string :initarg :gen :reader gen)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :gen nil) + (:title "Trade Marks") + (:fields (eui :string fmt-eui) (bas :string) (gen :string))) + +(defclass ltyp (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (typ :type string :initarg :typ :reader typ)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :typ nil) + (:title "Inflection Type") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) (typ :string))) + +(defclass lwd (umlsclass) + ((wrd :type string :initarg :wrd :reader wrd) + (euilist :type list :initarg :euilist :reader euilist)) + (:metaclass ml-class) + (:default-initargs :wrd nil :euilist nil) + (:title "Lexical Word Index") + (:fields (wrd :string) (euilist :string))) + +;;; Semantic NET objects + +(defclass sdef (umlsclass) + ((rt :type string :initarg :rt :reader rt) + (ui :type integer :initarg :ui :reader ui) + (styrl :type string :initarg :styrl :reader styrl) + (stnrtn :type string :initarg :stnrtn :reader stnrtn) + (def :type string :initarg :def :reader def) + (ex :type string :initarg :ex :reader ex) + (un :type string :initarg :un :reader un) + (rh :type string :initarg :rh :reader rh) + (abr :type string :initarg :abr :reader abr) + (rin :type string :initarg :rin :reader rin)) + (:metaclass ml-class) + (:default-initargs + :rt nil :ui nil :styrl nil :stnrtn nil :def nil :ex nil :un nil :rh nil + :abr nil :rin nil) + (:title "Basic information about Semantic Types and Relations") + (:fields + (rt :string) (ui :string fmt-tui) (styrl :string) (stnrtn :string-tui) + (def :string) (ex :string) (un :string) (rh :string) (abr :string) + (rin :string))) + +(defclass sstr (umlsclass) + ((styrl :type string :initarg :styrl :reader styrl) + (rl :type string :initarg :rl :reader rl) + (styrl2 :type string :initarg :styrl2 :reader styrl2) + (ls :type string :initarg :ls :reader ls)) + (:metaclass ml-class) + (:default-initargs :styrl nil :rl nil :styrl2 nil :ls nil) + (:title "Structure of the Network") + (:fields (styrl :string) (rl :string) (styrl2 :string) (ls :string))) + +(defclass sstre1 (umlsclass) + ((ui :type integer :initarg :ui :reader ui) + (ui2 :type integer :initarg :ui2 :reader ui2) + (ui3 :type integer :initarg :ui3 :reader ui3)) + (:metaclass ml-class) + (:default-initargs :ui nil :ui2 nil :ui3 nil) + (:title "Fully Inherited Set of Releatons (TUI's)") + (:fields (ui :string fmt-tui) (ui2 :string fmt-tui) (ui3 :string fmt-tui))) + +(defclass sstre2 (umlsclass) + ((sty :type string :initarg :ui :reader sty) + (rl :type string :initarg :ui2 :reader rl) + (sty2 :type string :initarg :ui3 :reader sty2)) + (:metaclass ml-class) + (:default-initargs :sty nil :rl nil :sty2 nil) + (:title "Fully Inherited Set of Releatons (strings)") + (:fields (sty :string) (rl :string) (sty2 :string))) + +;;; Formatting routines + +(defmethod fmt-cui ((c ucon)) + (format nil "C~7,'0d" (cui c))) + +(defmethod fmt-cui ((c fixnum)) + (format nil "C~7,'0d" c)) + +(defmethod fmt-cui ((c string)) + (if (eql (aref c 0) #\C) + c + (format nil "C~7,'0d" (parse-integer c)))) + +(defmethod fmt-cui ((c null)) + (format nil "nil")) + +(defmethod fmt-lui ((l uterm)) + (format nil "L~7,'0d" (lui l))) + +(defmethod fmt-lui ((l fixnum)) + (format nil "L~7,'0d" l)) + +(defmethod fmt-lui ((l string)) + (if (eql (aref l 0) #\L) + l + (format nil "L~7,'0d" (parse-integer l)))) + +(defmethod fmt-sui ((s ustr)) + (format nil "S~7,'0d" (sui s))) + +(defmethod fmt-sui ((s fixnum)) + (format nil "S~7,'0d" s)) + +(defmethod fmt-sui ((s string)) + (if (eql (aref s 0) #\S) + s + (format nil "S~7,'0d" (parse-integer s)))) + +(defmethod fmt-tui ((s fixnum)) + (format nil "T~3,'0d" s)) + +(defmethod fmt-tui ((s string)) + (if (eql (aref s 0) #\T) + s + (format nil "T~3,'0d" (parse-integer s)))) + +(defmethod fmt-eui ((e fixnum)) + (format nil "E~7,'0d" e)) + +(defmethod fmt-eui ((e string)) + (if (eql (aref e 0) #\E) + e + (format nil "E~7,'0d" (parse-integer e)))) + +(defmethod fmt-eui ((e null)) + (format nil "nil")) + +;;; Generic display functions + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun english-term-p (obj) + (and (eq (class-name (class-of obj)) 'uterm) + (string-equal (lat obj) "ENG")))) + +(defun display-umls-obj + (obj &key (os *standard-output*) (format :text) (label nil) + (file-wrapper t) (english-only nil) (subobjects nil) + (refvars nil)) + (display-ml-class + obj :os os :format format :label label :subobjects subobjects + :file-wrapper file-wrapper + :english-only-function (if english-only #'english-term-p nil) + :refvars refvars)) + +(defmacro defludisp-ml-class (newfuncname lookup-func) + "Defines functions for looking up and displaying objects" + `(defun ,newfuncname + (keyval &key (os *standard-output*) (format :text) (label nil) + (file-wrapper t) (english-only nil) (subobjects nil)) + (let ((obj (funcall ,lookup-func keyval))) + (display-umls-obj obj :os os :format format :label label + :file-wrapper file-wrapper :english-only english-only + :subobjects subobjects)))) + +(defludisp-ml-class disp-con #'find-ucon-cui) +(defludisp-ml-class disp-term #'find-uterm-lui) +(defludisp-ml-class disp-str #'find-ustr-sui) + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..3bc20c1 --- /dev/null +++ b/package.lisp @@ -0,0 +1,153 @@ +;;;; $Id: package.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ +;;;; +;;;; Package definition for UMLisp + +(in-package :cl-user) + +(defpackage umlisp + (:nicknames :u) + (:export + #:ucon + #:uterm + #:ustr + #:find-udef-cui + #:find-usty-cui + #:find-usty-word + #:find-urel-cui + #:find-urel-cui2 + #:find-ucon-rel-cui2 + #:find-ucoc-cui + #:find-ucoc-cui2 + #:find-ucon-coc-cui2 + #:find-ulo-cui + #:suistr + #:find-uatx-cui + #:display-umls-obj + #:find-ucon-cui + #:find-ucon-lui + #:find-ucon-sui + #:find-ucon-cuisui + #:find-ucon-str + #:find-ucon-all + #:find-uterm-cui + #:find-uterm-lui + #:find-uterm-cuilui + #:find-uterm-in-ucon + #:find-ustr-cuilui + #:find-ustr-cuisui + #:find-ustr-sui + #:find-ustr-sab + #:find-ustr-all + #:find-string-sui + #:find-uso-cuisui + #:find-ucxt-cuisui + #:find-usat-ui + #:find-bsab-sab + #:find-bsab-all + #:find-btty-tty + #:find-btty-all + #:find-brel-rel + #:find-pfstr-cui + #:find-ustr-in-uterm + #:find-usty-tui + #:find-usty-all + #:find-usty_freq-all + #:find-usrl-all + #:find-usrl_freq-all + #:find-cui-max + #:find-ucon-tui + #:find-ucon-word + #:find-ucon-normalized-word + #:find-ustr-word + #:find-ustr-normalized-word + #:find-ucon-multiword + #:find-ucon-normalized-multiword + #:find-ustr-multiword + #:find-ustr-normalized-multiword + #:find-lexterm-eui + #:find-lexterm-word + #:find-labr-eui + #:find-labr-bas + #:find-lagr-eui + #:find-lcmp-eui + #:find-lmod-eui + #:find-lnom-eui + #:find-lprn-eui + #:find-lprp-eui + #:find-lspl-eui + #:find-ltrm-eui + #:find-ltyp-eui + #:find-lwd-wrd + #:find-sdef-ui + #:find-sstre1-ui + #:find-sstre1-ui2 + #:find-sstr2-sty + #:find-sstr-rl + #:find-sstr-styrl + #:disp-con + #:disp-term + #:disp-str + + ;; composite.cl + #:tui-finding + #:tui-sign-or-symptom + #:tui-disease-or-syndrome + #:ucon-is-tui? + #:find-ucon2-tui + #:find-ucon2-coc-tui + #:find-ucon2-rel-tui + #:find-ucon2_freq-coc-tui + #:find-ucon2-str&sty + #:find-ucon2-coc-str&sty + #:find-ucon2-rel-str&sty + #:find-ucon2_freq-tui-all + #:find-ucon2_freq-rel-tui-all + #:find-ucon2_freq-coc-tui-all + #:ucon_freq + #:ustr_freq + #:usty_freq + #:usrl_freq + + #:umlisp-user + #:ustats + #:usrl + #:bsab + #:btty + #:brel + #:batn + #:urank + #:urel + #:usat + #:uso + #:ucxt + #:ustr + #:ulo + #:uterm + #:usty + #:urel + #:ucoc + #:uatx + #:ucon + #:uxw + #:uxnw + #:uxns + #:lexterm + #:labr + #:lagr + #:lcmp + #:lmod + #:lmod + #:lprn + #:prp + #:lspl + #:ltrm + #:ltyp + #:sdef + #:sstr + #:sstre1 + #:sstre2 + )) + + + + diff --git a/parse-2002.lisp b/parse-2002.lisp new file mode 100644 index 0000000..3d6728f --- /dev/null +++ b/parse-2002.lisp @@ -0,0 +1,433 @@ + ;;; UMLS-Parse +;;; Lisp Routines for parsing UMLS files +;;; and inserting into SQL databases +;;; +;;; Copyright (c) 2001 Kevin M. Rosenberg, M.D. +;;; $Id: parse-2002.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + +;;; Pre-read data for custom fields into hash tables +(defvar *parse-hash-init?* nil) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(let ((pfstr-hash nil) ;;; Preferred concept strings by CUI + (cui-lrl-hash nil) ;;; LRL by CUI + (lui-lrl-hash nil) ;;; LRL by LUI + (cuisui-lrl-hash nil) ;;; LRL by CUISUI + (sab-srl-hash nil)) ;;; SRL by SAB + + (defun make-parse-hash-table () + (if pfstr-hash + (progn + (clrhash pfstr-hash) + (clrhash cui-lrl-hash) + (clrhash lui-lrl-hash) + (clrhash cuisui-lrl-hash) + (clrhash sab-srl-hash)) + (setf + pfstr-hash (make-hash-table :size 800000) + cui-lrl-hash (make-hash-table :size 800000) + lui-lrl-hash (make-hash-table :size 1500000) + cuisui-lrl-hash (make-hash-table :size 1800000) + sab-srl-hash (make-hash-table :size 100 :test 'equal)))) + + (defun binit-hash-table (&optional (force-read nil)) + (when (or force-read (not *parse-hash-init?*)) + (make-parse-hash-table) + (setq *parse-hash-init?* t)) + (with-buffered-umls-file (line "MRCON") + (let ((cui (parse-ui (aref line 0))) + (lui (parse-ui (nth 3 line))) + (sui (parse-ui (nth 5 line))) + (lrl (parse-integer (nth 7 line)))) + (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui + (if (and (string-equal (aref line 1) "ENG") ; LAT + (string-equal (aref line 2) "P") ; ts + (string-equal (aref line 4) "PF")) ; stt + (setf (gethash cui pfstr-hash) (aref line 6)))) + (set-lrl-hash cui lrl cui-lrl-hash) + (set-lrl-hash lui lrl lui-lrl-hash) + (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash))) + (with-buffered-umls-file (line "MRSO") + (let ((sab (aref 3 line))) + (unless (gethash sab sab-srl-hash) ;; if haven't stored + (setf (gethash sab sab-srl-hash) (aref 6 line)))))) + + (defun init-hash-table (&optional (force-read nil)) + (when (or force-read (not *parse-hash-init?*)) + (make-parse-hash-table) + (setq *parse-hash-init?* t)) + (with-umls-file (line "MRCON") + (let ((cui (parse-ui (nth 0 line))) + (lui (parse-ui (nth 3 line))) + (sui (parse-ui (nth 5 line))) + (lrl (parse-integer (nth 7 line)))) + (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui + (if (and (string-equal (nth 1 line) "ENG") ; LAT + (string-equal (nth 2 line) "P") ; ts + (string-equal (nth 4 line) "PF")) ; stt + (setf (gethash cui pfstr-hash) (nth 6 line)))) + (set-lrl-hash cui lrl cui-lrl-hash) + (set-lrl-hash lui lrl lui-lrl-hash) + (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash))) + (with-umls-file (line "MRSO") + (let ((sab (nth 3 line))) + (multiple-value-bind (val found) (gethash sab sab-srl-hash) + (declare (ignore val)) + (unless found + (setf (gethash sab sab-srl-hash) (parse-integer (nth 6 line)))))))) + + (defun pfstr-hash (cui) + (gethash cui pfstr-hash)) + + (defun cui-lrl (cui) + (gethash cui cui-lrl-hash)) + + (defun lui-lrl (lui) + (gethash lui lui-lrl-hash)) + + (defun cuisui-lrl (cuisui) + (gethash cuisui cuisui-lrl-hash)) + + (defun sab-srl (sab) + (gu:aif (gethash sab sab-srl-hash) gu::it 0)) +)) ;; closure + +(defun set-lrl-hash (key lrl hash) + "Set the least restrictive level in hash table" + (multiple-value-bind (hash-lrl found) (gethash key hash) + (if (or (not found) (< lrl hash-lrl)) + (setf (gethash key hash) lrl)))) + +;; UMLS file and column structures + +(defstruct (umls-file) + "Record for each UMLS File" + fil table des fmt cls rws bts fields colstructs) + +(defstruct (umls-col) + "Record for each UMLS Column in each file" + col des ref min av max fil sqltype + dty ;; new in 2002 umls: suggested SQL datatype + parsefunc quotechar datatype custom-value-func) + +;;; SQL datatypes symbols +;;; sql-u - Unique identifier +;;; sql-s - Small integer (16-bit) +;;; sql-i - Integer (32-bit) +;;; sql-l - Big integer (64-bit) +;;; sql-f - Floating point + +(defconstant +col-datatypes+ + '(("AV" sql-f) ("BTS" sql-i) ("CLS" sql-i) ("COF" sql-i) ("CUI1" sql-u) + ("CUI2" sql-u) ("CUI" sql-u) ("CXN" sql-s) ("FR" sql-i) ("LRL" sql-s) + ("LUI" sql-u) ("MAX" sql-s) ("MIN" sql-s) ("RANK" sql-s) ("REF" sql-s) + ("RNK" sql-s) ("RWS" sql-i) ("SRL" sql-s) ("SUI" sql-u) ("TUI" sql-u) + ;;; Custom columns + ("KCUISUI" sql-l) ("KCUILUI" sql-l) ("KCUILRL" sql-i) ("KLUILRL" sql-i) + ("KSRL" sql-i) ("KLRL" sql-i) + ;;; LEX columns + ("EUI" sql-u) ("EUI2" sql-u) + ;;; Semantic net columns + ("UI" sql-u) ("UI2" sql-u) ("UI3" sql-u)) + "SQL data types for each non-string column") + +(defconstant +custom-tables+ + nil + #+ignore + '(("MRCONSO" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL FROM MRCON m, MRSO s WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI") + ("MRCONFULL" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL, t.TUI FROM MRCON m, MRSO s, MRSTY t WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI AND m.CUI=t.CUI AND s.CUI=t.CUI")) + "Custom tables to create") + +(defconstant +custom-cols+ + '(("MRCON" "KPFSTR" "TEXT" 1024 + (lambda (x) (pfstr-hash (parse-ui (nth 0 x))))) + ("MRCON" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x)))))) + ("MRCON" "KCUILUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x)))))) + ("MRCON" "KCUILRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (cui-lrl (parse-ui (nth 0 x)))))) + ("MRCON" "KLUILRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (lui-lrl (parse-ui (nth 3 x)))))) + ("MRLO" "KLRL" "INTEGER" 0 + (lambda (x) (format nil "~d" + (if (zerop (length (nth 4 x))) + (cui-lrl (parse-ui (nth 0 x))) + (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x)))))))) + ("MRSTY" "KLRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (cui-lrl (parse-ui (nth 0 x)))))) + ("MRCOC" "KLRL" "INTEGER" 0 + (lambda (x) (format nil "~d" + (max (cui-lrl (parse-ui (nth 0 x))) + (gu:aif (cui-lrl (parse-ui (nth 1 x))) gu::it 0))))) + ("MRSAT" "KSRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (sab-srl (nth 5 x))))) + ("MRREL" "KSRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (sab-srl (nth 4 x))))) + ("MRRANK" "KSRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (sab-srl (nth 1 x))))) + ("MRDEF" "KSRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (sab-srl (nth 1 x))))) + ("MRCXT" "KSRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (sab-srl (nth 2 x))))) + ("MRATX" "KSRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (sab-srl (nth 1 x))))) + ("MRXW.ENG" "KLRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (cuisui-lrl (make-cuisui + (parse-ui (nth 2 x)) + (parse-ui (nth 4 x))))))) + ("MRXW.NONENG" "KLRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (cuisui-lrl (make-cuisui + (parse-ui (nth 2 x)) + (parse-ui (nth 4 x))))))) + ("MRXNW.ENG" "KLRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (cuisui-lrl (make-cuisui + (parse-ui (nth 2 x)) + (parse-ui (nth 4 x))))))) + ("MRXNS.ENG" "KLRL" "INTEGER" 0 + (lambda (x) (format nil "~d" (cuisui-lrl (make-cuisui + (parse-ui (nth 2 x)) + (parse-ui (nth 4 x))))))) + ("MRREL" "KPFSTR2" "TEXT" 1024 + (lambda (x) (pfstr-hash (parse-ui (nth 2 x))))) + ("MRCOC" "KPFSTR2" "TEXT" 1024 + (lambda (x) (pfstr-hash (parse-ui (nth 1 x))))) + ("MRCXT" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x)))))) + ("MRSAT" "KCUILUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x)))))) + ("MRSAT" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x)))))) + ("MRSO" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x)))))) + ("MRXW.ENG" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))) + ("MRXNW.ENG" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))) + ("MRXNS.ENG" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))) + ("MRXW.NONENG" "LAT" "CHAR" 3 (lambda (x) (nth 0 x))) + ("MRXW.NONENG" "WD" "CHAR" 200 (lambda (x) (nth 1 x))) + ("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (nth 2 x))) + ("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (nth 3 x))) + ("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (nth 4 x))) + ("MRXW.NONENG" "KCUISUI" "BIGINT" 0 + (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))) + "Custom columns to create.(filename, col, sqltype, value-func).") + +(defconstant +index-cols+ + '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCON") ("LUI" "MRCON") + ("LRL" "MRCON") + ("SUI" "MRCON") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO") + ("CUI1" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT") + ("CUI" "MRSO") ("SAB" "MRSO") ("SRL" "MRSO") ("CUI" "MRSTY") + ("TUI" "MRSTY") ("CUI" "MRXNS_ENG") ("NSTR" "MRXNS_ENG" 10) + ("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG") + ("KCUISUI" "MRCON") ("KCUILUI" "MRCON") ("KCUILRL" "MRCON") + ("KLUILRL" "MRCON") ("KCUISUI" "MRCXT") + ("KCUISUI" "MRSO") ("KCUISUI" "MRSAT") ("KCUILUI" "MRSAT") + ("KCUISUI" "MRXW_ENG") ("KCUISUI" "MRXNW_ENG") + ("KCUISUI" "MRXNS_ENG") ("KCUISUI" "MRXW_NONENG") + ("KSRL" "MRATX") ("KSRL" "MRCXT") ("KSRL" "MRDEF") ("KSRL" "MRRANK") + ("KSRL" "MRREL") ("KSRL" "MRSAT") ("KLRL" "MRCOC") + ("KLRL" "MRLO") ("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG") + ("KLRL" "MRXNS_ENG") ("KLRL" "MRXW_NONENG") + ;; LEX indices + ("EUI" "LRABR") ("EUI2" "LRABR") ("EUI" "LRAGR") ("EUI" "LRCMP") ("EUI" "LRMOD") + ("EUI" "LRNOM") ("EUI2" "LRNOM") ("EUI" "LRPRN") ("EUI" "LRPRP") ("EUI" "LRSPL") + ("EUI" "LRTRM") ("EUI" "LRTYP") ("EUI" "LRWD") ("WRD" "LRWD") + ("BAS" "LRABR") + ;; Semantic NET indices + ("UI" "SRSTRE1") ("UI2" "SRSTRE1") ("UI3" "SRSTRE1") + ("STY_RL" "SRDEF") ("RT" "SRDEF") ("STY_RL" "SRSTR") ("STY_RL2" "SRSTR") + ("RL" "SRSTR")) + "Columns in files to index") + + +(defconstant +custom-index-cols+ + nil + #+ignore + '(("CUI" "MRCONFULL") ("SAB" "MRCONFULL") ("TUI" "MRCONFULL")) + "Indexes to custom tables") + +;; File & Column functions + +(defun init-umls (&optional (alwaysclear nil)) +"Initialize all UMLS file and column structures if not already initialized" + (when (or alwaysclear (null *umls-files*)) + (init-umls-cols) + (init-umls-files) + (init-field-lengths))) + +(defun init-umls-cols () + (setq *umls-cols* (append + (init-meta-cols) + (init-custom-cols) + (init-generic-cols "LRFLD") + (init-generic-cols "SRFLD")))) + +(defun init-meta-cols () +"Initialize all umls columns" + (let ((cols '())) + (with-umls-file (line "MRCOLS") + (destructuring-bind (col des ref min av max fil dty) line + (let ((c (make-umls-col + :col col + :des des + :ref ref + :min (parse-integer min) + :av (read-from-string av) + :max (parse-integer max) + :fil fil + :dty dty ;; new in 2002 UMLS + :sqltype "VARCHAR" ; default data type + :parsefunc #'add-sql-quotes + :custom-value-func nil + :quotechar "'"))) + (add-datatype-to-col c (datatype-for-col col)) + (push c cols)))) + (nreverse cols))) + +(defun init-custom-cols () +"Initialize umls columns for custom columns" + (let ((cols '())) + (dolist (customcol +custom-cols+) + (let ((c (make-umls-col :col (nth 1 customcol) + :des "" + :ref 0 + :min 0 + :max (nth 3 customcol) + :av 0 + :dty nil + :fil (nth 0 customcol) + :sqltype (nth 2 customcol) + :parsefunc #'add-sql-quotes + :custom-value-func (nth 4 customcol) + :quotechar "'"))) + (add-datatype-to-col c (datatype-for-col (nth 1 customcol))) + (push c cols))) + (nreverse cols))) + +(defun escape-column-name (name) + (substitute #\_ #\/ name)) + +(defun init-generic-cols (col-filename) +"Initialize for generic (LEX/NET) columns" + (let ((cols '())) + (with-umls-file (line col-filename) + (destructuring-bind (nam des ref fil) line + (setq nam (escape-column-name nam)) + (dolist (file (delimited-string-to-list fil #\,)) + (let ((c (make-umls-col + :col nam + :des des + :ref ref + :min nil + :av nil + :max nil + :fil file + :dty nil + :sqltype "VARCHAR" ; default data type + :parsefunc #'add-sql-quotes + :custom-value-func nil + :quotechar "'"))) + (add-datatype-to-col c (datatype-for-col nam)) + (push c cols))))) + (nreverse cols))) + +(defun init-umls-files () + (setq *umls-files* (append + (init-generic-files "MRFILES") + (init-generic-files "LRFIL") + (init-generic-files "SRFIL"))) + ;; need to separate this since init-custom-files depends on *umls-files* + (setq *umls-files* (append *umls-files* (init-custom-files)))) + + +(defun umls-field-string-to-list (fmt) + "Converts a comma delimited list of fields into a list of field names. Will +append a unique number (starting at 2) onto a column name that is repeated in the list" + (let ((field-list (delimited-string-to-list (escape-column-name fmt) #\,)) + (col-count (make-hash-table :test 'equal))) + (dotimes (i (length field-list)) + (declare (fixnum i)) + (let ((col (nth i field-list))) + (multiple-value-bind (key found) (gethash col col-count) + (if found + (let ((next-id (1+ key))) + (setf (nth i field-list) (concatenate 'string + col + (format nil "~D" next-id))) + (setf (gethash col col-count) next-id)) + (setf (gethash col col-count) 1))))) + field-list)) + +(defun init-generic-files (files-filename) +"Initialize all LEX file structures" + (let ((files '())) + (with-umls-file (line files-filename) + (destructuring-bind (fil des fmt cls rws bts) line + (let ((f (make-umls-file + :fil fil + :table (substitute #\_ #\. fil) + :des des + :fmt (escape-column-name fmt) + :cls (parse-integer cls) + :rws (parse-integer rws) + :bts (parse-integer bts) + :fields (concatenate 'list + (umls-field-string-to-list fmt) + (custom-colnames-for-filename fil))))) + (setf (umls-file-colstructs f) (umls-cols-for-umls-file f)) + (push f files)))) + (nreverse files))) + +(defun init-custom-files () + (let ((ffile (make-umls-file :fil "MRXW.NONENG" + :des "Custom NonEnglish Index" + :table "MRXW_NONENG" + :cls 5 + :rws 0 + :bts 0 + :fields (umls-file-fields (find-umls-file "MRXW.ENG"))))) + (setf (umls-file-colstructs ffile) + (umls-cols-for-umls-file ffile)) + (list ffile))) + +(defun datatype-for-col (colname) +"Return datatype for column name" + (car (cdr (find colname +col-datatypes+ :key #'car :test #'string-equal)))) + +(defun add-datatype-to-col (col datatype) +"Add data type information to column" + (setf (umls-col-datatype col) datatype) + (case datatype + (sql-u (setf (umls-col-sqltype col) "INTEGER" + (umls-col-parsefunc col) #'parse-ui + (umls-col-quotechar col) "")) + (sql-s (setf (umls-col-sqltype col) "SMALLINT" + (umls-col-parsefunc col) #'parse-integer + (umls-col-quotechar col) "")) + (sql-l (setf (umls-col-sqltype col) "BIGINT" + (umls-col-parsefunc col) #'parse-integer + (umls-col-quotechar col) "")) + (sql-i (setf (umls-col-sqltype col) "INTEGER" + (umls-col-parsefunc col) #'parse-integer + (umls-col-quotechar col) "")) + (sql-f (setf (umls-col-sqltype col) "NUMERIC" + (umls-col-parsefunc col) #'read-from-string + (umls-col-quotechar col) "")) + (t ; Default column type, optimized text storage + (setf (umls-col-parsefunc col) #'add-sql-quotes + (umls-col-quotechar col) "'") + (when (and (umls-col-max col) (umls-col-av col)) + (if (> (umls-col-max col) 255) + (setf (umls-col-sqltype col) "TEXT") + (if (< (- (umls-col-max col) (umls-col-av col)) 4) + (setf (umls-col-sqltype col) "CHAR") ; if average bytes wasted < 4 + (setf (umls-col-sqltype col) "VARCHAR"))))))) + + + diff --git a/parse-common.lisp b/parse-common.lisp new file mode 100644 index 0000000..9610539 --- /dev/null +++ b/parse-common.lisp @@ -0,0 +1,458 @@ +;;; UMLS-Parse General +;;; General purpose Lisp Routines for parsing UMLS files +;;; and inserting into SQL databases +;;; +;;; Copyright (c) 2001 Kevin M. Rosenberg, M.D. +;;; $Id: parse-common.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + +(defun umls-pathname (filename &optional (extension "")) +"Return pathname for a umls filename" + (etypecase filename + (string + (merge-pathnames + (make-pathname :name (concatenate 'string filename extension)) + (case (char filename 0) + ((#\M #\m) + *meta-path*) + ((#\L #\l) + *lex-path*) + ((#\S #\s) + *net-path*) + (t + *umls-path*)))) + (pathname + filename))) + +(defun read-umls-line (strm) + "Read a line from a UMLS stream, split into fields" + (let ((line (read-line strm nil 'eof))) + (if (stringp line) ;; ensure not 'eof + (let* ((len (length line)) + (maybe-remove-terminal ;; LRWD doesn't have '|' at end of line + (if (char= #\| (char line (1- len))) + (subseq line 0 (1- len)) + line))) + (declare (fixnum len)) + (delimited-string-to-list maybe-remove-terminal #\|)) + line))) + + +;;; Find field lengths for LEX and NET files + +(defun file-field-lengths (files) + (let ((lengths '())) + (dolist (file files) + (setq file (umls-file-fil file)) + (let (max-field count-field num-fields (count-lines 0)) + (with-umls-file (fields file) + (unless num-fields + (setq num-fields (length fields)) + (setq max-field (make-array num-fields :element-type 'fixnum + :initial-element 0)) + (setq count-field (make-array num-fields :element-type 'number + :initial-element 0))) + (dotimes (i (length fields)) + (declare (fixnum i)) + (let ((len (length (nth i fields)))) + (incf (aref count-field i) len) + (when (> len (aref max-field i)) + (setf (aref max-field i) len)))) + (incf count-lines)) + (dotimes (i num-fields) + (setf (aref count-field i) (float (/ (aref count-field i) count-lines)))) + (push (list file max-field count-field) lengths))) + (nreverse lengths))) + +(defun init-field-lengths () + "Initial colstruct field lengths for files that don't have a measurement. +Currently, these are the LEX and NET files." + (let ((measure-files '())) + (dolist (file *umls-files*) + (let ((filename (umls-file-fil file))) + (unless (or (char= #\M (char filename 0)) + (char= #\m (char filename 0))) + (push file measure-files)))) + (let ((length-lists (file-field-lengths measure-files))) + (dolist (length-list length-lists) + (let* ((filename (car length-list)) + (max-field (cadr length-list)) + (av-field (caddr length-list)) + (file (find-umls-file filename))) + (when file + (if (/= (length max-field) (length (umls-file-fields file))) + (format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S" + max-field file) + (dotimes (i (max (length max-field) (length (umls-file-fields file)))) + (declare (fixnum i)) + (let* ((field (nth i (umls-file-fields file))) + (col (find-umls-col field filename))) + (if col + (progn + (setf (umls-col-max col) (aref max-field i)) + (setf (umls-col-av col) (aref av-field i)) + (add-datatype-to-col col (datatype-for-col (umls-col-col col)))) + (error "can't find column ~A" field))))))))))) + + + +;;; UMLS column/file functions + +(defun find-col-in-columns (colname filename cols) +"Returns list of umls-col structure for a column name and a filename" + (dolist (col cols) + (when (and (string-equal filename (umls-col-fil col)) + (string-equal colname (umls-col-col col))) + (return-from find-col-in-columns col))) + nil) + +(defun find-or-make-col-in-columns (colname filename cols) + (let ((col (find-col-in-columns colname filename cols))) + (if col + col + ;; try to find column name without a terminal digit + (let* ((last-char (char colname (1- (length colname)))) + (digit (- (char-code last-char) (char-code #\0)))) + (if (and (>= digit 0) (<= digit 9)) + (let ((base-colname (subseq colname 0 (1- (length colname))))) + (setq col (find-col-in-columns base-colname filename cols)) + (if col + (let ((new-col (make-umls-col + :col (copy-seq colname) + :des (copy-seq (umls-col-des col)) + :ref (copy-seq (umls-col-ref col)) + :min (umls-col-min col) + :max (umls-col-max col) + :fil (copy-seq (umls-col-fil col)) + :sqltype (copy-seq (umls-col-sqltype col)) + :dty (copy-seq (umls-col-dty col)) + :parsefunc (umls-col-parsefunc col) + :quotechar (copy-seq (umls-col-quotechar col)) + :datatype (umls-col-datatype col) + :custom-value-func (umls-col-custom-value-func col)))) + (push new-col *umls-cols*) + new-col) + (error "Couldn't find a base column for col ~A in file ~A" + colname filename))) + (let ((new-col (make-umls-col + :col (copy-seq colname) + :des "Unknown" + :ref "" + :min nil + :max nil + :fil filename + :sqltype "VARCHAR" + :dty nil + :parsefunc #'add-sql-quotes + :quotechar "'" + :datatype nil + :custom-value-func nil))) + (push new-col *umls-cols*) + new-col)))))) + +(defun find-umls-col (colname filename) + "Returns list of umls-col structure for a column name and a filename" + (find-or-make-col-in-columns colname filename *umls-cols*)) + +(defun find-umls-file (filename) + "Returns umls-file structure for a filename" + (find-if (lambda (f) (string-equal filename (umls-file-fil f))) *umls-files*)) + +(defun umls-cols-for-umls-file (file) + "Returns list of umls-cols for a file structure" + (let ((filename (umls-file-fil file))) + (mapcar (lambda (col) (find-umls-col col filename)) + (umls-file-fields file)))) + + +;; SQL command functions + +(defun create-table-cmd (file) +"Return sql command to create a table" + (let ((col-func + (lambda (c) + (let ((sqltype (umls-col-sqltype c))) + (concatenate 'string (umls-col-col c) + " " + (if (or (string-equal sqltype "VARCHAR") + (string-equal sqltype "CHAR")) + (format nil "~a (~a)" sqltype (umls-col-max c)) + sqltype) + ","))))) + (format nil "CREATE TABLE ~a (~a)" (umls-file-table file) + (string-trim-last-character + (mapcar-append-string col-func (umls-cols-for-umls-file file)))))) + +(defun create-custom-table-cmd (tablename sql-cmd) +"Return SQL command to create a custom table" + (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd)) + +(defun insert-values-cmd (file values) +"Return sql insert command for a row of values" + (let ((insert-func + (lambda (col value) + (concatenate + 'string + (umls-col-quotechar col) + (if (null (umls-col-parsefunc col)) + value + (format nil "~A" (funcall (umls-col-parsefunc col) value))) + (umls-col-quotechar col) + ",")))) + (format + nil "INSERT INTO ~a (~a) VALUES (~a)" + (umls-file-table file) + (string-trim-last-character + (mapcar-append-string (lambda (c) (concatenate 'string c ",")) + (umls-file-fields file))) + (string-trim-last-character + (concatenate 'string + (mapcar2-append-string insert-func + (remove-custom-cols (umls-file-colstructs file)) + values) + (custom-col-values (custom-colstructs-for-file file) values "," t))) + ))) + +(defun custom-col-values (colstructs values delim doquote) + "Returns string of column values for SQL inserts for custom columns" + (let ((result "")) + (dolist (col colstructs) + (let* ((func (umls-col-custom-value-func col)) + (custom-value (funcall func values))) + (string-append result + (if doquote (umls-col-quotechar col)) + (escape-backslashes custom-value) + (if doquote (umls-col-quotechar col)) + delim))) + result)) + +(defun remove-custom-cols (cols) + "Remove custom cols from a list col umls-cols" + (remove-if #'umls-col-custom-value-func cols)) + +(defun find-custom-cols-for-filename (filename) + (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+)) + +(defun find-custom-col (filename col) + (find-if (lambda (x) (and (string-equal filename (car x)) + (string-equal col (cadr x)))) +custom-cols+)) + + +(defun custom-colnames-for-filename (filename) + (mapcar #'cadr (find-custom-cols-for-filename filename))) + +(defun custom-colstructs-for-file (file) + (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file))) + +(defun noneng-lang-index-files () + (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4) + (string-equal (umls-file-fil f) "MRXW." :end1 5) + (not (string-equal (umls-file-fil f) "MRXW.ENG")) + (not (string-equal (umls-file-fil f) "MRXW.NONENG")))) + *umls-files*)) + +;;; SQL Command Functions + +(defun create-index-cmd (colname tablename length) +"Return sql create index command" + (format nil "CREATE INDEX ~a ON ~a (~a ~a)" + (concatenate 'string tablename "_" colname "_X") tablename colname + (if (integerp length) + (format nil "(~d)" length) + ""))) + +(defun create-all-tables-cmdfile () +"Return sql commands to create all tables. Not need for automated SQL import" + (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*)) + + +;; SQL Execution functions + +(defun sql-drop-tables (conn) +"SQL Databases: drop all tables" + (mapcar + (lambda (file) + (ignore-errors + (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn))) + *umls-files*)) + +(defun sql-create-tables (conn) +"SQL Databases: create all tables" + (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*)) + +(defun sql-create-custom-tables (conn) +"SQL Databases: create all custom tables" + (mapcar (lambda (ct) + (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)) + +custom-tables+)) + +(defun sql-insert-values (conn file) +"SQL Databases: inserts all values for a file" + (with-umls-file (line (umls-file-fil file)) + (sql-execute (insert-values-cmd file line) conn))) + +(defun sql-insert-all-values (conn) +"SQL Databases: inserts all values for all files" + (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*)) + +(defun sql-create-indexes (conn &optional (indexes +index-cols+)) +"SQL Databases: create all indexes" +(mapcar + (lambda (idx) + (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)) + indexes)) + +(defun create-umls-db-by-insert () +"SQL Databases: initializes entire database via SQL insert commands" + (init-umls) + (init-hash-table) + (with-sql-connection (conn) +;; (sql-drop-tables conn) +;; (sql-create-tables conn) +;; (sql-insert-all-values conn) + (sql-create-indexes conn) + (sql-create-custom-tables conn) + (sql-create-indexes conn +custom-index-cols+))) + +(defun create-umls-db (&optional (extension ".trans") + (copy-cmd #'mysql-copy-cmd)) + "SQL Databases: initializes entire database via SQL copy commands" + (init-umls) + (init-hash-table) + (translate-all-files extension) + (with-sql-connection (conn) + (sql-drop-tables conn) + (sql-create-tables conn) + (mapcar + #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn)) + *umls-files*) + (sql-create-indexes conn) + (sql-create-custom-tables conn) + (sql-create-indexes conn +custom-index-cols+))) + +(defun translate-all-files (&optional (extension ".trans")) +"Copy translated files and return postgresql copy commands to import" + (make-noneng-index-file extension) + (mapcar (lambda (f) (translate-file f extension)) *umls-files*)) + +(defun translate-file (file extension) + "Translate a umls file into a format suitable for sql copy cmd" + (let ((path (umls-pathname (umls-file-fil file) extension))) + (if (probe-file path) + (progn + (format t "File ~A already exists: skipping~%" path) + nil) + (with-open-file (ostream path :direction :output) + (with-umls-file (line (umls-file-fil file)) + (princ (umls-translate file line) ostream) + (princ #\newline ostream)) + t)))) + +(defun make-noneng-index-file (extension) + "Make non-english index file" + (let* ((outfile (find-umls-file "MRXW.NONENG")) + (path (umls-pathname (umls-file-fil outfile) extension))) + + (if (probe-file path) + (progn + (format t "File ~A already exists: skipping~%" path) + nil) + (progn + (with-open-file (ostream path :direction :output) + (dolist (inputfile (noneng-lang-index-files)) + (with-umls-file (line (umls-file-fil inputfile)) + (princ (umls-translate outfile line) ostream) ;; use outfile for custom cols + (princ #\newline ostream)))) + t)))) + +(defun pg-copy-cmd (file extension) +"Return postgresql copy statement for a file" + (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''" + (umls-file-table file) (umls-pathname (umls-file-fil file) extension))) + +(defun mysql-copy-cmd (file extension) +"Return mysql copy statement for a file" + (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\"" + (umls-pathname (umls-file-fil file) extension) (umls-file-table file))) + +(defun umls-translate (file line) +"Translate a single line for sql output" +(string-trim-last-character + (concatenate 'string + (mapcar2-append-string + (lambda (col value) + (concatenate + 'string + (if (eq (umls-col-datatype col) 'sql-u) + (format nil "~d" (parse-ui value "")) + (escape-backslashes value)) + "|")) + (remove-custom-cols (umls-file-colstructs file)) + line) + (custom-col-values (custom-colstructs-for-file file) line "|" nil)))) + + +(defun umls-fixed-size-waste () + "Display storage waste if using all fixed size storage" + (let ((totalwaste 0) + (totalunavoidable 0) + (totalavoidable 0) + (unavoidable '()) + (avoidable '())) + (dolist (file *umls-files*) + (dolist (col (umls-file-colstructs file)) + (let* ((avwaste (- (umls-col-max col) (umls-col-av col))) + (cwaste (* avwaste (umls-file-rws file)))) + (unless (zerop cwaste) + (if (<= avwaste 6) + (progn + (incf totalunavoidable cwaste) + (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))) + (progn + (incf totalavoidable cwaste) + (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))) + (incf totalwaste cwaste))))) + (values totalwaste totalavoidable totalunavoidable avoidable unavoidable))) + +(defun display-waste () + (unless *umls-files* + (init-umls)) + (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste) + (format t "Total waste: ~d~%" tw) + (format t "Total avoidable: ~d~%" ta) + (format t "Total unavoidable: ~d~%" tu) + (format t "Avoidable:~%") + (dolist (w al) + (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w))) + (format t "Unavoidable:~%") + (dolist (w ul) + (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w))) + )) + +(defun max-umls-field () + "Return length of longest field" + (unless *umls-files* + (init-umls)) + (let ((max 0)) + (declare (fixnum max)) + (dolist (col *umls-cols*) + (when (> (umls-col-max col) max) + (setq max (umls-col-max col)))) + max)) + +(defun max-umls-row () + "Return length of longest row" + (if t + 6000 ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001 + (progn + (unless *umls-files* + (init-umls)) + (let ((rowsizes '())) + (dolist (file *umls-files*) + (let ((row 0) + (fields (umls-file-colstructs file))) + (dolist (field fields) + (incf row (1+ (umls-col-max field)))) + (push row rowsizes))) + (car (sort rowsizes #'>)))))) diff --git a/parse-macros.lisp b/parse-macros.lisp new file mode 100644 index 0000000..f3a8408 --- /dev/null +++ b/parse-macros.lisp @@ -0,0 +1,44 @@ +;;; UMLS-Parse General +;;; General purpose Lisp Routines for parsing UMLS files +;;; and inserting into SQL databases +;;; +;;; Copyright (c) 2001 Kevin M. Rosenberg, M.D. +;;; $Id: parse-macros.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + + +(defmacro with-umls-file ((line filename) &body body) +"Opens a UMLS and processes each parsed line with (body) argument" + (let ((ustream (gensym))) + `(with-open-file + (,ustream (umls-pathname ,filename) + :direction :input :if-exists :overwrite) + (do ((,line (read-umls-line ,ustream) (read-umls-line ,ustream))) + ((eq ,line 'eof) t) + ,@body)))) + +(defmacro with-buffered-umls-file ((line filename) &body body) +"Opens a UMLS and processes each parsed line with (body) argument" + (let ((ustream (gensym)) + (buffer (gensym))) + `(let ((,buffer (make-fields-buffer))) + (with-open-file + (,ustream (umls-pathname ,filename) + :direction :input :if-exists :overwrite) + (do ((,line (read-buffered-fields ,buffer ,ustream) (read-buffered-fields ,buffer ,ustream))) + ((eq ,line 'eof) t) + ,@body))))) + +(defmacro with-buffered2-umls-file ((line filename) &body body) +"Opens a UMLS and processes each parsed line with (body) argument" + (let ((ustream (gensym)) + (buffer (gensym))) + `(let ((,buffer (make-fields-buffer2))) + (with-open-file + (,ustream (umls-pathname ,filename) + :direction :input :if-exists :overwrite) + (do ((,line (read-buffered-fields2 ,buffer ,ustream) (read-buffered-fields2 ,buffer ,ustream))) + ((eq ,line 'eof) t) + ,@body))))) + diff --git a/sql.lisp b/sql.lisp new file mode 100644 index 0000000..3a71e36 --- /dev/null +++ b/sql.lisp @@ -0,0 +1,96 @@ +;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Pkg: umlisp -*- +;; SQL/UMLS database Layer over database backend +;; Copyright (c) 2001 Kevin M. Rosenberg, M.D. +;; $Id: sql.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + +(declaim (optimize (speed 1) (safety 3))) + +(defvar *umls-sql-dsn* "KUMLS2002AC") +(defun umls-sql-dsn () + *umls-sql-dsn*) +(defun umls-sql-dsn! (dbname) + (sql-disconnect-pooled) + (setq *umls-sql-dsn* dbname)) + +(defvar *umls-sql-user* "webumls") +(defun umls-sql-user () + *umls-sql-user*) +(defun umls-sql-user! (u) + (sql-disconnect-pooled) + (setq *umls-sql-user* u)) + +(defvar *umls-sql-passwd* "webumls") +(defun umls-sql-passwd () + *umls-sql-passwd*) +(defun umls-sql-passwd! (p) + (sql-disconnect-pooled) + (setq *umls-sql-passwd* p)) + +(defvar *umls-sql-host* "localhost") +(defun umls-sql-host () + *umls-sql-host*) +(defun umls-sql-host! (h) + (sql-disconnect-pooled) + (setq *umls-sql-host* h)) + +(defvar *umls-sql-type* :mysql) +(defun umls-sql-type () + *umls-sql-type*) +(defun umls-sql-type! (h) + (sql-disconnect-pooled) + (setq *umls-sql-type* h)) + +(defun sql-connect () + "Connect to UMLS database, automatically used pooled connections" + (clsql:connect `(,(umls-sql-host) ,(umls-sql-dsn) ,(umls-sql-user) ,(umls-sql-passwd)) + :database-type *umls-sql-type* :pool t)) + +(defun sql-disconnect (conn) + "Disconnect from UMLS database, but put connection back into pool" + (clsql:disconnect :database conn)) + +(defun sql-disconnect-pooled () + (clsql:disconnect-pooled)) + +(defmacro with-sql-connection ((conn) &body body) + `(let ((,conn (sql-connect))) + (unwind-protect + (progn ,@body) + (when ,conn (clsql:disconnect :database ,conn))))) + +(defun sql (stmt conn) + (if (string-equal "SELECT" (subseq stmt 0 6)) + (sql-query stmt conn) + (sql-execute stmt conn))) + +(defun sql-query (cmd conn &key (types :auto)) + (clsql:query cmd :database conn :types types)) + +(defun sql-execute (cmd conn) + (clsql:execute-command cmd :database conn)) + +(defun umls-sql (stmt) + (check-type stmt string) + (with-sql-connection (conn) + (sql stmt conn))) + +;;; Pool of open connections + +(defmacro with-mutex-sql ((conn) &body body) + `(let ((,conn (sql-connect))) + (unwind-protect + (progn ,@body) + (when ,conn (sql-disconnect ,conn))))) + +(defun mutex-sql-execute (cmd) + (with-mutex-sql (conn) + (sql-execute cmd conn))) + +(defun mutex-sql-query (cmd &key (types :auto)) + (with-mutex-sql (conn) + (sql-query cmd conn :types types))) + + + diff --git a/umlisp.asd b/umlisp.asd new file mode 100644 index 0000000..368ce84 --- /dev/null +++ b/umlisp.asd @@ -0,0 +1,18 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; $Id: umlisp.asd,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :asdf) + +(defsystem umlisp + :components + ((:file "package") + (:file "data-structures" :depends-on ("package")) + (:file "sql" :depends-on ("data-structures")) + (:file "utils" :depends-on ("data-structures")) + (:file "parse-macros" :depends-on ("sql")) + (:file "parse-2002" :depends-on ("parse-macros")) + (:file "parse-common" :depends-on ("parse-2002")) + (:file "obj" :depends-on ("utils")) + (:file "obj-sql" :depends-on ("obj" "sql")) + (:file "obj-composite" :depends-on ("obj-sql")))) + diff --git a/utils.lisp b/utils.lisp new file mode 100644 index 0000000..9bc35b8 --- /dev/null +++ b/utils.lisp @@ -0,0 +1,83 @@ +;;;; $Id: utils.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ + +(in-package :umlisp) + +(declaim (inline xml-cdata make-cuisui make-cuilui parse-ui parse-cui)) +(declaim (optimize (speed 3) (safety 1))) + +(defmacro def-metaclass-reader (field) + "Create function for reading slot of metaclass" + `(defun ,field (cl) + (car (slot-value (class-of cl) ',field)))) + +(defmacro def-metaclass-reader-car (field) + "Create function for reading slot of metaclass" + `(defun ,field (cl) + (car (slot-value (class-of cl) ',field)))) + +;;; Field transformations + +(defun parse-ui (s &optional (nullvalue 0)) + "Return integer value for a UMLS unique identifier." + (if (< (length s) 2) + nullvalue + (parse-integer s :start 1))) + +(defun parse-cui (cui) + (if (stringp cui) + (let ((ch (aref cui 0))) + (if (eql ch #\C) + (parse-ui cui) + (parse-integer cui))) + cui)) + +(defun parse-lui (lui) + (if (stringp lui) + (let ((ch (aref lui 0))) + (if (eql ch #\L) + (parse-ui lui) + (parse-integer lui))) + lui)) + +(defun parse-sui (sui) + (if (stringp sui) + (let ((ch (aref sui 0))) + (if (eql ch #\S) + (parse-ui sui) + (parse-integer sui))) + sui)) + +(defun parse-tui (tui) + (if (stringp tui) + (let ((ch (aref tui 0))) + (if (eql ch #\T) + (parse-ui tui) + (parse-integer tui))) + tui)) + +(defun parse-eui (eui) + (if (stringp eui) + (let ((ch (aref eui 0))) + (if (eql ch #\E) + (parse-ui eui) + (parse-integer eui))) + eui)) + +(defun xml-cdata (str) + (concatenate 'string "")) + +(defconstant +cuisui-scale+ 10000000) + +(defun make-cuisui (cui sui) + (declare (fixnum cui sui)) + (the integer (+ (* +cuisui-scale+ cui) sui))) + +(defun make-cuilui (cui lui) + (declare (fixnum cui lui)) + (the integer (+ (* +cuisui-scale+ cui) lui))) + +(defun decompose-cuisui (cuisui) + (declare (integer cuisui)) + (let* ((cui (the fixnum (truncate (/ cuisui +cuisui-scale+)))) + (sui (the fixnum (- cuisui (* cui +cuisui-scale+))))) + (values cui sui))) -- 2.34.1