2 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
3 ;;;; *************************************************************************
4 ;;;; FILE IDENTIFICATION
7 ;;;; Purpose: Create SQL database for UMLisp
8 ;;;; Programmer: Kevin M. Rosenberg
9 ;;;; Date Started: Apr 2000
11 ;;;; $Id: sql-create.lisp,v 1.3 2002/10/21 08:23:52 kevin Exp $
13 ;;;; This file, part of UMLisp, is
14 ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
16 ;;;; UMLisp users are granted the rights to distribute and use this software
17 ;;;; as governed by the terms of the GNU General Public License.
18 ;;;; *************************************************************************
21 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
24 (defun create-table-cmd (file)
25 "Return sql command to create a table"
28 (let ((sqltype (umls-col-sqltype c)))
29 (concatenate 'string (umls-col-col c)
31 (if (or (string-equal sqltype "VARCHAR")
32 (string-equal sqltype "CHAR"))
33 (format nil "~a (~a)" sqltype (umls-col-max c))
36 (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
37 (string-trim-last-character
38 (mapcar-append-string col-func (umls-cols-for-umls-file file))))))
40 (defun create-custom-table-cmd (tablename sql-cmd)
41 "Return SQL command to create a custom table"
42 (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
44 (defun insert-values-cmd (file values)
45 "Return sql insert command for a row of values"
50 (umls-col-quotechar col)
51 (if (null (umls-col-parsefunc col))
53 (format nil "~A" (funcall (umls-col-parsefunc col) value)))
54 (umls-col-quotechar col)
57 nil "INSERT INTO ~a (~a) VALUES (~a)"
58 (umls-file-table file)
59 (string-trim-last-character
60 (mapcar-append-string (lambda (c) (concatenate 'string c ","))
61 (umls-file-fields file)))
62 (string-trim-last-character
64 (mapcar2-append-string insert-func
65 (remove-custom-cols (umls-file-colstructs file))
67 (custom-col-values (custom-colstructs-for-file file) values "," t)))
70 (defun custom-col-values (colstructs values delim doquote)
71 "Returns string of column values for SQL inserts for custom columns"
73 (dolist (col colstructs)
74 (let* ((func (umls-col-custom-value-func col))
75 (custom-value (funcall func values)))
77 (if doquote (umls-col-quotechar col))
78 (escape-backslashes custom-value)
79 (if doquote (umls-col-quotechar col))
83 (defun remove-custom-cols (cols)
84 "Remove custom cols from a list col umls-cols"
85 (remove-if #'umls-col-custom-value-func cols))
87 (defun find-custom-cols-for-filename (filename)
88 (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
90 (defun find-custom-col (filename col)
91 (find-if (lambda (x) (and (string-equal filename (car x))
92 (string-equal col (cadr x)))) +custom-cols+))
95 (defun custom-colnames-for-filename (filename)
96 (mapcar #'cadr (find-custom-cols-for-filename filename)))
98 (defun custom-colstructs-for-file (file)
99 (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
101 (defun noneng-lang-index-files ()
102 (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
103 (string-equal (umls-file-fil f) "MRXW." :end1 5)
104 (not (string-equal (umls-file-fil f) "MRXW.ENG"))
105 (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
108 ;;; SQL Command Functions
110 (defun create-index-cmd (colname tablename length)
111 "Return sql create index command"
112 (format nil "CREATE INDEX ~a ON ~a (~a ~a)"
113 (concatenate 'string tablename "_" colname "_X") tablename colname
114 (if (integerp length)
115 (format nil "(~d)" length)
118 (defun create-all-tables-cmdfile ()
119 "Return sql commands to create all tables. Not need for automated SQL import"
120 (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
123 ;; SQL Execution functions
125 (defun sql-drop-tables (conn)
126 "SQL Databases: drop all tables"
130 (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
133 (defun sql-create-tables (conn)
134 "SQL Databases: create all tables"
135 (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))
137 (defun sql-create-custom-tables (conn)
138 "SQL Databases: create all custom tables"
140 (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
143 (defun sql-insert-values (conn file)
144 "SQL Databases: inserts all values for a file"
145 (with-umls-file (line (umls-file-fil file))
146 (sql-execute (insert-values-cmd file line) conn)))
148 (defun sql-insert-all-values (conn)
149 "SQL Databases: inserts all values for all files"
150 (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))
152 (defun sql-create-indexes (conn &optional (indexes +index-cols+))
153 "SQL Databases: create all indexes"
156 (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))
159 (defun make-usrl (conn)
160 (sql-execute "drop table if exists USRL" conn)
161 (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
162 (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc"))
163 (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
164 (car tuple) (ensure-integer (cadr tuple)))
167 (defun sql-create-special-tables (conn)
170 (defun create-umls-db-by-insert ()
171 "SQL Databases: initializes entire database via SQL insert commands"
174 (with-sql-connection (conn)
175 (sql-drop-tables conn)
176 (sql-create-tables conn)
177 (sql-insert-all-values conn)
178 (sql-create-indexes conn)
179 (sql-create-custom-tables conn)
180 (sql-create-indexes conn +custom-index-cols+)
181 (sql-create-special-tables conn)))
183 (defun create-umls-db (&optional (extension ".trans")
184 (copy-cmd #'mysql-copy-cmd))
185 "SQL Databases: initializes entire database via SQL copy commands.
186 This is much faster that using create-umls-db-insert."
189 (translate-all-files extension)
190 (with-sql-connection (conn)
191 (sql-drop-tables conn)
192 (sql-create-tables conn)
194 #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn))
196 (sql-create-indexes conn)
197 (sql-create-custom-tables conn)
198 (sql-create-indexes conn +custom-index-cols+)
199 (sql-create-special-tables conn)))
201 (defun translate-all-files (&optional (extension ".trans"))
202 "Copy translated files and return postgresql copy commands to import"
203 (make-noneng-index-file extension)
204 (mapcar (lambda (f) (translate-file f extension)) *umls-files*))
206 (defun translate-file (file extension)
207 "Translate a umls file into a format suitable for sql copy cmd"
208 (let ((path (umls-pathname (umls-file-fil file) extension)))
209 (if (probe-file path)
211 (format t "File ~A already exists: skipping~%" path)
213 (with-open-file (ostream path :direction :output)
214 (with-umls-file (line (umls-file-fil file))
215 (princ (umls-translate file line) ostream)
216 (princ #\newline ostream))
219 (defun make-noneng-index-file (extension)
220 "Make non-english index file"
221 (let* ((outfile (find-umls-file "MRXW.NONENG"))
222 (path (umls-pathname (umls-file-fil outfile) extension)))
224 (if (probe-file path)
226 (format t "File ~A already exists: skipping~%" path)
229 (with-open-file (ostream path :direction :output)
230 (dolist (inputfile (noneng-lang-index-files))
231 (with-umls-file (line (umls-file-fil inputfile))
232 (princ (umls-translate outfile line) ostream) ;; use outfile for custom cols
233 (princ #\newline ostream))))
236 (defun pg-copy-cmd (file extension)
237 "Return postgresql copy statement for a file"
238 (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
239 (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
241 (defun mysql-copy-cmd (file extension)
242 "Return mysql copy statement for a file"
243 (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
244 (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
246 (defun umls-translate (file line)
247 "Translate a single line for sql output"
248 (string-trim-last-character
250 (mapcar2-append-string
254 (if (eq (umls-col-datatype col) 'sql-u)
255 (format nil "~d" (parse-ui value ""))
256 (escape-backslashes value))
258 (remove-custom-cols (umls-file-colstructs file))
260 (custom-col-values (custom-colstructs-for-file file) line "|" nil))))
263 ;;; Routines for analyzing cost of fixed size storage
266 (defun umls-fixed-size-waste ()
267 "Display storage waste if using all fixed size storage"
273 (dolist (file *umls-files*)
274 (dolist (col (umls-file-colstructs file))
275 (let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
276 (cwaste (* avwaste (umls-file-rws file))))
277 (unless (zerop cwaste)
280 (incf totalunavoidable cwaste)
281 (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
283 (incf totalavoidable cwaste)
284 (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
285 (incf totalwaste cwaste)))))
286 (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))
288 (defun display-waste ()
291 (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
292 (format t "Total waste: ~d~%" tw)
293 (format t "Total avoidable: ~d~%" ta)
294 (format t "Total unavoidable: ~d~%" tu)
295 (format t "Avoidable:~%")
297 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
298 (format t "Unavoidable:~%")
300 (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
303 (defun max-umls-field ()
304 "Return length of longest field"
308 (declare (fixnum max))
309 (dolist (col *umls-cols*)
310 (when (> (umls-col-max col) max)
311 (setq max (umls-col-max col))))
314 (defun max-umls-row ()
315 "Return length of longest row"
317 6000 ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
321 (let ((rowsizes '()))
322 (dolist (file *umls-files*)
324 (fields (umls-file-colstructs file)))
325 (dolist (field fields)
326 (incf row (1+ (umls-col-max field))))
327 (push row rowsizes)))
328 (car (sort rowsizes #'>))))))