1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Create SQL database for UMLisp
7 ;;;; Author: Kevin M. Rosenberg
10 ;;;; This file, part of UMLisp, is
11 ;;;; Copyright (c) 2000-2010 by Kevin M. Rosenberg, M.D.
13 ;;;; UMLisp users are granted the rights to distribute and use this software
14 ;;;; as governed by the terms of the GNU General Public License.
15 ;;;; *************************************************************************
19 (defun create-table-cmd (file)
20 "Return sql command to create a table"
23 (let ((sqltype (sqltype c)))
27 ((string-equal sqltype "VARCHAR")
28 (setq sqltype "VARCHAR2"))
29 ((string-equal sqltype "BIGINT")
30 (setq sqltype "VARCHAR2(20)")))))
35 (if (or (string-equal sqltype "VARCHAR")
36 (string-equal sqltype "CHAR"))
37 (format nil "~a (~a)" sqltype (cmax c))
39 (format nil "CREATE TABLE ~a (~{~a~^,~})~A~A"
41 (mapcar col-func (ucols file))
42 (if (and (eq *umls-sql-type* :mysql)
43 (string-equal (table file) "MRCXT"))
46 (if (eq *umls-sql-type* :mysql)
47 " TYPE=MYISAM CHARACTER SET utf8"
50 (defun create-custom-table-cmd (tablename sql-cmd)
51 "Return SQL command to create a custom table"
52 (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
54 (defun insert-col-value (col value)
55 (if (null (parse-fun col))
57 (format nil "~A" (funcall (parse-fun col) value))))
59 (defun insert-values-cmd (file values)
60 "Return sql insert command for a row of values"
63 (concatenate 'string (quote-str col)
64 (insert-col-value col value)
67 nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
70 (concat-separated-strings
72 (mapcar insert-func (remove-custom-cols (ucols file)) values)
73 (custom-col-values (custom-ucols-for-file file) values t)))))
76 (defun custom-col-value (col values doquote)
77 (let ((custom-value (funcall (custom-value-fun col) values)))
80 (concatenate 'string (quote-str col)
81 (escape-backslashes custom-value)
83 (escape-backslashes custom-value))
86 (defun custom-col-values (ucols values doquote)
87 "Returns a list of string column values for SQL inserts for custom columns"
88 (loop for col in ucols collect (custom-col-value col values doquote)))
90 (defun remove-custom-cols (cols)
91 "Remove custom cols from a list col umls-cols"
92 (remove-if #'custom-value-fun cols))
94 (defun find-custom-cols-for-filename (filename)
95 (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
97 (defun find-custom-col (filename col)
98 (find-if (lambda (x) (and (string-equal filename (car x))
99 (string-equal col (cadr x)))) +custom-cols+))
101 (defun custom-colnames-for-filename (filename)
102 (mapcar #'cadr (find-custom-cols-for-filename filename)))
104 (defun custom-ucols-for-file (file)
105 (remove-if-not #'custom-value-fun (ucols file)))
107 (defun noneng-lang-index-files ()
109 (lambda (f) (and (> (length (fil f)) 4)
110 (string-equal (fil f) "MRXW_" :end1 5)
111 (not (string-equal (fil f) "MRXW_ENG.RRF"))
112 (not (string-equal (fil f) "MRXW_NONENG.RRF"))))
115 ;;; SQL Command Functions
117 (defun create-index-cmd (colname tablename length)
118 "Return sql create index command"
119 (format nil "CREATE INDEX ~a ON ~a (~a)"
120 (concatenate 'string tablename "_" colname "_X")
122 (case *umls-sql-type*
124 (concatenate 'string colname
125 (if (integerp length)
126 (format nil " (~d)" length)
128 ((:postgresql :postgresql-socket)
129 ;; FIXME: incorrect syntax for postgresql?
130 (if (integerp length)
131 (format nil "substr((~A)::text,1,~D)" colname length)
136 (defun create-all-tables-cmdfile ()
137 "Return sql commands to create all tables. Not need for automated SQL import"
138 (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
140 ;; SQL Execution functions
142 (defun sql-drop-tables (conn)
143 "SQL Databases: drop all tables"
144 (dolist (file *umls-files*)
146 (sql-execute (format nil "DROP TABLE ~a" (table file)) conn))))
148 (defun sql-create-tables (conn)
149 "SQL Databases: create all tables"
150 (dolist (file *umls-files*)
151 (sql-execute (create-table-cmd file) conn)))
154 (defun sql-create-kcon-table (conn)
155 "Create concept table, one row per concept."
156 (ignore-errors (execute-command "DROP TABLE KCON" :database conn))
158 (format nil "CREATE TABLE KCON (CUI INTEGER, STR ~A, LRL ~A)"
159 (case *umls-sql-type*
161 (format nil "VARCHAR2(~D)"
162 (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max)))
164 (case *umls-sql-type*
166 ((:postgresql :postgresql-socket) "INT2")
167 (:oracle "NUMBER(2,0)")
170 ;; KCON deprecated by KPFENG field in MRCONSO
172 (dolist (tuple (query "select distinct cui from MRCONSO order by cui"
174 (let ((cui (car tuple)))
176 (format nil "INSERT into KCON VALUES (~D,'~A',~D)"
178 (add-sql-quotes (pfstr-hash cui) )
182 (defun sql-create-custom-tables (conn)
183 "SQL Databases: create all custom tables"
184 ;;(sql-create-kcon-table conn)
185 (dolist (ct +custom-tables+)
186 (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
188 (defun sql-insert-values (conn file)
189 "SQL Databases: inserts all values for a file"
190 (with-umls-file (line (fil file))
191 (sql-execute (insert-values-cmd file line) conn)))
193 (defun sql-insert-all-values (conn)
194 "SQL Databases: inserts all values for all files"
195 (dolist (file *umls-files*)
196 (sql-insert-values conn file)))
198 (defun drop-index-cmd (colname tablename)
199 "Return sql create index command"
200 (case *umls-sql-type*
202 (format nil "DROP INDEX ~a ON ~a"
203 (concatenate 'string tablename "_" colname "_X")
206 (format nil "DROP INDEX ~a"
207 (concatenate 'string tablename "_" colname "_X")))))
209 (defun sql-create-indexes-mysql (conn indexes verbose)
212 (dolist (idx indexes)
213 (pushnew (second idx) tables :test 'string-equal)
214 (let ((table-col (find (second idx) table-cols :key 'car :test 'string-equal)))
216 (vector-push-extend (cons (first idx) (third idx)) (second table-col))
217 (push (list (second idx) (make-array (list 1) :initial-contents (list (cons (first idx) (third idx)))
218 :adjustable t :fill-pointer 1))
220 (dolist (table tables)
221 (let ((table-col (find table table-cols :key 'car :test 'string-equal))
223 (str (format nil "ALTER TABLE ~A" table)))
224 (loop for col across (second table-col)
226 (let ((colname (car col))
228 (ignore-errors (sql-execute (drop-index-cmd colname table) conn))
229 (setq str (concatenate 'string
236 (format nil "ADD INDEX ~A (~A)"
237 (concatenate 'string table "_" colname "_X")
240 (if (integerp length)
241 (format nil " (~d)" length)
244 (format t "UMLS Import: Creating indexes for columns ~A on table ~A.~%"
245 (mapcar 'car (coerce (second table-col) 'list)) table))
247 (sql-execute str conn))
250 (defun sql-create-indexes (conn &key (indexes +index-cols+) verbose)
251 "SQL Databases: create all indexes"
252 (if (eql :mysql *umls-sql-type*)
253 (sql-create-indexes-mysql conn indexes verbose)
254 (dolist (idx indexes)
255 (when verbose (format t "UMLS Import: Creating index for column ~A on table ~A.~%"
256 (first idx) (second idx)))
257 (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
258 (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))))
260 (defun make-usrl (conn)
261 (if (eql :mysql *umls-sql-type*)
262 (sql-execute "drop table if exists USRL" conn)
263 (ignore-errors (sql-execute "drop table USRL" conn)))
264 (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
265 (dolist (tuple (mutex-sql-query
266 "select distinct SAB,SRL from MRCONSO order by SAB asc"))
267 (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
268 (car tuple) (ensure-integer (cadr tuple)))
271 (defun sql-create-special-tables (conn)
275 (defun create-umls-db-by-insert (&key verbose)
276 "SQL Databases: initializes entire database via SQL insert commands"
277 (ensure-ucols+ufiles)
279 (with-sql-connection (conn)
280 (sql-drop-tables conn)
281 (sql-create-tables conn)
282 (sql-insert-all-values conn)
283 (sql-create-indexes conn)
284 (sql-create-custom-tables conn)
285 (sql-create-indexes conn :indexes +custom-index-cols+ :verbose verbose)
286 (sql-create-special-tables conn)))
288 (defun create-umls-db (&key (extension "-trans") (force-translation nil) (verbose nil))
289 "SQL Databases: initializes entire database via SQL copy commands.
290 This is much faster that using create-umls-db-insert."
291 (when verbose (format t "UMLS Import: Starting.~%"))
292 (ensure-ucols+ufiles)
293 (when verbose (format t "UMLS Import: Preparsing files.~%"))
295 (when verbose (format t "UMLS Import: Converting text UMLS files to optimized format.~%"))
296 (translate-all-files :extension extension :verbose verbose :force force-translation)
298 (ecase (umls-sql-type)
299 (:mysql #'mysql-copy-cmd)
300 (:postgresql #'pg-copy-cmd))))
301 (with-sql-connection (conn)
302 (clsql:truncate-database :database conn)
303 (sql-drop-tables conn)
304 (sql-create-tables conn)
305 (dolist (file *umls-files*)
306 (when verbose (format t "UMLS Import: Importing file ~A to SQL.~%" (fil file)))
307 (sql-execute (funcall copy-cmd file extension) conn))
308 (when verbose (format t "UMLS Import: Creating SQL indices.~%"))
309 (sql-create-indexes conn :verbose verbose)
310 (when verbose (format t "UMLS Import: Creating custom tables.~%"))
311 (sql-create-custom-tables conn)
312 (when verbose (format t "UMLS Import: Creating custom indices.~%"))
313 (sql-create-indexes conn :indexes +custom-index-cols+ :verbose verbose)
314 (when verbose (format t "UMLS Import: Creating special tables.~%"))
315 (sql-create-special-tables conn)))
316 (when verbose (format t "UMLS Import: Completed.~%"))
319 (defun translate-all-files (&key (extension "-trans") verbose force)
320 "Translate all *umls-files* to optimized import format."
321 (when verbose (format t "UMLS Import: Translating file ~A.~%" (fil (find-ufile "MRXW_NONENG.RRF"))))
322 (make-noneng-index-file extension :force force)
323 (dolist (f (remove "MRXW_NONENG.RRF" *umls-files* :test #'string= :key #'fil))
324 (when verbose (format t "UMLS Import: Translating file ~A.~%" (fil f)))
325 (translate-umls-file f extension :force force)))
327 (defun translate-umls-file (file extension &key force)
328 "Translate a umls file into a format suitable for sql copy cmd"
329 (translate-files file extension (list file) :force force))
331 (defun make-noneng-index-file (extension &key force)
332 "Make non-english index file"
333 (translate-files (find-ufile "MRXW_NONENG.RRF")
334 extension (noneng-lang-index-files) :force force))
336 (defun verify-translation-file (output-path input-ufiles)
337 "Returns t if translation file exists and is correct size. Warns and deletes incomplete translation file."
338 (when (probe-file output-path)
339 (let ((translated-lines 0)
341 (eof (cons nil nil)))
342 (catch 'done-counting
343 (with-open-file (ts output-path :direction :input
344 #+(and sbcl sb-unicode) :external-format
345 #+(and sbcl sb-unicode) :UTF-8
346 #+(and allegro ics) :external-format
347 #+(and allegro ics) :UTF-8
348 #+lispworks :external-format
350 #+(and clisp unicode) :external-format
351 #+(and clisp unicode) charset:utf-8)
352 (do ((c (read-char ts nil eof) (read-char ts nil eof)))
354 (when (eql c #\newline)
355 (incf translated-lines))))
356 (dolist (input-ufile input-ufiles)
357 (with-umls-ufile (line input-ufile)
359 (when (> input-lines translated-lines)
360 (throw 'done-counting 'incomplete)))))
362 ((< input-lines translated-lines)
363 (format t "Translated file ~A incomplete, deleting...~%" output-path)
364 (delete-file output-path)
366 ((eql input-lines translated-lines)
367 (format t "Translated file ~A already exists: skipping...~%" output-path)
370 (warn "The number of input lines is 0 for output file ~A." output-path)
372 ((> translated-lines input-lines)
373 (error "Shouldn't happen. Translated lines of ~A is ~D, greater than input lines ~D"
374 output-path translated-lines input-lines)
375 (delete-file output-path)
378 (defun translate-files (out-ufile extension input-ufiles &key force)
379 "Translate a umls file into a format suitable for sql copy cmd"
380 (let ((output-path (ufile-pathname out-ufile extension)))
381 (when (and (not force) (verify-translation-file output-path input-ufiles))
382 (return-from translate-files output-path))
383 (with-open-file (ostream output-path :direction :output
384 :if-exists :overwrite
385 :if-does-not-exist :create
386 #+(and sbcl sb-unicode) :external-format
387 #+(and sbcl sb-unicode) :UTF-8
388 #+(and allegro ics) :external-format
389 #+(and allegro ics) :UTF-8
390 #+lispworks :external-format
392 #+(and clisp unicode) :external-format
393 #+(and clisp unicode) charset:utf-8)
394 (dolist (input-ufile input-ufiles)
395 (with-umls-ufile (line input-ufile)
396 (translate-line out-ufile line ostream)
397 (princ #\newline ostream))))))
399 (defun translate-line (file line strm)
400 "Translate a single line for sql output"
401 (flet ((col-value (col value)
402 (if (eq (datatype col) 'sql-u)
403 (let ((ui (parse-ui value "")))
406 (write-to-string ui)))
407 (escape-backslashes value))))
408 (print-separated-strings
410 (mapcar #'col-value (remove-custom-cols (ucols file)) line)
411 (custom-col-values (custom-ucols-for-file file) line nil))))
413 (defun pg-copy-cmd (file extension)
414 "Return postgresql copy statement for a file"
416 nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
417 (table file) (ufile-pathname file extension)))
419 (defun mysql-copy-cmd (file extension &key (local-file t))
420 "Return mysql copy statement for a file"
423 "LOAD DATA ~AINFILE '~a' INTO TABLE ~a FIELDS TERMINATED BY '|'"
424 (if local-file "LOCAL " "")
425 (namestring (ufile-pathname file extension)) (table file)))
428 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
430 ;;; Routines for analyzing cost of fixed size storage
432 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
434 (defun umls-fixed-size-waste ()
435 "Display storage waste if using all fixed size storage"
441 (dolist (file *umls-files*)
442 (dolist (col (ucols file))
443 (let* ((avwaste (- (cmax col) (av col)))
444 (cwaste (* avwaste (rws file))))
448 (incf totalunavoidable cwaste)
449 (push (list (fil file) (col col)
453 (incf totalavoidable cwaste)
454 (push (list (fil file) (col col)
457 (incf totalwaste cwaste)))))
458 (values totalwaste totalavoidable totalunavoidable
459 (nreverse avoidable) (nreverse unavoidable))))
461 (defun display-waste ()
462 (ensure-ucols+ufiles)
463 (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
464 (format t "Total waste: ~d~%" tw)
465 (format t "Total avoidable: ~d~%" ta)
466 (format t "Total unavoidable: ~d~%" tu)
467 (format t "Avoidable:~%")
469 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
470 (format t "Unavoidable:~%")
472 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
475 (defun max-umls-field ()
476 "Return length of longest field"
477 (declare (optimize (speed 3) (space 0)))
478 (ensure-ucols+ufiles)
480 (declare (type (integer 0 1000000) max))
481 (dolist (ucol *umls-cols*)
482 (when (> (the (integer 0 1000000) (cmax ucol)) max)
483 (setq max (cmax ucol))))
486 (defun max-umls-row ()
487 "Return length of longest row"
488 (declare (optimize (speed 3) (space 0)))
489 (ensure-ucols+ufiles)
490 (let ((rowsizes '()))
491 (dolist (file *umls-files*)
493 (declare (type (integer 0 1000000) row))
494 (dolist (ucol (ucols file))
495 (let* ((col-max (cmax ucol))
496 (max-with-delim (1+ col-max)))
497 (declare (type (integer 0 1000000) col-max max-with-delim))
498 (incf row max-with-delim)))
499 (push row rowsizes)))
500 (car (sort rowsizes #'>))))