File: create-sql.lisp

package info (click to toggle)
cl-umlisp 1%3A2007ac.2-6
  • links: PTS, VCS
  • area: contrib
  • in suites: bookworm, bullseye, buster, jessie, jessie-kfreebsd, sid, stretch, wheezy
  • size: 296 kB
  • ctags: 418
  • sloc: lisp: 3,593; makefile: 55
file content (446 lines) | stat: -rw-r--r-- 17,308 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:     sql-create
;;;; Purpose:  Create SQL database for UMLisp
;;;; Author:   Kevin M. Rosenberg
;;;; Created:  Apr 2000
;;;;
;;;; $Id$
;;;;
;;;; This file, part of UMLisp, is
;;;;    Copyright (c) 2000-2006 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)

(defun create-table-cmd (file)
  "Return sql command to create a table"
  (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))))))
    (format nil "CREATE TABLE ~a (~{~a~^,~})~A~A"
            (table file)
            (mapcar col-func (ucols file))
            (if (and (eq *umls-sql-type* :mysql)
                     (string-equal (table file) "MRCXT"))
                " MAX_ROWS=200000000"
              "")
            (if (eq *umls-sql-type* :mysql)
                " TYPE=MYISAM CHARACTER SET utf8"
                ""))))

(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-col-value (col value)
  (if (null (parse-fun col))
      value
      (format nil "~A" (funcall (parse-fun col) value))))

(defun insert-values-cmd (file values)
  "Return sql insert command for a row of values"
  (let ((insert-func
         (lambda (col value)
           (concatenate 'string (quote-str col)
                        (insert-col-value col value)
                        (quote-str col)))))
    (format
     nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
     (table file)
     (fields file)
     (concat-separated-strings
      ","
      (mapcar insert-func (remove-custom-cols (ucols file)) values)
      (custom-col-values (custom-ucols-for-file file) values t)))))


(defun custom-col-value (col values doquote)
  (let ((custom-value (funcall (custom-value-fun col) values)))
    (if custom-value
        (if doquote
            (concatenate 'string (quote-str col)
                         (escape-backslashes custom-value)
                         (quote-str col))
            (escape-backslashes custom-value))
        "")))

(defun custom-col-values (ucols values doquote)
  "Returns a list of string column values for SQL inserts for custom columns"
  (loop for col in ucols collect (custom-col-value col values doquote)))

(defun remove-custom-cols (cols)
  "Remove custom cols from a list col umls-cols"
  (remove-if #'custom-value-fun 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-ucols-for-file (file)
  (remove-if-not #'custom-value-fun (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.RRF"))
                    (not (string-equal (fil f) "MRXW_NONENG.RRF"))))
   *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)"
          (concatenate 'string tablename "_" colname "_X")
          tablename
          (case *umls-sql-type*
            (:mysql
             (concatenate 'string colname
                          (if (integerp length)
                              (format nil " (~d)" length)
                              "")))
            ((:postgresql :postgresql-socket)
             ;; FIXME: incorrect syntax for postgresql?
             (if (integerp length)
                 (format nil "substr((~A)::text,1,~D)" colname length)
                 colname))
            (t
             colname))))

(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"
  (dolist (file *umls-files*)
    (ignore-errors
      (sql-execute (format nil "DROP TABLE ~a" (table file)) conn))))

(defun sql-create-tables (conn)
  "SQL Databases: create all tables"
  (dolist (file *umls-files*)
    (sql-execute (create-table-cmd file) conn)))

#+ignore
(defun sql-create-kcon-table (conn)
  "Create concept table, one row per concept."
  (ignore-errors (execute-command "DROP TABLE KCON" :database conn))
  (execute-command
   (format nil "CREATE TABLE KCON (CUI INTEGER, STR ~A, LRL ~A)"
           (case *umls-sql-type*
             (:oracle
              (format nil "VARCHAR2(~D)"
                      (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max)))
             (t "TEXT"))
           (case *umls-sql-type*
             (:mysql "TINYINT")
             ((:postgresql :postgresql-socket) "INT2")
             (:oracle "NUMBER(2,0)")
             (t "INTEGER")))
   :database conn)
  ;; KCON deprecated by KPFENG field in MRCONSO
  #+nil
  (dolist (tuple (query "select distinct cui from MRCONSO order by cui"
                        :database conn))
    (let ((cui (car tuple)))
      (execute-command
       (format nil "INSERT into KCON VALUES (~D,'~A',~D)"
               cui
               (add-sql-quotes (pfstr-hash cui) )
               (cui-lrl cui))
       :database conn))))

