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