;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: parse-common.lisp,v 1.2 2002/10/09 23:03:41 kevin Exp $
+;;;; $Id: parse-common.lisp,v 1.7 2003/05/06 07:17:35 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
;;;; as governed by the terms of the GNU General Public License.
;;;; *************************************************************************
-(in-package :umlisp)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+(in-package #:umlisp)
+
+(eval-when (:compile-toplevel)
+ (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
(defun umls-pathname (filename &optional (extension ""))
"Return pathname for a umls filename"
(pathname
filename)))
-(defun read-umls-line (strm)
+(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 (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)))
-
+ (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
(defun file-field-lengths (files)
(let ((lengths '()))
(dolist (file files)
- (setq file (umls-file-fil file))
+ (setq file (fil file))
(let (max-field count-field num-fields (count-lines 0))
(with-umls-file (fields file)
(unless num-fields
Currently, these are the LEX and NET files."
(let ((measure-files '()))
(dolist (file *umls-files*)
- (let ((filename (umls-file-fil file)))
+ (let ((filename (fil file)))
(unless (or (char= #\M (char filename 0))
(char= #\m (char filename 0)))
(push file measure-files))))
(av-field (caddr length-list))
(file (find-umls-file filename)))
(when file
- (if (/= (length max-field) (length (umls-file-fields file)))
+ (if (/= (length max-field) (length (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))))
+ (dotimes (i (max (length max-field) (length (fields file))))
(declare (fixnum i))
- (let* ((field (nth i (umls-file-fields file)))
+ (let* ((field (nth i (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))))
+ (setf (cmax col) (aref max-field i))
+ (setf (av col) (aref av-field i))
+ (add-datatype-to-col col (datatype-for-col (col col))))
(error "can't find column ~A" field)))))))))))
(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)))
+ (when (and (string-equal filename (fil col))
+ (string-equal colname (col col)))
(return-from find-col-in-columns col)))
nil)
(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
+ (let ((new-col (make-instance 'ucol
: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))))
+ :des (copy-seq (des col))
+ :ref (copy-seq (ref col))
+ :min (cmin col)
+ :max (cmax col)
+ :fil (copy-seq (fil col))
+ :sqltype (copy-seq (sqltype col))
+ :dty (copy-seq (dty col))
+ :parse-fun (parse-fun col)
+ :quotechar (copy-seq (quotechar col))
+ :datatype (datatype col)
+ :custom-value-fun (custom-value-fun 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
+ (let ((new-col (make-instance 'ucol
:col (copy-seq colname)
:des "Unknown"
:ref ""
:fil filename
:sqltype "VARCHAR"
:dty nil
- :parsefunc #'add-sql-quotes
+ :parse-fun #'add-sql-quotes
:quotechar "'"
:datatype nil
- :custom-value-func nil)))
+ :custom-value-fun nil)))
(push new-col *umls-cols*)
new-col))))))
(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*))
+ (find-if (lambda (f) (string-equal filename (fil f))) *umls-files*))
-(defun umls-cols-for-umls-file (file)
+(defun ucols-for-umls-file (file)
"Returns list of umls-cols for a file structure"
- (let ((filename (umls-file-fil file)))
+ (let ((filename (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)))
- ))
+ (fields file))))
-(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 #'>))))))
projects / umlisp.git / blobdiff