(defun sql-create-custom-tables (conn)
  "SQL Databases: create all custom tables"
  ;;(sql-create-kcon-table conn)
  (dolist (ct +custom-tables+)
    (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))

(defun sql-insert-values (conn file)
  "SQL Databases: inserts all values for a file"
  (with-umls-file (line (fil file))
    (sql-execute (insert-values-cmd file line) conn)))

(defun sql-insert-all-values (conn)
  "SQL Databases: inserts all values for all files"
  (dolist (file *umls-files*)
    (sql-insert-values conn file)))

(defun drop-index-cmd (colname tablename)
  "Return sql create index command"
  (case *umls-sql-type*
    (:mysql
     (format nil "DROP INDEX ~a ON ~a"
             (concatenate 'string tablename "_" colname "_X")
             tablename))
    (t
     (format nil "DROP INDEX ~a"
             (concatenate 'string tablename "_" colname "_X")))))

(defun sql-create-indexes (conn &key (indexes +index-cols+) verbose)
  "SQL Databases: create all indexes"
  (dolist (idx indexes)
    (when verbose (format t "UMLS Import: Creating index for column ~A on table ~A.~%"
                          (first idx) (second idx)))
    (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
    (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))

(defun make-usrl (conn)
  (if (eql :mysql *umls-sql-type*)
      (sql-execute "drop table if exists USRL" conn)
      (ignore-errors (sql-execute "drop table USRL" conn)))
  (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
  (dolist (tuple (mutex-sql-query
                  "select distinct SAB,SRL from MRCONSO order by SAB asc"))
    (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
                         (car tuple) (ensure-integer (cadr tuple)))
                 conn)))

(defun sql-create-special-tables (conn)
  (make-usrl conn)
  (make-ustats))

(defun create-umls-db-by-insert (&key verbose)
  "SQL Databases: initializes entire database via SQL insert commands"
  (ensure-ucols+ufiles)
  (ensure-preparse)
  (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 :indexes +custom-index-cols+ :verbose verbose)
    (sql-create-special-tables conn)))

(defun create-umls-db (&key (extension "-trans") (force-translation nil) (verbose nil))
  "SQL Databases: initializes entire database via SQL copy commands.
This is much faster that using create-umls-db-insert."
  (when verbose (format t "UMLS Import: Starting.~%"))
  (ensure-ucols+ufiles)
  (when verbose (format t "UMLS Import: Preparsing files.~%"))
  (ensure-preparse)
  (when verbose (format t "UMLS Import: Converting text UMLS files to optimized format.~%"))
  (translate-all-files :extension extension :verbose verbose :force force-translation)
  (let ((copy-cmd
         (ecase (umls-sql-type)
           (:mysql #'mysql-copy-cmd)
           (:postgresql #'pg-copy-cmd))))
    (with-sql-connection (conn)
      (clsql:truncate-database :database conn)
      (sql-drop-tables conn)
      (sql-create-tables conn)
      (dolist (file *umls-files*)
        (when verbose (format t "UMLS Import: Importing file ~A to SQL.~%" (fil file)))
        (sql-execute (funcall copy-cmd file extension) conn))
      (When verbose (format t "UMLS Import: Creating SQL indices.~%"))
      (sql-create-indexes conn :verbose verbose)
      (When verbose (format t "UMLS Import: Creating custom tables.~%"))
      (sql-create-custom-tables conn)
      (When verbose (format t "UMLS Import: Creating custom indices.~%"))
      (sql-create-indexes conn :indexes +custom-index-cols+ :verbose verbose)
      (When verbose (format t "UMLS Import: Creating special tables.~%"))
      (sql-create-special-tables conn)))
  (When verbose (format t "UMLS Import: Completed.~%"))
  t)

(defun translate-all-files (&key (extension "-trans") verbose force)
  "Translate all *umls-files* to optimized import format."
  (when verbose (format t "UMLS Import: Translating file ~A.~%" (fil (find-ufile "MRXW_NONENG.RRF"))))
  (make-noneng-index-file extension :force force)
  (dolist (f (remove "MRXW_NONENG.RRF" *umls-files* :test #'string= :key #'fil))
    (when verbose (format t "UMLS Import: Translating file ~A.~%" (fil f)))
    (translate-umls-file f extension :force force)))

(defun translate-umls-file (file extension &key force)
  "Translate a umls file into a format suitable for sql copy cmd"
  (translate-files file extension (list file) :force force))

(defun make-noneng-index-file (extension &key force)
  "Make non-english index file"
  (translate-files (find-ufile "MRXW_NONENG.RRF")
                   extension (noneng-lang-index-files) :force force))

(defun verify-translation-file (output-path input-ufiles)
  "Returns t if translation file exists and is correct size. Warns and deletes incomplete translation file."
  (when (probe-file output-path)
    (let ((translated-lines 0)
          (input-lines 0)
          (eof (cons nil nil)))
      (catch 'done-counting
        (with-open-file (ts output-path :direction :input
                            #+(and clisp unicode) :external-format
                            #+(and clisp unicode) charset:utf-8)
          (do ()
              ((eq (read-line ts nil eof) eof))
            (incf translated-lines)))
        (dolist (input-ufile input-ufiles)
          (with-umls-ufile (line input-ufile)
                           (incf input-lines)
                           (when (> input-lines translated-lines)
                             (throw 'done-counting 'incomplete)))))
      (cond
        ((< input-lines translated-lines)
          (format t "Translated file ~A incomplete, deleting...~%" output-path)
          (delete-file output-path)
          nil)
        ((eql input-lines translated-lines)
          (format t "Translated file ~A already exists: skipping...~%" output-path)
          t)
        ((eql input-lines 0)
          (warn "The number of input lines is 0 for output file ~A." output-path)
          nil)
        ((> translated-lines input-lines)
          (error "Shouldn't happen. Translated lines of ~A is ~D, greater than input lines ~D"
                 output-path translated-lines input-lines)
          (delete-file output-path)
          nil)))))

(defun translate-files (out-ufile extension input-ufiles &key force)
  "Translate a umls file into a format suitable for sql copy cmd"
  (let ((output-path (ufile-pathname out-ufile extension)))
    (when (and (not force) (verify-translation-file output-path input-ufiles))
      (return-from translate-files output-path))
    (with-open-file (ostream output-path :direction :output
                             :if-exists :overwrite
                             :if-does-not-exist :create
                             #+(and clisp unicode) :external-format
                             #+(and clisp unicode) charset:utf-8)
      (dolist (input-ufile input-ufiles)
        (with-umls-ufile (line input-ufile)
          (translate-line out-ufile line ostream)
          (princ #\newline ostream))))))

(defun translate-line (file line strm)
  "Translate a single line for sql output"
  (flet ((col-value (col value)
           (if (eq (datatype col) 'sql-u)
               (let ((ui (parse-ui value "")))
                 (if (stringp ui)
                     ui
                     (write-to-string ui)))
               (escape-backslashes value))))
    (print-separated-strings
     strm "|"
     (mapcar #'col-value (remove-custom-cols (ucols file)) line)
     (custom-col-values (custom-ucols-for-file file) line nil))))

(defun pg-copy-cmd (file extension)
  "Return postgresql copy statement for a file"
  (format
   nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
   (table file) (ufile-pathname file extension)))

(defun mysql-copy-cmd (file extension &key (local-file t))
  "Return mysql copy statement for a file"
  (format
   nil
   "LOAD DATA ~AINFILE '~a' INTO TABLE ~a FIELDS TERMINATED BY '|'"
   (if local-file "LOCAL " "")
   (namestring (ufile-pathname file extension)) (table file)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Routines for analyzing cost of fixed size storage
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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 (ucols file))
        (let* ((avwaste (- (cmax col) (av col)))
               (cwaste (* avwaste (rws file))))
          (when (plusp cwaste)
            (if (<= avwaste 6)
                (progn
                  (incf totalunavoidable cwaste)
                  (push (list (fil file) (col col)
                              avwaste cwaste)
                        unavoidable))
                (progn
                  (incf totalavoidable cwaste)
                  (push (list (fil file) (col col)
                              avwaste cwaste)
                        avoidable)))
            (incf totalwaste cwaste)))))
    (values totalwaste totalavoidable totalunavoidable
            (nreverse avoidable) (nreverse unavoidable))))

(defun display-waste ()
  (ensure-ucols+ufiles)
  (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)))
    ))

(defun max-umls-field ()
  "Return length of longest field"
  (declare (optimize (speed 3) (space 0)))
  (ensure-ucols+ufiles)
  (let ((max 0))
    (declare (type (integer 0 1000000) max))
    (dolist (ucol *umls-cols*)
      (when (> (the (integer 0 1000000) (cmax ucol)) max)
        (setq max (cmax ucol))))
    max))

(defun max-umls-row ()
  "Return length of longest row"
  (declare (optimize (speed 3) (space 0)))
  (ensure-ucols+ufiles)
  (let ((rowsizes '()))
    (dolist (file *umls-files*)
      (let ((row 0))
        (declare (type (integer 0 1000000) row))
        (dolist (ucol (ucols file))
          (let* ((col-max (cmax ucol))
                 (max-with-delim (1+ col-max)))
            (declare (type (integer 0 1000000) col-max max-with-delim))
            (incf row max-with-delim)))
        (push row rowsizes)))
    (car (sort rowsizes #'>))))