+++ /dev/null
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: sql-create
-;;;; Purpose: Create SQL database for UMLisp
-;;;; Author: Kevin M. Rosenberg
-;;;; Created: Apr 2000
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of UMLisp, is
-;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
-;;;;
-;;;; UMLisp users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU General Public License.
-;;;; *************************************************************************
-
-(in-package #:umlisp-orf)
-
-(defun create-table-cmd (file)
- "Return sql command to create a table"
- (let ((col-func
- (lambda (c)
- (let ((sqltype (sqltype c)))
- (concatenate 'string
- (col c)
- " "
- (if (or (string-equal sqltype "VARCHAR")
- (string-equal sqltype "CHAR"))
- (format nil "~a (~a)" sqltype (cmax c))
- sqltype))))))
- (format nil "CREATE TABLE ~a (~{~a~^,~})" (table file)
- (mapcar col-func (ucols file)))))
-
-(defun create-custom-table-cmd (tablename sql-cmd)
- "Return SQL command to create a custom table"
- (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
-
-(defun insert-col-value (col value)
- (if (null (parse-fun col))
- value
- (format nil "~A" (funcall (parse-fun col) value))))
-
-(defun insert-values-cmd (file values)
- "Return sql insert command for a row of values"
- (let ((insert-func
- (lambda (col value)
- (concatenate 'string (quote-str col)
- (insert-col-value col value)
- (quote-str col)))))
- (format
- nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
- (table file)
- (fields file)
- (concat-separated-strings
- ","
- (mapcar insert-func (remove-custom-cols (ucols file)) values)
- (custom-col-values (custom-ucols-for-file file) values t)))))
-
-
-(defun custom-col-value (col values doquote)
- (let ((custom-value (funcall (custom-value-fun col) values)))
- (if custom-value
- (if doquote
- (concatenate 'string (quote-str col)
- (escape-backslashes custom-value)
- (quote-str col))
- (escape-backslashes custom-value))
- "")))
-
-(defun custom-col-values (ucols values doquote)
- "Returns a list of string column values for SQL inserts for custom columns"
- (loop for col in ucols collect (custom-col-value col values doquote)))
-
-(defun remove-custom-cols (cols)
- "Remove custom cols from a list col umls-cols"
- (remove-if #'custom-value-fun cols))
-
-(defun find-custom-cols-for-filename (filename)
- (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
-
-(defun find-custom-col (filename col)
- (find-if (lambda (x) (and (string-equal filename (car x))
- (string-equal col (cadr x)))) +custom-cols+))
-
-(defun custom-colnames-for-filename (filename)
- (mapcar #'cadr (find-custom-cols-for-filename filename)))
-
-(defun custom-ucols-for-file (file)
- (remove-if-not #'custom-value-fun (ucols file)))
-
-(defun noneng-lang-index-files ()
- (remove-if-not
- (lambda (f) (and (> (length (fil f)) 4)
- (string-equal (fil f) "MRXW." :end1 5)
- (not (string-equal (fil f) "MRXW.ENG"))
- (not (string-equal (fil f) "MRXW.NONENG"))))
- *umls-files*))
-
-;;; SQL Command Functions
-
-(defun create-index-cmd (colname tablename length)
- "Return sql create index command"
- (format nil "CREATE INDEX ~a ON ~a (~a)"
- (concatenate 'string tablename "_" colname "_X")
- tablename
- (case *umls-sql-type*
- (:mysql
- (concatenate 'string colname
- (if (integerp length)
- (format nil " (~d)" length)
- "")))
- ((:postgresql :postgresql-socket)
- ;; FIXME: incorrect syntax
- (if (integerp length)
- (format nil "substr((~A)::text,1,~D)" colname length)
- colname))
- (t
- colname))))
-
-(defun create-all-tables-cmdfile ()
- "Return sql commands to create all tables. Not need for automated SQL import"
- (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
-
-;; SQL Execution functions
-
-(defun sql-drop-tables (conn)
- "SQL Databases: drop all tables"
- (dolist (file *umls-files*)
- (ignore-errors
- (sql-execute (format nil "DROP TABLE ~a" (table file)) conn))))
-
-(defun sql-create-tables (conn)
- "SQL Databases: create all tables"
- (dolist (file *umls-files*)
- (sql-execute (create-table-cmd file) conn)))
-
-(defun sql-create-custom-tables (conn)
- "SQL Databases: create all custom tables"
- (dolist (ct +custom-tables+)
- (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
-
-(defun sql-insert-values (conn file)
- "SQL Databases: inserts all values for a file"
- (with-umls-file (line (fil file))
- (sql-execute (insert-values-cmd file line) conn)))
-
-(defun sql-insert-all-values (conn)
- "SQL Databases: inserts all values for all files"
- (dolist (file *umls-files*)
- (sql-insert-values conn file)))
-
-(defun drop-index-cmd (colname tablename)
- "Return sql create index command"
- (case *umls-sql-type*
- (:mysql
- (format nil "DROP INDEX ~a ON ~a"
- (concatenate 'string tablename "_" colname "_X")
- tablename))
- (t
- (format nil "DROP INDEX ~a"
- (concatenate 'string tablename "_" colname "_X")))))
-
-(defun sql-create-indexes (conn &optional (indexes +index-cols+))
- "SQL Databases: create all indexes"
- (dolist (idx indexes)
- (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
- (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
-
-(defun make-usrl (conn)
- (if (eql :mysql *umls-sql-type*)
- (sql-execute "drop table if exists USRL" conn)
- (ignore-errors (sql-execute "drop table USRL" conn)))
- (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
- (dolist (tuple (mutex-sql-query
- "select distinct SAB,SRL from MRSO order by SAB asc"))
- (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
- (car tuple) (ensure-integer (cadr tuple)))
- conn)))
-
-(defun sql-create-special-tables (conn)
- (make-usrl conn)
- (make-ustats))
-
-(defun create-umls-db-by-insert ()
- "SQL Databases: initializes entire database via SQL insert commands"
- (ensure-ucols+ufiles)
- (ensure-preparse)
- (with-sql-connection (conn)
- (sql-drop-tables conn)
- (sql-create-tables conn)
- (sql-insert-all-values conn)
- (sql-create-indexes conn)
- (sql-create-custom-tables conn)
- (sql-create-indexes conn +custom-index-cols+)
- (sql-create-special-tables conn)))
-
-(defun create-umls-db (&key (extension ".trans") (skip-translation nil))
- "SQL Databases: initializes entire database via SQL copy commands.
-This is much faster that using create-umls-db-insert."
- (ensure-ucols+ufiles)
- (ensure-preparse)
- (unless skip-translation
- (translate-all-files extension))
- (let ((copy-cmd
- (ecase (umls-sql-type)
- (:mysql #'mysql-copy-cmd)
- (:postgresql #'pg-copy-cmd))))
- (with-sql-connection (conn)
- (clsql:truncate-database :database conn)
- (sql-drop-tables conn)
- (sql-create-tables conn)
- (dolist (file *umls-files*)
- (sql-execute (funcall copy-cmd file extension) conn))
- (sql-create-indexes conn)
- (sql-create-custom-tables conn)
- (sql-create-indexes conn +custom-index-cols+)
- (sql-create-special-tables conn))))
-
-(defun translate-all-files (&optional (extension ".trans"))
- "Copy translated files and return postgresql copy commands to import"
- (make-noneng-index-file extension)
- (dolist (f (remove "MRXW.NONENG" *umls-files* :test #'string= :key #'fil))
- (translate-umls-file f extension)))
-
-(defun translate-umls-file (file extension)
- "Translate a umls file into a format suitable for sql copy cmd"
- (translate-files file extension (list file)))
-
-(defun make-noneng-index-file (extension)
- "Make non-english index file"
- (translate-files (find-ufile "MRXW.NONENG")
- extension (noneng-lang-index-files)))
-
-(defun translate-files (out-ufile extension input-ufiles)
- "Translate a umls file into a format suitable for sql copy cmd"
- (let ((output-path (umls-pathname (fil out-ufile) extension)))
- (if (probe-file output-path)
- (format t "File ~A already exists: skipping~%" output-path)
- (with-open-file (ostream output-path :direction :output)
- (dolist (input-ufile input-ufiles)
- (with-umls-file (line (fil input-ufile))
- (translate-line out-ufile line ostream)
- (princ #\newline ostream)))))))
-
-(defun translate-line (file line strm)
- "Translate a single line for sql output"
- (flet ((col-value (col value)
- (if (eq (datatype col) 'sql-u)
- (let ((ui (parse-ui value "")))
- (if (stringp ui)
- ui
- (write-to-string ui)))
- (escape-backslashes value))))
- (print-separated-strings
- strm "|"
- (mapcar #'col-value (remove-custom-cols (ucols file)) line)
- (custom-col-values (custom-ucols-for-file file) line nil))))
-
-(defun pg-copy-cmd (file extension)
- "Return postgresql copy statement for a file"
- (format
- nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
- (table file) (umls-pathname (fil file) extension)))
-
-(defun mysql-copy-cmd (file extension &key local-file)
- "Return mysql copy statement for a file"
- (format
- nil
- "LOAD DATA ~AINFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
- (if local-file "LOCAL " "")
- (umls-pathname (fil file) extension) (table file)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Routines for analyzing cost of fixed size storage
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun umls-fixed-size-waste ()
- "Display storage waste if using all fixed size storage"
- (let ((totalwaste 0)
- (totalunavoidable 0)
- (totalavoidable 0)
- (unavoidable '())
- (avoidable '()))
- (dolist (file *umls-files*)
- (dolist (col (ucols file))
- (let* ((avwaste (- (cmax col) (av col)))
- (cwaste (* avwaste (rws file))))
- (when (plusp cwaste)
- (if (<= avwaste 6)
- (progn
- (incf totalunavoidable cwaste)
- (push (list (fil file) (col col)
- avwaste cwaste)
- unavoidable))
- (progn
- (incf totalavoidable cwaste)
- (push (list (fil file) (col col)
- avwaste cwaste)
- avoidable)))
- (incf totalwaste cwaste)))))
- (values totalwaste totalavoidable totalunavoidable
- (nreverse avoidable) (nreverse unavoidable))))
-
-(defun display-waste ()
- (ensure-ucols+ufiles)
- (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
- (format t "Total waste: ~d~%" tw)
- (format t "Total avoidable: ~d~%" ta)
- (format t "Total unavoidable: ~d~%" tu)
- (format t "Avoidable:~%")
- (dolist (w al)
- (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
- (format t "Unavoidable:~%")
- (dolist (w ul)
- (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
- ))
-
-(defun max-umls-field ()
- "Return length of longest field"
- (declare (optimize (speed 3) (space 0)))
- (ensure-ucols+ufiles)
- (let ((max 0))
- (declare (fixnum max))
- (dolist (ucol *umls-cols*)
- (when (> (cmax ucol) max)
- (setq max (cmax ucol))))
- max))
-
-(defun max-umls-row ()
- "Return length of longest row"
- (declare (optimize (speed 3) (space 0)))
- (ensure-ucols+ufiles)
- (let ((rowsizes '()))
- (dolist (file *umls-files*)
- (let ((row 0))
- (dolist (ucol (ucols file))
- (incf row (1+ (cmax ucol))))
- (push row rowsizes)))
- (car (sort rowsizes #'>))))
projects / umlisp.git / blobdiff