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