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.7 2003/05/05 23:13:28 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 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  21
  22
  23 (defun create-table-cmd-old (file)
  24   "Return sql command to create a table"
  25   (let ((col-func
  26          (lambda (c)
  27            (let ((sqltype (umls-col-sqltype c)))
  28              (concatenate 'string (umls-col-col c)
  29                           " "
  30                           (if (or (string-equal sqltype "VARCHAR")
  31                                   (string-equal sqltype "CHAR"))
  32                               (format nil "~a (~a)" sqltype (umls-col-max c))
  33                               sqltype)
  34                           ",")))))
  35     (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
  36             (string-trim-last-character
  37              (mapcar-append-string col-func (umls-cols-for-umls-file file))))))
  38
  39
  40 (defun create-table-cmd (file)
  41   "Return sql command to create a table"
  42   (let ((col-func
  43          (lambda (c)
  44            (let ((sqltype (umls-col-sqltype c)))
  45              (concatenate 'string
  46                           (umls-col-col c)
  47                           " "
  48                           (if (or (string-equal sqltype "VARCHAR")
  49                                   (string-equal sqltype "CHAR"))
  50                               (format nil "~a (~a)" sqltype (umls-col-max c))
  51                               sqltype))))))
  52     (format nil "CREATE TABLE ~a (~{~a~^,~})" (umls-file-table file)
  53             (mapcar col-func (umls-cols-for-umls-file file)))))
  54
  55 (defun create-custom-table-cmd (tablename sql-cmd)
  56   "Return SQL command to create a custom table"
  57   (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
  58
  59 (defun insert-values-cmd-old (file values)
  60   "Return sql insert command for a row of values"
  61   (let ((insert-func
  62          (lambda (col value)
  63            (concatenate
  64             'string
  65             (umls-col-quotechar col)
  66             (if (null (umls-col-parsefunc col))
  67                 value
  68                 (format nil "~A" (funcall (umls-col-parsefunc col) value)))
  69             (umls-col-quotechar col)
  70             ","))))
  71     (format
  72      nil "INSERT INTO ~a (~a) VALUES (~a)"
  73      (umls-file-table file)
  74      (string-trim-last-character
  75       (mapcar-append-string (lambda (c) (concatenate 'string c ","))
  76                             (umls-file-fields file)))
  77      (string-trim-last-character
  78       (concatenate 'string
  79                    (mapcar2-append-string insert-func
  80                                           (remove-custom-cols (umls-file-colstructs file))
  81                                           values)
  82                    (custom-col-values-old (custom-colstructs-for-file file) values "," t)))
  83      )))
  84
  85 (defun insert-col-value (col value)
  86   (if (null (umls-col-parsefunc col))
  87       value
  88       (format nil "~A" (funcall (umls-col-parsefunc col) value))))
  89
  90 (defun insert-values-cmd (file values)
  91   "Return sql insert command for a row of values"
  92   (let ((insert-func
  93          (lambda (col value)
  94            (let ((q (umls-col-quotechar col)))
  95              (concatenate 'string q (insert-col-value col value) q)))))
  96     (format
  97      nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
  98      (umls-file-table file)
  99      (umls-file-fields file)
 100      (concat-separated-strings
 101       ","
 102       (mapcar insert-func (remove-custom-cols (umls-file-colstructs file)) values)
 103       (custom-col-values (custom-colstructs-for-file file) values t)))))
 104
 105 (defun custom-col-values-old (colstructs values delim doquote)
 106   "Returns a string of column values for SQL inserts for custom columns"
 107   (let ((result ""))
 108     (dolist (col colstructs)
 109       (let* ((func (umls-col-custom-value-func col))
 110              (custom-value (funcall func values)))
 111         (string-append result
 112                        (if doquote (umls-col-quotechar col))
 113                        (escape-backslashes custom-value)
 114                        (if doquote (umls-col-quotechar col))
 115                        delim)))
 116     result))
 117
 118 (defun custom-col-value (col doquote values)
 119   (let ((custom-value (funcall (umls-col-custom-value-func col) values)))
 120     (if doquote
 121         (let ((q (umls-col-quotechar col)))
 122           (concatenate 'string q (escape-backslashes custom-value) q))
 123         (escape-backslashes custom-value))))
 124
 125 (defun custom-col-values (colstructs values doquote)
 126   "Returns a list of string column values for SQL inserts for custom columns"
 127   (loop for col in colstructs collect (custom-col-value col doquote values)))
 128
 129
 130 (defun remove-custom-cols (cols)
 131   "Remove custom cols from a list col umls-cols"
 132   (remove-if #'umls-col-custom-value-func cols))
 133
 134 (defun find-custom-cols-for-filename (filename)
 135   (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
 136
 137 (defun find-custom-col (filename col)
 138   (find-if (lambda (x) (and (string-equal filename (car x))
 139                             (string-equal col (cadr x)))) +custom-cols+))
 140
 141
 142 (defun custom-colnames-for-filename (filename)
 143   (mapcar #'cadr (find-custom-cols-for-filename filename)))
 144
 145 (defun custom-colstructs-for-file (file)
 146   (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
 147
 148 (defun noneng-lang-index-files ()
 149   (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
 150                                   (string-equal (umls-file-fil f) "MRXW." :end1 5)
 151                                   (not (string-equal (umls-file-fil f) "MRXW.ENG"))
 152                                   (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
 153                  *umls-files*))
 154
 155 ;;; SQL Command Functions
 156
 157 (defun create-index-cmd (colname tablename length)
 158   "Return sql create index command"
 159   (format nil "CREATE INDEX ~a ON ~a (~a ~a)"
 160           (concatenate 'string tablename "_" colname "_X") tablename colname
 161           (if (integerp length)
 162               (format nil "(~d)" length)
 163               "")))
 164
 165 (defun create-all-tables-cmdfile ()
 166   "Return sql commands to create all tables. Not need for automated SQL import"
 167   (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
 168
 169
 170 ;; SQL Execution functions
 171
 172 (defun sql-drop-tables (conn)
 173   "SQL Databases: drop all tables"
 174   (mapcar
 175    (lambda (file)
 176      (ignore-errors
 177        (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
 178    *umls-files*))
 179
 180 (defun sql-create-tables (conn)
 181   "SQL Databases: create all tables"
 182   (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))
 183
 184 (defun sql-create-custom-tables (conn)
 185   "SQL Databases: create all custom tables"
 186   (mapcar (lambda (ct)
 187             (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
 188           +custom-tables+))
 189
 190 (defun sql-insert-values (conn file)
 191   "SQL Databases: inserts all values for a file"
 192   (with-umls-file (line (umls-file-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   (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))
 198
 199 (defun sql-create-indexes (conn &optional (indexes +index-cols+))
 200   "SQL Databases: create all indexes"
 201   (mapcar
 202    (lambda (idx)
 203      (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))
 204    indexes))
 205
 206 (defun make-usrl (conn)
 207   (sql-execute "drop table if exists USRL" conn)
 208   (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
 209   (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc"))
 210     (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
 211                          (car tuple) (ensure-integer (cadr tuple)))
 212                  conn)))
 213
 214 (defun sql-create-special-tables (conn)
 215   (make-usrl conn))
 216
 217 (defun create-umls-db-by-insert ()
 218   "SQL Databases: initializes entire database via SQL insert commands"
 219   (init-umls)
 220   (init-hash-table)
 221   (with-sql-connection (conn)
 222     (sql-drop-tables conn)
 223     (sql-create-tables conn)
 224     (sql-insert-all-values conn)
 225     (sql-create-indexes conn)
 226     (sql-create-custom-tables conn)
 227     (sql-create-indexes conn +custom-index-cols+)
 228     (sql-create-special-tables conn)))
 229
 230 (defun create-umls-db (&optional (extension ".trans")
 231                        (copy-cmd #'mysql-copy-cmd))
 232   "SQL Databases: initializes entire database via SQL copy commands.
 233 This is much faster that using create-umls-db-insert."
 234   (init-umls)
 235   (init-hash-table)
 236   (translate-all-files extension)
 237   (with-sql-connection (conn)
 238     (sql-drop-tables conn)
 239     (sql-create-tables conn)
 240     (map 'nil
 241      #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn))
 242      *umls-files*)
 243     (sql-create-indexes conn)
 244     (sql-create-custom-tables conn)
 245     (sql-create-indexes conn +custom-index-cols+)
 246     (sql-create-special-tables conn)))
 247
 248 (defun translate-all-files (&optional (extension ".trans"))
 249   "Copy translated files and return postgresql copy commands to import"
 250   (make-noneng-index-file extension)
 251   (map 'nil (lambda (f) (translate-file f extension)) *umls-files*))
 252
 253 (defun translate-file (file extension)
 254   "Translate a umls file into a format suitable for sql copy cmd"
 255   (let ((path (umls-pathname (umls-file-fil file) extension)))
 256     (if (probe-file path)
 257         (progn
 258           (format t "File ~A already exists: skipping~%" path)
 259           nil)
 260         (with-open-file (ostream path :direction :output)
 261           (with-umls-file (line (umls-file-fil file))
 262             (umls-translate file line ostream)
 263             (princ #\newline ostream))
 264           t))))
 265
 266 (defun make-noneng-index-file (extension)
 267   "Make non-english index file"
 268   (let* ((outfile (find-umls-file "MRXW.NONENG"))
 269          (path (umls-pathname (umls-file-fil outfile) extension)))
 270
 271     (if (probe-file path)
 272         (progn
 273           (format t "File ~A already exists: skipping~%" path)
 274           nil)
 275         (progn
 276           (with-open-file (ostream path :direction :output)
 277             (dolist (inputfile (noneng-lang-index-files))
 278               (with-umls-file (line (umls-file-fil inputfile))
 279                 (umls-translate outfile line ostream) ;; use outfile for custom cols
 280                 (princ #\newline ostream))))
 281           t))))
 282
 283 (defun pg-copy-cmd (file extension)
 284   "Return postgresql copy statement for a file"
 285   (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
 286           (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
 287
 288 (defun mysql-copy-cmd (file extension)
 289   "Return mysql copy statement for a file"
 290   (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
 291           (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
 292
 293 (defun umls-translate-old (file line)
 294   "Translate a single line for sql output"
 295   (string-trim-last-character
 296    (concatenate 'string
 297                 (mapcar2-append-string
 298                  (lambda (col value)
 299                    (concatenate
 300                     'string
 301                     (if (eq (umls-col-datatype col) 'sql-u)
 302                         (format nil "~d" (parse-ui value ""))
 303                         (escape-backslashes value))
 304                     "|"))
 305                  (remove-custom-cols (umls-file-colstructs file))
 306                  line)
 307                 (custom-col-values-old (custom-colstructs-for-file file) line "|" nil))))
 308
 309 (defun concat-separated-strings (separator &rest lists)
 310   (format nil (format nil "~~{~~A~~^~A~~}" separator) (mapappend #'identity lists)))
 311
 312 (defun print-separated-strings (strm separator &rest lists)
 313   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) (compilation-speed 0)))
 314   (do* ((rest-lists lists (cdr rest-lists))
 315         (list (car rest-lists) (car rest-lists))
 316         (last-list (null (cdr rest-lists)) (null (cdr rest-lists))))
 317        ((null list) strm)
 318     (do* ((lst list (cdr lst))
 319           (elem (car lst) (car lst))
 320           (last-elem (null (cdr lst)) (null (cdr lst))))
 321          ((null lst))
 322       (write-string elem strm)
 323       (unless (and last-elem last-list)
 324         (write-string separator strm)))))
 325
 326 (defun col-value (col value)
 327   (if (eq (umls-col-datatype col) 'sql-u)
 328       (write-to-string (parse-ui value ""))
 329       (escape-backslashes value)))
 330
 331 (defun umls-translate (file line strm)
 332   "Translate a single line for sql output"
 333   (print-separated-strings
 334    strm "|"
 335    (mapcar #'col-value (remove-custom-cols (umls-file-colstructs file)) line)
 336    (custom-col-values (custom-colstructs-for-file file) line nil)))
 337
 338
 339 ;;; Routines for analyzing cost of fixed size storage
 340
 341
 342 (defun umls-fixed-size-waste ()
 343   "Display storage waste if using all fixed size storage"
 344   (let ((totalwaste 0)
 345         (totalunavoidable 0)
 346         (totalavoidable 0)
 347         (unavoidable '())
 348         (avoidable '()))
 349     (dolist (file *umls-files*)
 350       (dolist (col (umls-file-colstructs file))
 351         (let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
 352                (cwaste (* avwaste (umls-file-rws file))))
 353           (unless (zerop cwaste)
 354             (if (<= avwaste 6)
 355                 (progn
 356                   (incf totalunavoidable cwaste)
 357                   (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
 358                 (progn
 359                   (incf totalavoidable cwaste)
 360                   (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
 361             (incf totalwaste cwaste)))))
 362     (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))
 363
 364 (defun display-waste ()
 365   (unless *umls-files*
 366     (init-umls))
 367   (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
 368     (format t "Total waste: ~d~%" tw)
 369     (format t "Total avoidable: ~d~%" ta)
 370     (format t "Total unavoidable: ~d~%" tu)
 371     (format t "Avoidable:~%")
 372     (dolist (w al)
 373       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 374     (format t "Unavoidable:~%")
 375     (dolist (w ul)
 376       (format t "  (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
 377     ))
 378
 379 (defun max-umls-field ()
 380   "Return length of longest field"
 381   (unless *umls-files*
 382     (init-umls))
 383   (let ((max 0))
 384     (declare (fixnum max))
 385     (dolist (col *umls-cols*)
 386       (when (> (umls-col-max col) max)
 387         (setq max (umls-col-max col))))
 388     max))
 389
 390 (defun max-umls-row ()
 391   "Return length of longest row"
 392   (if t
 393       6000 ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
 394       (progn
 395         (unless *umls-files*
 396           (init-umls))
 397         (let ((rowsizes '()))
 398           (dolist (file *umls-files*)
 399             (let ((row 0)
 400                   (fields (umls-file-colstructs file)))
 401               (dolist (field fields)
 402                 (incf row (1+ (umls-col-max field))))
 403               (push row rowsizes)))
 404           (car (sort rowsizes #'>))))))