create-sql.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     sql-create
   6 ;;;; Purpose:  Create SQL database for UMLisp
   7 ;;;; Author:   Kevin M. Rosenberg
   8 ;;;; Created:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of UMLisp, is
  13 ;;;;    Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D.
  14 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (in-package #:umlisp)
  20
  21 (defun create-table-cmd (file)
  22   "Return sql command to create a table"
  23   (let ((col-func
  24          (lambda (c)
  25            (let ((sqltype (sqltype c)))
  26              (case *umls-sql-type*
  27                (:oracle
  28                 (cond
  29                  ((string-equal sqltype "VARCHAR")
  30                   (setq sqltype "VARCHAR2"))
  31                  ((string-equal sqltype "BIGINT")
  32                   (setq sqltype "VARCHAR2(20)")))))
  33
  34              (concatenate 'string
  35                (col c)
  36                " "
  37                (if (or (string-equal sqltype "VARCHAR")
  38                        (string-equal sqltype "CHAR"))
  39                    (format nil "~a (~a)" sqltype (cmax c))
  40                  sqltype))))))
  41     (format nil "CREATE TABLE ~a (~{~a~^,~})~A~A"
  42             (table file)
  43             (mapcar col-func (ucols file))
  44             (if (and (eq *umls-sql-type* :mysql)
  45                      (string-equal (table file) "MRCXT"))
  46                 " MAX_ROWS=200000000"
  47               "")
  48             (if (eq *umls-sql-type* :mysql)
  49                 " TYPE=MYISAM CHARACTER SET utf8"
  50                 ""))))
  51
  52 (defun create-custom-table-cmd (tablename sql-cmd)
  53   "Return SQL command to create a custom table"
  54   (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
  55
  56 (defun insert-col-value (col value)
  57   (if (null (parse-fun col))
  58       value
  59       (format nil "~A" (funcall (parse-fun col) value))))
  60
  61 (defun insert-values-cmd (file values)
  62   "Return sql insert command for a row of values"
  63   (let ((insert-func
  64          (lambda (col value)
  65            (concatenate 'string (quote-str col)
  66                         (insert-col-value col value)
  67                         (quote-str col)))))
  68     (format
  69      nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
  70      (table file)
  71      (fields file)
  72      (concat-separated-strings
  73       ","
  74       (mapcar insert-func (remove-custom-cols (ucols file)) values)
  75       (custom-col-values (custom-ucols-for-file file) values t)))))
  76
  77
  78 (defun custom-col-value (col values doquote)
  79   (let ((custom-value (funcall (custom-value-fun col) values)))
  80     (if custom-value
  81         (if doquote
  82             (concatenate 'string (quote-str col)
  83                          (escape-backslashes custom-value)
  84                          (quote-str col))
  85             (escape-backslashes custom-value))
  86         "")))
  87
  88 (defun custom-col-values (ucols values doquote)
  89   "Returns a list of string column values for SQL inserts for custom columns"
  90   (loop for col in ucols collect (custom-col-value col values doquote)))
  91
  92 (defun remove-custom-cols (cols)
  93   "Remove custom cols from a list col umls-cols"
  94   (remove-if #'custom-value-fun cols))
  95
  96 (defun find-custom-cols-for-filename (filename)
  97   (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
  98
  99 (defun find-custom-col (filename col)
 100   (find-if (lambda (x) (and (string-equal filename (car x))
 101                             (string-equal col (cadr x)))) +custom-cols+))
 102
 103 (defun custom-colnames-for-filename (filename)
 104   (mapcar #'cadr (find-custom-cols-for-filename filename)))
 105
 106 (defun custom-ucols-for-file (file)
 107   (remove-if-not #'custom-value-fun (ucols file)))
 108
 109 (defun noneng-lang-index-files ()
 110   (remove-if-not
 111    (lambda (f) (and (> (length (fil f)) 4)
 112                     (string-equal (fil f) "MRXW_" :end1 5)
 113                     (not (string-equal (fil f) "MRXW_ENG.RRF"))
 114                     (not (string-equal (fil f) "MRXW_NONENG.RRF"))))
 115    *umls-files*))
 116
 117 ;;; SQL Command Functions
 118
 119 (defun create-index-cmd (colname tablename length)
 120   "Return sql create index command"
 121   (format nil "CREATE INDEX ~a ON ~a (~a)"
 122           (concatenate 'string tablename "_" colname "_X")
 123           tablename
 124           (case *umls-sql-type*
 125             (:mysql
 126              (concatenate 'string colname
 127                           (if (integerp length)
 128                               (format nil " (~d)" length)
 129                               "")))
 130             ((:postgresql :postgresql-socket)
 131              ;; FIXME: incorrect syntax for postgresql?
 132              (if (integerp length)
 133                  (format nil "substr((~A)::text,1,~D)" colname length)
 134                  colname))
 135             (t
 136              colname))))
 137
 138 (defun create-all-tables-cmdfile ()
 139   "Return sql commands to create all tables. Not need for automated SQL import"
 140   (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
 141
 142 ;; SQL Execution functions
 143
 144 (defun sql-drop-tables (conn)
 145   "SQL Databases: drop all tables"
 146   (dolist (file *umls-files*)
 147     (ignore-errors
 148       (sql-execute (format nil "DROP TABLE ~a" (table file)) conn))))
 149
 150 (defun sql-create-tables (conn)
 151   "SQL Databases: create all tables"
 152   (dolist (file *umls-files*)
 153     (sql-execute (create-table-cmd file) conn)))
 154
 155 #+ignore
 156 (defun sql-create-kcon-table (conn)
 157   "Create concept table, one row per concept."
 158   (ignore-errors (execute-command "DROP TABLE KCON" :database conn))
 159   (execute-command
 160    (format nil "CREATE TABLE KCON (CUI INTEGER, STR ~A, LRL ~A)"
 161            (case *umls-sql-type*
 162              (:oracle
 163               (format nil "VARCHAR2(~D)"
 164                       (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max)))
 165              (t "TEXT"))
 166            (case *umls-sql-type*
 167              (:mysql "TINYINT")
 168              ((:postgresql :postgresql-socket) "INT2")
 169              (:oracle "NUMBER(2,0)")
 170              (t "INTEGER")))
 171    :database conn)
 172   ;; KCON deprecated by KPFENG field in MRCONSO
 173   #+nil
 174   (dolist (tuple (query "select distinct cui from MRCONSO order by cui"
 175                         :database conn))
 176     (let ((cui (car tuple)))
 177       (execute-command
 178        (format nil "INSERT into KCON VALUES (~D,'~A',~D)"
 179                cui
 180                (add-sql-quotes (pfstr-hash cui) )
 181                (cui-lrl cui))
 182        :database conn))))
 183
 184 (defun sql-create-custom-tables (conn)
 185   "SQL Databases: create all custom tables"
 186   ;;(sql-create-kcon-table conn)
 187   (dolist (ct +custom-tables+)
 188     (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
 189
 190 (defun sql-insert-values (conn file)
 191   "SQL Databases: inserts all values for a file"
 192   (with-umls-file (line (fil file))
 193     (sql-execute (insert-values-cmd file line) conn)))
 194
 195 (defun sql-insert-all-values (conn)
 196   "SQL Databases: inserts all values for all files"
 197   (dolist (file *umls-files*)
 198     (sql-insert-values conn file)))
 199
 200 (defun drop-index-cmd (colname tablename)
 201   "Return sql create index command"
 202   (case *umls-sql-type*
 203     (:mysql
 204      (format nil "DROP INDEX ~a ON ~a"
 205              (concatenate 'string tablename "_" colname "_X")
 206              tablename))
 207     (t
 208      (format nil "DROP INDEX ~a"
 209              (concatenate 'string tablename "_" colname "_X")))))
 210
 211 (defun sql-create-indexes (conn &optional (indexes +index-cols+))
 212   "SQL Databases: create all indexes"
 213   (dolist (idx indexes)
 214     (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
 215     (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
 216
 217 (defun make-usrl (conn)
 218   (if (eql :mysql *umls-sql-type*)
 219       (sql-execute "drop table if exists USRL" conn)
 220       (ignore-errors (sql-execute "drop table USRL" conn)))
 221   (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
 222   (dolist (tuple (mutex-sql-query
 223                   "select distinct SAB,SRL from MRCONSO order by SAB asc"))
 224     (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
 225                          (car tuple) (ensure-integer (cadr tuple)))
 226                  conn)))
 227
 228 (defun sql-create-special-tables (conn)
 229   (make-usrl conn)
 230   (make-ustats))
 231
 232 (defun create-umls-db-by-insert ()
 233   "SQL Databases: initializes entire database via SQL insert commands"
 234   (ensure-ucols+ufiles)
 235   (ensure-preparse)
 236   (with-sql-connection (conn)
 237     (sql-drop-tables conn)
 238     (sql-create-tables conn)
 239     (sql-insert-all-values conn)
 240     (sql-create-indexes conn)
 241     (sql-create-custom-tables conn)
 242     (sql-create-indexes conn +custom-index-cols+)
 243     (sql-create-special-tables conn)))
 244
 245 (defun create-umls-db (&key (extension "-trans") (skip-translation nil))
 246   "SQL Databases: initializes entire database via SQL copy commands.
 247 This is much faster that using create-umls-db-insert."
 248   (ensure-ucols+ufiles)
 249   (ensure-preparse)
 250   (unless skip-translation
 251     (translate-all-files extension))
 252   (let ((copy-cmd
 253          (ecase (umls-sql-type)
 254            (:mysql #'mysql-copy-cmd)
 255            (:postgresql #'pg-copy-cmd))))
 256     (with-sql-connection (conn)
 257       (clsql:truncate-database :database conn)
 258       (sql-drop-tables conn)
 259       (sql-create-tables conn)
 260       (dolist (file *umls-files*)
 261         (sql-execute (funcall copy-cmd file extension) conn))
 262       (sql-create-indexes conn)
 263       (sql-create-custom-tables conn)
 264       (sql-create-indexes conn +custom-index-cols+)
 265       (sql-create-special-tables conn)))
 266   t)
 267
 268 (defun translate-all-files (&optional (extension "-trans"))
 269   "Copy translated files and return postgresql copy commands to import"
 270   (make-noneng-index-file extension)
 271   (dolist (f (remove "MRXW_NONENG.RRF" *umls-files* :test #'string= :key #'fil))
 272     (translate-umls-file f extension)))
 273
 274 (defun translate-umls-file (file extension)
 275   "Translate a umls file into a format suitable for sql copy cmd"
 276   (translate-files file extension (list file)))
 277
 278 (defun make-noneng-index-file (extension)
 279   "Make non-english index file"
 280   (translate-files (find-ufile "MRXW_NONENG.RRF")
 281                    extension (noneng-lang-index-files)))
 282
 283 (defun verify-translation-file (output-path input-ufiles)
 284   "Returns t if translation file exists and is correct size. Warns and deletes incomplete translation file."
 285   (when (probe-file output-path)
 286     (let ((translated-lines 0)
 287           (input-lines 0)
 288           (eof (cons nil nil)))
 289       (catch 'done-counting
 290         (with-open-file (ts output-path :direction :input
 291                             #+(and clisp unicode) :external-format
 292                             #+(and clisp unicode) charset:utf-8)
 293           (do ()
 294               ((eq (read-line ts nil eof) eof))
 295             (incf translated-lines)))
 296         (dolist (input-ufile input-ufiles)
 297           (with-umls-ufile (line input-ufile)
 298             (incf input-lines)
 299             (when (> input-lines translated-lines)
 300               (throw 'done-counting 'incomplete)))))
 301       (cond
 302         ((eql input-lines 0)
 303           (error "Input lines is 0")
 304           nil)
 305         ((< input-lines translated-lines)
 306           (format t "Translated file ~A incomplete, deleting...~%" output-path)
 307           (delete-file output-path)
 308           nil)
 309         ((eql input-lines translated-lines)
 310           (format t "Translated file ~A already exists: skipping...~%" output-path)
 311           t)
 312         ((> translated-lines input-lines)
 313           (error "Shouldn't happen. Translated lines of ~A is ~D, greater than input lines ~D"
 314                  output-path translated-lines input-lines)
 315           (delete-file output-path)
 316           nil)))))
 317
 318 (defun translate-files (out-ufile extension input-ufiles)
 319   "Translate a umls file into a format suitable for sql copy cmd"
 320   (let ((output-path (ufile-pathname out-ufile extension)))
 321     (when (verify-translation-file output-path input-ufiles)
 322       (return-from translate-files output-path))
 323     (with-open-file (ostream output-path :direction :output
 324                              #+(and clisp unicode) :external-format
 325                              #+(and clisp unicode) charset:utf-8)
 326       (dolist (input-ufile input-ufiles)
 327         (with-umls-ufile (line input-ufile)
 328           (translate-line out-ufile line ostream)
 329           (princ #\newline ostream))))))
 330
 331 (defun translate-line (file line strm)
 332   "Translate a single line for sql output"
 333   (flet ((col-value (col value)
 334            (if (eq (datatype col) 'sql-u)
 335                (let ((ui (parse-ui value "")))
 336                  (if (stringp ui)
 337                      ui
 338                      (write-to-string ui)))
 339                (escape-backslashes value))))
 340     (print-separated-strings
 341      strm "|"
 342      (mapcar #'col-value (remove-custom-cols (ucols file)) line)
 343      (custom-col-values (custom-ucols-for-file file) line nil))))
 344
 345 (defun pg-copy-cmd (file extension)
 346   "Return postgresql copy statement for a file"
 347   (format
 348    nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
 349    (table file) (ufile-pathname file extension)))
 350
 351 (defun mysql-copy-cmd (file extension &key (local-file t))
 352   "Return mysql copy statement for a file"
 353   (format
 354    nil
 355    "LOAD DATA ~AINFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
 356    (if local-file "LOCAL " "")
 357    (namestring (ufile-pathname file extension)) (table file)))
 358
 359
 360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 361 ;;;
 362 ;;; Routines for analyzing cost of fixed size storage
 363 ;;;
 364 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 365
 366 (defun umls-fixed-size-waste ()
 367   "Display storage waste if using all fixed size storage"
 368   (let ((totalwaste 0)
 369         (totalunavoidable 0)
 370         (totalavoidable 0)
 371         (unavoidable '())
 372         (avoidable '()))
 373     (dolist (file *umls-files*)
 374       (dolist (col (ucols file))
 375         (let* ((avwaste (- (cmax col) (av col)))
 376                (cwaste (* avwaste (rws file))))
 377           (when (plusp cwaste)
 378             (if (<= avwaste 6)
 379                 (progn
 380                   (incf totalunavoidable cwaste)
 381                   (push (list (fil file) (col col)
 382                               avwaste cwaste)
 383                         unavoidable))
 384                 (progn
 385                   (incf totalavoidable cwaste)
 386                   (push (list (fil file) (col col)
 387                               avwaste cwaste)
 388                         avoidable)))
 389             (incf totalwaste cwaste)))))
 390     (values totalwaste totalavoidable totalunavoidable
 391             (nreverse avoidable) (nreverse unavoidable))))
 392
 393 (defun display-waste ()
 394   (ensure-ucols+ufiles)
 395   (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
 396     (format t "Total waste: ~d~%" tw)
 397     (format t "Total avoidable: ~d~%" ta)
 398     (format t "Total unavoidable: ~d~%" tu)
 399     (format t "Avoidable:~%")
 400     (dolist (w al)
 401       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 402     (format t "Unavoidable:~%")
 403     (dolist (w ul)
 404       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 405     ))
 406
 407 (defun max-umls-field ()
 408   "Return length of longest field"
 409   (declare (optimize (speed 3) (space 0)))
 410   (ensure-ucols+ufiles)
 411   (let ((max 0))
 412     (declare (fixnum max))
 413     (dolist (ucol *umls-cols*)
 414       (when (> (cmax ucol) max)
 415         (setq max (cmax ucol))))
 416     max))
 417
 418 (defun max-umls-row ()
 419   "Return length of longest row"
 420   (declare (optimize (speed 3) (space 0)))
 421   (ensure-ucols+ufiles)
 422   (let ((rowsizes '()))
 423     (dolist (file *umls-files*)
 424       (let ((row 0))
 425         (dolist (ucol (ucols file))
 426           (incf row (1+ (cmax ucol))))
 427         (push row rowsizes)))
 428     (car (sort rowsizes #'>))))