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