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