1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Create SQL database for UMLisp
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: sql-create.lisp,v 1.7 2003/05/05 23:13:28 kevin Exp $
12 ;;;; This file, part of UMLisp, is
13 ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
15 ;;;; UMLisp users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the GNU General Public License.
17 ;;;; *************************************************************************
20 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
23 (defun create-table-cmd-old (file)
24 "Return sql command to create a table"
27 (let ((sqltype (umls-col-sqltype c)))
28 (concatenate 'string (umls-col-col c)
30 (if (or (string-equal sqltype "VARCHAR")
31 (string-equal sqltype "CHAR"))
32 (format nil "~a (~a)" sqltype (umls-col-max c))
35 (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
36 (string-trim-last-character
37 (mapcar-append-string col-func (umls-cols-for-umls-file file))))))
40 (defun create-table-cmd (file)
41 "Return sql command to create a table"
44 (let ((sqltype (umls-col-sqltype c)))
48 (if (or (string-equal sqltype "VARCHAR")
49 (string-equal sqltype "CHAR"))
50 (format nil "~a (~a)" sqltype (umls-col-max c))
52 (format nil "CREATE TABLE ~a (~{~a~^,~})" (umls-file-table file)
53 (mapcar col-func (umls-cols-for-umls-file file)))))
55 (defun create-custom-table-cmd (tablename sql-cmd)
56 "Return SQL command to create a custom table"
57 (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
59 (defun insert-values-cmd-old (file values)
60 "Return sql insert command for a row of values"
65 (umls-col-quotechar col)
66 (if (null (umls-col-parsefunc col))
68 (format nil "~A" (funcall (umls-col-parsefunc col) value)))
69 (umls-col-quotechar col)
72 nil "INSERT INTO ~a (~a) VALUES (~a)"
73 (umls-file-table file)
74 (string-trim-last-character
75 (mapcar-append-string (lambda (c) (concatenate 'string c ","))
76 (umls-file-fields file)))
77 (string-trim-last-character
79 (mapcar2-append-string insert-func
80 (remove-custom-cols (umls-file-colstructs file))
82 (custom-col-values-old (custom-colstructs-for-file file) values "," t)))
85 (defun insert-col-value (col value)
86 (if (null (umls-col-parsefunc col))
88 (format nil "~A" (funcall (umls-col-parsefunc col) value))))
90 (defun insert-values-cmd (file values)
91 "Return sql insert command for a row of values"
94 (let ((q (umls-col-quotechar col)))
95 (concatenate 'string q (insert-col-value col value) q)))))
97 nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
98 (umls-file-table file)
99 (umls-file-fields file)
100 (concat-separated-strings
102 (mapcar insert-func (remove-custom-cols (umls-file-colstructs file)) values)
103 (custom-col-values (custom-colstructs-for-file file) values t)))))
105 (defun custom-col-values-old (colstructs values delim doquote)
106 "Returns a string of column values for SQL inserts for custom columns"
108 (dolist (col colstructs)
109 (let* ((func (umls-col-custom-value-func col))
110 (custom-value (funcall func values)))
111 (string-append result
112 (if doquote (umls-col-quotechar col))
113 (escape-backslashes custom-value)
114 (if doquote (umls-col-quotechar col))
118 (defun custom-col-value (col doquote values)
119 (let ((custom-value (funcall (umls-col-custom-value-func col) values)))
121 (let ((q (umls-col-quotechar col)))
122 (concatenate 'string q (escape-backslashes custom-value) q))
123 (escape-backslashes custom-value))))
125 (defun custom-col-values (colstructs values doquote)
126 "Returns a list of string column values for SQL inserts for custom columns"
127 (loop for col in colstructs collect (custom-col-value col doquote values)))
130 (defun remove-custom-cols (cols)
131 "Remove custom cols from a list col umls-cols"
132 (remove-if #'umls-col-custom-value-func cols))
134 (defun find-custom-cols-for-filename (filename)
135 (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
137 (defun find-custom-col (filename col)
138 (find-if (lambda (x) (and (string-equal filename (car x))
139 (string-equal col (cadr x)))) +custom-cols+))
142 (defun custom-colnames-for-filename (filename)
143 (mapcar #'cadr (find-custom-cols-for-filename filename)))
145 (defun custom-colstructs-for-file (file)
146 (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
148 (defun noneng-lang-index-files ()
149 (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
150 (string-equal (umls-file-fil f) "MRXW." :end1 5)
151 (not (string-equal (umls-file-fil f) "MRXW.ENG"))
152 (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
155 ;;; SQL Command Functions
157 (defun create-index-cmd (colname tablename length)
158 "Return sql create index command"
159 (format nil "CREATE INDEX ~a ON ~a (~a ~a)"
160 (concatenate 'string tablename "_" colname "_X") tablename colname
161 (if (integerp length)
162 (format nil "(~d)" length)
165 (defun create-all-tables-cmdfile ()
166 "Return sql commands to create all tables. Not need for automated SQL import"
167 (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
170 ;; SQL Execution functions
172 (defun sql-drop-tables (conn)
173 "SQL Databases: drop all tables"
177 (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
180 (defun sql-create-tables (conn)
181 "SQL Databases: create all tables"
182 (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))
184 (defun sql-create-custom-tables (conn)
185 "SQL Databases: create all custom tables"
187 (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
190 (defun sql-insert-values (conn file)
191 "SQL Databases: inserts all values for a file"
192 (with-umls-file (line (umls-file-fil file))
193 (sql-execute (insert-values-cmd file line) conn)))
195 (defun sql-insert-all-values (conn)
196 "SQL Databases: inserts all values for all files"
197 (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))
199 (defun sql-create-indexes (conn &optional (indexes +index-cols+))
200 "SQL Databases: create all indexes"
203 (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))
206 (defun make-usrl (conn)
207 (sql-execute "drop table if exists USRL" conn)
208 (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
209 (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc"))
210 (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
211 (car tuple) (ensure-integer (cadr tuple)))
214 (defun sql-create-special-tables (conn)
217 (defun create-umls-db-by-insert ()
218 "SQL Databases: initializes entire database via SQL insert commands"
221 (with-sql-connection (conn)
222 (sql-drop-tables conn)
223 (sql-create-tables conn)
224 (sql-insert-all-values conn)
225 (sql-create-indexes conn)
226 (sql-create-custom-tables conn)
227 (sql-create-indexes conn +custom-index-cols+)
228 (sql-create-special-tables conn)))
230 (defun create-umls-db (&optional (extension ".trans")
231 (copy-cmd #'mysql-copy-cmd))
232 "SQL Databases: initializes entire database via SQL copy commands.
233 This is much faster that using create-umls-db-insert."
236 (translate-all-files extension)
237 (with-sql-connection (conn)
238 (sql-drop-tables conn)
239 (sql-create-tables conn)
241 #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn))
243 (sql-create-indexes conn)
244 (sql-create-custom-tables conn)
245 (sql-create-indexes conn +custom-index-cols+)
246 (sql-create-special-tables conn)))
248 (defun translate-all-files (&optional (extension ".trans"))
249 "Copy translated files and return postgresql copy commands to import"
250 (make-noneng-index-file extension)
251 (map 'nil (lambda (f) (translate-file f extension)) *umls-files*))
253 (defun translate-file (file extension)
254 "Translate a umls file into a format suitable for sql copy cmd"
255 (let ((path (umls-pathname (umls-file-fil file) extension)))
256 (if (probe-file path)
258 (format t "File ~A already exists: skipping~%" path)
260 (with-open-file (ostream path :direction :output)
261 (with-umls-file (line (umls-file-fil file))
262 (umls-translate file line ostream)
263 (princ #\newline ostream))
266 (defun make-noneng-index-file (extension)
267 "Make non-english index file"
268 (let* ((outfile (find-umls-file "MRXW.NONENG"))
269 (path (umls-pathname (umls-file-fil outfile) extension)))
271 (if (probe-file path)
273 (format t "File ~A already exists: skipping~%" path)
276 (with-open-file (ostream path :direction :output)
277 (dolist (inputfile (noneng-lang-index-files))
278 (with-umls-file (line (umls-file-fil inputfile))
279 (umls-translate outfile line ostream) ;; use outfile for custom cols
280 (princ #\newline ostream))))
283 (defun pg-copy-cmd (file extension)
284 "Return postgresql copy statement for a file"
285 (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
286 (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
288 (defun mysql-copy-cmd (file extension)
289 "Return mysql copy statement for a file"
290 (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
291 (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
293 (defun umls-translate-old (file line)
294 "Translate a single line for sql output"
295 (string-trim-last-character
297 (mapcar2-append-string
301 (if (eq (umls-col-datatype col) 'sql-u)
302 (format nil "~d" (parse-ui value ""))
303 (escape-backslashes value))
305 (remove-custom-cols (umls-file-colstructs file))
307 (custom-col-values-old (custom-colstructs-for-file file) line "|" nil))))
309 (defun concat-separated-strings (separator &rest lists)
310 (format nil (format nil "~~{~~A~~^~A~~}" separator) (mapappend #'identity lists)))
312 (defun print-separated-strings (strm separator &rest lists)
313 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) (compilation-speed 0)))
314 (do* ((rest-lists lists (cdr rest-lists))
315 (list (car rest-lists) (car rest-lists))
316 (last-list (null (cdr rest-lists)) (null (cdr rest-lists))))
318 (do* ((lst list (cdr lst))
319 (elem (car lst) (car lst))
320 (last-elem (null (cdr lst)) (null (cdr lst))))
322 (write-string elem strm)
323 (unless (and last-elem last-list)
324 (write-string separator strm)))))
326 (defun col-value (col value)
327 (if (eq (umls-col-datatype col) 'sql-u)
328 (write-to-string (parse-ui value ""))
329 (escape-backslashes value)))
331 (defun umls-translate (file line strm)
332 "Translate a single line for sql output"
333 (print-separated-strings
335 (mapcar #'col-value (remove-custom-cols (umls-file-colstructs file)) line)
336 (custom-col-values (custom-colstructs-for-file file) line nil)))
339 ;;; Routines for analyzing cost of fixed size storage
342 (defun umls-fixed-size-waste ()
343 "Display storage waste if using all fixed size storage"
349 (dolist (file *umls-files*)
350 (dolist (col (umls-file-colstructs file))
351 (let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
352 (cwaste (* avwaste (umls-file-rws file))))
353 (unless (zerop cwaste)
356 (incf totalunavoidable cwaste)
357 (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
359 (incf totalavoidable cwaste)
360 (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
361 (incf totalwaste cwaste)))))
362 (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))
364 (defun display-waste ()
367 (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
368 (format t "Total waste: ~d~%" tw)
369 (format t "Total avoidable: ~d~%" ta)
370 (format t "Total unavoidable: ~d~%" tu)
371 (format t "Avoidable:~%")
373 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
374 (format t "Unavoidable:~%")
376 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
379 (defun max-umls-field ()
380 "Return length of longest field"
384 (declare (fixnum max))
385 (dolist (col *umls-cols*)
386 (when (> (umls-col-max col) max)
387 (setq max (umls-col-max col))))
390 (defun max-umls-row ()
391 "Return length of longest row"
393 6000 ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
397 (let ((rowsizes '()))
398 (dolist (file *umls-files*)
400 (fields (umls-file-colstructs file)))
401 (dolist (field fields)
402 (incf row (1+ (umls-col-max field))))
403 (push row rowsizes)))
404 (car (sort rowsizes #'>))))))