sql-create.lisp

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