-.PHONY: all clean test test-acl test-sbcl
+.PHONY: all clean test test-acl test-sbcl distclean
test-file:=`pwd`/run-tests.lisp
all:
+distclean: clean
clean:
@find . -type f -name "*.fasl*" -or -name "*.ufsl" -or -name "*.x86f" \
-or -name "*.fas" -or -name "*.pfsl" -or -name "*.dfsl" \
(defmethod fmt-tui ((tui string))
(if (eql (aref tui 0) #\T)
tui
- (fmt-tui (parse-integer tui))))
+ (fmt-tui (parse-integer tui))))
+
+(defgeneric fmt-aui (aui))
+(defmethod fmt-aui ((aui fixnum))
+ (prefixed-fixnum-string aui #\A 7))
+
+(defmethod fmt-aui ((aui string))
+ (if (eql (aref aui 0) #\A)
+ aui
+ (fmt-aui (parse-integer aui))))
(defgeneric fmt-eui (e))
(defmethod fmt-eui ((e fixnum))
(let ((col-func
(lambda (c)
(let ((sqltype (sqltype c)))
+ (case *umls-sql-type*
+ (:oracle
+ (cond
+ ((string-equal sqltype "VARCHAR")
+ (setq sqltype "VARCHAR2"))
+ ((string-equal sqltype "BIGINT")
+ (setq sqltype "VARCHAR2(20)")))))
+
(concatenate 'string
- (col c)
- " "
- (if (or (string-equal sqltype "VARCHAR")
- (string-equal sqltype "CHAR"))
- (format nil "~a (~a)" sqltype (cmax c))
- sqltype))))))
+ (col c)
+ " "
+ (if (or (string-equal sqltype "VARCHAR")
+ (string-equal sqltype "CHAR"))
+ (format nil "~a (~a)" sqltype (cmax c))
+ sqltype))))))
(format nil "CREATE TABLE ~a (~{~a~^,~})" (table file)
(mapcar col-func (ucols file)))))
(defun noneng-lang-index-files ()
(remove-if-not
(lambda (f) (and (> (length (fil f)) 4)
- (string-equal (fil f) "MRXW." :end1 5)
- (not (string-equal (fil f) "MRXW.ENG"))
- (not (string-equal (fil f) "MRXW.NONENG"))))
+ (string-equal (fil f) "MRXW_" :end1 5)
+ (not (string-equal (fil f) "MRXW_ENG.RRF"))
+ (not (string-equal (fil f) "MRXW_NONENG.RRF"))))
*umls-files*))
;;; SQL Command Functions
(defun translate-all-files (&optional (extension ".trans"))
"Copy translated files and return postgresql copy commands to import"
(make-noneng-index-file extension)
- (dolist (f (remove "MRXW.NONENG" *umls-files* :test #'string= :key #'fil))
+ (dolist (f (remove "MRXW_NONENG.RRF" *umls-files* :test #'string= :key #'fil))
(translate-umls-file f extension)))
(defun translate-umls-file (file extension)
(defun make-noneng-index-file (extension)
"Make non-english index file"
- (translate-files (find-ufile "MRXW.NONENG")
+ (translate-files (find-ufile "MRXW_NONENG.RRF")
extension (noneng-lang-index-files)))
(defun translate-files (out-ufile extension input-ufiles)
"Translate a umls file into a format suitable for sql copy cmd"
- (let ((output-path (umls-pathname (fil out-ufile) extension)))
+ (let ((output-path (ufile-pathname out-ufile extension)))
(if (probe-file output-path)
(format t "File ~A already exists: skipping~%" output-path)
(with-open-file (ostream output-path :direction :output)
(dolist (input-ufile input-ufiles)
- (with-umls-file (line (fil input-ufile))
+ (with-umls-ufile (line input-ufile)
(translate-line out-ufile line ostream)
(princ #\newline ostream)))))))
;;; Paths for files
(defvar *umls-path*
- (make-pathname :directory '(:absolute "data" "umls" "2003AC"))
+ (make-pathname :directory '(:absolute "data" "umls" "2004AA"))
"Path for base of UMLS data files")
(defvar *meta-path*
;; Preliminary objects to replace structures
(defclass ufile ()
- ((fil :initarg :fil :accessor fil)
+ ((subdir :initarg :subdir :accessor subdir)
+ (dir :initarg :dir :accessor dir)
+ (fil :initarg :fil :accessor fil)
(table :initarg :table :accessor table)
(des :initarg :des :accessor des)
(fmt :initarg :fmt :accessor fmt)
(fields :initarg :fields :accessor fields)
(ucols :initarg :ucols :accessor ucols))
(:default-initargs :fil nil :table nil :des nil :fmt nil :cls nil :rws nil :bts nil
- :fields nil :ucols nil)
+ :fields nil :ucols nil :subdir nil :dir nil)
(:documentation "UMLS File"))
(defclass ucol ()
+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: parse-2002.lisp
-;;;; Purpose: Parsing and SQL insertion routines for UMLisp which may
-;;;; change from year to year
-;;;; Author: Kevin M. Rosenberg
-;;;; Created: Apr 2000
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of UMLisp, is
-;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
-;;;;
-;;;; UMLisp users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License.
-;;;; *************************************************************************
-
-(in-package #:umlisp)
-
-;;; Pre-read data for custom fields into hash tables
-(defvar *preparse-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-preparse-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 buffered-ensure-preparse (&optional (force-read nil))
- (when (or force-read (not *preparse-hash-init?*))
- (make-preparse-hash-table)
- (setq *preparse-hash-init?* t))
- (with-buffered-umls-file (line "MRCON")
- (let ((cui (parse-ui (aref line 0)))
- (lui (parse-ui (aref line 3)))
- (sui (parse-ui (aref line 5)))
- (lrl (parse-integer (aref line 7))))
- (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 line 3)))
- (unless (gethash sab sab-srl-hash) ;; if haven't stored
- (setf (gethash sab sab-srl-hash) (aref line 6))))))
-
- (defun ensure-preparse (&optional (force-read nil))
- (when (or force-read (not *preparse-hash-init?*))
- (make-preparse-hash-table)
- (setq *preparse-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)
- (aif (gethash sab sab-srl-hash) 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
-;;; 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
-;;; sql-c - Character data
-
-(defparameter +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-c)
- ("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)
- ;; New fields for 2002AD
- ("RCUI" sql-u) ("VCUI" sql-u) ("CFR" sql-i) ("TFR" sql-i)
- )
- "SQL data types for each non-string column")
-
-(defparameter +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")
-
-(defparameter +custom-cols+
- '(("MRCON" "KPFSTR" "TEXT" 1024
- (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
- ("MRCON" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
- ("MRCON" "KCUILUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x))))))
- ("MRCON" "KCUILRL" "INTEGER" 0
- (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
- ("MRCON" "KLUILRL" "INTEGER" 0
- (lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x))))))
- ("MRLO" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string
- (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) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
- ("MRCOC" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string
- (max (cui-lrl (parse-ui (nth 0 x)))
- (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0)))))
- ("MRSAT" "KSRL" "INTEGER" 0
- (lambda (x) (write-to-string (sab-srl (nth 5 x)))))
- ("MRREL" "KSRL" "INTEGER" 0
- (lambda (x) (write-to-string (sab-srl (nth 4 x)))))
- ("MRRANK" "KSRL" "INTEGER" 0
- (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
- ("MRDEF" "KSRL" "INTEGER" 0
- (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
- ("MRCXT" "KSRL" "INTEGER" 0
- (lambda (x) (write-to-string (sab-srl (nth 2 x)))))
- ("MRATX" "KSRL" "INTEGER" 0
- (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
- ("MRXW.ENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (nth 2 x))
- (parse-ui (nth 4 x)))))))
- ("MRXW.NONENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (nth 2 x))
- (parse-ui (nth 4 x)))))))
- ("MRXNW.ENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (nth 2 x))
- (parse-ui (nth 4 x)))))))
- ("MRXNS.ENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (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) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
- ("MRSAT" "KCUILUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
- ("MRSAT" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
- ("MRSO" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
- ("MRXW.ENG" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
- ("MRXNW.ENG" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
- ("MRXNS.ENG" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
- ("MRXW.NONENG" "LAT" "VARCHAR" 3 (lambda (x) (nth 0 x)))
- ("MRXW.NONENG" "WD" "VARCHAR" 200 (lambda (x) (nth 1 x)))
- ("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x)))))
- ("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x)))))
- ("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x)))))
- ("MRXW.NONENG" "KCUISUI" "BIGINT" 0
- (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))))
- "Custom columns to create.(filename, col, sqltype, value-func).")
-
-(defparameter +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")
- #+ignore ("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")
- ("SRL" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB")
- ("VCUI" "MRSAB") ("LAT" "MRSAB"))
- "Columns in files to index")
-
-
-(defparameter +custom-index-cols+
- nil
- #+ignore
- '(("CUI" "MRCONFULL") ("SAB" "MRCONFULL") ("TUI" "MRCONFULL"))
- "Indexes to custom tables")
-
-;; File & Column functions
-
-(defun gen-ucols ()
- (add-ucols (gen-ucols-meta))
- (add-ucols (gen-ucols-custom))
- (add-ucols (gen-ucols-generic "LRFLD"))
- (add-ucols (gen-ucols-generic "SRFLD")))
-
-(defun gen-ucols-meta ()
-"Initialize all umls columns"
- (let ((cols '()))
- (with-umls-file (line "MRCOLS")
- (destructuring-bind (col des ref min av max fil dty) line
- (push (make-ucol col des ref (parse-integer min) (read-from-string av)
- (parse-integer max) fil dty)
- cols)))
- (nreverse cols)))
-
-(defun gen-ucols-custom ()
-"Initialize umls columns for custom columns"
- (loop for customcol in +custom-cols+
- collect
- (make-ucol (nth 1 customcol) "" 0 0 0 (nth 3 customcol)
- (nth 0 customcol) nil :sqltype (nth 2 customcol)
- :custom-value-fun (nth 4 customcol))))
-
-(defun gen-ucols-generic (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 #\,))
- (push
- (make-ucol nam des ref nil nil nil file nil)
- cols))))
- (nreverse cols)))
-
-
-(defun gen-ufiles ()
- (add-ufiles (gen-ufiles-generic "MRFILES"))
- (add-ufiles (gen-ufiles-generic "LRFIL"))
- (add-ufiles (gen-ufiles-generic "SRFIL"))
- ;; needs to come last
- (add-ufiles (gen-ufiles-custom)))
-
-
-(defun gen-ufiles-generic (files-filename)
-"Initialize all LEX file structures"
- (let ((files '()))
- (with-umls-file (line files-filename)
- (destructuring-bind (fil des fmt cls rws bts) line
- (push (make-ufile
- fil des (substitute #\_ #\. fil) (parse-integer cls)
- (parse-integer rws) (parse-integer bts)
- (concatenate 'list (umls-field-string-to-list fmt)
- (custom-colnames-for-filename fil)))
- files)))
- (nreverse files)))
-
-(defun gen-ufiles-custom ()
- (make-ufile "MRXW.NONENG" "Custom NonEnglish Index" "MRXW_NONENG"
- 5 0 0 (fields (find-ufile "MRXW.ENG"))))
-
-
-
(in-package #:umlisp)
(defun ensure-ucols+ufiles (&optional (alwaysclear nil))
-"Initialize all UMLS file and column structures if not already initialized"
+ "Initialize all UMLS file and column structures if not already initialized"
(when (or alwaysclear (null *umls-files*))
+ (setq *umls-cols* nil)
+ (setq *umls-files* nil)
(gen-ucols)
(gen-ufiles)
(ensure-field-lengths)))
(setq *umls-files* (append (mklist ufiles) *umls-files*))
ufiles)
+(defun ufile-pathname (ufile &optional (extension ""))
+ "Return pathname for a umls filename with an optional extension"
+ (assert (typep ufile 'ufile))
+ (let ((dirs (append (list (dir ufile))
+ (awhen (subdir ufile) (list it)))))
+ (merge-pathnames
+ (make-pathname :name (concatenate 'string (fil ufile) extension)
+ :directory (cons :relative dirs))
+ *umls-path*)))
+
(defun umls-pathname (filename &optional (extension ""))
"Return pathname for a umls filename with an optional extension"
(etypecase filename
(t
*umls-path*))))
(pathname
- filename)))
+ filename)))
-(defun read-umls-line (strm &optional (eof 'eof))
- "Read a line from a UMLS stream, split into fields"
- (let ((line (read-line strm nil eof)))
- (if (eq line eof)
- eof
- (delimited-string-to-list line #\| t))))
;;; Find field lengths for LEX and NET files
(loop for ufile in *umls-files*
unless (or (char= #\M (schar (fil ufile) 0))
(char= #\m (schar (fil ufile) 0)))
- collect ufile))
+ collect ufile))
(defun ufiles-field-lengths (ufiles)
"Returns a list of lists of containing (FILE MAX AV)"
- (loop for ufile in ufiles collect (file-field-lengths (fil ufile))))
+ (loop for ufile in ufiles collect (file-field-lengths ufile)))
-(defun file-field-lengths (filename)
+(defun file-field-lengths (ufile)
"Returns a list of FILENAME MAX AV"
(declare (optimize (speed 3) (safety 0)))
(let (fields-max fields-av num-fields (count-lines 0))
- (with-umls-file (line filename)
+ (with-umls-ufile (line ufile)
(unless num-fields
(setq num-fields (length line))
(setq fields-max (make-array num-fields :element-type 'fixnum
(incf count-lines))
(dotimes (i num-fields)
(setf (aref fields-av i) (float (/ (aref fields-av i) count-lines))))
- (list filename fields-max fields-av)))
+ (list (fil ufile) fields-max fields-av)))
;;; UMLS column/file functions
:col col :des des :ref ref :min min :av av
:max (if (eql max 0) 1 max) ;; ensure at least one char wide
:fil fil
- :dty dty :sqltype sqltype :quote-str quote-str
+ :dty dty
+ :sqltype sqltype
+ :quote-str quote-str
:parse-fun (ensure-compiled-fun parse-fun)
:custom-value-fun (ensure-compiled-fun custom-value-fun))))
(ensure-ucol-datatype ucol (datatype-for-colname col))
(setf (gethash colname col-counts) 1)
colname))))))
-(defun make-ufile (fil des table cls rws bts fields)
- (let ((ufile (make-instance 'ufile :fil fil :des des :table table :cls cls
- :rws rws :bts bts :fields fields)))
- (setf (ucols ufile) (find-ucols-for-ufile ufile))
- ufile))
+(defun decompose-fil (fil)
+ (if fil
+ (let ((pos (position #\/ fil)))
+ (if pos
+ (values (subseq fil (1+ pos)) (subseq fil 0 pos))
+ (values fil nil)))
+ (values nil nil)))
+
+(defun filename-to-tablename (file)
+ (let ((pos (search ".RRF" file)))
+ (when pos
+ (setf file (subseq file 0 pos))))
+ (substitute #\_ #\. file))
+
+(defun make-ufile (dir fil des cls rws bts fields)
+ (multiple-value-bind (file subdir) (decompose-fil fil)
+ (let ((ufile (make-instance 'ufile :dir dir :fil file :subdir subdir
+ :des des :cls cls
+ :rws rws :bts bts :fields fields
+ :table (filename-to-tablename file))))
+ (setf (ucols ufile) (find-ucols-for-ufile ufile))
+ ufile)))
(defun datatype-for-colname (colname)
"Return datatype for column name"
(in-package #:umlisp)
-(defmacro with-umls-file ((line filename) &body body)
-"Opens a UMLS and processes each parsed line with (body) argument"
+(defun read-umls-line (strm &optional (eof 'eof))
+ "Read a line from a UMLS stream, split into fields"
+ (let ((line (read-line strm nil eof)))
+ (if (eq line eof)
+ eof
+ (delimited-string-to-list line #\| t))))
+
+(defun source-files (path)
+ (if (probe-file path)
+ (list path)
+ (sort
+ (directory (make-pathname :defaults path
+ :type :wild
+ :name (concatenate 'string (pathname-name path)
+ (aif (pathname-type path)
+ (concatenate 'string "." it)
+ ""))))
+ #'(lambda (a b)
+ (string-lessp (pathname-type a) (pathname-type b))))))
+
+(defmacro with-buffered-reading-umls-file ((line path) &body body)
+ "Opens a UMLS and processes each parsed line with (body) argument"
(let ((ustream (gensym "STRM-"))
- (eof (gensym "EOF-")))
- `(let ((,eof (gensym "EOFSYM-")))
- (with-open-file
- (,ustream (umls-pathname ,filename) :direction :input)
- (do ((,line (read-umls-line ,ustream ,eof)
- (read-umls-line ,ustream ,eof)))
- ((eq ,line ,eof) t)
- ,@body)))))
+ (buffer (gensym "BUF-"))
+ (eof (gensym "EOF-"))
+ (files (gensym "FILES-")))
+ `(let ((,eof (gensym "EOFSYM-"))
+ (,buffer (make-fields-buffer))
+ (,files (source-files ,path)))
+ (with-open-file (,ustream (first ,files) :direction :input)
+ (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
+ (read-buffered-fields ,buffer ,ustream #\| ,eof)))
+ ((eq ,line ,eof) t)
+ (setq ,line (coerce ,line 'list))
+ (print ,line)
+ ,@body)))))
+
+(defmacro with-reading-umls-file ((line path) &body body)
+ "Opens a UMLS and processes each parsed line with (body) argument"
+ (let ((ustream (gensym "STRM-"))
+ (eof (gensym "EOF-"))
+ (files (gensym "FILES-")))
+ `(let ((,eof (gensym "EOFSYM-"))
+ (,files (source-files ,path)))
+ (with-open-file (,ustream (first ,files) :direction :input)
+ (do ((,line (read-umls-line ,ustream ,eof)
+ (read-umls-line ,ustream ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
+
+(defmacro with-umls-ufile ((line ufile) &body body)
+ "Opens a UMLS and processes each parsed line with (body) argument"
+ `(with-reading-umls-file (,line (ufile-pathname ,ufile))
+ ,@body))
+
+(defmacro with-umls-file ((line ufile) &body body)
+ "Opens a UMLS and processes each parsed line with (body) argument"
+ "Opens a UMLS and processes each parsed line with (body) argument"
+ `(with-reading-umls-file (,line (umls-pathname ,ufile))
+ ,@body))
(defmacro with-buffered-umls-file ((line filename) &body body)
"Opens a UMLS and processes each parsed line with (body) argument"
((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 "STRM-"))
- (buffer (gensym "BUF-"))
- (eof (gensym "EOF-")))
- `(let ((,buffer (make-fields-buffer2))
- (,eof (gensym "EOFSYM-")))
- (with-open-file
- (,ustream (umls-pathname ,filename)
- :direction :input :if-exists :overwrite)
- (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
- (read-buffered-fields ,buffer ,ustream #\| ,eof)))
- ((eq ,line ,eof) t)
- ,@body)))))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: parse-2002.lisp
+;;;; Purpose: Parsing and SQL insertion routines for UMLisp which may
+;;;; change from year to year
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp)
+
+;;; Pre-read data for custom fields into hash tables
+(defvar *preparse-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-preparse-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 ensure-preparse (&optional (force-read nil))
+ (when (or force-read (not *preparse-hash-init?*))
+ (make-preparse-hash-table)
+ (setq *preparse-hash-init?* t))
+ (with-umls-file (line "MRCONSO.RRF")
+ (let ((cui (parse-ui (nth 0 line)))
+ (lui (parse-ui (nth 3 line)))
+ (sui (parse-ui (nth 5 line)))
+ (sab (nth 11 line))
+ (srl (parse-integer (nth 15 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 14 line))))
+ (set-lrl-hash cui srl cui-lrl-hash)
+ (set-lrl-hash lui srl lui-lrl-hash)
+ (set-lrl-hash (make-cuisui cui sui) srl cuisui-lrl-hash)
+ (multiple-value-bind (val found) (gethash sab sab-srl-hash)
+ (declare (ignore val))
+ (unless found
+ (setf (gethash sab sab-srl-hash) srl))))))
+
+ (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)
+ (aif (gethash sab sab-srl-hash) 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
+;;; 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
+;;; sql-c - Character data
+
+(defparameter +col-datatypes+
+ '(("AV" sql-f) ("BTS" sql-i) ("CLS" sql-i) ("COF" sql-i) ("CUI1" sql-u)
+ ("AUI" sql-u) ("AUI1" sql-u) ("AUI2" 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-c)
+ ("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)
+ ;; New fields for 2002AD
+ ("RCUI" sql-u) ("VCUI" sql-u) ("CFR" sql-i) ("TFR" sql-i)
+ )
+ "SQL data types for each non-string column")
+
+(defparameter +custom-tables+
+ nil
+ "Custom tables to create")
+
+(defparameter +custom-cols+
+ '(("MRCONSO.RRF" "KPFSTR" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
+ ("MRCONSO.RRF" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
+ ("MRCONSO.RRF" "KCUILUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x))))))
+ ("MRCONSO.RRF" "KCUILRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCONSO.RRF" "KLUILRL" "INTEGER" 0
+ (lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x))))))
+ ;; Deprecated, last in 2004AA -- skip index
+ #+ignore
+ ("MRLO.RRF" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string
+ (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.RRF" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCOC.RRF" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string
+ (max (cui-lrl (parse-ui (nth 0 x)))
+ (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0)))))
+ ("MRSAT.RRF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 9 x)))))
+ ("MRREL.RRF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 10 x)))))
+ ("MRRANK.RRF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRDEF.RRF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 4 x)))))
+ ("MRCXT.RRF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 2 x)))))
+ ("MRATX.RRF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRXW_ENG.RRF" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXW_NONENG.RRF" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNW_ENG.RRF" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNS_ENG.RRF" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRREL.RRF" "KPFSTR2" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 4 x)))))
+ ("MRCOC.RRF" "KPFSTR2" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 2 x)))))
+ ("MRCXT.RRF" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT.RRF" "KCUILUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT.RRF" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
+ ("MRXW_ENG.RRF" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNW_ENG.RRF" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNS_ENG.RRF" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXW_NONENG.RRF" "LAT" "VARCHAR" 3 (lambda (x) (nth 0 x)))
+ ("MRXW_NONENG.RRF" "WD" "VARCHAR" 200 (lambda (x) (nth 1 x)))
+ ("MRXW_NONENG.RRF" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x)))))
+ ("MRXW_NONENG.RRF" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x)))))
+ ("MRXW_NONENG.RRF" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x)))))
+ ("MRXW_NONENG.RRF" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))))
+ "Custom columns to create.(filename, col, sqltype, value-func).")
+
+(defparameter +index-cols+
+ '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCONSO") ("LUI" "MRCONSO")
+ ("SRL" "MRCONSO") ("AUI" "MRCONSO")
+ ("SUI" "MRCONSO") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO")
+ ("CUI1" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT")
+ ("CUI" "MRSTY")
+ ("TUI" "MRSTY") ("CUI" "MRXNS_ENG")
+ #+ignore ("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")
+ #+ignore ("KLRL" "MRLO") ;; deprecated
+ ("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")
+ ("SRL" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB")
+ ("VCUI" "MRSAB") ("LAT" "MRSAB"))
+ "Columns in files to index")
+
+
+(defparameter +custom-index-cols+
+ nil
+ #+ignore
+ '(("CUI" "MRCONFULL") ("SAB" "MRCONFULL") ("TUI" "MRCONFULL"))
+ "Indexes to custom tables")
+
+;; File & Column functions
+
+(defun gen-ucols ()
+ (add-ucols (gen-ucols-meta))
+ (add-ucols (gen-ucols-custom))
+ (add-ucols (gen-ucols-generic "LRFLD"))
+ (add-ucols (gen-ucols-generic "SRFLD")))
+
+(defun gen-ucols-meta ()
+"Initialize all umls columns"
+ (let ((cols '()))
+ (with-umls-file (line "MRCOLS.RRF")
+ (destructuring-bind (col des ref min av max fil dty) line
+ (push (make-ucol col des ref (parse-integer min) (read-from-string av)
+ (parse-integer max) fil dty)
+ cols)))
+ (nreverse cols)))
+
+(defun gen-ucols-custom ()
+"Initialize umls columns for custom columns"
+ (loop for customcol in +custom-cols+
+ collect
+ (make-ucol (nth 1 customcol) "" 0 0 0 (nth 3 customcol)
+ (nth 0 customcol) nil :sqltype (nth 2 customcol)
+ :custom-value-fun (nth 4 customcol))))
+
+(defun gen-ucols-generic (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 #\,))
+ (push
+ (make-ucol nam des ref nil nil nil file nil)
+ cols))))
+ (nreverse cols)))
+
+
+(defun gen-ufiles ()
+ (add-ufiles (gen-ufiles-generic "MRFILES.RRF" "META"))
+ (add-ufiles (gen-ufiles-generic "LRFIL" "LEX"))
+ (add-ufiles (gen-ufiles-generic "SRFIL" "NET"))
+ ;; needs to come last
+ (add-ufiles (gen-ufiles-custom)))
+
+
+(defun gen-ufiles-generic (files-filename dir)
+"Initialize all LEX file structures"
+ (let ((files '()))
+ (with-umls-file (line files-filename)
+ (destructuring-bind (fil des fmt cls rws bts) line
+ (push (make-ufile
+ dir fil des
+ (parse-integer cls)
+ (parse-integer rws) (parse-integer bts)
+ (concatenate 'list (umls-field-string-to-list fmt)
+ (custom-colnames-for-filename fil)))
+ files)))
+ (nreverse files)))
+
+(defun gen-ufiles-custom ()
+ (make-ufile "META" "MRXW_NONENG.RRF" "Custom NonEnglish Index"
+ 5 0 0 (fields (find-ufile "MRXW_ENG.RRF"))))
+
+
+
,%%fields
,@(when %%where (list %%where))
,@(when %%where
- `((typecase ,where-value
- (fixnum
- (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
- (number
- (concatenate 'string "='" (write-to-string ,where-value) "'"))
- (null
- " is null")
- (t
- (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
+ `((typecase ,where-value
+ #+ignore
+ (fixnum
+ (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
+ (number
+ (concatenate 'string "='" (write-to-string ,where-value) "'"))
+ (null
+ " is null")
+ (t
+ (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
(if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
,@(when %%order (list %%order))
,@(when single (list " limit 1")))))
(if where-name
(format nil
(typecase where-value
- (number "=~D")
+ (number "='~D'")
(null " is null")
(t
(if like " like '%~A%""='~A'")))
(in-package #:umlisp)
(defvar +umls-sql-map+
- '((:2002AD . "KUMLS2002AD") (:2003AA . "KUMLS2003AA")
- (:2003AB . "KUMLS2003AB") (:2003AC . "KUMLS2003AC")
- (:2004AA . "KUMLS2004AA")))
-(defvar +default-umls-db+ :2003AC)
+ '((:2004aa . "KUMLS2004AA")))
+(defvar +default-umls-db+ :2004aa)
(defun lookup-db-name (db)
(in-package #:umlisp-tests)
-(deftest qs.1 (umlisp::query-string mrcon (cui lui))
- "select CUI,LUI from MRCON")
-
-(deftest qs.1e (umlisp::query-string-eval 'mrcon '(cui lui))
- "select CUI,LUI from MRCON")
-
-(deftest qs.2 (umlisp::query-string mrcon (cui lui) 0)
- "select CUI,LUI from MRCON and KCUILRL<=0")
-
-(deftest qs.2e (umlisp::query-string-eval 'mrcon '(cui lui) 0)
- "select CUI,LUI from MRCON and KCUILRL<=0")
-
-(deftest qs.3 (umlisp::query-string mrcon (cui lui) nil cui 5)
- "select CUI,LUI from MRCON where CUI=5")
-
-(deftest qs.3e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'cui 5)
- "select CUI,LUI from MRCON where CUI=5")
-
-(deftest qs.4 (umlisp::query-string mrcon (cui lui) nil kpfstr "Abc")
- "select CUI,LUI from MRCON where KPFSTR='Abc'")
-
-(deftest qs.4e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'kpfstr "Abc")
- "select CUI,LUI from MRCON where KPFSTR='Abc'")
-
-(deftest qs.5 (umlisp::query-string mrcon (cui lui) 2 cui 5 :single t)
- "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1")
-
-(deftest qs.5e (umlisp::query-string-eval 'mrcon '(cui lui) 2 'cui 5 :single t)
- "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1")
-
-(deftest qs.6 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :single t)
- "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1")
-
-(deftest qs.6e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :single t)
- "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1")
-
-(deftest qs.7 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc))
- "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc")
-
-(deftest qs.7e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc))
- "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc")
-
-(deftest qs.8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl
- :order (cui asc def desc))
- "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc")
-
-(deftest qs.8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl
- :order '(cui asc def desc))
- "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc")
-
-(deftest ui.1 (umlisp::parse-cui "C0002341") 2341)
-(deftest ui.2 (umlisp::parse-lui "L0002341") 2341)
-(deftest ui.3 (umlisp::parse-sui "S0000000") 0)
-(deftest ui.4 (umlisp::parse-tui "T123") 123)
-(deftest ui.5 (fmt-cui 2341) "C0002341")
-(deftest ui.6 (fmt-lui 2341) "L0002341")
-(deftest ui.7 (fmt-sui 2341) "S0002341")
-(deftest ui.8 (fmt-tui 231) "T231")
-(deftest ui.9 (fmt-tui 231) "T231")
-(deftest ui.10 (fmt-eui 231) "E0000231")
-(deftest ui.11 (umlisp::make-cuisui 5 11) 50000011)
-(deftest ui.12 (umlisp::decompose-cuisui 50000011) 5 11)
-(deftest ui.13 (umlisp::parse-eui "E00002311") 2311)
-(deftest ui.14 (umlisp::parse-lui "1234") 1234)
-(deftest ui.15 (umlisp::parse-lui 1234) 1234)
-
-(defun f2 (&key (srl *current-srl*))
- "Return list of all ucon's"
- (umlisp::with-umlisp-query ('mrcon (cui kpfstr kcuilrl) srl nil nil)
- (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
- :lrl (ensure-integer kcuilrl))))
-
-(defun f1 (&key (srl *current-srl*))
- "Return list of all ucon's"
- (umlisp::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)))
- (umlisp::query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil)
- :database db)))
+(setq *rt-basic*
+ '(
+ (deftest :qrystr/1 (umlisp::query-string mrcon (cui lui))
+ "select CUI,LUI from MRCON")
+
+ (deftest :qrystr/1e (umlisp::query-string-eval 'mrcon '(cui lui))
+ "select CUI,LUI from MRCON")
+
+ (deftest :qrystr/2 (umlisp::query-string mrcon (cui lui) 0)
+ "select CUI,LUI from MRCON and KCUILRL<=0")
+
+ (deftest :qrystr/2e (umlisp::query-string-eval 'mrcon '(cui lui) 0)
+ "select CUI,LUI from MRCON and KCUILRL<=0")
+
+ (deftest :qrystr/3 (umlisp::query-string mrcon (cui lui) nil cui 5)
+ "select CUI,LUI from MRCON where CUI='5'")
+
+ (deftest :qrystr/3e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'cui 5)
+ "select CUI,LUI from MRCON where CUI='5'")
+
+ (deftest :qrystr/4 (umlisp::query-string mrcon (cui lui) nil kpfstr "Abc")
+ "select CUI,LUI from MRCON where KPFSTR='Abc'")
+
+ (deftest :qrystr/4e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'kpfstr "Abc")
+ "select CUI,LUI from MRCON where KPFSTR='Abc'")
+
+ (deftest :qrystr/5 (umlisp::query-string mrcon (cui lui) 2 cui 5 :single t)
+ "select CUI,LUI from MRCON where CUI='5' and KCUILRL<=2 limit 1")
+
+ (deftest :qrystr/5e (umlisp::query-string-eval 'mrcon '(cui lui) 2 'cui 5 :single t)
+ "select CUI,LUI from MRCON where CUI='5' and KCUILRL<=2 limit 1")
+
+ (deftest :qrystr/6 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :single t)
+ "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 limit 1")
+
+ (deftest :qrystr/6e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :single t)
+ "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 limit 1")
+
+ (deftest :qrystr/7 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc))
+ "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc")
+
+ (deftest :qrystr/7e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc))
+ "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc")
+
+ (deftest :qrystr/8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl
+ :order (cui asc def desc))
+ "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc,DEF desc")
+
+ (deftest :qrystr/8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl
+ :order '(cui asc def desc))
+ "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc,DEF desc")
+
+ (deftest :ui/1 (umlisp::parse-cui "C0002341") 2341)
+ (deftest :ui/2 (umlisp::parse-lui "L0002341") 2341)
+ (deftest :ui/3 (umlisp::parse-sui "S0000000") 0)
+ (deftest :ui/4 (umlisp::parse-tui "T123") 123)
+ (deftest :ui/5 (fmt-cui 2341) "C0002341")
+ (deftest :ui/6 (fmt-lui 2341) "L0002341")
+ (deftest :ui/7 (fmt-sui 2341) "S0002341")
+ (deftest :ui/8 (fmt-tui 231) "T231")
+ (deftest :ui/9 (fmt-tui 231) "T231")
+ (deftest :ui/10 (fmt-eui 231) "E0000231")
+ (deftest :ui/11 (umlisp::make-cuisui 5 11) 50000011)
+ (deftest :ui/12 (umlisp::decompose-cuisui 50000011) 5 11)
+ (deftest :ui/13 (umlisp::parse-eui "E00002311") 2311)
+ (deftest :ui/14 (umlisp::parse-lui "1234") 1234)
+ (deftest :ui/15 (umlisp::parse-lui 1234) 1234)
+
+ ))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp-tests -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: basic.lisp
+;;;; Purpose: Basic tests for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: May 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-tests)
+
+(defvar *rt-basic* nil)
+(defvar *rt-parse* nil)
+(defvar *error-count* 0)
+(defvar *report-stream* *standard-output*)
+
+(setq regression-test::*catch-errors* nil)
+
+(defun run-tests ()
+ (regression-test:rem-all-tests)
+ (dolist (test-form (append *rt-basic* *rt-parse*))
+ (eval test-form))
+ (let ((remaining (regression-test:do-tests *report-stream*)))
+ (when (regression-test:pending-tests)
+ (incf *error-count* (length remaining))))
+ *error-count*)
(in-package #:cl-user)
(defpackage #:umlisp-tests
- (:use #:umlisp #:cl #:rtest #:kmrcl))
+ (:use #:umlisp #:cl #:rtest #:kmrcl)
+ (:export #:run-tests))
+
-(setf rtest::*catch-errors* nil)
(in-package #:umlisp-tests)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (if (probe-file (umlisp::umls-pathname "MRFILES"))
- (pushnew :umls-files cl:*features*)
- (format t "~&Skipping tests based on UMLS distribution~%")))
+ (import '(umlisp::*umls-files* umlisp::*umls-cols*)))
-(import '(umlisp::*umls-files* umlisp::*umls-cols*))
+(setq *rt-parse*
+ '(
+ (deftest :parse/1
+ (umlisp::decompose-fil "abc")
+ "abc" nil)
+
+ (deftest :parse/2
+ (umlisp::decompose-fil "dir/abc")
+ "abc" "dir")
+
+ (deftest :parse/3
+ (umlisp::decompose-fil nil)
+ nil nil)
+
+ (deftest :parse/4
+ (umlisp::filename-to-tablename "test")
+ "test")
+
+ (deftest :parse/5
+ (umlisp::filename-to-tablename "TEST.AB.RRF")
+ "TEST_AB")))
-#+umls-files
-(progn
+(when (probe-file (umlisp::umls-pathname "MRFILES.RRF"))
(umlisp::ensure-ucols+ufiles)
- (deftest uparse.1 (length *umls-files*) 52)
- (deftest uparse.2 (length *umls-cols*) 327)
- (deftest uparse.3
- (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCON")))
- #'string<)
- ("CUI" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LRL" "LUI" "STR"
- "STT" "SUI" "TS"))
- (deftest uparse.4
- (sort (umlisp::fields (umlisp::find-ufile "MRCON"))
- #'string<)
- ("CUI" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LRL" "LUI" "STR"
- "STT" "SUI" "TS"))
- (deftest uparse.5
- (sort
- (umlisp::custom-colnames-for-filename "MRCON")
- #'string<)
- ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR"))
- (deftest uparse.6
- (compiled-function-p
- (umlisp::custom-value-fun
- (umlisp::find-ucol "KCUISUI" "MRCON")))
- t)
- ) ;; umls-files
-
-#+umls-files
-(setq cl:*features* (delete :umls-files cl:*features*))
-
+ (setq
+ *rt-parse*
+ (append
+ *rt-parse*
+ '(
+ (deftest uparse.1 (length *umls-files*) 64)
+ (deftest uparse.2 (length *umls-cols*) 327)
+ (deftest uparse.3
+ (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF")))
+ #'string<)
+ ("AUI" "CODE" "CUI" "CVF" "ISPREF" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LUI" "SAB" "SAUI" "SCUI" "SDUI" "SRL" "STR"
+ "STT" "SUI" "SUPPRESS" "TS" "TTY"))
+ (deftest uparse.4
+ (equal
+ (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF")))
+ #'string<)
+ (sort (umlisp::fields (umlisp::find-ufile "MRCONSO.RRF"))
+ #'string<))
+ t)
+ (deftest uparse.5
+ (sort
+ (umlisp::custom-colnames-for-filename "MRCONSO.RRF")
+ #'string<)
+ ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR"))
+ (deftest uparse.6
+ (compiled-function-p
+ (umlisp::custom-value-fun
+ (umlisp::find-ucol "KCUISUI" "MRCONSO.RRF")))
+ t)
+ ))))
:depends-on (:rt :umlisp)
:components
((:module tests
+ :serial t
:components
((:file "package")
- (:file "basic" :depends-on ("package"))
- (:file "parse" :depends-on ("package"))))))
+ (:file "init")
+ (:file "basic")
+ (:file "parse")))))
-(defmethod perform ((o test-op) (c (eql (find-system :umlisp-tests))))
- (or (funcall (intern (symbol-name '#:do-tests)
- (find-package '#:regression-test)))
+(defmethod perform ((o test-op) (c (eql (find-system 'umlisp-tests))))
+ (or (funcall (intern (symbol-name '#:run-tests)
+ (find-package '#:umlisp-tests)))
(error "test-op failed")))
;;;; $Id$
;;;;
;;;; This file, part of UMLisp, is
-;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
;;;;
;;;; UMLisp users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU General Public License.
(:file "utils" :depends-on ("data-structures"))
(:file "sql" :depends-on ("utils"))
(:file "parse-macros" :depends-on ("sql"))
- (:file "parse-2002" :depends-on ("parse-macros"))
- (:file "parse-common" :depends-on ("parse-2002"))
+ (:file "parse-rrf" :depends-on ("parse-macros"))
+ (:file "parse-common" :depends-on ("parse-rrf"))
(:file "create-sql" :depends-on ("parse-common"))
(:file "sql-classes" :depends-on ("sql"))
(:file "classes" :depends-on ("sql-classes"))
:depends-on (clsql clsql-postgresql-socket kmrcl hyperobject))
#+(or allegro lispworks cmu sbcl openmcl scl)
-(defmethod perform ((o test-op) (c (eql (find-system :umlisp))))
- (oos 'load-op 'umlisp-tests)
- (oos 'test-op 'umlisp-tests))
+(defmethod perform ((o test-op) (c (eql (find-system 'umlisp))))
+ (operate 'load-op 'umlisp-tests)
+ (operate 'test-op 'umlisp-tests :force t))
(nth-value 0 (parse-integer tui))))
tui))
+(defun parse-aui (aui)
+ (declare (optimize (speed 3) (safety 0)))
+ (if (stringp aui)
+ (let ((ch (schar aui 0)))
+ (if (char-equal ch #\A)
+ (parse-ui aui)
+ (nth-value 0 (parse-integer aui))))
+ aui))
+
(defun parse-eui (eui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp eui)
eui))
(defconstant +cuisui-scale+ 10000000)
-(declaim (type fixnum +cuisui-scale+))
+(declaim (type (integer 0 10000000) +cuisui-scale+))
+
+#+64bit
+(defun make-cuisui (cui sui)
+ (declare (fixnum cui sui)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (the fixnum
+ (+ (the fixnum (* +cuisui-scale+ cui)) sui)))
+#-64bit
(defun make-cuisui (cui sui)
(declare (fixnum cui sui)
(optimize (speed 3) (safety 0) (space 0)))
(+ (* +cuisui-scale+ cui) sui))
+#+64bit
+(defun make-cuilui (cui lui)
+ (declare (fixnum cui lui)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (the fixnum
+ (+ (the fixnum (* +cuisui-scale+ cui)) lui)))
+
+#-64bit
(defun make-cuilui (cui lui)
(declare (fixnum cui lui)
(optimize (speed 3) (safety 0) (space 0)))
(defun decompose-cuisui (cuisui)
"Returns the CUI and SUI of a cuisui number"
+ #-64bit (declare (integer cuisui))
+ #+64bit (declare (fixnum cuisui))
(floor cuisui +cuisui-scale+))
;;; Lookup functions for uterms,ustr in ucons
projects / umlisp.git / commitdiff